darcs-2.10.2/0000755000175000017500000000000012620122474014722 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/NEWS0000644000175000017500000035247512620122474015441 0ustar00guillaumeguillaume00000000000000Darcs 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 Mon, 10 Nov 2008 10:40:00 GMT darcs (2.1.1) -- Eric Kow 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 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 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 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 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 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 Sun, 18 Sep 2008 02:36:45 GMT darcs (2.0.2) -- David Roundy 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 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 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 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 Sun, 07 Apr 2008 15:06:38 GMT darcs (2.0.0rc1) -- David Roundy 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 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 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 --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 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 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 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 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 Sun, 13 May 2006 17:14:38 GMT darcs (1.0.6) -- Tommy Pettersson 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 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 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 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 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 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 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 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 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 Sun, 26 Apr 2005 00:25:54 GMT darcs (1.0.2) * No changes from 1.0.2rc4. -- David Roundy 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 . -- David Roundy 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 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 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 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 Mon, 10 Mar 2003 09:48:55 -0500 darcs 0.9.0 * Initial Release. -- David Roundy Wed, 3 Mar 2003 13:51:58 -0500 Local variables: mode: outline outline-regexp: "[dD]\\| +\\*+" paragraph-separate: "[ ]*$" end: darcs-2.10.2/release/0000755000175000017500000000000012620122474016342 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/release/distributed-context0000644000175000017500000000022012620122474022263 0ustar00guillaumeguillaume00000000000000Just "\nContext:\n\n[TAG 2.10.2\nGuillaume Hoffmann **20151109135257\n Ignore-this: b5175dd8e51689988632b312af9611da\n] \n"darcs-2.10.2/release/distributed-version0000644000175000017500000000000612620122474022266 0ustar00guillaumeguillaume00000000000000Just 0darcs-2.10.2/src/0000755000175000017500000000000012620122474015511 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/0000755000175000017500000000000012620122474016545 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Repository.hs0000644000175000017500000010537212620122474021270 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2002-2004 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 #-} module Darcs.Repository ( Repository , HashedDir(..) , Cache(..) , CacheLoc(..) , WritableOrNot(..) , RepoJob(..) , maybeIdentifyRepository , identifyRepositoryFor , withRecorded , withRepoLock , withRepoLockCanFail , withRepository , withRepositoryDirectory , writePatchSet , findRepository , amInRepository , amNotInRepository , amInHashedRepository , replacePristine , readRepo , prefsUrl , repoPatchType , readRepoUsingSpecificInventory , addToPending , addPendingDiffToPending , tentativelyAddPatch , tentativelyRemovePatches , tentativelyAddToPending , tentativelyReplacePatches , readTentativeRepo , withManualRebaseUpdate , tentativelyMergePatches , considerMergeToWorking , revertRepositoryChanges , finalizeRepositoryChanges , createRepository , cloneRepository , patchSetToRepository , unrevertUrl , applyToWorking , patchSetToPatches , createPristineDirectoryTree , createPartialsPristineDirectoryTree , reorderInventory , cleanRepository , PatchSet , SealedPatchSet , PatchInfoAnd , setScriptsExecutable , setScriptsExecutablePatches , checkUnrelatedRepos , testTentative , modifyCache , reportBadSources -- * Recorded and unrecorded and pending. , readRecorded , readUnrecorded , unrecordedChanges , unrecordedChangesWithPatches , filterOutConflicts , readPending , readRecordedAndPending -- * Index. , readIndex , invalidateIndex -- * Used as command arguments , listFiles , listRegisteredFiles , listUnregisteredFiles ) where import Prelude hiding ( catch, pi ) import System.Exit ( exitSuccess ) import Data.List ( (\\), isPrefixOf ) import Data.Maybe( catMaybes, isJust, listToMaybe ) import Darcs.Repository.State ( readRecorded , readUnrecorded , readWorking , unrecordedChanges , unrecordedChangesWithPatches , readPendingAndWorking , readPending , readIndex , invalidateIndex , readRecordedAndPending , restrictDarcsdir , restrictBoring , applyTreeFilter , filterOutConflicts ) import Darcs.Repository.Internal (Repository(..) , maybeIdentifyRepository , identifyRepositoryFor , identifyRepository , IdentifyRepo(..) , findRepository , amInRepository , amNotInRepository , amInHashedRepository , readRepo , readTentativeRepo , readRepoUsingSpecificInventory , prefsUrl , withRecorded , tentativelyAddPatch , tentativelyRemovePatches , tentativelyReplacePatches , tentativelyAddToPending , revertRepositoryChanges , finalizeRepositoryChanges , unrevertUrl , applyToWorking , patchSetToPatches , createPristineDirectoryTree , createPartialsPristineDirectoryTree , reorderInventory , cleanRepository , setScriptsExecutable , setScriptsExecutablePatches , makeNewPending , seekRepo ) import Darcs.Repository.Job ( RepoJob(..) , withRepoLock , withRepoLockCanFail , withRepository , withRepositoryDirectory ) import Darcs.Repository.Rebase ( withManualRebaseUpdate ) import Darcs.Repository.Test ( testTentative ) import Darcs.Repository.Merge( tentativelyMergePatches , considerMergeToWorking ) import Darcs.Repository.Cache ( unionRemoteCaches , fetchFileUsingCache , speculateFileUsingCache , HashedDir(..) , Cache(..) , CacheLoc(..) , WritableOrNot(..) , hashedDir , bucketFolder , CacheType(Directory) , reportBadSources ) import Darcs.Patch ( RepoPatch , apply , invert , effect , PrimOf ) import Darcs.Patch.Set ( Origin , PatchSet(..) , SealedPatchSet , newset2RL , newset2FL , progressPatchSet ) import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch ) import Darcs.Patch.Commute( commuteFL ) import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL ) import Control.Exception ( catch, Exception, throwIO, finally, IOException ) import Control.Concurrent ( forkIO ) import Control.Concurrent.MVar ( MVar , newMVar , putMVar , takeMVar ) import Control.Monad ( unless, when, void ) import Control.Applicative( (<$>) ) 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, hopefully ) import Darcs.Repository.ApplyPatches ( applyPatches, runDefault ) import Darcs.Repository.HashedRepo ( applyToTentativePristine , pris2inv , inv2pris , revertTentativeChanges , copySources ) import Darcs.Repository.InternalTypes ( modifyCache ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FreeLeft, unFreeLeft ) import Darcs.Patch.Witnesses.Ordered ((:>)(..), reverseRL, reverseFL, lengthFL, mapFL_FL, FL(..), RL(..), bunchFL, mapFL, mapRL, lengthRL, (+>+), (:\/:)(..)) import Darcs.Repository.Format ( RepoProperty ( HashedInventory, Darcs2 ) , RepoFormat , createRepoFormat , formatHas , writeRepoFormat , readProblem ) import Darcs.Repository.Prefs ( writeDefaultPrefs, addRepoSource, deleteSources ) import Darcs.Repository.Match ( getOnePatchset ) import Darcs.Patch.Depends ( areUnrelatedRepos, findUncommon, findCommonWithThem , countUsThem ) import Darcs.Patch.Type ( PatchType(..) ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.English ( englishNum, Noun(..) ) import Darcs.Repository.External ( copyFileOrUrl , Cachable(..) , fetchFileLazyPS , gzFetchFilePS ) import Darcs.Util.Progress ( debugMessage , tediousSize , beginTedious , endTedious ) import Darcs.Patch.Progress ( progressRLShowTags , progressFL ) import Darcs.Repository.Lock ( writeBinFile , writeDocBinFile , withTemp ) import Darcs.Repository.Flags ( UpdateWorking(..) , UseCache(..) , UseIndex(..) , ScanKnown(..) , RemoteDarcs (..) , Reorder (..) , Compression (..) , CloneKind (..) , Verbosity (..) , DryRun (..) , UMask (..) , AllowConflicts (..) , ExternalMerge (..) , WantGuiPause (..) , SetScriptsExecutable (..) , RemoteRepos (..) , SetDefault (..) , DiffAlgorithm (..) , WithWorkingDir (..) , ForgetParent (..) , WithPatchIndex (..) ) import Darcs.Util.Download ( maxPipelineLength ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.URL ( isValidLocalPath ) import Darcs.Util.SignalHandler ( catchInterrupt ) import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc, RenderMode(..) ) import Storage.Hashed.Plain( readPlainTree ) import Storage.Hashed.Tree( Tree, emptyTree, expand, list ) import Storage.Hashed.Hash( encodeBase16 ) import Darcs.Util.Path( anchorPath ) import Storage.Hashed.Darcs( writeDarcsHashed, darcsAddMissingHashes ) import Darcs.Util.ByteString( 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 import Darcs.Repository.PatchIndex (createOrUpdatePatchIndexDisk, doesPatchIndexExist, createPIWithInterrupt) #include "impossible.h" -- @createRepository useFormat1 useNoWorkingDir patchIndex@ createRepository :: Bool -> WithWorkingDir -> WithPatchIndex -> IO () createRepository useFormat1 withWorkingDir createPatchIndex = 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." createDirectory $ darcsdir ++ "/pristine.hashed" createDirectory $ darcsdir ++ "/patches" createDirectory $ darcsdir ++ "/inventories" createDirectory $ darcsdir ++ "/prefs" writeDefaultPrefs let repoFormat = createRepoFormat useFormat1 withWorkingDir writeRepoFormat repoFormat (darcsdir++"/format") writeBinFile (darcsdir++"/hashed_inventory") "" writePristine "." emptyTree withRepository NoUseCache $ RepoJob $ \repo -> case createPatchIndex of NoPatchIndex -> return () -- default YesPatchIndex -> createOrUpdatePatchIndexDisk repo repoPatchType :: Repository p wR wU wT -> PatchType p repoPatchType _ = PatchType cloneRepository :: String -- origin repository path -> String -- new repository name (for relative path) -> Verbosity -> UseCache -> CloneKind -> UMask -> RemoteDarcs -> SetScriptsExecutable -> RemoteRepos -> SetDefault -> [MatchFlag] -> RepoFormat -> WithWorkingDir -> WithPatchIndex -- use patch index -> Bool -- use packs -> Bool -- --to-match given -> ForgetParent -> IO () cloneRepository repodir mysimplename v uc cloneKind um rdarcs sse remoteRepos setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks toMatch forget = do createDirectory mysimplename setCurrentDirectory mysimplename createRepository (not $ formatHas Darcs2 rfsource) withWorkingDir (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex) debugMessage "Finished initializing new directory." addRepoSource repodir NoDryRun remoteRepos setDefault if toMatch && cloneKind /= LazyClone then withRepository uc $ RepoJob $ \repository -> do debugMessage "Using economical clone --to-match handling" fromrepo <- identifyRepositoryFor repository uc repodir Sealed patches_to_get <- getOnePatchset fromrepo matchFlags patchSetToRepository fromrepo patches_to_get uc rdarcs debugMessage "Finished converting selected patch set to new repository" else copyRepoAndGoToChosenVersion repodir v uc cloneKind um rdarcs sse matchFlags withWorkingDir usePacks forget -- 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 :: String -- repository directory -> Verbosity -> UseCache -> CloneKind -> UMask -> RemoteDarcs -> SetScriptsExecutable -> [MatchFlag] -> WithWorkingDir -> Bool -> ForgetParent -> IO () copyRepoAndGoToChosenVersion repodir v uc gk um rdarcs sse matchFlags withWorkingDir usePacks forget = withRepository uc $ RepoJob $ \repository -> do debugMessage "Identifying and copying repository..." fromRepo@(Repo fromDir rffrom _ _) <- identifyRepositoryFor repository uc repodir case readProblem rffrom of Just e -> fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e Nothing -> return () debugMessage "Copying prefs" copyFileOrUrl rdarcs (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs") (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return () if formatHas HashedInventory rffrom then do -- copying basic repository (hashed_inventory and pristine) if usePacks && (not . isValidLocalPath) fromDir then copyBasicRepoPacked fromRepo v uc um rdarcs withWorkingDir else copyBasicRepoNotPacked fromRepo v uc um rdarcs withWorkingDir when (gk /= LazyClone) $ do when (gk /= CompleteClone) $ putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..." -- copying complete repository (inventories and patches) if usePacks && (not . isValidLocalPath) fromDir then copyCompleteRepoPacked fromRepo v uc um gk else copyCompleteRepoNotPacked fromRepo v uc um gk else -- old-fashioned repositories are cloned diferently since -- we need to copy all patches first and then build pristine copyRepoOldFashioned fromRepo v uc um withWorkingDir when (sse == YesSetScriptsExecutable) setScriptsExecutable when (havePatchsetMatch matchFlags) $ do putStrLn "Going to specified version..." -- read again repository on disk to get caches and sources right withRepoLock NoDryRun uc YesUpdateWorking um $ RepoJob $ \repository' -> do patches <- readRepo repository' Sealed context <- getOnePatchset repository' matchFlags 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 v $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " ++ englishNum (lengthFL ps) (Noun "patch") "" invalidateIndex repository' _ <- tentativelyRemovePatches repository' GzipCompression YesUpdateWorking us' tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect us' finalizeRepositoryChanges repository' YesUpdateWorking GzipCompression runDefault (apply (invert $ effect ps)) `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e) when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps) when (forget == YesForgetParent) deleteSources putInfo :: Verbosity -> Doc -> IO () putInfo Quiet _ = return () putInfo _ d = hPutDocLn Encode stderr d putVerbose :: Verbosity -> Doc -> IO () putVerbose Verbose d = putDocLn d putVerbose _ _ = return () copyBasicRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> UseCache -> UMask -> RemoteDarcs -> WithWorkingDir -> IO () copyBasicRepoNotPacked (Repo fromDir _ _ fromCache) verb useCache umask rdarcs withWorkingDir = do toRepo@(Repo toDir toFormat toPristine toCache) <- identifyRepository useCache "." let (_dummy :: Repository p wR wU wT) = toRepo --The witnesses are wrong, but cannot escape toCache2 <- unionRemoteCaches toCache fromCache fromDir let toRepo2 :: Repository p wR wU wT toRepo2 = Repo toDir toFormat toPristine toCache2 HashedRepo.copyHashedInventory toRepo2 rdarcs fromDir HashedRepo.copySources toRepo2 fromDir debugMessage "Grabbing lock in new repository to copy basic repo..." withRepoLock NoDryRun useCache YesUpdateWorking umask $ RepoJob $ \torepository -> do putVerbose verb $ text "Writing pristine and working directory contents..." createPristineDirectoryTree torepository "." withWorkingDir copyCompleteRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> UseCache -> UMask -> CloneKind -> IO () copyCompleteRepoNotPacked _ verb useCache umask cloneKind = do debugMessage "Grabbing lock in new repository to copy complete repo..." withRepoLock NoDryRun useCache YesUpdateWorking umask $ RepoJob $ \torepository@(Repo todir _ _ _) -> do let cleanup = putInfo verb $ text "Using lazy repository." allowCtrlC cloneKind cleanup $ do fetchPatchesIfNecessary torepository pi <- doesPatchIndexExist todir when pi $ createPIWithInterrupt torepository packsDir :: String packsDir = "/" ++ darcsdir ++ "/packs/" copyBasicRepoPacked :: forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> UseCache -> UMask -> RemoteDarcs -> WithWorkingDir -> IO () copyBasicRepoPacked r@(Repo fromDir _ _ _) verb useCache umask rdarcs withWorkingDir = do let hashURL = fromDir ++ packsDir ++ "pristine" mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing) let hiURL = fromDir ++ "/" ++ darcsdir ++ "/hashed_inventory" i <- gzFetchFilePS hiURL Uncachable let currentHash = BS.pack $ inv2pris i let copyNormally = copyBasicRepoNotPacked r verb useCache umask rdarcs withWorkingDir case mPackHash of Just packHash | packHash == currentHash -> ( copyBasicRepoPacked2 r verb useCache withWorkingDir `catchall` do putStrLn "Problem while copying basic pack, copying normally." copyNormally) _ -> do putVerbose verb $ text "Remote repo has no basic pack or outdated basic pack, copying normally." copyNormally copyBasicRepoPacked2 :: forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> UseCache -> WithWorkingDir -> IO () copyBasicRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache withWorkingDir = do b <- fetchFileLazyPS (fromDir ++ packsDir ++ "basic.tar.gz") Uncachable putVerbose verb $ text "Cloning packed basic repository." Repo toDir toFormat toPristine toCache <- identifyRepositoryFor fromRepo useCache "." toCache2 <- unionRemoteCaches toCache fromCache fromDir let toRepo :: Repository p wR wU wR -- In empty repo, t(entative) = r(ecorded) toRepo = Repo toDir toFormat toPristine toCache2 copySources toRepo fromDir Repo _ _ _ toCache3 <- identifyRepositoryFor toRepo useCache "." -- unpack inventory & pristine cache cleanDir "pristine.hashed" removeFile $ darcsdir "hashed_inventory" unpackBasic toCache3 . Tar.read $ decompress b createPristineDirectoryTree toRepo "." withWorkingDir putVerbose verb $ text "Basic repository unpacked. Will now see if there are new patches." -- pull new patches us <- readRepo toRepo them <- readRepo fromRepo us' :\/: them' <- return $ findUncommon us them revertTentativeChanges Sealed pw <- tentativelyMergePatches toRepo "clone" NoAllowConflicts YesUpdateWorking NoExternalMerge NoWantGuiPause GzipCompression verb NoReorder ( UseIndex, ScanKnown, MyersDiff ) us' them' invalidateIndex toRepo finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression when (withWorkingDir == WithWorkingDir) $ void $ applyToWorking toRepo verb pw where cleanDir d = mapM_ (\x -> removeFile $ darcsdir d x) . filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir d) copyCompleteRepoPacked :: forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> UseCache -> UMask -> CloneKind -> IO () copyCompleteRepoPacked r verb useCache umask cloneKind = ( copyCompleteRepoPacked2 r verb useCache cloneKind `catchall` do putVerbose verb $ text "Problem while copying patches pack, copying normally." copyCompleteRepoNotPacked r verb useCache umask cloneKind ) copyCompleteRepoPacked2 :: forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> UseCache -> CloneKind -> IO () copyCompleteRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache cloneKind = do Repo toDir toFormat toPristine toCache <- identifyRepositoryFor fromRepo useCache "." toCache2 <- unionRemoteCaches toCache fromCache fromDir let toRepo :: Repository p wR wU wR -- In empty repo, t(entative) = r(ecorded) toRepo = Repo toDir toFormat toPristine toCache2 Repo _ _ _ toCache3 <- identifyRepositoryFor toRepo useCache "." us <- readRepo toRepo -- get old patches let cleanup = putInfo verb $ text "Using lazy repository." allowCtrlC cloneKind cleanup $ do cleanDir "patches" putVerbose verb $ text "Using patches pack." unpackPatches toCache3 (mapRL hashedPatchFileName $ newset2RL us) . Tar.read . decompress =<< fetchFileLazyPS (fromDir ++ packsDir ++ "patches.tar.gz") Uncachable pi <- doesPatchIndexExist toDir when pi $ createPIWithInterrupt toRepo where cleanDir d = mapM_ (\x -> removeFile $ darcsdir d x) . filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir d) allowCtrlC :: CloneKind -> IO () -> IO () -> IO () allowCtrlC CompleteClone _ action = action allowCtrlC _ cleanup action = action `catchInterrupt` cleanup copyRepoOldFashioned :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> UseCache -> UMask -> WithWorkingDir -> IO () copyRepoOldFashioned fromrepository verb useCache umask withWorkingDir = do toRepo@(Repo _ _ _ toCache) <- identifyRepository useCache "." let (_dummy :: Repository p wR wU wT) = toRepo --The witnesses are wrong, but cannot escape -- copy all patches from remote HashedRepo.revertTentativeChanges patches <- readRepo fromrepository let k = "Copying patch" beginTedious k tediousSize k (lengthRL $ newset2RL patches) let patches' = progressPatchSet k patches HashedRepo.writeTentativeInventory toCache GzipCompression patches' endTedious k HashedRepo.finalizeTentativeChanges toRepo GzipCompression -- apply all patches into current hashed repository debugMessage "Grabbing lock in new repository..." withRepoLock NoDryRun useCache YesUpdateWorking umask $ RepoJob $ \torepository -> do local_patches <- readRepo torepository replacePristine torepository emptyTree let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply finalizeRepositoryChanges torepository YesUpdateWorking GzipCompression putVerbose verb $ text "Writing pristine and working directory contents..." createPristineDirectoryTree torepository "." withWorkingDir withControlMVar :: (MVar () -> IO ()) -> IO () withControlMVar f = do mv <- newMVar () f mv takeMVar mv forkWithControlMVar :: MVar () -> IO () -> IO () forkWithControlMVar mv f = do takeMVar mv _ <- forkIO $ finally f (putMVar mv ()) return () removeMetaFiles :: IO () removeMetaFiles = mapM_ (removeFile . (darcsdir )) . filter ("meta-" `isPrefixOf`) =<< getDirectoryContents darcsdir unpackBasic :: Exception e => Cache -> Tar.Entries e -> IO () unpackBasic c x = do withControlMVar $ \mv -> unpackTar c (basicMetaHandler c mv) x removeMetaFiles unpackPatches :: Exception e => Cache -> [String] -> Tar.Entries e -> IO () unpackPatches c ps x = do withControlMVar $ \mv -> unpackTar c (patchesMetaHandler c ps mv) x removeMetaFiles unpackTar :: Exception e => Cache -> IO () -> Tar.Entries e -> IO () unpackTar _ _ Tar.Done = return () unpackTar _ _ (Tar.Fail e)= throwIO e 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 path content = withTemp $ \tmp -> do BL.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) 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") 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 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 wA wB -> 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) _ <- 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 Origin wX -> UseCache -> IO (Repository p wR wU wT) writePatchSet patchset useCache = do maybeRepo <- maybeIdentifyRepository useCache "." let repo@(Repo _ _ _ 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 GzipCompression patchset HashedRepo.finalizeTentativeChanges repo GzipCompression 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. patchSetToRepository :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR1 wU1 wR1 -> PatchSet p Origin wX -> UseCache -> RemoteDarcs -> IO () patchSetToRepository (Repo fromrepo rf _ _) patchset useCache remoteDarcs = do when (formatHas HashedInventory rf) $ -- set up sources and all that do writeFile (darcsdir "tentative_pristine") "" -- this is hokey repox <- writePatchSet patchset useCache HashedRepo.copyHashedInventory repox remoteDarcs fromrepo HashedRepo.copySources repox fromrepo repo <- writePatchSet patchset useCache readRepo repo >>= (runDefault . applyPatches . newset2FL) debugMessage "Writing the pristine" pristineFromWorking repo checkUnrelatedRepos :: RepoPatch p => Bool -> PatchSet p wStart wX -> PatchSet p wStart wY -> IO () checkUnrelatedRepos allowUnrelatedRepos us them = when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $ do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?" unless confirmed $ do putStrLn "Cancelled." exitSuccess -- | This function fetches all patches that the given repository has -- with fetchFileUsingCache, unless --lazy is passed. fetchPatchesIfNecessary :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () fetchPatchesIfNecessary torepository@(Repo _ _ _ c) = do 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 wX wY . RL (PatchInfoAnd p) wX wY -> [String] hashes = catMaybes . mapRL (either (const Nothing) Just . extractHash) fetchAndSpeculate :: (String, [String]) -> IO () fetchAndSpeculate (f, ss) = do _ <- fetchFileUsingCache c HashedPatchesDir f mapM_ (speculateFileUsingCache c HashedPatchesDir) ss -- | Add an FL of patches started from the pending state to the pending patch. -- TODO: add witnesses for pending so we can make the types precise: currently -- the passed patch can be applied in any context, not just after pending. addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> FreeLeft (FL (PrimOf p)) -> IO () addPendingDiffToPending _ NoUpdateWorking _ = return () addPendingDiffToPending repo@(Repo{}) uw@YesUpdateWorking newP = do (toPend :> _) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing invalidateIndex repo case unFreeLeft newP of (Sealed p) -> makeNewPending repo uw $ toPend +>+ p -- | Add a 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 p wR wU wT -> UpdateWorking -> FL (PrimOf p) wU wY -> IO () addToPending _ NoUpdateWorking _ = return () addToPending repo@(Repo{}) uw@YesUpdateWorking p = do (toPend :> toUnrec) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing invalidateIndex repo case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of (toP' :> p' :> _excessUnrec) -> makeNewPending repo uw $ toPend +>+ reverseRL toP' +>+ p' -- | Replace the existing pristine with a new one (loaded up in a Tree object). replacePristine :: Repository p wR wU wT -> 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 pristineFromWorking :: RepoPatch p => Repository p wR wU wT -> IO () pristineFromWorking repo@(Repo dir _ _ _) = withCurrentDirectory dir $ readWorking >>= replacePristine repo -- | Get a list of all files and directories in the working copy, including -- boring files if necessary listFiles :: Bool -> IO [String] listFiles takeBoring = do nonboring <- considered emptyTree working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "." return $ map (anchorPath "" . fst) $ list working where considered = if takeBoring then const (return restrictDarcsdir) else restrictBoring -- | 'listUnregisteredFiles' returns the list of all non-boring unregistered -- files in the repository. listUnregisteredFiles :: Bool -> IO [String] listUnregisteredFiles includeBoring = do unregd <- listFiles includeBoring 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 YesUseCache (RepoJob readRecordedAndPending) return $ map (anchorPath "" . fst) $ list recorded darcs-2.10.2/src/Darcs/Patch/0000755000175000017500000000000012620122474017604 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Invert.hs0000644000175000017500000000114312620122474021406 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Invert ( Invert(..), invertFL, invertRL ) where import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), reverseFL, reverseRL ) class Invert p where invert :: p wX wY -> p wY wX invertFL :: Invert p => FL p wX wY -> RL p wY wX invertFL NilFL = NilRL invertFL (x:>:xs) = invert x :<: invertFL xs invertRL :: Invert p => RL p wX wY -> FL p wY wX invertRL NilRL = NilFL invertRL (x:<:xs) = invert x :>: invertRL xs instance Invert p => Invert (FL p) where invert = reverseRL . invertFL instance Invert p => Invert (RL p) where invert = reverseFL . invertRL darcs-2.10.2/src/Darcs/Patch/Bundle.hs0000644000175000017500000003273612620122474021364 0ustar00guillaumeguillaume00000000000000-- 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.Patch.Bundle ( hashBundle , makeBundle2 , makeBundleN , scanBundle , contextPatches , scanContextFile , patchFilename , getContext , minContext , parseBundle ) where import Data.Char ( isAlpha, toLower, isDigit, isSpace ) import qualified Data.ByteString as B ( ByteString, length, null, drop, isPrefixOf ) import qualified Data.ByteString.Char8 as BC ( unpack, break, pack ) import Storage.Hashed.Tree( Tree ) import Storage.Hashed.Monad( virtualTreeIO ) import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatchPartial ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Bracketed ( Bracketed, unBracketedFL ) import Darcs.Patch.Bracketed.Instances () import Darcs.Patch.Commute( commute ) import Darcs.Patch.Depends ( slightlyOptimizePatchset ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, showPatchInfoUI, isTag ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, fmapFLPIAP, info, patchInfoAndPatch, unavailable, hopefully ) import Darcs.Patch.ReadMonads ( parseStrictly ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (:>)(..), reverseFL, (+<+), mapFL, mapFL_FL, mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.ByteString ( mmapFilePS, linesPS, unlinesPS, dropSpace, substrPS) import Darcs.Util.Crypt.SHA1 ( sha1PS ) import Darcs.Util.Printer ( Doc, renderPS, newline, text, ($$), (<>), vcat, vsep, renderString, RenderMode(..) ) -- |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) wX wY -> String hashBundle to_be_sent = show $ sha1PS $ renderPS Standard $ vcat (mapFL showPatch to_be_sent) <> newline makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) -> PatchSet p wStart wX -> FL (Named p) wX wY -> 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 -- | 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) wStart wX -> FL (Named p) wX wY -> FL (Named p) wX wY -> 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' parseBundle :: forall p. RepoPatch p => B.ByteString -> Either String (Sealed ((PatchSet p :> FL (PatchInfoAnd p)) Origin)) parseBundle input | B.null input = Left "Bad patch bundle!" parseBundle input = case sillyLex input of ("New patches:", rest) -> case getPatches rest of (Sealed bracketedPatches, rest') -> case sillyLex rest' of ("Context:", rest'') -> case getContext rest'' of (cont, maybe_hash) -> let sealedCtxAndPs = sealCtxAndPs cont bracketedPatches in case substrPS (BC.pack "Patch bundle hash:") maybe_hash of Just n -> let hPs = mapFL_FL hopefully bracketedPatches realHash = hashBundle hPs getHash = fst . sillyLex . snd . sillyLex bundleHash = getHash $ B.drop n maybe_hash in if realHash == bundleHash then sealedCtxAndPs else Left hashFailureMessage Nothing -> sealedCtxAndPs (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 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." sealCtxAndPs ctx ps = Right $ sealContextWithPatches ctx ps sealContextWithPatches :: RepoPatch p => [PatchInfo] -> FL (PatchInfoAnd (Bracketed p)) wX wY -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) Origin) sealContextWithPatches context bracketedPatches = let patches = mapFL_FL (fmapFLPIAP unBracketedFL) bracketedPatches in case reverse context of (x : ry) | isTag x -> let ps = unavailablePatches (reverse ry) t = Tagged (piUnavailable x) Nothing NilRL in Sealed $ PatchSet ps (t :<: NilRL) :> patches _ -> let ps = PatchSet (unavailablePatches context) NilRL in Sealed $ ps :> 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. -- :{ scanBundle :: forall p . RepoPatch p => B.ByteString -> Either String (SealedPatchSet p Origin) scanBundle bundle = do Sealed (PatchSet recent tagged :> ps) <- parseBundle bundle return . Sealed $ PatchSet (reverseFL ps +<+ recent) tagged -- |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 | B.length x < 2 = x | BC.pack "- " `B.isPrefixOf` x = B.drop 2 x | otherwise = x not_context_or_newpatches s = (s /= BC.pack "Context:") && (s /= BC.pack "New patches:") -- |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) wX wY unavailablePatches = foldr ((:<:) . piUnavailable) (unsafeCoerceP NilRL) -- |piUnavailable returns an Unavailable within a PatchInfoAnd given a -- PatchInfo. piUnavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p wX wY piUnavailable i = patchInfoAndPatch i . unavailable $ "Patch not stored in patch bundle:\n" ++ renderString Encode (showPatchInfoUI 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) -- |(-:-) is used to build up a Sealed FL of patches and tuple it, along with -- any unconsumed input. (-:-) :: a wX wY -> (Sealed (FL a wY), b) -> (Sealed (FL a wX), b) p -:- (Sealed ps, r) = (Sealed (p :>: ps), r) -- |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)) wX), 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 -- |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) contextPatches :: RepoPatch p => PatchSet p Origin wX -> (PatchSet p :> RL (PatchInfoAnd p)) Origin wX 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 -- |'scanContextFile' scans the context in the file of the given name. scanContextFile :: RepoPatch p => FilePath -> IO (PatchSet p Origin wX) scanContextFile filename = scanContext `fmap` mmapFilePS filename where -- are the type witnesses sensible? scanContext :: RepoPatch p => B.ByteString -> PatchSet p Origin wX scanContext input | B.null input = error "Bad context!" | otherwise = case sillyLex input of ("Context:",rest) -> case getContext rest of (cont@(_ : _), _) | isTag (last cont) -> let ps = unavailablePatches $ init cont t = Tagged (piUnavailable $ last cont) Nothing NilRL in PatchSet ps (t :<: NilRL) (cont, _) -> PatchSet (unavailablePatches cont) NilRL ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> scanContext $ filterGpgDashes rest (_, rest) -> scanContext rest -- | Minimize the context of a bundle to be sent, taking into account -- the patches selected to be sent minContext :: (RepoPatch p) => PatchSet p wStart wB -> FL (PatchInfoAnd p) wB wC -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) wStart) minContext (PatchSet topCommon behindTag) to_be_sent = case go topCommon NilFL to_be_sent of Sealed (c :> to_be_sent') -> seal (PatchSet c behindTag :> to_be_sent') where go :: (RepoPatch p) => RL (PatchInfoAnd p) wA wB -- context we attempt to minimize -> FL (PatchInfoAnd p) wB wC -- patches we cannot remove from context -> FL (PatchInfoAnd p) wC wD -- patches to be included in the bundle -> Sealed (( RL (PatchInfoAnd p) :> FL (PatchInfoAnd p) ) wA ) go NilRL necessary to_be_sent' = seal (reverseFL necessary :> to_be_sent') go (candidate :<: rest) necessary to_be_sent' = let fl1 = (candidate :>: NilFL) in case commute (fl1 :> necessary) of Nothing -> go rest (candidate :>: necessary) to_be_sent' Just (necessary' :> fl1') -> case commute (fl1' :> to_be_sent') of Nothing -> go rest (candidate :>: necessary) to_be_sent' Just (to_be_sent'' :> _) -> -- commutation work, we can drop the patch go rest necessary' to_be_sent'' -- |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 _ = '_' darcs-2.10.2/src/Darcs/Patch/Prim/0000755000175000017500000000000012620122474020513 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Prim/Class.hs0000644000175000017500000001307012620122474022115 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimCanonize(..) , PrimClassify(..), PrimDetails(..) , PrimShow(..), showPrimFL, PrimRead(..) , PrimApply(..) , PrimPatch, PrimPatchBase(..) , FromPrim(..), FromPrims(..), ToFromPrim(..) ) where import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.FileHunk ( FileHunk, IsHunk ) import Darcs.Util.Path ( FileName ) import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.ReadMonads ( ParserM ) import Darcs.Patch.Repair ( RepairToFL ) import Darcs.Patch.Show ( ShowPatch ) import Darcs.Patch.SummaryData ( SummDetail ) import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, (:>), mapFL, mapFL_FL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed ) import Darcs.Util.Printer ( Doc, vcat ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import qualified Data.ByteString as B ( ByteString ) class (Patchy prim, MyEq prim ,PatchListFormat prim, IsHunk prim, RepairToFL prim ,PatchInspect prim, ReadPatch prim, ShowPatch 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 :: (* -> * -> *)) :: (* -> * -> *) 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 wX wY -> p wX wY class FromPrim p => ToFromPrim p where toPrim :: p wX wY -> Maybe (PrimOf p wX wY) class FromPrims p where fromPrims :: FL (PrimOf p) wX wY -> p wX wY instance FromPrim p => FromPrim (FL p) where fromPrim p = fromPrim p :>: NilFL instance FromPrim p => FromPrims (FL p) where fromPrims = mapFL_FL fromPrim instance FromPrim p => FromPrims (RL p) where fromPrims = reverseFL . mapFL_FL fromPrim class PrimClassify prim where primIsAddfile :: prim wX wY -> Bool primIsRmfile :: prim wX wY -> Bool primIsAdddir :: prim wX wY -> Bool primIsRmdir :: prim wX wY -> Bool primIsMove :: prim wX wY -> Bool primIsHunk :: prim wX wY -> Bool primIsTokReplace :: prim wX wY -> Bool primIsBinary :: prim wX wY -> Bool primIsSetpref :: prim wX wY -> Bool is_filepatch :: prim wX wY -> Maybe FileName class PrimConstruct prim where addfile :: FilePath -> prim wX wY rmfile :: FilePath -> prim wX wY adddir :: FilePath -> prim wX wY rmdir :: FilePath -> prim wX wY move :: FilePath -> FilePath -> prim wX wY changepref :: String -> String -> String -> prim wX wY hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> prim wX wY tokreplace :: FilePath -> String -> String -> String -> prim wX wY binary :: FilePath -> B.ByteString -> B.ByteString -> prim wX wY primFromHunk :: FileHunk wX wY -> prim wX wY anIdentity :: prim wX wX class PrimCanonize prim where -- | @tryToShrink ps@ simplifies @ps@ by getting rid of self-cancellations -- or coalescing patches -- -- Question (Eric Kow): what properties should this have? For example, -- the prim1 implementation only gets rid of the first self-cancellation -- it finds (as far as I can tell). Is that OK? Can we try harder? tryToShrink :: FL prim wX wY -> FL prim wX wY -- | @tryShrinkingInverse ps@ deletes the first subsequence of -- primitive patches that is followed by the inverse subsequence, -- if one exists. If not, it returns @Nothing@ tryShrinkingInverse :: FL prim wX wY -> Maybe (FL prim wX wY) -- | 'sortCoalesceFL' @ps@ coalesces as many patches in @ps@ as -- possible, sorting the results in some standard order. sortCoalesceFL :: FL prim wX wY -> 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 :: D.DiffAlgorithm -> 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. -- -- 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 :: D.DiffAlgorithm -> FL prim wX wY -> FL prim wX wY coalesce :: (prim :> prim) wX wY -> Maybe (FL prim wX wY) class PrimDetails prim where summarizePrim :: prim wX wY -> [SummDetail] class PrimShow prim where showPrim :: FileNameFormat -> prim wA wB -> Doc showPrimFL :: PrimShow prim => FileNameFormat -> FL prim wA wB -> Doc showPrimFL f xs = vcat (mapFL (showPrim f) xs) class PrimRead prim where readPrim :: ParserM m => FileNameFormat -> m (Sealed (prim wX)) class PrimApply prim where applyPrimFL :: ApplyMonad m (ApplyState prim) => FL prim wX wY -> m () darcs-2.10.2/src/Darcs/Patch/Prim/V3/0000755000175000017500000000000012620122474021003 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Prim/V3/Show.hs0000644000175000017500000000475512620122474022272 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, 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.Util.Printer ( text, packedString, blueText, (<+>), (<>), Doc ) #include "impossible.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 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" showPrim _ (Move{}) = bug "show for move not implemented" 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 wX wY -> 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 darcs-2.10.2/src/Darcs/Patch/Prim/V3/Apply.hs0000644000175000017500000000471712620122474022435 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} 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.Patch.Witnesses.Ordered ( FL(..) ) import Storage.Hashed.Hash( Hash(..) ) #include "impossible.h" instance Apply Prim where type ApplyState Prim = ObjectMap apply (Manifest i (dirid, name)) = editDirectory dirid (M.insert name i) apply (Demanifest _ (dirid, name)) = editDirectory dirid (M.delete name) apply (TextHunk i hunk) = editFile i (hunkEdit hunk) apply (BinaryHunk i hunk) = editFile i (hunkEdit hunk) apply Identity = return () apply (Move{}) = bug "apply for move not implemented" 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 i edit = do load <- gets getObject store <- gets putObject obj <- lift $ load i new <- lift $ store i $ 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 i edit = editObject i 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 i edit = editObject i 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 darcs-2.10.2/src/Darcs/Patch/Prim/V3/Read.hs0000644000175000017500000000412412620122474022213 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, 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.Patch.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 ) #include "impossible.h" 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 decodeWhite _ = impossible darcs-2.10.2/src/Darcs/Patch/Prim/V3/Core.hs0000644000175000017500000001251412620122474022232 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, OverloadedStrings, StandaloneDeriving #-} -- 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.Core ( Prim(..), Hunk(..), UUID(..), Location, Object(..), touches, hunkEdit ) where import qualified Data.ByteString as BS import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) 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 wX wY where Hunk :: !Int -> BS.ByteString -> BS.ByteString -> Hunk wX wY deriving Show instance Show1 (Hunk wX) where showDict1 = ShowDictClass instance Show2 Hunk where showDict2 = ShowDictClass invertHunk :: Hunk wX wY -> Hunk wY wX invertHunk (Hunk off old new) = Hunk off new old hunkEdit :: Hunk wX wY -> 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 wX wY where BinaryHunk :: !UUID -> Hunk wX wY -> Prim wX wY TextHunk :: !UUID -> Hunk wX wY -> Prim wX wY -- 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 wX wY Demanifest :: !UUID -> Location -> Prim wX wY Move :: !UUID -> Location -> Location -> Prim wX wY Identity :: Prim wX wX deriving instance Show (Prim wX wY) instance Show1 (Prim wX) where showDict1 = ShowDictClass instance Show2 Prim where showDict2 = ShowDictClass touches :: Prim wX wY -> [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 wX wY) where (==) = unsafeCompare darcs-2.10.2/src/Darcs/Patch/Prim/V3/Coalesce.hs0000644000175000017500000000071012620122474023053 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V3.Coalesce () where import Darcs.Patch.Prim.Class ( PrimCanonize(..) ) import Darcs.Patch.Witnesses.Ordered( FL(..) ) import Darcs.Patch.Prim.V3.Core( Prim ) -- TODO instance PrimCanonize Prim where tryToShrink = error "tryToShrink" tryShrinkingInverse _ = error "tryShrinkingInverse" sortCoalesceFL = id canonize _ = (:>: NilFL) canonizeFL _ = id coalesce = const Nothing darcs-2.10.2/src/Darcs/Patch/Prim/V3/Details.hs0000644000175000017500000000037312620122474022727 0ustar00guillaumeguillaume00000000000000{-# 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(..) ) -- TODO instance PrimDetails Prim where summarizePrim _ = [] darcs-2.10.2/src/Darcs/Patch/Prim/V3/Commute.hs0000644000175000017500000000554012620122474022754 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-overlapping-patterns #-} {-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V3.Commute ( CommuteMonad(..) ) where import Data.List ( intersect ) import qualified Data.ByteString as BS (length) import Darcs.Patch.Witnesses.Ordered ( (:>)(..) ) import Darcs.Patch.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" 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) wX wY -> m ((Hunk :> Hunk) wY wX) 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 darcs-2.10.2/src/Darcs/Patch/Prim/V3/ObjectMap.hs0000644000175000017500000000357112620122474023211 0ustar00guillaumeguillaume00000000000000-- 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] } darcs-2.10.2/src/Darcs/Patch/Prim/V3.hs0000644000175000017500000000114312620122474021336 0ustar00guillaumeguillaume00000000000000{-# 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 darcs-2.10.2/src/Darcs/Patch/Prim/V1/0000755000175000017500000000000012620122474021001 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Prim/V1/Show.hs0000644000175000017500000001535712620122474022270 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ViewPatterns #-} module Darcs.Patch.Prim.V1.Show ( showHunk ) where import Prelude hiding ( pi ) 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.Util.Path ( 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.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.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) ) import Darcs.Util.Printer ( Doc, vcat, text, userchunk, invisibleText, invisiblePS, blueText, ($$), (<+>), (<>), ) import Darcs.Util.Show ( appPrec, BSWrapper(..) ) -- 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 wX wY) 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 wX) where showDict1 = ShowDictClass instance Show (FilePatchType wX wY) 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) (map BSWrapper old) . showString " " . showsPrec (appPrec + 1) (map BSWrapper 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) (BSWrapper old) . showString " " . showsPrec (appPrec + 1) (BSWrapper new) instance Show (DirPatchType wX wY) where showsPrec _ RmDir = showString "RmDir" showsPrec _ AddDir = showString "AddDir" 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' showPrim _ (ChangePref p f t) = showChangePref p f t showAddFile :: FileNameFormat -> FileName -> Doc showAddFile x f = blueText "addfile" <+> formatFileName x f showRmFile :: FileNameFormat -> FileName -> Doc showRmFile x f = blueText "rmfile" <+> formatFileName x f showMove :: FileNameFormat -> FileName -> FileName -> Doc showMove x d d' = blueText "move" <+> formatFileName x d <+> formatFileName x 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 showRmDir :: FileNameFormat -> FileName -> Doc showRmDir x d = blueText "rmdir" <+> formatFileName x d showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc showHunk x f line old new = showFileHunk x (FileHunk f line old new) showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc showTok x f t o n = blueText "replace" <+> formatFileName x 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 $$ invisibleText "oldhex" $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex o) $$ invisibleText "newhex" $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex n) where makeprintable ps = invisibleText "*" <> invisiblePS ps breakEvery :: Int -> B.ByteString -> [B.ByteString] breakEvery n ps | B.length ps < n = [ps] | otherwise = B.take n ps : breakEvery n (B.drop n ps) darcs-2.10.2/src/Darcs/Patch/Prim/V1/Apply.hs0000644000175000017500000001511412620122474022424 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} {-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Apply () where import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Repair ( RepairToFL(..) ) import Darcs.Patch.Prim.Class ( PrimApply(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Prim.V1.Show ( showHunk ) import Darcs.Util.Path ( fn2fp ) import Darcs.Patch.Format ( FileNameFormat(..) ) import Darcs.Patch.TokenReplace ( tryTokInternal ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Storage.Hashed.Tree( Tree ) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, spanFL, (:>)(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart ) import Darcs.Util.ByteString ( unlinesPS, breakAfterNthNewline, breakBeforeNthNewline, ) import Darcs.Util.Printer( renderString, RenderMode(..) ) import qualified Data.ByteString as B ( ByteString, empty, null, concat ) import qualified Data.ByteString.Char8 as BC (pack, singleton, unpack) import Data.List ( intersperse ) #include "impossible.h" type FileContents = B.ByteString 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 ++ " couldn't apply." Just ls' -> return $ map B.concat ls' 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 ++ " couldn't apply." apply (DP d AddDir) = mCreateDirectory d apply (DP d RmDir) = mRemoveDirectory d apply (Move f f') = mRename f f' apply (ChangePref p f t) = mChangePref p f t instance RepairToFL Prim where applyAndTryToFixFL (FP f RmFile) = do x <- mReadFilePS f mRemoveFile f return $ if B.null x then Nothing else 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 ) applyAndTryToFixFL (FP f AddFile) = do exists <- mDoesFileExist f if exists then return $ Just ("WARNING: Dropping add of existing file "++fn2fp f, -- the old context was wrong, so we have to coerce unsafeCoercePStart NilFL ) else do mCreateFile f return Nothing applyAndTryToFixFL (DP f AddDir) = do exists <- mDoesDirectoryExist f if exists then return $ Just ("WARNING: Dropping add of existing directory "++fn2fp 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 instance PrimApply Prim where applyPrimFL NilFL = return () applyPrimFL (FP f h@(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 applyPrimFL ps' where f_hunk (FP f' (Hunk{})) | f == f' = True f_hunk _ = False hunkmod :: ApplyMonad m Tree => FL FilePatchType 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 Encode (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 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' 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' darcs-2.10.2/src/Darcs/Patch/Prim/V1/Read.hs0000644000175000017500000001062712620122474022216 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1.Read () where import Darcs.Patch.Prim.Class ( PrimRead(..), hunk, binary ) import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) ) import Darcs.Util.Path ( 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.Patch.Witnesses.Sealed ( seal ) 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 ) instance ReadPatch Prim where readPatch' = readPrim OldFormat instance PrimRead Prim where readPrim x = 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 ] where return' = liftM seal hunk' :: B.ByteString hunk' = BC.pack "hunk" replace :: B.ByteString replace = BC.pack "replace" binary' :: B.ByteString binary' = BC.pack "binary" addfile :: B.ByteString addfile = BC.pack "addfile" adddir :: B.ByteString adddir = BC.pack "adddir" rmfile :: B.ByteString rmfile = BC.pack "rmfile" rmdir :: B.ByteString rmdir = BC.pack "rmdir" move :: B.ByteString move = BC.pack "move" changepref :: B.ByteString changepref = BC.pack "changepref" readHunk :: ParserM m => FileNameFormat -> m (Prim wX wY) readHunk x = do string hunk' fi <- myLex' 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 [] [] skipNewline :: ParserM m => m Bool skipNewline = option False (char '\n' >> return True) readTok :: ParserM m => FileNameFormat -> m (Prim wX wY) readTok x = 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) where drop_brackets = B.init . B.tail -- * Binary file modification -- -- | Modify a binary file -- -- > binary FILENAME -- > oldhex -- > *HEXHEXHEX -- > ... -- > newhex -- > *HEXHEXHEX -- > ... readBinary :: ParserM m => FileNameFormat -> m (Prim wX wY) readBinary x = do string binary' fi <- myLex' _ <- myLex' skipSpace old <- linesStartingWith '*' _ <- myLex' skipSpace new <- linesStartingWith '*' return $ binary (fn2fp $ readFileName x fi) (fromHex2PS $ B.concat old) (fromHex2PS $ B.concat new) readAddFile :: ParserM m => FileNameFormat -> m (Prim wX wY) readAddFile x = do string addfile f <- myLex' return $ FP (readFileName x f) AddFile readRmFile :: ParserM m => FileNameFormat -> m (Prim wX wY) readRmFile x = do string rmfile f <- myLex' return $ FP (readFileName x f) RmFile readMove :: ParserM m => FileNameFormat -> m (Prim wX wY) readMove x = do string move d <- myLex' d' <- myLex' return $ Move (readFileName x d) (readFileName x d') readChangePref :: ParserM m => m (Prim wX wY) 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) readAddDir :: ParserM m => FileNameFormat -> m (Prim wX wY) readAddDir x = do string adddir f <- myLex' return $ DP (readFileName x f) AddDir readRmDir :: ParserM m => FileNameFormat -> m (Prim wX wY) readRmDir x = do string rmdir f <- myLex' return $ DP (readFileName x f) RmDir darcs-2.10.2/src/Darcs/Patch/Prim/V1/Core.hs0000644000175000017500000001466412620122474022240 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..), isIdentity, comparePrim, ) where import Prelude hiding ( pi ) import qualified Data.ByteString as B (ByteString) import Darcs.Util.Path ( FileName, fn2fp, fp2fn, normPath ) import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) ) data Prim wX wY where Move :: !FileName -> !FileName -> Prim wX wY DP :: !FileName -> !(DirPatchType wX wY) -> Prim wX wY FP :: !FileName -> !(FilePatchType wX wY) -> Prim wX wY ChangePref :: !String -> !String -> !String -> Prim wX wY 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 wX wY = RmDir | AddDir deriving (Eq,Ord) instance MyEq FilePatchType where unsafeCompare a b = a == unsafeCoerceP b instance MyEq DirPatchType where unsafeCompare a b = a == unsafeCoerceP b isIdentity :: Prim wX wY -> EqCheck wX wY 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 evalargs :: (a -> b -> c) -> a -> b -> c evalargs f x y = (f $! x) $! y 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 nFn :: FilePath -> FilePath nFn f = "./"++(fn2fp $ normPath $ fp2fn f) instance IsHunk Prim where isHunk (FP fn (Hunk line before after)) = Just (FileHunk fn 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 (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 (ChangePref _ _ _) = [] hunkMatches f (FP _ (Hunk _ remove add)) = anyMatches remove || anyMatches add where anyMatches = foldr ((||) . f) False hunkMatches _ (FP _ _) = False hunkMatches _ (DP _ _) = False hunkMatches _ (ChangePref _ _ _) = False hunkMatches _ (Move _ _) = False instance PatchDebug Prim instance MyEq 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 unsafeCompare (FP f1 fp1) (FP f2 fp2) = f1 == f2 && fp1 `unsafeCompare` fp2 unsafeCompare (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) = c1 == c2 && b1 == b2 && a1 == a2 unsafeCompare _ _ = False 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 wX wY -> Prim wW wZ -> 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) darcs-2.10.2/src/Darcs/Patch/Prim/V1/Coalesce.hs0000644000175000017500000002520112620122474023053 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Coalesce () where import Prelude hiding ( pi ) import Control.Arrow ( second ) import Data.Maybe ( fromMaybe ) import Data.Map ( elems, fromListWith, mapWithKey ) import qualified Data.ByteString as B (ByteString, empty) import System.FilePath ( () ) import Darcs.Patch.Prim.Class ( PrimCanonize(..) ) import Darcs.Patch.Prim.V1.Commute () import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..), DirPatchType(..) , comparePrim, isIdentity ) import Darcs.Patch.Prim.V1.Show () import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:<)(..) , reverseRL, mapFL, mapFL_FL , concatFL, lengthFL, (+>+) ) import Darcs.Patch.Witnesses.Sealed ( unseal, Sealed2(..), unsafeUnseal2 , Gap(..), unFreeLeft ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Commute ( Commute(..) ) -- import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Util.Diff ( getChanges ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Path ( FileName, fp2fn ) #include "impossible.h" -- | 'coalesceRev' @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. coalesceRev :: (Prim :< Prim) wX wY -> Maybe (FL Prim wX wY) coalesceRev (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing coalesceRev (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just NilFL coalesceRev (FP f1 p1 :< FP _ p2) = fmap (:>: NilFL) $ coalesceFilePrim f1 (p1 :< p2) -- f1 = f2 coalesceRev (Move a b :< Move b' a') | a == a' = Just $ Move b' b :>: NilFL coalesceRev (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile :>: NilFL coalesceRev (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir :>: NilFL coalesceRev (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile :>: NilFL coalesceRev (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir :>: NilFL coalesceRev (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 :>: NilFL coalesceRev _ = Nothing mapPrimFL :: (forall wX wY . FL Prim wX wY -> FL Prim wX wY) -> FL Prim wW wZ -> FL Prim wW wZ 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 where unsealList :: [Sealed2 p] -> FL p wA wB unsealList = foldr ((:>:) . unsafeUnseal2) (unsafeCoerceP NilFL) toSimpleSealed :: Sealed2 Prim -> Maybe (FileName, Sealed2 Simple) toSimpleSealed (Sealed2 p) = fmap (second Sealed2) (toSimple p) data Simple wX wY = SFP !(FilePatchType wX wY) | SDP !(DirPatchType wX wY) | SCP String String String deriving ( Show ) toSimple :: Prim wX wY -> Maybe (FileName, Simple wX wY) 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 $ darcsdir "prefs" "prefs", SCP a b c) fromSimple :: FileName -> Simple wX wY -> Prim wX wY 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 wX wY -> FL Prim wX wY fromSimples a = mapFL_FL (fromSimple a) tryHarderToShrink :: FL Prim wX wY -> FL Prim wX wY tryHarderToShrink x = tryToShrink2 $ fromMaybe x (tryShrinkingInverse x) tryToShrink2 :: FL Prim wX wY -> FL Prim wX wY 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 ps@ tries to simplify @ps@ by one patch, -- the first one we find that coalesces with its neighbour shrinkABit :: FL Prim wX wY -> FL Prim wX wY shrinkABit NilFL = NilFL shrinkABit (p:>:ps) = fromMaybe (p :>: shrinkABit ps) $ tryOne NilRL p ps -- | @tryOne acc p ps@ pushes @p@ as far down @ps@ as we can go -- until we can either coalesce it with something or it can't -- go any further. Returns @Just@ if we manage to get any -- coalescing out of this tryOne :: RL Prim wW wX -> Prim wX wY -> FL Prim wY wZ -> Maybe (FL Prim wW wZ) tryOne _ _ NilFL = Nothing tryOne sofar p (p1:>:ps) = case coalesceRev (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 -- | The heart of "sortCoalesceFL" sortCoalesceFL2 :: FL Prim wX wY -> FL Prim wX wY sortCoalesceFL2 NilFL = NilFL sortCoalesceFL2 (x:>:xs) | IsEq <- isIdentity x = sortCoalesceFL2 xs sortCoalesceFL2 (x:>:xs) = either id id $ pushCoalescePatch x $ sortCoalesceFL2 xs -- | '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 wX wY -> FL Prim wY wZ -> Either (FL Prim wX wZ) (FL Prim wX wZ) pushCoalescePatch new NilFL = Left (new:>:NilFL) pushCoalescePatch new ps@(p:>:ps') = case coalesceRev (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) coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) wX wY -> Maybe (Prim wX wY) 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) -- 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') | m == m' = Just $ FP f $ Binary o n coalesceFilePrim _ _ = Nothing coalesceHunk :: FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Int -> [B.ByteString] -> [B.ByteString] -> Maybe (Prim wX wY) coalesceHunk f line1 old1 new1 line2 old2 new2 | line1 == line2 && lengthold1 < lengthnew2 = if take lengthold1 new2 /= old1 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 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 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 extra-> coalesceHunk f line2 (extra ++ old1) (extra ++ new1) line2 old2 new2 | otherwise = Nothing where lengthold1 = length old1 lengthnew2 = length new2 canonizeHunk :: Gap w => D.DiffAlgorithm -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> w (FL Prim) canonizeHunk _ f line old new | null old || null new || old == [B.empty] || new == [B.empty] = freeGap (FP f (Hunk line old new) :>: NilFL) canonizeHunk da f line old new = makeHoley f line $ getChanges da old new makeHoley :: Gap w => FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])] -> w (FL Prim) makeHoley f line = foldr (joinGap (:>:) . (\(l,o,n) -> freeGap (FP f (Hunk (l+line) o n)))) (emptyGap NilFL) instance PrimCanonize Prim where tryToShrink = mapPrimFL tryHarderToShrink tryShrinkingInverse (x:>:y:>:z) | IsEq <- invert x =\/= y = Just z | otherwise = case tryShrinkingInverse (y:>:z) of Nothing -> Nothing Just yz' -> Just $ fromMaybe (x :>: yz') $ tryShrinkingInverse (x:>:yz') tryShrinkingInverse _ = Nothing sortCoalesceFL = mapPrimFL sortCoalesceFL2 canonize _ p | IsEq <- isIdentity p = NilFL canonize da (FP f (Hunk line old new)) = unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk da f line old new canonize _ p = p :>: NilFL -- Running canonize twice is apparently necessary to fix issue525; -- would be nice to understand why. canonizeFL da = concatFL . mapFL_FL (canonize da) . sortCoalesceFL . concatFL . mapFL_FL (canonize da) coalesce (x :> y) = coalesceRev (y :< x) darcs-2.10.2/src/Darcs/Patch/Prim/V1/Details.hs0000644000175000017500000000154312620122474022725 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1.Details () where import Prelude hiding ( pi ) import Darcs.Patch.Prim.Class ( PrimDetails(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..), DirPatchType(..) ) import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) 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 (DP d AddDir) = [SummAddDir d] summarizePrim (DP d RmDir) = [SummRmDir d] summarizePrim (Move f1 f2) = [SummMv f1 f2] summarizePrim (ChangePref{}) = [SummNone] darcs-2.10.2/src/Darcs/Patch/Prim/V1/Commute.hs0000644000175000017500000002075512620122474022757 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Commute ( Perhaps(..) , subcommutes, WrappedCommuteFunction(..) ) where import Prelude hiding ( pi ) import Control.Monad ( MonadPlus, msum, mzero, mplus ) import Control.Applicative ( Applicative(..), Alternative(..) ) import qualified Data.ByteString as B (ByteString, concat) import qualified Data.ByteString.Char8 as BC (pack) import Darcs.Util.Path ( FileName, fn2fp, movedirfilename ) import Darcs.Patch.Witnesses.Ordered ( (:<)(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Commute ( Commute(..), toFwdCommute, toRevCommute ) import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Patch.TokenReplace ( tryTokInternal ) #include "impossible.h" isInDirectory :: FileName -> FileName -> Bool isInDirectory d f = iid (fn2fp d) (fn2fp f) where iid (cd:cds) (cf:cfs) | cd /= cf = False | otherwise = iid cds cfs 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 return = Succeeded fail _ = Unknown instance Alternative Perhaps where empty = Unknown Unknown <|> ys = ys Failed <|> _ = Failed (Succeeded x) <|> _ = Succeeded x instance MonadPlus Perhaps where 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: Succeeded x Failed -> Failed 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` -- (case c (invert p2,invert p1) of -- Succeeded (p1', p2') -> Succeeded (invert p2', invert p1') -- Failed -> Failed -- Unknown -> Unknown) 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 _other = Unknown everythingElseCommute :: CommuteFunction everythingElseCommute = eec where eec :: CommuteFunction eec (ChangePref p f t : 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 || isInDirectory d2 d1) && d1 /= d2 then Succeeded ( DP d2 (unsafeCoerceP p2) :< DP d1 (unsafeCoerceP p1) ) else Failed commuteFiledir (DP d dp :< FP f fp) = if not $ isInDirectory d f then Succeeded (FP f (unsafeCoerceP fp) :< DP d (unsafeCoerceP dp)) 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') | 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')) commuteFiledir _ = Unknown type CommuteFunction = forall wX wY . (Prim :< Prim) wX wY -> Perhaps ((Prim :< Prim) wX wY) 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 commuteFP :: FileName -> (FilePatchType :< FilePatchType) wX wY -> Perhaps ((Prim :< Prim) wX wY) 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 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 _ _ = Unknown commuteHunk :: FileName -> (FilePatchType :< FilePatchType) wX wY -> Maybe ((Prim :< Prim) wX wY) 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 tryTokReplace :: String -> String -> String -> [B.ByteString] -> Maybe [B.ByteString] tryTokReplace t o n = mapM (fmap B.concat . tryTokInternal t (BC.pack o) (BC.pack n)) darcs-2.10.2/src/Darcs/Patch/Prim/V1.hs0000644000175000017500000000114212620122474021333 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1 ( Prim ) where import Darcs.Patch.Prim.V1.Apply () import Darcs.Patch.Prim.V1.Coalesce () import Darcs.Patch.Prim.V1.Commute () import Darcs.Patch.Prim.V1.Core ( Prim ) import Darcs.Patch.Prim.V1.Details () 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 darcs-2.10.2/src/Darcs/Patch/Patchy.hs0000644000175000017500000000237612620122474021400 0ustar00guillaumeguillaume00000000000000-- 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 #-} 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(..) ) class (Apply p, Commute p, Invert p) => Patchy p darcs-2.10.2/src/Darcs/Patch/Show.hs0000644000175000017500000000524412620122474021065 0ustar00guillaumeguillaume00000000000000-- 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.Patch.Show ( ShowPatchBasic(..) , ShowPatch(..) , showNamedPrefix , formatFileName ) where import Prelude hiding ( pi ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, ApplyMonad ) import Darcs.Patch.Format ( FileNameFormat(..) ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo ) import Darcs.Patch.Witnesses.Ordered ( FL ) import Darcs.Util.English ( plural, Noun(Noun) ) import Darcs.Util.Path ( FileName, fn2ps, encodeWhite, fn2fp ) import Darcs.Util.Printer ( Doc, vcat, blueText, ($$), text, packedString ) showNamedPrefix :: PatchInfo -> [PatchInfo] -> Doc showNamedPrefix n d = showPatchInfo n $$ blueText "<" $$ vcat (map showPatchInfo d) $$ blueText ">" class ShowPatchBasic p where showPatch :: p wX wY -> Doc class ShowPatchBasic p => ShowPatch p where showNicely :: p wX wY -> 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 wX wY -> m Doc showContextPatch p = return $ showPatch p description :: p wX wY -> Doc description = showPatch summary :: p wX wY -> Doc summaryFL :: FL p wX wY -> Doc thing :: p wX wY -> String thing _ = "patch" things :: p wX wY -> String things x = plural (Noun $ thing x) "" formatFileName :: FileNameFormat -> FileName -> Doc formatFileName OldFormat = packedString . fn2ps formatFileName NewFormat = text . encodeWhite . fn2fp darcs-2.10.2/src/Darcs/Patch/TokenReplace.hs0000644000175000017500000000465312620122474022524 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.TokenReplace ( tryTokInternal , forceTokReplace , breakOutToken ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Maybe ( isNothing ) import Darcs.Util.ByteString ( substrPS, linesPS, unlinesPS ) import Darcs.Patch.RegChars ( regChars ) -- | breakOutToken takes a String of token chars and an input ByteString, and -- returns the ByteString triple of (beforeToken, token, afterToken). breakOutToken :: String -> BC.ByteString -> (BC.ByteString, BC.ByteString, BC.ByteString) breakOutToken tokChars input = let isTokChar = regChars tokChars (before, tokAndRest) = BC.break isTokChar input (tok, remaining) = BC.break (not . isTokChar) tokAndRest in (before, tok, remaining) -- | tryTokInternal takes a String of token chars, an oldToken ByteString, a -- newToken ByteString and returns the list of token-delimited ByteStrings, -- with any tokens matching oldToken being replaced by newToken. If newToken is -- already in the input, we return Nothing. tryTokInternal :: String -> B.ByteString -> B.ByteString -> B.ByteString -> Maybe [B.ByteString] tryTokInternal _ oldToken newToken input | isNothing (substrPS oldToken input) && isNothing (substrPS newToken input) = Just [ input ] tryTokInternal tokChars oldToken newToken input = let (before, tok, remaining) = breakOutToken tokChars input in case tryTokInternal tokChars oldToken newToken remaining of Nothing -> Nothing Just rest | tok == oldToken -> Just $ before : newToken : rest | tok == newToken -> Nothing | otherwise -> Just $ before : tok : rest -- | forceTokReplace replaces all occurrences of the old token with the new -- token, throughout the input ByteString. forceTokReplace :: String -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString forceTokReplace tokChars oldToken newToken = forceReplaceLines where forceReplaceLines = unlinesPS . map forceReplace . linesPS breakOutAllTokens input | B.null input = [] breakOutAllTokens input = let (before, tok, remaining) = breakOutToken tokChars input in before : tok : breakOutAllTokens remaining forceReplace = B.concat . map replaceMatchingToken . breakOutAllTokens replaceMatchingToken input | input == oldToken = newToken | otherwise = input darcs-2.10.2/src/Darcs/Patch/Depends.hs0000644000175000017500000005375012620122474021534 0ustar00guillaumeguillaume00000000000000-- 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 , ScopedTypeVariables #-} module Darcs.Patch.Depends ( getUncovered , areUnrelatedRepos , findCommonAndUncommon , mergeThem , findCommonWithThem , countUsThem , removeFromPatchSet , slightlyOptimizePatchset , getPatchesBeyondTag , splitOnTag , newsetUnion , newsetIntersection , commuteToEnd , findUncommon , merge2FL ) where #include "impossible.h" import Prelude hiding ( pi ) import Data.List ( delete, intersect, (\\) ) import Data.Maybe ( fromMaybe ) import Darcs.Patch ( Patchy, getdeps, commute, commuteFLorComplain, commuteRL ) import Darcs.Patch.Info ( PatchInfo, isTag, showPatchInfoUI ) import Darcs.Patch.Merge ( Merge, mergeFL ) import Darcs.Patch.Permutations ( partitionFL, partitionRL, removeSubsequenceRL ) import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, hopefullyM, info ) import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, appendPSFL ) import Darcs.Patch.Progress ( progressRL ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=\/=), (=/\=) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart ) import Darcs.Patch.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..), (+>+), mapFL, RL(..), FL(..), isShorterThanRL, (+<+), reverseFL, reverseRL, mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, seal ) import Darcs.Util.Printer ( renderString, vcat, RenderMode(..) ) {- - This module uses the following definitions: - - Explicit dependencies: the set of patches that a patch depends on "by name", - i.e. irrespective of (non-)commutation (non commuting patches are implicit - dependencies, or conflicts). In other words, the set of patch names in a tag - or patch recorded with --ask-deps. - - Covered: a patch p covers another, q, if p's explicit dependencies include - q. E.g. in a repo [a,b,t] where t is a tag and a,b have no explicit - dependencies, then t will cover a and b. - - "Clean" tag: a tag in a repository is clean if all patches prior to the tag - are (transitively-)covered by the tag. An obvious example of obtaining an - unclean tag is by pulling from one repo into another - the tag could have - been commuted past other patches. When patches are created, they are clean, - since they explicitly depend on all uncovered patches. -} {-| taggedIntersection 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. Note that the first argument to taggedIntersection 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 rightmost argument. -} taggedIntersection :: forall p wStart wX wY . (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Fork (RL (Tagged p)) (RL (PatchInfoAnd p)) (RL (PatchInfoAnd p)) wStart wX wY taggedIntersection (PatchSet ps1 NilRL) s2 = Fork NilRL ps1 (newset2RL s2) taggedIntersection s1 (PatchSet ps2 NilRL) = Fork NilRL (newset2RL s1) ps2 taggedIntersection s1 (PatchSet ps2 (Tagged t _ _ :<: _)) | Just (PatchSet ps1 ts1) <- maybeSplitSetOnTag (info t) s1 = Fork ts1 ps1 (unsafeCoercePStart ps2) taggedIntersection s1 s2@(PatchSet ps2 (Tagged t _ p :<: ts2)) = case hopefullyM t of Just _ -> taggedIntersection s1 (PatchSet (ps2 +<+ t :<: p) ts2) Nothing -> case splitOnTag (info t) s1 of Just (PatchSet NilRL com :> us) -> Fork com us (unsafeCoercePStart ps2) Just _ -> impossible Nothing -> Fork NilRL (newset2RL s1) (newset2RL s2) -- |'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. maybeSplitSetOnTag :: PatchInfo -> PatchSet p wStart wX -> Maybe (PatchSet p wStart wX) maybeSplitSetOnTag t0 origSet@(PatchSet ps (Tagged t _ pst :<: ts)) | t0 == info t = Just origSet | otherwise = do PatchSet ps' ts' <- maybeSplitSetOnTag t0 (PatchSet (t :<: pst) ts) Just $ PatchSet (ps +<+ ps') ts' maybeSplitSetOnTag _ _ = Nothing getPatchesBeyondTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX -> FlippedSeal (RL (PatchInfoAnd p)) wX getPatchesBeyondTag t (PatchSet ps (Tagged hp _ _ :<: _)) | info hp == t = flipSeal ps getPatchesBeyondTag t patchset@(PatchSet (hp :<: ps) ts) = if info hp == t then if getUncovered patchset == [info hp] -- special case to avoid looking at redundant patches then flipSeal NilRL else case splitOnTag t patchset of Just (_ :> e) -> flipSeal e _ -> impossible else case getPatchesBeyondTag t (PatchSet ps ts) of FlippedSeal xxs -> FlippedSeal (hp :<: xxs) getPatchesBeyondTag t (PatchSet NilRL NilRL) = bug $ "tag\n" ++ renderString Encode (showPatchInfoUI t) ++ "\nis not in the patchset in getPatchesBeyondTag." getPatchesBeyondTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) = getPatchesBeyondTag t0 (PatchSet (t :<: ps) ts) -- |splitOnTag takes a tag's 'PatchInfo', and a 'PatchSet', and attempts to -- find the tag in the PatchSet, returning a pair: the clean PatchSet "up to" -- the tag, and a RL of patches after the tag; If the tag is not in the -- PatchSet, we return Nothing. splitOnTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX -> Maybe ((PatchSet p :> RL (PatchInfoAnd p)) wStart wX) -- If the tag we are looking for is the first Tagged tag of the patchset, just -- separate out the patchset's patches. splitOnTag t (PatchSet ps ts@(Tagged hp _ _ :<: _)) | info hp == t = Just $ PatchSet NilRL ts :> ps -- 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 hps@(hp :<: ps) ts) | info hp == t = if getUncovered patchset == [t] then Just $ PatchSet NilRL (Tagged hp Nothing ps :<: ts) :> NilRL else case partitionRL ((`notElem` (t : ds)) . info) hps of -- Partition hps by those that are the tag and its explicit deps. tagAndDeps@(hp' :<: ds') :> nonDeps -> -- If @ds@ doesn't contain the tag of the first Tagged, that -- tag will also be returned by the call to getUncovered - so -- we need to unwrap the next Tagged in order to expose it to -- being partitioned out in the recursive call to splitOnTag. if getUncovered (PatchSet tagAndDeps ts) == [t] then let tagged = Tagged hp' Nothing ds' in return $ PatchSet NilRL (tagged :<: ts) :> nonDeps else do unfolded <- unwrapOneTagged $ PatchSet tagAndDeps ts xx :> yy <- splitOnTag t unfolded return $ xx :> (nonDeps +<+ yy) _ -> impossible where ds = getdeps (hopefully hp) -- We drop the leading patch, to try and find a non-Tagged tag. splitOnTag t (PatchSet (p :<: ps) ts) = do ns :> x <- splitOnTag t (PatchSet ps ts) return $ ns :> (p :<: x) -- If there are no patches left, we "unfold" the next Tagged, and try again. splitOnTag t0 patchset@(PatchSet NilRL (Tagged _ _ _s :<: _)) = unwrapOneTagged patchset >>= splitOnTag t0 -- If we've checked all the patches, but haven't found the tag, return Nothing. splitOnTag _ (PatchSet NilRL NilRL) = Nothing -- |'unwrapOneTagged' unfolds a single Tagged object in a PatchSet, adding the -- tag and patches to the PatchSet's patch list. unwrapOneTagged :: (Monad m) => PatchSet p wX wY -> m (PatchSet p wX wY) unwrapOneTagged (PatchSet ps (Tagged t _ tps :<: ts)) = return $ PatchSet (ps +<+ t :<: tps) ts unwrapOneTagged _ = fail "called unwrapOneTagged with no Tagged's in the set" -- | @getUncovered 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. getUncovered :: PatchSet p wStart wX -> [PatchInfo] getUncovered patchset = case patchset of (PatchSet ps NilRL) -> findUncovered (mapRL infoAndExplicitDeps ps) (PatchSet ps (Tagged t _ _ :<: _)) -> findUncovered (mapRL infoAndExplicitDeps (ps +<+ t :<: NilRL)) where findUncovered :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo] findUncovered [] = [] findUncovered ((pi, Nothing) : rest) = pi : findUncovered rest findUncovered ((pi, Just deps) : rest) = pi : findUncovered (dropDepsIn deps rest) -- |dropDepsIn traverses the list of patches, dropping any patches that -- occur in the dependency list; when a patch is dropped, its dependencies -- are added to the dependency list used for later patches. dropDepsIn :: [PatchInfo] -> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])] dropDepsIn [] pps = pps dropDepsIn _ [] = [] dropDepsIn ds (hp : pps) | fst hp `elem` ds = let extraDeps = fromMaybe [] $ snd hp in dropDepsIn (extraDeps ++ delete (fst hp) ds) pps | otherwise = hp : dropDepsIn ds pps -- |infoAndExplicitDeps returns the patch info and (for tags only) the list -- of explicit dependencies of a patch. infoAndExplicitDeps :: PatchInfoAnd p wX wY -> (PatchInfo, Maybe [PatchInfo]) infoAndExplicitDeps p | isTag (info p) = (info p, getdeps `fmap` hopefullyM p) | otherwise = (info p, Nothing) -- | @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 wStart wX -> PatchSet p wStart wX slightlyOptimizePatchset (PatchSet ps0 ts0) = sops $ PatchSet (prog ps0) ts0 where prog = progressRL "Optimizing inventory" sops :: PatchSet p wStart wY -> PatchSet p wStart wY sops patchset@(PatchSet NilRL _) = patchset sops patchset@(PatchSet (hp :<: ps) ts) | isTag (info hp) = if getUncovered patchset == [info hp] -- exactly one tag and it depends on everything not already -- archived then PatchSet NilRL (Tagged hp Nothing ps :<: ts) -- other tags or other top-level patches too (so move past hp) else let ps' = sops $ PatchSet (prog ps) ts in appendPSFL ps' (hp :>: NilFL) | otherwise = appendPSFL (sops $ PatchSet ps ts) (hp :>: NilFL) commuteToEnd :: forall p wStart wX wY . (Patchy p, NameHack p) => RL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY -> (PatchSet p :> RL (PatchInfoAnd p)) wStart wX 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 removeFromPatchSet :: (Patchy p, NameHack p) => FL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX) removeFromPatchSet bad0 = rfns (reverseFL bad0) where rfns :: (Patchy p, NameHack p) => RL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX) 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) findCommonAndUncommon :: forall p wStart wX wY . (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Fork (PatchSet p) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wStart wX wY findCommonAndUncommon us them = case taggedIntersection us them of Fork common us' them' -> case partitionFL (infoIn them') $ reverseRL us' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" ++ renderString Encode (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) (common2 :> NilFL :> only_ours) -> case partitionFL (infoIn us') $ reverseRL them' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" ++ renderString Encode (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) _ :> NilFL :> only_theirs -> Fork (PatchSet (reverseFL common2) common) only_ours (unsafeCoercePStart only_theirs) where infoIn inWhat = (`elem` mapRL info inWhat) . info findCommonWithThem :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> (PatchSet p :> FL (PatchInfoAnd p)) wStart wX findCommonWithThem us them = case taggedIntersection us them of Fork common us' them' -> case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" ++ renderString Encode (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) common2 :> _nilfl :> only_ours -> PatchSet (reverseFL common2) common :> unsafeCoerceP only_ours findUncommon :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart 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' countUsThem :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> (Int, Int) countUsThem us them = case taggedIntersection us them of Fork _ us' them' -> let uu = mapRL info us' tt = mapRL info them' in (length $ uu \\ tt, length $ tt \\ uu) mergeThem :: (Patchy p, Merge p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Sealed (FL (PatchInfoAnd p) wX) mergeThem us them = case taggedIntersection us them of Fork _ us' them' -> case merge2FL (reverseRL us') (reverseRL them') of them'' :/\: _ -> Sealed them'' newsetIntersection :: (Patchy p, NameHack p) => [SealedPatchSet p wStart] -> SealedPatchSet p wStart newsetIntersection [] = seal $ PatchSet NilRL NilRL newsetIntersection [x] = x newsetIntersection (Sealed y : ys) = case newsetIntersection ys of Sealed z -> case taggedIntersection y z of Fork 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 newsetUnion :: (Patchy p, Merge p, NameHack p) => [SealedPatchSet p wStart] -> SealedPatchSet p wStart 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 -- | 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?) -- -- * 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 :: (Patchy p, Merge p, NameHack p) => FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wX wZ -> (FL (PatchInfoAnd p) :/\: FL (PatchInfoAnd p)) wY wZ merge2FL xs NilFL = NilFL :/\: xs merge2FL NilFL ys = ys :/\: NilFL 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' :/\: x' -> case merge2FL xs ys' of ys'' :/\: xs' -> ys'' :/\: (x' :>: xs') areUnrelatedRepos :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Bool areUnrelatedRepos us them = case taggedIntersection us them of Fork c u t -> checkit c u t 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 :: (Patchy p, NameHack p) => PatchInfoAnd p wX wY -> FL (PatchInfoAnd p) wX wZ -> Maybe (FL (PatchInfoAnd p) wY wZ) 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 :: (Patchy p, NameHack p) => RL (PatchInfoAnd p) wA0 wA -> FL (PatchInfoAnd p) wA wB -> Maybe ((PatchInfoAnd p :> FL (PatchInfoAnd p)) wA0 wB) 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 fastRemoveRL :: (Patchy p, NameHack p) => PatchInfoAnd p wY wZ -> RL (PatchInfoAnd p) wX wZ -> Maybe (RL (PatchInfoAnd p) wX wY) 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 :: (Patchy p, NameHack p) => FL (PatchInfoAnd p) wB wC -> RL (PatchInfoAnd p) wA wB -> Maybe ((RL (PatchInfoAnd p) :> PatchInfoAnd p) wA wC) 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 darcs-2.10.2/src/Darcs/Patch/RegChars.hs0000644000175000017500000000604012620122474021636 0ustar00guillaumeguillaume00000000000000-- 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.Patch.RegChars ( regChars, ) where (&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool (&&&) a b c = a c && b c (|||) :: (a -> Bool) -> (a -> Bool) -> a -> Bool (|||) a b c = a c || b c {-# INLINE regChars #-} -- | 'regChars' returns a filter function that tells if a char is a member -- of the regChar expression or not. The regChar expression is basically a -- set of chars, but it can contain ranges with use of the '-' (dash), and -- it can also be specified as a complement set by prefixing with '^' -- (caret). The dash and caret, as well as the backslash, can all be -- escaped with a backslash to suppress their special meaning. -- -- NOTE: The '.' (dot) is allowed to be escaped. It has no special meaning -- if it is not escaped, but the default 'filename_toks' in -- Darcs.Commands.Replace uses an escaped dot (WHY?). regChars :: String -> Char -> Bool regChars ('^':cs) = not . normalRegChars (unescapeChars cs) regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs regChars cs = normalRegChars $ unescapeChars cs {-# INLINE unescapeChars #-} -- | 'unescapeChars' unescapes whitespace, which is escaped in the replace -- patch file format. It will also unescape escaped carets, which is useful -- for escaping a leading caret that should not invert the regChars. All -- other escapes are left for the unescaping in 'normalRegChars'. unescapeChars :: String -> String unescapeChars ('\\':'n':cs) = '\n' : unescapeChars cs unescapeChars ('\\':'t':cs) = '\t' : unescapeChars cs unescapeChars ('\\':'^':cs) = '^' : unescapeChars cs unescapeChars (c:cs) = c : unescapeChars cs unescapeChars [] = [] {-# INLINE normalRegChars #-} -- | 'normalRegChars' assembles the filter function. It handles special -- 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 ('\\':'.':cs) = (=='.') ||| normalRegChars cs normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs normalRegChars ('\\':c:_) = error $ "'\\"++[c]++"' not supported." normalRegChars (c1:'-':c2:cs) = ((>= c1) &&& (<= c2)) ||| normalRegChars cs normalRegChars (c:cs) = (== c) ||| normalRegChars cs normalRegChars [] = \_ -> False darcs-2.10.2/src/Darcs/Patch/Set.hs0000644000175000017500000001074112620122474020676 0ustar00guillaumeguillaume00000000000000-- 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, EmptyDataDecls, StandaloneDeriving #-} module Darcs.Patch.Set ( PatchSet(..) , Tagged(..) , SealedPatchSet , Origin , progressPatchSet , tags , emptyPatchSet , appendPSFL , newset2RL , newset2FL ) where import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) import Darcs.Patch.Witnesses.Sealed ( Sealed ) import Darcs.Patch.Witnesses.Ordered ( FL, RL(..), (+<+), reverseFL, reverseRL, mapRL_RL, concatRL, mapRL ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) import Darcs.Util.Progress ( progress ) -- |'Origin' is a type used to represent the initial context of a repo. data Origin type SealedPatchSet p wStart = Sealed ((PatchSet p) wStart) -- |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. data PatchSet p wStart wY where PatchSet :: RL (PatchInfoAnd p) wX wY -> RL (Tagged p) wStart wX -> PatchSet p wStart wY deriving instance Show2 p => Show (PatchSet p wStart wY) instance Show2 p => Show1 (PatchSet p wStart) where showDict1 = ShowDictClass instance Show2 p => Show2 (PatchSet p) where showDict2 = ShowDictClass emptyPatchSet :: PatchSet p wX wX 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 :: PatchInfoAnd p wY wZ -> Maybe String -> RL (PatchInfoAnd p) wX wY -> Tagged p wX wZ deriving instance Show2 p => Show (Tagged p wX wZ) instance Show2 p => Show1 (Tagged p wX) where showDict1 = ShowDictClass instance Show2 p => Show2 (Tagged p) where showDict2 = ShowDictClass -- |'newset2RL' takes a 'PatchSet' and returns an equivalent, linear 'RL' of -- patches. newset2RL :: PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX newset2RL (PatchSet ps ts) = ps +<+ concatRL (mapRL_RL ts2rl ts) where ts2rl :: Tagged p wY wZ -> RL (PatchInfoAnd p) wY wZ ts2rl (Tagged t _ ps2) = t :<: ps2 -- |'newset2FL' takes a 'PatchSet' and returns an equivalent, linear 'FL' of -- patches. newset2FL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX newset2FL = reverseRL . newset2RL -- |'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 ps ts) newps = PatchSet (reverseFL newps +<+ ps) ts -- |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 wStart wX -> PatchSet p wStart wX progressPatchSet k (PatchSet ps ts) = PatchSet (mapRL_RL prog ps) $ mapRL_RL progressTagged ts where prog = progress k progressTagged :: Tagged p wY wZ -> Tagged p wY wZ progressTagged (Tagged t h tps) = Tagged (prog t) h (mapRL_RL prog tps) -- |'tags' returns the PatchInfos corresponding to the tags of a given -- 'PatchSet'. tags :: PatchSet p wStart wX -> [PatchInfo] tags (PatchSet _ ts) = mapRL taggedTagInfo ts where taggedTagInfo :: Tagged p wY wZ -> PatchInfo taggedTagInfo (Tagged t _ _) = info t darcs-2.10.2/src/Darcs/Patch/Apply.hs0000644000175000017500000000715412620122474021234 0ustar00guillaumeguillaume00000000000000-- 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, MultiParamTypeClasses #-} -- | -- Module : Darcs.Patch.Apply -- Copyright : 2002-2005 David Roundy -- License : GPL -- Maintainer : darcs-devel@darcs.net -- Stability : experimental -- Portability : portable module Darcs.Patch.Apply ( Apply(..) , applyToFilePaths , applyToTree , applyToState , applyToFileMods , effectOnFilePaths ) where import Prelude hiding ( catch, pi ) import Data.Set ( Set ) import Control.Applicative ( (<$>) ) import Control.Arrow ( (***) ) import Storage.Hashed.Tree( Tree ) import Storage.Hashed.Monad( virtualTreeMonad ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) ) import Darcs.Util.Path( FileName, fn2fp, fp2fn ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) ) import Darcs.Patch.Index.Monad ( withPatchMods ) import Darcs.Patch.Index.Types ( PatchMod ) class Apply p where type ApplyState p :: (* -> *) -> * apply :: ApplyMonad m (ApplyState p) => p wX wY -> m () instance Apply p => Apply (FL p) where type ApplyState (FL p) = ApplyState p apply NilFL = return () apply (p:>:ps) = apply p >> apply ps 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 wX wY -> [FilePath] -> [FilePath] effectOnFilePaths p fps = fps' where (_, fps', _) = applyToFilePaths p Nothing fps applyToFilePaths :: (Apply p, ApplyState p ~ Tree) => p wX wY -> 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) -- | Apply a patch to a 'Tree', yielding a new 'Tree'. applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree) => p wX wY -> Tree m -> m (Tree m) applyToTree patch t = snd <$> virtualTreeMonad (apply patch) t applyToState :: forall p m wX wY. (Apply p, ApplyMonadTrans m (ApplyState p)) => p wX wY -> (ApplyState p) m -> m ((ApplyState p) m) applyToState patch t = snd <$> runApplyMonad (apply patch) t -------------------------------------------------------------------------------- -- | Apply a patch to set of 'FileName's, yielding the new set of 'FileName's and 'PatchMod's applyToFileMods :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Set FileName -> (Set FileName, [PatchMod FileName]) applyToFileMods patch = withPatchMods (apply patch) darcs-2.10.2/src/Darcs/Patch/FileHunk.hs0000644000175000017500000000153612620122474021652 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..), showFileHunk ) where import Darcs.Util.Path ( FileName ) import Darcs.Patch.Format ( FileNameFormat ) import Darcs.Patch.Show ( formatFileName ) import Darcs.Util.Printer ( Doc, blueText, text, lineColor, vcat, userchunkPS , prefix, ($$), (<+>), Color(Cyan, Magenta) ) import qualified Data.ByteString as B ( ByteString ) data FileHunk wX wY = FileHunk !FileName !Int [B.ByteString] [B.ByteString] class IsHunk p where isHunk :: p wX wY -> Maybe (FileHunk wX wY) showFileHunk :: FileNameFormat -> FileHunk wX wY -> Doc showFileHunk x (FileHunk f line old new) = blueText "hunk" <+> formatFileName x f <+> text (show line) $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old)) $$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS new)) darcs-2.10.2/src/Darcs/Patch/Named.hs0000644000175000017500000002142512620122474021170 0ustar00guillaumeguillaume00000000000000-- 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.Patch.Named ( Named(..), infopatch, adddeps, namepatch, anonymous, getdeps, patch2patchinfo, patchname, patchcontents, fmapNamed, fmapFL_Named, commuterIdNamed, commuterNamedId, mergerIdNamed ) where import Prelude hiding ( pi ) import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterFLId , MergeFn, mergerIdFL ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(effect, effectRL) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, patchinfo, showPatchInfoUI, makePatchname, invertName ) import Darcs.Patch.Merge ( Merge(..) ) import Darcs.Patch.Patchy ( Commute(..), Invert(..), Apply(..), PatchInspect(..), ReadPatch(..) ) import Darcs.Patch.Prim ( PrimOf, PrimPatchBase ) import Darcs.Patch.ReadMonads ( ParserM, option, lexChar, choice, skipWhile, anyChar ) import Darcs.Patch.Rebase.NameHack ( NameHack(..) ) import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL, Check(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), showNamedPrefix ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.Viewing () -- for ShowPatch FL instances import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL, mapFL_FL ) import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal ) import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) ) import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) ) import Darcs.Util.Printer ( ($$), (<+>), (<>), prefix, text, vcat ) import Data.Maybe ( fromMaybe ) -- | The @Named@ type adds a patch info about a patch, that is a name. data Named p wX wY where NamedP :: !PatchInfo -> ![PatchInfo] -> !(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 -- @darcs record --ask-deps@). instance PrimPatchBase p => PrimPatchBase (Named p) where type PrimOf (Named p) = PrimOf p instance Effect p => Effect (Named p) where effect (NamedP _ _ p) = effect p effectRL (NamedP _ _ p) = effectRL p instance IsHunk (Named p) where isHunk _ = Nothing instance PatchListFormat (Named p) instance (ReadPatch p, PatchListFormat p) => ReadPatch (Named p) where readPatch' = readNamed readNamed :: (ReadPatch p, PatchListFormat p, ParserM m) => m (Sealed (Named p wX)) readNamed = do n <- readPatchInfo d <- readDepends p <- readPatch' return $ (NamedP n d) `mapSeal` p readDepends :: ParserM m => m [PatchInfo] readDepends = option [] $ do lexChar '<' readPis readPis :: ParserM m => m [PatchInfo] readPis = choice [ do pi <- readPatchInfo pis <- readPis return (pi:pis) , do skipWhile (/= '>') _ <- anyChar return [] ] instance Apply p => Apply (Named p) where type ApplyState (Named p) = ApplyState p apply (NamedP _ _ p) = apply p instance RepairToFL p => Repair (Named p) where applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p namepatch :: String -> String -> String -> [String] -> FL p wX wY -> IO (Named p wX wY) 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 :: FL p wX wY -> IO (Named p wX wY) anonymous p = namepatch "today" "anonymous" "unknown" ["anonymous"] p infopatch :: PatchInfo -> FL p wX wY -> Named p wX wY infopatch pi p = NamedP pi [] p adddeps :: Named p wX wY -> [PatchInfo] -> Named p wX wY adddeps (NamedP pi _ p) ds = NamedP pi ds p getdeps :: Named p wX wY -> [PatchInfo] getdeps (NamedP _ ds _) = ds patch2patchinfo :: Named p wX wY -> PatchInfo patch2patchinfo (NamedP i _ _) = i patchname :: Named p wX wY -> String patchname (NamedP i _ _) = show $ makePatchname i patchcontents :: Named p wX wY -> FL p wX wY patchcontents (NamedP _ _ p) = p 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 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 Invert p => Invert (Named p) where invert (NamedP n d p) = NamedP (invertName n) (map invertName d) (invert p) instance (Commute p, NameHack p) => Commute (Named p) where commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) = if n2 `elem` d1 || n1 `elem` d2 then Nothing else do (p2' :> p1') <- commute (p1 :> p2) let (informAdd, informDel) = fromMaybe (const id, const id) (nameHack MyersDiff) return (NamedP n2 d2 (informAdd n1 p2') :> NamedP n1 d1 (informDel n2 p1')) 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') 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') instance (Merge p, NameHack 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' 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' 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 Check p => Check (Named p) where isInconsistent (NamedP _ _ p) = isInconsistent 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 instance (Apply p, CommuteNoConflicts p, Conflict p, IsHunk 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 _ _) = showPatchInfoUI 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) instance Show2 p => Show1 (Named p wX) where showDict1 = ShowDictClass instance Show2 p => Show2 (Named p) where showDict2 = ShowDictClass instance PatchDebug p => PatchDebug (Named p) darcs-2.10.2/src/Darcs/Patch/MonadProgress.hs0000644000175000017500000000463112620122474022727 0ustar00guillaumeguillaume00000000000000{-# 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.Patch.MonadProgress ( MonadProgress(..) , ProgressAction(..) , silentlyRunProgressActions ) where import Prelude hiding ( catch ) import Darcs.Util.Printer ( Doc ) import Darcs.Util.Printer.Color () -- for instance Show Doc 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 () -- |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 darcs-2.10.2/src/Darcs/Patch/Read.hs0000644000175000017500000001177012620122474021021 0ustar00guillaumeguillaume00000000000000-- 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.Patch.Read ( ReadPatch(..), readPatch, readPatchPartial, bracketedFL, peekfor, readFileName ) where import Prelude hiding ( pi ) import Darcs.Util.ByteString ( dropSpace ) import qualified Data.ByteString as B (ByteString, null) import Darcs.Patch.Bracketed ( Bracketed(..), unBracketedFL ) import Darcs.Util.Path ( FileName, fp2fn, ps2fn, decodeWhite ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) ) import Darcs.Patch.ReadMonads (ParserM, parseStrictly, choice, lexChar, lexString, checkConsumes ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) import Control.Applicative ( (<$>), (<|>) ) import Control.Monad ( mzero ) import qualified Data.ByteString.Char8 as BC ( ByteString, unpack ) class ReadPatch p where readPatch' :: ParserM m => m (Sealed (p wX)) readPatchPartial :: ReadPatch p => B.ByteString -> Maybe (Sealed (p wX), B.ByteString) readPatchPartial ps = case parseStrictly readPatch' ps of Just (p, ps') -> Just (p, ps') _ -> Nothing readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p wX)) readPatch ps = case readPatchPartial ps of Just (p, ps') | B.null (dropSpace ps') -> Just p _ -> Nothing instance ReadPatch p => ReadPatch (Bracketed p) where readPatch' = mapSeal Braced <$> bracketedFL readPatch' '{' '}' <|> mapSeal Parens <$> bracketedFL readPatch' '(' ')' <|> mapSeal Singleton <$> readPatch' instance (ReadPatch p, PatchListFormat p) => ReadPatch (FL p) where readPatch' | ListFormatV1 <- patchListFormat :: ListFormat p = mapSeal unBracketedFL <$> readPatch' -- in the V2 format case, we only need to support () on reading, not {} -- for simplicity we just go through the same code path. | ListFormatV2 <- patchListFormat :: ListFormat p = mapSeal unBracketedFL <$> readPatch' | otherwise = read_patches where read_patches :: ParserM m => m (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) mp <- (Just <$> checkConsumes readPatch') <|> return Nothing case mp of Just (Sealed p) -> do --tracePeek "found one patch" Sealed ps <- read_patches return $ Sealed (p:>:ps) Nothing -> return $ Sealed NilFL -- tracePeek x = do y <- peekInput -- traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return () instance (ReadPatch p, PatchListFormat p) => ReadPatch (RL p) where readPatch' = mapSeal reverseFL <$> readPatch' {-# INLINE bracketedFL #-} bracketedFL :: forall p m wX . (ParserM m) => (forall wY . m (Sealed (p wY))) -> Char -> Char -> m (Sealed (FL p wX)) bracketedFL parser pre post = peekforc pre bfl mzero where bfl :: forall wZ . m (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 c ifstr ifnot = choice [ lexChar c >> ifstr , ifnot ] peekfor :: ParserM m => BC.ByteString -> m a -> m a -> m 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 darcs-2.10.2/src/Darcs/Patch/Bracketed.hs0000644000175000017500000000331512620122474022026 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Bracketed ( Bracketed(..), mapBracketed, unBracketed , BracketedFL, mapBracketedFLFL, unBracketedFL ) where import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, concatFL ) -- |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 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 wX wY = FL (Bracketed p) wX wY 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 wX wY -> FL p wX wY unBracketedFL = concatFL . mapFL_FL unBracketed 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 (mapBracketedFLFL f ps) mapBracketed f (Parens ps) = Parens (mapBracketedFLFL 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) darcs-2.10.2/src/Darcs/Patch/Inspect.hs0000644000175000017500000000123712620122474021550 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Inspect ( PatchInspect(..) ) where import Darcs.Patch.Witnesses.Ordered ( FL, RL, reverseRL, mapFL ) import qualified Data.ByteString.Char8 as BC import Data.List ( nub ) class PatchInspect p where listTouchedFiles :: p wX wY -> [FilePath] hunkMatches :: (BC.ByteString -> Bool) -> p wX wY -> Bool instance PatchInspect p => PatchInspect (FL p) where listTouchedFiles xs = nub $ concat $ mapFL listTouchedFiles xs hunkMatches f = or . mapFL (hunkMatches f) instance PatchInspect p => PatchInspect (RL p) where listTouchedFiles = listTouchedFiles . reverseRL hunkMatches f = hunkMatches f . reverseRL darcs-2.10.2/src/Darcs/Patch/Rebase.hs0000644000175000017500000006365212620122474021355 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2009 Ganesh Sittampalam -- -- BSD3 {-# LANGUAGE CPP, GADTs, PatternGuards, TypeOperators, NoMonomorphismRestriction, ViewPatterns, UndecidableInstances #-} module Darcs.Patch.Rebase ( Rebasing(..), RebaseItem(..), RebaseName(..), RebaseFixup(..) , simplifyPush, simplifyPushes , mkSuspended , takeHeadRebase, takeHeadRebaseFL, takeHeadRebaseRL , takeAnyRebase, takeAnyRebaseAndTrailingPatches , countToEdit ) where import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat, copyListFormat ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.MaybeInternal ( MaybeInternal(..), InternalChecker(..) ) import Darcs.Patch.Merge ( Merge(..) ) import Darcs.Patch.Named ( Named(..), patchcontents, namepatch , commuterIdNamed ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..), ShowPatch(..), ReadPatch(..), PatchInspect(..) ) import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL ) import Darcs.Patch.Read ( bracketedFL ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) import Darcs.Patch.Rebase.Name ( RebaseName(..) , commutePrimName, commuteNamePrim ) import Darcs.Patch.Rebase.NameHack ( NameHack(..) ) import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..), RecontextRebase1(..), RecontextRebase2(..) ) import Darcs.Patch.Repair ( Check(..), RepairToFL(..) ) import Darcs.Patch.Set ( PatchSet(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Patch.ReadMonads ( ParserM, lexString, myLex' ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), showsPrec2 , ShowDict(ShowDictClass), appPrec ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) import Darcs.Util.IsoDate ( getIsoDateTime ) import Darcs.Util.Text ( formatParas ) import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) ) import Prelude hiding ( pi ) import Control.Applicative ( (<$>), (<|>) ) import Control.Arrow ( (***), second ) import Control.Monad ( when ) import Data.Maybe ( catMaybes ) import qualified Data.ByteString as B ( ByteString ) import qualified Data.ByteString.Char8 as BC ( pack ) #include "impossible.h" {- Notes Note [Rebase representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The entire rebase state is stored in a single Suspended patch. This is both unnatural and inefficient: - Unnatural because the rebase state is not really a patch and treating it as one requires various hacks: - It has to be given a fake name: see mkSuspended - Since 'Named p' actually contains 'FL p', we have to assume/assert that the FL either contains a sequence of Normals or a single Suspended - When 'Named ps' commutes past 'Named (Suspended items :> NilFL)', we need to inject the name from 'Named ps' into 'items', which is a layering violation: see Darcs.Patch.Rebase.NameHack - We need to hide the patch in the UI: see Darcs.Patch.MaybeInternal - We need a conditional hook so that amend-record can change the Suspended patch itself: see Darcs.Patch.Rebase.Recontext (something like this might be necessary no matter what the representation) - Inefficient because we need to write the entire rebase state out each time, even though most operations will only affect a small portion near the beginning. - This also means that we need to commute the rebase patch back to the head of the repo lazily: we only do so when a rebase operation requires it. Otherwise, pulling in 100 patches would entail writing out the entire rebase patch to disk 100 times. The obvious alternative is to store the rebase state at the repository level, using inventories in some appropriate way. The main reason this wasn't done is that the repository handling code is quite fragile and hard to modify safely. Also, rebase relies heavily on witnesses to check correctness, and the witnesses on the Repository type are not as reliable as those on patch types, partly because of the cruft in the repository code, and partly because it's inherently harder to track witnesses when the objects being manipulated are stored on disk and being changed imperatively. If and when the repository code becomes easier to work with, rebase should be changed accordingly. -} -- TODO: move some of the docs of types to individual constructors -- once http://trac.haskell.org/haddock/ticket/43 is fixed. -- |A patch that lives in a repository where a rebase is in -- progress. Such a repository will consist of @Normal@ patches -- along with exactly one @Suspended@ patch. -- -- Most rebase operations will require the @Suspended@ patch -- to be at the end of the repository. -- -- @Normal@ represents a normal patch within a respository where a -- rebase is in progress. @Normal 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 -- @Suspended@ patch and setting the appropriate format flag. -- -- The single @Suspended@ patch contains the entire rebase -- state, in the form of 'RebaseItem's. -- -- Note that the witnesses are such that the @Suspended@ -- 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. -- -- See Note [Rebase representation] in the source for a discussion -- of the design choice to embed the rebase state in a single patch. data Rebasing p wX wY where Normal :: p wX wY -> Rebasing p wX wY Suspended :: FL (RebaseItem p) wX wY -> Rebasing p wX wX instance (Show2 p, Show2 (PrimOf p)) => Show (Rebasing p wX wY) where showsPrec d (Normal p) = showParen (d > appPrec) $ showString "Darcs.Patch.Rebase.Normal " . showsPrec2 (appPrec + 1) p showsPrec d (Suspended p) = showParen (d > appPrec) $ showString "Darcs.Patch.Rebase.Suspended " . showsPrec2 (appPrec + 1) p instance (Show2 p, Show2 (PrimOf p)) => Show1 (Rebasing p wX) where showDict1 = ShowDictClass instance (Show2 p, Show2 (PrimOf p)) => Show2 (Rebasing p) where showDict2 = ShowDictClass -- |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 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 p wX wY -> RebaseItem p wX wY instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY) where showsPrec d (ToEdit p) = showParen (d > appPrec) $ showString "ToEdit " . showsPrec2 (appPrec + 1) p showsPrec d (Fixup p) = showParen (d > appPrec) $ showString "Fixup " . showsPrec2 (appPrec + 1) p instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX) where showDict1 = ShowDictClass instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p) where showDict2 = ShowDictClass countToEdit :: FL (RebaseItem p) wX wY -> Int countToEdit NilFL = 0 countToEdit (ToEdit _ :>: ps) = 1 + countToEdit ps countToEdit (_ :>: ps) = countToEdit ps commuterRebasing :: (PrimPatchBase p, Commute p, Invert p, FromPrim p, Effect p) => D.DiffAlgorithm -> CommuteFn p p -> CommuteFn (Rebasing p) (Rebasing p) commuterRebasing _ commuter (Normal p :> Normal q) = do q' :> p' <- commuter (p :> q) return (Normal q' :> Normal p') -- Two rebases in sequence must have the same starting context, -- so they should trivially commute. -- This case shouldn't actually happen since each repo only has -- a single Suspended patch. commuterRebasing _ _ (p@(Suspended _) :> q@(Suspended _)) = return (q :> p) commuterRebasing da _ (Normal p :> Suspended qs) = return (unseal Suspended (addFixup da p qs) :> Normal p) commuterRebasing da _ (Suspended ps :> Normal q) = return (Normal q :> unseal Suspended (addFixup da (invert q) ps)) instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p) => Commute (Rebasing p) where commute = commuterRebasing D.MyersDiff commute instance (PrimPatchBase p, FromPrim p, Effect p, Commute p) => NameHack (Rebasing p) where nameHack da = Just (pushIn . AddName, pushIn . DelName) where pushIn :: RebaseName p wX wX -> FL (Rebasing p) wX wY -> FL (Rebasing p) wX wY pushIn n (Suspended ps :>: NilFL) = unseal (\qs -> Suspended qs :>: NilFL) (simplifyPush da (NameFixup n) ps) pushIn _ ps = ps instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p, CommuteNoConflicts p) => CommuteNoConflicts (Rebasing p) where commuteNoConflicts = commuterRebasing D.MyersDiff commuteNoConflicts instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Merge p) => Merge (Rebasing p) where merge (Normal p :\/: Normal q) = case merge (p :\/: q) of q' :/\: p' -> Normal q' :/\: Normal p' merge (p@(Suspended _) :\/: q@(Suspended _)) = q :/\: p merge (Normal p :\/: Suspended qs) = unseal Suspended (addFixup D.MyersDiff (invert p) qs) :/\: Normal p merge (Suspended ps :\/: Normal q) = Normal q :/\: unseal Suspended (addFixup D.MyersDiff (invert q) ps) instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Rebasing p) where listTouchedFiles (Normal p) = listTouchedFiles p listTouchedFiles (Suspended ps) = concat $ mapFL ltfItem ps where ltfItem :: RebaseItem p wX wY -> [FilePath] ltfItem (ToEdit q) = listTouchedFiles q ltfItem (Fixup (PrimFixup q)) = listTouchedFiles q ltfItem (Fixup (NameFixup _)) = [] hunkMatches f (Normal p) = hunkMatches f p hunkMatches f (Suspended ps) = or $ mapFL hmItem ps where hmItem :: RebaseItem p wA wB -> Bool hmItem (ToEdit q) = hunkMatches f q hmItem (Fixup (PrimFixup q)) = hunkMatches f q hmItem (Fixup (NameFixup _)) = False instance Invert p => Invert (Rebasing p) where invert (Normal p) = Normal (invert p) invert (Suspended ps) = Suspended ps -- TODO is this sensible? instance Effect p => Effect (Rebasing p) where effect (Normal p) = effect p effect (Suspended _) = NilFL instance (PrimPatchBase p, PatchListFormat p, Patchy p, FromPrim p, Conflict p, Effect p, CommuteNoConflicts p, IsHunk p) => Patchy (Rebasing p) instance PatchDebug p => PatchDebug (Rebasing p) instance ( PrimPatchBase p, PatchListFormat p, Patchy p , FromPrim p, Conflict p, Effect p , PatchInspect p , CommuteNoConflicts p, IsHunk p ) => Matchable (Rebasing p) instance (Conflict p, FromPrim p, Effect p, Invert p, Commute p) => Conflict (Rebasing p) where resolveConflicts (Normal p) = resolveConflicts p resolveConflicts (Suspended _) = [] instance Apply p => Apply (Rebasing p) where type ApplyState (Rebasing p) = ApplyState p apply (Normal p) = apply p apply (Suspended _) = return () instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Rebasing p) where showPatch (Normal p) = showPatch p showPatch (Suspended ps) = blueText "rebase" <+> text "0.0" <+> blueText "{" $$ vcat (mapFL showPatch ps) $$ blueText "}" instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (Rebasing p) where summary (Normal p) = summary p summary (Suspended ps) = summaryFL ps summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where showPatch (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch p $$ blueText ")" showPatch (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch p $$ blueText ")" showPatch (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch p $$ blueText ")" instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (RebaseItem p) where summary (ToEdit p) = summary p summary (Fixup (PrimFixup p)) = summary p summary (Fixup (NameFixup n)) = summary n summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts 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 m q wX . (ParserM m, ReadPatch q) => B.ByteString -> m (Sealed (q wX)) readWith str = do lexString str lexString (BC.pack "(") res <- readPatch' lexString (BC.pack ")") return res instance PrimPatchBase p => PrimPatchBase (Rebasing p) where type PrimOf (Rebasing p) = PrimOf p instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Rebasing p) where readPatch' = do lexString (BC.pack "rebase") version <- myLex' when (version /= BC.pack "0.0") $ error $ "can't handle rebase version " ++ show version (lexString (BC.pack "{}") >> return (seal (Suspended NilFL))) <|> (unseal (Sealed . Suspended) <$> bracketedFL readPatch' '{' '}') <|> mapSeal Normal <$> readPatch' instance IsHunk p => IsHunk (Rebasing p) where isHunk (Normal p) = isHunk p isHunk (Suspended _) = Nothing instance FromPrim p => FromPrim (Rebasing p) where fromPrim p = Normal (fromPrim p) instance Check p => Check (Rebasing p) where isInconsistent (Normal p) = isInconsistent p isInconsistent (Suspended ps) = case catMaybes (mapFL isInconsistent ps) of [] -> Nothing xs -> Just (vcat xs) instance Check p => Check (RebaseItem p) where isInconsistent (Fixup _) = Nothing isInconsistent (ToEdit p) = isInconsistent p instance RepairToFL p => RepairToFL (Rebasing p) where applyAndTryToFixFL (Normal p) = fmap (second $ mapFL_FL Normal) <$> applyAndTryToFixFL p -- TODO: ideally we would apply ps in a sandbox to check the individual patches -- are consistent with each other. applyAndTryToFixFL (Suspended ps) = return . fmap (unlines *** ((:>: NilFL) . Suspended)) $ repairInternal ps -- Just repair the internals of the patch, without applying it to anything -- or checking against an external context. -- Included for the internal implementation of applyAndTryToFixFL for Rebasing, -- consider either generalising it for use everywhere, or removing once -- the implementation works in a sandbox and thus can use the "full" Repair on the -- contained patches. class RepairInternalFL p where repairInternalFL :: p wX wY -> Maybe ([String], FL p wX wY) class RepairInternal p where repairInternal :: p wX wY -> Maybe ([String], p wX wY) instance RepairInternalFL p => RepairInternal (FL p) where repairInternal NilFL = Nothing repairInternal (x :>: ys) = case (repairInternalFL x, repairInternal ys) of (Nothing , Nothing) -> Nothing (Just (e, rxs), Nothing) -> Just (e , rxs +>+ ys ) (Nothing , Just (e', rys)) -> Just (e' , x :>: rys) (Just (e, rxs), Just (e', rys)) -> Just (e ++ e', rxs +>+ rys) instance RepairInternalFL (RebaseItem p) where repairInternalFL (ToEdit _) = Nothing repairInternalFL (Fixup p) = fmap (second $ mapFL_FL Fixup) $ repairInternalFL p instance RepairInternalFL (RebaseFixup p) where repairInternalFL (PrimFixup _) = Nothing repairInternalFL (NameFixup _) = Nothing instance PatchListFormat p => PatchListFormat (Rebasing p) where patchListFormat = copyListFormat (patchListFormat :: ListFormat p) instance RepoPatch p => RepoPatch (Rebasing p) instance (Commute p, PrimPatchBase p, FromPrim p, Effect p) => RecontextRebase (Rebasing p) where recontextRebase = Just (RecontextRebase1 recontext) where recontext :: forall wY wZ . Named (Rebasing p) wY wZ -> (EqCheck wY wZ, RecontextRebase2 (Rebasing p) wY wZ) recontext (patchcontents -> (Suspended ps :>: NilFL)) = (IsEq, RecontextRebase2 (\fixups -> unseal mkSuspended(simplifyPushes D.MyersDiff (mapFL_FL translateFixup fixups) ps))) recontext _ = (NotEq, bug "trying to recontext rebase without rebase patch at head") translateFixup :: RebaseFixup (Rebasing p) wX wY -> RebaseFixup p wX wY translateFixup (PrimFixup p) = PrimFixup p translateFixup (NameFixup n) = NameFixup (translateName n) translateName :: RebaseName (Rebasing p) wX wY -> RebaseName p wX wY translateName (AddName name) = AddName name translateName (DelName name) = DelName name translateName (Rename old new) = Rename old new instance MaybeInternal (Rebasing p) where patchInternalChecker = Just (InternalChecker rebaseIsInternal) where rebaseIsInternal :: FL (Rebasing p) wX wY -> EqCheck wX wY rebaseIsInternal (Suspended _ :>: NilFL) = IsEq rebaseIsInternal _ = NotEq addFixup :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) => D.DiffAlgorithm -> p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) addFixup da p = simplifyPushes da (mapFL_FL PrimFixup (effect p)) canonizeNamePair :: (RebaseName p :> RebaseName p) wX wY -> FL (RebaseName p) 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 -- |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 :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) => D.DiffAlgorithm -> RebaseFixup p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) simplifyPush _ _f NilFL = Sealed NilFL simplifyPush da (PrimFixup f1) (Fixup (PrimFixup f2) :>: ps) | IsEq <- isInverse = Sealed ps | otherwise = case commute (f1 :> f2) of Nothing -> Sealed (mapFL_FL (Fixup . PrimFixup) (canonizeFL da (f1 :>: f2 :>: NilFL)) +>+ ps) Just (f2' :> f1') -> mapSeal (Fixup (PrimFixup f2') :>:) (simplifyPush da (PrimFixup f1') ps) where isInverse = invert f1 =\/= f2 simplifyPush da (PrimFixup f) (Fixup (NameFixup n) :>: ps) = case commutePrimName (f :> n) of n' :> f' -> mapSeal (Fixup (NameFixup n') :>:) (simplifyPush da (PrimFixup f') ps) simplifyPush da (PrimFixup f) (ToEdit e :>: ps) = case commuterIdNamed selfCommuter (fromPrim f :> e) of Nothing -> Sealed (Fixup (PrimFixup f) :>: ToEdit e :>: ps) Just (e' :> f') -> mapSeal (ToEdit e' :>:) (simplifyPushes da (mapFL_FL PrimFixup (effect f')) ps) simplifyPush da (NameFixup n1) (Fixup (NameFixup n2) :>: ps) | IsEq <- isInverse = Sealed ps | otherwise = case commute (n1 :> n2) of Nothing -> Sealed (mapFL_FL (Fixup . NameFixup) (canonizeNamePair (n1 :> n2)) +>+ ps) Just (n2' :> n1') -> mapSeal (Fixup (NameFixup n2') :>:) (simplifyPush da (NameFixup n1') ps) where isInverse = invert n1 =\/= n2 simplifyPush da (NameFixup n) (Fixup (PrimFixup f) :>: ps) = case commuteNamePrim (n :> f) of f' :> n' -> mapSeal (Fixup (PrimFixup f') :>:) (simplifyPush da (NameFixup n') ps) simplifyPush da (NameFixup (AddName an)) (p@(ToEdit (NamedP pn deps _)) :>: ps) | an == pn = impossible | an `elem` deps = Sealed (Fixup (NameFixup (AddName an)) :>: p :>: ps) | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (AddName an)) ps) simplifyPush da (NameFixup (DelName dn)) (p@(ToEdit (NamedP pn deps _)) :>: ps) -- this case can arise if a patch is suspended then a fresh copy is pulled from another repo | dn == pn = Sealed (Fixup (NameFixup (DelName dn)) :>: p :>: ps) | dn `elem` deps = impossible | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (DelName dn)) ps) simplifyPush da (NameFixup (Rename old new)) (p@(ToEdit (NamedP pn deps body)) :>: ps) | old == pn = impossible | new == pn = impossible | old `elem` deps = impossible | new `elem` deps = let newdeps = map (\dep -> if new == dep then old else dep) deps in mapSeal (ToEdit (NamedP pn newdeps (unsafeCoerceP body)) :>:) (simplifyPush da (NameFixup (Rename old new)) ps) | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (Rename old new)) ps) -- |Like 'simplifyPush' but for a list of fixups. simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) => D.DiffAlgorithm -> FL (RebaseFixup p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) simplifyPushes _ NilFL ps = Sealed ps simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps) mkSuspended :: FL (RebaseItem p) wX wY -> IO (Named (Rebasing p) wX wX) mkSuspended ps = do let name = "DO NOT TOUCH: Rebase patch" let desc = formatParas 72 ["This patch is an internal implementation detail of rebase, used to store suspended patches, " ++ "and should not be visible in the user interface. Please report a bug if a darcs " ++ "command is showing you this patch."] date <- getIsoDateTime let author = "Invalid " namepatch date name author desc (Suspended ps :>: NilFL) -- |given the repository contents, get the rebase container patch, and its contents -- The rebase patch can be anywhere in the repository and is returned without being -- commuted to the end. takeAnyRebase :: PatchSet (Rebasing p) wA wB -> (Sealed2 (PatchInfoAnd (Rebasing p)), Sealed2 (FL (RebaseItem p))) takeAnyRebase (PatchSet NilRL _) = -- it should never be behind a tag so we can stop now error "internal error: no suspended patch found" takeAnyRebase (PatchSet (p :<: ps) pss) | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (Sealed2 p, Sealed2 rs) | otherwise = takeAnyRebase (PatchSet ps pss) -- |given the repository contents, get the rebase container patch, its contents, and the -- rest of the repository contents. Commutes the patch to the end of the repository -- if necessary. The rebase patch must be at the head of the repository. takeAnyRebaseAndTrailingPatches :: PatchSet (Rebasing p) wA wB -> FlippedSeal (PatchInfoAnd (Rebasing p) :> RL (PatchInfoAnd (Rebasing p))) wB takeAnyRebaseAndTrailingPatches (PatchSet NilRL _) = -- it should never be behind a tag so we can stop now error "internal error: no suspended patch found" takeAnyRebaseAndTrailingPatches (PatchSet (p :<: ps) pss) | Suspended _ :>: NilFL <- patchcontents (hopefully p) = FlippedSeal (p :> NilRL) | otherwise = case takeAnyRebaseAndTrailingPatches (PatchSet ps pss) of FlippedSeal (r :> ps') -> FlippedSeal (r :> (p :<: ps')) -- |given the repository contents, get the rebase container patch, its contents, and the -- rest of the repository contents. The rebase patch must be at the head of the repository. takeHeadRebase :: PatchSet (Rebasing p) wA wB -> (PatchInfoAnd (Rebasing p) wB wB, Sealed (FL (RebaseItem p) wB), PatchSet (Rebasing p) wA wB) takeHeadRebase (PatchSet NilRL _) = error "internal error: must have a rebase container patch at end of repository" takeHeadRebase (PatchSet (p :<: ps) pss) | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (p, Sealed rs, PatchSet ps pss) | otherwise = error "internal error: must have a rebase container patch at end of repository" takeHeadRebaseRL :: RL (PatchInfoAnd (Rebasing p)) wA wB -> (PatchInfoAnd (Rebasing p) wB wB, Sealed (FL (RebaseItem p) wB), RL (PatchInfoAnd (Rebasing p)) wA wB) takeHeadRebaseRL NilRL = error "internal error: must have a suspended patch at end of repository" takeHeadRebaseRL (p :<: ps) | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (p, Sealed rs, ps) | otherwise = error "internal error: must have a suspended patch at end of repository" takeHeadRebaseFL :: FL (PatchInfoAnd (Rebasing p)) wA wB -> (PatchInfoAnd (Rebasing p) wB wB, Sealed (FL (RebaseItem p) wB), FL (PatchInfoAnd (Rebasing p)) wA wB) takeHeadRebaseFL ps = let (a, b, c) = takeHeadRebaseRL (reverseFL ps) in (a, b, reverseRL c) darcs-2.10.2/src/Darcs/Patch/PatchInfoAnd.hs0000644000175000017500000002567312620122474022453 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2006 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.Patch.PatchInfoAnd ( Hopefully(..), SimpleHopefully(..), PatchInfoAnd(..), WPatchInfo, unWPatchInfo, compareWPatchInfo, piap, n2pia, patchInfoAndPatch, fmapPIAP, fmapFLPIAP, conscientiously, hopefully, info, winfo, hopefullyM, createHashed, extractHash, actually, unavailable, patchDesc ) where import System.IO.Unsafe ( unsafeInterleaveIO ) import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.Printer ( Doc, renderString, errorDoc, text, ($$), vcat , RenderMode(..) ) import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI, justName ) import Darcs.Patch ( Named, patch2patchinfo ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) 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.Rebase.NameHack ( NameHack ) import Darcs.Patch.Repair ( Repair(..), RepairToFL ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) import Darcs.Util.Exception ( prettyException ) import Storage.Hashed.Tree( Tree ) import Control.Applicative ( (<$>) ) -- | @'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 -- witness for the patch that should be there. The @Hopefully@ type -- just tells whether we expect the patch to be hashed or not, and -- '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 wX wY = Hopefully (SimpleHopefully a wX wY) | Hashed String (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 wX wY = Actually (a wX wY) | Unavailable String deriving Show -- | @'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 wA wB = PIAP !PatchInfo (Hopefully (Named p) wA wB) deriving Show instance Show2 p => Show1 (PatchInfoAnd p wX) where showDict1 = ShowDictClass instance Show2 p => Show2 (PatchInfoAnd p) where showDict2 = ShowDictClass instance PrimPatchBase p => PrimPatchBase (PatchInfoAnd p) where type PrimOf (PatchInfoAnd p) = PrimOf p -- | @'WPatchInfo' wA wB@ represents the info of a patch, marked with -- the patch's witnesses. newtype WPatchInfo wA wB = 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 wA wB -> WPatchInfo wC wD -> EqCheck (wA, wB) (wC, wD) compareWPatchInfo (WPatchInfo x) (WPatchInfo y) = if x == y then unsafeCoerceP IsEq else NotEq instance MyEq WPatchInfo where WPatchInfo x `unsafeCompare` WPatchInfo y = x == y 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) where ff (Actually a) = Actually (f a) ff (Unavailable e) = Unavailable e info :: PatchInfoAnd p wA wB -> PatchInfo info (PIAP i _) = i patchDesc :: forall p wX wY . PatchInfoAnd p wX wY -> String patchDesc p = justName $ info p winfo :: PatchInfoAnd p wA wB -> WPatchInfo wA wB winfo (PIAP i _) = WPatchInfo i -- | @'piap' i p@ creates a PatchInfoAnd containing p with info i. piap :: PatchInfo -> Named p wA wB -> PatchInfoAnd p wA wB piap i p = PIAP i (Hopefully $ Actually p) -- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch. n2pia :: Named p wX wY -> PatchInfoAnd p wX wY n2pia x = patch2patchinfo x `piap` x patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) wA wB -> PatchInfoAnd p wA wB patchInfoAndPatch = PIAP fmapPIAP :: (forall wA wB . p wA wB -> q wA wB) -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY 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) -- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd' -- value. If it fails, it outputs an error \"failed to read patch: -- \\". We get the description of the patch -- from the info part of 'hp' hopefully :: PatchInfoAnd p wA wB -> Named p wA wB hopefully = conscientiously $ \e -> text "failed to read patch:" $$ 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@. conscientiously :: (Doc -> Doc) -> PatchInfoAnd p wA wB -> Named p wA wB conscientiously er (PIAP pinf hp) = case hopefully2either hp of Right p -> p Left e -> errorDoc $ er (showPatchInfoUI pinf $$ text e) -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a -- monad instead of erroring. hopefullyM :: Monad m => PatchInfoAnd p wA wB -> m (Named p wA wB) hopefullyM (PIAP pinf hp) = case hopefully2either hp of Right p -> return p Left e -> fail $ renderString Encode (showPatchInfoUI pinf $$ text e) -- Any recommendations for a nice adverb to name the below? 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 wX wY -> Hopefully a wX wY actually = Hopefully . Actually createHashed :: String -> (String -> 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 wA wB -> Either (Named p wA wB) String extractHash (PIAP _ (Hashed s _)) = Right s extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp unavailable :: String -> Hopefully a wX wY unavailable = Hopefully . Unavailable -- Equality on PatchInfoAnd is solely determined by the PatchInfo -- It is a global invariant of darcs that once a patch is recorded, -- it should always have the same representation in the same context. instance MyEq (PatchInfoAnd p) where unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2 instance Invert p => Invert (PatchInfoAnd p) where invert (PIAP i p) = PIAP i (invert `fmapH` p) instance PatchListFormat (PatchInfoAnd p) instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (PatchInfoAnd p) where showPatch (PIAP n p) = case hopefully2either p of Right x -> showPatch x Left _ -> showPatchInfoUI n 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 $ showPatchInfoUI n description (PIAP n _) = showPatchInfoUI n summary (PIAP n p) = case hopefully2either p of Right x -> summary x Left _ -> showPatchInfoUI n summaryFL = vcat . mapFL summary showNicely (PIAP n p) = case hopefully2either p of Right x -> showNicely x Left _ -> showPatchInfoUI n instance (Commute p, NameHack p) => Commute (PatchInfoAnd p) where commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y) return $ (info y `piap` y') :> (info x `piap` x') instance (Merge p, NameHack 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 PatchInspect p => PatchInspect (PatchInfoAnd p) where listTouchedFiles = listTouchedFiles . hopefully hunkMatches _ _ = error "hunkmatches not implemented for PatchInfoAnd" instance Apply p => Apply (PatchInfoAnd p) where type ApplyState (PatchInfoAnd p) = ApplyState p apply p = apply $ hopefully p 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 (ReadPatch p, PatchListFormat p) => ReadPatch (PatchInfoAnd p) where readPatch' = mapSeal n2pia <$> readPatch' instance Effect p => Effect (PatchInfoAnd p) where effect = effect . hopefully effectRL = effectRL . hopefully instance IsHunk (PatchInfoAnd p) where isHunk _ = Nothing instance PatchDebug p => PatchDebug (PatchInfoAnd p) instance (Patchy p, NameHack p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd p) darcs-2.10.2/src/Darcs/Patch/Bracketed/0000755000175000017500000000000012620122474021470 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Bracketed/Instances.hs0000644000175000017500000000146512620122474023761 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Bracketed.Instances () where import Darcs.Patch.Bracketed ( Bracketed(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(NilFL), mapFL ) import Darcs.Util.Printer ( vcat, blueText, ($$) ) 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. darcs-2.10.2/src/Darcs/Patch/V1/0000755000175000017500000000000012620122474020072 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/V1/Show.hs0000644000175000017500000000151412620122474021347 0ustar00guillaumeguillaume00000000000000{-# 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.Patch.V1.Core ( Patch(..) ) import Darcs.Util.Printer ( Doc, text, blueText, ($$), (<+>) ) showPatch_ :: PrimPatch prim => Patch prim wA wB -> Doc showPatch_ (PP p) = showPrim OldFormat p showPatch_ (Merger _ _ p1 p2) = showMerger "merger" p1 p2 showPatch_ (Regrem _ _ p1 p2) = showMerger "regrem" p1 p2 showMerger :: PrimPatch prim => String -> Patch prim wA wB -> Patch prim wD wE -> Doc showMerger merger_name p1 p2 = blueText merger_name <+> text "0.0" <+> blueText "(" $$ showPatch_ p1 $$ showPatch_ p2 $$ blueText ")" darcs-2.10.2/src/Darcs/Patch/V1/Apply.hs0000644000175000017500000000142212620122474021512 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Apply () where 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.Witnesses.Ordered ( mapFL_FL ) instance PrimPatch prim => Apply (Patch prim) where type ApplyState (Patch prim) = ApplyState prim apply p = applyPrimFL $ effect p instance PrimPatch prim => RepairToFL (Patch prim) where applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x applyAndTryToFixFL x = do apply x; return Nothing darcs-2.10.2/src/Darcs/Patch/V1/Read.hs0000644000175000017500000000272612620122474021310 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Read () where 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.Patch.V1.Core ( Patch(..) ) import Darcs.Patch.V1.Commute ( merger ) 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 ) instance PrimPatch prim => ReadPatch (Patch prim) where readPatch' = choice [ liftM seal $ skipSpace >> readMerger True , liftM seal $ skipSpace >> readMerger False , liftM (mapSeal PP) readPatch' ] readMerger :: (ParserM m, PrimPatch prim) => Bool -> m (Patch prim wX wY) readMerger b = do string s g <- myLex' lexChar '(' Sealed p1 <- readPatch' Sealed p2 <- readPatch' lexChar ')' Sealed m <- return $ merger (BC.unpack g) p1 p2 return $ if b then unsafeCoerceP m else unsafeCoerceP (invert m) where s | b = merger' | otherwise = regrem merger' :: B.ByteString merger' = BC.pack "merger" regrem :: B.ByteString regrem = BC.pack "regrem" darcs-2.10.2/src/Darcs/Patch/V1/Viewing.hs0000644000175000017500000000122312620122474022034 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Viewing () where import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.V1.Apply () import Darcs.Patch.V1.Core ( Patch(..) ) import Darcs.Patch.V1.Show ( showPatch_ ) instance PrimPatch prim => ShowPatchBasic (Patch prim) where showPatch = showPatch_ instance PrimPatch prim => ShowPatch (Patch prim) where showContextPatch (PP p) = showContextPatch p showContextPatch p = return $ showPatch p summary = plainSummary summaryFL = plainSummary thing _ = "change" darcs-2.10.2/src/Darcs/Patch/V1/Core.hs0000644000175000017500000000656012620122474021325 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.Patch.V1.Core ( Patch(..), isMerger, mergerUndo ) where import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(ListFormatV1) ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Prim ( FromPrim(..), PrimOf, PrimPatchBase, PrimPatch ) import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( Check ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..) , ShowDict(ShowDictClass) , appPrec, showsPrec2 ) #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@. @undos@ = the effect of the merger @unwindings@ = TODO: eh? @conflicting@ = the patch we conflict with @original@ = the patch we really are -} data Patch prim wX wY where PP :: prim wX wY -> Patch prim wX wY Merger :: FL (Patch prim) wX wY -> RL (Patch prim) wX wB -> Patch prim wC wB -> Patch prim wC wD -> Patch prim wX wY Regrem :: FL (Patch prim) wX wY -> RL (Patch prim) wX wB -> Patch prim wC wB -> Patch prim wC wA -> Patch prim wY wX instance Show2 prim => Show (Patch 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 (Patch prim wX) where showDict1 = ShowDictClass instance Show2 prim => Show2 (Patch prim) where showDict2 = ShowDictClass instance MaybeInternal (Patch prim) instance NameHack (Patch prim) instance RecontextRebase (Patch prim) instance PrimPatch prim => PrimPatchBase (Patch prim) where type PrimOf (Patch prim) = prim instance FromPrim (Patch prim) where fromPrim = PP isMerger :: Patch prim wA wB -> Bool isMerger (Merger{}) = True isMerger (Regrem{}) = True isMerger _ = False mergerUndo :: Patch prim wX wY -> FL (Patch prim) wX wY mergerUndo (Merger undo _ _ _) = undo mergerUndo _ = impossible instance PatchListFormat (Patch 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) -- no checks instance PatchDebug prim => PatchDebug (Patch prim) darcs-2.10.2/src/Darcs/Patch/V1/Commute.hs0000644000175000017500000005102312620122474022040 0ustar00guillaumeguillaume00000000000000-- 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. {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} {-# LANGUAGE CPP #-} module Darcs.Patch.V1.Commute ( merge, merger, unravel, publicUnravel, ) where import Control.Monad ( MonadPlus, mplus, msum, mzero, guard ) import Control.Applicative ( Applicative(..), Alternative(..) ) import Data.Maybe ( isJust ) import Darcs.Patch.Commute ( toFwdCommute, selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdFL, commuterFLId ) import Darcs.Patch.ConflictMarking ( mangleUnravelled ) import Darcs.Util.Path ( FileName ) import Darcs.Patch.Invert ( invertRL ) import Darcs.Patch.Merge ( Merge(..) ) import Darcs.Patch.Patchy ( Commute(..), PatchInspect(..), Invert(..) ) import Darcs.Patch.V1.Core ( Patch(..), isMerger, mergerUndo ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) 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 ) import Darcs.Util.Printer ( text, vcat, ($$) ) import Darcs.Patch.V1.Show ( showPatch_ ) import Data.List ( nub, nubBy ) import Data.List.Ordered ( nubSort ) #include "impossible.h" import Darcs.Patch.Witnesses.Sealed ( Sealed(..) , mapSeal, unseal, FlippedSeal(..), mapFlipped , unsafeUnseal, unsafeUnsealFlipped ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..), MyEq(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart , unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Ordered ( mapFL_FL, 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 return = Succeeded fail _ = Unknown instance Alternative Perhaps where empty = Unknown Unknown <|> ys = ys Failed <|> _ = Failed (Succeeded x) <|> _ = Succeeded x instance MonadPlus Perhaps where 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' 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: Succeeded x Failed -> Failed Unknown -> case c (invert p2 :< invert p1) of Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1') Failed -> Failed Unknown -> Unknown -- | If we have two Filepatches which modify different files, we can return a -- result early, since the patches trivially commute. speedyCommute :: PrimPatch prim => CommuteFunction prim speedyCommute (p1 :< p2) | isJust p1_modifies && isJust p2_modifies && p1_modifies /= p2_modifies = Succeeded (unsafeCoerceP p2 :< unsafeCoerceP p1) | otherwise = Unknown where p1_modifies = isFilepatchMerger p1 p2_modifies = isFilepatchMerger p2 everythingElseCommute :: forall prim . PrimPatch prim => CommuteFunction prim everythingElseCommute (PP px :< PP py) = toPerhaps $ do x' :> y' <- commute (py :> px) return (PP y' :< PP x') everythingElseCommute _xx = msum [ cleverCommute commuteRecursiveMerger _xx ,cleverCommute otherCommuteRecursiveMerger _xx ] {- Note that it must be true that commutex (A^-1 A, P) = Just (P, A'^-1 A') and if commutex (A, B) == Just (B', A') then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1) -} unsafeMerger :: PrimPatch prim => String -> Patch prim wX wY -> Patch prim wX wZ -> Patch prim wA wB unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2 -- | Attempt to commute two patches, the first of which is a Merger patch. mergerCommute :: PrimPatch prim => (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) mergerCommute (Merger _ _ p1 p2 :< pA) | unsafeCompare pA p1 = Succeeded (unsafeMerger "0.0" p2 p1 :< unsafeCoercePStart p2) | unsafeCompare pA (invert (unsafeMerger "0.0" p2 p1)) = Failed mergerCommute (Merger _ _ (Merger _ _ c b) (Merger _ _ c' a) :< Merger _ _ b' c'') | 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)) mergerCommute _ = Unknown instance PrimPatch prim => Merge (Patch prim) where merge (y :\/: z) = case actualMerge (y:\/:z) of -- actualMerge returns one "arm" of a merge result (@y'@, which applies -- "after" @z@), but we need to return both arms. We therefore commute -- @z@ and @y'@, to obtain a @z'@, which applies "after" @y'' == y@. Sealed y' -> case commute (z :> y') of Nothing -> bugDoc $ text "merge_patches bug" $$ showPatch_ y $$ showPatch_ z $$ showPatch_ y' Just (_ :> z') -> unsafeCoercePStart z' :/\: y' instance PrimPatch prim => Commute (Patch prim) where commute x = toMaybe $ msum [toFwdCommute speedyCommute x, toFwdCommute (cleverCommute mergerCommute) x, toFwdCommute everythingElseCommute x ] instance PrimPatch prim => PatchInspect (Patch prim) where -- Recurse on everything, these are potentially spoofed patches listTouchedFiles (Merger _ _ p1 p2) = nubSort $ listTouchedFiles p1 ++ listTouchedFiles p2 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 (PP p) = hunkMatches f p commuteNoMerger :: PrimPatch prim => MaybeCommute prim commuteNoMerger x = toMaybe $ msum [speedyCommute x, everythingElseCommute x] isFilepatchMerger :: PrimPatch prim => Patch prim wX wY -> 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) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) commuteRecursiveMerger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ do (_ :> pA') <- commuterIdFL selfCommuter (pA :> undo) _ <- commuterIdFL selfCommuter (pA' :> invert undo) (_ :> pAmid) <- commute (pA :> unsafeCoercePStart (invert p1)) (p1' :> pAx) <- commute (pAmid :> p1) guard (pAx `unsafeCompare` pA) (p2' :> _) <- commute (pAmid :> p2) (p2o :> _) <- commute (invert pAmid :> p2') guard (p2o `unsafeCompare` p2) let p' = if unsafeCompare p1' p1 && unsafeCompare p2' p2 then unsafeCoerceP p else unsafeMerger "0.0" p1' p2' undo' = mergerUndo p' (pAo :> _) <- commuterFLId selfCommuter (undo' :> pA') guard (pAo `unsafeCompare` pA) return (pA' :< p') where undo = mergerUndo p commuteRecursiveMerger _ = Unknown otherCommuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) otherCommuteRecursiveMerger (pA':< p_old@(Merger _ _ p1' p2')) = toPerhaps $ do (pA :> _) <- commuterFLId selfCommuter (mergerUndo p_old :> pA') (pAmid :> p1) <- commute (unsafeCoercePEnd p1' :> pA) (_ :> pAmido) <- commute (pA :> invert p1) guard (pAmido `unsafeCompare` pAmid) (p2 :> _) <- commute (invert pAmid :> p2') (p2o' :> _) <- commute (pAmid :> p2) guard (p2o' `unsafeCompare` p2') let p = if p1 `unsafeCompare` p1' && p2 `unsafeCompare` p2' then unsafeCoerceP p_old else unsafeMerger "0.0" p1 p2 undo = mergerUndo p guard (not $ pA `unsafeCompare` p1) -- special case here... (_ :> pAo') <- commuterIdFL selfCommuter (pA :> undo) guard (pAo' `unsafeCompare` pA') return (p :< pA) otherCommuteRecursiveMerger _ = Unknown type CommuteFunction prim = forall wX wY . (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) type MaybeCommute prim = forall wX wY . (Patch prim :< Patch prim) wX wY -> Maybe ((Patch prim :< Patch prim) wX wY) revCommuteFLId :: MaybeCommute prim -> (FL (Patch prim) :< Patch prim) wX wY -> Maybe ((Patch prim :< FL (Patch prim)) wX wY) 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 attempts to perform the "intuitive" merge of two patches, -- from a common starting context @wX@. elegantMerge :: PrimPatch prim => (Patch prim :\/: Patch prim) wX wY -> Maybe ((Patch prim :/\: Patch prim) wX wY) 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' {- A note about mergers and type witnesses --------------------------------------- The merger code predates the introduction of type witnesses, and because of its complexity has proved the hardest part of the codebase to retrofit. Attempting to do this has exposed various places where the code behaves oddly (e.g. 'putBefore' below); these are likely to be bugs but fixing them would be potentially disruptive and dangerous as it might change the existing merge behaviour and thus break existing repositories. As a result the addition of witnesses to this code has required the liberal use of unsafe operators. In effect, witnesses bring no safety in this area; the sole purpose of adding them here was to allow this code to run as part of a codebase that uses witnesses everywhere else. A key problem point is the type of the 'Merger' and 'Regrem' constructors of Patch, where the witnesses seem odd. It is likely that some or many of the unsafe operations could be removed by finding a better type for these constructors. -} -- |actualMerge attempts to perform a merge; if successful, it returns the -- "right" branch of the merge -- -- TODO: why does this code throw away the other branch, only for merge to -- rebuild it? actualMerge :: PrimPatch prim => (Patch prim :\/: Patch prim) wX wY -> Sealed (Patch prim wY) actualMerge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of Just (_ :/\: p1') -> Sealed p1' Nothing -> merger "0.0" p2 p1 -- Recreates a patch history in reverse. unwind :: Patch prim wX wY -> Sealed (RL (Patch prim) wX) unwind (Merger _ unwindings _ _) = Sealed unwindings unwind p = Sealed (p :<: NilRL) -- Recreates a patch history in reverse. The patch being unwound is always at -- the start of the list of patches. trueUnwind :: PrimPatch prim => Patch prim wX wY -> Sealed (RL (Patch prim) wX) 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 reconcileUnwindings :: PrimPatch prim => Patch prim wA wB -> RL (Patch prim) wX wZ -> RL (Patch prim) wY wZ -> FlippedSeal (RL (Patch prim)) wZ reconcileUnwindings _ NilRL p2s = FlippedSeal p2s reconcileUnwindings _ p1s NilRL = FlippedSeal p1s reconcileUnwindings p (p1:<:p1s) p2s@(p2:<:tp2s) = case [(p1s', p2s')| p1s'@(hp1s':<:_) <- headPermutationsRL (p1:<:p1s), p2s'@(hp2s':<:_) <- headPermutationsRL p2s, hp1s' `unsafeCompare` hp2s'] of ((p1':<:p1s', _:<:p2s'):_) -> mapFlipped (p1' :<:) $ reconcileUnwindings p p1s' (unsafeCoercePEnd p2s') [] -> case reverseFL `fmap` putBefore p1 (reverseRL p2s) of Just p2s' -> mapFlipped (p1 :<:) $ reconcileUnwindings p p1s p2s' Nothing -> case fmap reverseFL $ putBefore p2 $ reverseRL (p1:<:p1s) of Just p1s' -> mapFlipped (p2 :<:) $ reconcileUnwindings p p1s' tp2s Nothing -> bugDoc $ text "in function reconcileUnwindings" $$ text "Original patch:" $$ showPatch_ p _ -> bug "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 wY wZ -> FL (Patch prim) wX wZ -> Maybe (FL (Patch 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 => Conflict (Patch prim) where resolveConflicts patch = rcs NilFL (patch :<: NilRL) where rcs :: FL (Patch prim) wY wW -> RL (Patch prim) wX wY -> [[Sealed (FL prim wW)]] rcs _ NilRL = [] rcs passedby (p@(Merger{}):<:ps) = case revCommuteFLId commuteNoMerger (passedby: 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 -- This type seems wrong - the most natural type for the result would seem to be -- [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 wX wY -> [Sealed (FL prim wY)] publicUnravel = map (mapSeal unsafeCoercePStart) . unravel unravel :: PrimPatch prim => Patch prim wX wY -> [Sealed (FL prim wX)] unravel p = nub $ map (mapSeal (sortCoalesceFL . concatFL . mapFL_FL effect)) $ getSupers $ map (mapSeal reverseRL) $ unseal (newUr p) $ unwind p getSupers :: PrimPatch prim => [Sealed (FL (Patch prim) wX)] -> [Sealed (FL (Patch prim) wX)] getSupers (x:xs) = case filter (not.(x `isSuperpatchOf`)) xs of xs' -> if any (`isSuperpatchOf` x) xs' then getSupers xs' else x : getSupers xs' getSupers [] = [] isSuperpatchOf :: PrimPatch prim => Sealed (FL (Patch prim) wX) -> Sealed (FL (Patch 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) wX wY -> FL (Patch 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] -- | 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 -> Patch prim wX wY -> Patch prim wX wZ -> Sealed (Patch prim wY) 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 = 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 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 wX wY -> Patch prim wX wZ -> Sealed (FL (Patch prim) wY) 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 effect (PP p) = p :>: NilFL instance IsHunk prim => IsHunk (Patch prim) where isHunk p = do PP p' <- return p isHunk p' newUr :: PrimPatch prim => Patch prim wA wB -> RL (Patch prim) wX wY -> [Sealed (RL (Patch prim) wX)] 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 op ps = case filter (\(p:<:_) -> isMerger p) $ headPermutationsRL ps of [] -> [Sealed ps] (ps':_) -> newUr op ps' instance Invert prim => Invert (Patch 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 unsafeCompare = eqPatches instance MyEq prim => Eq (Patch prim wX wY) where (==) = unsafeCompare eqPatches :: MyEq prim => Patch prim wX wY -> Patch prim wW wZ -> Bool eqPatches (PP p1) (PP p2) = unsafeCompare p1 p2 eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) = eqPatches p1a p2a && eqPatches p1b p2b eqPatches (Regrem _ _ p1a p1b) (Regrem _ _ p2a p2b) = eqPatches p1a p2a && eqPatches p1b p2b eqPatches _ _ = False darcs-2.10.2/src/Darcs/Patch/Matchable.hs0000644000175000017500000000055712620122474022027 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2013 Ganesh Sittampalam -- -- BSD3 module Darcs.Patch.Matchable ( Matchable ) where import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Rebase.NameHack ( NameHack ) class (Patchy p, PatchInspect p, MaybeInternal p, NameHack p) => Matchable p darcs-2.10.2/src/Darcs/Patch/Patchy/0000755000175000017500000000000012620122474021034 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Patchy/Instances.hs0000644000175000017500000000070512620122474023321 0ustar00guillaumeguillaume00000000000000{-# 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.Patch.Witnesses.Ordered ( FL, RL ) instance (IsHunk p, PatchListFormat p, Patchy p) => Patchy (FL p) instance (IsHunk p, PatchListFormat p, Patchy p) => Patchy (RL p) darcs-2.10.2/src/Darcs/Patch/Format.hs0000644000175000017500000000315312620122474021372 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Format ( PatchListFormat(..) , ListFormat(..) , copyListFormat , FileNameFormat(..) ) where -- | 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. class PatchListFormat p where 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 :: (* -> * -> *)) = 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. copyListFormat :: ListFormat p -> ListFormat q copyListFormat ListFormatDefault = ListFormatDefault copyListFormat ListFormatV1 = ListFormatV1 copyListFormat ListFormatV2 = ListFormatV2 data FileNameFormat = OldFormat | NewFormat darcs-2.10.2/src/Darcs/Patch/Type.hs0000644000175000017500000000035412620122474021063 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Type ( PatchType(..), patchType ) where -- |Used for indicating a patch type without having a concrete patch data PatchType (p :: * -> * -> *) = PatchType patchType :: p wX wY -> PatchType p patchType _ = PatchType darcs-2.10.2/src/Darcs/Patch/V2/0000755000175000017500000000000012620122474020073 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/V2/Real.hs0000644000175000017500000012342012620122474021314 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Patch.V2.Real ( RealPatch(..) , prim2real , isConsistent , isForward , isDuplicate , mergeUnravelled ) where #if MIN_VERSION_base(4,8,0) import Prelude hiding ( (*>) ) #endif 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.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL , commuteRLFL ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) , IsConflictedPrim(..), ConflictState(..) ) import Darcs.Patch.ConflictMarking ( mangleUnravelled ) import Darcs.Patch.Debug 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.MaybeInternal ( MaybeInternal ) 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.Rebase.NameHack ( NameHack ) import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) 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 Data.List.Ordered ( nubSort ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+), (+<+) , mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..) , reverseRL, lengthFL, lengthRL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal , unseal ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) , showsPrec2, appPrec ) import Darcs.Util.Printer.Color ( errorDoc, assertDoc ) import Darcs.Util.Printer ( Doc, 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 wX wY where Duplicate :: Non (RealPatch prim) wX -> RealPatch prim wX wX Etacilpud :: Non (RealPatch prim) wX -> RealPatch prim wX wX Normal :: prim wX wY -> RealPatch prim wX wY Conflictor :: [Non (RealPatch prim) wX] -> FL prim wX wY -> Non (RealPatch prim) wX -> RealPatch prim wY wX InvConflictor :: [Non (RealPatch prim) wX] -> FL prim wX wY -> Non (RealPatch prim) wX -> RealPatch prim wX wY 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 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 => RealPatch 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 $$ showPatch 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 (RealPatch prim) wX) 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) wX) -> Bool notNullS (Sealed NilFL) = False notNullS _ = True mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim wX)] -> Maybe (RL (RealPatch 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 (RealPatch prim) wX 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) wX] -> Maybe (FL (RealPatch prim) wX wX) mergeConflictingNons ns = mcn $ map unNon ns where mcn :: PrimPatch prim => [Sealed (FL (RealPatch prim) wX)] -> Maybe (FL (RealPatch 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 Common 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), MyEq (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 => RealPatch prim wX wY -> RealPatch prim wX wY 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) wX wX -> FL prim wX wY -> Maybe ( FL (RealPatch prim) wX wX , FL (RealPatch prim) wX wY) mergeAfterConflicting xxx yyy = mac (reverseFL xxx) yyy NilFL where mac :: PrimPatch prim => RL (RealPatch prim) wX wY -> FL prim wY wZ -> FL (RealPatch prim) wZ wA -> Maybe (FL (RealPatch prim) wX wX, FL (RealPatch prim) wX wA) 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) wX] -> FL prim wX wY -> ([Non (RealPatch prim) wX], FL (RealPatch 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 -> 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) wX] -> FL prim wX wY -> [Non (RealPatch prim) wX] xx2nons ix xx = fst $ geteff ix xx xx2patches :: PrimPatch prim => [Non (RealPatch prim) wX] -> FL prim wX wY -> FL (RealPatch 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 (RealPatch 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 => RealPatch 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" $$ 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) wX] -> Bool everyoneConflicts [] = True everyoneConflicts (x : xs) = case allConflictsWith x xs of ([], _) -> False (_, xs') -> everyoneConflicts xs' prim2real :: prim wX wY -> RealPatch prim wX wY prim2real = Normal instance MaybeInternal (RealPatch prim) instance NameHack (RealPatch prim) instance RecontextRebase (RealPatch prim) instance PrimPatch prim => Patchy (RealPatch prim) instance PatchDebug prim => PatchDebug (RealPatch prim) mergeWith :: PrimPatch prim => Non (RealPatch prim) wX -> [Non (RealPatch 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 (RealPatch 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 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) wX wY -> [Non (RealPatch prim) wX] 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) wX -> Non (RealPatch prim) wX 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) wX -> [FilePath] nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL) nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool) -> Non (RealPatch prim) wX -> Bool nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x toNons :: forall p wX wY . (Conflict p, Patchy p, PatchListFormat p, ToFromPrim 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 -> 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) 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 (x :<: rs) y ys lastNon_aux :: (p :> FL p) wX wZ -> (RL p :> p :> RL p) wX wZ lastNon_aux = commuteWhatWeCanRL . reverseFoo initsFL :: Patchy p => 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) filterConflictsFL :: PrimPatch prim => Non (RealPatch prim) wX -> FL prim wX wY -> (FL prim :> FL prim) wX wY 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) wX -> [Non (RealPatch prim) wX] -> ([Non (RealPatch prim) wX], [Non (RealPatch 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 (RealPatch prim) wX -> Non (RealPatch 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 = fromPrim $ invert y in case commuteFLorComplain (iy :> cx' +>+ fromPrim x' :>: NilFL) of Right _ -> False Left _ -> True Nothing -> True dependsUpon :: PrimPatch prim => Non (RealPatch prim) wX -> Non (RealPatch prim) wX -> 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) wX wY -> (RealPatch prim :/\: RealPatch prim) wX wY swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x' invertCommute :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY -> Maybe ((RealPatch prim :> RealPatch prim) wX wY) invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x) return (invert iy' :> invert ix') invertCommuteNC :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY -> Maybe ((RealPatch prim :> RealPatch prim) wX wY) 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, MyEq p) => FL p wO wX -> FL p wO wY -> Common p wO wX wY 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 wO wX wY where Common :: FL p wO wI -> FL p wI wX -> FL p wI wY -> Common 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 :: (Patchy p, MyEq 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 (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 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 (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 Show2 prim => Show (RealPatch prim wX wY) where showsPrec d (Normal prim) = showParen (d > appPrec) $ showString "Darcs.Patch.V2.Real.Normal " . showsPrec2 (appPrec + 1) prim showsPrec d (Duplicate x) = showParen (d > appPrec) $ showString "Darcs.Patch.V2.Real.Duplicate " . showsPrec (appPrec + 1) x showsPrec d (Etacilpud x) = showParen (d > appPrec) $ showString "Darcs.Patch.V2.Etacilpud " . showsPrec (appPrec + 1) x showsPrec d (Conflictor ix xx x) = showParen (d > appPrec) $ showString "Darcs.Patch.V2.Real.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 "Darcs.Patch.V2.Real.InvConflictor " . showsPrec (appPrec + 1) ix . showString " " . showsPrec (appPrec + 1) xx . showString " " . showsPrec (appPrec + 1) x instance Show2 prim => Show1 (RealPatch prim wX) where showDict1 = ShowDictClass instance Show2 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 darcs-2.10.2/src/Darcs/Patch/V2/Non.hs0000644000175000017500000002534312620122474021170 0ustar00guillaumeguillaume00000000000000-- 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, FlexibleContexts, UndecidableInstances #-} module Darcs.Patch.V2.Non ( Non(..) , Nonable(..) , unNon , showNon , showNons , readNon , readNons , commutePrimsOrAddToCtx , commuteOrAddToCtx , commuteOrRemFromCtx , commuteOrAddToCtxRL , commuteOrRemFromCtxFL , remNons , (*>) , (>*) , (*>>) , (>>*) ) where #if MIN_VERSION_base(4,8,0) import Prelude hiding ( rem, (*>) ) #else import Prelude hiding ( rem ) #endif import Data.List ( delete ) import Control.Monad ( liftM, mzero ) import Darcs.Patch.Commute ( commuteFL ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) 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.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (+>+), mapRL_RL , (:>)(..), reverseFL, reverseRL ) import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..), appPrec , showsPrec2 ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Read ( peekfor ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Viewing () 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 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 wX -> Sealed (FL p wX) unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL) 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 -- |showNons creates a Doc representing a list of Nons. showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => [Non p wX] -> Doc showNons [] = empty showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}" -- |showNon creates a Doc representing a Non. showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p wX -> Doc showNon (Non c p) = hiddenPrefix "|" (showPatch c) $$ hiddenPrefix "|" (blueText ":") $$ showPrim NewFormat 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 wX] readNons = peekfor (BC.pack "{{") rns (return []) where rns = peekfor (BC.pack "}}") (return []) $ do Sealed ps <- readPatch' lexChar ':' Sealed p <- readPrim NewFormat (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 wX) readNon = do Sealed ps <- readPatch' let doReadPrim = do Sealed p <- readPrim NewFormat 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 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 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 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 -- | 'commuteOrAddToCtxRL' @xs cy@ commutes as many patches of @xs@ past @cy@ -- as possible, adding any that don't commute to the context of cy. Suppose we -- have -- -- > x1 x2 x3 [c1 c2 y] -- -- and that in our example @x1@ fails to commute past @c1@, this function -- would commute down to -- -- > x1 [c1'' c2'' y''] x2' x3' -- -- and return @[x1 c1'' c2'' y'']@ commuteOrAddToCtxRL :: (Patchy 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 -- |abstract over 'FL'/'RL' class WL l where toFL :: l p wX wY -> FL p wX wY 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) wX wY -> Non p wY -> Non p wX commutePrimsOrAddToCtx q = commuteOrAddToCtxRL (mapRL_RL fromPrim $ toRL q) -- TODO: Figure out what remNons is for; it's is only used in one place - when -- commuting two Conflictors: -- -- > commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2) -- > ... -- > a1' = map (commutePrimsOrAddToCtx n2) a1 -- > p2ooo = remNons a1' p2 -- > n2n1 = n2 +>+ n1 -- > n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1 -- -- which appears to be munging the not-yet-undone FLs in the Conflictors. a1' -- will be the list of Nons with n2 commuted in/past them. So we then want to -- 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, MyEq p, ToFromPrim p, PrimPatchBase p, MyEq (PrimOf 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, MyEq p, ToFromPrim p, PrimPatchBase p, MyEq (PrimOf 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 a :> z -> sortCoalesceFL (effect c +>+ a) :> z | otherwise = case commuteWhatWeCanFL (c :> cs) of b :> c' :> d -> case remNonHelper ns b of a :> b' -> a :> (b' +>+ c' :>: d) -- |commuteOrRemFromCtx attempts to remove a given patch from a Non. If the -- patch was not in the Non, then the commute will succeed and the modified Non -- will be returned. If the commute fails then the patch is either in the Non -- context, or the Non patch itself; we attempt to remove the patch from the -- context and then return the non with the updated context. -- -- 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, MyEq 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, MyEq 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 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 wX wY -> Non p wY -> Maybe (Non p wX) y >* (Non c x) = do c' :> y' <- commuteFL (y :> c) px' :> _ <- commute (y' :> fromPrim 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 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) wX wY -> Non p wY -> Maybe (Non p wX) ps >>* n = commuteRLPastNon (toRL ps) n where commuteRLPastNon :: (Patchy 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 darcs-2.10.2/src/Darcs/Patch/Viewing.hs0000644000175000017500000001620512620122474021554 0ustar00guillaumeguillaume00000000000000-- 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. {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-} {-# LANGUAGE CPP #-} module Darcs.Patch.Viewing ( showContextHunk , showContextSeries ) where import Control.Applicative( (<$>) ) import qualified Data.ByteString as BS ( null ) import Prelude hiding ( pi, readFile ) import Storage.Hashed.Monad ( virtualTreeMonad ) import Storage.Hashed.Tree ( Tree ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, getApplyState, ApplyMonad(..), toTree ) import Darcs.Patch.FileHunk ( IsHunk(..), FileHunk(..), showFileHunk ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName ) import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), mapFL, mapFL_FL, reverseRL, concatFL ) import Darcs.Util.ByteString ( linesPS ) import Darcs.Util.Printer ( Doc, empty, vcat, text, blueText, Color(Cyan, Magenta), lineColor, ($$), (<+>), prefix, userchunkPS ) showContextSeries :: forall p m wX wY . (Apply p, ShowPatch p, IsHunk p, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => FL p wX wY -> m Doc showContextSeries = scs Nothing where scs :: forall m' wWw wXx wYy . (ApplyMonadTrans m' (ApplyState p), ApplyMonad m' (ApplyState p), ApplyMonadBase m ~ ApplyMonadBase m') => Maybe (FileHunk wWw wXx) -> FL p wXx wYy -> 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 wA wB) -> FileHunk wB wC -> Maybe (FileHunk wC wD) -> (ApplyState p) (ApplyMonadBase m) -> (ApplyMonadBase m) Doc cool pold fh ps s = fst <$> virtualTreeMonad (coolContextHunk pold fh ps) (toTree s) showContextHunk :: (ApplyMonad m Tree) => FileHunk wX wY -> m Doc showContextHunk h = coolContextHunk Nothing h Nothing coolContextHunk :: (ApplyMonad m Tree, ApplyMonadTrans m Tree) => Maybe (FileHunk wA wB) -> FileHunk wB wC -> Maybe (FileHunk wC wD) -> 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 -- This is a weird error... Nothing -> return $ showFileHunk OldFormat fh Just ls -> let pre = take numpre $ drop (l - numpre - 1) ls 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) 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 wX wY -> 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) 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 wX wY -> 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 description = vcat . mapFL description summary = summaryFL summaryFL = summaryFL . concatFL thing x = thing (helperx x) ++ "s" 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 instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) => ShowPatch (RL p) where showContextPatch = showContextPatch . reverseRL description = description . reverseRL summary = summary . reverseRL summaryFL = summaryFL . mapFL_FL reverseRL thing = thing . reverseRL things = things . reverseRL darcs-2.10.2/src/Darcs/Patch/ApplyMonad.hs0000644000175000017500000002060412620122474022206 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-} {-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-} -- Copyright (C) 2010, 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.ApplyMonad( ApplyMonad(..), ApplyMonadTrans(..), withFileNames, withFiles, ToTree(..) ) where 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 Data.Maybe ( fromMaybe ) import Storage.Hashed.Tree ( Tree ) import Darcs.Util.ByteString( linesPS, unlinesPS ) import Darcs.Util.Path ( FileName, movedirfilename, fn2fp, isParentOrEqOf, floatPath, AnchoredPath ) import Control.Monad.State.Strict import Control.Monad.Identity( Identity ) import Darcs.Patch.MonadProgress -- TODO should UUID/Object live somewhere more central? import Darcs.Patch.Prim.V3.ObjectMap ( UUID, ObjectMap, DirContent ) fn2ap :: FileName -> AnchoredPath fn2ap = floatPath . fn2fp class ToTree s where toTree :: s m -> Tree m instance ToTree Tree where toTree = id 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) instance (Functor m, Monad m) => ApplyMonadTrans m Tree where type ApplyMonadOver m Tree = HSM.TreeMonad m runApplyMonad = HSM.virtualTreeMonad 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 :: * -> * 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)) getApplyState :: m (state (ApplyMonadBase m)) putApplyState :: state m -> m () -- a semantic, ObjectMap-based interface for patch application editFile :: (state ~ ObjectMap) => UUID -> (B.ByteString -> B.ByteString) -> m () editDirectory :: (state ~ ObjectMap) => UUID -> (DirContent -> DirContent) -> m () -- 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 (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 -- putApplyState needs some support from HSM 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 -- 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 -- |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 old new pair@(latest, from) | old `isParentOrEqOf` latest = (latest, movedirfilename old new latest) | old `isParentOrEqOf` 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 -> FilePathMonadState withFileNames mbofnos fps x = execState 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 mCreateDirectory = mCreateFile mCreateFile f = modify $ \(ms, fs, rns) -> (f : ms, fs, rns) mRemoveFile f = modify $ \(ms, fs, rns) -> (f : ms, filter (/= f) fs, rns) mRemoveDirectory = mRemoveFile mRename a b = modify $ \(ms, fs, rns) -> ( a : b : ms , 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 darcs-2.10.2/src/Darcs/Patch/Match.hs0000644000175000017500000007555712620122474021217 0ustar00guillaumeguillaume00000000000000-- 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 #-} -- | /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.Patch.Match ( matchParser , helpOnMatchers , addInternalMatcher , matchFirstPatchset , matchSecondPatchset , splitSecondFL , matchPatch , matchAPatch , matchAPatchread , getNonrangeMatchS , firstMatch , secondMatch , haveNonrangeMatch , havePatchsetMatch , checkMatchSyntax , applyInvToMatcher , nonrangeMatcher , InclusiveOrExclusive(..) , matchExists , applyNInv , hasIndexRange , getMatchingTag , matchAPatchset , getFirstMatchS , nonrangeMatcherIsTag , MatchFlag(..) ) where import Text.ParserCombinators.Parsec ( parse , CharParser , () , (<|>) , noneOf , option , eof , many , try , between , spaces , char , oneOf , string , choice ) import Text.ParserCombinators.Parsec.Expr ( OperatorTable , Assoc( AssocLeft ) , Operator ( Infix, Prefix ) , buildExpressionParser ) import Text.Regex ( mkRegex, matchRegex ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad ( when ) import Data.List ( isPrefixOf, intercalate ) import Data.Char ( toLower ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Patch ( Patchy , hunkMatches , listTouchedFiles , patchcontents , Named , invert , invertRL , patch2patchinfo , apply ) import Darcs.Patch.Info ( justName, justAuthor, justLog, makePatchname, piDate ) import qualified Data.ByteString.Char8 as BC import Darcs.Patch.Dummy ( DummyPatch ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.MaybeInternal ( MaybeInternal, patchInternalChecker, isInternal, flIsInternal ) import Darcs.Patch.MonadProgress ( MonadProgress ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, conscientiously, hopefully ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, Origin ) import Darcs.Patch.Type ( PatchType(..) ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.ApplyPatches( applyPatches ) import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag ) import Darcs.Patch.Witnesses.Eq ( isIsEq ) import Darcs.Patch.Witnesses.Ordered ( RL(..), consRLSealed, FL(..), (:>)(..) ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..), seal, flipSeal, seal2, unsealFlipped, unseal2, unseal ) import Darcs.Util.Printer ( text, ($$) ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Darcs.Util.DateMatcher ( parseDateMatcher ) import Storage.Hashed.Tree ( Tree ) #include "impossible.h" -- | A type for predicates over patches which do not care about -- contexts type MatchFun p = Sealed2 (PatchInfoAnd 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) instance Show (Matcher p) where show (MATCH s _) = '"':s ++ "\"" data MatchFlag = OnePattern String | SeveralPattern String | AfterPattern String | UpToPattern String | OnePatch String | OneHash String | AfterHash String | UpToHash String | SeveralPatch String | AfterPatch String | UpToPatch String | OneTag String | AfterTag String | UpToTag String | LastN Int | PatchIndexRange Int Int | Context AbsolutePath deriving ( Show ) makeMatcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p makeMatcher = MATCH -- | @applyMatcher@ applies a matcher to a patch. applyMatcher :: Matcher p -> PatchInfoAnd p wX wY -> Bool applyMatcher (MATCH _ m) = m . seal2 parseMatch :: Matchable p => String -> Either String (MatchFun p) 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 matchPattern :: Matchable p => String -> Matcher p matchPattern pattern = case parseMatch pattern of Left err -> error err Right m -> makeMatcher pattern m addInternalMatcher :: Matchable p => Maybe (Matcher p) -> Maybe (Matcher p) addInternalMatcher om = case patchInternalChecker of Nothing -> om Just f -> let matchFun = unseal2 (not . isIsEq . isInternal f . patchcontents . hopefully) in case om of Nothing -> Just (MATCH "internal patch" matchFun) Just (MATCH s oldFun) -> Just (MATCH s (\p -> matchFun p && oldFun p)) matchParser :: Matchable p => CharParser st (MatchFun p) matchParser = submatcher helpfulErrorMsg where submatcher = do m <- option matchAnyPatch 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`." -- This type signature is just to bind an ambiguous type var. ps :: [(String, String, [String], String -> MatchFun DummyPatch)] ps = primitiveMatchers -- matchAnyPatch is returned if submatch fails without consuming any -- input, i.e. if we pass --match '', we want to match anything. matchAnyPatch :: Matchable p => MatchFun p matchAnyPatch = const True submatch :: Matchable p => CharParser st (MatchFun p) submatch = buildExpressionParser table match table :: OperatorTable Char st (MatchFun p) table = [ [prefix "not" negate_match, prefix "!" negate_match ] , [binary "||" or_match, binary "or" or_match, binary "&&" and_match, binary "and" and_match ] ] 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 trystring :: String -> CharParser st String trystring s = try $ string s match :: Matchable p => CharParser st (MatchFun p) 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) = 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 = ["Selecting Patches:", "", "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'", "- --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-patch and --to-match can be unproblematically combined:", " `darcs changes --from-patch='html.*documentation' --to-match='date 20040212'`", "", "The following primitive Boolean expressions are supported:" ,""] ++ keywords ++ ["", "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] 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 ++ "." 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 " ++ "'" ++ keyword ++ " " ++ example ++ "'" primitiveMatchers :: Matchable p => [(String, String, [String], String -> MatchFun p)] -- ^ keyword (operator), help description, list -- of examples, matcher function primitiveMatchers = [ ("exact", "check a literal string against the patch name" , ["\"Resolve issue17: use dynamic memory allocation.\""] , exactmatch ) , ("name", "check a regular expression against the patch name" , ["issue17", "\"^[Rr]esolve issue17\\>\""] , namematch ) , ("author", "check a regular expression against the author name" , ["\"David Roundy\"", "droundy", "droundy@darcs.net"] , authormatch ) , ("hunk", "check a regular expression against the contents of a hunk patch" , ["\"foo = 2\"", "\"^instance .* Foo where$\""] , hunkmatch ) , ("comment", "check a regular expression against the log message" , ["\"prevent deadlocks\""] , logmatch ) , ("hash", "match a full hash or a prefix for a patch" , ["c719567e92c3b0ab9eddd5290b705712b8b918ef","c7195"] , hashmatch ) , ("date", "match the patch date" , ["\"2006-04-02 22:41\"", "\"tea time yesterday\""] , datematch ) , ("touch", "match file paths for a patch" , ["src/foo.c", "src/", "\"src/*.(c|h)\""] , touchmatch ) ] parens :: CharParser st (MatchFun p) -> CharParser st (MatchFun p) parens = between (string "(") (string ")") quoted :: CharParser st String quoted = between (char '"') (char '"') (many $ do { _ <- char '\\' -- allow escapes ; try (oneOf "\\\"") <|> return '\\' } <|> noneOf "\"") <|> between spaces spaces (many $ noneOf " ()") "string" namematch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch :: Matchable p => String -> MatchFun p namematch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp) exactmatch r (Sealed2 hp) = r == justName (info hp) authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ justAuthor (info hp) logmatch :: Matchable p => String -> MatchFun p logmatch l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp) hunkmatch r (Sealed2 hp) = let patch = patchcontents $ hopefully hp regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack in hunkMatches regexMatcher patch hashmatch h (Sealed2 hp) = let rh = show $ makePatchname (info 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) touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp in any (isJust . matchRegex (mkRegex r)) files 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@, @--hash@ and @--index@ make @haveNonrangeMatch@ -- true, but not @--from-patch@ or @--to-patch@. haveNonrangeMatch :: forall p . Matchable p => PatchType p -> [MatchFlag] -> Bool haveNonrangeMatch _ fs = case hasIndexRange fs of Just (m,n) | m == n -> True; _ -> False || isJust (nonrangeMatcher fs::Maybe (Matcher p)) -- | @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 :: [MatchFlag] -> Bool havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch)) || hasC fs where hasC [] = False hasC (Context _:_) = True hasC (_:xs) = hasC xs getNonrangeMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p, ApplyState p ~ Tree) => [MatchFlag] -> PatchSet p Origin wX -> 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 :: [MatchFlag] -> Bool firstMatch fs = isJust (hasLastn fs) || isJust (firstMatcher fs::Maybe (Matcher DummyPatch)) || isJust (hasIndexRange fs) getFirstMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p) => [MatchFlag] -> PatchSet p Origin wX -> 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 getFirstMatchS." 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 :: [MatchFlag] -> Bool secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher DummyPatch)) || isJust (hasIndexRange fs) unpullLastN :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p, MaybeInternal p) => PatchSet p wX wY -> Int -> m () unpullLastN repo n = applyInvRL `unsealFlipped` safetake n (newset2RL repo) checkMatchSyntax :: [MatchFlag] -> IO () checkMatchSyntax opts = case getMatchPattern opts of Nothing -> return () Just p -> either fail (const $ return ()) (parseMatch p::Either String (MatchFun DummyPatch)) getMatchPattern :: [MatchFlag] -> Maybe String getMatchPattern [] = Nothing getMatchPattern (OnePattern m:_) = Just m getMatchPattern (SeveralPattern m:_) = Just m getMatchPattern (_:fs) = getMatchPattern fs tagmatch :: Matchable p => 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) patchmatch :: Matchable p => String -> Matcher p patchmatch r = makeMatcher ("patch-name "++r) (namematch r) hashmatch' :: Matchable p => String -> Matcher p 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, nonrangeMatcherArgs :: Matchable p => [MatchFlag] -> Maybe (Matcher p) nonrangeMatcher fs = addInternalMatcher $ nonrangeMatcherArgs fs nonrangeMatcherArgs [] = Nothing nonrangeMatcherArgs (OnePattern m:_) = strictJust $ matchPattern m nonrangeMatcherArgs (OneTag t:_) = strictJust $ tagmatch t nonrangeMatcherArgs (OnePatch p:_) = strictJust $ patchmatch p nonrangeMatcherArgs (OneHash h:_) = strictJust $ hashmatch' h nonrangeMatcherArgs (SeveralPattern m:_) = strictJust $ matchPattern m nonrangeMatcherArgs (SeveralPatch p:_) = strictJust $ patchmatch p nonrangeMatcherArgs (_:fs) = nonrangeMatcherArgs fs -- | @nonrangeMatcherIsTag@ returns true if the matching option was -- '--tag' nonrangeMatcherIsTag :: [MatchFlag] -> 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 :: Matchable p => [MatchFlag] -> 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 $ 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 :: Matchable p => [MatchFlag] -> Maybe (Matcher p) 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 -- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in -- the flags listed in @fs@. matchAPatchread :: Matchable p => [MatchFlag] -> PatchInfoAnd p wX wY -> 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 :: Matchable p => [MatchFlag] -> PatchInfoAnd p wX wY -> Bool matchAPatch fs p = case nonrangeMatcher fs of Nothing -> True Just m -> applyMatcher m p matchPatch :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> 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 wStart wX -> 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 -- | @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 (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 :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> SealedPatchSet p wStart 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 :: MaybeInternal p => Int -> PatchSet p wStart wX -> SealedPatchSet p wStart 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 (p:<:ps) ts) | isIsEq (flIsInternal (patchcontents (hopefully p))) = dropn n $ PatchSet ps ts 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 :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> SealedPatchSet p wStart 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 -- | 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 (PatchInfoAnd p)) -> [MatchFlag] -> FL q wX wY -> (FL q :> FL q) wX wY -- ^The first element is the patches before and including the first patch matching the second matcher, -- 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 bug "index matches not supported by splitSecondPatchesFL" Nothing -> case secondMatcher fs of Nothing -> bug "Couldn't splitSecondPatches" Just m -> splitMatchFL extract m ps -- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and -- calls 'error' if there is none. findAPatch :: Matchable p => Matcher p -> PatchSet p wStart wX -> 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 :: Matchable p => Matcher p -> PatchSet p wStart wX -> SealedPatchSet p wStart 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 :: Matchable p => Matcher p -> PatchSet p wStart wX -> SealedPatchSet p wStart 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 Nothing -> bug "splitOnTag couldn't find tag we explicitly provided!" Just (patchSet :> _) -> seal patchSet | otherwise = getMatchingTag m (PatchSet ps ts) splitMatchFL :: Matchable p => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd p)) -> Matcher p -> FL q wX wY -> (FL q :> FL q) wX wY splitMatchFL _extract m NilFL = error $ "Couldn't find patch matching " ++ show m splitMatchFL extract m (p :>: ps) | unseal2 (applyMatcher m) . extract $ p = (p :>: NilFL) :> ps | otherwise = case splitMatchFL extract m ps of before :> after -> (p :>: before) :> after -- | @matchExists m ps@ tells whether there is a patch matching -- @m@ in @ps@ matchExists :: Matcher p -> PatchSet p wStart wX -> 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 :: (Matchable p, ApplyMonad m (ApplyState p)) => InclusiveOrExclusive -> Matcher p -> PatchSet p Origin wX -> 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 :: (Matchable p, ApplyMonad m (ApplyState p)) => Int -> PatchSet p Origin wX -> 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), Matchable p) => InclusiveOrExclusive -> Matcher p -> PatchSet p Origin wX -> 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, Matchable p) => Matcher p -> PatchSet p Origin wX -> m () getTagS matcher repo = do let pinfo = patch2patchinfo `unseal2` findAPatch matcher 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 wX wY -> 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 :: MaybeInternal p => Int -> RL (PatchInfoAnd p) wX wY -> FlippedSeal (RL (PatchInfoAnd p)) wY safetake 0 _ = flipSeal NilRL safetake _ NilRL = error "There aren't that many patches..." safetake i (a:<:as) | isIsEq (flIsInternal (patchcontents (hopefully a))) = a `consRLSealed` safetake i as safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as applyInvRL :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => RL (PatchInfoAnd p) wX wR -> m () applyInvRL = applyPatches . invertRL -- this gives nicer feedback darcs-2.10.2/src/Darcs/Patch/Prim.hs0000644000175000017500000000140412620122474021046 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim ( showPrim, showPrimFL, primIsAddfile, primIsHunk, primIsBinary, primIsSetpref, primIsAdddir, is_filepatch, canonize, tryToShrink, sortCoalesceFL, coalesce, canonizeFL, tryShrinkingInverse, summarizePrim, applyPrimFL, readPrim, FromPrim(..), FromPrims(..), ToFromPrim(..), PrimPatch, PrimPatchBase(..), PrimConstruct(..) ) where import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimCanonize(..) , PrimClassify(..), PrimDetails(..) , PrimShow(..), showPrimFL, PrimRead(..) , PrimApply(..) , FromPrim(..), FromPrims(..), ToFromPrim(..) , PrimPatchBase(..), PrimPatch ) darcs-2.10.2/src/Darcs/Patch/Witnesses/0000755000175000017500000000000012620122474021570 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Witnesses/Show.hs0000644000175000017500000000270212620122474023045 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.Patch.Witnesses.Show ( ShowDict(..) , showD , showListD , showsPrecD , Show1(..) , Show2(..) , show1 , showsPrec1 , show2 , showsPrec2 , showOp2 , appPrec ) where import Darcs.Util.Show ( appPrec ) 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 wX) 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) 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 darcs-2.10.2/src/Darcs/Patch/Witnesses/Unsafe.hs0000644000175000017500000000110712620122474023344 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE MagicHash #-} module Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP , unsafeCoercePStart , unsafeCoercePEnd , unsafeCoerceP2 , unsafeCoerceP1 ) where import GHC.Base (unsafeCoerce#) 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# unsafeCoerceP2 :: t wW wX wY wZ -> t wA wB wC wD unsafeCoerceP2 = unsafeCoerce# unsafeCoerceP1 :: a wX -> a wY unsafeCoerceP1 = unsafeCoerce# darcs-2.10.2/src/Darcs/Patch/Witnesses/WZipper.hs0000644000175000017500000000526612620122474023535 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Patch.Witnesses.WZipper ( FZipper(..) , focus , leftmost , left , rightmost , right , jokers , clowns , flToZipper , lengthFZ , nullFZ , toEnd , toStart ) where 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\" -- 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 (b:>:r)) = FZipper (b :<: l) 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 (b :<: l) r) = FZipper l (b :>: r) left x@(FZipper NilRL _) = x toEnd :: FZipper p wX wY -> FZipper p wX wY toEnd (FZipper l r) = FZipper (reverseFL r +<+ l) NilFL toStart :: FZipper p wX wY -> FZipper p wX wY toStart (FZipper l r) = FZipper NilRL $ reverseRL l +>+ r darcs-2.10.2/src/Darcs/Patch/Witnesses/Sealed.hs0000644000175000017500000001447012620122474023327 0ustar00guillaumeguillaume00000000000000-- 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 #-} {-# OPTIONS_HADDOCK ignore-exports #-} module Darcs.Patch.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.Patch.Witnesses.Eq ( MyEq, 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 MyEq 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 unsafeUnsealFlipped :: FlippedSeal a wY -> a wX wY unsafeUnsealFlipped (FlippedSeal a) = unsafeCoerceP 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 unsealM :: Monad m => m (Sealed a) -> (forall wX . a wX -> m b) -> m b unsealM m1 m2 = do sx <- m1 unseal m2 sx liftSM :: Monad m => (forall wX . a wX -> b) -> m (Sealed a) -> m b liftSM f m = do sx <- m return (unseal f sx) 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 -- |'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 } -- |'Stepped' is a type level composition operator. -- For example, @ 'Stepped' ('Sealed' p) @ is equivalent to -- @ \\x -> 'Sealed' (p x) @ newtype Stepped (f :: (* -> *) -> *) a wX = Stepped { unStepped :: f (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 (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 wX) unFreeLeft (FLInternal x) = unStepped (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 (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'))) darcs-2.10.2/src/Darcs/Patch/Witnesses/Eq.hs0000644000175000017500000000354112620122474022474 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Witnesses.Eq ( EqCheck(..) , MyEq(..) , isIsEq ) where 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 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 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 infix 4 =\/=, =/\= isIsEq :: EqCheck wA wB -> Bool isIsEq IsEq = True isIsEq NotEq = False darcs-2.10.2/src/Darcs/Patch/Witnesses/Ordered.hs0000644000175000017500000003205312620122474023513 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Patch.Witnesses.Ordered ( -- * Directed Types -- $DirectedTypes (:>)(..) , (:<)(..) , FL(..) , RL(..) -- * Merge Types -- $MergeTypes , (:\/:)(..) , (:/\:)(..) , (:||:)(..) , Fork(..) -- * Functions , lengthFL , mapFL , mapFL_FL , spanFL , foldlFL , allFL , anyFL , filterFL , splitAtFL , splitAtRL , bunchFL , foldlRL , lengthRL , isShorterThanRL , mapRL , mapRL_RL , zipWithFL , filterOutFLFL , filterOutRLRL , filterRL , reverseFL , reverseRL , (+>+) , (+<+) , nullFL , concatFL , concatRL , consRLSealed , nullRL , toFL , dropWhileFL , dropWhileRL , spanFL_M , mapFL_FL_M , eqFL , eqFLRev , eqFLUnsafe ) where #include "impossible.h" import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..) , flipSeal , Sealed(..) , FreeLeft , unFreeLeft , Sealed2(..) , seal ) import Darcs.Patch.Witnesses.Eq ( MyEq(..), 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 :> -- | Directed Reverse Pairs data (a1 :< a2) wX wY = forall wZ . (a1 wZ wY) :< (a2 wX wZ) infix 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 (:<:) :: a wY wZ -> RL a wX wY -> 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) where showDict1 = ShowDictClass instance Show2 a => Show2 (FL a) where showDict2 = ShowDictClass instance Show2 a => Show (RL a wX wZ) 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 wX) where showDict1 = ShowDictClass instance Show2 a => Show2 (RL a) where showDict2 = ShowDictClass instance (Show2 a, Show2 b) => Show1 ((a :> b) wX) where showDict1 = ShowDictClass -- * 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 / \ a4 -- / \ -- wX wY -- \ / -- a1 \ / 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 -- \ / -- \ / -- \ / -- wU -- | -- | -- | -- 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 (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) wX wY) 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) wX wY) where (==) = unsafeCompare instance (Show2 a, Show2 b) => Show2 (a :> b) where showDict2 = ShowDictClass 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) where showDict2 = ShowDictClass 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) ) where showDict2 = ShowDictClass -- * Functions infixr 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 (x:<:xs) | IsEq <- f x = filterOutRLRL f xs | otherwise = x :<: filterOutRLRL f xs filterRL :: (forall wX wY . p wX wY -> Bool) -> RL p wA wB -> [Sealed2 p] filterRL _ NilRL = [] filterRL f (x :<: xs) | f x = Sealed2 x : (filterRL f xs) | otherwise = filterRL f xs (+>+) :: FL a wX wY -> FL a wY wZ -> FL a wX wZ NilFL +>+ ys = ys (x:>:xs) +>+ ys = x :>: xs +>+ ys (+<+) :: RL a wY wZ -> RL a wX wY -> RL a wX wZ NilRL +<+ ys = ys (x:<:xs) +<+ ys = x :<: xs +<+ ys 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 (a:<:ls) as reverseRL :: RL a wX wZ -> FL a wX wZ reverseRL xs = r NilFL xs -- r (xs :> NilFL) where r :: FL a wM wO -> RL a wL wM -> FL a wL wO r ls NilRL = ls r ls (a:<:as) = 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 (a:<:as) = a +<+ concatRL as 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 = NilRL :< xs splitAtRL _ NilRL = NilRL :< NilRL splitAtRL n (x:<:xs) = case splitAtRL (n-1) xs of (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 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 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 foldlFL :: (forall wW wY . a -> b wW wY -> a) -> a -> FL b wX wZ -> a foldlFL _ x NilFL = x foldlFL f x (y:>:ys) = foldlFL f (f x y) ys foldlRL :: (forall wW wY . a -> b wW wY -> a) -> a -> RL b wX wZ -> a foldlRL _ x NilRL = x foldlRL f x (y:<:ys) = foldlRL f (f x y) ys 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) 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 _ [] (_:>:_) = bug "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 (a:<:as) = f a :<: mapRL_RL f as 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 (a :<: b) = f a : mapRL f b 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) consRLSealed :: a wY wZ -> FlippedSeal (RL a) wY -> FlippedSeal (RL a) wZ consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as toFL :: [FreeLeft a] -> Sealed (FL a wX) toFL [] = Sealed NilFL toFL (x:xs) = case unFreeLeft x of Sealed y -> case toFL xs of Sealed ys -> Sealed (y :>: ys) 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@(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 wX wY -> FL a wX wZ -> EqCheck wY wZ eqFL NilFL NilFL = IsEq eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq eqFL _ _ = NotEq eqFLRev :: MyEq a => FL a wX wZ -> FL a wY wZ -> EqCheck wX wY eqFLRev NilFL NilFL = IsEq eqFLRev (x:>:xs) (y:>:ys) | IsEq <- eqFLRev xs ys, IsEq <- x =/\= y = IsEq eqFLRev _ _ = NotEq eqFLUnsafe :: MyEq a => FL a wX wY -> FL a wZ wW -> Bool eqFLUnsafe NilFL NilFL = True eqFLUnsafe (x:>:xs) (y:>:ys) = unsafeCompare x y && eqFLUnsafe xs ys eqFLUnsafe _ _ = False darcs-2.10.2/src/Darcs/Patch/Annotate.hs0000644000175000017500000002334312620122474021716 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE CPP, 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.Patch.Annotate -- Copyright : 2010 Petr Rockai -- License : MIT -- Maintainer : darcs-devel@darcs.net -- Stability : experimental -- Portability : portable module Darcs.Patch.Annotate ( annotate , annotateDirectory , format , machineFormat , AnnotateResult ) 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.Function ( on ) import Data.List( nub, groupBy ) import Data.Maybe( isJust, mapMaybe ) import Control.Monad.State ( modify, when, gets, State, execState ) import Control.Applicative( (<$>) ) import Darcs.Patch.ApplyMonad( ApplyMonad(..) ) import Darcs.Patch.Apply ( Apply, apply, ApplyState ) import Darcs.Patch.Info ( PatchInfo(..), showPatchInfoUI, piAuthor, makePatchname ) import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd ) import Darcs.Patch.Witnesses.Ordered import Storage.Hashed.Tree( Tree ) import Darcs.Util.Path ( FileName, movedirfilename, fn2ps, ps2fn ) import Darcs.Util.Printer( renderString, RenderMode(..) ) import Darcs.Util.ByteString ( linesPS, unlinesPS ) import Darcs.Util.Diff ( getChanges ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) #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 , diffAlgorithm :: D.DiffAlgorithm } deriving Show type AnnotateResult = V.Vector (Maybe PatchInfo, B.ByteString) 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 da <- gets diffAlgorithm reannotate $ getChanges da 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 annotate' :: (Apply p, ApplyState p ~ Tree) => FL (PatchInfoAnd p) wX wY -> 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) => D.DiffAlgorithm -> FL (PatchInfoAnd p) wX wY -> FileName -> B.ByteString -> AnnotateResult annotate da patches inipath inicontent = annotated $ 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) , diffAlgorithm = da } annotateDirectory :: (Apply p, ApplyState p ~ Tree) => D.DiffAlgorithm -> FL (PatchInfoAnd p) wX wY -> FileName -> [FileName] -> AnnotateResult annotateDirectory da patches inipath inicontent = annotated $ 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) , diffAlgorithm = da } 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 Encode (showPatchInfoUI 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 $ 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) = 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 darcs-2.10.2/src/Darcs/Patch/CommuteFn.hs0000644000175000017500000000642012620122474022037 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterFLId, commuterIdRL, commuterRLId, MergeFn, mergerIdFL, TotalCommuteFn, totalCommuterIdFL, totalCommuterFLId, totalCommuterFLFL ) where 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. 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 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'') 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'') 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'' 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 ((x :<: xs) :> y) = do y' :> x' <- commuter (x :> y) y'' :> xs' <- commuterRLId commuter (xs :> y') return (y'' :> (x' :<: xs')) 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') totalCommuterFLFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) (FL p2) totalCommuterFLFL commuter = totalCommuterFLId (totalCommuterIdFL commuter)darcs-2.10.2/src/Darcs/Patch/V2.hs0000644000175000017500000000057212620122474020433 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V2 ( RealPatch, prim2real ) where import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.V2.Real ( RealPatch, prim2real ) instance PrimPatch prim => Matchable (RealPatch prim) instance PrimPatch prim => RepoPatch (RealPatch prim) darcs-2.10.2/src/Darcs/Patch/Progress.hs0000644000175000017500000000504212620122474021745 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, GADTs #-} module Darcs.Patch.Progress ( progressRL , progressFL , progressRLShowTags ) where 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@(x :<: xs) = if xxsLen < minlist then xxs else startProgress x k xxsLen :<: pl xs where xxsLen = lengthRL xxs pl :: RL a wX wY -> RL a wX wY 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) wX wY -> RL (PatchInfoAnd p) wX wY progressRLShowTags _ NilRL = NilRL progressRLShowTags k xxs@(x :<: xs) = if xxsLen < minlist then xxs else startProgress x k xxsLen :<: pl xs where xxsLen = lengthRL xxs pl :: RL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY 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 darcs-2.10.2/src/Darcs/Patch/Debug.hs0000644000175000017500000000156412620122474021174 0ustar00guillaumeguillaume00000000000000module 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) darcs-2.10.2/src/Darcs/Patch/V1.hs0000644000175000017500000000110512620122474020423 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1 ( Patch ) where import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.V1.Apply () import Darcs.Patch.V1.Commute () import Darcs.Patch.V1.Core ( Patch ) import Darcs.Patch.V1.Read () import Darcs.Patch.V1.Show () import Darcs.Patch.V1.Viewing () instance PrimPatch prim => Patchy (Patch prim) instance PrimPatch prim => Matchable (Patch prim) instance PrimPatch prim => RepoPatch (Patch prim) darcs-2.10.2/src/Darcs/Patch/Permutations.hs0000644000175000017500000003110712620122474022634 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2002-2003 David Roundy -- Copyright (C) 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_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon, commuteWhatWeCanFL, commuteWhatWeCanRL, genCommuteWhatWeCanRL, genCommuteWhatWeCanFL, partitionFL, partitionRL, simpleHeadPermutationsFL, headPermutationsRL, headPermutationsFL, removeSubsequenceFL, removeSubsequenceRL, partitionConflictingFL, inverseCommuter ) where import Data.Maybe ( mapMaybe ) import Darcs.Patch.Commute ( Commute, commute, commuteFLorComplain, commuteRL ) import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+<+) , reverseFL, (+>+), (:\/:)(..), lengthFL , lengthRL, reverseRL ) #include "impossible.h" -- |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. -- Note that @p@ should be invariant under commutation (i.e. if 'x1' can commute to 'x2' then 'p x1 <=> p x2'). partitionFL :: Commute p => (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" -- optimise by using an accumulating parameter to track all the "right" patches that we've found so far partitionFL' :: Commute p => (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 :> FL p :> FL p) wA wD partitionFL keepleft = partitionFL' keepleft NilRL NilRL partitionFL' _ middle right NilFL = NilFL :> reverseRL middle :> reverseRL 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 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 -- optimise by using an accumulating parameter to track all the "left" patches that we've found so far partitionRL' :: Commute p => (forall wU wV . p wU wV -> Bool) -> RL p wX wZ -> FL p wZ wY -- the "left" patches found so far -> (RL p :> RL p) wX wY partitionRL keepright ps = partitionRL' keepright ps NilFL partitionRL' _ NilRL qs = reverseFL qs :> NilRL 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 genCommuteWhatWeCanFL :: Commute q => (forall wA wB . ((p:>q) wA wB -> Maybe ((q:>p)wA wB))) -> (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) wX wY -> (RL p :> p :> RL p) wX wY commuteWhatWeCanRL = genCommuteWhatWeCanRL commute genCommuteWhatWeCanRL :: Commute p => (forall wA wB . ((p :> q) wA wB -> Maybe ((q :> p) wA wB))) -> (RL p :> q) wX wY -> (RL p :> q :> RL p) wX wY genCommuteWhatWeCanRL com (x :<: xs :> 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 a :> p'' :> c -> a :> p'' :> x' :<: c genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL removeCommon :: (MyEq 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 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 -- | '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 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 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 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 wY wZ -> [RL p wX wZ] -> Maybe (RL p wX wY) r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs | otherwise = r z zss r _ _ = Nothing -- | 'removeSubsequenceFL' @ab abc@ returns @Just c'@ where all the patches in -- @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 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 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 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 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 -- | This is a minor variant of 'headPermutationsFL' with each permutation -- is simply returned as a 'FL' 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 -- in which one element of @ps@ is commuted past @p@ -- -- Suppose we have a sequence of patches -- -- > X h a y s-t-c k -- -- Suppose furthermore that the patch @c@ depends on @t@, which in turn -- depends on @s@. This function will return -- -- > X :> h a y s t c k -- > h :> X a y s t c k -- > a :> X h y s t c k -- > 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 wX wY -> [(p :> FL p) wX wY] headPermutationsFL NilFL = [] headPermutationsFL (p:>:ps) = (p:>ps) : mapMaybe (swapfirstFL.(p:>)) (headPermutationsFL ps) where swapfirstFL (p1:>p2:>xs) = do p2':>p1' <- commute (p1:>p2) Just $ p2':>p1':>:xs -- | '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 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 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 wX wY -> FL p wX wZ -> EqCheck wY wZ 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 (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 wX wY -> RL p wW wY -> EqCheck wX wW cmpSameLength (x:<:xs) xys | Just ys <- removeRL x xys = cmpSameLength xs ys cmpSameLength NilRL NilRL = IsEq cmpSameLength _ _ = NotEq xs =\/= ys = reverseRL xs =\/= reverseRL ys -- |Partition a list into the patches that merge with the given patch and those that don't (including dependencies) partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 wX wY -> p2 wX wZ -> (FL p1 :> FL p1) wX wY 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 inverseCommuter :: (Invert p, Invert q) => CommuteFn p q -> CommuteFn q p inverseCommuter commuter (p :> q) = do invp' :> invq' <- commuter (invert q :> invert p) return (invert invq' :> invert invp') darcs-2.10.2/src/Darcs/Patch/Dummy.hs0000644000175000017500000000506712620122474021243 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE EmptyDataDecls #-} module Darcs.Patch.Dummy ( DummyPatch ) where import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Patchy ( Patchy, ShowPatch, Invert, Commute, Apply(..), PatchInspect , ReadPatch ) import Darcs.Patch.Prim ( FromPrim, PrimPatch, PrimPatchBase(..) ) import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize, PrimClassify , PrimDetails, PrimShow, PrimRead, PrimApply ) import Darcs.Patch.Merge ( Merge) import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( Check, RepairToFL ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Witnesses.Eq ( MyEq ) import Storage.Hashed.Tree( Tree ) data DummyPrim wX wY data DummyPatch wX wY instance IsHunk DummyPrim instance PatchListFormat DummyPrim instance MyEq DummyPrim instance Invert DummyPrim instance PatchInspect DummyPrim instance ReadPatch DummyPrim instance ShowPatchBasic DummyPrim instance ShowPatch DummyPrim instance Commute DummyPrim instance Apply DummyPrim instance Patchy DummyPrim instance RepairToFL DummyPrim instance PrimConstruct DummyPrim instance PrimCanonize DummyPrim instance PrimClassify DummyPrim instance PrimDetails DummyPrim instance PrimShow DummyPrim instance PrimRead DummyPrim instance PrimApply DummyPrim instance PrimPatch DummyPrim instance PatchDebug DummyPrim 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 Matchable DummyPatch instance Patchy DummyPatch instance Effect DummyPatch instance Merge DummyPatch instance Conflict DummyPatch instance FromPrim DummyPatch instance CommuteNoConflicts DummyPatch instance Check DummyPatch instance RepairToFL DummyPatch instance PrimPatchBase DummyPatch where type PrimOf DummyPatch = DummyPrim instance MaybeInternal DummyPatch instance NameHack DummyPatch instance RecontextRebase DummyPatch instance RepoPatch DummyPatch instance PatchDebug DummyPatch darcs-2.10.2/src/Darcs/Patch/Conflict.hs0000644000175000017500000001152012620122474021700 0ustar00guillaumeguillaume00000000000000module 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.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) , mapFL, reverseFL, mapRL, reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed, unseal ) import Darcs.Patch.Witnesses.Show ( Show2, showsPrec2 ) import Darcs.Util.Show ( appPrec ) import Data.List.Ordered ( nubSort ) class (Effect p, PatchInspect (PrimOf p)) => Conflict p where listConflictedFiles :: p wX wY -> [FilePath] listConflictedFiles p = nubSort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p resolveConflicts :: p wX wY -> [[Sealed (FL (PrimOf p) wY)]] conflictedEffect :: p wX wY -> [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) wX wY -> Maybe ((p :> p) wX wY) 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' instance (CommuteNoConflicts p, Conflict p) => Conflict (RL p) where listConflictedFiles = nubSort . concat . mapRL listConflictedFiles resolveConflicts x = rcs x NilFL where rcs :: RL p wX wY -> FL p wY wW -> [[Sealed (FL (PrimOf p) wW)]] 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 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' data IsConflictedPrim prim where IsC :: !ConflictState -> !(prim wX wY) -> IsConflictedPrim prim data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read) 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 commuteNoConflictsFL :: CommuteNoConflicts p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY) 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'') commuteNoConflictsRL :: CommuteNoConflicts p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY) 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') commuteNoConflictsRLFL :: CommuteNoConflicts p => (RL p :> FL p) wX wY -> Maybe ((FL p :> RL p) wX wY) 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'') darcs-2.10.2/src/Darcs/Patch/ReadMonads.hs0000644000175000017500000002515712620122474022167 0ustar00guillaumeguillaume00000000000000-- | 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 Darcs.Util.ByteString ( 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 Data.Foldable ( asum ) 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 = lswew where lswew x | B.null x = Nothing | BC.head x == en = Just $ [] :*: B.tail x | BC.head x /= st = Nothing | otherwise = 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 = asum -- |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 = SM 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 darcs-2.10.2/src/Darcs/Patch/OldDate.hs0000644000175000017500000003364212620122474021464 0ustar00guillaumeguillaume00000000000000-- 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 ((<|>) . (\x -> try $ count x p)) (return []) $ 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] dayAndHMSTime :: CharParser a (Int, Int, Int, Int) dayAndHMSTime = do d <- day _ <- mySpaces h <- hour _ <- char ':' m <- minute _ <- char ':' s <- second return (d, h, m, s) cvsDateTime :: Int -> CharParser a CalendarTime cvsDateTime tz = do y <- year _ <- char '/' mon <- monthNum _ <- char '/' (d, h, m, s) <- dayAndHMSTime 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, h, m, s) <- dayAndHMSTime _ <- 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 [ char '+' >> return 1 , 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 darcs-2.10.2/src/Darcs/Patch/Split.hs0000644000175000017500000002203512620122474021235 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, RankNTypes, GADTs, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- 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.Patch.Split ( Splitter(..), rawSplitter, noSplitter, primSplitter, reversePrimSplitter ) where import Data.List ( intersperse ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed 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 () import Darcs.Patch.Viewing () import Darcs.Util.Printer ( renderPS, RenderMode(..) ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -- |A splitter is something that can take a patch and (possibly) render it -- as text in some format of its own choosing. -- This text can then be presented to the user for editing, and the result -- given to the splitter for parsing. -- If the parse succeeds, the result is a list of patches that could replace -- the original patch in any context. -- Typically this list will contain the changed version of the patch, along -- with fixup pieces to ensure that the overall effect of the list is the same -- as the original patch. -- The individual elements of the list can then be offered separately to the -- user, allowing them to accept some and reject others. -- -- There's no immediate application for a splitter for anything other than -- 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 wX wY . D.DiffAlgorithm -> 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 . D.DiffAlgorithm -> FL p wX wY -> FL p wX wY } {- Some facts that probably ought to be true about splitters: should make some QC properties applySplitter p = Just (bs, f) ==> f bs == Just (p :>: NilFL) applySplitter p = Just (bs, f) ; f bs' = Just ps ==> canonizeSplit ps = p :>: NilFL -} -- Does not canonize as there is no generic operation to do this. 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. rawSplitter :: (ShowPatch p, ReadPatch p, Invert p) => Splitter p rawSplitter = Splitter { applySplitter = \_ p -> Just (renderPS Standard . showPatch $ p, \str -> case parseStrictly readPatch' str of Just (Sealed res, _) -> Just (withEditedHead p res) _ -> Nothing ) ,canonizeSplit = \_ b -> id b } -- |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 = \_ b -> id b } 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" , "" ] doPrimSplit_ :: (PrimPatch prim, IsHunk p) => 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) =========================="] , before , [mkSep "=== AFTER (edit) ============================="] , after , [mkSep "=== (edit above) ============================="] ], \bs -> do let ls = BC.split '\n' bs (_, ls2) <- breakSep ls -- before (before', ls3) <- breakSep ls2 -- after 1 (after', _) <- breakSep ls3 -- after return $ if edit_before_part 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 wA wB hunk b a = canonize da (primFromHunk (FileHunk fn n b a)) 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 -- |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 } 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" , "" ] reversePrimSplitter :: PrimPatch prim => Splitter prim reversePrimSplitter = Splitter { applySplitter = doReversePrimSplit , canonizeSplit = canonizeFL} darcs-2.10.2/src/Darcs/Patch/RepoPatch.hs0000644000175000017500000000215712620122474022032 0ustar00guillaumeguillaume00000000000000module 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.Inspect ( PatchInspect ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.MaybeInternal ( MaybeInternal ) 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.Read ( ReadPatch ) import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( RepairToFL, Check ) import Darcs.Patch.Show ( ShowPatch ) class (Patchy p, Merge p, Effect p, IsHunk p, PatchInspect p, ReadPatch p, ShowPatch p, FromPrim p, Conflict p, CommuteNoConflicts p, Check p, RepairToFL p, PatchListFormat p, PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p), MaybeInternal p, RecontextRebase p, NameHack p, Matchable p ) => RepoPatch p darcs-2.10.2/src/Darcs/Patch/Summary.hs0000644000175000017500000001256712620122474021610 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Summary ( plainSummary, plainSummaryPrim, plainSummaryPrims, xmlSummary ) where import Darcs.Util.Path ( fn2fp ) import Darcs.Patch.Conflict ( Conflict(..), IsConflictedPrim(IsC), ConflictState(..) ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.Prim.Class ( PrimDetails(..), PrimPatchBase ) import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) import Darcs.Util.Printer ( Doc, empty, vcat, text, minus, plus, ($$), (<+>), (<>), ) plainSummaryPrim :: PrimDetails prim => prim wX wY -> Doc plainSummaryPrim = vcat . map summChunkToLine . genSummary . (:[]) . IsC Okay plainSummaryPrims :: PrimDetails prim => FL prim wX wY -> Doc plainSummaryPrims = vcat . map summChunkToLine . genSummary . mapFL (IsC Okay) plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e wX wY -> Doc plainSummary = vcat . map summChunkToLine . genSummary . conflictedEffect xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p wX wY -> Doc xmlSummary p = text "" $$ (vcat . map summChunkToXML . genSummary . conflictedEffect $ p) $$ text "" -- Yuck duplicated code below... escapeXML :: String -> Doc escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z: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 data SummChunk = SummChunk SummDetail ConflictState deriving (Ord, Eq) genSummary :: forall p . PrimDetails p => [IsConflictedPrim p] -> [SummChunk] genSummary p = combine $ concatMap s2 p where s2 :: IsConflictedPrim p -> [SummChunk] 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 combine (x:ss) = x : combine ss combine [] = [] -- combineDetail (SummFile o1 f1 r1 a1 x1) (SummFile o2 f2 r2 a2 x2) | f1 == f2 = do o3 <- combineOp o1 o2 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 -- 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 combineOp SummRm SummAdd = Nothing combineOp SummAdd _ = Just SummAdd combineOp _ SummAdd = Just SummAdd combineOp SummRm _ = Just SummRm combineOp _ SummRm = Just SummRm combineOp SummMod SummMod = Just SummMod summChunkToXML :: SummChunk -> Doc summChunkToXML (SummChunk detail c) = case detail of SummRmDir f -> xconf c "remove_directory" (xfn f) SummAddDir f -> xconf c "add_directory" (xfn f) SummFile SummRm f _ _ _ -> xconf c "remove_file" (xfn f) SummFile SummAdd f _ _ _ -> xconf c "add_file" (xfn f) SummFile SummMod f r a x -> xconf c "modify_file" $ xfn f <> xrm r <> xad a <> xrp x SummMv f1 f2 -> text " xfn f1 <> text "\" to=\"" <> xfn f2 <> text"\"/>" SummNone -> empty where xconf Okay t x = text ('<':t++">") $$ x $$ text ("") xconf Conflicted t x = text ('<':t++" conflict='true'>") $$ x $$ text ("") xconf Duplicated t x = text ('<':t++" duplicate='true'>") $$ x $$ text ("") xfn = escapeXML . dropDotSlash .fn2fp -- xad 0 = empty xad a = text "" xrm 0 = empty xrm a = text "" xrp 0 = empty xrp a = text "" summChunkToLine :: SummChunk -> Doc summChunkToLine (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) 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" -- ad 0 = empty ad a = plus <> text (show a) rm 0 = empty 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 darcs-2.10.2/src/Darcs/Patch/Index/0000755000175000017500000000000012620122474020653 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Index/Monad.hs0000644000175000017500000000777412620122474022264 0ustar00guillaumeguillaume00000000000000-- 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. {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} module Darcs.Patch.Index.Monad ( FileModMonad, withPatchMods ) where import Darcs.Patch.Index.Types ( PatchMod(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Control.Applicative ( Applicative ) import Control.Monad.State import Control.Arrow import Darcs.Util.Path ( FileName, fn2fp, movedirfilename ) import qualified Data.Set as S import Data.Set ( Set ) import Data.List ( isPrefixOf ) import Storage.Hashed.Tree (Tree) #include "impossible.h" newtype FileModMonad a = FMM (State (Set FileName, [PatchMod FileName]) a) deriving (Functor, Applicative, Monad, MonadState (Set FileName, [PatchMod FileName])) withPatchMods :: FileModMonad a -> Set FileName -> (Set FileName, [PatchMod FileName]) withPatchMods (FMM m) fps = second reverse $ execState m (fps,[]) -- These instances are defined to be used only with -- apply. instance ApplyMonad FileModMonad Tree where type ApplyMonadBase FileModMonad = FileModMonad mDoesDirectoryExist d = do fps <- gets fst return $ S.member d fps mDoesFileExist f = do fps <- gets fst return $ S.member f fps mReadFilePS _ = bug "mReadFilePS FileModMonad" nestedApply _ _ = bug "nestedApply FileModMonad" liftApply _ _ = bug "liftApply FileModMonad" getApplyState = bug "getApplyState FileModMonad" putApplyState _ = bug "putApplyState FileModMonad" mCreateFile = createFile mCreateDirectory = createDir mRemoveFile = remove mRemoveDirectory = remove mRename a b = do fns <- gets fst if S.notMember a fns then addMod (PInvalid a) -- works around some old repo inconsistencies else do -- we have to account for directory moves addMod (PRename a b) modifyFps (S.delete a) addFile b forM_ (S.toList fns) $ \fn -> when (fn2fp a `isPrefixOf` fn2fp fn) $ do modifyFps (S.delete fn) let newfn = movedirfilename a b fn addFile newfn addMod (PRename fn newfn) mModifyFilePS f _ = addMod (PTouch f) mModifyFilePSs f _ = addMod (PTouch f) -- --------------------------------------------------------------------- -- State Handling Functions addMod :: PatchMod FileName -> FileModMonad () addMod pm = modify $ second (pm :) addFile :: FileName -> FileModMonad () addFile f = modifyFps (S.insert f) createFile :: FileName -> FileModMonad () createFile fn = do errorIfPresent fn True addMod (PCreateFile fn) addFile fn createDir :: FileName -> FileModMonad () createDir fn = do errorIfPresent fn False addMod (PCreateDir fn) addFile fn errorIfPresent :: FileName -> Bool -> FileModMonad () errorIfPresent fn isFile = do fs <- gets fst when (S.member fn fs) $ error $ unwords [ "error: patch index entry for" , if isFile then "file" else "directory" , fn2fp fn , "created >1 times" ] remove :: FileName -> FileModMonad () remove f = addMod (PRemove f) >> modifyFps (S.delete f) modifyFps :: (Set FileName -> Set FileName) -> FileModMonad () modifyFps f = modify $ first f darcs-2.10.2/src/Darcs/Patch/Index/Types.hs0000644000175000017500000000614712620122474022323 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE DeriveFunctor #-} -- 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.Util.Crypt.SHA1( SHA1(..) ) import Darcs.Util.Path ( fp2fn, fn2fp, FileName ) import Darcs.Patch.Info ( makePatchname, PatchInfo ) import Data.Binary ( Binary(..) ) import Data.Word ( Word32 ) -- | 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::FileName,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 -- | Parse FileId from a string parseFileId :: String -> FileId parseFileId s = let (f,'.':i) = break (=='.') s in FileId (fp2fn f) (read i) -- | Convert FileId to string showFileId :: FileId -> String showFileId (FileId fn i) = show i++"#"++fn2fp fn -- | The PatchId identifies a patch and can be created from a PatchInfo with makePatchname newtype PatchId = PID {patchId :: SHA1} deriving (Show,Ord,Eq) instance Binary PatchId where put (PID p) = put p get = PID `fmap` get pid2string :: PatchId -> String pid2string = show . patchId -- | describes a filepath that is interpreted relative to a certain -- point in the history of the repository. The point is given by -- Just pid which denotes the history up to (including) pid or -- Nothing which denotes the history including the last patch data DatedFilePath = DatedFilePath FilePath (Maybe PatchId) -- | This is used to track changes to files data PatchMod a = PTouch a | PCreateFile a | PCreateDir a | PRename a a | PRemove a | PInvalid a -- ^ This is an invalid patch -- e.g. there is a patch 'Move Autoconf.lhs Autoconf.lhs.in' -- where there is no Autoconf.lhs in the darcs repo | 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) makePatchID :: PatchInfo -> PatchId makePatchID = PID . makePatchname short :: PatchId -> Word32 short (PID (SHA1 a _ _ _ _)) = a darcs-2.10.2/src/Darcs/Patch/Repair.hs0000644000175000017500000000426412620122474021370 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Repair ( Repair(..), RepairToFL(..), mapMaybeSnd, Check(..) ) where import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), mapFL, mapRL, (+>+) ) import Darcs.Util.Printer ( Doc ) import Data.Maybe ( catMaybes, listToMaybe ) class Check p where 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. class Repair p where applyAndTryToFix :: ApplyMonad m (ApplyState p) => 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. class Apply p => RepairToFL p where applyAndTryToFixFL :: ApplyMonad m (ApplyState p) => 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) mapMaybeSnd f (Just (a,b)) = Just (a,f b) mapMaybeSnd _ Nothing = Nothing instance Check p => Check (FL p) where isInconsistent = listToMaybe . catMaybes . mapFL isInconsistent instance Check p => Check (RL p) where isInconsistent = listToMaybe . catMaybes . mapRL isInconsistent 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') darcs-2.10.2/src/Darcs/Patch/Info.hs0000644000175000017500000003442012620122474021036 0ustar00guillaumeguillaume00000000000000-- 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.Patch.Info ( PatchInfo(..), patchinfo, invertName, rawPatchInfo, addJunk, makePatchname, makeFilename, readPatchInfo, justName, justAuthor, justLog, showPatchInfoUI, toXml, piDate, setPiDate, piDateString, piDateBytestring, piName, piRename, piAuthor, piTag, piLog, showPatchInfo, isTag, readPatchInfos, escapeXML ) where import System.Random ( randomRIO ) import Numeric ( showHex ) import Control.Monad ( when, unless, void ) import Darcs.Util.ByteString ( 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, takeTillChar, linesStartingWithEndingWith) 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 Data.List( isPrefixOf ) import Darcs.Util.Printer ( Doc, packedString, empty, ($$), (<>), (<+>), vcat, text, cyanText, blueText, prefix ) import Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime, toCalendarTime ) import System.IO.Unsafe ( unsafePerformIO ) import Darcs.Util.Crypt.SHA1 ( sha1PS, SHA1 ) import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Show ( appPrec ) import Prelude hiding (pi, log) -- | 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) instance Show PatchInfo where showsPrec d (PatchInfo date name author log inverted) = showParen (d > appPrec) $ showString "rawPatchInfo " . showsPrec (appPrec + 1) date . showString " " . showsPrec (appPrec + 1) name . showString " " . showsPrec (appPrec + 1) author . showString " " . showsPrec (appPrec + 1) log . showString " " . showsPrec (appPrec + 1) inverted rawPatchInfo :: String -> String -> String -> [String] -> Bool -> PatchInfo rawPatchInfo date name author log inverted = PatchInfo { _piDate = BC.pack date , _piName = packStringToUTF8 name , _piAuthor = packStringToUTF8 author , _piLog = map packStringToUTF8 log , isInverted = inverted } -- | @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 $ rawPatchInfo 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) when (_piLog pinf /= ignoreJunk (_piLog pinf)) $ do putStrLn "Lines beginning with 'Ignore-this: ' will be ignored." confirmed <- promptYorn "Proceed? " unless confirmed $ fail "User cancelled because of Ignore-this." return $ pinf { _piLog = BC.pack (head ignored++showHex x ""): _piLog pinf } ignored :: [String] -- this is a [String] so we can change the junk header. 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 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. justName :: PatchInfo -> String justName pinf = if isInverted pinf then "UNDO: " ++ nameString else nameString where nameString = metadataToString (_piName pinf) -- | Returns the author of a patch. justAuthor :: PatchInfo -> String justAuthor = metadataToString . _piAuthor justLog :: PatchInfo -> String justLog = unlines . map BC.unpack . _piLog showPatchInfoUI :: PatchInfo -> Doc showPatchInfoUI 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 " *" -- | Returns the name of the patch. Unlike 'justName', it does not preprend -- "UNDO: " to the name if the patch is inverted. piName :: PatchInfo -> String piName = metadataToString . _piName piRename :: PatchInfo -> String -> PatchInfo piRename x n = x { _piName = packStringToUTF8 n } -- | Returns the author of a patch. piAuthor :: PatchInfo -> String piAuthor = metadataToString . _piAuthor 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. readPatchDate :: B.ByteString -> CalendarTime readPatchDate = ignoreTz . readUTCDate . BC.unpack where ignoreTz ct = ct { ctTZ = 0 } piDate :: PatchInfo -> CalendarTime piDate = readPatchDate . _piDate 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 -- | Get the tag name, if the patch is a tag patch. piTag :: PatchInfo -> Maybe String piTag pinf = if l == t then Just $ metadataToString r else Nothing where (l, r) = B.splitAt (B.length t) (_piName pinf) t = BC.pack "TAG " -- | Convert a metadata ByteString to a string. It first tries to convert -- using UTF-8, and if that fails, tries the locale encoding. -- 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 | '\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 = text " 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 (show $ makePatchname pi) <> text "'>" $$ prefix "\t" ( text "" <> escapeXMLByteString (_piName pi) <> text "" $$ commentsAsXml (_piLog pi)) $$ text "" commentsAsXml :: [B.ByteString] -> Doc commentsAsXml comments | B.length comments' > 0 = text "" <> escapeXMLByteString comments' <> text "" | otherwise = empty where comments' = unlinesPS comments -- escapeXML is duplicated in Patch.lhs and Annotate.lhs -- It should probably be refactored to exist in one place. escapeXML :: String -> Doc escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" -- Escape XML characters in a UTF-8 encoded ByteString, and turn it into a Doc. -- The data will be in the Doc as a bytestring. escapeXMLByteString :: B.ByteString -> Doc escapeXMLByteString = packedString . bstrReplace '\'' "'" . bstrReplace '"' """ . bstrReplace '>' ">" . bstrReplace '<' "<" . bstrReplace '&' "&" strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z: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 | otherwise = if BC.head bs == c then B.append (BC.pack s) (bstrReplace c s (B.tail bs)) else B.cons (B.head bs) (bstrReplace c s (B.tail bs)) -- | 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 = showIsoDateTime d++"-"++sha1_a++"-"++ (show $ makePatchname pi) ++ ".gz" where d = readPatchDate $ _piDate pi sha1_a = take 5 $ show $ sha1PS $ _piAuthor pi -- | Hash on patch metadata (patch name, author, date, log, and \"inverted\" -- flag. Robust against context changes but does not garantee 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] -- |Patch is stored between square brackets. -- -- > [ -- > * -- > (indented one) -- > -- > -- > -- > ] -- -- note that below I assume the name has no newline in it. -- See 'readPatchInfo' for the inverse operation. showPatchInfo :: PatchInfo -> Doc showPatchInfo pi = blueText "[" <> packedString (_piName pi) $$ packedString (_piAuthor pi) <> text inverted <> packedString (_piDate pi) <> myunlines (_piLog pi) <> blueText "] " where inverted = if isInverted pi then "*-" else "**" myunlines [] = empty myunlines xs = foldr (\s -> ((text "\n " <> packedString s) <>)) (text "\n") xs -- |Parser for 'PatchInfo' as stored in patch bundles and inventory files, -- for example: -- -- > [Document the foo interface -- > John Doe **20110615084241 -- > Ignore-this: 85b94f67d377c4ab671101266ef9c229 -- > Nobody knows what a 'foo' is, so describe it. -- > ] -- -- See 'showPatchInfo' for the inverse operation. readPatchInfo :: ParserM m => m PatchInfo readPatchInfo = do skipSpace char '[' name <- takeTillChar '\n' _ <- anyChar author <- takeTillChar '*' s2 <- RM.take 2 ct <- takeTill (\c->c==']'||c=='\n') 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 _ -> [] darcs-2.10.2/src/Darcs/Patch/Rebase/0000755000175000017500000000000012620122474021005 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Patch/Rebase/Recontext.hs0000644000175000017500000000321112620122474023311 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2012 Ganesh Sittampalam -- -- BSD3 module Darcs.Patch.Rebase.Recontext ( RecontextRebase(..) , RecontextRebase1(..) , RecontextRebase2(..) ) where import Darcs.Patch.Named ( Named ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup ) import Darcs.Patch.Witnesses.Eq ( EqCheck ) import Darcs.Patch.Witnesses.Ordered ( FL ) -- |Check whether a given patch is a suspended rebase patch, and if so provide -- evidence that the start and end contexts are the same (from the point of view -- of the containing repo), and return a function that produces a new version -- with some fixups added. -- -- Nested in a type to avoid needing an impredicative argument to 'Maybe'. newtype RecontextRebase1 p = RecontextRebase1 { recontextFunc1 :: forall wY wZ . Named p wY wZ -> (EqCheck wY wZ, RecontextRebase2 p wY wZ) } -- |Return a suspended patch with the given fixups added. -- -- Nested in a type to avoid needing an impredicative argument to a tuple. newtype RecontextRebase2 p wY wZ = RecontextRebase2 { recontextFunc2 :: forall wX . FL (RebaseFixup p) wX wY -> IO (Named p wX wX) } -- |Some non-rebase code needs to manipulate the rebase state if one exists. -- This class provides the hook for them to do so without needing to explicitly -- detect that there is a rebase state: 'recontextRebase' abstracts out that -- information. -- -- The hook is used in amend-record - look there for an explanation of how. -- -- There is a default so that other patch types only need to declare the instance. class RecontextRebase p where recontextRebase :: Maybe (RecontextRebase1 p) recontextRebase = Nothingdarcs-2.10.2/src/Darcs/Patch/Rebase/Fixup.hs0000644000175000017500000001425012620122474022436 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2011-2 Ganesh Sittampalam -- -- BSD3 {-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) , commuteNamedFixup, commuteFixupNamed, commuteNamedFixups , flToNamesPrims ) where import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..), selfCommuter ) import Darcs.Patch.CommuteFn ( totalCommuterIdFL ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.Prim ( FromPrim(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Named ( Named(..), commuterNamedId, commuterIdNamed ) import Darcs.Patch.Prim ( PrimPatchBase, PrimOf ) import Darcs.Patch.Rebase.Name ( RebaseName , commuteNamedName, commuteNameNamed , commutePrimName, commuteNamePrim ) import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, (:>)(..), (+>+) ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), showsPrec2 , ShowDict(ShowDictClass), appPrec ) -- |A single rebase fixup, needed to ensure that the actual patches -- being stored in the rebase state have the correct context. data RebaseFixup p wX wY where PrimFixup :: PrimOf p wX wY -> RebaseFixup p wX wY NameFixup :: RebaseName p wX wY -> RebaseFixup p wX wY instance Show2 (PrimOf p) => Show (RebaseFixup p 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 (PrimOf p) => Show1 (RebaseFixup p wX) where showDict1 = ShowDictClass instance Show2 (PrimOf p) => Show2 (RebaseFixup p) where showDict2 = ShowDictClass instance PrimPatchBase p => PrimPatchBase (RebaseFixup p) where type PrimOf (RebaseFixup p) = PrimOf p instance (PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseFixup p) where type ApplyState (RebaseFixup p) = ApplyState p apply (PrimFixup p) = apply p apply (NameFixup p) = apply p instance Effect (RebaseFixup p) where effect (PrimFixup p) = p :>: NilFL effect (NameFixup p) = effect p instance MyEq (PrimOf p) => MyEq (RebaseFixup p) where PrimFixup p1 `unsafeCompare` PrimFixup p2 = p1 `unsafeCompare` p2 PrimFixup _ `unsafeCompare` _ = False _ `unsafeCompare` PrimFixup _ = False NameFixup n1 `unsafeCompare` NameFixup n2 = n1 `unsafeCompare` n2 -- NameFixup _ `unsafeCompare` _ = False -- _ `unsafeCompare` NameFixup _ = False instance Invert (PrimOf p) => Invert (RebaseFixup p) where invert (PrimFixup p) = PrimFixup (invert p) invert (NameFixup n) = NameFixup (invert n) instance PatchInspect (PrimOf p) => PatchInspect (RebaseFixup p) 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 PrimPatchBase p => Commute (RebaseFixup p) 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') -- |Split a sequence of fixups into names and prims flToNamesPrims :: PrimPatchBase p => FL (RebaseFixup p) wX wY -> (FL (RebaseName p) :> FL (PrimOf p)) 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) -- Note that this produces a list result because of the need to use effect to -- extract the result. -- Some general infrastructure for commuting p with PrimOf p would be helpful here, commuteNamedPrim :: (FromPrim p, Effect p, Commute p) => (Named p :> PrimOf p) wX wY -> Maybe ((FL (PrimOf p) :> Named p) wX wY) commuteNamedPrim (p :> q) = do q' :> p' <- commuterNamedId selfCommuter (p :> fromPrim q) return (effect q' :> p') commutePrimNamed :: (FromPrim p, Effect p, Commute p) => (PrimOf p :> Named p) wX wY -> Maybe ((Named p :> FL (PrimOf p)) wX wY) commutePrimNamed (p :> q) = do q' :> p' <- commuterIdNamed selfCommuter (fromPrim p :> q) return (q' :> effect p') commuteNamedFixup :: (FromPrim p, Effect p, Commute p, Invert p) => (Named p :> RebaseFixup p) wX wY -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY) commuteNamedFixup (p :> PrimFixup q) = do qs' :> p' <- commuteNamedPrim (p :> q) return (mapFL_FL PrimFixup qs' :> p') commuteNamedFixup (p :> NameFixup n) = do n' :> p' <- commuteNamedName (p :> n) return ((NameFixup n' :>: NilFL) :> p') commuteNamedFixups :: (FromPrim p, Effect p, Commute p, Invert p) => (Named p :> FL (RebaseFixup p)) wX wY -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY) commuteNamedFixups (p :> NilFL) = return (NilFL :> p) commuteNamedFixups (p :> (q :>: rs)) = do qs' :> p' <- commuteNamedFixup (p :> q) rs' :> p'' <- commuteNamedFixups (p' :> rs) return ((qs' +>+ rs') :> p'') commuteFixupNamed :: (FromPrim p, Effect p, Commute p, Invert p) => (RebaseFixup p :> Named p) wX wY -> Maybe ((Named p :> FL (RebaseFixup p)) wX wY) commuteFixupNamed (PrimFixup p :> q) = do q' :> ps' <- commutePrimNamed (p :> q) return (q' :> mapFL_FL PrimFixup ps') commuteFixupNamed (NameFixup n :> q) = do q' :> n' <- commuteNameNamed (n :> q) return (q' :> (NameFixup n' :>: NilFL))darcs-2.10.2/src/Darcs/Patch/Rebase/Viewing.hs0000644000175000017500000005741412620122474022764 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2009 Ganesh Sittampalam -- -- BSD3 {-# LANGUAGE CPP, GADTs, UndecidableInstances #-} module Darcs.Patch.Rebase.Viewing ( RebaseSelect(..) , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect , partitionUnconflicted , rsToPia , WithDroppedDeps(..), WDDNamed, commuterIdWDD , RebaseChange(..), toRebaseChanges ) where import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterRLId, MergeFn , totalCommuterIdFL ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) , IsConflictedPrim ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat(..) ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Invert ( invertFL, invertRL ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.MaybeInternal ( MaybeInternal(..) ) import Darcs.Patch.Merge ( Merge(..), selfMerger ) import Darcs.Patch.Named ( Named(..), namepatch, infopatch , mergerIdNamed , adddeps, getdeps , patch2patchinfo, patchcontents ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..), ShowPatch(..), ReadPatch(..), PatchInspect(..) ) import Darcs.Patch.Prim ( PrimPatch, PrimPatchBase, PrimOf, FromPrim(..), FromPrims(..) ) import Darcs.Patch.Rebase ( Rebasing(..), RebaseItem(..) ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) , commuteFixupNamed, commuteNamedFixups , flToNamesPrims ) import Darcs.Patch.Rebase.Name ( RebaseName(..) ) import Darcs.Patch.Rebase.NameHack ( NameHack(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) , showsPrec2 ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) import Darcs.Util.IsoDate ( getIsoDateTime ) import Darcs.Util.Printer ( ($$), redText, empty, vcat ) import Darcs.Util.Show ( appPrec ) import Prelude hiding ( pi ) import Control.Applicative ( (<$>) ) import Data.List ( nub, (\\) ) import Data.Maybe ( fromMaybe ) #include "impossible.h" -- |Encapsulate a single patch in the rebase state together with its fixups. -- Used during interactive selection to make sure that each item presented -- to the user corresponds to a patch. data RebaseSelect p wX wY where -- The normal case for a RebaseSelect - a patch that points forwards. RSFwd :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseSelect p wX wZ -- We need an 'Invert' instance. We just represent inverses -- with a different constructor instead of trying to come up with some logical -- inversion of the individual components. Typically they get uninverted -- before anything significant is done with them, so a lot of code that -- processes 'RebaseSelect' patches just uses 'impossible' for 'RSRev'. RSRev :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseSelect p wZ wX instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseSelect p wX wY) where showsPrec d (RSFwd fixups toedit) = showParen (d > appPrec) $ showString "RSFwd " . showsPrec2 (appPrec + 1) fixups . showString " " . showsPrec2 (appPrec + 1) toedit showsPrec d (RSRev fixups toedit) = showParen (d > appPrec) $ showString "RSRev " . showsPrec2 (appPrec + 1) fixups . showString " " . showsPrec2 (appPrec + 1) toedit instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseSelect p wX) where showDict1 = ShowDictClass instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseSelect p) where showDict2 = ShowDictClass -- TODO: merge with RebaseSelect. -- |Used for displaying during 'rebase changes'. -- 'Named (RebaseChange p)' is very similar to 'RebaseSelect p' but slight -- mismatches ('Named' embeds an 'FL') makes it not completely trivial to merge -- them. data RebaseChange p wX wY where RCFwd :: FL (RebaseFixup p) wX wY -> FL p wY wZ -> RebaseChange p wX wZ RCRev :: FL (RebaseFixup p) wX wY -> FL p wY wZ -> RebaseChange p wZ wX instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseChange p wX) where showDict1 = ShowDictClass instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseChange p) where showDict2 = ShowDictClass instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseChange p wX wY) where showsPrec d (RCFwd fixups changes) = showParen (d > appPrec) $ showString "RCFwd " . showsPrec2 (appPrec + 1) fixups . showString " " . showsPrec2 (appPrec + 1) changes showsPrec d (RCRev fixups changes) = showParen (d > appPrec) $ showString "RCRev " . showsPrec2 (appPrec + 1) fixups . showString " " . showsPrec2 (appPrec + 1) changes -- |Get hold of the 'PatchInfoAnd' patch inside a 'RebaseSelect'. rsToPia :: RebaseSelect p wX wY -> Sealed2 (PatchInfoAnd p) rsToPia (RSFwd _ toEdit) = Sealed2 (n2pia toEdit) rsToPia (RSRev _ toEdit) = Sealed2 (n2pia toEdit) instance PrimPatchBase p => PrimPatchBase (RebaseSelect p) where type PrimOf (RebaseSelect p) = PrimOf p instance (PrimPatchBase p, PatchListFormat p, Conflict p, FromPrim p, Effect p, CommuteNoConflicts p, IsHunk p, Patchy p, ApplyState p ~ ApplyState (PrimOf p), NameHack p) => Patchy (RebaseSelect p) instance ( PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p) , Invert p ) => Patchy (RebaseChange p) instance PatchDebug p => PatchDebug (RebaseSelect p) instance PatchDebug p => PatchDebug (RebaseChange p) instance (PrimPatchBase p, Invert p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseSelect p) where type ApplyState (RebaseSelect p) = ApplyState p apply (RSFwd fixups toedit) = apply fixups >> apply toedit apply (RSRev fixups toedit) = apply (invert toedit) >> apply (invertFL fixups) instance ( PrimPatchBase p, Invert p, Apply p , ApplyState p ~ ApplyState (PrimOf p) ) => Apply (RebaseChange p) where type ApplyState (RebaseChange p) = ApplyState p apply (RCFwd fixups contents) = apply fixups >> apply contents apply (RCRev fixups contents) = apply (invert contents) >> apply (invertFL fixups) instance (PrimPatchBase p, FromPrim p, Conflict p, CommuteNoConflicts p, Invert p) => Conflict (RebaseSelect p) where resolveConflicts (RSFwd _ toedit) = resolveConflicts toedit resolveConflicts (RSRev{}) = impossible -- newtypes to help the type-checker with the 'changeAsMerge' abstraction newtype ResolveConflictsResult p wY = ResolveConflictsResult { getResolveConflictsResult :: [[Sealed (FL (PrimOf p) wY)]] } newtype ListConflictedFilesResult (p :: * -> * -> *) wY = ListConflictedFilesResult { getListConflictedFilesResult :: [FilePath] } newtype ConflictedEffectResult p wY = ConflictedEffectResult { getConflictedEffectResult :: [IsConflictedPrim (PrimOf p)] } changeAsMerge :: (PrimPatchBase p, Invert p, FromPrim p, Merge p) => (forall wX' . FL p wX' wY -> result p wY) -> RebaseChange p wX wY -> result p wY changeAsMerge f (RCFwd fixups changes) = case flToNamesPrims fixups of _names :> prims -> case merge (invert (fromPrims prims) :\/: changes) of changes' :/\: _ifixups' -> -- it might make sense to pass -- (changes' +>+ invert _ifixups') to resolveConflicts, -- but this isn't actually treated as a conflict by -- either V1 or V2 patches (not quite sure why) f (unsafeCoercePEnd changes') changeAsMerge _ (RCRev _ _) = impossible instance ( PrimPatchBase p, Invert p, Effect p , FromPrim p, Merge p, Conflict p, CommuteNoConflicts p ) => Conflict (RebaseChange p) where resolveConflicts = getResolveConflictsResult . changeAsMerge (ResolveConflictsResult . resolveConflicts) listConflictedFiles = getListConflictedFilesResult . changeAsMerge (ListConflictedFilesResult . listConflictedFiles) conflictedEffect = getConflictedEffectResult . changeAsMerge (ConflictedEffectResult . conflictedEffect) instance (PrimPatchBase p, Invert p, Effect p) => Effect (RebaseSelect p) where effect (RSFwd fixups toedit) = concatFL (mapFL_FL effect fixups) +>+ effect toedit effect (RSRev fixups toedit) = invertRL . reverseFL . effect $ RSFwd fixups toedit instance (PrimPatchBase p, Invert p, Effect p) => Effect (RebaseChange p) where effect (RCFwd fixups changes) = concatFL (mapFL_FL effect fixups) +>+ effect changes effect (RCRev fixups changes) = invertRL . reverseFL . effect $ RCFwd fixups changes instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseSelect p) where showPatch (RSFwd fixups toedit) = showPatch (Suspended (mapFL_FL Fixup fixups +>+ ToEdit toedit :>: NilFL)) showPatch (RSRev {}) = impossible instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseChange p) where showPatch (RCFwd fixups contents) = vcat (mapFL showPatch contents) $$ (if nullFL fixups then empty else redText "" $$ redText "conflicts:" $$ redText "" $$ vcat (mapRL showFixup (invertFL fixups)) ) where showFixup (PrimFixup p) = showPatch p showFixup (NameFixup n) = showPatch n showPatch (RCRev {}) = impossible instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (RebaseSelect p) where description (RSFwd _ toedit) = description toedit description (RSRev _ _toedit) = impossible summary = summaryFL . fromRebaseSelect . (:>: NilFL) summaryFL = summaryFL . fromRebaseSelect instance ( PrimPatchBase p, PatchListFormat p, ShowPatchBasic p , Invert p, Effect p, Merge p, FromPrim p , Conflict p, CommuteNoConflicts p ) => ShowPatch (RebaseChange p) where summary = plainSummary summaryFL = plainSummary instance ReadPatch p => ReadPatch (RebaseSelect p) where readPatch' = error "can't read RebaseSelect patches" instance ReadPatch (RebaseChange p) where readPatch' = error "can't read RebaseChange patches" -- |Turn a list of rebase items being rebased into a list suitable for use -- by interactive selection. Each actual patch being rebased is grouped -- together with any fixups needed. toRebaseSelect :: PrimPatchBase p => FL (RebaseItem p) wX wY -> FL (RebaseSelect p) wX wY -- |Turn a list of items back from the format used for interactive selection -- into a normal list fromRebaseSelect :: FL (RebaseSelect p) wX wY -> FL (RebaseItem p) wX wY fromRebaseSelect NilFL = NilFL fromRebaseSelect (RSFwd fixups toedit :>: ps) = mapFL_FL Fixup fixups +>+ ToEdit toedit :>: fromRebaseSelect ps fromRebaseSelect (RSRev {} :>: _) = impossible toRebaseSelect NilFL = NilFL toRebaseSelect (Fixup f :>: ps) = case toRebaseSelect ps of RSFwd fixups toedit :>: rest -> RSFwd (f :>: fixups) toedit :>: rest NilFL -> bug "rebase chain with Fixup at end" _ -> impossible toRebaseSelect (ToEdit te :>: ps) = RSFwd NilFL te :>: toRebaseSelect ps toRebaseChanges :: PrimPatchBase p => FL (RebaseItem p) wX wY -> FL (PatchInfoAnd (RebaseChange p)) wX wY toRebaseChanges = mapFL_FL toChange . toRebaseSelect toChange :: RebaseSelect p wX wY -> PatchInfoAnd (RebaseChange p) wX wY toChange (RSFwd fixups named) = n2pia $ flip adddeps (getdeps named) $ infopatch (patch2patchinfo named) $ (:>: NilFL) $ RCFwd fixups (patchcontents named) toChange (RSRev fixups named) = n2pia $ flip adddeps (getdeps named) $ infopatch (patch2patchinfo named) $ (:>: NilFL) $ RCRev fixups (patchcontents named) instance PrimPatch (PrimOf p) => PrimPatchBase (RebaseChange p) where type PrimOf (RebaseChange p) = PrimOf p instance Invert p => Invert (RebaseSelect p) where invert (RSFwd fixups edit) = RSRev fixups edit invert (RSRev fixups edit) = RSFwd fixups edit instance Invert (RebaseChange p) where invert (RCFwd fixups contents) = RCRev fixups contents invert (RCRev fixups contents) = RCFwd fixups contents instance (PrimPatchBase p, Commute p, MyEq p) => MyEq (RebaseSelect p) where RSFwd fixups1 edit1 =\/= RSFwd fixups2 edit2 | IsEq <- fixups1 =\/= fixups2, IsEq <- edit1 =\/= edit2 = IsEq RSRev fixups1 edit1 =\/= RSRev fixups2 edit2 | IsEq <- edit1 =/\= edit2, IsEq <- fixups1 =/\= fixups2 = IsEq _ =\/= _ = impossible instance (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) => Commute (RebaseSelect p) where commute (RSFwd {} :> RSRev {}) = impossible commute (RSRev {} :> RSFwd {}) = impossible commute (RSRev fixups1 edit1 :> RSRev fixups2 edit2) = do RSFwd fixups1' edit1' :> RSFwd fixups2' edit2' <- commute (RSFwd fixups2 edit2 :> RSFwd fixups1 edit1) return (RSRev fixups2' edit2' :> RSRev fixups1' edit1') commute (RSFwd fixups1 edit1 :> RSFwd fixups2 edit2) = do fixups2' :> edit1' <- commuteNamedFixups (edit1 :> fixups2) edit2' :> edit1'' <- commute (edit1' :> edit2) fixupsS :> (fixups2'' :> edit2'') :> fixups1' <- return $ pushThrough (fixups1 :> (fixups2' :> edit2')) return (RSFwd (fixupsS +>+ fixups2'') edit2'' :> RSFwd fixups1' edit1'') instance Commute (RebaseChange p) where commute _ = impossible instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseSelect p) where listTouchedFiles (RSFwd fixup toedit) = nub (listTouchedFiles fixup ++ listTouchedFiles toedit) listTouchedFiles (RSRev fixup toedit) = nub (listTouchedFiles fixup ++ listTouchedFiles toedit) hunkMatches f (RSFwd fixup toedit) = hunkMatches f fixup || hunkMatches f toedit hunkMatches f (RSRev fixup toedit) = hunkMatches f fixup || hunkMatches f toedit instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseChange p) where listTouchedFiles (RCFwd fixup contents) = nub (listTouchedFiles fixup ++ listTouchedFiles contents) listTouchedFiles (RCRev fixup contents) = nub (listTouchedFiles fixup ++ listTouchedFiles contents) hunkMatches f (RCFwd fixup contents) = hunkMatches f fixup || hunkMatches f contents hunkMatches f (RCRev fixup contents) = hunkMatches f fixup || hunkMatches f contents -- |Split a list of rebase patches into those that will -- have conflicts if unsuspended and those that won't. partitionUnconflicted :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) => FL (RebaseSelect p) wX wY -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wY partitionUnconflicted = partitionUnconflictedAcc NilRL partitionUnconflictedAcc :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) => RL (RebaseSelect p) wX wY -> FL (RebaseSelect p) wY wZ -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wZ partitionUnconflictedAcc right NilFL = NilFL :> right partitionUnconflictedAcc right (p :>: ps) = case commuterRLId selfCommuter (right :> p) of Just (p'@(RSFwd NilFL _) :> right') -> case partitionUnconflictedAcc right' ps of left' :> right'' -> (p' :>: left') :> right'' _ -> partitionUnconflictedAcc (p :<: right) 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 -- 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 :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p) => (FL (RebaseFixup p) :> (FL (RebaseFixup p) :> Named p)) wX wY -> (FL (RebaseFixup p) :> (FL (RebaseFixup p) :> Named p) :> FL (RebaseFixup p)) 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' <- commuterIdFL selfCommuter (p :> psS) qs' :> p'' <- commuterIdFL selfCommuter (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 p :> WDDNamed p) wX wY -> (WDDNamed p :> RebaseName p) wX wY forceCommuteName (AddName an :> WithDroppedDeps (NamedP pn deps body) ddeps) | an == pn = impossible | 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 = impossible | dn `elem` deps = impossible | otherwise = unsafeCoerceP p :> DelName dn forceCommuteName (Rename old new :> WithDroppedDeps (NamedP pn deps body) ddeps) | old == pn = impossible | new == pn = impossible | old `elem` deps = impossible | 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 :: (Commute p, Merge p, Invert p, Effect p, FromPrim p) => (PrimOf p :> WDDNamed p) wX wY -> (WDDNamed p :> FL (PrimOf p)) wX wY forceCommutePrim (p :> q) = case mergerIdWDD (mergerIdNamed selfMerger) (invert (fromPrim p) :\/: q) of q' :/\: invp' -> q' :> effect (invert invp') forceCommutesPrim :: (Commute p, Merge p, Invert p, Effect p, FromPrim p) => (PrimOf p :> FL (WDDNamed p)) wX wY -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY forceCommutesPrim (p :> NilFL) = NilFL :> (p :>: NilFL) forceCommutesPrim (p :> (q :>: qs)) = case forceCommutePrim (p :> q) of q' :> p' -> case forceCommutessPrim ( p' :> qs) of qs' :> p'' -> (q' :>: qs') :> p'' forceCommutessPrim :: (Commute p, Merge p, Invert p, Effect p, FromPrim p) => (FL (PrimOf p) :> FL (WDDNamed p)) wX wY -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY forceCommutessPrim (NilFL :> qs) = qs :> NilFL forceCommutessPrim ((p :>: ps) :> qs) = case forceCommutessPrim (ps :> qs) of qs' :> ps' -> case forceCommutesPrim (p :> qs') of qs'' :> p' -> qs'' :> (p' +>+ ps') forceCommutess :: (Commute p, Merge p, Invert p, Effect p, FromPrim p) => (FL (RebaseFixup p) :> FL (WDDNamed p)) wX wY -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY forceCommutess (NilFL :> qs) = qs :> NilFL forceCommutess ((NameFixup n :>: ps) :> qs) = case forceCommutess (ps :> qs) of qs' :> ps' -> case totalCommuterIdFL forceCommuteName (n :> qs') of qs'' :> n' -> qs'' :> (NameFixup n' :>: ps') forceCommutess ((PrimFixup p :>: ps) :> qs) = case forceCommutess (ps :> qs) of qs' :> ps' -> case forceCommutesPrim (p :> qs') of qs'' :> p' -> qs'' :> (mapFL_FL PrimFixup p' +>+ 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. extractRebaseSelect :: (Commute p, Merge p, Invert p, Effect p, FromPrim p, PrimPatchBase p) => FL (RebaseSelect p) wX wY -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY extractRebaseSelect NilFL = NilFL :> NilFL extractRebaseSelect (RSFwd fixups toedit :>: rest) = case extractRebaseSelect rest of toedits2 :> fixups2 -> case forceCommutess (fixups :> (WithDroppedDeps toedit [] :>: toedits2)) of toedits' :> fixups' -> toedits' :> (fixups' +>+ fixups2) extractRebaseSelect (RSRev{} :>: _) = impossible -- signature to be compatible with extractRebaseSelect -- | Like 'extractRebaseSelect', but any fixups are "reified" into a separate patch. reifyRebaseSelect :: forall p wX wY . (PrimPatchBase p, Commute p, Merge p, Invert p, Effect p, FromPrim p) => FL (RebaseSelect p) wX wY -> IO ((FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY) reifyRebaseSelect rs = do res <- concatFL <$> mapFL_FL_M reifyOne rs return (res :> NilFL) where reifyOne :: RebaseSelect p wA wB -> IO (FL (WDDNamed p) wA wB) reifyOne (RSFwd fixups toedit) = case flToNamesPrims fixups of names :> NilFL -> return (mapFL_FL (noDroppedDeps . mkDummy) names +>+ noDroppedDeps toedit :>: NilFL) names :> prims -> do n <- mkReified prims return (mapFL_FL (noDroppedDeps . mkDummy) names +>+ noDroppedDeps n :>: noDroppedDeps toedit :>: NilFL) reifyOne (RSRev{}) = impossible mkReified :: FromPrim p => FL (PrimOf p) wX wY -> IO (Named p wX wY) mkReified ps = do let name = "Reified fixup patch" let desc = [] date <- getIsoDateTime let author = "Invalid " namepatch date name author desc (mapFL_FL fromPrim ps) mkDummy :: RebaseName p 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 CommuteNoConflicts (RebaseChange p) where commuteNoConflicts _ = impossible instance MaybeInternal (RebaseChange p) instance IsHunk p => IsHunk (RebaseChange p) 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 NameHack (RebaseChange p) instance PatchListFormat (RebaseChange p) instance ( PrimPatchBase p, Apply p, Invert p , PatchInspect p , ApplyState p ~ ApplyState (PrimOf p) ) => Matchable (RebaseChange p) darcs-2.10.2/src/Darcs/Patch/Rebase/NameHack.hs0000644000175000017500000000176212620122474023016 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2009-2012 Ganesh Sittampalam -- -- BSD3 module Darcs.Patch.Rebase.NameHack ( NameHack(..) ) where import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Witnesses.Ordered ( FL ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) -- |When commuting a @Normal@ patch past a @Suspended@ one, we need to adjust the -- internals of the @Suspended@ one to take account of the effect of the @Normal@ patch. -- This includes the name of the @Normal@ patch - but the layering is such that we -- are actually commuting patches of type @Named (Rebasing p)@ - i.e. @Rebasing p@ -- doesn't actually contain the name. We therefore need to add a hook to the @Commute@ -- instances for @Named@ which @Rebasing@ can then implement. -- -- There is a default so that other patch types only need to declare the instance. class NameHack p where nameHack :: D.DiffAlgorithm -> Maybe (PatchInfo -> FL p wX wY -> FL p wX wY, PatchInfo -> FL p wW wZ -> FL p wW wZ) nameHack = \_ -> Nothing darcs-2.10.2/src/Darcs/Patch/Rebase/Name.hs0000644000175000017500000002002712620122474022222 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2011-2 Ganesh Sittampalam -- -- BSD3 {-# LANGUAGE CPP #-} module Darcs.Patch.Rebase.Name ( RebaseName(..) , commuteNamePrim, commutePrimName , commuteNameNamed, commuteNamedName ) where import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.Info ( PatchInfo, isInverted, showPatchInfo, readPatchInfo ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Named ( Named(..) ) import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..) , ShowPatch(..), ReadPatch(..) ) import Darcs.Patch.Permutations ( inverseCommuter ) import Darcs.Patch.Prim ( PrimPatchBase, PrimOf ) import Darcs.Patch.ReadMonads ( lexString ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..) , ShowDict(ShowDictClass) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.Printer ( empty, blueText, ($$) ) import Control.Applicative ( (<|>) ) import qualified Data.ByteString.Char8 as BC ( pack ) #include "impossible.h" -- 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 (p :: * -> * -> *) wX wY where AddName :: PatchInfo -> RebaseName p wX wY DelName :: PatchInfo -> RebaseName p wX wY Rename :: PatchInfo -> PatchInfo -> RebaseName p wX wY deriving Show instance Show1 (RebaseName p wX) where showDict1 = ShowDictClass instance Show2 (RebaseName p) where showDict2 = ShowDictClass instance ShowPatchBasic (RebaseName p) where showPatch (AddName n) = blueText "addname" $$ showPatchInfo n showPatch (DelName n) = blueText "delname" $$ showPatchInfo n showPatch (Rename old new) = blueText "rename" $$ showPatchInfo old $$ showPatchInfo new instance ShowPatch (RebaseName p) where summary _ = empty -- TODO improve this? summaryFL _ = empty instance ReadPatch (RebaseName p) 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 p) where commute (AddName n1 :> AddName n2) | n1 == n2 = impossible | otherwise = Just (AddName n2 :> AddName n1) commute (DelName n1 :> DelName n2) | n1 == n2 = impossible | 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 = impossible -- 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 = impossible -- precondition of Rename is that new doesn't exist | otherwise = Just (Rename old new :> AddName n) commute (Rename old new :> DelName n) | n == old = impossible -- 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 = impossible -- 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 = impossible | new1 == new2 = impossible | old1 == new2 = Nothing | new1 == old2 = Nothing | otherwise = Just (Rename old2 new2 :> Rename old1 new1) instance Invert (RebaseName p) where invert (AddName n) = DelName n invert (DelName n) = AddName n invert (Rename old new) = Rename new old instance PatchInspect (RebaseName p) where listTouchedFiles _ = [] hunkMatches _ _ = False instance Apply p => Apply (RebaseName p) where type ApplyState (RebaseName p) = ApplyState p apply _ = return () instance Apply p => Patchy (RebaseName p) instance PrimPatchBase p => PrimPatchBase (RebaseName p) where type PrimOf (RebaseName p) = PrimOf p instance Effect (RebaseName p) where effect _ = unsafeCoerceP NilFL instance MyEq (RebaseName p) where AddName n1 `unsafeCompare` AddName n2 = n1 == n2 AddName _ `unsafeCompare` _ = False _ `unsafeCompare` AddName _ = False DelName n1 `unsafeCompare` DelName n2 = n1 == n2 DelName _ `unsafeCompare` _ = False _ `unsafeCompare` DelName _ = False Rename old1 new1 `unsafeCompare` Rename old2 new2 = old1 == old2 && new1 == new2 -- Rename _ _ `unsafeCompare` _ = False -- _ `unsafeCompare` Rename _ _ = False -- |Commute a name patch and a primitive patch. They trivially -- commute so this just involves changing the witnesses. commuteNamePrim :: PrimPatchBase p => (RebaseName p :> PrimOf p) wX wY -> (PrimOf p :> RebaseName p) wX wY commuteNamePrim (n :> f) = unsafeCoerceP f :> unsafeCoerceP n -- |Commute a primitive patch and a name patch. They trivially -- commute so this just involves changing the witnesses. commutePrimName :: PrimPatchBase p => (PrimOf p :> RebaseName p) wX wY -> (RebaseName p :> PrimOf p) wX wY commutePrimName (f :> n) = unsafeCoerceP n :> unsafeCoerceP f -- |Commute a name patch and a named patch. In most cases this is -- trivial but we do need to check explicit dependencies. commuteNameNamed :: Invert p => CommuteFn (RebaseName p) (Named p) commuteNameNamed pair@(_ :> NamedP pn _ _) | isInverted pn = inverseCommuter commuteNamedName pair commuteNameNamed (AddName an :> p@(NamedP pn deps _)) | an == pn = impossible | an `elem` deps = Nothing | otherwise = Just (unsafeCoerceP p :> AddName an) commuteNameNamed (DelName dn :> p@(NamedP pn deps _)) | dn == pn = impossible | dn `elem` deps = impossible | otherwise = Just (unsafeCoerceP p :> DelName dn) commuteNameNamed (Rename old new :> NamedP pn deps body) | old == pn = impossible | new == pn = impossible | old `elem` deps = impossible | 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 :: Invert p => CommuteFn (Named p) (RebaseName p) commuteNamedName pair@(NamedP pn _ _ :> _) | isInverted pn = inverseCommuter commuteNameNamed pair commuteNamedName (p@(NamedP pn deps _) :> AddName an) | an == pn = impossible -- the NamedP introduces pn, then AddName introduces it again | an `elem` deps = impossible -- 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 = impossible | new `elem` deps = impossible | otherwise = let newdeps = map (\dep -> if old == dep then new else dep) deps in Just (Rename old new :> NamedP pn newdeps (unsafeCoerceP body)) darcs-2.10.2/src/Darcs/Patch/Commute.hs0000644000175000017500000000627712620122474021565 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Commute ( Commute(..) , commuteFL , commuteFLorComplain , commuteRL , commuteRLFL , toFwdCommute , toRevCommute , selfCommuter ) where import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), reverseFL, reverseRL, (:>)(..), (:<)(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed2, seal2 ) -- | Commute represents things that can be (possibly) commuted. class Commute p where commute :: (p :> p) wX wY -> Maybe ((p :> p) wX wY) 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' -- |'commuteRLFL' commutes an 'RL' past an 'FL'. commuteRLFL :: Commute p => (RL p :> FL p) wX wY -> Maybe ((FL p :> RL p) wX wY) 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'') instance Commute p => Commute (RL p) where commute (xs :> ys) = do fys' :> xs' <- commuteRLFL (xs :> reverseRL ys) return (reverseFL fys' :> xs') -- |'commuteRL' commutes a RL past a single element. commuteRL :: Commute p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY) 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) -- |'commuteFL' commutes a single element past a FL. commuteFL :: Commute p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY) commuteFL = either (const Nothing) Just . commuteFLorComplain -- |'commuteFLorComplain' attempts to commute a single element past a FL. If -- any individual commute fails, then we return the patch that first patch that -- cannot be commuted past. commuteFLorComplain :: Commute p => (p :> FL p) wX wY -> Either (Sealed2 p) ((FL p :> p) wX wY) 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 -- | Swaps the ordered pair type so that commute can be called directly. toFwdCommute :: (Commute p, Commute q, Monad m) => ((p :< q) wX wY -> m ((q :< p) wX wY)) -> (q :> p) wX wY -> m ((p :> q) wX wY) toFwdCommute c (x :> y) = do x' :< y' <- c (y :< x) return (y' :> x') -- | Swaps the ordered pair type from the order expected by commute to the -- reverse order. toRevCommute :: (Commute p, Commute q, Monad m) => ((p :> q) wX wY -> m ((q :> p) wX wY)) -> (q :< p) wX wY -> m ((p :< q) wX wY) toRevCommute c (x :< y) = do x' :> y' <- c (y :> x) return (y' :< x') -- |Build a commuter between a patch and itself using the operation from the type class. selfCommuter :: Commute p => CommuteFn p p selfCommuter = commute darcs-2.10.2/src/Darcs/Patch/Merge.hs0000644000175000017500000000265412620122474021206 0ustar00guillaumeguillaume00000000000000 -- | -- Module : Darcs.Patch.Merge -- Maintainer : darcs-devel@darcs.net -- Stability : experimental -- Portability : portable module Darcs.Patch.Merge ( Merge(..) , selfMerger , mergeFL ) where import Data.Maybe ( fromJust ) import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.CommuteFn ( MergeFn ) import Darcs.Patch.Witnesses.Ordered ( (:\/:)(..) , (:/\:)(..) , FL(..) , RL , reverseFL , reverseRL ) -- | Things that can always be merged class Commute p => Merge p where merge :: (p :\/: p) wX wY -> (p :/\: p) wX wY selfMerger :: Merge p => MergeFn p p selfMerger = merge 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')) instance Merge p => Merge (RL p) where merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx' mergeFL :: Merge p => (p :\/: FL p) wX wY -> (FL p :/\: p) wX wY 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'') darcs-2.10.2/src/Darcs/Patch/TouchesFiles.hs0000644000175000017500000001173712620122474022546 0ustar00guillaumeguillaume00000000000000-- 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.Patch.TouchesFiles ( lookTouch, chooseTouching, choosePreTouching, selectTouching, deselectNotTouching, selectNotTouching, ) where import Control.Applicative ( (<$>) ) import Data.List ( isSuffixOf, nub ) import Darcs.Patch.Choices ( PatchChoices, Label, LabelledPatch, patchChoices, label, getChoices, forceFirsts, forceLasts, lpPatch, ) import Darcs.Patch ( Patchy, invert ) import Darcs.Patch.Apply ( ApplyState, applyToFilePaths, effectOnFilePaths ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) ) import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) import Storage.Hashed.Tree( Tree ) labelTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Bool -> [FilePath] -> FL (LabelledPatch p) wX wY -> [Label] labelTouching _ _ NilFL = [] labelTouching wantTouching fs (lp :>: lps) = case lookTouchOnlyEffect fs (lpPatch lp) of (doesTouch, fs') -> let rest = labelTouching wantTouching fs' lps in (if doesTouch == wantTouching then (label lp :) else id) rest labelNotTouchingFM :: (PatchInspect p, Patchy p, ApplyState p ~ Tree) => [FilePath] -> PatchChoices p wX wY -> [Label] labelNotTouchingFM files pc = case getChoices pc of fc :> mc :> _ -> labelTouching False (map fix files) (fc +>+ mc) selectTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectTouching Nothing pc = pc selectTouching (Just files) pc = forceFirsts xs pc where xs = case getChoices pc of _ :> mc :> lc -> labelTouching True (map fix files) (mc +>+ lc) deselectNotTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY deselectNotTouching Nothing pc = pc deselectNotTouching (Just files) pc = forceLasts (labelNotTouchingFM files pc) pc selectNotTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectNotTouching Nothing pc = pc selectNotTouching (Just files) pc = forceFirsts (labelNotTouchingFM files pc) pc fix :: FilePath -> FilePath fix f | "/" `isSuffixOf` f = fix $ init f fix "" = "." fix "." = "." fix f = "./" ++ f chooseTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> 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 lpPatch fc choosePreTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX) choosePreTouching files patch = chooseTouching filesBeforePatch patch where filesBeforePatch = effectOnFilePaths (invert patch) <$> files lookTouchOnlyEffect :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => [FilePath] -> p wX wY -> (Bool, [FilePath]) lookTouchOnlyEffect fs p = (wasTouched, fs') where (wasTouched, _, fs', _) = lookTouch Nothing fs p lookTouch :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [(FilePath, FilePath)] -> [FilePath] -> p wX wY -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)]) 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 darcs-2.10.2/src/Darcs/Patch/SummaryData.hs0000644000175000017500000000061012620122474022364 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) where import Darcs.Util.Path ( FileName ) data SummDetail = SummAddDir FileName | SummRmDir FileName | SummFile SummOp FileName Int Int Int | SummMv FileName FileName | SummNone deriving (Ord, Eq) data SummOp = SummAdd | SummRm | SummMod deriving (Ord, Eq) darcs-2.10.2/src/Darcs/Patch/ApplyPatches.hs0000644000175000017500000000176312620122474022544 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.ApplyPatches ( applyPatches ) where import Darcs.Patch.Info ( showPatchInfoUI ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.MonadProgress ( MonadProgress, ProgressAction(..), runProgressActions) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) import Darcs.Util.Printer ( text, ($$) ) applyPatches :: (MonadProgress m, ApplyMonad m (ApplyState p), Patchy p) => FL (PatchInfoAnd p) wX wY -> m () applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps) where doApply hp = ProgressAction { paAction = apply (hopefully hp) , paMessage = showPatchInfoUI (info hp) , paOnError = text "Unapplicable patch:" $$ showPatchInfoUI (info hp) } darcs-2.10.2/src/Darcs/Patch/Choices.hs0000644000175000017500000004253412620122474021525 0ustar00guillaumeguillaume00000000000000-- 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 #-} -- | 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 -- 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. -- -- 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). -- -- 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, patchChoicesLps, patchChoicesLpsSub, patchSlot, patchSlot', getChoices, refineChoices, separateFirstMiddleFromLast, separateFirstFromMiddleLast, forceFirst, forceFirsts, forceLast, forceLasts, forceMatchingFirst, forceMatchingLast, selectAllMiddles, makeUncertain, makeEverythingLater, makeEverythingSooner, LabelledPatch, Label, label, lpPatch, Slot(..), substitute ) where import Control.Monad.Identity ( Identity ) import Control.Monad.State ( StateT(..) ) import Prelude hiding ( pred ) import Darcs.Patch ( Patchy, commuteRL, commute, merge, listTouchedFiles, hunkMatches , invert ) import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL ) import Darcs.Patch.Patchy ( Invert, Commute, PatchInspect ) import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..), zipWithFL, mapFL_FL, concatFL, (+>+), reverseRL, anyFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) ) #include "impossible.h" -- | '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 @Label mp i@. The @i@ is just some -- arbitrary label, 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 @Label Nothing -- 5@, the resulting sub-patches could be identified as @Label (Label Nothing 5) -- 1@, @Label (Label Nothing 5) 2@, etc. data Label = Label (Maybe Label) Integer deriving ( Eq, Ord ) data LabelledPatch p wX wY = LP Label (p wX wY) -- | The @Bool@ parameter indicates whether the patch has been explicitely -- selected (or rejected) by the user. data PatchChoice p wX wY = PC { pcPatch :: (LabelledPatch p wX wY) , _pcChoice :: Bool} data PatchChoices p wX wY where PCs :: { pcsFirsts :: FL (LabelledPatch p) wX wM , pcsLasts :: FL (PatchChoice p) wM wY} -> PatchChoices p wX wY -- | See module documentation for 'Darcs.Patch.Choices' data Slot = InFirst | InMiddle | InLast label :: LabelledPatch p wX wY -> Label label (LP tg _) = tg lpPatch :: LabelledPatch p wX wY -> p wX wY lpPatch (LP _ p) = p liftLP :: (p wX wY -> p wA wB) -> (LabelledPatch p wX wY -> LabelledPatch p wA wB) liftLP f (LP t p) = LP t (f p) -- 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 MyEq p => MyEq (LabelledPatch p) where unsafeCompare (LP l1 p1) (LP l2 p2) = l1 == l2 && unsafeCompare p1 p2 instance Invert p => Invert (LabelledPatch p) where invert = liftLP invert 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 PatchInspect p => PatchInspect (LabelledPatch p) where listTouchedFiles (LP _ p) = listTouchedFiles p hunkMatches f (LP _ p) = hunkMatches f p instance Merge p => Merge (LabelledPatch p) where merge (LP l1 p1 :\/: LP l2 p2) = case merge (p1 :\/: p2) of p2' :/\: p1' -> LP l2 p2' :/\: LP l1 p1' 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) 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 lp1 c1 :\/: PC lp2 c2) = case merge (lp1 :\/: lp2) of lp2' :/\: lp1' -> PC lp2' c2 :/\: PC lp1' c1 patchChoices :: Patchy p => FL p wX wY -> PatchChoices p wX wY patchChoices = fst . patchChoicesLps -- |Label a sequence of patches as subpatches of an existing label. This is intended for -- use when substituting a patch for an equivalent patch or patches. patchChoicesLpsSub :: Patchy p => Maybe Label -> FL p wX wY -> (PatchChoices p wX wY, FL (LabelledPatch p) wX wY) patchChoicesLpsSub tg ps = let lps = zipWithFL LP (map (Label tg) [1..]) ps in (PCs NilFL (mapFL_FL (\lp -> PC lp False) lps), lps) -- |Label a sequence of patches. patchChoicesLps :: Patchy p => FL p wX wY -> (PatchChoices p wX wY, FL (LabelledPatch p) wX wY) patchChoicesLps = patchChoicesLpsSub Nothing instance MyEq p => MyEq (PatchChoice p) where unsafeCompare (PC lp1 _) (PC lp2 _) = unsafeCompare lp1 lp2 separateFirstFromMiddleLast :: Patchy p => PatchChoices p wX wZ -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ separateFirstFromMiddleLast (PCs f l) = f :> mapFL_FL (\ (PC lp _) -> lp) l separateFirstMiddleFromLast :: Patchy 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 wX wY -> (FL (LabelledPatch p) :> FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY getChoices (PCs f l) = case pushLasts l of (m :> l') -> f :> m :> l' pushLasts :: Patchy p => FL (PatchChoice p) wX wY -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY pushLasts NilFL = NilFL :> NilFL pushLasts (PC lp False :>: pcs) = case pushLasts pcs of (m :> l) -> (lp :>: m) :> l pushLasts (PC lp True :>: pcs) = case pushLasts pcs of (m :> 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 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 patchSlot :: forall p wA wB wX wY. Patchy p => LabelledPatch p wA wB -> PatchChoices p wX wY -> (Slot, PatchChoices p wX wY) patchSlot (LP t _) pc@(PCs f l) = if foundIn f then (InFirst, pc) else psLast f NilRL NilRL l where 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 +>+ settleB bubble +>+ 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 lp' False :>: settleB bubble' +>+ ls}) Nothing -> (InLast, PCs { pcsFirsts = firsts , pcsLasts = settleM middles +>+ settleB bubble +>+ PC lp True :>: ls}) psLast firsts middles bubble (PC lp True :>: ls) = psLast firsts middles (lp :<: bubble) ls psLast firsts middles bubble (PC lp False :>: ls) = case commuteRL (bubble :> lp) of Just (lp' :> bubble') -> psLast firsts (lp' :<: middles) bubble' ls Nothing -> psLast firsts middles (lp :<: bubble) ls psLast _ _ _ NilFL = impossible settleM middles = mapFL_FL (\lp -> PC lp False) $ reverseRL middles settleB bubble = mapFL_FL (\lp -> PC lp True) $ reverseRL bubble patchSlot' :: Patchy p => LabelledPatch p wA wB -> StateT (PatchChoices p wX wY) Identity Slot patchSlot' lp = StateT (return . patchSlot lp) forceMatchingFirst :: forall p wA wB. Patchy p => ( forall wX wY . LabelledPatch p wX wY -> Bool) -> PatchChoices p wA wB -> PatchChoices p wA wB forceMatchingFirst pred (PCs fn l) = fmfLasts fn NilRL l where 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 (deps :> a' :> l1') -> 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 NilFL = PCs { pcsFirsts = f , pcsLasts = reverseRL l1 } pred_pc :: forall wX wY . PatchChoice p wX wY -> Bool pred_pc (PC lp _) = pred lp forceFirsts :: Patchy p => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB forceFirsts ps = forceMatchingFirst ((`elem` ps) . label) forceFirst :: Patchy 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 wX wY. Patchy p => Bool -> PatchChoices p wX wY -> PatchChoices p wX wY selectAllMiddles True (PCs f l) = PCs f (mapFL_FL g l) where g (PC lp _) = PC lp True selectAllMiddles False (PCs f l) = samf f NilRL NilRL l where 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 lp True :<: l1) l2 Just ((PC lp' _) :> l1') -> samf f1 (lp' :<: f2) l1' l2 samf f1 f2 l1 (PC lp True :>: l2) = samf f1 f2 (PC lp True :<: l1) l2 samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1) forceMatchingLast :: Patchy p => (forall wX wY . LabelledPatch p wX wY -> Bool) -> PatchChoices p wA wB -> PatchChoices p wA wB forceMatchingLast pred (PCs f l) = do fmlFirst pred True NilRL f l fmlFirst :: forall p wA wB wM1 wM2 . Patchy p => (forall wX wY . LabelledPatch p wX wY -> Bool) -> Bool -> RL (LabelledPatch p) wA wM1 -> FL (LabelledPatch p) wM1 wM2 -> FL (PatchChoice p) wM2 wB -> PatchChoices p wA wB fmlFirst pred b f1 (a :>: f2) l | pred a = case commuteWhatWeCanFL (a :> f2) of (f2' :> a' :> deps) -> let l' = mapFL_FL (\lp -> PC lp 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 lp c) = (PC lp (if pred lp then b else c) ) forceLasts :: Patchy p => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB forceLasts ps = forceMatchingLast ((`elem` ps) . label) forceLast :: Patchy p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB forceLast p = forceMatchingLast ((== p) . label) makeUncertain :: Patchy p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB makeUncertain t (PCs f l) = fmlFirst ((== t) . label) False NilRL f l makeEverythingLater :: Patchy p => PatchChoices p wX wY -> PatchChoices p wX wY makeEverythingLater (PCs f l) = let m = mapFL_FL (\lp -> PC lp False) f l' = mapFL_FL (\(PC lp _) -> PC lp True) l in PCs NilFL $ m +>+ l' makeEverythingSooner :: forall p wX wY. Patchy p => PatchChoices p wX wY -> PatchChoices p wX wY makeEverythingSooner (PCs f l) = case mes NilRL NilRL l of (m :> l') -> PCs (f +>+ m) l' where 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 :>: ls) = mes middle (lp :<: bubble) ls mes middle bubble (PC lp False :>: ls) = case commuteRL (bubble :> lp) of Nothing -> mes middle (lp :<: bubble) ls Just (lp' :> bubble') -> mes (lp' :<: middle) bubble' ls 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 wX wY . Patchy p => 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 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 (flip PC c) new_lps | otherwise = PC lp' c :>: NilFL darcs-2.10.2/src/Darcs/Patch/ConflictMarking.hs0000644000175000017500000000775412620122474023227 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam {-# LANGUAGE CPP, 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, intercalate ) import Data.Maybe ( isJust ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk, isHunk ) import Darcs.Util.Path ( 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.Patch.Witnesses.Ordered ( FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) #include "impossible.h" applyHunks :: IsHunk prim => [Maybe B.ByteString] -> FL prim wX wY -> [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 wX)] -> FileName getAFilename (Sealed ((is_filepatch -> Just f):>:_):_) = f getAFilename _ = fp2fn "" getOld :: PrimPatch prim => [Maybe B.ByteString] -> [Sealed (FL prim wX)] -> [Maybe B.ByteString] getOld = foldl getHunksOld getHunksOld :: PrimPatch prim => [Maybe B.ByteString] -> Sealed (FL prim wX) -> [Maybe B.ByteString] getHunksOld mls (Sealed ps) = applyHunks (applyHunks mls ps) (invert ps) getHunksNew :: IsHunk prim => [Maybe B.ByteString] -> Sealed (FL prim wX) -> [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 wX)] -> Sealed (FL prim wX) mangleUnravelled pss = if onlyHunks pss then (:>: NilFL) `mapSeal` mangleUnravelledHunks pss else head pss onlyHunks :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Bool onlyHunks [] = False onlyHunks pss = fn2fp f /= "" && all oh pss where f = getAFilename pss oh :: Sealed (FL prim wY) -> Bool oh (Sealed (p:>:ps)) = primIsHunk p && [fn2fp f] == listTouchedFiles p && oh (Sealed ps) oh (Sealed NilFL) = True mangleUnravelledHunks :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (prim wX) --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] ++ 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 eol_c = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old then "\r" else "" darcs-2.10.2/src/Darcs/Patch/MaybeInternal.hs0000644000175000017500000000302312620122474022670 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2009-2012 Ganesh Sittampalam -- -- BSD3 module Darcs.Patch.MaybeInternal ( InternalChecker(..) , MaybeInternal(..) , flIsInternal ) where import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL ) -- Note: the EqCheck result could be replaced by a Bool if clients were changed to commute the patch -- out if necessary. newtype InternalChecker p = InternalChecker { isInternal :: forall wX wY . p wX wY -> EqCheck wX wY } -- |Provides a hook for flagging whether a patch is "internal" to the repo -- and therefore shouldn't be referred to externally, e.g. by inclusion in tags. -- Note that despite the name, every patch type has to implement it, but for -- normal (non-internal) types the default implementation is fine. -- Currently only used for rebase internal patches. class MaybeInternal p where -- | @maybe (const NotEq) (fmap isInternal patchInternalChecker) p@ -- returns 'IsEq' if @p@ is internal, and 'NotEq' otherwise. -- The two-level structure is purely for efficiency: 'Nothing' and 'Just (InternalChecker (const NotEq))' are -- semantically identical, but 'Nothing' allows clients to avoid traversing an entire list. -- The patch type is passed as an 'FL' because that's how the internals of named patches are stored. patchInternalChecker :: Maybe (InternalChecker (FL p)) patchInternalChecker = Nothing flIsInternal :: MaybeInternal p => FL p wX wY -> EqCheck wX wY flIsInternal = maybe (const NotEq) isInternal patchInternalChecker darcs-2.10.2/src/Darcs/Patch/Effect.hs0000644000175000017500000000154012620122474021334 0ustar00guillaumeguillaume00000000000000module Darcs.Patch.Effect ( Effect(..) ) where import Darcs.Patch.Prim.Class ( PrimOf ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), reverseFL, reverseRL , concatFL, concatRL, mapFL_FL, mapRL_RL ) -- | Patches whose concrete effect which 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 wX wY -> FL (PrimOf p) wX wY effect = reverseRL . effectRL effectRL :: p wX wY -> RL (PrimOf p) wX wY effectRL = reverseFL . effect instance Effect p => Effect (FL p) where effect p = concatFL $ mapFL_FL effect p effectRL p = concatRL $ mapRL_RL effectRL $ reverseFL p instance Effect p => Effect (RL p) where effect p = concatFL $ mapFL_FL effect $ reverseRL p effectRL p = concatRL $ mapRL_RL effectRL p darcs-2.10.2/src/Darcs/Patch.hs0000644000175000017500000000757512620122474020156 0ustar00guillaumeguillaume00000000000000-- 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. {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7 module Darcs.Patch ( RepoPatch , PrimOf , Named , Patchy , fromPrim , fromPrims , rmfile , addfile , rmdir , adddir , move , hunk , tokreplace , namepatch , anonymous , binary , description , showContextPatch , showPatch , showNicely , infopatch , changepref , thing , things , primIsAddfile , primIsHunk , primIsSetpref , merge , commute , listTouchedFiles , hunkMatches , forceTokReplace , PrimPatch -- * for PatchTest , resolveConflicts , Effect , effect , primIsBinary , primIsAdddir , invert , invertFL , invertRL , commuteFLorComplain , commuteRL , readPatch , readPatchPartial , canonize , sortCoalesceFL , tryToShrink , patchname , patchcontents , applyToFilePaths , apply , applyToTree , effectOnFilePaths , patch2patchinfo , summary , summaryFL , plainSummary , xmlSummary , plainSummaryPrims , adddeps , getdeps , listConflictedFiles , isInconsistent ) where import Darcs.Patch.Apply ( applyToFilePaths, effectOnFilePaths, applyToTree, ApplyState ) import Darcs.Patch.Commute ( commuteFLorComplain, commuteRL ) import Darcs.Patch.Conflict ( listConflictedFiles, resolveConflicts ) import Darcs.Patch.Effect ( Effect(effect) ) import Darcs.Patch.Invert ( invertRL, invertFL ) import Darcs.Patch.Named ( Named, adddeps, namepatch, 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, fromPrim, canonize, sortCoalesceFL, rmdir, rmfile, tokreplace, adddir, addfile, binary, changepref, hunk, move, primIsAdddir, primIsAddfile, primIsHunk, primIsBinary, primIsSetpref, tryToShrink, PrimPatch, PrimPatchBase(..) ) import Darcs.Patch.Read ( readPatch, readPatchPartial ) import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Repair ( isInconsistent ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Summary ( xmlSummary, plainSummary, plainSummaryPrims ) import Darcs.Patch.TokenReplace ( forceTokReplace ) import Darcs.Patch.V1.Commute ( merge ) import Storage.Hashed.Tree( Tree ) instance (Patchy p, NameHack p, ApplyState p ~ Tree) => Patchy (Named p) darcs-2.10.2/src/Darcs/Repository/0000755000175000017500000000000012620122474020724 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Repository/Compat.hs0000644000175000017500000001160012620122474022501 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Repository.Compat ( stdoutIsAPipe , mkStdoutTemp , canonFilename , maybeRelink , atomicCreate , sloppyAtomicCreate ) where import Prelude hiding ( catch ) import Darcs.Util.File ( withCurrentDirectory ) #ifdef WIN32 import Data.Bits ( (.&.) ) import System.Random ( randomIO ) import Numeric ( showHex ) #else #endif import Control.Monad ( unless ) import Foreign.C.Types ( CInt(..) ) import Foreign.C.String ( CString, withCString #ifndef WIN32 , peekCString #endif ) 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.Util.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 } showHexLen :: (Integral a, Show a) => Int -> a -> String showHexLen n x = let s = showHex x "" in replicate (n - length s) ' ' ++ s #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 _ <- dupTo fd stdOutput _ <- 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 darcs-2.10.2/src/Darcs/Repository/Old.hs0000644000175000017500000001560212620122474022002 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2002-2005,2007-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, ScopedTypeVariables #-} module Darcs.Repository.Old ( readOldRepo, revertTentativeChanges, oldRepoFailMsg ) where import Prelude hiding ( catch ) 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 ( () ) import Darcs.Patch.PatchInfoAnd ( Hopefully, PatchInfoAnd, patchInfoAndPatch, actually, unavailable ) import qualified Data.ByteString.Char8 as BC (break, pack) import Darcs.Patch ( RepoPatch, Named, readPatch ) import Darcs.Patch.Witnesses.Ordered ( RL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal ) import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfos, showPatchInfo ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin ) import Darcs.Repository.External ( gzFetchFilePS , Cachable(..) , cloneFile ) import Darcs.Repository.Lock ( writeBinFile ) import Darcs.Util.Printer ( renderString, RenderMode(..) ) import Darcs.Util.Global ( darcsdir ) import Control.Exception ( catch, IOException ) #include "impossible.h" readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p Origin) readOldRepo d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d let k = "Reading inventory of repository "++d beginTedious k readRepoPrivate k realdir "inventory" `catch` (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e) readRepoPrivate :: RepoPatch p => String -> FilePath -> FilePath -> IO (SealedPatchSet p Origin) readRepoPrivate k d iname = do i <- gzFetchFilePS (d darcsdir iname) Uncachable finishedOneIO k iname let parse inf = parse2 inf $ d darcsdir "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) 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) where read_ts :: RepoPatch p => (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB))) -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) Origin)) read_ts _ Nothing = do endTedious k return $ seal NilRL read_ts parse (Just tag0) = do debugMessage $ "Looking for inventory for:\n"++ renderString Encode (showPatchInfo tag0) i <- unsafeInterleaveIO $ do x <- gzFetchFilePS (d darcsdir "inventories" makeFilename tag0) Uncachable finishedOneIO k (renderString Encode (showPatchInfo 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) 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 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 wX)) -> Sealed (Hopefully (Named a1dr) wX) hopefullyNoParseError _ (Just (Sealed x)) = seal $ actually x hopefullyNoParseError s Nothing = seal $ unavailable $ "Couldn't parse file "++s read_patches :: RepoPatch p => (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 (:<:) (read_patches parse is) (parse i `catch` \(e :: IOException) -> return $ seal $ patchInfoAndPatch i $ unavailable $ show e) 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" ++ "See http://wiki.darcs.net/OF for more details." darcs-2.10.2/src/Darcs/Repository/Cache.hs0000644000175000017500000005577312620122474022304 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.Repository.Cache ( cacheHash , okayHash , takeHash , Cache(..) , CacheType(..) , CacheLoc(..) , WritableOrNot(..) , HashedDir(..) , hashedDir , bucketFolder , 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 qualified Data.ByteString as B (length, drop, ByteString ) import qualified Data.ByteString.Char8 as BC (unpack) import Data.List ( nub, intercalate ) import Data.Maybe ( catMaybes, listToMaybe, fromMaybe ) import System.FilePath.Posix ( (), joinPath, dropFileName ) import System.Directory ( createDirectoryIfMissing, removeFile, doesFileExist, doesDirectoryExist, getDirectoryContents, getPermissions ) import qualified System.Directory as SD ( writable ) import System.IO ( hPutStrLn, stderr ) import System.Posix.Files ( createLink, linkCount, getSymbolicLinkStatus ) import Darcs.Util.ByteString ( gzWriteFilePS, linesPS ) import Darcs.Util.Global ( darcsdir, addBadSource, isBadSource, addReachableSource, isReachableSource, getBadSourcesList ) import Darcs.Repository.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl, copyFileOrUrl, Cachable( Cachable ) ) import Darcs.Repository.Flags ( Compression(..), RemoteDarcs(..) ) import Darcs.Repository.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS, withTemp ) import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Crypt.SHA1 ( sha1PS ) import Darcs.Util.Crypt.SHA256 ( sha256sum ) import Darcs.Util.English ( englishNum, Noun(..), Pronoun(..) ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Progress ( progressList, debugMessage, debugFail ) import qualified Darcs.Util.Download as Download ( 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 ( 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] instance Eq CacheLoc where (Cache aTy _ aSrc) == (Cache bTy _ bSrc) = aTy == bTy && aSrc == bSrc 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 | isValidLocalPath repourl = do f <- filtered return $ local `unionCaches` Ca f | otherwise = return local where filtered = catMaybes `fmap` mapM (\x -> mbGetRemoteCacheLoc x `catchall` return Nothing) remote mbGetRemoteCacheLoc :: CacheLoc -> IO (Maybe CacheLoc) mbGetRemoteCacheLoc (Cache Repo Writable _) = return Nothing 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 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 = if sizeStrLen > 10 then shaOfPs else replicate (10 - sizeStrLen) '0' ++ sizeStr ++ '-' : shaOfPs where sizeStr = show $ B.length ps sizeStrLen = length sizeStr shaOfPs = sha256sum ps okayHash :: String -> Bool okayHash s = length s `elem` [40, 64, 75] takeHash :: B.ByteString -> Maybe (String, B.ByteString) takeHash ps = do h <- listToMaybe $ linesPS ps let v = BC.unpack h guard $ okayHash v return (v, B.drop (B.length h) ps) checkHash :: String -> B.ByteString -> Bool checkHash h s | length h == 40 = (show $ 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 bucketFolder :: String -> String bucketFolder f = take 2 (cleanHash f) where cleanHash fileName = case dropWhile (/= '-') fileName of [] -> fileName s -> drop 1 s -- | @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 = joinPath [d, hashedDir s, bucketFolder f, f] hashedFilePath (Cache Repo _ r) s f = joinPath [r, darcsdir, hashedDir s, f] -- | @hashedFilePathReadOnly cachelocation subdir hash@ returns the physical filename -- of hash @hash@ in the @subdir@ section of @cachelocation@. -- If directory, assume it is non-bucketed cache (old cache location). hashedFilePathReadOnly :: CacheLoc -> HashedDir -> String -> String hashedFilePathReadOnly (Cache Directory _ d) s f = d ++ "/" ++ hashedDir s ++ "/" ++ f hashedFilePathReadOnly (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 $ hashedFilePath c subdir f if ex then return True else cacheHasIt cs -- | @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 ) -- | We hace a list of locations (@cache@) ordered from "closest/fastest" -- (typically, the destination repo) to "farthest/slowest" (typically, -- the source repo). -- @copyFileUsingCache@ first checks whether given file @f@ is present -- in some writeable location, if yes, do nothing. If no, it copies it -- to the last writeable location, which would be the global cache -- by default, or the destination repo if `--no-cache` is passed. -- Function does nothing if there is no writeable location at all. -- If the copy should occur between two locations of the same filesystem, -- a hard link is actually made. -- TODO document @oos@: what happens when we only speculate? 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 True (reverse $ dropWhile (/= '/') $ reverse stickItHere) debugMessage $ "Will effectively do copyFileUsingCache to: " ++ show stickItHere filterBadSources cache >>= sfuc stickItHere `catchall` return () where -- return last writeable cache/repo location for file. -- usually returns the global cache unless `--no-cache` is passed. 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 sfuc _ [] = return () sfuc out (c : cs) | not (writable c) = let cacheFile = hashedFilePathReadOnly c subdir f in if oos == OnlySpeculate then speculateFileOrUrl cacheFile out `catchNonSignal` \e -> checkCacheReachability (show e) c else do debugMessage $ "Copying from " ++ show cacheFile ++ " to " ++ show out copyFileOrUrl DefaultRemoteDarcs cacheFile out Cachable `catchNonSignal` (\e -> do checkCacheReachability (show e) c sfuc out cs) -- try another read-only location | otherwise = sfuc out cs 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 | isValidLocalPath source = doUnreachableCheck $ checkFileReachability (doesDirectoryExist source) | isHttpUrl source = doUnreachableCheck $ do let err = case dropWhile (/= '(') e of (_ : xs) -> fst (break (==')') xs) _ -> e case reads err :: [(Download.ConnectionError, String)] of [(_, _)] -> addBadSource source _ -> 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 DefaultRemoteDarcs f tempout Cachable return True `catchNonSignal` const (return False) -- | Get contents of some hashed file taking advantage of the cache system. -- We hace 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 :: 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 || isValidLocalPath (hashedFilePathReadOnly c subdir f)) = do let cacheFile = hashedFilePathReadOnly c subdir f -- 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 f x then do x' <- fetchFilePS cacheFile Cachable unless (checkHash f 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 `catchNonSignal` \e -> do -- something bad happened, check if cache became unaccessible and try other ones checkCacheReachability (show e) c filterBadSources cs >>= ffuc | writable c = let cacheFile = hashedFilePath c subdir f in do debugMessage $ "About to gzFetchFilePS from " ++ show cacheFile x1 <- gzFetchFilePS cacheFile Cachable debugMessage $ "gzFetchFilePS done." x <- if not $ checkHash f x1 then do x2 <- fetchFilePS cacheFile Cachable unless (checkHash f x2) $ do hPutStrLn stderr $ "Hash failure in " ++ cacheFile removeFile cacheFile fail $ "Hash failure in " ++ cacheFile return x2 else return x1 mapM_ (tryLinking cacheFile) cs return (cacheFile, x) `catchNonSignal` \e -> do debugMessage "Caught exception, now attempt creating cache." createCache c subdir `catchall` return () checkCacheReachability (show e) c (fname, x) <- filterBadSources cs >>= ffuc -- fetch file from remaining locations 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 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 (hashedFilePath c subdir f) `catchall` return () tryLinking _ _ = return () 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 = do _ <- 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 -- FIXME: create links in caches write compr (hashedFilePath c subdir hash) ps return hash wfuc [] = debugFail $ "No location to write file `" ++ hashedDir 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 = 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 [ "\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." ] darcs-2.10.2/src/Darcs/Repository/Prefs.hs0000644000175000017500000004625612620122474022354 0ustar00guillaumeguillaume00000000000000-- 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.Repository.Prefs ( addToPreflist , deleteSources , getPreflist , setPreflist , getGlobal , environmentHelpHome , defaultrepo , getDefaultRepoPath , addRepoSource , getPrefval , setPrefval , changePrefval , defPrefval , writeDefaultPrefs , boringRegexps , boringFileFilter , darcsdirFilter , FileType(..) , filetypeFunction , getCaches , binariesFileHelp , boringFileHelp , globalCacheDir , globalPrefsDirDoc , globalPrefsDir , oldGlobalCacheDir ) where import Control.Exception ( catch ) import Control.Monad ( unless, when, liftM ) import Data.Char ( toUpper ) import Data.List ( nub, isPrefixOf, union, sortBy ) import Data.Maybe ( isJust, fromMaybe, mapMaybe, catMaybes, maybeToList ) import Prelude hiding ( catch ) import qualified Control.Exception as C import qualified Data.ByteString as B ( empty ) import qualified Data.ByteString.Char8 as BC ( unpack ) import System.Directory ( getAppUserDataDirectory, doesDirectoryExist, createDirectory, doesFileExist ) import System.Environment ( getEnvironment ) import System.FilePath.Posix ( normalise, dropTrailingPathSeparator, () ) import System.IO.Error ( isDoesNotExistError ) import System.IO ( stderr ) import System.Info ( os ) import Text.Regex ( Regex, mkRegex, matchRegex ) import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..), compareByLocality ) import Darcs.Repository.External ( gzFetchFilePS , Cachable( Cachable )) import Darcs.Repository.Flags( UseCache (..), DryRun (..), SetDefault (..), RemoteRepos (..) ) import Darcs.Repository.Lock( readBinFile, writeBinFile ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Path ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory ) import Darcs.Util.Printer( hPutDocLn, text, RenderMode(..) ) import Darcs.Util.URL ( isValidLocalPath ) import Darcs.Util.File ( osxCacheDir, xdgCacheDir, removeFileMayNotExist ) windows,osx :: Bool windows = "mingw" `isPrefixOf` os -- GHC under Windows is compiled with mingw osx = os == "darwin" writeDefaultPrefs :: IO () writeDefaultPrefs = do setPreflist "boring" defaultBoring setPreflist "binaries" defaultBinaries setPreflist "motd" [] {-# NOINLINE defaultBoring #-} defaultBoring :: [String] defaultBoring = map ("# " ++) boringFileHelp ++ [ "" , "### 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$" , "# emacs saved sessions (desktops)" , "(^|.*/)\\.emacs\\.desktop(\\.lock)?$" ] 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 fp = (darcsdir ++ "/") `isPrefixOf` fp || fp == darcsdir -- | 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 :: String -> IO [String] getGlobal f = do dir <- globalPrefsDir case dir of (Just d) -> getPreffile $ d f Nothing -> return [] globalCacheDir :: IO (Maybe FilePath) globalCacheDir | windows = (( "cache2") `fmap`) `fmap` globalPrefsDir | osx = (( "darcs") `fmap`) `fmap` osxCacheDir | otherwise = (( "darcs") `fmap`) `fmap` xdgCacheDir -- |oldGlobalCacheDir is the old cache path @~/.darcs/cache@ -- now ony used with read-only access. oldGlobalCacheDir :: IO (Maybe FilePath) oldGlobalCacheDir = do dir <- (( "cache") `fmap`) `fmap` globalPrefsDir case dir of Nothing -> return Nothing Just d -> do exists <- doesDirectoryExist d if exists then return $ Just d else return Nothing -- |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 Encode 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 <- defPrefval "boringfile" (darcsdir ++ "/prefs/boring") localBores <- getPrefLines borefile `catchall` return [] globalBores <- getGlobal "boring" liftM catMaybes $ mapM tryMakeBoringRegexp $ localBores ++ globalBores boringFileFilter :: IO ([FilePath] -> [FilePath]) boringFileFilter = filterBoringAndDarcsdir `fmap` boringRegexps where filterBoringAndDarcsdir regexps = filter (notBoring regexps . doNormalise) notBoring regexps file = not $ isDarcsdir 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` readBinFile f where removeCRsCommentsAndConflicts = filter notconflict . noncomments . map stripCr . lines 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) {-# 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 = map ("# "++) binariesFileHelp ++ [ "\\." ++ 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" ] 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 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 findPrefsDirectory :: IO (Maybe String) findPrefsDirectory = do inDarcsRepo <- doesDirectoryExist darcsdir return $ if inDarcsRepo then Just $ darcsdir ++ "/prefs/" else Nothing withPrefsDirectory :: (String -> IO ()) -> IO () withPrefsDirectory job = findPrefsDirectory >>= maybe (return ()) job addToPreflist :: String -> String -> IO () addToPreflist pref value = withPrefsDirectory $ \prefs -> do hasprefs <- doesDirectoryExist prefs unless hasprefs $ createDirectory prefs pl <- getPreflist pref writeBinFile (prefs ++ pref) . unlines $ union [value] pl getPreflist :: String -> IO [String] getPreflist p = findPrefsDirectory >>= 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" $ 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 fixRepoPath :: String -> IO FilePath fixRepoPath p | isValidLocalPath p = toFilePath `fmap` ioAbsolute p | otherwise = return p defaultrepo :: RemoteRepos -> AbsolutePath -> [String] -> IO [String] defaultrepo (RemoteRepos rrepos) _ [] = do case rrepos of [] -> maybeToList `fmap` getDefaultRepoPath rs -> mapM fixRepoPath rs defaultrepo _ _ r = return r getDefaultRepoPath :: IO (Maybe String) getDefaultRepoPath = do defaults <- getPreflist defaultRepoPref case defaults of [] -> return Nothing (d : _) -> Just `fmap` fixRepoPath d defaultRepoPref :: String defaultRepoPref = "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 -> RemoteRepos -> SetDefault -> IO () addRepoSource r isDryRun (RemoteRepos rrepos) setDefault = (do olddef <- getPreflist defaultRepoPref let shouldDoIt = null noSetDefault && greenLight greenLight = shouldAct && not rIsTmp && (olddef /= [r] || olddef == []) -- 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 defaultRepoPref [r] else when (True `notElem` noSetDefault && greenLight) $ putStr . unlines $ setDefaultMsg addToPreflist "repos" r) `catchall` return () where shouldAct = isDryRun == NoDryRun rIsTmp = r `elem` rrepos noSetDefault = case setDefault of NoSetDefault x -> [x] _ -> [] setDefaultMsg = [ "HINT: if you want to change the default remote repository to" , " " ++ r ++ "," , " quit now and issue the same command with the --set-default " ++ "flag." ] -- | delete references to other repositories. -- Used when cloning to a ssh destination. -- Assume the current working dir is the repository. deleteSources :: IO () deleteSources = do let prefsdir = darcsdir ++ "/prefs/" removeFileMayNotExist (prefsdir ++ "sources") removeFileMayNotExist (prefsdir ++ "repos") getCaches :: UseCache -> String -> IO Cache getCaches useCache repodir = do here <- parsehs `fmap` getPreffile sourcesFile there <- (parsehs . lines . BC.unpack) `fmap` (gzFetchFilePS (repodir sourcesFile) Cachable `catchall` return B.empty) oldGlobalcachedir <- oldGlobalCacheDir globalcachedir <- globalCacheDir let oldGlobalcache = if nocache then [] else case oldGlobalcachedir of Nothing -> [] Just d -> [Cache Directory NotWritable d] 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] thatrepo = [Cache Repo NotWritable repodir] tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++ here ++ thatrepo ++ filterExternalSources there ++ oldGlobalcache return $ Ca $ sortBy compareByLocality tempCache where sourcesFile = darcsdir ++ "/prefs/sources" 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 = useCache == NoUseCache filterExternalSources there = if isValidLocalPath repodir then there else filter (not . isValidLocalPath . cacheSource) there darcs-2.10.2/src/Darcs/Repository/Util.hs0000644000175000017500000004127412620122474022205 0ustar00guillaumeguillaume00000000000000-- 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. {-# LANGUAGE CPP #-} module Darcs.Repository.Util ( getReplaces , floatSubPath , maybeApplyToTree , defaultToks , getMovesPs , patchSetfMap , getRecursiveDarcsRepos ) where import Prelude hiding ( catch ) import Control.Applicative ( (<$>) ) import Control.Monad ( foldM, forM ) import Control.Exception ( catch, IOException ) import qualified Data.ByteString as B ( null, concat ) import qualified Data.ByteString.Char8 as BC ( unpack, pack ) import qualified Data.ByteString.Lazy as BL ( toChunks ) import Data.Maybe ( isJust, fromJust, catMaybes ) import Data.Ord ( comparing ) import Data.List ( sortBy ) #ifdef USE_LOCAL_DATA_MAP_STRICT import qualified Darcs.Data.Map.Strict as M ( Map, lookup, fromList, insert, map, empty, assocs, size, findWithDefault, delete ) #else import qualified Data.Map.Strict as M ( Map, lookup, fromList, insert, map, empty, assocs, size, findWithDefault, delete ) #endif import Storage.Hashed( floatPath, readPlainTree ) import Storage.Hashed.Tree ( Tree, emptyTree, expand, ItemType(..), itemType, readBlob, modifyTree, findFile, TreeItem(..), makeBlobBS, expandPath ) import Storage.Hashed.AnchoredPath ( AnchoredPath, anchorPath, parents, replacePrefixPath, anchoredRoot ) import qualified Storage.Hashed.Tree as T ( list ) import Storage.Hashed.Index ( listFileIDs, getFileID ) import System.Posix.Types ( FileID ) import System.Directory ( getDirectoryContents, doesDirectoryExist ) import System.FilePath.Posix ( () ) import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, primIsHunk, applyToTree, tokreplace, forceTokReplace, move ) import Darcs.Patch.Set ( newset2RL, PatchSet(..) ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Patchy ( Apply ) import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), Prim(..) ) import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize ) import Darcs.Patch.Permutations ( partitionRL ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) import Darcs.Patch.TokenReplace ( breakOutToken ) import Darcs.Patch.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..), foldlFL, concatFL, toFL, (+>+), mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft, mapSeal, freeGap, emptyGap, joinGap, FreeLeft, Gap(..) ) import Darcs.Repository ( Repository , readUnrecorded , readRecordedAndPending , maybeIdentifyRepository ) import Darcs.Repository.Internal ( IdentifyRepo(..) ) import Darcs.Repository.InternalTypes ( Repository(..), Pristine(..) ) import Darcs.Repository.Diff( treeDiff ) import Darcs.Repository.Flags ( UseIndex(..), ScanKnown, DiffAlgorithm(..), UseCache(..) ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Repository.State ( TreeFilter(..), applyTreeFilter, restrictSubpaths, readWorking, restrictBoring, readIndex ) import Darcs.Util.Path( fn2fp, SubPath, toFilePath, simpleSubPath, normPath, floatSubPath ) getMovesPs :: forall p wR wU wB prim. (PrimConstruct prim, PrimCanonize prim, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository p wR wU wR -> Maybe [SubPath] -> IO (FL prim wB wB) getMovesPs repository files = mkMovesFL <$> getMovedFiles repository files where mkMovesFL [] = NilFL mkMovesFL ((a,b,_):xs) = move (anchorPath "" a) (anchorPath "" b) :>: mkMovesFL xs getMovedFiles :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository p wR wU wR -> Maybe [SubPath] -> IO [(AnchoredPath, AnchoredPath, ItemType)] getMovedFiles repo fs = do old <- sortBy (comparing snd) <$> (listFileIDs =<< readIndex repo) nonboring <- restrictBoring emptyTree new <- sortBy (comparing snd) <$> (addFileIDs . (map (\(a,b) -> (a, itemType b)) . T.list) =<< expand =<< applyTreeFilter nonboring <$> readPlainTree ".") let movedfiles = matchFileLists old new fmovedfiles = case fs of Nothing -> movedfiles Just subpath -> filter (\(old',new',_) -> old' `elem` selfiles || new' `elem` selfiles) movedfiles where selfiles = map (floatPath . toFilePath) subpath return (resolveMoves fmovedfiles) resolveMoves :: [(AnchoredPath, AnchoredPath, ItemType)] -> [(AnchoredPath, AnchoredPath, ItemType)] resolveMoves xs = changePaths $ resolveDeps 0 (M.size movesMap) visited movesMap movesDepsMap where changePaths [] = [] changePaths (y:ys) | fst' y == snd' y = changePaths $ map replacepp ys | isPath y = y:changePaths (map replacepp ys) | otherwise = y:changePaths ys where replacepp i | nfst == anchoredRoot = i | otherwise = (nfst, snd' i, thd' i) where nfst = replacePrefixPath (fst' y) (snd' y) (fst' i) -- sort and index moves movesMap = M.fromList $ zip [0..] $ sortBy (comparing thd') xs movesIDMap :: M.Map (AnchoredPath,AnchoredPath,ItemType) Int movesIDMap = M.fromList $ zip (sortBy (comparing thd') $ xs) [0..] -- establish a relation of dependencies between moves (destination or parent of destination is moved again) movesDepsMap :: M.Map Int [Int] movesDepsMap = M.map (getMoveDeps (M.fromList (map (\x -> (fst' x,x)) xs)) (M.fromList (map (\x -> (snd' x,x)) xs))) movesMap getMoveDeps :: M.Map AnchoredPath (AnchoredPath, AnchoredPath, ItemType) -- source to move -> M.Map AnchoredPath (AnchoredPath, AnchoredPath, ItemType) -- destin to move -> (AnchoredPath, AnchoredPath, ItemType) -- some move -> [Int] getMoveDeps am bm y = catMaybes $ map (`M.lookup` movesIDMap) $ -- retrieve mode ID of deps catMaybes $ byname ++ map (`M.lookup` bm) (parents $ snd' y) -- see if current move is moved to moved dir where byname | fst' y == snd' y = [] | otherwise = [M.lookup (snd' y) am] -- see if current move is moved again fst' (a,_,_) = a snd' (_,a,_) = a thd' (_,_,a) = a resolveDeps :: Int -> Int -> M.Map Int (Int,Bool) -> M.Map Int (AnchoredPath, AnchoredPath, ItemType) -> M.Map Int [Int] -> [(AnchoredPath, AnchoredPath, ItemType)] resolveDeps n end v mm mdm | n == end = reverse $ catMaybes $ map (flip M.lookup mm . abs) $ getMoves (map fst (filter (\(_,(_,f)) -> f) $ sortBy (comparing (fst . snd)) (M.assocs v))) mdm | M.lookup n v /= Nothing = resolveDeps (n+1) end v mm mdm | otherwise = resolveDeps (n+1) end nv nmm nmdm where (nv, nmm, nmdm) = walk True n n v mm mdm getMoves [] _ = [] getMoves (r:roots) mdm = [r]++bds r++getMoves roots mdm where bds r' = lookupList r' mdm ++ concatMap bds (map abs $ lookupList r' mdm) lookupList x mdm = M.findWithDefault [] x mdm walk b n x v mm mdm | x < 0 = (v, mm, mdm) | Just n == (fst <$> M.lookup x v) = resolveClashName n x v mm mdm | otherwise = foldl (\(v',mm', mdm') dep -> walk False n dep v' mm' mdm') (M.insert x (n,b) v, mm, mdm) (lookupList x mdm) -- Ignore swap moves -- Currently, handling them would involve introducing intermediate file names. -- When darcs has swapmove primitive hunk we may fix this. resolveClashName n x v mm mdm = (v', mm', mdm') where v' = M.insert x (n,False) $ foldl addvisited v (lookupList x mdm) mm' = M.delete x mm -- forget about x mdm' = M.insert x [] mdm -- remove dependencies for x addvisited nv k | (fst <$> M.lookup k nv) /= Just n = foldl addvisited (M.insert k (n, False) nv) (lookupList k mdm) | otherwise = nv visited = M.empty :: M.Map Int (Int, Bool) isPath (_, _, TreeType) = True isPath _ = False addFileIDs :: [(AnchoredPath, ItemType)] -> IO [((AnchoredPath, ItemType),FileID)] addFileIDs = foldM (\xs (apath, it)-> do fid <- getFileID apath return $ case fid of Nothing -> xs Just fileid -> ((apath, it), fileid):xs) [] matchFileLists :: [((AnchoredPath, ItemType),FileID)] -> [((AnchoredPath, ItemType),FileID)] -> [(AnchoredPath, AnchoredPath, ItemType)] matchFileLists [] _ = [] matchFileLists _ [] = [] matchFileLists (x:xs) (y:ys) | snd x > snd y = matchFileLists (x:xs) ys | snd x < snd y = matchFileLists xs (y:ys) | snd (fst x) /= snd (fst y) = matchFileLists xs ys | otherwise = (fst (fst x), fst (fst y), snd (fst x)):matchFileLists xs ys -- | 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 p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, wX ~ wR) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> IO (Sealed (FL (PrimOf p) wX)) getReplaces (useindex, _, dopts) repo files = do relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) files working <- applyTreeFilter relevant <$> case useindex of UseIndex -> readUnrecorded repo Nothing IgnoreIndex -> readWorking pending <- applyTreeFilter relevant <$> readRecordedAndPending repo ftf <- filetypeFunction Sealed changes <- unFreeLeft <$> treeDiff dopts ftf pending working _ :> hunks <- return $ partitionRL primIsHunk $ reverseFL changes let unfilteredReplaces = foldlFL modifiedTokens [] (reverseRL hunks) replaces = filterInvalidReplaces unfilteredReplaces mapSeal concatFL . toFL <$> mapM (\(f,a,b) -> doReplace defaultToks pending (fromJust $ simpleSubPath $ fn2fp $ normPath f) (BC.unpack a) (BC.unpack b)) replaces where -- get individual tokens that have been modified modifiedTokens xs (FP f (Hunk _ old new)) = (map (\(a,b) -> (f, a, b)) $ concatMap checkForReplaces $ filter (\(a,b) -> length a == length b) $ zip (map breakToTokens old) (map breakToTokens new)) ++xs modifiedTokens _ _ = error "modifiedTokens: Not Hunk patch" -- from a pair of token lists, create a pair of modified token lists checkForReplaces ([],[]) = [] checkForReplaces ((a:as),(b:bs)) | a == b = checkForReplaces (as,bs) | otherwise = (a,b):checkForReplaces (as,bs) checkForReplaces _ = error "checkForReplaces: Lists are not of the same length" -- keep tokens that have been consistently replaced filterInvalidReplaces [] = [] filterInvalidReplaces ((f,old,new):rs) | any (\(f',a,b) -> f' == f && old == a && b /= new) rs = filterInvalidReplaces $ filter (\(f'',a',_) -> f'' == f && a' /= old) rs filterInvalidReplaces (r:rs) = r:filterInvalidReplaces (filter (/=r) rs) -- break a single bytestring into tokens breakToTokens input | B.null input = [] breakToTokens input = let (_, tok, remaining) = breakOutToken defaultToks input in tok : breakToTokens remaining doReplace toks pend f old new = do let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p pendReplaced <- maybeReplace pend if pendReplaced then return $ joinGap (:>:) (freeGap replacePatch) gapNilFL else getForceReplace f toks pend old new where gapNilFL = emptyGap NilFL fp = toFilePath f replacePatch = tokreplace fp toks old new getForceReplace :: PrimPatch prim => SubPath -> String -> Tree IO -> String -> String -> IO (FreeLeft (FL prim)) getForceReplace f toks tree old new = do let path = floatSubPath f -- 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 Storage.Hashed.Tree is justified. expandedTree <- expandPath tree path content <- case findFile expandedTree path of Just blob -> readBlob blob Nothing -> do 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 <- filetypeFunction normaliseNewTokPatch <- treeDiff dopts ftf expandedTree tree' return . joinGap (+>+) normaliseNewTokPatch $ freeGap $ tokreplace (toFilePath f) toks old new :>: NilFL maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO -> IO (Maybe (Tree IO)) maybeApplyToTree patch tree = (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing) patchSetfMap:: (forall wW wZ . PatchInfoAnd p wW wZ -> IO a) -> PatchSet p wW' wZ' -> IO [a] patchSetfMap f = sequence . mapRL f . newset2RL defaultToks :: String defaultToks = "A-Za-z_0-9" -- |getRecursiveDarcsRepos returns all paths to repositories under topdir. getRecursiveDarcsRepos :: FilePath -> IO [FilePath] getRecursiveDarcsRepos topdir = do isDir <- doesDirectoryExist topdir if isDir then do status <- maybeIdentifyRepository NoUseCache topdir case status of GoodRepository (Repo _ _ pris _) -> case pris of HashedPristine -> return [topdir] _ -> return [] -- old fashioned or broken repo _ -> getRecursiveDarcsRepos' topdir else return [] where getRecursiveDarcsRepos' d = do names <- getDirectoryContents d let properNames = filter (\x -> head x /= '.') names paths <- forM properNames $ \name -> do let path = d name getRecursiveDarcsRepos path return (concat paths) darcs-2.10.2/src/Darcs/Repository/Read.hs0000644000175000017500000000213012620122474022127 0ustar00guillaumeguillaume00000000000000module Darcs.Repository.Read ( readRepo ) where import Darcs.Patch (RepoPatch) import Darcs.Patch.Apply ( ApplyState ) import Storage.Hashed.Tree ( Tree ) import Darcs.Repository.InternalTypes ( Repository(Repo) ) import Darcs.Patch.Set ( PatchSet, Origin ) import Darcs.Repository.Format ( formatHas, RepoProperty(HashedInventory) ) import qualified Darcs.Repository.HashedRepo as HashedRepo ( readRepo ) import qualified Darcs.Repository.Old as Old ( readOldRepo ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -- @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 wR wU wT -> IO (PatchSet p Origin wR) readRepo repo@(Repo r rf _ _) | formatHas HashedInventory rf = HashedRepo.readRepo repo r | otherwise = do Sealed ps <- Old.readOldRepo r return $ unsafeCoerceP ps darcs-2.10.2/src/Darcs/Repository/Rebase.hs0000644000175000017500000002212612620122474022464 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2009-2012 Ganesh Sittampalam -- -- BSD3 {-# LANGUAGE CPP #-} module Darcs.Repository.Rebase ( withManualRebaseUpdate , rebaseJob , startRebaseJob , repoJobOnRebaseRepo ) where import Darcs.Util.Global ( darcsdir ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.CommuteFn ( commuterIdRL ) import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully ) import Darcs.Patch.Rebase ( RebaseFixup , Rebasing , mkSuspended , takeHeadRebase , takeAnyRebase , takeAnyRebaseAndTrailingPatches , countToEdit ) import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..) , RecontextRebase1(..) , RecontextRebase2(..) ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Set ( PatchSet(..) ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..), reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), FlippedSeal(..) ) import Darcs.Repository.Flags ( Compression , UpdateWorking(..) , Verbosity ) import Darcs.Repository.Format ( RepoProperty ( RebaseInProgress ) , formatHas , addToFormat , removeFromFormat , writeRepoFormat ) import Darcs.Repository.Internal ( tentativelyAddPatch , tentativelyAddPatch_ , tentativelyAddPatches_ , tentativelyRemovePatches , tentativelyRemovePatches_ , finalizeRepositoryChanges , revertRepositoryChanges , readTentativeRepo , readRepo , UpdatePristine(..) ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Util.Progress ( debugMessage ) import Storage.Hashed.Tree ( Tree ) import Control.Applicative ( (<$>) ) import Control.Exception ( finally ) import System.FilePath.Posix ( () ) #include "impossible.h" withManualRebaseUpdate :: forall p x wR wU wT1 wT2 . (RepoPatch p, ApplyState p ~ Tree) => Compression -> Verbosity -> UpdateWorking -> Repository p wR wU wT1 -> (Repository p wR wU wT1 -> IO (Repository p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)) -> IO (Repository p wR wU wT2, x) withManualRebaseUpdate compr verb uw r subFunc | Just (RecontextRebase1 recontext1) <- recontextRebase :: Maybe (RecontextRebase1 p) = do patches <- readTentativeRepo r let go :: PatchSet p wS wT1 -> IO (Repository p wR wU wT2, x) go (PatchSet NilRL _) = bug "trying to recontext rebase without rebase patch at head (tag)" go (PatchSet (q :<: _) _) = case recontext1 (hopefully q) of (NotEq, _) -> bug "trying to recontext rebase without rebase patch at head (not match)" (IsEq, recontext2) -> do r' <- tentativelyRemovePatches r compr uw (q :>: NilFL) (r'', fixups, x) <- subFunc r' q' <- n2pia <$> recontextFunc2 recontext2 fixups r''' <- tentativelyAddPatch r'' compr verb uw q' return (r''', x) go patches withManualRebaseUpdate _compr _verb _uw r subFunc = do (r', _, x) <- subFunc r return (r', x) -- got a normal darcs operation to run on a repo that happens to have a rebase in progress repoJobOnRebaseRepo :: (RepoPatch p, ApplyState p ~ Tree) => (Repository (Rebasing p) wR wU wR -> IO a) -> Repository (Rebasing p) wR wU wR -> IO a repoJobOnRebaseRepo job repo = do res <- job repo -- TODO can we munge the repo here to hide the rebase patch? displaySuspendedStatus repo return res -- got a rebase operation to run where it is required that a rebase is already in progress rebaseJob :: (RepoPatch p, ApplyState p ~ Tree) => (Repository (Rebasing p) wR wU wR -> IO a) -> Repository (Rebasing p) wR wU wR -> Compression -> Verbosity -> UpdateWorking -> IO a rebaseJob job repo compr verb uw = do repo' <- moveRebaseToEnd repo compr verb uw job repo' -- the use of finally here is because various things in job -- might cause an "expected" early exit leaving us needing -- to remove the rebase-in-progress state (e.g. when suspending, -- conflicts with recorded, user didn't specify any patches). -- It's a bit questionable/non-standard as it's doing quite a bit -- of cleanup and if there was an unexpected error then this -- may may things worse. -- The better fix would be to standardise expected early exits -- e.g. using a layer on top of IO or a common Exception type -- and then just catch those. `finally` checkSuspendedStatus repo' compr verb uw -- got a rebase operation to run where we may need to initialise the rebase state first startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree) => (Repository (Rebasing p) wR wU wR -> IO a) -> Repository (Rebasing p) wR wU wR -> Compression -> Verbosity -> UpdateWorking -> IO a startRebaseJob job repo compr verb uw = do repo' <- startRebaseIfNecessary repo compr verb uw rebaseJob job repo' compr verb uw checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wR -> Compression -> Verbosity -> UpdateWorking -> IO () checkSuspendedStatus repo@(Repo _ rf _ _) compr verb uw = do allpatches <- readRepo repo (_, Sealed2 ps) <- return $ takeAnyRebase allpatches case countToEdit ps of 0 -> do debugMessage "Removing the rebase patch file..." -- this shouldn't actually be necessary since the count should -- only go to zero after an actual rebase operation which would -- leave the patch at the end anyway, but be defensive. repo' <- moveRebaseToEnd repo compr verb uw revertRepositoryChanges repo' uw -- in theory moveRebaseToEnd could just return the commuted one, -- but since the repository has been committed and re-opened -- best to just do things carefully (rebase, _, _) <- takeHeadRebase <$> readRepo repo' repo'' <- tentativelyRemovePatches repo' compr uw (rebase :>: NilFL) finalizeRepositoryChanges repo'' uw compr writeRepoFormat (removeFromFormat RebaseInProgress rf) (darcsdir "format") putStrLn "Rebase finished!" n -> putStrLn $ "Rebase in progress: " ++ show n ++ " suspended patches" moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wR -> Compression -> Verbosity -> UpdateWorking -> IO (Repository (Rebasing p) wR wU wR) moveRebaseToEnd repo compr verb uw = do allpatches <- readRepo repo case takeAnyRebaseAndTrailingPatches allpatches of FlippedSeal (_ :> NilRL) -> return repo -- already at head FlippedSeal (r :> ps) -> do Just (ps' :> r') <- return $ commuterIdRL selfCommuter (r :> ps) debugMessage "Moving rebase patch to head..." revertRepositoryChanges repo uw repo' <- tentativelyRemovePatches_ DontUpdatePristine repo compr uw (reverseRL ps) repo'' <- tentativelyRemovePatches_ DontUpdatePristine repo' compr uw (r :>: NilFL) repo''' <- tentativelyAddPatches_ DontUpdatePristine repo'' compr verb uw (reverseRL ps') repo'''' <- tentativelyAddPatch_ DontUpdatePristine repo''' compr verb uw r' finalizeRepositoryChanges repo'''' uw compr return repo'''' displaySuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wR -> IO () displaySuspendedStatus repo = do allpatches <- readRepo repo (_, Sealed2 ps) <- return $ takeAnyRebase allpatches putStrLn $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches" startRebaseIfNecessary :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wT -> Compression -> Verbosity -> UpdateWorking -> IO (Repository (Rebasing p) wR wU wT) startRebaseIfNecessary repo@(Repo _ rf _ _) compr verb uw = if formatHas RebaseInProgress rf then return repo else do -- TODO this isn't under the repo lock, and it should be writeRepoFormat (addToFormat RebaseInProgress rf) (darcsdir "format") debugMessage "Writing the rebase patch file..." revertRepositoryChanges repo uw mypatch <- mkSuspended NilFL repo' <- tentativelyAddPatch_ UpdatePristine repo compr verb uw $ n2pia mypatch finalizeRepositoryChanges repo' uw compr return repo' darcs-2.10.2/src/Darcs/Repository/Format.hs0000644000175000017500000002032112620122474022506 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2005 David Roundy -- -- This file is licensed under the GPL, version two or later. {-# LANGUAGE CPP #-} module Darcs.Repository.Format ( RepoFormat(..) , RepoProperty(..) , identifyRepoFormat , tryIdentifyRepoFormat , createRepoFormat , writeRepoFormat , writeProblem , readProblem , transferProblem , formatHas , addToFormat , removeFromFormat ) where #include "impossible.h" import Control.Monad ( mplus, (<=<) ) import qualified Data.ByteString.Char8 as BC ( split, unpack, elemIndex ) import qualified Data.ByteString as B ( null, empty ) import Data.List ( partition, intercalate, (\\) ) import Data.Maybe ( isJust, mapMaybe ) import Darcs.Repository.External ( fetchFilePS , Cachable( Cachable ) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Repository.Lock ( writeBinFile ) import qualified Darcs.Repository.Flags as F ( WithWorkingDir (..) ) import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.Exception ( catchall, prettyException ) import Darcs.Util.ByteString ( linesPS ) import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO ) data RepoProperty = Darcs1 | Darcs2 | HashedInventory | NoWorkingDir | RebaseInProgress | UnknownFormat String deriving ( Eq ) -- | Define string constants in one place, for reuse in show/parse functions. darcs1Format, darcs2Format, hashedInventoryFormat :: String noWorkingDirFormat, rebaseInProgressFormat :: String darcs1Format = "darcs-1.0" darcs2Format = "darcs-2" hashedInventoryFormat = "hashed" noWorkingDirFormat = "no-working-dir" rebaseInProgressFormat = "rebase-in-progress" instance Show RepoProperty where show Darcs1 = darcs1Format show Darcs2 = darcs2Format show HashedInventory = hashedInventoryFormat show NoWorkingDir = noWorkingDirFormat show RebaseInProgress = rebaseInProgressFormat show (UnknownFormat f) = "Unknown format: " ++ f readRepoProperty :: String -> RepoProperty readRepoProperty input | input == darcs1Format = Darcs1 | input == darcs2Format = Darcs2 | input == hashedInventoryFormat = HashedInventory | input == noWorkingDirFormat = NoWorkingDir | input == rebaseInProgressFormat = RebaseInProgress | otherwise = UnknownFormat input -- | Representation of the format of a repository. Each -- sublist corresponds to a line in the format file. -- Currently all lines are expected to be singleton words. newtype RepoFormat = RF [[RepoProperty]] -- | Is a given property contained within a given format? formatHas :: RepoProperty -> RepoFormat -> Bool formatHas f (RF rps) = f `elem` concat rps -- | 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 let k = "Identifying repository " ++ repo beginTedious k finishedOneIO k "format" formatInfo <- (fetchFilePS (repoPath "format") Cachable) `catchall` (return B.empty) -- 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). format <- if (B.null formatInfo || isJust (BC.elemIndex '<' formatInfo)) then do finishedOneIO k "inventory" missingInvErr <- checkFile (repoPath "inventory") case missingInvErr of Nothing -> return . Right $ RF [[Darcs1]] Just e -> return . Left $ makeErrorMsg e else return . Right $ readFormat formatInfo endTedious k return format where repoPath fileName = repo ++ "/" ++ darcsdir ++ "/" ++ fileName readFormat = RF . map (map (readRepoProperty . BC.unpack)) . splitFormat -- split into lines, then split each non-empty line on '|' splitFormat = map (BC.split '|') . filter (not . B.null) . linesPS checkFile path = (fetchFilePS path Cachable >> return Nothing) `catchNonSignal` (return . Just . prettyException) makeErrorMsg e = unlines [ "Not a repository: " ++ repo ++ " (" ++ e ++ ")" , "" , "HINT: Do you have the right URI for the repository?" ] -- | Write the repo format to the given file. writeRepoFormat :: RepoFormat -> FilePath -> IO () writeRepoFormat rf loc = writeBinFile loc $ show rf -- | @createRepoFormat useFormat1 useNoWorkingDir@ create a repo format createRepoFormat :: Bool -> F.WithWorkingDir -> RepoFormat createRepoFormat useFormat1 wwd = RF $ (HashedInventory : flags2wd wwd) : flags2format where flags2format = if useFormat1 then [] else [[Darcs2]] flags2wd F.NoWorkingDir = [NoWorkingDir] flags2wd _ = [] -- | @writeProblem form@ tells if we can write to a repo in format @form@, -- first checking if we can read that repo It returns @Nothing@ if there's no -- problem writing to such a repository. writeProblem :: RepoFormat -> Maybe String writeProblem target = readProblem target `mplus` findProblems target wp where wp [] = impossible wp x = case partition isKnown x of (_, []) -> Nothing (_, unknowns) -> Just . unwords $ "Can't write repository format: " : 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 Darcs2 source /= formatHas Darcs2 target = Just "Cannot mix darcs-2 repositories with older formats" | formatHas RebaseInProgress source = -- we could support this, by applying an appropriate filter to the patches -- as we pull them. Just "Cannot transfer patches from a repository where a 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 repositoryformat: format 2 is incompatible with format 1" readProblem source = findProblems source rp where rp x | any isKnown x = Nothing rp [] = impossible rp x = Just . unwords $ "Can't understand repository format:" : 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 , HashedInventory , NoWorkingDir , RebaseInProgress ] darcs-2.10.2/src/Darcs/Repository/LowLevel.hs0000644000175000017500000001205412620122474023013 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Repository.LowLevel ( readPending , readTentativePending , writeTentativePending -- deprecated interface: , readNewPending , writeNewPending , pendingName ) where import Control.Applicative import qualified Data.ByteString as BS ( empty ) import Darcs.Util.Global ( darcsdir ) import Darcs.Repository.Lock ( writeDocBinFile ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Patch ( readPatch, RepoPatch, PrimOf ) import Darcs.Patch.Read ( ReadPatch(..), bracketedFL ) import Darcs.Patch.ReadMonads ( ParserM ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Util.Exception ( catchall ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal ) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) import Darcs.Util.ByteString ( gzReadFilePS ) import Darcs.Util.Printer ( Doc, ($$), (<>), text, vcat ) pendingName :: String pendingName = darcsdir ++ "/patches/pending" newSuffix, tentativeSuffix :: String newSuffix = ".new" tentativeSuffix = ".tentative" -- | Read the contents of pending. -- The return type is currently incorrect as it refers to the tentative -- state rather than the recorded state. readPending :: RepoPatch p => Repository p wR wU wT -> IO (Sealed (FL (PrimOf p) wT)) readPending = readPendingFile "" -- |Read the contents of tentative pending. readTentativePending :: RepoPatch p => Repository p wR wU wT -> IO (Sealed (FL (PrimOf p) wT)) readTentativePending = readPendingFile tentativeSuffix -- |Read the contents of tentative pending. readNewPending :: RepoPatch p => Repository p wR wU wT -> IO (Sealed (FL (PrimOf p) wT)) readNewPending = readPendingFile newSuffix -- |Read the pending file with the given suffix. CWD should be the repository -- directory. readPendingFile :: ReadPatch prim => String -> Repository p wR wU wT -> IO (Sealed (FL prim wX)) readPendingFile suffix _ = do pend <- gzReadFilePS (pendingName ++ suffix) `catchall` return BS.empty return . maybe (Sealed NilFL) (mapSeal unFLM) . readPatch $ 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 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 = showMaybeBracketedFL showPatch '{' '}' . unFLM readMaybeBracketedFL :: forall m p wX . ParserM m => (forall wY . m (Sealed (p wY))) -> Char -> Char -> m (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 p wR wU wT -> FL (PrimOf p) wT wY -> IO () writeTentativePending = writePendingFile tentativeSuffix -- |Write the contents of new pending. CWD should be the repository directory. writeNewPending :: RepoPatch p => Repository p wR wU wT -> FL (PrimOf p) wT wY -> IO () writeNewPending = writePendingFile newSuffix -- Write a pending file, with the given suffix. CWD should be the repository -- directory. writePendingFile :: ShowPatchBasic prim => String -> Repository p wR wU wT -> FL prim wX wY -> IO () writePendingFile suffix _ = writePatch name . FLM where name = pendingName ++ suffix writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO () writePatch f p = writeDocBinFile f $ showPatch p <> text "\n" darcs-2.10.2/src/Darcs/Repository/Internal.hs0000644000175000017500000013236412620122474023045 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Repository.Internal ( Repository(..) , maybeIdentifyRepository , identifyRepository , identifyRepositoryFor , IdentifyRepo(..) , findRepository , amInRepository , amNotInRepository , amInHashedRepository , revertRepositoryChanges , announceMergeConflicts , setTentativePending , checkUnrecordedConflicts , readRepo , readTentativeRepo , readRepoUsingSpecificInventory , prefsUrl , withRecorded , withTentative , tentativelyAddPatch , tentativelyRemovePatches , tentativelyRemovePatches_ , tentativelyRemoveFromPending , tentativelyAddToPending , tentativelyAddPatch_ , tentativelyAddPatches_ , tentativelyReplacePatches , finalizeRepositoryChanges , unrevertUrl , applyToWorking , patchSetToPatches , createPristineDirectoryTree , createPartialsPristineDirectoryTree , reorderInventory , cleanRepository , setScriptsExecutable , setScriptsExecutablePatches , UpdatePristine(..) , MakeChanges(..) , applyToTentativePristine , makeNewPending , seekRepo ) where import Prelude hiding ( catch ) import Darcs.Util.Printer ( putDocLn , (<+>) , text , ($$) , redText , putDocLnWith , ($$) ) import Darcs.Util.Printer.Color (fancyPrinters) import Darcs.Repository.State ( readRecorded , readWorking , updateIndex ) import Darcs.Repository.LowLevel ( readPending , readTentativePending , writeTentativePending , readNewPending , writeNewPending , pendingName ) import System.Exit ( exitSuccess ) import Darcs.Repository.ApplyPatches ( runTolerantly , runSilently , runDefault ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Repository.Format ( RepoFormat , RepoProperty( HashedInventory , NoWorkingDir ) , tryIdentifyRepoFormat , formatHas , readProblem , transferProblem ) import System.Directory ( doesDirectoryExist , setCurrentDirectory , createDirectoryIfMissing , doesFileExist ) import Control.Monad ( when , unless , filterM , void ) import Control.Applicative ( (<$>) ) import Control.Exception ( catch, IOException ) import qualified Data.ByteString as B ( readFile , isPrefixOf ) import qualified Data.ByteString.Char8 as BC (pack) import Data.List.Ordered ( nubSort ) import Data.Maybe ( fromMaybe ) import Darcs.Patch ( Effect , primIsHunk , primIsBinary , description , tryToShrink , commuteFLorComplain , commute , fromPrim , RepoPatch , Patchy , merge , listConflictedFiles , listTouchedFiles , Named , commuteRL , fromPrims , readPatch , effect , invert , primIsAddfile , primIsAdddir , primIsSetpref , apply , applyToTree ) import Darcs.Patch.Dummy ( DummyPatch ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Prim ( PrimPatchBase , PrimOf , tryShrinkingInverse , PrimPatch ) import Darcs.Patch.Bundle ( scanBundle , makeBundleN ) import Darcs.Patch.Info ( isTag ) import Darcs.Patch.MaybeInternal ( flIsInternal ) import Darcs.Patch.Named ( patchcontents ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd , hopefully , info ) import qualified Darcs.Repository.HashedRepo as HashedRepo ( revertTentativeChanges , finalizeTentativeChanges , removeFromTentativeInventory , copyPristine , copyPartialsPristine , applyToTentativePristine , addToTentativeInventory , readTentativeRepo , readRepoUsingSpecificInventory , cleanPristine , cleanInventories , cleanPatches ) import qualified Darcs.Repository.Old as Old ( revertTentativeChanges , oldRepoFailMsg ) import Darcs.Repository.Flags ( Compression, Verbosity(..), UseCache(..), UpdateWorking (..), AllowConflicts (..), ExternalMerge (..) , WorkRepo (..), WithWorkingDir (WithWorkingDir) ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart ) import Darcs.Patch.Witnesses.Ordered ( FL(..) , RL(..) , (:\/:)(..) , (:/\:)(..) , (:>)(..) , (+>+) , (+<+) , lengthFL , allFL , filterOutFLFL , reverseFL , mapFL_FL , concatFL , reverseRL , mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) , seal , FlippedSeal(FlippedSeal) , flipSeal , mapSeal ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL , removeFL ) import Darcs.Patch.Set ( PatchSet(..) , SealedPatchSet , newset2FL , newset2RL , Origin ) import Darcs.Patch.Depends ( removeFromPatchSet , mergeThem , splitOnTag ) import Darcs.Patch.Show ( ShowPatch ) import Darcs.Util.Path ( FilePathLike , AbsolutePath , toFilePath , ioAbsoluteOrRemote , toPath , anchorPath ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Patch.Progress (progressFL) import Darcs.Util.URL ( isValidLocalPath ) import Darcs.Util.Workaround ( getCurrentDirectory , renameFile , setExecutable ) import Darcs.Repository.Prefs ( getCaches ) import Darcs.Repository.Lock ( writeDocBinFile , removeFileMayNotExist ) import Darcs.Repository.InternalTypes( Repository(..) , Pristine(..) ) import Darcs.Util.Global ( darcsdir ) import System.Mem( performGC ) import qualified Storage.Hashed.Tree as Tree import Storage.Hashed.Tree ( Tree ) import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist ) import Darcs.Repository.Read ( readRepo ) #include "impossible.h" -- | The status of a given directory: is it a darcs repository? data IdentifyRepo p wR wU wT = BadRepository String -- ^ looks like a repository with some error | NonRepository String -- ^ safest guess | GoodRepository (Repository p wR wU wT) -- | Tries to identify the repository in a given directory maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo p wR wU wT) maybeIdentifyRepository useCache "." = do darcs <- doesDirectoryExist darcsdir if not darcs then return (NonRepository $ "Missing " ++ darcsdir ++ " directory") else do repoFormatOrError <- tryIdentifyRepoFormat "." here <- toPath `fmap` 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 here return $ GoodRepository $ Repo here rf pris cs maybeIdentifyRepository useCache url' = do url <- toPath `fmap` ioAbsoluteOrRemote url' repoFormatOrError <- tryIdentifyRepoFormat 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 url return $ GoodRepository $ Repo url rf 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." -- | identifyRepository identifies the repo at 'url'. Warning: -- you have to know what kind of patches are found in that repo. identifyRepository :: forall p wR wU wT. UseCache -> String -> IO (Repository p wR wU wT) identifyRepository useCache url = do er <- maybeIdentifyRepository useCache 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 wR wU wT vR vU vT. RepoPatch p => Repository p wR wU wT -> UseCache -> String -> IO (Repository p vR vU vT) identifyRepositoryFor (Repo _ source _ _) useCache url = do Repo absurl target x c <- identifyRepository useCache url case transferProblem target source of Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e Nothing -> return $ Repo absurl target x c amInRepository :: WorkRepo -> IO (Either String ()) amInRepository (WorkRepoDir d) = do setCurrentDirectory d `catchall` fail ("can't set directory to "++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.") 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 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 YesUseCache "." 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 :: 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 (WorkRepoPossibleURL d) | isValidLocalPath d = do setCurrentDirectory d `catchall` fail ("can't set directory to "++d) findRepository WorkRepoCurrentDir findRepository (WorkRepoDir d) = do setCurrentDirectory d `catchall` fail ("can't set directory to "++d) findRepository WorkRepoCurrentDir findRepository _ = fromMaybe (Right ()) <$> seekRepo -- TODO: see also Repository.State.readPendingLL ... to be removed after GHC 7.2 readNewPendingLL :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Sealed ((FL p) wT)) readNewPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` readNewPending repo -- | @makeNewPending repo YesUpdateWorking pendPs@ verifies that the -- @pendPs@ could be applied to pristine if we wanted to, and if so -- writes it to disk. If it can't be applied, @pendPs@ must -- be somehow buggy, so we save it for forensics and crash. makeNewPending :: forall p wR wU wT wY. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wT wY -> IO () makeNewPending _ NoUpdateWorking _ = return () makeNewPending repo@(Repo r _ _ _) YesUpdateWorking origp = withCurrentDirectory r $ do let newname = pendingName ++ ".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) wT)) -- We don't ever use the resulting tree. _ <- catch (applyToTree p cur) $ \(err :: IOException) -> do let buggyname = pendingName ++ "_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 debugMessage $ "Finished writing new pending: " ++ newname -- | @siftForPending ps@ simplifies the candidate pending patch @ps@ -- through a combination of looking for self-cancellations -- (sequences of patches followed by their inverses), coalescing, -- and getting rid of any hunk/binary patches we can commute out -- the back -- -- The visual image of sifting can be quite helpful here. We are -- repeatedly tapping (shrinking) the patch sequence and -- shaking it (sift). Whatever falls out is the pending we want -- to keep. We do this until the sequence looks about as clean as -- we can get it siftForPending :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> Sealed (FL prim wX) siftForPending simple_ps = if allFL (\p -> primIsAddfile p || primIsAdddir p) oldps then seal oldps else fromJust $ do Sealed x <- return $ sift NilFL $ reverseFL oldps return $ case tryToShrink x of ps | lengthFL ps < lengthFL oldps -> siftForPending ps | otherwise -> seal ps where oldps = fromMaybe simple_ps $ tryShrinkingInverse $ crudeSift simple_ps -- get rid of any hunk/binary patches that we can commute out the -- back (ie. we work our way backwards, pushing the patches down -- to the very end and popping them off; so in (addfile f :> hunk) -- we can nuke the hunk, but not so in (hunk :> replace) sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC) sift sofar NilRL = seal sofar sift sofar (p:<:ps) | primIsHunk p || primIsBinary p = case commuteFLorComplain (p :> sofar) of Right (sofar' :> _) -> sift sofar' ps Left _ -> sift (p:>:sofar) ps sift sofar (p:<:ps) = sift (p:>:sofar) ps readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (PatchSet p Origin wT) 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 wR wU wT -> IO (PatchSet p Origin wT) readRepoUsingSpecificInventory invPath repo@(Repo r rf _ _) | formatHas HashedInventory rf = HashedRepo.readRepoUsingSpecificInventory invPath repo r | otherwise = fail Old.oldRepoFailMsg prefsUrl :: Repository p wR wU wT -> String prefsUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/prefs" unrevertUrl :: Repository p wR wU wT -> String unrevertUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/patches/unrevert" applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p) => Repository p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository p wR wY wT) applyToWorking (Repo r rf t c) verb patch = do unless (formatHas NoWorkingDir rf) $ withCurrentDirectory r $ if verb == Quiet then runSilently $ apply patch else runTolerantly $ apply patch return (Repo r rf t c) -- | @tentativelyRemoveFromPending p@ is used by Darcs whenever it -- adds a patch to the repository (eg. with apply or record). -- Think of it as one part of transferring patches from pending to -- somewhere else. -- -- Question (Eric Kow): how do we detect patch equivalence? tentativelyRemoveFromPending :: forall p wR wU wT wX wY. (RepoPatch p) => Repository p wR wU wT -> UpdateWorking -> PatchInfoAnd p wX wY -> IO () tentativelyRemoveFromPending _ NoUpdateWorking _ = return () tentativelyRemoveFromPending repo YesUpdateWorking p = do Sealed pend <- readTentativePending repo -- Question (Eric Kow): why does pending being all simple matter for -- changepref patches in p? isSimple includes changepref, so what do -- adddir/etc have to do with it? Why don't we we systematically -- crudeSift/not? 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 effect pending@ removes as much of @effect@ from @pending@ -- as possible -- -- Note that @effect@ and @pending@ must start from the same context -- This is not a bad thing to assume because @effect@ is a patch we want to -- add to the repository anyway so it'd kind of have to start from wR anyway -- -- Question (Eric Kow), ok then why not -- @PatchInfoAnd p wR wY@ in the type signature above? rmpend :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB) 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 wX wY -> Bool isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x -- This seems to do the opposite of sifting, ie. we retain hunk/binary patches -- but delete changepref patches. -- -- Why not just filterOutFLFL (not . primIsSetpref)? Is it important to only -- have this behaviour when all other patches are either hunk or binary? crudeSift :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> FL prim wX wY crudeSift xs = if allFL isSimple xs then filterOutFLFL ishunkbinary xs else xs where ishunkbinary :: prim wA wB -> EqCheck wA wB 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 -> AllowConflicts -> ExternalMerge -> FL p wX wY -> IO Bool announceMergeConflicts cmd allowConflicts externalMerge resolved_pw = case nubSort $ listTouchedFiles resolved_pw of [] -> return False cfs -> if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark] || externalMerge /= NoExternalMerge then do putDocLnWith fancyPrinters $ redText "We have conflicts in the following files:" $$ text (unlines cfs) return True else do putDocLnWith fancyPrinters $ redText "There are conflicts in the following files:" $$ text (unlines 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 wT wY. RepoPatch p => UpdateWorking -> FL (Named p) wT wY -> IO Bool checkUnrecordedConflicts NoUpdateWorking _ = return False -- because we are called by `darcs convert` hence we don't care checkUnrecordedConflicts _ pc = do repository <- identifyRepository NoUseCache "." cuc repository where cuc :: Repository p wR wU wT -> IO Bool cuc r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- readPending r :: IO (Sealed (FL (PrimOf p) wT)) 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." exitSuccess return True fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB fromPrims_ = fromPrims tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> Verbosity -> UpdateWorking -> PatchInfoAnd p wT wY -> IO (Repository p wR wU wY) tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine data UpdatePristine = UpdatePristine | DontUpdatePristine | DontUpdatePristineNorRevert deriving Eq tentativelyAddPatches_ :: forall p wR wU wT wY . (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine -> Repository p wR wU wT -> Compression -> Verbosity -> UpdateWorking -> FL (PatchInfoAnd p) wT wY -> IO (Repository p wR wU wY) tentativelyAddPatches_ _up r _compr _verb _uw NilFL = return r tentativelyAddPatches_ up r compr verb uw (p:>:ps) = do r' <- tentativelyAddPatch_ up r compr verb uw p tentativelyAddPatches_ up r' compr verb uw ps -- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun -- :: Bool, with dryRun = unsafePerformIO $ readIORef ... tentativelyAddPatch_ :: forall p wR wU wT wY . (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine -> Repository p wR wU wT -> Compression -> Verbosity -> UpdateWorking -> PatchInfoAnd p wT wY -> IO (Repository p wR wU wY) tentativelyAddPatch_ up r@(Repo dir rf t c) compr verb uw p = withCurrentDirectory dir $ do decideHashedOrNormal rf HvsO { hashed = void $ HashedRepo.addToTentativeInventory c compr p, old = fail Old.oldRepoFailMsg} when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..." applyToTentativePristine r verb p debugMessage "Updating pending..." tentativelyRemoveFromPending r uw p return (Repo dir rf t c) applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, ShowPatch q, PrimPatchBase q) => Repository p wR wU wT -> Verbosity -> q wT wY -> IO () applyToTentativePristine (Repo dir rf _ _) verb p = withCurrentDirectory dir $ do when (verb == Verbose) $ putDocLn $ text "Applying to pristine..." <+> description p decideHashedOrNormal rf HvsO {hashed = HashedRepo.applyToTentativePristine p, old = fail Old.oldRepoFailMsg} -- | @tentativelyAddToPending repo NoDryRun YesUpdateWorking pend ps@ -- appends @ps@ to the pending patch. -- -- It has no effect with @NoUpdateWorking@. -- -- 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 wR wU wT wX wY. RepoPatch p => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO () tentativelyAddToPending _ NoUpdateWorking _ = return () tentativelyAddToPending repo@(Repo dir _ _ _) YesUpdateWorking patch = withCurrentDirectory dir $ do Sealed pend <- readTentativePending repo FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL (PrimOf p) wA wX) patch writeTentativePending repo (unsafeCoercePStart newpend_) where newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC 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 wR wU wT wX wY. RepoPatch p => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO () setTentativePending _ NoUpdateWorking _ = return () setTentativePending repo@(Repo dir _ _ _) YesUpdateWorking patch = do Sealed prims <- return $ siftForPending patch withCurrentDirectory dir $ writeTentativePending repo (unsafeCoercePStart prims) -- | @prepend repo YesUpdateWorking ps@ prepends @ps@ to the pending patch -- It's used right before removing @ps@ from the repo. This ensures that -- the pending patch can still be applied on top of the recorded state. -- -- This function is basically unsafe. It overwrites the pending state -- with a new one, not related to the repository state. prepend :: forall p wR wU wT wX wY. RepoPatch p => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO () prepend _ NoUpdateWorking _ = return () prepend repo YesUpdateWorking patch = do Sealed pend <- readTentativePending repo Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_) where newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA) newpend NilFL patch_ = seal patch_ newpend p patch_ = seal $ patch_ +>+ p tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> UpdateWorking -> FL (PatchInfoAnd p) wX wT -> IO (Repository p wR wU wX) tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine tentativelyRemovePatches_ :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine -> Repository p wR wU wT -> Compression -> UpdateWorking -> FL (PatchInfoAnd p) wX wT -> IO (Repository p wR wU wX) tentativelyRemovePatches_ up repository@(Repo dir rf t c) compr uw ps = withCurrentDirectory dir $ do when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..." prepend repository uw $ effect ps unless (up == DontUpdatePristineNorRevert) $ 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 rf t c) -- FIXME this is a rather weird API. If called with a patch that isn't already -- in the repo, it fails with an obscure error from 'commuteToEnd'. It also -- ends up redoing the work that the caller has already done - if it has -- already commuted these patches to the end, it must also know the commuted -- versions of the other patches in the repo. -- |Given a sequence of patches anchored at the end of the current repository, -- actually pull them to the end of the repository by removing any patches -- with the same name and then adding the passed in sequence. -- Typically callers will have obtained the passed in sequence using -- 'findCommon' and friends. tentativelyReplacePatches :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> UpdateWorking -> Verbosity -> FL (PatchInfoAnd p) wX wT -> IO () tentativelyReplacePatches repository compr uw verb ps = do let ps' = filterOutFLFL (flIsInternal . patchcontents . hopefully) ps repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps' mapAdd repository' ps' where mapAdd :: Repository p wM wL wI -> FL (PatchInfoAnd p) wI wJ -> IO () mapAdd _ NilFL = return () mapAdd r (a:>:as) = do r' <- tentativelyAddPatch_ DontUpdatePristine r compr verb uw a mapAdd r' as -- | Replace the pending patch with the tentative pending. -- If @NoUpdateWorking@, this merely deletes the tentative pending -- without replacing the current one. -- -- Question (Eric Kow): shouldn't this also delete the tentative -- pending if @YesUpdateWorking@? I'm just puzzled by the seeming -- inconsistency of the @NoUpdateWorking@ doing deletion, but -- @YesUpdateWorking@ not bothering. finalizePending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> IO () finalizePending (Repo dir _ _ _) NoUpdateWorking = withCurrentDirectory dir $ removeFileMayNotExist pendingName finalizePending repository@(Repo dir _ _ _) updateWorking@YesUpdateWorking = withCurrentDirectory dir $ do Sealed tpend <- readTentativePending repository Sealed new_pending <- return $ siftForPending tpend makeNewPending repository updateWorking new_pending finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> Compression -> IO () finalizeRepositoryChanges repository@(Repo dir rf _ _) updateWorking compr | formatHas HashedInventory rf = withCurrentDirectory dir $ do debugMessage "Finalizing changes..." withSignalsBlocked $ do HashedRepo.finalizeTentativeChanges repository compr finalizePending repository updateWorking debugMessage "Done finalizing changes..." doesPatchIndexExist dir >>= (`when` createOrUpdatePatchIndexDisk repository) updateIndex repository | otherwise = fail Old.oldRepoFailMsg -- 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 p wR wU wT -> UpdateWorking -> IO () revertRepositoryChanges r@(Repo dir rf _ _) uw = withCurrentDirectory dir $ do removeFileMayNotExist (pendingName ++ ".tentative") Sealed x <- readPending r setTentativePending r uw x when (uw == NoUpdateWorking) $ removeFileMayNotExist pendingName decideHashedOrNormal rf HvsO { hashed = HashedRepo.revertTentativeChanges, old = Old.revertTentativeChanges } patchSetToPatches :: RepoPatch p => PatchSet p wX wY -> FL (Named p) wX wY patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet removeFromUnrevertContext :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> FL (PatchInfoAnd p) wX wT -> 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 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 Origin wZ -> 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 wXxx) -> (forall wYyy . ppp wXxx wYyy -> 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!" cleanRepository :: RepoPatch p => Repository p wR wU wT -> IO () cleanRepository repository@(Repo _ rf _ _) = decideHashedOrNormal rf HvsO { hashed = cleanHashedRepo repository, old = fail Old.oldRepoFailMsg} where cleanHashedRepo r = do HashedRepo.cleanPristine r HashedRepo.cleanInventories r HashedRepo.cleanPatches r -- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree, -- possibly writing a clean working copy in the process. createPristineDirectoryTree :: RepoPatch p => Repository p wR wU wT -> FilePath -> WithWorkingDir -> IO () createPristineDirectoryTree (Repo r rf _ c) reldir wwd | formatHas HashedInventory rf = do createDirectoryIfMissing True reldir withCurrentDirectory reldir $ HashedRepo.copyPristine c r (darcsdir++"/hashed_inventory") wwd | otherwise = fail Old.oldRepoFailMsg -- fp below really should be FileName -- | Used by the commands dist and diff createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p wR wU wT -> [fp] -> FilePath -> IO () createPartialsPristineDirectoryTree (Repo r rf _ c) prefs dir | formatHas HashedInventory rf = do createDirectoryIfMissing True dir withCurrentDirectory dir $ HashedRepo.copyPartialsPristine c r (darcsdir++"/hashed_inventory") prefs | otherwise = fail Old.oldRepoFailMsg withRecorded :: RepoPatch p => Repository p wR wU wT -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a withRecorded repository mk_dir f = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) WithWorkingDir f d withTentative :: forall p a wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a withTentative (Repo dir rf _ c) mk_dir f | formatHas HashedInventory rf = mk_dir $ \d -> do HashedRepo.copyPristine c dir (darcsdir++"/tentative_pristine") WithWorkingDir f d withTentative repository@(Repo dir _ _ _) mk_dir f = withRecorded repository mk_dir $ \d -> do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine") runDefault $ apply ps f d where read_patches :: FilePath -> IO (Sealed (FL p wX)) read_patches fil = do ps <- B.readFile fil return $ fromMaybe (seal NilFL) $ 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_ :: PatchInspect p => Maybe (p wX wY) -> 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 wX wY)) setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO () setScriptsExecutablePatches = setScriptsExecutable_ . Just -- | 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. reorderInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> Compression -> UpdateWorking -> Verbosity -> IO () reorderInventory repository@(Repo _ rf _ _) compr uw verb = decideHashedOrNormal rf HvsO { hashed = do debugMessage "Reordering the inventory." PatchSet ps _ <- misplacedPatches `fmap` readRepo repository tentativelyReplacePatches repository compr uw verb $ reverseRL ps HashedRepo.finalizeTentativeChanges repository compr debugMessage "Done reordering the inventory.", old = fail Old.oldRepoFailMsg } -- | Returns the patches that make the most recent tag dirty. misplacedPatches :: forall p wS wX . RepoPatch p => PatchSet p wS wX -> PatchSet p wS wX misplacedPatches ps = -- Filter the repository keeping only with the tags, ordered from the -- most recent. case filter isTag $ mapRL info $ newset2RL ps of [] -> ps (lt:_) -> -- Take the most recent tag, and split the repository in, -- the clean PatchSet "up to" the tag (ts), and a RL of -- patches after the tag (r). case splitOnTag lt ps of Just (PatchSet xs ts :> r) -> PatchSet (r+<+xs) ts _ -> impossible -- Because the tag is in ps. darcs-2.10.2/src/Darcs/Repository/Match.hs0000644000175000017500000000743512620122474022325 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Repository.Match ( getNonrangeMatch , getPartialNonrangeMatch , getFirstMatch , getOnePatchset ) where import Darcs.Patch.Match ( getNonrangeMatchS , getFirstMatchS , nonrangeMatcherIsTag , getMatchingTag , matchAPatchset , nonrangeMatcher , applyNInv , hasIndexRange , MatchFlag(..) ) import Darcs.Patch.Bundle ( scanContextFile ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, Origin ) import Darcs.Patch.Witnesses.Sealed ( seal ) import Darcs.Repository.Flags ( WithWorkingDir (WithWorkingDir) ) import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault ) import Darcs.Repository.Internal ( Repository, readRepo, createPristineDirectoryTree ) import Storage.Hashed.Tree ( Tree ) import Darcs.Util.Path ( FileName, toFilePath ) #include "impossible.h" getNonrangeMatch :: (ApplyMonad DefaultIO (ApplyState p), RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [MatchFlag] -> IO () getNonrangeMatch r = withRecordedMatch r . getMatch where getMatch fs = case hasIndexRange fs of Just (n, m) | n == m -> applyNInv (n-1) | otherwise -> fail "Index range is not allowed for this command." _ -> getNonrangeMatchS fs getPartialNonrangeMatch :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) => Repository p wR wU wT -> [MatchFlag] -> [FileName] -> IO () getPartialNonrangeMatch r fs _ = withRecordedMatch r (getNonrangeMatchS fs) getFirstMatch :: (ApplyMonad DefaultIO (ApplyState p), RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [MatchFlag] -> IO () getFirstMatch r fs = withRecordedMatch r (getFirstMatchS fs) getOnePatchset :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [MatchFlag] -> IO (SealedPatchSet p 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 `fmap` (scanContextFile . toFilePath . context_f $ fs) where context_f [] = bug "Couldn't match_nonrange_patchset" context_f (Context f:_) = f context_f (_:xs) = context_f xs withRecordedMatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> (PatchSet p Origin wR -> DefaultIO ()) -> IO () withRecordedMatch r job = do createPristineDirectoryTree r "." WithWorkingDir readRepo r >>= runDefault . job darcs-2.10.2/src/Darcs/Repository/External.hs0000644000175000017500000002437112620122474023051 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.Repository.External ( cloneTree , cloneFile , fetchFilePS , fetchFileLazyPS , gzFetchFilePS , speculateFileOrUrl , copyFileOrUrl , Cachable(..) , backupByRenaming , backupByCopying , environmentHelpProtocols ) where import Prelude hiding ( catch ) import Control.Exception ( catch, IOException ) import System.Posix.Files ( getSymbolicLinkStatus , isRegularFile , isDirectory , createLink ) import System.Directory ( createDirectory , getDirectoryContents , doesDirectoryExist , doesFileExist , renameFile , renameDirectory , copyFile ) import System.Exit ( ExitCode(..) ) import System.Environment ( getEnv ) import System.FilePath.Posix ( (), normalise ) import System.IO.Error ( isDoesNotExistError ) import Control.Monad ( unless , when , zipWithM_ ) import Data.Char ( toUpper ) import Darcs.Util.Exec ( exec, Redirect(..) ) import Darcs.Util.Download ( copyUrl , copyUrlFirst , waitUrl , Cachable(..) ) import Darcs.Util.URL ( isValidLocalPath , isHttpUrl , isSshUrl , splitSshUrl ) import Darcs.Util.Text ( breakCommand ) import Darcs.Util.Exception ( catchall ) import Darcs.Repository.Flags ( RemoteDarcs(..) ) import Darcs.Repository.Lock ( withTemp ) import Darcs.Repository.Ssh ( copySSH ) import Darcs.Util.ByteString ( gzReadFilePS ) import qualified Data.ByteString as B (ByteString, readFile ) import qualified Data.ByteString.Lazy as BL #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 copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO () copyFileOrUrl _ fou out _ | isValidLocalPath 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 copyLocal :: String -> FilePath -> IO () copyLocal fou out = createLink fou out `catchall` cloneFile fou out 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 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 -> unless (isDoesNotExistError e) $ ioError e) cloneFile :: FilePath -> FilePath -> IO () cloneFile = copyFile 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 _ | isValidLocalPath 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 = copyAndReadFile BL.readFile #endif gzFetchFilePS :: String -> Cachable -> IO B.ByteString gzFetchFilePS = copyAndReadFile gzReadFilePS 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 copyRemoteNormal :: String -> FilePath -> Cachable -> IO () copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u speculateFileOrUrl :: String -> FilePath -> IO () speculateFileOrUrl fou out | isHttpUrl fou = speculateRemote fou out | otherwise = return () 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 _ = const () `fmap` maybeURLCmd "GET" u #endif environmentHelpProtocols :: ([String], [String]) environmentHelpProtocols = (["DARCS_GET_FOO", "DARCS_APPLY_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 `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:", "", " fetch -q -o -", " curl -s -f", " lynx -source", " wget -q -O -", "", "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:", "", " export DARCS_GET_SMB='smbclient -c get'", " darcs get smb://fs/twb/Desktop/hello-world", "", "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, unfortunately, Darcs splits the command on", "whitespace and does not understand quotation or escaping. Therefore,", "we instead need to put commands in separate, executable scripts.", "", "Continuing our smbclient example, we create an executable script", "`~/.darcs/libexec/get_smb` with the following contents:", "", " #!/bin/bash -e", " IFS=/ read host share file <<<'${1#smb://}'", " smbclient //$host/$share -c 'get $file -'", "", "And at last we can say", "", " export DARCS_GET_SMB=~/.darcs/libexec/get_smb", " darcs get smb://fs/twb/Desktop/hello-world", "", "The APPLY command will be called with a darcs patchfile piped into", "its standard input." ]) darcs-2.10.2/src/Darcs/Repository/InternalTypes.hs0000644000175000017500000000442512620122474024066 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Repository.InternalTypes ( Repository(..), Pristine(..) , extractCache, modifyCache ) where import Data.List ( nub, sortBy ) import Darcs.Repository.Cache ( Cache (..) , compareByLocality ) import Darcs.Repository.Format ( RepoFormat ) import Darcs.Patch ( RepoPatch ) data Pristine = NoPristine | PlainPristine | HashedPristine deriving ( Show, Eq ) -- |A @Repository@ is a token representing the state of a repository on disk. -- It is parameterized by the patch type in the repository, and witnesses for -- the recorded state of the repository (i.e. what darcs get would retrieve), -- the unrecorded state (what's in the working directory now), -- and the tentative state, which represents work in progress that will -- eventually become the new recorded state unless something goes wrong. data Repository (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate = Repo !String !RepoFormat !Pristine Cache deriving ( Show ) extractCache :: Repository p wR wU wT -> Cache extractCache (Repo _ _ _ c) = c -- | 'modifyCache' @repository function@ modifies the cache of -- @repository@ with @function@, remove duplicates and sort the results with 'compareByLocality'. modifyCache :: forall p wR wU wT . (RepoPatch p) => Repository p wR wU wT -> (Cache -> Cache) -> Repository p wR wU wT modifyCache (Repo dir rf pristine cache) f = Repo dir rf pristine $ cmap ( sortBy compareByLocality . nub ) $ f cache where cmap g (Ca c) = Ca (g c) darcs-2.10.2/src/Darcs/Repository/HashedIO.hs0000644000175000017500000003606612620122474022717 0ustar00guillaumeguillaume00000000000000-- 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. {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} module Darcs.Repository.HashedIO ( HashedIO, copyHashed, copyPartialsHashed, cleanHashdir, getHashedFiles, RW(RW) -- only exported to make warning go away , pathsAndContents ) where import Darcs.Util.Global ( darcsdir ) import qualified Data.Set as Set import System.Directory ( getDirectoryContents, createDirectoryIfMissing ) import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift, evalStateT ) import Control.Monad ( when, void, unless ) 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.Patch.ApplyMonad ( ApplyMonad(..) ) import Darcs.Repository.Flags ( Compression( .. ), WithWorkingDir (..) ) import Darcs.Repository.Lock ( writeAtomicFilePS, removeFileMayNotExist ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Progress ( debugMessage, tediousSize, finishedOneIO ) import Darcs.Util.Path ( FileName , normPath , fp2fn , fn2fp , fn2niceps , niceps2fn , breakOnDir , ownName , superName , FilePathLike , toFilePath , isMaliciousSubPath ) import Darcs.Util.ByteString ( 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 ) -- | @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, 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 = snd `fmap` withh h j readroot :: HashedIO p [(ObjType, FileName, String)] readroot = do haveitalready <- peekroot cc <- gets rootHash >>= readdir unless 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 -- pristine files are always compressed lift $ writeFileUsingCache c GzipCompression HashedPristineDir ps -- | Grab a whole pristine tree from a hash, and, if asked, -- write files in the working copy. copyHashed :: String -> Cache -> WithWorkingDir -> String -> IO () copyHashed k c wwd z = void . runStateT cph $ HashDir { permissions = RW, cache = c, rootHash = z } 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) case wwd of WithWorkingDir -> lift $ writeAtomicFilePS (fn2fp n) ps NoWorkingDir -> ps `seq` return () -- force evaluation of ps to actually copy hashed file cp (D,n,h) = if isMaliciousSubPath (fn2fp n) then fail ("Caught malicious path: " ++ fn2fp n) else do lift $ finishedOneIO k (fn2fp n) case wwd of WithWorkingDir -> do lift $ createDirectoryIfMissing False (fn2fp n) lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c WithWorkingDir h NoWorkingDir -> lift $ copyHashed k c NoWorkingDir h -- | Returns a list of pairs (FilePath, (strict) ByteString) of -- the pristine tree starting with the hash @root@. -- @path@ should be either "." or end with "/" -- Separator "/" is used since this function is used to generate -- zip archives from pristine trees. pathsAndContents :: FilePath -> Cache -> String -> IO [(FilePath,B.ByteString)] pathsAndContents path c root = evalStateT cph $ HashDir { permissions = RW, cache = c, rootHash = root } where cph = do cc <- readroot pacs <- concat <$> mapM cp cc let current = if path == "." then [] else [(path ++ "/" , B.empty)] return $ current ++ pacs cp (F,n,h) = do ps <- readhash h let p = (if path == "." then "" else path ++ "/") ++ fn2fp n return [(p,ps)] cp (D,n,h) = do let p = (if path == "." then "" else path) ++ fn2fp n ++ "/" lift $ pathsAndContents p c h copyPartialsHashed :: FilePathLike fp => Cache -> String -> [fp] -> IO () copyPartialsHashed c root = mapM_ (copyPartialHashed c root) copyPartialHashed :: FilePathLike fp => Cache -> String -> fp -> IO () copyPartialHashed c root ff = do createDirectoryIfMissing True (basename $ toFilePath ff) void $ runStateT (cp $ fp2fn $ toFilePath ff) HashDir { permissions = RW, cache = c, rootHash = root } 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 WithWorkingDir 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_ ++ "/" hs <- set <$> getHashedFiles hashdir 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 -- | getHashedFiles returns all hash files targeted by files in hashroots in -- the hashdir directory. getHashedFiles :: String -> [String] -> IO [String] getHashedFiles hashdir hashroots = do let 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 <- concat <$> mapM listone hashroots return hsdarcs-2.10.2/src/Darcs/Repository/Lock.hs0000644000175000017500000003622212620122474022155 0ustar00guillaumeguillaume00000000000000-- 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.Repository.Lock ( withLock , withLockCanFail , environmentHelpLocks , 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 , environmentHelpTmpdir , environmentHelpKeepTmpdir , addToErrorLoc ) where import Prelude hiding ( catch ) import Data.List ( inits ) import Data.Maybe ( isJust, listToMaybe ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( withBinaryFile, openBinaryTempFile, hClose, hPutStr, Handle, IOMode(WriteMode, AppendMode), hFlush, stdout ) import System.IO.Error ( isAlreadyExistsError , annotateIOError ) import Control.Exception ( IOException , bracket , throwIO , catch , try , SomeException ) import System.Directory ( removeFile, removeDirectory, doesFileExist, doesDirectoryExist, getDirectoryContents, createDirectory, getTemporaryDirectory, ) import System.FilePath.Posix ( splitDirectories ) import Control.Concurrent ( threadDelay ) import Control.Monad ( unless, when, liftM ) import Darcs.Util.URL ( isRelative ) import Darcs.Util.Environment ( maybeGetEnv ) import Darcs.Util.Exception ( firstJustIO , catchall ) import Darcs.Util.File ( withCurrentDirectory , doesDirectoryReallyExist, removeFileMayNotExist ) import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath, getCurrentDirectory, setCurrentDirectory ) import Darcs.Util.ByteString ( gzWriteFilePSs, decodeLocale, encodeLocale ) import qualified Data.ByteString as B (null, readFile, hPut, ByteString) import qualified Data.ByteString.Char8 as BC (unpack) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs, RenderMode(..) ) import Darcs.Util.AtExit ( atexit ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Workaround ( renameFile ) import Darcs.Repository.Compat ( mkStdoutTemp , canonFilename , maybeRelink , atomicCreate , sloppyAtomicCreate ) import System.Posix.Files ( fileMode, getFileStatus, setFileMode ) #include "impossible.h" withLock :: String -> IO a -> IO a withLock s job = bracket (getlock s 30) releaseLock (\_ -> 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) (\l -> when l $ releaseLock s) (\l -> if l then liftM Right job 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 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."]) -- |'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 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 = liftM fromJust $ firstJustIO [ liftM (Just . head . words) (readBinFile (darcsdir++"/prefs/tmpdir")) >>= chkdir, maybeGetEnv "DARCS_TMPDIR" >>= chkdir, getTemporaryDirectory >>= chkdir . Just, getCurrentDirectorySansDarcs, return $ Just "." -- always returns a Just ] where chkdir Nothing = return Nothing chkdir (Just d) = liftM (\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 -> String -- path parameter -> (AbsolutePath -> IO a) -> IO a withDir _ "" _ = bug "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 0) (\dir -> do setCurrentDirectory formerdir k <- keepTempDir unless k $ 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 createDir :: FilePath -> Int -> IO AbsolutePath createDir name n = do createDirectory $ newname name n setCurrentDirectory $ newname name n getCurrentDirectory `catch` (\e -> if isAlreadyExistsError e then createDir name (n+1) else throwIO e) keepTempDir = 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 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 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 Standard 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 Standard 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 Standard d writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () writeToFile f job = withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do 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 => p -> (Handle -> IO ()) -> IO () appendToFile f job = withSignalsBlocked $ withBinaryFile (toFilePath f) AppendMode job addToErrorLoc :: IOException -> String -> IOException addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing darcs-2.10.2/src/Darcs/Repository/Job.hs0000644000175000017500000002536512620122474022005 0ustar00guillaumeguillaume00000000000000-- 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 #-} {-# LANGUAGE ForeignFunctionInterface #-} module Darcs.Repository.Job ( RepoJob(..) , withRepoLock , withRepoLockCanFail , withRepository , withRepositoryDirectory ) where import Darcs.Util.Global ( darcsdir ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.V1 ( Patch ) import Darcs.Patch.V2 ( RealPatch ) import Darcs.Patch.Named ( Named ) import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.Prim ( PrimOf ) import Darcs.Patch.Rebase ( Rebasing ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Repository.Flags ( UseCache(..), UpdateWorking(..), DryRun(..), UMask (..) , Compression, Verbosity ) import Darcs.Repository.Format ( RepoProperty( Darcs2 , RebaseInProgress ) , formatHas , writeProblem ) import Darcs.Repository.Internal ( identifyRepository , revertRepositoryChanges ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Rebase ( repoJobOnRebaseRepo , startRebaseJob , rebaseJob ) import Darcs.Repository.Lock ( withLock, withLockCanFail ) import Darcs.Util.Progress ( debugMessage ) import Control.Monad ( when ) import Control.Exception ( bracket_ ) import Foreign.C.String ( CString, withCString ) import Foreign.C.Error ( throwErrno ) import Foreign.C.Types ( CInt(..) ) import Storage.Hashed.Tree ( Tree ) #include "impossible.h" getUMask :: UMask -> Maybe String getUMask (YesUMask s) = Just s getUMask NoUMask = Nothing withUMaskFlag :: UMask -> IO a -> IO a withUMaskFlag = maybe id withUMask . getUMask 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 -- |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 a -- = RepoJob (forall p wR wU . RepoPatch p => Repository p wR wU wR -> IO a) -- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob = -- |The most common @RepoJob@; the underlying action can accept any patch type that -- a darcs repository may use. RepoJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository p wR wU wR -> IO a) -- |A job that only works on darcs 1 patches | V1Job (forall wR wU . Repository (Patch Prim) wR wU wR -> IO a) -- |A job that only works on darcs 2 patches | V2Job (forall wR wU . Repository (RealPatch Prim) wR wU wR -> IO 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 this should be replaced with a more abstract inspection API as part of 'PrimPatch'. | PrimV1Job (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim) => Repository p wR wU wR -> IO a) -- A job that works on normal darcs repositories, but will want access to the rebase patch if it exists. | RebaseAwareJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository p wR wU wR -> IO a) | RebaseJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a) | StartRebaseJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a) onRepoJob :: RepoJob a -> (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => (Repository p wR wU wR -> IO a) -> Repository p wR wU wR -> 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) onRepoJob (RebaseAwareJob compr verb uw job) f = RebaseAwareJob compr verb uw (f job) onRepoJob (RebaseJob compr verb uw job) f = RebaseJob compr verb uw (f job) onRepoJob (StartRebaseJob compr verb uw job) f = StartRebaseJob compr verb uw (f job) -- | apply a given RepoJob to a repository in the current working directory withRepository :: UseCache -> RepoJob a -> IO a withRepository useCache = withRepositoryDirectory useCache "." -- | apply a given RepoJob to a repository in a given url withRepositoryDirectory :: UseCache -> String -> RepoJob a -> IO a withRepositoryDirectory useCache url repojob = do Repo dir rf t c <- identifyRepository useCache url let startRebase = case repojob of StartRebaseJob {} -> True _ -> False case (formatHas Darcs2 rf, startRebase || formatHas RebaseInProgress rf) of (True, False) -> do debugMessage $ "Identified darcs-2 repo: " ++ dir let therepo = Repo dir rf t c :: Repository (RealPatch Prim) wR wU wR case repojob of RepoJob job -> job therepo PrimV1Job job -> job therepo -- TreeJob job -> job therepo V2Job job -> job therepo V1Job _ -> fail $ "This repository contains darcs v1 patches," ++ " but the command requires darcs v2 patches." RebaseAwareJob _compr _verb _uw job -> job therepo RebaseJob {} -> fail "No rebase in progress. Try 'darcs rebase suspend' first." StartRebaseJob {} -> impossible (False, False) -> do debugMessage $ "Identified darcs-1 repo: " ++ dir let therepo = Repo dir rf t c :: Repository (Patch Prim) wR wU wR case repojob of RepoJob job -> job therepo PrimV1Job job -> job therepo V1Job job -> job therepo V2Job _ -> fail $ "This repository contains darcs v2 patches," ++ " but the command requires darcs v1 patches." RebaseAwareJob _compr _verb _uw job -> job therepo RebaseJob {} -> fail "No rebase in progress. Try 'darcs rebase suspend' first." StartRebaseJob {} -> impossible (True, True ) -> do debugMessage $ "Identified darcs-2 rebase repo: " ++ dir let therepo = Repo dir rf t c :: Repository (Rebasing (RealPatch Prim)) wR wU wR case repojob of RepoJob job -> repoJobOnRebaseRepo job therepo PrimV1Job job -> repoJobOnRebaseRepo job therepo -- TreeJob job -> job therepo V2Job _ -> fail "This command is not supported while a rebase is in progress." V1Job _ -> fail $ "This repository contains darcs v1 patches," ++ " but the command requires darcs v2 patches." RebaseAwareJob compr verb uw job -> rebaseJob job therepo compr verb uw RebaseJob compr verb uw job -> rebaseJob job therepo compr verb uw StartRebaseJob compr verb uw job -> startRebaseJob job therepo compr verb uw (False, True ) -> do debugMessage $ "Identified darcs-1 rebase repo: " ++ dir let therepo = Repo dir rf t c :: Repository (Rebasing (Patch Prim)) wR wU wR case repojob of RepoJob job -> repoJobOnRebaseRepo job therepo PrimV1Job job -> repoJobOnRebaseRepo job therepo V1Job _ -> fail "This command is not supported while a rebase is in progress." V2Job _ -> fail $ "This repository contains darcs v2 patches," ++ " but the command requires darcs v1 patches." RebaseAwareJob compr verb uw job -> rebaseJob job therepo compr verb uw RebaseJob compr verb uw job -> rebaseJob job therepo compr verb uw StartRebaseJob compr verb uw job -> startRebaseJob job therepo compr verb uw -- | apply a given RepoJob to a repository in the current working directory, -- taking a lock withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a withRepoLock dry useCache uw um repojob = withRepository useCache $ onRepoJob repojob $ \job repository@(Repo _ rf _ _) -> do maybe (return ()) fail $ writeProblem rf let name = "./"++darcsdir++"/lock" withUMaskFlag um $ if dry == YesDryRun then job repository else withLock name (revertRepositoryChanges repository uw >> job repository) -- | apply a given RepoJob to a repository in the current working directory, -- taking a lock. If lock not takeable, do nothing. withRepoLockCanFail :: UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO () withRepoLockCanFail useCache uw um repojob = withRepository useCache $ onRepoJob repojob $ \job repository@(Repo _ rf _ _) -> do maybe (return ()) fail $ writeProblem rf let name = "./"++darcsdir++"/lock" withUMaskFlag um $ do eitherDone <- withLockCanFail name (revertRepositoryChanges repository uw >> job repository) case eitherDone of Left _ -> debugMessage "Lock could not be obtained, not doing the job." Right _ -> return () darcs-2.10.2/src/Darcs/Repository/Test.hs0000644000175000017500000001276012620122474022205 0ustar00guillaumeguillaume00000000000000-- 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.Repository.Test ( getTest , runPosthook , runPrehook , testTentative ) where import System.Exit ( ExitCode(..) ) import System.Process ( system ) import System.IO ( hPutStrLn, stderr ) import Control.Monad ( when ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Prompt ( askUser ) import Darcs.Repository.Prefs ( getPrefval ) import Darcs.Patch ( RepoPatch ) import Darcs.Repository.Internal ( setScriptsExecutable , withTentative ) import Darcs.Repository.Flags ( LeaveTestDir(..) , Verbosity(..) , SetScriptsExecutable(..) , RunTest (..) ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Repository.Lock ( withTempDir , withPermDir ) import Darcs.Patch.Apply ( ApplyState ) import Storage.Hashed.Tree ( Tree ) getTest :: Verbosity -> IO (IO ExitCode) getTest verb = let putInfo s = when (verb /= Quiet) $ putStr s in do testline <- getPrefval "test" return $ case testline of Nothing -> return ExitSuccess Just testcode -> do putInfo "Running test...\n" runTest testcode putInfo runPosthook :: Maybe String -> Bool -> Verbosity -> AbsolutePath -> IO ExitCode runPosthook mPostHook askPostHook verb repodir = do ph <- getPosthook mPostHook askPostHook withCurrentDirectory repodir $ runHook verb "Posthook" ph getPosthook :: Maybe String -> Bool -> IO (Maybe String) getPosthook mPostHookCmd askPostHook = case mPostHookCmd of Nothing -> return Nothing Just command -> if askPostHook 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 _ -> putStrLn "Posthook cancelled..." >> return Nothing else return $ Just command runPrehook :: Maybe String -> Bool -> Verbosity -> AbsolutePath -> IO ExitCode runPrehook mPreHookCmd askPreHook verb repodir = do ph <- getPrehook mPreHookCmd askPreHook withCurrentDirectory repodir $ runHook verb "Prehook" ph getPrehook :: Maybe String -> Bool -> IO (Maybe String) getPrehook mPreHookCmd askPreHook= case mPreHookCmd of Nothing -> return Nothing Just command -> if askPreHook 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 _ -> putStrLn "Prehook 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 testTentative :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> RunTest -> LeaveTestDir -> SetScriptsExecutable -> Verbosity -> IO ExitCode testTentative = testAny withTentative runTest :: String -> (String -> IO ()) -> IO ExitCode runTest testcode putInfo = do ec <- system testcode if ec == ExitSuccess then putInfo "Test ran successfully.\n" else putInfo "Test failed!\n" return ec testAny :: RepoPatch p => (Repository p wR wU wT -> ((AbsolutePath -> IO ExitCode) -> IO ExitCode) -> (AbsolutePath -> IO ExitCode) -> IO ExitCode ) -> Repository p wR wU wT -> RunTest -> LeaveTestDir -> SetScriptsExecutable -> Verbosity -> IO ExitCode testAny withD repository@(Repo dir _ _ _) doRunTest ltd sse verb = debugMessage "Considering whether to test..." >> if doRunTest == NoRunTest then return ExitSuccess else withCurrentDirectory dir $ do let putInfo = if verb == Quiet 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 (sse == YesSetScriptsExecutable) setScriptsExecutable runTest testcode putInfo where wd = if ltd == YesLeaveTestDir then withPermDir else withTempDir darcs-2.10.2/src/Darcs/Repository/Resolution.hs0000644000175000017500000001635312620122474023433 0ustar00guillaumeguillaume00000000000000-- 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.Repository.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.Repository.Diff( treeDiff ) import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, resolveConflicts, effectOnFilePaths, patchcontents, invert, listConflictedFiles, commute, applyToTree, fromPrim ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Prim ( PrimPatchBase ) import Darcs.Util.Path ( toFilePath, filterFilePaths ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+), mapFL_FL, concatFL, reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft ) import Darcs.Util.CommandLine ( parseCmd ) import Darcs.Patch.PatchInfoAnd ( hopefully ) import Darcs.Util.Prompt ( askEnter ) import Darcs.Patch.Set ( PatchSet(..), Origin ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Util.Exec ( exec, Redirect(..) ) import Darcs.Repository.Lock ( withTempDir ) import Darcs.Repository.External ( cloneTree ) import Darcs.Repository.Flags ( WantGuiPause(..), DiffAlgorithm(..) ) import qualified Storage.Hashed.Tree as Tree import Storage.Hashed ( writePlainTree, readPlainTree ) --import Darcs.Util.Printer.Color ( traceDoc ) --import Darcs.Util.Printer ( greenText, ($$), Doc ) --import Darcs.Patch ( showPatch ) standardResolution :: (PrimPatchBase p, Conflict p, CommuteNoConflicts p) => FL p wX wY -> Sealed (FL (PrimOf p) wY) standardResolution p = mergeList $ map head $ resolveConflicts p mergeList :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX) mergeList = doml NilFL where doml :: FL prim wX wY -> [Sealed (FL prim wX)] -> Sealed (FL prim wX) 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 wX wY wZ wA. (RepoPatch p, ApplyState p ~ Tree.Tree) => DiffAlgorithm -> Tree.Tree IO -> String -- ^ external merge tool command -> WantGuiPause -- ^ tell whether we want GUI pause -> FL (PrimOf p) wX wY -> FL (PrimOf p) wX wZ -> FL p wY wA -> IO (Sealed (FL (PrimOf p) wA)) externalResolution diffa s1 c wantGuiPause 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 wX wY = mapFL_FL fromPrim p1_prim p2 :: FL p wX wZ = mapFL_FL fromPrim p2_prim sa <- applyToTree (invert p1) s1 sm <- applyToTree pmerged s1 s2 <- applyToTree p2 sa let nms = listConflictedFiles pmerged nas = effectOnFilePaths (invert pmerged) nms n1s = effectOnFilePaths p1 nas n2s = effectOnFilePaths 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 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', d1f1), ('2', d2f2), ('a', dafa), ('o', dmfm), ('%', "%")] when (ec /= ExitSuccess) $ putStrLn $ "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,Null,Null) rr [] = return ExitSuccess patchsetConflictResolutions :: RepoPatch p => PatchSet p Origin wX -> Sealed (FL (PrimOf p) wX) 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 $ concatFL $ 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 darcs-2.10.2/src/Darcs/Repository/Flags.hs0000644000175000017500000000613612620122474022322 0ustar00guillaumeguillaume00000000000000module Darcs.Repository.Flags ( Compression (..) , RemoteDarcs (..) , Reorder (..) , Verbosity (..) , UpdateWorking (..) , UseCache (..) , DryRun (..) , UMask (..) , LookForAdds (..) , LookForReplaces (..) , DiffAlgorithm (..) , LookForMoves (..) , RunTest (..) , SetScriptsExecutable (..) , LeaveTestDir (..) , RemoteRepos (..) , SetDefault (..) , UseIndex (..) , ScanKnown (..) , CloneKind (..) , AllowConflicts (..) , ExternalMerge (..) , WorkRepo (..) , WantGuiPause (..) , WithPatchIndex (..) , WithWorkingDir (..) , ForgetParent (..) ) where import Darcs.Util.Diff ( DiffAlgorithm(..) ) data Verbosity = Quiet | NormalVerbosity | Verbose deriving ( Eq, Show ) data Compression = NoCompression | GzipCompression deriving ( Eq, Show ) data WithPatchIndex = YesPatchIndex | NoPatchIndex deriving ( Eq, Show ) data RemoteDarcs = RemoteDarcs String | DefaultRemoteDarcs deriving ( Eq, Show ) data Reorder = NoReorder | Reorder deriving ( Eq ) data UpdateWorking = YesUpdateWorking | NoUpdateWorking 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 = YesLookForAdds | NoLookForAdds deriving ( Eq, Show ) data LookForReplaces = YesLookForReplaces | NoLookForReplaces deriving ( Eq, Show ) data LookForMoves = YesLookForMoves | NoLookForMoves deriving ( Eq, Show ) data RunTest = YesRunTest | NoRunTest deriving ( Eq, Show ) data SetScriptsExecutable = YesSetScriptsExecutable | NoSetScriptsExecutable deriving ( Eq, Show ) data LeaveTestDir = YesLeaveTestDir | NoLeaveTestDir deriving ( Eq, Show ) data RemoteRepos = RemoteRepos [String] deriving ( Eq, Show ) data SetDefault = YesSetDefault Bool | NoSetDefault Bool deriving ( Eq, Show ) data UseIndex = UseIndex | IgnoreIndex deriving ( Eq, Show ) data ScanKnown = ScanKnown -- ^Just files already known to darcs | ScanAll -- ^All files, i.e. look for new ones | ScanBoring -- ^All files, even boring ones -- 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 | YesAllowConflictsAndMark deriving ( Eq, Show ) data ExternalMerge = YesExternalMerge String | NoExternalMerge 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 ) darcs-2.10.2/src/Darcs/Repository/Repair.hs0000644000175000017500000002377212620122474022515 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, PatternGuards #-} module Darcs.Repository.Repair ( replayRepository, checkIndex, replayRepositoryInTemp, RepositoryConsistency(..) ) where import Prelude hiding ( catch ) import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO ) import Control.Applicative( (<$>) ) import Control.Exception ( catch, finally, IOException ) import Data.Maybe ( catMaybes ) import Data.List ( sort, (\\) ) import System.Directory ( createDirectoryIfMissing, getCurrentDirectory, setCurrentDirectory ) import System.FilePath ( () ) import Darcs.Util.Path( anchorPath, AbsolutePath, ioAbsolute, toFilePath ) import Darcs.Patch.PatchInfoAnd ( hopefully, PatchInfoAnd, info, winfo, WPatchInfo, unWPatchInfo, compareWPatchInfo ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), lengthFL, reverseFL, mapRL, nullFL, (:||:)(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Repair ( Repair(applyAndTryToFix) ) import Darcs.Patch.Info ( showPatchInfoUI ) import Darcs.Patch.Set ( Origin, PatchSet(..), newset2FL, newset2RL ) import Darcs.Patch ( RepoPatch, PrimOf, isInconsistent ) import Darcs.Patch.Named ( patchcontents ) import Darcs.Repository.Flags ( Verbosity(..), Compression, DiffAlgorithm ) import Darcs.Repository.Format ( identifyRepoFormat, RepoProperty ( HashedInventory ), formatHas ) import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) import Darcs.Repository.HashedIO ( cleanHashdir ) import Darcs.Repository.HashedRepo ( readHashedPristineRoot, writeAndReadPatch ) import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Repository.Internal ( readRepo ) import Darcs.Repository.State ( readRecorded , readIndex , readRecordedAndPending ) import Darcs.Repository.Diff( treeDiff ) import Darcs.Util.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Global ( darcsdir ) import Darcs.Repository.Lock( rmRecursive, withTempDir ) import Darcs.Util.Printer ( Doc, putDocLn, text, RenderMode(..) ) import Darcs.Util.Printer.Color ( showDoc ) import Storage.Hashed.Monad( TreeIO ) import Storage.Hashed.Darcs( darcsUpdateHashes, hashedTreeIO ) import Storage.Hashed.Hash( Hash(NoHash), encodeBase16 ) import Storage.Hashed.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees ) import Storage.Hashed.Index( updateIndex ) import Storage.Hashed( readPlainTree ) import qualified Data.ByteString.Char8 as BS #include "impossible.h" replaceInFL :: FL (PatchInfoAnd a) wX wY -> [Sealed2 (WPatchInfo :||: PatchInfoAnd a)] -> FL (PatchInfoAnd a) wX wY 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 applyAndFix :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> FL (PatchInfoAnd p) Origin wR -> TreeIO (FL (PatchInfoAnd p) Origin wR, Bool) applyAndFix _ _ NilFL = return (NilFL, True) applyAndFix r@(Repo r' _ _ c) compr 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) wW wZ -> 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 $ showDoc Encode $ showPatchInfoUI $ unWPatchInfo winfp (ps', restok) <- aaf ps case mp' of Nothing -> return (ps', restok) Just (e,pp) -> liftIO $ do putStrLn e p' <- withCurrentDirectory r' $ writeAndReadPatch c compr pp return (Sealed2 (winfp :||: p'):ps', False) data RepositoryConsistency p wX = RepositoryConsistent | BrokenPristine (Tree IO) | BrokenPatches (Tree IO) (PatchSet p Origin wX) checkUniqueness :: (RepoPatch p, ApplyState p ~ Tree) => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p wR wU wT -> 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 $ showPatchInfoUI pinf fail "Duplicate patches found." hasDuplicate :: Ord a => [a] -> Maybe a hasDuplicate li = hd $ sort li where hd [_] = Nothing hd [] = Nothing hd (x1:x2:xs) | x1 == x2 = Just x1 | otherwise = hd (x2:xs) replayRepository' :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree) => DiffAlgorithm -> AbsolutePath -> Repository p wR wU wT -> Compression -> Verbosity -> IO (RepositoryConsistency p wR) replayRepository' dflag whereToReplay' repo compr verbosity = do let whereToReplay = toFilePath whereToReplay' putVerbose s = when (verbosity == Verbose) $ putDocLn s putInfo s = unless (verbosity == Quiet) $ 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 compr psin ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree whereToReplay debugMessage "Done fixing broken patches..." let newpatches = PatchSet (reverseFL ps) NilRL debugMessage "Checking pristine against slurpy" ftf <- filetypeFunction is_same <- do Sealed diff <- unFreeLeft `fmap` treeDiff dflag ftf pris newpris :: IO (Sealed (FL (PrimOf p) wR)) 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) cleanupRepositoryReplay :: Repository p wR wU wT -> 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] replayRepositoryInTemp :: (RepoPatch p, ApplyState p ~ Tree) => DiffAlgorithm -> Repository p wR wU wT -> Compression -> Verbosity -> IO (RepositoryConsistency p wR) replayRepositoryInTemp dflag r compr verb = do repodir <- getCurrentDirectory withTempDir "darcs-check" $ \tmpDir -> do setCurrentDirectory repodir replayRepository' dflag tmpDir r compr verb replayRepository :: (RepoPatch p, ApplyState p ~ Tree) => DiffAlgorithm -> Repository p wR wU wT -> Compression -> Verbosity -> (RepositoryConsistency p wR -> IO a) -> IO a replayRepository dflag r compr verb f = run `finally` cleanupRepositoryReplay r where run = do createDirectoryIfMissing False $ darcsdir "pristine.hashed" hashedPristine <- ioAbsolute $ darcsdir "pristine.hashed" st <- replayRepository' dflag hashedPristine r compr verb f st checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Bool -> IO Bool checkIndex repo quiet = do index <- updateIndex =<< readIndex repo pristine <- expand =<< readRecordedAndPending repo working <- expand =<< restrict pristine <$> readPlainTree "." working_hashed <- darcsUpdateHashes working let index_paths = [ p | (p, _) <- list index ] working_paths = [ p | (p, _) <- list working ] 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 Nothing Nothing = error $ "Bad case at " ++ show p mismatches = [ miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2 ] format paths = unlines $ map ((" " ++) . anchorPath "") paths mismatches_disp = unlines [ anchorPath "" p ++ "\n index: " ++ BS.unpack (encodeBase16 h1) ++ "\n working: " ++ BS.unpack (encodeBase16 h2) | (p, h1, h2) <- mismatches ] unless (quiet || null index_extra) $ putStrLn $ "Extra items in index!\n" ++ format index_extra unless (quiet || null working_extra) $ putStrLn $ "Missing items in index!\n" ++ format working_extra unless (quiet || null mismatches) $ putStrLn $ "Hash mismatch(es)!\n" ++ mismatches_disp return $ null index_extra && null working_extra && null mismatches darcs-2.10.2/src/Darcs/Repository/PatchIndex.hs0000644000175000017500000010022412620122474023306 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, NamedFieldPuns #-} -- 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.Repository.PatchIndex ( doesPatchIndexExist, isPatchIndexDisabled, isPatchIndexInSync, canUsePatchIndex, canCreatePI, createPIWithInterrupt, createOrUpdatePatchIndexDisk, deletePatchIndex, dumpPatchIndex, dumpPatchIndexFiles, filterPatches, PatchFilter, maybeFilterPatches, getRelevantSubsequence, piTest, attemptCreatePatchIndex ) where import Prelude hiding ( catch, pi ) import Data.Binary ( encodeFile, decodeFile ) import Data.Word ( Word32 ) import Data.Int ( Int8 ) import Data.List ( group, mapAccumL, sort, isPrefixOf, nub, (\\) ) import Data.Maybe ( fromMaybe, isJust ) import Data.Set (Set) import Data.Map (Map) import qualified Data.Map as M import qualified Data.Set as S import Control.Exception ( catch ) import Control.Monad ( forM_, unless, when ) import Control.Monad.State.Strict ( evalState, execState, State, gets, modify ) import Control.Applicative ( (<$>) ) import System.Directory ( createDirectory, renameDirectory, doesFileExist, doesDirectoryExist ) import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Read ( readRepo ) import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal, seal2, unsafeUnseal ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd(..), info ) import Darcs.Repository.Lock ( withPermDir, rmRecursive ) import Darcs.Patch ( RepoPatch, listTouchedFiles ) import Darcs.Util.Path ( FileName, fp2fn, fn2fp, toFilePath ) import Darcs.Patch.Apply ( applyToFileMods, ApplyState(..) ) import Darcs.Patch.Set ( newset2FL, Origin, newset2FL ) import Darcs.Patch.Patchy ( Commute ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Patch.Index.Types import System.FilePath( () ) import System.IO (openFile, IOMode(WriteMode), hClose) import qualified Data.ByteString as B import Darcs.Util.Crypt.SHA256 (sha256sum ) import Darcs.Util.Crypt.SHA1 ( SHA1(..), showAsHex ) import Storage.Hashed.Tree ( Tree(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.SignalHandler ( catchInterrupt ) #include "impossible.h" {- ----------------------------------------------------------------------------- The patch index stores additional information that is extracted from the PatchSet for the repository to speed up certain commands. createPatchIndexDisk: Create the on-disk patch-index index from scratch. updatePatchIndexDisk: Update the on-disk patch-index index. ----------------------------------------------------------------------------- -} -- --------------------------------------------------------------------- -- Data structures for the patch-index 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 !FileName -- 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, e.g.. is a file or a directory data FileInfo = FileInfo { isFile::Bool, touching::Set Word32} -- first word of patch hash deriving (Show,Eq,Ord) -- | timespans where a certain filename corresponds to a file with a given id type FileIdSpans = Map FileName [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 { -- |all the PatchIds tracked by this patch index, with the most -- recent patch at the head of the list (note, stored in the -- reverse order to this on disk for backwards compatibility -- with an older format). pids::[PatchId], fidspans::FileIdSpans, fpspans::FilePathSpans, infom::InfoMap } -- | an empty patch-index emptyPatchIndex :: PatchIndex emptyPatchIndex = PatchIndex [] M.empty M.empty M.empty -- | 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 version :: Int8 version = 2 -- --------------------------------------------------------------------- -- Query the patch-index getInventoryHash :: FilePath -> IO String getInventoryHash repodir = do inv <- B.readFile (repodir darcsdir "hashed_inventory") return $ sha256sum inv -- --------------------------------------------------------------------- -- create patch-index -- | 'applyPatchMods pmods pindex' applies a list of PatchMods to the given -- patch index pindex applyPatchMods :: [(PatchId, [PatchMod FileName])] -> PatchIndex -> PatchIndex applyPatchMods pmods pindex = flip execState pindex $ mapM_ goList pmods where goList :: (PatchId, [PatchMod FileName]) -> PIM () -- nubSeq handles invalid patch in darcs repo: -- move with identical target name "rename darcs_patcher to darcs-patcher." goList (pid, mods) = do modify (\pind -> pind{pids = pid:pids pind}) mapM_ (curry go pid) (nubSeq mods) go :: (PatchId, PatchMod FileName) -> PIM () go (pid, PCreateFile fn) = do fid <- createFidStartSpan fn pid startFpSpan fid fn pid createInfo fid True insertTouch fid pid go (pid, PCreateDir fn) = do fid <- createFidStartSpan fn pid startFpSpan fid fn pid createInfo fid False insertTouch fid pid go (pid, PTouch fn) = do fid <- lookupFid fn insertTouch fid pid go (pid, PRename oldfn newfn) = do fid <- lookupFid oldfn stopFpSpan fid pid startFpSpan fid newfn pid insertTouch fid pid stopFidSpan oldfn pid startFidSpan newfn pid fid go (pid, PRemove fn) = do fid <- lookupFid fn insertTouch fid pid stopFidSpan fn pid stopFpSpan fid pid go (_, PInvalid _) = return () -- just ignore invalid changes go (pid, PDuplicateTouch fn) = do fidm <- gets fidspans case M.lookup fn fidm of Just (FidSpan fid _ _:_) -> insertTouch fid pid Nothing -> return () Just [] -> error $ "applyPatchMods: impossible, no entry for "++show fn ++" in FileIdSpans in duplicate, empty list" -- --------------------------------------------------------------------- -- Update and query patch index type PIM a = State PatchIndex a -- | create new filespan for created file createFidStartSpan :: FileName -> 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 -> FileName -> 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 :: FileName -> 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 :: FileName -> 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 S.empty) alt (Just _) = Just (FileInfo isF S.empty) -- forget old false positives -- | insert touching patchid for given file id insertTouch :: FileId -> PatchId -> PIM () insertTouch fid pid = modify (\pind -> pind {infom=M.alter alt fid (infom pind)}) where alt Nothing = impossible "Fileid does not exist" alt (Just (FileInfo isF pids)) = Just (FileInfo isF (S.insert (short pid) pids)) -- | lookup current fid of filepath lookupFid :: FileName -> PIM FileId lookupFid fn = do maybeFid <- lookupFid' fn case maybeFid of Nothing -> bug $ "couldn't find " ++ fn2fp fn ++ " in patch index" Just fid -> return fid -- | lookup current fid of filepatch, returning a Maybe to allow failure lookupFid' :: FileName -> PIM (Maybe FileId) lookupFid' fn = do fidm <- gets fidspans case M.lookup fn fidm of Just (FidSpan fid _ _:_) -> return $ Just fid _ -> return Nothing -- | lookup all the file ids of a given path lookupFidf' :: FileName -> PIM [FileId] lookupFidf' fn = do fidm <- gets fidspans case M.lookup fn fidm of Just spans -> return $ map (\(FidSpan fid _ _) -> fid) spans Nothing -> error $ "lookupFidf': no entry for " ++ show fn ++ " in FileIdSpans" -- | return all fids of matching subpaths -- of the given filepath lookupFids :: FileName -> PIM [FileId] lookupFids fn = do fid_spans <- gets fidspans file_idss <- mapM (lookupFidf' . fp2fn) $ filter (isPrefixOf (fn2fp fn)) (fpSpans2filePaths' fid_spans) return $ nub $ concat file_idss -- | returns a single file id if the given path is a file -- if it is a directory, if returns all the file ids of all paths inside it, -- at any point in repository history lookupFids' :: FileName -> PIM [FileId] lookupFids' fn = do info_map <- gets infom fps_spans <- gets fpspans a <- lookupFid' fn if isJust a then do let fid = fromJust a case M.lookup fid info_map of Just (FileInfo True _) -> return [fid] Just (FileInfo False _) -> let file_names = map (\(FpSpan x _ _) -> x) (fps_spans M.! fid) in nub . concat <$> mapM lookupFids file_names Nothing -> error "lookupFids' : could not find file" else return [] -- | remove sequential duplicates nubSeq :: Eq a => [a] -> [a] nubSeq = map head . group -- --------------------------------------------------------------------- -- Create/Update patch-index on disk -- | create patch index that corresponds to all patches in repo createPatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () createPatchIndexDisk repository = do rawpatches <- newset2FL `fmap` readRepo repository let patches = mapFL Sealed2 rawpatches createPatchIndexFrom repository $ patches2patchMods patches S.empty -- | convert patches to patchmods patches2patchMods :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) => [Sealed2 (PatchInfoAnd p)] -> Set FileName -> [(PatchId, [PatchMod FileName])] patches2patchMods 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 = map fp2fn $ listTouchedFiles p touched_effect = concatMap touched pmods_effect touched_invalid = [ f | (PInvalid f) <- 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_invalid `S.union` S.fromList touched_effect) -- | return set of current filenames in patch index fpSpans2fileNames :: FilePathSpans -> Set FileName 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 (impossible "removePidSuffix") (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 p wR wU wT -> IO () updatePatchIndexDisk repo@(Repo repodir _ _ _) = do (_,_,pid2idx,pindex) <- loadPatchIndex repodir -- check that patch index is up to date patches <- newset2FL `fmap` readRepo repo let pidsrepo = mapFL (makePatchID . info) patches (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 rawpatches <- newset2FL `fmap` readRepo repo let newpatches = drop len_common $ mapFL seal2 rawpatches newpmods = patches2patchMods newpatches filenames inv_hash <- getInventoryHash repodir storePatchIndex repodir 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 :: RepoPatch p => Repository p wR wU wT -> [(PatchId, [PatchMod FileName])] -> IO () createPatchIndexFrom (Repo repodir _ _ _) pmods = do inv_hash <- getInventoryHash repodir storePatchIndex repodir cdir inv_hash (applyPatchMods pmods emptyPatchIndex) where cdir = repodir indexDir -- --------------------------------------------------------------------- -- Load/Store patch-Index -- | load patch-index from disk 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) -- | load patch-index, -- | ensuring that whenever loaded, the patch-index -- | can actually be read by the current version of darcs, -- | and up to date. loadSafePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Map PatchId Int, PatchIndex) loadSafePatchIndex repo@(Repo repodir _ _ _) = do can_use <- isPatchIndexInSync repo (_,_,pid2idx,pi) <- if can_use then loadPatchIndex repodir else do createOrUpdatePatchIndexDisk repo loadPatchIndex repodir return (pid2idx, pi) -- | check if patch-index exits for this repository doesPatchIndexExist :: FilePath -> IO Bool doesPatchIndexExist repodir = do filesArePresent <- fmap and $ mapM (doesFileExist . (pindex_dir )) [repoStateFile, pidsFile, touchMapFile, fidMapFile, fpMapFile] if filesArePresent then do (v, _, _, _) <- loadPatchIndex repodir return (v == version) -- consider PI only of on-disk format is the current one else return False where pindex_dir = repodir indexDir -- | check if noPatchIndex exists isPatchIndexDisabled :: FilePath -> IO Bool isPatchIndexDisabled repodir = doesFileExist (repodir darcsdir noPatchIndex) -- | create or update patch index createOrUpdatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () createOrUpdatePatchIndexDisk repo@(Repo repodir _ _ _)= do rmRecursive (repodir darcsdir noPatchIndex) `catch` \(_ :: IOError) -> return () dpie <- doesPatchIndexExist repodir if dpie then updatePatchIndexDisk repo else createPatchIndexDisk repo -- | 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 :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO Bool canCreatePI (Repo repodir format _ _) = (not . or) <$> sequence [ doesntHaveHashedInventory format , isPatchIndexDisabled repodir , doesPatchIndexExist repodir ] where doesntHaveHashedInventory = return . not . formatHas HashedInventory -- | see if the default is to use patch index or not -- | creates Patch index, if it does not exist, and noPatchIndex is not set canUsePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO Bool canUsePatchIndex (Repo repodir _ _ _) = do piExists <- doesPatchIndexExist repodir piDisabled <- isPatchIndexDisabled repodir case (piExists, piDisabled) of (True, False) -> return True (False, True) -> return False (True, True) -> error "patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify." (False, False) -> return False createPIWithInterrupt :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () createPIWithInterrupt repo@(Repo repodir _ _ _) = do putStrLn "Creating a patch index, please wait. To stop press Ctrl-C" (do createPatchIndexDisk repo putStrLn "Created patch index.") `catchInterrupt` (putStrLn "Patch Index Disabled" >> deletePatchIndex repodir) -- | check if patch-index is in sync with repository isPatchIndexInSync :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO Bool isPatchIndexInSync (Repo repodir _ _ _) = do 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 -- | store patch-index on disk storePatchIndex :: FilePath -> FilePath -> String -> PatchIndex -> IO () storePatchIndex repodir cdir inv_hash (PatchIndex pids fidspans fpspans infom) = do createDirectory cdir `catch` \(_ :: IOError) -> return () tmpdir <- withPermDir (repodir "filecache-tmp") $ \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 rmRecursive cdir `catch` \(_ :: IOError) -> return () renameDirectory tmpdir cdir 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 zero :: PatchId zero = PID $ SHA1 0 0 0 0 0 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 -- | Base directory for the patch index indexDir :: String indexDir = darcsdir "patch_index" repoStateFile :: String repoStateFile = "repo_state" pidsFile :: String pidsFile = "patch_ids" fidMapFile :: String fidMapFile = "fid_map" fpMapFile :: String fpMapFile = "fp_map" touchMapFile :: String touchMapFile = "touch_map" noPatchIndex :: String noPatchIndex = "no_patch_index" ----------------------------------------------------------------------- -- Delete patch index deletePatchIndex :: FilePath -> IO () deletePatchIndex repodir = do exists <- doesDirectoryExist indexDir when exists $ rmRecursive indexDir `catch` \(e :: IOError) -> error $ "Error: Could not delete patch index\n" ++ show e (openFile (repodir darcsdir noPatchIndex) WriteMode >>= hClose) `catch` \(e :: IOError) -> error $ "Error: Could not disable patch index\n" ++ show e ----------------------------------------------------------------------- -- Dump information in patch index dumpRepoState :: [PatchId] -> String dumpRepoState = unlines . map pid2string dumpFileIdSpans :: FileIdSpans -> String dumpFileIdSpans fidspans = unlines [fn2fp 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++" -> "++ fn2fp 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 w32 | (fid,FileInfo isF w32s) <- M.toList infom, w32 <- S.elems w32s] -- | return set of current filepaths in patch index fpSpans2filePaths :: FilePathSpans -> InfoMap -> [FilePath] fpSpans2filePaths fpSpans infom = sort [fn2fp fn ++ (if isF then "" else "/") | (fid,FpSpan fn _ Nothing:_) <- M.toList fpSpans, let Just (FileInfo isF _) = M.lookup fid infom] -- | return set of current filepaths in patch index, for internal use fpSpans2filePaths' :: FileIdSpans -> [FilePath] fpSpans2filePaths' fidSpans = [fn2fp fp | (fp, _) <- M.toList fidSpans] dumpPatchIndex :: FilePath -> IO () dumpPatchIndex repodir = do (_,inv_hash,_,PatchIndex pids fidspans fpspans infom) <- loadPatchIndex repodir putStrLn $ "Inventory hash:" ++ inv_hash putStrLn "=================" putStrLn "Repo state:" putStrLn "===========" putStrLn $ dumpRepoState pids putStrLn "Fileid spans:" putStrLn "=============" putStrLn $ dumpFileIdSpans fidspans putStrLn "Filepath spans:" putStrLn "==============" putStrLn $ dumpFilePathSpans fpspans putStrLn "Info Map:" putStrLn "=========" putStrLn $ dumpTouchingMap infom putStrLn "Files:" putStrLn "==============" putStrLn $ unlines $ fpSpans2filePaths fpspans infom dumpPatchIndexFiles :: FilePath -> IO () dumpPatchIndexFiles repodir = do (_,_,_,PatchIndex _ _ fpspans infom) <- loadPatchIndex repodir putStr $ unlines $ fpSpans2filePaths fpspans infom ----------------------------------------------------------------------- -- Filtering functions based on FilePaths -- returns an RL in which the order of patches matters, for annotate to use getRelevantSubsequence :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) => Sealed ((RL a) wK) -> Repository p wR wU wR -> [FileName] -> IO (Sealed ((RL a) Origin)) getRelevantSubsequence pxes repository fns = do (_, pi@(PatchIndex _ _ _ infom)) <- loadSafePatchIndex repository let fids = map (\fn -> evalState (lookupFid fn) pi) fns pidss = map ((\(FileInfo _ a) -> a).fromJust.(`M.lookup` infom)) fids pids = S.unions pidss let flpxes = reverseRL $ unsafeUnseal 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 -> S.Set Word32 -> RL a wP wQ keepElems NilFL acc _ = unsafeCoerceP acc keepElems (x:>:xs) acc pids | (short $ makePatchID $ info x) `S.member` pids = keepElems xs (x:<:acc) pids | otherwise = keepElems (unsafeCoerceP xs) acc pids -- | filter given patches so as to keep only the patches that modify the given files filterPatches :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) => Repository p wR wU wT -> [FilePath] -> [Sealed2 a] -> IO [Sealed2 a] filterPatches repository fps ops = do (_, pi@(PatchIndex _ _ _ infom)) <- loadSafePatchIndex repository let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi). fp2fn) fps npids = S.unions $ map (touching.fromJust.(`M.lookup` infom)) fids return $ filter (flip S.member npids . (\(Sealed2 (PIAP pin _)) -> short $ makePatchID pin)) ops type PatchFilter p = [FilePath] -> [Sealed2 (PatchInfoAnd p)] -> IO [Sealed2 (PatchInfoAnd p)] -- | If a patch index is available, filter given patches so as to keep only the patches that -- modify the given files. If none is available, return the original input. maybeFilterPatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> PatchFilter p maybeFilterPatches repo fps ops = do usePI <- canUsePatchIndex repo -- in theory we could change the type signature to make this function staged, -- but it doesn't seem worth it. if usePI then filterPatches repo fps ops else return ops ----------------------------------------------------------------------- -- Test patch index piTest :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () piTest repository = do (_, PatchIndex rpids fidspans fpspans infom) <- loadSafePatchIndex repository 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) (error $ "In order test failed! filename: " ++ show fn) forM_ spans $ \(FidSpan fid _ _) -> unless (M.member fid fpspans) (error $ "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) (error $ "In order test failed! fileid: " ++ show fid) forM_ spans $ \(FpSpan fn _ _) -> unless (M.member fn fidspans) (error $ "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 (tail spans)) (error $ "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 S.isSubsetOf (S.fromList $ map short pids) . S.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 -- | Check if patch index can be created and build it with interrupt. attemptCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () attemptCreatePatchIndex repo = do canCreate <- canCreatePI repo when canCreate $ createPIWithInterrupt repo darcs-2.10.2/src/Darcs/Repository/State.hs0000644000175000017500000005004512620122474022344 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} {-# LANGUAGE CPP #-} -- 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.State ( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir -- * Diffs. , unrecordedChanges, unrecordedChangesWithPatches, readPending -- * Trees. , readRecorded, readUnrecorded, readRecordedAndPending, readWorking , readPendingAndWorking -- * Index. , readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..) -- * Utilities , filterOutConflicts ) where import Prelude hiding ( filter, catch ) import Control.Monad( when ) import Control.Applicative( (<$>) ) import Control.Exception ( catch, IOException ) import Data.Maybe( isJust ) import Data.List( union ) import Text.Regex( matchRegex ) import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile ) import System.FilePath ( () ) import qualified Data.ByteString as BS ( readFile, drop, writeFile, empty ) import qualified Data.ByteString.Char8 as BSC ( pack, split ) import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrim, fromPrims , effect, anonymous ) import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths ) import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (+>+), mapFL_FL , (:>)(..) ) import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal ) import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdRL ) import Darcs.Patch.Permutations ( partitionConflictingFL ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir)) import qualified Darcs.Repository.LowLevel as LowLevel import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps ) import Darcs.Repository.Diff ( treeDiff ) import Darcs.Util.Path( AnchoredPath(..), anchorPath, floatPath, Name(..), fn2fp, SubPath, sp2fn, filterPaths ) 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 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 wR wU wT -> IO (Sealed ((FL p) wT)) 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 -- 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 wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [SubPath] -> 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' restrictPaths :: FilterTree tree m => tree m -> tree m restrictPaths = filter (filterPaths anchored) 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 -- | 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.) -- -- 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) 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 restrictTree :: FilterTree t m => t m -> t m restrictTree = filter $ \p _ -> case find guide p of Nothing -> boring' p _ -> 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) -- | 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 wR wU wT . (RepoPatch p, ApplyState p ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU) unrecordedChanges opts r paths = do (pending :> working) <- readPendingAndWorking opts r paths return $ sortCoalesceFL (pending +>+ working) unrecordedChangesWithPatches :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> FL (PrimOf p) wX wT -- look-for-moves patches -> FL (PrimOf p) wT wT -- look-for-replaces patches -> IO (FL (PrimOf p) wT wU) unrecordedChangesWithPatches opts r paths movesPs replacesPs = do (pending :> working) <- readPendingAndWorkingWithPatches opts r paths movesPs replacesPs return $ sortCoalesceFL (pending +>+ unsafeCoerceP (movesPs +>+ replacesPs) +>+ working) -- | Mostly a helper function to 'unrecordedChangesWithPatches', returning the pending -- patch plus `patches` and the subsequent diff from working as two different patches readPendingAndWorkingWithPatches :: forall p wR wU wT wZ. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> FL (PrimOf p) wZ wT -- look-for-moves patches -> FL (PrimOf p) wT wT -- look-for-replaces patches -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU) readPendingAndWorkingWithPatches _ r@(Repo _ rf _ _) _ _ _ | (formatHas NoWorkingDir rf) = do IsEq <- return $ workDirLessRepoWitness r return (NilFL :> NilFL) readPendingAndWorkingWithPatches (useidx', scan, dflag) repo mbpaths movesPs replacesPs = do let allPatches = movesPs +>+ replacesPs let useidx = case allPatches of NilFL -> useidx' _ -> IgnoreIndex (all_current, Sealed (pending :: FL p wT wX)) <- readPending repo all_current_with_patches <- applyToTree allPatches all_current relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths let getIndex = applyToTree movesPs =<< I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) current = applyTreeFilter relevant all_current_with_patches 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 ft <- filetypeFunction Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX)) IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU) return (effect pending :> diff) -- | Mostly a helper function to 'unrecordedChanges', returning the pending -- patch and the subsequent diff from working as two different patches readPendingAndWorking :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU) readPendingAndWorking _ r@(Repo _ rf _ _) _ | (formatHas NoWorkingDir rf) = do IsEq <- return $ workDirLessRepoWitness r return (NilFL :> NilFL) readPendingAndWorking (useidx, scan, dflag) repo mbpaths = do (all_current, Sealed (pending :: FL p wT wX)) <- readPending repo relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) current = applyTreeFilter relevant all_current 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 ft <- filetypeFunction Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX)) IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU) return (effect pending :> 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 wR wU wT -> EqCheck wU wT workDirLessRepoWitness (Repo _ rf _ _) | formatHas NoWorkingDir rf = unsafeCoerceP IsEq | otherwise = NotEq -- | 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 wR wU wT -> 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!" -- | 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. -- -- 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 wR wU wT -> 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 darcsdir) readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO) readRecordedAndPending repo = fst `fmap` readPending repo readPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO, Sealed (FL p wT)) 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 (darcsdir "patches" "pending") (darcsdir "patches" "pending_buggy") return (pristine, seal NilFL) -- | 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 _ = BS.writeFile (darcsdir "index_invalid") BS.empty readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO I.Index readIndex repo = do invalid <- doesFileExist $ darcsdir "index_invalid" exists <- doesFileExist $ darcsdir "index" formatValid <- if exists then I.indexFormatValid $ darcsdir "index" else return True when (exists && not formatValid) $ #if mingw32_HOST_OS renameFile (darcsdir "index") (darcsdir "index.old") #else removeFile $ darcsdir "index" #endif if not exists || invalid || not formatValid then do pris <- readRecordedAndPending repo idx <- I.updateIndexFrom (darcsdir "index") darcsTreeHash pris when invalid $ removeFile $ darcsdir "index_invalid" return idx else I.readIndex (darcsdir "index") darcsTreeHash updateIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () updateIndex repo = do invalid <- doesFileExist $ darcsdir "index_invalid" exists <- doesFileExist $ darcsdir "index" formatValid <- if exists then I.indexFormatValid $ darcsdir "index" else return True when (exists && not formatValid) $ #if mingw32_HOST_OS renameFile (darcsdir "index") (darcsdir "index.old") #else removeFile $ darcsdir "index" #endif pris <- readRecordedAndPending repo _ <- I.updateIndexFrom (darcsdir "index") darcsTreeHash pris when invalid $ removeFile $ darcsdir "index_invalid" -- |Remove any patches (+dependencies) from a sequence that -- conflict with the recorded or unrecorded changes in a repo filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree) => RL (PatchInfoAnd p) wX wT -- ^Recorded patches from repository, starting from -- same context as the patches to filter -> Repository p wR wU wT -- ^Repository itself, used for grabbing unrecorded changes -> 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 us repository them = do let commuter = commuterIdRL selfCommuter unrec <- fmap n2pia . anonymous . fromPrims =<< unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository Nothing them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us) return (check rest, Sealed them') where check :: FL p wA wB -> Bool check NilFL = False check _ = True darcs-2.10.2/src/Darcs/Repository/HashedRepo.hs0000644000175000017500000011100012620122474023273 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Repository.HashedRepo ( inventoriesDir , pristineDir , patchesDir , hashedInventory , revertTentativeChanges , finalizeTentativeChanges , cleanPristine , filterDirContents , cleanInventories , cleanPatches , copyPristine , copyPartialsPristine , applyToTentativePristine , addToSpecificInventory , addToTentativeInventory , removeFromTentativeInventory , readRepo , readTentativeRepo , readRepoUsingSpecificInventory , writeAndReadPatch , writeTentativeInventory , copyHashedInventory , readHashedPristineRoot , pris2inv , inv2pris , copySources , listInventories , listInventoriesLocal , listInventoriesRepoDir , listPatchesLocalBucketed , writePatchIfNecessary , readRepoFromInventoryList , readPatchIds , set , unset ) where #include "impossible.h" import Prelude hiding ( catch ) import Control.Applicative ( (<$>) ) import Control.Arrow ( (&&&) ) import Control.Exception ( catch, IOException ) import Control.Monad ( unless ) import Data.Maybe import qualified Data.ByteString as B ( null, length, empty ,tail, drop, ByteString, splitAt ) import qualified Data.ByteString.Char8 as BC ( unpack, dropWhile, break, pack, ByteString ) import Data.List ( delete ) import qualified Data.Set as Set import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize, readDarcsHashed, writeDarcsHashed, decodeDarcsHash, decodeDarcsSize ) import Storage.Hashed.Tree( treeHash, Tree ) import Storage.Hashed.Hash( encodeBase16, Hash(..) ) import System.Directory ( createDirectoryIfMissing, getDirectoryContents , doesFileExist, doesDirectoryExist ) import System.FilePath.Posix( () ) import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO ( stderr, hPutStrLn ) import Darcs.Util.Printer.Color ( showDoc ) import Darcs.Repository.External ( copyFileOrUrl , cloneFile , fetchFilePS , gzFetchFilePS , Cachable( Uncachable ) ) import Darcs.Repository.Flags ( Compression, RemoteDarcs, WithWorkingDir ) import Darcs.Util.Global ( darcsdir ) import Darcs.Repository.Lock ( writeBinFile , writeDocBinFile , writeAtomicFilePS , appendBinFile , appendDocBinFile , removeFileMayNotExist ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info, extractHash, createHashed ) import Darcs.Patch ( RepoPatch, Patchy, showPatch, readPatch, apply ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.ReadMonads ( parseStrictly ) import Darcs.Patch.Depends ( commuteToEnd, slightlyOptimizePatchset ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo, showPatchInfoUI, readPatchInfo ) import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath ) import Darcs.Repository.Cache ( Cache(..), CacheLoc(..), fetchFileUsingCache, speculateFilesUsingCache, writeFileUsingCache, unionCaches, repo2cache, okayHash, takeHash, HashedDir(..), hashedDir, peekInCache, bucketFolder ) import qualified Darcs.Repository.Cache as DarcsCache import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed, cleanHashdir ) import Darcs.Repository.InternalTypes ( Repository(..), extractCache, modifyCache ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Patch.Witnesses.Ordered ( reverseRL, reverseFL, (+<+), FL(..), RL(..), (:>)(..), mapRL, mapFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.ByteString ( gzReadFilePS, dropSpace ) import Darcs.Util.Crypt.SHA256 ( sha256sum ) import Darcs.Util.Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS, RenderMode(..) ) import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO ) import Darcs.Util.Workaround ( renameFile ) import Darcs.Repository.Prefs ( globalCacheDir ) makeDarcsdirPath :: String -> String makeDarcsdirPath name = darcsdir name hashedInventory, hashedInventoryPath :: String hashedInventory = "hashed_inventory" hashedInventoryPath = makeDarcsdirPath hashedInventory tentativeHashedInventory, tentativeHashedInventoryPath :: String tentativeHashedInventory = "tentative_hashed_inventory" tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory inventoriesDir, inventoriesDirPath :: String inventoriesDir = "inventories" inventoriesDirPath = makeDarcsdirPath inventoriesDir pristineDir, tentativePristinePath, pristineDirPath :: String tentativePristinePath = makeDarcsdirPath "tentative_pristine" pristineDir = "pristine.hashed" pristineDirPath = makeDarcsdirPath pristineDir patchesDir, patchesDirPath :: String patchesDir = "patches" patchesDirPath = makeDarcsdirPath patchesDir pristineNamePrefix :: String pristineNamePrefix = "pristine:" pristineName :: B.ByteString pristineName = BC.pack pristineNamePrefix -- | 'applyToHashedPristine' takes a root hash, a patch @p@ and attempts to -- apply the patch to the 'Tree' identified by @h@. If we encounter an old, -- size-prefixed pristine, we first convert it to the non-size-prefixed format, -- then apply the patch. applyToHashedPristine :: (ApplyState p ~ Tree, Patchy p) => String -> p wX wY -> IO String applyToHashedPristine h p = applyOrConvertOldPristineAndApply where applyOrConvertOldPristineAndApply = tryApply hash `catch` \(_ :: IOException) -> handleOldPristineAndApply hash = decodeDarcsHash $ BC.pack h failOnMalformedRoot (SHA256 _) = return () failOnMalformedRoot root = fail $ "Cannot handle hash: " ++ show root hash2root = BC.unpack . encodeBase16 tryApply :: Hash -> IO String tryApply root = do failOnMalformedRoot root -- Read a non-size-prefixed pristine, failing if we encounter one. tree <- readDarcsHashedNosize pristineDirPath root (_, updatedTree) <- hashedTreeIO (apply p) tree pristineDirPath return . hash2root $ treeHash updatedTree warn = "WARNING: Doing a one-time conversion of pristine format.\n" ++ "This may take a while. The new format is backwards-compatible." handleOldPristineAndApply = do hPutStrLn stderr warn inv <- gzReadFilePS hashedInventoryPath let oldroot = BC.pack $ inv2pris inv oldrootSizeandHash = (decodeDarcsSize &&& decodeDarcsHash) oldroot -- Read the old size-prefixed pristine tree old <- readDarcsHashed pristineDirPath oldrootSizeandHash -- Write out the pristine tree as a non-size-prefixed pristine. root <- writeDarcsHashed old pristineDirPath let newroot = hash2root root -- Write out the new inventory. writeDocBinFile hashedInventoryPath $ pris2inv newroot inv cleanHashdir (Ca []) HashedPristineDir [newroot] hPutStrLn stderr "Pristine conversion done..." -- Retry applying the patch, which should now succeed. tryApply root -- |revertTentativeChanges swaps the tentative and "real" hashed inventory -- files, and then updates the tentative pristine with the "real" inventory -- hash. revertTentativeChanges :: IO () revertTentativeChanges = do cloneFile hashedInventoryPath tentativeHashedInventoryPath i <- gzReadFilePS hashedInventoryPath writeBinFile tentativePristinePath $ pristineNamePrefix ++ inv2pris i -- |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, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> IO () finalizeTentativeChanges r compr = do debugMessage "Optimizing the inventory..." -- Read the tentative patches ps <- readTentativeRepo r "." writeTentativeInventory (extractCache r) compr ps i <- gzReadFilePS tentativeHashedInventoryPath p <- gzReadFilePS tentativePristinePath -- Write out the "optimised" tentative inventory. writeDocBinFile tentativeHashedInventoryPath $ pris2inv (inv2pris p) i -- Atomically swap. renameFile tentativeHashedInventoryPath hashedInventoryPath -- |readHashedPristineRoot attempts to read the pristine hash from the current -- inventory, returning Nothing if it cannot do so. readHashedPristineRoot :: Repository p wR wU wT -> IO (Maybe String) readHashedPristineRoot (Repo d _ _ _) = withCurrentDirectory d $ do i <- (Just <$> gzReadFilePS hashedInventoryPath) `catch` (\(_ :: IOException) -> return Nothing) return $ inv2pris <$> i -- |cleanPristine removes any obsolete (unreferenced) entries in the pristine -- cache. cleanPristine :: Repository p wR wU wT -> IO () cleanPristine r@(Repo d _ _ _) = withCurrentDirectory d $ do debugMessage "Cleaning out the pristine cache..." i <- gzReadFilePS hashedInventoryPath cleanHashdir (extractCache r) HashedPristineDir [inv2pris i] -- |filterDirContents returns the contents of the directory @d@ -- except files whose names begin with '.' (directories . and .., -- hidden files) and files whose names are filtered by the function @f@, if -- @dir@ is empty, no paths are returned. filterDirContents :: FilePath -> (FilePath -> Bool) -> IO [FilePath] filterDirContents d f = do let realPath = makeDarcsdirPath d exists <- doesDirectoryExist realPath if exists then filter (\x -> head x /= '.' && f x) <$> getDirectoryContents realPath else return [] -- |set converts a list of strings into a set of Char8 ByteStrings for faster -- Set operations. set :: [String] -> Set.Set BC.ByteString set = Set.fromList . map BC.pack -- |unset is the inverse of set. unset :: Set.Set BC.ByteString -> [String] unset = map BC.unpack . Set.toList -- |cleanInventories removes any obsolete (unreferenced) files in the -- inventories directory. cleanInventories :: Repository p wR wU wT -> IO () cleanInventories _ = do debugMessage "Cleaning out inventories..." hs <- listInventoriesLocal fs <- filterDirContents inventoriesDir (const True) mapM_ (removeFileMayNotExist . (inventoriesDirPath )) (unset $ (set fs) `Set.difference` (set hs)) -- |specialPatches list of special patch files that may exist in the directory -- _darcs/patches/. specialPatches :: [FilePath] specialPatches = ["unrevert", "pending", "pending.tentative"] -- |cleanPatches removes any obsolete (unreferenced) files in the -- patches directory. cleanPatches :: Repository p wR wU wT -> IO () cleanPatches _ = do debugMessage "Cleaning out patches..." hs <- listPatchesLocal darcsdir fs <- filterDirContents patchesDir (`notElem` specialPatches) mapM_ (removeFileMayNotExist . (patchesDirPath )) (unset $ (set fs) `Set.difference` (set hs)) -- |addToSpecificInventory adds a patch to a specific inventory file, and -- returns the FilePath whichs corresponds to the written-out patch. addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression -> PatchInfoAnd p wX wY -> IO FilePath addToSpecificInventory invPath c compr p = do let invFile = darcsdir invPath hash <- snd <$> 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 wX wY -> IO FilePath addToTentativeInventory = addToSpecificInventory tentativeHashedInventory -- |removeFromTentativeInventory attempts to remove an FL of patches from the -- tentative inventory. This is used for commands that wish to modify -- already-recorded patches. removeFromTentativeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> FL (PatchInfoAnd p) wX wT -> IO () removeFromTentativeInventory repo compr to_remove = do -- 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. allpatches <- readTentativeRepo repo "." _ :> skipped <- return $ commuteToEnd (reverseFL to_remove) allpatches okay <- simpleRemoveFromTentativeInventory $ mapFL info to_remove ++ mapRL info skipped unless okay $ bug "bug in HashedRepo.removeFromTentativeInventory" sequence_ $ mapFL (addToTentativeInventory (extractCache repo) compr) (reverseRL skipped) where simpleRemoveFromTentativeInventory :: [PatchInfo] -> IO Bool simpleRemoveFromTentativeInventory 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 cut_inv :: [PatchInfo] -> PatchSet p wStart wX -> Maybe (SealedPatchSet p wStart) 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 takes a Doc and writes it as a hash-named file, returning the -- filename that the contents were written to. 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 Standard d -- |readRepo returns the "current" repo patchset. readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> IO (PatchSet p Origin wR) readRepo = readRepoUsingSpecificInventory hashedInventory -- |readRepo returns the tentative repo patchset. readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> IO (PatchSet p Origin wT) readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory -- |readRepoUsingSpecificInventory uses the inventory at @invPath@ to read the -- repository @repo@. readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p wR wU wT -> String -> IO (PatchSet p Origin wS) readRepoUsingSpecificInventory invPath repo dir = do realdir <- toPath <$> ioAbsoluteOrRemote dir Sealed ps <- readRepoPrivate (extractCache repo) realdir invPath `catch` \e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e return $ unsafeCoerceP ps where readRepoPrivate :: (RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath -> FilePath -> IO (SealedPatchSet p Origin) readRepoPrivate cache d iname = do inventory <- readInventoryPrivate (d darcsdir) iname readRepoFromInventoryList cache inventory -- |readRepoFromInventoryList allows the caller to provide an optional "from -- inventory" hash, and a list of info/hash pairs that identify a list of -- patches, returning a patchset of the resulting repo. readRepoFromInventoryList :: (RepoPatch p, ApplyState p ~ Tree) => Cache -> (Maybe String, [(PatchInfo, String)]) -> IO (SealedPatchSet p Origin) readRepoFromInventoryList cache = parseinvs where speculateAndParse h is i = speculate h is >> parse i h read_patches :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) wX)) read_patches [] = return $ seal NilRL read_patches allis@((i1, h1) : is1) = lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest) (rp is1) (createHashed h1 (const $ speculateAndParse h1 allis i1)) where rp :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) wX)) rp [] = return $ seal NilRL rp [(i, h), (il, hl)] = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) (rp [(il, hl)]) (createHashed h (const $ speculateAndParse h (reverse allis) i)) 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 wX)) read_tag (i, h) = mapSeal (patchInfoAndPatch i) <$> 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 :: ReadPatch p => PatchInfo -> String -> IO (Sealed (p wX)) parse i h = do debugMessage ("Reading patch file: "++ showDoc Encode (showPatchInfoUI 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 Encode $ showPatchInfoUI i ] parseinvs :: (RepoPatch p, ApplyState p ~ Tree) => (Maybe String, [(PatchInfo, String)]) -> IO (SealedPatchSet p Origin) parseinvs (Nothing, ris) = mapSeal (flip PatchSet NilRL) <$> 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 <$> unsafeInterleaveIO (read_ts t h) Sealed ps <- unseal seal <$> 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) Origin)) read_ts tag0 h0 = do contents <- unsafeInterleaveIO $ readTaggedInventoryFromHash h0 let is = reverse $ case contents of (Just _, _ : ris0) -> ris0 (Nothing, ris0) -> ris0 (Just _, []) -> bug "inventory without tag!" Sealed ts <- 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 <$> unsafeInterleaveIO (read_patches is) Sealed tag00 <- read_tag tag0 return $ seal $ Tagged tag00 (Just h0) ps :<: ts readTaggedInventoryFromHash :: String -> IO (Maybe String, [(PatchInfo, String)]) readTaggedInventoryFromHash invHash = do (fileName, pristineAndInventory) <- fetchFileUsingCache cache HashedInventoriesDir invHash readInventoryFromContent fileName pristineAndInventory 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 <- unseal seal <$> unsafeInterleaveIO iox Sealed y <- unseal seal <$> unsafeInterleaveIO ioy return $ seal $ f y x -- |readInventoryPrivate reads the inventory with name @invName@ in @dir@. readInventoryPrivate :: String -> String -> IO (Maybe String, [(PatchInfo, String)]) readInventoryPrivate dir invName = do inv <- skipPristine <$> gzFetchFilePS (dir invName) Uncachable readInventoryFromContent (toPath dir ++ "/" ++ darcsdir ++ invName) inv -- |readInventoryFromContent extracts an inventory from the content of an -- inventory file, who's path is @fileName@. readInventoryFromContent :: FilePath -> B.ByteString -> IO (Maybe String, [(PatchInfo, String)]) readInventoryFromContent fileName pristineAndInventory = do (hash, patchIds) <- if mbStartingWith == BC.pack "Starting with inventory:" then let (hash, pids) = BC.break ('\n' ==) $ B.tail pistr hashStr = BC.unpack hash in if okayHash hashStr then return (Just hashStr, pids) else fail $ "Bad hash in file " ++ fileName else return (Nothing, inventory) return (hash, readPatchIds patchIds) where inventory = skipPristine pristineAndInventory (mbStartingWith, pistr) = BC.break ('\n' ==) inventory -- |copyRepo copies the hashed inventory of @repo@ to the repository located at -- @remote@. copyHashedInventory :: RepoPatch p => Repository p wR wU wT -> RemoteDarcs -> String -> IO () copyHashedInventory (Repo outr _ _ _) remote inr = do createDirectoryIfMissing False (outr ++ "/" ++ inventoriesDirPath) copyFileOrUrl remote (inr darcsdir hashedInventory) (outr darcsdir hashedInventory) Uncachable -- no need to copy anything but hashed_inventory! 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 wR wU wT -> String -> IO () copySources repo@(Repo outr _ _ _) inr = do let repoCache = extractCache $ modifyCache repo dropNonRepos appendBinFile (outr ++ "/" ++ darcsdir ++ "/prefs/sources") (show $ repo2cache inr `unionCaches` repoCache ) debugMessage "Done copying and filtering pref/sources." where dropNonRepos (Ca cache) = Ca $ filter notRepo cache notRepo xs = case xs of Cache DarcsCache.Directory _ _ -> False Cache _ DarcsCache.Writable _ -> False _ -> True -- |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 -> Compression -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY) writeAndReadPatch c compr p = do (i, h) <- writePatchIfNecessary c compr p unsafeInterleaveIO $ readp h i where parse i h = do debugMessage ("Rereading patch file: "++ showDoc Encode (showPatchInfoUI 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 Encode $ showPatchInfoUI i] readp h i = do Sealed x <- createHashed h (parse i) return . patchInfoAndPatch i $ unsafeCoerceP x -- | writeTentativeInventory writes @patchSet@ as the tentative inventory. writeTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchSet p Origin wX -> IO () writeTentativeInventory cache compr patchSet = do debugMessage "in writeTentativeInventory..." createDirectoryIfMissing False inventoriesDirPath beginTedious tediousName hsh <- writeInventoryPrivate $ slightlyOptimizePatchset patchSet endTedious tediousName debugMessage "still in writeTentativeInventory..." case hsh of Nothing -> writeBinFile (darcsdir tentativeHashedInventory) "" Just h -> do content <- snd <$> fetchFileUsingCache cache HashedInventoriesDir h writeAtomicFilePS (darcsdir tentativeHashedInventory) content where tediousName = "Writing inventory" writeInventoryPrivate :: RepoPatch p => PatchSet p Origin wX -> IO (Maybe String) writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing writeInventoryPrivate (PatchSet ps NilRL) = do inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps let inventorylist = hcat (map pihash $ reverse inventory) hash <- writeHashFile cache compr HashedInventoriesDir inventorylist return $ Just hash writeInventoryPrivate (PatchSet x xs@(Tagged t _ _ :<: _)) = do resthash <- write_ts xs finishedOneIO tediousName $ fromMaybe "" 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 writes out a tagged patchset. If it has already been -- written, we'll have the hash, so we can immediately return it. write_ts :: RepoPatch p => RL (Tagged p) Origin wX -> IO (Maybe String) write_ts (Tagged _ (Just h) _ :<: _) = return (Just h) write_ts (Tagged _ Nothing pps :<: tts) = writeInventoryPrivate $ PatchSet pps tts write_ts NilRL = return Nothing -- |writeHashIfNecessary writes the patch and returns the resulting info/hash, -- if it has not already been written. If it has been written, we have the hash -- in the PatchInfoAnd, so we extract and return the info/hash. writePatchIfNecessary :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p wX wY -> IO (PatchInfo, String) writePatchIfNecessary c compr hp = infohp `seq` case extractHash hp of Right h -> return (infohp, h) Left p -> (\h -> (infohp, h)) <$> writeHashFile c compr HashedPatchesDir (showPatch p) where infohp = info hp -- |pihash takes an info/hash pair, and renders the info, along with the hash -- as a Doc. pihash :: (PatchInfo, String) -> Doc pihash (pinf, hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n") -- |listInventoriesWith returns a list of the inventories hashes. -- The function @f@ can be readInventoryPrivate or readInventoryLocalPrivate. -- The argument @hashedRepoDir@ is the path to the repository, -- where it's the 'hashed_inventory' file. -- The argument @darcsDir@ is the path to the directory of inventories files. listInventoriesWith :: (String -> String -> IO (Maybe String, [(PatchInfo, String)])) -> String -> String -> IO [String] listInventoriesWith f darcsDir hashedRepoDir = do mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory followStartingWiths mbStartingWithInv where getStartingWithHash invDir inv = fst <$> f invDir inv followStartingWiths Nothing = return [] followStartingWiths (Just startingWith) = do mbNextInv <- getStartingWithHash (darcsDir inventoriesDir) startingWith (startingWith :) <$> followStartingWiths mbNextInv -- |listInventoriesBucketedWith is similar to listInventoriesWith, but -- it read the inventory directory under @darcsDir@ in bucketed format. listInventoriesBucketedWith :: (String -> String -> IO (Maybe String, [(PatchInfo, String)])) -> String -> String -> IO [String] listInventoriesBucketedWith f darcsDir hashedRepoDir = do mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory followStartingWiths mbStartingWithInv where getStartingWithHash invDir inv = fst <$> f invDir inv followStartingWiths Nothing = return [] followStartingWiths (Just startingWith) = do mbNextInv <- getStartingWithHash (darcsDir inventoriesDir bucketFolder startingWith) startingWith (startingWith :) <$> followStartingWiths mbNextInv -- |listInventories returns a list of the inventories hashes. -- This function attempts to retrieve missing inventory files. listInventories :: IO [String] listInventories = listInventoriesWith readInventoryPrivate darcsdir darcsdir -- |readInventoryLocalPrivate reads the inventory with name @invName@ in @dir@ -- if it exist, otherwise returns an empty inventory. readInventoryLocalPrivate :: String -> String -> IO (Maybe String, [(PatchInfo, String)]) readInventoryLocalPrivate dir invName = do b <- doesFileExist (dir invName) if b then readInventoryPrivate dir invName else return (Nothing, []) -- |listInventoriesLocal returns a list of the inventories hashes. -- This function does not attempt to retrieve missing inventory files. listInventoriesLocal :: IO [String] listInventoriesLocal = listInventoriesWith readInventoryLocalPrivate darcsdir darcsdir -- |listInventoriesRepoDir returns a list of the inventories hashes. -- The argument @repoDir@ is the directory of the repository from which -- we are going to read the "hashed_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' listInventoriesBucketedWith readInventoryLocalPrivate gCacheInvDir (repoDir darcsdir) -- |listPatchesLocal returns a list of the patches hashes, extracted -- from inventory files, by following the inventory "chain" of "Starting -- with inventory" hashes. This function does not attempt to download missing -- inventory files. -- The argument @darcsDir@ is the path to the darcs directory (e.g. "_darcs") -- of the repository from which we're going to read the inventories. listPatchesLocal :: String -> IO [String] listPatchesLocal darcsDir = do inventory <- readInventoryPrivate darcsDir hashedInventory followStartingWiths (fst inventory) (getPatches inventory) where followStartingWiths Nothing patches = return patches followStartingWiths (Just startingWith) patches = do inv <- readInventoryLocalPrivate (darcsDir inventoriesDir) startingWith (patches++) <$> followStartingWiths (fst inv) (getPatches inv) getPatches inv = map snd (snd inv) -- |listPatchesLocalBucketed is similar to listPatchesLocal, but -- it read the inventory directory under @darcsDir@ in bucketed format. listPatchesLocalBucketed :: String -> String -> IO [String] listPatchesLocalBucketed darcsDir hashedRepoDir = do inventory <- readInventoryPrivate hashedRepoDir hashedInventory followStartingWiths (fst inventory) (getPatches inventory) where followStartingWiths Nothing patches = return patches followStartingWiths (Just startingWith) patches = do inv <- readInventoryLocalPrivate (darcsDir inventoriesDir bucketFolder startingWith) startingWith (patches++) <$> followStartingWiths (fst inv) (getPatches inv) getPatches inv = map snd (snd inv) -- | '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' where 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) -- |applyToTentativePristine applies a patch @p@ to the tentative pristine -- tree, and updates the tentative pristine hash applyToTentativePristine :: (ApplyState p ~ Tree, Patchy p) => p wX wY -> IO () applyToTentativePristine p = do tentativePristine <- gzReadFilePS tentativePristinePath -- Extract the pristine hash from the tentativePristine file, using -- inv2pris (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 = inv2pris tentativePristine newPristineHash <- applyToHashedPristine tentativePristineHash p writeDocBinFile tentativePristinePath $ pris2inv newPristineHash tentativePristine -- | copyPristine copies a pristine tree into the current pristine dir, -- and possibly copies a clean working copy. -- The target is read from the passed-in dir/inventory name combination. copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO () copyPristine cache dir iname wwd = do i <- fetchFilePS (dir ++ "/" ++ iname) Uncachable debugMessage $ "Copying hashed pristine tree: " ++ inv2pris i let tediousName = "Copying pristine" beginTedious tediousName copyHashed tediousName cache wwd $ inv2pris i endTedious tediousName -- |copyPartialsPristine copies the pristine entries for a given list of -- filepaths. copyPartialsPristine :: FilePathLike fp => Cache -> String -> String -> [fp] -> IO () copyPartialsPristine c d iname fps = do i <- fetchFilePS (d ++ "/" ++ iname) Uncachable copyPartialsHashed c (inv2pris i) fps -- |pris2inv takes an updated pristine hash and an inventory, and outputs the -- new pristine hash followed by the original inventory (having skipped the old -- inventory hash). pris2inv :: String -> B.ByteString -> Doc pris2inv h inv = invisiblePS pristineName <> text h $$ invisiblePS (skipPristine inv) -- |inv2pris takes the content of an inventory, and extracts the corresponding -- pristine hash from the inventory (the hash is prefixed by "pristine:"). inv2pris :: B.ByteString -> String inv2pris inv = case tryDropPristineName inv of Just rest -> case takeHash rest of Just (h, _) -> h Nothing -> error "Bad hash in inventory!" Nothing -> sha256sum B.empty -- |skipPristine drops the 'pristine: HASH' prefix line, if present. skipPristine :: B.ByteString -> B.ByteString skipPristine ps = case tryDropPristineName ps of Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest Nothing -> ps -- |tryDropPristineName returns the result of dropping the pristineName from -- the input, if it was present, otherwise it returns Nothing. 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 darcs-2.10.2/src/Darcs/Repository/Merge.hs0000644000175000017500000002110412620122474022315 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2002-2004,2007-2008 David Roundy -- Copyright (C) 2005 Juliusz Chroboczek -- Copyright (C) 2009 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. module Darcs.Repository.Merge ( tentativelyMergePatches , considerMergeToWorking ) where import Control.Monad ( when ) import Storage.Hashed.Tree( Tree ) import Darcs.Repository.External ( backupByCopying ) import Darcs.Repository.Flags ( UseIndex , ScanKnown , AllowConflicts (..) , Reorder (..) , UpdateWorking (..) , ExternalMerge (..) , Verbosity (..) , Compression (..) , WantGuiPause (..) , DiffAlgorithm (..) ) import Darcs.Patch ( RepoPatch, PrimOf, merge, listTouchedFiles, patchcontents, anonymous, fromPrims, effect ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Depends( merge2FL ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully ) import Darcs.Patch.Progress( progressFL ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL, concatFL ) import Darcs.Patch.Witnesses.Sealed( Sealed(Sealed), seal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) import Darcs.Repository.InternalTypes( Repository(..) ) import Darcs.Repository.State( unrecordedChanges, readUnrecorded ) import Darcs.Repository.Resolution ( standardResolution, externalResolution ) import Darcs.Repository.Internal ( announceMergeConflicts, checkUnrecordedConflicts, MakeChanges(..), setTentativePending, tentativelyAddPatch_, applyToTentativePristine, tentativelyReplacePatches, UpdatePristine(..) ) import Darcs.Util.Progress( debugMessage ) tentativelyMergePatches_ :: forall p wR wU wT wY wX. (RepoPatch p, ApplyState p ~ Tree) => MakeChanges -> Repository p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> ( UseIndex, ScanKnown, DiffAlgorithm ) -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wY -> IO (Sealed (FL (PrimOf p) wU)) tentativelyMergePatches_ mc r cmd allowConflicts updateWorking externalMerge wantGuiPause compression verbosity reorder diffingOpts@(_, _, dflag) usi themi = do let us = mapFL_FL hopefully usi them = mapFL_FL hopefully themi ((pc :: FL (PatchInfoAnd p) wT wMerged) :/\: us_merged) <- return $ merge2FL (progressFL "Merging us" usi) (progressFL "Merging them" themi) pend <- unrecordedChanges diffingOpts r Nothing anonpend <- n2pia `fmap` anonymous (fromPrims pend) pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL) let pwprim = concatFL $ progressFL "Examining patches for conflicts" $ mapFL_FL (patchcontents . hopefully) pw Sealed standard_resolved_pw <- return $ standardResolution pwprim debugMessage "Checking for conflicts..." when (allowConflicts == YesAllowConflictsAndMark) $ mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw debugMessage "Announcing conflicts..." have_conflicts <- announceMergeConflicts cmd allowConflicts externalMerge standard_resolved_pw debugMessage "Checking for unrecorded conflicts..." have_unrecorded_conflicts <- checkUnrecordedConflicts updateWorking $ mapFL_FL hopefully pc debugMessage "Reading working directory..." working <- readUnrecorded r Nothing debugMessage "Working out conflicts in actual working directory..." let haveConflicts = have_conflicts || have_unrecorded_conflicts Sealed pw_resolution <- case (externalMerge , haveConflicts) of (NoExternalMerge, _) -> return $ if allowConflicts == YesAllowConflicts then seal NilFL else seal standard_resolved_pw (_, False) -> return $ seal standard_resolved_pw (YesExternalMerge c, True) -> externalResolution dflag working c wantGuiPause (effect us +>+ pend) (effect them) pwprim debugMessage "Applying patches to the local directories..." when (mc == MakeChanges) $ do let doChanges :: FL (PatchInfoAnd p) wX wT -> IO (Repository p wR wU wMerged) -- This first case is a possible optimisation: if 'usi' is empty, then -- the merge2FL call above will return pc = themi, but the wMerged -- witness is quantified in the :/\: constructor so we lose the -- information that wX=wT => wMerged=wY so we have to coerce. -- TODO: it's not really clear why if this is an optimisation in -- practice, as pc would be trivial to calculate in this case and -- there aren't any obvious memory benefits. doChanges NilFL = applyps r (unsafeCoercePEnd themi) doChanges _ = applyps r pc r' <- doChanges usi setTentativePending r' updateWorking (effect pend' +>+ pw_resolution) when (reorder == Reorder) $ -- TODO: we end up applying the merged remote patches on top of the unmerged -- local patches, then commuting out the unmerged local patches and finally -- adding the merged local patches. -- It would better to just remove the unmerged local patche, then apply the -- unmerged remote patches and then the merged local patches. -- The handling of 'unrecorded' might complicate this slightly so this -- refactoring may be better deferred until we have reliable witness tracking -- for repositories. tentativelyReplacePatches r' compression YesUpdateWorking verbosity us_merged return $ seal (effect pwprim +>+ pw_resolution) where mapAdd :: Repository p wM wL wI -> FL (PatchInfoAnd p) wI wJ -> IO (Repository p wM wL wJ) mapAdd repo NilFL = return repo mapAdd repo (a:>:as) = do repo' <- tentativelyAddPatch_ DontUpdatePristine repo compression verbosity updateWorking a mapAdd repo' as applyps :: Repository p wM wL wI -> FL (PatchInfoAnd p) wI wJ -> IO (Repository p wM wL wJ) applyps repo ps = do debugMessage "Adding patches to inventory..." repo' <- mapAdd repo ps debugMessage "Applying patches to pristine..." applyToTentativePristine repo verbosity ps return repo' tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> ( UseIndex, ScanKnown, DiffAlgorithm ) -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wY -> IO (Sealed (FL (PrimOf p) wU)) tentativelyMergePatches = tentativelyMergePatches_ MakeChanges considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> ( UseIndex, ScanKnown, DiffAlgorithm ) -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wY -> IO (Sealed (FL (PrimOf p) wU)) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges darcs-2.10.2/src/Darcs/Repository/Diff.hs0000644000175000017500000001362712620122474022141 0ustar00guillaumeguillaume00000000000000-- 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 {-# LANGUAGE CPP #-} module Darcs.Repository.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 Darcs.Util.Path( AnchoredPath, anchorPath ) import Darcs.Util.ByteString ( isFunky ) import Darcs.Patch ( PrimPatch , hunk , canonize , binary , addfile , rmfile , adddir , rmdir , invert ) import Darcs.Repository.Prefs ( FileType(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) ) import Darcs.Patch.Witnesses.Sealed ( Gap(..) ) import Darcs.Repository.Flags ( DiffAlgorithm(..) ) #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) => 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 $ 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 (Changed a'@(File _) subtree@(SubTree _)) = do rmFileP <- diff p (Changed a' (File emptyBlob)) 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 (Changed (File emptyBlob) b') return $ joinGap (+>+) rmDirP addFileP 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 da (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 darcs-2.10.2/src/Darcs/Repository/ApplyPatches.hs0000644000175000017500000001721412620122474023662 0ustar00guillaumeguillaume00000000000000-- 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-missing-methods #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} module Darcs.Repository.ApplyPatches ( applyPatches , runTolerantly , runSilently , DefaultIO, runDefault ) where import Prelude hiding ( catch ) import Control.Exception ( catch, SomeException, IOException ) import Data.Char ( toLower ) import Data.List ( isSuffixOf ) import System.IO ( stderr ) import System.IO.Error ( isDoesNotExistError, isPermissionError ) import Control.Monad ( unless, mplus ) import Control.Applicative (Applicative) import System.Directory ( createDirectory, removeDirectory, removeFile, renameFile, renameDirectory, doesDirectoryExist, doesFileExist ) import Darcs.Patch.ApplyMonad( ApplyMonad(..) ) import Darcs.Patch.ApplyPatches ( applyPatches ) import Darcs.Patch.MonadProgress ( MonadProgress(..), ProgressAction(..) ) import Darcs.Repository.Prefs( changePrefval ) import Darcs.Repository.Lock ( writeAtomicFilePS ) import Darcs.Util.Exception ( prettyException ) import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) import Darcs.Util.Printer ( hPutDocLn, RenderMode(..) ) import Darcs.Util.Printer.Color ( showDoc ) import Darcs.Repository.External ( backupByCopying, backupByRenaming ) import Darcs.Util.Path ( FileName, fn2fp ) import qualified Data.ByteString as B (empty, null, readFile) import Storage.Hashed.Tree( Tree ) newtype DefaultIO a = DefaultIO { runDefaultIO :: IO a } deriving (Functor, Applicative, Monad) instance MonadProgress DefaultIO where runProgressActions _ [] = return () runProgressActions what items = DefaultIO $ do do beginTedious what tediousSize what (length items) mapM_ go items endTedious what where go item = do finishedOneIO what (showDoc Encode $ paMessage item) runDefaultIO (paAction item) `catch` \e -> do hPutDocLn Encode stderr $ paOnError item ioError e instance ApplyMonad DefaultIO Tree where type ApplyMonadBase DefaultIO = IO mDoesDirectoryExist = DefaultIO . doesDirectoryExist . fn2fp mChangePref a b c = DefaultIO $ changePrefval a b c mModifyFilePS f j = DefaultIO $ B.readFile (fn2fp f) >>= runDefaultIO . j >>= writeAtomicFilePS (fn2fp f) mCreateDirectory = DefaultIO . createDirectory . fn2fp mCreateFile f = DefaultIO $ 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 = DefaultIO $ do let fp = fn2fp f x <- B.readFile fp unless (B.null x) $ fail $ "Cannot remove non-empty file "++fp removeFile fp mRemoveDirectory = DefaultIO . removeDirectory . fn2fp mRename a b = DefaultIO $ 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 -> unless (isDoesNotExistError e) $ ioError e) where x = fn2fp a y = fn2fp b class (Functor m, Monad 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) instance TolerantMonad TolerantIO where warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e runIO (TIO io) = io runTM = TIO newtype SilentIO a = SIO { runSIO :: IO a } deriving (Functor, Applicative, Monad) 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) -- | 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 = runDefaultIO instance TolerantMonad m => ApplyMonad (TolerantWrapper m) Tree where type ApplyMonadBase (TolerantWrapper m) = IO 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 " ++ 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 >> runDefaultIO (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) darcs-2.10.2/src/Darcs/Repository/Motd.hs0000644000175000017500000000310212620122474022157 0ustar00guillaumeguillaume00000000000000-- 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 qualified Data.ByteString as B (null, hPut, empty, ByteString) import System.IO ( stdout ) import Darcs.Repository.External ( fetchFilePS, Cachable(..) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Exception ( catchall ) -- | 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 = repo ++ "/" ++ darcsdir ++ "/prefs/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 '*' darcs-2.10.2/src/Darcs/Repository/Ssh.hs0000644000175000017500000002211112620122474022012 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} -- | -- Module : Darcs.Repository.Ssh -- Maintainer : darcs-devel@darcs.net -- Stability : experimental -- Portability : portable module Darcs.Repository.Ssh ( copySSH , SSHCmd(..) , getSSH , environmentHelpSsh , environmentHelpScp , environmentHelpSshPort , remoteDarcs ) where import Prelude hiding ( lookup, catch ) import System.Environment ( getEnv ) import System.Exit ( ExitCode(..) ) import Control.Exception ( throwIO ) import Control.Monad ( unless, (>=>) ) import Control.Monad.IO.Class ( liftIO ) 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.Util.SignalHandler ( catchNonSignal ) import Darcs.Repository.Flags( RemoteDarcs(..) ) import Darcs.Util.Ssh ( defaultSsh, SshSettings) import Darcs.Util.URL (SshFilePath(..), urlOf) import Darcs.Util.Text ( breakCommand ) import Darcs.Util.Exception ( prettyException, catchall ) import Darcs.Util.Exec ( readInteractiveProcess, ExecException(..), Redirect(AsIs) ) import Darcs.Util.Progress ( withoutProgress, debugMessage, debugFail ) import qualified Darcs.Util.Ssh as Settings import qualified Darcs.Util.Ratified as Ratified ( hGetContents ) sshConnections :: IORef (Map String (Maybe Connection)) sshConnections = unsafePerformIO $ newIORef empty {-# NOINLINE sshConnections #-} data Connection = C { inp :: !Handle , out :: !Handle , err :: !Handle , deb :: String } -- | @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 <- liftIO $ 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_) <- liftIO $ getSSH SSH let sshargs = sshargs_ ++ [sshUhost repoid, rdarcs, "transfer-mode","--repodir",sshRepo repoid] liftIO $ debugMessage $ unwords (ssh : sshargs) (i,o,e,_) <- liftIO $ runInteractiveProcess ssh sshargs Nothing Nothing liftIO $ (do hSetBinaryMode i True hSetBinaryMode o True l <- hGetLine o unless (l == "Hello user, I am darcs transfer mode") $ debugFail "Couldn't start darcs transfer-mode on server" let c = C { inp = i, out = o, err = e, deb = "with ssh (transfer-mode) " ++ sshUhost repoid } modifyIORef sshConnections (insert (sshUhost repoid) (Just c)) return $ Just c) `catchNonSignal` \exn -> do debugMessage $ "Failed to start ssh connection:\n "++ prettyException exn 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 debugMessage (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 (grabSSH dest >=> B.writeFile to) $ do let u = escape_dollar $ urlOf dest (scp, args) <- getSSH SCP let scp_args = filter (/="-q") args ++ [u, to] (r, scp_err) <- readInteractiveProcess scp scp_args unless (r == ExitSuccess) $ throwIO $ ExecException scp 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] -- --------------------------------------------------------------------- -- 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."]) darcs-2.10.2/src/Darcs/UI/0000755000175000017500000000000012620122474017062 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/UI/PrintPatch.hs0000644000175000017500000000566512620122474021506 0ustar00guillaumeguillaume00000000000000-- 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.UI.PrintPatch ( printPatch , contextualPrintPatch , printPatchPager , printFriendly , showFriendly ) where import Storage.Hashed.Monad( virtualTreeIO ) import Storage.Hashed.Tree( Tree ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch ( showContextPatch, showPatch, showNicely, description, summary ) import Darcs.Patch.Show ( ShowPatch ) import Darcs.UI.External ( viewDocWith ) --import Darcs.UI.Flags ( DarcsFlag(Summary, Verbose), isUnified ) import Darcs.UI.Options.All ( Verbosity(..), Summary(..), WithContext(..) ) import Darcs.Util.Printer ( Doc, putDocLnWith, RenderMode(..) ) -- | @'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, ApplyState p ~ Tree) => Maybe (Tree IO) -> Verbosity -> Summary -> WithContext -> p wX wY -> IO () printFriendly (Just pristine) _ _ YesContext = contextualPrintPatch pristine 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 -> Summary -> p wX wY -> Doc showFriendly Verbose _ = showNicely showFriendly _ YesSummary = summary showFriendly _ NoSummary = description -- | 'printPatch' prints a patch on standard output. printPatch :: ShowPatch p => p wX wY -> IO () printPatch p = putDocLnWith fancyPrinters $ showPatch p -- | 'printPatchPager' runs '$PAGER' and shows a patch in it. printPatchPager :: ShowPatch p => p wX wY -> IO () printPatchPager p = viewDocWith fancyPrinters Standard $ showPatch p -- | 'contextualPrintPatch' prints a patch, together with its context, on -- standard output. contextualPrintPatch :: (ShowPatch p, ApplyState p ~ Tree) => Tree IO -> p wX wY -> IO () contextualPrintPatch s p = do (contextedPatch, _) <- virtualTreeIO (showContextPatch p) s putDocLnWith fancyPrinters contextedPatch darcs-2.10.2/src/Darcs/UI/Commands/0000755000175000017500000000000012620122474020623 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/UI/Commands/GZCRCs.hs0000644000175000017500000002416312620122474022220 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.GZCRCs ( gzcrcs , doCRCWarnings ) where import Prelude hiding ( (^) ) 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 ( hPutStr, hPutStrLn, stderr ) import Darcs.Util.File ( getRecursiveContentsFullPath ) import Darcs.Util.ByteString ( isGZFile, gzDecompress ) import Darcs.Util.Global ( getCRCWarnings, resetCRCWarnings ) import Darcs.Repository ( Repository, withRepository, RepoJob(..) ) -- 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.Cache ( Cache(..), writable, isThisRepo, hashedFilePath, allHashedDirs ) import Darcs.Repository.InternalTypes ( extractCache ) import Darcs.Repository.Lock ( gzWriteAtomicFilePSs ) import Darcs.Patch ( RepoPatch ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) import Darcs.UI.Flags ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo ) , useCache ) import Darcs.Util.Text ( formatText ) import Darcs.Util.Printer ( putDocLn, text ) gzcrcsHelp :: String 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 hPutStr stderr . formatText 80 $ ["" , "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 gzcrcsDescription :: String gzcrcsDescription = "Check or repair the CRCs of compressed files in the " ++ "repository." gzcrcsBasicOpts :: DarcsOption a (Maybe O.GzcrcsAction -> Bool -> Maybe String -> a) gzcrcsBasicOpts = O.gzcrcsActions ^ O.justThisRepo ^ O.workingRepoDir gzcrcsOpts :: DarcsOption a (Maybe O.GzcrcsAction -> Bool -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) gzcrcsOpts = gzcrcsBasicOpts `withStdOpts` oid gzcrcs :: DarcsCommand [DarcsFlag] gzcrcs = DarcsCommand { commandProgramName = "darcs" , commandName = "gzcrcs" , commandHelp = gzcrcsHelp , commandDescription = gzcrcsDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = gzcrcsCmd , commandPrereq = amInRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc gzcrcsBasicOpts , commandDefaults = defaultFlags gzcrcsOpts , commandCheckOptions = ocheck gzcrcsOpts , commandParseOptions = onormalise gzcrcsOpts } gzcrcsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () gzcrcsCmd _ opts _ | Check `elem` opts || Repair `elem` opts = withRepository (useCache opts) (RepoJob (gzcrcs' opts)) gzcrcsCmd _ _ _ = error "You must specify --check or --repair for gzcrcs" gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p wR wU wT -> IO () gzcrcs' 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 Ca locs = extractCache 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 $ "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 $ "Corrupt: " ++ file when (isWritable && shouldRepair) $ doRepair file uncompressed when (count > (0 :: Int)) $ do liftIO . putInfo $ "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 (Check `elem` opts && checkFailed) $ exitWith (ExitFailure 1) where [shouldRepair, isQuiet, isVerbose, isJustThisRepo] = zipWith ($) (elem `fmap` [Repair, Quiet, Verbose, JustThisRepo]) (repeat opts) putInfo = unless isQuiet . putDocLn . text putVerbose = when isVerbose . putDocLn . text doRepair name contents = liftIO $ gzWriteAtomicFilePSs name contents darcs-2.10.2/src/Darcs/UI/Commands/Move.hs0000644000175000017500000003567412620122474022104 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE RankNTypes #-} -- 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.UI.Commands.Move ( move, mv ) where import Prelude hiding ( (^) ) import Control.Applicative ( (<$>) ) import Control.Monad ( when, unless, forM_, forM ) import Data.Maybe ( fromMaybe ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag(Quiet) , doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask , maybeFixSubPaths, fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Diff ( treeDiff ) import Darcs.Repository.Flags ( UpdateWorking (..), DiffAlgorithm(..) ) import Darcs.Repository.Prefs ( filetypeFunction ) import System.FilePath.Posix ( (), takeFileName ) import System.Directory ( renameDirectory ) import Darcs.Repository.State ( readRecordedAndPending, readRecorded, updateIndex ) import Darcs.Repository ( Repository , withRepoLock , RepoJob(..) , addPendingDiffToPending , listFiles ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) ) import Darcs.Patch.Witnesses.Sealed ( emptyGap, freeGap, joinGap, FreeLeft ) import Darcs.Util.Global ( debugMessage ) import qualified Darcs.Patch import Darcs.Patch ( RepoPatch, PrimPatch ) import Darcs.Patch.Apply( ApplyState ) import Data.List ( nub, sort ) import qualified System.FilePath.Windows as WindowsFilePath import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase, treeHasFile ) import Storage.Hashed.Tree( Tree, modifyTree ) import Storage.Hashed.Plain( readPlainTree ) import Darcs.Util.Path ( floatPath , fp2fn , fn2fp , superName , SubPath() , toFilePath , AbsolutePath ) import Darcs.Util.Workaround ( renameFile ) 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" moveBasicOpts :: DarcsOption a (Bool -> Bool -> Maybe String -> a) moveBasicOpts = O.allowProblematicFilenames ^ O.workingRepoDir moveAdvancedOpts :: DarcsOption a (O.UMask -> a) moveAdvancedOpts = O.umask moveOpts :: DarcsOption a (Bool -> Bool -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) moveOpts = moveBasicOpts `withStdOpts` moveAdvancedOpts move :: DarcsCommand [DarcsFlag] move = DarcsCommand { commandProgramName = "darcs" , commandName = "move" , commandHelp = moveHelp , commandDescription = moveDescription , commandExtraArgs = -1 , commandExtraArgHelp = [" ... "] , commandCommand = moveCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = listFiles False , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc moveAdvancedOpts , commandBasicOptions = odesc moveBasicOpts , commandDefaults = defaultFlags moveOpts , commandCheckOptions = ocheck moveOpts , commandParseOptions = onormalise moveOpts } moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () moveCmd fps opts args | length args < 2 = fail "The `darcs move' command requires at least two arguments." | length args == 2 = do xs <- maybeFixSubPaths fps 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 fps [to] case x of Nothing -> fail "Invalid destination directory." Just to' -> do xs <- nub . sort <$> fixSubPaths fps 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 of the working directory -> Tree IO -- ^ tree of recorded and pending changes -> Tree IO -- ^ tree of recorded changes -> FilePath -> 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 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 = withRepoAndState opts $ \(repo, work, cur, recorded) -> do let old_fp = toFilePath old new_fp = toFilePath new new_fs <- fileStatus work cur recorded new_fp old_fs <- fileStatus work cur recorded old_fp let doSimpleMove = simpleMove repo opts cur work old_fp new_fp case (old_fs, new_fs) of (Nonexistant, _) -> fail $ old_fp ++ " does not exist." (Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded." (Known _, Nonexistant) -> doSimpleMove (Known _, Shadow _) -> doSimpleMove (_, Nonexistant) -> fail $ old_fp ++ " is not in the repository." (Known _, Known Dir) -> moveToDir repo opts cur work [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' -> doSimpleMove (Shadow File, Known Dir) -> moveToDir repo opts cur work [old_fp] new_fp (Shadow Dir, Known Dir) -> doSimpleMove (Shadow File, Known File) -> doSimpleMove (Shadow k, _) -> fail $ "cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp ++ " : " ++ "did you already move it elsewhere?" moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO () moveFilesToDir opts froms to = withRepoAndState opts $ \(repo, work, cur, _) -> moveToDir repo opts cur work (map toFilePath froms) $ toFilePath to withRepoAndState :: [DarcsFlag] -> (forall p wR wU . (ApplyState p ~ Tree, RepoPatch p) => (Repository p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()) -> IO () withRepoAndState opts f = withRepoLock dr uc YesUpdateWorking um $ RepoJob $ \repo -> do work <- readPlainTree "." cur <- readRecordedAndPending repo recorded <- readRecorded repo f (repo, work, cur, recorded) where dr = dryRun opts uc = useCache opts um = umask opts simpleMove :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath -> IO () simpleMove repository opts cur work old_fp new_fp = do doMoves repository opts cur work [(old_fp, new_fp)] unless (Quiet `elem` opts) $ putStrLn $ unwords ["Moved:", old_fp, "to:", new_fp] moveToDir :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath -> IO () moveToDir repository opts cur work moved finaldir = do let movetargets = map ((finaldir ) . takeFileName) moved moves = zip moved movetargets doMoves repository opts cur work moves unless (Quiet `elem` opts) $ putStrLn $ unwords $ ["Moved:"] ++ moved ++ ["to:", finaldir] doMoves :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> [(FilePath, FilePath)] -> 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) addPendingDiffToPending repository YesUpdateWorking pendingDiff moveFileOrDir work old new updateIndex repository -- 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 -> (FilePath, FilePath) -> 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 = fn2fp $ superName $ fp2fn new haveNewParent <- treeHasDir cur dirPath unless haveNewParent $ fail $ "The target directory " ++ 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 unless (Quiet `elem` opts) $ putStrLn "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" ++ new Just <$> if newInRecorded then deleteNewFromRepoPatches else return $ emptyGap NilFL where newIsOkWindowsPath = doAllowWindowsReserved opts || WindowsFilePath.isValid new newNotOkWindowsPathMsg = "The filename " ++ 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 unless (Quiet `elem` opts) $ putStrLn $ "Existing recorded contents of " ++ new ++ " will be overwritten." ftf <- filetypeFunction let curNoNew = modifyTree cur (floatPath 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 (floatPath old) Nothing) new treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase alreadyExists inWhat = if doAllowCaseOnly opts then "A file or dir named "++new++" already exists in " ++ inWhat ++ "." else "A file or dir named "++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 -> 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 [DarcsFlag] mv = commandAlias "mv" Nothing move darcs-2.10.2/src/Darcs/UI/Commands/Show.hs0000644000175000017500000000704712620122474022107 0ustar00guillaumeguillaume00000000000000-- 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, list, query ) where import Darcs.UI.Commands ( DarcsCommand(..) , normalCommand, hiddenCommand , commandAlias, amInRepository ) import Darcs.UI.Commands.ShowAuthors ( showAuthors ) import Darcs.UI.Commands.ShowBug ( showBug ) import Darcs.UI.Commands.ShowContents ( showContents ) import Darcs.UI.Commands.ShowFiles ( showFiles, manifestCmd, toListManifest ) import Darcs.UI.Commands.ShowTags ( showTags ) import Darcs.UI.Commands.ShowRepo ( showRepo ) import Darcs.UI.Commands.ShowIndex ( showIndex, showPristineCmd ) import Darcs.UI.Commands.ShowPatchIndex ( showPatchIndexAll, showPatchIndexFiles, showPatchIndexStatus, patchIndexTest ) import Darcs.UI.Flags ( DarcsFlag ) 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 [DarcsFlag] showCommand = SuperCommand { commandProgramName = "darcs" , commandName = "show" , commandHelp = showHelp , commandDescription = showDescription , commandPrereq = amInRepository , commandSubCommands = [ hiddenCommand showBug , normalCommand showContents , normalCommand showFiles, hiddenCommand showManifest , normalCommand showIndex , normalCommand showPristine , normalCommand showRepo , normalCommand showAuthors , normalCommand showTags , normalCommand showPatchIndexAll , normalCommand showPatchIndexFiles , normalCommand showPatchIndexStatus , normalCommand patchIndexTest ] } query :: DarcsCommand [DarcsFlag] query = commandAlias "query" Nothing showCommand list :: DarcsCommand [DarcsFlag] list = commandAlias "list" Nothing showCommand -- unfortunately, aliases for sub-commands have to live in their parent command -- to avoid an import cycle showPristine :: DarcsCommand [DarcsFlag] 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 [DarcsFlag] showManifest = (commandAlias "manifest" (Just showCommand) showFiles) { commandCommand = manifestCmd toListManifest } darcs-2.10.2/src/Darcs/UI/Commands/ShowRepo.hs0000644000175000017500000001606212620122474022732 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.UI.Commands.ShowRepo ( showRepo ) where import Prelude hiding ( (^) ) 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(XMLOutput, Verbose, NoFiles), useCache ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.Repository ( withRepository, RepoJob(..), readRepo ) import Darcs.Repository.Internal ( Repository(..) ) import Darcs.Repository.InternalTypes ( Pristine(..) ) import Darcs.Repository.Cache ( Cache(..) ) 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.Patch.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" showRepoBasicOpts :: DarcsOption a (Maybe String -> Bool -> O.XmlOutput -> a) showRepoBasicOpts = O.workingRepoDir ^ O.files ^ O.xmloutput showRepoOpts :: DarcsOption a (Maybe String -> Bool -> O.XmlOutput -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) showRepoOpts = showRepoBasicOpts `withStdOpts` oid showRepo :: DarcsCommand [DarcsFlag] showRepo = DarcsCommand { commandProgramName = "darcs" , commandName = "repo" , commandHelp = showRepoHelp , commandDescription = showRepoDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = repoCmd , commandPrereq = amInRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showRepoBasicOpts , commandDefaults = defaultFlags showRepoOpts , commandCheckOptions = ocheck showRepoOpts , commandParseOptions = onormalise showRepoOpts } repoCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () repoCmd _ opts _ = let put_mode = if XMLOutput `elem` 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 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 wR wU wR -> [DarcsFlag] -> IO () actuallyShowRepo out r@(Repo loc rf pris cs) opts = do when (XMLOutput `elem` opts) (putStr "\n") when (Verbose `elem` opts) (out "Show" $ show r) showRepoFormat out rf out "Root" loc showRepoAux out pris cs showRepoPrefs out unless (NoFiles `elem` opts) (numPatches r >>= (out "Num Patches" . show )) showRepoMOTD out r when (XMLOutput `elem` opts) (putStr "\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. showRepoFormat :: PutInfo -> RepoFormat -> IO () showRepoFormat out rf = out "Format" . intercalate ", " . lines . show $ rf showRepoAux :: PutInfo -> Pristine -> Cache -> IO () showRepoAux out 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 wR wU wR -> 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 wR wU wR -> IO Int numPatches r = (lengthRL . newset2RL) `liftM` readRepo r darcs-2.10.2/src/Darcs/UI/Commands/Revert.hs0000644000175000017500000001542012620122474022430 0ustar00guillaumeguillaume00000000000000-- 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.Revert ( revert ) where import Prelude hiding ( (^), catch ) import Control.Applicative ( (<$>) ) import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import Data.List ( sort ) import Darcs.UI.Flags ( DarcsFlag( Debug ), diffingOpts, verbosity, diffAlgorithm, isInteractive, isUnified , dryRun, umask, useCache, fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Commands.Util ( announceFiles ) import Darcs.UI.Commands.Unrevert ( writeUnrevert ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) import Darcs.Repository ( withRepoLock , RepoJob(..) , addToPending , applyToWorking , readRecorded , unrecordedChanges , listRegisteredFiles ) import Darcs.Patch ( invert, effectOnFilePaths, commute ) import Darcs.Patch.Split ( reversePrimSplitter ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), nullFL, (+>+) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(Last) , selectionContextPrim , runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Patch.TouchesFiles ( chooseTouching ) 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" revertBasicOpts :: DarcsOption a (Maybe Bool -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> a) revertBasicOpts = O.interactive -- True ^ O.workingRepoDir ^ O.withContext ^ O.diffAlgorithm revertAdvancedOpts :: DarcsOption a (O.UseIndex -> O.UMask -> a) revertAdvancedOpts = O.useIndex ^ O.umask revertOpts :: DarcsOption a (Maybe Bool -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseIndex -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) revertOpts = revertBasicOpts `withStdOpts` revertAdvancedOpts patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = [] , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = isUnified flags } revert :: DarcsCommand [DarcsFlag] 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 = odesc revertAdvancedOpts , commandBasicOptions = odesc revertBasicOpts , commandDefaults = defaultFlags revertOpts , commandCheckOptions = ocheck revertOpts , commandParseOptions = onormalise revertOpts } revertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () revertCmd fps opts args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do files <- if null args then return Nothing else Just . sort <$> fixSubPaths fps 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 recorded <- 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 Last "revert" (patchSelOpts opts) (Just reversePrimSplitter) pre_changed_files (Just recorded) (norevert:>p) <- runSelection (selectChanges changes) context if nullFL p then putStrLn $ "If you don't want to revert after all," ++ " that's fine with me!" else do addToPending repository YesUpdateWorking $ invert p when (Debug `elem` opts) $ putStrLn "About to write the unrevert file." case commute (norevert:>p) of Just (p':>_) -> writeUnrevert repository p' recorded NilFL Nothing -> writeUnrevert repository (norevert+>+p) recorded NilFL when (Debug `elem` opts) $ putStrLn "About to apply to the working directory." _ <- applyToWorking repository (verbosity opts) (invert p) `catch` \(e :: IOException) -> fail ("Unable to apply inverse patch!" ++ show e) return ()) :: IO () putStrLn "Finished reverting." darcs-2.10.2/src/Darcs/UI/Commands/MarkConflicts.hs0000644000175000017500000001534612620122474023727 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.MarkConflicts ( markconflicts ) where import Prelude hiding ( (^), catch ) import System.Exit ( exitSuccess ) import Data.List.Ordered ( nubSort ) import Control.Monad ( when, unless ) import Control.Exception ( catch, IOException ) import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Printer( putDocLn, putDocLnWith, text, redText, ($$) ) import Darcs.Util.Printer.Color (fancyPrinters) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag, diffingOpts, verbosity, dryRun, umask, useCache ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..) ) import Darcs.Repository ( withRepoLock, RepoJob(..), addToPending, applyToWorking, readRepo, unrecordedChanges, Repository ) import Darcs.Patch ( invert, PrimOf, listTouchedFiles ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Repository.Resolution ( patchsetConflictResolutions ) #include "impossible.h" markconflictsDescription :: String markconflictsDescription = "Mark unresolved conflicts in working tree, for manual resolution." markconflictsHelp :: String markconflictsHelp = unlines ["Darcs requires human guidance to unify changes to the same part of a" ,"source file. When a conflict first occurs, darcs will add the" ,"initial state and both choices to the working tree, delimited by the" ,"markers `v v v`, `=====`, `* * *` and `^ ^ ^`, as follows:" ,"" ," v v v v v v v" ," Initial state." ," =============" ," First choice." ," *************" ," Second choice." ," ^ ^ ^ ^ ^ ^ ^" ,"" ,"However, you might revert or manually delete these markers without" ,"actually resolving the conflict. In this case, `darcs mark-conflicts`" ,"is useful to show where are the unresolved conflicts. It is also" ,"useful if `darcs apply` is called with `--apply-conflicts`," ,"where conflicts aren't marked initially." ,"" ,"Unless you use the `--dry-run` flag, any unrecorded changes to the" ,"working tree WILL be lost forever when you run this command!" ,"You will be prompted for confirmation before this takes place." ] markconflictsBasicOpts :: DarcsOption a (O.UseIndex -> Maybe String -> O.DiffAlgorithm -> O.DryRun -> O.XmlOutput -> a) markconflictsBasicOpts = O.useIndex ^ O.workingRepoDir ^ O.diffAlgorithm ^ O.dryRunXml markconflictsAdvancedOpts :: DarcsOption a (O.UMask -> a) markconflictsAdvancedOpts = O.umask markconflictsOpts :: DarcsOption a (O.UseIndex -> Maybe String -> O.DiffAlgorithm -> O.DryRun -> O.XmlOutput -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) markconflictsOpts = markconflictsBasicOpts `withStdOpts` markconflictsAdvancedOpts markconflicts :: DarcsCommand [DarcsFlag] markconflicts = DarcsCommand { commandProgramName = "darcs" , commandName = "mark-conflicts" , commandHelp = markconflictsHelp , commandDescription = markconflictsDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = markconflictsCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc markconflictsAdvancedOpts , commandBasicOptions = odesc markconflictsBasicOpts , commandDefaults = defaultFlags markconflictsOpts , commandCheckOptions = ocheck markconflictsOpts , commandParseOptions = onormalise markconflictsOpts } markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () markconflictsCmd _ opts [] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do pend <- unrecordedChanges (diffingOpts opts) repository Nothing r <- readRepo repository Sealed res <- return $ patchsetConflictResolutions r case nubSort $ listTouchedFiles res of [] -> putStrLn "No conflicts to mark." >> exitSuccess cfs -> putDocLnWith fancyPrinters $ redText "Conflicts found in the following files:" $$ text (unlines cfs) when (dryRun opts == O.YesDryRun) $ do putDocLn $ text "Conflicts will not be marked: this is a dry run." exitSuccess let undoUnrec :: FL (PrimOf p) wR wU -> IO (Repository p wR wR wR) 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 exitSuccess applyToWorking repository (verbosity opts) (invert pend') `catch` \(e :: IOException) -> bug ("Can't undo pending changes!" ++ show e) repository' <- undoUnrec pend withSignalsBlocked $ do addToPending repository' YesUpdateWorking res _ <- applyToWorking repository' (verbosity opts) res `catch` \(e :: IOException) -> bug ("Problem marking conflicts in mark-conflicts!" ++ show e) return () putStrLn "Finished marking conflicts." markconflictsCmd _ _ _ = impossible darcs-2.10.2/src/Darcs/UI/Commands/Apply.hs0000644000175000017500000004140612620122474022251 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Apply ( apply, applyCmd , getPatchBundle -- used by darcsden ) where import System.Exit ( exitSuccess ) import Prelude hiding ( (^), catch ) import Control.Monad ( when ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , putVerbose , amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag , doHappyForwarding, doReverse, verbosity, useCache, dryRun , reorder, umask , fixUrl, getCc, getSendmailCmd , diffAlgorithm, isUnified, getReply ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) import Darcs.Repository ( Repository , SealedPatchSet , withRepoLock , readRepo , filterOutConflicts ) import Darcs.Patch.Set ( Origin, newset2RL ) import Darcs.Patch ( RepoPatch, PrimOf ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI ) import Darcs.Patch.Witnesses.Ordered ( RL(..), (:\/:)(..), (:>)(..) , mapRL, nullFL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Util.ByteString ( linesPS, unlinesPS, 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.Util.Download ( Cachable(Uncachable) ) import Darcs.Repository.External ( gzFetchFilePS ) import Darcs.UI.External ( sendEmailDoc , resendEmail , verifyPS ) import Darcs.UI.Email ( readEmail ) import Darcs.Patch.Depends ( findUncommon, findCommonWithThem ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..), PatchProxy ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(..) , runSelection , selectionContext ) import qualified Darcs.UI.SelectChanges as S import Darcs.Patch.Bundle ( scanBundle ) import Darcs.Util.Printer ( packedString, vcat, text, empty , renderString, RenderMode(..) ) import Storage.Hashed.Tree( Tree ) #include "impossible.h" applyDescription :: String applyDescription = "Apply a patch bundle created by `darcs send'." applyHelp :: String applyHelp = unlines [ "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 the `--reply noreply@example.net` option is used, and the bundle is" , "attached to an email, Darcs will send a report (indicating success or" , "failure) to the sender of the bundle (the `To` field). The argument to" , "noreply is the address the report will appear to originate FROM." , "" , "The `--cc` option will cause the report to be CC'd to another address," , "for example `--cc reports@lists.example.net,admin@lists.example.net`." , "Using `--cc` without `--reply` is undefined." , "" , "If you want to use a command different from the default one for sending mail," , "you need to specify a command line with the `--sendmail-command` option." , "The command line can contain the format specifier `%t` for to" , "and you can add `%<` 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:" , "" , " msmtp -t %<" , "" , "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. In that" , "case, the rejection email from `--reply` will include the test output." ] stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] stdindefault _ x = return x conflictsOpt :: DarcsOption a (Maybe O.AllowConflicts -> a) conflictsOpt = O.conflicts O.NoAllowConflicts applyBasicOpts :: DarcsOption a (O.Verify -> O.Reorder -> Maybe Bool -> O.DryRun -> O.XmlOutput -> [O.MatchFlag] -> Maybe O.AllowConflicts -> O.ExternalMerge -> O.RunTest -> O.LeaveTestDir -> Maybe String -> O.DiffAlgorithm -> a) applyBasicOpts = O.verify ^ O.reorder ^ O.interactive ^ O.dryRunXml ^ O.matchSeveral ^ conflictsOpt ^ O.useExternalMerge ^ O.test ^ O.leaveTestDir ^ O.workingRepoDir ^ O.diffAlgorithm applyAdvancedOpts :: DarcsOption a (Maybe String -> Maybe String -> Bool -> (Bool, Maybe String) -> O.UseIndex -> O.Compression -> O.SetScriptsExecutable -> O.UMask -> Bool -> Bool -> O.WantGuiPause -> a) applyAdvancedOpts = O.reply ^ O.ccApply ^ O.happyForwarding ^ O.sendmail ^ O.useIndex ^ O.compress ^ O.setScriptsExecutable ^ O.umask ^ O.restrictPaths ^ O.changesReverse ^ O.pauseForGui applyOpts :: DarcsOption a (O.Verify -> O.Reorder -> Maybe Bool -> O.DryRun -> O.XmlOutput -> [O.MatchFlag] -> Maybe O.AllowConflicts -> O.ExternalMerge -> O.RunTest -> O.LeaveTestDir -> Maybe String -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> Maybe String -> Maybe String -> Bool -> (Bool, Maybe String) -> O.UseIndex -> O.Compression -> O.SetScriptsExecutable -> O.UMask -> Bool -> Bool -> O.WantGuiPause -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts apply :: DarcsCommand [DarcsFlag] apply = DarcsCommand { commandProgramName = "darcs" , commandName = "apply" , commandHelp = applyHelp ++ "\n" ++ applyHelp' , commandDescription = applyDescription , commandExtraArgs = 1 , commandExtraArgHelp = [""] , commandCommand = applyCmd StandardPatchApplier , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = const stdindefault , commandAdvancedOptions = odesc applyAdvancedOpts , commandBasicOptions = odesc applyBasicOpts , commandDefaults = defaultFlags applyOpts , commandCheckOptions = ocheck applyOpts , commandParseOptions = onormalise applyOpts } applyCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () applyCmd _ _ _ [""] = fail "Empty filename argument given to apply!" applyCmd patchApplier _ opts ["-"] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ repoJob patchApplier opts $ \patchProxy repository -> do -- for darcs users who try out 'darcs apply' without any arguments putVerbose opts $ text "reading patch bundle from stdin..." bundle <- gzReadStdin applyCmdCommon patchApplier patchProxy opts bundle repository applyCmd patchApplier (_,o) opts [unfixed_patchesfile] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ repoJob patchApplier opts $ \patchProxy repository -> do patchesfile <- fixUrl o unfixed_patchesfile bundle <- gzFetchFilePS (toFilePath patchesfile) Uncachable applyCmdCommon patchApplier patchProxy opts bundle repository applyCmd _ _ _ _ = impossible applyCmdCommon :: forall pa p wR wU . ( PatchApplier pa, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree , RepoPatch (CarrierType pa p), ApplyState (CarrierType pa p) ~ Tree ) => pa -> PatchProxy p -> [DarcsFlag] -> B.ByteString -> Repository (CarrierType pa p) wR wU wR -> IO () applyCmdCommon patchApplier patchProxy opts bundle repository = do let from_whom = getFrom bundle us <- readRepo repository either_them <- getPatchBundle opts bundle Sealed them <- case either_them of Right t -> return t Left er -> do forwarded <- considerForwarding opts bundle if forwarded then 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 (CarrierType pa p)) wX wY -> [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 Encode $ vcat $ map showPatchInfoUI 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) <- if parseFlags conflictsOpt opts == Nothing -- skip conflicts then filterOutConflicts (reverseFL us') repository 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 doReverse opts then FirstReversed else First context = selectionContext direction "apply" (patchSelOpts opts) Nothing Nothing (to_be_applied :> _) <- runSelection (selectChanges their_ps) context applyPatches patchApplier patchProxy "apply" opts from_whom repository us' to_be_applied -- see the default (False) for the option -- where fixed_opts = if Interactive `elem` opts -- then opts -- else All : opts getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString -> IO (Either String (SealedPatchSet p Origin)) getPatchBundle opts 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 $ scanBundle bundle (Nothing, Just bundle) -> return $ scanBundle 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 scanBundle bundle of Left e -> case scanBundle $ 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 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 bundle = readFrom $ linesPS bundle where readFrom [] = "" readFrom (x:xs) | B.take 5 x == fromStart = BC.unpack $ B.drop 5 x | otherwise = readFrom xs 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 bundle = case getReply opts of Nothing -> return False Just from -> case break is_from (linesPS bundle) of (m1, f:m2) -> let m_lines = forwardingMessage:m1 ++ m2 m' = unlinesPS m_lines f' = BC.unpack (B.drop 5 f) in if from == f' || from == init f' then return False -- Refuse possible email loop. else do scmd <- getSendmailCmd opts if doHappyForwarding opts then resendEmail from scmd bundle else sendEmailDoc f' from "A forwarded darcs patch" cc scmd (Just (empty,empty)) (packedString m') return True _ -> return False -- Don't forward emails lacking headers! where cc = getCc opts is_from l = B.take 5 l == fromStart fromStart :: B.ByteString fromStart = BC.pack "From:" patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags , S.diffAlgorithm = diffAlgorithm flags , S.interactive = maybeIsInteractive flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = isUnified flags } maybeIsInteractive :: [DarcsFlag] -> Bool maybeIsInteractive = maybe False id . parseFlags O.interactive darcs-2.10.2/src/Darcs/UI/Commands/Optimize.hs0000644000175000017500000006746712620122474023003 0ustar00guillaumeguillaume00000000000000-- 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, OverloadedStrings #-} module Darcs.UI.Commands.Optimize ( optimize, doOptimizeHTTP ) where import Prelude hiding ( (^) ) import Control.Applicative ( (<$>) ) import Control.Exception ( finally ) import Control.Monad ( when, unless, forM_ ) import Data.Maybe ( isJust, fromJust ) import Data.List ( sort ) import Data.Set ( difference ) import System.Directory ( getDirectoryContents , doesDirectoryExist , doesFileExist , renameFile , getModificationTime , createDirectoryIfMissing , removeFile , getHomeDirectory ) import System.IO.Unsafe ( unsafeInterleaveIO ) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL import Darcs.Patch.PatchInfoAnd ( extractHash ) import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, amInRepository, putInfo , normalCommand, withStdOpts ) import Darcs.Repository.Prefs ( getPreflist, getCaches, globalCacheDir, oldGlobalCacheDir ) import Darcs.Repository ( Repository , withRepoLock , RepoJob(..) , readRepo , reorderInventory , cleanRepository , replacePristine ) import Darcs.Repository.HashedRepo ( inventoriesDir, patchesDir, pristineDir, hashedInventory, filterDirContents, readHashedPristineRoot, listInventoriesRepoDir, listPatchesLocalBucketed, set, unset, inv2pris ) import Darcs.Repository.HashedIO ( getHashedFiles ) import Darcs.Repository.Old ( oldRepoFailMsg ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Util ( getRecursiveDarcsRepos ) import Darcs.Patch.Witnesses.Ordered ( mapFL , bunchFL , lengthRL ) import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Set ( newset2RL , newset2FL , progressPatchSet ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Util.ByteString ( gzReadFilePS ) import Darcs.Util.Printer ( text ) import Darcs.Repository.Lock ( maybeRelink , gzWriteAtomicFilePS , writeAtomicFilePS , rmRecursive , removeFileMayNotExist ) import Darcs.Util.File ( withCurrentDirectory, getRecursiveContents ) import Darcs.UI.External ( catchall ) import Darcs.Util.Progress ( beginTedious , endTedious , tediousSize , debugMessage ) import Darcs.Util.Global ( darcsdir ) import System.FilePath.Posix ( takeExtension , () , (<.>) , takeFileName , joinPath ) import Text.Printf ( printf ) import System.Posix.Files ( getFileStatus, isDirectory ) import Darcs.UI.Flags ( DarcsFlag(Compress) , compression, verbosity, useCache, umask ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..), DryRun ( NoDryRun ), UseCache (..), UMask (..) , WithWorkingDir(WithWorkingDir) ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Repository.Cache ( hashedDir, bucketFolder, HashedDir(HashedPristineDir) ) import Darcs.Repository.Format ( identifyRepoFormat , createRepoFormat , writeRepoFormat , formatHas , RepoProperty ( HashedInventory ) ) import Darcs.Repository.PatchIndex import qualified Darcs.Repository.HashedRepo as HashedRepo import Darcs.Repository.State ( readRecorded ) import Storage.Hashed.Tree ( Tree , TreeItem(..) , list , expand , emptyTree ) import Darcs.Util.Path( anchorPath, toFilePath, AbsolutePath ) import Storage.Hashed.Plain( readPlainTree ) import Storage.Hashed.Darcs ( writeDarcsHashed , decodeDarcsSize ) import Codec.Archive.Tar ( write ) import Codec.Archive.Tar.Entry ( fileEntry, toTarPath ) import Codec.Compression.GZip ( compress ) 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." optimize :: DarcsCommand [DarcsFlag] 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 optimizePristine, normalCommand optimizeUpgrade, normalCommand optimizeGlobalCache ] } commonBasicOpts :: DarcsOption a (Maybe String -> UMask -> a) commonBasicOpts = O.workingRepoDir ^ O.umask commonAdvancedOpts :: DarcsOption a a commonAdvancedOpts = oid commonOpts :: DarcsOption a (Maybe String -> UMask -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) commonOpts = commonBasicOpts `withStdOpts` commonAdvancedOpts common :: DarcsCommand [DarcsFlag] common = DarcsCommand { commandProgramName = "darcs" , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandPrereq = amInRepository , commandArgdefaults = nodefaults , commandName = undefined , commandHelp = undefined , commandDescription = undefined , commandCommand = undefined , commandGetArgPossibilities = undefined , commandAdvancedOptions = odesc commonAdvancedOpts , commandBasicOptions = odesc commonBasicOpts , commandDefaults = defaultFlags commonOpts , commandCheckOptions = ocheck commonOpts , commandParseOptions = onormalise commonOpts } optimizeClean :: DarcsCommand [DarcsFlag] optimizeClean = common { commandName = "clean" , commandHelp = "This command deletes obsolete files within the repository." , commandDescription = "garbage collect pristine, inventories and patches" , commandCommand = optimizeCleanCmd } optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeCleanCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories putInfo opts "Done cleaning repository!" optimizeUpgrade :: DarcsCommand [DarcsFlag] optimizeUpgrade = common { commandName = "upgrade" , commandHelp = "Convert old-fashioned repositories to the current default hashed format." , commandDescription = "upgrade repository to latest compatible format" , commandCommand = optimizeUpgradeCmd } optimizeHttp :: DarcsCommand [DarcsFlag] optimizeHttp = common { commandName = "http" , commandHelp = optimizeHelpHttp , commandDescription = "optimize repository for getting over network" , commandCommand = optimizeHttpCmd } optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeHttpCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories doOptimizeHTTP repository putInfo opts "Done creating packs!" optimizePristine :: DarcsCommand [DarcsFlag] optimizePristine = common { commandName = "pristine" , commandHelp = "This command updates the format of `_darcs/pristine.hashed/`, which was different\n" ++ "before darcs 2.3.1." , commandDescription = "optimize hashed pristine layout" , commandCommand = optimizePristineCmd } optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizePristineCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories doOptimizePristine opts repository putInfo opts "Done optimizing pristine!" optimizeCompress :: DarcsCommand [DarcsFlag] optimizeCompress = common { commandName = "compress" , commandHelp = optimizeHelpCompression , commandDescription = "compress patches and inventories" , commandCommand = optimizeCompressCmd } optimizeUncompress :: DarcsCommand [DarcsFlag] optimizeUncompress = common { commandName = "uncompress" , commandHelp = optimizeHelpCompression , commandDescription = "uncompress patches and inventories" , commandCommand = optimizeUncompressCmd } optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeCompressCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories optimizeCompression [Compress] putInfo opts "Done optimizing by compression!" optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeUncompressCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories optimizeCompression [] putInfo opts "Done optimizing by uncompression!" optimizeCompression :: [DarcsFlag] -> IO () optimizeCompression opts = do putInfo opts "Optimizing (un)compression of patches..." do_compress (darcsdir++"/patches") putInfo opts "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 optimizeEnablePatchIndex :: DarcsCommand [DarcsFlag] optimizeEnablePatchIndex = common { commandName = "enable-patch-index" , commandHelp = "Build the patch index, an internal data structure that accelerates\n" ++ "commands that need to know what patches touch a given file. Such as\n" ++ "annotate and log." , commandDescription = "Enable patch index" , commandCommand = optimizeEnablePatchIndexCmd } optimizeDisablePatchIndex :: DarcsCommand [DarcsFlag] optimizeDisablePatchIndex = common { commandName = "disable-patch-index" , commandHelp = "Delete and stop maintaining the patch index from the repository." , commandDescription = "Disable patch index" , commandCommand = optimizeDisablePatchIndexCmd } optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeEnablePatchIndexCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do createOrUpdatePatchIndexDisk repository putInfo opts "Done enabling patch index!" optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeDisablePatchIndexCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(Repo repodir _ _ _) -> do deletePatchIndex repodir putInfo opts "Done disabling patch index!" optimizeReorder :: DarcsCommand [DarcsFlag] optimizeReorder = common { commandName = "reorder" , commandHelp = "This command 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." , commandDescription = "reorder the patches in the repository" , commandCommand = optimizeReorderCmd } optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeReorderCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do reorderInventory repository (compression opts) YesUpdateWorking (verbosity opts) putInfo opts "Done reordering!" optimizeRelinkBasicOpts :: DarcsOption a (Maybe String -> UMask -> [AbsolutePath] -> a) optimizeRelinkBasicOpts = commonBasicOpts ^ O.siblings optimizeRelinkOpts :: DarcsOption a (Maybe String -> UMask -> [AbsolutePath] -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) optimizeRelinkOpts = optimizeRelinkBasicOpts `withStdOpts` commonAdvancedOpts optimizeRelink :: DarcsCommand [DarcsFlag] optimizeRelink = common { commandName = "relink" , commandHelp = optimizeHelpRelink , commandDescription = "relink random internal data to a sibling" , commandCommand = optimizeRelinkCmd , commandAdvancedOptions = odesc commonAdvancedOpts , commandBasicOptions = odesc optimizeRelinkBasicOpts , commandDefaults = defaultFlags optimizeRelinkOpts , commandCheckOptions = ocheck optimizeRelinkOpts , commandParseOptions = onormalise optimizeRelinkOpts } optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeRelinkCmd _ opts _ = do withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories doRelink opts putInfo opts "Done relinking!" optimizeHelpHttp :: String optimizeHelpHttp = unlines [ "Using this option creates 'repository packs' that could 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." ] 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." 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 clone` to copy a\n" ++ "repository, or if you pulled the same patch from a remote repository\n" ++ "into multiple local repositories." doOptimizePristine :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository p wR wU wT -> IO () doOptimizePristine opts 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 putInfo opts "Optimizing hashed pristine..." readRecorded repo >>= replacePristine repo cleanRepository repo doRelink :: [DarcsFlag] -> IO () doRelink opts = do let some_siblings = parseFlags 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 (darcsdir "patches") let patches = [ anchorPath "" p | (p, File _) <- list patch_tree ] maybeRelinkFiles siblings patches $ darcsdir "patches" 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 optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeUpgradeCmd _ opts _ = do debugMessage "Upgrading to hashed..." 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 "Checking repository in case of corruption..." withRepoLock NoDryRun YesUseCache YesUpdateWorking NoUMask $ RepoJob $ \repository -> actuallyUpgradeFormat repository actuallyUpgradeFormat :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> 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 YesUseCache "." 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 -- We ignore the returned root hash, we don't use it. _ <- writeDarcsHashed emptyTree $ darcsdir "pristine.hashed" sequence_ $ mapFL HashedRepo.applyToTentativePristine $ bunchFL 100 patchesToApply -- now make it official HashedRepo.finalizeTentativeChanges repository compr writeRepoFormat (createRepoFormat True WithWorkingDir) (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 where rmGzsIn dir = withCurrentDirectory dir $ do gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "." mapM_ removeFile gzs doOptimizeHTTP :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> 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 -- pristine hash Just hash <- readHashedPristineRoot repo writeFile ( packsDir "pristine" ) hash -- pack patchesTar ps <- mapFL hashedPatchFileName . newset2FL <$> 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 = map ((darcsdir d) ) <$> (filterDirContents d $ const True) 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 optimizeBucketed :: [DarcsFlag] -> IO () optimizeBucketed opts = do putInfo opts "Migrating global cache to bucketed format." gOldCacheDir <- oldGlobalCacheDir 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 case gOldCacheDir of Nothing -> debugMessage "Old global cache doesn't exist." Just gOldCacheDir' -> do debugMessage "Making bucketed cache from old cache." toBucketed (joinPath [gOldCacheDir', pristineDir]) gCachePristineDir toBucketed (joinPath [gOldCacheDir', inventoriesDir]) gCacheInventoriesDir toBucketed (joinPath [gOldCacheDir', patchesDir]) 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 <- getDirectoryContents src forM_ fileNames $ \file -> do fileStatus <- getFileStatus (src file) if not $ isDirectory fileStatus 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 [DarcsFlag] optimizeGlobalCache = common { commandName = "cache" , commandExtraArgs = -1 , commandExtraArgHelp = [ " ..." ] , commandHelp = optimizeHelpGlobalCache , commandDescription = "garbage collect global cache" , commandCommand = optimizeGlobalCacheCmd , commandPrereq = \_ -> return $ Right () } optimizeHelpGlobalCache :: String optimizeHelpGlobalCache = unlines [ "This command deletes obsolete files within the global cache." , "It takes one or more directories as arguments, and recursively" , "searches all repositories within these directories. Then it deletes" , "all files in the global cache not belonging to these repositories." , "When no directory is given, it searches repositories in the user's" , "home directory." , "" , "It also automatically migrates the global cache to the (default)" , "bucketed format." ] optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeGlobalCacheCmd _ opts args = do optimizeBucketed opts home <- getHomeDirectory let args' = if null args then [home] else args cleanGlobalCache args' opts putInfo opts "Done cleaning global cache!" cleanGlobalCache :: [String] -> [DarcsFlag] -> IO () cleanGlobalCache dirs opts = do putInfo opts "\nLooking for repositories in the following directories:" putInfo opts $ text $ unlines dirs gCacheDir' <- globalCacheDir repoPaths' <- mapM getRecursiveDarcsRepos dirs putInfo opts "Finished listing repositories." let repoPaths = unset . set $ concat repoPaths' gCache = fromJust gCacheDir' gCacheInvDir = gCache inventoriesDir gCachePatchesDir = gCache patchesDir gCachePristineDir = gCache pristineDir createDirectoryIfMissing True gCacheInvDir createDirectoryIfMissing True gCachePatchesDir createDirectoryIfMissing True gCachePristineDir remove listInventoriesRepoDir gCacheInvDir repoPaths remove ((listPatchesLocalBucketed gCache) . ( darcsdir)) gCachePatchesDir repoPaths remove getPristine gCachePristineDir repoPaths where remove fGetFiles cacheSubDir repoPaths = do s1 <- mapM fGetFiles repoPaths s2 <- getRecursiveContents cacheSubDir remove' cacheSubDir s2 (concat s1) remove' :: String -> [String] -> [String] -> IO () remove' dir s1 s2 = do mapM_ (removeFileMayNotExist . (\hashedFile -> dir bucketFolder hashedFile hashedFile)) (unset $ (set s1) `difference` (set s2)) getPristine :: String -> IO [String] getPristine darcsDir = do i <- gzReadFilePS (darcsDir darcsdir hashedInventory) priss <- getHashedFiles (darcsDir darcsdir pristineDir) [inv2pris i] return priss darcs-2.10.2/src/Darcs/UI/Commands/ShowBug.hs0000644000175000017500000000527012620122474022541 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.ShowBug ( showBug ) where import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) import Darcs.UI.Flags ( DarcsFlag ) import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O ( workingRepoDir, StdCmdAction, Verbosity, UseCache ) import Darcs.Util.Path ( AbsolutePath ) #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" showBugBasicOpts :: DarcsOption a (Maybe String -> a) showBugBasicOpts = O.workingRepoDir showBugOpts :: DarcsOption a (Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) showBugOpts = showBugBasicOpts `withStdOpts` oid showBug :: DarcsCommand [DarcsFlag] showBug = DarcsCommand { commandProgramName = "darcs" , commandName = "bug" , commandHelp = showBugHelp , commandDescription = showBugDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = showBugCmd , commandPrereq = findRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showBugBasicOpts , commandDefaults = defaultFlags showBugOpts , commandCheckOptions = ocheck showBugOpts , commandParseOptions = onormalise showBugOpts } showBugCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showBugCmd _ _ _ = bug "This is actually a fake bug in darcs." darcs-2.10.2/src/Darcs/UI/Commands/ShowFiles.hs0000644000175000017500000001635012620122474023067 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.UI.Commands.ShowFiles ( showFiles , manifestCmd, toListManifest -- for alias , manifest ) where import Prelude hiding ( (^) ) import Darcs.UI.Flags ( DarcsFlag, useCache ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.Repository ( Repository, withRepository, RepoJob(..), repoPatchType ) import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Repository.State ( readRecorded, readRecordedAndPending ) import Storage.Hashed.Tree( Tree, TreeItem(..), list, expand ) import Darcs.Util.Path( anchorPath, AbsolutePath ) import Storage.Hashed.Plain( readPlainTree ) import System.FilePath ( splitDirectories ) import Data.List( isPrefixOf ) import Darcs.Patch.Match ( haveNonrangeMatch ) import Darcs.Repository.Match ( getNonrangeMatch ) import Darcs.Repository.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 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" showFilesBasicOpts :: DarcsOption a (Bool -> Bool -> Bool -> Bool -> [O.MatchFlag] -> Maybe String -> a) showFilesBasicOpts = O.files ^ O.directories ^ O.pending ^ O.nullFlag ^ O.matchOne ^ O.workingRepoDir showFilesOpts :: DarcsOption a (Bool -> Bool -> Bool -> Bool -> [O.MatchFlag] -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) showFilesOpts = showFilesBasicOpts `withStdOpts` oid showFiles :: DarcsCommand [DarcsFlag] 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 = odesc showFilesBasicOpts, commandDefaults = defaultFlags showFilesOpts, commandCheckOptions = ocheck showFilesOpts, commandParseOptions = onormalise showFilesOpts } toListFiles, toListManifest :: [DarcsFlag] -> Tree m -> [FilePath] toListFiles opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories opts) toListManifest opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories 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]) -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () manifestCmd to_list _ opts argList = mapM_ output =<< manifestHelper to_list opts argList where output_null name = do { putStr name ; putChar '\0' } output = if parseFlags O.nullFlag 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 (useCache opts) (RepoJob myslurp) case argList of [] -> return list' prefixes -> return (onlysubdirs prefixes list') where myslurp :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> IO (Tree IO) myslurp r = do let fRevisioned = haveNonrangeMatch (repoPatchType r) (parseFlags O.matchOne opts) fPending = parseFlags O.pending opts -- this covers all 4 possibilities expand =<< case (fRevisioned,fPending) of (True,False) -> slurpRevision opts r (True,True) -> error "can't mix revisioned and pending flags" (False,False) -> readRecorded r (False,True) -> readRecordedAndPending r -- pending is default 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 wR wU wR -> IO (Tree IO) slurpRevision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do getNonrangeMatch r (parseFlags O.matchOne opts) expand =<< readPlainTree "." darcs-2.10.2/src/Darcs/UI/Commands/Pull.hs0000644000175000017500000004357212620122474022106 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Pull ( -- * Commands. pull, fetch, pullCmd, StandardPatchApplier, -- * Utility functions. fetchPatches, revertable ) where import Prelude hiding ( (^) ) import System.Exit ( exitSuccess ) import Control.Monad ( when, unless, (>=>) ) import Data.List ( nub ) import Data.Maybe ( fromMaybe ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , putInfo , setEnvDarcsPatches , formatPath , defaultRepo , amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag ( AllowConflicts , Complement , DryRun , Intersection , MarkConflicts , NoAllowConflicts , SkipConflicts , Verbose , XMLOutput , Quiet , AllowUnrelatedRepos ) , fixUrl, getOutput , doReverse, verbosity, dryRun, umask, useCache, selectDeps , remoteRepos, reorder, setDefault , isUnified, hasSummary , diffAlgorithm, isInteractive ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..) ) import Darcs.Repository ( Repository , identifyRepositoryFor , withRepoLock , RepoJob(..) , readRepo , checkUnrelatedRepos , modifyCache , modifyCache , Cache(..) , CacheLoc(..) , WritableOrNot(..) , filterOutConflicts ) import qualified Darcs.Repository.Cache as DarcsCache import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefully, patchDesc ) import Darcs.Patch ( RepoPatch, description ) import Darcs.Patch.Bundle( makeBundleN, patchFilename ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:\/:)(..), FL(..), RL(..) , mapFL, nullFL, reverseFL, mapFL_FL ) import Darcs.Patch.Permutations ( partitionFL ) import Darcs.Repository.Prefs ( addToPreflist, addRepoSource, getPreflist ) import Darcs.Repository.Motd (showMotd ) import Darcs.Patch.Depends ( findUncommon, findCommonWithThem, newsetIntersection, newsetUnion ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..) ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(..) , runSelection , selectionContext ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Printer ( putDocLn, vcat, ($$), text, putDoc ) import Darcs.Repository.Lock ( writeDocBinFile ) import Darcs.Util.Path ( useAbsoluteOrStd, stdOut, AbsolutePath ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Storage.Hashed.Tree( Tree ) #include "impossible.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 = unlines [ "Pull is used to bring patches made in another repository into the current" , "repository (that is, either the one in the current directory, or the one" , "specified with the `--repodir` option). Pull allows you to bring over all or" , "some of the patches that are in that repository but not in this one. Pull" , "accepts arguments, which are URLs from which to pull, and when called" , "without an argument, pull will use the repository from which you have most" , "recently either pushed or pulled." , "" , "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." , "" , "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." , "" , "See `darcs help apply` for detailed description of many options." ] fetchHelp :: String fetchHelp = unlines [ "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`." , "" , "Fetch's behaviour is essentially similar to pull's, so please consult" , "the help of `pull` to know more." ] pullBasicOpts :: DarcsOption a ([O.MatchFlag] -> O.Reorder -> Maybe Bool -> Maybe O.AllowConflicts -> O.ExternalMerge -> O.RunTest -> O.DryRun -> O.XmlOutput -> Maybe O.Summary -> O.SelectDeps -> Maybe Bool -> Maybe String -> Bool -> O.DiffAlgorithm -> a) pullBasicOpts = O.matchSeveral ^ O.reorder ^ O.interactive -- True ^ O.conflicts O.YesAllowConflictsAndMark ^ O.useExternalMerge ^ O.test ^ O.dryRunXml ^ O.summary ^ O.selectDeps ^ O.setDefault ^ O.workingRepoDir ^ O.allowUnrelatedRepos ^ O.diffAlgorithm pullAdvancedOpts :: DarcsOption a (O.RepoCombinator -> O.Compression -> O.UseIndex -> O.RemoteRepos -> O.SetScriptsExecutable -> O.UMask -> Bool -> Bool -> O.WantGuiPause -> O.NetworkOptions -> a) pullAdvancedOpts = O.repoCombinator ^ O.compress ^ O.useIndex ^ O.remoteRepos ^ O.setScriptsExecutable ^ O.umask ^ O.restrictPaths ^ O.changesReverse ^ O.pauseForGui ^ O.network pullOpts :: DarcsOption a ([O.MatchFlag] -> O.Reorder -> Maybe Bool -> Maybe O.AllowConflicts -> O.ExternalMerge -> O.RunTest -> O.DryRun -> O.XmlOutput -> Maybe O.Summary -> O.SelectDeps -> Maybe Bool -> Maybe String -> Bool -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.RepoCombinator -> O.Compression -> O.UseIndex -> O.RemoteRepos -> O.SetScriptsExecutable -> O.UMask -> Bool -> Bool -> O.WantGuiPause -> O.NetworkOptions -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts fetchBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe Bool -> O.DryRun -> Maybe O.Summary -> O.SelectDeps -> Maybe Bool -> Maybe String -> Maybe O.Output -> Bool -> O.DiffAlgorithm -> a) fetchBasicOpts = O.matchSeveral ^ O.interactive -- True ^ O.dryRun ^ O.summary ^ O.selectDeps ^ O.setDefault ^ O.workingRepoDir ^ O.output ^ O.allowUnrelatedRepos ^ O.diffAlgorithm fetchAdvancedOpts :: DarcsOption a (O.RepoCombinator -> O.RemoteRepos -> O.NetworkOptions -> a) fetchAdvancedOpts = O.repoCombinator ^ O.remoteRepos ^ O.network fetchOpts :: DarcsOption a ([O.MatchFlag] -> Maybe Bool -> O.DryRun -> Maybe O.Summary -> O.SelectDeps -> Maybe Bool -> Maybe String -> Maybe O.Output -> Bool -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.RepoCombinator -> O.RemoteRepos -> O.NetworkOptions -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) fetchOpts = fetchBasicOpts `withStdOpts` fetchAdvancedOpts fetch :: DarcsCommand [DarcsFlag] fetch = DarcsCommand { commandProgramName = "darcs" , commandName = "fetch" , commandHelp = fetchHelp , commandDescription = fetchDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[REPOSITORY]..."] , commandCommand = fetchCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = getPreflist "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc fetchAdvancedOpts , commandBasicOptions = odesc fetchBasicOpts , commandDefaults = defaultFlags fetchOpts , commandCheckOptions = ocheck fetchOpts , commandParseOptions = onormalise fetchOpts } pull :: DarcsCommand [DarcsFlag] pull = DarcsCommand { commandProgramName = "darcs" , commandName = "pull" , commandHelp = pullHelp , commandDescription = pullDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[REPOSITORY]..."] , commandCommand = pullCmd StandardPatchApplier , commandPrereq = amInHashedRepository , commandGetArgPossibilities = getPreflist "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc pullAdvancedOpts , commandBasicOptions = odesc pullBasicOpts , commandDefaults = defaultFlags pullOpts , commandCheckOptions = ocheck pullOpts , commandParseOptions = onormalise pullOpts } mergeOpts :: [DarcsFlag] -> [DarcsFlag] mergeOpts opts | NoAllowConflicts `elem` opts = opts | AllowConflicts `elem` opts = opts | otherwise = MarkConflicts : opts pullCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () pullCmd patchApplier (_,o) opts repos = do pullingFrom <- mapM (fixUrl o) repos withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ repoJob patchApplier opts $ \patchProxy initRepo -> do let repository = modifyCache initRepo $ addReposToCache pullingFrom (_, Sealed (us' :\/: to_be_pulled)) <- fetchPatches o opts' repos "pull" repository let from_whom = error "Internal error: pull shouldn't need a 'from' address" applyPatches patchApplier patchProxy "pull" opts' from_whom repository us' to_be_pulled where opts' = mergeOpts opts addReposToCache repos' (Ca cache) = Ca $ [ toReadOnlyCache r | r <- repos' ] ++ cache toReadOnlyCache = Cache DarcsCache.Repo NotWritable fetchCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fetchCmd (_,o) opts repos = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ fetchPatches o opts repos "fetch" >=> makeBundle opts fetchPatches :: forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => AbsolutePath -> [DarcsFlag] -> [String] -> String -> Repository p wR wU wR -> IO (SealedPatchSet p Origin, Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wR)) fetchPatches o opts unfixedrepodirs@(_:_) jobname repository = do here <- getCurrentDirectory repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl o) 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 && XMLOutput `notElem` 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 addRepoSource (head repodirs) (dryRun opts) (remoteRepos opts) (setDefault False opts) mapM_ (addToPreflist "repos") repodirs unless (Quiet `elem` opts || XMLOutput `elem` opts) $ mapM_ showMotd repodirs us <- readRepo repository checkUnrelatedRepos (AllowUnrelatedRepos `elem` 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 () unless (nullFL ps) $ putDocLn $ text "They have the following patches to pull:" $$ vcat (mapFL description ps) (hadConflicts, Sealed psFiltered) <- if SkipConflicts `elem` opts then filterOutConflicts (reverseFL us') repository ps else return (False, Sealed ps) when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts." when (nullFL psFiltered) $ do putInfo opts $ text "No remote patches to pull in!" setEnvDarcsPatches psFiltered when (reorder opts /= O.Reorder) exitSuccess let direction = if doReverse opts then FirstReversed else First context = selectionContext direction jobname (pullPatchSelOpts opts) Nothing Nothing (to_be_pulled :> _) <- runSelection (selectChanges psFiltered) context return (seal common, seal $ 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] -> (SealedPatchSet p Origin, Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wR)) -> 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 wR wU wT -> [DarcsFlag] -> [String] -> IO (SealedPatchSet p Origin,SealedPatchSet p Origin) readRepos _ _ [] = impossible readRepos to_repo opts us = do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo (useCache opts) 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)) pullPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions pullPatchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = isUnified flags } darcs-2.10.2/src/Darcs/UI/Commands/ShowTags.hs0000644000175000017500000000770212620122474022724 0ustar00guillaumeguillaume00000000000000-- 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 Control.Monad ( unless, join ) import Data.Maybe ( fromMaybe ) import System.IO ( stderr, hPutStrLn ) import Darcs.Patch.Set ( PatchSet(..) ) import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Repository ( readRepo, withRepositoryDirectory, RepoJob(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) import Darcs.UI.Commands.Tag ( getTags ) import Darcs.UI.Flags ( DarcsFlag, useCache, getRepourl ) import Darcs.UI.Options ( DarcsOption, PrimDarcsOption , oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Text ( formatText ) import Darcs.Util.Path ( AbsolutePath ) showTagsDescription :: String showTagsDescription = "Show all tags in the repository." showTagsHelp :: String 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." ] showTagsBasicOpts :: PrimDarcsOption (Maybe String) showTagsBasicOpts = O.possiblyRemoteRepo showTagsOpts :: DarcsOption a (Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) showTagsOpts = showTagsBasicOpts `withStdOpts` oid showTags :: DarcsCommand [DarcsFlag] showTags = DarcsCommand { commandProgramName = "darcs" , commandName = "tags" , commandHelp = showTagsHelp , commandDescription = showTagsDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = tagsCmd , commandPrereq = findRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showTagsBasicOpts , commandDefaults = defaultFlags showTagsOpts , commandCheckOptions = ocheck showTagsOpts , commandParseOptions = onormalise showTagsOpts } tagsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () tagsCmd _ opts _ = let repodir = fromMaybe "." (getRepourl opts) in withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> readRepo repo >>= printTags where printTags :: MaybeInternal p => PatchSet p wW wZ -> IO () printTags = join . fmap (sequence_ . map process) . getTags 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 darcs-2.10.2/src/Darcs/UI/Commands/Util.hs0000644000175000017500000001165312620122474022102 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Util ( announceFiles , filterExistingFiles , testTentativeAndMaybeExit , getUniqueRepositoryName , getUniqueDPatchName ) where import Control.Monad ( unless ) import System.Exit ( ExitCode(..), exitWith ) import Storage.Hashed.Monad ( virtualTreeIO, exists ) import Storage.Hashed.Tree ( Tree ) import Storage.Hashed( floatPath, readPlainTree ) import Darcs.Util.Path ( SubPath, toFilePath, getUniquePathName ) import Darcs.Patch ( RepoPatch ) import Darcs.Repository ( Repository, readRecorded, readUnrecorded, testTentative ) import Darcs.Repository.State ( applyTreeFilter, restrictBoring ) import Darcs.Repository.Flags ( LookForAdds (..) ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Bundle ( patchFilename ) import Darcs.UI.Options.All ( Verbosity, SetScriptsExecutable, TestChanges (..) , RunTest(..), LeaveTestDir(..) ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Prompt ( PromptConfig(..), promptChar ) announceFiles :: Maybe [SubPath] -> String -> IO () announceFiles Nothing _ = return () announceFiles (Just files) message = putStrLn $ message ++ " " ++ unwords (map show files) ++ ":\n" testTentativeAndMaybeExit :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> TestChanges -> SetScriptsExecutable -> Bool -> String -> String -> Maybe String -> IO () testTentativeAndMaybeExit repo verb test sse interactive failMessage confirmMsg withClarification = do let (rt,ltd) = case test of NoTestChanges -> (NoRunTest, YesLeaveTestDir) YesTestChanges x -> (YesRunTest, x) testResult <- testTentative repo rt ltd sse verb unless (testResult == ExitSuccess) $ do let doExit = maybe id (flip clarifyErrors) withClarification $ exitWith testResult unless interactive doExit putStrLn $ "Looks like " ++ failMessage let prompt = "Shall I " ++ confirmMsg ++ " anyway?" yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') []) unless (yn == 'y') doExit filterExistingFiles :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> LookForAdds -> [SubPath] -> IO [SubPath] filterExistingFiles repo lfa 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 . 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) | lfa == YesLookForAdds = putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!" maybe_warn _ = return () 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 = getUniquePathName True buildMsg buildName where buildName i = if i == -1 then patchFilename name else patchFilename $ name++"_"++show i buildMsg n = "Directory or file '"++ name ++ "' already exists, creating dpatch as '"++ n ++"'" darcs-2.10.2/src/Darcs/UI/Commands/Help.hs0000644000175000017500000004157312620122474022061 0ustar00guillaumeguillaume00000000000000-- 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.Help ( helpCmd, commandControlList, environmentHelp, -- these are for preproc.hs printVersion, listAvailableCommands ) where import Darcs.UI.Flags ( DarcsFlag , environmentHelpEmail , environmentHelpSendmail ) import Darcs.UI.Options.Markdown ( optionsMarkdown ) import Darcs.UI.Commands ( CommandArgs(..) , CommandControl(..) , normalCommand , DarcsCommand(..), withStdOpts , WrappedCommand(..) , wrappedCommandName , disambiguateCommands , extractCommands , getCommandHelp , nodefaults , usage ) import Darcs.UI.External ( viewDoc ) import Darcs.Repository.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir , environmentHelpLocks ) import Darcs.Patch.Match ( helpOnMatchers ) import Darcs.Repository.Prefs ( boringFileHelp, binariesFileHelp, environmentHelpHome ) import Darcs.Repository.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) import Darcs.Repository.External ( environmentHelpProtocols ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Path ( AbsolutePath ) import Control.Arrow ( (***) ) import Data.Char ( isAlphaNum, toLower, toUpper ) import Data.Either ( partitionEithers ) import Data.List ( groupBy, isPrefixOf, intercalate, nub ) import Darcs.Util.English ( andClauses ) import Darcs.Util.Printer (text, vcat, vsep, ($$), empty) import Darcs.Util.Printer.Color ( environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite ) import System.Exit ( exitSuccess ) import Version ( version ) import Darcs.Util.Download ( environmentHelpProxy, environmentHelpProxyPassword ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.UI.Options ( DarcsOption, defaultFlags, ocheck, onormalise, oid ) import qualified Darcs.UI.Options.All as O ( StdCmdAction, Verbosity, UseCache ) import qualified Darcs.UI.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" argPossibilities :: [String] argPossibilities = map wrappedCommandName $ extractCommands commandControlList helpOpts :: DarcsOption a (Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) helpOpts = withStdOpts oid oid help :: DarcsCommand [DarcsFlag] help = DarcsCommand { commandProgramName = "darcs" , commandName = "help" , commandHelp = helpHelp , commandDescription = helpDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[ [DARCS_SUBCOMMAND]] "] , commandCommand = \ x y z -> helpCmd x y z >> exitSuccess , commandPrereq = \_ -> return $ Right () , commandGetArgPossibilities = return argPossibilities , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = [] , commandDefaults = defaultFlags helpOpts , commandCheckOptions = ocheck helpOpts , commandParseOptions = onormalise helpOpts } helpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () helpCmd _ _ ["manpage"] = putStr $ unlines manpageLines helpCmd _ _ ["markdown"] = putStr $ unlines markdownLines helpCmd _ _ ["patterns"] = viewDoc $ text $ unlines helpOnMatchers helpCmd _ _ ("environment":vs_) = viewDoc $ header $$ vsep (map render known) $$ footer where header | null known = empty | otherwise = text "Environment Variables" $$ text "=====================" footer | null unknown = empty | otherwise = text "" $$ 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 $ 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 (\(WrappedCommand c)-> withCurrentDirectory here $ commandPrereq c []) (extractCommands commandControlList) putStr $ unlines $ map (wrappedCommandName . 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 = 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, environmentHelpProxy, environmentHelpProxyPassword, environmentHelpProtocols, environmentHelpTimeout] -- | 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 (unlines 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: 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 :: [String] synopsis = foldl iter [] commandControlList where iter :: [String] -> CommandControl -> [String] iter acc (GroupName _) = acc iter acc (HiddenCommand _) = acc iter acc (CommandData (WrappedCommand c@SuperCommand {})) = acc ++ concatMap (render (commandName c ++ " ")) (extractCommands (commandSubCommands c)) iter acc (CommandData c) = acc ++ render "" c render :: String -> WrappedCommand -> [String] render prefix (WrappedCommand 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 (WrappedCommand c@SuperCommand {})) = acc ++ concatMap (render (commandName c ++ " ")) (extractCommands (commandSubCommands c)) iter acc (CommandData c) = acc ++ render "" c render :: String -> WrappedCommand -> [String] render prefix (WrappedCommand 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] 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) markdownLines :: [String] markdownLines = [ "Darcs " ++ version, "" , "# Commands", "" , unlines commands , "# Environment variables" , "", unlines environment , "# Patterns" , "", unlines helpOnMatchers ] where 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 (WrappedCommand c@SuperCommand {})) = acc ++ concatMap (render (commandName c ++ " ")) (extractCommands (commandSubCommands c)) iter acc (CommandData c) = acc ++ render "" c render :: String -> WrappedCommand -> [String] render prefix (WrappedCommand c) = [ "### " ++ prefix ++ commandName c , "", "darcs " ++ prefix ++ commandName c ++ " [OPTION]... " ++ unwords (commandExtraArgHelp c) , "", commandDescription c , "", commandHelp c , "Options:", optionsMarkdown $ commandBasicOptions c , if null opts2 then "" else unlines ["Advanced Options:", optionsMarkdown opts2] ] where opts2 = commandAdvancedOptions c 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."]) 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."]) 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. darcs-2.10.2/src/Darcs/UI/Commands/Rebase.hs0000644000175000017500000012525312620122474022370 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2009 Ganesh Sittampalam -- -- BSD3 {-# LANGUAGE CPP, TypeOperators #-} module Darcs.UI.Commands.Rebase ( rebase ) where import Prelude hiding ( (^), catch, log ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , normalCommand, hiddenCommand , commandAlias , defaultRepo, nodefaults , putInfo, putVerbose , setEnvDarcsPatches , printDryRunMessageAndExit , amInHashedRepository ) import Darcs.UI.Commands.Amend ( updatePatchHeader ) import Darcs.UI.Commands.Apply ( applyCmd ) import Darcs.UI.Commands.Log ( changelog, getLogInfo ) import Darcs.UI.Commands.Pull ( pullCmd, revertable ) import Darcs.UI.Commands.Unrecord ( getLastPatches, matchingHead ) import Darcs.UI.CommandsAux ( checkPaths ) import Darcs.UI.Flags ( DarcsFlag ( AllowConflicts , NoAllowConflicts , MarkConflicts , SkipConflicts , SetScriptsExecutable) , externalMerge, allowConflicts , compression, diffingOpts , dryRun, reorder, verbosity , useCache, wantGuiPause , umask, toMatchFlags, doReverse , DarcsFlag(XMLOutput) , showChangesOnlyToFiles , diffAlgorithm, maxCount, hasSummary, isInteractive , selectDeps, hasXmlOutput ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository ( Repository, RepoJob(..), withRepoLock, withRepository , tentativelyAddPatch, finalizeRepositoryChanges , invalidateIndex , tentativelyRemovePatches, readRepo , tentativelyAddToPending, unrecordedChanges, applyToWorking , revertRepositoryChanges , setScriptsExecutablePatches , listFiles ) import Darcs.Repository.Flags ( UpdateWorking(..), ExternalMerge(..) ) import Darcs.Repository.Internal ( announceMergeConflicts ) import Darcs.Repository.Merge ( tentativelyMergePatches ) import Darcs.Repository.Prefs ( getPreflist ) import Darcs.Repository.Resolution ( standardResolution ) import Darcs.Patch ( invert, effect, commute, RepoPatch, description ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdFL ) import Darcs.Patch.Info ( showPatchInfo ) import Darcs.Patch.Match ( firstMatch, secondMatch, splitSecondFL ) import Darcs.Patch.Named ( patchcontents , Named, fmapNamed, fmapFL_Named , patch2patchinfo ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia, hopefully ) import Darcs.Patch.Prim ( PrimOf, canonizeFL, fromPrim ) import Darcs.Patch.Rebase ( Rebasing(..), RebaseItem(..) , mkSuspended , simplifyPush, simplifyPushes , takeHeadRebase, takeHeadRebaseFL ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims ) import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed ) import Darcs.Patch.Rebase.Viewing ( RebaseSelect(RSFwd), rsToPia , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect , partitionUnconflicted , WithDroppedDeps(..), WDDNamed, commuterIdWDD , toRebaseChanges ) import Darcs.Patch.Permutations ( partitionConflictingFL ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Patch.Set ( PatchSet(..), appendPSFL ) import Darcs.Patch.Show ( showNicely ) import Darcs.Patch.Split ( primSplitter ) import Darcs.UI.ApplyPatches ( PatchApplier(..), PatchProxy(..) ) import Darcs.UI.SelectChanges ( selectChanges, runSelection , selectionContext, selectionContextGeneric, selectionContextPrim , 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 , (:>)(..) , RL(..), reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal , FlippedSeal(..) , Sealed2(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.English ( englishNum, Noun(Noun) ) import Darcs.Util.Printer ( vcat, text, ($$) , putDocLnWith, simplePrinters , renderString, RenderMode(..) ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Path ( AbsolutePath ) import Storage.Hashed.Tree ( Tree ) import Control.Applicative ( (<$>) ) import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import System.Exit ( exitSuccess ) #include "impossible.h" rebaseDescription :: String rebaseDescription = "Edit several patches at once." rebaseHelp :: String rebaseHelp = "The `darcs rebase' command is used to edit a collection of darcs patches.\n" rebase :: DarcsCommand [DarcsFlag] rebase = SuperCommand { commandProgramName = "darcs" , commandName = "rebase" , commandHelp = rebaseHelp , commandDescription = rebaseDescription , commandPrereq = amInHashedRepository , commandSubCommands = [ normalCommand pull , normalCommand apply , normalCommand suspend , normalCommand unsuspend , hiddenCommand reify , hiddenCommand inject , normalCommand obliterate , normalCommand log , hiddenCommand changes ] } suspendBasicOpts :: DarcsOption a ([O.MatchFlag] -> O.SelectDeps -> Maybe Bool -> Maybe O.Summary -> O.DiffAlgorithm -> a) suspendBasicOpts = O.matchSeveralOrLast ^ O.selectDeps ^ O.interactive ^ O.summary ^ O.diffAlgorithm suspendAdvancedOpts :: DarcsOption a (Bool -> O.UseIndex -> a) suspendAdvancedOpts = O.changesReverse ^ O.useIndex suspendOpts :: DarcsOption a ([O.MatchFlag] -> O.SelectDeps -> Maybe Bool -> Maybe O.Summary -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> Bool -> O.UseIndex -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts suspend :: DarcsCommand [DarcsFlag] suspend = DarcsCommand { commandProgramName = "darcs" , commandName = "suspend" , commandHelp = "Select patches to move into a suspended state at the end of the repo.\n" , commandDescription = "Select patches to move into a suspended state at the end of the repo." , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = suspendCmd , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc suspendAdvancedOpts , commandBasicOptions = odesc suspendBasicOpts , commandDefaults = defaultFlags suspendOpts , commandCheckOptions = ocheck suspendOpts , commandParseOptions = onormalise suspendOpts } suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () suspendCmd _ opts _args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ StartRebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \repository -> do allpatches <- readRepo repository (rOld, Sealed qs, allpatches_tail) <- return $ takeHeadRebase allpatches (_ :> patches) <- return $ if firstMatch (parseFlags O.matchSeveralOrLast opts) then getLastPatches (parseFlags O.matchSeveralOrLast opts) allpatches_tail else matchingHead (parseFlags O.matchSeveralOrLast opts) allpatches_tail let direction = if doReverse opts then Last else LastReversed patches_context = selectionContext direction "suspend" (patchSelOpts True opts) Nothing Nothing (_ :> psToSuspend) <- runSelection (selectChanges patches) patches_context when (nullFL psToSuspend) $ do putStrLn "No patches selected!" exitSuccess repository' <- doSuspend opts repository qs rOld psToSuspend finalizeRepositoryChanges repository' YesUpdateWorking (compression opts) return () doSuspend :: forall p wR wU wT wX wY . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => [DarcsFlag] -> Repository (Rebasing p) wR wU wT -> FL (RebaseItem p) wT wY -> PatchInfoAnd (Rebasing p) wT wT -> FL (PatchInfoAnd (Rebasing p)) wX wT -> IO (Repository (Rebasing p) wR wU wX) doSuspend opts repository qs rOld psToSuspend = do pend <- unrecordedChanges (diffingOpts opts) repository Nothing FlippedSeal psAfterPending <- let effectPsToSuspend = effect psToSuspend in case commute (effectPsToSuspend :> pend) of Just (_ :> res) -> return (FlippedSeal res) Nothing -> do putVerbose opts $ let invPsEffect = invert effectPsToSuspend doPartition = partitionConflictingFL (commuterIdFL selfCommuter) in case (doPartition invPsEffect pend, doPartition pend invPsEffect) of (_ :> invSuspendedConflicts, _ :> pendConflicts) -> let suspendedConflicts = invert invSuspendedConflicts in text "these changes in the suspended patches:" $$ showNicely suspendedConflicts $$ text "conflict with these local changes:" $$ showNicely pendConflicts fail $ "Can't suspend selected patches without reverting some unrecorded change. Use --verbose to see the details." rNew <- mkSuspended (mapFL_FL (ToEdit . fmapNamed unNormal . hopefully) psToSuspend +>+ qs) invalidateIndex repository repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (psToSuspend +>+ (rOld :>: NilFL)) tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect psToSuspend repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) _ <- applyToWorking repository'' (verbosity opts) (invert psAfterPending) `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e) return repository'' where unNormal :: Rebasing p wA wB -> p wA wB unNormal (Normal q) = q unNormal (Suspended _) = error "Can't suspend a rebase patch" unsuspendBasicOpts :: DarcsOption a (Maybe O.AllowConflicts -> [O.MatchFlag] -> Maybe Bool -> Maybe O.Summary -> ExternalMerge -> Bool -> Maybe String -> O.DiffAlgorithm -> a) unsuspendBasicOpts = O.conflicts O.YesAllowConflictsAndMark ^ O.matchSeveralOrFirst ^ O.interactive ^ O.summary ^ O.useExternalMerge ^ O.keepDate ^ O.author ^ O.diffAlgorithm unsuspendAdvancedOpts :: DarcsOption a (O.UseIndex -> a) unsuspendAdvancedOpts = O.useIndex unsuspendOpts :: DarcsOption a (Maybe O.AllowConflicts -> [O.MatchFlag] -> Maybe Bool -> Maybe O.Summary -> ExternalMerge -> Bool -> Maybe String -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseIndex -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) unsuspendOpts = unsuspendBasicOpts `withStdOpts` unsuspendAdvancedOpts unsuspend :: DarcsCommand [DarcsFlag] unsuspend = DarcsCommand { commandProgramName = "darcs" , commandName = "unsuspend" , commandHelp = "Selected patches to restore from a suspended state to the end of the repo.\n" , commandDescription = "Select suspended patches to restore to the end of the repo." , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = unsuspendCmd False , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc unsuspendAdvancedOpts , commandBasicOptions = odesc unsuspendBasicOpts , commandDefaults = defaultFlags unsuspendOpts , commandCheckOptions = ocheck unsuspendOpts , commandParseOptions = onormalise unsuspendOpts } reifyBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe Bool -> Bool -> Maybe String -> O.DiffAlgorithm -> a) reifyBasicOpts = O.matchSeveralOrFirst ^ O.interactive ^ O.keepDate ^ O.author ^ O.diffAlgorithm reifyOpts :: DarcsOption a ([O.MatchFlag] -> Maybe Bool -> Bool -> Maybe String -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) reifyOpts = reifyBasicOpts `withStdOpts` oid reify :: DarcsCommand [DarcsFlag] reify = DarcsCommand { commandProgramName = "darcs" , commandName = "reify" , commandHelp = "Select suspended patches to restore to the end of the repo, reifying any fixup patches.\n" , commandDescription = "Select suspended patches to restore to the end of the repo, reifying any fixup patches." , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = unsuspendCmd True , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc reifyBasicOpts , commandDefaults = defaultFlags reifyOpts , commandCheckOptions = ocheck reifyOpts , commandParseOptions = onormalise reifyOpts } unsuspendCmd :: Bool -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unsuspendCmd reifyFixups _ opts _args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \(repository :: Repository (Rebasing p) wR wU wR) -> (do patches <- readRepo repository pend <- unrecordedChanges (diffingOpts opts) repository Nothing let checkChanges :: FL (PrimOf p) wA wB -> IO (EqCheck wA wB) checkChanges NilFL = return IsEq checkChanges _ = error "can't unsuspend when there are unrecorded changes" IsEq <- checkChanges pend :: IO (EqCheck wR wU) (rOld, Sealed ps, _) <- return $ takeHeadRebase patches let selects = toRebaseSelect ps let matchFlags = toMatchFlags opts inRange :> outOfRange <- return $ if secondMatch matchFlags then splitSecondFL rsToPia matchFlags selects else selects :> NilFL offer :> dontoffer <- return $ if SkipConflicts `elem` opts then partitionUnconflicted inRange else inRange :> NilRL let warnSkip :: RL q wX wY -> IO () warnSkip NilRL = return () warnSkip _ = putStrLn "Skipping some patches which would cause conflicts." warnSkip dontoffer let patches_context = selectionContextGeneric rsToPia First "unsuspend" (patchSelOpts True opts) Nothing (chosen :> keep) <- runSelection (selectChanges offer) patches_context when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess (ps_to_unsuspend :: FL (WDDNamed p) wR wZ) :> chosen_fixups <- (if reifyFixups then reifyRebaseSelect else return . extractRebaseSelect) chosen let da = diffAlgorithm opts ps_to_keep = simplifyPushes da chosen_fixups . fromRebaseSelect $ keep +>+ reverseRL dontoffer +>+ outOfRange Sealed standard_resolved_p <- return $ standardResolution $ concatFL $ progressFL "Examining patches for conflicts" $ mapFL_FL (patchcontents . wddPatch) ps_to_unsuspend :: IO (Sealed (FL (PrimOf p) wZ)) let merge_opts | NoAllowConflicts `elem` opts = opts | AllowConflicts `elem` opts = opts | otherwise = MarkConflicts : opts have_conflicts <- announceMergeConflicts "unsuspend" (allowConflicts merge_opts) (externalMerge merge_opts) standard_resolved_p Sealed (resolved_p :: FL (PrimOf p) wA wB) <- case (externalMerge opts, have_conflicts) of (NoExternalMerge,_) -> return $ if AllowConflicts `elem` opts -- i.e. don't mark them then seal NilFL else seal standard_resolved_p (_,False) -> return $ seal standard_resolved_p (YesExternalMerge _, True) -> error "external resolution for unsuspend not implemented yet" let effect_to_apply = concatFL (mapFL_FL effect ps_to_unsuspend) +>+ resolved_p invalidateIndex repository repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL) -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord tentativelyAddToPending repository' YesUpdateWorking effect_to_apply (repository'', renames) <- doAdd repository' ps_to_unsuspend rNew <- unseal mkSuspended . unseal (simplifyPushes da (mapFL_FL NameFixup renames)) $ ps_to_keep repository''' <- tentativelyAddPatch repository'' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) finalizeRepositoryChanges repository''' YesUpdateWorking (compression opts) _ <- applyToWorking repository''' (verbosity opts) effect_to_apply `catch` \(e :: IOException) -> fail ("couldn't apply patch in working dir.\n" ++ show e) return () ) :: IO () where doAdd :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wT -> FL (WDDNamed p) wT wT2 -> IO (Repository (Rebasing p) wR wU wT2, FL (RebaseName p) wT2 wT2) doAdd repo NilFL = return (repo, NilFL) doAdd repo ((p :: WDDNamed p wT wU) :>:ps) = do case wddDependedOn p of [] -> return () deps -> 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 putStr $ "Warning: dropping the following explicit " ++ englishNum (length deps) (Noun "dependency") ":\n\n" let printIndented n = mapM_ (putStrLn . (replicate n ' '++)) . lines . renderString Encode . showPatchInfo putStrLn . renderString Encode . showPatchInfo . patch2patchinfo $ wddPatch p putStr " depended on:\n" mapM_ (printIndented 2) deps putStr "\n" -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord p' <- snd <$> updatePatchHeader False -- askDeps (patchSelOpts True opts) (parseFlags O.keepDate opts) (parseFlags O.selectAuthor opts) (parseFlags O.author opts) (parseFlags O.patchname opts) (parseFlags O.askLongComment opts) repo (n2pia (fmapNamed Normal (wddPatch p))) NilFL repo' <- tentativelyAddPatch repo (compression opts) (verbosity opts) YesUpdateWorking p' -- create a rename that undoes the change we just made, so the contexts match up let rename :: RebaseName p wU wU rename = Rename (info p') (patch2patchinfo (wddPatch p)) -- push it through the remaining patches to fix them up Just (ps2 :> (rename2 :: RebaseName p wV wT2)) <- return (commuterIdFL (commuterIdWDD commuteNameNamed) (rename :> ps)) -- assert that the rename still has a null effect on the context after commuting IsEq <- return (unsafeCoerceP IsEq :: EqCheck wV wT2) (repo'', renames) <- doAdd repo' ps2 -- return the renames so that the suspended patch can be fixed up return (repo'', rename2 :>: renames) injectBasicOpts :: DarcsOption a (Bool -> Maybe String -> O.DiffAlgorithm -> a) injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm injectOpts :: DarcsOption a (Bool -> Maybe String -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) injectOpts = injectBasicOpts `withStdOpts` oid inject :: DarcsCommand [DarcsFlag] inject = DarcsCommand { commandProgramName = "darcs" , commandName = "inject" , commandHelp = "Merge a change from the fixups of a patch into the patch itself.\n" , commandDescription = "Merge a change from the fixups of a patch into the patch itself." , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = injectCmd , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc injectBasicOpts , commandDefaults = defaultFlags injectOpts , commandCheckOptions = ocheck injectOpts , commandParseOptions = onormalise injectOpts } injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () injectCmd _ opts _args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \(repository :: Repository (Rebasing p) wR wU wR) -> do patches <- readRepo repository (rOld, Sealed ps, _) <- return $ takeHeadRebase patches let selects = toRebaseSelect ps -- TODO this selection doesn't need to respect dependencies -- TODO we only want to select one patch: generalise withSelectedPatchFromRepo let patches_context = selectionContextGeneric rsToPia First "inject into" (patchSelOpts True opts) Nothing (chosens :> rest_selects) <- runSelection (selectChanges selects) patches_context let extractSingle :: FL (RebaseSelect p) wX wY -> (FL (RebaseFixup p) :> Named p) wX wY extractSingle (RSFwd fixups toedit :>: NilFL) = fixups :> toedit extractSingle (_ :>: NilFL) = impossible extractSingle _ = error "You must select precisely one patch!" fixups :> toedit <- return $ extractSingle chosens name_fixups :> prim_fixups <- return $ flToNamesPrims fixups let changes_context = selectionContextPrim Last "inject" (patchSelOpts True opts) (Just primSplitter) Nothing Nothing (rest_fixups :> injects) <- runSelection (selectChanges prim_fixups) changes_context when (nullFL injects) $ do putStrLn "No changes selected!" exitSuccess -- Don't bother to update patch header since unsuspend will do that later let da = diffAlgorithm opts toeditNew = fmapFL_Named (mapFL_FL fromPrim . canonizeFL da . (injects +>+) . effect) toedit rNew <- unseal mkSuspended $ unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups)) $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups) $ ToEdit toeditNew :>: fromRebaseSelect rest_selects repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL) repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) finalizeRepositoryChanges repository'' YesUpdateWorking (compression opts) return () obliterateBasicOpts :: DarcsOption a (O.DiffAlgorithm -> a) obliterateBasicOpts = O.diffAlgorithm obliterateOpts :: DarcsOption a (O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) obliterateOpts = obliterateBasicOpts `withStdOpts` oid obliterate :: DarcsCommand [DarcsFlag] obliterate = DarcsCommand { commandProgramName = "darcs" , commandName = "obliterate" , commandHelp = "Obliterate a patch that is currently suspended.\n" , commandDescription = "Obliterate a patch that is currently suspended.\n" , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = obliterateCmd , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc obliterateBasicOpts , commandDefaults = defaultFlags obliterateOpts , commandCheckOptions = ocheck obliterateOpts , commandParseOptions = onormalise obliterateOpts } obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () obliterateCmd _ opts _args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \(repository :: Repository (Rebasing p) wR wU wR) -> (do patches <- readRepo repository (rOld, Sealed ps, _) <- return $ takeHeadRebase patches let selects = toRebaseSelect ps -- TODO this selection doesn't need to respect dependencies let patches_context = selectionContextGeneric rsToPia First "obliterate" (obliteratePatchSelOpts opts) Nothing (chosen :> keep) <- runSelection (selectChanges selects) patches_context when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess let da = diffAlgorithm opts do_obliterate :: FL (RebaseItem p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) do_obliterate NilFL = Sealed do_obliterate (Fixup f :>: qs) = unseal (simplifyPush da f) . do_obliterate qs do_obliterate (ToEdit e :>: qs) = -- 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 (effect (patchcontents e)))) . do_obliterate qs let ps_to_keep = do_obliterate (fromRebaseSelect chosen) (fromRebaseSelect keep) rNew <- unseal mkSuspended ps_to_keep repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL) repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) finalizeRepositoryChanges repository'' YesUpdateWorking (compression opts) return () ) :: IO () pullDescription :: String pullDescription = "Copy and apply patches from another repository, suspending any local patches that conflict." pullHelp :: String pullHelp = "Copy and apply patches from another repository, suspending any local patches that conflict." pullBasicOpts :: DarcsOption a ([O.MatchFlag] -> O.Reorder -> Maybe Bool -> Maybe O.AllowConflicts -> ExternalMerge -> O.RunTest -> O.DryRun -> O.XmlOutput -> Maybe O.Summary -> O.SelectDeps -> Maybe Bool -> Maybe String -> Bool -> O.DiffAlgorithm -> a) pullBasicOpts = O.matchSeveral ^ O.reorder ^ O.interactive ^ O.conflicts O.YesAllowConflictsAndMark ^ O.useExternalMerge ^ O.test ^ O.dryRunXml ^ O.summary ^ O.selectDeps ^ O.setDefault ^ O.workingRepoDir ^ O.allowUnrelatedRepos ^ O.diffAlgorithm pullAdvancedOpts :: DarcsOption a (O.RepoCombinator -> O.Compression -> O.UseIndex -> O.RemoteRepos -> O.SetScriptsExecutable -> O.UMask -> Bool -> Bool -> O.NetworkOptions -> a) pullAdvancedOpts = O.repoCombinator ^ O.compress ^ O.useIndex ^ O.remoteRepos ^ O.setScriptsExecutable ^ O.umask ^ O.restrictPaths ^ O.changesReverse ^ O.network pullOpts :: DarcsOption a ([O.MatchFlag] -> O.Reorder -> Maybe Bool -> Maybe O.AllowConflicts -> ExternalMerge -> O.RunTest -> O.DryRun -> O.XmlOutput -> Maybe O.Summary -> O.SelectDeps -> Maybe Bool -> Maybe String -> Bool -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.RepoCombinator -> O.Compression -> O.UseIndex -> O.RemoteRepos -> O.SetScriptsExecutable -> O.UMask -> Bool -> Bool -> O.NetworkOptions -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts pull :: DarcsCommand [DarcsFlag] pull = DarcsCommand { commandProgramName = "darcs" , commandName = "pull" , commandHelp = pullHelp , commandDescription = pullDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[REPOSITORY]..."] , commandCommand = pullCmd RebasePatchApplier , commandPrereq = amInHashedRepository , commandGetArgPossibilities = getPreflist "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc pullAdvancedOpts , commandBasicOptions = odesc pullBasicOpts , commandDefaults = defaultFlags pullOpts , commandCheckOptions = ocheck pullOpts , commandParseOptions = onormalise pullOpts } applyDescription :: String applyDescription = "Apply a patch bundle, suspending any local patches that conflict." applyHelp :: String applyHelp = "Apply a patch bundle, suspending any local patches that conflict." stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] stdindefault _ x = return x apply :: DarcsCommand [DarcsFlag] apply = DarcsCommand { commandProgramName = "darcs" , commandName = "apply" , commandHelp = applyHelp , commandDescription = applyDescription , commandExtraArgs = 1 , commandExtraArgHelp = [""] , commandCommand = applyCmd RebasePatchApplier , commandPrereq = amInHashedRepository , commandGetArgPossibilities = listFiles False , commandArgdefaults = const stdindefault , commandAdvancedOptions = odesc applyAdvancedOpts , commandBasicOptions = odesc applyBasicOpts , commandDefaults = defaultFlags applyOpts , commandCheckOptions = ocheck applyOpts , commandParseOptions = onormalise applyOpts } applyBasicOpts :: DarcsOption a (O.Verify -> O.Reorder -> Maybe Bool -> O.DryRun -> O.XmlOutput -> [O.MatchFlag] -> Maybe String -> O.DiffAlgorithm -> a) applyBasicOpts = O.verify ^ O.reorder ^ O.interactive ^ O.dryRunXml ^ O.matchSeveral ^ O.workingRepoDir ^ O.diffAlgorithm applyAdvancedOpts :: DarcsOption a (Maybe String -> Maybe String -> Bool -> (Bool, Maybe String) -> O.UseIndex -> O.Compression -> O.SetScriptsExecutable -> O.UMask -> Bool -> Bool -> O.WantGuiPause -> a) applyAdvancedOpts = O.reply ^ O.ccApply ^ O.happyForwarding ^ O.sendmail ^ O.useIndex ^ O.compress ^ O.setScriptsExecutable ^ O.umask ^ O.restrictPaths ^ O.changesReverse ^ O.pauseForGui applyOpts :: DarcsOption a (O.Verify -> O.Reorder -> Maybe Bool -> O.DryRun -> O.XmlOutput -> [O.MatchFlag] -> Maybe String -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> Maybe String -> Maybe String -> Bool -> (Bool, Maybe String) -> O.UseIndex -> O.Compression -> O.SetScriptsExecutable -> O.UMask -> Bool -> Bool -> O.WantGuiPause -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts data RebasePatchApplier = RebasePatchApplier instance PatchApplier RebasePatchApplier where type CarrierType RebasePatchApplier p = Rebasing p repoJob RebasePatchApplier opts f = StartRebaseJob (compression opts) (verbosity opts) YesUpdateWorking (f PatchProxy) applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd applyPatchesForRebaseCmd :: forall p wR wU wX wT wZ . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => String -> [DarcsFlag] -> String -> Repository (Rebasing p) wR wU wT -> FL (PatchInfoAnd (Rebasing p)) wX wT -> FL (PatchInfoAnd (Rebasing p)) wX wZ -> IO () applyPatchesForRebaseCmd cmdName opts _from_whom repository us' to_be_applied = do printDryRunMessageAndExit cmdName (verbosity opts) (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput opts) (isInteractive True opts) to_be_applied setEnvDarcsPatches to_be_applied when (nullFL to_be_applied) $ do putStrLn $ "You don't want to " ++ cmdName ++ " any patches, and that's fine with me!" exitSuccess checkPaths opts to_be_applied putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:" putVerbose opts $ vcat $ mapFL description to_be_applied usOk :> usConflicted <- return $ partitionConflictingFL (commuterIdFL selfCommuter) 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 patches_context = selectionContext LastReversed "suspend" applyPatchSelOpts Nothing Nothing (usKeep :> usToSuspend) <- runSelection (selectChanges usConflicted) patches_context (rOld, Sealed qs, _) <- return $ takeHeadRebaseFL us' repository' <- doSuspend opts repository qs rOld usToSuspend -- TODO This is a nasty hack, caused by the fact that readUnrecorded -- claims to read the tentative state but actual reads the committed state -- as a result we have to commit here so that tentativelyMergePatches does -- the right thing. finalizeRepositoryChanges repository' YesUpdateWorking (compression opts) >> revertRepositoryChanges repository' YesUpdateWorking Sealed pw <- tentativelyMergePatches repository' cmdName (allowConflicts opts) YesUpdateWorking (externalMerge opts) (wantGuiPause opts) (compression opts) (verbosity opts) (reorder opts) (diffingOpts opts) (usOk +>+ usKeep) to_be_applied invalidateIndex repository finalizeRepositoryChanges repository' YesUpdateWorking (compression opts) _ <- revertable $ applyToWorking repository' (verbosity opts) pw when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches pw putInfo opts $ text $ "Finished " ++ cmdName ++ "ing." -- TODO I doubt this is right, e.g. withContext should be inherited applyPatchSelOpts :: S.PatchSelectionOptions applyPatchSelOpts = S.PatchSelectionOptions { S.verbosity = O.NormalVerbosity , S.matchFlags = [] , S.diffAlgorithm = O.PatienceDiff , S.interactive = True , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary , S.withContext = O.NoContext } 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 = parseFlags O.matchSeveralOrLast flags , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive defInteractive flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = O.NoContext } log :: DarcsCommand [DarcsFlag] log = DarcsCommand { commandProgramName = "darcs" , commandName = "log" , commandHelp = "List the currently suspended changes.\n" , commandDescription = "List the currently suspended changes" , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = logCmd , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc logAdvancedOpts , commandBasicOptions = odesc logBasicOpts , commandDefaults = defaultFlags logOpts , commandCheckOptions = ocheck logOpts , commandParseOptions = onormalise logOpts } logBasicOpts :: DarcsOption a (Maybe O.Summary -> Maybe Bool -> a) logBasicOpts = O.summary ^ O.interactive -- False logAdvancedOpts :: DarcsOption a a logAdvancedOpts = oid logOpts :: DarcsOption a (Maybe O.Summary -> Maybe Bool -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) logOpts = logBasicOpts `withStdOpts` logAdvancedOpts logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () logCmd _ opts _files = withRepository (useCache opts) $ RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \repository -> do patches <- readRepo repository (_, Sealed ps, _) <- return $ takeHeadRebase patches let psToShow = toRebaseChanges ps if isInteractive False opts then viewChanges (patchSelOpts False opts) (mapFL Sealed2 psToShow) else do debugMessage "About to print the changes..." let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters emptyPatchSet = PatchSet NilRL NilRL patchSet = appendPSFL emptyPatchSet psToShow logInfo <- getLogInfo (maxCount opts) (toMatchFlags opts) (showChangesOnlyToFiles opts) Nothing (\_ qs -> return qs) patchSet let logDoc = changelog opts patchSet logInfo putDocLnWith printers logDoc -- | changes is an alias for log changes :: DarcsCommand [DarcsFlag] changes = commandAlias "changes" Nothing log {- TODO: - amend-record shows the diff between the conflicted state and the resolution, which is unhelpful - testing - make aggregate commands - argument handling - what should happen to patch comment on unsuspend? - don't just drop explicit dependencies: - turn patchnames/explicit deps into patch type and use commutation - repo representation - seem to be able to get a messed up unrevert context - darcs pull/get can setup a rebase patch in a remote repo without the right format - rebase patches seem to parse as empty rather than failing?? - warn about suspending conflicts - indication of expected conflicts on unsuspend - why isn't ! when you do x accurate? - rebase obliterate for more efficient removing of suspended patches - rebase pull needs more UI work - automatically answer yes re suspension - offer all patches (so they can be kept in order) - or perhaps rebase suspend --complement? - rebase changes for viewing suspended patch - matching options for rebase unsuspend (etc) - make unsuspend actually display the patch helpfully like normal selection - 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 - warning message on suspend about not being able to unsuspend with unrecorded changes - aborting during a rebase pull or rebase suspend causes it to leave the repo marked for rebase - rebase suspend needs --match - patch count: get English right in suspended patch(es) - darcs check should check integrity of rebase patch - review existence of reify and inject commands - bit of an internals hack - need to move rebase to front before adding amend-record hint (and test this) - print something while moving rebase to front -} darcs-2.10.2/src/Darcs/UI/Commands/Tag.hs0000644000175000017500000002330012620122474021670 0ustar00guillaumeguillaume00000000000000-- 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, getTags ) where import Prelude hiding ( (^) ) import Control.Applicative ( (<$>) ) import Control.Monad ( when ) import Data.Maybe ( catMaybes ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Commands.Record ( getLog ) import Darcs.UI.Flags ( DarcsFlag(AskDeps), getDate, compression, verbosity, useCache, umask, getAuthor , hasAuthor, diffAlgorithm ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully ) import Darcs.Repository ( withRepoLock, Repository, RepoJob(..), readRepo, tentativelyAddPatch, finalizeRepositoryChanges, ) import Darcs.Patch ( infopatch, adddeps, Patchy, PrimPatch, PrimOf , RepoPatch ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Info ( patchinfo, piTag ) import Darcs.Patch.Depends ( getUncovered ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) import Darcs.Patch.MaybeInternal ( MaybeInternal(patchInternalChecker), InternalChecker(..) ) import Darcs.Patch.Named ( patchcontents ) import Darcs.Patch.Set ( PatchSet(..), emptyPatchSet, appendPSFL, newset2FL ) import Darcs.Patch.Witnesses.Ordered ( FL(..), filterOutRLRL, (:>)(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(..) , selectionContext , runSelection , PatchSelectionContext(allowSkipAll) ) import qualified Darcs.UI.SelectChanges as S import Darcs.Repository.Util ( patchSetfMap ) import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) ) import Darcs.Util.Path ( AbsolutePath ) import Storage.Hashed.Tree( Tree ) import System.IO ( hPutStr, stderr ) 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 .\n" ++ "\n" ++ "To reproduce the state of a repository `R` as at tag `t`, use the\n" ++ "command `darcs clone --tag t R`. The command `darcs show tags` lists\n" ++ "all tags in the current repository.\n" ++ "\n" ++ "Tagging also provides significant performance benefits: when Darcs\n" ++ "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" ++ "By default a tag names the entire repository state at the time the tag\n" ++ "is created. If the --ask-deps option is used, the patches to include\n" ++ "as part of the tag can be explicitly selected.\n" ++ "\n" ++ "The `darcs tag` command accepts the `--pipe` option, which behaves as\n" ++ "described in `darcs record`.\n" tagBasicOpts :: DarcsOption a (Maybe String -> Maybe String -> Bool -> Maybe O.AskLongComment -> Bool -> Maybe String -> a) tagBasicOpts = O.patchname ^ O.author ^ O.pipe ^ O.askLongComment ^ O.askdeps ^ O.workingRepoDir tagAdvancedOpts :: DarcsOption a (O.Compression -> O.UMask -> a) tagAdvancedOpts = O.compress ^ O.umask tagOpts :: DarcsOption a (Maybe String -> Maybe String -> Bool -> Maybe O.AskLongComment -> Bool -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.Compression -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) tagOpts = tagBasicOpts `withStdOpts` tagAdvancedOpts tag :: DarcsCommand [DarcsFlag] tag = DarcsCommand { commandProgramName = "darcs" , commandName = "tag" , commandHelp = tagHelp , commandDescription = tagDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[TAGNAME]"] , commandCommand = tagCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc tagAdvancedOpts , commandBasicOptions = odesc tagBasicOpts , commandDefaults = defaultFlags tagOpts , commandCheckOptions = ocheck tagOpts , commandParseOptions = onormalise tagOpts } filterNonInternal :: MaybeInternal p => PatchSet p wX wY -> PatchSet p wX wY filterNonInternal = case patchInternalChecker of Nothing -> id Just f -> \(PatchSet ps ts) -> PatchSet (filterOutRLRL (isInternal f . patchcontents . hopefully) ps) ts tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () tagCmd _ opts args = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do date <- getDate (hasPipe opts) the_author <- getAuthor (hasAuthor opts) (hasPipe opts) patches <- readRepo repository tags <- getTags patches let nonInternalPatches = filterNonInternal patches Sealed chosenPatches <- if AskDeps `elem` opts then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (newset2FL nonInternalPatches) else return $ Sealed nonInternalPatches let deps = getUncovered chosenPatches (name, long_comment) <- get_name_log (NilFL :: FL (PrimOf p) wA wA) args tags myinfo <- patchinfo date name the_author long_comment let mypatch = infopatch myinfo NilFL _ <- tentativelyAddPatch repository (compression opts) (verbosity opts) YesUpdateWorking $ n2pia $ adddeps mypatch deps finalizeRepositoryChanges repository YesUpdateWorking (compression opts) putStrLn $ "Finished tagging patch '"++name++"'" where get_name_log ::(Patchy prim, PrimPatch prim) => FL prim wA wA -> [String] -> [String] -> IO (String, [String]) get_name_log nilFL a tags = do (name, comment, _) <- getLog (case parseFlags O.patchname opts of Nothing -> Just (unwords a) Just s -> Just s) (hasPipe opts) (parseFlags O.logfile opts) (parseFlags O.askLongComment opts) Nothing nilFL 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) getTags :: MaybeInternal p => PatchSet p wW wR -> IO [String] getTags ps = catMaybes `fmap` patchSetfMap (return . piTag . info) ps -- 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. 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.diffAlgorithm = diffAlgorithm flags , S.interactive = True , S.selectDeps = O.PromptDeps , S.summary = O.NoSummary , S.withContext = O.NoContext } (deps:>_) <- runSelection (selectChanges ps) $ ((selectionContext FirstReversed "depend on" opts Nothing Nothing) { allowSkipAll = False }) return $ Sealed deps hasPipe :: [DarcsFlag] -> Bool hasPipe = parseFlags O.pipe darcs-2.10.2/src/Darcs/UI/Commands/Annotate.hs0000644000175000017500000002260012620122474022730 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.UI.Commands.Annotate ( annotate ) where import Prelude hiding ( (^) ) import Control.Arrow ( first ) import Control.Monad ( unless ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag(NoPatchIndexFlag), isUnified, useCache, fixSubPaths, hasSummary, umask ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Storage.Hashed.Plain( readPlainTree ) import Darcs.Repository.State ( readRecorded ) import Darcs.Repository ( withRepository , withRepoLockCanFail , RepoJob(..) , readRepo , repoPatchType , listRegisteredFiles ) import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex ) import Darcs.Patch.Set ( newset2RL ) import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, invertRL ) import qualified Darcs.Patch ( summary ) import Darcs.Patch.Type ( PatchType(..) ) import Darcs.Patch.Dummy ( DummyPatch ) import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate ) import Data.ByteString.Lazy ( toChunks ) import Darcs.UI.PrintPatch ( printPatch, contextualPrintPatch ) import Darcs.Patch.ApplyMonad( withFileNames ) import System.FilePath.Posix ( () ) import Darcs.Patch.Info ( showPatchInfoUI, showPatchInfo ) import Darcs.Patch.Match ( matchPatch, haveNonrangeMatch, getNonrangeMatchS ) import Darcs.Repository.Match ( getFirstMatch, getOnePatchset ) import Darcs.Repository.Lock ( withTempDir ) import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal ) import qualified Darcs.Patch.Annotate as A import Darcs.Util.Printer ( putDocLn, Doc ) import Storage.Hashed.Tree( TreeItem(..), readBlob, list, expand ) import Storage.Hashed.Monad( findM, virtualTreeIO ) import Darcs.Util.Path( floatPath, anchorPath, fp2fn, toFilePath , AbsolutePath ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) #include "impossible.h" annotateDescription :: String annotateDescription = "Display which patch last modified something." annotateHelp :: String annotateHelp = unlines [ "The `darcs annotate` command provides two unrelated operations. When" , "called on a file, it will find the patch that last modified each line" , "in that file. When called on a patch (e.g. using `--patch`), it will" , "print the internal representation of that patch." , "" , "The `--summary` option will result in a summarized patch annotation," , "similar to `darcs whatsnew`. It has no effect on file annotations." , "" , "By default, output is in a human-readable format. The `--machine-readable`" , "option can be used to generate output for machine postprocessing." ] annotateBasicOpts :: DarcsOption a (Maybe O.Summary -> O.WithContext -> Bool -> [O.MatchFlag] -> Maybe String -> a) annotateBasicOpts = O.summary ^ O.withContext ^ O.machineReadable ^ O.matchOne ^ O.workingRepoDir annotateAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a) annotateAdvancedOpts = O.patchIndexYes annotateOpts :: DarcsOption a (Maybe O.Summary -> O.WithContext -> Bool -> [O.MatchFlag] -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.WithPatchIndex -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) annotateOpts = annotateBasicOpts `withStdOpts` annotateAdvancedOpts annotate :: DarcsCommand [DarcsFlag] 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 = odesc annotateAdvancedOpts , commandBasicOptions = odesc annotateBasicOpts , commandDefaults = defaultFlags annotateOpts , commandCheckOptions = ocheck annotateOpts , commandParseOptions = onormalise annotateOpts } annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () annotateCmd fps opts [""] = annotate' fps opts [] -- when does that happen? annotateCmd fps opts [] = do let matchFlags = parseFlags O.matchOne opts unless (haveNonrangeMatch (PatchType :: PatchType DummyPatch) matchFlags) $ fail $ "Annotate requires either a patch pattern or a " ++ "file or directory argument." annotate' fps opts [] annotateCmd fps opts args = annotate' fps opts args annotate' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () annotate' _ opts [] = -- annotating a patch (ie, showing its contents) withRepository (useCache opts) $ RepoJob $ \repository -> do let matchFlags = parseFlags O.matchOne opts Sealed2 p <- matchPatch matchFlags `fmap` readRepo repository if hasSummary O.NoSummary opts == O.YesSummary then do putDocLn $ showpi $ patch2patchinfo p putDocLn $ show_summary p else if isUnified opts == O.YesContext then withTempDir "context" $ \_ -> do getFirstMatch repository matchFlags c <- readPlainTree "." contextualPrintPatch c p else printPatch p where showpi | parseFlags O.machineReadable opts = showPatchInfo | otherwise = showPatchInfoUI show_summary :: RepoPatch p => Named p wX wY -> Doc show_summary = Darcs.Patch.summary annotate' fps opts args@[_] = do -- annotating a file or a directory unless (NoPatchIndexFlag `elem` opts) $ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts) $ RepoJob attemptCreatePatchIndex withRepository (useCache opts) $ RepoJob $ \repository -> do let matchFlags = parseFlags O.matchOne opts r <- readRepo repository (origpath:_) <- fixSubPaths fps args recorded <- readRecorded repository (patches, initial, path') <- if haveNonrangeMatch (repoPatchType repository) matchFlags then do Sealed x <- getOnePatchset repository matchFlags let fn = [fp2fn $ toFilePath origpath] nonRangeMatch = getNonrangeMatchS matchFlags r (_, [path], _) = withFileNames Nothing fn nonRangeMatch initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS matchFlags r) recorded return (seal $ newset2RL x, initial, toFilePath path) else return (seal $ newset2RL r, recorded, toFilePath origpath) let path = "./" ++ path' found <- findM initial (floatPath $ toFilePath path) -- TODO need to decide about the --machine flag let fmt = if parseFlags O.machineReadable 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), "/"] (Sealed ans_patches) <- do upi <- canUsePatchIndex repository if not upi then return patches else getRelevantSubsequence patches repository subs putStrLn $ fmt (BC.intercalate "\n" $ map (showPath . first (anchorPath "")) $ list s') $ A.annotateDirectory D.MyersDiff (invertRL ans_patches) (fp2fn path) subs Just (File b) -> do (Sealed ans_patches) <- do upi <- canUsePatchIndex repository if not upi then return patches else getRelevantSubsequence patches repository [fp2fn path] con <- BC.concat `fmap` toChunks `fmap` readBlob b putStrLn $ fmt con $ A.annotate D.MyersDiff (invertRL ans_patches) (fp2fn path) con Just (Stub _ _) -> impossible annotate' _ _ _ = fail "annotate accepts at most one argument" darcs-2.10.2/src/Darcs/UI/Commands/ShowIndex.hs0000644000175000017500000001201512620122474023066 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.UI.Commands.ShowIndex ( showIndex , showPristineCmd -- for alias ) where import Control.Applicative ( (<$>) ) import Control.Monad ( (>=>) ) import Darcs.UI.Flags ( DarcsFlag(NullFlag), useCache ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Prelude hiding ( (^) ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository ( 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, listFileIDs ) import Darcs.Util.Path( anchorPath, AbsolutePath ) import System.Posix.Types ( FileID ) import qualified Data.ByteString.Char8 as BS import Data.Maybe ( fromJust ) import qualified Data.Map as M ( Map, lookup, fromList ) showIndexBasicOpts :: DarcsOption a (Bool -> Bool -> Bool -> Maybe String -> a) showIndexBasicOpts = O.files ^ O.directories ^ O.nullFlag ^ O.workingRepoDir showIndexOpts :: DarcsOption a (Bool -> Bool -> Bool -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) showIndexOpts = showIndexBasicOpts `withStdOpts` oid showIndex :: DarcsCommand [DarcsFlag] 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 = odesc showIndexBasicOpts, commandDefaults = defaultFlags showIndexOpts, commandCheckOptions = ocheck showIndexOpts, commandParseOptions = onormalise showIndexOpts } dump :: [DarcsFlag] -> Maybe (M.Map FilePath FileID) -> Tree IO -> IO () dump opts fileids 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 _ -> "/" _ -> "" fileid = case fileids of Nothing -> "" Just fileids' -> " " ++ (show $ fromJust $ M.lookup path fileids') line $ hash ++ fileid ++ " " ++ path ++ isdir x <- expand tree mapM_ output $ (floatPath ".", SubTree x) : list x showIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showIndexCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \repo -> do index <- readIndex repo index_tree <- updateIndex index fileids <- (M.fromList . map (\((a,_),b) -> (anchorPath "" a,b))) <$> listFileIDs index dump opts (Just fileids) index_tree showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showPristineCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ readRecorded >=> dump opts Nothing darcs-2.10.2/src/Darcs/UI/Commands/Dist.hs0000644000175000017500000002157312620122474022072 0ustar00guillaumeguillaume00000000000000-- 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 Prelude hiding ( (^), writeFile ) import Data.ByteString.Lazy ( writeFile ) import Data.Char ( isAlphaNum ) import Control.Monad ( when ) import System.Directory ( setCurrentDirectory ) import System.Process ( system ) import System.Exit ( ExitCode(..), exitWith ) import System.FilePath.Posix ( takeFileName, () ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Codec.Archive.Tar ( pack, write ) import Codec.Archive.Tar.Entry ( entryPath ) import Codec.Compression.GZip ( compress ) import Codec.Archive.Zip ( emptyArchive, fromArchive, addEntryToArchive, toEntry ) import Darcs.Repository.External ( fetchFilePS, Cachable( Uncachable ) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Repository.HashedRepo ( inv2pris ) import Darcs.Repository.HashedIO ( pathsAndContents ) import Darcs.Repository.InternalTypes ( Repository (..) ) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B import Darcs.UI.Flags ( DarcsFlag(Verbose, Quiet, DistName, DistZip, SetScriptsExecutable), useCache ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.Repository.Lock ( withTempDir ) import Darcs.Patch.Match ( haveNonrangeMatch , firstMatch ) import Darcs.Repository.Match ( getFirstMatch , getNonrangeMatch ) import Darcs.Repository ( withRepository, withRepositoryDirectory, RepoJob(..), setScriptsExecutable, repoPatchType, createPartialsPristineDirectoryTree ) import Darcs.Repository.Prefs ( getPrefval ) import Darcs.Util.DateTime ( getCurrentTime, toSeconds ) import Darcs.Util.Path ( AbsolutePath, toFilePath ) import Darcs.Util.File ( withCurrentDirectory ) distDescription :: String distDescription = "Create a distribution archive." distHelp :: String distHelp = 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." ] distBasicOpts :: DarcsOption a (Maybe String -> Bool -> Maybe String -> [O.MatchFlag] -> O.SetScriptsExecutable -> Bool -> a) distBasicOpts = O.distname ^ O.distzip ^ O.workingRepoDir ^ O.matchOne ^ O.setScriptsExecutable ^ O.storeInMemory distOpts :: DarcsOption a (Maybe String -> Bool -> Maybe String -> [O.MatchFlag] -> O.SetScriptsExecutable -> Bool -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) distOpts = distBasicOpts `withStdOpts` oid dist :: DarcsCommand [DarcsFlag] dist = DarcsCommand { commandProgramName = "darcs" , commandName = "dist" , commandHelp = distHelp , commandDescription = distDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = distCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc distBasicOpts , commandDefaults = defaultFlags distOpts , commandCheckOptions = ocheck distOpts , commandParseOptions = onormalise distOpts } distCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () distCmd _ opts _ | DistZip `elem` opts = doFastZip opts distCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \repository -> do let matchFlags = parseFlags O.matchOne opts 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 (repoPatchType repository) matchFlags then if firstMatch matchFlags then withCurrentDirectory ddir $ getFirstMatch repository matchFlags else withCurrentDirectory ddir $ getNonrangeMatch repository matchFlags 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 doFastZip :: [DarcsFlag] -> IO () doFastZip opts = do currentdir <- getCurrentDirectory let distname = getDistName currentdir [x | DistName x <- opts] let resultfile = currentdir distname ++ ".zip" doFastZip' opts currentdir (writeFile resultfile) when (Quiet `notElem` opts) $ putStrLn $ "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 = withRepositoryDirectory (useCache opts) path $ RepoJob $ \(Repo _ _ _ c) -> do when (SetScriptsExecutable `elem` opts) $ putStrLn "WARNING: Zip archives cannot store executable flag." let distname = getDistName path [x | DistName x <- opts] i <- fetchFilePS (path darcsdir "hashed_inventory") Uncachable pristine <- pathsAndContents (distname ++ "/") c (inv2pris i) epochtime <- toSeconds `fmap` getCurrentTime let entries = [ toEntry filepath epochtime (toLazy contents) | (filepath,contents) <- pristine ] let archive = foldr addEntryToArchive emptyArchive entries act (fromArchive archive) toLazy :: B.ByteString -> BL.ByteString toLazy bs = BL.fromChunks [bs] darcs-2.10.2/src/Darcs/UI/Commands/Convert.hs0000644000175000017500000012440212620122474022602 0ustar00guillaumeguillaume00000000000000-- 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 CPP, MagicHash, OverloadedStrings, DeriveDataTypeable #-} module Darcs.UI.Commands.Convert ( convert ) where import Prelude hiding ( (^), readFile, log, lex ) import System.FilePath.Posix ( () ) import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, createDirectory, removeFile ) import System.IO ( stdin ) import Data.IORef ( newIORef, modifyIORef, readIORef ) import Data.Char ( isSpace ) import Control.Monad ( when, unless, void, forM_ ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State.Strict ( gets, modify ) import Control.Exception ( finally ) import Control.Applicative ( (<|>) ) import GHC.Base ( unsafeCoerce# ) import System.Time ( toClockTime ) import Data.Maybe ( catMaybes, fromMaybe ) import qualified Data.IntMap as M 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.ByteString.Lazy.UTF8 as BLU import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Attoparsec.ByteString.Char8( () ) import qualified Storage.Hashed.Tree as T import qualified Storage.Hashed.Monad as TM import Storage.Hashed.Monad hiding ( createDirectory, exists, rename ) import Storage.Hashed.Darcs ( hashedTreeIO, darcsAddMissingHashes ) import Storage.Hashed.Tree( Tree, treeHash, readBlob, TreeItem(..) , emptyTree, listImmediate, findTree ) import Storage.Hashed.AnchoredPath( anchorPath, appendPath, floatPath , AnchoredPath(..), Name(..) ) import Storage.Hashed.Hash( encodeBase16, sha256, Hash(..) ) import Darcs.Util.DateTime ( formatDateTime, fromClockTime, parseDateTime, startOfTime ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath, AbsolutePath ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Prompt ( askUser ) import Darcs.Util.Printer ( text, ($$) ) import Darcs.Util.Printer.Color ( traceDoc ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Patch.Depends ( getUncovered ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info, hopefully ) import Darcs.Patch ( Named, showPatch, patch2patchinfo, fromPrim, fromPrims, infopatch, adddeps, getdeps, effect, patchcontents, RepoPatch, apply, listTouchedFiles ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=/\=) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapFL_FL, concatFL, mapRL, nullFL, (+>+) ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed(..), unFreeLeft , flipSeal, unsafeUnsealFlipped ) import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo, patchinfo, piName, piLog, piDate, piAuthor, makePatchname ) 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 ( sortCoalesceFL ) import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL, newset2FL ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Repository.Flags ( UpdateWorking(..), Reorder (..), UseIndex(..), ScanKnown(..) , AllowConflicts(..), ExternalMerge(..), WantGuiPause(..) , Compression(..), DryRun(NoDryRun), DiffAlgorithm(MyersDiff, PatienceDiff) ) import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withRepositoryDirectory, createRepository, invalidateIndex, tentativelyMergePatches, patchSetToPatches, createPristineDirectoryTree, revertRepositoryChanges, finalizeRepositoryChanges, applyToWorking , readRepo, readTentativeRepo, cleanRepository ) import qualified Darcs.Repository as R( setScriptsExecutable ) import Darcs.Repository.State( readRecorded ) import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) import Darcs.Repository.InternalTypes ( extractCache ) import Darcs.Repository.HashedRepo ( readHashedPristineRoot, addToTentativeInventory ) import Darcs.Repository.HashedIO ( cleanHashdir ) import Darcs.Repository.Prefs( FileType(..) ) import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2)) import Darcs.Repository.Motd ( showMotd ) import Darcs.Repository.Lock ( writeBinFile ) import Darcs.Repository.External ( fetchFilePS, Cachable(Uncachable) ) import Darcs.Repository.Diff( treeDiff ) import Darcs.UI.External ( catchall ) import Darcs.UI.Flags ( verbosity, useCache, umask, withWorkingDir, runPatchIndex , DarcsFlag ( NewRepo ) , getRepourl, patchFormat ) import Darcs.UI.Commands ( DarcsCommand(..), amInRepository, nodefaults, putInfo , normalCommand, withStdOpts ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O #include "impossible.h" convertDescription :: String convertDescription = "Convert repositories between various formats." convertHelp :: String convertHelp = unlines [ "This command converts a repository that uses the old patch semantics" , "`darcs-1` to a new repository with current `darcs-2` semantics." , "" , convertHelp' ] -- | 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' = 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." , "" , "Furthermore, repositories created by different invocations of" , "this command SHOULD NOT exchange patches." ] convertExportHelp :: String convertExportHelp = 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 ." ] convertImportHelp :: String convertImportHelp = 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) | 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." ] convert :: DarcsCommand [DarcsFlag] convert = SuperCommand { commandProgramName = "darcs" , commandName = "convert" , commandHelp = "" , commandDescription = convertDescription , commandPrereq = amInRepository , commandSubCommands = [ normalCommand convertDarcs2, normalCommand convertExport, normalCommand convertImport ] } convertDarcs2BasicOpts :: DarcsOption a (Maybe String -> O.SetScriptsExecutable -> O.WithWorkingDir -> a) convertDarcs2BasicOpts = O.reponame ^ O.setScriptsExecutable ^ O.useWorkingDir convertDarcs2AdvancedOpts :: DarcsOption a (O.NetworkOptions -> O.WithPatchIndex -> a) convertDarcs2AdvancedOpts = O.network ^ O.patchIndex convertDarcs2Opts :: DarcsOption a (Maybe String -> O.SetScriptsExecutable -> O.WithWorkingDir -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.NetworkOptions -> O.WithPatchIndex -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) convertDarcs2Opts = convertDarcs2BasicOpts `withStdOpts` convertDarcs2AdvancedOpts convertDarcs2SilentOpts :: DarcsOption a (O.PatchFormat -> a) convertDarcs2SilentOpts = O.patchFormat convertDarcs2 :: DarcsCommand [DarcsFlag] convertDarcs2 = DarcsCommand { commandProgramName = "darcs" , commandName = "darcs-2" , commandHelp = convertHelp , commandDescription = "Convert darcs-1 repository to the darcs-2 patch format" , commandExtraArgs = -1 , commandExtraArgHelp = ["", "[]"] , commandCommand = toDarcs2 , commandPrereq = \_ -> return $ Right () , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc convertDarcs2AdvancedOpts , commandBasicOptions = odesc convertDarcs2BasicOpts , commandDefaults = defaultFlags (convertDarcs2Opts ^ convertDarcs2SilentOpts) , commandCheckOptions = ocheck convertDarcs2Opts , commandParseOptions = onormalise convertDarcs2Opts } convertExportBasicOpts :: DarcsOption a (Maybe String -> Maybe String -> Maybe String -> a) convertExportBasicOpts = O.reponame ^ O.marks convertExportAdvancedOpts :: DarcsOption a (O.NetworkOptions -> a) convertExportAdvancedOpts = O.network convertExportOpts :: DarcsOption a (Maybe String -> Maybe String -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.NetworkOptions -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) convertExportOpts = convertExportBasicOpts `withStdOpts` convertExportAdvancedOpts convertExport :: DarcsCommand [DarcsFlag] 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 , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc convertExportAdvancedOpts , commandBasicOptions = odesc convertExportBasicOpts , commandDefaults = defaultFlags convertExportOpts , commandCheckOptions = ocheck convertExportOpts , commandParseOptions = onormalise convertExportOpts } convertImportBasicOpts :: DarcsOption a (Maybe String -> O.SetScriptsExecutable -> O.PatchFormat -> O.WithWorkingDir -> a) convertImportBasicOpts = O.reponame ^ O.setScriptsExecutable ^ O.patchFormat ^ O.useWorkingDir convertImportAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a) convertImportAdvancedOpts = O.patchIndex convertImportOpts :: DarcsOption a (Maybe String -> O.SetScriptsExecutable -> O.PatchFormat -> O.WithWorkingDir -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.WithPatchIndex -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) convertImportOpts = convertImportBasicOpts `withStdOpts` convertImportAdvancedOpts convertImport :: DarcsCommand [DarcsFlag] convertImport = DarcsCommand { commandProgramName = "darcs" , commandName = "import" , commandHelp = convertImportHelp , commandDescription = "Import from a git-fast-export stream into darcs" , commandExtraArgs = -1 , commandExtraArgHelp = ["[]"] , commandCommand = fastImport , commandPrereq = \_ -> return $ Right () , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc convertImportAdvancedOpts , commandBasicOptions = odesc convertImportBasicOpts , commandDefaults = defaultFlags convertImportOpts , commandCheckOptions = ocheck convertImportOpts , commandParseOptions = onormalise convertImportOpts } toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () toDarcs2 fps opts [inrepodir, outname] = toDarcs2 fps (NewRepo outname:opts) [inrepodir] toDarcs2 _ 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." unless (parseFlags O.verbosity opts == O.Quiet) $ showMotd repodir mysimplename <- makeRepoName opts repodir createDirectory mysimplename setCurrentDirectory mysimplename createRepository False (withWorkingDir opts) (runPatchIndex opts) writeBinFile (darcsdir++"/hashed_inventory") "" withRepoLock NoDryRun (useCache opts) NoUpdateWorking (umask opts) $ V2Job $ \repository -> withRepositoryDirectory (useCache opts) repodir $ V1Job $ \themrepo -> do theirstuff <- readRepo themrepo let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff outOfOrderTags = catMaybes $ mapRL oot $ newset2RL 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] convertOne :: Patch Prim wX wY -> FL (RealPatch Prim) wX wY 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) wX wY -> FL (RealPatch Prim) wX wY convertFL = concatFL . mapFL_FL convertOne convertNamed :: Named (Patch Prim) wX wY -> PatchInfoAnd (RealPatch Prim) wX wY convertNamed n = n2pia $ adddeps (infopatch (convertInfo $ patch2patchinfo n) $ convertFL $ patchcontents n) (map convertInfo $ concatMap fixDep $ getdeps n) convertInfo n | n `elem` inOrderTags theirstuff = 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) wA wB wA Sealed pw <- tentativelyMergePatches repository2 "convert" YesAllowConflicts NoUpdateWorking NoExternalMerge NoWantGuiPause GzipCompression (verbosity opts) NoReorder (UseIndex, ScanKnown, MyersDiff) NilFL xs finalizeRepositoryChanges repository2 NoUpdateWorking GzipCompression -- this is to clean out pristine.hashed revertRepositoryChanges repository2 NoUpdateWorking _ <- revertable $ applyToWorking repository2 (verbosity opts) pw invalidateIndex repository2 sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches invalidateIndex repository revertable $ createPristineDirectoryTree repository "." (withWorkingDir opts) when (parseFlags O.setScriptsExecutable opts == O.YesSetScriptsExecutable) R.setScriptsExecutable -- Copy over the prefs file let prefsRelPath = darcsdir "prefs" "prefs" (fetchFilePS (repodir prefsRelPath) Uncachable >>= B.writeFile prefsRelPath) `catchall` return () 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."] toDarcs2 _ _ _ = fail "You must provide 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 fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fastExport _ opts _ = do let repodir = fromMaybe "." $ getRepourl opts marks <- case parseFlags O.readMarks opts of Nothing -> return emptyMarks Just f -> readMarks f newMarks <- withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> fastExport' repo marks case parseFlags O.writeMarks opts of Nothing -> return () Just f -> writeMarks f newMarks fastExport' :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u r -> Marks -> IO Marks fastExport' repo marks = do putStrLn "progress (reading repository)" patchset <- readRepo repo marksref <- newIORef marks let patches = newset2FL 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 $ darcsdir "pristine.hashed" let patches'' = unsafeUnsealFlipped patches' void $ hashedTreeIO (dumpPatches tags mark n patches'') tree' $ darcsdir "pristine.hashed" readIORef marksref `finally` do putStrLn "progress (cleaning up)" current <- readHashedPristineRoot repo cleanHashdir (extractCache repo) HashedPristineDir $ catMaybes [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 $ map floatPath $ 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 isfile <- fileExists file isdir <- directoryExists file when isfile $ do bits <- readFile file dumpBits [ BLU.fromString $ "M 100644 inline " ++ anchorPath "" file , 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 " ++ anchorPath "" file tt <- gets tree -- ick let subs = [ file `appendPath` n | (n, _) <- listImmediate $ fromJust $ findTree tt file ] dumpFiles subs when (not isfile && not isdir) $ liftIO $ putStrLn $ "D " ++ anchorPath "" file dumpPatch :: (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ()) -> (PatchInfoAnd p) x y -> Int -> TreeIO () dumpPatch mark p n = do dumpBits [ BLC.pack $ "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 " -- e.g. -- -> john -- john@home -> john -- john -> john -- john john -- -> john patchAuthor :: (PatchInfoAnd p) x y -> String patchAuthor p | null author = unknownEmail "unknown" | otherwise = case span (/='<') author of -- No name, but have email (nothing spanned) ("", email) -> case span (/='@') (tail email) of -- Not a real email address (no @). (n, "") -> case span (/='>') n of (name, _) -> unknownEmail name -- A "real" email address. (user, rest) -> case span (/= '>') (tail 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 (/='>') $ tail rest of (email, _) -> n ++ emailPad email where author = dropWhile isSpace $ piAuthor (info p) unknownEmail = flip mkAuthor "" emailPad email = "<" ++ email ++ ">" mkAuthor name email = name ++ " " ++ email 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) ] type Marked = Maybe Int type Branch = B.ByteString type AuthorInfo = B.ByteString type Message = B.ByteString type Content = B.ByteString data RefId = MarkId Int | HashId B.ByteString | Inline deriving Show data Object = Blob (Maybe Int) Content | Reset Branch (Maybe RefId) | Commit Branch Marked AuthorInfo Message | Tag Int AuthorInfo Message | Modify (Either Int Content) B.ByteString -- (mark or content), filename | Gitlink B.ByteString | Delete B.ByteString -- filename | From Int | Merge Int | Progress B.ByteString | End deriving Show type Ancestors = (Marked, [Int]) data State = Toplevel Marked Branch | InCommit Marked Ancestors Branch (Tree IO) PatchInfo | Done instance Show State where show (Toplevel _ _) = "Toplevel" show (InCommit _ _ _ _ _) = "InCommit" show Done = "Done" fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fastImport _ opts [outrepo] = do createDirectory outrepo withCurrentDirectory outrepo $ do createRepository (patchFormat opts == O.PatchFormat1) (withWorkingDir opts) (runPatchIndex opts) withRepoLock NoDryRun (useCache opts) NoUpdateWorking (umask opts) $ V2Job $ \repo -> do -- TODO implement --dry-run, which would be read-only? marks <- fastImport' repo emptyMarks createPristineDirectoryTree repo "." (withWorkingDir opts) return marks fastImport _ _ _ = fail "I need exactly one output repository." fastImport' :: forall p r u . (RepoPatch p, ApplyState p ~ Tree) => Repository p r u r -> Marks -> IO () fastImport' repo marks = do pristine <- readRecorded repo marksref <- newIORef marks let initial = Toplevel Nothing $ BC.pack "refs/branches/master" go :: State -> 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 = floatPath (darcsdir "marks") `appendPath` (Name $ BC.pack $ show (n `div` 1000)) `appendPath` (Name $ BC.pack $ show (n `mod` 1000)) makeinfo author message tag = do let (name:log) = lines $ BC.unpack message (author'', date'') = span (/='>') $ BC.unpack author date' = dropWhile (`notElem` ("0123456789" :: String)) date'' author' = author'' ++ ">" date = formatDateTime "%Y%m%d%H%M%S" $ case (parseDateTime "%s %z" date') of Just x -> x Nothing -> startOfTime liftIO $ patchinfo date (if tag then "TAG " ++ name else name) author' log addtag author msg = do info_ <- makeinfo author msg True gotany <- liftIO $ doesFileExist $ darcsdir "tentative_hashed_pristine" deps <- if gotany then liftIO $ getUncovered `fmap` readTentativeRepo repo else return [] let ident = NilFL :: FL (RealPatch Prim) cX cX patch = adddeps (infopatch info_ ident) deps void $ liftIO $ addToTentativeInventory (extractCache repo) GzipCompression (n2pia patch) -- processing items updateHashes = do let nodarcs = (\(AnchoredPath (Name x:_)) _ -> x /= BC.pack darcsdir) hashblobs (File blob@(T.Blob con NoHash)) = do hash <- sha256 `fmap` readBlob blob return $ File (T.Blob con hash) hashblobs x = return x tree' <- liftIO . T.partiallyUpdateTree hashblobs nodarcs =<< gets tree modify $ \s -> s { tree = tree' } return $ T.filter nodarcs tree' process :: State -> Object -> TreeIO State process s (Progress p) = do liftIO $ putStrLn ("progress " ++ BC.unpack 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 = encodeBase16 $ treeHash tree' liftIO $ do putStrLn $ "\\o/ It seems we survived. Enjoy your new repo." B.writeFile (darcsdir "tentative_pristine") $ BC.concat [BC.pack "pristine:", root] return Done process (Toplevel n b) (Tag what author msg) = do if Just what == n then addtag author msg else liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " ++ (head $ lines $ BC.unpack msg) 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 " ++ BC.unpack 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 " ++ BC.unpack link return x process (Toplevel previous pbranch) (Commit branch mark author message) = do when (pbranch /= branch) $ do liftIO $ putStrLn ("Tagging branch: " ++ BC.unpack pbranch) addtag author pbranch info_ <- makeinfo author message False startstate <- updateHashes return $ InCommit mark (previous, []) branch startstate info_ process s@(InCommit _ _ _ _ _) (Modify (Left m) path) = do TM.copy (markpath m) (floatPath $ BC.unpack path) return s process s@(InCommit _ _ _ _ _) (Modify (Right bits) path) = do TM.writeFile (floatPath $ BC.unpack path) (BLC.fromChunks [bits]) return s process s@(InCommit _ _ _ _ _) (Delete path) = do TM.unlink (floatPath $ BC.unpack path) return s process (InCommit mark (prev, current) branch start info_) (From from) = do return $ InCommit mark (prev, from:current) branch start info_ process (InCommit mark (prev, current) branch start info_) (Merge from) = do return $ InCommit mark (prev, from:current) branch start info_ process (InCommit mark ancestors branch start 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 Sealed diff <- unFreeLeft `fmap` (liftIO $ treeDiff PatienceDiff (const TextFile) start current) prims <- return $ fromPrims $ sortCoalesceFL diff let patch = infopatch info_ ((NilFL :: FL p cX cX) +>+ prims) void $ liftIO $ addToTentativeInventory (extractCache repo) GzipCompression (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: " ++ BC.unpack n' process (Toplevel mark branch) x process state obj = do liftIO $ print obj fail $ "Unexpected object in state " ++ show state void $ hashedTreeIO (go initial B.empty) pristine $ darcsdir "pristine.hashed" finalizeRepositoryChanges repo YesUpdateWorking GzipCompression cleanRepository 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_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" >> line -- FIXME we ignore branch for now lexString "from" mark <- p_marked author <- p_author "tagger" message <- p_data return $ 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` line p_modify = do lexString "M" mode <- lex $ A.takeWhile (A.inClass "01234567890") mark <- p_refid path <- line 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 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" ++ BC.unpack chunk ++ "\n=== end chunk ====" fail $ "Error parsing stream. " ++ err ++ "\nContext: " ++ show ctx patchHash :: PatchInfoAnd p cX cY -> BC.ByteString patchHash p = BC.pack $ show $ makePatchname (info p) 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 inOrderTags :: PatchSet p wS wX -> [PatchInfo] inOrderTags (PatchSet _ ts) = go ts where go :: RL(Tagged t1) wT wY -> [PatchInfo] go (Tagged t _ _ :<: ts') = info t : go ts' go NilRL = [] 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"] darcs-2.10.2/src/Darcs/UI/Commands/Send.hs0000644000175000017500000005377612620122474022072 0ustar00guillaumeguillaume00000000000000-- 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, OverloadedStrings #-} module Darcs.UI.Commands.Send ( send ) where import Prelude hiding ( (^), catch ) import System.Exit ( exitSuccess #ifndef HAVE_MAPI , ExitCode ( ExitFailure ) , exitWith #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 ) #ifdef HAVE_HTTP import Data.List ( stripPrefix ) #endif import Data.Maybe ( isNothing, fromMaybe ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , putInfo , putVerbose , printDryRunMessageAndExit , setEnvDarcsPatches , defaultRepo , amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag( Target , Context , Mail , DryRun , Quiet , AllowUnrelatedRepos ) , willRemoveLogFile, doReverse, dryRun, useCache, remoteRepos, setDefault , fixUrl , getCc , getAuthor , getSubject , getInReplyTo , getSendmailCmd , getOutput , getCharset , verbosity , hasSummary , isInteractive , hasAuthor , hasLogfile , selectDeps , minimize , editDescription ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc ) import Darcs.Repository ( PatchSet, Repository, identifyRepositoryFor, withRepository, RepoJob(..), readRepo, readRecorded, prefsUrl, checkUnrelatedRepos ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch ( RepoPatch, description, applyToTree, 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 ( minContext, makeBundleN, scanContextFile, patchFilename ) import Darcs.Repository.Prefs ( addRepoSource, getPreflist ) import Darcs.Repository.External ( fetchFilePS, Cachable(..) ) import Darcs.UI.External ( signString , sendEmailDoc , generateEmail , editFile , catchall , getSystemEncoding , isUTF8Locale #ifndef HAVE_MAPI , haveSendmail #endif ) import Darcs.Util.ByteString ( mmapFilePS, isAscii ) import qualified Data.ByteString.Char8 as BC (unpack) import Darcs.Repository.Lock ( withOpenTemp , writeDocBinFile , readDocBinFile , removeFileMayNotExist ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(..) , selectionContext , 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.Util.Printer ( Doc, vsep, text, ($$), (<+>), (<>), putDoc, putDocLn , renderPS, RenderMode(..) ) import Darcs.Util.English ( englishNum, Noun(..) ) import Darcs.Util.Path ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd, getCurrentDirectory, useAbsoluteOrStd, makeAbsoluteOrStd ) import Darcs.Util.Download.HTTP ( postUrl ) import Darcs.Util.Workaround ( renameFile ) import Darcs.Util.Global ( darcsSendMessage, darcsSendMessageFinal ) import Darcs.Util.SignalHandler ( catchInterrupt ) import qualified Darcs.UI.Message.Send as Msg #include "impossible.h" sendBasicOpts :: DarcsOption a ([O.MatchFlag] -> O.SelectDeps -> Maybe Bool -> O.HeaderFields -> Maybe String -> Maybe String -> (Bool, Maybe String) -> Maybe O.Output -> O.Sign -> O.DryRun -> O.XmlOutput -> Maybe O.Summary -> Bool -> Maybe Bool -> Maybe String -> Bool -> Bool -> a) sendBasicOpts = O.matchSeveral ^ O.selectDeps ^ O.interactive -- True ^ O.headerFields ^ O.author ^ O.charset ^ O.sendmail ^ O.output ^ O.sign ^ O.dryRunXml ^ O.summary ^ O.editDescription ^ O.setDefault ^ O.workingRepoDir ^ O.minimize ^ O.allowUnrelatedRepos sendAdvancedOpts :: DarcsOption a (O.Logfile -> O.RemoteRepos -> Maybe AbsolutePath -> Bool -> O.NetworkOptions -> a) sendAdvancedOpts = O.logfile ^ O.remoteRepos ^ O.sendToContext ^ O.changesReverse ^ O.network sendOpts :: DarcsOption a ([O.MatchFlag] -> O.SelectDeps -> Maybe Bool -> O.HeaderFields -> Maybe String -> Maybe String -> (Bool, Maybe String) -> Maybe O.Output -> O.Sign -> O.DryRun -> O.XmlOutput -> Maybe O.Summary -> Bool -> Maybe Bool -> Maybe String -> Bool -> Bool -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.Logfile -> O.RemoteRepos -> Maybe AbsolutePath -> Bool -> O.NetworkOptions -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) sendOpts = sendBasicOpts `withStdOpts` sendAdvancedOpts patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags , S.diffAlgorithm = O.PatienceDiff , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = O.NoContext } send :: DarcsCommand [DarcsFlag] send = DarcsCommand { commandProgramName = "darcs" , commandName = "send" , commandHelp = Msg.cmdHelp , commandDescription = Msg.cmdDescription , commandExtraArgs = 1 , commandExtraArgHelp = ["[REPOSITORY]"] , commandCommand = sendCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = getPreflist "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc sendAdvancedOpts , commandBasicOptions = odesc sendBasicOpts , commandDefaults = defaultFlags sendOpts , commandCheckOptions = ocheck sendOpts , commandParseOptions = onormalise sendOpts } sendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () sendCmd fps input_opts [""] = sendCmd fps input_opts [] sendCmd (_,o) input_opts [unfixedrepodir] = withRepository (useCache input_opts) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do context_ps <- the_context input_opts case context_ps of Just them -> do wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository p wR wU wR)) sendToThem repository input_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 Msg.cannotSendToSelf old_default <- getPreflist "defaultrepo" when (old_default == [repodir] && Quiet `notElem` input_opts) $ putDocLn (Msg.creatingPatch repodir) repo <- identifyRepositoryFor repository (useCache input_opts) repodir them <- readRepo repo addRepoSource repodir (dryRun input_opts) (remoteRepos input_opts) (setDefault False 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 `fmap` scanContextFile (toFilePath foo) the_context (_:fs) = the_context fs sendCmd _ _ _ = impossible sendToThem :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p Origin wX -> 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 Msg.noWorkingSendmail exitWith $ ExitFailure 1 #endif us <- readRepo repo common :> us' <- return $ findCommonWithThem us them checkUnrelatedRepos (AllowUnrelatedRepos `elem` opts) us them case us' of NilFL -> do putInfo opts Msg.nothingSendable exitSuccess _ -> putVerbose opts $ Msg.selectionIs (mapFL description us') pristine <- readRecorded repo let direction = if doReverse opts then FirstReversed else First context = selectionContext direction "send" (patchSelOpts opts) Nothing Nothing (to_be_sent :> _) <- runSelection (selectChanges us') context printDryRunMessageAndExit "send" (verbosity opts) (hasSummary O.NoSummary opts) (dryRun opts) O.NoXml (isInteractive True opts) to_be_sent when (nullFL to_be_sent) $ do putInfo opts Msg.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:>:_) = patchFilename $ patchDesc tb make_fname _ = impossible fname = make_fname to_be_sent outname = case getOutput opts fname of Just f -> Just f Nothing | Mail `elem` opts -> Nothing | not $ null [ p | Post p <- wtds] -> Nothing | otherwise -> Just (makeAbsoluteOrStd here 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 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 $ mapFL_FL hopefully us') pristine makeBundleN (Just pristine') (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent) Left to_be_sent -> makeBundleN Nothing (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent) signString (parseFlags 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= 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 ++ "..." in do thetargets <- getTargets wtds from <- getAuthor (hasAuthor 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 $ Msg.emailBackedUp mf Nothing -> return () warnCharset msg = do confirmed <- promptYorn $ Msg.promptCharSetWarning msg unless confirmed $ do putDocLn Msg.charsetAborted warnMailBody exitSuccess thecharset <- case getCharset opts of -- Always trust provided charset providedCset@(Just _) -> return providedCset Nothing -> case mailcharset of Nothing -> do warnCharset Msg.charsetCouldNotGuess return mailcharset Just "utf-8" -> do -- Check the locale encoding for consistency encoding <- getSystemEncoding debugMessage $ Msg.currentEncodingIs encoding unless (isUTF8Locale encoding) $ warnCharset Msg.charsetUtf8MailDiffLocale 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 (Msg.success to (getCc opts)) `catch` \e -> do warnMailBody fail $ ioeGetErrorString e 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 $ Msg.postingPatch 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 (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 (Msg.wroteBundle a) putstd = putDoc (d $$ bundle) useAbsoluteOrStd putabs putstd fname let to = generateEmailToString wtds unless (null to) $ putInfo opts $ Msg.savedButNotSent 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 wR wU wT) -> 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 msg = Msg.willSendTo (dryRun opts) (map pn emails) in if DryRun `elem` opts then putInfo opts msg else when (null the_targets && isNothing (getOutput opts "")) $ putInfo opts msg getTargets :: [WhatToDo] -> IO [WhatToDo] getTargets [] = fmap ((:[]) . SendMail) $ askUser Msg.promptTarget 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) 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 $ Msg.aboutToEdit file (_, changed) <- editFile file unless changed $ do confirmed <- promptYorn Msg.promptNoDescriptionChange unless confirmed $ do putDocLn Msg.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 Standard content in if isAscii body then Just "us-ascii" else either (const Nothing) (const $ Just "utf-8") (decodeUtf8' body) darcs-2.10.2/src/Darcs/UI/Commands/Push.hs0000644000175000017500000002562112620122474022104 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Push ( push ) where import Prelude hiding ( (^) ) import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ), exitSuccess ) import Control.Monad ( when, unless ) import Data.Char ( toUpper ) import Data.Maybe ( isJust, isNothing ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , putVerbose , putInfo , abortRun , printDryRunMessageAndExit , setEnvDarcsPatches , formatPath , defaultRepo , amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag , isInteractive, verbosity, isUnified, hasSummary, diffAlgorithm , hasXmlOutput, selectDeps, applyAs , doReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( DryRun (..) ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) import Darcs.Repository ( Repository, withRepository, RepoJob(..), identifyRepositoryFor, readRepo, checkUnrelatedRepos ) 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 ( addRepoSource, getPreflist ) import Darcs.UI.External ( maybeURLCmd, signString ) import Darcs.Util.URL ( isHttpUrl, isValidLocalPath ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(..) , selectionContext , runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Patch.Depends ( findCommonWithThem, countUsThem ) import Darcs.Patch.Bundle ( makeBundleN ) import Darcs.Patch.Patchy( ShowPatch ) import Darcs.Patch.Set ( PatchSet, Origin ) import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$) ) import Darcs.UI.RemoteApply ( remoteApply ) import Darcs.UI.Email ( makeEmail ) import Darcs.Util.English (englishNum, Noun(..)) import Darcs.Util.Workaround ( getCurrentDirectory ) import Storage.Hashed.Tree( Tree ) #include "impossible.h" pushDescription :: String pushDescription = "Copy and apply patches from this repository to another one." pushHelp :: String pushHelp = unlines [ "Push is the opposite of pull. Push allows you to copy patches from the" , "current repository into another repository." , "" , "If you give the `--apply-as` flag, darcs will use sudo to apply the" , "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." , "" , "Darcs push will by default 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 to send the" , "data in un-compressed form (which is a lot slower for large patches, but" , "should always work)." ] pushBasicOpts :: DarcsOption a ([O.MatchFlag] -> O.SelectDeps -> Maybe Bool -> O.Sign -> O.DryRun -> O.XmlOutput -> Maybe O.Summary -> Maybe String -> Maybe Bool -> Bool -> a) pushBasicOpts = O.matchSeveral ^ O.selectDeps ^ O.interactive ^ O.sign ^ O.dryRunXml ^ O.summary ^ O.workingRepoDir ^ O.setDefault ^ O.allowUnrelatedRepos pushAdvancedOpts :: DarcsOption a (Maybe String -> O.RemoteRepos -> Bool -> O.Compression -> O.NetworkOptions -> a) pushAdvancedOpts = O.applyAs ^ O.remoteRepos ^ O.changesReverse ^ O.compress ^ O.network pushOpts :: DarcsOption a ([O.MatchFlag] -> O.SelectDeps -> Maybe Bool -> O.Sign -> DryRun -> O.XmlOutput -> Maybe O.Summary -> Maybe String -> Maybe Bool -> Bool -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> Maybe String -> O.RemoteRepos -> Bool -> O.Compression -> O.NetworkOptions -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) pushOpts = pushBasicOpts `withStdOpts` pushAdvancedOpts push :: DarcsCommand [DarcsFlag] push = DarcsCommand { commandProgramName = "darcs" , commandName = "push" , commandHelp = pushHelp , commandDescription = pushDescription , commandExtraArgs = 1 , commandExtraArgHelp = ["[REPOSITORY]"] , commandCommand = pushCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = getPreflist "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc pushAdvancedOpts , commandBasicOptions = odesc pushBasicOpts , commandDefaults = defaultFlags pushOpts , commandCheckOptions = ocheck pushOpts , commandParseOptions = onormalise pushOpts } pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () pushCmd _ _ [""] = impossible pushCmd (_,o) opts [unfixedrepodir] = do repodir <- fixUrl o 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 <- withRepository (useCache opts) $ RepoJob $ prepareBundle opts repodir sbundle <- signString (parseFlags 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 putStrLn "Apply failed!" exitWith (ExitFailure ec) ExitSuccess -> putInfo opts $ text "Push successful." pushCmd _ _ _ = impossible prepareBundle :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> String -> Repository p wR wU wT -> 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 "++formatPath repodir++"..." them <- identifyRepositoryFor repository (useCache opts) repodir >>= readRepo addRepoSource repodir (dryRun opts) (remoteRepos opts) (setDefault False opts) us <- readRepo repository common :> us' <- return $ findCommonWithThem us them prePushChatter opts us (reverseFL us') them let direction = if doReverse opts then FirstReversed else First context = selectionContext direction "push" (pushPatchSelOpts opts) Nothing Nothing runSelection (selectChanges us') context >>= bundlePatches opts common prePushChatter :: forall p a wX wY wT . (RepoPatch p, ShowPatch a) => [DarcsFlag] -> PatchSet p Origin wX -> RL a wT wX -> PatchSet p Origin wY -> IO () prePushChatter opts us us' them = do checkUnrelatedRepos (parseFlags 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 us') unless (nullRL us') $ putInfo opts pull_reminder when (nullRL us') $ do putInfo opts $ text "No recorded local patches to push!" exitSuccess bundlePatches :: forall t p wZ wW wA. (RepoPatch p, ApplyState p ~ Tree) => [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) (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput 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 makeBundleN 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" maybeapply <- maybeURLCmd "APPLY" repodir when (isNothing maybeapply) $ 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 when (parseFlags 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 = parseFlags O.matchSeveral flags , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = isUnified flags } darcs-2.10.2/src/Darcs/UI/Commands/ShowContents.hs0000644000175000017500000001175212620122474023623 0ustar00guillaumeguillaume00000000000000-- 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 Prelude hiding ( (^) ) import Control.Monad ( filterM, forM_, forM ) import System.IO ( stdout ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) import Darcs.UI.Flags ( DarcsFlag, useCache, fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O ( MatchFlag , matchOne , workingRepoDir , StdCmdAction , Verbosity , UseCache ) import Darcs.Patch.Match ( haveNonrangeMatch ) import Darcs.Repository ( withRepository, RepoJob(..), readRecorded, repoPatchType ) import Darcs.Repository.Lock ( withDelayedDir ) import Darcs.Repository.Match ( getNonrangeMatch ) import Storage.Hashed.Plain( readPlainTree ) import qualified Storage.Hashed.Monad as HSM import Darcs.Util.Path( floatPath, sp2fn, toFilePath, AbsolutePath ) 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" showContentsBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe String -> a) showContentsBasicOpts = O.matchOne ^ O.workingRepoDir showContentsOpts :: DarcsOption a ([O.MatchFlag] -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) showContentsOpts = O.matchOne ^ O.workingRepoDir `withStdOpts` oid showContents :: DarcsCommand [DarcsFlag] showContents = DarcsCommand { commandProgramName = "darcs" , commandName = "contents" , commandHelp = showContentsHelp , commandDescription = showContentsDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[FILE]..."] , commandCommand = showContentsCmd , commandPrereq = findRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showContentsBasicOpts , commandDefaults = defaultFlags showContentsOpts , commandCheckOptions = ocheck showContentsOpts , commandParseOptions = onormalise showContentsOpts } showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showContentsCmd _ _ [] = fail "show contents needs at least one argument." showContentsCmd fps opts args = do floatedPaths <- map (floatPath . toFilePath . sp2fn) `fmap` fixSubPaths fps args let matchFlags = parseFlags O.matchOne opts withRepository (useCache opts) $ RepoJob $ \repository -> do let readContents = do okpaths <- filterM HSM.fileExists floatedPaths forM okpaths $ \f -> (B.concat . BL.toChunks) `fmap` HSM.readFile f -- Note: The two calls to execReadContents below are from -- different working directories. This matters despite our -- use of virtualTreeIO. execReadContents tree = fst `fmap` HSM.virtualTreeIO readContents tree files <- if haveNonrangeMatch (repoPatchType repository) matchFlags then withDelayedDir "show.contents" $ \_ -> do -- this call populates our temporary directory, but note that -- it does so lazily: the tree gets (partly) expanded inside -- execReadContents, so it is important that we execute the -- latter from the same working directory. getNonrangeMatch repository matchFlags readPlainTree "." >>= execReadContents else do -- we can use the existing pristine tree because we don't modify -- anything in this case readRecorded repository >>= execReadContents forM_ files $ B.hPut stdout darcs-2.10.2/src/Darcs/UI/Commands/SetPref.hs0000644000175000017500000001272512620122474022536 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.SetPref ( setpref ) where import System.Exit ( exitWith, ExitCode(..) ) import Control.Monad (when) import Data.Maybe (fromMaybe) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag, useCache, dryRun, umask) import Darcs.UI.Options ( DarcsOption, PrimDarcsOption, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..) ) import Darcs.Repository ( addToPending, withRepoLock, RepoJob(..) ) 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 ) #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" setprefBasicOpts :: PrimDarcsOption (Maybe String) setprefBasicOpts = O.workingRepoDir setprefAdvancedOpts :: PrimDarcsOption O.UMask setprefAdvancedOpts = O.umask setprefOpts :: DarcsOption a (Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) setprefOpts = setprefBasicOpts `withStdOpts` setprefAdvancedOpts setpref :: DarcsCommand [DarcsFlag] setpref = DarcsCommand { commandProgramName = "darcs" , commandName = "setpref" , commandHelp = setprefHelp , commandDescription = setprefDescription , commandExtraArgs = 2 , commandExtraArgHelp = ["", ""] , commandCommand = setprefCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return validPrefs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc setprefAdvancedOpts , commandBasicOptions = odesc setprefBasicOpts , commandDefaults = defaultFlags setprefOpts , commandCheckOptions = ocheck setprefOpts , commandParseOptions = onormalise setprefOpts } setprefCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () setprefCmd _ opts [pref,val] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (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 YesUpdateWorking (changepref pref old val :>: NilFL) setprefCmd _ _ _ = impossible darcs-2.10.2/src/Darcs/UI/Commands/Test.hs0000644000175000017500000003360112620122474022101 0ustar00guillaumeguillaume00000000000000-- 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.Test ( test ) where import Prelude hiding ( (^), init, catch ) import Control.Exception ( catch, IOException ) import Control.Monad( when ) import System.Process ( system ) import System.Exit ( ExitCode(..), exitWith ) import System.IO ( hFlush, stdout ) import Storage.Hashed.Tree( Tree ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , nodefaults , putInfo , amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag( SetScriptsExecutable , Linear , Backoff , Bisect , LeaveTestDir ) , useCache, verbosity ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Patch.PatchInfoAnd ( hopefully ) import Darcs.Repository ( readRepo , withRepository , RepoJob(..) , withRecorded , setScriptsExecutablePatches , setScriptsExecutable ) import Darcs.Patch.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.Inspect ( PatchInspect ) import Darcs.Patch.Patchy ( Patchy , Invert , Apply , ShowPatch ) import Darcs.Patch ( RepoPatch , Named , description , apply , invert ) import Darcs.Patch.Set ( newset2RL ) import Darcs.Util.Printer ( putDocLn , text ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault ) import Darcs.Repository.Test ( getTest ) import Darcs.Repository.Lock ( withTempDir , withPermDir ) testDescription :: String testDescription = "Run regression test." testHelp :: String testHelp = 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." ] testBasicOpts :: DarcsOption a (O.TestStrategy -> O.LeaveTestDir -> Maybe String -> a) testBasicOpts = O.testStrategy ^ O.leaveTestDir ^ O.workingRepoDir testAdvancedOpts :: DarcsOption a (O.SetScriptsExecutable -> a) testAdvancedOpts = O.setScriptsExecutable testOpts :: DarcsOption a (O.TestStrategy -> O.LeaveTestDir -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.SetScriptsExecutable -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) testOpts = testBasicOpts `withStdOpts` testAdvancedOpts test :: DarcsCommand [DarcsFlag] test = DarcsCommand { commandProgramName = "darcs" , commandName = "test" , commandHelp = testHelp , commandDescription = testDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[[INITIALIZATION]", "COMMAND]"] , commandCommand = testCommand , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc testAdvancedOpts , commandBasicOptions = odesc testBasicOpts , commandDefaults = defaultFlags testOpts , commandCheckOptions = ocheck testOpts , commandParseOptions = onormalise testOpts } -- | Functions defining a strategy for executing a test type Strategy = forall p wX wY . (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) => [DarcsFlag] -> IO ExitCode -- ^ test command -> ExitCode -> RL (Named p) wX wY -> IO () testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () testCommand _ opts args = withRepository (useCache opts) $ RepoJob $ \repository -> do patches <- readRepo repository (init,testCmd) <- case args of [] -> do t <- getTest (verbosity opts) return (return ExitSuccess, t) [cmd] -> do putStrLn $ "Using test command:\n"++cmd return (return ExitSuccess, system cmd) [init,cmd] -> do putStrLn $ "Using initialization command:\n"++init putStrLn $ "Using test command:\n"++cmd return (system init, system cmd) _ -> fail "Test expects zero to two arguments." let wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir withRecorded repository (wd "testing") $ \_ -> do when (SetScriptsExecutable `elem` opts) setScriptsExecutable _ <- init putInfo opts $ text "Running test...\n" testResult <- testCmd let track = chooseStrategy opts track opts testCmd testResult (mapRL_RL hopefully . newset2RL $ patches) chooseStrategy :: [DarcsFlag] -> Strategy chooseStrategy opts | Bisect `elem` opts = trackBisect | Linear `elem` opts = trackLinear | Backoff `elem` opts = trackBackoff | otherwise = oneTest -- | test only the last recorded state oneTest :: Strategy oneTest opts _ ExitSuccess _ = putInfo opts $ text "Test ran successfully.\n" oneTest opts _ testResult _ = do putInfo opts $ text "Test failed!\n" exitWith testResult -- | linear search (with --linear) trackLinear :: Strategy trackLinear _ _ ExitSuccess _ = putStrLn "Success!" trackLinear opts testCmd (ExitFailure _) (p:<:ps) = do let ip = invert p safeApply ip when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches ip putStrLn "Trying without the patch:" putDocLn $ description ip hFlush stdout testResult <- testCmd trackLinear opts testCmd testResult ps trackLinear _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!" -- | exponential backoff search (with --backoff) trackBackoff :: Strategy trackBackoff _ _ ExitSuccess NilRL = putStrLn "Success!" trackBackoff _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!" trackBackoff _ _ ExitSuccess _ = putStrLn "Test does not fail on head." trackBackoff opts testCmd (ExitFailure _) ps = trackNextBackoff opts testCmd 4 ps trackNextBackoff :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) => [DarcsFlag] -> IO ExitCode -> Int -- ^ number of patches to skip -> RL (Named p) wY wZ -- ^ patches not yet skipped -> IO () trackNextBackoff _ _ _ NilRL = putStrLn "Noone passed the test!" trackNextBackoff opts testCmd n ahead | n >= lengthRL ahead = initialBisect opts testCmd ahead trackNextBackoff opts testCmd n ahead = do putStrLn $ "Skipping " ++ show n ++ " patches..." hFlush stdout case splitAtRL n ahead of ( skipped' :< ahead' ) -> do unapplyRL skipped' when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches skipped' testResult <- testCmd case testResult of ExitFailure _ -> trackNextBackoff opts testCmd (2*n) ahead' ExitSuccess -> do applyRL skipped' -- offending patch is one of these initialBisect opts testCmd skipped' -- bisect to find it -- | binary search (with --bisect) trackBisect :: Strategy trackBisect _ _ ExitSuccess NilRL = putStrLn "Success!" trackBisect _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!" trackBisect _ _ ExitSuccess _ = putStrLn "Test does not fail on head." trackBisect opts testCmd (ExitFailure _) ps = initialBisect opts testCmd ps initialBisect :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) => [DarcsFlag] -> IO ExitCode -> RL (Named p) wX wY -> IO () initialBisect opts testCmd ps = trackNextBisect opts currProg testCmd BisectRight (patchTreeFromRL ps) where maxProg = 1 + round ((logBase 2 $ fromIntegral $ lengthRL ps) :: Double) currProg = (1, maxProg) :: BisectState -- | Bisect Patch Tree data PatchTree p wX wY where Leaf :: p wX wY -> PatchTree p wX wY Fork :: PatchTree p wY wZ -> PatchTree p wX wY -> PatchTree p wX wZ -- | 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 wX wY -> PatchTree p wX wY 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 wX wY -> RL p wX wY patchTree2RL (Leaf p) = p :<: NilRL patchTree2RL (Fork l r) = patchTree2RL l +<+ patchTree2RL r -- | Iterate the Patch Tree trackNextBisect :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) => [DarcsFlag] -> BisectState -> IO ExitCode -- ^ test command -> BisectDir -> PatchTree (Named p) wX wY -> IO () trackNextBisect opts (dnow, dtotal) testCmd 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 testResult <- testCmd -- execute test on repo case testResult of ExitSuccess -> trackNextBisect opts (dnow+1, dtotal) testCmd BisectLeft l -- continue left (to the present) _ -> trackNextBisect opts (dnow+1, dtotal) testCmd 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, ShowPatch p, PatchInspect p, Patchy p, ApplyMonad DefaultIO (ApplyState p)) => [DarcsFlag] -> PatchTree p wX wY -> IO () jumpHalfOnRight opts l = do unapplyRL ps when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches ps where ps = patchTree2RL l jumpHalfOnLeft :: (IsHunk p, Conflict p, PatchListFormat p, ShowPatch p, PatchInspect p, Patchy p, ApplyMonad DefaultIO (ApplyState p)) => [DarcsFlag] -> PatchTree p wX wY -> IO () jumpHalfOnLeft opts r = do applyRL p when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches p where p = patchTree2RL r applyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p)) => RL p wX wY -> IO () applyRL patches = sequence_ (mapFL safeApply (reverseRL patches)) unapplyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p)) => RL p wX wY -> IO () unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches) safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p)) => p wX wY -> IO () safeApply p = runDefault (apply p) `catch` \(msg :: IOException) -> fail $ "Bad patch:\n" ++ show msg darcs-2.10.2/src/Darcs/UI/Commands/Clone.hs0000644000175000017500000003452212620122474022225 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Clone ( get , put , clone , makeRepoName , cloneToSSH ) where import Prelude hiding ( (^), catch ) import System.Directory ( doesDirectoryExist, doesFileExist , setCurrentDirectory ) import System.Exit ( ExitCode(..) ) import Control.Exception ( catch, SomeException ) import Control.Monad ( when, unless ) import Data.Maybe ( listToMaybe ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , nodefaults , commandStub , commandAlias , putInfo ) import Darcs.UI.Flags( DarcsFlag( NewRepo , UpToPattern , UpToPatch , OnePattern , OnePatch ) , toMatchFlags, useCache, umask, remoteRepos , setDefault , DarcsFlag(Quiet), usePacks , remoteDarcs, cloneKind, verbosity, setScriptsExecutable , withWorkingDir, runPatchIndex ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands.Util ( getUniqueRepositoryName ) import Darcs.Repository ( cloneRepository ) import Darcs.Repository.Format ( identifyRepoFormat , RepoProperty ( HashedInventory , RebaseInProgress ) , formatHas ) import Darcs.Repository.Lock ( withTempDir ) import Darcs.Repository.Ssh ( getSSH, SSHCmd(SCP) ) import Darcs.Repository.Flags ( CloneKind(CompleteClone), SetDefault(NoSetDefault), ForgetParent(..) ) import Darcs.Patch.Bundle ( scanContextFile ) import Darcs.Patch.Dummy ( DummyPatch ) import Darcs.Patch.Set ( PatchSet, Origin ) import Darcs.Repository.Motd ( showMotd ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Printer ( text, ($$) ) import Darcs.Util.Path ( toFilePath, toPath, ioAbsoluteOrRemote, AbsolutePath ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Util.URL ( isSshUrl ) import Darcs.Util.Exec ( exec, Redirect(..), ) cloneDescription :: String cloneDescription = "Make a copy of an existing repository." cloneHelp :: String cloneHelp = unlines [ "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." , "This means the copy is completely independent of the original; you can" , "operate on the new repository even when the original is inaccessible." , "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 instead of many" , "little files, which makes cloning faster over HTTP." , "" , "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 cloneBasicOpts :: DarcsOption a (Maybe String -> CloneKind -> [O.MatchFlag] -> Maybe Bool -> O.SetScriptsExecutable -> O.WithWorkingDir -> a) cloneBasicOpts = O.reponame ^ O.partial ^ O.matchOneContext ^ O.setDefault ^ O.setScriptsExecutable ^ O.useWorkingDir cloneAdvancedOpts :: DarcsOption a (Bool -> O.WithPatchIndex -> O.NetworkOptions -> a) cloneAdvancedOpts = O.usePacks ^ O.patchIndex ^ O.network cloneOpts :: DarcsOption a (Maybe String -> CloneKind -> [O.MatchFlag] -> Maybe Bool -> O.SetScriptsExecutable -> O.WithWorkingDir -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> Bool -> O.WithPatchIndex -> O.NetworkOptions -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) cloneOpts = cloneBasicOpts `withStdOpts` cloneAdvancedOpts clone :: DarcsCommand [DarcsFlag] clone = DarcsCommand { commandProgramName = "darcs" , commandName = "clone" , commandHelp = cloneHelp , commandDescription = cloneDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["", "[]"] , commandCommand = cloneCmd , commandPrereq = validContextFile , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc cloneAdvancedOpts , commandBasicOptions = odesc cloneBasicOpts , commandDefaults = defaultFlags cloneOpts , commandCheckOptions = ocheck cloneOpts , commandParseOptions = onormalise cloneOpts } get :: DarcsCommand [DarcsFlag] get = commandAlias "get" Nothing clone putDescription :: String putDescription = "Deprecated command, replaced by clone." putHelp :: String putHelp = unlines [ "This command is deprecated." , "" , "To clone the current repository to a ssh destination," , "use the syntax `darcs clone . user@server:path` ." ] put :: DarcsCommand [DarcsFlag] put = commandStub "put" putHelp putDescription clone cloneCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () cloneCmd fps opts [inrepodir, outname] = cloneCmd fps (NewRepo outname:opts) [inrepodir] cloneCmd _ opts [inrepodir] = do debugMessage "Starting work on clone..." typed_repodir <- ioAbsoluteOrRemote inrepodir let repodir = toPath typed_repodir unless (Quiet `elem` opts) $ showMotd repodir rfsource <- identifyRepoFormat repodir debugMessage $ "Found the format of "++repodir++"..." -- there's no fundamental reason for banning gets of repositories with -- rebase in progress, but it seems a bit dubious to actually copy the -- rebase state, and removing it is a bit of work since the current -- implementation just copies the inventory file when (formatHas RebaseInProgress rfsource) $ fail "Can't clone a repository with a 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 putInfo opts $ text "Creating local clone..." currentDir <- getCurrentDirectory cloneRepository repodir "local" (verbosity opts) (useCache opts) CompleteClone (umask opts) (remoteDarcs opts) (setScriptsExecutable opts) (remoteRepos opts) (NoSetDefault True) (toMatchFlags $ map convertUpToToOne opts) rfsource (withWorkingDir opts) (runPatchIndex opts) (usePacks opts) (not $ null [p | UpToPattern p <- opts] ) -- --to-match given YesForgetParent setCurrentDirectory currentDir (scp, args) <- getSSH SCP putInfo opts $ text "Transferring clone by SCP..." r <- exec scp (args ++ ["-r", "local", 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) (remoteDarcs opts) (setScriptsExecutable opts) (remoteRepos opts) (setDefault True opts) (toMatchFlags $ map convertUpToToOne opts) rfsource (withWorkingDir opts) (runPatchIndex opts) (usePacks opts) (not $ null [p | UpToPattern p <- opts] ) -- --to-match given NoForgetParent putInfo opts $ text "Finished cloning." cloneCmd _ _ _ = fail "You must provide 'clone' with either one or two arguments." cloneToSSH :: [DarcsFlag] -> Maybe String cloneToSSH fs = case parseFlags O.reponame fs of Nothing -> Nothing Just r -> if isSshUrl r then Just r else Nothing makeRepoName :: Bool -> [DarcsFlag] -> FilePath -> IO String makeRepoName talkative dfs d = case [ n | NewRepo n <- dfs] of (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 [] -> case dropWhile (=='.') $ reverse $ takeWhile (\c -> c /= '/' && c /= ':') $ dropWhile (=='/') $ reverse d of "" -> getUniqueRepositoryName talkative "anonymous_repo" base@('/':_) -> getUniqueRepositoryName talkative base -- Absolute base -> do -- Relative cwd <- getCurrentDirectory getUniqueRepositoryName talkative (cwd ++ "/" ++ base) cloneHelpTag :: String cloneHelpTag = unlines [ "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`, so tagging is preferred." , "" ] cloneHelpSSE :: String cloneHelpSSE = unlines [ "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 (\"#!\")." ] validContextFile :: [DarcsFlag] -> IO (Either String ()) validContextFile opts = case getContext opts of Nothing -> return $ Right () Just ctxAbsolutePath -> do let ctxFilePath = toFilePath ctxAbsolutePath exists <- doesFileExist ctxFilePath if exists then do (ps :: PatchSet DummyPatch Origin wX) <- scanContextFile ctxFilePath (ps `seq` return $ Right ()) `catch` \(_ :: SomeException) -> return . Left $ "File " ++ ctxFilePath ++ " is not a valid context file" else return . Left $ "Context file " ++ ctxFilePath ++ " does not exist" -- | '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 fs = listToMaybe [ f | O.Context f <- toMatchFlags fs ] -- The 'clone' command takes --to-patch and --to-match as arguments, -- but internally wants to handle them as if they were --patch and --match -- TODO: remove this when we get rid of directly looking at [DarcsFlag] -- for this command. convertUpToToOne :: DarcsFlag -> DarcsFlag convertUpToToOne (UpToPattern p) = OnePattern p convertUpToToOne (UpToPatch p) = OnePatch p convertUpToToOne f = f darcs-2.10.2/src/Darcs/UI/Commands/WhatsNew.hs0000644000175000017500000004160312620122474022723 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.WhatsNew ( whatsnew , status ) where import Prelude hiding ( (^), catch ) import Control.Applicative ( (<$>) ) import Control.Monad ( void ) import Control.Monad.Reader ( runReaderT ) import Control.Monad.State ( evalStateT, liftIO ) import Storage.Hashed.Tree ( Tree ) import System.Exit ( ExitCode (..), exitSuccess, exitWith ) import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch , applyToTree, plainSummaryPrims, primIsHunk ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Choices ( patchChoicesLps, lpPatch ) import Darcs.Patch.FileHunk ( IsHunk (..) ) import Darcs.Patch.Format ( PatchListFormat (..) ) import Darcs.Patch.Inspect ( PatchInspect (..) ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Permutations ( partitionRL ) import Darcs.Patch.Prim.Class ( PrimDetails (..) ) import Darcs.Patch.Show ( ShowPatch ) import Darcs.Patch.Split ( primSplitter ) import Darcs.Patch.TouchesFiles ( choosePreTouching ) import Darcs.Patch.Witnesses.Ordered ( (:>) (..), FL (..), RL (..) , lengthFL, reverseFL, reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed (..), Sealed2 (..) , unFreeLeft ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.WZipper ( FZipper (..) ) import Darcs.Repository ( RepoJob (..), Repository , listRegisteredFiles, readRecorded , unrecordedChangesWithPatches, withRepository ) import Darcs.Repository.Diff ( treeDiff ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Repository.Util ( getMovesPs, getReplaces ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, amInRepository , commandAlias, nodefaults ) import Darcs.UI.Commands.Util ( announceFiles ) import Darcs.UI.Flags ( DarcsFlag (Summary, LookForAdds, LookForMoves), diffAlgorithm, diffingOpts , isUnified, useCache, fixSubPaths , verbosity, isInteractive, isUnified, lookForAdds, lookForMoves, lookForReplaces, hasSummary ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PrintPatch ( contextualPrintPatch, printPatch , printPatchPager ) import Darcs.UI.SelectChanges ( InteractiveSelectionContext (..) , InteractiveSelectionM, KeyPress (..) , WhichChanges (..), backAll , backOne, currentFile , currentPatch, decide , decideWholeFile, helpFor , keysFor, prompt , selectionContextPrim, skipMundane , skipOne, printSummary ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath ) import Darcs.Util.Printer ( putDocLn, renderString, RenderMode(..) , text, vcat ) import Darcs.Util.Prompt ( PromptConfig (..), promptChar ) whatsnewBasicOpts :: DarcsOption a (Maybe O.Summary -> O.WithContext -> O.LookFor -> O.DiffAlgorithm -> Maybe String -> Maybe Bool -> a) whatsnewBasicOpts = O.summary ^ O.withContext ^ O.lookfor ^ O.diffAlgorithm ^ O.workingRepoDir ^ O.interactive -- False whatsnewAdvancedOpts :: DarcsOption a (O.UseIndex -> Bool -> a) whatsnewAdvancedOpts = O.useIndex ^ O.includeBoring whatsnewOpts :: DarcsOption a (Maybe O.Summary -> O.WithContext -> O.LookFor -> O.DiffAlgorithm -> Maybe String -> Maybe Bool -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseIndex -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) whatsnewOpts = whatsnewBasicOpts `withStdOpts` whatsnewAdvancedOpts patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = [] , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = hasSummary (defaultSummary flags) flags , S.withContext = isUnified flags } defaultSummary :: [DarcsFlag] -> O.Summary defaultSummary flags = if lookForAdds flags == O.YesLookForAdds then O.YesSummary else O.NoSummary whatsnew :: DarcsCommand [DarcsFlag] 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 = odesc whatsnewAdvancedOpts , commandBasicOptions = odesc whatsnewBasicOpts , commandDefaults = defaultFlags whatsnewOpts , commandCheckOptions = ocheck whatsnewOpts , commandParseOptions = onormalise whatsnewOpts } 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 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () whatsnewCmd fps opts args = withRepository (useCache opts) $ RepoJob $ \(repo :: Repository p wR wU wR) -> do files <- if null args then return Nothing else Just <$> fixSubPaths fps args let isLookForMoves = lookForMoves opts == O.YesLookForMoves && parseFlags O.summary opts /= Just O.NoSummary isLookForAdds = lookForAdds opts == O.YesLookForAdds && parseFlags O.summary opts /= Just O.NoSummary isLookForReplaces = lookForReplaces opts == O.YesLookForReplaces -- LookForAdds and LookForMoves implies Summary, unless it's explcitly disabled. optsModifier = if isLookForAdds then (Summary :) . filter (\o -> LookForAdds /= o && LookForMoves /= o ) else id opts' = optsModifier opts movesPs <- if isLookForMoves then getMovesPs repo files else return NilFL Sealed replacePs <- if isLookForReplaces then getReplaces (diffingOpts opts) repo files else return (Sealed NilFL) Sealed noLookChanges <- filteredUnrecordedChanges opts' repo files movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) pristine <- readRecorded repo -- If we are looking for moves, return the corresponding FL of changes. -- 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 movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine lookAddsTree <- applyAddPatchesToPristine lookChanges 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) announceFiles files "What's new in" exitOnNoChanges (unaddedNewPathsPs, noLookChanges) if maybeIsInteractive opts then runInteractive (interactiveHunks pristine) opts' pristine noLookChanges else do 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 wX wY, FL p wU wV) -> IO () exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!" exitWith $ ExitFailure 1 exitOnNoChanges _ = return () printUnaddedPaths :: PrimPatch p => FL p wX wY -> IO () printUnaddedPaths NilFL = return () printUnaddedPaths ps = putDocLn . lowercaseAs . renderString Encode . 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, ShowPatch p, PrimDetails p, ApplyState p ~ Tree) => [DarcsFlag] -> Tree IO -> FL p wX wY -> IO () printChanges opts' pristine changes | Summary `elem` opts' = putDocLn $ plainSummaryPrims changes | isUnified opts' == O.YesContext = contextualPrintPatch pristine changes | otherwise = printPatch changes -- |return the unrecorded changes that affect an optional list of paths. filteredUnrecordedChanges :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => [DarcsFlag] -> Repository p wR wU wT -> Maybe [SubPath] -> FL (PrimOf p) wR wT -- look-for-moves patches -> FL (PrimOf p) wT wT -- look-for-replaces patches -> IO (Sealed (FL (PrimOf p) wT)) filteredUnrecordedChanges opts' repo files movesPs replacesPs = let filePaths = map toFilePath <$> files in choosePreTouching filePaths <$> unrecordedChangesWithPatches (diffingOpts opts') repo files movesPs replacesPs -- | Runs the 'InteractiveSelectionM' code runInteractive :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, PrimPatch p, PatchInspect p, PrimDetails p, ApplyState p ~ Tree) => InteractiveSelectionM p wX wY () -- Selection to run -> [DarcsFlag] -- Command-line options -> Tree IO -- Pristine -> FL p wX wY -- A list of patches -> IO () runInteractive i opts pristine ps' = do let (choices',lps') = patchChoicesLps ps' let ps = evalStateT i $ ISC { total = lengthFL lps' , current = 0 , lps = FZipper NilRL lps' , choices = choices' } void $ runReaderT ps $ selectionContextPrim First "view" (patchSelOpts opts) (Just primSplitter) Nothing (Just pristine) -- | The interactive part of @darcs whatsnew@ interactiveHunks :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, PatchInspect p, PrimDetails p, ApplyState p ~ Tree) => Tree IO -> InteractiveSelectionM p wX wY () interactiveHunks pristine = do c <- currentPatch case c of Nothing -> liftIO $ putStrLn "No more changes!" Just (Sealed2 lp) -> do liftIO $ printPatch (lpPatch 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 hunk in context 'v' -> liftIO (contextualPrintPatch pristine (lpPatch lp)) >> repeatThis lp -- View summary of the change 'x' -> liftIO (printSummary (lpPatch lp)) >> repeatThis lp -- View hunk and move on 'y' -> liftIO (contextualPrintPatch pristine (lpPatch 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 hunk in a pager 'p' -> liftIO (printPatchPager $ lpPatch lp) >> repeatThis lp -- Next hunk 'j' -> next_hunk -- Previous hunk '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 pristine next_hunk = skipOne >> skipMundane >> interactiveHunks pristine prev_hunk = backOne >> interactiveHunks pristine options_yn = [ KeyPress 'v' "view this hunk in a context" , KeyPress 'y' "view this hunk in a context and go to the next one" , KeyPress 'n' "go to the next hunk" ] optionsView = [ KeyPress 'p' "view this hunk in context wih pager " , KeyPress 'x' "view a summary of this patch" ] optionsNav = [ KeyPress 'q' "quit whatsnew" , KeyPress 's' "skip the rest of the changes to this file" , KeyPress 'j' "skip to the next hunk" , KeyPress 'k' "back up to previous hunk" , KeyPress 'g' "start over from the first hunk" ] basic_options = [ options_yn ] adv_options = [ optionsView, optionsNav ] -- |status is an alias for whatsnew, with implicit Summary and LookForAdds -- flags. We override the default description, to include the implicit flags. status :: DarcsCommand [DarcsFlag] status = statusAlias { commandCommand = statusCmd , commandDescription = statusDesc } where statusAlias = commandAlias "status" Nothing whatsnew statusCmd fps fs = commandCommand whatsnew fps (Summary : LookForAdds : fs) statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '." maybeIsInteractive :: [DarcsFlag] -> Bool maybeIsInteractive = maybe False id . parseFlags O.interactive darcs-2.10.2/src/Darcs/UI/Commands/TransferMode.hs0000644000175000017500000001063012620122474023550 0ustar00guillaumeguillaume00000000000000-- 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 #-} -- The pragma above is only for pattern guards. module Darcs.UI.Commands.TransferMode ( transferMode ) where import Prelude hiding ( catch ) import Control.Exception ( catch ) import System.IO ( stdout, hFlush ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Exception ( prettyException ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.UI.Flags ( DarcsFlag ) import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Progress ( setProgressMode ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Path ( AbsolutePath ) 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" transferModeBasicOpts :: DarcsOption a (Maybe String -> a) transferModeBasicOpts = O.workingRepoDir transferModeOpts :: DarcsOption a (Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) transferModeOpts = transferModeBasicOpts `withStdOpts` oid transferMode :: DarcsCommand [DarcsFlag] transferMode = DarcsCommand { commandProgramName = "darcs" , commandName = "transfer-mode" , commandHelp = transferModeHelp , commandDescription = transferModeDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandGetArgPossibilities = return [] , commandCommand = transferModeCmd , commandPrereq = amInRepository , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc transferModeBasicOpts , commandDefaults = defaultFlags transferModeOpts , commandCheckOptions = ocheck transferModeOpts , commandParseOptions = onormalise transferModeOpts } transferModeCmd :: (AbsolutePath, AbsolutePath) -> [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` (return . Left . prettyException) darcs-2.10.2/src/Darcs/UI/Commands/ShowPatchIndex.hs0000644000175000017500000001306112620122474024050 0ustar00guillaumeguillaume00000000000000module Darcs.UI.Commands.ShowPatchIndex ( showPatchIndexFiles, showPatchIndexAll, showPatchIndexStatus, patchIndexTest ) where import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag, useCache ) import Prelude hiding ( (^) ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository ( withRepository, RepoJob(..) ) import Darcs.Repository.PatchIndex import Control.Arrow () showPatchIndexBasicOpts :: DarcsOption a (Bool -> Bool -> Bool -> Maybe String -> a) showPatchIndexBasicOpts = O.files ^ O.directories ^ O.nullFlag ^ O.workingRepoDir showPatchIndexOpts :: DarcsOption a (Bool -> Bool -> Bool -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) showPatchIndexOpts = showPatchIndexBasicOpts `withStdOpts` oid showPatchIndexAll :: DarcsCommand [DarcsFlag] showPatchIndexAll = DarcsCommand { commandProgramName = "darcs", commandName = "patch-index-all", commandDescription = "Dump complete content of patch index.", commandHelp = "The `darcs show patch-index all' command lists all information in the patch index", commandExtraArgs = 0, commandExtraArgHelp = [], commandCommand = showPatchIndexAllCmd, commandPrereq = amInHashedRepository, commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, commandAdvancedOptions = [], commandBasicOptions = odesc showPatchIndexBasicOpts, commandDefaults = defaultFlags showPatchIndexOpts, commandCheckOptions = ocheck showPatchIndexOpts, commandParseOptions = onormalise showPatchIndexOpts } showPatchIndexFiles :: DarcsCommand [DarcsFlag] showPatchIndexFiles = DarcsCommand { commandProgramName = "darcs", commandName = "patch-index-files", commandDescription = "Dump current files registered in patch index.", commandHelp = "The `darcs show patch-index files' command lists all current files registered in the patch index", commandExtraArgs = 0, commandExtraArgHelp = [], commandCommand = showPatchIndexFilesCmd, commandPrereq = amInHashedRepository, commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, commandAdvancedOptions = [], commandBasicOptions = odesc showPatchIndexBasicOpts, commandDefaults = defaultFlags showPatchIndexOpts, commandCheckOptions = ocheck showPatchIndexOpts, commandParseOptions = onormalise showPatchIndexOpts } showPatchIndexStatus :: DarcsCommand [DarcsFlag] showPatchIndexStatus = DarcsCommand { commandProgramName = "darcs", commandName = "patch-index-status", commandDescription = " Report patch-index status", commandHelp = "The `darcs show patch-index-status' reports if the patch index is in sync, out of sync, or does not exist", commandExtraArgs = 0, commandExtraArgHelp = [], commandCommand = showPatchIndexStatus', commandPrereq = amInHashedRepository, commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, commandAdvancedOptions = [], commandBasicOptions = odesc showPatchIndexBasicOpts, commandDefaults = defaultFlags showPatchIndexOpts, commandCheckOptions = ocheck showPatchIndexOpts, commandParseOptions = onormalise showPatchIndexOpts } patchIndexTest :: DarcsCommand [DarcsFlag] patchIndexTest = DarcsCommand { commandProgramName = "darcs", commandName = "patch-index-test", commandDescription = "Test patch-index", commandHelp = "The `darcs show patch-index-test' tests patch index", commandExtraArgs = 0, commandExtraArgHelp = [], commandCommand = piTest', commandPrereq = amInHashedRepository, commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, commandAdvancedOptions = [], commandBasicOptions = odesc showPatchIndexBasicOpts, commandDefaults = defaultFlags showPatchIndexOpts, commandCheckOptions = ocheck showPatchIndexOpts, commandParseOptions = onormalise showPatchIndexOpts } showPatchIndexAllCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showPatchIndexAllCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \(Repo repodir _ _ _) -> dumpPatchIndex repodir showPatchIndexFilesCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showPatchIndexFilesCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \(Repo repodir _ _ _) -> dumpPatchIndexFiles repodir showPatchIndexStatus' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showPatchIndexStatus' _ opts _ = withRepository (useCache opts) $ RepoJob $ \(repo@(Repo repodir _ _ _)) -> do ex <- doesPatchIndexExist repodir 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" piTest' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () piTest' _ opts _ = withRepository (useCache opts) $ RepoJob piTest darcs-2.10.2/src/Darcs/UI/Commands/Add.hs0000644000175000017500000003361412620122474021656 0ustar00guillaumeguillaume00000000000000-- 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 {-# LANGUAGE CPP #-} module Darcs.UI.Commands.Add ( add , expandDirs ) where #include "impossible.h" import Prelude hiding ( (^), catch ) import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless, liftM ) import Data.List ( (\\), nub ) import Data.List.Ordered ( nubSort ) import Data.Maybe ( isNothing, maybeToList ) import Darcs.Util.Printer ( text ) import Storage.Hashed.Tree ( Tree, findTree, expand ) import Darcs.Util.Path ( floatPath, anchorPath, parents, SubPath, toFilePath, simpleSubPath, toPath, AbsolutePath ) 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.UI.Commands ( DarcsCommand(..), withStdOpts, putInfo, putWarning, putVerboseWarning , nodefaults, amInHashedRepository) import Darcs.UI.Flags ( DarcsFlag , includeBoring, doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask , fixSubPaths, verbosity ) import Darcs.UI.Options ( DarcsOption , (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase ) import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.Patch ( Patchy, PrimPatch, applyToTree, addfile, adddir ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Repository.State ( readRecordedAndPending, updateIndex ) import Darcs.Repository ( withRepoLock , RepoJob(..) , addToPending , listFiles , listUnregisteredFiles ) import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter ) import Darcs.Util.File ( getFileStatus, withCurrentDirectory ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL ) import Darcs.Patch.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" addBasicOpts :: DarcsOption a (Bool -> Bool -> Bool -> Bool -> Maybe String -> O.DryRun -> a) addBasicOpts = O.includeBoring ^ O.allowProblematicFilenames ^ O.recursive ^ O.workingRepoDir ^ O.dryRun addAdvancedOpts :: DarcsOption a (O.UMask -> a) addAdvancedOpts = O.umask addOpts :: DarcsOption a (Bool -> Bool -> Bool -> Bool -> Maybe String -> O.DryRun -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) addOpts = withStdOpts addBasicOpts addAdvancedOpts add :: DarcsCommand [DarcsFlag] add = DarcsCommand { commandProgramName = "darcs" , commandName = "add" , commandHelp = addHelp ++ addHelp' , commandDescription = addDescription , commandExtraArgs = -1 , commandExtraArgHelp = [ " ..." ] , commandCommand = addCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = listUnregisteredFiles False -- bash completion should not offer boring files , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc addAdvancedOpts , commandBasicOptions = odesc addBasicOpts , commandDefaults = defaultFlags addOpts , commandCheckOptions = ocheck addOpts , commandParseOptions = onormalise addOpts } addCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () addCmd paths opts args | null args = putStrLn $ "Nothing specified, nothing added." ++ "Maybe you wanted to say `darcs add --recursive .'?" | otherwise = do fs <- fixSubPaths paths args case fs of [] -> fail "No valid arguments were given" _ -> addFiles opts fs addFiles :: [DarcsFlag] -- ^ Command options -> [SubPath] -> IO () addFiles opts origfiles = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (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 =<< readRecordedAndPending repository let parlist = getParents cur (map toFilePath origfiles) flist' <- if parseFlags O.recursive opts then expandDirs (includeBoring opts) origfiles else return origfiles let flist = nubSort (parlist ++ toFilePath `map` flist') nboring <- if includeBoring opts then return darcsdirFilter else boringFileFilter mapM_ (putWarning opts . text . ((msgSkipping msgs ++ " boring file ")++)) $ flist \\ nboring flist Sealed ps <- fmap unFreeLeft $ addp msgs opts cur $ nboring flist when (nullFL ps && not (null origfiles) && notQuiet) $ fail "No files were added" unless gotDryRun $ do addToPending repository YesUpdateWorking ps updateIndex repository where gotDryRun = dryRun opts == O.YesDryRun msgs | gotDryRun = dryRunMessages | otherwise = normalMessages notQuiet = verbosity opts /= O.Quiet 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 $ "WARNING: Some files were not added because they are already in the repository." putVerboseWarning opts . text $ dupMsg ++ caseMsg mapM_ (putVerboseWarning 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 putInfo 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 :: Bool -> [SubPath] -> IO [SubPath] expandDirs doIncludeBoring fs = do liftM (map (fromJust . simpleSubPath)) $ concat `fmap` mapM (expandOne doIncludeBoring . toPath) fs expandOne :: Bool -> FilePath -> IO [FilePath] expandOne doIncludeBoring "" = listFiles doIncludeBoring expandOne doIncludeBoring f = do isdir <- doesDirectoryReallyExist f if not isdir then return [f] else do fs <- withCurrentDirectory f (listFiles doIncludeBoring) 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 darcs-2.10.2/src/Darcs/UI/Commands/Amend.hs0000644000175000017500000004653512620122474022220 0ustar00guillaumeguillaume00000000000000-- 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 module Darcs.UI.Commands.Amend ( amend , amendrecord , updatePatchHeader ) where import Prelude hiding ( (^) ) import Data.Maybe ( isNothing, isJust ) import Control.Applicative ( (<$>) ) import Control.Monad ( unless, when ) import System.Exit ( exitSuccess ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , commandAlias , nodefaults , setEnvDarcsFiles , setEnvDarcsPatches , amInHashedRepository ) import Darcs.UI.Commands.Record ( getLog ) import Darcs.UI.Commands.Util ( announceFiles, testTentativeAndMaybeExit ) import Darcs.UI.Flags ( DarcsFlag , diffOpts, fixSubPaths, getEasyAuthor, promptAuthor, getDate ) import Darcs.UI.Options ( DarcsOption, (^), oparse, odesc, ocheck, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) ) import Darcs.Patch ( RepoPatch, description, PrimOf, fromPrims, infopatch, getdeps, adddeps, effect, invert, invertFL ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString, 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.Patch.Rebase.Fixup ( RebaseFixup(..) ) import Darcs.Patch.Rebase.Name ( RebaseName(..) ) import Darcs.Util.Path ( toFilePath, SubPath(), AbsolutePath ) import Darcs.Repository ( Repository , withRepoLock , RepoJob(..) , tentativelyRemovePatches , tentativelyAddPatch , withManualRebaseUpdate , finalizeRepositoryChanges , invalidateIndex , unrecordedChangesWithPatches , readRecorded , listRegisteredFiles ) import Darcs.Repository.Prefs ( globalPrefsDirDoc ) import Darcs.Repository.Util ( getMovesPs, getReplaces ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(..) , selectionContextPrim , runSelection , withSelectedPatchFromRepo , askAboutDepends ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Prompt ( askUser ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL, reverseRL, mapFL_FL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.Printer ( putDocLn ) import Storage.Hashed.Tree( Tree ) import Darcs.Repository.Internal ( tentativelyRemoveFromPending ) amendDescription :: String amendDescription = "Improve a patch before it leaves your repository." amendHelp :: String amendHelp = "Amend updates a \"draft\" patch with additions or improvements,\n" ++ "resulting in a single \"finished\" patch.\n" ++ "\n" ++ "By default `amend` proposes you to record additional changes.\n" ++ "If instead you want to remove changes, use the flag `--unrecord`.\n" ++ "\n" ++ "When recording a draft patch, it is a good idea to start the name with\n" ++ "`DRAFT:`. When done, remove it with `darcs amend --edit-long-comment`.\n" ++ "Alternatively, to change the patch name without starting an editor, \n" ++ "use the `--name`/`-m` flag:\n" ++ "\n" ++ " darcs amend --match 'name \"DRAFT: foo\"' --name 'foo2'\n" ++ "\n" ++ "Like `darcs record`, if you call amend 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 --match 'touch foo.c' bar.c\n" ++ "\n" ++ "It is usually a bad idea to amend another developer's patch. To make\n" ++ "amend only ask about your own patches by default, you can add\n" ++ "something like `amend match David Roundy` to `" ++ globalPrefsDirDoc ++ "defaults`, \n" ++ "where `David Roundy` is your name.\n" amendBasicOpts :: DarcsOption a (Bool -> [O.MatchFlag] -> O.TestChanges -> Maybe Bool -> Maybe String -> Bool -> Maybe String -> Bool -> Maybe O.AskLongComment -> Bool -> O.LookFor -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> a) amendBasicOpts = O.amendUnrecord ^ O.matchOneNontag ^ O.testChanges ^ O.interactive --True ^ O.author ^ O.selectAuthor ^ O.patchname ^ O.askdeps ^ O.askLongComment ^ O.keepDate ^ O.lookfor ^ O.workingRepoDir ^ O.withContext ^ O.diffAlgorithm amendAdvancedOpts :: DarcsOption a (O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> a) amendAdvancedOpts = O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable amendOpts :: DarcsOption a (Bool -> [O.MatchFlag] -> O.TestChanges -> Maybe Bool -> Maybe String -> Bool -> Maybe String -> Bool -> Maybe O.AskLongComment -> Bool -> O.LookFor -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) amendOpts = withStdOpts amendBasicOpts amendAdvancedOpts data AmendConfig = AmendConfig { amendUnrecord :: Bool , matchFlags :: [O.MatchFlag] , testChanges :: O.TestChanges , interactive :: Maybe Bool , author :: Maybe String , selectAuthor :: Bool , patchname :: Maybe String , askDeps :: Bool , askLongComment :: Maybe O.AskLongComment , keepDate :: Bool , lookfor :: O.LookFor , _workingRepoDir :: Maybe String , withContext :: O.WithContext , diffAlgorithm :: O.DiffAlgorithm , verbosity :: O.Verbosity , compress :: O.Compression , useIndex :: O.UseIndex , umask :: O.UMask , sse :: O.SetScriptsExecutable , useCache :: O.UseCache } amendConfig :: [DarcsFlag] -> AmendConfig amendConfig = oparse (amendBasicOpts ^ O.verbosity ^ amendAdvancedOpts ^ O.useCache) AmendConfig amend :: DarcsCommand AmendConfig amend = DarcsCommand { commandProgramName = "darcs" , commandName = "amend" , commandHelp = amendHelp , commandDescription = amendDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = amendCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = listRegisteredFiles , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc amendAdvancedOpts , commandBasicOptions = odesc amendBasicOpts , commandDefaults = defaultFlags amendOpts , commandCheckOptions = ocheck amendOpts , commandParseOptions = amendConfig } amendrecord :: DarcsCommand AmendConfig amendrecord = commandAlias "amend-record" Nothing amend amendCmd :: (AbsolutePath, AbsolutePath) -> AmendConfig -> [String] -> IO () amendCmd _ cfg [] = doAmend cfg Nothing amendCmd fps cfg args = do files <- fixSubPaths fps args if null files then fail "No valid arguments were given, nothing to do." else doAmend cfg $ Just files doAmend :: AmendConfig -> Maybe [SubPath] -> IO () doAmend cfg files = withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ RebaseAwareJob (compress cfg) (verbosity cfg) YesUpdateWorking $ \(repository :: Repository p wR wU wR) -> withSelectedPatchFromRepo "amend" repository (patchSelOpts cfg) $ \ (_ :> 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 wU1 . FL (PrimOf p) wR wU1 -> IO () go NilFL | not (hasEditMetadata cfg) = putStrLn "No changes!" go ch = do let context = selectionContextPrim First "record" (patchSelOpts cfg) --([All,Unified] `intersect` opts) (Just primSplitter) (map toFilePath <$> files) (Just pristine) (chosenPatches :> _) <- runSelection (selectChanges ch) context addChangesToPatch cfg repository oldp chosenPatches if not (isTag (info oldp)) -- amending a normal patch then if amendUnrecord cfg then do let sel = selectChanges (effect oldp) context = selectionContextPrim Last "unrecord" (patchSelOpts cfg) -- ([All,Unified] `intersect` opts) (Just primSplitter) (map toFilePath <$> files) (Just pristine) (_ :> chosenPrims) <- runSelection sel context let invPrims = reverseRL (invertFL chosenPrims) addChangesToPatch cfg repository oldp invPrims else do Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces then getReplaces (diffingOpts cfg) repository files else return (Sealed NilFL) movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves then getMovesPs repository files else return NilFL go =<< unrecordedChangesWithPatches (diffingOpts cfg) repository files movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) -- 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 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)." go NilFL addChangesToPatch :: forall p wR wU wT wX wY . (RepoPatch p, ApplyState p ~ Tree) => AmendConfig -> Repository p wR wU wT -> PatchInfoAnd p wX wT -> FL (PrimOf p) wT wY -> IO () addChangesToPatch cfg repository oldp chs = if nullFL chs && not (hasEditMetadata cfg) then putStrLn "You don't want to record anything!" else do invalidateIndex 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 -- the normal commute rules for the rebase state 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 (compress cfg) (verbosity cfg) YesUpdateWorking repository $ \repository' -> do repository'' <- tentativelyRemovePatches repository' (compress cfg) YesUpdateWorking (oldp :>: NilFL) (mlogf, newp) <- updatePatchHeader (askDeps cfg) (patchSelOpts cfg) (keepDate cfg) (selectAuthor cfg) (author cfg) (patchname cfg) (askLongComment cfg) repository'' oldp chs let fixups = mapFL_FL PrimFixup (invert chs) +>+ NameFixup (Rename (info newp) (info oldp)) :>: NilFL setEnvDarcsFiles newp repository''' <- tentativelyAddPatch repository'' (compress cfg) (verbosity cfg) YesUpdateWorking newp return (repository''', fixups, (mlogf, newp)) let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf testTentativeAndMaybeExit repository''' (verbosity cfg) (testChanges cfg) (sse cfg) (isInteractive True cfg) ("you have a bad patch: '" ++ patchDesc newp ++ "'") "amend it" (Just failmsg) when (O.moves (lookfor cfg) == O.YesLookForMoves || O.replaces (lookfor cfg) == O.YesLookForReplaces) $ tentativelyRemoveFromPending repository''' YesUpdateWorking oldp finalizeRepositoryChanges repository''' YesUpdateWorking (compress cfg) `clarifyErrors` failmsg putStrLn "Finished amending patch:" putDocLn $ description newp setEnvDarcsPatches (newp :>: NilFL) updatePatchHeader :: forall p wX wY wR wU wT . (RepoPatch p, ApplyState p ~ Tree) => Bool -- askDeps -> S.PatchSelectionOptions -> Bool -- keepDate -> Bool -- selectAuthor -> Maybe String -- author -> Maybe String -- patchname -> Maybe O.AskLongComment -> Repository p wR wU wT -> PatchInfoAnd p wT wX -> FL (PrimOf p) wX wY -> IO (Maybe String, PatchInfoAnd p wT wY) updatePatchHeader ask_deps pSelOpts nKeepDate nSelectAuthor nAuthor nPatchname nAskLongComment repository oldp chs = do let newchs = canonizeFL (S.diffAlgorithm pSelOpts) (effect oldp +>+ chs) let old_pdeps = getdeps $ hopefully oldp newdeps <- if ask_deps then askAboutDepends repository newchs pSelOpts old_pdeps else return old_pdeps let old_pinf = info oldp prior = (piName old_pinf, piLog old_pinf) old_author = piAuthor old_pinf date <- if nKeepDate then return (piDateString old_pinf) else getDate False (new_author,edit_author) <- getAuthor nSelectAuthor nAuthor old_author warnIfHijacking old_author edit_author (new_name, new_log, mlogf) <- getLog nPatchname False (O.Logfile Nothing False) nAskLongComment (Just prior) chs let 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 :: String -- Original author -> Bool -- Author change requested by options -> IO () warnIfHijacking old_author edit_author = do authors_here <- getEasyAuthor unless (edit_author || old_author `elem` authors_here) $ do yorn <- askUser $ "You're not " ++ old_author ++"! Amend anyway? " case yorn of ('y':_) -> return () _ -> exitSuccess hasEditMetadata :: AmendConfig -> Bool hasEditMetadata cfg = isJust (author cfg) || selectAuthor cfg || isJust (patchname cfg) || askLongComment cfg == Just O.YesEditLongComment || askLongComment cfg == Just O.PromptLongComment || askDeps cfg -- hasEditMetadata [] = False -- hasEditMetadata (Author _:_) = True -- hasEditMetadata (SelectAuthor:_) = True -- hasEditMetadata (LogFile _:_) = True -- ??? not listed as an option for amend -- hasEditMetadata (PatchName _:_) = True -- hasEditMetadata (EditLongComment:_) = True -- hasEditMetadata (PromptLongComment:_) = True -- hasEditMetadata (AskDeps:_) = True -- hasEditMetadata (_:fs) = hasEditMetadata fs getAuthor :: Bool -> Maybe String -> String -> IO (String,Bool) getAuthor True _ _ = do a <- promptAuthor False True return (a,True) getAuthor False (Just a) _ = return (a,True) getAuthor False Nothing old = return (old,False) -- getAuthor (SelectAuthor:_) _ = do -- a <- promptAuthor False True -- return (a,True) -- getAuthor (Author a:_) _ = return (a,True) -- getAuthor (_:as) old = getAuthor as old -- getAuthor [] old = return (old,False) patchSelOpts :: AmendConfig -> S.PatchSelectionOptions patchSelOpts cfg = S.PatchSelectionOptions { S.verbosity = verbosity cfg , S.matchFlags = matchFlags cfg , S.diffAlgorithm = diffAlgorithm cfg , S.interactive = isInteractive True cfg , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = withContext cfg } diffingOpts :: AmendConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) False (diffAlgorithm cfg) isInteractive :: Bool -> AmendConfig -> Bool isInteractive def = maybe def id . interactive darcs-2.10.2/src/Darcs/UI/Commands/Record.hs0000644000175000017500000006013612620122474022403 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Record ( record , commit , getLog -- used by amend and tag, too , recordConfig, RecordConfig(..) -- needed for darcsden ) where import Prelude hiding ( (^), catch ) import Control.Applicative ( (<$>) ) import Control.Exception ( handleJust, catch, IOException ) import Control.Monad ( when, unless, void ) import System.IO ( stdin ) import Data.List ( sort, isPrefixOf ) import Data.Char ( ord ) import System.Exit ( exitFailure, exitSuccess, ExitCode(..) ) import System.Directory ( removeFile ) import qualified Data.ByteString as B ( hPut ) import Darcs.Repository.Lock ( readLocaleFile , writeLocaleFile , appendToFile ) import Darcs.Patch.PatchInfoAnd ( n2pia ) import Darcs.Repository ( Repository , withRepoLock , RepoJob(..) , tentativelyAddPatch , finalizeRepositoryChanges , invalidateIndex , unrecordedChangesWithPatches , readRecorded , listRegisteredFiles ) import Darcs.Patch ( RepoPatch, Patchy, PrimOf, PrimPatch , namepatch, summaryFL, adddeps, fromPrims ) import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), nullFL ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Split ( primSplitter ) import Darcs.UI.External ( editFile ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(..) , selectionContextPrim , runSelection , askAboutDepends ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Util.Path ( FilePathLike, SubPath, toFilePath, AbsolutePath ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , nodefaults , commandStub , setEnvDarcsFiles , setEnvDarcsPatches , amInHashedRepository ) import Darcs.UI.Commands.Util ( announceFiles, filterExistingFiles, testTentativeAndMaybeExit ) import Darcs.UI.Flags ( DarcsFlag , fileHelpAuthor , getAuthor , getDate , diffOpts , fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, oparse, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..), DryRun(NoDryRun) ) import Darcs.Repository.Util ( getMovesPs, getReplaces ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Prompt ( askUser, promptYorn ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Global ( darcsLastMessage ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Util.Printer ( putDocLn, hPutDocLn, text, ($$), prefixLines, RenderMode(..) ) import Darcs.Util.ByteString ( encodeLocale ) import qualified Darcs.Util.Ratified as Ratified ( hGetContents ) import Storage.Hashed.Tree( Tree ) 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'' recordBasicOpts :: DarcsOption a (Maybe String -> Maybe String -> O.TestChanges -> Maybe Bool -> Bool -> Bool -> Maybe O.AskLongComment -> O.LookFor -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> a) recordBasicOpts = O.patchname ^ O.author ^ O.testChanges ^ O.interactive ^ O.pipe ^ O.askdeps ^ O.askLongComment ^ O.lookfor ^ O.workingRepoDir ^ O.withContext ^ O.diffAlgorithm recordAdvancedOpts :: DarcsOption a (O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> a) recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable recordOpts :: DarcsOption a (Maybe String -> Maybe String -> O.TestChanges -> Maybe Bool -> Bool -> Bool -> Maybe O.AskLongComment -> O.LookFor -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts data RecordConfig = RecordConfig { patchname :: Maybe String , author :: Maybe String , testChanges :: O.TestChanges , interactive :: Maybe Bool , pipe :: Bool , askDeps :: Bool , askLongComment :: Maybe O.AskLongComment , lookfor :: O.LookFor , _workingRepoDir :: Maybe String , withContext :: O.WithContext , diffAlgorithm :: O.DiffAlgorithm , verbosity :: O.Verbosity , logfile :: O.Logfile , compress :: O.Compression , useIndex :: O.UseIndex , umask :: O.UMask , sse :: O.SetScriptsExecutable , useCache :: O.UseCache } recordConfig :: [DarcsFlag] -> RecordConfig recordConfig = oparse (recordBasicOpts ^ O.verbosity ^ recordAdvancedOpts ^ O.useCache) RecordConfig record :: DarcsCommand RecordConfig 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 = odesc recordAdvancedOpts , commandBasicOptions = odesc recordBasicOpts , commandDefaults = defaultFlags recordOpts , commandCheckOptions = ocheck recordOpts , commandParseOptions = recordConfig } 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 RecordConfig commit = commandStub "commit" commitHelp commitDescription record recordCmd :: (AbsolutePath, AbsolutePath) -> RecordConfig -> [String] -> IO () recordCmd fps cfg args = do checkNameIsNotOption (patchname cfg) (isInteractive True cfg) withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do files <- if null args then return Nothing else Just . sort <$> fixSubPaths fps args when (files == Just []) $ fail "No valid arguments were given." announceFiles files "Recording changes in" existing_files <- maybe (return Nothing) (fmap Just . filterExistingFiles repository (O.adds (lookfor cfg))) files when (existing_files == Just []) $ fail "None of the files you specified exist!" debugMessage "About to get the unrecorded changes." Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces then getReplaces (diffingOpts cfg) repository files else return (Sealed NilFL) movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves then getMovesPs repository files else return NilFL changes <- unrecordedChangesWithPatches (diffingOpts cfg) repository files movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) debugMessage "I've got unrecorded changes." case changes of NilFL | not (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 (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 = when (length name == 1 || (length name == 2 && head name == '-')) $ 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, ApplyState (PrimOf p) ~ Tree) => Repository p wR wU wR -> RecordConfig -> Maybe [SubPath] -> FL (PrimOf p) wR wX -> IO () doRecord repository cfg files ps = do date <- getDate (pipe cfg) my_author <- getAuthor (author cfg) (pipe cfg) debugMessage "I'm slurping the repository." debugMessage "About to select changes..." pristine <- readRecorded repository (chs :> _ ) <- runSelection (selectChanges ps) $ selectionContextPrim First "record" (patchSelOpts cfg) (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!" exitSuccess handleJust onlySuccessfulExits (\_ -> return ()) $ do deps <- if askDeps cfg then askAboutDepends repository chs (patchSelOpts cfg) [] else return [] when (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 (patchname cfg) (pipe cfg) (logfile cfg) (askLongComment cfg) Nothing chs debugMessage ("Patch name as received from getLog: " ++ show (map ord name)) doActualRecord repository cfg name date my_author my_log logf deps chs where is_empty_but_not_askdeps l | askDeps cfg = False -- a "partial tag" patch; see below. | otherwise = nullFL l doActualRecord :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> RecordConfig -> String -> String -> String -> [String] -> Maybe String -> [PatchInfo] -> FL (PrimOf p) wR wX -> IO () doActualRecord repository cfg 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 let pia = n2pia $ adddeps mypatch deps -- We don't care about the returned updated repository _ <- tentativelyAddPatch repository (compress cfg) (verbosity cfg) YesUpdateWorking $ pia invalidateIndex repository debugMessage "Applying to pristine..." testTentativeAndMaybeExit repository (verbosity cfg) (testChanges cfg) (sse cfg) (isInteractive True cfg) ("you have a bad patch: '" ++ name ++ "'") "record it" (Just failuremessage) finalizeRepositoryChanges repository YesUpdateWorking (compress cfg) `clarifyErrors` failuremessage debugMessage "Syncing timestamps..." removeLogFile logf unless (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 -> "" recordHelp' :: String recordHelp' = unlines [ "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)." , "" , "The patch name should be a short sentence that concisely describes the" , "patch, such as \"Add error handling to main event loop.\" You can" , "supply it in advance with the `-m` option, in which case no text editor" , "is launched, unless you use the `--edit-long-comment` option." , "" , "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 patch description. This is" , "useful if a previous record failed and left a `darcs-record-0` file." , "" , unlines fileHelpAuthor , "" , "If you want to manually define any extra dependencies for your patch," , "you can use the `--ask-deps` flag, and darcs will ask you for the patch's" , "dependencies. 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 (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 `--pipe`" , "prompts look like:" , "" , " 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" ] data PName = FlagPatchName String | PriorPatchName String | NoPatchName -- | 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 :: forall prim wX wY . (Patchy prim, PrimPatch prim) => 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 -> FL prim wX wY -- ^ 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 = go has_pipe log_file ask_long where go True _ _ = 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) go _ (O.Logfile { O._logfile = Just f }) _ = do mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return []) firstname <- case (patchname_specified, mlp) of (FlagPatchName p, []) -> return p (_, p:_) -> if 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 -> actually_get_log p PriorPatchName p -> actually_get_log p NoPatchName -> actually_get_log "" go _ _ (Just O.NoEditLongComment) = case patchname_specified of 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) go _ _ (Just O.PromptLongComment) = case patchname_specified of FlagPatchName 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 -> return (p, default_log, Nothing) -- record (or amend) -m PriorPatchName "" -> actually_get_log "" PriorPatchName p -> return (p, default_log, Nothing) NoPatchName -> actually_get_log "" patchname_specified = case (m_name, m_old) of (Just name, _) | badName name -> NoPatchName | otherwise -> FlagPatchName name (Nothing, Just (name,_)) -> PriorPatchName name (Nothing, Nothing) -> NoPatchName badName "" = True badName n = "TAG" `isPrefixOf` n default_log = case m_old of Nothing -> [] Just (_,l) -> l prompt_patchname retry = do n <- askUser "What is the patch name? " if badName 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 let logf = darcsLastMessage -- 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 _ <- editFile logf (name,long) <- read_long_comment logf p if badName name then do putStrLn "WARNING: empty or incorrect patch name!" pn <- prompt_patchname True return (pn, long, Nothing) else return (name,long,Just logf) read_long_comment :: FilePathLike p => p -> String -> IO (String, [String]) read_long_comment f oldname = do f' <- readLocaleFile f let t = filter (not.("#" `isPrefixOf`)) $ (lines.filter (/='\r')) f' case t of [] -> return (oldname, []) (n:ls) -> return (n, ls) 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 Encode h $ 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 "# This patch contains the following changes:" $$ text "#" $$ prefixLines (text "#") (summaryFL chs) 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 clone` for an explanation of the script heuristic.\n" ++ "\n" ++ "If your test command is tediously slow (e.g. `make all`) and you are\n" ++ "recording several patches in a row, you may wish to use `--no-test` to\n" ++ "skip all but the final test.\n" ++ "\n" ++ "To see some context (unchanged lines) around each change, use the\n" ++ "`--unified` option.\n" patchSelOpts :: RecordConfig -> S.PatchSelectionOptions patchSelOpts cfg = S.PatchSelectionOptions { S.verbosity = verbosity cfg , S.matchFlags = [] , S.diffAlgorithm = diffAlgorithm cfg , S.interactive = isInteractive True cfg , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = withContext cfg } diffingOpts :: RecordConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) False (diffAlgorithm cfg) isInteractive :: Bool -> RecordConfig -> Bool isInteractive def = maybe def id . interactive darcs-2.10.2/src/Darcs/UI/Commands/Repair.hs0000644000175000017500000001703412620122474022406 0ustar00guillaumeguillaume00000000000000-- 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.Repair ( repair , check ) 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 System.FilePath ( () ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putInfo, commandAlias, amInHashedRepository ) import Darcs.UI.Flags as F ( DarcsFlag(Quiet,DryRun) , verbosity, dryRun, umask, useIndex , useCache, compression, diffAlgorithm ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..) ) import Darcs.Repository.Repair( replayRepository, checkIndex, replayRepositoryInTemp, RepositoryConsistency(..) ) import Darcs.Repository ( Repository, withRepository, readRecorded, RepoJob(..), withRepoLock, replacePristine, writePatchSet ) import Darcs.Patch ( RepoPatch, showPatch, PrimOf ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Repository.Diff( treeDiff ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Printer ( text, ($$), (<+>) ) import Darcs.Util.Path ( AbsolutePath ) import Storage.Hashed.Tree( Tree ) 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" ++ "This command rebuilds a pristine tree by applying successively the\n" ++ "patches in the repository to an empty tree.\n" ++ "\n" ++ "The flag `--dry-run` make this operation read-only, making darcs exit\n" ++ "unsuccessfully (with a non-zero exit status) if the rebuilt pristine is\n" ++ "different from the current pristine.\n" repairBasicOpts :: DarcsOption a (Maybe String -> O.UseIndex -> O.DryRun -> O.DiffAlgorithm -> a) repairBasicOpts = O.workingRepoDir ^ O.useIndex ^ O.dryRun ^ O.diffAlgorithm repairAdvancedOpts :: DarcsOption a (O.UMask -> a) repairAdvancedOpts = O.umask repairOpts :: DarcsOption a (Maybe String -> O.UseIndex -> O.DryRun -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) repairOpts = repairBasicOpts `withStdOpts` repairAdvancedOpts repair :: DarcsCommand [DarcsFlag] repair = DarcsCommand { commandProgramName = "darcs" , commandName = "repair" , commandHelp = repairHelp , commandDescription = repairDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = repairCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc repairAdvancedOpts , commandBasicOptions = odesc repairBasicOpts , commandDefaults = defaultFlags repairOpts , commandCheckOptions = ocheck repairOpts , commandParseOptions = onormalise repairOpts } repairCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () repairCmd _ opts _ | DryRun `elem` opts = withRepository (useCache opts) (RepoJob (check' opts)) | otherwise = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do replayRepository (F.diffAlgorithm opts) repository (compression opts) (verbosity 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 (useCache opts) putStrLn "Fixing pristine tree..." replacePristine repository tree index_ok <- checkIndex repository (Quiet `elem` opts) unless index_ok $ do renameFile (darcsdir "index") (darcsdir "index.bad") putStrLn "Bad index discarded." check' :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository p wR wU wT -> IO () check' opts repository = do state <- replayRepositoryInTemp (F.diffAlgorithm opts) repository (compression opts) (verbosity opts) failed <- case state of RepositoryConsistent -> do putInfo opts $ text "The repository is consistent!" return False BrokenPristine newpris -> do brokenPristine newpris return True BrokenPatches newpris _ -> do brokenPristine newpris putInfo opts $ text "Found broken patches." return True bad_index <- if useIndex opts == O.IgnoreIndex then return False else not <$> checkIndex repository (Quiet `elem` opts) 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' <- (Just `fmap` 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" Just mc -> do ftf <- filetypeFunction Sealed (diff :: FL (PrimOf p) wR wR2) <- unFreeLeft `fmap` treeDiff (F.diffAlgorithm opts) ftf newpris mc :: IO (Sealed (FL (PrimOf p) wR)) putInfo opts $ case diff of NilFL -> text "Nothing" patch -> text "Difference: " <+> showPatch patch putInfo opts $ text "" $$ text "Inconsistent repository!" -- |check is an alias for repair, with implicit DryRun flag. check :: DarcsCommand [DarcsFlag] check = checkAlias { commandCommand = checkCmd , commandDescription = checkDesc } where checkAlias = commandAlias "check" Nothing repair checkCmd fps fs = commandCommand repair fps (DryRun : fs) checkDesc = "Alias for `darcs " ++ commandName repair ++ " --dry-run'." darcs-2.10.2/src/Darcs/UI/Commands/Init.hs0000644000175000017500000001115412620122474022064 0ustar00guillaumeguillaume00000000000000-- 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.Init ( initialize, initializeCmd ) where import Prelude hiding ( (^) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amNotInRepository, putInfo, formatPath ) import Darcs.UI.Flags ( DarcsFlag( WorkRepoDir ), withWorkingDir, patchFormat, runPatchIndex ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O ( patchFormat, useWorkingDir, workingRepoDir, patchIndex, hashed , PatchFormat, WithWorkingDir, WithPatchIndex , StdCmdAction, Verbosity, UseCache, PatchFormat(..) ) import Darcs.UI.Options.All ( ) import Darcs.Util.Printer ( text ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Repository ( createRepository ) initializeDescription :: String initializeDescription = "Make the current directory or the specified 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 `--darcs-1`, 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" initBasicOpts :: DarcsOption a (O.PatchFormat -> O.WithWorkingDir -> Maybe String -> a) initBasicOpts = O.patchFormat ^ O.useWorkingDir ^ O.workingRepoDir initAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> () -> a) initAdvancedOpts = O.patchIndex ^ O.hashed initOpts :: DarcsOption a (O.PatchFormat -> O.WithWorkingDir -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.WithPatchIndex -> () -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) initOpts = initBasicOpts `withStdOpts` initAdvancedOpts initialize :: DarcsCommand [DarcsFlag] initialize = DarcsCommand { commandProgramName = "darcs" , commandName = "initialize" , commandHelp = initializeHelp , commandDescription = initializeDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[]"] , commandPrereq = \_ -> return $ Right () , commandCommand = initializeCmd , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc initAdvancedOpts , commandBasicOptions = odesc initBasicOpts , commandDefaults = defaultFlags initOpts , commandCheckOptions = ocheck initOpts , commandParseOptions = onormalise initOpts } initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () initializeCmd aps opts [outname] | null [ () | WorkRepoDir _ <- opts ] = initializeCmd aps (WorkRepoDir outname:opts) [] initializeCmd _ opts [] = do location <- amNotInRepository opts case location of Left msg -> fail $ "Unable to " ++ formatPath ("darcs " ++ commandName initialize) ++ " here.\n\n" ++ msg Right () -> do createRepository (patchFormat opts == O.PatchFormat1) (withWorkingDir opts) (runPatchIndex opts) putInfo opts $ text "Repository initialized." initializeCmd _ _ _ = fail "You must provide 'initialize' with either zero or one argument." darcs-2.10.2/src/Darcs/UI/Commands/Unrevert.hs0000644000175000017500000002060712620122474022776 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.UI.Commands.Unrevert ( unrevert, writeUnrevert ) where import Prelude hiding ( (^), catch ) import Control.Exception ( catch, IOException ) import System.Exit ( exitSuccess ) import Storage.Hashed.Tree( Tree ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags ( diffingOpts, verbosity, useCache, umask, compression, diffAlgorithm , isInteractive, isUnified ) import Darcs.Repository.Flags ( UseIndex(..), ScanKnown (..), Reorder(..), AllowConflicts(..), ExternalMerge(..) , WantGuiPause(..), UpdateWorking(..), DryRun(NoDryRun) ) import Darcs.UI.Flags ( DarcsFlag ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..), unrevertUrl, considerMergeToWorking, tentativelyAddToPending, finalizeRepositoryChanges, readRepo, readRecorded, applyToWorking, unrecordedChanges ) import Darcs.Patch ( RepoPatch, PrimOf, commute, namepatch, fromPrims ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (+>+) ) import Darcs.UI.SelectChanges ( selectChanges , WhichChanges(First) , runSelection , selectionContextPrim ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import qualified Data.ByteString as B import Darcs.Repository.Lock ( writeDocBinFile, removeFileMayNotExist ) import Darcs.Patch.Depends ( mergeThem ) import Darcs.UI.External ( catchall ) import Darcs.Util.Prompt ( askUser ) import Darcs.Patch.Bundle ( scanBundle, makeBundleN ) import Darcs.Util.IsoDate ( getIsoDateTime ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Path ( AbsolutePath ) #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" unrevertBasicOpts :: DarcsOption a (O.UseIndex -> Maybe Bool -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> a) unrevertBasicOpts = O.useIndex ^ O.interactive -- True ^ O.workingRepoDir ^ O.withContext ^ O.diffAlgorithm unrevertAdvancedOpts :: DarcsOption a (O.UMask -> a) unrevertAdvancedOpts = O.umask unrevertOpts :: DarcsOption a (UseIndex -> Maybe Bool -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) unrevertOpts = unrevertBasicOpts `withStdOpts` unrevertAdvancedOpts patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = [] , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = isUnified flags } unrevert :: DarcsCommand [DarcsFlag] unrevert = DarcsCommand { commandProgramName = "darcs" , commandName = "unrevert" , commandHelp = unrevertHelp , commandDescription = unrevertDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = unrevertCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc unrevertAdvancedOpts , commandBasicOptions = odesc unrevertBasicOpts , commandDefaults = defaultFlags unrevertOpts , commandCheckOptions = ocheck unrevertOpts , commandParseOptions = onormalise unrevertOpts } unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unrevertCmd _ opts [] = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do us <- readRepo repository Sealed them <- unrevertPatchBundle repository recorded <- readRecorded repository unrecorded <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository Nothing Sealed h_them <- return $ mergeThem us them Sealed pw <- considerMergeToWorking repository "unrevert" YesAllowConflictsAndMark YesUpdateWorking NoExternalMerge NoWantGuiPause (compression opts) (verbosity opts) NoReorder ( UseIndex, ScanKnown, diffAlgorithm opts ) NilFL h_them let context = selectionContextPrim First "unrevert" (patchSelOpts opts) Nothing Nothing (Just recorded) (p :> skipped) <- runSelection (selectChanges pw) context tentativelyAddToPending repository YesUpdateWorking p withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compression opts) _ <- applyToWorking repository (verbosity opts) p `catch` \(e :: IOException) -> fail ("Error applying unrevert to working directory...\n" ++ show e) debugMessage "I'm about to writeUnrevert." writeUnrevert repository skipped recorded (unrecorded+>+p) debugMessage "Finished unreverting." unrevertCmd _ _ _ = impossible writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> FL (PrimOf p) wX wY -> Tree IO -> FL (PrimOf p) wR wX -> IO () writeUnrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository writeUnrevert repository ps recorded pend = case commute (pend :> ps) of Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? " case really of ('y':_) -> return () _ -> exitSuccess writeUnrevert repository NilFL recorded pend Just (p' :> _) -> do rep <- readRepo repository date <- getIsoDateTime np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p') bundle <- makeBundleN (Just recorded) rep (np :>: NilFL) writeDocBinFile (unrevertUrl repository) bundle where fromRepoPrims :: RepoPatch p => Repository p wR wU wT -> FL (PrimOf p) wR wY -> FL p wR wY fromRepoPrims _ = fromPrims unrevertPatchBundle :: RepoPatch p => Repository p wR wU wT -> IO (SealedPatchSet p 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 darcs-2.10.2/src/Darcs/UI/Commands/Rollback.hs0000644000175000017500000002077012620122474022716 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Rollback ( rollback ) where import Prelude hiding ( (^), catch ) import Control.Applicative ( (<$>) ) import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import Data.List ( sort ) import Storage.Hashed.Tree( Tree ) import System.Exit ( exitSuccess ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Match ( firstMatch ) import Darcs.Patch.PatchInfoAnd ( n2pia ) import Darcs.Patch ( RepoPatch, invert, effect, fromPrims, sortCoalesceFL, canonize, anonymous, PrimOf ) import Darcs.Patch.Set ( PatchSet(..), newset2FL ) import Darcs.Patch.Split ( reversePrimSplitter ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..), concatFL, nullFL, mapFL_FL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Repository.Flags ( AllowConflicts (..), UseIndex(..), Reorder(..), ScanKnown(..), UpdateWorking(..), DryRun(NoDryRun)) import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), applyToWorking, readRepo, finalizeRepositoryChanges, tentativelyAddToPending, considerMergeToWorking, listRegisteredFiles ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, setEnvDarcsPatches, amInHashedRepository ) import Darcs.UI.Commands.Unrecord ( getLastPatches ) import Darcs.UI.Commands.Util ( announceFiles ) import Darcs.UI.Flags as F ( DarcsFlag(Quiet), verbosity, umask, useCache, compression, externalMerge, wantGuiPause, diffAlgorithm, fixSubPaths, isInteractive ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.UI.SelectChanges ( selectChanges, WhichChanges(..), selectionContext, selectionContextPrim, runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) import Darcs.Util.Progress ( debugMessage ) rollbackDescription :: String rollbackDescription = "Apply the inverse of recorded changes to the working copy." rollbackHelp :: String rollbackHelp = unlines [ "Rollback is used to undo the effects of some changes from patches" , "in the repository. The selected changes are undone in your working" , "copy, 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 copy (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 copy." ] rollbackBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe Bool -> Maybe String -> O.DiffAlgorithm -> a) rollbackBasicOpts = O.matchSeveralOrLast ^ O.interactive -- True ^ O.workingRepoDir ^ O.diffAlgorithm rollbackAdvancedOpts :: DarcsOption a (O.UMask -> a) rollbackAdvancedOpts = O.umask rollbackOpts :: DarcsOption a ([O.MatchFlag] -> Maybe Bool -> Maybe String -> O.DiffAlgorithm -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) rollbackOpts = rollbackBasicOpts `withStdOpts` rollbackAdvancedOpts patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps , S.summary = O.NoSummary , S.withContext = O.NoContext } rollback :: DarcsCommand [DarcsFlag] 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 = odesc rollbackAdvancedOpts , commandBasicOptions = odesc rollbackBasicOpts , commandDefaults = defaultFlags rollbackOpts , commandCheckOptions = ocheck rollbackOpts , commandParseOptions = onormalise rollbackOpts } 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 NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do files <- if null args then return Nothing else Just . sort <$> fixSubPaths fps args when (files == Just []) $ fail "No valid arguments were given." announceFiles files "Rolling back changes in" allpatches <- readRepo repository let matchFlags = parseFlags O.matchSeveralOrLast opts (_ :> patches) <- return $ if firstMatch matchFlags then getLastPatches matchFlags allpatches else PatchSet NilRL NilRL :> newset2FL allpatches let filesFps = map toFilePath <$> files patchCtx = selectionContext LastReversed "rollback" (patchSelOpts opts) Nothing filesFps (_ :> ps) <- runSelection (selectChanges patches) patchCtx exitIfNothingSelected ps "patches" setEnvDarcsPatches ps let hunkContext = selectionContextPrim Last "rollback" (patchSelOpts opts) (Just reversePrimSplitter) filesFps Nothing hunks = concatFL . mapFL_FL (canonize $ F.diffAlgorithm opts) . sortCoalesceFL . effect $ ps whatToUndo <- runSelection (selectChanges hunks) hunkContext undoItNow opts repository whatToUndo undoItNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => [DarcsFlag] -> Repository p wR wU wT -> (q :> FL (PrimOf p)) wA wT -> IO () undoItNow opts repo (_ :> prims) = do exitIfNothingSelected prims "changes" rbp <- n2pia `fmap` anonymous (fromPrims $ invert prims) Sealed pw <- considerMergeToWorking repo "rollback" YesAllowConflictsAndMark YesUpdateWorking (externalMerge opts) (wantGuiPause opts) (compression opts) (verbosity opts) NoReorder (UseIndex, ScanKnown, F.diffAlgorithm opts) NilFL (rbp :>: NilFL) tentativelyAddToPending repo YesUpdateWorking pw finalizeRepositoryChanges repo YesUpdateWorking (compression opts) _ <- applyToWorking repo (verbosity opts) pw `catch` \(e :: IOException) -> fail $ "error applying rolled back patch to working directory\n" ++ show e debugMessage "Finished applying unrecorded rollback patch" when (F.Quiet `notElem` opts) $ putStrLn "Changes rolled back in working directory" darcs-2.10.2/src/Darcs/UI/Commands/Diff.hs0000644000175000017500000002757412620122474022046 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Diff ( diffCommand ) where import Prelude hiding ( (^), all ) import System.FilePath.Posix ( takeFileName, () ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( askEnter ) import Control.Monad ( when ) import Data.List ( (\\) ) import Storage.Hashed.Plain( writePlainTree ) import Storage.Hashed.Darcs( hashedTreeIO ) import Data.Maybe ( isJust ) import System.Directory ( findExecutable ) import Darcs.Util.CommandLine ( parseCmd ) import Darcs.UI.External ( diffProgram , execPipeIgnoreError ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag ( AfterPatch, DiffCmd, LastN ) , wantGuiPause, useCache, fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( WantGuiPause (..), DiffAlgorithm(MyersDiff) ) import Darcs.Patch.PatchInfoAnd ( info, n2pia ) import Darcs.Util.Path ( toFilePath, SubPath, simpleSubPath, isSubPathOf, AbsolutePath ) import Darcs.Util.Global ( darcsdir ) import Darcs.Patch.Match ( firstMatch , secondMatch , matchFirstPatchset , matchSecondPatchset ) import Darcs.Repository ( withRepository, RepoJob(..), readRepo ) import Darcs.Repository.State ( readUnrecorded, restrictSubpaths , readRecorded, unrecordedChanges , UseIndex(..), ScanKnown(..), applyTreeFilter ) import Darcs.Patch.Witnesses.Ordered ( mapRL, (:>)(..), (+>+), RL(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Sealed ( unseal, Sealed(..), seal ) import Darcs.Patch ( RepoPatch, apply, listTouchedFiles, invert, fromPrims, anonymous ) import Darcs.Patch.Depends ( findCommonWithThem ) import Darcs.Patch.Set ( PatchSet(..), newset2RL ) import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI ) import Darcs.Repository.Lock ( withTempDir ) import Darcs.Util.Printer ( Doc, putDoc, putDocLn, vcat, empty, RenderMode(..) ) #include "impossible.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" diffBasicOpts :: DarcsOption a ([O.MatchFlag] -> O.ExternalDiff -> Bool -> Maybe String -> Bool -> a) diffBasicOpts = O.matchRange ^ O.extDiff ^ O.unidiff ^ O.workingRepoDir ^ O.storeInMemory diffAdvancedOpts :: DarcsOption a (WantGuiPause -> a) diffAdvancedOpts = O.pauseForGui diffOpts :: DarcsOption a ([O.MatchFlag] -> O.ExternalDiff -> Bool -> Maybe String -> Bool -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> WantGuiPause -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) diffOpts = diffBasicOpts `withStdOpts` diffAdvancedOpts diffCommand :: DarcsCommand [DarcsFlag] 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 = odesc diffAdvancedOpts , commandBasicOptions = odesc diffBasicOpts , commandDefaults = defaultFlags diffOpts , commandCheckOptions = ocheck diffOpts , commandParseOptions = onormalise diffOpts } getDiffOpts :: [DarcsFlag] -> [String] getDiffOpts fs = addUnified $ otherDiffOpts fs where addUnified = if parseFlags O.unidiff fs then ("-u":) else id otherDiffOpts = O._diffOpts . parseFlags O.extDiff -- | 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 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () diffCmd fps 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 fps args doDiff :: [DarcsFlag] -> Maybe [SubPath] -> IO () doDiff opts msubpaths = withRepository (useCache opts) $ RepoJob $ \repository -> do formerdir <- getCurrentDirectory let thename = takeFileName formerdir patchset <- readRepo repository unrecorded <- fromPrims `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository msubpaths unrecorded' <- n2pia `fmap` anonymous unrecorded let matchFlags = parseFlags O.matchRange opts Sealed all <- return $ case (secondMatch matchFlags, patchset) of (True, _) -> seal patchset (False, PatchSet untagged tagged) -> seal $ PatchSet (unrecorded' :<: untagged) tagged Sealed ctx <- return $ if firstMatch matchFlags then matchFirstPatchset matchFlags patchset else seal patchset Sealed match <- return $ if secondMatch matchFlags then matchSecondPatchset matchFlags patchset else seal all (_ :> todiff) <- return $ findCommonWithThem match ctx (_ :> tounapply) <- return $ findCommonWithThem all match base <- if secondMatch matchFlags then readRecorded repository else readUnrecorded repository Nothing let touched = map (fromJust . simpleSubPath) $ listTouchedFiles todiff files = case msubpaths of Nothing -> touched Just subpaths -> concatMap (\s -> filter (isSubPathOf s) touched) subpaths relevant <- restrictSubpaths repository files let filt = applyTreeFilter relevant . snd ppath = darcsdir "pristine.hashed" oldtree <- filt `fmap` hashedTreeIO (apply . invert $ unsafeCoercePEnd todiff +>+ tounapply) base ppath newtree <- filt `fmap` hashedTreeIO (apply . invert $ tounapply) base ppath withTempDir ("old-"++thename) $ \odir -> withTempDir ("new-"++thename) $ \ndir -> withCurrentDirectory formerdir $ do writePlainTree oldtree (toFilePath odir) writePlainTree newtree (toFilePath ndir) thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $ rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir) morepatches <- readRepo repository putDocLn $ changelog (getDiffInfo opts morepatches) putDoc $ 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) -> do if length (filter (==f1) d_args) /= 1 || length (filter (==f2) d_args) /= 1 then fail $ "Invalid argument (%1 or %2) in --diff-command" else return () cmdExists <- findExecutable d_cmd if isJust cmdExists then return () else fail $ d_cmd ++ " is not an executable in --diff-command" let pausingForGui = (wantGuiPause opts == YesWantGuiPause) in do when pausingForGui $ putStrLn $ "Running command '" ++ unwords (d_cmd:d_args) ++ "'" output <- execPipeIgnoreError Encode d_cmd d_args empty when pausingForGui $ askEnter "Hit return to move on..." return output getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p wStart wX -> [PatchInfo] getDiffInfo opts ps = let matchFlags = parseFlags O.matchRange opts infos = mapRL info . newset2RL handle (match_cond, do_match) | match_cond matchFlags = unseal infos (do_match matchFlags ps) | otherwise = infos ps in handle (secondMatch, matchSecondPatchset) \\ handle (firstMatch, matchFirstPatchset) changelog :: [PatchInfo] -> Doc changelog pis = vcat $ map showPatchInfoUI pis darcs-2.10.2/src/Darcs/UI/Commands/Replace.hs0000644000175000017500000003316412620122474022541 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Replace ( replace , defaultToks ) where import Prelude hiding ( (^), catch ) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import Data.Char ( isSpace ) import Data.Maybe ( isJust ) import Control.Applicative( (<$>) ) import Control.Exception ( catch, IOException ) import Control.Monad ( unless, filterM, void ) import Storage.Hashed.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree , makeBlobBS ) import Darcs.Util.Path( SubPath, toFilePath, AbsolutePath ) import Darcs.UI.Flags ( DarcsFlag( ForceReplace, Toks ) , verbosity, useCache, dryRun, umask, diffAlgorithm, fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.Repository.Diff( treeDiff ) import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace , applyToTree ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Patchy ( Apply ) import Darcs.Patch.RegChars ( regChars ) import Darcs.Repository ( withRepoLock , RepoJob(..) , addToPending , applyToWorking , readUnrecorded , readRecordedAndPending , listRegisteredFiles ) import Darcs.Repository.Prefs ( FileType(TextFile) ) import Darcs.Repository.Util ( floatSubPath, defaultToks ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal ) #include "impossible.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" replaceBasicOpts :: DarcsOption a (Maybe String -> Bool -> Maybe String -> a) replaceBasicOpts = O.tokens ^ O.forceReplace ^ O.workingRepoDir replaceAdvancedOpts :: DarcsOption a (O.UseIndex -> O.UMask -> a) replaceAdvancedOpts = O.useIndex ^ O.umask replaceOpts :: DarcsOption a (Maybe String -> Bool -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseIndex -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) replaceOpts = replaceBasicOpts `withStdOpts` replaceAdvancedOpts replace :: DarcsCommand [DarcsFlag] replace = DarcsCommand { commandProgramName = "darcs" , commandName = "replace" , commandHelp = replaceHelp , commandDescription = replaceDescription , commandExtraArgs = -1 , commandExtraArgHelp = [ "" , "" , " ..." ] , commandCommand = replaceCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = listRegisteredFiles , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc replaceAdvancedOpts , commandBasicOptions = odesc replaceBasicOpts , commandDefaults = defaultFlags replaceOpts , commandCheckOptions = ocheck replaceOpts , commandParseOptions = onormalise replaceOpts } replaceCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () replaceCmd fps opts (old : new : relfs@(_ : _)) = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do fs <- fixSubPaths fps relfs toks <- chooseToks opts old new let checkToken tok = unless (isTok toks tok) $ fail $ "'" ++ tok ++ "' is not a valid token!" mapM_ checkToken [ old, new ] working <- readUnrecorded repository Nothing pending <- readRecordedAndPending repository files <- filterM (exists working) fs Sealed replacePs <- mapSeal concatFL . toFL <$> mapM (doReplace toks pending working) files addToPending repository YesUpdateWorking replacePs void $ applyToWorking repository (verbosity opts) replacePs `catch` \(e :: IOException) -> fail $ "Can't do replace on working!\n" ++ "Perhaps one of the files already" ++ " contains '" ++ new ++ "'?\n" ++ show e where exists tree file = if isJust $ findFile tree (floatSubPath file) then return True else do putStrLn $ skipmsg file return False skipmsg f = "Skipping file '" ++ toFilePath f ++ "' which isn't in the repository." doReplace :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree) => String -> Tree IO -> Tree IO -> SubPath -> IO (FreeLeft (FL prim)) doReplace toks pend work f = do let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p workReplaced <- maybeReplace work pendReplaced <- maybeReplace pend if workReplaced && pendReplaced then return $ joinGap (:>:) (freeGap replacePatch) gapNilFL else if ForceReplace `elem` opts then getForceReplace f toks work else putStrLn existsMsg >> return gapNilFL where existsMsg = "Skipping file '" ++ fp ++ "'\nPerhaps the recorded" ++ " version of this file already contains '" ++ new ++ "'?\nUse the --force option to override." gapNilFL = emptyGap NilFL fp = toFilePath f replacePatch = tokreplace fp 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 => SubPath -> String -> Tree IO -> IO (FreeLeft (FL prim)) getForceReplace f toks tree = do let path = floatSubPath f content <- readBlob $ fromJust $ findFile tree path let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old) (BS.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 (toFilePath f) toks old new :>: NilFL replaceCmd _ _ [_, _] = fail "You need to supply a list of files to replace in!" replaceCmd _ _ _ = fail "Usage: darcs replace OLD NEW [FILES]" -- | Attempts to apply a given replace patch to a Tree. If the apply fails (if -- the file the patch applies to already contains the target token), we return -- Nothing, otherwise we return the updated Tree. maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO -> IO (Maybe (Tree IO)) maybeApplyToTree patch tree = (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing) 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 = badTokenSpec $ "It must contain more than 2 characters, because it" ++ " should be enclosed in square brackets" | head t /= '[' || last t /= ']' = badTokenSpec "It should be enclosed in square brackets" | '^' == head tok && length tok == 1 = badTokenSpec "Must be at least one character in the complementary set" | any isSpace t = badTokenSpec "Space is not allowed in the spec" | 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 $ tail t :: String badTokenSpec msg = fail $ "Bad token spec: '" ++ t ++ "' (" ++ msg ++ ")" spaceyToken x = x ++ " must not contain any space" notAToken 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 darcs-2.10.2/src/Darcs/UI/Commands/Log.hs0000644000175000017500000005274612620122474021716 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.UI.Commands.Log ( changes, log , changelog, getLogInfo ) 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.UI.PrintPatch ( showFriendly ) import Darcs.Patch.PatchInfoAnd ( fmapFLPIAP, hopefullyM, info ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, findRepository ) import Darcs.UI.External ( viewDocWith ) import Darcs.UI.Flags ( DarcsFlag(GenContext, HumanReadable, MachineReadable, Count, Interactive, NumberPatches, XMLOutput, Summary, Verbose, Debug, NoPatchIndexFlag) , doReverse, showChangesOnlyToFiles , useCache, maxCount, umask , verbosity, isUnified, isInteractive, diffAlgorithm, hasSummary , fixSubPaths, getRepourl ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( SubPath(), toFilePath, fp2fn, fn2fp, normPath, AbsolutePath, simpleSubPath ) import Darcs.Repository ( PatchSet, PatchInfoAnd, withRepositoryDirectory, RepoJob(..), readRepo, unrecordedChanges, withRepoLockCanFail ) import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(MyersDiff), UpdateWorking(..) ) import Darcs.Repository.Lock ( withTempDir ) import Darcs.Patch.Set ( PatchSet(..), newset2RL ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Info ( toXml, showPatchInfo, escapeXML, PatchInfo ) import Darcs.Patch.Depends ( findCommonWithThem ) import Darcs.Patch.Bundle( contextPatches ) import Darcs.Patch.Prim ( PrimPatchBase ) import Darcs.Patch.Show ( ShowPatch ) import Darcs.Patch.TouchesFiles ( lookTouch ) import Darcs.Patch.Type ( PatchType(PatchType) ) import Darcs.Patch.Apply ( Apply, ApplyState ) import Darcs.Patch ( invert, xmlSummary, description, effectOnFilePaths, listTouchedFiles ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(NilFL), RL(..), filterOutFLFL, filterRL, reverseFL, (:>)(..), mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..), seal2 ) import Darcs.Patch.Match ( MatchFlag , firstMatch , secondMatch , matchAPatchread , haveNonrangeMatch , matchFirstPatchset , matchSecondPatchset ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Util.Printer ( Doc, simplePrinters, (<+>), prefix, text, vcat, vsep, (<>), ($$), errorDoc, insertBeforeLastline, empty, RenderMode(..) ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( setProgressMode, debugMessage ) import Darcs.Util.URL ( isValidLocalPath ) import Darcs.UI.SelectChanges ( viewChanges ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Repository.PatchIndex ( PatchFilter, maybeFilterPatches, attemptCreatePatchIndex ) import Storage.Hashed.Tree( Tree ) logHelp :: String logHelp = "The `darcs log` 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" ++ logHelp' ++ "\n" ++ logHelp'' logBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe Int -> Bool -> Maybe O.ChangesFormat -> Maybe O.Summary -> Bool -> Maybe String -> Maybe String -> Maybe Bool -> a) logBasicOpts = O.matchSeveralOrRange ^ O.matchMaxcount ^ O.onlyToFiles ^ O.changesFormat ^ O.summary ^ O.changesReverse ^ O.possiblyRemoteRepo ^ O.workingRepoDir ^ O.interactive -- False logAdvancedOpts :: DarcsOption a (O.NetworkOptions -> O.WithPatchIndex -> a) logAdvancedOpts = O.network ^ O.patchIndexYes logOpts :: DarcsOption a ([O.MatchFlag] -> Maybe Int -> Bool -> Maybe O.ChangesFormat -> Maybe O.Summary -> Bool -> Maybe String -> Maybe String -> Maybe Bool -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.NetworkOptions -> O.WithPatchIndex -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) logOpts = logBasicOpts `withStdOpts` logAdvancedOpts log :: DarcsCommand [DarcsFlag] log = DarcsCommand { commandProgramName = "darcs" , commandName = "log" , commandHelp = logHelp , commandDescription = "List patches in the repository." , commandExtraArgs = -1 , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandGetArgPossibilities = return [] , commandCommand = logCmd , commandPrereq = findRepository , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc logAdvancedOpts , commandBasicOptions = odesc logBasicOpts , commandDefaults = defaultFlags logOpts , commandCheckOptions = ocheck logOpts , commandParseOptions = onormalise logOpts } logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () logCmd fps opts args | GenContext `elem` opts = 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 $ nub $ sort 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 fs <- fixSubPaths fps args case fs of [] -> putStrLn "No valid arguments were given, nothing to do." _ -> do unless (Interactive `elem` opts) $ unless (NoPatchIndexFlag `elem` opts) $ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts) $ RepoJob attemptCreatePatchIndex showLog opts $ Just $ nub $ sort fs maybeNotNull :: [a] -> Maybe [a] maybeNotNull [] = Nothing maybeNotNull xs = Just xs hasRemoteRepo :: [DarcsFlag] -> Bool hasRemoteRepo = maybe False (not . isValidLocalPath) . parseFlags O.possiblyRemoteRepo 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 [SubPath] -> IO () showLog opts files = let repodir = fromMaybe "." (getRepourl opts) in withRepositoryDirectory (useCache 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, MyersDiff) 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 <$> getLogInfo (maxCount opts) (parseFlags O.matchSeveralOrRange opts) (showChangesOnlyToFiles opts) recFiles (maybeFilterPatches repository) p debugMessage "About to read the repository..." patches <- readRepo repository debugMessage "Done reading the repository." if Interactive `elem` opts then do (fp_and_fs, _, _) <- filtered_changes patches let fp = map fst fp_and_fs viewChanges (logPatchSelOpts opts) fp else do let header = if isJust files && XMLOutput `notElem` opts then text $ "Changes to "++unwords (fromJust recFiles)++":\n" else empty debugMessage "About to print the patches..." let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters ps <- readRepo repository -- read repo again to prevent holding onto -- values forced by filtered_changes logOutput <- changelog opts ps `fmap` filtered_changes patches viewDocWith printers Encode $ header $$ logOutput 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 logHelp' :: String logHelp' = "When given one or more files or directories as arguments, only\n" ++ "patches which affect those files or directories are listed. This\n" ++ "includes patches that happened to files before they were moved or\n" ++ "renamed.\n" ++ "\n" ++ "When given a `--from-tag`, `--from-patch` or `--from-match`, only patches\n" ++ "since that tag or patch are listed. Similarly, the `--to-tag`,\n" ++ "`--to-patch` and `--to-match` options restrict the list to older patches.\n" ++ "\n" ++ "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 log foo.c\n" ++ "--max-count 3` will print the last three patches that affect foo.c,\n" ++ "whereas `darcs log --last 3 foo.c` will, of the last three\n" ++ "patches, print only those that affect foo.c.\n" getLogInfo :: forall p wX wY . (Matchable p, ApplyState p ~ Tree) => Maybe Int -> [MatchFlag] -> Bool -> Maybe [FilePath] -> PatchFilter p -> PatchSet p wX wY -> IO ( [(Sealed2 (PatchInfoAnd p), [FilePath])] , [(FilePath, FilePath)] , Maybe Doc ) getLogInfo maxCountFlag matchFlags onlyToFilesFlag plain_fs patchFilter 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 -> return $ foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $ maybe id take maxCountFlag ps' Just fs -> let fs' = map (\x -> "./" ++ x) fs in do filterOutUnrelatedChanges <$> do ps'' <- patchFilter fs' ps' return $ filterPatchesByNames maxCountFlag fs' ps'' where sp1s = if firstMatch matchFlags then matchFirstPatchset matchFlags ps else Sealed $ PatchSet NilRL NilRL sp2s = if secondMatch matchFlags then matchSecondPatchset matchFlags ps else Sealed ps pf = if haveNonrangeMatch (PatchType :: PatchType p) matchFlags then matchAPatchread matchFlags else \_ -> True filterOutUnrelatedChanges (pfs, renames, doc) | onlyToFilesFlag = (map onlyRelated pfs, renames, doc) | otherwise = (pfs, renames, doc) 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 = unsafeCoerce 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 . (Matchable 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 $ uncurry (/=) 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 patches prior to:" $$ showPatchInfo (info hp) return ([], renames, Just err) Just p -> case lookTouch (Just renames) fs (invert p) of (True, affected, [], renames') -> 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 wStart wX . ( Apply p, ApplyState p ~ Tree, ShowPatch p, IsHunk p , PrimPatchBase p, PatchListFormat p , Conflict p, CommuteNoConflicts p ) => [DarcsFlag] -> PatchSet p wStart wX -> ([(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 "" $$ vcat created_as_xml $$ vcat actual_xml_changes $$ text "" | Summary `elem` opts || Verbose `elem` opts = mbAppendErr $ vsep (map (number_patch change_with_summary) pis) | otherwise = mbAppendErr $ vsep (map (number_patch description') pis) where mbAppendErr = maybe id (\err -> ($$ err)) mbErr change_with_summary :: Sealed2 (PatchInfoAnd p) -> Doc change_with_summary (Sealed2 hp) | Just p <- hopefullyM hp = showFriendly (verbosity opts) (hasSummary O.NoSummary opts) p | otherwise = description hp $$ indent (text "[this patch is unavailable]") 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 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) wStart wY -> 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 -- FIXME: this prose is unreadable. --twb, 2009-08 logHelp'' :: String logHelp'' = "Three output formats exist. The default is `--human-readable`. You can\n" ++ "also select `--context`, which is the internal format (as seen in patch\n" ++ "bundles) that can be re-read by Darcs (e.g. `darcs clone --context`).\n" ++ "\n" ++ "Finally, there is `--xml-output`, which emits valid XML... unless a the\n" ++ "patch metadata (author, name or description) contains a non-ASCII\n" ++ "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 clone be\n" ++ "able to read the output. On the other hand, sufficient information\n" ++ "WILL be output for a knowledgeable human to recreate the current state\n" ++ "of the repository.\n" logContext :: [DarcsFlag] -> IO () logContext opts = do let repodir = fromMaybe "." $ getRepourl opts withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repository -> do (_ :> ps') <- contextPatches `fmap` readRepo repository let ps = mapRL (\p -> (seal2 p, [])) ps' let header = if fancy then empty else text "\nContext:\n" let logOutput = changelog opts' emptyset (ps, [], Nothing) viewDocWith simplePrinters Encode $ header $$ logOutput where opts' = if fancy then opts else MachineReadable : opts fancy = HumanReadable `elem` opts || XMLOutput `elem` opts emptyset = PatchSet NilRL NilRL -- | changes is an alias for log changes :: DarcsCommand [DarcsFlag] changes = commandAlias "changes" Nothing log createdAsXml :: PatchInfo -> (String, String) -> Doc createdAsXml pinfo (current, createdAs) = text "" $$ toXml pinfo $$ text "" logPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions logPatchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrRange flags , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive False flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = hasSummary O.NoSummary flags , S.withContext = isUnified flags } darcs-2.10.2/src/Darcs/UI/Commands/Util/0000755000175000017500000000000012620122474021540 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/UI/Commands/Util/Tree.hs0000644000175000017500000000524312620122474022777 0ustar00guillaumeguillaume00000000000000-- 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.Util.Tree ( -- * Tree lookup. treeHas , treeHasDir , treeHasFile , treeHasAnycase ) where import Control.Monad ( forM ) import Control.Monad.State.Strict( gets ) import qualified Data.ByteString.Char8 as BSC import Data.Char ( toLower ) 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 Storage.Hashed ( floatPath ) import Darcs.Util.Path ( AnchoredPath(..), Name(..) ) treeHasAnycase :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool treeHasAnycase tree path = fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree existsAnycase :: (Functor m, Monad m) => AnchoredPath -> TreeMonad m Bool existsAnycase (AnchoredPath []) = return True existsAnycase (AnchoredPath (Name x:xs)) = 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 :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool treeHas tree path = fst `fmap` virtualTreeMonad (HS.exists $ floatPath path) tree treeHasDir :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool treeHasDir tree path = fst `fmap` virtualTreeMonad (directoryExists $ floatPath path) tree treeHasFile :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool treeHasFile tree path = fst `fmap` virtualTreeMonad (fileExists $ floatPath path) tree darcs-2.10.2/src/Darcs/UI/Commands/Remove.hs0000644000175000017500000002163112620122474022417 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands.Remove ( remove, rm, unadd ) where import Prelude hiding ( (^) ) import Control.Monad ( when, foldM ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, commandStub, putWarning , amInHashedRepository ) import Darcs.UI.Commands.Add( expandDirs ) import Darcs.UI.Flags ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, fixSubPaths, verbosity ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..) ) import Darcs.Repository ( Repository , withRepoLock , RepoJob(..) , addToPending , readRecordedAndPending , readUnrecorded , listRegisteredFiles ) import Darcs.Repository.Diff( treeDiff ) import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile, listTouchedFiles ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft ) import Darcs.Repository.Prefs ( filetypeFunction, FileType ) import Storage.Hashed.Tree( Tree, TreeItem(..), find, modifyTree, expand, list ) import Darcs.Util.Path( anchorPath, AnchoredPath, fn2fp, SubPath, sp2fn , AbsolutePath ) import Storage.Hashed( floatPath ) import Darcs.Util.Printer ( text ) 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" removeBasicOpts :: DarcsOption a (Maybe String -> Bool -> a) removeBasicOpts = O.workingRepoDir ^ O.recursive removeAdvancedOpts :: DarcsOption a (O.UMask -> a) removeAdvancedOpts = O.umask removeOpts :: DarcsOption a (Maybe String -> Bool -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UMask -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) removeOpts = removeBasicOpts `withStdOpts` removeAdvancedOpts remove :: DarcsCommand [DarcsFlag] remove = DarcsCommand { commandProgramName = "darcs" , commandName = "remove" , commandHelp = removeHelp , commandDescription = removeDescription , commandExtraArgs = -1 , commandExtraArgHelp = [" ..."] , commandCommand = removeCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = listRegisteredFiles , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc removeAdvancedOpts , commandBasicOptions = odesc removeBasicOpts , commandDefaults = defaultFlags removeOpts , commandCheckOptions = ocheck removeOpts , commandParseOptions = onormalise removeOpts } removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () removeCmd fps opts relargs = do when (null relargs) $ fail "Nothing specified, nothing removed." origfiles <- fixSubPaths fps relargs when (null origfiles) $ fail "No valid arguments were given." withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do args <- if parseFlags O.recursive opts then reverse `fmap` expandDirs False origfiles else return origfiles Sealed p <- makeRemovePatch opts repository args let notQuiet = verbosity opts /= O.Quiet when (nullFL p && not (null origfiles) && notQuiet) $ fail "No files were removed." addToPending repository YesUpdateWorking p when notQuiet $ putStr $ unlines $ ["Will stop tracking:"] ++ 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 p wR wU wT -> [SubPath] -> IO (Sealed (FL (PrimOf p) wU)) 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)) -> if not $ null (list unrecordedChildren) then skipAndWarn "it is not empty" else return $ Just $ freeGap (rmdir f_fp :>: NilFL) (Just (File _), Just (File _)) -> do Just `fmap` treeDiff (diffAlgorithm opts) 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 [DarcsFlag] rm = commandStub "rm" rmHelp rmDescription remove unadd :: DarcsCommand [DarcsFlag] unadd = commandAlias "unadd" Nothing remove darcs-2.10.2/src/Darcs/UI/Commands/Unrecord.hs0000644000175000017500000004530312620122474022745 0ustar00guillaumeguillaume00000000000000-- 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, OverloadedStrings #-} module Darcs.UI.Commands.Unrecord ( unrecord , unpull , obliterate , getLastPatches , matchingHead ) where import Prelude hiding ( (^), catch ) import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import Data.Maybe( isJust, mapMaybe ) import Data.List ( intercalate ) import Storage.Hashed.Tree( Tree ) import System.Exit ( exitSuccess ) import Darcs.Patch ( RepoPatch, invert, commute, effect ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Bundle ( makeBundleN, contextPatches, minContext ) import Darcs.Patch.Depends ( findCommonWithThem, newsetUnion ) import Darcs.Patch.Match ( firstMatch, matchFirstPatchset, matchAPatchread, MatchFlag ) import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), appendPSFL, Origin, SealedPatchSet ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal ) import Darcs.Patch.Witnesses.Ordered ( RL(..), (:>)(..), (+<+), mapFL_FL, nullFL, reverseRL, mapRL, FL(..) ) import Darcs.Util.Path( useAbsoluteOrStd, AbsolutePath, toFilePath, doesPathExist ) import Darcs.Util.SignalHandler ( catchInterrupt ) import Darcs.Repository ( PatchInfoAnd, withRepoLock, RepoJob(..), Repository, tentativelyRemovePatches, finalizeRepositoryChanges, tentativelyAddToPending, applyToWorking, readRepo, invalidateIndex, unrecordedChanges, identifyRepositoryFor ) import Darcs.Repository.Flags( UseIndex(..), ScanKnown(..), UpdateWorking(..), DryRun(NoDryRun) ) import Darcs.Repository.Lock( writeDocBinFile ) import Darcs.Repository.Prefs ( getDefaultRepoPath ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias , putVerbose, printDryRunMessageAndExit , setEnvDarcsPatches, amInHashedRepository , putInfo ) import Darcs.UI.Commands.Util ( getUniqueDPatchName ) import Darcs.UI.Flags ( doReverse, compression, verbosity, getOutput , useCache, dryRun, umask, DarcsFlag ( NotInRemote ), minimize , diffAlgorithm, hasXmlOutput, hasSummary, isInteractive, selectDeps ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import Darcs.UI.Options.All ( notInRemoteFlagName ) import qualified Darcs.UI.Options.All as O import Darcs.UI.SelectChanges ( selectChanges, WhichChanges(..), selectionContext, runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.English ( presentParticiple ) import Darcs.Util.Printer ( text, putDoc ) import Darcs.Util.Progress ( debugMessage ) unrecordDescription :: String unrecordDescription = "Remove recorded patches without changing the working copy." unrecordHelp :: String unrecordHelp = unlines [ "Unrecord does the opposite of record: it deletes patches from" , "the repository, without changing the working copy." , "Deleting patches from the repository makes active changes again" , "which you may record or revert later." , "Beware that you should not use this command if there is a" , "possibility that another user may have already pulled the patch." ] unrecordBasicOpts :: DarcsOption a ([MatchFlag] -> O.SelectDeps -> Maybe Bool -> Maybe String -> a) unrecordBasicOpts = O.matchSeveralOrLast ^ O.selectDeps ^ O.interactive -- True ^ O.workingRepoDir unrecordAdvancedOpts :: DarcsOption a (O.Compression -> O.UMask -> Bool -> a) unrecordAdvancedOpts = O.compress ^ O.umask ^ O.changesReverse unrecordOpts :: DarcsOption a ([MatchFlag] -> O.SelectDeps -> Maybe Bool -> Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.Compression -> O.UMask -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) unrecordOpts = unrecordBasicOpts `withStdOpts` unrecordAdvancedOpts unrecord :: DarcsCommand [DarcsFlag] unrecord = DarcsCommand { commandProgramName = "darcs" , commandName = "unrecord" , commandHelp = unrecordHelp , commandDescription = unrecordDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = unrecordCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc unrecordAdvancedOpts , commandBasicOptions = odesc unrecordBasicOpts , commandDefaults = defaultFlags unrecordOpts , commandCheckOptions = ocheck unrecordOpts , commandParseOptions = onormalise unrecordOpts } unrecordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unrecordCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do allpatches <- readRepo repository let matchFlags = parseFlags O.matchSeveralOrLast opts (_ :> patches) <- return $ if firstMatch matchFlags then getLastPatches matchFlags allpatches else matchingHead matchFlags allpatches let direction = if doReverse opts then Last else LastReversed context = selectionContext direction "unrecord" (patchSelOpts opts) Nothing Nothing (_ :> to_unrecord) <- runSelection (selectChanges patches) context when (nullFL to_unrecord) $ do putStrLn "No patches selected!" exitSuccess putVerbose opts $ text "About to write out (potentially) modified patches..." setEnvDarcsPatches to_unrecord invalidateIndex repository _ <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking to_unrecord finalizeRepositoryChanges repository YesUpdateWorking (compression opts) putStrLn "Finished unrecording." getLastPatches :: RepoPatch p => [MatchFlag] -> PatchSet p Origin wR -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR getLastPatches matchFlags ps = case matchFirstPatchset matchFlags ps of Sealed p1s -> findCommonWithThem ps p1s unpullDescription :: String unpullDescription = "Opposite of pull; unsafe if patch is not in remote repository." unpullHelp :: String unpullHelp = unlines [ "Unpull completely removes recorded patches from your local repository." , "The changes will be undone in your working copy and the patches" , "will not be shown in your changes list anymore. Beware that if the" , "patches are not still present in another repository you will lose" , "precious code by unpulling!" , "" , "One way to save unpulled 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`." ] unpull :: DarcsCommand [DarcsFlag] unpull = (commandAlias "unpull" Nothing obliterate) { commandHelp = unpullHelp , commandDescription = unpullDescription , commandCommand = unpullCmd } unpullCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unpullCmd = genericObliterateCmd "unpull" obliterateDescription :: String obliterateDescription = "Delete selected patches from the repository. (UNSAFE!)" obliterateHelp :: String obliterateHelp = unlines [ "Obliterate completely removes recorded patches from your local" , "repository. The changes will be undone in your working copy and the" , "patches will not be shown in your changes list anymore. Beware that" , "you can lose precious code by obliterating!" , "" , "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`." ] obliterateBasicOpts :: DarcsOption a ([Maybe String] -> [MatchFlag] -> O.SelectDeps -> Maybe Bool -> Maybe String -> Maybe O.Summary -> Maybe O.Output -> Bool -> O.DiffAlgorithm -> O.DryRun -> O.XmlOutput -> a) obliterateBasicOpts = O.notInRemote ^ O.matchSeveralOrLast ^ O.selectDeps ^ O.interactive ^ O.workingRepoDir ^ O.summary ^ O.output ^ O.minimize ^ O.diffAlgorithm ^ O.dryRunXml obliterateAdvancedOpts :: DarcsOption a (O.Compression -> O.UseIndex -> O.UMask -> Bool -> a) obliterateAdvancedOpts = O.compress ^ O.useIndex ^ O.umask ^ O.changesReverse obliterateOpts :: DarcsOption a ([Maybe String] -> [MatchFlag] -> O.SelectDeps -> Maybe Bool -> Maybe String -> Maybe O.Summary -> Maybe O.Output -> Bool -> O.DiffAlgorithm -> DryRun -> O.XmlOutput -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.Compression -> UseIndex -> O.UMask -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) obliterateOpts = obliterateBasicOpts `withStdOpts` obliterateAdvancedOpts obliterate :: DarcsCommand [DarcsFlag] obliterate = DarcsCommand { commandProgramName = "darcs" , commandName = "obliterate" , commandHelp = obliterateHelp , commandDescription = obliterateDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = obliterateCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc obliterateAdvancedOpts , commandBasicOptions = odesc obliterateBasicOpts , commandDefaults = defaultFlags obliterateOpts , commandCheckOptions = ocheck obliterateOpts , commandParseOptions = onormalise obliterateOpts } obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () obliterateCmd = genericObliterateCmd "obliterate" data NotInRemoteLocation = NotInDefaultRepo | NotInRemotePath String -- | genericObliterateCmd is the function that executes the "obliterate" and -- "unpull" commands. The first argument is the name under which the command is -- invoked (@unpull@ or @obliterate@). genericObliterateCmd :: String -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () genericObliterateCmd cmdname _ opts _ = let cacheOpt = useCache opts in withRepoLock (dryRun opts) cacheOpt YesUpdateWorking (umask 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, diffAlgorithm opts) repository Nothing allpatches <- readRepo repository let collectNotIns (NotInRemote nir) = case nir of Just p -> Just $ NotInRemotePath p Nothing -> Just NotInDefaultRepo collectNotIns _ = Nothing notIns = mapMaybe collectNotIns opts (auto_kept :> removal_candidates) <- case notIns of [] -> do let matchFlags = parseFlags O.matchSeveralOrLast opts return $ if firstMatch matchFlags then getLastPatches matchFlags allpatches else matchingHead matchFlags allpatches nirs -> do (Sealed thems) <- getNotInRemotePatches cacheOpt repository nirs return $ findCommonWithThem allpatches thems let direction = if doReverse opts then Last else LastReversed context = selectionContext direction cmdname (patchSelOpts opts) Nothing Nothing (kept :> removed) <- runSelection (selectChanges removal_candidates) context when (nullFL removed) $ do putStrLn "No patches selected!" 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" (verbosity opts) (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput opts) (isInteractive True opts) removed setEnvDarcsPatches removed when (isJust $ getOutput opts "") $ savetoBundle opts (auto_kept `appendPSFL` kept) removed invalidateIndex repository _ <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking removed tentativelyAddToPending repository YesUpdateWorking $ invert $ effect removed finalizeRepositoryChanges repository YesUpdateWorking (compression opts) debugMessage "Applying patches to working directory..." _ <- applyToWorking repository (verbosity opts) (invert p_after_pending) `catch` \(e :: IOException) -> fail $ "Couldn't undo patch in working dir.\n" ++ show e putStrLn $ "Finished " ++ presentParticiple cmdname ++ "." -- | Get the union of the set of patches in each specified location getNotInRemotePatches :: (RepoPatch p, ApplyState p ~ Tree) => O.UseCache -> Repository p wX wU wT -> [NotInRemoteLocation] -> IO (SealedPatchSet p Origin) getNotInRemotePatches cacheOpt repository nirs = do putStrLn $ "Determining patches not in" ++ pluralExtra ++ ":\n" ++ names nirsPaths <- mapM getNotInRemotePath nirs newsetUnion `fmap` mapM readNir nirsPaths where toName (NotInRemotePath s) = "'" ++ s ++ "'" toName NotInDefaultRepo = "Default push/pull repo" pluralExtra = if length names > 1 then " any of" else "" names = intercalate "\n" $ map ((leader ++) . toName) nirs leader = " - " readNir n = do r <- identifyRepositoryFor repository cacheOpt n rps <- readRepo r return $ seal rps getNotInRemotePath (NotInRemotePath p) = return p getNotInRemotePath NotInDefaultRepo = do defaultRepo <- getDefaultRepoPath let err = fail $ "No default push/pull repo configured, please pass a " ++ "repo name to --" ++ notInRemoteFlagName maybe err return defaultRepo -- | 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. RepoPatch 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 (matchAPatchread matchFlags) 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 Origin wZ -> FL (PatchInfoAnd p) wZ wT -> IO () savetoBundle opts kept removed@(x :>: _) = do let genFullBundle = makeBundleN 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') -> makeBundleN Nothing kept' (mapFL_FL hopefully removed') ) `catchInterrupt` genFullBundle filename <- getUniqueDPatchName (patchDesc x) let Just outname = 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 savetoBundle _ _ NilFL = return () patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = O.NoContext } darcs-2.10.2/src/Darcs/UI/Commands/ShowAuthors.hs0000644000175000017500000002261512620122474023453 0ustar00guillaumeguillaume00000000000000-- 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 Prelude hiding ( (^), catch ) import Control.Arrow ( (&&&), (***) ) import Control.Exception ( catch, IOException ) import Data.Char ( toLower, isSpace ) import Data.Function ( on ) import Data.List ( isInfixOf, sortBy, groupBy, group, sort ) import Data.Maybe( isJust ) import Data.Ord ( comparing ) import Text.ParserCombinators.Parsec hiding ( lower, count, Line ) import Text.ParserCombinators.Parsec.Error import Text.Regex ( Regex, mkRegexWithOpts, matchRegex ) import Darcs.UI.Flags ( DarcsFlag(Verbose), useCache ) import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O ( workingRepoDir, StdCmdAction, Verbosity, UseCache ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putWarning, amInRepository ) import Darcs.UI.External ( viewDoc ) import Darcs.Patch.PatchInfoAnd ( info ) import Darcs.Patch.Info ( piAuthor ) import Darcs.Patch.Set ( newset2RL ) import Darcs.Repository ( readRepo, withRepository, RepoJob(..) ) import Darcs.Patch.Witnesses.Ordered ( mapRL ) import Darcs.Util.Printer ( text ) import Darcs.Util.Path ( AbsolutePath ) import qualified Darcs.Util.Ratified as Ratified ( readFile ) 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
[, 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 \n" ++ " John Snagge , John, snagge@, js@(si|mit).edu\n" ++ " Chuck Jones\\, Jr. , cj\\+user@example.com\n" showAuthorsBasicOpts :: DarcsOption a (Maybe String -> a) showAuthorsBasicOpts = O.workingRepoDir showAuthorsOpts :: DarcsOption a (Maybe String -> Maybe O.StdCmdAction -> Bool -> Bool -> O.Verbosity -> Bool -> O.UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) showAuthorsOpts = showAuthorsBasicOpts `withStdOpts` oid showAuthors :: DarcsCommand [DarcsFlag] showAuthors = DarcsCommand { commandProgramName = "darcs" , commandName = "authors" , commandHelp = showAuthorsHelp , commandDescription = showAuthorsDescription , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = authorsCmd , commandPrereq = amInRepository , commandGetArgPossibilities = return [] , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc showAuthorsBasicOpts , commandDefaults = defaultFlags showAuthorsOpts , commandCheckOptions = ocheck showAuthorsOpts , commandParseOptions = onormalise showAuthorsOpts } authorsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () authorsCmd _ flags _ = withRepository (useCache flags) $ RepoJob $ \repository -> do patches <- readRepo repository spellings <- compiledAuthorSpellings flags let authors = mapRL (piAuthor . info) $ newset2RL patches viewDoc $ text $ unlines $ if Verbose `elem` flags then authors else rankAuthors spellings authors rankAuthors :: [Spelling] -> [String] -> [String] rankAuthors spellings authors = -- A list of the form ["# "]. -- 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 *** head) . unzip) . groupBy ((==) `on` snd) . sortBy (comparing snd) . -- Because it would take a long time to canonize "foo" into -- "foo " 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 flags = 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 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 ",<" darcs-2.10.2/src/Darcs/UI/Options/0000755000175000017500000000000012620122474020515 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/UI/Options/All.hs0000644000175000017500000012567612620122474021602 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE RecordWildCards #-} {- | 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 -- root , RootAction (..) , rootActions -- all commands , StdCmdAction (..) , stdCmdActions , debug , Verbosity (..) -- re-export , verbosity , timings , anyVerbosity , 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 , matchMaxcount -- local or remote repo(s) , WorkRepo (..) -- re-export , workRepo , workingRepoDir , RemoteRepos (..) -- re-export , remoteRepos , possiblyRemoteRepo , reponame , notInRemote , notInRemoteFlagName , RepoCombinator (..) , repoCombinator , allowUnrelatedRepos , justThisRepo , WithWorkingDir (..) -- re-export , useWorkingDir , SetDefault (..) -- re-export , setDefault -- patch meta-data , patchname , author , AskLongComment (..) , askLongComment , keepDate , Logfile (..) , logfile -- looking for changes , LookFor (..) , LookForAdds (..) -- re-export , LookForMoves (..) -- re-export , LookForReplaces (..) -- re-export , lookfor -- files to consider , UseIndex (..) -- re-export , ScanKnown (..) -- re-export , diffing , includeBoring , allowProblematicFilenames , allowCaseDifferingFilenames , allowWindowsReservedFilenames , onlyToFiles , useIndex , recursive -- differences , DiffAlgorithm (..) -- re-export , diffAlgorithm , WithContext (..) , withContext , unidiff , ExternalDiff (..) , extDiff -- tests , TestChanges (..) , testChanges , RunTest (..) -- re-export , test , LeaveTestDir (..) -- re-export , leaveTestDir -- mail related , HeaderFields (..) , headerFields , sendToContext , sendmail , sendmailCmd , charset , editDescription , ccApply , reply , happyForwarding -- patch bundles , applyAs , Sign (..) , sign , Verify (..) , verify -- merging patches , AllowConflicts (..) -- re-export , conflicts , ExternalMerge (..) -- re-export , useExternalMerge -- optimizations , Compression (..) -- re-export , compress , usePacks , WithPatchIndex (..) -- re-export , patchIndex , patchIndexYes , Reorder (..) -- re-export , reorder , minimize , storeInMemory -- miscellaneous , Output (..) , output , Summary (..) , summary , RemoteDarcs (..) -- re-export , NetworkOptions (..) , network , UMask (..) -- re-export , umask , SetScriptsExecutable (..) -- re-export , setScriptsExecutable , restrictPaths -- command specific -- amend , amendUnrecord , selectAuthor -- annotate , humanReadable , machineReadable -- clone , CloneKind (..) , partial -- dist , distname , distzip -- convert import/export, init , marks , readMarks , writeMarks , PatchFormat (..) , patchFormat , hashed -- log , ChangesFormat (..) , changesFormat -- replace , tokens , forceReplace -- test , TestStrategy (..) , testStrategy -- show files/index , files , directories , pending , nullFlag -- gzcrcs , GzcrcsAction (..) , gzcrcsActions -- optimize , siblings , reorderPatches , optimizePatchIndex ) where import Prelude hiding ( (^) ) import Data.Char ( isDigit ) import Data.List ( intercalate ) import Data.Maybe ( listToMaybe ) import Darcs.Repository.Flags ( Compression (..) , RemoteDarcs (..) , Reorder (..) , Verbosity (..) , UseCache (..) , UMask (..) , DryRun (..) , LookForAdds (..) , LookForMoves (..) , LookForReplaces (..) , DiffAlgorithm (..) , RunTest (..) , SetScriptsExecutable (..) , LeaveTestDir (..) , RemoteRepos (..) , SetDefault (..) , UseIndex (..) , ScanKnown (..) , CloneKind (..) , ExternalMerge (..) , WorkRepo (..) , AllowConflicts (..) , WantGuiPause (..) , WithPatchIndex (..) , WithWorkingDir (..) ) 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. The first parameter is instantiated to -- The flag type is instantiate to 'Flag'. type DarcsOption = OptSpec DarcsOptDescr Flag type RawDarcsOption = forall v. v -> RawOptSpec Flag v -- * 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", "overview"] F.Help (Just RootHelp) "show a brief description of all darcs commands and top-level options" , RawNoArg ['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","list-options"] 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 brief 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 "give only debug output" debugHttp :: PrimDarcsOption Bool debugHttp = singleNoArg [] ["debug-http"] F.DebugHTTP "debug output from libcurl" 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 "give verbose output" ] timings :: PrimDarcsOption Bool timings = singleNoArg [] ["timings"] F.Timings "provide debugging timings information" anyVerbosity :: DarcsOption a (Bool -> Bool -> Verbosity -> Bool -> a) anyVerbosity = debug ^ debugHttp ^ verbosity ^ timings where -- ** Hooks hooks :: DarcsOption a (Maybe String -> Bool -> Maybe String -> Bool -> a) hooks = preHook ^ postHook preHook :: DarcsOption a (Maybe String -> Bool -> a) preHook = prehookCmd ^ hookPrompt "prehook" F.AskPrehook F.RunPrehook postHook :: DarcsOption a (Maybe String -> Bool -> a) postHook = 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. That is beyond the goals of this sub-project (which is already large enough). -} data XmlOutput = NoXml | YesXml deriving (Eq, Show) xmloutput :: PrimDarcsOption XmlOutput xmloutput = withDefault NoXml [__xmloutput YesXml] __xmloutput :: RawDarcsOption __xmloutput val = RawNoArg [] ["xml-output"] F.XMLOutput val "generate XML formatted output" -- | 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. -- -- See also issue2397. dryRun :: PrimDarcsOption DryRun dryRun = (imap . cps) (Iso fw bw) $ singleNoArg [] ["dry-run"] F.DryRun "don't actually take the action" where fw True = YesDryRun fw False = NoDryRun bw YesDryRun = True bw NoDryRun = False dryRunXml :: DarcsOption a (DryRun -> XmlOutput -> a) dryRunXml = dryRun ^ xmloutput __dryrun :: RawDarcsOption __dryrun val = RawNoArg [] ["dry-run"] F.DryRun val "don't actually take the action" 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" ] -- | TODO: Returning @-1@ if the argument cannot be parsed as an integer is -- not something I expected to find in a Haskell program. Instead, the flag -- should take either a plain 'String' argument (leaving it to a later stage -- to parse the 'String' to an 'Int'), or else a @'Maybe' 'Int'@, taking -- the possibility of a failed parse into account. matchMaxcount :: PrimDarcsOption (Maybe Int) matchMaxcount = OptSpec {..} where ounparse k (Just n) = k [ F.MaxCount n ] ounparse k Nothing = k [] oparse k fs = k $ listToMaybe [ s | F.MaxCount s <- fs ] ocheck fs = case [ "--max-count="++show n | F.MaxCount n <- fs ] of cfs@(_:_:_) -> ["conflicting flags: " ++ intercalate ", " cfs] _ -> [] odesc = [ strArg [] ["max-count"] (F.MaxCount . toInt) "NUMBER" "return only NUMBER results" ] toInt s = if not (null s) && all isDigit s then read s else (-1) -- * Local or remote repo workRepo :: PrimDarcsOption WorkRepo workRepo = imap (Iso fw bw) $ workingRepoDir ^ possiblyRemoteRepo where fw k (WorkRepoDir s) = k (Just s) Nothing fw k (WorkRepoPossibleURL s) = k Nothing (Just s) fw k WorkRepoCurrentDir = k Nothing Nothing bw k (Just s) _ = k (WorkRepoDir s) bw k Nothing (Just s) = k (WorkRepoPossibleURL s) bw k Nothing Nothing = k WorkRepoCurrentDir workingRepoDir :: PrimDarcsOption (Maybe String) workingRepoDir = singleStrArg [] ["repodir"] F.WorkRepoDir arg "DIRECTORY" "specify the repository directory in which to run" where arg (F.WorkRepoDir s) = Just s arg _ = Nothing -- | @--repodir@ is there for compatibility, should be removed eventually -- -- IMHO the whole option can disappear; it overlaps with using an extra (non-option) -- argument, which is how e.g. @darcs get@ is usually invoked. reponame :: PrimDarcsOption (Maybe String) reponame = 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 remoteRepos :: PrimDarcsOption RemoteRepos remoteRepos = (imap . cps) (Iso fw bw) $ multiStrArg [] ["remote-repo"] F.RemoteRepo mkV "URL" "specify the remote repository URL to work with" where mkV fs = [ s | F.RemoteRepo s <- fs ] fw ss = RemoteRepos ss bw (RemoteRepos ss) = ss notInRemoteFlagName :: String notInRemoteFlagName = "not-in-remote" notInRemote :: PrimDarcsOption [Maybe String] notInRemote = 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] 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 useWorkingDir :: PrimDarcsOption WithWorkingDir useWorkingDir = withDefault WithWorkingDir [ RawNoArg [] ["with-working-dir"] F.UseWorkingDir WithWorkingDir "Create a working directory (normal repository)" , RawNoArg [] ["no-working-dir"] F.UseNoWorkingDir NoWorkingDir "Do not create a working directory (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" ] -- * 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) -- TODO: fix non-default behavior 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 data LookFor = LookFor { adds :: LookForAdds , replaces :: LookForReplaces , moves :: LookForMoves } lookfor :: PrimDarcsOption LookFor lookfor = imap (Iso fw bw) (lookforadds ^ lookforreplaces ^ lookformoves) where fw k (LookFor a r m) = k a r m bw k a r m = k (LookFor a r m) lookforadds :: PrimDarcsOption LookForAdds lookforadds = withDefault NoLookForAdds [ RawNoArg ['l'] ["look-for-adds"] F.LookForAdds YesLookForAdds "look for (non-boring) files that could be added" , RawNoArg [] ["dont-look-for-adds","no-look-for-adds"] F.NoLookForAdds NoLookForAdds "don't look for any files that could be added" ] 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 diffing :: PrimDarcsOption (UseIndex, ScanKnown, DiffAlgorithm) diffing = imap (Iso curry3 uncurry3) $ useIndex ^ scanKnown ^ diffAlgorithm where uncurry3 k x y z = k (x,y,z) curry3 k (x,y,z) = k x y z useIndex :: PrimDarcsOption UseIndex useIndex = (imap . cps) (Iso fw bw) ignoreTimes where fw False = UseIndex fw True = IgnoreIndex bw UseIndex = False bw IgnoreIndex = True scanKnown :: PrimDarcsOption ScanKnown scanKnown = imap (Iso fw bw) $ lookforadds ^ includeBoring where fw k ScanKnown = k NoLookForAdds False fw k ScanAll = k YesLookForAdds False fw k ScanBoring = k YesLookForAdds True bw k NoLookForAdds _ = k ScanKnown bw k YesLookForAdds False = k ScanAll bw k YesLookForAdds True = k ScanBoring 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) 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 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" ] data ExternalDiff = ExternalDiff { _diffCmd :: Maybe String, _diffOpts :: [String] } deriving (Eq, Show) extDiff :: PrimDarcsOption ExternalDiff extDiff = imap (Iso fw bw) $ extDiffCmd ^ extDiffOpts where fw k (ExternalDiff cmd opts) = k cmd opts bw k cmd opts = k (ExternalDiff cmd opts) 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 ] -- * Runnign tests data TestChanges = NoTestChanges | YesTestChanges LeaveTestDir deriving (Eq) testChanges :: PrimDarcsOption TestChanges testChanges = imap (Iso fw bw) $ test ^ leaveTestDir where fw k NoTestChanges = k NoRunTest {- undefined -} YesLeaveTestDir fw k (YesTestChanges ltd) = k YesRunTest ltd bw k NoRunTest _ = k NoTestChanges bw k YesRunTest ltd = k (YesTestChanges ltd) test :: PrimDarcsOption RunTest test = 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 YesLeaveTestDir [ 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.Target mkV "EMAIL" "specify destination email" where mkV fs = [ s | F.Target 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 -- TODO: do something about the nonsensical case (False, Just s) -- -- Some of the tests actually do this (pass --sendmail-command without -- passing --mail) and it's unclear if it's deliberate or just a historical -- accident after the issue2204 changes. We should untangle that and -- perhaps turn this into a single option with an optional argument. -- The other question to resolve is the interaction with the 'output' -- options to darcs send. sendmailIso :: Iso (Bool -> Maybe String -> a) ((Bool, Maybe String) -> a) sendmailIso = Iso uncurry curry sendmail :: PrimDarcsOption (Bool, Maybe String) sendmail = imap sendmailIso $ mail ^ sendmailCmd 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" ] -- TODO: turn these two into a combined option ccApply :: PrimDarcsOption (Maybe String) ccApply = singleStrArg [] ["cc"] F.Cc arg "EMAIL" "mail results to additional EMAIL(s). Requires --reply" where arg (F.Cc s) = Just s arg _ = Nothing reply :: PrimDarcsOption (Maybe String) reply = singleStrArg [] ["reply"] F.Reply arg "FROM" "reply to email-based patch using FROM address" where arg (F.Reply s) = Just s arg _ = Nothing happyForwarding :: PrimDarcsOption Bool happyForwarding = withDefault False [ RawNoArg [] ["happy-forwarding"] F.HappyForwarding True "forward unsigned messages without extra header" , RawNoArg [] ["no-happy-forwarding"] F.NoHappyForwarding False "don't forward unsigned messages without extra header" ] -- * 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 -- applyConflictOptions = conflicts NoAllowConflicts -- pullConflictOptions = conflicts YesAllowConflictsAndMark conflicts :: AllowConflicts -> PrimDarcsOption (Maybe AllowConflicts) conflicts def = withDefault (Just def) [ RawNoArg [] ["mark-conflicts"] F.MarkConflicts (Just YesAllowConflictsAndMark) "mark conflicts" , RawNoArg [] ["allow-conflicts"] F.AllowConflicts (Just YesAllowConflicts) "allow conflicts, but don't mark them" -- , RawNoArg [] ["no-resolve-conflicts"] -- NoAllowConflicts "equivalent to --dont-allow-conflicts, for backwards compatibility" , 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" ] -- Technically not an isomorphism, see 'sendmailIso'. useExternalMerge :: PrimDarcsOption ExternalMerge useExternalMerge = imap (Iso fw bw) $ singleStrArg [] ["external-merge"] F.ExternalMerge arg "COMMAND" "use external tool to merge conflicts" where arg (F.ExternalMerge s) = Just s arg _ = Nothing bw k (Just s) = k (YesExternalMerge s) bw k Nothing = k NoExternalMerge fw k (YesExternalMerge s) = k (Just s) fw k NoExternalMerge = k Nothing -- * Optimizations 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 patchIndex :: PrimDarcsOption WithPatchIndex patchIndex = 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" ] -- * 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 Summary = NoSummary | YesSummary deriving (Eq, Show) summary :: PrimDarcsOption (Maybe Summary) summary = withDefault Nothing [ RawNoArg ['s'] ["summary"] F.Summary (Just YesSummary) "summarize changes" , RawNoArg [] ["no-summary"] F.NoSummary (Just NoSummary) "don't summarize changes" ] -- | TODO: reconsider this grouping of options data NetworkOptions = NetworkOptions { noHttpPipelining :: Bool , remoteDarcs :: RemoteDarcs } networkIso :: Iso (Bool -> Maybe String -> a) (NetworkOptions -> a) networkIso = Iso fw bw where fw k (NetworkOptions x (RemoteDarcs y)) = k x (Just y) fw k (NetworkOptions x DefaultRemoteDarcs) = k x Nothing bw k x (Just y) = k (NetworkOptions x (RemoteDarcs y)) bw k x Nothing = k (NetworkOptions x DefaultRemoteDarcs) network :: PrimDarcsOption NetworkOptions network = imap networkIso $ singleNoArg [] ["no-http-pipelining"] F.NoHTTPPipelining "disable HTTP pipelining" ^ 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 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" ] restrictPaths :: PrimDarcsOption Bool restrictPaths = withDefault True [ RawNoArg [] ["restrict-paths"] F.RestrictPaths True "don't allow darcs to touch external files or repo metadata" , RawNoArg [] ["dont-restrict-paths","no-restrict-paths"] F.DontRestrictPaths False "allow darcs to modify any file or directory (unsafe)" ] -- * 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 -- | TODO: These should be mutually exclusive, but are they? The code is almost inscrutable. humanReadable :: PrimDarcsOption Bool humanReadable = withDefault False [__humanReadable True] __humanReadable :: RawDarcsOption __humanReadable val = RawNoArg [] ["human-readable"] F.HumanReadable val "give human-readable output" -- | See above. machineReadable :: PrimDarcsOption Bool machineReadable = singleNoArg [] ["machine-readable"] F.MachineReadable "give machine-readable output" -- ** clone partial :: PrimDarcsOption CloneKind partial = 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 String -> Maybe String -> a) marks = readMarks ^ writeMarks readMarks :: PrimDarcsOption (Maybe String) readMarks = singleStrArg [] ["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 String) writeMarks = singleStrArg [] ["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" ] data PatchFormat = PatchFormat1 | PatchFormat2 deriving (Eq, Show) patchFormat :: PrimDarcsOption PatchFormat patchFormat = withDefault PatchFormat2 [ 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 | GenContext | GenXml | NumberPatches | CountPatches deriving (Eq, Show) changesFormat :: PrimDarcsOption (Maybe ChangesFormat) changesFormat = withDefault Nothing [ RawNoArg [] ["context"] F.GenContext (Just GenContext) "give output suitable for get --context" , __xmloutput (Just GenXml) , __humanReadable (Just HumanReadable) , 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" ] -- ** show files/index 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 included recorded patches in output" ] -- "null" is already taken nullFlag :: PrimDarcsOption Bool nullFlag = singleNoArg ['0'] ["null"] F.NullFlag "separate file names by NUL characters" -- ** 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 "URL" "specify a sibling directory" where mkV fs = [ s | F.Sibling s <- fs ] reorderPatches :: PrimDarcsOption Bool reorderPatches = singleNoArg [] ["reorder-patches"] F.Reorder "reorder the patches in the repository" reorder :: PrimDarcsOption Reorder reorder = withDefault NoReorder [ RawNoArg [] ["reorder-patches"] F.Reorder Reorder "reorder the patches in the repository" , RawNoArg [] ["no-reorder-patches"] F.NoReorder NoReorder "don't reorder the patches in the repository" ] optimizePatchIndex :: PrimDarcsOption (Maybe WithPatchIndex) optimizePatchIndex = withDefault Nothing [ __patchIndex (Just YesPatchIndex) , __noPatchIndex (Just NoPatchIndex) ] darcs-2.10.2/src/Darcs/UI/Options/Util.hs0000644000175000017500000003033312620122474021770 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE RecordWildCards #-} -- | Constructing 'OptSpec's and 'OptDescr's module Darcs.UI.Options.Util ( Flag , PrimDarcsOption , DarcsOptDescr , noArg , strArg , optStrArg , absPathArg , absPathOrStdArg , optAbsPathArg , RawOptSpec(..) , withDefault , singleNoArg , singleStrArg , multiStrArg , multiOptStrArg , singleAbsPathArg , multiAbsPathArg , deprecated -- Re-exports , AbsolutePath , AbsolutePathOrStd , makeAbsolute , makeAbsoluteOrStd ) where import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) ) import Data.Functor.Compose import Data.List ( intercalate ) import Data.Maybe ( maybeToList, fromMaybe ) 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 'OptDescr's -- | Construct an '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 an '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 an '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 an '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 an '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 an '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 long switch names from a raw option. Used to construct error messages. switchNames :: RawOptSpec f v -> [String] switchNames (RawNoArg _ l _ _ _) = l switchNames (RawStrArg _ l _ _ _ _ _ _) = l switchNames (RawAbsPathArg _ l _ _ _ _ _ _) = l switchNames (RawAbsPathOrStdArg _ l _ _ _ _ _ _) = l switchNames (RawOptAbsPathArg _ l _ _ _ _ _ _ _) = l -- | 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' -> ["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' -> ("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 darcs-2.10.2/src/Darcs/UI/Options/Iso.hs0000644000175000017500000000140512620122474021603 0ustar00guillaumeguillaume00000000000000module Darcs.UI.Options.Iso where -- * 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) darcs-2.10.2/src/Darcs/UI/Options/Core.hs0000644000175000017500000002550012620122474021743 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE RecordWildCards #-} {-| Option specifications using continuations with a changing answer type. Based on @@ with additional inspiration provided by @@ 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 Prelude hiding ( (^) ) import Data.Monoid ( Monoid(..) ) import Darcs.UI.Options.Iso -- * Option specifications {-| 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] -> [String] -- ^ 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, which is useful as long as there is -- legacy code that circumvents the 'OptSpec' abstraction and directly tests -- for flag membership. -- -- 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 = [] -- | See 'oappend' and 'oempty'. instance Monoid (PrimOptSpec d f a [v]) where mappend = oappend 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 darcs-2.10.2/src/Darcs/UI/Options/Matching.hs0000644000175000017500000002130312620122474022602 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE RecordWildCards #-} {-| 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 , matchOne , matchOneContext , matchOneNontag , matchSeveral , matchSeveralOrFirst , matchSeveralOrLast , matchRange , matchSeveralOrRange , matchAny -- temporary, for toMatchFlags , context -- temporary, for getContext ) where import Prelude hiding ( last ) import Data.Char ( isDigit ) import Data.Monoid ( (<>), mconcat ) 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 matchOne :: MatchOption -- ^ amend, show files/contents, dist, annotate matchOne = 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, fetch matchSeveral :: MatchOption matchSeveral = matches <> patches <> tags <> hash -- | 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 matchRange :: MatchOption matchRange = mconcat [ matchTo, matchFrom, match, patch, hash, 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, 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 with 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 with 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.OneTag s | OneTag s <- mfs ] oparse k fs = k [ OneTag s | F.OneTag s <- fs ] ocheck _ = [] odesc = [ strArg ['t'] ["tags"] F.OneTag "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 with 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 s | LastN s <- mfs ] oparse k fs = k [ LastN s | F.LastN s <- fs ] ocheck _ = [] odesc = [ strArg [] ["last"] (F.LastN . toInt) "NUMBER" "select the last NUMBER patches" ] toInt s = if not (null s) && all isDigit s then read s else (-1) -- | TODO: see 'Darcs.UI.Options.matchMaxcount'. index = OptSpec {..} where ounparse k mfs = k [ F.PatchIndexRange n m | PatchIndexRange n m <- mfs ] oparse k fs = k [ PatchIndexRange n m | F.PatchIndexRange n m <- fs ] ocheck _ = [] odesc = [ strArg ['n'] ["index"] indexrange "N" "select one patch" ] indexrange s = if all isDigit s then F.PatchIndexRange (read s) (read s) else F.PatchIndexRange 0 0 -- | TODO: see 'Darcs.UI.Options.matchMaxcount'. indexes = OptSpec {..} where ounparse k mfs = k [ F.PatchIndexRange n m | PatchIndexRange n m <- mfs ] oparse k fs = k [ PatchIndexRange n m | F.PatchIndexRange n m <- fs ] ocheck _ = [] odesc = [ strArg ['n'] ["index"] indexrange "N-M" "select a range of patches" ] indexrange s = if all isokay s then if '-' `elem` s then let x1 = takeWhile (/= '-') s x2 = reverse $ takeWhile (/= '-') $ reverse s in F.PatchIndexRange (read x1) (read x2) else F.PatchIndexRange (read s) (read s) else F.PatchIndexRange 0 0 isokay c = isDigit c || c == '-' darcs-2.10.2/src/Darcs/UI/Options/Flags.hs0000644000175000017500000001112612620122474022106 0ustar00guillaumeguillaume00000000000000-- |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.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 | Target 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 | OneHash String | AfterPatch String | UpToPatch String | AfterHash String | UpToHash 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 | 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 | RemoteRepo 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 | OnePattern String | SeveralPattern String | AfterPattern String | UpToPattern String | NonApply | NonVerify | NonForce | DryRun | SetDefault | NoSetDefault | Disable | SetScriptsExecutable | DontSetScriptsExecutable | Once | Linear | Backoff | Bisect | Hashed -- deprecated flag, here to output an error message | UseFormat1 | UseFormat2 | 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 String | WriteMarks String | NullFlag | NoAmendUnrecord | AmendUnrecord | PatchIndexFlag | NoPatchIndexFlag deriving ( Eq, Show ) darcs-2.10.2/src/Darcs/UI/Options/Markdown.hs0000644000175000017500000000266412620122474022643 0ustar00guillaumeguillaume00000000000000-- Support for @darcs help markdown@ module Darcs.UI.Options.Markdown ( optionsMarkdown ) where import Data.Functor.Compose ( Compose(..) ) import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) ) import Darcs.UI.Options.Util ( DarcsOptDescr ) optionsMarkdown :: [DarcsOptDescr f] -> String optionsMarkdown opts = unlines [ "", unlines (map optionMarkdown opts), "
" ] optionMarkdown :: DarcsOptDescr f -> String optionMarkdown (Compose (Option a b (NoArg _) h)) = unlines [ "", "", showShortOptionsMd a, "" , "", showLongOptionsMd b , "" , "", h, "" , "" ] optionMarkdown (Compose (Option a b (ReqArg _ arg) h)) = unlines [ "", "", showShortOptionsMd a, "" , "", showLongOptionsMd (map (++(' ' : arg)) b), "" , "", h, "", "" ] optionMarkdown (Compose (Option a b (OptArg _ arg) h)) = unlines [ "", "", showShortOptionsMd a, "" , "", showLongOptionsMd (map (++("[="++arg++"]")) b), "" , "", h, "", "" ] 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 darcs-2.10.2/src/Darcs/UI/Email.hs0000644000175000017500000002553712620122474020461 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.UI.Email ( makeEmail , readEmail , formatHeader ) where import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) import Data.List ( isInfixOf ) import Darcs.Util.Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS , RenderMode(..) ) 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 ) 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 -- 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 /= 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 Standard 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 Standard bundle) of Just s -> packedString $ qpencode s -- this should not happen, but in case it does, keep everything Nothing -> packedString $ qpencode $ renderPS Standard 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 Standard 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' darcs-2.10.2/src/Darcs/UI/Options.hs0000644000175000017500000000155112620122474021053 0ustar00guillaumeguillaume00000000000000module Darcs.UI.Options ( module Darcs.UI.Options.Core , module Darcs.UI.Options.Markdown , DarcsOption , PrimDarcsOption , DarcsOptDescr , optDescr ) where import Data.Functor.Compose import System.Console.GetOpt import Darcs.UI.Options.All import Darcs.UI.Options.Core import Darcs.UI.Options.Markdown import Darcs.UI.Options.Util ( DarcsOptDescr, PrimDarcsOption ) import Darcs.Util.Path ( AbsolutePath ) -- * Type instantiations -- | The @instance Functor OptDescr@ was introduced only in base-4.7.0.0, which is -- why we implement it here manually. optDescr :: AbsolutePath -> DarcsOptDescr f -> OptDescr f optDescr path = omap ($path) . getCompose where omap f (Option s l a h) = Option s l (amap f a) h amap f (NoArg a) = NoArg (f a) amap f (ReqArg mkF n) = ReqArg (fmap f mkF) n amap f (OptArg mkF n) = OptArg (fmap f mkF) n darcs-2.10.2/src/Darcs/UI/TheCommands.hs0000644000175000017500000001026712620122474021626 0ustar00guillaumeguillaume00000000000000-- 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.UI.TheCommands ( commandControlList ) where import Prelude () 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, list, query ) 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 ) 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 "Changing and querying the working copy:" , normalCommand add , normalCommand remove, hiddenCommand unadd, hiddenCommand rm , normalCommand move, hiddenCommand mv , normalCommand replace , normalCommand revert , normalCommand unrevert , normalCommand whatsnew, hiddenCommand status , commandGroup "Copying changes between the working copy and the repository:" , normalCommand record, hiddenCommand commit , normalCommand unrecord , normalCommand amend , hiddenCommand amendrecord , normalCommand markconflicts , commandGroup "Direct modification of the repository:" , normalCommand tag , normalCommand setpref , commandGroup "Querying the repository:" , normalCommand diffCommand , normalCommand log, hiddenCommand changes , normalCommand annotate , normalCommand dist , normalCommand test , normalCommand showCommand, hiddenCommand list, hiddenCommand query , hiddenCommand transferMode , commandGroup "Copying patches between repositories with working copy update:" , normalCommand pull , normalCommand fetch , normalCommand obliterate, hiddenCommand unpull , normalCommand rollback , normalCommand push , normalCommand send , normalCommand apply , normalCommand clone, hiddenCommand get, hiddenCommand put , commandGroup "Administrating repositories:" , normalCommand initialize , normalCommand optimize , normalCommand repair, hiddenCommand check , normalCommand convert , hiddenCommand gzcrcs , normalCommand rebase ] darcs-2.10.2/src/Darcs/UI/Usage.hs0000644000175000017500000000562612620122474020473 0ustar00guillaumeguillaume00000000000000-- | This module provides a variant of 'System.Console.GetOpt.usageInfo'. -- -- Unlike the standard @usageInfo@ function, lists of long switches are broken -- across multiple lines to economise on columns. For example, -- -- @ -- -r --recursive add contents of subdirectories -- --not-recursive, -- --no-recursive don't add contents of subdirectories -- @ module Darcs.UI.Usage ( usageInfo ) where import Data.Functor.Compose import System.Console.GetOpt( OptDescr(..), ArgDescr(..) ) import Darcs.UI.Options ( DarcsOptDescr ) -- | Variant of 'System.Console.GetOpt.usageInfo'. -- Return a string describing the usage of a command, derived from the header -- (first argument) and the options described by the second argument. -- -- Sequences of long switches are presented on separate lines. usageInfo :: String -- header -> [DarcsOptDescr a] -- option descriptors -> String -- nicely formatted decription of options usageInfo header optDescr = unlines (header:table) where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr table = zipWith3 paste shortPadded (zipWith (++) (map (unlines' . init) ls) (sameLen $ map last ls)) ds shortPadded = sameLen ss prePad = replicate (4 + length (head 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 sepBy _ [] = "" sepBy _ [x] = x sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs sosFmt = sepBy ',' (map (fmtShort ad) sos) losFmt = map (fmtLong ad) los -------------------------------------------------------------------------------- -- Verbatim copies: these definitions aren't exported by System.Console.GetOpt -------------------------------------------------------------------------------- fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _ ) so = ['-', so] fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _ ) lo = "--" ++ lo fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" darcs-2.10.2/src/Darcs/UI/External.hs0000644000175000017500000005515712620122474021215 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.UI.External ( sendEmail , generateEmail , sendEmailDoc , resendEmail , signString , verifyPS , execDocPipe , execPipeIgnoreError , pipeDoc , pipeDocSSH , maybeURLCmd , viewDoc , viewDocWith , haveSendmail , sendmailPath , diffProgram , darcsProgram , editText , editFile , catchall -- * Locales , setDarcsEncodings , getSystemEncoding , isUTF8Locale ) where import Prelude hiding ( catch ) import Data.Maybe ( isJust, isNothing, maybeToList ) import Control.Monad ( unless, when, filterM, liftM2, void ) import GHC.MVar ( MVar ) import System.Exit ( ExitCode(..) ) import System.Environment ( getEnv #if __GLASGOW_HASKELL__ >= 706 , getExecutablePath #else , getProgName #endif ) import System.IO ( hPutStr, hPutStrLn, hClose, hIsTerminalDevice, stdout, stderr, Handle ) import System.Directory ( doesFileExist, findExecutable ) import System.FilePath.Posix ( () ) import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) ) import System.Process.Internals ( ProcessHandle ) import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 ) import Foreign.C.String ( CString, peekCString ) import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar ) import Control.Exception ( try, finally, catch, IOException ) import System.IO.Error ( ioeGetErrorType ) import GHC.IO.Exception ( IOErrorType(ResourceVanished) ) import Data.Char ( toUpper, toLower ) import Text.Regex #if defined (HAVE_MAPI) import Foreign.C ( withCString ) #endif #ifdef HAVE_MAPI import Foreign.Ptr ( nullPtr ) import Darcs.Repository.Lock ( canonFilename, writeDocBinFile ) #endif import Darcs.Util.SignalHandler ( catchNonSignal ) 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 (ByteString, empty, null, readFile ,hGetContents, writeFile, hPut, length ,take, concat, drop, isPrefixOf, singleton, append) import qualified Data.ByteString.Char8 as BC (unpack, pack) import Darcs.Repository.Lock ( withTemp , withNamedTemp , withOpenTemp ) import Darcs.Repository.Ssh ( getSSH, SSHCmd(..) ) import Darcs.Util.CommandLine ( parseCmd, addUrlencoded ) import Darcs.Util.Exec ( execInteractive, exec, Redirect(..), withoutNonBlock ) import Darcs.Util.URL ( SshFilePath, sshUhost ) import Darcs.Util.Printer ( Doc, Printers, hPutDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS, simplePrinters, hPutDocCompr, text, empty, packedString, vcat, renderString, RenderMode(..) ) import qualified Darcs.Util.Ratified as Ratified import Darcs.UI.Email ( formatHeader ) 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 @getExecutablePath@) darcsProgram :: IO String #if __GLASGOW_HASKELL__ >= 706 darcsProgram = getExecutablePath #else darcsProgram = getProgName #endif 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 pipeDoc :: RenderMode -> 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 -> RenderMode -> String -> [String] -> Doc -> IO ExitCode pipeDocInternal whereToPipe target c args inp = withoutNonBlock $ withoutProgress $ do debugMessage $ unwords (c:args) (Just i,_,_,pid) <- createProcess (proc c args){ std_in = CreatePipe {- , delegate_ctlc = True -- requires process 1.2.2.0 -} } debugMessage "Start transferring data" case whereToPipe of PipeToSsh GzipCompression -> hPutDocCompr target i inp PipeToSsh NoCompression -> hPutDoc target i inp PipeToOther printers -> hPutDocWith printers target 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 -> RenderMode -> SshFilePath -> [String] -> Doc -> IO ExitCode pipeDocSSH compress target remoteAddr args input = do (ssh, ssh_args) <- getSSH SSH pipeDocInternal (PipeToSsh compress) target 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 unless (null cc) $ putHeader "Cc" cc putHeader "X-Mail-Originator" "Darcs Version Control System" hPutDocLn Standard 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 Standard hat bundle return [ ('b', renderString Standard content) , ('a', at) ] Nothing -> return [ ('b', renderString Standard 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 Standard 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 Standard 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 Standard) $ execDocPipe Standard c args $ packedString ps execAndGetOutput :: RenderMode -> FilePath -> [String] -> Doc -> IO (ProcessHandle, MVar (), B.ByteString) execAndGetOutput target c args instr = do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing _ <- forkIO $ hPutDoc target i instr >> hClose i mvare <- newEmptyMVar _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed hPutStr stderr) `finally` putMVar mvare ()) out <- B.hGetContents o return (pid, mvare, out) execDocPipe :: RenderMode -> String -> [String] -> Doc -> IO Doc execDocPipe target c args instr = withoutProgress $ do (pid, mvare, out) <- execAndGetOutput target c args instr 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 :: RenderMode -> String -> [String] -> Doc -> IO Doc execPipeIgnoreError target c args instr = withoutProgress $ do (pid, mvare, out) <- execAndGetOutput target c args instr _ <- waitForProcess pid takeMVar mvare return $ if B.null out then empty else packedString out 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 Standard "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 Standard "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 $ 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 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 Encode viewDocWith :: Printers -> RenderMode -> Doc -> IO () viewDocWith pr mode msg = do isTerminal <- hIsTerminalDevice stdout void $ if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString mode msg) then do mbViewerPlusArgs <- getViewer case mbViewerPlusArgs of Just viewerPlusArgs -> do let (viewer : args) = words viewerPlusArgs pipeDocToPager viewer args pr mode msg Nothing -> return $ ExitFailure 127 -- No such command -- TEMPORARY passing the -K option should be removed as soon as -- we can use the delegate_ctrl_c feature in process `ortryrunning` pipeDocToPager "less" ["-RK"] pr mode msg `ortryrunning` pipeDocToPager "more" [] pr mode msg #ifdef WIN32 `ortryrunning` pipeDocToPager "more.com" [] pr mode msg #endif `ortryrunning` pipeDocToPager "" [] pr mode msg else pipeDocToPager "" [] pr mode 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 -> RenderMode -> Doc -> IO ExitCode pipeDocToPager "" _ pr mode inp = do hPutDocLnWith pr mode stdout inp return ExitSuccess pipeDocToPager c args pr mode inp = pipeDocInternal (PipeToOther pr) mode 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 execInteractive ed f `ortryrunning` execInteractive "vi" f `ortryrunning` execInteractive "emacs" f `ortryrunning` execInteractive "emacs -nw" 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 "nano" catchall :: IO a -> IO a -> IO a a `catchall` b = a `catchNonSignal` (\_ -> b) -- | 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@. -- -- Prevent HLint from warning us about a redundant do if the macro isn't -- defined: setDarcsEncodings :: IO () setDarcsEncodings = do -- 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 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]+" darcs-2.10.2/src/Darcs/UI/Defaults.hs0000644000175000017500000002267412620122474021200 0ustar00guillaumeguillaume00000000000000module Darcs.UI.Defaults ( applyDefaults ) where import Control.Monad.Writer import Data.Char ( isSpace ) import Data.Functor.Compose ( Compose(..) ) import Data.List ( nub, intercalate ) import Data.Maybe ( catMaybes ) import qualified Data.Map as M import System.Console.GetOpt import Text.Regex.Applicative ( (<$>), (<*>), (*>), (<|>) , match, pure, many, some , psym, anySym, string ) import Darcs.UI.Flags ( DarcsFlag ) import Darcs.UI.Options ( DarcsOptDescr ) import Darcs.UI.Commands ( DarcsCommand(..), commandAlloptions, extractAllCommands , WrappedCommand(..) ) 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 -> DarcsCommand pf -> AbsolutePath -> [String] -> [String] -> [DarcsFlag] -> ([DarcsFlag], [String]) applyDefaults msuper cmd cwd user repo flags = 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 -- | 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] -> [String]) -> [DarcsFlag] -> Writer [String] [DarcsFlag] runChecks source check fs = case check fs of [] -> return fs es -> do tell [intercalate "\n" $ map ((source++": ")++) es] return fs -- | 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. -- -- It is debatable whether these checks are useful. On the one hand they can help -- detect typos in defaults files. On the other hand they make it difficult to -- use different versions of darcs in parallel: a default for an option that is -- only available in a later version will make the earlier version produce an -- error. Maybe reduce this to a warning? parseDefaults :: String -> AbsolutePath -> CmdName -> [DarcsOptDescr DarcsFlag] -> ([DarcsFlag] -> [String]) -> [String] -> Writer [String] [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 [source++": command '"++showCmdName cmd ++"' has no option '"++switch++"'."] return Nothing else mapErrors ((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 *> opt_dashes *> word) <*> rest match_cmd (NormalCmd name) = string name match_cmd (SuperCmd super sub) = string super *> spaces *> string sub opt_dashes = string "--" <|> pure "" word = some $ psym (not.isSpace) spaces = some $ psym isSpace rest = spaces *> many anySym <|> pure "" {- $note This definition is a bit simpler, and doesn't need Text.Regex.Applicative, but it has two disadvantages over the one above: * Flag arguments are split and joined again with words/unwords, which means that whitespace inside an argument is not preserved literally. * It is less easily extendable with new syntax. > parseDefaultsLines :: CmdName -> [String] -> [(String, String)] > parseDefaultsLines name entries = case name of > SuperCmd super sub -> [ mk_def d as | (s:c:d:as) <- map words entries, s == super, c == sub ] > NormalCmd cmd -> [ mk_def d as | (c:d:as) <- map words entries, c == cmd ] > where > mk_def d as = (drop_dashes d, unwords as) > drop_dashes ('-':'-':switch) = switch > drop_dashes switch = switch -} -- | 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 [String] (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 ["'"++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 ["'"++switch++"' requires an argument, but no "++"argument given."] return Nothing else return $ Just $ mkFlag arg cwd -- | Get all the longSwitches from a list of options. optionSwitches :: [DarcsOptDescr DarcsFlag] -> [String] optionSwitches = concatMap sel where sel (Compose (Option _ switches _ _)) = switches -- | A finite map from long switches 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@(Compose (Option _ switches _ _)) = map (add_option o) switches -- | List of option switches of all commands (except help but that has no options). allOptionSwitches :: [String] allOptionSwitches = nub $ optionSwitches $ concatMap (\(WrappedCommand c) -> uncurry (++) . commandAlloptions $ c) $ extractAllCommands commandControlList darcs-2.10.2/src/Darcs/UI/RunCommand.hs0000644000175000017500000002447012620122474021470 0ustar00guillaumeguillaume00000000000000-- 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 #-} -- | 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 ) where import Prelude hiding ( (^) ) import Data.Functor ((<$>)) import Data.List ( intercalate ) import Control.Monad ( unless, when ) import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ), OptDescr( Option ), getOpt ) import System.Exit ( ExitCode ( ExitSuccess ), exitWith ) import Darcs.UI.Options ( DarcsOption, (^), odesc, oparse, parseFlags, optDescr ) import Darcs.UI.Options.All ( stdCmdActions, StdCmdAction(..) , anyVerbosity, verbosity, Verbosity(..), network, NetworkOptions(..) , preHook, postHook ) import Darcs.UI.Defaults ( applyDefaults ) import Darcs.UI.External ( viewDoc ) import Darcs.UI.Flags ( DarcsFlag (NewRepo), toMatchFlags, fixRemoteRepos ) import Darcs.UI.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ) , CommandControl , DarcsCommand , commandName , commandCommand , commandPrereq , commandExtraArgHelp , commandExtraArgs , commandArgdefaults , commandGetArgPossibilities , commandOptions , commandParseOptions , wrappedCommandName , disambiguateCommands , getCommandHelp , getCommandMiniHelp , getSubcommands , extractCommands , superName , subusage , formatPath ) import Darcs.UI.Commands.GZCRCs ( doCRCWarnings ) import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH ) import Darcs.Patch.Match ( checkMatchSyntax ) import Darcs.Repository.Prefs ( getGlobal, getPreflist ) import Darcs.Repository.Test ( runPosthook, runPrehook ) import Darcs.Util.AtExit ( atexit ) import Darcs.Util.Download ( setDebugHTTP, disableHTTPPipelining ) import Darcs.Util.Global ( setDebugMode, setTimingsMode ) import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute ) import Darcs.Util.Printer ( text ) import Darcs.Util.Progress ( setProgressMode ) import Darcs.Util.Text ( chompTrailingNewline ) 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 runCommand :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [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 old_wd <- getCurrentDirectory let options = commandOptions 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 user_defs <- getGlobal "defaults" repo_defs <- getPreflist "defaults" let (flags,flag_errors) = applyDefaults (fmap commandName msuper) cmd old_wd user_defs repo_defs cmdline_flags case parseFlags stdCmdActions flags of Just Help -> viewDoc $ text $ getCommandHelp msuper cmd Just ListOptions -> do setProgressMode False file_args <- commandGetArgPossibilities cmd putStrLn $ intercalate "\n" $ getOptionsOptions options : file_args Just Disable -> fail $ "Command "++commandName cmd++" disabled with --disable option!" Nothing -> case prereq_errors of Left complaint -> fail $ "Unable to " ++ formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++ " here.\n\n" ++ complaint Right () -> case getopt_errs ++ flag_errors of [] -> do extra <- commandArgdefaults cmd flags old_wd orig_extra case extraArgumentsError extra cmd msuper of Nothing -> runWithHooks cmd old_wd flags extra Just msg -> fail msg es -> fail (intercalate "\n" es) fixupMsgs :: (a, b, [String]) -> (a, b, [String]) fixupMsgs (fs,as,es) = (fs,as,map (("command line: "++).chompTrailingNewline) es) withHookOpts :: DarcsOption a (t2 -> t3 -> t4 -> t1) -> (t2 -> t3 -> t4 -> t -> t1) -> [DarcsFlag] -> t -> a withHookOpts opts runHook flags path = oparse opts runHook' flags where runHook' mcmd ask verb = runHook mcmd ask verb path runWithHooks :: DarcsCommand pf -> AbsolutePath -> [DarcsFlag] -> [String] -> IO () runWithHooks cmd old_wd flags extra = do -- NOTE: we must get the cwd again because commandPrereq has the side-effect of changing it. new_wd <- getCurrentDirectory checkMatchSyntax $ toMatchFlags flags -- set any global variables oparse (anyVerbosity ^ network) setGlobalVariables flags -- actually run the command and its hooks preHookExitCode <- withHookOpts (preHook ^ verbosity) runPrehook flags new_wd if preHookExitCode /= ExitSuccess then exitWith preHookExitCode else do fixedFlags <- fixRemoteRepos old_wd flags phDir <- getPosthookDir new_wd cmd fixedFlags extra let parsedFlags = commandParseOptions cmd fixedFlags commandCommand cmd (new_wd, old_wd) parsedFlags extra postHookExitCode <- withHookOpts (postHook ^ verbosity) runPosthook flags phDir exitWith postHookExitCode setGlobalVariables :: Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO () setGlobalVariables debug debugHttp verb timings net = do when timings setTimingsMode when debug setDebugMode when debugHttp setDebugHTTP when (verb == Quiet) $ setProgressMode False when (noHttpPipelining net) disableHTTPPipelining 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 pf -> [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 (NewRepo outname:flags) [inrepodir] [inrepodir] -> case cloneToSSH flags of Nothing -> do repodir <- toPath <$> ioAbsoluteOrRemote inrepodir reponame <- makeRepoName False flags repodir return $ makeAbsolute new_wd reponame _ -> return new_wd _ -> fail "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 pf1 -> Maybe (DarcsCommand pf2) -> 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" getOptionsOptions :: [OptDescr DarcsFlag] -> String getOptionsOptions = intercalate "\n" . concatMap goo where goo (Option _ os _ _) = map ("--"++) os runRawSupercommand :: DarcsCommand pf -> [String] -> IO () runRawSupercommand super [] = fail $ "Command '"++ commandName super ++"' requires a subcommand!\n\n" ++ 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 $ text $ getCommandHelp Nothing super Just ListOptions -> do putStrLn "--help" mapM_ (putStrLn . wrappedCommandName) (extractCommands $ getSubcommands super) Just Disable -> do fail $ "Command " ++ commandName super ++ " disabled with --disable option!" Nothing -> fail $ case getopt_errs of [] -> "Invalid subcommand!\n\n" ++ subusage super _ -> intercalate "\n" getopt_errs darcs-2.10.2/src/Darcs/UI/CommandsAux.hs0000644000175000017500000000614412620122474021642 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2006 Tommy Pettersson -- -- 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.UI.CommandsAux ( checkPaths , maliciousPatches , hasMaliciousPath ) where import Control.Monad ( when ) import Darcs.UI.Flags ( DarcsFlag ) import Darcs.UI.Options ( parseFlags ) import Darcs.UI.Options.All ( restrictPaths ) import Darcs.Patch.Inspect ( PatchInspect, listTouchedFiles ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2 ) import Darcs.Util.Path ( isMaliciousPath ) -- * 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 :: PatchInspect p => [DarcsFlag] -> FL p wX wY -> IO () checkPaths opts patches = when (parseFlags restrictPaths opts && or (mapFL hasMaliciousPath patches)) $ fail $ unlines $ ["Malicious path in patch:"] ++ map (" " ++) (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 -- | Filter out patches that contains some malicious file path maliciousPatches :: PatchInspect p => [Sealed2 p] -> [Sealed2 p] maliciousPatches = filter (unseal2 hasMaliciousPath) hasMaliciousPath :: PatchInspect p => p wX wY -> Bool hasMaliciousPath patch = case maliciousPaths patch of [] -> False _ -> True maliciousPaths :: PatchInspect p => p wX wY -> [String] maliciousPaths patch = let paths = listTouchedFiles patch in filter isMaliciousPath paths darcs-2.10.2/src/Darcs/UI/Flags.hs0000644000175000017500000004740312620122474020462 0ustar00guillaumeguillaume00000000000000-- 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.Flags ( -- TODO we want to stop exporting the constructors of DarcsFlag -- from here. First need to change all the relevant code over to the -- using helpers from this module instead. F.DarcsFlag( .. ) , compression , remoteDarcs , reorder , minimize , editDescription , diffingOpts , diffOpts , externalMerge , wantGuiPause , isInteractive , maxCount , willRemoveLogFile , isUnified , doHappyForwarding , includeBoring , doAllowCaseOnly , doAllowWindowsReserved , doReverse , usePacks , showChangesOnlyToFiles , removeFromAmended , toMatchFlags , verbosity , useCache , umask , dryRun , lookForAdds , lookForMoves , lookForReplaces , diffAlgorithm , runTest , testChanges , setScriptsExecutable , withWorkingDir , leaveTestDir , remoteRepos , setDefault , cloneKind , workRepo , allowConflicts , runPatchIndex , useIndex , hasSummary , hasXmlOutput , selectDeps , hasAuthor , hasLogfile , patchFormat , fixRemoteRepos , fixUrl , fixSubPaths , maybeFixSubPaths , getRepourl , getAuthor , promptAuthor , getEasyAuthor , getSendmailCmd , fileHelpAuthor , environmentHelpEmail , getSubject , getCharset , getInReplyTo , getCc , environmentHelpSendmail , siblings , getOutput , getDate , getReply , applyAs ) where import Prelude hiding ( (^) ) import Data.List ( nub, intercalate ) import Data.Maybe ( isJust , maybeToList , isNothing , catMaybes ) import Control.Monad ( unless ) import Control.Applicative( (<$>) ) import System.Directory ( doesDirectoryExist, createDirectory ) import System.FilePath.Posix ( () ) import qualified Darcs.Patch.Match as MF ( MatchFlag(..) ) import Darcs.UI.External ( catchall ) import qualified Darcs.UI.Options.Flags as F ( DarcsFlag( .. ) ) import Darcs.UI.Options.Core import qualified Darcs.UI.Options.All as O import Darcs.Util.Environment ( maybeGetEnv ) import Darcs.Util.Exception ( firstJustIO ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( askUser , askUserListItem ) import Darcs.Repository.Lock ( writeLocaleFile ) import Darcs.Repository.Prefs ( getPreflist , getGlobal , globalPrefsDirDoc , globalPrefsDir ) import Darcs.Util.ByteString ( decodeString ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.IsoDate ( getIsoDateTime, cleanLocalDate ) import Darcs.Util.Path ( AbsolutePath , AbsolutePathOrStd , SubPath , toFilePath , makeSubPathOf , ioAbsolute , makeAbsoluteOrStd ) import Darcs.Util.Printer ( putDocLn, text, ($$) ) import Darcs.Util.URL ( isValidLocalPath ) type Config = [F.DarcsFlag] compression :: Config -> O.Compression compression = parseFlags O.compress remoteDarcs :: Config -> O.RemoteDarcs remoteDarcs = O.remoteDarcs . parseFlags O.network reorder :: Config -> O.Reorder reorder = parseFlags O.reorder minimize :: Config -> Bool minimize = parseFlags O.minimize editDescription :: Config -> Bool editDescription = parseFlags O.editDescription -- | Non-trivial interaction between options. diffOpts :: O.UseIndex -> O.LookForAdds -> Bool -> O.DiffAlgorithm -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) diffOpts use_index look_for_adds include_boring diff_alg = (use_index, scanKnown look_for_adds include_boring, diff_alg) where scanKnown O.NoLookForAdds _ = O.ScanKnown scanKnown O.YesLookForAdds False = O.ScanAll scanKnown O.YesLookForAdds True = O.ScanBoring diffingOpts :: Config -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) diffingOpts flags = diffOpts (useIndex flags) (lookForAdds flags) False (diffAlgorithm flags) externalMerge :: Config -> O.ExternalMerge externalMerge = parseFlags O.useExternalMerge -- | 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 = (/= O.NoExternalMerge) . parseFlags O.useExternalMerge 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 maxCount :: Config -> Maybe Int maxCount = parseFlags O.matchMaxcount willRemoveLogFile :: Config -> Bool willRemoveLogFile = O._rmlogfile . parseFlags O.logfile isUnified :: Config -> O.WithContext isUnified = parseFlags O.withContext doHappyForwarding :: Config -> Bool doHappyForwarding = parseFlags O.happyForwarding includeBoring :: Config -> Bool includeBoring = parseFlags O.includeBoring doAllowCaseOnly :: Config -> Bool doAllowCaseOnly = parseFlags O.allowCaseDifferingFilenames doAllowWindowsReserved :: Config -> Bool doAllowWindowsReserved = parseFlags O.allowWindowsReservedFilenames doReverse :: Config -> Bool doReverse = parseFlags O.changesReverse usePacks :: Config -> Bool usePacks = parseFlags O.usePacks showChangesOnlyToFiles :: Config -> Bool showChangesOnlyToFiles = parseFlags O.onlyToFiles removeFromAmended :: Config -> Bool removeFromAmended = parseFlags O.amendUnrecord toMatchFlags :: Config -> [MF.MatchFlag] toMatchFlags = parseFlags O.matchAny verbosity :: Config -> O.Verbosity verbosity = parseFlags O.verbosity useCache :: Config -> O.UseCache useCache = parseFlags O.useCache umask :: Config -> O.UMask umask = parseFlags O.umask dryRun :: Config -> O.DryRun dryRun = parseFlags O.dryRun runPatchIndex :: Config -> O.WithPatchIndex runPatchIndex = parseFlags O.patchIndex lookForAdds :: Config -> O.LookForAdds lookForAdds = O.adds . parseFlags O.lookfor lookForReplaces :: Config -> O.LookForReplaces lookForReplaces = O.replaces . parseFlags O.lookfor diffAlgorithm :: Config -> O.DiffAlgorithm diffAlgorithm = parseFlags O.diffAlgorithm lookForMoves :: Config -> O.LookForMoves lookForMoves = O.moves . parseFlags O.lookfor runTest :: Config -> O.RunTest runTest = parseFlags O.test testChanges :: Config -> O.TestChanges testChanges = parseFlags O.testChanges setScriptsExecutable :: Config -> O.SetScriptsExecutable setScriptsExecutable = parseFlags O.setScriptsExecutable withWorkingDir :: Config -> O.WithWorkingDir withWorkingDir = parseFlags O.useWorkingDir leaveTestDir :: Config -> O.LeaveTestDir leaveTestDir = parseFlags O.leaveTestDir remoteRepos :: Config -> O.RemoteRepos remoteRepos = parseFlags O.remoteRepos 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 cloneKind :: Config -> O.CloneKind cloneKind = parseFlags O.partial workRepo :: Config -> O.WorkRepo workRepo = parseFlags O.workRepo allowConflicts :: Config -> O.AllowConflicts allowConflicts = maybe O.NoAllowConflicts id . parseFlags (O.conflicts O.NoAllowConflicts) -- | Ugly. The alternative is to put the remoteRepos accessor into the IO monad, -- which is hardly better. fixRemoteRepos :: AbsolutePath -> Config -> IO Config fixRemoteRepos d = mapM fixRemoteRepo where fixRemoteRepo (F.RemoteRepo p) = F.RemoteRepo `fmap` fixUrl d p fixRemoteRepo f = return f -- | 'fixUrl' takes a String that may be a file path or a URL. -- It returns either the URL, or an absolute version of the path. fixUrl :: AbsolutePath -> String -> IO String fixUrl d f = if isValidLocalPath f then toFilePath `fmap` withCurrentDirectory d (ioAbsolute 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 :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [Maybe SubPath] maybeFixSubPaths (r, o) 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 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 :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [SubPath] fixSubPaths fps fs = nub . catMaybes <$> maybeFixSubPaths fps (filter (not . null) fs) -- | '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 `). 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 (fancyPrompt as) (fancyPrompt as) else return a [] -> askForAuthor shortPrompt longPrompt _ -> askForAuthor (fancyPrompt as) (fancyPrompt as) where shortPrompt = askUser "What is your email address? " longPrompt = askUser "What is your email address (e.g. Fred Bloggs )? " 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 && store then do putDocLn $ text "Each patch is attributed to its author, usually by email address (for" $$ text "example, `Fred Bloggs '). Darcs could not determine" $$ text "your email address, so you will be prompted for it." $$ text "" $$ text ("Your address will be stored in " ++ globalPrefsDirDoc ++ "author") $$ text "It will be used for all patches you record in ALL repositories." $$ text ("If you move that file to " ++ darcsdir "prefs" "author, it will") $$ text "be used for patches recorded in this repository only." add <- askfn1 maybeprefsdir <- globalPrefsDir prefsdir <- case maybeprefsdir of Nothing -> do putStrLn "WARNING: Global preference directory could not be found." return $ darcsdir "prefs" Just dir -> do exists <- doesDirectoryExist dir unless exists $ createDirectory dir return dir writeLocaleFile (prefsdir "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 = firstNotNullIO [ (take 1 . nonblank) `fmap` getPreflist "author" , nonblank `fmap` getGlobal "author" , maybeToList `fmap` maybeGetEnv "DARCS_EMAIL" , maybeToList `fmap` maybeGetEnv "EMAIL" ] >>= mapM decodeString 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 String getSendmailCmd fs = case parseFlags O.sendmailCmd fs of Just cmd -> return cmd Nothing -> fmap (maybe "" id) $ firstJustIO [ maybeGetEnv "SENDMAIL" ] -- | Accessor for output option getOutput :: Config -> FilePath -> Maybe AbsolutePathOrStd getOutput fs fp = fmap go (parseFlags O.output fs) where go (O.Output ap) = ap go (O.OutputAutoName ap) = makeAbsoluteOrStd ap fp getCharset :: Config -> Maybe String getCharset = parseFlags O.charset -- |'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 getReply :: Config -> Maybe String getReply = parseFlags O.reply -- | 'flagsToSiblings' collects the contents of all @Sibling@ flags in a list of flags. siblings :: Config -> [AbsolutePath] siblings = parseFlags O.siblings useIndex :: Config -> O.UseIndex useIndex = parseFlags O.useIndex hasSummary :: O.Summary -> Config -> O.Summary hasSummary def = maybe def id . parseFlags O.summary hasXmlOutput :: Config -> O.XmlOutput hasXmlOutput = parseFlags O.xmloutput selectDeps :: Config -> O.SelectDeps selectDeps = parseFlags O.selectDeps hasLogfile :: Config -> Maybe AbsolutePath hasLogfile = O._logfile . parseFlags O.logfile hasAuthor :: Config -> Maybe String hasAuthor = parseFlags O.author patchFormat :: Config -> O.PatchFormat patchFormat = parseFlags O.patchFormat applyAs :: Config -> Maybe String applyAs = parseFlags O.applyAs darcs-2.10.2/src/Darcs/UI/SelectChanges.hs0000644000175000017500000012755712620122474022147 0ustar00guillaumeguillaume00000000000000-- 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.UI.SelectChanges ( -- * Working with changes selectChanges , WhichChanges(..) , viewChanges , withSelectedPatchFromRepo , runSelection , selectionContextPrim , selectionContextGeneric , selectionContext , PatchSelectionContext(allowSkipAll) , printSummary -- * Interactive selection utils , PatchSelectionOptions(..) , InteractiveSelectionM , InteractiveSelectionContext(..) -- ** Navigating the patchset , currentPatch , skipMundane , skipOne , backOne , backAll , showCur -- ** Decisions , decide , decideWholeFile -- ** Prompts and queries , isSingleFile , currentFile , promptUser , prompt , KeyPress(..) , keysFor , helpFor , askAboutDepends ) where import Prelude hiding ( (^) ) import Control.Monad ( liftM, unless, when, (>=>) ) import Control.Monad.Identity ( Identity (..) ) import Control.Monad.Reader ( Reader, ReaderT, asks , runReader, runReaderT ) import Control.Monad.State ( StateT, execStateT, gets , modify, runStateT ) import Control.Monad.Trans ( liftIO ) import Data.Char ( toUpper ) import Data.List ( intercalate, union ) import Data.Maybe ( isJust, isNothing, catMaybes ) import System.Exit ( exitSuccess ) import Darcs.Patch ( Patchy, PrimPatch, RepoPatch, PrimOf , commuteFLorComplain, invert , listTouchedFiles, anonymous, fromPrims ) import qualified Darcs.Patch ( thing, things, summary ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Choices ( PatchChoices, Slot (..), LabelledPatch , patchChoicesLps, forceFirsts , forceFirst, forceLast, forceMatchingFirst , forceMatchingLast, getChoices , makeEverythingLater, makeEverythingSooner , makeUncertain, patchChoices , patchChoicesLpsSub, patchSlot' , refineChoices, selectAllMiddles , separateFirstFromMiddleLast , substitute, label, lpPatch ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia ) import Darcs.Patch.Set ( PatchSet(..), newset2RL ) import Darcs.Patch.Show ( ShowPatch ) import Darcs.Patch.Split ( Splitter (..) ) import qualified Darcs.Patch.TouchesFiles as TouchesFiles import Darcs.Patch.Type ( PatchType (..) ) import Darcs.Patch.Witnesses.Eq ( unsafeCompare ) import Darcs.Patch.Witnesses.Ordered ( (:>) (..), (:||:) (..), FL (..) , RL (..), filterFL, lengthFL, mapFL , mapFL_FL, reverseFL, spanFL, spanFL_M , (+<+), (+>+), reverseRL ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal (..), Sealed2 (..) , flipSeal, seal2, unseal2 ) import Darcs.Patch.Witnesses.WZipper ( FZipper (..), left, right , rightmost, toEnd, toStart ) import Darcs.Repository ( Repository, readRepo, readTentativeRepo ) import Darcs.UI.External ( editText ) import Darcs.UI.Options.All ( Verbosity(..), Summary(..), DiffAlgorithm(..) , WithContext(..), SelectDeps(..), MatchFlag ) import Darcs.UI.PrintPatch ( printFriendly, printPatch , printPatchPager, showFriendly ) import Darcs.Util.English ( Noun (..), englishNum ) import Darcs.Util.Printer ( prefix, putDocLn ) import Darcs.Util.Prompt ( PromptConfig (..), askUser, promptChar ) 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. data MatchCriterion p = MatchCriterion { mcHasNonrange :: Bool , mcFunction :: WhichChanges -> Sealed2 p -> Bool } data PatchSelectionOptions = PatchSelectionOptions { verbosity :: Verbosity , matchFlags :: [MatchFlag] , diffAlgorithm :: DiffAlgorithm , interactive :: Bool , selectDeps :: SelectDeps , summary :: Summary , withContext :: WithContext } -- | A @PatchSelectionContext@ contains all the static settings for selecting -- patches. See "PatchSelectionM" data PatchSelectionContext p = PSC { opts :: PatchSelectionOptions , splitter :: Maybe (Splitter p) , files :: Maybe [FilePath] , matchCriterion :: MatchCriterion p , jobname :: String , allowSkipAll :: Bool , pristine :: Maybe (Tree IO) , whichChanges :: WhichChanges } -- | A 'PatchSelectionContext' for selecting 'Prim' patches. selectionContextPrim :: PrimPatch prim => WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter prim) -> Maybe [FilePath] -> Maybe (Tree IO) -> PatchSelectionContext prim selectionContextPrim whch jn o spl fs p = PSC { opts = o , splitter = spl , files = fs , matchCriterion = triv , jobname = jn , allowSkipAll = True , pristine = p , whichChanges = whch } -- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches) selectionContext :: (RepoPatch p) => WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter (PatchInfoAnd p)) -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd p) selectionContext whch jn o spl fs = PSC { opts = o , splitter = spl , files = fs , matchCriterion = iswanted seal2 (matchFlags o) , jobname = jn , allowSkipAll = True , pristine = Nothing , whichChanges = whch } -- | A generic 'PatchSelectionContext'. selectionContextGeneric :: (RepoPatch p, Invert q) => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd p)) -> WhichChanges -> String -> PatchSelectionOptions -> Maybe [FilePath] -> PatchSelectionContext q selectionContextGeneric extract whch jn o fs = PSC { opts = o , splitter = Nothing , files = fs , matchCriterion = iswanted extract (matchFlags o) , jobname = jn , allowSkipAll = True , pristine = Nothing , whichChanges = whch } -- | The dynamic parameters for interactive selection of patches. data InteractiveSelectionContext 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 (PatchSelectionContext p) a type InteractiveSelectionM p wX wY a = StateT (InteractiveSelectionContext p wX wY) (PatchSelectionM p IO) a type PatchSelection p wX wY = PatchSelectionM p IO ((FL p :> FL p) wX wY) -- 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 :: forall p q . (RepoPatch p, Invert q) => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd p)) -> [MatchFlag] -> MatchCriterion q iswanted extract mflags = MatchCriterion { mcHasNonrange = haveNonrangeMatch (PatchType :: PatchType p) mflags , mcFunction = isWantedMcFunction } where isWantedMcFunction x = unseal2 $ iw x iw First = unseal2 (matchAPatch mflags) . extract iw Last = unseal2 (matchAPatch mflags) . extract iw LastReversed = unseal2 (matchAPatch mflags) . extract . invert iw FirstReversed = unseal2 (matchAPatch mflags) . extract . 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 wX wY -> PatchSelectionContext p -> IO ((FL p :> FL p) wX wY) runSelection = runReaderT -- | Select patches from a @FL@. selectChanges :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) => FL p wX wY -> PatchSelection p wX wY selectChanges ps = do whch <- asks whichChanges case whch of First -> normal ps Last -> normal ps FirstReversed -> reversed ps LastReversed -> reversed ps where normal = sc1 reversed = return . invert >=> sc1 >=> return . invertC sc1 :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) => FL p wX wY -> PatchSelection p wX wY sc1 = (liftR . patchesToConsider) >=> realSelectChanges >=> (\ps -> do whch <- asks whichChanges ; return $ selectedPatches whch ps) >=> (liftR . canonizeAfterSplitter) -- | inverses the choices that have been made invertC :: (Patchy p) => (FL p :> FL p) wX wY -> (FL p :> FL p) wY wX 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, ShowPatch 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" , "" , ": 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 wR wU wT. (RepoPatch p, ApplyState p ~ Tree) => String -- name of calling command (always "amend" as of now) -> Repository p wR wU wT -> PatchSelectionOptions -> (forall wA . (FL (PatchInfoAnd p) :> PatchInfoAnd p) wA wR -> IO ()) -> IO () withSelectedPatchFromRepo jn repository o job = do patchSet <- readRepo repository sp <- wspfr jn (matchAPatchread $ matchFlags o) (newset2RL patchSet) NilFL case sp of Just (FlippedSeal (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 wU. (RepoPatch p, ApplyState p ~ Tree) => String -> (forall wA wB . (PatchInfoAnd p) wA wB -> Bool) -> RL (PatchInfoAnd p) wX wY -> FL (WithSkipped (PatchInfoAnd p)) wY wU -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> PatchInfoAnd p) wU)) wspfr _ _ NilRL _ = return Nothing wspfr jn matches remaining@(p:<:pps) skipped | not $ matches p = wspfr jn matches pps (WithSkipped SkippedAutomatically p :>: skipped) | otherwise = case commuteFLorComplain (p :> mapFL_FL skippedPatch skipped) of Left _ -> do putStrLn "\nSkipping depended-upon patch:" defaultPrintFriendly p wspfr jn matches pps (WithSkipped SkippedAutomatically p :>: skipped) Right (skipped' :> p') -> do defaultPrintFriendly 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' -> previousPatch remaining skipped 'v' -> printPatch p >> repeatThis 'p' -> printPatchPager p >> repeatThis 'x' -> do putDocLn $ prefix " " $ Darcs.Patch.summary p repeatThis 'q' -> do putStrLn $ jnCapital ++ " cancelled." 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 (WithSkipped SkippedManually p:>:skipped) previousPatch :: RL (PatchInfoAnd p) wX wQ -> FL (WithSkipped (PatchInfoAnd p)) wQ wU -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> PatchInfoAnd p) wU)) previousPatch remaining' NilFL = wspfr jn matches remaining' NilFL previousPatch remaining' (WithSkipped sk prev :>: skipped'') = case sk of SkippedManually -> wspfr jn matches (prev :<: remaining') skipped'' SkippedAutomatically -> previousPatch (prev :<: remaining') 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) ]] defaultPrintFriendly = printFriendly Nothing NormalVerbosity NoSummary NoContext -- After selecting with a splitter, the results may not be canonical canonizeAfterSplitter :: (FL p :> FL p) wX wY -> Reader (PatchSelectionContext p) ((FL p :> FL p) wX wY) canonizeAfterSplitter (x :> y) = do o <- asks opts mspl <- asks splitter let canonizeIfNeeded = maybe (\_ b -> b) canonizeSplit mspl da = diffAlgorithm o return $ canonizeIfNeeded da x :> canonizeIfNeeded da y realSelectChanges :: forall p wX wY. (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree) => PatchChoices p wX wY -> PatchSelectionM p IO (PatchChoices p wX wY) realSelectChanges autoChoices = do o <- asks opts whch <- asks whichChanges if not $ interactive o then return $ promote whch autoChoices else refineChoices textSelect autoChoices where forward whch = not $ backward whch promote whch = if forward whch then makeEverythingSooner else makeEverythingLater -- | When using @--match@, remove unmatched patches not depended upon by matched -- patches. deselectUnwanted :: forall p wX wY . Patchy p => PatchChoices p wX wY -> Reader (PatchSelectionContext p) (PatchChoices p wX wY) deselectUnwanted pc = do o <- asks opts mc <- asks matchCriterion whichch <- asks whichChanges let iswanted_ = mcFunction mc whichch . seal2 . lpPatch select = if forward whichch then forceMatchingFirst iswanted_ else forceMatchingLast iswanted_ deselect = if forward whichch then forceMatchingLast (not . iswanted_) else forceMatchingFirst (not . iswanted_) return $ if mcHasNonrange mc then if selectDeps o == NoDeps then deselect pc else demote whichch $ select pc else pc where forward whichch = not $ backward whichch demote whichch = if forward whichch 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 :: forall p wX wY . (Patchy p, PatchInspect p, ApplyState p ~ Tree) => FL p wX wY -> Reader (PatchSelectionContext p) (PatchChoices p wX wY) patchesToConsider ps = do fs <- asks files crit <- asks matchCriterion whch <- asks whichChanges let deselectNotTouching = case whch of First -> TouchesFiles.deselectNotTouching Last -> TouchesFiles.selectNotTouching FirstReversed -> TouchesFiles.selectNotTouching LastReversed -> TouchesFiles.deselectNotTouching everything = patchChoices ps if isNothing fs && not (mcHasNonrange crit) then return everything else do notUnwanted <- deselectUnwanted everything return $ deselectNotTouching fs notUnwanted -- | Returns the results of a patch selection user interaction selectedPatches :: Patchy p => WhichChanges -> PatchChoices p wY wZ -> (FL p :> FL p) wY wZ selectedPatches Last pc = case getChoices pc of fc :> mc :> lc -> mapFL_FL lpPatch (fc +>+ mc) :> mapFL_FL lpPatch lc selectedPatches First pc = case separateFirstFromMiddleLast pc of xs :> ys -> mapFL_FL lpPatch xs :> mapFL_FL lpPatch ys selectedPatches LastReversed pc = case separateFirstFromMiddleLast pc of xs :> ys -> mapFL_FL lpPatch xs :> mapFL_FL lpPatch ys selectedPatches FirstReversed pc = case getChoices pc of fc :> mc :> lc -> mapFL_FL lpPatch (fc +>+ mc) :> mapFL_FL lpPatch lc -- | Runs a function on the underlying @PatchChoices@ object liftChoices :: forall p a wX wY . Patchy p => 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 :: Patchy p => Int -> InteractiveSelectionM p wX wY () justDone n = modify $ \isc -> isc{ current = current isc + n} -- | The actual interactive selection process. textSelect :: forall p wX wY . (Patchy p, ShowPatch 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 = do userSelection <- execStateT (skipMundane >> showCur >> textSelectIfAny) ISC { total = lengthFL lps' , current = 0 , lps = FZipper NilRL lps' , choices = pcs } return $ choices userSelection where textSelectIfAny = do z <- gets lps unless (rightmost z) $ textSelect' textSelect' :: (Patchy p, ShowPatch 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 '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 :: forall p wX wY . (Patchy p, 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 summary 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 :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY (Maybe (Sealed2 (LabelledPatch p))) currentPatch = do (FZipper _ lps_todo) :: FZipper (LabelledPatch p) wX wY <- gets lps case lps_todo of NilFL -> return Nothing (lp:>:_) -> return $ Just (Sealed2 lp) -- | Returns the patches we have yet to ask the user about. todo :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY (FlippedSeal (FL (LabelledPatch p)) wY) todo = do (FZipper _ lps_todo) <- gets lps return (FlippedSeal lps_todo) -- | Modify the underlying @PatchChoices@ by some function modChoices :: forall p wX wY . Patchy p => (PatchChoices p wX wY -> PatchChoices p wX wY) -> InteractiveSelectionM p wX wY () modChoices f = modify $ \isc -> isc{choices = f $ choices isc} -- | returns @Just f@ if the 'currentPatch' only modifies @f@, -- @Nothing@ otherwise. currentFile :: forall p wX wY . (Patchy p, PatchInspect p) => InteractiveSelectionM p wX wY (Maybe FilePath) 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 :: forall p wX wY wT wU . Patchy p => Bool -> LabelledPatch p wT wU -> InteractiveSelectionM p wX wY () decide takeOrDrop lp = do whch <- asks whichChanges if backward whch == takeOrDrop -- we go backward xor we are dropping then modChoices $ forceLast (label lp) else modChoices $ forceFirst (label lp) -- | like 'decide', but for all patches touching @file@ decideWholeFile :: forall p wX wY. (Patchy p, PatchInspect p) => FilePath -> Bool -> InteractiveSelectionM p wX wY () decideWholeFile file takeOrDrop = do FlippedSeal lps_todo <- todo let patches_to_skip = filterFL (\lp' -> listTouchedFiles lp' == [file]) lps_todo mapM_ (unseal2 $ decide takeOrDrop) patches_to_skip -- | Undecide the current patch. postponeNext :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY () postponeNext = do Just (Sealed2 lp) <- currentPatch modChoices $ makeUncertain (label lp) -- | Focus the next patch. skipOne :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY () skipOne = modify so where so x = x{lps = right (lps x), current = current x +1} -- | Focus the previous patch. backOne :: forall p wX wY . Patchy p => 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 :: forall p wX wY . Patchy p => Splitter p -> InteractiveSelectionM p wX wY () splitCurrent s = do FZipper lps_done (lp:>:lps_todo) <- gets lps o <- asks opts case applySplitter s (diffAlgorithm o) (lpPatch 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 . snd $ patchChoicesLpsSub (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) } -- | Returns a list of the currently selected patches, in -- their original context, i.e., not commuted past unselected -- patches. selected :: forall p wX wY. Patchy p => InteractiveSelectionM p wX wY [Sealed2 p] selected = do whichch <- asks whichChanges c <- gets choices (first_chs :> _ :> last_chs) <- return $ getChoices c return $ if backward whichch then mapFL (repr whichch . Sealed2 . lpPatch) last_chs else mapFL (repr whichch . Sealed2 . lpPatch) first_chs -- | Prints the list of the selected patches. See 'selected'. printSelected :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY () printSelected = do someThings <- things o <- asks opts s <- selected liftIO $ do putStrLn $ "---- Already selected "++someThings++" ----" mapM_ (putDocLn . unseal2 (showFriendly (verbosity o) (summary o))) s putStrLn $ "---- end of already selected "++someThings++" ----" printSummary :: forall p wX wY . ShowPatch p => p wX wY -> IO () printSummary = putDocLn . prefix " " . Darcs.Patch.summary -- | Skips all remaining patches. skipAll :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY () skipAll = modify $ \isc -> isc {lps = toEnd $ lps isc} backAll :: forall p wX wY . Patchy p => 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 :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY () askConfirmation = do jn <- asks jobname liftIO $ when (jn `elem` ["unpull", "unrecord", "obliterate"]) $ do yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? " case yorn of ('y':_) -> return () _ -> exitSuccess -- | The singular form of the noun for items of type @p@. thing :: (Patchy p, 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 :: (Patchy p, 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 :: (Patchy p, 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 :: forall p wX wY . (Patchy p, 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 :: forall p wX wY. (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree) => 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 (lpPatch lp) reprCur = repr whichch (Sealed2 (lpPatch lp)) (basicOptions,advancedOptions) <- options singleFile theSlot <- liftChoices $ patchSlot' lp let the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot jnCapital = toUpper (head jn) : tail jn yorn <- promptUser singleFile the_default let nextPatch = skipMundane >> showCur 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 >> showCur >> 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 $ unseal2 printPatch reprCur >> return False 'p' -> liftIO $ unseal2 printPatchPager reprCur >> return False 'l' -> printSelected >> showCur >> return False 'x' -> liftIO $ unseal2 printSummary reprCur >> return False 'd' -> skipAll >> return True 'g' -> backAll >> showCur >> return False 'a' -> do askConfirmation modChoices $ selectAllMiddles (whichch == Last || whichch == FirstReversed) skipAll return True 'q' -> liftIO $ do putStrLn $ jnCapital++" cancelled." exitSuccess 'j' -> skipOne >> showCur >> return False 'k' -> backOne >> showCur >> return False _ -> do liftIO . putStrLn $ helpFor jn basicOptions advancedOptions return False lastQuestion :: forall p wX wY . (Patchy p, ShowPatch p, ApplyState p ~ Tree) => InteractiveSelectionM p wX wY Bool lastQuestion = do jn <- asks jobname theThings <-things aThing <- thing let (basicOptions, advancedOptions) = optionsLast jn aThing yorn <- liftIO . promptChar $ PromptConfig { pPrompt = "Do you want to "++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 >> showCur >> return False 'l' -> printSelected >> return False 'k' -> backOne >> showCur >> return False _ -> do liftIO . putStrLn $ helpFor "this confirmation prompt" basicOptions advancedOptions return False -- | Shows the current patch as it should be seen by the user. showCur :: forall p wX wY . (Patchy p, ShowPatch p, ApplyState p ~ Tree) => InteractiveSelectionM p wX wY () showCur = do o <- asks opts p <- asks pristine c <- currentPatch whichch <- asks whichChanges case c of Nothing -> return () Just (Sealed2 lp) -> do let reprCur = repr whichch (Sealed2 (lpPatch lp)) liftIO . unseal2 (printFriendly p (verbosity o) (summary o) (withContext o)) $ reprCur -- | The interactive part of @darcs changes@ textView :: forall p . (Patchy p, ShowPatch 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 unseal2 (printFriendly Nothing (verbosity o) (summary o) (withContext 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 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 printPatch p >> next_patch 'n' -> next_patch 'v' -> unseal2 printPatch p >> repeatThis 'p' -> unseal2 printPatchPager p >> repeatThis 'x' -> do putDocLn $ prefix " " $ unseal2 Darcs.Patch.summary 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 :: (Patchy 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 whichch <- asks whichChanges (skipped :> unskipped) <- liftChoices $ spanFL_M (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 whichch . seal2 . lpPatch) unskipped else NilFL :> unskipped case boringThenInteresting of boring :> interesting -> do justDone $ lengthFL boring + numSkipped modify $ \isc -> isc {lps = FZipper (reverseFL boring +<+ reverseFL skipped +<+ lps_done) 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 :: (Patchy p, ShowPatch p) => FL (LabelledPatch p) wY wT -> IO () showskippedpatch = sequence_ . mapFL (printSummary . lpPatch) 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' askAboutDepends :: forall p wR wU wT wY . (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> FL (PrimOf p) wT wY -> PatchSelectionOptions -> [PatchInfo] -> IO [PatchInfo] askAboutDepends repository 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. pps <- readTentativeRepo repository pa <- n2pia `fmap` anonymous (fromPrims pa') -- FIXME: this code is completely unreadable FlippedSeal ps <- return ((case pps of PatchSet x _ -> FlippedSeal (reverseRL x+>+(pa:>:NilFL))) :: FlippedSeal (FL (PatchInfoAnd p)) wY) let (pc, my_lps) = patchChoicesLps ps tas = case catMaybes (mapFL (\lp -> if pa `unsafeCompare` lpPatch lp || info (lpPatch lp) `elem` olddeps then Just (label lp) else Nothing) my_lps) of [] -> error "askAboutDepends: []" tgs -> tgs Sealed2 ps' <- return $ case getChoices (forceFirsts tas pc) of _ :> mc :> _ -> Sealed2 $ mapFL_FL lpPatch mc (deps:>_) <- runSelection (selectChanges ps') $ selectionContext FirstReversed "depend on" ps_opts { matchFlags = [], interactive = True } Nothing Nothing return $ olddeps `union` mapFL info deps {- where askdep_allowed = not . patchSelectFlag opts' = filter askdep_allowed cfg psOpts = (recordPatchSelOpts cfg) -} {- -- | @'patchSelectFlag' f@ holds whenever @f@ is a way of selecting -- patches such as @PatchName n@. <- ??? patchSelectFlag :: F.DarcsFlag -> Bool patchSelectFlag F.All = True patchSelectFlag (F.PatchName _) = True -- ??? patchSelectFlag (F.OnePatch _) = True patchSelectFlag (F.OneHash _) = True patchSelectFlag (F.SeveralPatch _) = True patchSelectFlag (F.AfterPatch _) = True patchSelectFlag (F.UpToPatch _) = True patchSelectFlag (F.TagName _) = True patchSelectFlag (F.LastN _) = True patchSelectFlag (F.OneTag _) = True patchSelectFlag (F.AfterTag _) = True patchSelectFlag (F.UpToTag _) = True patchSelectFlag (F.OnePattern _) = True patchSelectFlag (F.SeveralPattern _) = True patchSelectFlag (F.AfterPattern _) = True patchSelectFlag (F.UpToPattern _) = True patchSelectFlag _ = False -} darcs-2.10.2/src/Darcs/UI/Commands.hs0000644000175000017500000004670412620122474021172 0ustar00guillaumeguillaume00000000000000-- 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.UI.Commands ( CommandControl ( CommandData, HiddenCommand, GroupName ) , DarcsCommand ( .. ) , WrappedCommand(..) , wrappedCommandName , commandAlias , commandStub , commandOptions , commandAlloptions , withStdOpts , disambiguateCommands , CommandArgs(..) , getCommandHelp , getCommandMiniHelp , getSubcommands , usage , usageHelper , subusage , extractCommands , extractAllCommands , normalCommand , hiddenCommand , commandGroup , superName , nodefaults , putInfo , putVerbose , putWarning , putVerboseWarning , abortRun , printDryRunMessageAndExit , setEnvDarcsPatches , setEnvDarcsFiles , formatPath , defaultRepo , amInHashedRepository , amInRepository , amNotInRepository , findRepository ) where import Prelude hiding ( (^) ) import Control.Monad ( when, unless ) import Data.List ( sort, isPrefixOf ) import Data.Maybe ( catMaybes ) import Storage.Hashed.Tree ( Tree ) import System.Console.GetOpt ( OptDescr ) import System.Exit ( exitSuccess ) import System.IO ( stderr ) #ifndef WIN32 import System.Posix.Env ( setEnv ) import Darcs.Patch ( listTouchedFiles ) import qualified Darcs.Patch ( summary ) #endif import Darcs.Patch ( RepoPatch, xmlSummary, Patchy ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Info ( toXml ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) import qualified Darcs.Repository as R ( amInHashedRepository, amInRepository , amNotInRepository, findRepository ) import Darcs.Repository.Prefs ( defaultrepo ) import Darcs.UI.Options ( DarcsOption, DarcsOptDescr, (^), optDescr, odesc, parseFlags ) import Darcs.UI.Options.All ( StdCmdAction, stdCmdActions, anyVerbosity, UseCache, useCache, hooks , Verbosity(..), verbosity, Summary(..), DryRun(..), dryRun, XmlOutput(..) ) import Darcs.UI.Flags ( remoteRepos, workRepo, DarcsFlag ) import Darcs.UI.PrintPatch ( showFriendly ) import Darcs.UI.Usage ( usageInfo ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc , vsep, insertBeforeLastline, prefix, ($$), vcat #ifndef WIN32 , renderString #endif , RenderMode(..) ) #ifndef WIN32 import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize , finishedOneIO ) #endif import Darcs.Util.Text ( chompTrailingNewline ) extractCommands :: [CommandControl] -> [WrappedCommand] extractCommands ccl = [ cmd | CommandData cmd <- ccl ] extractHiddenCommands :: [CommandControl] -> [WrappedCommand] extractHiddenCommands ccl = [ cmd | HiddenCommand cmd <- ccl ] extractAllCommands :: [CommandControl] -> [WrappedCommand] extractAllCommands ccl = concatMap flatten (extractCommands ccl ++ extractHiddenCommands ccl) where flatten c@(WrappedCommand (DarcsCommand {})) = [c] flatten c@(WrappedCommand (SuperCommand { commandSubCommands = scs })) = c : extractAllCommands scs -- |A 'WrappedCommand' is a 'DarcsCommand' where the options type has been hidden data WrappedCommand where WrappedCommand :: DarcsCommand parsedFlags -> WrappedCommand normalCommand :: DarcsCommand parsedFlags -> CommandControl normalCommand c = CommandData (WrappedCommand c) hiddenCommand :: DarcsCommand parsedFlags -> CommandControl hiddenCommand c = HiddenCommand (WrappedCommand c) commandGroup :: String -> CommandControl commandGroup = GroupName wrappedCommandName :: WrappedCommand -> String wrappedCommandName (WrappedCommand c) = commandName c wrappedCommandDescription :: WrappedCommand -> String wrappedCommandDescription (WrappedCommand c) = commandDescription c data CommandControl = CommandData WrappedCommand | HiddenCommand WrappedCommand | GroupName String -- |A 'DarcsCommand' represents a command like add, record etc. -- The 'parsedFlags' type represents the options that are -- passed to the command's implementation data DarcsCommand parsedFlags = DarcsCommand { commandProgramName -- programs that use libdarcs can change the name here , commandName , commandHelp , commandDescription :: String , commandExtraArgs :: Int , commandExtraArgHelp :: [String] , commandCommand :: -- First 'AbsolutePath' is the repository path, -- second one is the path where darcs was executed. (AbsolutePath, AbsolutePath) -> parsedFlags -> [String] -> IO () , commandPrereq :: [DarcsFlag] -> IO (Either String ()) , commandGetArgPossibilities :: IO [String] , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] , commandBasicOptions :: [DarcsOptDescr DarcsFlag] , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag] , commandDefaults :: [DarcsFlag] , commandCheckOptions :: [DarcsFlag] -> [String] , commandParseOptions :: [DarcsFlag] -> parsedFlags } | SuperCommand { commandProgramName , commandName , commandHelp , commandDescription :: String , commandPrereq :: [DarcsFlag] -> IO (Either String ()) , commandSubCommands :: [CommandControl] } withStdOpts :: DarcsOption (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c -> DarcsOption (UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) b -> DarcsOption a c withStdOpts basicOpts advancedOpts = basicOpts ^ stdCmdActions ^ anyVerbosity ^ advancedOpts ^ useCache ^ hooks commandAlloptions :: DarcsCommand pf -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag]) commandAlloptions DarcsCommand { commandBasicOptions = opts1 , commandAdvancedOptions = opts2 } = ( opts1 ++ odesc stdCmdActions , odesc anyVerbosity ++ opts2 ++ odesc useCache ++ odesc hooks ) commandAlloptions SuperCommand { } = (odesc stdCmdActions, []) -- 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 pf -> [OptDescr DarcsFlag] commandOptions cwd = map (optDescr cwd) . uncurry (++) . commandAlloptions nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] nodefaults _ _ = return getSubcommands :: DarcsCommand pf -> [CommandControl] getSubcommands c@(SuperCommand {}) = commandSubCommands c getSubcommands _ = [] commandAlias :: String -> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf 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 pf -> DarcsCommand pf commandStub n h d c = c { commandName = n , commandHelp = h , commandDescription = d , commandCommand = \_ _ _ -> putStr h } usage :: [CommandControl] -> String usage cs = unlines [ "Usage: darcs COMMAND ..." , "" , "Commands:" , usageHelper cs , "Use 'darcs COMMAND --help' for help on a single command." , "Use 'darcs --version' to see the darcs version number." , "Use 'darcs --exact-version' to see a detailed darcs version." , "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." , "" , "Check bug reports at http://bugs.darcs.net/" ] subusage :: DarcsCommand pf -> String subusage super = usageInfo header (odesc stdCmdActions) ++ superHelp where header = unlines [ unwords [ "Usage:" , commandProgramName super , commandName super , "SUBCOMMAND ..." ] , "" , commandDescription super , "" , "Subcommands:" , usageHelper (getSubcommands super) , "Options:" ] superHelp = '\n' : commandHelp super usageHelper :: [CommandControl] -> String usageHelper xs = usageHelper' (maximum $ 15 : (catMaybes $ map f xs)) xs where -- returns length of necessary tabbing this command f (CommandData c) = Just ((+2) . length . wrappedCommandName $ c) f _ = Nothing usageHelper' :: Int -> [CommandControl] -> String usageHelper' _ [] = "" usageHelper' x (HiddenCommand _ : cs) = usageHelper' x cs usageHelper' x (CommandData c : cs) = " " ++ padSpaces (wrappedCommandName c) x ++ chompTrailingNewline (wrappedCommandDescription c) ++ "\n" ++ usageHelper' x cs usageHelper' x (GroupName n : cs) = "\n" ++ n ++ "\n" ++ usageHelper' x cs padSpaces :: String -> Int -> String padSpaces s n = s ++ replicate (n - length s) ' ' superName :: Maybe (DarcsCommand pf) -> String superName Nothing = "" superName (Just x) = commandName x ++ " " getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String getCommandMiniHelp msuper cmd = unlines [ getCommandHelpCore msuper cmd , "" , unwords [ "See" , commandProgramName cmd , "help" , maybe "" ((++ " ") . commandName) msuper ++ commandName cmd , "for details." ] ] getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String getCommandHelp msuper cmd = basicHelp ++ advancedHelp ++ cmdHelp where basicHelp = unlines (reverse basicR) advancedHelp = if null advanced then "" else '\n' : unlines ("Advanced options:" : reverse advancedR) cmdHelp = '\n' : commandHelp cmd -- we could just call usageInfo twice, but then the advanced -- options might not line up with the basic ones (no short switches) (advancedR, basicR) = splitAt (length advanced) . reverse . lines $ combinedUsage combinedUsage = let header = getCommandHelpCore msuper cmd ++ subcommands ++ "\n\nOptions:" in usageInfo header (basic ++ advanced) (basic, advanced) = commandAlloptions 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 pf1) -> DarcsCommand pf2 -> String getCommandHelpCore msuper cmd = unwords [ "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 where CommandOnly :: DarcsCommand parsedFlags -> CommandArgs SuperCommandOnly :: DarcsCommand parsedFlags -> CommandArgs SuperCommandSub :: DarcsCommand parsedFlags1 -> DarcsCommand parsedFlags2 -> CommandArgs -- Parses a darcs command line with potentially abbreviated commands disambiguateCommands :: [CommandControl] -> String -> [String] -> Either String (CommandArgs, [String]) disambiguateCommands allcs cmd args = do WrappedCommand 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 (WrappedCommand sc) -> return (SuperCommandSub c sc, as) extract :: String -> [CommandControl] -> Either String WrappedCommand 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 wrappedCommandName $ cs' ] where potentials = [c | c <- extractCommands cs, cmd `isPrefixOf` wrappedCommandName c] ++ [h | h <- extractHiddenCommands cs, cmd == wrappedCommandName h] amVerbose :: [DarcsFlag] -> Bool amVerbose = (== Verbose) . parseFlags verbosity amQuiet :: [DarcsFlag] -> Bool amQuiet = (== Quiet) . parseFlags verbosity putVerbose :: [DarcsFlag] -> Doc -> IO () putVerbose flags = when (amVerbose flags) . putDocLn putInfo :: [DarcsFlag] -> Doc -> IO () putInfo flags = unless (amQuiet flags) . putDocLn putWarning :: [DarcsFlag] -> Doc -> IO () putWarning flags = unless (amQuiet flags) . hPutDocLn Encode stderr putVerboseWarning :: [DarcsFlag] -> Doc -> IO () putVerboseWarning flags = when (amVerbose flags) . hPutDocLn Encode stderr abortRun :: [DarcsFlag] -> Doc -> IO () abortRun flags msg = if parseFlags dryRun flags == YesDryRun then putInfo flags $ text "NOTE:" <+> msg else errorDoc msg -- | @'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, ApplyState p ~ Tree) => String -> Verbosity -> Summary -> DryRun -> XmlOutput -> Bool -- interactive -> FL (PatchInfoAnd p) wX wY -> IO () printDryRunMessageAndExit action v s d x interactive patches = do when (d == YesDryRun) $ do putInfoX . text $ unwords [ "Would" , action , "the following changes:" ] putDocLn put_mode putInfoX $ text "" putInfoX $ text "Making no changes: this is a dry run." exitSuccess when (not interactive && s == YesSummary) $ do putInfoX . text $ unwords [ "Will" , action , "the following changes:" ] putDocLn put_mode where put_mode = if x == YesXml then text "" $$ vcat (mapFL (indent . xml_info s) patches) $$ text "" 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 " " -- | 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) wX wY -> 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 Encode $ Darcs.Patch.summary ps) finishedOneIO k "DARCS_PATCHES_XML" setEnvCautiously "DARCS_PATCHES_XML" . renderString Encode $ text "" $$ vcat (mapFL (toXml . info) ps) $$ text "" 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 :: (PatchInspect p, Patchy p) => p wX wY -> IO () #ifndef WIN32 setEnvDarcsFiles ps = setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps) #else setEnvDarcsFiles _ = return () #endif -- | 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 defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] defaultRepo fs = defaultrepo (remoteRepos fs) 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 (workRepo fs) findRepository :: [DarcsFlag] -> IO (Either String ()) findRepository fs = R.findRepository (workRepo fs) darcs-2.10.2/src/Darcs/UI/Message/0000755000175000017500000000000012620122474020446 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/UI/Message/Send.hs0000644000175000017500000002001012620122474021664 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE OverloadedStrings #-} -- 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 #-} -- | Help text and UI messages for @darcs send@ module Darcs.UI.Message.Send where import Darcs.Util.Path ( FilePathLike(..), toFilePath ) import Darcs.UI.Commands ( formatPath ) import Darcs.Repository.Flags ( DryRun(..) ) import Darcs.Util.Text ( sentence ) import Darcs.Util.Printer cmdDescription :: String cmdDescription = "Prepare a bundle of patches to be applied to some target repository." cmdHelp :: String cmdHelp = unlines [ "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:" , "" , " evolution \"mailto:%T?subject=%S&attach=%A&cc=%C&body=%B\"" , " msmtp -t %<" , "" , "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:" , "" , "* 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." , "" , "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." ] cannotSendToSelf :: String cannotSendToSelf = "Can't send to current repository! Did you mean send --context?" creatingPatch :: String -> Doc creatingPatch repodir = "Creating patch to" <+> text (formatPath repodir) <> "..." noWorkingSendmail :: Doc noWorkingSendmail = "No working sendmail instance on your machine!" 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." currentEncodingIs :: String -> String currentEncodingIs e = "Current locale encoding: " ++ e charsetUtf8MailDiffLocale :: String charsetUtf8MailDiffLocale = "your mail is valid UTF-8 but your locale differs." 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?" darcs-2.10.2/src/Darcs/UI/ApplyPatches.hs0000644000175000017500000001714112620122474022017 0ustar00guillaumeguillaume00000000000000module Darcs.UI.ApplyPatches ( PatchApplier(..), PatchProxy(..) , StandardPatchApplier(..) ) where import System.Exit ( ExitCode ( ExitSuccess ), exitSuccess ) import Prelude hiding ( catch ) import System.IO ( hClose, stdout, stderr ) import Control.Exception ( catch, fromException, SomeException, throwIO ) import Control.Monad ( when, unless ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.UI.Commands ( putVerbose , putInfo , printDryRunMessageAndExit , setEnvDarcsPatches ) import Darcs.UI.CommandsAux ( checkPaths ) import Darcs.UI.Flags ( DarcsFlag, verbosity, compression, reorder, allowConflicts, externalMerge , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive, testChanges , hasXmlOutput, getReply, getCc, getSendmailCmd, hasSummary, dryRun ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit ) import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.Repository ( Repository , tentativelyMergePatches , finalizeRepositoryChanges , applyToWorking , invalidateIndex , setScriptsExecutablePatches ) import Darcs.Repository.Job ( RepoJob(RepoJob) ) import Darcs.Patch ( RepoPatch, description, PrimOf ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.UI.External ( sendEmail ) import Darcs.Repository.Lock ( withStdoutTemp, readBinFile ) import Darcs.Util.Printer ( vcat, text ) import Storage.Hashed.Tree( Tree ) data PatchProxy (p :: * -> * -> *) = PatchProxy -- |This class is a hack to abstract over pull/apply and rebase pull/apply. class PatchApplier pa where -- |'CarrierType pa p' resolves to either 'p' or 'Rebasing p' type CarrierType pa (p :: * -> * -> *) :: * -> * -> * repoJob :: pa -> [DarcsFlag] -> (forall p wR wU . ( RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree , RepoPatch (CarrierType pa p), ApplyState (CarrierType pa p) ~ Tree , ApplyState (PrimOf (CarrierType pa p)) ~ Tree ) => (PatchProxy p -> Repository (CarrierType pa p) wR wU wR -> IO ())) -> RepoJob () applyPatches :: forall p wR wU wT wX wZ . (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) => pa -> PatchProxy p -> String -> [DarcsFlag] -> String -> Repository (CarrierType pa p) wR wU wT -> FL (PatchInfoAnd (CarrierType pa p)) wX wT -> FL (PatchInfoAnd (CarrierType pa p)) wX wZ -> IO () data StandardPatchApplier = StandardPatchApplier instance PatchApplier StandardPatchApplier where type CarrierType StandardPatchApplier p = p repoJob StandardPatchApplier _opts f = RepoJob (f PatchProxy) applyPatches StandardPatchApplier PatchProxy = standardApplyPatches standardApplyPatches :: forall p wR wU wT wX wZ . (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) => String -> [DarcsFlag] -> String -> Repository p wR wU wT -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wZ -> IO () standardApplyPatches cmdName opts from_whom repository us' to_be_applied = do printDryRunMessageAndExit cmdName (verbosity opts) (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput opts) (isInteractive True opts) to_be_applied when (nullFL to_be_applied && reorder opts == O.NoReorder) $ do putStrLn $ "You don't want to " ++ cmdName ++ " any patches, so I'm exiting!" exitSuccess checkPaths opts to_be_applied redirectOutput opts from_whom $ do unless (nullFL to_be_applied) $ do putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:" putVerbose opts . vcat $ mapFL description to_be_applied setEnvDarcsPatches to_be_applied Sealed pw <- tentativelyMergePatches repository cmdName (allowConflicts opts) YesUpdateWorking (externalMerge opts) (wantGuiPause opts) (compression opts) (verbosity opts) (reorder opts) (diffingOpts opts) us' to_be_applied invalidateIndex repository testTentativeAndMaybeExit repository (verbosity opts) (testChanges opts) (setScriptsExecutable opts) (isInteractive True opts) "those patches do not pass the tests." (cmdName ++ " them") Nothing withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compression opts) _ <- applyToWorking repository (verbosity opts) pw `catch` \(e :: SomeException) -> fail ("Error applying patch to working dir:\n" ++ show e) when (setScriptsExecutable opts == O.YesSetScriptsExecutable) $ setScriptsExecutablePatches pw return () case (nullFL to_be_applied, reorder opts == O.Reorder) of (True,True) -> putInfo opts $ text $ "Nothing to " ++ cmdName ++ ", finished reordering." (False,True) -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing and reordering." _ -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing." redirectOutput :: [DarcsFlag] -> String -> IO () -> IO () redirectOutput opts to doit = case getReply opts of Nothing -> doit Just from -> withStdoutTemp $ \tempf -> doitAndCleanup `catch` sendit tempf from where -- TODO: I suggest people writing such code should *at least* put in some comments. -- It is unclear how this works and how the intertwined exception handlers make -- this do what the author wanted. doitAndCleanup = doit >> hClose stdout >> hClose stderr sendit :: FilePath -> String -> SomeException -> IO a sendit tempf from e | Just ExitSuccess <- fromException e = do sendSanitizedEmail opts from to "Patch applied" cc tempf throwIO e sendit tempf from e | Just (_ :: ExitCode) <- fromException e = do sendSanitizedEmail opts from to "Patch failed!" cc tempf throwIO ExitSuccess sendit tempf from e = do sendSanitizedEmail opts from to "Darcs error applying patch!" cc $ tempf ++ "\n\nCaught exception:\n"++ show e++"\n" throwIO ExitSuccess cc = getCc opts -- |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 from to subject cc mailtext = do scmd <- getSendmailCmd opts body <- sanitizeFile mailtext sendEmail from 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 darcs-2.10.2/src/Darcs/UI/RemoteApply.hs0000644000175000017500000000532612620122474021665 0ustar00guillaumeguillaume00000000000000-- | This module is used by the push and put commands to apply 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.UI.RemoteApply ( remoteApply ) where import System.Exit ( ExitCode ) import Darcs.UI.Flags ( DarcsFlag, remoteDarcs, applyAs ) import Darcs.Util.Text ( breakCommand ) import Darcs.Util.URL ( isHttpUrl, isSshUrl, splitSshUrl, SshFilePath(..) ) import Darcs.UI.External ( darcsProgram , pipeDoc , pipeDocSSH , maybeURLCmd ) import Darcs.UI.Options ( parseFlags ) import Darcs.UI.Options.All ( debug, compress ) import qualified Darcs.Repository.Ssh as Ssh ( remoteDarcs ) import Darcs.Util.Printer ( Doc, RenderMode(..) ) remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode remoteApply opts repodir bundle = case applyAs opts of Nothing | isSshUrl repodir -> applyViaSsh opts (splitSshUrl repodir) bundle | isHttpUrl repodir -> applyViaUrl opts repodir bundle | otherwise -> applyViaLocal opts repodir bundle Just un -> if isSshUrl repodir then applyViaSshAndSudo opts (splitSshUrl repodir) un bundle else applyViaSudo un repodir bundle applyViaSudo :: String -> String -> Doc -> IO ExitCode applyViaSudo user repo bundle = darcsProgram >>= \darcs -> pipeDoc Standard "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode applyViaLocal opts repo bundle = darcsProgram >>= \darcs -> pipeDoc Standard 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 Standard cmd (args ++ [repo]) bundle applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode applyViaSsh opts repo = pipeDocSSH (parseFlags compress opts) Standard repo [Ssh.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++ " --repodir '"++sshRepo repo++"'"] applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode applyViaSshAndSudo opts repo username = pipeDocSSH (parseFlags compress opts) Standard repo ["sudo -u "++username++" "++Ssh.remoteDarcs (remoteDarcs opts)++ " apply --all --repodir '"++sshRepo repo++"'"] applyopts :: [DarcsFlag] -> [String] applyopts opts = if parseFlags debug opts then ["--debug"] else [] darcs-2.10.2/src/Darcs/Util/0000755000175000017500000000000012620122474017462 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Util/Printer/0000755000175000017500000000000012620122474021105 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Util/Printer/Color.hs0000644000175000017500000003731212620122474022525 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.Util.Printer.Color ( showDoc, errorDoc, traceDoc, assertDoc, fancyPrinters , environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite ) where import Darcs.Util.Printer ( Printer, Printers, Printers'(..), Printable(..), Color(..), RenderMode(..) , invisiblePrinter, (<>), (), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat , unsafeText, unsafePackedString , renderStringWith, prefix ) import Prelude hiding ( catch ) import Control.Monad ( liftM ) import Control.Exception ( catch, IOException ) import Debug.Trace ( trace ) 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 ( 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" errorDoc :: Doc -> a errorDoc = error . showDoc Encode traceDoc :: Doc -> a -> a traceDoc d = trace (showDoc Encode d) assertDoc :: Maybe Doc -> a -> a assertDoc Nothing x = x assertDoc (Just e) _ = errorDoc e showDoc :: RenderMode -> Doc -> String showDoc = 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 = (/= "0") `liftM` safeGetEnv s safeGetEnv s = getEnv s `catch` \(_ :: IOException) -> return "0" getEnvString s = getEnv s `catch` \(_ :: IOException) -> return "" {- - 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 = 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 = "" -- 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", "DARCS_DO_COLOR_LINES"],[ "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", "`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"]) 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_ISPRINT", "DARCS_DONT_ESCAPE_8BIT", "DARCS_DONT_ESCAPE_EXTRA", "DARCS_ESCAPE_EXTRA"],[ "Darcs needs to escape certain characters when printing patch contents to", "a terminal. Characters like 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 tab and", "newline. All other octets are printed in quoted form (as `^`", "or `\\`).", "", "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 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)."]) darcs-2.10.2/src/Darcs/Util/Download/0000755000175000017500000000000012620122474021231 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Util/Download/Request.hs0000644000175000017500000000623712620122474023225 0ustar00guillaumeguillaume00000000000000module Darcs.Util.Download.Request ( UrlRequest(..) , Cachable(..) , UrlState(..) , Q(..) , readQ , insertQ , pushQ , addUsingPriority , deleteQ , elemQ , emptyQ , nullQ , Priority(..) , ConnectionError(..) ) where import Data.List ( delete ) import Data.Map ( Map ) import Foreign.C.Types ( CInt ) data Priority = High | Low deriving Eq data Cachable = Cachable | Uncachable | MaxAge !CInt deriving (Show, Eq) -- | A UrlRequest object contains a url to get, the file into which the -- contents at the given url should be written, the cachability of this request -- and the request's priority. data UrlRequest = UrlRequest { url :: String , file :: FilePath , cachable :: Cachable , priority :: Priority } type InProgressStatus = ( FilePath -- FilePath to write url contents into , [FilePath] -- Extra paths to copy complete file into , Cachable -- Cachable status ) -- | A UrlState object contains a map of url -> InProgressStatus, a Q of urls -- waiting to be started, the current pipe length and the unique junk to -- create unique filenames. data UrlState = UrlState { inProgress :: Map String InProgressStatus , waitToStart :: Q String , pipeLength :: Int , randomJunk :: String } -- |Q represents a prioritised queue, with two-tier priority. The left list -- contains higher priority items than the right list. data Q a = Q [a] [a] -- |'readQ' will try and take an element from the Q, preferring elements from -- the high priority list. readQ :: Q a -> Maybe (a, Q a) readQ (Q (x : xs) ys) = return (x, Q xs ys) readQ (Q [] ys) = do x : xs <- return $ reverse ys return (x, Q xs []) -- | Return a function for adding an element based on the priority. addUsingPriority :: Priority -> a -> Q a -> Q a addUsingPriority High = pushQ addUsingPriority Low = insertQ -- |'insertQ' inserts a low priority item into a Q. insertQ :: a -> Q a -> Q a insertQ y (Q xs ys) = Q xs (y:ys) -- |'pushQ' inserts a high priority item into a Q. pushQ :: a -> Q a -> Q a pushQ x (Q xs ys) = Q (x:xs) ys -- |'deleteQ' removes any instances of a given element from the Q. deleteQ :: Eq a => a -> Q a -> Q a deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys) -- |'deleteQ' checks for membership in a Q. elemQ :: Eq a => a -> Q a -> Bool elemQ x (Q xs ys) = x `elem` xs || x `elem` ys -- |'emptyQ' is an empty Q. emptyQ :: Q a emptyQ = Q [] [] -- |'nullQ' checks if the Q contains no items. nullQ :: Q a -> Bool nullQ (Q [] []) = True nullQ _ = False -- | 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) darcs-2.10.2/src/Darcs/Util/Download/HTTP.hs0000644000175000017500000001053312620122474022346 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.Util.Download.HTTP ( fetchUrl, postUrl, requestUrl, waitNextUrl ) where import Prelude hiding ( catch ) import Darcs.Util.Global ( debugFail ) import Darcs.Util.Download.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.Util.Global ( debugMessage ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Version ( version ) #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 darcs-2.10.2/src/Darcs/Util/Download/Curl.hs0000644000175000017500000000476312620122474022504 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Util.Download.Curl where #ifdef HAVE_CURL import Control.Exception ( bracket ) import Control.Monad ( when ) import Foreign.C.Types ( CLong(..), CInt(..) ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Download.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 -> bracket malloc free $ \ errorPointer -> do e <- curl_request_url ustr fstr (cachableToInt cache) errorPointer >>= peekCString errorNum <- peek errorPointer when (errorNum == 90 ) $ debugMessage "The environment variable DARCS_CONNECTION_TIMEOUT is not a number" return e 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 null e then return Nothing else return $ case errorNum of 6 -> Just CouldNotResolveHost 7 -> Just CouldNotConnectToServer 28 -> Just OperationTimeout _ -> 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 -> Ptr 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 darcs-2.10.2/src/Darcs/Util/Show.hs0000644000175000017500000000056012620122474020737 0ustar00guillaumeguillaume00000000000000module Darcs.Util.Show ( appPrec, BSWrapper(..) ) where import qualified Data.ByteString as B appPrec :: Int appPrec = 10 newtype BSWrapper = BSWrapper B.ByteString instance Show BSWrapper where showsPrec d (BSWrapper bs) = showParen (d > appPrec) $ showString "Data.ByteString.Char8.pack " . showsPrec (appPrec + 1) bs darcs-2.10.2/src/Darcs/Util/URL.hs0000644000175000017500000000760312620122474020466 0ustar00guillaumeguillaume00000000000000{-# 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.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl, isRelative, isAbsolute, isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, urlOf, splitSshUrl ) where import Darcs.Util.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 isValidLocalPath :: String -> Bool isValidLocalPath f@(_:_:fou) = ':' `notElem` fou && FP.isValid f isValidLocalPath 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 | isValidLocalPath 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 darcs-2.10.2/src/Darcs/Util/Environment.hs0000644000175000017500000000051512620122474022323 0ustar00guillaumeguillaume00000000000000module Darcs.Util.Environment ( maybeGetEnv ) where import Prelude hiding ( catch ) import System.Environment ( getEnv ) import Darcs.Util.Exception ( catchall ) maybeGetEnv :: String -> IO (Maybe String) maybeGetEnv s = fmap Just (getEnv s) `catchall` return Nothing -- err can only be isDoesNotExist darcs-2.10.2/src/Darcs/Util/Printer.hs0000644000175000017500000004611712620122474021452 0ustar00guillaumeguillaume00000000000000-- | A 'Document' is at heart 'ShowS' from the prelude -- -- Essentially, if you give a Doc a string it'll print out whatever it -- wants followed by that string. So @text "foo"@ makes the Doc that -- prints @"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.: -- -- > (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" ++ ""))) -- -- The Empty alternative comes in because you want -- -- > text "a" $$ vcat xs $$ text "b" -- -- '$$' means above, 'vcat' is the list version of '$$' -- (to be @\"a\\nb\"@ when @xs@ is @[]@), but without the concept of an -- Empty Document each @$$@ would add a @'\n'@ and you'd end up with -- @\"a\\n\\nb\"@. -- Note that @Empty \/= text \"\"@ (the latter would cause two -- @'\\n'@). -- -- This code was made generic in the element type by Juliusz Chroboczek. module Darcs.Util.Printer ( Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..) , RenderMode(..) , hPutDoc, hPutDocLn, putDoc, putDocLn , hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith , hPutDocCompr , debugDocLn , renderString, renderStringWith, renderPS, renderPSWith , renderPSs, renderPSsWith, lineColor , prefix, insertBeforeLastline, colorText, invisibleText , prefixLines , 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 Control.Exception ( throwIO, ErrorCall(..) ) import Data.String ( IsString(..) ) import Data.List (intersperse) import GHC.Stack ( currentCallStack ) import System.IO (Handle, stdout, hPutStr) import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString as B (ByteString, hPut, concat) import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton) import Darcs.Util.ByteString ( linesPS, 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 -- | '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 x = unsafePerformIO $ do stack <- currentCallStack throwIO $ ErrorCall $ renderString Encode $ x $$ vcat (map text stack) -- | 'putDocWith' puts a doc on stdout using the given printer. putDocWith :: Printers -> Doc -> IO () putDocWith prs = hPutDocWith prs Encode stdout -- | 'putDocLnWith' puts a doc, followed by a newline on stdout using -- the given printer. putDocLnWith :: Printers -> Doc -> IO () putDocLnWith prs = hPutDocLnWith prs Encode stdout -- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'. putDoc :: Doc -> IO () putDoc = hPutDoc Encode stdout -- | 'putDocLn' puts a doc, followed by a newline on stdout using -- 'simplePrinters' putDocLn :: Doc -> IO () putDocLn = hPutDocLn Encode stdout -- | 'hputDocWith' puts a doc on the given handle using the given printer. hPutDocWith :: Printers -> RenderMode -> Handle -> Doc -> IO () hPutDocWith prs target h d = hPrintPrintables target h (renderWith (prs h) d) -- | 'hputDocLnWith' puts a doc, followed by a newline on the given -- handle using the given printer. hPutDocLnWith :: Printers -> RenderMode -> Handle -> Doc -> IO () hPutDocLnWith prs target h d = hPutDocWith prs target h (d newline) -- |'hputDoc' puts a doc on the given handle using 'simplePrinters' hPutDoc :: RenderMode -> Handle -> Doc -> IO () hPutDoc = hPutDocWith simplePrinters -- 'hputDocLn' puts a doc, followed by a newline on the given handle using -- 'simplePrinters'. hPutDocLn :: RenderMode -> Handle -> Doc -> IO () hPutDocLn = hPutDocLnWith simplePrinters -- | like 'hPutDoc' but with compress data before writing hPutDocCompr :: RenderMode -> Handle -> Doc -> IO () hPutDocCompr target h = gzWriteHandle h . renderPSs target -- | Write a 'Doc' to stderr if debugging is turned on. debugDocLn :: Doc -> IO () debugDocLn = debugMessage . renderString Standard -- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h hPrintPrintables :: RenderMode -> Handle -> [Printable] -> IO () hPrintPrintables target h = mapM_ (hPrintPrintable target h) -- | @hPrintPrintable h@ prints a 'Printable' to the handle h. hPrintPrintable :: RenderMode -> Handle -> Printable -> IO () hPrintPrintable Standard h (S ps) = hPutStr h ps hPrintPrintable Encode h (S ps) = B.hPut h (encodeLocale ps) hPrintPrintable Standard h (PS ps) = B.hPut h ps hPrintPrintable Encode h (PS ps) = B.hPut h ps hPrintPrintable Standard h (Both _ ps) = B.hPut h ps hPrintPrintable Encode 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 } instance IsString Doc where fromString = text -- TODO this is a rather ad-hoc hack that further complicates -- some already confusing code. We should find a more general -- solution. See the discussion on issue1639. -- | Used when rendering a 'Doc' to indicate if the result -- should be encoded to the current locale or left alone. -- In practice this only affects output when a relevant -- DARCS_DONT_ESCAPE_XXX option is set (see Darcs.Util.Printer.Color) -- If in doubt, choose 'Standard'. data RenderMode = Encode -- ^Encode Strings with the current locale. -- At present ByteStrings are assumed to be in -- UTF8 and are left alone, so will be mis-encoded -- in non-UTF8 locales. | Standard -- ^Don't encode. -- | 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 :: RenderMode -> Doc -> String renderString = renderStringWith simplePrinters' -- | renders a 'Doc' into a 'String' using a given set of printers. renderStringWith :: Printers' -> RenderMode -> Doc -> String renderStringWith prs target d = concatMap (toString target) $ renderWith prs d where toString Standard (S s) = s toString Encode (S s) = BC.unpack . encodeLocale $ s toString Standard (PS ps) = BC.unpack ps toString Encode (PS ps) = BC.unpack ps toString Standard (Both s _) = s toString Encode (Both s _) = BC.unpack . encodeLocale $ s -- | renders a 'Doc' into 'B.ByteString' with control codes for the -- special features of the Doc. See also 'readerString'. renderPS :: RenderMode -> Doc -> B.ByteString renderPS = renderPSWith simplePrinters' -- | renders a 'Doc' into a list of 'PackedStrings', one for each line. renderPSs :: RenderMode -> Doc -> [B.ByteString] renderPSs = renderPSsWith simplePrinters' -- | renders a doc into a 'B.ByteString' using a given set of printers. renderPSWith :: Printers' -> RenderMode -> Doc -> B.ByteString renderPSWith prs target d = B.concat $ renderPSsWith prs target 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' -> RenderMode -> Doc -> [B.ByteString] renderPSsWith prs target d = map (toPS target) $ renderWith prs d where toPS Standard (S s) = BC.pack s toPS Encode (S s) = encodeLocale s toPS Standard (PS ps) = ps toPS Encode (PS ps) = ps toPS Standard (Both _ ps) = ps toPS Encode (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 $ -- this will just get round-tripped back into a Doc, renderPS Standard 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 = -- as this will just get round-tripped back into a Doc, -- we use 'Standard' as the Target type so the encoding -- is left alone case reverse $ map packedString $ linesPS $ renderPS Standard 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 Standard $ 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 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 -- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'. 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 -- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@ userchunk :: String -> Doc userchunk = userchunkPrintable . S -- | 'blueText' creates a 'Doc' containing blue text from a @String@ 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 -- | '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 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 <> 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 darcs-2.10.2/src/Darcs/Util/Exec.hs0000644000175000017500000002033112620122474020701 0ustar00guillaumeguillaume00000000000000-- 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.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 #ifndef WIN32 import Control.Exception ( bracket ) 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 _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 $ 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 = 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 darcs-2.10.2/src/Darcs/Util/Bug.hs0000644000175000017500000000152212620122474020533 0ustar00guillaumeguillaume00000000000000-- Reporting bugs in darcs. See also impossible.h. module Darcs.Util.Bug ( _bug, _bugDoc, _impossible, _fromJust ) where import Data.Maybe(fromMaybe) import Darcs.Util.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 = fromMaybe (_bug bs $ "fromJust error at " ++ _bugLoc bs) darcs-2.10.2/src/Darcs/Util/AtExit.hs0000644000175000017500000000507612620122474021224 0ustar00guillaumeguillaume00000000000000-- 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.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 Control.Concurrent.MVar import Control.Exception ( bracket_, catch, SomeException , mask ) import System.IO.Unsafe (unsafePerformIO) import System.IO ( hPutStrLn, stderr, hPrint ) import Prelude hiding (catch) 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 = bracket_ (return ()) exit 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:" hPrint stderr exn darcs-2.10.2/src/Darcs/Util/DateMatcher.hs0000644000175000017500000001646312620122474022211 0ustar00guillaumeguillaume00000000000000-- 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 : 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 ) where 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 ) -- | '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 -- | '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 darcs-2.10.2/src/Darcs/Util/Encoding/0000755000175000017500000000000012620122474021210 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Util/Encoding/IConv.hsc0000644000175000017500000001627112620122474022734 0ustar00guillaumeguillaume00000000000000-- 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 Darcs.Util.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 #include #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) darcs-2.10.2/src/Darcs/Util/Encoding/Win32.hs0000644000175000017500000000670312620122474022454 0ustar00guillaumeguillaume00000000000000-- 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 Darcs.Util.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 darcs-2.10.2/src/Darcs/Util/Global.hs0000644000175000017500000001141512620122474021220 0ustar00guillaumeguillaume00000000000000-- 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.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 ( timingsMode , setTimingsMode , whenDebugMode , withDebugMode , setDebugMode , debugMessage , debugFail , putTiming , addCRCWarning , getCRCWarnings , resetCRCWarnings , addBadSource , getBadSourcesList , isBadSource , darcsdir , darcsLastMessage , darcsSendMessage , darcsSendMessageFinal , isReachableSource , addReachableSource ) where import Control.Monad ( when ) import Data.IORef ( modifyIORef, IORef, newIORef, readIORef, writeIORef ) import System.IO.Unsafe (unsafePerformIO) import System.IO ( hPutStrLn, hPutStr, stderr ) import System.Time ( calendarTimeToString, toCalendarTime, getClockTime ) import System.FilePath.Posix ( combine, (<.>) ) import Prelude hiding (catch) -- 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 #-} 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" darcsLastMessage :: String darcsLastMessage = combine darcsdir "patch_description.txt" darcsSendMessage :: String darcsSendMessage = combine darcsdir "darcs-send" darcsSendMessageFinal :: String darcsSendMessageFinal = darcsSendMessage <.> "final" darcs-2.10.2/src/Darcs/Util/DateTime.hs0000644000175000017500000000435312620122474021517 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2011 Eric Sessoms -- -- BSD3 {-# LANGUAGE CPP #-} #if MIN_VERSION_time(1,5,0) -- for parseTime, which we need to use while we support time-1.4 {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif module Darcs.Util.DateTime ( getCurrentTime, toSeconds , formatDateTime, fromClockTime, parseDateTime, startOfTime ) where import qualified Data.Time.Calendar as Calendar ( fromGregorian ) import Data.Time.Clock ( UTCTime(UTCTime), UniversalTime(ModJulianDate) , getModJulianDate, secondsToDiffTime, getCurrentTime ) import Data.Time.Format ( formatTime, parseTime ) import Data.Time.LocalTime ( utc , localTimeToUT1, ut1ToLocalTime , localTimeToUTC, utcToLocalTime ) #if MIN_VERSION_time(1,5,0) import Data.Time ( defaultTimeLocale ) #else import System.Locale ( defaultTimeLocale ) #endif 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 = parseTime 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 darcs-2.10.2/src/Darcs/Util/Ratified.hs0000644000175000017500000000024312620122474021544 0ustar00guillaumeguillaume00000000000000-- | XXX: Perhaps a word of explanation here [WL] module Darcs.Util.Ratified ( readFile , hGetContents ) where import System.IO( hGetContents ) darcs-2.10.2/src/Darcs/Util/Exception.hs0000644000175000017500000000415012620122474021754 0ustar00guillaumeguillaume00000000000000{-# Language MultiParamTypeClasses, DeriveDataTypeable #-} module Darcs.Util.Exception ( firstJustIO , catchall , clarifyErrors , prettyException , prettyError ) where import Prelude hiding ( catch ) import Control.Exception ( SomeException, Exception(fromException), catch ) import Data.Maybe ( isJust ) import System.IO.Error ( isUserError, ioeGetErrorString , isDoesNotExistError, ioeGetFileName ) import Darcs.Util.SignalHandler ( catchNonSignal ) catchall :: IO a -> IO a -> IO a a `catchall` b = a `catchNonSignal` (\_ -> 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 -> 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 darcs-2.10.2/src/Darcs/Util/Workaround.hs0000644000175000017500000000712712620122474022160 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} -- | -- Module : Darcs.Util.Workaround -- Copyright : 2008 David Roundy -- License : GPL -- Maintainer : darcs-devel@darcs.net -- Stability : experimental -- Portability : portable module Darcs.Util.Workaround ( renameFile , setExecutable , getCurrentDirectory , installHandler , raiseSignal , Handler(..) , Signal , sigINT , sigHUP , sigABRT , sigALRM , sigTERM , sigPIPE ) where import Prelude hiding ( catch ) #ifdef WIN32 import Control.Monad ( unless ) 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 -> unless (System.IO.Error.isDoesNotExistError e) $ 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 _ <- 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 darcs-2.10.2/src/Darcs/Util/ByteString.hs0000644000175000017500000004607612620122474022125 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- 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 ( unsafeWithInternals, unpackPSFromUTF8, packStringToUTF8, -- IO with mmap or gzip gzReadFilePS, mmapFilePS, gzWriteFilePS, gzWriteFilePSs, gzReadStdin, gzWriteHandle, -- 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 mingw32_HOST_OS #else import Control.Exception ( catch, SomeException ) #endif import System.IO import System.IO.Unsafe ( unsafePerformIO ) import Foreign.Storable ( 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 ) #if MIN_VERSION_zlib(0,6,0) import Control.Monad.ST.Lazy ( ST ) #endif 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.Util.Encoding ( decode, encode ) import Darcs.Util.Global ( addCRCWarning ) #if mingw32_HOST_OS #else import System.IO.MMap( mmapFileByteString ) import System.Mem( performGC ) import System.Posix.Files( fileSize, getSymbolicLinkStatus ) #endif -- ----------------------------------------------------------------------------- -- obsolete debugging code -- ----------------------------------------------------------------------------- -- 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 = (`elem` [0x20, 0x09, 0x0A, 0x0D]) {-# INLINE isSpaceWord8 #-} dropSpace :: B.ByteString -> B.ByteString dropSpace bs = B.dropWhile isSpaceWord8 bs breakSpace :: B.ByteString -> (B.ByteString, B.ByteString) breakSpace bs = B.break isSpaceWord8 bs ------------------------------------------------------------------------ {-# 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 = f (0 :: Int32) 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 #if MIN_VERSION_zlib(0,6,0) decompressWarn (ZI.decompressST ZI.gzipFormat decompressParams) #else toListWarn . ZI.decompressWithErrors ZI.gzipFormat decompressParams #endif where decompressParams = case mbufsize of Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize } Nothing -> GZ.defaultDecompressParams #if MIN_VERSION_zlib(0,6,0) 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 #else 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 #endif -- 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. #if MIN_VERSION_zlib(0,6,0) handleBad (ZI.DataFormatError "incorrect data check") = ([], True) handleBad e = error (show e) #else handleBad ZI.DataError "incorrect data check" = ([], True) handleBad _ msg = error msg #endif 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 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 /= 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 #if mingw32_HOST_OS mmapFilePS = B.readFile #else mmapFilePS f = mmapFileByteString f Nothing `catch` (\(_ :: SomeException) -> do size <- fileSize `fmap` getSymbolicLinkStatus f if size == 0 then return B.empty else performGC >> mmapFileByteString f Nothing) #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) | otherwise = Just (B.empty, the_ps) breakAfterNthNewline n the_ps = go n (B.elemIndices (BI.c2w '\n') the_ps) where go 0 [] = Just (the_ps, B.empty) go _ [] = Nothing go 1 (i:_) = Just $ B.splitAt (i+1) the_ps go !m (_:is) = go (m-1) is -- ------------------------------------------------------------------------- -- breakBeforeNthNewline breakBeforeNthNewline :: Int -> B.ByteString -> (B.ByteString, B.ByteString) breakBeforeNthNewline 0 the_ps | B.null the_ps = (B.empty, B.empty) breakBeforeNthNewline n the_ps = go n (B.elemIndices (BI.c2w '\n') the_ps) where go _ [] = (the_ps, B.empty) go 0 (i:_) = B.splitAt i the_ps go !m (_:is) = go (m-1) is -- | Test if a ByteString is made of ascii characters isAscii :: B.ByteString -> Bool isAscii = B.all (< 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 char8 encoding (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) encodeChar8 :: String -> B.ByteString encodeChar8 = 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. -- Note: we globally enforce char8 as the default encoding, see "Main" and -- "Darcs.Utils". This means we get command line args and environment variables -- as 'String's with char8 encoding, too. So we need this to convert such -- strings back to the user's encoding. decodeString :: String -> IO String decodeString = decode . encodeChar8 darcs-2.10.2/src/Darcs/Util/CommandLine.hs0000644000175000017500000001204112620122474022202 0ustar00guillaumeguillaume00000000000000-- 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. -- -- Some tests for the parser. -- -- > formatTable = [('s',""), -- > ('a',"")] -- > -- > 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",""], True))] -- > -- > runTests = map (uncurry $ testParser (commandline formatTable)) testCases module Darcs.Util.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 = 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 darcs-2.10.2/src/Darcs/Util/Progress.hs0000644000175000017500000002037712620122474021633 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} -- | -- 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 , debugMessage , debugFail , withoutProgress , progress , progressKeepLatest , finishedOne , finishedOneIO , progressList , minlist , setProgressMode ) where import Prelude hiding (lookup) import Control.Arrow ( second ) import Control.Exception ( bracket ) import Control.Monad ( when, unless, 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 System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn, hSetBuffering, hIsTerminalDevice, Handle, BufferMode(LineBuffering) ) import System.IO.Unsafe ( unsafePerformIO ) import Darcs.Util.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 (second $ delete k) 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 $ putStr spaces else \s -> unless (null s) $ do hPutStrLn fe s hFlush fe 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 darcs-2.10.2/src/Darcs/Util/Path.hs0000644000175000017500000004544312620122474020724 0ustar00guillaumeguillaume00000000000000-- 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 ( module Storage.Hashed.AnchoredPath , FileName( ) , fp2fn , fn2fp , fn2ps , ps2fn , niceps2fn , fn2niceps , breakOnDir , normPath , ownName , superName , movedirfilename , encodeWhite , decodeWhite , isParentOrEqOf -- * AbsolutePath , AbsolutePath , makeAbsolute , ioAbsolute , rootDirectory -- * AbsolutePathOrStd , AbsolutePathOrStd , makeAbsoluteOrStd , ioAbsoluteOrStd , useAbsoluteOrStd , stdOut -- * AbsoluteOrRemotePath , AbsoluteOrRemotePath , ioAbsoluteOrRemote , isRemote -- * SubPath , SubPath , makeSubPathOf , simpleSubPath , isSubPathOf , floatSubPath -- * Miscellaneous , sp2fn , FilePathOrURL(..) , FilePathLike(toFilePath) , getCurrentDirectory , setCurrentDirectory , getUniquePathName , doesPathExist -- * Check for malicious paths , isMaliciousPath , isMaliciousSubPath -- * Tree filtering. , filterFilePaths , filterPaths ) where import Storage.Hashed.AnchoredPath import Control.Applicative ( (<$>) ) import Data.List ( isPrefixOf , isSuffixOf , stripPrefix , intersect ) import Data.Char ( isSpace, chr, ord ) import Control.Exception ( tryJust, bracket_ ) import Control.Monad ( when ) import System.IO.Error ( isDoesNotExistError ) import qualified Darcs.Util.Workaround as Workaround ( getCurrentDirectory ) import qualified System.Directory ( setCurrentDirectory ) import System.Directory ( doesDirectoryExist, doesFileExist ) import qualified System.FilePath.Posix as FilePath ( normalise ) import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory ) import System.FilePath ( splitDirectories ) import System.Posix.Files ( isDirectory, getSymbolicLinkStatus ) import Darcs.Util.ByteString ( packStringToUTF8, unpackPSFromUTF8 ) import qualified Data.ByteString.Char8 as BC (unpack, pack) import qualified Data.ByteString as B (ByteString) import Data.Binary import Darcs.Util.Global ( darcsdir ) import Darcs.Util.URL ( isAbsolute, isRelative, isSshNopath ) #include "impossible.h" -- | FileName is an abstract type intended to facilitate the input and output of -- unicode filenames. 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 instance Binary FileName where put (FN h) = put h get = FN `fmap` get {-# INLINE fp2fn #-} fp2fn :: FilePath -> FileName fp2fn = FN {-# 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 {-# INLINE sp2fn #-} sp2fn :: SubPath -> FileName sp2fn = fp2fn . toFilePath -- | '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_ = go cs_ [] False where go "" acc True = reverse acc -- if there was a replace, use new string go "" _ False = cs_ -- if not, use input string go ('\\':cs) acc _ = case break (=='\\') cs of (theord, '\\':rest) -> go rest (chr (read theord) :acc) True _ -> error "malformed filename" go (c:cs) acc modified = go cs (c:acc) modified 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) -- | convert a path string into a sequence of directories strings -- "/", "." and ".." are generally interpreted as expected. -- Behaviour with too many '..' is to leave them. -- -- Examples: -- Splitting: -- "aa/bb/cc" -> ["aa","bb","cc"] -- Ignoring "." and extra "/": -- "aa/./bb" -> ["aa","bb"] -- "aa//bb" -> ["aa","bb"] -- "/aa/bb/" -> ["aa","bb"] -- Handling "..": -- "aa/../bb/cc" -> ["bb","cc"] -- "aa/bb/../../cc" -> ["cc"] -- "aa/../bb/../cc" -> ["cc"] -- "../cc" -> ["..","cc"] normPath :: FileName -> FileName normPath (FN p) = FN $ norm p norm :: String -> String norm ('.':'/':s) = norm s norm ('/':s) = norm s norm "." = "" norm s = go s [] False where go "" _ False = s -- no modification go "" acc True = reverse acc go ('/':r) acc _ | sep r = go r acc True go ('/':'.':r) acc _ | sep r = go r acc True go ('/':'.':'.':r) acc _ | sep r = go r (doDotDot acc) True go (c:s') acc changed = go s' (c:acc) changed -- remove last path or add "/.." if impossible doDotDot "" = ".." doDotDot acc@('.':'.':r) | sep r = '.':'.':'/':acc doDotDot acc = let a' = dropWhile (/='/') acc in -- eat dir if null a' then "" else tail a' -- check if is a path separator sep ('/':_) = True sep [] = True -- end of string is considered separator sep _ = False breakFirst :: Char -> String -> Maybe (String,String) breakFirst c = bf [] 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) 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 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 FileName where toPath = fn2fp instance FilePathLike FileName where toFilePath = 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 isSubPathOf :: SubPath -> SubPath -> Bool isSubPathOf (SubPath p1) (SubPath p2) = p1 == "" || p1 == p2 || (p1 ++ "/") `isPrefixOf` p2 -- | 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 doesPathExist :: FilePath -> IO Bool doesPathExist p = do dir_exists <- doesDirectoryExist p file_exists <- doesFileExist p return $ dir_exists || file_exists -- | 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) (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 -- | 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 {-| 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 -- | 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 -- | 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 _ when 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 -- | Transform a SubPath into an AnchoredPath. floatSubPath :: SubPath -> AnchoredPath floatSubPath = floatPath . fn2fp . sp2fn darcs-2.10.2/src/Darcs/Util/Text.hs0000644000175000017500000000276112620122474020750 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE OverloadedStrings #-} module Darcs.Util.Text ( -- * Text construction. sentence -- * Text formatting. , formatText , formatParas , formatPara , chompTrailingNewline -- * Text processing , breakCommand ) where import Control.Arrow ( first ) import Data.List ( intercalate ) import Darcs.Util.Printer ( Doc, (<>) ) sentence :: Doc -> Doc sentence = (<> ".") -- |Take a list of paragraphs and format them to the given line length, with -- a blank line between paragraphs. formatText :: Int -> [String] -> String formatText linelen = unlines . formatParas linelen formatParas :: Int -> [String] -> [String] formatParas linelen = intercalate [""] . map (map unwords . formatPara linelen . 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. formatPara :: Int -> [[a]] -> [[[a]]] formatPara 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) breakCommand :: String -> (String, [String]) breakCommand s = case words s of (arg0:args) -> (arg0,args) [] -> (s,[]) chompTrailingNewline :: String -> String chompTrailingNewline "" = "" chompTrailingNewline s = if last s == '\n' then init s else s darcs-2.10.2/src/Darcs/Util/English.hs0000644000175000017500000000700012620122474021404 0ustar00guillaumeguillaume00000000000000-- 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 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" darcs-2.10.2/src/Darcs/Util/IsoDate.hs0000644000175000017500000010056312620122474021353 0ustar00guillaumeguillaume00000000000000-- 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 , 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 -> 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 -- | 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 ((<|>) . (\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 } darcs-2.10.2/src/Darcs/Util/Encoding.hs0000644000175000017500000000370112620122474021545 0ustar00guillaumeguillaume00000000000000-- 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 ) where import Data.ByteString ( ByteString ) #ifdef WIN32 import qualified Darcs.Util.Encoding.Win32 as Backend ( encode, decode ) #else import qualified Darcs.Util.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 darcs-2.10.2/src/Darcs/Util/Prompt.hs0000644000175000017500000000723312620122474021304 0ustar00guillaumeguillaume00000000000000module Darcs.Util.Prompt ( -- * User prompts askEnter , askUser , askUserListItem , PromptConfig(..) , promptYorn , promptChar ) where import Prelude hiding ( catch ) import Control.Monad ( void ) 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 (error "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 (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 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 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 . toLower) 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 darcs-2.10.2/src/Darcs/Util/Diff.hs0000644000175000017500000000106612620122474020671 0ustar00guillaumeguillaume00000000000000module Darcs.Util.Diff ( getChanges , DiffAlgorithm(..) ) where 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.getChangesdarcs-2.10.2/src/Darcs/Util/File.hs0000644000175000017500000001010612620122474020673 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.Util.File ( -- * Files and directories getFileStatus , withCurrentDirectory , doesDirectoryReallyExist , removeFileMayNotExist -- * OS-dependent special directories , xdgCacheDir , osxCacheDir , getDirectoryContents , getRecursiveContents , getRecursiveContentsFullPath ) where import Prelude hiding ( catch ) import Control.Exception ( catch, bracket ) import Control.Monad ( when, unless, forM ) import System.Environment ( getEnvironment ) import System.Directory ( removeFile, getHomeDirectory, getAppUserDataDirectory, doesDirectoryExist, createDirectory, getDirectoryContents ) import System.IO.Error ( isDoesNotExistError ) import System.Posix.Files( getSymbolicLinkStatus, FileStatus, isDirectory #ifndef WIN32 , setFileMode, ownerModes #endif ) import System.FilePath.Posix ( () ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Path( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath ) 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) getFileStatus :: FilePath -> IO (Maybe FileStatus) getFileStatus f = Just `fmap` getSymbolicLinkStatus f `catchall` return Nothing doesDirectoryReallyExist :: FilePath -> IO Bool doesDirectoryReallyExist f = catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False 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 -- |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 #ifndef WIN32 -- see http://bugs.darcs.net/issue2334 setFileMode d ownerModes #endif return $ Just d `catchall` return Nothing -- |getRecursiveContents returns all files under topdir that aren't -- directories. getRecursiveContents :: FilePath -> IO [FilePath] getRecursiveContents topdir = do names <- getDirectoryContents topdir let properNames = filter (`notElem` [".", ".."]) names paths <- forM properNames $ \name -> do let path = topdir name isDir <- doesDirectoryExist path if isDir then getRecursiveContents path else return [name] return (concat paths) -- |getRecursiveContentsFullPath returns all files under topdir -- that aren't directories. -- Unlike getRecursiveContents this function returns the full path. getRecursiveContentsFullPath :: FilePath -> IO [FilePath] getRecursiveContentsFullPath topdir = do names <- getDirectoryContents topdir let properNames = filter (`notElem` [".", ".."]) names paths <- forM properNames $ \name -> do let path = topdir name isDir <- doesDirectoryExist path if isDir then getRecursiveContentsFullPath path else return [path] return (concat paths) darcs-2.10.2/src/Darcs/Util/Download.hs0000644000175000017500000003303012620122474021564 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-deprecations #-} -- using isEmptyChan {-# LANGUAGE CPP #-} -- | -- Module : Darcs.Util.Download -- Copyright : 2008 Dmitry Kurochkin -- License : GPL -- Maintainer : darcs-devel@darcs.net -- Stability : experimental -- Portability : portable module Darcs.Util.Download ( copyUrl , copyUrlFirst , setDebugHTTP , disableHTTPPipelining , maxPipelineLength , waitUrl , Cachable(Cachable, Uncachable, MaxAge) , environmentHelpProxy , environmentHelpProxyPassword , ConnectionError(..) ) where import Control.Arrow ( (&&&) ) 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.State ( evalStateT, get, modify, put, StateT ) import Control.Monad.Trans ( liftIO ) import Data.IORef ( newIORef, readIORef, writeIORef, IORef ) import Data.Map ( Map ) import qualified Data.Map as Map import Data.Tuple ( swap ) import System.Directory ( copyFile ) import System.IO.Unsafe ( unsafePerformIO ) import System.Random ( randomRIO ) import Darcs.Util.AtExit ( atexit ) import Darcs.Util.File ( removeFileMayNotExist ) import Numeric ( showHex ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Download.Request import Darcs.Util.Workaround ( renameFile ) #ifdef HAVE_CURL import qualified Darcs.Util.Download.Curl as Curl #elif defined(HAVE_HTTP) import qualified Darcs.Util.Download.HTTP as HTTP #else import Darcs.Util.Progress ( debugFail ) import qualified HTTP ( requestUrl, waitNextUrl ) #endif #include "impossible.h" {-# NOINLINE maxPipelineLengthRef #-} maxPipelineLengthRef :: IORef Int maxPipelineLengthRef = unsafePerformIO $ do enabled <- pipeliningEnabled #ifdef HAVE_CURL unless 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 (Maybe String))) urlNotifications = unsafePerformIO $ newMVar Map.empty {-# NOINLINE urlChan #-} urlChan :: Chan UrlRequest urlChan = unsafePerformIO $ do ch <- newChan _ <- forkIO (urlThread ch) return ch type UrlM a = StateT UrlState IO a urlThread :: Chan UrlRequest -> IO () urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk) where rrange = (0, 2 ^ (128 :: Integer) :: Integer) urlThread' :: UrlM () urlThread' = do empty <- liftIO $ isEmptyChan ch (l, w) <- (pipeLength &&& waitToStart) `fmap` get -- If we've got UrlRequests waiting on the chan, or there's nothing -- waiting to start and nothing already downloading, we just block -- waiting for more UrlRequests. reqs <- if not empty || (nullQ w && l == 0) then liftIO readAllRequests else return [] mapM_ addReq reqs checkWaitToStart waitNextUrl urlThread' readAllRequests :: IO [UrlRequest] readAllRequests = do r <- readChan ch debugMessage $ "URL.urlThread (" ++ url r ++ "\n"++ "-> " ++ file r ++ ")" empty <- isEmptyChan ch reqs <- if not empty then readAllRequests else return [] return (r : reqs) -- | addReq adds a UrlRequest to the current downloads, being careful to -- update the lists of target filenames if the url is already being -- downloaded. addReq :: UrlRequest -> UrlM () addReq (UrlRequest u f c p) = do d <- liftIO (alreadyDownloaded u) if d then dbg "Ignoring UrlRequest of URL that is already downloaded." else do (ip, wts) <- (inProgress &&& waitToStart) `fmap` get case Map.lookup u ip of Nothing -> modify $ \st -> st { inProgress = Map.insert u (f, [], c) ip , waitToStart = addUsingPriority p u wts } Just (f', fs', c') -> do let new_c = minCachable c c' when (c /= c') $ do let new_p = Map.insert u (f', fs', new_c) ip modify (\s -> s { inProgress = new_p }) dbg $ "Changing " ++ u ++ " request cachability from " ++ show c ++ " to " ++ show new_c when (u `elemQ` wts && p == High) $ do modify $ \s -> s { waitToStart = pushQ u (deleteQ u wts) } dbg $ "Moving " ++ u ++ " to head of download queue." if f `notElem` (f' : fs') then do let new_ip = Map.insert u (f', f : fs', new_c) ip modify (\s -> s { inProgress = new_ip }) dbg "Adding new file to existing UrlRequest." else dbg $ "Ignoring UrlRequest of file that's " ++ "already queued." alreadyDownloaded :: String -> IO Bool alreadyDownloaded u = do n <- withMVar urlNotifications $ return . Map.lookup u maybe (return True) (\v -> not `fmap` isEmptyMVar v) n -- |'checkWaitToStart' will inspect the current waiting-to-start queue, if the -- pipe isn't full, checkWaitToStart :: UrlM () checkWaitToStart = do st <- get let l = pipeLength st mpl <- liftIO maxPipelineLength when (l < mpl) $ case readQ (waitToStart st) of Nothing -> return () Just (u, rest) -> do case Map.lookup u (inProgress st) of Nothing -> bug $ "bug in URL.checkWaitToStart " ++ u Just (f, _, c) -> do dbg $ "URL.requestUrl (" ++ u ++ "\n" ++ "-> " ++ f ++ ")" let f_new = createDownloadFileName f st err <- liftIO $ requestUrl u f_new c if null err then do -- waitNextUrl might never return this url as -- complete/failed, so being careful, we should -- try and delete the corresponding file atexit liftIO $ atexit (removeFileMayNotExist f_new) -- We've started off another download, so the -- pipline length should increase. 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 } checkWaitToStart 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 . swap . 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 ++ ")" createDownloadFileName :: FilePath -> UrlState -> FilePath createDownloadFileName f st = f ++ "-new_" ++ randomJunk st waitNextUrl :: UrlM () 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 liftIO $ case Map.lookup u p of Nothing -> -- A url finished downloading, but we don't have a record of it bug $ "bug in URL.waitNextUrl: " ++ u Just (f, fs, _) -> if null e then do -- Succesful download renameFile (createDownloadFileName f st) f mapM_ (safeCopyFile st f) fs downloadComplete u e debugMessage $ "URL.waitNextUrl succeeded: " ++ u ++ " " ++ f else do -- An error while downloading removeFileMayNotExist (createDownloadFileName f st) downloadComplete u (maybe e show ce) debugMessage $ "URL.waitNextUrl failed: " ++ u ++ " " ++ f ++ " " ++ e unless (null u) . put $ st { inProgress = Map.delete u p , pipeLength = l - 1 } where safeCopyFile st f t = do let new_t = createDownloadFileName t st 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 $ if null e then Nothing else Just 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 Nothing -> return () -- file was already downloaded Just var -> do mbErr <- readMVar var modifyMVar_ urlNotifications (return . Map.delete u) flip (maybe (return ())) mbErr $ \e -> do debugMessage $ "Failed to download URL " ++ u ++ ": " ++ e fail e 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://][: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." ] ) darcs-2.10.2/src/Darcs/Util/Ssh.hs0000644000175000017500000000620012620122474020551 0ustar00guillaumeguillaume00000000000000-- -- -- 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 ) where import Control.Applicative ( (<$>), (<*>) ) import Control.Exception ( catch, catchJust, SomeException ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isPrefixOf ) import System.Info ( os ) import System.IO.Unsafe (unsafePerformIO) import System.IO.Error ( ioeGetErrorType, isDoesNotExistErrorType ) import System.Process ( readProcessWithExitCode ) import System.Environment ( getEnv ) import Prelude hiding (catch) 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 -- | 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 darcs-2.10.2/src/Darcs/Util/SignalHandler.hs0000644000175000017500000001313412620122474022533 0ustar00guillaumeguillaume00000000000000-- 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.Util.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 ( catch, throw, 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) withSignalsHandled :: IO a -> IO a newtype SignalException = SignalException Signal deriving (Show, Typeable) instance Exception SignalException where toException = SomeException 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 unless 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 () 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 _ -> 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 "" = 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 darcs-2.10.2/src/Darcs/Util/Diff/0000755000175000017500000000000012620122474020332 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Util/Diff/Patience.hs0000644000175000017500000004162112620122474022422 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} -- 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 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 ) #ifdef USE_LOCAL_DATA_MAP_STRICT import qualified Darcs.Data.Map.Strict as M #else import qualified Data.Map.Strict as M #endif ( Map, lookup, insertWith, empty, elems ) import qualified Data.Hashable as H ( hash ) import Darcs.Util.Diff.Myers (initP, aLen, PArray, getSlice) #include "impossible.h" 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 | oldbs == Nothing || null oldhunkpair = insert hash bs lmap | otherwise = (fst $ head $ oldhunkpair, lmap) where hash = H.hash bs oldbs = M.lookup hash (getMap lmap) oldhunkpair = filter ((== bs) . snd) $ fromJust oldbs 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 (_,[]) -> impossible (_,[]) -> impossible 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 = if rmd == add then mkdiff boring (ny+length add+1) ls restx resty else if boring rmd && boring add then 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 else 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 = if boring rmd && boring add then case lcs rmd add of [] -> prefixPostfixDiff ny rmd add ll -> mkdiff (const False) ny ll rmd add else 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 _ -> impossible _ -> impossible 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 $ lcs_simple (reverse (c1:c1s)) (reverse (c2:c2s)) lcs_simple :: Ord a => [a] -> [a] -> [a] lcs_simple [] _ = [] lcs_simple _ [] = [] lcs_simple s1@(c1:c1s) s2@(c2:c2s) | c1 == c2 = c1: lcs c1s c2s | otherwise = hunt $ prune_matches s1 $! find_matches s1 s2 prune_matches :: [a] -> [[Int]] -> [(a, [Int])] prune_matches _ [] = [] prune_matches [] _ = [] prune_matches (_:cs) ([]:ms) = prune_matches cs ms prune_matches (c:cs) (m:ms) = (c,m): prune_matches cs ms type Threshold s a = STArray s Int (Int,[a]) hunt :: [(a, [Int])] -> [a] hunt [] = [] hunt csmatches = runST ( do th <- empty_threshold (length csmatches) l hunt_internal csmatches th hunt_recover th (-1) l ) where l = maximum (0 : concat (map snd csmatches)) hunt_internal :: [(a, [Int])] -> Threshold s a -> ST s () hunt_internal [] _ = return () hunt_internal ((c,m):csms) th = do hunt_one_char c m th hunt_internal csms th hunt_one_char :: a -> [Int] -> Threshold s a -> ST s () hunt_one_char _ [] _ = return () hunt_one_char c (j:js) th = do index_k <- my_bs j th case index_k of Nothing -> return () Just k -> do (_, rest) <- readArray th (k-1) writeArray th k (j, c:rest) hunt_one_char c js th -- This is O(n), which is stupid. hunt_recover :: Threshold s a -> Int -> Int -> ST s [a] hunt_recover th n limit = do (_, th_max) <- getBounds th if n < 0 then hunt_recover th th_max limit else if n == 0 then return [] else if n > th_max then return [] else do (thn, sn) <- readArray th n if thn <= limit then return $ reverse sn else hunt_recover th (n-1) limit empty_threshold :: Int -> Int -> ST s (Threshold s a) empty_threshold l th_max = do th <- newArray (0,l) (th_max+1, []) writeArray th 0 (0, []) return th my_bs :: Int -> Threshold s a -> ST s (Maybe Int) my_bs j th = do bnds <- getBounds th my_helper_bs j bnds th my_helper_bs :: Int -> (Int,Int) -> Threshold s a -> ST s (Maybe Int) my_helper_bs j (th_min,th_max) th = if th_max - th_min > 1 then do (midth, _) <- readArray th th_middle if j > midth then my_helper_bs j (th_middle,th_max) th else my_helper_bs 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 find_matches :: Ord a => [a] -> [a] -> [[Int]] find_matches [] [] = [] find_matches [] (_:bs) = []: find_matches [] bs find_matches _ [] = [] find_matches a b = unzip_indexed $ sort $ find_sorted_matches indexeda indexedb [] [] where indexeda = sort $ zip a [1..] indexedb = sort $ zip b [1..] unzip_indexed :: [(Int,[a])] -> [[a]] unzip_indexed s = unzip_indexed_helper 1 s where unzip_indexed_helper _ [] = [] unzip_indexed_helper thisl ((l,c):rest) | thisl == l = c: unzip_indexed_helper (l+1) rest | otherwise = []: unzip_indexed_helper (thisl+1) ((l,c):rest) find_sorted_matches :: Ord a => [(a, Int)] -> [(a, Int)] -> [a] -> [Int] -> [(Int, [Int])] find_sorted_matches [] _ _ _ = [] find_sorted_matches _ [] _ _ = [] find_sorted_matches ((a,na):as) ((b,nb):bs) aold aoldmatches | [a] == aold = (na, aoldmatches) : find_sorted_matches as ((b,nb):bs) aold aoldmatches | a > b = find_sorted_matches ((a,na):as) bs aold aoldmatches | a < b = find_sorted_matches as ((b,nb):bs) aold aoldmatches -- following line is inefficient if a line is repeated many times. find_sorted_matches ((a,na):as) bs _ _ -- a == b = (na, matches) : find_sorted_matches as bs [a] matches where matches = reverse $ map snd $ filter ((==a) . fst) bs darcs-2.10.2/src/Darcs/Util/Diff/Myers.hs0000644000175000017500000005104512620122474021772 0ustar00guillaumeguillaume00000000000000-- 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 : 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 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 ) #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 | 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) 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 = 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 darcs-2.10.2/src/Darcs/Util/Crypt/0000755000175000017500000000000012620122474020563 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/Darcs/Util/Crypt/SHA256.hs0000644000175000017500000000042412620122474021767 0ustar00guillaumeguillaume00000000000000module Darcs.Util.Crypt.SHA256 ( sha256sum ) where import Crypto.Hash.SHA256 ( hash ) import Data.ByteString ( ByteString ) import Data.ByteString.Base16 ( encode ) import Data.ByteString.Char8 ( unpack ) sha256sum :: ByteString -> String sha256sum = unpack . encode . hash darcs-2.10.2/src/Darcs/Util/Crypt/SHA1.hs0000644000175000017500000002237312620122474021622 0ustar00guillaumeguillaume00000000000000-- Copyright (C) 2001, 2004 Ian Lynagh -- -- 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 : Darcs.Util.Crypt.SHA1 -- Copyright : 2001, 2004 Ian Lynagh -- License : GPL -- Maintainer : darcs-devel@darcs.net -- Stability : experimental -- Portability : portable module Darcs.Util.Crypt.SHA1 ( sha1PS, SHA1(..), showAsHex ) where import Darcs.Util.ByteString (unsafeWithInternals) import qualified Data.ByteString as B (ByteString, pack, length, concat) import Data.Binary ( Binary(..) ) 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 SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32 deriving (Eq,Ord) data XYZ = XYZ !Word32 !Word32 !Word32 instance Show SHA1 where show (SHA1 a b c d e) = concatMap showAsHex [a, b, c, d, e] 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) sha1PS:: B.ByteString -> SHA1 sha1PS s = abcde' 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) 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 :: SHA1 sha1Step3Init = SHA1 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 sha1Step4Main :: SHA1 -> Ptr Word32 -> Int -> IO SHA1 sha1Step4Main abcde _ 0 = return $! abcde sha1Step4Main (SHA1 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' = SHA1 (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) 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) darcs-2.10.2/src/umask.c0000644000175000017500000000115012620122474016772 0ustar00guillaumeguillaume00000000000000#include #include #include #include #include "umask.h" int set_umask(char *mask_string) { #ifndef WIN32 int rc; unsigned mask; char *end; mask = strtoul(mask_string, &end, 8); if(!end || *end != '\0') { errno = EINVAL; return -1; } rc = umask(mask); return rc; #else /* umask() has no useful meaning on win32. */ return 0; #endif /* #ifndef WIN32 ... else ... */ } int reset_umask(int old_mask) { #ifndef WIN32 umask(old_mask); return 1; #else return 0; #endif /* #ifndef WIN32 ... else ... */ } darcs-2.10.2/src/win32/0000755000175000017500000000000012620122474016453 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/win32/Darcs/0000755000175000017500000000000012620122474017507 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/win32/Darcs/Util/0000755000175000017500000000000012620122474020424 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/win32/Darcs/Util/CtrlC.hs0000644000175000017500000000113112620122474021763 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE ForeignFunctionInterface #-} module Darcs.Util.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) (setConsoleCtrlHandler fp 0) m darcs-2.10.2/src/win32/System/0000755000175000017500000000000012620122474017737 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/win32/System/Posix.hs0000644000175000017500000000056012620122474021376 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE ForeignFunctionInterface #-} module System.Posix ( sleep ) where import Foreign.C.Types ( CInt(..), CUInt(..), CULong(..) ) foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt sleep :: Integer -> IO CInt sleep n = c_SleepEx (1000 * fromIntegral n) 1 darcs-2.10.2/src/win32/System/Posix/0000755000175000017500000000000012620122474021041 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/win32/System/Posix/IO.hsc0000644000175000017500000000372412620122474022055 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE ForeignFunctionInterface #-} module System.Posix.IO where #if mingw32_HOST_OS && __GLASGOW_HASKELL__ >= 612 import Foreign.C.String( withCWString ) #else import Foreign.C.String ( withCString ) #endif 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.Types ( Fd(..), FileMode ) import System.IO ( Handle ) import Data.Bits ( (.|.) ) stdOutput :: Fd stdOutput = Fd 1 stdError :: Fd stdError = Fd 2 data OpenFileFlags = OpenFileFlags { append :: Bool, exclusive :: Bool, noctty :: Bool, nonBlock :: Bool, trunc :: Bool } -- Adapted from System.Posix.IO in ghc #include openFd :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd openFd name how maybe_mode off = do #if mingw32_HOST_OS withCWString name $ \s -> do #else withCString name $ \s -> do #endif fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w) return (Fd fd) where 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 open_mode = case how of ReadOnly -> (#const O_RDONLY) WriteOnly -> (#const O_WRONLY) ReadWrite -> (#const O_RDWR) 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 darcs-2.10.2/src/win32/System/Posix/Files.hsc0000644000175000017500000000257212620122474022610 0ustar00guillaumeguillaume00000000000000{-# 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 darcs-2.10.2/src/win32/sys/0000755000175000017500000000000012620122474017271 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/src/win32/sys/mman.h0000644000175000017500000000022612620122474020372 0ustar00guillaumeguillaume00000000000000 #include void *mmap(void *start, size_t length, int prot, int flags, int fd, off_t offset); int munmap(void *start, size_t length); darcs-2.10.2/src/win32/send_email.c0000644000175000017500000002140012620122474020714 0ustar00guillaumeguillaume00000000000000 #include #include #include #include "send_email.h" typedef struct sMapiFuns { LPMAPILOGON logon; LPMAPISENDMAIL sendmail; LPMAPIRESOLVENAME resolve; LPMAPIFREEBUFFER free_buf; LPMAPILOGOFF logoff; HMODULE dll; } MapiFuns; int load_dll(const char* name, MapiFuns* funs); void free_dll(MapiFuns* funs); void get_recipient(MapiFuns* funs, const char *name, ULONG recipClass, MapiRecipDesc *desc, lpMapiRecipDesc *desc_lookup); int send_email(const char *sendname, const char *recvname, const char *ccname, const char *subj, const char *body, const char *path) { FLAGS flags; MapiMessage msg; ULONG send_res; MapiRecipDesc orig; MapiRecipDesc recips[2]; MapiRecipDesc *orig_lookup, *recip_lookup, *cc_lookup; int num_recip = 1, return_code = -1; MapiFileDesc attachment; MapiFileTagExt file_type; const char *filename; char *attachment_path = 0; MapiFuns funs; if(load_dll("mapistub.dll", &funs) || load_dll("mapi32.dll", &funs)) { return_code=0; } else { fprintf(stderr, "Unable to load mapistub.dll or mapi32.dll: Bailing out. \n"); return_code=-1; } if(return_code==0) { LHANDLE session; /* logon seems to be necessary for outlook express, sometimes, and doesn't seem to hurt, otherwise. */ funs.logon(0, 0, 0, MAPI_LOGON_UI, 0, &session); orig_lookup = recip_lookup = cc_lookup = NULL; get_recipient(&funs, sendname, MAPI_ORIG, &orig, &orig_lookup); get_recipient(&funs, recvname, MAPI_TO, &recips[0], &recip_lookup); if (ccname && strlen(ccname) > 0) { get_recipient(&funs, ccname, MAPI_CC, &recips[1], &cc_lookup); num_recip++; } memset(&msg, 0, sizeof(msg)); msg.lpOriginator = &orig; msg.lpRecips = recips; msg.lpszMessageType = "text/plain"; msg.lpszNoteText = (LPSTR) body; msg.lpszSubject = (LPSTR)subj; msg.nRecipCount = num_recip; msg.flFlags = 0; if (path) { attachment_path = strdup(path); /* convert / to \ (thunderbird doesn't like /) */ char *p = attachment_path; while ((p = strchr(p, '/'))) *p = '\\'; /* find filename */ filename = strrchr(attachment_path, '\\'); if (filename == 0) filename = attachment_path; else filename++; memset(&attachment, 0, sizeof(attachment)); attachment.nPosition = -1; attachment.lpszPathName = (LPTSTR)attachment_path; attachment.lpszFileName = (LPTSTR)filename; attachment.lpFileType = &file_type; memset(&file_type, 0, sizeof(file_type)); file_type.lpTag = "text/plain"; file_type.cbTag = sizeof(file_type.lpTag); msg.nFileCount = 1; msg.lpFiles = &attachment; } flags = 0; send_res = funs.sendmail(0, 0, &msg, flags, 0); if (send_res == SUCCESS_SUCCESS) return_code = 0; else { return_code=-1; if(send_res==MAPI_E_USER_ABORT) fprintf(stderr, "MAPI error: User aborted.\n"); else if(send_res== MAPI_E_FAILURE) fprintf(stderr, "MAPI error: Generic error.\n"); else if(send_res== MAPI_E_LOGIN_FAILURE) fprintf(stderr, "MAPI error: Login failure.\n"); else if(send_res== MAPI_E_DISK_FULL) fprintf(stderr, "MAPI error: Disk full.\n"); else if(send_res== MAPI_E_INSUFFICIENT_MEMORY) fprintf(stderr, "MAPI error: Insufficient memory.\n"); else if(send_res== MAPI_E_ACCESS_DENIED) fprintf(stderr, "MAPI error: Access denied.\n"); else if(send_res== MAPI_E_TOO_MANY_SESSIONS) fprintf(stderr, "MAPI error: Too many sessions\n"); else if(send_res== MAPI_E_TOO_MANY_FILES) fprintf(stderr, "MAPI error: Too many files.\n"); else if(send_res== MAPI_E_TOO_MANY_RECIPIENTS) fprintf(stderr, "MAPI error: Too many recipients.\n"); else if(send_res== MAPI_E_ATTACHMENT_NOT_FOUND) fprintf(stderr, "MAPI error: Attachment not found.\n"); else if(send_res== MAPI_E_ATTACHMENT_OPEN_FAILURE) fprintf(stderr, "MAPI error: Failed to open attachment.\n"); else if(send_res== MAPI_E_ATTACHMENT_WRITE_FAILURE) fprintf(stderr, "MAPI error: Failed to write attachment.\n"); else if(send_res== MAPI_E_UNKNOWN_RECIPIENT) fprintf(stderr, "MAPI error: Unknown recipient\n"); else if(send_res== MAPI_E_BAD_RECIPTYPE) fprintf(stderr, "MAPI error: Bad type of recipent.\n"); else if(send_res== MAPI_E_NO_MESSAGES) fprintf(stderr, "MAPI error: No messages.\n"); else if(send_res== MAPI_E_INVALID_MESSAGE) fprintf(stderr, "MAPI error: Invalid message.\n"); 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_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"); else if(send_res== MAPI_E_INVALID_RECIPS) fprintf(stderr, "MAPI error: Invalid recipient(s)\n"); else if(send_res== MAPI_E_NOT_SUPPORTED) fprintf(stderr, "MAPI error: Operation not supported.\n"); else fprintf(stderr, "MAPISendMail returned %ld\n", send_res); } if (orig_lookup) funs.free_buf(orig_lookup); if (recip_lookup) funs.free_buf(recip_lookup); if (cc_lookup) funs.free_buf(cc_lookup); if (attachment_path) free(attachment_path); funs.logoff(session, 0, 0, 0); } free_dll(&funs); return return_code; } void get_recipient(MapiFuns* funs, const char *name, ULONG recipClass, MapiRecipDesc *desc, lpMapiRecipDesc *desc_lookup) { ULONG ret = funs->resolve(0, 0, (LPSTR) name, 0, 0, desc_lookup); if (ret == SUCCESS_SUCCESS) { memcpy(desc, *desc_lookup, sizeof(MapiRecipDesc)); } else { /* Default to something sensible if MAPIResolveName is not supported * by the mail client (thunderbird) */ memset(desc, 0, sizeof(MapiRecipDesc)); desc->lpszName = (LPSTR)name; desc->lpszAddress = (LPSTR)name; desc->lpEntryID = 0; desc->ulEIDSize = 0; } desc->ulRecipClass = recipClass; } int load_dll(const char* name, MapiFuns* funs) { funs->dll = 0; funs->dll = LoadLibrary(name); if(funs->dll!=NULL) { /* We try first loading by easy name, then by ordinal, and then by other names seen */ funs->logon = (LPMAPILOGON) GetProcAddress(funs->dll, "MAPILogon"); if(funs->logon==NULL) funs->logon = (LPMAPILOGON) GetProcAddress(funs->dll, (LPCSTR)209); funs->logoff = (LPMAPILOGOFF) GetProcAddress(funs->dll, "MAPILogOff"); if(funs->logoff==NULL) funs->logoff = (LPMAPILOGOFF) GetProcAddress(funs->dll, (LPCSTR)210); funs->resolve = (LPMAPIRESOLVENAME) GetProcAddress(funs->dll, "MAPIResolveName"); if(funs->resolve==NULL) funs->resolve = (LPMAPIRESOLVENAME) GetProcAddress(funs->dll, (LPCSTR)219); funs->free_buf = (LPMAPIFREEBUFFER) GetProcAddress(funs->dll, "MAPIFreeBuffer"); if(funs->free_buf==NULL) funs->free_buf = (LPMAPIFREEBUFFER) GetProcAddress(funs->dll, (LPCSTR)16); if(funs->free_buf==NULL) funs->free_buf = (LPMAPIFREEBUFFER) GetProcAddress(funs->dll, "MAPIFreeBuffer@4"); funs->sendmail = (LPMAPISENDMAIL) GetProcAddress(funs->dll, "MAPISendMail"); if(funs->sendmail==NULL) funs->sendmail = (LPMAPISENDMAIL) GetProcAddress(funs->dll, (LPCSTR)211); } return funs->dll!=NULL && funs->logon!=NULL && funs->logoff!=NULL && funs->resolve!=NULL && funs->free_buf!=NULL && funs->sendmail!=NULL; } void free_dll(MapiFuns* funs) { if(funs->dll!=NULL) FreeLibrary(funs->dll); funs->dll=NULL; } darcs-2.10.2/src/win32/send_email.h0000644000175000017500000000032712620122474020726 0ustar00guillaumeguillaume00000000000000 int send_email(const char *sendname, const char *recvname, const char *ccname, const char *subj, const char *body, const char *path); darcs-2.10.2/src/fpstring.h0000644000175000017500000000036012620122474017515 0ustar00guillaumeguillaume00000000000000#include #include 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); darcs-2.10.2/src/h_iconv.h0000644000175000017500000000036712620122474017315 0ustar00guillaumeguillaume00000000000000#include 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); darcs-2.10.2/src/maybe_relink.c0000644000175000017500000001165612620122474020327 0ustar00guillaumeguillaume00000000000000/* 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. */ #include #include #include #include #include #include #include #include #include #ifdef _WIN32 int maybe_relink(const char *src, const char *dst, int careful) { return 0; } #else /* Tries to link src to dst if both files exist and have the same contents. If careful is false only the file sizes are compared; if it is true, the full contents are compared. This code assumes that dst cannot change behind our back -- the caller is supposed to protect it by a lock. On the other hand, it does handle simultaneous access to src, but only if src is never modified in place. It should also be safe over NFS. Assumes that rename cannot fail mid-way on a single filesystem. Returns 1 on success, 0 if the files are already linked, -1 for an error in errno, -2 if the files cannot be linked because they are not the same, on different devices, or on a filesystem with no support for hard links, -3 if there was a race condition, -4 if something unexpected happened. */ int maybe_relink(char *src, char *dst, int careful) { #define RELINK_BUFFER_SIZE 8192 int len, rc, saved_errno; char *tempname; struct stat srcstat, dststat, tempstat; struct timeval now; rc = stat(src, &srcstat); if(rc < 0) { if(errno == ENOENT) return -2; else return -1; } rc = stat(dst, &dststat); if(rc < 0) return -1; if(!S_ISREG(srcstat.st_mode) || !S_ISREG(dststat.st_mode)) { return -4; } if(srcstat.st_dev != dststat.st_dev) { return -2; } if(srcstat.st_ino == dststat.st_ino) /* Files are already linked */ return 0; if(srcstat.st_size != dststat.st_size) return -2; /* link is atomic even on NFS, we will fail gracefully if the name is not unique. */ gettimeofday(&now, NULL); rc = strlen(dst) + 6; tempname = malloc(rc); if(tempname == NULL) return -1; len = snprintf(tempname, rc, "%s-%04x", dst, ((unsigned)(now.tv_usec ^ (now.tv_usec >> 16))) & 0xFFFF); if(len < 0 || len >= rc) { free(tempname); return -4; } rc = link(src, tempname); if(rc < 0) { /* We need to try to remove the link in case this was a problem with NFS over an unreliable transport. */ goto fail; } rc = stat(tempname, &tempstat); if(rc < 0) goto fail; /* Check for a race condition. The size and mtime checks are gratuitious, but they don't cost much, and might save your data if you're on a filesystem without i-nodes. */ if(tempstat.st_ino != srcstat.st_ino || tempstat.st_size != srcstat.st_size || tempstat.st_mtime != srcstat.st_mtime) { unlink(tempname); free(tempname); return -3; } if(careful) { int fd1, fd2, i, rc1, rc2; char buf1[RELINK_BUFFER_SIZE], buf2[RELINK_BUFFER_SIZE]; fd1 = open(tempname, O_RDONLY); if(fd1 < 0) goto fail; fd2 = open(dst, O_RDONLY); if(fd2 < 0) { close(fd1); goto fail; } i = 0; /* This comparison is approximate: it doesn't deal with short reads and EINTR. It's okay, as these cases are rare and if they happen, we're still safe. */ while(i < tempstat.st_size) { rc1 = read(fd1, buf1, RELINK_BUFFER_SIZE); if(rc1 < 0) { close(fd1); close(fd2); goto fail; } rc2 = read(fd2, buf2, RELINK_BUFFER_SIZE); if(rc2 < 0) { close(fd1); close(fd2); goto fail; } if(rc1 == 0 || rc1 != rc2 || memcmp(buf1, buf2, rc1) != 0) { close(fd1); close(fd2); unlink(tempname); free(tempname); return -2; } i += rc1; } close(fd1); close(fd2); } rc = rename(tempname, dst); if(rc < 0) goto fail; free(tempname); return 1; fail: saved_errno = errno; unlink(tempname); free(tempname); errno = saved_errno; if(errno == EPERM || errno == EOPNOTSUPP) return -2; return -1; #undef RELINK_BUFFER_SIZE } #endif darcs-2.10.2/src/system_encoding.c0000644000175000017500000000024012620122474021043 0ustar00guillaumeguillaume00000000000000#include "system_encoding.h" char* get_system_encoding() { #ifdef WIN32 return "utf8"; #else setlocale(LC_ALL,""); return nl_langinfo(CODESET); #endif } darcs-2.10.2/src/impossible.h0000644000175000017500000000046412620122474020034 0ustar00guillaumeguillaume00000000000000import qualified Darcs.Util.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) darcs-2.10.2/src/maybe_relink.h0000644000175000017500000000010112620122474020313 0ustar00guillaumeguillaume00000000000000int maybe_relink(const char *src, const char *dst, int careful); darcs-2.10.2/src/h_iconv.c0000644000175000017500000000116712620122474017307 0ustar00guillaumeguillaume00000000000000#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); } darcs-2.10.2/src/atomic_create.h0000644000175000017500000000053712620122474020466 0ustar00guillaumeguillaume00000000000000 #include #include #include int sloppy_atomic_create(const char *p); int atomic_create(const char *p); #ifdef _WIN32 int mkstemp(char *p); int pipe( int fildes[2] ); int renamefile(const char *from, const char *to); #endif int stdout_is_a_pipe(); int maybe_relink(const char *src, const char *dst, int careful); darcs-2.10.2/src/hscurl.c0000644000175000017500000002212312620122474017155 0ustar00guillaumeguillaume00000000000000#include "hscurl.h" #include #include #include #include #include #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* errorCode) { int error; *errorCode = -1; 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 = set_time_out(easy, errorCode); if (error != CURLE_OK ){ *errorCode = error; return curl_easy_strerror(error); } 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_CONNECTTIMEOUT, time_out); return error; } darcs-2.10.2/src/hscurl.h0000644000175000017500000000062712620122474017167 0ustar00guillaumeguillaume00000000000000#define DEFAULT_CONNECTION_TIMEOUT 30 const char *curl_request_url(const char *url, const char *filename, int cache_time, int *errorCode); 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(); darcs-2.10.2/src/fpstring.c0000644000175000017500000000330112620122474017506 0ustar00guillaumeguillaume00000000000000/* * 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 #include #include #ifdef _WIN32 #include #else #include #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; } darcs-2.10.2/src/atomic_create.c0000644000175000017500000001125212620122474020455 0ustar00guillaumeguillaume00000000000000/* 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. */ #include #include #include #include #include #include #include #include #include #ifdef _WIN32 #include #include #endif int sloppy_atomic_create(const char *p) { int fd; fd = open(p, O_WRONLY | O_EXCL | O_CREAT, 0666); if(fd < 0) return -1; close(fd); return 1; } #ifdef _WIN32 int atomic_create(const char *p) { return sloppy_atomic_create(p); } #else static int careful_atomic_create(const char *p) { /* O_EXCL is not available over NFSv2, and even under NFSv3, it is broken on many systems. The following protocol is provably safe assuming that: - creation of hard links is atomic; - stat hits the server rather than working from the cache. */ static char hostname[65] = {'\0'}; int fd, rc, saved_errno; #define FILENAME_SIZE (11 + 15 + 8 + 1) char *filename; char *lastslash; int dirlen; struct timeval now; struct stat sb; if(hostname[0] == '\0') { char *c; int i; /* POSIX guarantees 65 is enough. */ rc = gethostname(hostname, 65); if(rc < 0 || rc >= 65) { fprintf(stderr, "Error reading hostname when locking.\n"); strcpy(hostname, "kremvax"); } c = strchr(hostname, '.'); if(c != NULL) *c = '\0'; hostname[15] = '\0'; /* clean up a few possible nasty characters folks might put in their hostname */ for (i=0;i<15;i++) if (hostname[i] == ':' || hostname[i] == '/' || hostname[i] == '\\') hostname[i] = '-'; } lastslash = strrchr(p, '/'); dirlen = lastslash ? lastslash - p + 1 : 0; filename = malloc(dirlen + FILENAME_SIZE); if(filename == NULL) return -1; if(dirlen > 0) memcpy(filename, p, dirlen); filename[dirlen] = '\0'; gettimeofday(&now, NULL); rc = snprintf(filename + dirlen, FILENAME_SIZE, "darcs_lock_%s%04x%04x", hostname, ((unsigned)getpid()) & 0xFFFF, ((unsigned)(now.tv_usec ^ (now.tv_usec >> 16))) & 0xFFFF); if(rc < 0 || rc >= FILENAME_SIZE) { fprintf(stderr, "Error writing to lock filename (%d)\n", rc < 0 ? errno : 0); goto fail2; } fd = open(filename, O_WRONLY | O_EXCL | O_CREAT, 0666); if(fd < 0) goto fail2; /* Paranoia: should cause the client to flush its metadata cache. */ rc = close(fd); if(rc < 0) { fprintf(stderr, "Error closing file %s. (%d)\n", filename, errno); goto fail; } rc = link(filename, p); if(rc >= 0) goto success; 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); } else if(errno != EEXIST && errno != EIO) goto fail; /* The link may still have been successful if we're running over UDP and got EEXIST or EIO. Check the file's link count. */ rc = stat(filename, &sb); if(rc < 0) { goto fail; } if(sb.st_nlink != 2) { errno = EEXIST; goto fail; } success: unlink(filename); free(filename); return 1; fail: saved_errno = errno; unlink(filename); errno = saved_errno; fail2: free(filename); return -1; } int atomic_create(const char *p) { static int sloppy = -1; if(sloppy < 0) { char *s = getenv("DARCS_SLOPPY_LOCKS"); sloppy = (s != NULL); } if(sloppy) return sloppy_atomic_create(p); else return careful_atomic_create(p); } #endif darcs-2.10.2/src/system_encoding.h0000644000175000017500000000023612620122474021055 0ustar00guillaumeguillaume00000000000000#ifndef __SYSTEM_ENCODING__ #define __SYSTEM_ENCODING__ #ifndef WIN32 #include #include #endif char* get_system_encoding(); #endif darcs-2.10.2/src/umask.h0000644000175000017500000000010112620122474016772 0ustar00guillaumeguillaume00000000000000int set_umask(char *mask_string); int reset_umask(int old_mask); darcs-2.10.2/darcs.cabal0000644000175000017500000006701312620122474017011 0ustar00guillaumeguillaume00000000000000Name: darcs version: 2.10.2 License: GPL License-file: COPYING Author: David Roundy , Maintainer: 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.10 extra-source-files: -- C headers src/*.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, 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/renameHelper.hs 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 -- hashed-storage hashed-storage/LICENSE hashed-storage/testdata.zip GNUmakefile source-repository head type: darcs location: http://darcs.net/ flag curl description: Use libcurl for HTTP support. -- in future this could extend to any other external libraries, -- e.g. libiconv flag pkgconfig description: Use pkgconfig to configure libcurl default: False flag http description: Use the pure Haskell HTTP package for HTTP support. 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 executable description: Build darcs executable default: True flag hpc default: False flag rts default: False -- 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 manual: True description: Build with warnings-as-errors -- To allow building with containers < 0.5, we keep a local copy of this -- module. flag use-local-data-map-strict default: False description: Support containers < 0.5, by using a local copy of the Data.Map.Strict module from containers 0.5. -- 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 flag hashed-storage-diff default: False -- with time>=1.5 (needed with GHC 7.10) we get defaultTimeLocale from time:Data.Time -- with time<1.5 we get defaultTimeLocale from old-locale:System.Locale flag use-time-1point5 default: False flag network-uri description: Get Network.URI from the network-uri package default: True -- ---------------------------------------------------------------------- -- darcs library -- ---------------------------------------------------------------------- Library build-tools: ghc >= 7.4 && < 7.12 default-language: Haskell2010 hs-source-dirs: src include-dirs: src exposed-modules: Darcs.Patch Darcs.Patch.Annotate Darcs.Patch.Apply Darcs.Patch.ApplyMonad Darcs.Patch.ApplyPatches Darcs.Patch.Bracketed Darcs.Patch.Bracketed.Instances Darcs.Patch.Bundle Darcs.Patch.Choices Darcs.Patch.Commute Darcs.Patch.CommuteFn Darcs.Patch.Conflict Darcs.Patch.ConflictMarking Darcs.Patch.Debug Darcs.Patch.Depends Darcs.Patch.Dummy Darcs.Patch.Effect Darcs.Patch.FileHunk Darcs.Patch.Index.Monad Darcs.Patch.Index.Types Darcs.Patch.Format Darcs.Patch.Info Darcs.Patch.Inspect Darcs.Patch.Invert Darcs.Patch.Match Darcs.Patch.Matchable Darcs.Patch.MaybeInternal Darcs.Patch.Merge Darcs.Patch.MonadProgress 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.Progress Darcs.Patch.Read Darcs.Patch.Rebase Darcs.Patch.Rebase.Fixup Darcs.Patch.Rebase.Name Darcs.Patch.Rebase.NameHack Darcs.Patch.Rebase.Recontext Darcs.Patch.Rebase.Viewing 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.Type 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.Patch.Witnesses.Eq Darcs.Patch.Witnesses.Ordered Darcs.Patch.Witnesses.Sealed Darcs.Patch.Witnesses.Show Darcs.Patch.Witnesses.Unsafe Darcs.Patch.Witnesses.WZipper Darcs.Repository Darcs.Repository.ApplyPatches Darcs.Repository.Cache Darcs.Repository.PatchIndex Darcs.Repository.Compat Darcs.Repository.Diff Darcs.Repository.External Darcs.Repository.Flags Darcs.Repository.Format Darcs.Repository.HashedIO Darcs.Repository.HashedRepo Darcs.Repository.Internal Darcs.Repository.Job Darcs.Repository.Lock Darcs.Repository.LowLevel Darcs.Repository.Merge Darcs.Repository.InternalTypes Darcs.Repository.Match Darcs.Repository.Motd Darcs.Repository.Old Darcs.Repository.Prefs Darcs.Repository.Rebase Darcs.Repository.Repair Darcs.Repository.Read Darcs.Repository.Resolution Darcs.Repository.Ssh Darcs.Repository.State Darcs.Repository.Test Darcs.Repository.Util Darcs.UI.ApplyPatches Darcs.UI.Commands Darcs.UI.Commands.Add Darcs.UI.Commands.Amend Darcs.UI.Commands.Annotate Darcs.UI.Commands.Apply Darcs.UI.CommandsAux Darcs.UI.Commands.Clone Darcs.UI.Commands.Convert 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.ShowBug Darcs.UI.Commands.ShowContents 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.TransferMode Darcs.UI.Commands.Util Darcs.UI.Commands.Util.Tree Darcs.UI.Commands.Unrecord Darcs.UI.Commands.Unrevert Darcs.UI.Commands.WhatsNew Darcs.UI.Email Darcs.UI.External Darcs.UI.Defaults 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.PrintPatch Darcs.UI.RemoteApply Darcs.UI.RunCommand Darcs.UI.SelectChanges Darcs.UI.TheCommands Darcs.UI.Usage Darcs.UI.Message.Send Darcs.Util.AtExit Darcs.Util.Bug Darcs.Util.ByteString Darcs.Util.CommandLine Darcs.Util.Crypt.SHA1 Darcs.Util.Crypt.SHA256 Darcs.Util.DateMatcher Darcs.Util.DateTime Darcs.Util.Diff Darcs.Util.Diff.Myers Darcs.Util.Diff.Patience Darcs.Util.Download Darcs.Util.Download.Request Darcs.Util.Download.HTTP Darcs.Util.English Darcs.Util.Environment Darcs.Util.Exception Darcs.Util.Exec Darcs.Util.File Darcs.Util.Global Darcs.Util.IsoDate Darcs.Util.Path Darcs.Util.Printer Darcs.Util.Printer.Color Darcs.Util.Progress Darcs.Util.Prompt Darcs.Util.Ratified Darcs.Util.Show Darcs.Util.SignalHandler Darcs.Util.Ssh Darcs.Util.Text Darcs.Util.URL Darcs.Util.Workaround other-modules: Version Darcs.Util.Download.Curl Darcs.Util.Encoding c-sources: src/atomic_create.c src/fpstring.c src/maybe_relink.c src/umask.c src/system_encoding.c 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: unix-compat >= 0.1.2 && < 0.5, Win32 >= 2.2 && < 2.4 else other-modules: Darcs.Util.Encoding.IConv c-sources: src/h_iconv.c if flag(use-local-data-map-strict) build-depends: containers >= 0.4 && < 0.5, deepseq >= 1.3 && < 1.4 hs-source-dirs: containers-0.5.2.1 other-modules: Darcs.Data.Map.Base Darcs.Data.Map.Strict Darcs.Data.Set.Base Darcs.Data.StrictPair cpp-options: -DUSE_LOCAL_DATA_MAP_STRICT else build-depends: containers >= 0.5 && < 0.6 if os(solaris) cc-options: -DHAVE_SIGINFO_H build-depends: base >= 4.5 && < 4.9 build-depends: binary >= 0.5 && < 0.8, regex-compat-tdfa >= 0.95.1 && < 0.96, regex-applicative >= 0.2 && < 0.4, mtl >= 2.1 && < 2.3, transformers >= 0.3 && < 0.4.0.0 || > 0.4.0.0 && < 0.5, -- for the Control.Monad.Error -> Control.Monad.Except -- transition transformers-compat >= 0.4 && < 0.5, parsec >= 3.1 && < 3.2, html == 1.0.*, filepath >= 1.2.0.0 && < 1.5.0.0, haskeline >= 0.6.3 && < 0.8, cryptohash >= 0.4 && < 0.12, base16-bytestring >= 0.1 && < 0.2, utf8-string >= 0.3.6 && < 1.1, vector >= 0.7 && < 0.11, tar == 0.4.*, data-ordlist == 0.4.*, attoparsec >= 0.11 && < 0.14, zip-archive >= 0.2.3 && < 0.3 if !os(windows) build-depends: unix >= 2.5 && < 2.8 build-depends: bytestring >= 0.9.0 && < 0.11, old-time >= 1.1 && < 1.2, directory >= 1.1.0.2 && < 1.3.0.0, process >= 1.1.0.1 && < 1.3.0.0, array >= 0.4 && < 0.6, random >= 1.0 && < 1.2, hashable >= 1.0 && < 1.3 -- release notes of GHC 7.10.2 recommends to use text >= 1.2.1.3: -- https://mail.haskell.org/pipermail/haskell/2015-July/024641.html if impl(ghc>=7.10) build-depends: text >= 1.2.1.3 && < 1.3 else build-depends: text >= 0.11.3.1 && < 1.3 if flag(use-time-1point5) build-depends: time >= 1.5 && < 1.6 else build-depends: time >= 1.4 && < 1.5, old-locale >= 1.0 && < 1.1 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(rts) ghc-options: -rtsopts if flag(curl) cpp-options: -DHAVE_CURL c-sources: src/hscurl.c cc-options: -DHAVE_CURL if flag(pkgconfig) pkgconfig-depends: libcurl else extra-libraries: curl includes: curl/curl.h if flag(http) if flag(network-uri) build-depends: network-uri == 2.6.*, network == 2.6.* else build-depends: network >= 2.3 && < 2.6 build-depends: HTTP >= 4000.2.3 && < 4000.3 cpp-options: -DHAVE_HTTP x-have-http: if (!flag(curl) && !flag(http)) buildable: False build-depends: mmap >= 0.5 && < 0.6 build-depends: zlib >= 0.5.3.0 && < 0.7.0.0 -- The terminfo package cannot be built on Windows. if flag(terminfo) && !os(windows) build-depends: terminfo >= 0.3 && < 0.5 cpp-options: -DHAVE_TERMINFO -- if true to work around cabal bug with flag ordering if true default-extensions: BangPatterns PatternGuards GADTs TypeOperators FlexibleContexts FlexibleInstances ScopedTypeVariables KindSignatures RankNTypes TypeFamilies 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 -- once the minimum version of ghc is >= 7.6 we can remove the hiding -- clauses and this flag ghc-options: -fno-warn-dodgy-imports -- hashed-storage inclusion hs-source-dirs: hashed-storage exposed-modules: Storage.Hashed Storage.Hashed.AnchoredPath Storage.Hashed.Index Storage.Hashed.Monad Storage.Hashed.Tree Storage.Hashed.Hash Storage.Hashed.Packed Storage.Hashed.Plain Storage.Hashed.Darcs if flag(hashed-storage-diff) exposed-modules: Storage.Hashed.Diff build-depends: lcs other-modules: Bundled.Posix Storage.Hashed.Utils build-depends: sandi >= 0.2 && < 0.4, unix-compat >= 0.1.2 && < 0.5, cryptohash >= 0.4 && < 0.12 if os(windows) cpp-options: -DWIN32 build-depends: Win32 >= 2.2 && < 2.4 -- end of hashed-storage inclusion -- ---------------------------------------------------------------------- -- darcs itself -- ---------------------------------------------------------------------- Executable darcs if !flag(executable) buildable: False else buildable: True build-tools: ghc >= 7.4 && < 7.12 default-language: Haskell2010 main-is: darcs.hs hs-source-dirs: darcs 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 if flag(rts) ghc-options: -rtsopts cc-options: -D_REENTRANT build-depends: base >= 4.5 && < 4.9 build-depends: darcs, filepath >= 1.2.0.0 && < 1.5.0.0, regex-compat-tdfa >= 0.95.1 && < 0.96 -- if true to work around cabal bug with flag ordering if true default-extensions: BangPatterns PatternGuards GADTs TypeOperators FlexibleContexts FlexibleInstances ScopedTypeVariables KindSignatures RankNTypes TypeFamilies NoMonoLocalBinds -- ---------------------------------------------------------------------- -- unit test driver -- ---------------------------------------------------------------------- test-suite darcs-test buildable: True build-tools: ghc >= 7.4 && < 7.12 type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: test.hs hs-source-dirs: harness build-depends: base >= 4.5 && < 4.9 if os(windows) cpp-options: -DWIN32 build-depends: darcs, array >= 0.4 && < 0.6, bytestring >= 0.9.0 && < 0.11, cmdargs >= 0.10 && < 0.11, containers >= 0.1 && < 0.6, filepath >= 1.2.0.0 && < 1.5.0.0, html == 1.0.*, mtl >= 2.1 && < 2.3, parsec >= 3.1 && < 3.2, regex-compat-tdfa >= 0.95.1 && < 0.96, shelly >= 1.6.2 && < 1.7, split >= 0.1.4.1 && < 0.3, directory >= 1.1.0.2 && < 1.3.0.0, FindBin >= 0.0 && < 0.1, QuickCheck >= 2.3 && < 2.9, HUnit >= 1.0 && < 1.3, test-framework >= 0.4.0 && < 0.9, test-framework-hunit >= 0.2.2 && < 0.4, test-framework-quickcheck2 >= 0.3 && < 0.4 -- release notes of GHC 7.10.2 recommends to use text >= 1.2.1.3: -- https://mail.haskell.org/pipermail/haskell/2015-July/024641.html if impl(ghc>=7.10) build-depends: text >= 1.2.1.3 && < 1.3 else build-depends: text >= 0.11.3.1 && < 1.3 -- list all unit test modules not exported by libdarcs; otherwise Cabal won't -- include them in the tarball other-modules: Darcs.Test.Email 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.Rebase 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(hpc) ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs-test if flag(rts) ghc-options: -rtsopts cc-options: -D_REENTRANT -- if true to work around cabal bug with flag ordering if true default-extensions: BangPatterns PatternGuards GADTs TypeOperators FlexibleContexts FlexibleInstances ScopedTypeVariables KindSignatures RankNTypes TypeFamilies NoMonoLocalBinds -- hashed-storage inclusion test-suite hashed-storage-test buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: hashed-storage ghc-options: -Wall -O2 -fwarn-tabs ghc-prof-options: -prof -auto-all -O2 if flag(hpc) ghc-prof-options: -fhpc if flag(warn-as-error) ghc-options: -Werror 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 -- once the minimum version of ghc is >= 7.6 we can remove the hiding -- clauses and this flag ghc-options: -fno-warn-dodgy-imports main-is: test.hs other-modules: Bundled.Posix Storage.Hashed.Test if os(windows) cpp-options: -DWIN32 build-depends: Win32 >= 2.2 && < 2.4 -- hashed-storage inclusion: duplicated these from the library - -- probably needed because of the higher cabal-version in darcs.cabal -- not using version constraints here to save on maintaining duplicates, -- since these packages are all constrained elsewhere in the cabal file. build-depends: base, containers, mtl, directory, filepath, bytestring, sandi, cryptohash, binary, zlib, mmap, unix-compat build-depends: test-framework, test-framework-hunit, test-framework-quickcheck2, QuickCheck, HUnit, process, zip-archive -- end of hashed-storage inclusion darcs-2.10.2/README0000644000175000017500000000162412620122474015605 0ustar00guillaumeguillaume00000000000000Darcs ===== [Darcs](http://darcs.net) is a distributed version control system written in Haskell. Getting started =============== Compiling --------- Build instructions are available at . Using ----- To clone a repository from HTTP and send patches by mail: $ darcs clone --lazy http://darcs.net $ (edit files) $ darcs add (new files) $ darcs record -m "my changes" $ darcs send To clone from SSH and push patches: $ darcs clone user@hub.darcs.net:user/repo $ (edit files) $ darcs add (new files) $ darcs record -m "my changes" $ darcs push To create a project and start working: $ darcs init (project) $ cd (project) $ (add files) $ darcs add (files) $ darcs record -m "initial version" See for more information. Reporting bugs ============== Please send bug reports to . darcs-2.10.2/Setup.lhs0000644000175000017500000003665112620122474016545 0ustar00guillaumeguillaume00000000000000\begin{code} {-# LANGUAGE TemplateHaskell #-} -- 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, testSuites), Executable(buildInfo, exeName) , BuildInfo(customFieldsBI), emptyBuildInfo , TestSuite(testBuildInfo) , FlagName(FlagName) , updatePackageDescription , cppOptions, ccOptions, ldOptions , library, libBuildInfo, otherModules , extraLibs, extraLibDirs, includeDirs ) import Distribution.Package ( packageVersion, packageName, PackageName(..), Package ) import Distribution.Version ( 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 qualified Distribution.Simple.Setup as DSS -- to get replVerbosity in Cabal > 1.18 import Distribution.Simple.BuildPaths ( autogenModulesDir, exeExtension ) import Distribution.System ( OS(Windows), buildOS ) import Distribution.Simple.Utils (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout, rewriteFile, withTempFile, cabalVersion) import Distribution.Verbosity ( Verbosity ) import Distribution.Text ( display ) import Control.Monad ( zipWithM_, when, unless, filterM ) import Control.Exception ( bracket, handle, IOException ) import Language.Haskell.TH ( mkName, newName, recUpdE, varE, appE, lamE, varP ) 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 ) import System.Process( rawSystem ) import System.FilePath ( (), (<.>), splitDirectories, isAbsolute ) import Foreign.Marshal.Utils ( with ) import Foreign.Storable ( peek ) import Foreign.Ptr ( castPtr ) import Data.Monoid ( mappend ) import Data.Word ( Word8, Word32 ) import qualified Control.Exception as Exception catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException)) {- Template Haskell hackery for replHook while we want to support Cabal < 1.18 -} replVerbosity = $(if cabalVersion >= Version [1,18,0] [] then varE (mkName "DSS.replVerbosity") else [| error "This shouldn't be called" |] ) replHookBody replHookSel = \pkg lbi hooks flags args -> let verb = fromFlag $ replVerbosity flags in commonBuildHook replHookSel pkg lbi hooks verb >>= (\f -> f flags args) addReplHook = $(if cabalVersion >= Version [1,18,0] [] then do hooks <- newName "hooks" let replHook = mkName "replHook" app <- appE (varE (mkName "replHookBody")) (varE replHook) lamE [varP hooks] (recUpdE (varE hooks) [return (replHook, app)]) else [| \hooks -> hooks |] ) {- End of Template Haskell hackery -} main :: IO () main = defaultMainWithHooks $ addReplHook $ 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) , {- -- this is the actual replHook code we want 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, 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) : [arg | (arg, True) <- -- include fst iff snd. [("-DHAVE_HTTP", "x-have-http" `elem` customFields), -- We have MAPI iff building on/for Windows. ("-DHAVE_MAPI", buildOS == Windows), ("-DLITTLEENDIAN", littleEndian), ("-DBIGENDIAN", not littleEndian)]] bi = emptyBuildInfo { cppOptions = args, ccOptions = args } hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg]) pkg' = updatePackageDescription hbi pkg -- updatePackageDescription doesn't handle test suites so we -- need to do this manually updateTestSuiteBI bi testSuite = testSuite { testBuildInfo = bi `mappend` testBuildInfo testSuite } pkg'' = pkg' { testSuites = map (updateTestSuiteBI bi) (testSuites 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) -- --------------------------------------------------------------------- -- man page -- --------------------------------------------------------------------- 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")] -- --------------------------------------------------------------------- -- 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 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" ["log", "-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" ["log", "-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 " , "int main(void) {" , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");" , " return 0;" , "}" ] \end{code} darcs-2.10.2/containers-0.5.2.1/0000755000175000017500000000000012620122474017666 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/containers-0.5.2.1/Darcs/0000755000175000017500000000000012620122474020722 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/containers-0.5.2.1/Darcs/Data/0000755000175000017500000000000012620122474021573 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/containers-0.5.2.1/Darcs/Data/StrictPair.hs0000644000175000017500000000055012620122474024213 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif module Darcs.Data.StrictPair (StrictPair(..), toPair) where -- | Same as regular Haskell pairs, but (x :*: _|_) = (_|_ :*: y) = -- _|_ data StrictPair a b = !a :*: !b toPair :: StrictPair a b -> (a, b) toPair (x :*: y) = (x, y) {-# INLINE toPair #-}darcs-2.10.2/containers-0.5.2.1/Darcs/Data/Map/0000755000175000017500000000000012620122474022310 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/containers-0.5.2.1/Darcs/Data/Map/Base.hs0000644000175000017500000032336012620122474023525 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Map.Base -- Copyright : (c) Daan Leijen 2002 -- (c) Andriy Palamarchuk 2008 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- An efficient implementation of maps from keys to values (dictionaries). -- -- Since many function names (but not the type name) clash with -- "Prelude" names, this module is usually imported @qualified@, e.g. -- -- > import Data.Map (Map) -- > import qualified Data.Map as Map -- -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -- -- * Stephen Adams, \"/Efficient sets: a balancing act/\", -- Journal of Functional Programming 3(4):553-562, October 1993, -- . -- -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973. -- -- Note that the implementation is /left-biased/ -- the elements of a -- first argument are always preferred to the second, for example in -- 'union' or 'insert'. -- -- Operation comments contain the operation time complexity in -- the Big-O notation . ----------------------------------------------------------------------------- -- [Note: Using INLINABLE] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- It is crucial to the performance that the functions specialize on the Ord -- type when possible. GHC 7.0 and higher does this by itself when it sees th -- unfolding of a function -- that is why all public functions are marked -- INLINABLE (that exposes the unfolding). -- [Note: Using INLINE] -- ~~~~~~~~~~~~~~~~~~~~ -- For other compilers and GHC pre 7.0, we mark some of the functions INLINE. -- We mark the functions that just navigate down the tree (lookup, insert, -- delete and similar). That navigation code gets inlined and thus specialized -- when possible. There is a price to pay -- code growth. The code INLINED is -- therefore only the tree navigation, all the real work (rebalancing) is not -- INLINED by using a NOINLINE. -- -- All methods marked INLINE have to be nonrecursive -- a 'go' function doing -- the real work is provided. -- [Note: Type of local 'go' function] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- If the local 'go' function uses an Ord class, it sometimes heap-allocates -- the Ord dictionary when the 'go' function does not have explicit type. -- In that case we give 'go' explicit type. But this slightly decrease -- performance, as the resulting 'go' function can float out to top level. -- [Note: Local 'go' functions and capturing] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- As opposed to IntMap, when 'go' function captures an argument, increased -- heap-allocation can occur: sometimes in a polymorphic function, the 'go' -- floats out of its enclosing function and then it heap-allocates the -- dictionary and the argument. Maybe it floats out too late and strictness -- analyzer cannot see that these could be passed on stack. -- -- For example, change 'member' so that its local 'go' function is not passing -- argument k and then look at the resulting code for hedgeInt. -- [Note: Order of constructors] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The order of constructors of Map matters when considering performance. -- Currently in GHC 7.0, when type has 2 constructors, a forward conditional -- jump is made when successfully matching second constructor. Successful match -- of first constructor results in the forward jump not taken. -- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip -- improves the benchmark by up to 10% on x86. module Darcs.Data.Map.Base ( -- * Map type Map(..) -- instance Eq,Show,Read -- * Operators , (!), (\\) -- * Query , null , size , member , notMember , lookup , findWithDefault , lookupLT , lookupGT , lookupLE , lookupGE -- * Construction , empty , singleton -- ** Insertion , insert , insertWith , insertWithKey , insertLookupWithKey -- ** Delete\/Update , delete , adjust , adjustWithKey , update , updateWithKey , updateLookupWithKey , alter -- * Combine -- ** Union , union , unionWith , unionWithKey , unions , unionsWith -- ** Difference , difference , differenceWith , differenceWithKey -- ** Intersection , intersection , intersectionWith , intersectionWithKey -- ** Universal combining function , mergeWithKey -- * Traversal -- ** Map , map , mapWithKey , traverseWithKey , mapAccum , mapAccumWithKey , mapAccumRWithKey , mapKeys , mapKeysWith , mapKeysMonotonic -- * Folds , foldr , foldl , foldrWithKey , foldlWithKey -- ** Strict folds , foldr' , foldl' , foldrWithKey' , foldlWithKey' -- * Conversion , elems , keys , assocs , keysSet , fromSet -- ** Lists , toList , fromList , fromListWith , fromListWithKey -- ** Ordered lists , toAscList , toDescList , fromAscList , fromAscListWith , fromAscListWithKey , fromDistinctAscList -- * Filter , filter , filterWithKey , partition , partitionWithKey , mapMaybe , mapMaybeWithKey , mapEither , mapEitherWithKey , split , splitLookup -- * Submap , isSubmapOf, isSubmapOfBy , isProperSubmapOf, isProperSubmapOfBy -- * Indexed , lookupIndex , findIndex , elemAt , updateAt , deleteAt -- * Min\/Max , findMin , findMax , deleteMin , deleteMax , deleteFindMin , deleteFindMax , updateMin , updateMax , updateMinWithKey , updateMaxWithKey , minView , maxView , minViewWithKey , maxViewWithKey -- * Debugging , showTree , showTreeWith , valid -- Used by the strict version , bin , balance , balanced , balanceL , balanceR , delta , join , insertMax , merge , glue , trim , trimLookupLo , foldlStrict , MaybeS(..) , filterGt , filterLt ) where import Control.Applicative (Applicative(..), (<$>)) import Control.DeepSeq (NFData(rnf)) import Data.Bits (shiftL, shiftR) import qualified Data.Foldable as Foldable import Data.Monoid (Monoid(..)) import Darcs.Data.StrictPair import Data.Traversable (Traversable(traverse)) import Data.Typeable import Prelude hiding (lookup, map, filter, foldr, foldl, null) import qualified Darcs.Data.Set.Base as Set #if __GLASGOW_HASKELL__ import GHC.Exts ( build ) import Text.Read import Data.Data #endif -- Use macros to define strictness of functions. -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter. -- We do not use BangPatterns, because they are not in any standard and we -- want the compilers to be compiled by as many compilers as possible. #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined #define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined #define STRICT_1_OF_4(fn) fn arg _ _ _ | arg `seq` False = undefined #define STRICT_2_OF_4(fn) fn _ arg _ _ | arg `seq` False = undefined {-------------------------------------------------------------------- Operators --------------------------------------------------------------------} infixl 9 !,\\ -- -- | /O(log n)/. Find the value at a key. -- Calls 'error' when the element can not be found. -- -- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map -- > fromList [(5,'a'), (3,'b')] ! 5 == 'a' (!) :: Ord k => Map k a -> k -> a (!) m k = find k m #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE (!) #-} #endif -- | Same as 'difference'. (\\) :: Ord k => Map k a -> Map k b -> Map k a m1 \\ m2 = difference m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE (\\) #-} #endif {-------------------------------------------------------------------- Size balanced trees. --------------------------------------------------------------------} -- | A Map from keys @k@ to values @a@. -- See Note: Order of constructors data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) | Tip type Size = Int instance (Ord k) => Monoid (Map k v) where mempty = empty mappend = union mconcat = unions #if __GLASGOW_HASKELL__ {-------------------------------------------------------------------- A Data instance --------------------------------------------------------------------} -- This instance preserves data abstraction at the cost of inefficiency. -- We provide limited reflection services for the sake of data abstraction. instance (Data k, Data a, Ord k) => Data (Map k a) where gfoldl f z m = z fromList `f` toList m toConstr _ = fromListConstr gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = mapDataType dataCast2 f = gcast2 f fromListConstr :: Constr fromListConstr = mkConstr mapDataType "fromList" [] Prefix mapDataType :: DataType mapDataType = mkDataType "Data.Map.Base.Map" [fromListConstr] #endif {-------------------------------------------------------------------- Query --------------------------------------------------------------------} -- | /O(1)/. Is the map empty? -- -- > Data.Map.null (empty) == True -- > Data.Map.null (singleton 1 'a') == False null :: Map k a -> Bool null Tip = True null (Bin {}) = False {-# INLINE null #-} -- | /O(1)/. The number of elements in the map. -- -- > size empty == 0 -- > size (singleton 1 'a') == 1 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 size :: Map k a -> Int size Tip = 0 size (Bin sz _ _ _ _) = sz {-# INLINE size #-} -- | /O(log n)/. Lookup the value at a key in the map. -- -- The function will return the corresponding value as @('Just' value)@, -- or 'Nothing' if the key isn't in the map. -- -- An example of using @lookup@: -- -- > import Prelude hiding (lookup) -- > import Data.Map -- > -- > employeeDept = fromList([("John","Sales"), ("Bob","IT")]) -- > deptCountry = fromList([("IT","USA"), ("Sales","France")]) -- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")]) -- > -- > employeeCurrency :: String -> Maybe String -- > employeeCurrency name = do -- > dept <- lookup name employeeDept -- > country <- lookup dept deptCountry -- > lookup country countryCurrency -- > -- > main = do -- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John")) -- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete")) -- -- The output of this program: -- -- > John's currency: Just "Euro" -- > Pete's currency: Nothing lookup :: Ord k => k -> Map k a -> Maybe a lookup = go where STRICT_1_OF_2(go) go _ Tip = Nothing go k (Bin _ kx x l r) = case compare k kx of LT -> go k l GT -> go k r EQ -> Just x #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookup #-} #else {-# INLINE lookup #-} #endif -- | /O(log n)/. Is the key a member of the map? See also 'notMember'. -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True -- > member 1 (fromList [(5,'a'), (3,'b')]) == False member :: Ord k => k -> Map k a -> Bool member = go where STRICT_1_OF_2(go) go _ Tip = False go k (Bin _ kx _ l r) = case compare k kx of LT -> go k l GT -> go k r EQ -> True #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE member #-} #else {-# INLINE member #-} #endif -- | /O(log n)/. Is the key not a member of the map? See also 'member'. -- -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True notMember :: Ord k => k -> Map k a -> Bool notMember k m = not $ member k m #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE notMember #-} #else {-# INLINE notMember #-} #endif -- | /O(log n)/. Find the value at a key. -- Calls 'error' when the element can not be found. find :: Ord k => k -> Map k a -> a find = go where STRICT_1_OF_2(go) go _ Tip = error "Map.!: given key is not an element in the map" go k (Bin _ kx x l r) = case compare k kx of LT -> go k l GT -> go k r EQ -> x #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE find #-} #else {-# INLINE find #-} #endif -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns -- the value at key @k@ or returns default value @def@ -- when the key is not in the map. -- -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' findWithDefault :: Ord k => a -> k -> Map k a -> a findWithDefault = go where STRICT_2_OF_3(go) go def _ Tip = def go def k (Bin _ kx x l r) = case compare k kx of LT -> go def k l GT -> go def k r EQ -> x #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE findWithDefault #-} #else {-# INLINE findWithDefault #-} #endif -- | /O(log n)/. Find largest key smaller than the given one and return the -- corresponding (key, value) pair. -- -- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing -- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') lookupLT :: Ord k => k -> Map k v -> Maybe (k, v) lookupLT = goNothing where STRICT_1_OF_2(goNothing) goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l | otherwise = goJust k kx x r STRICT_1_OF_4(goJust) goJust _ kx' x' Tip = Just (kx', x') goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l | otherwise = goJust k kx x r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupLT #-} #else {-# INLINE lookupLT #-} #endif -- | /O(log n)/. Find smallest key greater than the given one and return the -- corresponding (key, value) pair. -- -- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') -- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing lookupGT :: Ord k => k -> Map k v -> Maybe (k, v) lookupGT = goNothing where STRICT_1_OF_2(goNothing) goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l | otherwise = goNothing k r STRICT_1_OF_4(goJust) goJust _ kx' x' Tip = Just (kx', x') goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l | otherwise = goJust k kx' x' r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupGT #-} #else {-# INLINE lookupGT #-} #endif -- | /O(log n)/. Find largest key smaller or equal to the given one and return -- the corresponding (key, value) pair. -- -- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing -- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') -- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') lookupLE :: Ord k => k -> Map k v -> Maybe (k, v) lookupLE = goNothing where STRICT_1_OF_2(goNothing) goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l EQ -> Just (kx, x) GT -> goJust k kx x r STRICT_1_OF_4(goJust) goJust _ kx' x' Tip = Just (kx', x') goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l EQ -> Just (kx, x) GT -> goJust k kx x r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupLE #-} #else {-# INLINE lookupLE #-} #endif -- | /O(log n)/. Find smallest key greater or equal to the given one and return -- the corresponding (key, value) pair. -- -- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') -- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') -- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing lookupGE :: Ord k => k -> Map k v -> Maybe (k, v) lookupGE = goNothing where STRICT_1_OF_2(goNothing) goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l EQ -> Just (kx, x) GT -> goNothing k r STRICT_1_OF_4(goJust) goJust _ kx' x' Tip = Just (kx', x') goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l EQ -> Just (kx, x) GT -> goJust k kx' x' r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupGE #-} #else {-# INLINE lookupGE #-} #endif {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} -- | /O(1)/. The empty map. -- -- > empty == fromList [] -- > size empty == 0 empty :: Map k a empty = Tip {-# INLINE empty #-} -- | /O(1)/. A map with a single element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 singleton :: k -> a -> Map k a singleton k x = Bin 1 k x Tip Tip {-# INLINE singleton #-} {-------------------------------------------------------------------- Insertion --------------------------------------------------------------------} -- | /O(log n)/. Insert a new key and value in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value. 'insert' is equivalent to -- @'insertWith' 'const'@. -- -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' -- See Note: Type of local 'go' function insert :: Ord k => k -> a -> Map k a -> Map k a insert = go where go :: Ord k => k -> a -> Map k a -> Map k a STRICT_1_OF_3(go) go kx x Tip = singleton kx x go kx x (Bin sz ky y l r) = case compare kx ky of LT -> balanceL ky y (go kx x l) r GT -> balanceR ky y l (go kx x r) EQ -> Bin sz kx x l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #else {-# INLINE insert #-} #endif -- Insert a new key and value in the map if it is not already present. -- Used by `union`. -- See Note: Type of local 'go' function insertR :: Ord k => k -> a -> Map k a -> Map k a insertR = go where go :: Ord k => k -> a -> Map k a -> Map k a STRICT_1_OF_3(go) go kx x Tip = singleton kx x go kx x t@(Bin _ ky y l r) = case compare kx ky of LT -> balanceL ky y (go kx x l) r GT -> balanceR ky y l (go kx x r) EQ -> t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertR #-} #else {-# INLINE insertR #-} #endif -- | /O(log n)/. Insert with a function, combining new value and old value. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will -- insert the pair @(key, f new_value old_value)@. -- -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith f = insertWithKey (\_ x' y' -> f x' y') #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertWith #-} #else {-# INLINE insertWith #-} #endif -- | /O(log n)/. Insert with a function, combining key, new value and old value. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will -- insert the pair @(key,f key new_value old_value)@. -- Note that the key passed to f is the same key passed to 'insertWithKey'. -- -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" -- See Note: Type of local 'go' function insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a insertWithKey = go where go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a STRICT_2_OF_4(go) go _ kx x Tip = singleton kx x go f kx x (Bin sy ky y l r) = case compare kx ky of LT -> balanceL ky y (go f kx x l) r GT -> balanceR ky y l (go f kx x r) EQ -> Bin sy kx (f kx x y) l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertWithKey #-} #else {-# INLINE insertWithKey #-} #endif -- | /O(log n)/. Combines insert operation with old value retrieval. -- The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@). -- -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value -- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) -- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) -- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") -- -- This is how to define @insertLookup@ using @insertLookupWithKey@: -- -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) -- See Note: Type of local 'go' function insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a) insertLookupWithKey = go where go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a) STRICT_2_OF_4(go) go _ kx x Tip = (Nothing, singleton kx x) go f kx x (Bin sy ky y l r) = case compare kx ky of LT -> let (found, l') = go f kx x l in (found, balanceL ky y l' r) GT -> let (found, r') = go f kx x r in (found, balanceR ky y l r') EQ -> (Just y, Bin sy kx (f kx x y) l r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertLookupWithKey #-} #else {-# INLINE insertLookupWithKey #-} #endif {-------------------------------------------------------------------- Deletion --------------------------------------------------------------------} -- | /O(log n)/. Delete a key and its value from the map. When the key is not -- a member of the map, the original map is returned. -- -- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > delete 5 empty == empty -- See Note: Type of local 'go' function delete :: Ord k => k -> Map k a -> Map k a delete = go where go :: Ord k => k -> Map k a -> Map k a STRICT_1_OF_2(go) go _ Tip = Tip go k (Bin _ kx x l r) = case compare k kx of LT -> balanceR kx x (go k l) r GT -> balanceL kx x l (go k r) EQ -> glue l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE delete #-} #else {-# INLINE delete #-} #endif -- | /O(log n)/. Update a value at a specific key with the result of the provided function. -- When the key is not -- a member of the map, the original map is returned. -- -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > adjust ("new " ++) 7 empty == empty adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a adjust f = adjustWithKey (\_ x -> f x) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjust #-} #else {-# INLINE adjust #-} #endif -- | /O(log n)/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > let f key x = (show key) ++ ":new " ++ x -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > adjustWithKey f 7 empty == empty adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x')) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjustWithKey #-} #else {-# INLINE adjustWithKey #-} #endif -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a update f = updateWithKey (\_ x -> f x) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE update #-} #else {-# INLINE update #-} #endif -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound -- to the new value @y@. -- -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -- See Note: Type of local 'go' function updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a updateWithKey = go where go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a STRICT_2_OF_3(go) go _ _ Tip = Tip go f k(Bin sx kx x l r) = case compare k kx of LT -> balanceR kx x (go f k l) r GT -> balanceL kx x l (go f k r) EQ -> case f kx x of Just x' -> Bin sx kx x' l r Nothing -> glue l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateWithKey #-} #else {-# INLINE updateWithKey #-} #endif -- | /O(log n)/. Lookup and update. See also 'updateWithKey'. -- The function returns changed value, if it is updated. -- Returns the original key value if the map entry is deleted. -- -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")]) -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") -- See Note: Type of local 'go' function updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) updateLookupWithKey = go where go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) STRICT_2_OF_3(go) go _ _ Tip = (Nothing,Tip) go f k (Bin sx kx x l r) = case compare k kx of LT -> let (found,l') = go f k l in (found,balanceR kx x l' r) GT -> let (found,r') = go f k r in (found,balanceL kx x l r') EQ -> case f kx x of Just x' -> (Just x',Bin sx kx x' l r) Nothing -> (Just x,glue l r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateLookupWithKey #-} #else {-# INLINE updateLookupWithKey #-} #endif -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in a 'Map'. -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. -- -- > let f _ = Nothing -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > -- > let f _ = Just "c" -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] -- See Note: Type of local 'go' function alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a alter = go where go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a STRICT_2_OF_3(go) go f k Tip = case f Nothing of Nothing -> Tip Just x -> singleton k x go f k (Bin sx kx x l r) = case compare k kx of LT -> balance kx x (go f k l) r GT -> balance kx x l (go f k r) EQ -> case f (Just x) of Just x' -> Bin sx kx x' l r Nothing -> glue l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE alter #-} #else {-# INLINE alter #-} #endif {-------------------------------------------------------------------- Indexing --------------------------------------------------------------------} -- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in -- the sequence sorted by keys. The index is a number from /0/ up to, but not -- including, the 'size' of the map. Calls 'error' when the key is not -- a 'member' of the map. -- -- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map -- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0 -- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1 -- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map -- See Note: Type of local 'go' function findIndex :: Ord k => k -> Map k a -> Int findIndex = go 0 where go :: Ord k => Int -> k -> Map k a -> Int STRICT_1_OF_3(go) STRICT_2_OF_3(go) go _ _ Tip = error "Map.findIndex: element is not in the map" go idx k (Bin _ kx _ l r) = case compare k kx of LT -> go idx k l GT -> go (idx + size l + 1) k r EQ -> idx + size l #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE findIndex #-} #endif -- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in -- the sequence sorted by keys. The index is a number from /0/ up to, but not -- including, the 'size' of the map. -- -- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False -- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0 -- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1 -- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False -- See Note: Type of local 'go' function lookupIndex :: Ord k => k -> Map k a -> Maybe Int lookupIndex = go 0 where go :: Ord k => Int -> k -> Map k a -> Maybe Int STRICT_1_OF_3(go) STRICT_2_OF_3(go) go _ _ Tip = Nothing go idx k (Bin _ kx _ l r) = case compare k kx of LT -> go idx k l GT -> go (idx + size l + 1) k r EQ -> Just $! idx + size l #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupIndex #-} #endif -- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based -- index in the sequence sorted by keys. If the /index/ is out of range (less -- than zero, greater or equal to 'size' of the map), 'error' is called. -- -- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b") -- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a") -- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range elemAt :: Int -> Map k a -> (k,a) STRICT_1_OF_2(elemAt) elemAt _ Tip = error "Map.elemAt: index out of range" elemAt i (Bin _ kx x l r) = case compare i sizeL of LT -> elemAt i l GT -> elemAt (i-sizeL-1) r EQ -> (kx,x) where sizeL = size l -- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in -- the sequence sorted by keys. If the /index/ is out of range (less than zero, -- greater or equal to 'size' of the map), 'error' is called. -- -- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")] -- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")] -- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range -- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range -- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range -- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a updateAt f i t = i `seq` case t of Tip -> error "Map.updateAt: index out of range" Bin sx kx x l r -> case compare i sizeL of LT -> balanceR kx x (updateAt f i l) r GT -> balanceL kx x l (updateAt f (i-sizeL-1) r) EQ -> case f kx x of Just x' -> Bin sx kx x' l r Nothing -> glue l r where sizeL = size l -- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in -- the sequence sorted by keys. If the /index/ is out of range (less than zero, -- greater or equal to 'size' of the map), 'error' is called. -- -- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range -- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range deleteAt :: Int -> Map k a -> Map k a deleteAt i t = i `seq` case t of Tip -> error "Map.deleteAt: index out of range" Bin _ kx x l r -> case compare i sizeL of LT -> balanceR kx x (deleteAt i l) r GT -> balanceL kx x l (deleteAt (i-sizeL-1) r) EQ -> glue l r where sizeL = size l {-------------------------------------------------------------------- Minimal, Maximal --------------------------------------------------------------------} -- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty. -- -- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b") -- > findMin empty Error: empty map has no minimal element findMin :: Map k a -> (k,a) findMin (Bin _ kx x Tip _) = (kx,x) findMin (Bin _ _ _ l _) = findMin l findMin Tip = error "Map.findMin: empty map has no minimal element" -- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty. -- -- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a") -- > findMax empty Error: empty map has no maximal element findMax :: Map k a -> (k,a) findMax (Bin _ kx x _ Tip) = (kx,x) findMax (Bin _ _ _ _ r) = findMax r findMax Tip = error "Map.findMax: empty map has no maximal element" -- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty. -- -- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")] -- > deleteMin empty == empty deleteMin :: Map k a -> Map k a deleteMin (Bin _ _ _ Tip r) = r deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r deleteMin Tip = Tip -- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty. -- -- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")] -- > deleteMax empty == empty deleteMax :: Map k a -> Map k a deleteMax (Bin _ _ _ l Tip) = l deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r) deleteMax Tip = Tip -- | /O(log n)/. Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMin :: (a -> Maybe a) -> Map k a -> Map k a updateMin f m = updateMinWithKey (\_ x -> f x) m -- | /O(log n)/. Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMax :: (a -> Maybe a) -> Map k a -> Map k a updateMax f m = updateMaxWithKey (\_ x -> f x) m -- | /O(log n)/. Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a updateMinWithKey _ Tip = Tip updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of Nothing -> r Just x' -> Bin sx kx x' Tip r updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r -- | /O(log n)/. Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a updateMaxWithKey _ Tip = Tip updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of Nothing -> l Just x' -> Bin sx kx x' l Tip updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r) -- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. -- -- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") -- > minViewWithKey empty == Nothing minViewWithKey :: Map k a -> Maybe ((k,a), Map k a) minViewWithKey Tip = Nothing minViewWithKey x = Just (deleteFindMin x) -- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. -- -- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b") -- > maxViewWithKey empty == Nothing maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a) maxViewWithKey Tip = Nothing maxViewWithKey x = Just (deleteFindMax x) -- | /O(log n)/. Retrieves the value associated with minimal key of the -- map, and the map stripped of that element, or 'Nothing' if passed an -- empty map. -- -- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a") -- > minView empty == Nothing minView :: Map k a -> Maybe (a, Map k a) minView Tip = Nothing minView x = Just (first snd $ deleteFindMin x) -- | /O(log n)/. Retrieves the value associated with maximal key of the -- map, and the map stripped of that element, or 'Nothing' if passed an -- -- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b") -- > maxView empty == Nothing maxView :: Map k a -> Maybe (a, Map k a) maxView Tip = Nothing maxView x = Just (first snd $ deleteFindMax x) -- Update the 1st component of a tuple (special case of Control.Arrow.first) first :: (a -> b) -> (a,c) -> (b,c) first f (x,y) = (f x, y) {-------------------------------------------------------------------- Union. --------------------------------------------------------------------} -- | The union of a list of maps: -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). -- -- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "b"), (5, "a"), (7, "C")] -- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] -- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] unions :: Ord k => [Map k a] -> Map k a unions ts = foldlStrict union empty ts #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unions #-} #endif -- | The union of a list of maps, with a combining operation: -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). -- -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a unionsWith f ts = foldlStrict (unionWith f) empty ts #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unionsWith #-} #endif -- | /O(n+m)/. -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. -- It prefers @t1@ when duplicate keys are encountered, -- i.e. (@'union' == 'unionWith' 'const'@). -- The implementation uses the efficient /hedge-union/ algorithm. -- -- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")] union :: Ord k => Map k a -> Map k a -> Map k a union Tip t2 = t2 union t1 Tip = t1 union t1 t2 = hedgeUnion NothingS NothingS t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE union #-} #endif -- left-biased hedge union hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a b -> Map a b hedgeUnion _ _ t1 Tip = t1 hedgeUnion blo bhi Tip (Bin _ kx x l r) = join kx x (filterGt blo l) (filterLt bhi r) hedgeUnion _ _ t1 (Bin _ kx x Tip Tip) = insertR kx x t1 -- According to benchmarks, this special case increases -- performance up to 30%. It does not help in difference or intersection. hedgeUnion blo bhi (Bin _ kx x l r) t2 = join kx x (hedgeUnion blo bmi l (trim blo bmi t2)) (hedgeUnion bmi bhi r (trim bmi bhi t2)) where bmi = JustS kx #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE hedgeUnion #-} #endif {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------} -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a unionWith f m1 m2 = unionWithKey (\_ x y -> f x y) m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unionWith #-} #endif -- | /O(n+m)/. -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a unionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) id id t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unionWithKey #-} #endif {-------------------------------------------------------------------- Difference --------------------------------------------------------------------} -- | /O(n+m)/. Difference of two maps. -- Return elements of the first map not existing in the second map. -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b" difference :: Ord k => Map k a -> Map k b -> Map k a difference Tip _ = Tip difference t1 Tip = t1 difference t1 t2 = hedgeDiff NothingS NothingS t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE difference #-} #endif hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a c -> Map a b hedgeDiff _ _ Tip _ = Tip hedgeDiff blo bhi (Bin _ kx x l r) Tip = join kx x (filterGt blo l) (filterLt bhi r) hedgeDiff blo bhi t (Bin _ kx _ l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l) (hedgeDiff bmi bhi (trim bmi bhi t) r) where bmi = JustS kx #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE hedgeDiff #-} #endif -- | /O(n+m)/. Difference with a combining function. -- When two equal keys are -- encountered, the combining function is applied to the values of these keys. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) -- > == singleton 3 "b:B" differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a differenceWith f m1 m2 = differenceWithKey (\_ x y -> f x y) m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE differenceWith #-} #endif -- | /O(n+m)/. Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) -- > == singleton 3 "3:b|B" differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a differenceWithKey f t1 t2 = mergeWithKey f id (const Tip) t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE differenceWithKey #-} #endif {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------} -- | /O(n+m)/. Intersection of two maps. -- Return data in the first map for the keys existing in both maps. -- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). -- The implementation uses an efficient /hedge/ algorithm comparable with -- /hedge-union/. -- -- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a" intersection :: Ord k => Map k a -> Map k b -> Map k a intersection Tip _ = Tip intersection _ Tip = Tip intersection t1 t2 = hedgeInt NothingS NothingS t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersection #-} #endif hedgeInt :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k b -> Map k a hedgeInt _ _ _ Tip = Tip hedgeInt _ _ Tip _ = Tip hedgeInt blo bhi (Bin _ kx x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2) r' = hedgeInt bmi bhi r (trim bmi bhi t2) in if kx `member` t2 then join kx x l' r' else merge l' r' where bmi = JustS kx #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE hedgeInt #-} #endif -- | /O(n+m)/. Intersection with a combining function. The implementation uses -- an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c intersectionWith f m1 m2 = intersectionWithKey (\_ x y -> f x y) m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersectionWith #-} #endif -- | /O(n+m)/. Intersection with a combining function. The implementation uses -- an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c intersectionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) (const Tip) (const Tip) t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersectionWithKey #-} #endif {-------------------------------------------------------------------- MergeWithKey --------------------------------------------------------------------} -- | /O(n+m)/. A high-performance universal combining function. This function -- is used to define 'unionWith', 'unionWithKey', 'differenceWith', -- 'differenceWithKey', 'intersectionWith', 'intersectionWithKey' and can be -- used to define other custom combine functions. -- -- Please make sure you know what is going on when using 'mergeWithKey', -- otherwise you can be surprised by unexpected code growth or even -- corruption of the data structure. -- -- When 'mergeWithKey' is given three arguments, it is inlined to the call -- site. You should therefore use 'mergeWithKey' only to define your custom -- combining functions. For example, you could define 'unionWithKey', -- 'differenceWithKey' and 'intersectionWithKey' as -- -- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 -- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 -- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 -- -- When calling @'mergeWithKey' combine only1 only2@, a function combining two -- 'IntMap's is created, such that -- -- * if a key is present in both maps, it is passed with both corresponding -- values to the @combine@ function. Depending on the result, the key is either -- present in the result with specified value, or is left out; -- -- * a nonempty subtree present only in the first map is passed to @only1@ and -- the output is added to the result; -- -- * a nonempty subtree present only in the second map is passed to @only2@ and -- the output is added to the result. -- -- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. -- The values can be modified arbitrarily. Most common variants of @only1@ and -- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or -- @'filterWithKey' f@ could be used for any @f@. mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c mergeWithKey f g1 g2 = go where go Tip t2 = g2 t2 go t1 Tip = g1 t1 go t1 t2 = hedgeMerge NothingS NothingS t1 t2 hedgeMerge _ _ t1 Tip = g1 t1 hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ join kx x (filterGt blo l) (filterLt bhi r) hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2) (found, trim_t2) = trimLookupLo kx bhi t2 r' = hedgeMerge bmi bhi r trim_t2 in case found of Nothing -> case g1 (singleton kx x) of Tip -> merge l' r' (Bin _ _ x' Tip Tip) -> join kx x' l' r' _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)" Just x2 -> case f kx x x2 of Nothing -> merge l' r' Just x' -> join kx x' l' r' where bmi = JustS kx {-# INLINE mergeWithKey #-} {-------------------------------------------------------------------- Submap --------------------------------------------------------------------} -- | /O(n+m)/. -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -- isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE isSubmapOf #-} #endif {- | /O(n+m)/. The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when applied to their respective values. For example, the following expressions are all 'True': > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) But the following are all 'False': > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)]) > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)]) -} isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool isSubmapOfBy f t1 t2 = (size t1 <= size t2) && (submap' f t1 t2) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE isSubmapOfBy #-} #endif submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool submap' _ Tip _ = True submap' _ _ Tip = False submap' f (Bin _ kx x l r) t = case found of Nothing -> False Just y -> f x y && submap' f l lt && submap' f r gt where (lt,found,gt) = splitLookup kx t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE submap' #-} #endif -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool isProperSubmapOf m1 m2 = isProperSubmapOfBy (==) m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE isProperSubmapOf #-} #endif {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when @m1@ and @m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when applied to their respective values. For example, the following expressions are all 'True': > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) But the following are all 'False': > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) -} isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool isProperSubmapOfBy f t1 t2 = (size t1 < size t2) && (submap' f t1 t2) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE isProperSubmapOfBy #-} #endif {-------------------------------------------------------------------- Filter and partition --------------------------------------------------------------------} -- | /O(n)/. Filter all values that satisfy the predicate. -- -- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty -- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty filter :: (a -> Bool) -> Map k a -> Map k a filter p m = filterWithKey (\_ x -> p x) m -- | /O(n)/. Filter all keys\/values that satisfy the predicate. -- -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a filterWithKey _ Tip = Tip filterWithKey p (Bin _ kx x l r) | p kx x = join kx x (filterWithKey p l) (filterWithKey p r) | otherwise = merge (filterWithKey p l) (filterWithKey p r) -- | /O(n)/. Partition the map according to a predicate. The first -- map contains all elements that satisfy the predicate, the second all -- elements that fail the predicate. See also 'split'. -- -- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") -- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) -- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a) partition p m = partitionWithKey (\_ x -> p x) m -- | /O(n)/. Partition the map according to a predicate. The first -- map contains all elements that satisfy the predicate, the second all -- elements that fail the predicate. See also 'split'. -- -- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b") -- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a) partitionWithKey p0 t0 = toPair $ go p0 t0 where go _ Tip = (Tip :*: Tip) go p (Bin _ kx x l r) | p kx x = join kx x l1 r1 :*: merge l2 r2 | otherwise = merge l1 r1 :*: join kx x l2 r2 where (l1 :*: l2) = go p l (r1 :*: r2) = go p r -- | /O(n)/. Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b mapMaybe f = mapMaybeWithKey (\_ x -> f x) -- | /O(n)/. Map keys\/values and collect the 'Just' results. -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b mapMaybeWithKey _ Tip = Tip mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -- -- > let f a = if a < "c" then Left a else Right a -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) -- > -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c) mapEither f m = mapEitherWithKey (\_ x -> f x) m -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. -- -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) -- > -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c) mapEitherWithKey f0 t0 = toPair $ go f0 t0 where go _ Tip = (Tip :*: Tip) go f (Bin _ kx x l r) = case f kx x of Left y -> join kx y l1 r1 :*: merge l2 r2 Right z -> merge l1 r1 :*: join kx z l2 r2 where (l1 :*: l2) = go f l (r1 :*: r2) = go f r {-------------------------------------------------------------------- Mapping --------------------------------------------------------------------} -- | /O(n)/. Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] map :: (a -> b) -> Map k a -> Map k b map _ Tip = Tip map f (Bin sx kx x l r) = Bin sx kx (f x) (map f l) (map f r) -- | /O(n)/. Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] mapWithKey :: (k -> a -> b) -> Map k a -> Map k b mapWithKey _ Tip = Tip mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r) -- | /O(n)/. -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ -- That is, behaves exactly like a regular 'traverse' except that the traversing -- function also has access to the key associated with a value. -- -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing {-# INLINE traverseWithKey #-} traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b) traverseWithKey f = go where go Tip = pure Tip go (Bin s k v l r) = flip (Bin s k) <$> go l <*> f k v <*> go r -- | /O(n)/. The function 'mapAccum' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a b = (a ++ b, b ++ "X") -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumWithKey f a t = mapAccumL f a t -- | /O(n)/. The function 'mapAccumL' threads an accumulating -- argument through the map in ascending order of keys. mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumL _ a Tip = (a,Tip) mapAccumL f a (Bin sx kx x l r) = let (a1,l') = mapAccumL f a l (a2,x') = f a1 kx x (a3,r') = mapAccumL f a2 r in (a3,Bin sx kx x' l' r') -- | /O(n)/. The function 'mapAccumR' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip) mapAccumRWithKey f a (Bin sx kx x l r) = let (a1,r') = mapAccumRWithKey f a r (a2,x') = f a1 kx x (a3,l') = mapAccumRWithKey f a2 l in (a3,Bin sx kx x' l' r') -- | /O(n*log n)/. -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct -- keys to the same new key. In this case the value at the greatest of the -- original keys is retained. -- -- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] -- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" -- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) [] #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE mapKeys #-} #endif -- | /O(n*log n)/. -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct -- keys to the same new key. In this case the associated values will be -- combined using @c@. -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE mapKeysWith #-} #endif -- | /O(n)/. -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ -- is strictly monotonic. -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. -- /The precondition is not checked./ -- Semi-formally, we have: -- -- > and [x < y ==> f x < f y | x <- ls, y <- ls] -- > ==> mapKeysMonotonic f s == mapKeys f s -- > where ls = keys s -- -- This means that @f@ maps distinct original keys to distinct resulting keys. -- This function has better performance than 'mapKeys'. -- -- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] -- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True -- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a mapKeysMonotonic _ Tip = Tip mapKeysMonotonic f (Bin sz k x l r) = Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r) {-------------------------------------------------------------------- Folds --------------------------------------------------------------------} -- | /O(n)/. Fold the values in the map using the given right-associative -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. -- -- For example, -- -- > elems map = foldr (:) [] map -- -- > let f a len = len + (length a) -- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 foldr :: (a -> b -> b) -> b -> Map k a -> b foldr f z = go z where go z' Tip = z' go z' (Bin _ _ x l r) = go (f x (go z' r)) l {-# INLINE foldr #-} -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldr' :: (a -> b -> b) -> b -> Map k a -> b foldr' f z = go z where STRICT_1_OF_2(go) go z' Tip = z' go z' (Bin _ _ x l r) = go (f x (go z' r)) l {-# INLINE foldr' #-} -- | /O(n)/. Fold the values in the map using the given left-associative -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. -- -- For example, -- -- > elems = reverse . foldl (flip (:)) [] -- -- > let f len a = len + (length a) -- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 foldl :: (a -> b -> a) -> a -> Map k b -> a foldl f z = go z where go z' Tip = z' go z' (Bin _ _ x l r) = go (f (go z' l) x) r {-# INLINE foldl #-} -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldl' :: (a -> b -> a) -> a -> Map k b -> a foldl' f z = go z where STRICT_1_OF_2(go) go z' Tip = z' go z' (Bin _ _ x l r) = go (f (go z' l) x) r {-# INLINE foldl' #-} -- | /O(n)/. Fold the keys and values in the map using the given right-associative -- binary operator, such that -- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. -- -- For example, -- -- > keys map = foldrWithKey (\k x ks -> k:ks) [] map -- -- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" -- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b foldrWithKey f z = go z where go z' Tip = z' go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l {-# INLINE foldrWithKey #-} -- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b foldrWithKey' f z = go z where STRICT_1_OF_2(go) go z' Tip = z' go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l {-# INLINE foldrWithKey' #-} -- | /O(n)/. Fold the keys and values in the map using the given left-associative -- binary operator, such that -- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. -- -- For example, -- -- > keys = reverse . foldlWithKey (\ks k x -> k:ks) [] -- -- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" -- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)" foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a foldlWithKey f z = go z where go z' Tip = z' go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r {-# INLINE foldlWithKey #-} -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a foldlWithKey' f z = go z where STRICT_1_OF_2(go) go z' Tip = z' go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r {-# INLINE foldlWithKey' #-} {-------------------------------------------------------------------- List variations --------------------------------------------------------------------} -- | /O(n)/. -- Return all elements of the map in the ascending order of their keys. -- Subject to list fusion. -- -- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"] -- > elems empty == [] elems :: Map k a -> [a] elems = foldr (:) [] -- | /O(n)/. Return all keys of the map in ascending order. Subject to list -- fusion. -- -- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] -- > keys empty == [] keys :: Map k a -> [k] keys = foldrWithKey (\k _ ks -> k : ks) [] -- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map -- in ascending key order. Subject to list fusion. -- -- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] -- > assocs empty == [] assocs :: Map k a -> [(k,a)] assocs m = toAscList m -- | /O(n)/. The set of all keys of the map. -- -- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5] -- > keysSet empty == Data.Set.empty keysSet :: Map k a -> Set.Set k keysSet Tip = Set.Tip keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r) -- | /O(n)/. Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a fromSet _ Set.Tip = Tip fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r) {-------------------------------------------------------------------- Lists use [foldlStrict] to reduce demand on the control-stack --------------------------------------------------------------------} -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. -- If the list contains more than one value for the same key, the last value -- for the key is retained. -- -- If the keys of the list are ordered, linear-time implementation is used, -- with the performance equal to 'fromDistinctAscList'. -- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] -- For some reason, when 'singleton' is used in fromList or in -- create, it is not inlined, so we inline it manually. fromList :: Ord k => [(k,a)] -> Map k a fromList [] = Tip fromList [(kx, x)] = Bin 1 kx x Tip Tip fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0 | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 where not_ordered _ [] = False not_ordered kx ((ky,_) : _) = kx >= ky {-# INLINE not_ordered #-} fromList' t0 xs = foldlStrict ins t0 xs where ins t (k,x) = insert k x t STRICT_1_OF_3(go) go _ t [] = t go _ t [(kx, x)] = insertMax kx x t go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs | otherwise = case create s xss of (r, ys, []) -> go (s `shiftL` 1) (join kx x l r) ys (r, _, ys) -> fromList' (join kx x l r) ys -- The create is returning a triple (tree, xs, ys). Both xs and ys -- represent not yet processed elements and only one of them can be nonempty. -- If ys is nonempty, the keys in ys are not ordered with respect to tree -- and must be inserted using fromList'. Otherwise the keys have been -- ordered so far. STRICT_1_OF_2(create) create _ [] = (Tip, [], []) create s xs@(xp : xss) | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss) | otherwise -> (Bin 1 kx x Tip Tip, xss, []) | otherwise = case create (s `shiftR` 1) xs of res@(_, [], _) -> res (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs) (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys) | otherwise -> case create (s `shiftR` 1) yss of (r, zs, ws) -> (join ky y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] -- > fromListWith (++) [] == empty fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromListWith #-} #endif -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. -- -- > let f k a1 a2 = (show k) ++ a1 ++ a2 -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] -- > fromListWithKey f [] == empty fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromListWithKey f xs = foldlStrict ins empty xs where ins t (k,x) = insertWithKey f k x t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromListWithKey #-} #endif -- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion. -- -- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] -- > toList empty == [] toList :: Map k a -> [(k,a)] toList = toAscList -- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are -- in ascending order. Subject to list fusion. -- -- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] toAscList :: Map k a -> [(k,a)] toAscList = foldrWithKey (\k x xs -> (k,x):xs) [] -- | /O(n)/. Convert the map to a list of key\/value pairs where the keys -- are in descending order. Subject to list fusion. -- -- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")] toDescList :: Map k a -> [(k,a)] toDescList = foldlWithKey (\xs k x -> (k,x):xs) [] -- List fusion for the list generating functions. #if __GLASGOW_HASKELL__ -- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion. -- They are important to convert unfused methods back, see mapFB in prelude. foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b foldrFB = foldrWithKey {-# INLINE[0] foldrFB #-} foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a foldlFB = foldlWithKey {-# INLINE[0] foldlFB #-} -- Inline assocs and toList, so that we need to fuse only toAscList. {-# INLINE assocs #-} {-# INLINE toList #-} -- The fusion is enabled up to phase 2 included. If it does not succeed, -- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to -- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were -- used in a list fusion, otherwise it would go away in phase 1), and let compiler -- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to -- inline it before phase 0, otherwise the fusion rules would not fire at all. {-# NOINLINE[0] elems #-} {-# NOINLINE[0] keys #-} {-# NOINLINE[0] toAscList #-} {-# NOINLINE[0] toDescList #-} {-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-} {-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-} {-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-} {-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-} {-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-} {-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-} {-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-} {-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-} #endif {-------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time. Note that if [xs] is ascending that: fromAscList xs == fromList xs fromAscListWith f xs == fromListWith f xs --------------------------------------------------------------------} -- | /O(n)/. Build a map from an ascending list in linear time. -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False fromAscList :: Eq k => [(k,a)] -> Map k a fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromAscList #-} #endif -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] -- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromAscListWith #-} #endif -- | /O(n)/. Build a map from an ascending list in linear time with a -- combining function for equal keys. -- /The precondition (input list is ascending) is not checked./ -- -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] -- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs) where -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] combineEq _ xs' = case xs' of [] -> [] [x] -> [x] (x:xx) -> combineEq' x xx combineEq' z [] = [z] combineEq' z@(kz,zz) (x@(kx,xx):xs') | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs' | otherwise = z:combineEq' x xs' #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromAscListWithKey #-} #endif -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. -- /The precondition is not checked./ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False -- For some reason, when 'singleton' is used in fromDistinctAscList or in -- create, it is not inlined, so we inline it manually. fromDistinctAscList :: [(k,a)] -> Map k a fromDistinctAscList [] = Tip fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 where STRICT_1_OF_3(go) go _ t [] = t go s l ((kx, x) : xs) = case create s xs of (r, ys) -> go (s `shiftL` 1) (join kx x l r) ys STRICT_1_OF_2(create) create _ [] = (Tip, []) create s xs@(x' : xs') | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, xs') | otherwise = case create (s `shiftR` 1) xs of res@(_, []) -> res (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of (r, zs) -> (join ky y l r, zs) {-------------------------------------------------------------------- Utility functions that return sub-ranges of the original tree. Some functions take a `Maybe value` as an argument to allow comparisons against infinite values. These are called `blow` (Nothing is -\infty) and `bhigh` (here Nothing is +\infty). We use MaybeS value, which is a Maybe strict in the Just case. [trim blow bhigh t] A tree that is either empty or where [x > blow] and [x < bhigh] for the value [x] of the root. [filterGt blow t] A tree where for all values [k]. [k > blow] [filterLt bhigh t] A tree where for all values [k]. [k < bhigh] [split k t] Returns two trees [l] and [r] where all keys in [l] are <[k] and all keys in [r] are >[k]. [splitLookup k t] Just like [split] but also returns whether [k] was found in the tree. --------------------------------------------------------------------} data MaybeS a = NothingS | JustS !a {-------------------------------------------------------------------- [trim blo bhi t] trims away all subtrees that surely contain no values between the range [blo] to [bhi]. The returned tree is either empty or the key of the root is between @blo@ and @bhi@. --------------------------------------------------------------------} trim :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k a trim NothingS NothingS t = t trim (JustS lk) NothingS t = greater lk t where greater lo (Bin _ k _ _ r) | k <= lo = greater lo r greater _ t' = t' trim NothingS (JustS hk) t = lesser hk t where lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l lesser _ t' = t' trim (JustS lk) (JustS hk) t = middle lk hk t where middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l middle _ _ t' = t' #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE trim #-} #endif -- Helper function for 'mergeWithKey'. The @'trimLookupLo' lk hk t@ performs both -- @'trim' (JustS lk) hk t@ and @'lookup' lk t@. -- See Note: Type of local 'go' function trimLookupLo :: Ord k => k -> MaybeS k -> Map k a -> (Maybe a, Map k a) trimLookupLo lk0 mhk0 t0 = toPair $ go lk0 mhk0 t0 where go lk NothingS t = greater lk t where greater :: Ord k => k -> Map k a -> StrictPair (Maybe a) (Map k a) greater lo t'@(Bin _ kx x l r) = case compare lo kx of LT -> lookup lo l :*: t' EQ -> (Just x :*: r) GT -> greater lo r greater _ Tip = (Nothing :*: Tip) go lk (JustS hk) t = middle lk hk t where middle :: Ord k => k -> k -> Map k a -> StrictPair (Maybe a) (Map k a) middle lo hi t'@(Bin _ kx x l r) = case compare lo kx of LT | kx < hi -> lookup lo l :*: t' | otherwise -> middle lo hi l EQ -> Just x :*: lesser hi r GT -> middle lo hi r middle _ _ Tip = (Nothing :*: Tip) lesser :: Ord k => k -> Map k a -> Map k a lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l lesser _ t' = t' #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE trimLookupLo #-} #endif {-------------------------------------------------------------------- [filterGt b t] filter all keys >[b] from tree [t] [filterLt b t] filter all keys <[b] from tree [t] --------------------------------------------------------------------} filterGt :: Ord k => MaybeS k -> Map k v -> Map k v filterGt NothingS t = t filterGt (JustS b) t = filter' b t where filter' _ Tip = Tip filter' b' (Bin _ kx x l r) = case compare b' kx of LT -> join kx x (filter' b' l) r EQ -> r GT -> filter' b' r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE filterGt #-} #endif filterLt :: Ord k => MaybeS k -> Map k v -> Map k v filterLt NothingS t = t filterLt (JustS b) t = filter' b t where filter' _ Tip = Tip filter' b' (Bin _ kx x l r) = case compare kx b' of LT -> join kx x l (filter' b' r) EQ -> l GT -> filter' b' l #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE filterLt #-} #endif {-------------------------------------------------------------------- Split --------------------------------------------------------------------} -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where -- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. -- Any key equal to @k@ is found in neither @map1@ nor @map2@. -- -- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")]) -- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a") -- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") -- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty) -- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty) split :: Ord k => k -> Map k a -> (Map k a,Map k a) split k0 t0 = k0 `seq` toPair $ go k0 t0 where go k t = case t of Tip -> (Tip :*: Tip) Bin _ kx x l r -> case compare k kx of LT -> let (lt :*: gt) = go k l in lt :*: join kx x gt r GT -> let (lt :*: gt) = go k r in join kx x l lt :*: gt EQ -> (l :*: r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE split #-} #endif -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just -- like 'split' but also returns @'lookup' k map@. -- -- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")]) -- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a") -- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a") -- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty) -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty) splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a) splitLookup k t = k `seq` case t of Tip -> (Tip,Nothing,Tip) Bin _ kx x l r -> case compare k kx of LT -> let (lt,z,gt) = splitLookup k l gt' = join kx x gt r in gt' `seq` (lt,z,gt') GT -> let (lt,z,gt) = splitLookup k r lt' = join kx x l lt in lt' `seq` (lt',z,gt) EQ -> (l,Just x,r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE splitLookup #-} #endif {-------------------------------------------------------------------- Utility functions that maintain the balance properties of the tree. All constructors assume that all values in [l] < [k] and all values in [r] > [k], and that [l] and [r] are valid trees. In order of sophistication: [Bin sz k x l r] The type constructor. [bin k x l r] Maintains the correct size, assumes that both [l] and [r] are balanced with respect to each other. [balance k x l r] Restores the balance and size. Assumes that the original tree was balanced and that [l] or [r] has changed by at most one element. [join k x l r] Restores balance and size. Furthermore, we can construct a new tree from two trees. Both operations assume that all values in [l] < all values in [r] and that [l] and [r] are valid: [glue l r] Glues [l] and [r] together. Assumes that [l] and [r] are already balanced with respect to each other. [merge l r] Merges two trees and restores balance. Note: in contrast to Adam's paper, we use (<=) comparisons instead of (<) comparisons in [join], [merge] and [balance]. Quickcheck (on [difference]) showed that this was necessary in order to maintain the invariants. It is quite unsatisfactory that I haven't been able to find out why this is actually the case! Fortunately, it doesn't hurt to be a bit more conservative. --------------------------------------------------------------------} {-------------------------------------------------------------------- Join --------------------------------------------------------------------} join :: k -> a -> Map k a -> Map k a -> Map k a join kx x Tip r = insertMin kx x r join kx x l Tip = insertMax kx x l join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz) | delta*sizeL < sizeR = balanceL kz z (join kx x l lz) rz | delta*sizeR < sizeL = balanceR ky y ly (join kx x ry r) | otherwise = bin kx x l r -- insertMin and insertMax don't perform potentially expensive comparisons. insertMax,insertMin :: k -> a -> Map k a -> Map k a insertMax kx x t = case t of Tip -> singleton kx x Bin _ ky y l r -> balanceR ky y l (insertMax kx x r) insertMin kx x t = case t of Tip -> singleton kx x Bin _ ky y l r -> balanceL ky y (insertMin kx x l) r {-------------------------------------------------------------------- [merge l r]: merges two trees. --------------------------------------------------------------------} merge :: Map k a -> Map k a -> Map k a merge Tip r = r merge l Tip = l merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry) | delta*sizeL < sizeR = balanceL ky y (merge l ly) ry | delta*sizeR < sizeL = balanceR kx x lx (merge rx r) | otherwise = glue l r {-------------------------------------------------------------------- [glue l r]: glues two trees together. Assumes that [l] and [r] are already balanced with respect to each other. --------------------------------------------------------------------} glue :: Map k a -> Map k a -> Map k a glue Tip r = r glue l Tip = l glue l r | size l > size r = let ((km,m),l') = deleteFindMax l in balanceR km m l' r | otherwise = let ((km,m),r') = deleteFindMin r in balanceL km m l r' -- | /O(log n)/. Delete and find the minimal element. -- -- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) -- > deleteFindMin Error: can not return the minimal element of an empty map deleteFindMin :: Map k a -> ((k,a),Map k a) deleteFindMin t = case t of Bin _ k x Tip r -> ((k,x),r) Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balanceR k x l' r) Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip) -- | /O(log n)/. Delete and find the maximal element. -- -- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")]) -- > deleteFindMax empty Error: can not return the maximal element of an empty map deleteFindMax :: Map k a -> ((k,a),Map k a) deleteFindMax t = case t of Bin _ k x l Tip -> ((k,x),l) Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balanceL k x l r') Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip) {-------------------------------------------------------------------- [balance l x r] balances two trees with value x. The sizes of the trees should balance after decreasing the size of one of them. (a rotation). [delta] is the maximal relative difference between the sizes of two trees, it corresponds with the [w] in Adams' paper. [ratio] is the ratio between an outer and inner sibling of the heavier subtree in an unbalanced setting. It determines whether a double or single rotation should be performed to restore balance. It is corresponds with the inverse of $\alpha$ in Adam's article. Note that according to the Adam's paper: - [delta] should be larger than 4.646 with a [ratio] of 2. - [delta] should be larger than 3.745 with a [ratio] of 1.534. But the Adam's paper is erroneous: - It can be proved that for delta=2 and delta>=5 there does not exist any ratio that would work. - Delta=4.5 and ratio=2 does not work. That leaves two reasonable variants, delta=3 and delta=4, both with ratio=2. - A lower [delta] leads to a more 'perfectly' balanced tree. - A higher [delta] performs less rebalancing. In the benchmarks, delta=3 is faster on insert operations, and delta=4 has slightly better deletes. As the insert speedup is larger, we currently use delta=3. --------------------------------------------------------------------} delta,ratio :: Int delta = 3 ratio = 2 -- The balance function is equivalent to the following: -- -- balance :: k -> a -> Map k a -> Map k a -> Map k a -- balance k x l r -- | sizeL + sizeR <= 1 = Bin sizeX k x l r -- | sizeR > delta*sizeL = rotateL k x l r -- | sizeL > delta*sizeR = rotateR k x l r -- | otherwise = Bin sizeX k x l r -- where -- sizeL = size l -- sizeR = size r -- sizeX = sizeL + sizeR + 1 -- -- rotateL :: a -> b -> Map a b -> Map a b -> Map a b -- rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r -- | otherwise = doubleL k x l r -- -- rotateR :: a -> b -> Map a b -> Map a b -> Map a b -- rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r -- | otherwise = doubleR k x l r -- -- singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b -- singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3 -- singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3) -- -- doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b -- doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4) -- doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4) -- -- It is only written in such a way that every node is pattern-matched only once. balance :: k -> a -> Map k a -> Map k a -> Map k a balance k x l r = case l of Tip -> case r of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _)) | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr) (Bin ls lk lx ll lr) -> case r of Tip -> case (ll, lr) of (Tip, Tip) -> Bin 2 k x l Tip (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip) ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip) ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr)) | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip) | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip) (Bin rs rk rx rl rr) | rs > delta*ls -> case (rl, rr) of (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr) (_, _) -> error "Failure in Data.Map.balance" | ls > delta*rs -> case (ll, lr) of (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr) | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r) | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r) (_, _) -> error "Failure in Data.Map.balance" | otherwise -> Bin (1+ls+rs) k x l r {-# NOINLINE balance #-} -- Functions balanceL and balanceR are specialised versions of balance. -- balanceL only checks whether the left subtree is too big, -- balanceR only checks whether the right subtree is too big. -- balanceL is called when left subtree might have been inserted to or when -- right subtree might have been deleted from. balanceL :: k -> a -> Map k a -> Map k a -> Map k a balanceL k x l r = case r of Tip -> case l of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip) (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip) (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr)) | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip) | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip) (Bin rs _ _ _ _) -> case l of Tip -> Bin (1+rs) k x Tip r (Bin ls lk lx ll lr) | ls > delta*rs -> case (ll, lr) of (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr) | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r) | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r) (_, _) -> error "Failure in Data.Map.balanceL" | otherwise -> Bin (1+ls+rs) k x l r {-# NOINLINE balanceL #-} -- balanceR is called when right subtree might have been inserted to or when -- left subtree might have been deleted from. balanceR :: k -> a -> Map k a -> Map k a -> Map k a balanceR k x l r = case l of Tip -> case r of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _)) | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr) (Bin ls _ _ _ _) -> case r of Tip -> Bin (1+ls) k x l Tip (Bin rs rk rx rl rr) | rs > delta*ls -> case (rl, rr) of (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr) (_, _) -> error "Failure in Data.Map.balanceR" | otherwise -> Bin (1+ls+rs) k x l r {-# NOINLINE balanceR #-} {-------------------------------------------------------------------- The bin constructor maintains the size of the tree --------------------------------------------------------------------} bin :: k -> a -> Map k a -> Map k a -> Map k a bin k x l r = Bin (size l + size r + 1) k x l r {-# INLINE bin #-} {-------------------------------------------------------------------- Eq converts the tree to a list. In a lazy setting, this actually seems one of the faster methods to compare two trees and it is certainly the simplest :-) --------------------------------------------------------------------} instance (Eq k,Eq a) => Eq (Map k a) where t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) {-------------------------------------------------------------------- Ord --------------------------------------------------------------------} instance (Ord k, Ord v) => Ord (Map k v) where compare m1 m2 = compare (toAscList m1) (toAscList m2) {-------------------------------------------------------------------- Functor --------------------------------------------------------------------} instance Functor (Map k) where fmap f m = map f m instance Traversable (Map k) where traverse f = traverseWithKey (\_ -> f) instance Foldable.Foldable (Map k) where fold Tip = mempty fold (Bin _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r foldr = foldr foldl = foldl foldMap _ Tip = mempty foldMap f (Bin _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r instance (NFData k, NFData a) => NFData (Map k a) where rnf Tip = () rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r {-------------------------------------------------------------------- Read --------------------------------------------------------------------} instance (Ord k, Read k, Read e) => Read (Map k e) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec return (fromList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \ r -> do ("fromList",s) <- lex r (xs,t) <- reads s return (fromList xs,t) #endif {-------------------------------------------------------------------- Show --------------------------------------------------------------------} instance (Show k, Show a) => Show (Map k a) where showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) -- | /O(n)/. Show the tree that implements the map. The tree is shown -- in a compressed, hanging format. See 'showTreeWith'. showTree :: (Show k,Show a) => Map k a -> String showTree m = showTreeWith showElem True False m where showElem k x = show k ++ ":=" ++ show x {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown. > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]] > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t > (4,()) > +--(2,()) > | +--(1,()) > | +--(3,()) > +--(5,()) > > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t > (4,()) > | > +--(2,()) > | | > | +--(1,()) > | | > | +--(3,()) > | > +--(5,()) > > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t > +--(5,()) > | > (4,()) > | > | +--(3,()) > | | > +--(2,()) > | > +--(1,()) -} showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String showTreeWith showelem hang wide t | hang = (showsTreeHang showelem wide [] t) "" | otherwise = (showsTree showelem wide [] [] t) "" showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS showsTree showelem wide lbars rbars t = case t of Tip -> showsBars lbars . showString "|\n" Bin _ kx x Tip Tip -> showsBars lbars . showString (showelem kx x) . showString "\n" Bin _ kx x l r -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r . showWide wide rbars . showsBars lbars . showString (showelem kx x) . showString "\n" . showWide wide lbars . showsTree showelem wide (withEmpty lbars) (withBar lbars) l showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS showsTreeHang showelem wide bars t = case t of Tip -> showsBars bars . showString "|\n" Bin _ kx x Tip Tip -> showsBars bars . showString (showelem kx x) . showString "\n" Bin _ kx x l r -> showsBars bars . showString (showelem kx x) . showString "\n" . showWide wide bars . showsTreeHang showelem wide (withBar bars) l . showWide wide bars . showsTreeHang showelem wide (withEmpty bars) r showWide :: Bool -> [String] -> String -> String showWide wide bars | wide = showString (concat (reverse bars)) . showString "|\n" | otherwise = id showsBars :: [String] -> ShowS showsBars bars = case bars of [] -> id _ -> showString (concat (reverse (tail bars))) . showString node node :: String node = "+--" withBar, withEmpty :: [String] -> [String] withBar bars = "| ":bars withEmpty bars = " ":bars {-------------------------------------------------------------------- Typeable --------------------------------------------------------------------} #include "Typeable.h" INSTANCE_TYPEABLE2(Map,mapTc,"Map") {-------------------------------------------------------------------- Assertions --------------------------------------------------------------------} -- | /O(n)/. Test if the internal map structure is valid. -- -- > valid (fromAscList [(3,"b"), (5,"a")]) == True -- > valid (fromAscList [(5,"a"), (3,"b")]) == False valid :: Ord k => Map k a -> Bool valid t = balanced t && ordered t && validsize t ordered :: Ord a => Map a b -> Bool ordered t = bounded (const True) (const True) t where bounded lo hi t' = case t' of Tip -> True Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (kx) hi r -- | Exported only for "Debug.QuickCheck" balanced :: Map k a -> Bool balanced t = case t of Tip -> True Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && balanced l && balanced r validsize :: Map a b -> Bool validsize t = (realsize t == Just (size t)) where realsize t' = case t' of Tip -> Just 0 Bin sz _ _ l r -> case (realsize l,realsize r) of (Just n,Just m) | n+m+1 == sz -> Just sz _ -> Nothing {-------------------------------------------------------------------- Utilities --------------------------------------------------------------------} foldlStrict :: (a -> b -> a) -> a -> [b] -> a foldlStrict f = go where go z [] = z go z (x:xs) = let z' = f z x in z' `seq` go z' xs {-# INLINE foldlStrict #-} darcs-2.10.2/containers-0.5.2.1/Darcs/Data/Map/Strict.hs0000644000175000017500000013045012620122474024117 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Safe #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Map.Strict -- Copyright : (c) Daan Leijen 2002 -- (c) Andriy Palamarchuk 2008 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- An efficient implementation of ordered maps from keys to values -- (dictionaries). -- -- API of this module is strict in both the keys and the values. -- If you need value-lazy maps, use "Data.Map.Lazy" instead. -- The 'Map' type is shared between the lazy and strict modules, -- meaning that the same 'Map' value can be passed to functions in -- both modules (although that is rarely needed). -- -- These modules are intended to be imported qualified, to avoid name -- clashes with Prelude functions, e.g. -- -- > import qualified Data.Map.Strict as Map -- -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -- -- * Stephen Adams, \"/Efficient sets: a balancing act/\", -- Journal of Functional Programming 3(4):553-562, October 1993, -- . -- -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973. -- -- Note that the implementation is /left-biased/ -- the elements of a -- first argument are always preferred to the second, for example in -- 'union' or 'insert'. -- -- Operation comments contain the operation time complexity in -- the Big-O notation (). -- -- Be aware that the 'Functor', 'Traversable' and 'Data' instances -- are the same as for the "Data.Map.Lazy" module, so if they are used -- on strict maps, the resulting maps will be lazy. ----------------------------------------------------------------------------- -- See the notes at the beginning of Data.Map.Base. module Darcs.Data.Map.Strict ( -- * Strictness properties -- $strictness -- * Map type #if !defined(TESTING) Map -- instance Eq,Show,Read #else Map(..) -- instance Eq,Show,Read #endif -- * Operators , (!), (\\) -- * Query , null , size , member , notMember , lookup , findWithDefault , lookupLT , lookupGT , lookupLE , lookupGE -- * Construction , empty , singleton -- ** Insertion , insert , insertWith , insertWithKey , insertLookupWithKey -- ** Delete\/Update , delete , adjust , adjustWithKey , update , updateWithKey , updateLookupWithKey , alter -- * Combine -- ** Union , union , unionWith , unionWithKey , unions , unionsWith -- ** Difference , difference , differenceWith , differenceWithKey -- ** Intersection , intersection , intersectionWith , intersectionWithKey -- ** Universal combining function , mergeWithKey -- * Traversal -- ** Map , map , mapWithKey , traverseWithKey , mapAccum , mapAccumWithKey , mapAccumRWithKey , mapKeys , mapKeysWith , mapKeysMonotonic -- * Folds , foldr , foldl , foldrWithKey , foldlWithKey -- ** Strict folds , foldr' , foldl' , foldrWithKey' , foldlWithKey' -- * Conversion , elems , keys , assocs , keysSet , fromSet -- ** Lists , toList , fromList , fromListWith , fromListWithKey -- ** Ordered lists , toAscList , toDescList , fromAscList , fromAscListWith , fromAscListWithKey , fromDistinctAscList -- * Filter , filter , filterWithKey , partition , partitionWithKey , mapMaybe , mapMaybeWithKey , mapEither , mapEitherWithKey , split , splitLookup -- * Submap , isSubmapOf, isSubmapOfBy , isProperSubmapOf, isProperSubmapOfBy -- * Indexed , lookupIndex , findIndex , elemAt , updateAt , deleteAt -- * Min\/Max , findMin , findMax , deleteMin , deleteMax , deleteFindMin , deleteFindMax , updateMin , updateMax , updateMinWithKey , updateMaxWithKey , minView , maxView , minViewWithKey , maxViewWithKey -- * Debugging , showTree , showTreeWith , valid #if defined(TESTING) -- * Internals , bin , balanced , join , merge #endif ) where import Prelude hiding (lookup,map,filter,foldr,foldl,null) import Darcs.Data.Map.Base hiding ( findWithDefault , singleton , insert , insertWith , insertWithKey , insertLookupWithKey , adjust , adjustWithKey , update , updateWithKey , updateLookupWithKey , alter , unionWith , unionWithKey , unionsWith , differenceWith , differenceWithKey , intersectionWith , intersectionWithKey , mergeWithKey , map , mapWithKey , mapAccum , mapAccumWithKey , mapAccumRWithKey , mapKeysWith , fromSet , fromList , fromListWith , fromListWithKey , fromAscList , fromAscListWith , fromAscListWithKey , fromDistinctAscList , mapMaybe , mapMaybeWithKey , mapEither , mapEitherWithKey , updateAt , updateMin , updateMax , updateMinWithKey , updateMaxWithKey ) import qualified Darcs.Data.Set.Base as Set import Darcs.Data.StrictPair import Data.Bits (shiftL, shiftR) -- Use macros to define strictness of functions. STRICT_x_OF_y -- denotes an y-ary function strict in the x-th parameter. Similarly -- STRICT_x_y_OF_z denotes an z-ary function strict in the x-th and -- y-th parameter. We do not use BangPatterns, because they are not -- in any standard and we want the compilers to be compiled by as many -- compilers as possible. #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined #define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined #define STRICT_1_2_OF_3(fn) fn arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined #define STRICT_2_3_OF_4(fn) fn _ arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined -- $strictness -- -- This module satisfies the following strictness properties: -- -- 1. Key and value arguments are evaluated to WHNF; -- -- 2. Keys and values are evaluated to WHNF before they are stored in -- the map. -- -- Here are some examples that illustrate the first property: -- -- > insertWith (\ new old -> old) k undefined m == undefined -- > delete undefined m == undefined -- -- Here are some examples that illustrate the second property: -- -- > map (\ v -> undefined) m == undefined -- m is not empty -- > mapKeys (\ k -> undefined) m == undefined -- m is not empty {-------------------------------------------------------------------- Query --------------------------------------------------------------------} -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns -- the value at key @k@ or returns default value @def@ -- when the key is not in the map. -- -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' -- See Map.Base.Note: Local 'go' functions and capturing findWithDefault :: Ord k => a -> k -> Map k a -> a findWithDefault def k = def `seq` k `seq` go where go Tip = def go (Bin _ kx x l r) = case compare k kx of LT -> go l GT -> go r EQ -> x #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE findWithDefault #-} #else {-# INLINE findWithDefault #-} #endif {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} -- | /O(1)/. A map with a single element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 singleton :: k -> a -> Map k a singleton k x = x `seq` Bin 1 k x Tip Tip {-# INLINE singleton #-} {-------------------------------------------------------------------- Insertion --------------------------------------------------------------------} -- | /O(log n)/. Insert a new key and value in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value. 'insert' is equivalent to -- @'insertWith' 'const'@. -- -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' -- See Map.Base.Note: Type of local 'go' function insert :: Ord k => k -> a -> Map k a -> Map k a insert = go where go :: Ord k => k -> a -> Map k a -> Map k a STRICT_1_2_OF_3(go) go kx x Tip = singleton kx x go kx x (Bin sz ky y l r) = case compare kx ky of LT -> balanceL ky y (go kx x l) r GT -> balanceR ky y l (go kx x r) EQ -> Bin sz kx x l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #else {-# INLINE insert #-} #endif -- | /O(log n)/. Insert with a function, combining new value and old value. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will -- insert the pair @(key, f new_value old_value)@. -- -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith f = insertWithKey (\_ x' y' -> f x' y') #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertWith #-} #else {-# INLINE insertWith #-} #endif -- | /O(log n)/. Insert with a function, combining key, new value and old value. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will -- insert the pair @(key,f key new_value old_value)@. -- Note that the key passed to f is the same key passed to 'insertWithKey'. -- -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" -- See Map.Base.Note: Type of local 'go' function insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a insertWithKey = go where go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a STRICT_2_3_OF_4(go) go _ kx x Tip = singleton kx x go f kx x (Bin sy ky y l r) = case compare kx ky of LT -> balanceL ky y (go f kx x l) r GT -> balanceR ky y l (go f kx x r) EQ -> let x' = f kx x y in x' `seq` Bin sy kx x' l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertWithKey #-} #else {-# INLINE insertWithKey #-} #endif -- | /O(log n)/. Combines insert operation with old value retrieval. -- The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@). -- -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value -- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) -- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) -- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") -- -- This is how to define @insertLookup@ using @insertLookupWithKey@: -- -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) -- See Map.Base.Note: Type of local 'go' function insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a) insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0 where go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a) STRICT_2_3_OF_4(go) go _ kx x Tip = Nothing :*: singleton kx x go f kx x (Bin sy ky y l r) = case compare kx ky of LT -> let (found :*: l') = go f kx x l in found :*: balanceL ky y l' r GT -> let (found :*: r') = go f kx x r in found :*: balanceR ky y l r' EQ -> let x' = f kx x y in x' `seq` (Just y :*: Bin sy kx x' l r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertLookupWithKey #-} #else {-# INLINE insertLookupWithKey #-} #endif {-------------------------------------------------------------------- Deletion --------------------------------------------------------------------} -- | /O(log n)/. Update a value at a specific key with the result of the provided function. -- When the key is not -- a member of the map, the original map is returned. -- -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > adjust ("new " ++) 7 empty == empty adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a adjust f = adjustWithKey (\_ x -> f x) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjust #-} #else {-# INLINE adjust #-} #endif -- | /O(log n)/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > let f key x = (show key) ++ ":new " ++ x -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > adjustWithKey f 7 empty == empty adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x')) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjustWithKey #-} #else {-# INLINE adjustWithKey #-} #endif -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a update f = updateWithKey (\_ x -> f x) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE update #-} #else {-# INLINE update #-} #endif -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound -- to the new value @y@. -- -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -- See Map.Base.Note: Type of local 'go' function updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a updateWithKey = go where go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a STRICT_2_OF_3(go) go _ _ Tip = Tip go f k(Bin sx kx x l r) = case compare k kx of LT -> balanceR kx x (go f k l) r GT -> balanceL kx x l (go f k r) EQ -> case f kx x of Just x' -> x' `seq` Bin sx kx x' l r Nothing -> glue l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateWithKey #-} #else {-# INLINE updateWithKey #-} #endif -- | /O(log n)/. Lookup and update. See also 'updateWithKey'. -- The function returns changed value, if it is updated. -- Returns the original key value if the map entry is deleted. -- -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")]) -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") -- See Map.Base.Note: Type of local 'go' function updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0 where go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a) STRICT_2_OF_3(go) go _ _ Tip = (Nothing :*: Tip) go f k (Bin sx kx x l r) = case compare k kx of LT -> let (found :*: l') = go f k l in found :*: balanceR kx x l' r GT -> let (found :*: r') = go f k r in found :*: balanceL kx x l r' EQ -> case f kx x of Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r) Nothing -> (Just x :*: glue l r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateLookupWithKey #-} #else {-# INLINE updateLookupWithKey #-} #endif -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in a 'Map'. -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. -- -- > let f _ = Nothing -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > -- > let f _ = Just "c" -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] -- See Map.Base.Note: Type of local 'go' function alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a alter = go where go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a STRICT_2_OF_3(go) go f k Tip = case f Nothing of Nothing -> Tip Just x -> singleton k x go f k (Bin sx kx x l r) = case compare k kx of LT -> balance kx x (go f k l) r GT -> balance kx x l (go f k r) EQ -> case f (Just x) of Just x' -> x' `seq` Bin sx kx x' l r Nothing -> glue l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE alter #-} #else {-# INLINE alter #-} #endif {-------------------------------------------------------------------- Indexing --------------------------------------------------------------------} -- | /O(log n)/. Update the element at /index/. Calls 'error' when an -- invalid index is used. -- -- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")] -- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")] -- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range -- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range -- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range -- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a updateAt f i t = i `seq` case t of Tip -> error "Map.updateAt: index out of range" Bin sx kx x l r -> case compare i sizeL of LT -> balanceR kx x (updateAt f i l) r GT -> balanceL kx x l (updateAt f (i-sizeL-1) r) EQ -> case f kx x of Just x' -> x' `seq` Bin sx kx x' l r Nothing -> glue l r where sizeL = size l {-------------------------------------------------------------------- Minimal, Maximal --------------------------------------------------------------------} -- | /O(log n)/. Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMin :: (a -> Maybe a) -> Map k a -> Map k a updateMin f m = updateMinWithKey (\_ x -> f x) m -- | /O(log n)/. Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMax :: (a -> Maybe a) -> Map k a -> Map k a updateMax f m = updateMaxWithKey (\_ x -> f x) m -- | /O(log n)/. Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a updateMinWithKey _ Tip = Tip updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of Nothing -> r Just x' -> x' `seq` Bin sx kx x' Tip r updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r -- | /O(log n)/. Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a updateMaxWithKey _ Tip = Tip updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of Nothing -> l Just x' -> x' `seq` Bin sx kx x' l Tip updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r) {-------------------------------------------------------------------- Union. --------------------------------------------------------------------} -- | The union of a list of maps, with a combining operation: -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). -- -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a unionsWith f ts = foldlStrict (unionWith f) empty ts #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unionsWith #-} #endif {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------} -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a unionWith f m1 m2 = unionWithKey (\_ x y -> f x y) m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unionWith #-} #endif -- | /O(n+m)/. -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a unionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) id id t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unionWithKey #-} #endif {-------------------------------------------------------------------- Difference --------------------------------------------------------------------} -- | /O(n+m)/. Difference with a combining function. -- When two equal keys are -- encountered, the combining function is applied to the values of these keys. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) -- > == singleton 3 "b:B" differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a differenceWith f m1 m2 = differenceWithKey (\_ x y -> f x y) m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE differenceWith #-} #endif -- | /O(n+m)/. Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) -- > == singleton 3 "3:b|B" differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a differenceWithKey f t1 t2 = mergeWithKey f id (const Tip) t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE differenceWithKey #-} #endif {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------} -- | /O(n+m)/. Intersection with a combining function. The implementation uses -- an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c intersectionWith f m1 m2 = intersectionWithKey (\_ x y -> f x y) m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersectionWith #-} #endif -- | /O(n+m)/. Intersection with a combining function. The implementation uses -- an efficient /hedge/ algorithm comparable with /hedge-union/. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c intersectionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) (const Tip) (const Tip) t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersectionWithKey #-} #endif {-------------------------------------------------------------------- MergeWithKey --------------------------------------------------------------------} -- | /O(n+m)/. A high-performance universal combining function. This function -- is used to define 'unionWith', 'unionWithKey', 'differenceWith', -- 'differenceWithKey', 'intersectionWith', 'intersectionWithKey' and can be -- used to define other custom combine functions. -- -- Please make sure you know what is going on when using 'mergeWithKey', -- otherwise you can be surprised by unexpected code growth or even -- corruption of the data structure. -- -- When 'mergeWithKey' is given three arguments, it is inlined to the call -- site. You should therefore use 'mergeWithKey' only to define your custom -- combining functions. For example, you could define 'unionWithKey', -- 'differenceWithKey' and 'intersectionWithKey' as -- -- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 -- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 -- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 -- -- When calling @'mergeWithKey' combine only1 only2@, a function combining two -- 'IntMap's is created, such that -- -- * if a key is present in both maps, it is passed with both corresponding -- values to the @combine@ function. Depending on the result, the key is either -- present in the result with specified value, or is left out; -- -- * a nonempty subtree present only in the first map is passed to @only1@ and -- the output is added to the result; -- -- * a nonempty subtree present only in the second map is passed to @only2@ and -- the output is added to the result. -- -- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. -- The values can be modified arbitrarily. Most common variants of @only1@ and -- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or -- @'filterWithKey' f@ could be used for any @f@. mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c mergeWithKey f g1 g2 = go where go Tip t2 = g2 t2 go t1 Tip = g1 t1 go t1 t2 = hedgeMerge NothingS NothingS t1 t2 hedgeMerge _ _ t1 Tip = g1 t1 hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ join kx x (filterGt blo l) (filterLt bhi r) hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2) (found, trim_t2) = trimLookupLo kx bhi t2 r' = hedgeMerge bmi bhi r trim_t2 in case found of Nothing -> case g1 (singleton kx x) of Tip -> merge l' r' (Bin _ _ x' Tip Tip) -> join kx x' l' r' _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)" Just x2 -> case f kx x x2 of Nothing -> merge l' r' Just x' -> x' `seq` join kx x' l' r' where bmi = JustS kx {-# INLINE mergeWithKey #-} {-------------------------------------------------------------------- Filter and partition --------------------------------------------------------------------} -- | /O(n)/. Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b mapMaybe f = mapMaybeWithKey (\_ x -> f x) -- | /O(n)/. Map keys\/values and collect the 'Just' results. -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b mapMaybeWithKey _ Tip = Tip mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of Just y -> y `seq` join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -- -- > let f a = if a < "c" then Left a else Right a -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) -- > -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c) mapEither f m = mapEitherWithKey (\_ x -> f x) m -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. -- -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) -- > -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c) mapEitherWithKey f0 t0 = toPair $ go f0 t0 where go _ Tip = (Tip :*: Tip) go f (Bin _ kx x l r) = case f kx x of Left y -> y `seq` (join kx y l1 r1 :*: merge l2 r2) Right z -> z `seq` (merge l1 r1 :*: join kx z l2 r2) where (l1 :*: l2) = go f l (r1 :*: r2) = go f r {-------------------------------------------------------------------- Mapping --------------------------------------------------------------------} -- | /O(n)/. Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] map :: (a -> b) -> Map k a -> Map k b map _ Tip = Tip map f (Bin sx kx x l r) = let x' = f x in x' `seq` Bin sx kx x' (map f l) (map f r) -- | /O(n)/. Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] mapWithKey :: (k -> a -> b) -> Map k a -> Map k b mapWithKey _ Tip = Tip mapWithKey f (Bin sx kx x l r) = let x' = f kx x in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r) -- | /O(n)/. The function 'mapAccum' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a b = (a ++ b, b ++ "X") -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumWithKey f a t = mapAccumL f a t -- | /O(n)/. The function 'mapAccumL' threads an accumulating -- argument through the map in ascending order of keys. mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumL _ a Tip = (a,Tip) mapAccumL f a (Bin sx kx x l r) = let (a1,l') = mapAccumL f a l (a2,x') = f a1 kx x (a3,r') = mapAccumL f a2 r in x' `seq` (a3,Bin sx kx x' l' r') -- | /O(n)/. The function 'mapAccumR' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip) mapAccumRWithKey f a (Bin sx kx x l r) = let (a1,r') = mapAccumRWithKey f a r (a2,x') = f a1 kx x (a3,l') = mapAccumRWithKey f a2 l in x' `seq` (a3,Bin sx kx x' l' r') -- | /O(n*log n)/. -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct -- keys to the same new key. In this case the associated values will be -- combined using @c@. -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE mapKeysWith #-} #endif {-------------------------------------------------------------------- Conversions --------------------------------------------------------------------} -- | /O(n)/. Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a fromSet _ Set.Tip = Tip fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r) {-------------------------------------------------------------------- Lists use [foldlStrict] to reduce demand on the control-stack --------------------------------------------------------------------} -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. -- If the list contains more than one value for the same key, the last value -- for the key is retained. -- -- If the keys of the list are ordered, linear-time implementation is used, -- with the performance equal to 'fromDistinctAscList'. -- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] -- For some reason, when 'singleton' is used in fromList or in -- create, it is not inlined, so we inline it manually. fromList :: Ord k => [(k,a)] -> Map k a fromList [] = Tip fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0 | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 where not_ordered _ [] = False not_ordered kx ((ky,_) : _) = kx >= ky {-# INLINE not_ordered #-} fromList' t0 xs = foldlStrict ins t0 xs where ins t (k,x) = insert k x t STRICT_1_OF_3(go) go _ t [] = t go _ t [(kx, x)] = x `seq` insertMax kx x t go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs | otherwise = case create s xss of (r, ys, []) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys (r, _, ys) -> x `seq` fromList' (join kx x l r) ys -- The create is returning a triple (tree, xs, ys). Both xs and ys -- represent not yet processed elements and only one of them can be nonempty. -- If ys is nonempty, the keys in ys are not ordered with respect to tree -- and must be inserted using fromList'. Otherwise the keys have been -- ordered so far. STRICT_1_OF_2(create) create _ [] = (Tip, [], []) create s xs@(xp : xss) | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss) | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, []) | otherwise = case create (s `shiftR` 1) xs of res@(_, [], _) -> res (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs) (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys) | otherwise -> case create (s `shiftR` 1) yss of (r, zs, ws) -> y `seq` (join ky y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] -- > fromListWith (++) [] == empty fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromListWith #-} #endif -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. -- -- > let f k a1 a2 = (show k) ++ a1 ++ a2 -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] -- > fromListWithKey f [] == empty fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromListWithKey f xs = foldlStrict ins empty xs where ins t (k,x) = insertWithKey f k x t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromListWithKey #-} #endif {-------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time. Note that if [xs] is ascending that: fromAscList xs == fromList xs fromAscListWith f xs == fromListWith f xs --------------------------------------------------------------------} -- | /O(n)/. Build a map from an ascending list in linear time. -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False fromAscList :: Eq k => [(k,a)] -> Map k a fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromAscList #-} #endif -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] -- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromAscListWith #-} #endif -- | /O(n)/. Build a map from an ascending list in linear time with a -- combining function for equal keys. -- /The precondition (input list is ascending) is not checked./ -- -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] -- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs) where -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] combineEq _ xs' = case xs' of [] -> [] [x] -> [x] (x:xx) -> combineEq' x xx combineEq' z [] = [z] combineEq' z@(kz,zz) (x@(kx,xx):xs') | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs' | otherwise = z:combineEq' x xs' #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromAscListWithKey #-} #endif -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. -- /The precondition is not checked./ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False -- For some reason, when 'singleton' is used in fromDistinctAscList or in -- create, it is not inlined, so we inline it manually. fromDistinctAscList :: [(k,a)] -> Map k a fromDistinctAscList [] = Tip fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 where STRICT_1_OF_3(go) go _ t [] = t go s l ((kx, x) : xs) = case create s xs of (r, ys) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys STRICT_1_OF_2(create) create _ [] = (Tip, []) create s xs@(x' : xs') | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs') | otherwise = case create (s `shiftR` 1) xs of res@(_, []) -> res (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of (r, zs) -> y `seq` (join ky y l r, zs) darcs-2.10.2/containers-0.5.2.1/Darcs/Data/Set/0000755000175000017500000000000012620122474022326 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/containers-0.5.2.1/Darcs/Data/Set/Base.hs0000644000175000017500000015261612620122474023547 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Set.Base -- Copyright : (c) Daan Leijen 2002 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- An efficient implementation of sets. -- -- These modules are intended to be imported qualified, to avoid name -- clashes with Prelude functions, e.g. -- -- > import Data.Set (Set) -- > import qualified Data.Set as Set -- -- The implementation of 'Set' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -- -- * Stephen Adams, \"/Efficient sets: a balancing act/\", -- Journal of Functional Programming 3(4):553-562, October 1993, -- . -- -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973. -- -- Note that the implementation is /left-biased/ -- the elements of a -- first argument are always preferred to the second, for example in -- 'union' or 'insert'. Of course, left-biasing can only be observed -- when equality is an equivalence relation instead of structural -- equality. ----------------------------------------------------------------------------- -- [Note: Using INLINABLE] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- It is crucial to the performance that the functions specialize on the Ord -- type when possible. GHC 7.0 and higher does this by itself when it sees th -- unfolding of a function -- that is why all public functions are marked -- INLINABLE (that exposes the unfolding). -- [Note: Using INLINE] -- ~~~~~~~~~~~~~~~~~~~~ -- For other compilers and GHC pre 7.0, we mark some of the functions INLINE. -- We mark the functions that just navigate down the tree (lookup, insert, -- delete and similar). That navigation code gets inlined and thus specialized -- when possible. There is a price to pay -- code growth. The code INLINED is -- therefore only the tree navigation, all the real work (rebalancing) is not -- INLINED by using a NOINLINE. -- -- All methods marked INLINE have to be nonrecursive -- a 'go' function doing -- the real work is provided. -- [Note: Type of local 'go' function] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- If the local 'go' function uses an Ord class, it sometimes heap-allocates -- the Ord dictionary when the 'go' function does not have explicit type. -- In that case we give 'go' explicit type. But this slightly decrease -- performance, as the resulting 'go' function can float out to top level. -- [Note: Local 'go' functions and capturing] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- As opposed to IntSet, when 'go' function captures an argument, increased -- heap-allocation can occur: sometimes in a polymorphic function, the 'go' -- floats out of its enclosing function and then it heap-allocates the -- dictionary and the argument. Maybe it floats out too late and strictness -- analyzer cannot see that these could be passed on stack. -- -- For example, change 'member' so that its local 'go' function is not passing -- argument x and then look at the resulting code for hedgeInt. -- [Note: Order of constructors] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The order of constructors of Set matters when considering performance. -- Currently in GHC 7.0, when type has 2 constructors, a forward conditional -- jump is made when successfully matching second constructor. Successful match -- of first constructor results in the forward jump not taken. -- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip -- improves the benchmark by up to 10% on x86. module Darcs.Data.Set.Base ( -- * Set type Set(..) -- instance Eq,Ord,Show,Read,Data,Typeable -- * Operators , (\\) -- * Query , null , size , member , notMember , lookupLT , lookupGT , lookupLE , lookupGE , isSubsetOf , isProperSubsetOf -- * Construction , empty , singleton , insert , delete -- * Combine , union , unions , difference , intersection -- * Filter , filter , partition , split , splitMember -- * Indexed , lookupIndex , findIndex , elemAt , deleteAt -- * Map , map , mapMonotonic -- * Folds , foldr , foldl -- ** Strict folds , foldr' , foldl' -- ** Legacy folds , fold -- * Min\/Max , findMin , findMax , deleteMin , deleteMax , deleteFindMin , deleteFindMax , maxView , minView -- * Conversion -- ** List , elems , toList , fromList -- ** Ordered list , toAscList , toDescList , fromAscList , fromDistinctAscList -- * Debugging , showTree , showTreeWith , valid -- Internals (for testing) , bin , balanced , join , merge ) where import Prelude hiding (filter,foldl,foldr,null,map) import qualified Data.List as List import Data.Bits (shiftL, shiftR) import Data.Monoid (Monoid(..)) import qualified Data.Foldable as Foldable import Data.Typeable import Control.DeepSeq (NFData(rnf)) import Darcs.Data.StrictPair #if __GLASGOW_HASKELL__ import GHC.Exts ( build ) import Text.Read import Data.Data #endif -- Use macros to define strictness of functions. -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter. -- We do not use BangPatterns, because they are not in any standard and we -- want the compilers to be compiled by as many compilers as possible. #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined #define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined {-------------------------------------------------------------------- Operators --------------------------------------------------------------------} infixl 9 \\ -- -- | /O(n+m)/. See 'difference'. (\\) :: Ord a => Set a -> Set a -> Set a m1 \\ m2 = difference m1 m2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE (\\) #-} #endif {-------------------------------------------------------------------- Sets are size balanced trees --------------------------------------------------------------------} -- | A set of values @a@. -- See Note: Order of constructors data Set a = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a) | Tip type Size = Int instance Ord a => Monoid (Set a) where mempty = empty mappend = union mconcat = unions instance Foldable.Foldable Set where fold Tip = mempty fold (Bin _ k l r) = Foldable.fold l `mappend` k `mappend` Foldable.fold r foldr = foldr foldl = foldl foldMap _ Tip = mempty foldMap f (Bin _ k l r) = Foldable.foldMap f l `mappend` f k `mappend` Foldable.foldMap f r #if __GLASGOW_HASKELL__ {-------------------------------------------------------------------- A Data instance --------------------------------------------------------------------} -- This instance preserves data abstraction at the cost of inefficiency. -- We provide limited reflection services for the sake of data abstraction. instance (Data a, Ord a) => Data (Set a) where gfoldl f z set = z fromList `f` (toList set) toConstr _ = fromListConstr gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = setDataType dataCast1 f = gcast1 f fromListConstr :: Constr fromListConstr = mkConstr setDataType "fromList" [] Prefix setDataType :: DataType setDataType = mkDataType "Data.Set.Base.Set" [fromListConstr] #endif {-------------------------------------------------------------------- Query --------------------------------------------------------------------} -- | /O(1)/. Is this the empty set? null :: Set a -> Bool null Tip = True null (Bin {}) = False {-# INLINE null #-} -- | /O(1)/. The number of elements in the set. size :: Set a -> Int size Tip = 0 size (Bin sz _ _ _) = sz {-# INLINE size #-} -- | /O(log n)/. Is the element in the set? member :: Ord a => a -> Set a -> Bool member = go where STRICT_1_OF_2(go) go _ Tip = False go x (Bin _ y l r) = case compare x y of LT -> go x l GT -> go x r EQ -> True #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE member #-} #else {-# INLINE member #-} #endif -- | /O(log n)/. Is the element not in the set? notMember :: Ord a => a -> Set a -> Bool notMember a t = not $ member a t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE notMember #-} #else {-# INLINE notMember #-} #endif -- | /O(log n)/. Find largest element smaller than the given one. -- -- > lookupLT 3 (fromList [3, 5]) == Nothing -- > lookupLT 5 (fromList [3, 5]) == Just 3 lookupLT :: Ord a => a -> Set a -> Maybe a lookupLT = goNothing where STRICT_1_OF_2(goNothing) goNothing _ Tip = Nothing goNothing x (Bin _ y l r) | x <= y = goNothing x l | otherwise = goJust x y r STRICT_1_OF_3(goJust) goJust _ best Tip = Just best goJust x best (Bin _ y l r) | x <= y = goJust x best l | otherwise = goJust x y r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupLT #-} #else {-# INLINE lookupLT #-} #endif -- | /O(log n)/. Find smallest element greater than the given one. -- -- > lookupGT 4 (fromList [3, 5]) == Just 5 -- > lookupGT 5 (fromList [3, 5]) == Nothing lookupGT :: Ord a => a -> Set a -> Maybe a lookupGT = goNothing where STRICT_1_OF_2(goNothing) goNothing _ Tip = Nothing goNothing x (Bin _ y l r) | x < y = goJust x y l | otherwise = goNothing x r STRICT_1_OF_3(goJust) goJust _ best Tip = Just best goJust x best (Bin _ y l r) | x < y = goJust x y l | otherwise = goJust x best r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupGT #-} #else {-# INLINE lookupGT #-} #endif -- | /O(log n)/. Find largest element smaller or equal to the given one. -- -- > lookupLE 2 (fromList [3, 5]) == Nothing -- > lookupLE 4 (fromList [3, 5]) == Just 3 -- > lookupLE 5 (fromList [3, 5]) == Just 5 lookupLE :: Ord a => a -> Set a -> Maybe a lookupLE = goNothing where STRICT_1_OF_2(goNothing) goNothing _ Tip = Nothing goNothing x (Bin _ y l r) = case compare x y of LT -> goNothing x l EQ -> Just y GT -> goJust x y r STRICT_1_OF_3(goJust) goJust _ best Tip = Just best goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x best l EQ -> Just y GT -> goJust x y r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupLE #-} #else {-# INLINE lookupLE #-} #endif -- | /O(log n)/. Find smallest element greater or equal to the given one. -- -- > lookupGE 3 (fromList [3, 5]) == Just 3 -- > lookupGE 4 (fromList [3, 5]) == Just 5 -- > lookupGE 6 (fromList [3, 5]) == Nothing lookupGE :: Ord a => a -> Set a -> Maybe a lookupGE = goNothing where STRICT_1_OF_2(goNothing) goNothing _ Tip = Nothing goNothing x (Bin _ y l r) = case compare x y of LT -> goJust x y l EQ -> Just y GT -> goNothing x r STRICT_1_OF_3(goJust) goJust _ best Tip = Just best goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x y l EQ -> Just y GT -> goJust x best r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupGE #-} #else {-# INLINE lookupGE #-} #endif {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} -- | /O(1)/. The empty set. empty :: Set a empty = Tip {-# INLINE empty #-} -- | /O(1)/. Create a singleton set. singleton :: a -> Set a singleton x = Bin 1 x Tip Tip {-# INLINE singleton #-} {-------------------------------------------------------------------- Insertion, Deletion --------------------------------------------------------------------} -- | /O(log n)/. Insert an element in a set. -- If the set already contains an element equal to the given value, -- it is replaced with the new value. -- See Note: Type of local 'go' function insert :: Ord a => a -> Set a -> Set a insert = go where go :: Ord a => a -> Set a -> Set a STRICT_1_OF_2(go) go x Tip = singleton x go x (Bin sz y l r) = case compare x y of LT -> balanceL y (go x l) r GT -> balanceR y l (go x r) EQ -> Bin sz x l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #else {-# INLINE insert #-} #endif -- Insert an element to the set only if it is not in the set. -- Used by `union`. -- See Note: Type of local 'go' function insertR :: Ord a => a -> Set a -> Set a insertR = go where go :: Ord a => a -> Set a -> Set a STRICT_1_OF_2(go) go x Tip = singleton x go x t@(Bin _ y l r) = case compare x y of LT -> balanceL y (go x l) r GT -> balanceR y l (go x r) EQ -> t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertR #-} #else {-# INLINE insertR #-} #endif -- | /O(log n)/. Delete an element from a set. -- See Note: Type of local 'go' function delete :: Ord a => a -> Set a -> Set a delete = go where go :: Ord a => a -> Set a -> Set a STRICT_1_OF_2(go) go _ Tip = Tip go x (Bin _ y l r) = case compare x y of LT -> balanceR y (go x l) r GT -> balanceL y l (go x r) EQ -> glue l r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE delete #-} #else {-# INLINE delete #-} #endif {-------------------------------------------------------------------- Subset --------------------------------------------------------------------} -- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). isProperSubsetOf :: Ord a => Set a -> Set a -> Bool isProperSubsetOf s1 s2 = (size s1 < size s2) && (isSubsetOf s1 s2) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE isProperSubsetOf #-} #endif -- | /O(n+m)/. Is this a subset? -- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. isSubsetOf :: Ord a => Set a -> Set a -> Bool isSubsetOf t1 t2 = (size t1 <= size t2) && (isSubsetOfX t1 t2) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE isSubsetOf #-} #endif isSubsetOfX :: Ord a => Set a -> Set a -> Bool isSubsetOfX Tip _ = True isSubsetOfX _ Tip = False isSubsetOfX (Bin _ x l r) t = found && isSubsetOfX l lt && isSubsetOfX r gt where (lt,found,gt) = splitMember x t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE isSubsetOfX #-} #endif {-------------------------------------------------------------------- Minimal, Maximal --------------------------------------------------------------------} -- | /O(log n)/. The minimal element of a set. findMin :: Set a -> a findMin (Bin _ x Tip _) = x findMin (Bin _ _ l _) = findMin l findMin Tip = error "Set.findMin: empty set has no minimal element" -- | /O(log n)/. The maximal element of a set. findMax :: Set a -> a findMax (Bin _ x _ Tip) = x findMax (Bin _ _ _ r) = findMax r findMax Tip = error "Set.findMax: empty set has no maximal element" -- | /O(log n)/. Delete the minimal element. Returns an empty set if the set is empty. deleteMin :: Set a -> Set a deleteMin (Bin _ _ Tip r) = r deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r deleteMin Tip = Tip -- | /O(log n)/. Delete the maximal element. Returns an empty set if the set is empty. deleteMax :: Set a -> Set a deleteMax (Bin _ _ l Tip) = l deleteMax (Bin _ x l r) = balanceL x l (deleteMax r) deleteMax Tip = Tip {-------------------------------------------------------------------- Union. --------------------------------------------------------------------} -- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@). unions :: Ord a => [Set a] -> Set a unions = foldlStrict union empty #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unions #-} #endif -- | /O(n+m)/. The union of two sets, preferring the first set when -- equal elements are encountered. -- The implementation uses the efficient /hedge-union/ algorithm. union :: Ord a => Set a -> Set a -> Set a union Tip t2 = t2 union t1 Tip = t1 union t1 t2 = hedgeUnion NothingS NothingS t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE union #-} #endif hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a hedgeUnion _ _ t1 Tip = t1 hedgeUnion blo bhi Tip (Bin _ x l r) = join x (filterGt blo l) (filterLt bhi r) hedgeUnion _ _ t1 (Bin _ x Tip Tip) = insertR x t1 -- According to benchmarks, this special case increases -- performance up to 30%. It does not help in difference or intersection. hedgeUnion blo bhi (Bin _ x l r) t2 = join x (hedgeUnion blo bmi l (trim blo bmi t2)) (hedgeUnion bmi bhi r (trim bmi bhi t2)) where bmi = JustS x #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE hedgeUnion #-} #endif {-------------------------------------------------------------------- Difference --------------------------------------------------------------------} -- | /O(n+m)/. Difference of two sets. -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. difference :: Ord a => Set a -> Set a -> Set a difference Tip _ = Tip difference t1 Tip = t1 difference t1 t2 = hedgeDiff NothingS NothingS t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE difference #-} #endif hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a hedgeDiff _ _ Tip _ = Tip hedgeDiff blo bhi (Bin _ x l r) Tip = join x (filterGt blo l) (filterLt bhi r) hedgeDiff blo bhi t (Bin _ x l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l) (hedgeDiff bmi bhi (trim bmi bhi t) r) where bmi = JustS x #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE hedgeDiff #-} #endif {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------} -- | /O(n+m)/. The intersection of two sets. The implementation uses an -- efficient /hedge/ algorithm comparable with /hedge-union/. Elements of the -- result come from the first set, so for example -- -- > import qualified Data.Set as S -- > data AB = A | B deriving Show -- > instance Ord AB where compare _ _ = EQ -- > instance Eq AB where _ == _ = True -- > main = print (S.singleton A `S.intersection` S.singleton B, -- > S.singleton B `S.intersection` S.singleton A) -- -- prints @(fromList [A],fromList [B])@. intersection :: Ord a => Set a -> Set a -> Set a intersection Tip _ = Tip intersection _ Tip = Tip intersection t1 t2 = hedgeInt NothingS NothingS t1 t2 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersection #-} #endif hedgeInt :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a hedgeInt _ _ _ Tip = Tip hedgeInt _ _ Tip _ = Tip hedgeInt blo bhi (Bin _ x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2) r' = hedgeInt bmi bhi r (trim bmi bhi t2) in if x `member` t2 then join x l' r' else merge l' r' where bmi = JustS x #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE hedgeInt #-} #endif {-------------------------------------------------------------------- Filter and partition --------------------------------------------------------------------} -- | /O(n)/. Filter all elements that satisfy the predicate. filter :: (a -> Bool) -> Set a -> Set a filter _ Tip = Tip filter p (Bin _ x l r) | p x = join x (filter p l) (filter p r) | otherwise = merge (filter p l) (filter p r) -- | /O(n)/. Partition the set into two sets, one with all elements that satisfy -- the predicate and one with all elements that don't satisfy the predicate. -- See also 'split'. partition :: (a -> Bool) -> Set a -> (Set a,Set a) partition p0 t0 = toPair $ go p0 t0 where go _ Tip = (Tip :*: Tip) go p (Bin _ x l r) = case (go p l, go p r) of ((l1 :*: l2), (r1 :*: r2)) | p x -> join x l1 r1 :*: merge l2 r2 | otherwise -> merge l1 r1 :*: join x l2 r2 {---------------------------------------------------------------------- Map ----------------------------------------------------------------------} -- | /O(n*log n)/. -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. -- -- It's worth noting that the size of the result may be smaller if, -- for some @(x,y)@, @x \/= y && f x == f y@ map :: Ord b => (a->b) -> Set a -> Set b map f = fromList . List.map f . toList #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE map #-} #endif -- | /O(n)/. The -- -- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic. -- /The precondition is not checked./ -- Semi-formally, we have: -- -- > and [x < y ==> f x < f y | x <- ls, y <- ls] -- > ==> mapMonotonic f s == map f s -- > where ls = toList s mapMonotonic :: (a->b) -> Set a -> Set b mapMonotonic _ Tip = Tip mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r) {-------------------------------------------------------------------- Fold --------------------------------------------------------------------} -- | /O(n)/. Fold the elements in the set using the given right-associative -- binary operator. This function is an equivalent of 'foldr' and is present -- for compatibility only. -- -- /Please note that fold will be deprecated in the future and removed./ fold :: (a -> b -> b) -> b -> Set a -> b fold = foldr {-# INLINE fold #-} -- | /O(n)/. Fold the elements in the set using the given right-associative -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@. -- -- For example, -- -- > toAscList set = foldr (:) [] set foldr :: (a -> b -> b) -> b -> Set a -> b foldr f z = go z where go z' Tip = z' go z' (Bin _ x l r) = go (f x (go z' r)) l {-# INLINE foldr #-} -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldr' :: (a -> b -> b) -> b -> Set a -> b foldr' f z = go z where STRICT_1_OF_2(go) go z' Tip = z' go z' (Bin _ x l r) = go (f x (go z' r)) l {-# INLINE foldr' #-} -- | /O(n)/. Fold the elements in the set using the given left-associative -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@. -- -- For example, -- -- > toDescList set = foldl (flip (:)) [] set foldl :: (a -> b -> a) -> a -> Set b -> a foldl f z = go z where go z' Tip = z' go z' (Bin _ x l r) = go (f (go z' l) x) r {-# INLINE foldl #-} -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldl' :: (a -> b -> a) -> a -> Set b -> a foldl' f z = go z where STRICT_1_OF_2(go) go z' Tip = z' go z' (Bin _ x l r) = go (f (go z' l) x) r {-# INLINE foldl' #-} {-------------------------------------------------------------------- List variations --------------------------------------------------------------------} -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order. -- Subject to list fusion. elems :: Set a -> [a] elems = toAscList {-------------------------------------------------------------------- Lists --------------------------------------------------------------------} -- | /O(n)/. Convert the set to a list of elements. Subject to list fusion. toList :: Set a -> [a] toList = toAscList -- | /O(n)/. Convert the set to an ascending list of elements. Subject to list fusion. toAscList :: Set a -> [a] toAscList = foldr (:) [] -- | /O(n)/. Convert the set to a descending list of elements. Subject to list -- fusion. toDescList :: Set a -> [a] toDescList = foldl (flip (:)) [] -- List fusion for the list generating functions. #if __GLASGOW_HASKELL__ -- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion. -- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude. foldrFB :: (a -> b -> b) -> b -> Set a -> b foldrFB = foldr {-# INLINE[0] foldrFB #-} foldlFB :: (a -> b -> a) -> a -> Set b -> a foldlFB = foldl {-# INLINE[0] foldlFB #-} -- Inline elems and toList, so that we need to fuse only toAscList. {-# INLINE elems #-} {-# INLINE toList #-} -- The fusion is enabled up to phase 2 included. If it does not succeed, -- convert in phase 1 the expanded to{Asc,Desc}List calls back to -- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in -- a list fusion, otherwise it would go away in phase 1), and let compiler do -- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it -- before phase 0, otherwise the fusion rules would not fire at all. {-# NOINLINE[0] toAscList #-} {-# NOINLINE[0] toDescList #-} {-# RULES "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-} {-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-} {-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-} {-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-} #endif -- | /O(n*log n)/. Create a set from a list of elements. -- -- If the elemens are ordered, linear-time implementation is used, -- with the performance equal to 'fromDistinctAscList'. -- For some reason, when 'singleton' is used in fromList or in -- create, it is not inlined, so we inline it manually. fromList :: Ord a => [a] -> Set a fromList [] = Tip fromList [x] = Bin 1 x Tip Tip fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0 | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0 where not_ordered _ [] = False not_ordered x (y : _) = x >= y {-# INLINE not_ordered #-} fromList' t0 xs = foldlStrict ins t0 xs where ins t x = insert x t STRICT_1_OF_3(go) go _ t [] = t go _ t [x] = insertMax x t go s l xs@(x : xss) | not_ordered x xss = fromList' l xs | otherwise = case create s xss of (r, ys, []) -> go (s `shiftL` 1) (join x l r) ys (r, _, ys) -> fromList' (join x l r) ys -- The create is returning a triple (tree, xs, ys). Both xs and ys -- represent not yet processed elements and only one of them can be nonempty. -- If ys is nonempty, the keys in ys are not ordered with respect to tree -- and must be inserted using fromList'. Otherwise the keys have been -- ordered so far. STRICT_1_OF_2(create) create _ [] = (Tip, [], []) create s xs@(x : xss) | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss) else (Bin 1 x Tip Tip, xss, []) | otherwise = case create (s `shiftR` 1) xs of res@(_, [], _) -> res (l, [y], zs) -> (insertMax y l, [], zs) (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys) | otherwise -> case create (s `shiftR` 1) yss of (r, zs, ws) -> (join y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif {-------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time. Note that if [xs] is ascending that: fromAscList xs == fromList xs --------------------------------------------------------------------} -- | /O(n)/. Build a set from an ascending list in linear time. -- /The precondition (input list is ascending) is not checked./ fromAscList :: Eq a => [a] -> Set a fromAscList xs = fromDistinctAscList (combineEq xs) where -- [combineEq xs] combines equal elements with [const] in an ordered list [xs] combineEq xs' = case xs' of [] -> [] [x] -> [x] (x:xx) -> combineEq' x xx combineEq' z [] = [z] combineEq' z (x:xs') | z==x = combineEq' z xs' | otherwise = z:combineEq' x xs' #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromAscList #-} #endif -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. -- /The precondition (input list is strictly ascending) is not checked./ -- For some reason, when 'singleton' is used in fromDistinctAscList or in -- create, it is not inlined, so we inline it manually. fromDistinctAscList :: [a] -> Set a fromDistinctAscList [] = Tip fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0 where STRICT_1_OF_3(go) go _ t [] = t go s l (x : xs) = case create s xs of (r, ys) -> go (s `shiftL` 1) (join x l r) ys STRICT_1_OF_2(create) create _ [] = (Tip, []) create s xs@(x : xs') | s == 1 = (Bin 1 x Tip Tip, xs') | otherwise = case create (s `shiftR` 1) xs of res@(_, []) -> res (l, y:ys) -> case create (s `shiftR` 1) ys of (r, zs) -> (join y l r, zs) {-------------------------------------------------------------------- Eq converts the set to a list. In a lazy setting, this actually seems one of the faster methods to compare two trees and it is certainly the simplest :-) --------------------------------------------------------------------} instance Eq a => Eq (Set a) where t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) {-------------------------------------------------------------------- Ord --------------------------------------------------------------------} instance Ord a => Ord (Set a) where compare s1 s2 = compare (toAscList s1) (toAscList s2) {-------------------------------------------------------------------- Show --------------------------------------------------------------------} instance Show a => Show (Set a) where showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) {-------------------------------------------------------------------- Read --------------------------------------------------------------------} instance (Read a, Ord a) => Read (Set a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec return (fromList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \ r -> do ("fromList",s) <- lex r (xs,t) <- reads s return (fromList xs,t) #endif {-------------------------------------------------------------------- Typeable/Data --------------------------------------------------------------------} #include "Typeable.h" INSTANCE_TYPEABLE1(Set,setTc,"Set") {-------------------------------------------------------------------- NFData --------------------------------------------------------------------} instance NFData a => NFData (Set a) where rnf Tip = () rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r {-------------------------------------------------------------------- Utility functions that return sub-ranges of the original tree. Some functions take a `Maybe value` as an argument to allow comparisons against infinite values. These are called `blow` (Nothing is -\infty) and `bhigh` (here Nothing is +\infty). We use MaybeS value, which is a Maybe strict in the Just case. [trim blow bhigh t] A tree that is either empty or where [x > blow] and [x < bhigh] for the value [x] of the root. [filterGt blow t] A tree where for all values [k]. [k > blow] [filterLt bhigh t] A tree where for all values [k]. [k < bhigh] [split k t] Returns two trees [l] and [r] where all values in [l] are <[k] and all keys in [r] are >[k]. [splitMember k t] Just like [split] but also returns whether [k] was found in the tree. --------------------------------------------------------------------} data MaybeS a = NothingS | JustS !a {-------------------------------------------------------------------- [trim blo bhi t] trims away all subtrees that surely contain no values between the range [blo] to [bhi]. The returned tree is either empty or the key of the root is between @blo@ and @bhi@. --------------------------------------------------------------------} trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a trim NothingS NothingS t = t trim (JustS lx) NothingS t = greater lx t where greater lo (Bin _ x _ r) | x <= lo = greater lo r greater _ t' = t' trim NothingS (JustS hx) t = lesser hx t where lesser hi (Bin _ x l _) | x >= hi = lesser hi l lesser _ t' = t' trim (JustS lx) (JustS hx) t = middle lx hx t where middle lo hi (Bin _ x _ r) | x <= lo = middle lo hi r middle lo hi (Bin _ x l _) | x >= hi = middle lo hi l middle _ _ t' = t' #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE trim #-} #endif {-------------------------------------------------------------------- [filterGt b t] filter all values >[b] from tree [t] [filterLt b t] filter all values <[b] from tree [t] --------------------------------------------------------------------} filterGt :: Ord a => MaybeS a -> Set a -> Set a filterGt NothingS t = t filterGt (JustS b) t = filter' b t where filter' _ Tip = Tip filter' b' (Bin _ x l r) = case compare b' x of LT -> join x (filter' b' l) r EQ -> r GT -> filter' b' r #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE filterGt #-} #endif filterLt :: Ord a => MaybeS a -> Set a -> Set a filterLt NothingS t = t filterLt (JustS b) t = filter' b t where filter' _ Tip = Tip filter' b' (Bin _ x l r) = case compare x b' of LT -> join x l (filter' b' r) EQ -> l GT -> filter' b' l #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE filterLt #-} #endif {-------------------------------------------------------------------- Split --------------------------------------------------------------------} -- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@ -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ -- comprises the elements of @set@ greater than @x@. split :: Ord a => a -> Set a -> (Set a,Set a) split x0 t0 = toPair $ go x0 t0 where go _ Tip = (Tip :*: Tip) go x (Bin _ y l r) = case compare x y of LT -> let (lt :*: gt) = go x l in (lt :*: join y gt r) GT -> let (lt :*: gt) = go x r in (join y l lt :*: gt) EQ -> (l :*: r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE split #-} #endif -- | /O(log n)/. Performs a 'split' but also returns whether the pivot -- element was found in the original set. splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a) splitMember _ Tip = (Tip, False, Tip) splitMember x (Bin _ y l r) = case compare x y of LT -> let (lt, found, gt) = splitMember x l gt' = join y gt r in gt' `seq` (lt, found, gt') GT -> let (lt, found, gt) = splitMember x r lt' = join y l lt in lt' `seq` (lt', found, gt) EQ -> (l, True, r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE splitMember #-} #endif {-------------------------------------------------------------------- Indexing --------------------------------------------------------------------} -- | /O(log n)/. Return the /index/ of an element, which is its zero-based -- index in the sorted sequence of elements. The index is a number from /0/ up -- to, but not including, the 'size' of the set. Calls 'error' when the element -- is not a 'member' of the set. -- -- > findIndex 2 (fromList [5,3]) Error: element is not in the set -- > findIndex 3 (fromList [5,3]) == 0 -- > findIndex 5 (fromList [5,3]) == 1 -- > findIndex 6 (fromList [5,3]) Error: element is not in the set -- See Note: Type of local 'go' function findIndex :: Ord a => a -> Set a -> Int findIndex = go 0 where go :: Ord a => Int -> a -> Set a -> Int STRICT_1_OF_3(go) STRICT_2_OF_3(go) go _ _ Tip = error "Set.findIndex: element is not in the set" go idx x (Bin _ kx l r) = case compare x kx of LT -> go idx x l GT -> go (idx + size l + 1) x r EQ -> idx + size l #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE findIndex #-} #endif -- | /O(log n)/. Lookup the /index/ of an element, which is its zero-based index in -- the sorted sequence of elements. The index is a number from /0/ up to, but not -- including, the 'size' of the set. -- -- > isJust (lookupIndex 2 (fromList [5,3])) == False -- > fromJust (lookupIndex 3 (fromList [5,3])) == 0 -- > fromJust (lookupIndex 5 (fromList [5,3])) == 1 -- > isJust (lookupIndex 6 (fromList [5,3])) == False -- See Note: Type of local 'go' function lookupIndex :: Ord a => a -> Set a -> Maybe Int lookupIndex = go 0 where go :: Ord a => Int -> a -> Set a -> Maybe Int STRICT_1_OF_3(go) STRICT_2_OF_3(go) go _ _ Tip = Nothing go idx x (Bin _ kx l r) = case compare x kx of LT -> go idx x l GT -> go (idx + size l + 1) x r EQ -> Just $! idx + size l #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupIndex #-} #endif -- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based -- index in the sorted sequence of elements. If the /index/ is out of range (less -- than zero, greater or equal to 'size' of the set), 'error' is called. -- -- > elemAt 0 (fromList [5,3]) == 3 -- > elemAt 1 (fromList [5,3]) == 5 -- > elemAt 2 (fromList [5,3]) Error: index out of range elemAt :: Int -> Set a -> a STRICT_1_OF_2(elemAt) elemAt _ Tip = error "Set.elemAt: index out of range" elemAt i (Bin _ x l r) = case compare i sizeL of LT -> elemAt i l GT -> elemAt (i-sizeL-1) r EQ -> x where sizeL = size l -- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in -- the sorted sequence of elements. If the /index/ is out of range (less than zero, -- greater or equal to 'size' of the set), 'error' is called. -- -- > deleteAt 0 (fromList [5,3]) == singleton 5 -- > deleteAt 1 (fromList [5,3]) == singleton 3 -- > deleteAt 2 (fromList [5,3]) Error: index out of range -- > deleteAt (-1) (fromList [5,3]) Error: index out of range deleteAt :: Int -> Set a -> Set a deleteAt i t = i `seq` case t of Tip -> error "Set.deleteAt: index out of range" Bin _ x l r -> case compare i sizeL of LT -> balanceR x (deleteAt i l) r GT -> balanceL x l (deleteAt (i-sizeL-1) r) EQ -> glue l r where sizeL = size l {-------------------------------------------------------------------- Utility functions that maintain the balance properties of the tree. All constructors assume that all values in [l] < [x] and all values in [r] > [x], and that [l] and [r] are valid trees. In order of sophistication: [Bin sz x l r] The type constructor. [bin x l r] Maintains the correct size, assumes that both [l] and [r] are balanced with respect to each other. [balance x l r] Restores the balance and size. Assumes that the original tree was balanced and that [l] or [r] has changed by at most one element. [join x l r] Restores balance and size. Furthermore, we can construct a new tree from two trees. Both operations assume that all values in [l] < all values in [r] and that [l] and [r] are valid: [glue l r] Glues [l] and [r] together. Assumes that [l] and [r] are already balanced with respect to each other. [merge l r] Merges two trees and restores balance. Note: in contrast to Adam's paper, we use (<=) comparisons instead of (<) comparisons in [join], [merge] and [balance]. Quickcheck (on [difference]) showed that this was necessary in order to maintain the invariants. It is quite unsatisfactory that I haven't been able to find out why this is actually the case! Fortunately, it doesn't hurt to be a bit more conservative. --------------------------------------------------------------------} {-------------------------------------------------------------------- Join --------------------------------------------------------------------} join :: a -> Set a -> Set a -> Set a join x Tip r = insertMin x r join x l Tip = insertMax x l join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz) | delta*sizeL < sizeR = balanceL z (join x l lz) rz | delta*sizeR < sizeL = balanceR y ly (join x ry r) | otherwise = bin x l r -- insertMin and insertMax don't perform potentially expensive comparisons. insertMax,insertMin :: a -> Set a -> Set a insertMax x t = case t of Tip -> singleton x Bin _ y l r -> balanceR y l (insertMax x r) insertMin x t = case t of Tip -> singleton x Bin _ y l r -> balanceL y (insertMin x l) r {-------------------------------------------------------------------- [merge l r]: merges two trees. --------------------------------------------------------------------} merge :: Set a -> Set a -> Set a merge Tip r = r merge l Tip = l merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry) | delta*sizeL < sizeR = balanceL y (merge l ly) ry | delta*sizeR < sizeL = balanceR x lx (merge rx r) | otherwise = glue l r {-------------------------------------------------------------------- [glue l r]: glues two trees together. Assumes that [l] and [r] are already balanced with respect to each other. --------------------------------------------------------------------} glue :: Set a -> Set a -> Set a glue Tip r = r glue l Tip = l glue l r | size l > size r = let (m,l') = deleteFindMax l in balanceR m l' r | otherwise = let (m,r') = deleteFindMin r in balanceL m l r' -- | /O(log n)/. Delete and find the minimal element. -- -- > deleteFindMin set = (findMin set, deleteMin set) deleteFindMin :: Set a -> (a,Set a) deleteFindMin t = case t of Bin _ x Tip r -> (x,r) Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balanceR x l' r) Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip) -- | /O(log n)/. Delete and find the maximal element. -- -- > deleteFindMax set = (findMax set, deleteMax set) deleteFindMax :: Set a -> (a,Set a) deleteFindMax t = case t of Bin _ x l Tip -> (x,l) Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balanceL x l r') Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip) -- | /O(log n)/. Retrieves the minimal key of the set, and the set -- stripped of that element, or 'Nothing' if passed an empty set. minView :: Set a -> Maybe (a, Set a) minView Tip = Nothing minView x = Just (deleteFindMin x) -- | /O(log n)/. Retrieves the maximal key of the set, and the set -- stripped of that element, or 'Nothing' if passed an empty set. maxView :: Set a -> Maybe (a, Set a) maxView Tip = Nothing maxView x = Just (deleteFindMax x) {-------------------------------------------------------------------- [balance x l r] balances two trees with value x. The sizes of the trees should balance after decreasing the size of one of them. (a rotation). [delta] is the maximal relative difference between the sizes of two trees, it corresponds with the [w] in Adams' paper. [ratio] is the ratio between an outer and inner sibling of the heavier subtree in an unbalanced setting. It determines whether a double or single rotation should be performed to restore balance. It is correspondes with the inverse of $\alpha$ in Adam's article. Note that according to the Adam's paper: - [delta] should be larger than 4.646 with a [ratio] of 2. - [delta] should be larger than 3.745 with a [ratio] of 1.534. But the Adam's paper is errorneous: - it can be proved that for delta=2 and delta>=5 there does not exist any ratio that would work - delta=4.5 and ratio=2 does not work That leaves two reasonable variants, delta=3 and delta=4, both with ratio=2. - A lower [delta] leads to a more 'perfectly' balanced tree. - A higher [delta] performs less rebalancing. In the benchmarks, delta=3 is faster on insert operations, and delta=4 has slightly better deletes. As the insert speedup is larger, we currently use delta=3. --------------------------------------------------------------------} delta,ratio :: Int delta = 3 ratio = 2 -- The balance function is equivalent to the following: -- -- balance :: a -> Set a -> Set a -> Set a -- balance x l r -- | sizeL + sizeR <= 1 = Bin sizeX x l r -- | sizeR > delta*sizeL = rotateL x l r -- | sizeL > delta*sizeR = rotateR x l r -- | otherwise = Bin sizeX x l r -- where -- sizeL = size l -- sizeR = size r -- sizeX = sizeL + sizeR + 1 -- -- rotateL :: a -> Set a -> Set a -> Set a -- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r -- | otherwise = doubleL x l r -- rotateR :: a -> Set a -> Set a -> Set a -- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r -- | otherwise = doubleR x l r -- -- singleL, singleR :: a -> Set a -> Set a -> Set a -- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3 -- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3) -- -- doubleL, doubleR :: a -> Set a -> Set a -> Set a -- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4) -- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4) -- -- It is only written in such a way that every node is pattern-matched only once. -- -- Only balanceL and balanceR are needed at the moment, so balance is not here anymore. -- In case it is needed, it can be found in Data.Map. -- Functions balanceL and balanceR are specialised versions of balance. -- balanceL only checks whether the left subtree is too big, -- balanceR only checks whether the right subtree is too big. -- balanceL is called when left subtree might have been inserted to or when -- right subtree might have been deleted from. balanceL :: a -> Set a -> Set a -> Set a balanceL x l r = case r of Tip -> case l of Tip -> Bin 1 x Tip Tip (Bin _ _ Tip Tip) -> Bin 2 x l Tip (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip) (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip) (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr)) | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip) | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip) (Bin rs _ _ _) -> case l of Tip -> Bin (1+rs) x Tip r (Bin ls lx ll lr) | ls > delta*rs -> case (ll, lr) of (Bin lls _ _ _, Bin lrs lrx lrl lrr) | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r) | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r) (_, _) -> error "Failure in Data.Map.balanceL" | otherwise -> Bin (1+ls+rs) x l r {-# NOINLINE balanceL #-} -- balanceR is called when right subtree might have been inserted to or when -- left subtree might have been deleted from. balanceR :: a -> Set a -> Set a -> Set a balanceR x l r = case l of Tip -> case r of Tip -> Bin 1 x Tip Tip (Bin _ _ Tip Tip) -> Bin 2 x Tip r (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip) (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _)) | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr) (Bin ls _ _ _) -> case r of Tip -> Bin (1+ls) x l Tip (Bin rs rx rl rr) | rs > delta*ls -> case (rl, rr) of (Bin rls rlx rll rlr, Bin rrs _ _ _) | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr) (_, _) -> error "Failure in Data.Map.balanceR" | otherwise -> Bin (1+ls+rs) x l r {-# NOINLINE balanceR #-} {-------------------------------------------------------------------- The bin constructor maintains the size of the tree --------------------------------------------------------------------} bin :: a -> Set a -> Set a -> Set a bin x l r = Bin (size l + size r + 1) x l r {-# INLINE bin #-} {-------------------------------------------------------------------- Utilities --------------------------------------------------------------------} foldlStrict :: (a -> b -> a) -> a -> [b] -> a foldlStrict f = go where go z [] = z go z (x:xs) = let z' = f z x in z' `seq` go z' xs {-# INLINE foldlStrict #-} {-------------------------------------------------------------------- Debugging --------------------------------------------------------------------} -- | /O(n)/. Show the tree that implements the set. The tree is shown -- in a compressed, hanging format. showTree :: Show a => Set a -> String showTree s = showTreeWith True False s {- | /O(n)/. The expression (@showTreeWith hang wide map@) shows the tree that implements the set. If @hang@ is @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown. > Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5] > 4 > +--2 > | +--1 > | +--3 > +--5 > > Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5] > 4 > | > +--2 > | | > | +--1 > | | > | +--3 > | > +--5 > > Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5] > +--5 > | > 4 > | > | +--3 > | | > +--2 > | > +--1 -} showTreeWith :: Show a => Bool -> Bool -> Set a -> String showTreeWith hang wide t | hang = (showsTreeHang wide [] t) "" | otherwise = (showsTree wide [] [] t) "" showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS showsTree wide lbars rbars t = case t of Tip -> showsBars lbars . showString "|\n" Bin _ x Tip Tip -> showsBars lbars . shows x . showString "\n" Bin _ x l r -> showsTree wide (withBar rbars) (withEmpty rbars) r . showWide wide rbars . showsBars lbars . shows x . showString "\n" . showWide wide lbars . showsTree wide (withEmpty lbars) (withBar lbars) l showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS showsTreeHang wide bars t = case t of Tip -> showsBars bars . showString "|\n" Bin _ x Tip Tip -> showsBars bars . shows x . showString "\n" Bin _ x l r -> showsBars bars . shows x . showString "\n" . showWide wide bars . showsTreeHang wide (withBar bars) l . showWide wide bars . showsTreeHang wide (withEmpty bars) r showWide :: Bool -> [String] -> String -> String showWide wide bars | wide = showString (concat (reverse bars)) . showString "|\n" | otherwise = id showsBars :: [String] -> ShowS showsBars bars = case bars of [] -> id _ -> showString (concat (reverse (tail bars))) . showString node node :: String node = "+--" withBar, withEmpty :: [String] -> [String] withBar bars = "| ":bars withEmpty bars = " ":bars {-------------------------------------------------------------------- Assertions --------------------------------------------------------------------} -- | /O(n)/. Test if the internal set structure is valid. valid :: Ord a => Set a -> Bool valid t = balanced t && ordered t && validsize t ordered :: Ord a => Set a -> Bool ordered t = bounded (const True) (const True) t where bounded lo hi t' = case t' of Tip -> True Bin _ x l r -> (lo x) && (hi x) && bounded lo (x) hi r balanced :: Set a -> Bool balanced t = case t of Tip -> True Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && balanced l && balanced r validsize :: Set a -> Bool validsize t = (realsize t == Just (size t)) where realsize t' = case t' of Tip -> Just 0 Bin sz _ l r -> case (realsize l,realsize r) of (Just n,Just m) | n+m+1 == sz -> Just sz _ -> Nothing darcs-2.10.2/contrib/0000755000175000017500000000000012620122474016362 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/contrib/_darcs.zsh0000644000175000017500000000221612620122474020344 0ustar00guillaumeguillaume00000000000000#compdef darcs ## Darcs completion snippet for zsh. ## ## 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. if (($CURRENT == 2)); then # We're completing the first word after "darcs" -- the command. _wanted command expl 'darcs command' \ 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... /*|./*|\~*|../*) _arguments '*:file:_files' ;; # Otherwise, let's ask darcs for all possible options *) _arguments '*: :($(words[$CURRENT]="--list-options" && $words))' ;; esac fi darcs-2.10.2/contrib/darcs-errors.hlint0000644000175000017500000000402112620122474022025 0ustar00guillaumeguillaume00000000000000-- 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 -- indefinitely. This is called a fd leak. Other than being annoying and if done -- often, leading to fd exhaustion and failure to open any new files (which is -- usually fatal), it also prevents the file to be unlinked (deleted) on win32. -- On the other hand, *strict* bytestring version of readFile will read the whole -- file into a contiguous buffer, *close the fd* and return. This is perfectly -- safe with regards to fd leaks. Btw., this is *not* the case with lazy -- bytestring variant of readFile, so that one is unsafe as well. error "Avoid Prelude.readFile" = Prelude.readFile ==> Data.ByteString.readFile error "Avoid hGetContents" = System.IO.hGetContents ==> Data.ByteString.hGetContents error "Avoid BL.hGetContents" = Data.ByteString.Lazy.hGetContents ==> Data.ByteString.hGetContents error "Avoid BL.hGetContents" = Data.ByteString.Lazy.Char8.hGetContents ==> Data.ByteString.hGetContents -- error "Avoid BL.readFile" = Data.ByteString.Lazy.Char8.readFile ==> Data.ByteString.readFile -- error "Avoid BL.readFile" = Data.ByteString.Lazy.readFile ==> Data.ByteString.readFile darcs-2.10.2/contrib/cygwin-wrapper.bash0000644000175000017500000002011712620122474022200 0ustar00guillaumeguillaume00000000000000#! /bin/bash DIRNAME=`dirname "${0}"` if [ "${DIRNAME:0:1}" = "/" ] ; then DARCSPACKAGEDIR="${DIRNAME}" else DARCSPACKAGEDIR="${PWD}/${DIRNAME}" fi # If the DARCSPACKAGEDIR assignment above doesn't work for some funny reason, # you could set these variables by hand. Or fix the script to work # automatically and submit a patch. # Should be set to the full Cygwin path to the directory containing the # putty executables. putty_binary_dir="${DARCSPACKAGEDIR}" # Should be set to the full Cygwin path to the directory containing the # Windows binary "darcs.exe". darcs_binary_dir="$putty_binary_dir" # Should be set to the full Cygwin path to the Windows binary # "darcs.exe". darcs_binary="${darcs_binary_dir}/realdarcs.exe" #--------------------------------------------------------------------- # Darcs Wrapper for Cygwin # # A Bash script that allows Cywin paths on the command line when using # a version of Darcs compiled for Windows. Darcs will still use still # Windows paths internally. # #--------------------------------------------------------------------- # Usage # # Edit this file and set the variables above. Then, rename this # script to "darcs" and put it in your PATH somewhere before the # original binary. # # Darcs needs to launch itself for some operations and so the original # binary needs to be in your Windows PATH. Do not rename it. # #--------------------------------------------------------------------- # Known Issues # # This script is just a stopgap measure. Things don't work perfectly. # We really need a Cygwin build of Darcs. # # No path conversion is performed on: # - Any preferences set with "setpref" # - The "COMMAND" argument to "darcs trackdown" # # When Darcs launches external programs, it uses a Windows system call # to do so. This means you may not be able to run "hash bang" scripts # directly. For example, to run the Bash script "myscript", you'll # have to tell Darcs to run "bash myscript". # # -------------------------------------------------------------------- PATH="$putty_binary_dir:$darcs_binary_dir:${PATH}" debug=false cmd="$1" # Print each argument to stderr on a separate line. Then exit. function die() { local line for line in "$@"; do echo "$line" > /dev/stderr done exit 2 } # Make sure 'darcs_binary_dir' is set. if [ ! -d "$darcs_binary_dir" ]; then die "Please edit this script and set the 'darcs_binary_dir' variable" \ "to refer to a valid directory." \ " script path = '$0'" \ " darcs_binary_dir = '$darcs_binary_dir'" fi # Special case for when the first argument is an option. if expr match "$cmd" '-' > /dev/null; then if $debug; then # echo "SIMPLE CASE:" for arg in "$@"; do echo " arg = '$arg'" done else # echo about to exec -a darcs "$darcs_binary" "$@" exec -a darcs "$darcs_binary" "$@" fi fi # Shift off the darcs command name shift function is_opaque_opt() { local opt for opt in "${opaque_binary_opts[@]}"; do if [ "$opt" == "$1" ]; then return 0 fi done return 1 } function is_file_opt() { local opt for opt in "${file_binary_opts[@]}"; do if [ "$opt" == "$1" ]; then return 0 fi done return 1 } # Options are not dealt with in a command-specific way. AFAIK, Darcs # doesn't use the same option in two different ways, so we should be # fine. # List of "opaque" binary options. These are options where we don't # treat the option argument like a file. declare -a opaque_binary_opts=( \ '--repo-name' \ '--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' \ '--sign-as' '--creator-hash' \ '--last' '--diff-opts' \ '-d' '--dist-name' \ '--log-file' \ '--apply-as' \ ) # List of binary options that take file arguments that need to be converted. declare -a file_binary_opts=( \ '--repodir' '--repo' '--sibling' \ '--context' \ '--logfile' '-o' '--output' \ '--external-merge' \ '--sign-ssl' '--verify' '--verify-ssl' \ ) # -------------------------------------------------------------------- # The three command categories. We only use the first one, but the # others are listed to make sure we've covered everything. Luckily, # there aren't any commands that have some args that need to be # converted and some that don't. # Commands whose arguments are file paths that need to be translated. 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|log|setpref|test|amend|revert|diff|annotate' # Commands that don't accept non-option arguments #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 # list. The match may not be unambiguous, we can rely on Darcs to # deal with that correctly. if expr match "$cmds_convert_nonoption_args" ".*|$cmd" > /dev/null; then convert_nonoption_args=true else convert_nonoption_args=false fi function convert_path() { # echo "converting path ${*} ..." >> /tmp/log if expr match "$1" '[-@._A-Za-z0-9]*:' > /dev/null; then # Some sort of URL or remote ssh pathname ("xxx:/") echo "$1" # echo "converting path ${*} ... to ${1}" >> /tmp/log elif [ "$1" == '.' ]; then # Compensate for stupid 'cygpath' behavior. echo '.' # echo "converting path ${*} ... to ." >> /tmp/log else cygpath -wl -- "$1" # echo "converting path ${*} ... to `cygpath -wl -- ${1}`" >> /tmp/log fi } declare -a params=("$cmd") num_nonoption_args=0 while [ $# -gt 0 ]; do arg=$1 shift if expr match "$arg" '-' > /dev/null; then # It's an option. Check to see if it's an opaque binary option. if expr match "$arg" '.*=' > /dev/null; then # The option has an '=' in it. opt=`expr match "$arg" '\([^=]*\)'` opt_arg=`expr match "$arg" '[^=]*=\(.*\)'` if is_opaque_opt "$opt"; then true; elif is_file_opt "$opt"; then opt_arg=`convert_path "$opt_arg"` else die "darcs-wrapper: I don't think '$opt' accepts an argument." \ "[ If it does, then there is a bug in the wrapper script. ]" fi params[${#params[*]}]="$opt=$opt_arg" else # The option doesn't have an '=' opt="$arg" if is_opaque_opt "$opt"; then if [ $# -eq 0 ]; then die "darcs-wrapper: I think '$arg' requires an argument." \ "[ If it doesn't, then there is a bug in the wrapper script. ]" fi opt_arg="$1" shift params[${#params[*]}]="$opt" params[${#params[*]}]="$opt_arg" elif is_file_opt "$opt"; then if [ $# -eq 0 ]; then die "darcs-wrapper: I think '$arg' requires an argument." \ "[ If it doesn't, then there is a bug in the wrapper script. ]" fi opt_arg=`convert_path "$1"` shift params[${#params[*]}]="$opt" params[${#params[*]}]="$opt_arg" else params[${#params[*]}]="$opt" fi fi else if $convert_nonoption_args; then arg=`convert_path "$arg"` fi params[${#params[*]}]="$arg" (( num_nonoption_args += 1 )) fi done # DEBUG if $debug; then echo "ARGS:" for arg in "${params[@]}"; do echo " arg = '$arg'" done else # echo about to exec -a darcs "$darcs_binary" "${params[@]}" exec -a darcs "$darcs_binary" "${params[@]}" fi darcs-2.10.2/contrib/upload.cgi0000644000175000017500000000755312620122474020344 0ustar00guillaumeguillaume00000000000000#!/usr/bin/perl use strict; use File::Temp qw/ tempdir tempfile /; # this is a sample cgi script to accept darcs patches via POST # it simply takes patches and sends them using sendmail or # places them in a Maildir style mailbox. my $tmp_dir; # temporary directory, when placing patches to maildir # files are linked from $tmp_dir to $maildir $tmp_dir = "/tmp"; # target email addresses--leave blank to use To: header in patch contents. my $target_email; # target repository for patch testing. Leave blank to use DarcsURL header # in patch contents. my $target_repo; my $sendmail_cmd; # command to send patches with $sendmail_cmd = "/usr/sbin/sendmail -i -t $target_email"; my $maildir; # maildir to put patches to, replace sendmail #$maildir = "/tmp/maildir"; my $patch_test_cmd; # command to test patches with $patch_test_cmd = "darcs apply --dry-run --repodir 'TARGETREPO' 'TARGETPATCH'"; 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 { my ($m) = @_; print "Status: 500 Error accepting patch\n"; print "Content-Type: text/plain\n\n"; print($m || "There was an error processing your request"); print "\n"; exit 0; } sub success_page { print "Content-Type: text/plain\n\n"; print "Thank you for your contribution!\n"; exit 0; } if ($ENV{CONTENT_TYPE} eq 'message/rfc822') { my $m = start_message() or error_page("could not create temporary file"); my $fh = $m->{fh}; my ($totalbytes, $bytesread, $buffer); do { $bytesread = read(STDIN, $buffer, 1024); print $fh $buffer; $totalbytes += $bytesread; } while ($bytesread); my $r = end_message($m); $r ? error_page($r) : success_page(); } elsif ($ENV{CONTENT_TYPE}) { error_page("invalid content type, I expect something of message/rfc822"); } else { error_page("This url is for accepting darcs patches."); } sub maildir_file { my ($tmp_file) = @_; my $base_name = sprintf("patch-%d-%d-0000", $$, time()); my $count = 0; until (link("$tmp_file", "$maildir/$base_name")) { $base_name =~ s/-(\d+)$/"-" . (1 + $1)/e; return undef if $count++ > 100; } return "$maildir/$base_name"; } sub start_message { my ($fh, $fname) = tempfile("$tmp_dir/dpatch".'X'x8, UNLINK => 1) or return undef; return { fh => $fh, filename => $fname }; } sub end_message { my ($m) = @_; close $m->{fh} or return "$!: $m->{filename} - Could not close filehandle"; unless ($target_repo) { # Look for DarcsURL header my $darcsurl; open(MF,$m->{filename}) or return "$!: $m->{filename} - Could not open file"; while () { if (/^DarcsURL: (.+)$/) { $darcsurl = $1; last; } } close(MF); return "Could not find DarcsURL header" unless $darcsurl; my $test_dir = tempdir(CLEANUP => 1).'/repo' or return "$!: Could not create test directory"; $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/; $patch_test_cmd =~ s/TARGETPATCH/$m->{filename}/; system("$patch_test_cmd >/dev/null 2>/dev/null") == 0 or return "Patch is not valid: '$patch_test_cmd' failed"; if ($maildir) { maildir_file("$m->{filename}") or return "$!: Could not create a new file in maildir"; } else { system("$sendmail_cmd < '$m->{filename}'") == 0 or return "$!: Could not send mail"; } return 0; } darcs-2.10.2/contrib/update_roundup.pl0000644000175000017500000000520412620122474021756 0ustar00guillaumeguillaume00000000000000#!/usr/bin/perl use strict; use warnings; # A script to update the status of an issue in a Roundup bug tracker # based on the format of a darcs patch name. # It is intended to be run from a darcs posthook. # The format we look for is: # resolved issue123 # in the first line of the patch. use Getopt::Long; use MIME::Lite; use XML::Simple; my $UPDATE_STRING="status=resolved"; if (scalar(@ARGV) == 1) { $UPDATE_STRING=$ARGV[0]; } unless ($ENV{DARCS_PATCHES_XML}) { die "DARCS_PATCHES_XML was expected to be set in the environment, but was not found. Are you running this from a Darcs 2.0 or newer posthook?" } my $xml = eval { XMLin($ENV{DARCS_PATCHES_XML}, forcearray=>['patch']); }; die "hmmm.. we couldn't parse your XML. The error was: $@" if $@; # $xml structure returned looks like this: # 'patch' => { # 'resolved issue123: adding t.t' => { # 'hash' => '20080215033723-20bb4-54f935f89817985a3e98f3de8e8ac9dad5e8e0e5.gz', # 'inverted' => 'False', # 'date' => '20080215033723', # 'author' => 'Mark Stosberg ', # 'local_date' => 'Thu Feb 14 22:37:23 EST 2008' # }, # 'some other patch' => { ... }, for my $patch_name (keys %{ $xml->{patch} }) { my $issue_re = qr/resolved? \s+ (issue ?\d+)/msxi; next unless ($patch_name =~ $issue_re); my $issue = $1; my $patch = $xml->{patch}{$patch_name}; # Using the Command Line would be a simpler alternative. # my $out = `roundup-admin -i /var/lib/roundup/trackers/darcs set $issue status=resolved`; # warn "unexpected output: $out" if $out; my $author = $patch->{author}; # If the Author name contains an @ sign, we take it to be an e-mail address. # 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 $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 my $msg = MIME::Lite->new( From => 'noreply@darcs.net', To =>'bugs@lists.osuosl.org', #To =>'mark@stosberg.com', Subject =>"[$issue] [$UPDATE_STRING]", Type =>'text/plain', Data => qq!The following patch sent by $email updated issue $issue with $UPDATE_STRING * $patch_name $comment ! ); $msg->send; # An alternative to actually sending, for debugging. # use File::Slurp; # write_file("msg-$patch->{hash}.out",$msg->as_string); } darcs-2.10.2/contrib/darcs_completion0000644000175000017500000000356412620122474021642 0ustar00guillaumeguillaume00000000000000#-*- mode: shell-script;-*- # darcs command line completion. # Copyright 2002 "David Roundy" # This archive should be copied in the directory /etc/bash_completion.d/ _darcs() { local cur cur=${COMP_WORDS[COMP_CWORD]} COMPREPLY=() if (($COMP_CWORD == 1)); then COMPREPLY=( $( darcs --commands | command grep "^$cur" ) ) 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//./\\.}") ) # 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"} done return 0 } complete -F _darcs -o default darcs darcs-2.10.2/COPYING0000644000175000017500000004310312620122474015756 0ustar00guillaumeguillaume00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble 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 Lesser 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. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. 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. 1. 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. 2. 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: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) 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. c) 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.) 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. 3. 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: a) 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, b) 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, c) 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.) 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. 4. 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. 5. 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. 6. 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. 7. 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. 8. 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. 9. 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. 10. 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. NO WARRANTY 11. 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. 12. 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 OF TERMS AND CONDITIONS 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. Copyright (C) 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 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: 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. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `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: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice 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 Lesser General Public License instead of this License. darcs-2.10.2/hashed-storage/0000755000175000017500000000000012620122474017620 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/hashed-storage/testdata.zip0000644000175000017500000004043512620122474022163 0ustar00guillaumeguillaume00000000000000PK Z:_darcs/UT lJ95IJux PK wY:_darcs/pristine.hashed/UT R@`J95IJux PK Z:=.[[b_darcs/pristine.hashed/0000000088-b629d32eda4e44b4f196579e6b36caafc53107eff12d1dde063bdd8b52d21a38UT \5IJ\5IJux 5A 0{RhԴ)Q([O獫(ѭQO^\6=Lpr ؜r›'[XPKV: Hb_darcs/pristine.hashed/0000000002-87428fc522803d31065e7bce3cf03fe475096631e5e07bbd7a0fde60c4cf25c7UT T5IJT5IJux `f'L _erPKR:Ib_darcs/pristine.hashed/0000000002-0263829989b6fd954f72baaf2fc64bc2e2f01d692d4de72986ea808f6e99813fUT L5IJL5IJux `fGL G>PKkY:{9.b_darcs/pristine.hashed/0000000010-e6f805fa5fc041ab4bb7aa119641f77ac3e9f42106bc9f92354080692736c8deUT 9@`J9@`Jux `fo/sz,Y FiwnPľ0%6.;=]&&:^ZTz![[}ⶡ,'蘏brk5*WΫM$4>[|eޒrzLJ/[h~_( X ʠ*KXYsettx3RIVLXfݙ X+]ÜZ.g&߁dRWPK I: _darcs/prefs/UT 95IJ95IJux PKI:qAě_darcs/prefs/binariesUT 95IJ95IJux PMo0 W60@/;ɚ)X}شզ@ont#P4J <1R8lrҰ׆g0`?aDVq Ԁ@-zwDWy셞pФ* 2 ,6R/Z! vemV)WLt- $*pF ~iLFXEHf)('t 8\ Oɗji˒n޲DEi( ]>]X"LF]V8aX}_E:l\fKMؾPTT=N׹M[HWACv5naN97Oa E<|m~ VHUQbOԤǑrmBcm  3V׾:BP q:qKjJ$`Q_];f&+P[P8>KpӃU.ߏ)oޥ4suقd02S{Sqճi}NאSӲtU9J&!4so 7wѹ&!/2đ5I4JH߮l$9هBulAaT-j{D3_y_"/DKֺx_J'B\p>[,v4&6^aʖLǭL cn?5$uZ*"왍$K'D9^f'xUٷc,,8m26iX56J: gۙkJ,>'{RZ`y"r$HT!؛͆mVS֔anv'8>{^_2;J_r琩0X&_w]IPK I:_darcs/prefs/motdUT 95IJ95IJux PK wY:_darcs/patches/UT R@`J95IJux PK wY:bZ_darcs/patches/0000000375-0004f58841fa2a879732c077eb6e7309f1dd8b3dbae3559298cb97afad38c36aUT R@`JR@`Jux } 0 {"gEm7x&^HekeoD1?E14׳Ciyl(u-C^UC&D禞hpk! ۳-M%eҹJPR !5IP$ );la[4sbϴ'~ gnzb+ c$3aR~6q' |*BwPK h:r.Z_darcs/patches/0000000227-e54718f289070d7e09bbb752616934e0417290b8a798388083f8e2038817bc92UT t5IJt5IJux m 0E|ś+֤6UD&I:Åùt7`,8\3.u&nÐrH(*5+] #L˱ -h)Hq$jn\cujY+%ч\־b` ;g؏a]GQPK n: xZ_darcs/patches/0000000147-fa3ee8d70a3fb3d9f6aee557675eeb116df0813520a93346453419f119a2d71dUT 5IJ5IJux e wM1:Wc [H(uvn'"<(Zky]s9i9CסVh8(&'PHu[0Az\R,2N_&N`j Ōsɻ{+JJY*b]d jWhProƠ44p2 X-!*DB%ZcZ>PK a:~^_darcs/inventories/0000000382-2da2908c780ff8ef88ebae3cbe219df46a51b982a6a8c16e27a5d85d5cbc25e9UT e5IJe5IJux JCA YZ2L.݉"$m?čݳjyj%SlOyNW+`3f2/mجjX =L3v# .L%Q{u6JEJ>=Sm-~4Uw^263ȁU 钲Ci-S8-:1'QPK u:0k^_darcs/inventories/0000001008-09bafef4ebd348512b5ba6e115464ffe9041691421420c0ab559a99ce1d813fcUT 5IJ5IJux n1 w?.%EQhnEנ($&6`_App'v0~?>h{?I %iœn?tȀ woX!l[ k.}LSћJD3FqlآPW4aҺQ ROz_*teePtMF!e+ʑ h^i87PULi*4#JUv}߂Dp^|9>&'ZQHuu΂5 0q޻p*C9I&0 bye=EIN*6EV|iKQ3vܫ 4"M4wf)³*'hJKfʨ85Aγ2]1 58լIkIԬi ^X'.w/uSd G # ER'4628ey;PK Z:b9^_darcs/inventories/0000000190-ff575eca8b1699926e287033bf74a351fbe492ef357c1a1c205c63dcf0a36edfUT \5IJ\5IJux % 0=O`4鉈n*"ܝvޜe]=#O[few@H>٬󻵹B*5)B,.fDikEDE.(~Z*!#-IQqZN7?LPK wY:a,(22^_darcs/inventories/0000001211-d705032f80e41ed76d51c764b549a46416bd29e9c379e00695f8b0f8908441ecUT R@`JR@`Jux Mo1 @+\i']!Gnk8v*Tr8g1y8|8._m;;Ӷ?|J 5iœw2tԽ 8۲OfX穣q9x͔QKhթ8 ΓFiu9ϦEa&v㤳QKsTDФ4JwtN-92@jB7 i2s ܿ-:e %p}n=8FK@]{Ɍ2C0 vTCƘKP[Pqȯ+ywZ.H,TU]4j$4%c.^O#w F!r^ W.uL(\(NH;ǟv肉(Mr./$ɚTj"--x`)KB<TX g3YF*8>YZ0;_?v~/FEQ!,Qbu(e!"oZ2aeJUg1F͜J9߁S/̻PK I:gի _darcs/formatUT 95IJ95IJux hashed darcs-2 PKwY:Қ׎HU_darcs/tentative_pristineUT R@`JR@`Jux %I 0 &MXpNsyGZfwAK0@ UE"DwJLnӖPK M:foo_aUT A5IJA5IJux a PK T:foo_dir/UT O5IJD5IJux PK V:foo_dir/foo_subdir/UT T5IJO5IJux PK V:foo_dir/foo_subdir/foo_aUT T5IJT5IJux a PK Q: foo_dir/foo_aUT J5IJJ5IJux a PK R: foo_dir/foo_bUT L5IJL5IJux b PK nY: foo space/UT @@`J?`Jux PK nY:foo space/foo_aUT @@`J@@`Jux a PK kY:f= foo space/foo\backslashUT 9@`J9@`Jux backslash PK QY:ȁfoo space/foo newlineUT  @`J @`Jux newline PK Z:A_darcs/UTlJux PK wY:AA_darcs/pristine.hashed/UTR@`Jux PK Z:=.[[b_darcs/pristine.hashed/0000000088-b629d32eda4e44b4f196579e6b36caafc53107eff12d1dde063bdd8b52d21a38UT\5IJux PKV: Hb_darcs/pristine.hashed/0000000002-87428fc522803d31065e7bce3cf03fe475096631e5e07bbd7a0fde60c4cf25c7UTT5IJux PKR:Ib8_darcs/pristine.hashed/0000000002-0263829989b6fd954f72baaf2fc64bc2e2f01d692d4de72986ea808f6e99813fUTL5IJux PKkY:{9.b_darcs/pristine.hashed/0000000010-e6f805fa5fc041ab4bb7aa119641f77ac3e9f42106bc9f92354080692736c8deUT9@`Jux PK wY:&b_darcs/pristine.hashed/0000000284-ba1baff2dab9f3fdb42f8ab4c97d43fd636d14c891207c5e47a978a02aba9739UTR@`Jux PK u:C_b_darcs/pristine.hashed/0000000183-6eebdc0ce46aec3457a7feefefaeb3732907150540c6e376c0564543b8eecddaUT5IJux PK u:=b._darcs/pristine.hashed/0000000274-c40f7f018b5cdb889583641e449e5386271af224695d24ec1e692b9fb1db01e3UT5IJux PKQY:#b_darcs/pristine.hashed/0000000008-7ba826f0c347f6adc4686c8d1f61aeb2e2e98322749cd4f82204c926f4022ceeUT @`Jux PK wY:b>_darcs/pristine.hashed/0000000283-5e1671028edb90cc82bfb81b3ee29ec4f1daa354ec423398f2cc983f2f4ad4fbUTR@`Jux PKwY:ZS _darcs/hashed_inventoryUTR@`Jux PK I: AG _darcs/prefs/UT95IJux PKI:qAě _darcs/prefs/binariesUT95IJux PKI:L2x_darcs/prefs/boringUT95IJux PK I:_darcs/prefs/motdUT95IJux PK wY:A-_darcs/patches/UTR@`Jux PK wY:bZv_darcs/patches/0000000375-0004f58841fa2a879732c077eb6e7309f1dd8b3dbae3559298cb97afad38c36aUTR@`Jux PK h:r.Z_darcs/patches/0000000227-e54718f289070d7e09bbb752616934e0417290b8a798388083f8e2038817bc92UTt5IJux PK n: xZ_darcs/patches/0000000147-fa3ee8d70a3fb3d9f6aee557675eeb116df0813520a93346453419f119a2d71dUT5IJux PK wY: 3_darcs/patches/pending.tentativeUTR@`Jux PK u:WZ_darcs/patches/0000000200-f845b978211aa40061d5c1503e11c150a1f486aee7bc95868f6a1ae56c5271aaUT5IJux PK wY:_darcs/patches/pendingUTR@`Jux PK Z:xZ_darcs/patches/0000000140-4f9db7bc4438e289cba97ffad517e754d1afb6f9e91d75d06abd3fc7f3d60762UT\5IJux PK `:$Z<_darcs/patches/0000000125-330b85f2d1b798ce83ce5a9ff9542e97169cbb92c9990caa40c9415d174bd089UTd5IJux PK wY:AV_darcs/inventories/UTR@`Jux PK n:KT^_darcs/inventories/0000000796-a69cac87af8a076fef18f51d4849f17ca57ad8eedd2fb0f15d02a34a950a9c55UT5IJux PK a:~^_darcs/inventories/0000000382-2da2908c780ff8ef88ebae3cbe219df46a51b982a6a8c16e27a5d85d5cbc25e9UTe5IJux PK h:dII^d_darcs/inventories/0000000593-94396dc37bfeebdcddd2f4a467ce3f00092341caaf3058fd26189017da72ca99UTt5IJux PK u:0k^E!_darcs/inventories/0000001008-09bafef4ebd348512b5ba6e115464ffe9041691421420c0ab559a99ce1d813fcUT5IJux PK Z:b9^#_darcs/inventories/0000000190-ff575eca8b1699926e287033bf74a351fbe492ef357c1a1c205c63dcf0a36edfUT\5IJux PK wY:a,(22^$_darcs/inventories/0000001211-d705032f80e41ed76d51c764b549a46416bd29e9c379e00695f8b0f8908441ecUTR@`Jux PK I:gի '_darcs/formatUT95IJux PKwY:Қ׎HU(_darcs/tentative_pristineUTR@`Jux PK M:(foo_aUTA5IJux PK T:A(foo_dir/UTO5IJux PK V:A9)foo_dir/foo_subdir/UTT5IJux PK V:)foo_dir/foo_subdir/foo_aUTT5IJux PK Q: )foo_dir/foo_aUTJ5IJux PK R: #*foo_dir/foo_bUTL5IJux PK nY: Al*foo space/UT@@`Jux PK nY:*foo space/foo_aUT@@`Jux PK kY:f= *foo space/foo\backslashUT9@`Jux PK QY:ȁV+foo space/foo newlineUT @`Jux PK,,Z+darcs-2.10.2/hashed-storage/Storage/0000755000175000017500000000000012620122474021224 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/hashed-storage/Storage/Hashed/0000755000175000017500000000000012620122474022420 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/hashed-storage/Storage/Hashed/Tree.hs0000644000175000017500000005167012620122474023664 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, BangPatterns #-} -- | The abstract representation of a Tree and useful abstract utilities to -- handle those. module Storage.Hashed.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 -- * Files (Blobs). , readBlob -- * Filtering trees. , FilterTree(..), restrict -- * Manipulating trees. , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay , addMissingHashes ) where import Control.Exception( catch, IOException ) import Prelude hiding( lookup, filter, all, catch ) import Storage.Hashed.AnchoredPath import Storage.Hashed.Hash import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS import qualified Data.Map as M import Data.Maybe( catMaybes, isNothing ) import Data.Either( lefts, rights ) import Data.List( union, sort ) import Control.Monad( filterM ) import Control.Applicative( (<$>) ) -------------------------------- -- Tree, Blob and friends -- data Blob m = Blob !(m BL.ByteString) !Hash data TreeItem m = File !(Blob m) | SubTree !(Tree m) | Stub !(m (Tree m)) !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 :: !Hash } listImmediate :: Tree m -> [(Name, TreeItem m)] listImmediate = M.toList . items -- | Get a hash of a TreeItem. May be Nothing. itemHash :: TreeItem m -> 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 :: (Monad m) => Tree m emptyTree = Tree { items = M.empty , treeHash = NoHash } emptyBlob :: (Monad m) => Blob m emptyBlob = Blob (return BL.empty) NoHash makeBlob :: (Monad m) => BL.ByteString -> Blob m makeBlob str = Blob (return str) (sha256 str) makeBlobBS :: (Monad m) => BS.ByteString -> Blob m makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (sha256 s) makeTree :: (Monad m) => [(Name,TreeItem m)] -> Tree m makeTree l = Tree { items = M.fromList l , treeHash = NoHash } makeTreeWithHash :: (Monad m) => [(Name,TreeItem m)] -> Hash -> Tree m makeTreeWithHash l h = Tree { items = M.fromList l , treeHash = 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 ] expandUpdate :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m) expandUpdate update t_ = go (AnchoredPath []) t_ 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, isSub item ] let orig_map = M.filter (not . isSub) (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 $ \_ -> 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_ path_ = expand' t_ path_ where expand' t (AnchoredPath []) = return t expand' t (AnchoredPath (n:rest)) = case lookup t n of (Just item) | isSub item -> amend t n rest =<< unstub item _ -> return t -- fail $ "Descent error in expandPath: " ++ show path_ amend t name rest sub = do sub' <- expand' 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, 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) (hashFunc f `catch` (\(_ :: IOException) -> return NoHash)) 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, NoHash, Nothing) subs <- mapM subtree [ x | x@(_, item) <- listImmediate t_, isSub 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 . isSub) (items t) expanded_map = M.fromList $ rights subs tree = t_ {items = orig_map `M.union` expanded_map} h' <- hashFunc (SubTree t_) if 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 t_ = filter' t_ (AnchoredPath []) where filter' t path = 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' t npath filterSub npath (Stub stub h) = Stub (do x <- stub return $ filter' x npath) h 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, Monad n) => 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. (Functor 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 NoHash }) 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` case lookup t n of Nothing -> NoHash Just i -> itemHash i 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) NoHash) Nothing -> (False, SubTree $! snd $! subtree emptyTree) _ -> error $ "Modify tree at " ++ show path go _ (AnchoredPath []) (Just (Stub _ _)) = error $ "BUG: Error descending in modifyTree, path = " ++ show p_ go _ (AnchoredPath []) (Just (File _)) = error $ "BUG: Error descending in modifyTree, path = " ++ show p_ go _ (AnchoredPath []) Nothing = error $ "BUG: Error descending in modifyTree, path = " ++ show p_ countmap :: forall a k. M.Map k a -> Int countmap = M.fold (\_ 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 = NoHash } 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 :: (Functor m, 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 :: (Functor m, 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 t'' <- fun . SubTree $ t { items = items' , treeHash = NoHash } return t'' maybeupdate path (k, item) = case predi (path `appendPath` k) item of True -> update (path `appendPath` k) (k, item) False -> 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 :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m overlay base over = Tree { items = M.fromList immediate , treeHash = NoHash } 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 (flip overlay o `fmap` b) NoHash (Just (SubTree b), Just (Stub o _)) -> Stub (overlay b `fmap` o) NoHash (Just (Stub b _), Just (Stub o _)) -> Stub (do o' <- o b' <- b return $ overlay b' o') NoHash (Just x, _) -> x (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "." addMissingHashes :: (Monad m, Functor m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m) addMissingHashes make = updateTree update -- use partiallyUpdateTree here where update (SubTree t) = make (SubTree t) >>= \x -> return $ SubTree (t { treeHash = x }) update (File blob@(Blob con NoHash)) = do hash <- make $ File blob return $ File (Blob con hash) update (Stub s NoHash) = 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 isSub :: TreeItem m -> Bool isSub (File _) = False isSub _ = True darcs-2.10.2/hashed-storage/Storage/Hashed/Hash.hs0000644000175000017500000000557712620122474023655 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE DeriveDataTypeable #-} module Storage.Hashed.Hash( Hash(..), encodeBase64u, decodeBase64u , encodeBase16, decodeBase16, sha256, rawHash , match ) where import qualified Crypto.Hash.SHA256 as SHA256 ( hash ) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BS8 import qualified Codec.Binary.Base64Url as B64U import qualified Codec.Binary.Base16 as B16 import Data.Maybe( isJust, fromJust ) import Data.Char( toLower, toUpper ) import Data.Data( Data ) import Data.Typeable( Typeable ) data Hash = SHA256 !BS.ByteString | SHA1 !BS.ByteString | NoHash deriving (Show, Eq, Ord, Read, Typeable, Data) base16 :: BS.ByteString -> BS.ByteString debase16 :: BS.ByteString -> Maybe BS.ByteString base64u :: BS.ByteString -> BS.ByteString debase64u :: BS.ByteString -> Maybe BS.ByteString base16 = BS8.map toLower . B16.b16_enc base64u = B64U.encode debase64u bs = case B64U.decode bs of Right s -> Just s Left _ -> Nothing debase16 bs = case B16.b16_dec $ BS8.map toUpper bs of Right (s, _) -> Just s Left _ -> Nothing encodeBase64u :: Hash -> BS.ByteString encodeBase64u (SHA256 bs) = base64u bs encodeBase64u (SHA1 bs) = base64u bs encodeBase64u NoHash = BS.empty -- | 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 -> BS.ByteString encodeBase16 (SHA256 bs) = base16 bs encodeBase16 (SHA1 bs) = base16 bs encodeBase16 NoHash = BS.empty -- | Take a base64/url-encoded string and decode it as a "Hash". If the string -- is malformed, yields NoHash. decodeBase64u :: BS.ByteString -> Hash decodeBase64u bs | BS.length bs == 44 && isJust (debase64u bs) = SHA256 (fromJust $ debase64u bs) | BS.length bs == 28 && isJust (debase64u bs) = SHA1 (fromJust $ debase64u bs) | otherwise = NoHash -- | Take a base16-encoded string and decode it as a "Hash". If the string is -- malformed, yields NoHash. decodeBase16 :: BS.ByteString -> Hash decodeBase16 bs | BS.length bs == 64 && isJust (debase16 bs) = SHA256 (fromJust $ debase16 bs) | BS.length bs == 40 && isJust (debase16 bs) = SHA1 (fromJust $ debase16 bs) | otherwise = NoHash -- | Compute a sha256 of a (lazy) ByteString. However, although this works -- correctly for any bytestring, it is only efficient if the bytestring only -- has a sigle chunk. sha256 :: BL.ByteString -> Hash sha256 bits = SHA256 $ SHA256.hash $ BS.concat $ BL.toChunks bits rawHash :: Hash -> BS.ByteString rawHash NoHash = error "Cannot obtain raw hash from NoHash." rawHash (SHA1 s) = s rawHash (SHA256 s) = s match :: Hash -> Hash -> Bool NoHash `match` _ = False _ `match` NoHash = False x `match` y = x == y darcs-2.10.2/hashed-storage/Storage/Hashed/Plain.hs0000644000175000017500000000716712620122474024032 0ustar00guillaumeguillaume00000000000000-- | 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' and 'plainTreeIO' implemented in this module are safe in -- this respect). module Storage.Hashed.Plain( readPlainTree, writePlainTree, plainTreeIO -- (obsolete? if so remove implementation!) ) where import Data.Maybe( catMaybes ) import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import System.FilePath( () ) import System.Directory( getDirectoryContents , createDirectoryIfMissing ) import Bundled.Posix( getFileStatus, isDirectory, isRegularFile, FileStatus ) import Storage.Hashed.AnchoredPath import Storage.Hashed.Utils import Storage.Hashed.Hash( Hash( NoHash) ) import Storage.Hashed.Tree( Tree(), TreeItem(..) , Blob(..), makeTree , list, readBlob, expand ) import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState ) import Control.Monad.State( liftIO ) readPlainDir :: FilePath -> IO [(FilePath, FileStatus)] readPlainDir dir = withCurrentDirectory dir $ do items <- getDirectoryContents "." sequence [ do st <- getFileStatus s return (s, st) | s <- items, s `notElem` [ ".", ".." ] ] readPlainTree :: FilePath -> IO (Tree IO) readPlainTree dir = do items <- readPlainDir dir let subs = catMaybes [ let name = Name (BS8.pack name') in case status of _ | isDirectory status -> Just (name, Stub (readPlainTree (dir name')) NoHash) _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name) NoHash) _ -> Nothing | (name', status) <- items ] return $ makeTree subs where readBlob' (Name name) = readSegment (dir BS8.unpack name, Nothing) -- | Write out /full/ tree to a plain directory structure. If you instead want -- to make incremental updates, refer to "Storage.Hashed.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) -- | Run a 'TreeIO' action in a plain tree setting. Writes out changes to the -- plain tree every now and then (after the action is finished, the last tree -- state is always flushed to disk). XXX Modify the tree with filesystem -- reading and put it back into st (ie. replace the in-memory Blobs with normal -- ones, so the memory can be GCd). plainTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO) plainTreeIO action t _ = runTreeMonad action $ initialState t (\_ -> return NoHash) updatePlain where updatePlain path (File b) = do liftIO $ createDirectoryIfMissing True (anchorPath "" $ parent path) liftIO $ readBlob b >>= BL.writeFile (anchorPath "" path) return $ File $ Blob (BL.readFile $ anchorPath "" path) NoHash updatePlain _ x = return x darcs-2.10.2/hashed-storage/Storage/Hashed/Utils.hs0000644000175000017500000001300212620122474024050 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | Mostly internal utilities for use by the rest of the library. Subject to -- removal without further notice. module Storage.Hashed.Utils where import Prelude hiding ( lookup, catch ) import System.Mem( performGC ) import Bundled.Posix( getFileStatus, fileSize ) import System.Directory( getCurrentDirectory, setCurrentDirectory ) import System.FilePath( (), isAbsolute ) import Data.Int( Int64 ) import Data.Maybe( catMaybes ) import Control.Exception( catch, bracket, SomeException(..) ) import Control.Monad( when ) import Control.Monad.Identity( runIdentity ) import Control.Applicative( (<$>) ) import Foreign.ForeignPtr( withForeignPtr ) import Foreign.Ptr( plusPtr ) import Data.ByteString.Internal( toForeignPtr, memcpy ) import System.IO (withFile, IOMode(ReadMode), hSeek, SeekMode(AbsoluteSeek)) import Data.Bits( Bits ) #ifdef BIGENDIAN import Data.Bits( (.&.), (.|.), shift, shiftL, rotateR ) #endif import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString as BS import qualified Data.Set as S import qualified Data.Map as M -- | 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 `catch` (\(_::SomeException) -> do size <- fileSize `fmap` getFileStatus f if size == 0 then return BS8.empty else performGC >> tryToRead) return $ BL.fromChunks [bs] where tryToRead = do case range of Nothing -> BS.readFile f Just (off, size) -> withFile f ReadMode $ \h -> do hSeek h AbsoluteSeek $ fromIntegral off BS.hGet h size {-# INLINE readSegment #-} -- | Run an IO action with @path@ as a working directory. Does neccessary -- bracketing. withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory name = bracket (do cwd <- getCurrentDirectory when (name /= "") (setCurrentDirectory name) return cwd) (\oldwd -> setCurrentDirectory oldwd `catch` \(_::SomeException) -> return ()) . const makeAbsolute :: FilePath -> IO FilePath makeAbsolute p = do cwd <- getCurrentDirectory return $! if isAbsolute p then p else cwd p -- Wow, unsafe. unsafePokeBS :: BS8.ByteString -> BS8.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 -> memcpy (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 #-} xlate32 :: (Num a, Bits a) => a -> a xlate64 :: (Num a, Bits a) => a -> a #ifdef LITTLEENDIAN xlate32 = id xlate64 = id #endif #ifdef BIGENDIAN bytemask :: (Num a, Bits a) => a bytemask = 255 xlate32 a = ((a .&. (bytemask `shift` 0)) `shiftL` 24) .|. ((a .&. (bytemask `shift` 8)) `shiftL` 8) .|. ((a .&. (bytemask `shift` 16)) `rotateR` 8) .|. ((a .&. (bytemask `shift` 24)) `rotateR` 24) xlate64 a = ((a .&. (bytemask `shift` 0)) `shiftL` 56) .|. ((a .&. (bytemask `shift` 8)) `shiftL` 40) .|. ((a .&. (bytemask `shift` 16)) `shiftL` 24) .|. ((a .&. (bytemask `shift` 24)) `shiftL` 8) .|. ((a .&. (bytemask `shift` 32)) `rotateR` 8) .|. ((a .&. (bytemask `shift` 40)) `rotateR` 24) .|. ((a .&. (bytemask `shift` 48)) `rotateR` 40) .|. ((a .&. (bytemask `shift` 56)) `rotateR` 56) #endif -- | Find a monadic fixed point of @f@ that is the least above @i@. (Will -- happily diverge if there is none.) mfixFrom :: (Eq a, Functor m, Monad m) => (a -> m a) -> a -> m a mfixFrom f i = do x <- f i if x == i then return i else mfixFrom f x -- | Find a fixed point of @f@ that is the least above @i@. (Will happily -- diverge if there is none.) fixFrom :: (Eq a) => (a -> a) -> a -> a fixFrom f i = runIdentity $ mfixFrom (return . f) i -- | For a @refs@ function, a @map@ (@key@ -> @value@) and a @rootSet@, find a -- submap of @map@ such that all items in @map@ are reachable, through @refs@ -- from @rootSet@. reachable :: forall monad key value. (Functor monad, Monad monad, Ord key, Eq value) => (value -> monad [key]) -> (key -> monad (Maybe (key, value))) -> S.Set key -> monad (M.Map key value) reachable refs lookup rootSet = do lookupSet rootSet >>= mfixFrom expand where lookupSet :: S.Set key -> monad (M.Map key value) expand :: M.Map key value -> monad (M.Map key value) lookupSet s = do list <- mapM lookup (S.toAscList s) return $ M.fromAscList (catMaybes list) expand from = do refd <- concat <$> mapM refs (M.elems from) M.union from <$> lookupSet (S.fromList refd) darcs-2.10.2/hashed-storage/Storage/Hashed/Index.hs0000644000175000017500000005752112620122474024035 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, ScopedTypeVariables, 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 -- library: 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 best 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 copy 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. -- -- /Index format/ -- -- The Index is organised into \"lines\" where each line describes a single -- indexed item. Cf. 'Item'. -- -- The first word on the index \"line\" is the length of the file path (which is -- the only variable-length part of the line). Then comes the path itself, then -- fixed-length hash (sha256) of the file in question, then three words, one for -- size, one for "aux", which is used differently for directories and for files, and -- one for the fileid (inode or fhandle) of the file. -- -- With directories, this aux holds the offset of the next sibling line in the -- index, so we can efficiently skip reading the whole subtree starting at a -- given directory (by just seeking aux bytes forward). The lines are -- pre-ordered with respect to directory structure -- the directory comes first -- and after it come all its items. Cf. 'readIndex''. -- -- For files, the aux field holds a timestamp. module Storage.Hashed.Index( readIndex, updateIndexFrom, indexFormatValid , updateIndex, listFileIDs, Index, filter , getFileID ) where import Prelude hiding ( lookup, readFile, writeFile, filter, catch ) import Storage.Hashed.Utils import Storage.Hashed.Tree import Storage.Hashed.AnchoredPath import Data.Int( Int64, Int32 ) import Bundled.Posix( getFileStatusBS, modificationTime, getFileStatus, fileSize, fileExists, isDirectory ) import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) ) import System.IO( ) import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist ) #if mingw32_HOST_OS import System.Directory( renameFile ) import System.FilePath( (<.>) ) #else import System.Directory( removeFile ) #endif import System.FilePath( () ) import System.Posix.Types ( FileID ) import Control.Monad( when ) import Control.Exception( catch, SomeException ) import Control.Applicative( (<$>) ) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Unsafe( unsafeHead, unsafeDrop ) import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy , nullForeignPtr, c2w ) import Data.IORef( ) import Data.Maybe( fromJust, isJust, fromMaybe ) import Data.Bits( Bits ) import Foreign.Storable import Foreign.ForeignPtr import Foreign.Ptr import Storage.Hashed.Hash( sha256, rawHash ) #ifdef WIN32 import System.Win32.File ( createFile, getFileInformationByHandle, BY_HANDLE_FILE_INFORMATION(..), fILE_SHARE_NONE, fILE_FLAG_BACKUP_SEMANTICS, gENERIC_NONE, oPEN_EXISTING, closeHandle ) #else import System.PosixCompat ( fileID, getSymbolicLinkStatus ) #endif -------------------------- -- 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. 'readIndex'). data Item = Item { iBase :: !(Ptr ()) , iHashAndDescriptor :: !BS.ByteString } deriving Show size_magic :: Int size_magic = 4 -- the magic word, first 4 bytes of the index 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 path size_hash = 32 -- hash representation 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_hash + size_size + size_aux + size_fileid + size_dsclen + 2 + BS.length (flatten apath) itemSize, itemNext :: Item -> Int itemSize i = size_size + size_aux + size_fileid + size_dsclen + (BS.length $ iHashAndDescriptor i) itemNext i = align 4 (itemSize i + 1) iPath, iHash, iDescriptor :: Item -> BS.ByteString iDescriptor = unsafeDrop size_hash . iHashAndDescriptor iPath = unsafeDrop 1 . iDescriptor iHash = BS.take size_hash . iHashAndDescriptor 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' -- xlatePeek32 = fmap xlate32 . peek xlatePeek64 :: (Storable a, Num a, Bits a) => Ptr a -> IO a xlatePeek64 = fmap xlate64 . peek -- xlatePoke32 ptr v = poke ptr (xlate32 v) xlatePoke64 :: (Storable a, Num a, Bits a) => Ptr a -> a -> IO () xlatePoke64 ptr v = poke ptr (xlate64 v) -- | Lay out the basic index item structure in memory. The memory location is -- 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 = BS.concat [ BSC.singleton $ if typ == TreeType then 'D' else 'F' , flatten apath , BS.singleton 0 ] (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc withForeignPtr fp $ \p -> withForeignPtr dsc_fp $ \dsc_p -> do fileid <- fromMaybe 0 <$> getFileID apath pokeByteOff p (off + off_fileid) (xlate64 $ fromIntegral fileid :: Int64) pokeByteOff p (off + off_dsclen) (xlate32 $ fromIntegral dsc_len :: Int32) memcpy (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 <- xlate32 `fmap` 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) (size_hash + nl - 1) return $! Item { iBase = plusPtr p off , iHashAndDescriptor = dsc } -- | Update an existing item with new hash and optionally mtime (give Nothing -- when updating directory entries). updateItem :: Item -> Int64 -> Hash -> IO () updateItem item _ NoHash = fail $ "Index.update NoHash: " ++ BSC.unpack (iPath item) updateItem item size hash = do xlatePoke64 (iSize item) size unsafePokeBS (iHash item) (rawHash hash) updateFileID :: Item -> FileID -> IO () updateFileID item fileid = xlatePoke64 (iFileID item) $ fromIntegral fileid updateAux :: Item -> Int64 -> IO () updateAux item aux = xlatePoke64 (iAux item) $ aux updateTime :: forall a.(Enum a) => Item -> a -> IO () updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime) iHash' :: Item -> Hash iHash' i = SHA256 (iHash i) -- | 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 exist <- doesFileExist indexpath act_size <- fromIntegral `fmap` if exist then fileSize `fmap` getFileStatus indexpath else return 0 let size = case req_size > 0 of True -> req_size False | act_size >= size_magic -> act_size - size_magic | otherwise -> 0 case size of 0 -> return (castForeignPtr nullForeignPtr, size) _ -> do (x, _, _) <- mmapFileForeignPtr indexpath ReadWriteEx (Just (0, size + size_magic)) return (x, size) data IndexM m = Index { mmap :: (ForeignPtr ()) , basedir :: FilePath , hashtree :: Tree m -> Hash , predicate :: AnchoredPath -> TreeItem m -> Bool } | EmptyIndex type Index = IndexM IO data State = State { dirlength :: !Int , path :: !AnchoredPath , start :: !Int } data Result = Result { -- | marks if the item has changed since the last update to the index changed :: !Bool -- | next is the position of the next item, in bytes. , next :: !Int -- | treeitem is Nothing in case of the item doesn't exist in the tree -- or is filtered by a FilterTree. Or a TreeItem otherwise. , treeitem :: !(Maybe (TreeItem IO)) -- | resitem is the item extracted. , resitem :: !Item } data ResultF = ResultF { -- | nextF is the position of the next item, in bytes. nextF :: !Int -- | resitemF is the item extracted. , resitemF :: !Item -- | _fileIDs contains the fileids of the files and folders inside, -- in a folder item and its own fileid for file item). , _fileIDs :: [((AnchoredPath, ItemType), FileID)] } readItem :: Index -> State -> IO Result readItem index state = do item <- peekItem (mmap index) (start state) res' <- if itemIsDir item then readDir index state item else readFile index state item return res' readDir :: Index -> State -> Item -> IO Result readDir index state item = do following <- fromIntegral <$> xlatePeek64 (iAux item) st <- getFileStatusBS (iPath item) let exists = fileExists st && isDirectory st fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item) when (fileid == 0) $ updateFileID item fileid' let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC namelength = (BS.length $ iDescriptor item) - (dirlength state) myname = name item (dirlength state) substate = state { start = start state + itemNext item , path = path state `appendPath` myname , dirlength = if myname == Name (BSC.singleton '.') then dirlength state else dirlength state + namelength } want = exists && (predicate index) (path substate) (Stub undefined NoHash) oldhash = iHash' item subs off | off < following = do result <- readItem index $ substate { start = off } rest <- subs $ next result return $! (name (resitem result) $ dirlength substate, result) : rest subs coff | coff == following = return [] | otherwise = fail $ "Offset mismatch at " ++ show coff ++ " (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 && oldhash == nullsha nullsha = SHA256 (BS.replicate 32 0) tree' = makeTree [ (n, fromJust $ treeitem s) | (n, s) <- inferiors, isJust $ treeitem s ] treehash = if we_changed then hashtree index tree' else oldhash tree = tree' { treeHash = treehash } when (exists && we_changed) $ updateItem item 0 treehash return $ Result { changed = not exists || we_changed , next = following , treeitem = if want then Just $ SubTree tree else Nothing , resitem = item } readFile :: Index -> State -> Item -> IO Result readFile index state item = do st <- getFileStatusBS (iPath item) mtime <- fromIntegral <$> (xlatePeek64 $ iAux item) size <- xlatePeek64 $ iSize item fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item) let mtime' = modificationTime st size' = fromIntegral $ fileSize st readblob = readSegment (basedir index BSC.unpack (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' 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 } updateIndex :: Index -> IO (Tree IO) updateIndex EmptyIndex = return emptyTree updateIndex index = do let initial = State { start = size_magic , dirlength = 0 , path = AnchoredPath [] } res <- readItem index initial case treeitem res of Just (SubTree tree) -> return $ filter (predicate index) tree _ -> fail "Unexpected failure in updateIndex!" -- | 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_magic , dirlength = 0 , path = AnchoredPath [] } 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 <- fromIntegral <$> (xlatePeek64 $ iFileID item) following <- fromIntegral <$> xlatePeek64 (iAux item) let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC namelength = (BS.length $ iDescriptor item) - (dirlength state) myname = name item (dirlength state) substate = state { start = start state + itemNext item , path = path state `appendPath` myname , dirlength = if myname == Name (BSC.singleton '.') then dirlength state else dirlength state + namelength } subs off | off < following = do result <- readItemFileIDs index $ substate { start = off } rest <- subs $ nextF result return $! (name (resitemF result) $ dirlength substate, result) : rest subs coff | coff == following = return [] | otherwise = fail $ "Offset mismatch at " ++ show coff ++ " (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' <- fromIntegral <$> (xlatePeek64 $ iFileID item) let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) myname = name item (dirlength state) return $ ResultF { nextF = start state + itemNext item , resitemF = item , _fileIDs = [((path state `appendPath` myname, BlobType), fileid')] } -- | Read an index and build up a 'Tree' object from it, referring to current -- working directory. The initial Index object returned by readIndex is not -- directly useful. However, you can use 'Tree.filter' on it. Either way, to -- obtain the actual Tree object, call update. -- -- The usual use pattern is this: -- -- > do (idx, update) <- readIndex -- > tree <- update =<< filter predicate idx -- -- The resulting tree will be fully expanded. readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index readIndex indexpath ht = do (mmap_ptr, mmap_size) <- mmapIndex indexpath 0 base <- getCurrentDirectory return $ if mmap_size == 0 then EmptyIndex else Index { mmap = mmap_ptr , basedir = base , hashtree = ht , predicate = \_ _ -> True } formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO () formatIndex mmap_ptr old reference = do _ <- create (SubTree reference) (AnchoredPath []) size_magic unsafePokeBS magic (BSC.pack "HSI5") where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4 create (File _) path' off = do i <- createItem BlobType path' mmap_ptr off let flatpath = BSC.unpack $ flatten path' case find old path' of Nothing -> return () -- TODO calling getFileStatus here is both slightly -- inefficient and slightly race-prone Just ti -> do st <- getFileStatus flatpath let hash = itemHash ti mtime = modificationTime st size = fileSize st updateItem i (fromIntegral size) hash updateTime i mtime return $ off + itemNext i create (SubTree s) path' off = do i <- createItem TreeType path' mmap_ptr off case find old path' of Nothing -> return () Just ti | itemHash ti == NoHash -> return () | otherwise -> updateItem i 0 $ itemHash ti 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) xlatePoke64 (iAux i) (fromIntegral lastOff) return lastOff create (Stub _ _) path' _ = fail $ "Cannot create index from stubbed Tree at " ++ show path' -- | Will add and remove files in index to make it match the 'Tree' object -- given (it is an error for the 'Tree' to contain a file or directory that -- does not exist in a plain form in current working directory). updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index updateIndexFrom indexpath hashtree' ref = do old_idx <- updateIndex =<< readIndex indexpath hashtree' reference <- expand ref let len_root = itemAllocSize anchoredRoot len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ] exist <- doesFileExist indexpath #if mingw32_HOST_OS when exist $ renameFile indexpath (indexpath <.> "old") #else when exist $ removeFile indexpath -- to avoid clobbering oldidx #endif (mmap_ptr, _) <- mmapIndex indexpath len formatIndex mmap_ptr old_idx reference readIndex indexpath hashtree' -- | 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 magic <- mmapFileByteString path' (Just (0, size_magic)) return $ case BSC.unpack magic of "HSI5" -> True _ -> False `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 } -- | For a given file or folder path, get the corresponding fileID from the -- filesystem. getFileID :: AnchoredPath -> IO (Maybe FileID) getFileID = getFileID' . anchorPath "" getFileID' :: FilePath -> IO (Maybe FileID) getFileID' fp = do file_exists <- doesFileExist fp dir_exists <- doesDirectoryExist fp if file_exists || dir_exists #ifdef WIN32 then do h <- createFile fp gENERIC_NONE fILE_SHARE_NONE Nothing oPEN_EXISTING fILE_FLAG_BACKUP_SEMANTICS Nothing fhnumber <- (Just . fromIntegral . bhfiFileIndex) <$> getFileInformationByHandle h closeHandle h return fhnumber #else then (Just . fileID) <$> getSymbolicLinkStatus fp #endif else return Nothing darcs-2.10.2/hashed-storage/Storage/Hashed/Test.hs0000644000175000017500000007224412620122474023704 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Storage.Hashed.Test( tests ) where import Prelude hiding ( filter, readFile, writeFile, lookup ) import qualified Prelude import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS import Control.Exception( finally ) import System.Directory( doesFileExist, removeFile, doesDirectoryExist ) import System.FilePath( () ) import Control.Monad.Identity import Control.Monad.Trans( lift ) import Control.Applicative( (<$>) ) import Data.Maybe import Data.Word import Data.List( sort, intercalate, nub, intersperse ) import Storage.Hashed import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree hiding ( lookup ) import Storage.Hashed.Index import Storage.Hashed.Utils import Storage.Hashed.Darcs import Storage.Hashed.Packed hiding ( lookup ) import Storage.Hashed.Hash import Storage.Hashed.Monad hiding ( tree ) import System.Mem( performGC ) import qualified Data.Set as S import qualified Data.Map as M import qualified Bundled.Posix as Posix ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists ) import Test.HUnit hiding ( path ) import Test.Framework( testGroup ) import qualified Test.Framework as TF ( Test ) import Test.QuickCheck import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 ------------------------ -- Test Data -- blobs :: [(AnchoredPath, BL.ByteString)] blobs = [ (floatPath "foo_a", BL.pack "a\n") , (floatPath "foo_dir/foo_a", BL.pack "a\n") , (floatPath "foo_dir/foo_b", BL.pack "b\n") , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n") , (floatPath "foo space/foo\nnewline", BL.pack "newline\n") , (floatPath "foo space/foo\\backslash", BL.pack "backslash\n") , (floatPath "foo space/foo_a", BL.pack "a\n") ] files :: [AnchoredPath] files = map fst blobs dirs :: [AnchoredPath] dirs = [ floatPath "foo_dir" , floatPath "foo_dir/foo_subdir" , floatPath "foo space" ] emptyStub :: TreeItem IO emptyStub = Stub (return emptyTree) NoHash testTree :: Tree IO testTree = makeTree [ (makeName "foo", emptyStub) , (makeName "subtree", SubTree sub) , (makeName "substub", Stub getsub NoHash) ] where sub = makeTree [ (makeName "stub", emptyStub) , (makeName "substub", Stub getsub2 NoHash) , (makeName "x", SubTree emptyTree) ] getsub = return sub getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) , (makeName "file2", File $ Blob (return $ BL.pack "foo") NoHash) ] 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 "Bundled.Posix" posix , testGroup "Storage.Hashed.Utils" utils , testGroup "Storage.Hashed.Hash" hash , testGroup "Storage.Hashed.Tree" tree , testGroup "Storage.Hashed.Index" index , testGroup "Storage.Hashed.Packed" packed , testGroup "Storage.Hashed.Monad" monad , testGroup "Storage.Hashed" 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 = do t <- readDarcsPristine "." >>= expand forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") (path `elem` (dirs ++ files)) have_files = readPlainTree "." >>= expand >>= check_files have_pristine_files = readDarcsPristine "." >>= expand >>= check_files pristine_contents = do t <- readDarcsPristine "." >>= expand equals_testdata t plain_contents = do t <- expand =<< filter nondarcs `fmap` readPlainTree "." equals_testdata t write_plain = 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 ] 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 <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x return (x, idx) check_index = 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 = do (_, idx) <- build_index plain <- readPlainTree "." x <- sequence $ zipCommonFiles check_blob_pair plain idx assertBool "files match" (length x > 0) check_index_versions = 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 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 (BL.pack x)) (sha256 $ BL.pack x) name = Name . BS.pack check_modify = let t = makeTree [(name "foo", blob "bar")] modify = modifyTree t (floatPath "foo") (Just $ blob "bla") in do x <- readBlob $ fromJust $ findFile t (floatPath "foo") y <- readBlob $ fromJust $ findFile modify (floatPath "foo") assertEqual "old version" x (BL.pack "bar") assertEqual "new version" y (BL.pack "bla") assertBool "list has foo" $ isJust (Prelude.lookup (floatPath "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 (floatPath "bar/foo") (Just $ blob "bla") in do foo <- readBlob $ fromJust $ findFile t (floatPath "foo") foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo") bar_foo <- readBlob $ fromJust $ findFile t (floatPath "bar/foo") bar_foo' <- readBlob $ fromJust $ findFile modify (floatPath "bar/foo") assertEqual "old foo" foo (BL.pack "bar") assertEqual "old bar/foo" bar_foo (BL.pack "bar") assertEqual "new foo" foo' (BL.pack "bar") assertEqual "new bar/foo" bar_foo' (BL.pack "bla") assertBool "list has bar/foo" $ isJust (Prelude.lookup (floatPath "bar/foo") $ list modify) assertBool "list has foo" $ isJust (Prelude.lookup (floatPath "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 (floatPath "foo") Nothing modify2 = modifyTree t2 (floatPath "bar") Nothing file = findFile modify1 (floatPath "foo") subtree = findTree modify2 (floatPath "bar") in do assertBool "file is gone" (isNothing file) assertBool "subtree is gone" (isNothing subtree) no_stubs t = null [ () | (_, Stub _ _) <- list t ] path = floatPath "substub/substub/file" badpath = floatPath "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 $ floatPath "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 $ floatPath "substub" t' <- expandPath testTree $ floatPath "substub/stub" t'' <- expandPath testTree $ floatPath "subtree/stub" assertBool "leaf is not a Stub" $ isNothing (findTree testTree $ floatPath "substub") assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub") assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub") assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub") check_diffTrees = flip finally (Prelude.writeFile "foo_dir/foo_a" "a\n") $ do Prelude.writeFile "foo_dir/foo_a" "b\n" working_plain <- filter nondarcs `fmap` readPlainTree "." working <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash working_plain pristine <- readDarcsPristine "." (working', pristine') <- diffTrees working pristine let foo_work = findFile working' (floatPath "foo_dir/foo_a") foo_pris = findFile pristine' (floatPath "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) BL.unpack foo_work_c @?= "b\n" BL.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 packed :: [TF.Test] packed = [ testCase "loose pristine tree" check_loose , testCase "load" check_load , testCase "live" check_live , testCase "compact" check_compact ] where root_hash = treeHash <$> get_pristine get_pristine = darcsUpdateDirHashes <$> (expand =<< readDarcsPristine ".") check_loose = do x <- readDarcsPristine "." os <- create "_darcs/loose" Loose (os', root) <- writePackedDarcsPristine x os y <- expand =<< readPackedDarcsPristine os' root equals_testdata y check_load = do os <- load "_darcs/loose" format (hatchery os) @?= Loose root <- root_hash y <- expand =<< readPackedDarcsPristine os root equals_testdata y check_live = do os <- load "_darcs/loose" x <- get_pristine root <- root_hash alive <- live (os { roots = [ root ] , references = darcsPristineRefs }) [hatchery os] sequence_ [ assertBool (show hashValue ++ " is alive") $ hashValue `S.member` M.keysSet alive | hashValue <- map (itemHash . snd) $ list x ] length (M.toList alive) @?= 1 + length (nub $ map snd blobs) + length dirs check_compact = do os <- load "_darcs/loose" x <- darcsUpdateDirHashes `fmap` (expand =<< readDarcsPristine ".") (os', root) <- storePackedDarcsPristine x os hatch_root_old <- blockLookup (hatchery os') root assertBool "bits in the old hatchery" $ isJust hatch_root_old os'' <- compact os' length (mature os'') @?= 1 hatch_root <- blockLookup (hatchery os'') root mature_root <- blockLookup (head $ mature os'') root assertBool "bits no longer in hatchery" $ isNothing hatch_root assertBool "bits now in the mature space" $ isJust mature_root mature_root_con <- readSegment (fromJust mature_root) Just mature_root_con @?= darcsFormatDir x y <- expand =<< readPackedDarcsPristine os'' root equals_testdata y utils :: [TF.Test] utils = [ testProperty "xlate32" prop_xlate32 , testProperty "xlate64" prop_xlate64 , testProperty "align bounded" prop_align_bounded , testProperty "align aligned" prop_align_aligned , testProperty "reachable is a subset" prop_reach_subset , testProperty "roots are reachable" prop_reach_roots , testProperty "nonexistent roots are not reachable" prop_reach_nonroots , testCase "an example for reachable" check_reachable , testCase "fixFrom" check_fixFrom , testCase "mmap empty file" check_mmapEmpty ] where prop_xlate32 x = (xlate32 . xlate32) x == x where _types = x :: Word32 prop_xlate64 x = (xlate64 . xlate64) x == x where _types = x :: Word64 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) check_fixFrom = let f 0 = 0 f n = f (n - 1) in fixFrom f 5 @?= (0 :: Integer) check_mmapEmpty = flip finally (removeFile "test_empty") $ do Prelude.writeFile "test_empty" "" x <- readSegment ("test_empty", Nothing) x @?= BL.empty reachable' ref look rootsSet = runIdentity $ reachable ref look rootsSet check_reachable = let refs 0 = [1, 2] refs 1 = [2] refs 2 = [0, 4] refs 3 = [4, 6, 7] refs 4 = [0, 1] refs _ = error "internal error in check_reachable" set = S.fromList [1, 2] mp = M.fromList [ (n, refs n) | n <- [0..10] :: [Int] ] reach = reachable' return (lookup mp) set in do M.keysSet reach @?= S.fromList [0, 1, 2, 4] prop_reach_subset (set :: S.Set Int, mp :: M.Map Int [Int]) = M.keysSet (reachable' return (lookup mp) set) `S.isSubsetOf` M.keysSet mp prop_reach_roots (set :: S.Set Int, mp :: M.Map Int [Int]) = set `S.isSubsetOf` M.keysSet mp ==> set `S.isSubsetOf` M.keysSet (reachable' return (lookup mp) set) prop_reach_nonroots (set :: S.Set Int, mp :: M.Map Int [Int]) = set `S.intersection` M.keysSet mp == M.keysSet (reachable' (return . const []) (lookup mp) set) lookup :: (Ord a) => M.Map a [a] -> a -> Identity (Maybe (a, [a])) lookup m k = return $ case M.lookupIndex k m of Nothing -> Nothing Just i -> Just $ M.elemAt i m hash :: [TF.Test] hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 , testProperty "decodeBase64u . encodeBase64u == id" prop_base64u ] where prop_base16 x = (decodeBase16 . encodeBase16) x == x prop_base64u x = (decodeBase64u . encodeBase64u) x == 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 (floatPath "substub/substub/file") file2 <- readFile (floatPath "substub/substub/file2") lift $ BL.unpack file @?= "" lift $ BL.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 /= NoHash where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2") posix :: [TF.Test] posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] where check_stat fun = flip finally (removeFile "test_empty") $ do x <- Posix.fileSize `fmap` fun "foo_a" Prelude.writeFile "test_empty" "" y <- Posix.fileSize `fmap` fun "test_empty" exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist" exist_existent <- Posix.fileExists `fmap` fun "test_empty" assertEqual "file size" x 2 assertEqual "file size" y 0 assertBool "existence check" $ not exist_nonexistent assertBool "existence check" exist_existent ---------------------------------- -- Arbitrary instances -- instance (Arbitrary a, Ord a) => Arbitrary (S.Set a) where arbitrary = S.fromList `fmap` arbitrary instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where arbitrary = M.fromList `fmap` arbitrary instance Arbitrary BL.ByteString where arbitrary = BL.pack `fmap` arbitrary instance Arbitrary Hash where arbitrary = sized hash' where hash' 0 = return NoHash hash' _ = do tag <- oneof [return False, return True] case tag of False -> SHA256 . BS.pack <$> sequence [ arbitrary | _ <- [1..32] :: [Int] ] True -> SHA1 . BS.pack <$> sequence [ arbitrary | _ <- [1..20] :: [Int] ] 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) NoHash) subtree n = do branches <- choose (1, n) let sub name = do t <- tree' ((n - 1) `div` branches) return (makeName $ show name, t) sublist <- mapM sub [0..branches] oneof [ tree' 0 , return (SubTree $ makeTree sublist) , return $ (Stub $ return (makeTree sublist)) NoHash ] 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, Functor 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, Functor 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 (Name x:_)) _ | x == BS.pack "_darcs" = False | otherwise = True nondarcs (AnchoredPath []) _ = True readDarcsPristine :: FilePath -> IO (Tree IO) readDarcsPristine dir = do let darcs = dir "_darcs" h_inventory = darcs "hashed_inventory" repo <- doesDirectoryExist darcs unless repo $ fail $ "Not a darcs repository: " ++ dir isHashed <- doesFileExist h_inventory if isHashed then do inv <- BS.readFile h_inventory let thelines = BS.split '\n' inv case thelines of [] -> return emptyTree (pris_line:_) -> do let thehash = decodeDarcsHash $ BS.drop 9 pris_line thesize = decodeDarcsSize $ BS.drop 9 pris_line when (thehash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line readDarcsHashed (darcs "pristine.hashed") (thesize, thehash) else do have_pristine <- doesDirectoryExist $ darcs "pristine" have_current <- doesDirectoryExist $ darcs "current" case (have_pristine, have_current) of (True, _) -> readPlainTree $ darcs "pristine" (False, True) -> readPlainTree $ darcs "current" (_, _) -> fail "No pristine tree is available!" darcs-2.10.2/hashed-storage/Storage/Hashed/Monad.hs0000644000175000017500000002666712620122474024033 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE ScopedTypeVariables, BangPatterns, TypeSynonymInstances, UndecidableInstances, FlexibleInstances #-} -- | An experimental monadic interface to 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 monad interface itself is -- generic, and a number of actual implementations can be used. This module -- provides just 'virtualTreeIO' that never writes any changes, but may trigger -- filesystem reads as appropriate. module Storage.Hashed.Monad ( virtualTreeIO, virtualTreeMonad , readFile, writeFile, createDirectory, rename, copy, unlink , fileExists, directoryExists, exists, withDirectory , currentDirectory , tree, TreeState, TreeMonad, TreeIO, runTreeMonad , initialState, replaceItem , findM, findFileM, findTreeM , TreeRO, TreeRW ) where import Prelude hiding ( readFile, writeFile ) import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree import Control.Applicative( (<$>) ) import Data.List( sortBy ) import Data.Int( Int64 ) import Data.Maybe( isNothing, isJust ) import qualified Data.ByteString.Lazy.Char8 as BL import Control.Monad.RWS.Strict import qualified Data.Map as M type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age -- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree -- content, unsync'd changes and a current working directory (of the monad). data TreeState m = TreeState { tree :: !(Tree m) , changed :: !Changed , changesize :: !Int64 , maxage :: !Int64 , updateHash :: TreeItem m -> m Hash , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m) } -- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well, -- which is a sort of virtual filesystem. Depending on how you obtained your -- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the -- actual real filesystem. For 'virtualTreeIO', nothing happens in real -- filesystem, however with 'plainTreeIO', the plain tree will be updated every -- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get -- updated. type TreeMonad m = RWST AnchoredPath () (TreeState m) m type TreeIO = TreeMonad IO class (Functor m, Monad m) => TreeRO m where currentDirectory :: m AnchoredPath withDirectory :: AnchoredPath -> m a -> m a expandTo :: AnchoredPath -> m AnchoredPath -- | Grab content of a file in the current Tree at the given path. readFile :: AnchoredPath -> m BL.ByteString -- | Check for existence of a node (file or directory, doesn't matter). exists :: AnchoredPath -> m Bool -- | Check for existence of a directory. directoryExists ::AnchoredPath -> m Bool -- | Check for existence of a file. fileExists :: AnchoredPath -> m Bool class TreeRO m => TreeRW m where -- | 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 :: AnchoredPath -> BL.ByteString -> m () createDirectory :: AnchoredPath -> m () unlink :: AnchoredPath -> m () rename :: AnchoredPath -> AnchoredPath -> m () copy :: AnchoredPath -> AnchoredPath -> m () initialState :: Tree m -> (TreeItem m -> m Hash) -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) -> TreeState m initialState t uh u = TreeState { tree = t , changed = M.empty , changesize = 0 , updateHash = uh , maxage = 0 , update = u } flush :: (Functor m, 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' ++ [AnchoredPath []]) flushItem runTreeMonad' :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) runTreeMonad' action initial = do (out, final, _) <- runRWST action (AnchoredPath []) initial return (out, tree final) runTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) runTreeMonad action initial = do let action' = do x <- action flush return x runTreeMonad' action' initial -- | Run a TreeIO 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 a form of modified Tree. virtualTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m) virtualTreeMonad action t = runTreeMonad' action $ initialState t (\_ -> return NoHash) (\_ x -> return x) 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 :: (Functor m, Monad m) => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () modifyItem path item = do path' <- (`catPaths` path) `fmap` currentDirectory age <- gets maxage changed' <- gets changed let getsize (Just (File b)) = lift (BL.length `fmap` 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 :: (Functor m, Monad m) => AnchoredPath -> AnchoredPath -> TreeMonad m () renameChanged from to = modify $ \st -> st { changed = rename' $ changed st } where rename' = M.fromList . map renameone . M.toList renameone (x, d) | from `isPrefix` x = (to `catPaths` relative from x, d) | otherwise = (x, d) relative (AnchoredPath from') (AnchoredPath x) = AnchoredPath $ drop (length from') x -- | 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 :: (Functor m, Monad m) => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () replaceItem path item = do path' <- (`catPaths` path) `fmap` currentDirectory modify $ \st -> st { tree = modifyTree (tree st) path' item } flushItem :: forall m. (Monad m, Functor m) => AnchoredPath -> TreeMonad m () flushItem path = do current <- gets tree case find current path of Nothing -> return () -- vanished, do nothing Just x -> do y <- fixHash x new <- gets update >>= ($ y) . ($ path) replaceItem path (Just new) where fixHash :: TreeItem m -> TreeMonad m (TreeItem m) fixHash f@(File (Blob con NoHash)) = do hash <- gets updateHash >>= \x -> lift $ x f return $ File $ Blob con hash fixHash (SubTree s) | treeHash s == NoHash = gets updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s) fixHash x = return x -- | If buffers are becoming large, sync, otherwise do nothing. flushSome :: (Monad m, Functor 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 <- (\s -> s - 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 instance (Functor m, Monad m) => TreeRO (TreeMonad m) where expandTo p = do t <- gets tree p' <- (`catPaths` p) `fmap` ask t' <- lift $ expandPath t p' modify $ \st -> st { tree = t' } return p' fileExists p = do p' <- expandTo p (isJust . (flip findFile p')) `fmap` gets tree directoryExists p = do p' <- expandTo p (isJust . (flip findTree p')) `fmap` gets tree exists p = do p' <- expandTo p (isJust . (flip find p')) `fmap` gets tree readFile p = do p' <- expandTo p t <- gets tree let f = findFile t p' case f of Nothing -> fail $ "No such file " ++ show p' Just x -> lift (readBlob x) currentDirectory = ask withDirectory dir act = do dir' <- expandTo dir local (\_ -> dir') act instance (Functor m, Monad m) => TreeRW (TreeMonad m) where writeFile p con = do _ <- expandTo p modifyItem p (Just blob) flushSome where blob = File $ Blob (return con) hash hash = NoHash -- 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 NoHash occurrences createDirectory p = do _ <- expandTo p modifyItem p $ Just $ SubTree emptyTree unlink p = do _ <- expandTo p modifyItem p Nothing rename from to = do from' <- expandTo from to' <- expandTo to tr <- gets tree let item = find tr from' found_to = find tr to' unless (isNothing found_to) $ fail $ "Error renaming: destination " ++ show to ++ " exists." unless (isNothing item) $ do modifyItem from Nothing modifyItem to item renameChanged from to copy from to = do from' <- expandTo from _ <- expandTo to tr <- gets tree let item = find tr from' unless (isNothing item) $ modifyItem to item findM' :: forall m a. (Monad m, Functor 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 = expandTo >=> \p' -> flip what p' <$> gets tree findM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (TreeItem m)) findM = findM' find findTreeM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Tree m)) findTreeM = findM' findTree findFileM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Blob m)) findFileM = findM' findFile darcs-2.10.2/hashed-storage/Storage/Hashed/Darcs.hs0000644000175000017500000003147612620122474024023 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} -- | A few darcs-specific utility functions. These are used for reading and -- writing darcs and darcs-compatible hashed trees. module Storage.Hashed.Darcs where import Prelude hiding ( lookup, catch ) import System.FilePath ( () ) import System.Directory( doesFileExist ) import Codec.Compression.GZip( decompress, compress ) import Control.Applicative( (<$>) ) import Control.Exception( catch, IOException ) import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import Data.List( sortBy ) import Data.Char( chr, ord, isSpace ) import Data.Maybe( fromJust, isJust ) import Control.Monad.State.Strict import Storage.Hashed.Tree hiding ( lookup ) import Storage.Hashed.AnchoredPath import Storage.Hashed.Utils import Storage.Hashed.Hash import Storage.Hashed.Packed import Storage.Hashed.Monad --------------------------------------------------------------------- -- Utilities for coping with the darcs directory format. -- -- | 'darcsDecodeWhite' interprets the Darcs-specific \"encoded\" filenames -- produced by 'darcsEncodeWhite' -- -- > darcsDecodeWhite "hello\32\there" == "hello there" -- > darcsDecodeWhite "hello\92\there" == "hello\there" -- > darcsDecodeWhite "hello\there" == error "malformed filename" darcsDecodeWhite :: String -> FilePath darcsDecodeWhite ('\\':cs) = case break (=='\\') cs of (theord, '\\':rest) -> chr (read theord) : darcsDecodeWhite rest _ -> error "malformed filename" darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs darcsDecodeWhite "" = "" -- | 'darcsEncodeWhite' translates whitespace in filenames to a darcs-specific -- format (backslash followed by numerical representation according to 'ord'). -- Note that backslashes are also escaped since they are used in the encoding. -- -- > darcsEncodeWhite "hello there" == "hello\32\there" -- > darcsEncodeWhite "hello\there" == "hello\92\there" darcsEncodeWhite :: FilePath -> String darcsEncodeWhite (c:cs) | isSpace c || c == '\\' = '\\' : (show $ ord c) ++ "\\" ++ darcsEncodeWhite cs darcsEncodeWhite (c:cs) = c : darcsEncodeWhite cs darcsEncodeWhite [] = [] darcsEncodeWhiteBS :: BS8.ByteString -> BS8.ByteString darcsEncodeWhiteBS = BS8.pack . darcsEncodeWhite . BS8.unpack decodeDarcsHash :: BS8.ByteString -> Hash decodeDarcsHash bs = case BS8.split '-' bs of [s, h] | BS8.length s == 10 -> decodeBase16 h _ -> decodeBase16 bs decodeDarcsSize :: BS8.ByteString -> Maybe Int decodeDarcsSize bs = case BS8.split '-' bs of [s, _] | BS8.length s == 10 -> case reads (BS8.unpack s) of [(x, _)] -> Just x _ -> Nothing _ -> Nothing darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment darcsLocation dir (s,h) = case hash of "" -> error "darcsLocation: invalid hash" _ -> (dir prefix s ++ hash, Nothing) where prefix Nothing = "" prefix (Just s') = formatSize s' ++ "-" formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n hash = BS8.unpack (encodeBase16 h) ---------------------------------------------- -- Darcs directory format. -- darcsFormatDir :: Tree m -> Maybe BL8.ByteString darcsFormatDir t = BL8.fromChunks <$> concat <$> mapM string (sortBy cmp $ listImmediate t) where cmp (Name a, _) (Name b, _) = compare a b string (Name name, item) = do header <- case item of File _ -> Just $ BS8.pack "file:\n" _ -> Just $ BS8.pack "directory:\n" hash <- case itemHash item of NoHash -> Nothing x -> Just $ encodeBase16 x return $ [ header , darcsEncodeWhiteBS name , BS8.singleton '\n' , hash, BS8.singleton '\n' ] darcsParseDir :: BL8.ByteString -> [(ItemType, Name, Maybe Int, Hash)] darcsParseDir content = parse (BL8.split '\n' content) where parse (t:n:h':r) = (header t, Name $ BS8.pack $ darcsDecodeWhite (BL8.unpack n), decodeDarcsSize hash, decodeDarcsHash hash) : parse r where hash = BS8.concat $ BL8.toChunks h' parse _ = [] header x | x == BL8.pack "file:" = BlobType | x == BL8.pack "directory:" = TreeType | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL8.unpack x ---------------------------------------- -- Utilities. -- -- | Compute a darcs-compatible hash value for a tree-like structure. darcsTreeHash :: Tree m -> Hash darcsTreeHash t = case darcsFormatDir t of Nothing -> NoHash Just x -> sha256 x -- The following two are mostly for experimental use in Packed. darcsUpdateDirHashes :: Tree m -> Tree m darcsUpdateDirHashes = updateSubtrees update where update t = t { treeHash = darcsTreeHash t } darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) darcsUpdateHashes = updateTree update where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t } update (File blob@(Blob con _)) = do hash <- sha256 <$> readBlob blob return $ File (Blob con hash) update stub = return stub darcsHash :: (Monad m, Functor m) => TreeItem m -> m Hash darcsHash (SubTree t) = return $ darcsTreeHash t darcsHash (File blob) = sha256 <$> readBlob blob darcsHash _ = return NoHash darcsAddMissingHashes :: (Monad m, Functor 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 @dir@ -- and with a given @hash@. readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)] readDarcsHashedDir dir h = do exist <- doesFileExist $ fst (darcsLocation dir h) unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h) compressed <- readSegment $ darcsLocation dir h let content = decompress compressed return $ if BL8.null compressed then [] else darcsParseDir content -- | Read in a darcs-style hashed tree. This is mainly useful for reading -- \"pristine.hashed\". You need to provide the root hash you are interested in -- (found in _darcs/hashed_inventory). readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO) readDarcsHashed' _ _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash" readDarcsHashed' sizefail dir root@(_, hash) = do items' <- readDarcsHashedDir dir root subs <- sequence [ do when (sizefail && isJust s) $ fail ("Unexpectedly encountered size-prefixed hash in " ++ dir) case tp of BlobType -> return (d, File $ Blob (readBlob' (s, h)) h) TreeType -> do let t = readDarcsHashed dir (s, h) return (d, Stub t h) | (tp, d, s, h) <- items' ] return $ makeTreeWithHash subs hash where readBlob' = fmap decompress . readSegment . darcsLocation dir readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO) readDarcsHashed = readDarcsHashed' False readDarcsHashedNosize :: FilePath -> Hash -> IO (Tree IO) readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash) ---------------------------------------------------- -- Writing darcs-style hashed trees. -- -- | Write a Tree into a darcs-style hashed directory. writeDarcsHashed :: Tree IO -> FilePath -> IO Hash writeDarcsHashed tree' dir = do t <- darcsUpdateDirHashes <$> expand tree' sequence_ [ dump =<< readBlob b | (_, File b) <- list t ] let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] _ <- mapM dump $ map fromJust dirs return $ darcsTreeHash t where dump bits = do let name = dir BS8.unpack (encodeBase16 $ sha256 bits) exist <- doesFileExist name unless exist $ BL.writeFile name (compress bits) -- | Create a hashed file from a 'FilePath' and content. In case the file exists -- it is kept untouched and is assumed to have the right content. XXX Corrupt -- files should be probably renamed out of the way automatically or something -- (probably when they are being read though). fsCreateHashedFile :: FilePath -> BL8.ByteString -> TreeIO () fsCreateHashedFile fn content = liftIO $ do exist <- doesFileExist fn unless exist $ BL.writeFile fn content -- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed -- to be fully available from the @directory@, and any changes will be written -- out to same. Please note that actual filesystem files are never removed. hashedTreeIO :: TreeIO a -- ^ action -> Tree IO -- ^ initial -> FilePath -- ^ directory -> IO (a, Tree IO) hashedTreeIO action t dir = do runTreeMonad action $ initialState t darcsHash updateItem where updateItem _ (File b) = File <$> updateFile b updateItem _ (SubTree s) = SubTree <$> updateSub s updateItem _ x = return x updateFile b@(Blob _ !h) = do content <- liftIO $ readBlob b let fn = dir BS8.unpack (encodeBase16 h) nblob = Blob (decompress <$> rblob) h rblob = BL.fromChunks <$> return <$> BS.readFile fn newcontent = compress content fsCreateHashedFile fn newcontent return nblob updateSub s = do let !hash = treeHash s Just dirdata = darcsFormatDir s fn = dir BS8.unpack (encodeBase16 hash) fsCreateHashedFile fn (compress dirdata) return s -------------------------------------------------------------- -- Reading and writing packed pristine. EXPERIMENTAL. ---- -- | Read a Tree in the darcs hashed format from an object storage. This is -- basically the same as readDarcsHashed from Storage.Hashed, but uses an -- object storage instead of traditional darcs filesystem layout. Requires the -- tree root hash as a starting point. readPackedDarcsPristine :: OS -> Hash -> IO (Tree IO) readPackedDarcsPristine os root = do items' <- darcsParseDir <$> grab root subs <- sequence [ case tp of BlobType -> return (d, File $ file h) TreeType -> let t = readPackedDarcsPristine os h in return (d, Stub t h) | (tp, d, _, h) <- items' ] return $ makeTreeWithHash subs root where file h = Blob (grab h) h grab hash = do maybeseg <- lookup os hash case maybeseg of Nothing -> fail $ "hash " ++ BS8.unpack (encodeBase16 hash) ++ " not available" Just seg -> readSegment seg -- | Write a Tree into an object storage, using the darcs-style directory -- formatting (and therefore darcs-style hashes). Gives back the object storage -- and the root hash of the stored Tree. NB. The function expects that the Tree -- comes equipped with darcs-style hashes already! writePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash) writePackedDarcsPristine tree' os = do t <- darcsUpdateDirHashes <$> expand tree' files <- sequence [ readBlob b | (_, File b) <- list t ] let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] os' <- hatch os $ files ++ (map fromJust dirs) return (os', darcsTreeHash t) storePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash) storePackedDarcsPristine tree' os = do (os', root) <- writePackedDarcsPristine tree' os return $ (os' { roots = root : roots os' -- FIXME we probably don't want to override the references -- thing completely here... , references = darcsPristineRefs }, root) darcsPristineRefs :: FileSegment -> IO [Hash] darcsPristineRefs fs = do con <- (darcsParseDir <$> readSegment fs) `catch` \(_ :: IOException) -> return [] return $! [ hash | (_, _, _, hash) <- con, valid hash ] where valid NoHash = False valid _ = True darcsCheckExpand :: Tree IO -> IO (Either [(FilePath, Hash, Maybe Hash)] (Tree IO)) darcsCheckExpand t = do problemsOrTree <- checkExpand darcsHash t case problemsOrTree of Left problems -> return . Left $ map render problems Right tree' -> return . Right $ tree' where render (path, h, h') = (anchorPath "." path, h, h')darcs-2.10.2/hashed-storage/Storage/Hashed/Packed.hs0000644000175000017500000002377512620122474024161 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE ParallelListComp #-} -- | This module implements an "object storage". This is a directory on disk -- containing a content-addressed storage. This is useful for storing all kinds -- of things, particularly filesystem trees, or darcs pristine caches and patch -- objects. However, this is an abstract, flat storage: no tree semantics are -- provided. You just need to provide a reference-collecting functionality, -- computing a list of references for any given object. The system provides -- transparent garbage collection and packing. module Storage.Hashed.Packed ( Format(..), Block, OS -- * Basic operations. , hatch, compact, repack, lookup -- * Creating and loading. , create, load -- * Low-level. , format, blockLookup, live, hatchery, mature, roots, references, rootdir ) where import Prelude hiding ( lookup, read ) import Storage.Hashed.AnchoredPath( ) import Storage.Hashed.Tree ( ) import Storage.Hashed.Utils import Storage.Hashed.Hash import Control.Monad( forM, forM_, unless ) import Control.Applicative( (<$>) ) import System.FilePath( (), (<.>) ) import System.Directory( createDirectoryIfMissing, removeFile , getDirectoryContents ) import Bundled.Posix( fileExists, isDirectory, getFileStatus ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS import Data.Maybe( listToMaybe, catMaybes, isNothing ) import Data.Binary( encode, decode ) import qualified Data.Set as S import qualified Data.Map as M import Data.List( sort ) import Data.Int( Int64 ) -- | On-disk format for object storage: we implement a completely loose format -- (one file per object), a compact format stored in a single append-only file -- and an immutable \"pack\" format. data Format = Loose | Compact | Pack deriving (Show, Eq) loose_dirs :: [[Char]] loose_dirs = let chars = ['0'..'9'] ++ ['a'..'f'] in [ [a,b] | a <- chars, b <- chars ] loosePath :: OS -> Hash -> FilePath loosePath _ NoHash = error "No path for NoHash!" loosePath os hash = let hash' = BS.unpack (encodeBase16 hash) in rootdir os "hatchery" take 2 hash' drop 2 hash' looseLookup :: OS -> Hash -> IO (Maybe FileSegment) looseLookup _ NoHash = return Nothing looseLookup os hash = do let path = loosePath os hash exist <- fileExists <$> getFileStatus path return $ if exist then Just (path, Nothing) else Nothing -- | Object storage block. When used as a hatchery, the loose or compact format -- are preferable, while for mature space, the pack format is more useful. data Block = Block { blockLookup :: Hash -> IO (Maybe FileSegment) , size :: Int64 , format :: Format } -- | Object storage. Contains a single \"hatchery\" and possibly a number of -- mature space blocks, usually in form of packs. It also keeps a list of root -- pointers and has a way to extract pointers from objects (externally -- supplied). These last two things are used to implement a simple GC. data OS = OS { hatchery :: Block , mature :: [Block] , roots :: [Hash] , references :: FileSegment -> IO [Hash] , rootdir :: FilePath } -- | Reduce number of packs in the object storage. This may both recombine -- packs to eliminate dead objects and join some packs to form bigger packs. repack :: OS -> IO OS repack _ = error "repack undefined" -- | Add new objects to the object storage (i.e. put them into hatchery). It is -- safe to call this even on objects that are already present in the storage: -- such objects will be skipped. hatch :: OS -> [BL.ByteString] -> IO OS hatch os blobs = do processed <- mapM sieve blobs write [ (h, b) | (True, h, b) <- processed ] where write bits = case format (hatchery os) of Loose -> do _ <- forM bits $ \(hash, blob) -> do BL.writeFile (loosePath os hash) blob return os Compact -> error "hatch/compact undefined" _ -> fail "Hatchery must be either Loose or Compact." sieve blob = do let hash = sha256 blob absent <- isNothing <$> lookup os hash return (absent, hash, blob) -- | Move things from hatchery into a (new) pack. compact :: OS -> IO OS compact os = do objects <- live os [hatchery os] block <- createPack os (M.toList objects) cleanup return $ os { mature = block:mature os } where cleanup = case format (hatchery os) of Loose -> forM_ loose_dirs $ nuke . ((rootdir os "hatchery") ) Compact -> removeFile (rootdir os "hatchery") >> return () _ -> fail "Hatchery must be either Loose or Compact." nuke dir = mapM (removeFile . (dir )) =<< (Prelude.filter (`notElem` [".", ".."]) `fmap` getDirectoryContents dir) blocksLookup :: [Block] -> Hash -> IO (Maybe (Hash, FileSegment)) blocksLookup blocks hash = do segment <- cat `fmap` mapM (flip blockLookup hash) blocks return $ case segment of Nothing -> Nothing Just seg -> Just (hash, seg) where cat = listToMaybe . catMaybes lookup :: OS -> Hash -> IO (Maybe FileSegment) lookup os hash = do res <- blocksLookup (hatchery os : mature os) hash return $ case res of Nothing -> Nothing Just (_, seg) -> Just seg -- | Create an empty object storage in given directory, with a hatchery of -- given format. The directory is created if needed, but is assumed to be -- empty. create :: FilePath -> Format -> IO OS create path fmt = do createDirectoryIfMissing True path _ <- initHatchery load path where initHatchery | fmt == Loose = do mkdir hatchpath forM loose_dirs $ mkdir . (hatchpath ) | fmt == Compact = error "create/mkHatchery Compact undefined" | otherwise = error "create/mkHatchery Pack undefined" mkdir = createDirectoryIfMissing False hatchpath = path "hatchery" load :: FilePath -> IO OS load path = do hatch_stat <- getFileStatus $ path "hatchery" let is_os = fileExists hatch_stat is_dir = isDirectory hatch_stat unless is_os $ fail $ path ++ " is not an object storage!" let _hatchery = Block { blockLookup = look os , format = if is_dir then Loose else Compact , size = undefined } os = OS { hatchery = _hatchery , rootdir = path , mature = packs , roots = _roots , references = undefined } look | format _hatchery == Loose = looseLookup | otherwise = undefined packs = [] -- FIXME read packs _roots = [] -- FIXME read root pointers return os readPack :: FilePath -> IO Block readPack file = do bits <- readSegment (file, Nothing) let count = decode (BL.take 8 $ bits) _lookup NoHash _ _ = return Nothing _lookup hash first final = do let middle = first + ((final - first) `div` 2) rawhash = rawHash hash res <- case ( compare rawhash (hashof first) , compare rawhash (hashof middle) , compare rawhash (hashof final) ) of (LT, _, _) -> return Nothing ( _, _, GT) -> return Nothing (EQ, _, _) -> return $ Just (segof first) ( _, _, EQ) -> return $ Just (segof final) (GT, EQ, LT) -> return $ Just (segof middle) (GT, GT, LT) | middle /= final -> _lookup hash middle final (GT, LT, LT) | first /= middle -> _lookup hash first middle ( _, _, _) -> return Nothing return res headerof i = BL.take 51 $ BL.drop (8 + i * 51) bits hashof i = BS.concat $ BL.toChunks $ BL.take 32 $ headerof i segof i = (file, Just (count * 51 + 8 + from, sz)) where from = decode (BL.take 8 $ BL.drop 33 $ headerof i) sz = decode (BL.take 8 $ BL.drop 42 $ headerof i) return $ Block { size = BL.length bits , format = Pack , blockLookup = \h -> _lookup h 0 (count - 1) } createPack :: OS -> [(Hash, FileSegment)] -> IO Block createPack os bits = do contents <- mapM readSegment (map snd bits) let offsets = scanl (+) 0 $ map BL.length contents headerbits = [ BL.concat [ BL.fromChunks [rawhash] , BL.pack "@" , encode offset , BL.pack "!" , encode $ BL.length string , BL.pack "\n" ] | (SHA256 rawhash, _) <- bits | string <- contents | offset <- offsets ] header = BL.concat $ (encode $ length bits) : sort headerbits blob = BL.concat $ header:contents hash = sha256 blob path = rootdir os BS.unpack (encodeBase16 hash) <.> "bin" BL.writeFile path blob readPack path -- | Build a map of live objects (i.e. those reachable from the given roots) in -- a given list of Blocks. live :: OS -> [Block] -> IO (M.Map Hash FileSegment) live os blocks = reachable (references os) (blocksLookup blocks) (S.fromList $ roots os) darcs-2.10.2/hashed-storage/Storage/Hashed/Diff.hs0000644000175000017500000001262312620122474023630 0ustar00guillaumeguillaume00000000000000module Storage.Hashed.Diff where import Prelude hiding ( lookup, filter ) import qualified Data.ByteString.Lazy.Char8 as BL import Storage.Hashed.Tree import Storage.Hashed.AnchoredPath import Data.List.LCS import Data.List ( groupBy ) unidiff :: Tree IO -> Tree IO -> IO BL.ByteString unidiff l r = do (from, to) <- diffTrees l r diffs <- sequence $ zipCommonFiles diff from to return $ BL.concat diffs where diff p a b = do x <- readBlob a y <- readBlob b return $ diff' p x y diff' p x y = case unifiedDiff x y of x' | BL.null x' -> BL.empty | otherwise -> (BL.pack $ "--- " ++ anchorPath "old" p ++ "\n" ++ "+++ " ++ anchorPath "new" p ++ "\n") `BL.append` x' type Line = BL.ByteString data WeaveLine = Common Line | Remove Line | Add Line | Replace Line Line | Skip Int deriving Show -- | A weave -- two files woven together, with common and differing regions -- marked up. Cf. 'WeaveLine'. type Weave = [WeaveLine] -- | Sort of a sub-weave. type Hunk = [WeaveLine] -- | Produce unified diff (in a string form, ie. formatted) from a pair of -- bytestrings. unifiedDiff :: BL.ByteString -> BL.ByteString -> BL.ByteString unifiedDiff a b = printUnified $ concat unifiedHunks where unifiedHunks = reduceContext 3 $ map unifyHunk $ hunks $ weave a b -- | Weave two bytestrings. Intermediate data structure for the actual unidiff -- implementation. No skips are produced. weave :: BL.ByteString -> BL.ByteString -> Weave weave a' b' = weave' left common right where left = init' (BL.split '\n' a') -- drop trailing newline right = init' (BL.split '\n' b') -- drop trailing newline init' [] = [] init' x = init x common = lcs left right weave' [] [] [] = [] weave' [] c [] = error $ "oops: Left & Right empty, Common: " ++ show c weave' [] [] (b:bs) = Add b : weave' [] [] bs weave' (a:as) [] [] = Remove a : weave' as [] [] weave' (a:as) [] (b:bs) = Replace a b : weave' as [] bs weave' (a:as) (c:cs) (b:bs) | a == c && b == c = Common a : weave' as cs bs | a == c && b /= c = Add b : weave' (a:as) (c:cs) bs | a /= c && b == c = Remove a : weave' as (c:cs) (b:bs) | a /= c && b /= c = Replace a b : weave' as (c:cs) bs | otherwise = error "oops!" weave' a c b = error $ "oops: \nLeft: " ++ show a ++ "\nCommon: " ++ show c ++ "\nRight: " ++ show b -- | Break up a 'Weave' into 'Hunk's. hunks :: Weave -> [Hunk] hunks = groupBy grp where grp (Common _) (Common _) = True grp (Common _) _ = False grp _ (Common _) = False grp _ _ = True -- | Reformat a 'Hunk' into a format suitable for unified diff. Replaces are -- turned into add/remove pairs, all removals in a hunk go before all -- adds. 'Hunk's of 'Common' lines are left intact. Produces input suitable for -- 'reduceContext'. unifyHunk :: Hunk -> Hunk unifyHunk h = case h of (Common _:_) -> h _ -> reorder $ concatMap breakup h where reorder h' = [ Remove a | Remove a <- h' ] ++ [ Add a | Add a <- h' ] breakup (Replace f t) = [Remove f, Add t] breakup x = [x] -- | Break up a 'Weave' into unified 'Hunk's, leaving @n@ lines of context around -- every hunk. Consecutive 'Common' lines not used as context are replaced with -- 'Skip's. reduceContext :: Int -> [Hunk] -> [Hunk] reduceContext n hs = case hs of [] -> [] [Common _:_] -> [] [x] -> [x] [h,t] -> [reduce 0 n h, reduce n 0 t] (h:rest) -> reduce 0 n h : map (reduce n n) (init rest) ++ [reduce n 0 $ last rest] where reduce s e h@(Common _:_) | length h <= s + e = h | otherwise = take s h ++ [Skip $ length h - e - s ] ++ drop (length h - e) h reduce _ _ h = h -- | Format a 'Weave' for printing. deweave :: Weave -> BL.ByteString deweave = BL.unlines . map disp where disp (Common l) = BL.cons ' ' l disp (Remove l) = BL.cons '-' l disp (Add l) = BL.cons '+' l disp (Replace _ t) = BL.cons '!' t disp (Skip n) = BL.pack $ "-- skip " ++ show n ++ " lines --" -- | Print a \"hunked\" weave in form of an unified diff. 'Hunk' boundaries are -- marked up as 'Skip' lines. Cf. 'reduceContext'. printUnified :: Weave -> BL.ByteString printUnified hunked = printHunks 1 1 $ groupBy splits hunked where splits (Skip _) _ = False splits _ (Skip _) = False splits _ _ = True printHunks _ _ [] = BL.empty printHunks l r ([Skip n]:rest) = printHunks (n+l) (n+r) rest printHunks l r (h:rest) = (BL.pack $ "@@ -" ++ show l ++ "," ++ show (removals h) ++ " +" ++ show r ++ "," ++ show (adds h) ++ " @@\n") `BL.append` deweave h `BL.append` printHunks (l + removals h) (r + adds h) rest commons h = length [ () | (Common _) <- h ] adds h = commons h + length [ () | (Add _) <- h ] removals h = commons h + length [ () | (Remove _) <- h ] darcs-2.10.2/hashed-storage/Storage/Hashed/AnchoredPath.hs0000644000175000017500000001175412620122474025324 0ustar00guillaumeguillaume00000000000000-- | This module implements 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). module Storage.Hashed.AnchoredPath ( Name(..), AnchoredPath(..), anchoredRoot, appendPath, anchorPath , isPrefix, parent, parents, catPaths, flatten, makeName, appendToName -- * Unsafe functions. , floatBS, floatPath, replacePrefixPath ) where import qualified Data.ByteString.Char8 as BS import Data.List( isPrefixOf, inits ) import System.FilePath( (), splitDirectories, normalise, dropTrailingPathSeparator ) ------------------------------- -- AnchoredPath utilities -- newtype Name = Name BS.ByteString deriving (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 ("floatPath" -- but take care when doing that) or . newtype AnchoredPath = AnchoredPath [Name] deriving (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 = case n of (Name s) | s == BS.empty -> AnchoredPath p | s == BS.pack "." -> AnchoredPath p | otherwise -> 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 -> AnchoredPath parent (AnchoredPath x) = AnchoredPath (init x) -- | List all parents of a given path. foo/bar/baz -> [foo, foo/bar] parents :: AnchoredPath -> [AnchoredPath] parents (AnchoredPath x) = map AnchoredPath . init . inits $ x -- | 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 BS.unpack (flatten p) {-# INLINE anchorPath #-} -- | Unsafe. Only ever use on bytestrings that came from flatten on a -- pre-existing AnchoredPath. floatBS :: BS.ByteString -> AnchoredPath floatBS = AnchoredPath . map Name . takeWhile (not . BS.null) . BS.split '/' flatten :: AnchoredPath -> BS.ByteString flatten (AnchoredPath []) = BS.singleton '.' flatten (AnchoredPath p) = BS.intercalate (BS.singleton '/') [ n | (Name n) <- p ] makeName :: String -> Name makeName ".." = error ".. is not a valid AnchoredPath component name" makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name" | otherwise = Name $ BS.pack n -- | Take a relative FilePath and turn it into an AnchoredPath. The operation -- is (relatively) unsafe. Basically, by using floatPath, you are testifying -- that the argument is a path relative to some common root -- i.e. the root of -- the associated "Tree" object. Also, there are certain invariants about -- AnchoredPath that this function tries hard to preserve, but probably cannot -- guarantee (i.e. this is a best-effort thing). You should sanitize any -- FilePaths before you declare them "good" by converting into AnchoredPath -- (using this function). floatPath :: FilePath -> AnchoredPath floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator where make ["."] = AnchoredPath [] make x = AnchoredPath $ map (Name . BS.pack) x anchoredRoot :: AnchoredPath anchoredRoot = AnchoredPath [] -- | Take a prefix path, the changed prefix path, and a path to change. -- Assumes the prefix path is a valid prefix. If prefix is wrong return -- AnchoredPath []. replacePrefixPath :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath replacePrefixPath (AnchoredPath []) b c = catPaths b c replacePrefixPath (AnchoredPath (r:p)) b (AnchoredPath (r':p')) | r == r' = replacePrefixPath (AnchoredPath p) b (AnchoredPath p') | otherwise = AnchoredPath [] replacePrefixPath _ _ _ = AnchoredPath [] -- | Append a ByteString to the last Name of an AnchoredPath. appendToName :: AnchoredPath -> String -> AnchoredPath appendToName (AnchoredPath p) s = AnchoredPath (init p++[Name finalname]) where suffix = BS.pack s finalname | suffix `elem` (BS.tails lastname) = lastname | otherwise = BS.append lastname suffix lastname = case last p of Name name -> name darcs-2.10.2/hashed-storage/Storage/Hashed.hs0000644000175000017500000000400012620122474022746 0ustar00guillaumeguillaume00000000000000module Storage.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). readPlainTree, readDarcsHashed -- * Blob access. , readBlob -- * Writing trees. , writePlainTree, writeDarcsHashed -- * Unsafe functions for the curious explorer. -- -- | These are more useful for playing within ghci than for real, serious -- programs. They generally trade safety for conciseness. Please use -- responsibly. Don't kill innocent kittens. , floatPath, printPath ) where import Storage.Hashed.AnchoredPath import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL import Storage.Hashed.Tree ( Tree, TreeItem(..), listImmediate, find, readBlob ) -- For re-exports. import Storage.Hashed.Darcs( readDarcsHashed, writeDarcsHashed ) import Storage.Hashed.Plain( readPlainTree, writePlainTree ) ------------------------ -- For explorers -- -- | Take a relative FilePath within a Tree and print the contents of the -- object there. Useful for exploration, less so for serious programming. printPath :: Tree IO -> FilePath -> IO () printPath t p = print' $ find t (floatPath p) where print' Nothing = putStrLn $ "ERROR: No object at " ++ p print' (Just (File b)) = do putStrLn $ "== Contents of file " ++ p ++ ":" BL.unpack `fmap` readBlob b >>= putStr print' (Just (SubTree t')) = do putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):" putStr $ unlines $ map BS.unpack $ listNames t' print' (Just (Stub _ _)) = putStrLn $ "== (not listing stub at " ++ p ++ ")" listNames t' = [ n | (Name n, _) <- listImmediate t' ] darcs-2.10.2/hashed-storage/test.hs0000644000175000017500000000137612620122474021142 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE ScopedTypeVariables #-} import Storage.Hashed.Test( tests ) import Prelude hiding( catch ) import Test.Framework( defaultMain ) import System.Directory( createDirectory, removeDirectoryRecursive , setCurrentDirectory ) import Codec.Archive.Zip( extractFilesFromArchive, toArchive ) import qualified Data.ByteString.Lazy as BL import Control.Exception( catch, IOException ) main :: IO () main = do zipFile <- toArchive `fmap` BL.readFile "hashed-storage/testdata.zip" removeDirectoryRecursive "_test_playground" `catch` \(_ :: IOException) -> return () createDirectory "_test_playground" setCurrentDirectory "_test_playground" extractFilesFromArchive [] zipFile defaultMain tests darcs-2.10.2/hashed-storage/Bundled/0000755000175000017500000000000012620122474021175 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/hashed-storage/Bundled/Posix.hsc0000644000175000017500000000645712620122474023012 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, RankNTypes #-} module Bundled.Posix( getFdStatus, getSymbolicLinkStatus, getFileStatus , getFileStatusBS , fileExists , modificationTime, fileSize, FileStatus , EpochTime, isDirectory, isRegularFile ) where import qualified Data.ByteString.Char8 as BS #if mingw32_HOST_OS #else import Data.ByteString.Unsafe( unsafeUseAsCString ) #endif import Foreign.Marshal.Alloc ( allocaBytes ) import Foreign.C.Error ( throwErrno, getErrno, eNOENT ) import Foreign.C.Types ( CTime, CInt ) import Foreign.Ptr ( Ptr ) import System.Posix.Internals ( CStat, c_fstat, sizeof_stat , st_mode, st_size, st_mtime, s_isdir, s_isreg ) #if mingw32_HOST_OS import System.Posix.Internals ( c_stat, CFilePath ) #endif import System.Posix.Types ( Fd(..), CMode, EpochTime ) #if mingw32_HOST_OS import Foreign.C.String( withCWString, CWString ) #else import Foreign.C.String ( withCString, CString ) #endif #if mingw32_HOST_OS import Data.Int ( Int64 ) type FileOffset = Int64 lstat :: CFilePath -> Ptr CStat -> IO CInt lstat = c_stat #else import System.Posix.Types ( FileOffset ) import System.Posix.Internals( lstat ) #endif #if mingw32_HOST_OS bsToPath :: forall a. BS.ByteString -> (CWString -> IO a) -> IO a bsToPath s f = withCWString (BS.unpack s) f strToPath :: forall a. String -> (CWString -> IO a) -> IO a strToPath = withCWString #else bsToPath :: forall a. BS.ByteString -> (CString -> IO a) -> IO a bsToPath = unsafeUseAsCString strToPath :: forall a. String -> (CString -> IO a) -> IO a strToPath = withCString #endif data FileStatus = FileStatus { fst_exists :: !Bool, fst_mode :: !CMode, fst_mtime :: !CTime, fst_size :: !FileOffset } getFdStatus :: Fd -> IO FileStatus getFdStatus (Fd fd) = do do_stat (c_fstat fd) do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus do_stat stat_func = do allocaBytes sizeof_stat $! \p -> do ret <- stat_func p if (ret == -1) then do err <- getErrno if (err == eNOENT) then return $! (FileStatus False 0 0 0) else throwErrno "do_stat" else do mode <- st_mode p mtime <- st_mtime p size <- st_size p return $! FileStatus True mode mtime size {-# INLINE do_stat #-} isDirectory :: FileStatus -> Bool isDirectory = s_isdir . fst_mode isRegularFile :: FileStatus -> Bool isRegularFile = s_isreg . fst_mode modificationTime :: FileStatus -> EpochTime modificationTime = fst_mtime fileSize :: FileStatus -> FileOffset fileSize = fst_size fileExists :: FileStatus -> Bool fileExists = fst_exists #include -- lstat is broken on win32 with at least GHC 6.10.3 getSymbolicLinkStatus :: FilePath -> IO FileStatus ##if mingw32_HOST_OS getSymbolicLinkStatus = getFileStatus ##else getSymbolicLinkStatus fp = do_stat (\p -> (fp `strToPath` (`lstat` p))) ##endif getFileStatus :: FilePath -> IO FileStatus getFileStatus fp = do_stat (\p -> (fp `strToPath` (`lstat` p))) -- | Requires NULL-terminated bytestring -> unsafe! Use with care. getFileStatusBS :: BS.ByteString -> IO FileStatus getFileStatusBS fp = do_stat (\p -> (fp `bsToPath` (`lstat` p))) {-# INLINE getFileStatusBS #-} darcs-2.10.2/hashed-storage/LICENSE0000644000175000017500000000246412620122474020633 0ustar00guillaumeguillaume00000000000000Copyright Petr Rockai, Jose Neder 2009-2013 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. 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. darcs-2.10.2/darcs/0000755000175000017500000000000012620122474016016 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/darcs/darcs.hs0000644000175000017500000000641712620122474017456 0ustar00guillaumeguillaume00000000000000-- 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 ( AssertionFailed(..), handle ) import Control.Monad ( forM_ ) import System.IO ( stdin, stdout, stderr, hSetBinaryMode ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs ) import Darcs.UI.RunCommand ( runTheCommand ) import Darcs.UI.Commands.Help ( helpCmd, listAvailableCommands, printVersion, commandControlList ) import Darcs.UI.Flags ( DarcsFlag(Verbose) ) import Darcs.Util.AtExit ( withAtexit, atexit ) import Darcs.Repository( reportBadSources ) import Darcs.Util.SignalHandler ( withSignalsHandled ) import Darcs.Util.ByteString ( decodeString ) import Darcs.UI.External ( setDarcsEncodings ) import Darcs.Util.Exec ( ExecException(..) ) import Darcs.Util.Path ( getCurrentDirectory ) 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 >>= mapM decodeString here <- getCurrentDirectory let runHelpCmd = helpCmd (here, here) [] [] -- Explicitly handle no-args and special "help" arguments. case argv of [] -> printVersion >> runHelpCmd ["-h"] -> runHelpCmd ["--help"] -> runHelpCmd ["--overview"] -> helpCmd (here, here) [Verbose] [] ["--commands"] -> listAvailableCommands ["-v"] -> putStrLn version ["--version"] -> putStrLn version ["--exact-version"] -> printExactVersion _ -> 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 printExactVersion = do putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__ putStrLn context putStrLn "Compiled with:\n" putStr builddeps darcs-2.10.2/GNUmakefile0000644000175000017500000000116012620122474016772 0ustar00guillaumeguillaume00000000000000# Good for tags. DARCS_FILES = $(wildcard src/[A-Z]*.hs src/*/[A-Z]*.hs src/*/*/[A-Z]*.hs) \ $(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,$^) ctags -a $(filter %.c,$^) # TAGS is for etags, whereas tags is for ctags TAGS: $(DARCS_FILES) src/*.c hasktags -e $(filter %.lhs %.hs,$^) etags -a $(filter %.c,$^) clean: rm -f TAGS tags darcs-2.10.2/tests/0000755000175000017500000000000012620122474016064 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/tests/uniqueoptions.sh0000644000175000017500000000120712620122474021342 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash echo echo Checking that each command expects each option only once echo . ./lib if echo $OS | grep -i windows; then echo Noone knows how to handle newlines under cygwin, so we skip this test exit 0 fi rm -rf temp1 mkdir temp1 cd temp1 for i in `darcs --commands | grep -v -- -- | xargs echo`; do 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 if cmp $i uni$i; then echo passed. else echo failed! diff -c uni$i $i exit 1 fi done cd .. rm -rf temp1 darcs-2.10.2/tests/invalid_pending_after_mv_to_self.sh0000644000175000017500000000043512620122474025152 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # A regression test for issue567 . ./lib rm -rf temp mkdir temp cd temp darcs init mkdir dir touch dir/t.t darcs add dir darcs add dir/t.t darcs record -am 'initial add' # grand finale? Can we move the file to itself? darcs mv dir/t.t dir/ cd .. rm -rf temp darcs-2.10.2/tests/issue1224_convert-darcs2-repository.sh0000644000175000017500000000332212620122474025212 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1224 - Attempting to darcs convert a repository ## which is already in darcs-2 format leads to inconsistent result ## ## Copyright (C) 2009 Tomas Caithaml ## ## 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 not relevant for other than darcs 2 repositories grep darcs-2 $HOME/.darcs/defaults || exit 200 . lib rm -rf R darcs init --repo R echo File contents > R/file.txt darcs add R/file.txt --repodir R 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 not darcs convert temp/repo-2 temp/repo-2-converted < ack rm -rf R darcs-2.10.2/tests/mv-formerly-pl.sh0000644000175000017500000000627712620122474021324 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/unrecord-add.sh0000644000175000017500000000043012620122474020764 0ustar00guillaumeguillaume00000000000000#!/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 record -a -m 'addfoo' darcs unrecord -a darcs whatsnew > unrecorded cat unrecorded diff -u correct unrecorded cd .. rm -rf temp1 darcs-2.10.2/tests/query_manifest.sh0000644000175000017500000000551412620122474021460 0ustar00guillaumeguillaume00000000000000#!/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 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 darcs-2.10.2/tests/issue761-fail-early-bad-pull-match.sh0000644000175000017500000000145312620122474024624 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue803.sh0000644000175000017500000000067312620122474020011 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # http://bugs.darcs.net/issue803: Darcs 2.0 regression on manual renames . lib rm -rf temp mkdir temp cd temp darcs init touch a.txt darcs add a.txt darcs record -a -m "First" -A me mkdir subdir darcs add subdir darcs record -a -m "Second" -A me mv a.txt subdir/ darcs mv a.txt subdir/a.txt darcs record -a -m "Third" -A me darcs changes --last 1 -v > stdout cat stdout not grep 'rmfile' stdout cd .. rm -rf temp darcs-2.10.2/tests/issue1248.sh0000644000175000017500000000046012620122474020067 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/binary.sh0000644000175000017500000000075312620122474017711 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib binary=example_binary.png function checkbinary(){ cmp $binary ../temp1/$binary } rm -rf temp1 temp2 mkdir temp1 temp2 cd temp1 darcs init cp $TESTDATA/$binary . darcs add $binary darcs record -am P1 cd ../temp2 darcs init test ! -e $binary darcs pull ../temp1 -a checkbinary darcs obliterate -a test ! -e $binary darcs pull ../temp1 -a checkbinary darcs unrecord -a checkbinary darcs revert -a test ! -e $binary darcs unrevert -a checkbinary rm -rf temp1 temp2 darcs-2.10.2/tests/issue2207-annotate-directory.sh0000644000175000017500000000256212620122474023701 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2207 - ## ## 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 # Load some portability helpers. rm -rf R darcs init --repo R cd R mkdir d touch d/f darcs record -lam 'p1' darcs annotate d | grep 'p1' darcs-2.10.2/tests/issue2382-mv-dir-to-file-confuses-darcs.sh0000644000175000017500000000721012620122474025535 0ustar00guillaumeguillaume00000000000000#!/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\+//' > $1 darcs unrecord --last 1 -a } function rmOutputFiles () { rm recoutput* expected* whoutput* } . lib 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 darcs-2.10.2/tests/issue1978.sh0000644000175000017500000000066112620122474020104 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash #pragma repo-format darcs-2 . lib mkdir future cd future darcs init touch titi darcs add titi darcs record -am titi cat > _darcs/format < log not grep apple log not grep banana log grep clementine log cd .. rm -rf temp1 # not sure what i'm going for here - if coalescing happens strictly # before commuting, no problem, but what if patches are commuted # before coalescing? mkdir temp1 cd temp1 darcs init darcs setpref predist apple darcs setpref predist banana darcs setpref predist apple darcs setpref predist clementine darcs setpref predist banana darcs record -a -m manamana darcs changes --verbose > log not grep apple log not grep clementine log grep banana log cd .. rm -rf temp1 darcs-2.10.2/tests/repair.sh0000644000175000017500000000067712620122474017714 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 mkdir 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 echo B > foo darcs record -a -m BB -A x echo C > foo darcs record -a -m CC -A x for i in _darcs/pristine*; do echo Empty the pristine directory: $i rm -rf $i mkdir $i done darcs repair cd .. rm -rf temp1 darcs-2.10.2/tests/amend-record-back-up.sh0000644000175000017500000000266612620122474022312 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## 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. 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 darcs changes -p 'file2' -v | grep amended darcs-2.10.2/tests/issue154_pull_dir_not_empty.sh0000644000175000017500000000313112620122474023770 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue154 - when applying a patch that removes a directory, ## don't remove the directory from the working tree unless it's empty. ## ## Copyright (C) 2008 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 temp1 mkdir temp1 cd temp1 darcs init mkdir d darcs add d darcs record -a -m "Added directory d" darcs get ./ puller cd puller touch d/moo darcs add d/moo cd .. rm -rf d darcs record -a -m "Remove directory d" cd puller echo y | darcs pull -a .. > log grep -i "backing up" log grep -i "finished pulling" log cd .. rm -rf temp1 darcs-2.10.2/tests/tag-ask-deps.sh0000644000175000017500000000257212620122474020706 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue142_record-log.sh0000644000175000017500000000302212620122474022111 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/failing-issue2238-unadded-files-showing-added.sh0000644000175000017500000000255212620122474026717 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2238 - passing -l twice to whatsnew reports unadded files as ## already added. ## ## 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 foo darcs wh -l | grep 'a \./foo' darcs wh -ll | grep 'a \./foo' darcs wh -ll | not grep 'A \./foo' darcs-2.10.2/tests/failing-issue2383-hunk-edit-fails.sh0000644000175000017500000000442412620122474024465 0ustar00guillaumeguillaume00000000000000#!/bin/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' darcs-2.10.2/tests/merging_newlines.sh0000644000175000017500000000134612620122474021760 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # trick: requiring something to fail . lib # 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 .. 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" 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 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 cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue1488_whatsnew-l.sh0000644000175000017500000000271212620122474022250 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1488 - whatsnew in non-added directory crashes on fromJust ## ## Copyright (C) 2009 Marnix Klooster ## ## 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 -p R/Foo/Bar # 2 directory levels needed cd R darcs init cd Foo/Bar # and now the real problem causer: darcs whatsnew -l . # a "fromJust error" in Whatsnew.lhs darcs-2.10.2/tests/unpull-formerly-pl.sh0000644000175000017500000000144612620122474022212 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 not darcs whatsnew grep 'love the world' foo echo yy | darcs unpull -p baz2world not darcs whatsnew grep 'love the baz' foo echo yy | darcs unpull -p bar2baz grep 'love the bar' foo echo yy | darcs unpull -p nolove grep 'love' foo && exit 1 || true cd .. rm -rf tempA darcs-2.10.2/tests/mv_and_remove_tests.sh0000644000175000017500000000206012620122474022461 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 mkdir d darcs add d darcs mv f* d darcs remove d/fi cd d darcs remove fo echo let us have fun > fun darcs add fun darcs mv fun fum .. darcs record --author me --all --no-test --name mv cd .. if darcs show files | egrep '^./fee$'; then false; else true; fi test ! -f fee darcs show contents d/fee | cmp d/fee - test ! -f fi test -f d/fi if darcs show files | egrep '^./fi$'; then false; else true; fi if darcs show files | egrep '^./d/fi$'; then false; else true; fi test ! -f fo test -f d/fo if darcs show files | egrep '^./fo$'; then false; else true; fi if darcs show files | egrep '^./d/fo$'; then false; else true; fi darcs show contents fun | cmp fun - darcs show contents fum | cmp fum - darcs mv fun d darcs record -A me -a --no-test -m "fun again" darcs show content d/fun | cmp d/fun - test ! -f fun if darcs show files | egrep '^./fun$'; then false; else true; fi # Now clean up. cd .. rm -rf temp darcs-2.10.2/tests/issue1465_ortryrunning.sh0000644000175000017500000000555712620122474022744 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1465 - ortryrunning should try RHS if AND ONLY IF the ## LHS wasn't found or wasn't executable. ## ## 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. darcs init --repo R # Create our test repo. FAKE_EDITOR_HOME=`pwd` cat < editor-good.hs import System.Environment import System.IO main = getArgs >>= \[name] -> writeFile name "fake" FAKE ghc -o editor-good --make editor-good.hs cat < editor-bad.hs import System.Exit main = exitWith (ExitFailure 127) FAKE ghc -o editor-bad --make editor-bad.hs cat < editor-gave-up.hs import System.Exit main = exitWith (ExitFailure 1) FAKE ghc -o editor-gave-up --make editor-gave-up.hs cat < vi.hs import System.Environment import System.IO main = getArgs >>= \[name] -> writeFile name "vi" VI ghc -o vi --make vi.hs cd R mkdir d unset TERM DARCSDIR=$(dirname $(which darcs)) # the /dev/null stdin redirection is to make vi or the fallback editor just fail DARCS_EDITOR=$FAKE_EDITOR_HOME/editor-good \ darcs record -lam 'Initial commit.' --edit log-1 darcs changes > changes-1 darcs unrecord -a grep fake changes-1 # Bad editor: fall through to the next choice DARCS_EDITOR=$FAKE_EDITOR_HOME/editor-bad \ PATH=.:$DARCSDIR \ darcs record -lam 'Initial commit.' --edit log-2 darcs changes > changes-2 darcs unrecord -a grep "Initial" changes-2 egrep -i 'vi|emacs|nano|edit' log-2 # Normal failure (eg. user hit ^-C) # If Darcs did the right thing, the output won't make any mention of # the fallback editors. DARCS_EDITOR=$FAKE_EDITOR_HOME/editor-gave-up \ darcs record -lam 'Initial commit.' --edit log-3 darcs changes > changes-3 darcs unrecord -a grep "Initial" changes-3 not egrep -i 'not found|vi|emacs|nano|edit' log-3 darcs-2.10.2/tests/issue1611_amend-tag.sh0000644000175000017500000000310612620122474021776 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1611 - amend-record should prevent adding new changes to a tag. ## ## Copyright (C) 2011 Iago Abal Rivas ## ## 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 # Creates a patch echo 'Example content.' > f darcs record -lam 'Add f' darcs tag V1 # Creates a tag echo 'Another example content.' > f # Edit repository # Amend the tag should be illegal echo y | darcs amend -ap 'V1' | not grep 'amending patch' darcs-2.10.2/tests/issue1111-pull-intersection.sh0000644000175000017500000000354612620122474023542 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue2076-move_into_dir.sh0000644000175000017500000000265512620122474022732 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Copyright (C) 2011 Lennart Kolmodin ## ## 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 issue2076 cd issue2076 touch file1 darcs record -lam 'file1' mkdir dir1 mv file1 dir1 not darcs mv file1 dir1 # we require dir1 to be added first darcs add dir1 darcs mv file1 dir1 darcs whatsnew darcs-2.10.2/tests/issue1373_replace_token_chars.sh0000644000175000017500000000355012620122474024144 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1373 - check that --token-chars [^ \t] is allowed. ## While we're at it, check some other things *aren't* allowed. ## ## 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 temp # Another script may have left a mess. darcs init --repodir temp replace () { darcs replace --repodir temp --token-chars "$1" x y; } ## These are not well-formed tokens. not replace '' not replace 'a' not replace ']a[' not replace '[]' not replace '[^]' ## These are well-formed, but allow tokens to contain whitespace. not replace $'[ ]' not replace $'[\t]' not replace $'[\n]' not replace $'[\r]' not replace $'[\v]' not replace $'[^ ]' not replace $'[^\t]' not replace $'[^\n]' not replace $'[^\r]' not replace $'[^\v]' rm -rf temp # Clean up after ourselves. darcs-2.10.2/tests/addmv.sh0000644000175000017500000000047512620122474017521 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue1043_geteff_b.sh0000644000175000017500000000210512620122474021677 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 # creating the fork point mkdir temp1 cd temp1 darcs init cat > foo << FOO original - apple original - banana FOO darcs add foo darcs record -am init cd .. darcs get temp1 temp2 # do some work in the mainline cd temp1 cat > foo << FOO original - apple conflict 1 - brocolli FOO darcs record -am 'conflict 1b' cat > foo << FOO conflict 1 - artichoke original - banana FOO darcs record -am 'conflict 1a' cd .. # do some work in the branch cd temp2 cat > foo << FOO conflict 2 - aardvark original - banana conflict 2 - cougar FOO darcs record -am 'conflict 2' cd .. # in the branch, pull from the mainline and resolve the conflict cd temp2 darcs pull -a ../temp1 --allow-conflicts cat > foo << FOO resolution original - apple original - banana FOO darcs record -am 'resolve conflicts 2,1a,1b' cd .. # do some extra work in the mainline cd temp1 cat > foo << FOO original - apple FOO darcs record -am 'conflict 1c' cd .. # in the branch, pull from the mainline again cd temp2 darcs pull -a ../temp1 --allow-conflicts cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/disable.sh0000644000175000017500000000162612620122474020030 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init 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 -- -- || 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 darcs-2.10.2/tests/issue1277-repo-format.sh0000644000175000017500000000376412620122474022334 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1277 - repository format errors should be reported ## correctly (ie. not as some totally unrelated error) ## ## 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 darcs init --repo R2 # Protect the darcs darcs repo with R cd R2 echo impossible >> _darcs/format echo 'Example content.' > f not darcs add f > log 2>&1 grep "Can't understand repository format" log not darcs whatsnew > log 2>&1 grep "Can't understand repository 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 cd .. not darcs whatsnew --repodir R2 > log 2>&1 grep "R2 looks like a repository directory," log grep "Can't understand repository format" log cd .. darcs-2.10.2/tests/patch-index-spans.sh0000644000175000017500000000447312620122474021756 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for patch index integrity of spans - ## ## 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-all > 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-all > 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-all > 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 darcs-2.10.2/tests/rebase-pull.sh0000644000175000017500000000404512620122474020636 0ustar00guillaumeguillaume00000000000000#!/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 | grep "Rebase in progress: 2 suspended patches" echo yny | darcs rebase unsuspend | grep "We have conflicts" cat > expected < foo echo yyy | darcs amend --patch '3' echo yy | darcs rebase unsuspend | grep "We have conflicts" cat > expected < foo echo yyy | darcs amend --patch '4' cd .. darcs-2.10.2/tests/issue1845-record-removed.sh0000644000175000017500000000072612620122474023012 0ustar00guillaumeguillaume00000000000000#!/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 ny | darcs record f 2>&1 | tee log not grep "None of the files" log cd .. darcs-2.10.2/tests/failing-issue1926_amend-record_ignores_--index.sh0000644000175000017500000000415012620122474027170 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1926 - amend-record --index ## ## Copyright (C) 2010 Iago Abal ## ## 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 echo 'Example content 1.' > f darcs record -lam 'Add file f' echo 'Example content 2.' > g darcs record -lam 'Add file g' 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. darcs changes > changes cd .. cd S echo "y" | darcs amend-record -p 'Add file f' -m 'A new file f' # -p works as expected and amends the right patch. darcs changes > changes cd .. diff R/changes S/changes # Shows us the differences between both 'darcs changes'. darcs-2.10.2/tests/tricky_unrecord.sh0000644000175000017500000000073512620122474021633 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/sametwice.sh0000644000175000017500000000117512620122474020405 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init 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 darcs record -m add_foo echo hello >> foo darcs record -m mod_foo cd .. darcs get --repo-name temp2 temp1 cd temp2 cp ../temp1/_darcs/prefs/defaults _darcs/prefs echo y/d/y | tr / \\012 | darcs unpull --interactive test -f foo -a ! -s foo echo hello >> foo darcs record -m mod_foo_again darcs pull ../temp1 test -s foo cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/pull_many_files.sh0000644000175000017500000000075212620122474021606 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib #pragma repo-format darcs-1,darcs-2 rm -rf temp1 temp2 if grep darcs-1 .darcs/defaults; then format=hashed elif grep darcs-2 .darcs/defaults; then format=darcs-2 else format=ERROR; 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 darcs-2.10.2/tests/changes.sh0000644000175000017500000000211312620122474020025 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # Some tests for 'darcs changes -a' rm -rf temp1 mkdir temp1 cd temp1 darcs init date >> date.t darcs add date.t darcs record -A 'Mark Stosberg ' -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 '<a@b.com>' 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 darcs-2.10.2/tests/issue2125-always-warn-forced-replace.sh0000644000175000017500000000467612620122474025213 0ustar00guillaumeguillaume00000000000000#!/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' darcs-2.10.2/tests/issue2066_add_and_remove.sh0000644000175000017500000000277412620122474023107 0ustar00guillaumeguillaume00000000000000#!/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 ## ## 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 .. darcs-2.10.2/tests/rmdir.sh0000644000175000017500000000207412620122474017540 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 temp3 # initialise temp1 mkdir temp1 cd temp1 darcs initialize mkdir foo echo hello world > foo/bar darcs add foo foo/bar darcs record -a -m add cd .. # get temp1 into temp2 darcs get temp1 temp2 cd temp2 echo hello world > foo/baz cd .. # remove a directory from temp1 and record cd temp1 rm -rf foo darcs record -a -m del cd .. cd temp2 test -e foo/baz test -e foo/bar test -d foo darcs show files --no-pending --no-dir >> files grep foo/bar files darcs show files --no-pending --no-fil >> dirs grep foo dirs cd .. darcs pull -a --repodir=temp2 > pullresult cat pullresult grep 'Warning: .ot deleting' pullresult # get temp1 into temp3 darcs get temp1 temp3 cd temp3 darcs obliterate --last 1 -a echo hello world > foo/baz cd .. cd temp3 test -e foo/baz test -e foo/bar test -d foo darcs show files --no-pending --no-dir >> files grep foo/bar files darcs show files --no-pending --no-fil >> dirs grep foo dirs cd .. darcs pull -q -a --repodir=temp3 > pullresult cat pullresult test ! -s pullresult rm -rf temp1 temp2 temp3 darcs-2.10.2/tests/send-encoding.sh0000644000175000017500000000326512620122474021143 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Copyright (C) 2011 Ganesh Sittampalam ## ## Test that darcs send uses the UTF-8 encoding for emails ## when non-ASCII characters are in the message ## ## 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 darcs init --repo empty darcs init --repo send cd send echo 'file1' > file1 darcs record -lam 'file1' LANG=en_GB.UTF-8 \ DARCS_EDITOR='echo Non-ASCII chars: é è ề Ψ ޡ ߐ ह ჴ Ᏻ ‱ ⁂ ∰ ✈ ⢅ .. >' \ darcs send -a ../empty --to=invalid@invalid --edit \ --sendmail-command='grep "Content-Type: text/plain; charset=\"utf-8\"" %<' darcs-2.10.2/tests/failing-issue1790_darcs-send.sh0000644000175000017500000000506012620122474023604 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1790 - darcs send --context foo should not require ## a remote repository ## ## Copyright (C) 2009 Loup Vaillant ## ## 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 # populate R (optional) echo foo > foo.txt darcs add foo.txt darcs record -a -m "foo" # create a context file to represent R's state darcs changes --context > ../R.context cd .. # copy the repository the hard way. # normally one would use `darcs get A B` to do that, # but when no central server is available, this sort of # hard copy may be perceived as simpler: Just tar xcfz # the repository and send it via email. cp -r R S cd S # Make sure there is no _darcs/prefs/defaultrepo file # If there is one even on new repositories, that would # appear to solve the issue, but I think this is not a # good solution: the absence of the defaultrepo file # is useful to indicate the absence of interaction with # remote repositories. # # Of course, at the time of this writing, the following # line has no effect rm -rf _darcs/prefs/defaultrepo # make some further modifications (optional) echo bar > bar.txt darcs add bar.txt darcs record -a -m "bar" # try to send a patch to the first repository, # using its context file darcs send -a -o ../bar.patch --context=../R.context cd .. darcs-2.10.2/tests/merge_three_patches.sh0000644000175000017500000000172112620122474022416 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf tempOld tempA tempB mkdir tempOld tempA cd tempOld darcs initialize 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 echo D >> foo echo E >> foo echo F >> foo echo G >> foo echo H >> foo darcs add foo darcs record -m Old cd .. cd tempA darcs initialize cp ../tempOld/_darcs/prefs/defaults _darcs/prefs darcs pull ../tempOld cp foo temp cat temp | grep -v A | grep -v B | grep -v D | sed s/E/e/ \ | grep -v G | sed s/H/h/ > foo darcs record -m AA cd .. darcs get tempOld tempB cd tempB cp ../tempOld/_darcs/prefs/defaults _darcs/prefs echo 7 > foo darcs record -m BB darcs pull ../tempA darcs record -m "conflict resolution" cd .. cd tempA darcs pull ../tempB darcs annotate -p B darcs annotate -p resolution cd .. cmp tempA/foo tempB/foo rm -rf tempOld tempA tempB darcs-2.10.2/tests/issue1888-changes-context.sh0000644000175000017500000000334312620122474023174 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/pull-union.sh0000644000175000017500000000077212620122474020530 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue1825-remove-pending.sh0000644000175000017500000000344312620122474023011 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1825 - buggy pending when reverting a removed ## directory and file. ## ## Copyright (C) 2010 Ferenc Wagner ## 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 -p a echo foo >a/b 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? darcs revert -a a/b darcs-2.10.2/tests/failing-issue1702-optimize-relink-vs-cache.sh0000644000175000017500000000604612620122474026306 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1702 - an optimize --relink does not relink the files ## in ~/.darcs/cache. ## ## 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 S # Another script may have left a mess. darcs init --repo R # Create our test repos. ## Create a patch. echo 'Example content.' > R/f darcs record -lam 'Add f.' --repodir R ## Get a hard link into the cache. darcs get R S ## Are hard links available? x=(R/_darcs/patches/*-*) x=${x#R/_darcs/patches/} if [[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] 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. ## 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 ## Break all hard links. rm -rf S cp -r R S rm -rf R 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 ## Optimize *should* hard-link all three together. 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 darcs-2.10.2/tests/dist-v.sh0000644000175000017500000000033312620122474017625 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # 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 darcs-2.10.2/tests/issue2313-trailing-newlines-stack-overflow.sh0000644000175000017500000000054412620122474026461 0ustar00guillaumeguillaume00000000000000#!/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 tempdarcs-2.10.2/tests/issue1584_optimize_upgrade.sh0000644000175000017500000000315412620122474023524 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1584 - darcs optimize --upgrade ## ## 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. 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 upgrade --repo R darcs check --repo R grep hashed R/_darcs/format not grep darcs-2 R/_darcs/format darcs whatsnew --repo R | grep 'hunk ./foo 1' darcs-2.10.2/tests/failing-issue2310-rollback-doesnt-readd.sh0000644000175000017500000000277212620122474025633 0ustar00guillaumeguillaume00000000000000## 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 'A ./foo' darcs-2.10.2/tests/send-output-v1.sh0000644000175000017500000000407712620122474021243 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test that we produce exactly correct output when sending v1 patches ## ## 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. #pragma repo-format darcs-1 . lib # Load some portability helpers. grep darcs-1 $HOME/.darcs/defaults || exit 200 rm -rf empty mkdir empty cd empty darcs init cd .. rm -rf repo gunzip -c $TESTDATA/simple-v1.tgz | tar xf - cd repo darcs send --no-minimize -o repo.dpatch -a ../empty day=$(grep "Date: " $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 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 - cd repo darcs send --no-minimize -o repo.dpatch -a ../empty day=$(grep "Date: " $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 cd .. darcs-2.10.2/tests/look_for_moves.sh0000644000175000017500000000766312620122474021457 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 mkdir temp1 temp2 cd temp1 # simple add and move darcs init touch foo darcs record -a -m add_file -A x --look-for-adds mv foo foo2 darcs wh --summary --look-for-moves >log 2>&1 cat > log.expected < ./foo2 EOF diff -u log log.expected rm log log.expected darcs record -a -m move_file -A x --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 -a -m add_dir -A x --look-for-adds mv foo foo2 darcs wh --summary --look-for-moves >log 2>&1 cat > log.expected < ./foo2 EOF diff -u log log.expected rm log log.expected darcs record -a -m move_file -A x --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 -a -m add_file -A x --look-for-adds mv foo foo2 touch foo darcs wh --summary --look-for-moves >log 2>&1 cat > log.expected < ./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 < ./foo2 a ./foo EOF darcs record -a -m move_file_add_file -A x --look-for-moves --look-for-adds grep -vE "(^ *$|^\+|No changes!)" log rm -rf * # amend-record darcs init touch foo darcs record -a -m add_file -A x --look-for-adds mv foo foo2 echo 'yyy' | darcs amend-record -p add_file -A x --look-for-moves darcs wh --look-for-moves --look-for-adds >log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log darcs annotate --patch add_file | grep "] addfile ./foo2" rm -rf * # add, move, add same name and amend-record darcs init touch foo darcs record -a -m add_file -A x --look-for-adds mv foo foo2 touch foo echo 'yyyy' | darcs amend-record -p add_file -A x --look-for-moves --look-for-adds darcs wh --look-for-moves --look-for-adds >log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log darcs annotate --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 -a -m add_file -A x --look-for-adds mv foo foo2 echo 'yyy' | darcs amend-record -p add_file -A x --look-for-moves mv foo2 foo echo 'yyy' | darcs amend-record -p add_file -A x --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 -a -m add_files -A x --look-for-adds mv dir dir2 darcs wh --summary --look-for-moves > log 2>&1 cat > log.expected < ./dir2 EOF diff -u log log.expected rm log log.expected darcs record -a -m move_dir -A x --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 -A x mv foo foo.tmp mv foo2 foo mv foo.tmp foo2 not darcs wh --look-for-moves rm -rf * # dir swapping -- ignored darcs init mkdir dir dir2 touch dir/foo dir2/foo2 darcs record -a -m add_files_and_dirs -A x --look-for-adds mv dir dir.tmp mv dir2 dir mv dir.tmp dir2 not darcs wh --summary --look-for-moves rm -rf * # darcs mv before a plain mv darcs init touch foo darcs record -a -m add_files_and_dirs -A x --look-for-adds darcs mv foo foo2 mv foo2 foo3 darcs wh --summary --look-for-moves > log 2>&1 cat > log.expected < ./foo3 EOF diff -u log log.expected rm log log.expected darcs record -a -m move_dirs -A x --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 -a -m add_files_and_dirs -A x --look-for-adds mv foo foo~ darcs wh --summary --look-for-moves > log 2>&1 cat > log.expected <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. darcs-2.10.2/tests/external-resolution.sh0000644000175000017500000000153012620122474022442 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init echo "Conflict, Base ." > child_of_conflict darcs add child_of_conflict darcs record -am 'Conflict Base' cd .. darcs get temp1 temp2 # Add and record differing lines to both repos cd temp1 echo "Conflict, Part 1." > child_of_conflict darcs record -A author -am 'Conflict Part 1' cd .. cd temp2 echo "Conflict, Part 2." > child_of_conflict darcs record -A author -am 'Conflict Part 2' cd .. cd temp1 echo | darcs pull -a ../temp2 --external-merge 'cp %2 %o' cd .. grep "Part 2" temp1/child_of_conflict diff -u temp1/child_of_conflict temp2/child_of_conflict cd temp1 darcs wh darcs rev -a echo y | darcs unpull --last 1 -a echo | darcs pull -a ../temp2 --external-merge 'cp %1 %o' cd .. cat temp1/child_of_conflict grep "Part 1" temp1/child_of_conflict rm -rf temp1 temp2 darcs-2.10.2/tests/issue1472_read_too_much.sh0000644000175000017500000000344412620122474022763 0ustar00guillaumeguillaume00000000000000#!/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. darcs-2.10.2/tests/issue2199-get-dirty-tag.sh0000644000175000017500000000301612620122474022554 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue2136-changes_created_as_for_multiple_files.sh0000644000175000017500000000520312620122474027607 0ustar00guillaumeguillaume00000000000000#!/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 changes --xml tldir/f2 f5 tldir/d2 d5 f6) xmlChangesRev=$(darcs changes --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 "" -C2 | tail -1 | grep "$4" } 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 "]*'\./f6'" darcs-2.10.2/tests/issue1756_moves_index.sh0000644000175000017500000000340112620122474022471 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1756 - moving files between directories breaks index ## ## 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 S # 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 'a' > d/a echo 'b' > d/b echo 'c' > e/c darcs record -lam '.' darcs mv d/a e/ darcs check --no-ignore-times cd .. rm -rf R darcs init --repo R cd R mkdir d e # Change the working tree. echo 'a' > d/a echo 'b' > e/b darcs record -lam '.' darcs mv d/a e/ darcs check --no-ignore-times cd .. rm -rf R darcs-2.10.2/tests/issue1473_annotate_repodir.sh0000644000175000017500000000051412620122474023504 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./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 darcs-2.10.2/tests/apply-reorder.sh0000644000175000017500000000231612620122474021207 0ustar00guillaumeguillaume00000000000000#!/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 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 --no-minimize --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 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 .. darcs-2.10.2/tests/issue279_get_extra.sh0000644000175000017500000000135312620122474022056 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # issue279: a conflict case resulting in "bug in get_extra" with old # format repos and "Malformed patch bundle" with darcs-2 repos. . lib rm -rf temp1 temp_a temp_b temp_c temp_d mkdir temp1 cd temp1 darcs init --darcs-2 echo 0 > f darcs add f darcs record -am 00 cd .. for r in a b c d; do darcs get temp1 temp_$r cd temp_$r; echo $r > f 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 cd .. cd temp_c darcs pull -a ../temp_a darcs pull -a ../temp_b echo rc > f darcs record -a -m rc cd .. cd temp_d darcs pull -a ../temp_c > log not grep -i "no remote" log not grep -i get_extra log cd .. rm -rf temp1 temp_a temp_b temp_c temp_d log darcs-2.10.2/tests/whatsnew.sh0000644000175000017500000000177412620122474020271 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib # Some tests for 'darcs whatsnew ' rm -rf temp1 temp2 mkdir temp1 cd temp1 # RT#505 whatsnew -s after removal of file without a newline darcs init echo -n foobar > foo darcs record -la -m "add foo" | grep "Finished record" rm -f foo darcs whatsnew -s | grep R darcs record -a -m "remove foo" # RT#245 --look-for-adds implies --summary touch look_summary.txt darcs whatsnew -l | grep -i "a ./look_summary.txt" #whatsnew works with uncommon file names if echo $OS | grep -i windows; then echo test does not work on windows exit 0; else echo foo > \\ darcs add \\ darcs whatsnew | tee log grep 'hunk ./\\92\\' log fi echo foo > "foo bar" darcs add "foo bar" darcs wh | tee log grep 'hunk ./foo\\32\\bar' log # check that filename encoding does not botch up the index darcs rec -am "weird filenames" not darcs wh # whatsnew works with absolute paths DIR="`pwd`" echo date.t > date.t touch date.t darcs add date.t darcs whatsnew "$DIR/date.t" | grep hunk cd .. rm -rf temp1 darcs-2.10.2/tests/nodeps.sh0000644000175000017500000000357012620122474017715 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # Test the --no-deps option with Send, Push, Pull, Obliterate and Unrecord. # # Create four patches with dependencies. # file 'f': patch 'fa' and 'fb' # file 'g': patch 'ga' and 'gb' # The 'b' patches depend on the 'a' patches. rm -rf tmp1 mkdir tmp1 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 echo 'a' > g darcs add g darcs rec -am 'ga' g echo 'b' > f darcs rec -am 'fb' f echo 'b' > g darcs rec -am 'gb' g mkdir d darcs init --repodir d # Try to Send all 'b' and 'g' patches. The two 'g' patches should succeed, # but the 'fb' patch depends on the unselected 'fa' patch, an should be # skipped. darcs send -o bundle -a -p '[bg]' --no-deps d grep '^\[ga$' bundle grep '^\[fb$' bundle && exit 1 # Try to Push all 'b' and 'g' patches. Expect same result as for Send. darcs push -a -p '[bg]' --no-deps d cd d darcs changes | grep '^ \* ga$' darcs changes | grep '^ \* fb$' && exit 1 # stay in d !! # Try to Pull all 'b' and 'g' patches. Expect same result as for Send. # already in d rm -rf *; darcs init darcs pull -a -p '[bg]' --no-deps .. darcs changes | grep '^ \* ga$' darcs changes | grep '^ \* fb$' && exit 1 cd .. # Try to Obliterate all 'a' and 'g' patches. The two 'g' patches should # succeed, but the 'fa' patch depends on the unselected 'fb' patch, an # should be skipped. darcs get . tmp; cd tmp echo y/y/y/q | tr / \\012 | darcs obliterate -p '[ag]' --no-deps darcs changes | grep '^ \* gb$' && exit 1 darcs changes | grep '^ \* fa$' cd .. # Try to Unrecord all 'a' and 'g' patches. Expect same result as for # Obliterate. # in "top" tmp repo -- destroys it! echo y/y/y/q | tr / \\012 | darcs unrecord -p '[ag]' --no-deps darcs changes | grep '^ \* gb$' && exit 1 darcs changes | grep '^ \* fa$' cd .. rm -rf tmp1 darcs-2.10.2/tests/replace_after_pending_add.sh0000644000175000017500000000031712620122474023531 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/rebase-tag.sh0000644000175000017500000000274512620122474020442 0ustar00guillaumeguillaume00000000000000#!/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" --ignore-times echo 'yy' | darcs rebase suspend darcs tag 'ugh' darcs check darcs changes # because darcs check doesn't complain about a corrupt rebase state :-( darcs-2.10.2/tests/issue1337_darcs_changes_false_positives.sh0000644000175000017500000000310512620122474026210 0ustar00guillaumeguillaume00000000000000#!/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')" darcs-2.10.2/tests/show_contents.sh0000644000175000017500000000134312620122474021316 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init touch foo darcs add foo echo first > foo darcs record -a -m "first edit" -A author1 echo second > foo darcs record -a -m "second edit" -A author2 darcs tag t1 -A moi echo third > foo darcs record -a -m "third edit" -A author3 echo fourth > foo darcs record -a -m "fourth edit" -A author4 echo unrecorded > foo darcs show contents foo | grep fourth darcs show contents foo -p third | grep third 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 darcs show contents -n 2 foo | grep third cd .. rm -rf temp1 darcs-2.10.2/tests/issue2343.sh0000644000175000017500000000423612620122474020071 0ustar00guillaumeguillaume00000000000000#!/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 2>&1 cat > log.expected < 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 darcs-2.10.2/tests/rebase-count.sh0000644000175000017500000000261112620122474021007 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue183_mv_order.sh0000644000175000017500000000320312620122474021677 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue183 - mv and other patches should be in replayable ## order ## ## 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 touch f darcs add f darcs record -am 'Create f' mkdir d darcs add d darcs mv f d darcs record -am 'Create d and mv f in it' cat > expected << EOF A ./d/ ./f -> ./d/f EOF darcs changes -s -p 'Create d' | grep "d/" > log diff -q expected log cd .. darcs-2.10.2/tests/failing-issue612_repo_not_writable.sh0000644000175000017500000000134412620122474025210 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Test that darcs fails appropriately when the target repo inventory file is not writable. # See issue612 . lib abort_windows 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 darcs-2.10.2/tests/prehook.sh0000644000175000017500000000063112620122474020067 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 mkdir temp1 cd temp1 darcs init touch foo darcs add foo # Check that prehook runs darcs whatsnew -s --prehook 'touch prehook-ran' test -f prehook-ran rm prehook-ran # Check that --prehook works with defaults... echo ALL --prehook touch prehook-ran > _darcs/prefs/defaults darcs whatsnew -s test -f prehook-ran rm prehook-ran echo Successful. cd .. rm -rf temp1 darcs-2.10.2/tests/issue2287_obliterate_overwrite.sh0000644000175000017500000000374412620122474024423 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/patch-index-rename.sh0000644000175000017500000000257712620122474022104 0ustar00guillaumeguillaume00000000000000#!/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-test darcs-2.10.2/tests/emailformat.sh0000644000175000017500000000226312620122474020723 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib switch_to_latin9_locale rm -rf temp1 rm -rf temp2 rm -rf temp3 mkdir temp1 mkdir temp2 mkdir temp3 cd temp1 seventysevenaddy="" darcs init echo "Have you seen the smrrebrd of Ren avsant?" > non_ascii_file darcs add non_ascii_file darcs record -am "non-ascii file add" -A test cd ../temp2 darcs init cd ../temp1 # long email adress: check that email adresses of <= 77 chars don't get split up darcs send --mail\ --from="Kjlt berstrm $seventysevenaddy" \ --subject "Un patch pour le rpositoire" \ --to="Un garon franais " \ --sendmail-command='tee mail_as_file %<' \ -a ../temp2 cat mail_as_file # The long mail address should be in there as a whole grep $seventysevenaddy mail_as_file # Check that there are no non-ASCII characters in the mail cd ../temp3 cat > is_ascii.hs <>= print . not . any (> Data.Char.chr 127) EOF ghc --make is_ascii.hs -o is_ascii ./is_ascii < ../temp1/mail_as_file | grep '^True$' cd .. rm -rf temp1 rm -rf temp2 rm -rf temp3 darcs-2.10.2/tests/unrevert-replace-moved.sh0000644000175000017500000000070612620122474023016 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/failing-issue2293-laziness-amend.sh0000644000175000017500000000244712620122474024416 0ustar00guillaumeguillaume00000000000000#!/bin/sh -e ## ## Test that amend-record doesn'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 gunzip -c $TESTDATA/laziness-cut.tgz | tar xf - cd repo echo 'baz' > bar echo yyyy | darcs amend-rec darcs-2.10.2/tests/failing-issue1609_ot_convergence.sh0000644000175000017500000000515212620122474024562 0ustar00guillaumeguillaume00000000000000#!/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 ## Copyright (C) 2009 Pascal Molli ## ## 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 darcs-2.10.2/tests/show_tags.sh0000644000175000017500000000100212620122474020407 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./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 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 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 darcs tag -m 2.0 -A x darcs show tags > my cat my cat > ref < _darcs/prefs/author echo m1 > foo darcs add foo darcs record -a -m m1 --ignore-times 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 cd .. # step 3 cd temp0 echo m2 > foo darcs record -a -m m2 --ignore-times cd .. # step 4 cd temp1 darcs pull -a echo m2-a1 > foo darcs record -a -m 'Fix conflict m2-a1' --ignore-times echo a2 > foo darcs record -a -m a2 --ignore-times cd .. #step 5 cd temp0 echo m3 > foo darcs record -a -m m3 --ignore-times cd .. #step 6 darcs get temp0 temp2 cd temp2 echo temp2 > _darcs/prefs/author echo b1 > foo darcs record -a -m b1 --ignore-times cd .. #step 7 cd temp0 echo m4 > foo darcs record -a -m m4 --ignore-times 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 echo a3 > foo darcs record -a -m a3 --ignore-times cd .. #step 9 cd temp1 darcs pull -av ../temp2 cd .. rm -rf temp0 temp1 temp2 darcs-2.10.2/tests/issue1269_setpref_predist.sh0000644000175000017500000000077512620122474023365 0ustar00guillaumeguillaume00000000000000#!/bin/sh . ./lib not () { "$@" && exit 1 || :; } rm -rf temp rm -rf dist1269.tar.gz mkdir temp cd temp darcs init printf "Line1\nLine2\nLine3\n" > foo darcs record -alm Base darcs setpref predist false # It is a bug in darcs if the dist succeeds. It should # fail with a non-zero exit code not darcs dist -d dist1269 # It is a bug in darcs if the dist file has been created # it should /not/ be created if the predist cmd returned # a non-zero exit code not test -f dist1269.tar.gz cd .. rm -rf temp darcs-2.10.2/tests/setpref.sh0000644000175000017500000000065612620122474020077 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init echo 'test file 1' > foo darcs record --look-for-adds --all -m"Patch 1" echo 'test boringfile' > bar darcs setpref boringfile bar darcs record --look-for-adds --all -m"Patch 2" echo 'test file 3' > baz # there should be no -R darcs record --look-for-adds --all -m"Patch 3" > ../temp2 cat ../temp2 not grep R ../temp2 cd .. rm -rf temp1 rm -f temp2 darcs-2.10.2/tests/issue494-pending-sort.sh0000644000175000017500000000262612620122474022426 0ustar00guillaumeguillaume00000000000000#!/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' darcs-2.10.2/tests/failing-issue2242-rollback-mv.sh0000644000175000017500000000312712620122474023703 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2242 - rollback of a mv patch generates bogus changes ## ## 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 # 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 darcs-2.10.2/tests/obliterate.sh0000644000175000017500000000146212620122474020555 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 not darcs whatsnew grep 'love the world' foo echo yy | darcs obliterate -p baz2world not darcs whatsnew grep 'love the baz' foo echo yy | darcs obliterate -p bar2baz grep 'love the bar' foo echo yy | darcs obliterate -p nolove grep 'love' foo && exit 1 || true cd .. rm -rf tempA darcs-2.10.2/tests/issue1765_recursive-remove-on-root.sh0000644000175000017500000000310412620122474025046 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issueNNNN - ## ## 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 darcs-2.10.2/tests/issue1860-incomplete-pristine.sh0000644000175000017500000000316512620122474024064 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## 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 S # Another script may have left a mess. darcs init --repo R # Create our test repos. cd R mkdir tools darcs rec -lam "add tools" mkdir tools/cgi echo bar > tools/cgi/README darcs rec -lam "add cgi" darcs move tools contrib darcs rec -lam "rename tools/ to contrib/" rm -rf contrib/cgi darcs rec -lam "drop cgi" cd .. darcs get R S cd S darcs show pristine darcs unpull --last 2 -a darcs show pristine cd .. darcs-2.10.2/tests/impossible_unrevert.sh0000644000175000017500000000144512620122474022524 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 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 # 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 yy | darcs revert -a echo ydyy | darcs unpull # Now add the date back on at the end: echo yy | 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 darcs-2.10.2/tests/push_conflicts.sh0000644000175000017500000000336512620122474021452 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/issue2052-default-unified-diff.sh0000644000175000017500000000301012620122474024024 0ustar00guillaumeguillaume00000000000000#!/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. . ./lib . 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 darcs-2.10.2/tests/send-external.sh0000644000175000017500000000200112620122474021162 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib DARCS_EDITOR=echo export DARCS_EDITOR rm -rf temp1 temp2 mkdir temp1 temp2 cd temp2 darcs init cd .. cd temp1 darcs init date > foobar darcs add foobar darcs rec -a -m add-foobar cat > saveit.sh <>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 # foobar darcs send --mail\ --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 cat saved.out grep add-foobar saved.out grep 'addfile ./foobar' saved.out cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue2286-metadata-encoding.sh0000644000175000017500000000250712620122474023440 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2286 - darcs changes fails when reading non-UTF8 encoded ## metadata ## ## 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 switch_to_utf8_locale gunzip -c $TESTDATA/metadata-encoding.tgz | tar xf - cd metadata-encoding darcs changes darcs-2.10.2/tests/invalid_absolute_paths.sh0000644000175000017500000000356312620122474023152 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## ## Regression test for patch178 ## ## Copyright (C) 2010 Alexey Levan ## ## 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 if darcs move /non_existent_path/a /non_existent_path/b 2>&1 | grep 'bug'; then echo 'Not OK 1: darcs move causes a bug' exit 1 else echo 'OK 1' fi if darcs move /non_existent_path/a /non_existent_path/b /non_existent_path/c 2>&1 | grep 'Prelude.init: empty list'; then echo 'Not OK 2: darcs move causes an error' exit 1 else echo 'OK 2' fi if darcs annotate /non_existent_path/a 2>&1 | grep 'Pattern match failure'; then echo 'Not OK 3: darcs annotate causes an error' exit 1 else echo 'OK 3' fi cd .. rm -rf R darcs-2.10.2/tests/double-unrevert.sh0000644000175000017500000000120112620122474021534 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # 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 nyny | darcs unrev darcs unrev -a cd .. rm -rf temp1 darcs-2.10.2/tests/issue121.sh0000644000175000017500000000340312620122474017774 0ustar00guillaumeguillaume00000000000000#!/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 'yYyY' | tr '[A-Z]' '[a-z]' | darcs amend --ask-deps darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z' darcs-2.10.2/tests/workingdir.sh0000644000175000017500000000300112620122474020571 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib # test for working dir woes # the setup... rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init mkdir a echo temp0 > a/x darcs add a darcs add a/x darcs record -am "aa" darcs mv a/x a/y darcs record -am "x to y" echo temp1 > b darcs add b darcs record -am "bb" mkdir d darcs add d darcs record -am "dd" darcs tag 1 echo 1-b2 > b darcs record -am "b2" cd .. # try to move a file that we don't have the right to do darcs get temp1 temp2 --to-patch aa cd temp2 chmod u-w a darcs pull -a test -e b chmod u+w a cd .. rm -rf temp2 # [issue319] try to overwrite file(s) in our working dir darcs get temp1 temp2 --to-patch aa cd temp2 echo temp2 > b echo temp2 > d darcs pull -a -t 1 grep temp1 b grep temp2 b.~0~ grep temp2 d.~0~ # now make sure we didn't overdo it darcs pull -a grep '1-b2' b test -e b.~0~ test ! -e b.~1~ cd .. rm -rf temp2 # [issue298] backup working dir files with conflicts darcs get temp1 temp2 --tag 1 cd temp2 echo 2-b2 > b darcs pull -a grep "v v v" b grep "2-b2" b.~0~ not grep "v v v" b.~0~ cd .. rm -rf temp2 # [issue440] a) try to overwrite a file in our working dir darcs get temp1 temp2 --to-patch a cd temp2 echo temp2 > a/y echo old-bak > a/y.~0~ darcs pull -a grep temp0 a/y grep old-bak a/y.~0~ grep temp2 a/y.~1~ cd .. rm -rf temp2 # [issue440] b) try to overwrite a directory in our working dir darcs get temp1 temp2 --to-patch a cd temp2 mkdir a/y echo old-bak > a/y.~0~ darcs pull -a grep temp0 a/y grep old-bak a/y.~0~ test -d a/y.~1~ cd .. rm -rf temp2 rm -rf temp1 darcs-2.10.2/tests/repair-corrupt.sh0000644000175000017500000000265312620122474021404 0ustar00guillaumeguillaume00000000000000. lib rm -rf bad mkdir bad cd bad darcs init --no-patch-index 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 .. darcs-2.10.2/tests/mutex-option-precedence.sh0000644000175000017500000000335312620122474023167 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issueNNNN - with mutually exclusive options "ALL foo" and ## "bar no-foo", "darcs bar" should mean "darcs bar --no-foo". ## ## 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. . ../tests/lib # Load some portability helpers. rm -rf R # Another script may have left a mess. darcs init --repo R # Create our test repo. darcs init --repo S # Create our test repos. cd R echo 'Example content.' >f # Change the working tree. darcs record -lam 'Add f.' darcs send -aof.dpatch ../S darcs obl -a cat >>_darcs/prefs/defaults < _darcs/prefs/defaults # name requires an argument echo 'ALL unified foobar' >> _darcs/prefs/defaults # unified takes no argument darcs record && exit 1 darcs whats && exit 1 rm -rf temp darcs-2.10.2/tests/pull_conflicts.sh0000644000175000017500000000335412620122474021445 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/rebase-suspend-from-patch.sh0000644000175000017500000000267712620122474023412 0ustar00guillaumeguillaume00000000000000#!/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' darcs-2.10.2/tests/issue1514-send-minimize.sh0000644000175000017500000000365412620122474022641 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/patch-index-annotate.sh0000644000175000017500000000130512620122474022432 0ustar00guillaumeguillaume00000000000000. 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 darcs-2.10.2/tests/failing-issue1316.sh0000644000175000017500000000276112620122474021500 0ustar00guillaumeguillaume00000000000000#!/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. mkdir 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 darcs-2.10.2/tests/data/0000755000175000017500000000000012620122474016775 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/tests/data/oldfashioned-compressed.tgz0000644000175000017500000001007112620122474024323 0ustar00guillaumeguillaume00000000000000LzL] xս_@F+ EDI kgwI !*83!;lH"\mo{A*X*BA"|(`r?مt4%ٙ?D K2o4(jItdH*\@>vIx(e8#)$G{߅d# Q̇KU5ځ%^ ir~a(,7B&4z%Ǫޒ> K۱9;W4Ò /tn.fJDKF%2ub*6 q[LECi"de|A1 ȈgY$y_*s )@FQ#لP:(!Z$IRAZ$e y*NP*ӡEh!D$"CH?C)V >(mbEcu#OJ}Hs>Fb?@>kV_S?]id}N_P a[ !&ODU0\*I$rQL 0r #iaN@_LN m8Ga )Ѩ5 Lh0!"'+uv5RB*.!: QW4fj1>^m-^\^8iShDR % ɓf/T꜄9>lt5>fsjjs2c&&N44"[Y:bSlVBZ]$^YSQ<dмmFP L VwpԦ=J0:f;a-L4"=,ҍIp35^ Fzkl(C3*CL±#B؆d>$1K[j0qU+5#̛v! PᰔZ}9{Z BEEg&Vp5QfJHD@A#DXuJx;Aa+FCB@880gtG"Z+J(9ƭEe@JBZ, v --JdEU~qC%Ǜ $mbJعx Ym&Xk$>Gy-6 1i|U(6ӒYK8$EsFXi -!au"R *A:S϶Ah8cFX(x9c8aa5̘amDuPe6IDѤ10cdv|hUKMR/FAC6Đc^5IHב=SPX 2+րSkyB 39T7%\rg3MsPNډYP8$1joĄMѤE.t'Bɪb& 0Y*4JD;(:Nl#Z'Ց:S%0}-?+|Di55  E x9y & m5k S^ݖVڙmVI"qJb6"d%v}bO)BU(0P#!HYt&0{-(.g!+'@Ttd;CydӬƓ0?(:G` )˕G2jbMJRcL>MuI*\©ZPg%bR,9m\1}NLŲm]mD 7E+4ѐ KoṼI 4‚zC Z+H 矕nX~[M8G,3ȟ\Eئϋj]FL{NՔc@*[vs$s!ϴ?+߯pz8􁞞_/,ao`x5D"I'I$E8C9IUgRMI|Y >_(Eُ@@|#EZXYgi? yȄ[/41:Oi>73d8|SѕsN 8adn| 3\V1g[b53F{|1km'җy xZ}ѣo?gNJ^qF/b[>^wBز<=eUw>/_̩cU@9sښcL]}K<͚)ۃ\{/휹xqkW)6tͪ5ߨ^^[tmo_^'\׳=.*_HohW77p4h6IY?2b@XZ?$$/]!l? sm<*}?8/=8 .=fk! e7ʁv{Ӛn>;oW7y_Y+{BɰC7.hy| nj]_=Ĥ;YNN8;sl\yqTr(Y}<%2 Ӕ 38_pC)?ot=Np߼ϼϬf/*b>d[Ck?Yzxy 4Zls37|ޣX/lcMGݓ=//5`^??=g싻)U S.=jx?ISVJtW4 -[q?:/i'WPwktOgSvgl?GWyuot@?ۿh߭oU4p.7}SiI?6B]*yϾeVXxޫ&>۟[<*tן~zpہGX?O=g$Ffow7F9-uk,704{]=~sS;fݴl bEX%c?L<⺗6-7hď2nC19kz. Rڿrg#s4f]Uelx~¨z/jϭ?ytaCo<؇ZP9w%3Ln͊<ōOe;5;ʟ=+n9ۯg~IOUi0Į7o6WyF 6|^{G+?\Ɣc][y~7w;uovtğbߒ{gn޼qtӡ)y]:4zdO4P+2^&_roo?54Rؿ׽))1W༏x[-y'4x16O6{_4M<4OPF;?GZg?j"lvYҽ ?&sT>9P5>tps-X_[A ~spe\ AWx0ޕpn NCNp74k:sf`/\ǵ_cjf汒3oo'6M߇bHA~1P8'٢k'&N7d3q?ןUA?g*J QVƧWzIՉ_AQ„I3QEMq1Qsk/c0!^#({x8^-[My\ÌK=gň ٳq;m!tj:5>_ZW\gH_ ?A{ߟա0w|VEɐQԈNb;TzaB UOaۜ aAY5oSֵę-g6gTc*C1(Xa#tM`Tż ]SSʬG2$҄%z~D>)D}wi%AMUEW!NχR|"jg QZ !LIY«spGz~JeKr`Hi+4Y3=נ%*H{u WHWp@`9` StE Q-$j8wsci"c`Fw֌Fmr,A1g-Φnw_C \'"hr lD rZ{lLm3Ilz_7o3_Tϑw1-dXJ3Vt4P4K[]_" lpi\O͝6A` `Pb3Z#O2o4sJ@.=`ua::a>+Wo!l!ʆ@Bs԰FOpT*HB\ Fh2skX+Ip+RGCuʆrws9r2dCϛK@b!Ȫ &5-v&d;sbrmcΝ }BϜ"M@G:9wFrf f0Q25+R),SBɯBt6H$"KQ 0V2eV{7 THW 9k"Fs 뉰k ? ,rKMMcrSy2\>;ǁ\M-g'|Oap- ,h*P4?~Ai't0A*Cg3(}-WH* L,E5Sobe4}|gř<(=TH'(|s#o\F$lII*SrU|xիūW%.C5eH%\5i TD38&%dFeZMIdrȬ) a !la1͡ ۓӔtM9r~Q\^2LZ20U՞9%QJnJG\9am_c-ErItfz"߱G3͖"2~~V)P$FPS*8p>eJrRu7\ը~lej$N3!aKR1P%D!,R װDg;}tGL{mpYң!?Tb. QDc< l},>h(ՙe έhzA#.x4w+ފ)VFB :N]OJcJN|rF~T"po"p=؏"cg ET{FTʏE.Ft*FG)ߍ3!=$bToZVEee ZVEeAgg#"(_UX"־8mv |zve>!A* wNvSna3OVX&E\IN 1Z~_'))FbC?j_1K?ޔ%4ac'~ (PNi/Cb7RbBAI]|a' _3tog8tiSrbD&ƍ)Jzt 6|FJw~)qT+1?b? ד@XY8psMiꢅ#p$d]˄Q|wьP  SGsˑy@ZՃ^]C|v~m5 8&;g}87 mӫ~rqA6{=tuqyB`[k[͞vj7@[>Vw ttE[?ik׻NWeoկk]^vzMa5Zyulw6}3|h7"6U;=oRG+J} f z>7$B s>lPE&htqn$v #$r$fǯ_Q[aEGrS13Ul'-׳kM;[_ΒM{Lz\a pRrQ\  ?Worm"If$mj}'.m|bkQ܁?řA[IOҡРf87PK\<wDHlUe_-sk#H0],84MM+ܖl_-Pco45h.H ޅҟ̋uA4O=> ]5y3*pz/uP=BMSݵ'IʼnB$URfΖZ,//drpif凐iy(Q`m1Ď?@?{-O>|;,s{}c9sK$4O菲N x#FhY\wg?L[G.,iw]WE:a wgI?\ǴXP'ͱV=0 XLLZXŸ S%geOLh@+ϑJq}/T,'֐ }g1WV6jGMwsl+LﹳcfV [t]g_w2$ign/EP{Q _GW:=mR&窗V]$oX~W$Ϲie&C /h͝.vыMnk3Fč/mO?hxm@O]^_7wx_|.iH5g:0?S{&d(ʳbh,荬˸ACOǃX%>%ᦰWU/1^8LcG˙M.s]P ) c.@X; y-F PUCF2ml[{$|7LNCSG=Ž#o[B2hZi&.<1M 0>ۨdx%.M~ik Cefo~{*0P ?wzoO%n6~@I.#1 2 T9>8 '4vJ¸AE5 8 `I4]&ޑvjDHM,o*8cf {}K{@MR^dJI-Lykja%ɷ%d˽l@Eǿ6we5 HF3p_|18hn2R-)ϛhv&ir>TFXn'Ɨl;w'׿^ \tj.x8N,H-%/prɃde;@P/*$L JBQy ̤B **JS*- *"*("{kwv%mSxwdVW֋`$"Gi6ҁ|b \hSLEUW[9PG٘<$?*B7T;DbXzػ $F}JPʁAӲ Z3<$oUp"Qg(ra7_Nc!"OG? IJ|>>n>,D7J=8J_ ob 3_$Dpl7ڠR-XH9~=bq$NJJ84Vb"^$I0bDEJ|P>=_7D>47$r *X̔¢,'t8iBA zF0$I٨7 b0'(90 OrXA"a =`HR[ \CM?InR+d[Zz9LH ìsazX"B ӡD(1t$UImi|%CV@P2@~$,$CQ^(v{ 4W0pgdAJ44ɨL&91$,:% HF@К׍`è nA3viu:&s`Fr>6 D)z50$dne9K+[ÐiFXhyzy\ǒhAƃac|1\yH_ \D }RlDl>*USy.e«^m0zol%&'xh{SbQrbMFiE!zeEHdpeV~o$4HP.9YWP0D6pw 'ldr/-= L ra,F#B Z I)yP taHglҨɬ DJY\I~IEw jR)lU</D+`᫴xMIPJ$"F  ? n mɡd mPǑ0/?+UHM|Nn߂^}@Þڕ  Ҳ2 p  *^y]FMB{8 qN[ZΟ\4Js)/n\L dP&1)G -OH6GK/)4}hX=j)Ŗ: KIu9JzV-uL>>"?jPdA;ze =,݁y4Yxtc 0:4ԡHWN(a{Ǵ Ԙ 7÷ n%4J;Rv@!P$g:랤q=qAHI}ǐj!#as ĨdHŘDq"DGbW?,"tVP+uWa^%`_Z7h0$ bF}lE <˜C< m&| x(3q\D HL^V>bIRǁw9K{Sn`,+G+h*"m|$¯@έAx,pДr3jz hbX R Q(ŵ?4DzuWS!nEU8Y"%aAx- BvаV3X=MWJ'wez%Jx=r0WJ¾JW&GH YrU ހR*ラr }2NCR&>]&Db]**PrO՞vb4iZUi 9HHT{Iy 'FlR=˓pPO*=a.Rt[RDcey]F\h9 *f1|H 4\7-UI9y tu[I~c=\? K%mC:$Dd+ jڰyq3AB!ט ˄p% C^pfrF)k<!kKn@Uہ^EB%)OvnAv"͊Hv[bP/e7q[v3 kB^1K:VR%:u:N^!iL`r11Q6V^M(/$ao1+Kh_L'{QygˉJ9*j%u+B29w^}6̎q2j18R FۙrLKES`:vVAExT +NFW`‰)bʒm&M@n>AgԜOM5?jq]+瀛v=oQkxRA{2$`C lĹðE!<4q+<,0E511D` YtKJ,5ϣ`%; N R[`dsu6=aNvPTߓx=@Ύ0e$@ab "34ȉCW38{bh L#n ` #ޭ0]0PEF:;hƱSQ`ShAQ+"c`g(>b8 qCw mkAw0Z$#n+V!E90aq'1d?w!2LnՈ0- Ddrm"Xν%aN~ %r o+GP#ϣF9%ďX;*% h]Vd& "\ 69%a(d QO"qQwUP)ơ+ *bءpC?v3/(D$>cq/x$"nNb?v#e22R I+dfLۄƵ d *z:5ћy0 zDӫcE6-S5!OGJ}~|;HrLJ 9dmr8hA}7b#7x@6,!> w$+7F5I!YߪwpY$Q 4 URh MbXY!SΤEA/Dĉ4$mRJRZ]ʢ1!$a^V*VSU%sx@#F!$@Xa]x&$$~h`jC 򁚁W6ӣ7"\Ԏ6!asDAi#% F\!|}36@sRōxK:Y"(dߡIx^­b01B QV+s:Pg .@c]~ Qh<CFKܚPq!ρ 5$vyMP|&7H,(ˉdx3r)拋XRGߓ 88Vp0ޔEE"⭘ _ad+젗^ӑWYU/"̈Z%eWfDAH$RJZd%]}WUKôotsvFRH!6J;j"IMp  B!RKI[;IGG,E4""d a;̨IcQqM |Ȩj*Q/hq Ȼ," h "azsE74* ;> yHK:䢨'NFZ>67NH5E'"h%nh(np-ܮF"Cd+lX_ˁ/TB7㢰C-J%cDig\ xp'tUQk.ILb ShO*A{%Qȑ\zL.D|$KF$0V[QAӄT }Vb-$d7v5oh.}^;j9xa4nT*m??|ɊF(QY^M!'ue? }WS)p_ !eY/Ѩ0y\j5]"DkN.wleU!PȾ``~&MuOH%@? u$^ bSk.T58[jem($N B",샮Q(G-mڛ7([3x A+!3*"YIAb$&ZU"N [+Q)JLț@j`\ƕuI 0 Y}`à ]pTa{trL?D- zqHUb7]@)Z~'(T#QsHB}Hò[!1hpr$=MO*$5Q)p \=/l1XFܥrAB,D 0(whni'P gv~vHF% KC84&`8a:RCJHbkr('8ID9Ak,O:U`;%SsF&\- :GU\9W VYZт9Y/An.=rrno7 z\T|$ <6G ) o7H]}cTڒ:{^}>|q*/'OieT(g[T'm89cF M ?6/dSӴގv7{GmCgv,|Źg[6w͖Qp|ABqG{{jnlf;Vހ3g:m ezlFNo:Ck-yD?k~N]LOMRfHq?ca= Mz.et`g?w6KUY{[Lx~NmNe$u?D)_~;^՛mO<)9{ e|HmvI;j}עCwznjgگuiqCF OqL:~9jk +?+ύ?B_Mvs<nVb2Y#Lfc]XlkV<"VS.v3Y4iNSݿ~o٤"OƩG.m{s[厗jwaۿT IތE#ֲrrvFoZpo7WU-;ܢxcʜ'$Z[:{y権ۜvWtJ(XX4׵w#Lxe|nո ..U z`!be52rɚ6EY,j1prA &\ICFM[Hvvow}i'~k儸fxmcoyo[9GynڧKOɤ v(瑋җn0-[?C3lj?Xy׉M:uאwJr٣럽R%G@;U=7u6ho28b299m+v!2zX7To#ɬ5Ho]bŞt?5EM2_.oW1xhAwbƕ>{ YAW,1}U+}-E- AԳ*<ۓ'g]a0aq;$S ?);v'k3FVit"w#yԹmv$&T3o#O>wKS3+ :/νM.Uh^Ҽ2w:kw>go|~Q58N3&+N\[':tێR´w u\h_:]ͷqЄ㞩4ܡNIm8T9:o:׻apRug"%OMjc31|'gzCo~p.-5XMC_8<`(>N{ΝzDUiSo~mQpsGG?יK:O/xpo*oJE/36ՠ7Or&hw"!bലFc9 v)ߠ^[?~~ .|ּ}dGu L76ڳl$Ig55~gC󯷹p!Ҫ߲1^o-#gnb2rL:Z3wʭu1Ş oo?73F`Ybszj4XӮ9rL.߈PŃe[ V|*f:gfc苇&7h?/_Cכ\aV-ݶgo7-H)wɞi3SwO7n.aY~Wjѳ]RȰ忤9CZ?oL#K'no2Ŷ~Kt_~N'R7F;YVoq[Yf2m6ftZ\j1#fD7[M1o5  Nk<{H?~痢]>1Ţ Zt-ؼ{~Qw~``ot7Ўxa_cYA:ܺGl8tW.G&v=0sʿڽ׳wmgNx6'C%][~?x 6\?P2C9/\[NG0q}<ͷuY8ߚOÆO:}X͋/~PWϖd3O6;D d6d'kM&ns,hs.ⱻo-Jozk ߠ{']ڦwFwgOh˹ 1L}=ęJܙ34Vn=.*ŎOkݙj\;>I4}7ҳs;&{nig >˾w{2eŋ>Omi9ۡs_VǠ+?h͐'վzWަ%{nLsm7sQopb͗=/;^x]B3∷l;Fvnv_/=-lI'јHۺmǿ{ނGJBO%=aof՝<1'2ӛKO]zʊKɋV 6fe'?n+>/o5eM׹wZp_׾}#zs8j򰜛5y\659X-.NoquffK,[ <"gom6^Wkb٢/25̑msN2cqށs`ݿY1x`Ԅ?ь%SۍCMZ $l>oV/s_2jp:Q/h:3ތVН43x |+įW^uno$~ޡ|n-.:oF]4"o0Z &Nbvhvݔok[HFG>42~lgΜ4&ߦ4n^֌ }{diYdfz2=s09=s[ŽFάɗ0\~gKGr֚cbQ73kBl3YcrY  5!MAgA Mj}y;| Xxڻc-1"~fx222Q⮥c*&u㊂H+{PQ4):UPtTAQPCE RE('{wg$Z_h!V󜫦,*<=o߼ !6x{WAG_{+|@@0D$*DƒqD( KB~?ej2ѣ9X>;!SNgj 6{f=P7UxqFomuqv6o?hZ~0Q`VCU ⎔&*mV~uQ2bmi}H Go#1 \mܯ~73ɡd|MĮuȽt~J0Xvu3s\{gxSoU i1ħ3Lf."1R*nW͢n BC*;vӾa1d?W,'TPzNj-+cNN?NгKgrd.l0x̙pwm]_:ߌ;{FUʒALvfkǹwy4.]wg9@ 髪xq=T>NuON2ba2Ahs2o;G[Z-!{Zz|][=ɠ1"idX͖6-<,g }[&ww~TdPȬٛb~H S=dSϏa#i'>Ћէ1LӋ?)l'u[tg"SFϸe,}0D)\6Ymc| N٪vWQ\E^ OC^RƞsF&-9?Ph“[gnצ x<0C#rZ2Qc3>ig:gQE>Uy @FAeՃ$UH4V1JVV֯I~d)-['[Λqj+C97*ZJL[lB*v:4NQ"Fj{o] ^aObf_@qC2? ]rquYLqЦxs&&E*ioJ7YS%rߤ{"&8:).CRF gijSWr?j3G&IX" G)8,@%0R_R[-jѨ_;kbɨ<ϵh1Bx< GœBb0?JoYe&o9(c'SRx܊`M ͻz"ę$ tIidfS.V=מȶ rQ v_SBOyNybPJ麏@q = gm=UAaiAL*܍aɤVzۓ`ٯ|%ςgejRUJ2Ϊ٘Ӟdjn%/Q"A¡d \ F B)OS K߲DLɨa]zvSEB}5 Aer6Kg3hC,7un)&U><|/]=@_HeUumDaWםRװsMTfi;LlB>?FM Hm{mq})W×S132ftRRM'Wʿ[=,Pv\Z"mfBKI#5yf)#?/nKĚOExGd6Z^¨ۦ$Ds?ü< |%cY79[aX]Y ,? b ܟa<GxK!-<~cp $ R/ˢ!:xD0kvGKREn'`2R.|uK}j>?CI[cC}`FcG_' xW.'ط^+5m}ku"ZZd!mX0E9-BI%W-޾-70ή3!kZ~6mèL-wА馡9,EkhF<2 04߯koڽx u.51q+g-'` L&GX&T [x"$ P%CJoYY<:U% fQn3͆A>_L]%$gG^|{nkb9*ɠw+!&ܷkwT(-lKтjJ^3"آv%n= nS#A .|CE#8K3j4÷S*W gcF1}9}sXxO*͛_{6 S-SpX D@QJE$ ЅMTR?Eo FxǁGjW퇷m<;eɕ~ȘןƑ{nyɫRo|Ja^QnFe5Ze~iʻ$PU ϻb}P?ϊKߞ%4ݔpۘt杩h5\zwo"0?'!D<R@@!*^&Q d,dR̿-ۘ~9&'^ݫՓn{-YDT˦Ju܄[$_rܪ{̓WLɕ}bUClږބ$E|6+'xhDOdq`^k3(lHP$A%KtDrDtD@ s$9Jh$,Ib "e^kTU9u~:ϩZ{}^֒}f.DT; { ,~8 C"pXMX `?L+TUIN8{[*e0 ITغtH ^})3.5\Klw_EF29fq98N 3% !ed\̵%Ž(7m|5hOle-^GvCqZ[NCX]gNJ1ͺ8j7 0BaC7la@4yK cC0jy'KhTQHkZX/o4,1)D4@Sy^Vew['{KE)[d*Vx9a1%FmBD#*y^XY|8^s(8BFcP$ ` <C?6OǠ==7XٌlT~=0?v8 HH4 % XI`18O-qPC  541ĿпYiELN׆n+gk^GqEMe{/hLd?HևYn)C{(4Ҍ,?OBů0aqP$ww  ap( F?T/kO7?tZd9>2TU1S]vDruI* }O6#lIVQS4U@k7꺡 P:_ حdqŀGUo Us[$Z7/\HI#9j37D^ _)J6rXxKMb,8,rk1yH5$ kmʹrHԾ-Տ4A?~^L^ROt37}ӻ,}ԗ(gw-5Nus+C->;  C!x p8@cqP]/g2OXYu"'Sebm*dLi$qc5%{aNt9_:c<)[F Y@en@^\zI"^)F.ǟH$-r?}=} hT'xM>edV[K'xr {7G_&v\L -%ȋ%힑m1x^ւ AطhSH_ׯ\4N_k嘚u ~bM%V񏧢yT|D&9k]gXF^?O%D+=/RZ:ޟ|ivŇ >P&/s 2=RN3›bWVJU25(cd֨߷:{rS_4D>-*!w["b Š0k.um,L_XP2-kкeLu Egʗ X`8:I&$eAXQjU:n#*MƇ\cN |Mg4]A;EhK0MÃd=eBiUL< 궐.:iWté T Xn j73*"[>6"b/gWmg{T3\XJKi<J#+HqP~ǁmsp҉{s} @s"K] A匐Īm#M@2sT7zihN&=/(Oʹ'Oxk{2jgf}ǎbΎKܱI3ss7lII - (?_ĺs;wuIѬɤyIC8ua9KvX$=oRݿv/@I|"-qCD68\\dv::j^8!@,> F ƒ PA@#`PoJU򀰰8PHUM\29->͙Ȇ 2c 18 0УEj{ _DBHPZVE{C#֖&[Ș棌j,P˅)~/gp`` C/D#P ` _o.QhpKbMBšeF4D +PS18$/\<& 4!H-:CG"- ? SZG\>v1#P&B!R?9萹elfXL-/股Z꿗4Ӝ}ߏt-< DH55}t㠷̩vՂrݲz%1+r:ݕc.yYm =m>ypƬĺMi Wqktqh-|0R;^MBѥ'+4tgOu&+B&gDН-j:=;zW;PA)kCQMdKw UKV2ʊ?B1I⧻\S0k'P{%PRKI s_D/@Klj=6}*h(Лin;U/Ǧ__ETTsNva^e GX[ؓY,M_?hc^Pd>GaÚ4рe*P%z/lO½QB+/{w{9gh/~N_v\].4Y3 lNep~yx\"9nA! *:m97{Fx⼶|B0'SD@9Bl[7Zz"؛8ìJ#/qE{$Dzҩ\2Aq 6I,ghI:{!Zt0k#MIAY铂q.(a4i͇ 3G_xIuԬOyE.ArFDrPA@rN"N ɠdA$$HP@d rZg[깷U{fjzn8SztJWgA)f+}{{[H -K!Fk ky[)~@R!"\z˖!)m>Ze?k]~JOEn\OP䊨+vK[KiԽ=W3ֽY9n&T_VK;/L{*9C n\Co 9'1m }: G9?%V]?"r^]+##Mw;_b7|S*iLQ@{,[475&fw]M(x4Ȥ'1*O=䟑Ė^sY]Y^.b' jj^ W"#xNż֢O5 mmgdjHݻx ƿV:u/yD_rӽ̄ùwꜥ$?:\Y$y$![27Iख़f$uƝ\Sm, &E邠Q C#p/ KYg:;ݼ_TaI,1T r<ydsU;Ysʘ4$ڹoz'Hμɼ]nPp1^D1j:== o_^X8W6Rxsfsžrl.ZdL2>gV:3LZ@'9 5^uF ҥaNtU ?]\kd;=옿`sX%$,.fX%KU^f:h[~DJg\kԆr$UZ s3*^:IdLA٨nH hp<[dv²-@B^f.CR\Z34a8[ni89wy3߃)-o27D$Júfpk2ep ^2_JVpU󘙓}lO[*ִj%e/(5Rʁ&a.g|Sҽ-d>y#}o:l.1|1~JUiF/u?}\ފo8|=U"ӌr_Q7'*4BHD6j[ ^#iFۈR׹9f79nO '!!6"K}ǎNbf(@{SÉ `Y蟻$_C(BP 0K%sP襄6-N}꽪گ |gESC(?B[2h&aLH y50#`P?0 @` Â8!}8 AP%} u-QӐj*s P2L4*,o4~n2tҽޮlH=v&8͡%e*P'b:u=*ev<Ŷ,ػnm|ijo?>;"MwMd]G ZU%Kx쒖>D7˛MFɷ% ;lx$္tW\SIFuVz ҏB6{z "Q  P(,C q ?Ko-2L{ʏ:%ܶTk(+z؇YE*啹~Ʉ|\,^="I򨌠 c6S\+{YF˦KX\U¿π.QU=Hc q1fePL-dQf>˃b璤T"#ӃDl;A*>hΕLSFl0)3$sӀ-N]U-VF}w\uUhW_Zo;X-?[T~=AKcKNW_AU62(hNeDڂ2N a)O9>6+&ʸh' Ȗ>[̞˞O(HoxCT3geΡ-t ők=14KTM/?AtIm'Zƕ_f0P PGH%x{kmJ'OjiS,0«W8LVyUuaHJ(q:PU "QSAߧ<.pX c``#q  k%Sgcw+2۔a{^V>UQnEbpV5 9%i7>W6-o)o)#űX4I X \T87,""vkb6l*9̕]"utk{@tAQ I<.>6ʂj3qLSw%>G6߯&AͦPC5vxľ*DfgJ:gXĥQ3զ|ا=7`Q YG)4.| H\ц7j&3_nUh*wϓbܚ~k8{o&Br:߼/$ThcvSfS@yXƬDM^ 0VXY < Nn4KȝKaߤ0$+t_Q쮾tEw5S7 hrqB{Rke A`+?~@ 7"Ah(@C0ﭿx >}! !B5SoTFt;R䡈>I/_m7c$e\߬t:PfmiEHn4phMKV/\ [qwGE׍,$&lWhtZu]{n:窬B?&>^N=ɽ5BcpKk7/U~jٸG))ֶu?PjۉL(x{Y '%M/յ6vlO>bG/WC??}+B}GQH4}+4C~fWa?_?YJw0x2<[]IdVe x?>Y왪Ro{ĉ3×ߥNDŋJ{ |۝TړEX'}h0cN+Ljb.US`#TGy֔ε0}Xt1ÚdGGIĽOcx8P8CNǃ=0,Q,~f3W*콽bg"”^Tt^Y68LnlpM{7CyiiP$ܶW}|esS4jLv`QܒEԧ,AIfM^>;>MߨB,w|Ro4{ :^;\\S_S#oT Td"0hʒ8Bnڈ3ͨQr>x̓adoޣ4'9i@à)dFErZab_C\cC@OҼ*&34CRofSV8ɻs"vпY|5>fpy"Z"Uևa^O9+_}9@z7 \H,LpO 'Ti-ŞҔwɐe]:'-ȡ X!iv:߀Jm*un Q{^fkg>S"T{離Qy< q:uHj>7Ϙt+dX<)Uk#>0V3gqz7._uݝK^Ǎuy_իN~j7 ?'sؠTXxѝrU(+xtĢN♮*"*PrST LX D1sl~RjacַS4;a}]D~hh2^'YPҘUiw˛ 0ŁzyG_F66J4R2ٝI>㊧UM7[V{ B4 W„)qNp:Bv?@`?Aa1( ~C " X(}rL'C_?Yն6YaZt\ۼ!I]@BX| >10ൕ}Q+Jl]ő(f)^ bV7ڣJY Es\'.:vo+LzjůLhwyb /PY;OyW|o5w-OB]]dJ|,5Nt߁ұCcSU]}?SɴuA.("c0QOΗ/xD3+2W#]fFr-^>?o?XC@Ap @ b~f +_~??L ns}Q,~8 MXfPJx2ߝQ'#YD:^o ~Cl"H4FO(fedP s3AzYx A be>@vV,kO_kߟ5ѝpOMW*$ S_\W@(zx8 1H 1 ^EC!pDB,3 COeޖ)rMm1]k}0؄,MuzyR1lKu Dh_iwl\M+ʬ J4u#,[Y^a~]fp-c8"o8[SJ/[=eY@5OV~2-ս$eϺ;1mNZiڰ|+@MW]S9?{ڄ_X1)ۦ3 Umz]??7 < N,sz,9e1h D?G{/џ ن#v4R2zPiXŢ.IIq%Jwt) ]R(Hwo}wǸ:{w3wg5wwp/\l}ŚU&C(>w{98//İ ~Ot8L _UX۽'|eógyBÝNB.LY|{ڽ-())m`6t]G*=m"Ce m4wKIw_OO-K-6?؂eCk`A>\x\`~j;6jQ]t9Af&{7*lζWlWiN:c yb_K"*cBwY'ehgE]U]#ڼ=ڥ ^M7fPCDA?? _ىA+X` v)_w+WO5Msu<믃$*NțWh95N)F#Ů{$ܟwE_ѥFW~maNL~\-n"BÅMWi-L?>s$Dް\:?|9|.CZm8Om=skPSq_5 H~X op-|I>s@y.e! |yF,53ĕ- ?1(7&)>$ GC D(Q Ts? 7 T$nLKͶzf+63#āt&':O$F6Ǖs8#uu_?y)Fʁfg$\r|%5^wEu|(1޾VXf-QIek5J!@艪4bɏ(Db%5POd[?I*u{7PAD`X aHQ( `P Ň??QDxǥַYE'ܾڄzghc2>tpP0}CM\BK5b)"v"'ߢ:nzWd7Z9Z8d,&kӊEvMgwj=wM_Ny DFkg*jзd T@E`OP8DH h@ DQ?؟P/j7k!s\}* I‹}=g/GF%u/xdIu$Vc%vI}Q hĬ˂( XC~DŽɝx*ޥ>,Bp=ɮ)wтk"i4~C,VAs>T+ɋ]DܸwTڦzj^WjWܰMhFT|[uGHӾ '&~vcNNo:,9I/WyYKUo+i?"jF\^\Ht$xؒv*R iGj}z㐸jql˾s  ][\y]{uq=ǷZ&9,ݤ %QtBNka1g NFCns!1Y qU? ^ 4 @XE@@àX 3`WC~{U^-~#L $8?ֺ"\~\iNt1 t ?19Ic\q#:ޗ"D:ozbpݦ-\ 3.x\-0ܒ; "$,$$5ir%y~5V0<L0}oQ9\U0TŷqՏ$PqSÌUN&!cET<8G.xd[/YrJJ0vti d:(5QOÙ`ϪIOKY{r䚨+]vn38 2{dkx|]2|朢?Qb=|'ˀZoۆ4>t#`Ma㙾'.C&JҋN0;6Tsxgԯ+(;J}JC cѥ%-_wsnJ:7R ZN69=G\2 6 `C/GL%i"_sN+5Pju'Yx6Yx1\.}Uԧ3!_Z]%ʫq]΀=Xc͇ty)h馚~_z?#u+lEFUx~&6#)WXYȣ<`|qO~ >-t iD؄x--J  qϱ\xBqrׂXoU>C1eSt |a~?^p= =rNW}fm8Me Ćl>X5D<%YZ#}b<^4js!ZK2W}G/ .Y 062o.Cr}3#gr:!)APξᜓqo9!Oa94!EVkYKXk{׺Ysf iScP /'&W5rgnHc0Of&\0^U^h5//%Muxoska aRX1Sj{X<7>V(;1ViUE;%H8mi{Xzo3M{f+@"yVan -+ $~a(t"C '#y]}DxaWcݣCO&4Ew{8DJ$(7`3Nq9F@n5:XK7sO |B+ܕ%yWԬmّ%qw$qepan\HV#Y l5F8 U 5SvX=&j^N5df>9~{Ϩ$*3pamXy,yQ!Au{㠶\XaW;Y[/)h~!ThYW>eY璴+1iQNp(CFV}*-슒Gf6$+kK>а-=a>BX6&Dd'6~iKTܡZk5)킹dHccDZW>~&~ʦbϭۭ݅aY1% *h.PB+wߑ- ]>t?y2lvKonœ9oTt3<aFu]WҎ&(7f *]HkݎRK^%kmubp W#??E`(00! H('ȷ[+{D <φksRdͭT3ʆkJ\ $4#_]Ouvv XO..}Ê -Xw ff\c~哛gaEV,ϟm---PԪ{nĬA*os<,`Еdhw_o)#̚R :ĭ=tLpe}O|"&xYJ3ΗCb?d '6v~)~8X"+UZ:|XvKn}6"ȰvzQoĺkJhty(DmӨAFbe͐g?_.jd&xTWjP[baKmt9gmij9FjU"HCŤzI9.K̍{ݵ2] +춶/T=߹m4!HЦ),\;Jԫ`&+KR͚qYT,:Frc|2ޱ*zX[듽_;iυ'B|KbEͫR ^f4)PFAp ' %3xUN\/8m+R*&!VT,)-i^ue &c6?Qhսj`s5ȋIjFa"xG|/hcv ^Of^4>5IqsU0^ٝbAY(ZX~7Pcƒ}Ţ՗ICf^m 1š-exͭS8˥:=TJ0TIT݀>Kj/֕}|Rb4KpeRWMfb6HݗA Xh*,/S%CBdIKkj~2ڱ3ť _gT&pXWJzʹ#,39DTܺKB{Fxm a8::[фqU8*w'&в3֝%R>[4+h;7({vzrR¿w7$*F$ M`` X7"PX D_ C S mT= 7m`j3SbSxPo<'/lvJ45]yi;`>/kyZ+֐6ʷF4*RՕ q /Jyp??sIs[˗\ד[[om= V+OU{{4ߒg|d tF߲~U5YIfd\sL{!awXz #5@0ś)hF'KqZ!O(d>T%V0&zc;H]D.U^84@@1ot WWgǞю-MJ1Mj]|FQWOxU8bTN$o*_VekF](J(~fCz='lPUl.s_"X-A9)85Y5Bio.~;iu8hB.)f;},ȓ;feO8ZˁNs bZ0}ny7ܛ$'Qqz693Aff eL^|<zLndB@Ӎȓ 4c 6ʾwsiV ]|]KkE^u?UKNLR+MiכaOd?՚eᴨ(8V) |ᥬvZ`kR,&ȖZhgW?4+uرKT ߜU}<(C.scd)CZ 8Ϝ;?U\i婩+-ߏ/h#`݊N]s`$. 윱ܠB[s%' E䉪n3nD&R@# 3.yϿuJJӯ+%L3їs1ef8'?3/gݠWIzҢ3& !]! 4ك(_MFWxJK~'t >J g4ּ\(Le1&U=4T = z"t`pᶆg}1n4S4u,:wW':*֟3"ڻ38|{>2!4/ I,Dj MHb>mw|\dA6 @ Ȭ%~< -Vjq\ wŇtC:bvzr_+^b_Q 2j=Xt7{DR[dwZ %]d0ihZQ{Y,l~p䍙9X\m)}\-mrݱCh+%9 m NiZl5R[n9ü2}6Wp0( p8, /__E~?iC8}ľ8JɌj8G%@a"A.̞1md\J-F,S*mmEl/ Ae9I?}N˭1^ХYw}FVE.i.~VvA&/XfGLl93mb:m)Ad#^W# G_M, ΜnWX '8{ ;b 3;˵.Ր.'([|/UH<5^BX%?Bq"Ttܤf([Y 0[uxL- 4/wP}&Sm-\ΡJ6iy/1ڪAbT[tt@5>2&yM]J=BPy딶qJ$$Y)hVf (PW9}2:D)o]M ~tyn=? GbX( `X0 @ F~(\Tg!_%Sf&y1^5O,{|ut?o.4R5H󸅊P(SrW)J6ӽ%*OjH jьٶ9e8re @Ghw/3[iP g]XMaY貖\ᕕty83 _[cS *Fmit@JG$ -L-L&⯜VRdp7Iv>>٩E|YN= [[=k7uIFnyʝIvKk m~)͡J4I}sWϦK(.,qS?=I` "AcD]P M (.3 Go_ jPﻷ|V~=/lG/G9VtV:}=uEf$*Dž~"sٕ>D;#zvqi#|[q|lY+^3L/$S[]\:^:e!=/$% >ػ,L?n F|" P]X(cftCA_:Yh@tE vmeNV󚡆v FHLtP޻zA5 nc<8Ѿ`a+%|怹B`㒨Uw!( n*׋Y>O3$jD]R%;p0krũk>8‘S? ?QBѢ(N"1 H!v[WKM}@^n{n5c<|%Iđ_ĝ+Y3X7ö'6Fnrs*]jyzgyb\=^2d"2d^^ýSd.!C̤֘PBZȐ!D)ÒP"S*Ny>y ~_w>_8ئRSB*FJ FtXC82_MmM M)_y_a +INw; 53fzz.J];~wr-r?<+n)x,*a$0ֆK[/Ο';"!s;s!}A6ݢ(tZZ L6lnbYgt!feG·HaB]r&<2E][cn1MJJ683;$3Y28+tnp +HA-/r=[ Xujw5< w myv- -sb온'7Mj(Z]crջpi4vRѰki=v\|Ç*3 8u'':kqŖZ%(xؔgr-/} 9q! 85G?4v牑U*v@>#Zjlcᵂd >yTk~R$eH#UNn\[p?k\kT o&\+%15imLQv֣D /92Y# ܐ mWEh}3ڼb]0Zi%[`dwϸ aci _CYn\L=Qu~$R4"S ^͔U}+BJrѭ`v#_#ӫWcbdշ& oYm$6HyžM=z;4 6A~sۆWՁRN(L'z=8vSaUW I]k ̛Or2 y4h/Q;.3l~lXO̿WQw 6k&\>@AcgSvX^9h[+ }x^^A!(2#gE"TI* C )?oFOSsvLKV-c}6B^ttW/촚 Q/3'{ogty7"Bk{Lh-kmgV)$$I:#91҃#o+z98~s,S휉S0wubέ AlNZ\iѴeKiŻ ft5~-:#'GX.Z\fٰG0A$ H~Þ X$Đ12Q֍;H"Jh_ǀ߿FBXp%}HGY/7;CH<^i9LśY[i/#k:x' D;?zf]{窠ۣJĴ-mi3& `Kfi*{YRfGlalAa(w7wcrRJz=ϯJup\]#O(di*Ϙ^$d9tMx Qvٚʯ{_ä[Hj֤n=,ѐِ7Kʹ05&S^Ufji=L5D(KH2HQd,BRP"L(uo#/ѿ W0@XP9dgw~:{{qL/9䔸cǍJX63ً;]f([_4UHJ"EXk *\?QzVq;Q%Bo^ c,gxZGJy8p,T<(뛿@HH2I%H4I¬/4??# _M%ev6=[<x򞠖,0;c0@h9ͷi[-{I"xejí 3zT״b:ۢ)7xRҁSDk=y;ftS-Bk}Elvkkʚ*A+mldÈrY!ľyJi{EmĭjKW}! )ǘһ? c C׌TBh/8 3KEFuyE'Nݮޠ36{ܭ..u ;q{ #F/=6pꎣ eWmqqRk4ܮʫ_zF tpn /zs/<_Q|޺Wq/{JuX/wCaP?Pho}(4 ! hCQ( DS_F_g뼲s|I BuX ^!:Ļ*>_7hY=Kg.FJG3oӶ@x1f K |l*,4hU` 6.kke-:Ol9=-]8mJo~[%}K xd :E2:ꍔ\ȟڜh%/?@MWJգ-bD۶~pdul I^e6K{4Cg4 !-*>CYLw(O(|ƌ̩XM[קL q4P# 7s'-ဌz扪mN='m{~6CE9@DbєoFTJE8 3?  }W]`A7WY' ۨu/|=a/U >Mc9&0\YqTcv_|p_cS93P7b\qjgGeS׬\,UxlUڡEcūzf܉[}s4l oXW+^=@u;HVq8<'9_JmkAE[^~m9Etb~~5h,ǕM"{X{Ok7p|~ [3,Ž -'%BP/=mXϭG3w~ͷyf.X!į&D;]L|YI'qvj81V/vᔩeEFO` &zDUs%i=(,{hz2ߩ1A!0D, !H, #<(`/?5q4~F p&&`:_jLPYH]Ğ=عyFIDGPۼ'P⬜X̉,tJ1E %(MuaPYHYDZ2֨V0fK➻2ZX' K)mk) }U;.­53ʕ} esgBJh.S1f+镻j*V偾=30Ì"mdwa| /Tj(7pxCOhٝ,TިIH6;wo\)(zڍ3))0:RIIe*I턐*e͉acޱ;w]lYijZ;|{vAעQT΀pz @WK}⋝5/Ǭ%%o(* Vs |a~s^Ҧ5=ۜ7]Zn^w[o)I_WM9{v'*" L`zz▒1z,mntɧu1P7t-˜9X^EViK+Px +p~qdm@@ >terR}O+ w)$PB5ǖJ6[z'rExEF,?a-IdE:WHW^.!ϫ&E*_رEPL].&{nh.+m#z˔ד5"h' 1# |jxDT"{-ax CŘ  6`ƢfzVLW2>*x5x#fm}\qRZ6\ُ{RH~'9GfSK!p_ x>P"A)1p0DP܏pp/S 7jY9ic,dw,qTYvAO.ks>:f\w@) C!4(w{JCgkQ밄2)2ǒz el?oܦAzPN$"[RGjZV~bǶ曵GC?}@?H (Axȷ`X?__?H[QPMzMwCUmH0gm[`-Ծ 1+72GDk~q|Qك$PM3#dT!ptUB  I+r˧ֶedR %1.vvˊ.!0 h ͊#&Kj 6x _a紱fٗ DK; /{W.C{o'pT8Ϭ٢uLS4Nm*l.eFb{E3W6OIMb4k{L~Kü5žV-'ē}wگLf},ik}c .4#?{9HjyB'R1-6u\FYȭ;4f{v9E< b($ m0 Dq` kO1s?DG˙ch)Mv E;d9Lc gN^ɭYjB:g4h5ZȍDHܵC{'Kd])v}Ƃ\uZ  s@|a\7(NkEmnmh Gn:Юt";DF/bX+(f>Zj#ȹ(Tbh#{X jYX=rN&,WRk{z7/՛}usޖ,0#WU]'6"dJ'/)"ۖ_ __̗A0W_*SuQ;3U^. }L72[]1{#V8>98سA<`$QD@@a2bax1Z???GO-C,R}6N-zrw+^ד"Cu[o]fzO}z:_Xӕ앏mZ<=h…wu>4;X,4,LsDLF .˪>UV԰mEkvZq*U{X2dչ%vD 0w޿+4Un&|'o'HDL@baSZXBQ0p <(h? /m͝-&RMZ:r2fîrf uXf[u!fn%%^`fF8\oƇB%Cw'<3, K[XJ{ %Hœr<^$QPUvIo\鞄}k_Qp"Eh, d v= m ׳2G &8#tLƖwϞ{OWc\[ YW=MTN!ŋ)dtvi41@n~zbG 9rkƘ>>|F;%HU &ꧬDK\m3K/]7$JFޢp`L{2,[]_čWˬ(Nװqˌƻdde:V ONXOJRڱW%ؔd6o̼ M8UV./޷ է-5z$(x('P_)~c!")dIax8K 꿀2W7~=1aKU[OTQ5{UBfx`EG *JE(nٻzbػu"E;%6'="ܗ$TblaEKxbOe݇Ԫ<=]R;?MBi`,Lp\Jʊs,zAjnLS> ^%S4]^Nhb?rQe#u廢};Ĺ[?k?}uuAϾUۖ;䃉v\8;u4V-bEǖwsEy'^3&iki>7;_}4K -4{8aر}-}v9SI#Jy!snvB]1!EMBdlk`v#OK>x^?qBK\*KN"$yf*]%+vɶ.q^MM/U֣>1D8%Mg^X2 (8KĐHx"a `c}F_n|g ZFJ6JMyJ9L=%N%?y' ca:myLB@-S]?jTMK}W|.[BB4IpC2Dkbz$yi:RֶY;#NX󍅅bsT֩#&.\zCv͞*MeUϴFX`!ɝҋe=uf~_7`Sd?U =\AĢLn9M>g8(|fOGxKv:%ά'%.[آ<@ ے+B%-+jDg4v+{;B)\,*zi/oƓ|qgB(k#G;7vBAOzjOM+=O;zd^#((o\pf=b>^]cd2z Dyt;NEGzys  ï0L )*@ڏst|0$@$x)2_ 0$?R ??j=)op6>Ťw3=ql;k}Iȹzm)wzca'BdUw"Q&oHz'ϝNVTR>6ŋ HPڧ|܈#YcJڈ @] ݼ/9({xg쎆3d\#Jth4p~3Q.xdIk9On0ת"#]qaB`^mPw;uTiI f4s켍/H3dVPkR``{c)F`jq\ }1l6UIO],ؿ4B}>m5ٮeB?+v#D{zlN2NNmiM;D\P:#yC. ljΈxA4o ѕ\*05 q+t<Xں~}tOw㯕t5c[9zx*sLuc5&V{kϑ.Ky|sq$am嫫RKa7* X pAKҬd9dxX ,| o$ ;H9zw'OCh0=0Ru8LSi-TӘIȉ=SXɒeY8ᬗMm̈́qHHjzg*(玿xG}` .DKB$Xp*LA6~h/OoxzW{VTCWqyF҂vZ`hTSެU͙£ 6:O:U3,[ k0JKTN?Õ3?.ϛ~*Rmkc~z ~*!$_s{vEbL 1J2g˙09M L &~`Ujk+ܚ'nlLkiܿvT\޵]V,\];cͽL7sivIH[%SYPcBɭ5:3$Da_:Hj|5\KZu`OكSOvSk)=|h/6ϝ^.;m$df+fKwsJ⟌QV:ǚ"Z:{w:#+.6?n ꋖ_5Rq#aEbm#?oܯ~CA$"0@FXL b ?|w0i(Ds_h;x&=̐;?o_-rъ5STmbD5}msR)C`([RYLkhz7 ~9 |z#=:n 2֗$&HdKaMZ2}F9 K귃^f@ַp$epB͂fӏgYu!K=s3Pc#PX[p 2(LYKP~G`7.Pڡ`.>ч(L, $뼲GL=4O9azSN}!3PImhkX&o}utgo7S"Ĺ0z0R~=eϏ#@:yM;}wN5T1)q ?@A`4p0 ¡N4C!7g/?/wGO[ֽÜr`åQRÚJK q s?R;Dw Tfpe%-q噍 >/1kW]-A2%ԍs]$m ;L8kj()m"y9-_m71׈zϟ/qYu(d▀:J^;8F!Yz s;k<ÏUkGF  zk/_?|3|BIPH 1(00OapDƩX157b#SOn}DHB+uSL=o ƌ[qXgG9W>.+ B SiIoe~t3Mx&$˶&Ҫ׭\T H|Ӟ޾"Χ@2 .7NV,1j>LRUz.\k[Zm1IaU"!b#ᾟ[Uy;}2 ]A,;Uh=T!HX-WgWLߏƘQЗPaGXRa*i!*86)J՝fuv"|J-ڛ&wLrטgA^C=}AQ>"zzcJIO nJ F Io"fo\brEү⽘WJ ,)LL=g`[@NOb(l|-N]u%pȗ 玳 @0?p' x &Aa`/w;}":}jx_i* k* ͽg@,1a!-m Rݧ/͵WO178D*'4ū+RGYxNv`vrRlvrb~S t"/"<5GJDЏG1 A80`1<F0Xہ a KW l޶_8< 2xz0+IH-M%"Ylm!s=ڑKjm_Y[]#QS3^O7( yq &[Q)_E>u u]_of e'lpyp>>Y_yyofDŽhax}HsjONTRL[]y$Eh˰$yv9\yjvOR5 W@eOnv_{d4 2?(ɛ6!/T@DcZ1,;J@Rm/z>1}YARx'5HA8ҠΣpyxRz͓yZhէ@s PȤkV\f9:5K=!l{.uX "-PZᡖ\֧چq)-Dd}@C8{ԋcּq&i]PπLT_݃rDwFx$\\or.T)d'uV*ˠEj ¾RYXC+#j+vK]m~mtL!g뛵c[2jQoΏSu ؊1\TiF辚XzUΑMúYR%.x'q U>,SW)vh٬3,J^7' Պ↾Ŵ0}YER]ͭC*c(+I^$Dkpk׮pa{q?YJCϾuθ37Iy[ڦ WdgȼN cehĤzjnJ]< Y3uO.)v'Ch! 2%W0+}qEwn  ~mzYځQy,fڅ:ܨB؁P>jusJg*EΔ(bugZw3C$ ":O|}.5X;xv3iR³编3/5L R+ &S (h#;>OGè̎#c3E HO'}ұjayj`mWK6njQ?r!BPms~*&>ĦZD[FZ*0A_W, u""j[Z:n(Ԯ0&xYj(;W!{|t YSѶWG}4I"~z۩ᐥ<׶-rFC<9+֨b} L˜F㵃݂w|uOX9-Pl x.N>q''7"xj$$6|1gsřdi!(@ݜ-L;Z_z4eDfr ,3JpE!.i^i؁FT2o Mgn߳lbEOu~VβyE:*ؿnwgm~uzX踚=8u })8~.T~'bsi_t$J[^&6iڿȘya]0u @κMd-{[zR/\ +4U_~IS9qAL,х[$GTS|BT%QX47>dJusW,OM?EWnVsBjXj}0}`)~՜9@'V|~n^'Y0Ltu 'rDuK PqBz~=m(1 b+Z}/cWN ]ovF*y~~ey׺6j;;ݩi?G;6Oax;&=X~ϘexWBk7 z-z˞·$!ڧ O4{FƧe{flBh>w紖N_- 5}3r,+mUe:>]Bxim8/Yrh뵩(dBSer:ܹQ;}sǸy+5klb˾G׀o kYSBpZ5;A oA.Ɏ|~B_Jh{I̻c7uP.] b3gz%#Bq\o8E6WYۃҠ^ƴU3#9Xeǂje^pXc!3 F;v5`^lcHՔN2CoKŁEe"m,}S {ƝT^ю)R;Ւ;gV6ŒTkiZRKgR򥆋cS-Mߴ=fQ^kM;G8rZJJwrωB}VPK=9zXU9]u{~ڈÅw?zcGy"higf\j}Ts1+o9~G@(I@@PpGh `x BQPCv;p@ (+r3$#ƉR\SLtAmX91}smS.nvx]tX,k iy7hac@"X@5By΍GA'#U 4 N9QY(ч<ʧL1/a&,fKftvlpo?*&i:-Yu/l(96Hٚ IzZu3DCٛ~Џ8X04Z{ ¾0OC}7 n`u)B4lux*ngVu>{^80?,V5YzS ݃JPviXUXXoZMMe)>=3ўDkW(1/mNu-aQ!gDms` G޴(Β\[iCC&۸"6Xׯ ?`$mH8]#?3_7d?xҧ씦iOȻm)]1JFk4I:Z- K0Wg,DK'lܧ$ %KOqeZSg b6=(`3wIm>TjpWnB_9OݎfګrlO}AZ:/WǗaAGxO]<_=`;N6`Q],( g7;ْ&S4<~ c5.a5YT/#䡖&tCН7;4S8E:S1FyM9_9>ܧ޷0EiOV*|Wۈǿ d@  Ł(<@?wkjr|KNA6.¡$>R/Y|0>Y EceÄwFGg'I\sC{XJkX2?y3HPNuHZʒ#$VJB<5%A??P$0~Bs0D^e6 KfpjXUp܁B'dq UVKgz=7_K577#ts}H2}rߍ~g[C4wML;^^_m?UB/&BSXv\H0M^^IԌ|qx/Hį'nK`j?Ӫc̖7%a+ExZP g%?l~YGdm3dTvp}c_ZH3w NtFVY/tYͧ /A2.$sw7\}_i^'bw5}{z (-h9HwFN=M9k k8TK2ĵҞLqW(bu7+)MoΔ&ב`O~Ğa G 4~  ~zlOTsx75qrW<[]ϵ\ӕ-5ʈ+ٞל@!L+xCC; ui 9l[lyj>Wǔ58m(Zkx.}V4җeV&ߝF`h=k#xZF /ـap.$Ǩgz.Bbgޮ|̞yͽbNdzxSлZ?֩ |N_Rv[T>$M(f$7NYtMWg(@@pF<0O1H bKu|47 2ν~(ho|mdLTBV]4AS|sq@Y\m)iՔ{s5ULF&1_ WM.b/?ؽA -)ƫiZYzkf>#y[s b"qm j*/5?m1p8Bzw!! $ġ@4 pX a@ C"HOAA?(wK}sS?fB5҇47dEnc:,urW{]OHs _t4e]uxY2Zd3dݴ3ؗ{3Fj_8Fn" |YhfEcQbGWՒgȍWmTeOrJ|yT($ 4};=874np 1 '>5H" "#G?r B<ڵƕ,Fо+~e_? ?f!BD̅"QDh@} dna)/$w/i?*b- 906Z[p-+JQ9䗩bKcrQ}{e c?g=kX;(XW^|e҅,_iܻ°×[Oy)*TffJ:Uue>RKγ.V_* i^?Gkكr_{Be6C7bNy퉢m ? -L%U@B|0|s)Re,5Иu-y"ηx9´Ȭ0*ȫ\T/KC|+%\60rNjt VWFRn;8hMZ`ֶAU S B&;|}H~ g65N%`.46_խL]m Xd{QkFsƤ#eI*j2-Bq'!>Qm!ʘ>:U6:I+¯Y8 OI^Ԥl$rrwčֺ9~^ xUg)GEǏ.#Jmk$뜷X0 n;Κby]H r4Hl6ͬ::6K.Vtl5z!x > o'QGUY:V@^]hzyb$&t+}fIrλ x8re(]S~#&9oǙцoW gC/%m2-. Al_p4[֥E9 sjyUvuM}{S;6b={;9%Hڄ\شP%JBN`@ݾahپ0%_$zN#(;ŻE^Mۧ*xs'D C臨g5č`32Rw+(-JY?en0˽P'XFx3TL ""syy[}Q;zeIZ/IG"FC!AkFZ׷Ÿ{'O.\6~ίM$ v6U7@бZ#k+p בs+%3ӎ>ow;?? SasyYkۼAϩ_-rƶ6w\TVLX 57?RuHw-99[W%ڸ?5qc!R?a=mƆ7\jf.G"C섇t/=Y$0Gi{_z|?}gkEX5hx{ #dCYJs3ʟ{@ 4WqwCZlҁt[K[LzC+4ӡiNBwY0Udr37EwL\I&vǟ+)z]0j{r[V!2GY/:(u˾+sS /),Cʽ|\Ntʥɔ7_S, 4QI ';>G8Ȣ\AODA|>nExRYl5jT!KUc]3SM2ޣ·E>ME 8֔Nƃ=|OyCҨU}xqpّe']4ݙDUn kq _>nk(7-}qI܈YV1_)MFbdSCI (^hF)gryZܾ&vnrq{Abdl6 'yJW}mB3#vOlgxG5 sO$xXKSop -pX*RK\ ߖ^]L:)Qc|`d^́8+1]Q^ED0BxS.DvDOUqtoKͰ8sWƗJ f-n={eJw}%O)]Ӳ3Y>#`@֮UH&.%#R<#|sE~k̘f6-O6wi"|*=nfI=^Мz$STlY;dZQ&ɫU8I~zܝrWF8"oB\/w>3Ώ{&#Epںwo>vBn_/OɔzY\Z[w<Wji%^?1_ܡ7m C /:l/~ttblQ[Y$ I7cWF܂]€% s ;+a$ޮКdCMώ%1 ,{)ҧ]/BXpdZ׉x.;8lc44.~Ko\3H (I\Hr9J:VZBRțX?N;Z\ Ut^' _RhUrMMya7 /sD$9X.6g}\@Y=|c,ζv+z#o-mn=6!WPaeE ơa]@m|e7T&N5,KӯĞ>q1q8Tڕoj<픮 eRZ4@m=BZJ#? %[.6lzz&23>)I|Nl^OA#"MJS p]YvS%c{:Xl~9|,ΰ*0SD3)n[xL5| YtT4 +ֺDa<|Fڧu]a/񆧶OR$?|upK봕hݴ,5NgvW!G{r vVu^a^ !8Ċη]+>F{kijZ6&<=_2&2PDžSjɔޟLٔ1¿^+Ɇ5 RzlJvFyy 3 ΄o\GשG؃ibEϷ}&j0̡ b};v?|PQm31!iyCAKwe G9%{ߥ5ҿ :k 9Bc>d8_)ag|JӦخV9иm;/I6+u)8&MO0٬ÀWCty=g3_G2Yd!)t{T룆]ta!)j>2o֊?0O_.>9_m^koYܩN\P,3Qw>˛~mTIFnޚ\ U})" =Z>Ʊn4WXm`Ž|* `~[>NP␶Md'g[Y8wü©Fsp_hݱSKZb9Xw P7͑S"LH7ڵb2ikvRJL4hj~lC5x'3kQ$YdEK#>Q Gޮ쁫2;fSn$Y&3`X29PHMڭ?WuJc[wD\IQ8{W-X籥j?eEVL{P΂.ۓ-}8,YI]}Wn[>6~ PY,7_V|0ے`%{Q j/Ts pC> pOQ$[V 6"N2˭}Xgs|E?+$/nV 9X AZ BA!`)/iUj=[aMSy>5'4{Taz@zo~냽w#QxiC:w-GzD|NZ15/O񿈠+*( 󂡂` F:` 9,$,",l. !" !/Ҏ]󗴟SiLT^{=!gLm]˭w_:W_e:hV7G{>QW@XyHJd[Yq#CD)ZTIpMŮw!,,pILnu\F9e秏=}W}])7k(Rڃe߱<}vp!xjQeZ0^ZdD#w ~Q="n\< )'AA8ey,v>y! 7Ǟ$^UeH̯Xr_}uLÛuPB'>\1g?Aca[`\&IszdUa 1Gn;)ªOe/K dHK.^ɉ# S[7(z9[U~M Tv55Gˉ77w'IZ<Z[?Jƻ4ܖY@bw&y؍nH~8+kKXa|Rgnf&xj:4oc?5s9l+Ļ ,b %yM溔BT ;&M^'x \v;TI,y5HPvz[IV<#KC Ș3sVfN6~"yJsF D#2WG I僜Sj2-.?W>[q#_u^B_YIr=j'[|q5 QMPvWI`aIO*yՈEYMO >V # %G Ǥp̻ZF5}%[KN/$ڃK Yzn[k14X>$W3/_pAO}~ufqO@ -OMC\s#))Ü/+4֤^"װTĄݻs<iї9FH w(.aؗ5͝䌄OFFO|I˯f'Y?c!L=_JK->G7bTWKX±OQ~[U&:~W{6&M`9}׹R3*72M%?k}c}{bˢYDP0/_\~QדEJ1UY87>䖣˴@+mzLBʭ#{dm.\ WyWG77IlwKc''pu FCn9MQx3n{JnT+UKZrX.d?q8֋e:>Oă˳&iݯkKn iW/ħ{ov6鰗= xlƁ;$S 4&!+Pw4v(S^~K|ed}0=6EYn-A![3;D:Bh?ym4xє{dde+Nlwpx4u'?6nRw~ cɛ xeYF"vWEUCK0׮,vg΃BVwceW=qů_]VW7>g;d(OEvWZv}gV9.?H&؅RW!#B8oBYǝhۢr o:8:{2 (x!.Rgc?o]YH|X ~"]}PN"ɇT(_%7pO$e(1cc'үǂ1vLN4(y;\°D9<~9S?L G)HYy×+e4X+eϤ}7BU>/48U޲・ZП/lKT7Fz <6_Uua{~M*ӷGMz|][wrImX]]Fpma~U#O9Jqmn⃮wK}bɹm e'>ZS{TH?ka@:D-  sas(P ``! & XP ѿ#w_~mByQ؇ G6avѬr аR Ԋے7u6vCܭoث_Hz h!Z֧U7p8|GWRћ&[>֯ǭ-ޕ+YBzfз6|hM`QeAN`Hڡ!!scz{jֿ%e`bA7 vX`y$[8HU9tst_ w3b!{iBws8 /k aY^wUW+}6kGT#3/ r{Yܛޥ ;t[!6!^*٫3ktoI֗f͵L#v &gc@6|'ۣɻCQ&MBob <~퓗X^Cם?Gܺuf_z=+W\7/9.<Sڤ]pyT_Ļ*e iiޱm OȌUҹ֝Ee5n_uV䩧8थ}4С}m@tG=Cv/?%B`9B"DBBP0j PRDXDf) !{*I]!NJE+cyW;,upG811h|ݯ5鞕P}7gH󝲼;]!'u)ǭ'[W~LJSOǫx};9VuDcn'S?JFU{c5ha Iɨbڨ'yu)kx OG>{nM|-( Oaڐb "D‚񧭧vz/LFS}*>-'2R^NHx֯bt1vN\T/U҃7-vu)yxZ'GȦq tR$+ngKG1b6l7u,t>:?HH-H5Ӆ\%c]6Z=ykx",~|%J:ᦖN; J]Mw9}!+lT'n9Lj2|]~;cQ}]Y1>o|.\[RL|7R b(屿 W@ GG~jhBN}yqicR,kWeR>H>!vUO[y5̨ -|'ҵlEdl9 qw@&_W?vY t)39Tq*BPX昨e,,ܮ.\XR;:ҩjX rJ Q7e;Vn45?|2d_yZj^fiN%v܀i{uن=ٯxxƃ}+upk"T3-> Xۄev]vn!Vu,֦-'^XPKrC <&(6[[ݺ@0EBo6c㑱ex\U7&B˻6$l[i '<1^G>>Xӧ+F?1ls4i+}Uo[3QHb:7ҖP\K4Ң?n ?t@ئWVYq9p6_h/+'} Rn$twG٩$ɵ2ݴ0b{~HAa]-F'"/Sz=[jSQgD˥63Ċs^^?^Կ@|QYĻEZN#lNC׮1 i>o-a;Wb&o;WڥvVk B/H 5Hq l1DW#RrhSmB2FDԊr6b\>q[$mBS9LJR͉?.ʳ.g%J' D {:\~e.8;uz_]P=MͦO%ioHhtu(C蒣8X؃4gήXq`z eQ( Ïs* ߠ8 ^"s࣫s".GpwrVsfc1gDHrU ?}u/G{枤7Xߥg&ۉim{M }~0gPq|Rջ* KKş;:Tʷ6>Z"98uv&440ttkT PakУlm>d` xIAd]r̗UIZu_66txw酎eGFSb V>cwiM\l=GZ+GR+%9c"$y[rRuۥO@'&{<*nbڊ nZMN`_{#ߟ*j'![y[0ݻѺkp1R/E=?}/ަU(d:(x8u}b?IT,xgx5ң3,Y?+3.DN%c#Q=BcT Z\7[ښV.Ikw׮}Y }k[$GI|]tknok`OdXt?sGH7x Ia\G[Z}<3<ŵs] rR>)}=^PJJ^ XG~!f I8/:HJ񻫔'/lG%?u."QLoj|J 6)YC{DJ=Vy[7nB`wRR|.V6gs 11pąg'0PKlxv^$EHoqj]\ ".iDSS9'>kqjŤ7q&(c%<۵cZ& 6e)^e3wO+DDZyݯtz˒3+y>b7VPךsF箚(0)Vrr&'y~޳NnOֺƒK vzN9)PՈr7g4bn 6<[=n^볼 Ъbaҵp霴]o%Z;%bB 7WK^--#3R &g.RVReqvn59Eͧ4l=,yCuI !;%o 7FL"kWBO8<=&nmő,EMZ>OΏdd!CvQ/65 IN>e&_mr<63k%?SXRڀ7MT]1ye"Mpсu{m'JT*#n︇; >\ \zUoRC OPJ%{9$GZ *R^j$vEg--ŸUN iծW#b1ҲgHwB'wj/Qxn"״xI]Cǐ0qbR}[}ESLJ3Tn5yc·}|WxUzwI(m7 3u/ ۈř4^vQ\2JRTfN8cHXLܝG.5.#5^-,;h #T"MR݅RڂAEPA}`/NA`e匢Ufۉ]5ŃMIL =#Ľ&puII脮BÈYk`+~L,6R=fLw\6cMTS\Zݛ.MFcWvs_ҽt¿J~!I7 T:wa}9+8 .\̖]ӱGh\'n1KqJ;rxFCj_/sv}:C3QjƧΊvsgI5wrk)cbA`;c)JWܓ)qMz&UbeղOLU /P輾c!ꩄ)H‚Y9qڟ*C\NL2Bo`\iU2R|L~qLRu_z~+*]nq'sI\_#HX@_.h鍉wmcM 늋) ME;Or!_r+.]:ǚh$%A]z.$"t #{=g}LFw җ^hgb T/Cц.<+)E\R$<[Wӟn ڊ=qiJfDzI96/wUej=(VVx2 ޝ\/%y LP*w膏f#.8QQʌ=/簷/SŴϦtS;C>LJT@QFevנf)+-%3s| ,Jz?)} qk=Hլ8{^y>sCfA^/ț廗].ra\y E:{.>֦yD.ݽCߘa܆Ŗuc[2buOlSV^M~%^>Q$ka$>MT7 !#*Yg"ypV@¢,lM% cc^&R<|fvv:bmr+o^ًDsNt}o]_B؂*!5@##QX}ϛKI"|U,*^Qb.?•yXCau2a7ϱ),{#4\ͷ=q__HR>Y~lt /7RoӶfD: ~!VD!>y$SJ^|rO~o'J{[^oXnrMK1w ܰ1{l<|rmk#hSv9[*y 9ZMIdLM$$ D{O,ZzKIn^ |M>ܘ{r"«pjbFWm>pOUo[n_WԧLBRG(=،tsr*Gs~)YEZ,zq7^!{ B)ݤ?S^5Yd>\ s}k"_F2>/3z.Et{!A O9RSy~%t+oyBj{,97\Jf'3;ӵ Ԝ}k$O.^:7-N)qr-)ڠo]LZ 5ʢi{;M*wA"VxDC_ۛبIi ,vŝ;0{0Edi:3<<)( ?'?,6D mlbF謂wZ(d/,)߮!V7P0XYٯ^)z^cenSmqxcaS s0ܮw1un[^72zDuQj]O)aB5i[Or2X}oح]@l R2&;P!_+d[Zrxm e6Um WiDS?^p!eRt=m:ͣ lk̭5sWI.n (uW,^ #-G_uQ1(\Ff4DoTW;ѝGKEH7]$Z_Ywasx%謵06qrkiʂ'`~M”}J:ʼ7K-_JT>:޼I#SRi+s}qhW̖c^ܵ)6FTxKii8p~ 㐬7ST;!t ޔoFx}?,,]6/@da)b  YZB` As!(@@H\B -_c(ToxZ_lL.aH{+L }hX[!0F6gTt L8u]/Q=sϋ" 3PN5ck_f}kkZ).j)ɨ2/1^Jbva`4~J#:_ɜW ,beq anB ̆Ia\<Ô }^bN'{N\?84_2m`\lT9{%p iۄl`@-кjoqˀIv2FٺI؅ImoB;V="l"(xM:5$Rqa+,DU3m")pw /mmhQK?J?+QOFoZX BZX -""B ?S+\6vDŽ#H K\GMŘ7e9۵hO7xmn+Dx<- rwU&']m͐]0#Xʦt\̣aagRsϹՔITWr'ԷAh]s{ps{i$!y; +7A2&x&IJ٣?{dGSA$;%6)#Cy <]+Zq~^^$P{"Fs?v>MO?_Z6҄y׹J[UoL݇}ۈKz|طXn!EQ8t;>Cqr6 : ,Q׫?-n~g?\kM3{t^{YC%"DTΑINL{>>l9"9 x'v5IgAGT/{ Nm|(5stxح{kK@s[;ܲL^R/Gƕȸ{#4} IFCsW{Kp";n]S/R}{%.ƹ_tYv5s|Yṕ஽MμG'/s1 b ?}=h?Sɍ.:A!p*6td_y Zr$j"v^%ĜQ"b )%sǴ 2N`8nKq r>]1`ٷe[w< [ /'임6KShg xw:Y<܁EyoM1k:_BU@Rc%rLIWS/ ݣoէ2lŶo|7J6S-?'GW5G鰈|/OMh We0 g!q˝ui^*z=uUZޣUFFR[ջlzs$vgS+f`uy{|,&ا@2}v ҬzD9$ /;:B6ݽQt>k|d=KzKWROsT[ "ܛ. }(1\ʺσ݆}Di.pR9àAkzʓrs<,b6&uFb LwIαw{U;m0oΊҺn!QJmw*.gO@T@ Z!`% ZD #/ D-E@0s@0XMw_dtGUyY(H:߿]m-E3<|w}yNoَ\zWx6s̹}TpFZתdJm.!y|Raq>"+^[kLKϟ(Ve^{&v_ 3bsq{=@>ɧ#KWԦ;pGc櫊֌eR%.ф偧VJ}L"pQ=[@>?Wu#sގf#9C>7"\~l)k򽽂ߜlذ}K+ϱho<-!$ TdvK^fRUhDv ̺ ϮQfկ^63w4ugV0á4#< Yq!n:|PvzAXAʖn bNo;(E.A@ ]Ѕ ƍ=Xue2B>OI^JYjo|=f0{l΁F%w5Wz!NFRӼ;D{!\qCC"twiDqs7u;f Նz^r\QEY6P~D^#aժ6f Ewez7\QJAxucR ش`m3GZ;~ E&gvP{R[SfǤԍ{Q{xQϢFV\t\U ,Q}VLCiFï]r[V_PG>qxoJR{͎U +wH6d ש8|곛&t5c{Sa4z#Dwip7*$v~N{rf~y YTr'?5p):ߋ+ҽeEa>0=8o%bW-j{aj?lL}U=u'Y/K֎{0ޝҦ$47n~rMJ(y8el+贷*Yq,3dɇ^kqܿ_4֐' ]B_:JCCQqEll8-)@k4o׹c+1/Bɕ ̶k\Syk\A:WR6:[CTv2V_^984yiPQH\us2VcPQu e9Zk߆ʊ]i4z3-\⏶W+݅{i3]:2CN)#(.ifT} GN_ 5Wg~Hfq 6D?AzY;2(!j{<%J7G ҥ )Ny~ʔhX8u-(4HrZ7\rqV}$ԦkKOwxyXE}Pt71:2L箐~{?Pѻ"y: _wYR`ӝH$ j_}h4`aeUx>Ztc';W]\+{N˦lV3oUG;̽J@jX>> b]l: %"aLUj}:`WF+ OZ ,I. )5ͪ2G7"DZ!~q"xʕ6ޠ^4~tsܦ{L! *1vL8{ 钍jw1 Ny QLqMdJw2O~1FdXL9J7VXpeX*>HDe_prtY*7%W,O#r&L-z{V^݃ |Og﯆sG7s`^_`Yy,yĺV@.-<\O$WGloY`؋u{K]}\Y,?~98U\v!u.$ʼކ_ٞރ;꟨+./2#8WS&̾u~kj4\R6×{SM;[)cH Yˀn]L8Q6T}qi_RSk[Gcg8\tkgƒB$|t^7g0{Gv/[] Ψc)QƳՂ+A)aZW5`^\tVFHjh^5]Oqd}2JY<7#K/e/;7v76Uҫ\S妧ڲ!8))J\p9ү@aT78eWV@KGd\-QSzb6xv;*^5w37ߥ!t ĸ$tUPSt^Xd{A =,%[)GgGY]\7[SGJ-4lq~E\]51Q]&]V+8L 1s帗V6Ԕ ަpMdU5>X$d$0y{/5]֜}A/F{ 8nu&,"8mp8%Y =Q%aF꓾b+yҍ;[ԒkFJQnrnb=| f_|V((yg-IM|NIʵ{^d>#^W§PH*3 ]6 Ȣ~14}A؂ SНr ם]#+n6'fQrU{E4}NʄM_xpY%|ShG2CN<09#ܒ@ꖞ1ڦ~ѪY^q}"unzcޤ_d~1Lrf0'U\YS%?]0ptm9E彅\6CU[#/%|#0}X͊{RͻGktcܧW/٨[; hGmMێz2۽R2/נ+HLFB)1`\vWͣ דy՟'ffg [pf%揈Goz@oɱ_YK;N#o@ ] vG }&`gqT/)Ӥ$>ǻ3{T̬8*Zu/ &eP?yǻ-@IA*!l/cj T61N)eviiGywK>n a35-|)?IwYUA=C(ou6G'R!]׍}cC Lew\5ƫ_?HmpB8؅ U`u*-pCN+fIf.:vůfdG:Pd_FZ'5^9XU+y['0!f۾6CFgUxuSݮMM寽7$^0봞0X8_C2]3~C9B]蛫5ޛ>+]' ψ j'枒{U60Sr8Ϫ}?x'~ P|\7(F&u} rkֱkCznU(-o[NwK0d} [@88h[[a@,B`]L]RfF.:I55{YȜOē[ˌLx;I dW p @0 ADͅ '_AEOڦ~=%I3 + qCB%, Z<`#~t/ɴw47Nf,"Z4x۷{rHyM8cdf0N.\5)X LN<\'J=\DsV;tgcD6qgHHm44>{^Wܗ} '[ ?};jl:|%#_H?j 8:}LSqU؟X&U:.ד1A6.q'K6͞\)%HS@$H(|C @I|L"]Fx KYn3)6, 9S :+ a AQa!9(,@?BQ,!]^*@h`u]JT>h05a'9ڭ 6UoՋʆd„zSֽMffY".Yd>΁UJ[BTUAދ#ɜh\sNRm_BO-m XRZ^gzeٝ|;iҬtQH Ӿ59Uw./M/$\wa/KoeP^\й/g[^&M utAON$"^ݑr Vvm jOrE (N,!T3`2D#XhH>2åd/N 8aӾvޝ@}6A}JAJLz*J3lóHy.] vAS,+C*&O9|) Ïwf$*< ;Dx9r'.xКʶ5:/IUH:o>q,NaQh:ϗҶޕfQ6 rod{v`j%O-rDV|D=H=>uh~޹ǖy+5JhIQDq?VQYB俀 C9Y A@Q @@(0ͅ--~Oyo/i?M.9>z!JK4-~t\k٥foxS&>ol;=Yv^3$pi:`eȹ1&9c>]dS<`(=yNiLgcʸNsoaJ‘ }H!]K .Ol3;VAjFjf 5\Rݗ7ʩ#;jȺ2/OKrV/tt75Іr^4 :LvtCAnQc}$K`u<fbh&;.?vYR*|`- -\Ʀu~aڻB!ig! FM_Sx>V橒칬N{MTxned?'An@pXD ۃ0fiߞ \N@b|vwK+jʐ&H`eYd>qoQK-bzKAyq S,Ak}i}'ϋ|KC3r (_1;^Po?V=|ѸjGšUsݗ 6@BօJ.ϰy`OzOsGzWVJ'2J/ 'rŤqwR;>+V1HN^г0.Z7Ou\4>w,OY %__<}aQ蹝n6#41FC8azEvk7c?> ;rC=y ?jq7:[ {## ymJ|)ֿ.0K_(!//"|NFjs!7q}O!4F-ma.0+B ׄ*C"W j"uBߧxz;;?}}2^#ߎ~N{TGɜY)9iP2ꚨq;;)gm``{38ꯎ/G tAtOWt Ol ) ' !o(-Prk#y5Hy7wq? BhHGhwpBua8Bm]a.H@=@\a,ޞڂK U_^s8~nn p=jgE]ur#wfWy 9hw 5Ol-h~y%~u'7 _ωdawDp\EB>̅ #xR^P%yfqC]a^6V֮aprT!!(.].[Nt6j^1/Wk##baC!dB'acaA ~l{sh?=AMuG9Bq "/kDA;(7yhic悞okaS<wsur;jeѧQUדUCuh A"E8!%K4ŚCѷ;A, VFx!\a5CxQðqDJ{PyxO0W7,{z# )(d0j0$=xá^ȧoAmWQtqsqJ;Cϔ$g"qs" -C PHwuAO~6eY}i"쎰rDR(Ivvh,Htك<ngCsX@\qIgͽ]6 ŏ>udtˆ֏OuOB. ~z^x 6WqyOϘ#M1 rbh8! /lw9Q,;o#9+leBey=t(_C7DS60Gi_w7рA9G٨ppwqBZꮨnXX3bwD!$,wD݋Z"W14__p3z^N0FTtH1B>:a]qIiN.pwdatCAT>{k#!.gg;Z!iIQSWMFU<򋔹 * wXIR ((DCet@@A(h?8fw:X!>'8ґ@PyCTE@ .0 sٷ= _(˨ohr6x2z@`.?9%F 2<R3p7 6p C+u$o.;H/,8!iQfg2Φ˝~ v S;txN0\-8$kT6HHm+B79UvC09"!y"Wu/uDh|"g(otpG!EA"hG<4ʑ (, ˨$DGT``D8wFAm@vhd$TW$5#B3ₔF6(ʳAJJBq)@mBؠ@f;@@ (p&~[L@R0B]!aŃBWY "x7GFKRnϟtS/ 6!o@mVrCQ&˙/9"tHKR=r.#rc *JL98@Paod'9R DT]Q!=IsVy82:"-h,FJ$3E rw(6J{1CъKCGA @!H4Th@(Y@ȹ#MAX(" b»!9䄹ߺDZ.xQ5Xi"ũ9sBd@>FRBA8X!sRoSfƟ/N eVcHnFBAi#6A^93/Vf0{=c@hPUN~#A;! Zu,hG2z] RθYlQ4SY7LT`RCڰBK䁒H j~&ċ .p3=n)39&dp(/r!QF9*؎Jh@ovRi0@ .eX̯v!MuMiFT <√-RݹM_2d} O9 ~~,h%Ni֤_  "urHNFTfG> Ry̧ό#rPR-h'IthA5 R6TH2@jIX0sS9SVNH7+9/$QÄFR%4FRY"GZ~Fqnn NTG(O  W<@HW r5}99(,lNEl2/=P6C i%~7K˟GrAE;<:hTT񻵋rf6 }J# qd*D$*̈.MBG6x5PEH 17Br \Q! mxfe@g;؈0BCō[! Xoa?xY< ?9/J0Z#*B*1_#Y<-A֔:tZ2?NU)S|:{Q-{rj P+rĹ jteNjG@~C~e: AY@ 1994ѪGL{FrU6)A>P6 =Ya#a"?IEy*FPˆ$_Hk!{\xdz< 4ѣ8C?aH"E]E\Gz`G)Й+"e.a۸Ӄ hmB@`m#!lл|P&)g۸"`{> 0i*: K$ĩO`AOg=271~:E4#[OP"yH{p?d/AhڱusC&F'I^h-6v:lt] ?bޓcВ̤Hc lL>t(`KcR6$ꎩRIOOOד(+g[Ђ8="l·p[Ț)wwn9QPGVE8eW|DsaОVaf+oފ'cG *)J;z`kJL]լAk7(J<gV1_.;'o[Ò]mW ݝ=`;Uwj9.6?zZ=j,=3?WqEVI:+f-dM9巙}ʂY-W̛w∢c p6uBL%i= [BaͶB8,}Vr-^nWq`MSw7`/wSD 3&̰_ʗvvpw-rɱ.v9tP,)+\RsawD7)/6&ik9>"k=Qǧ1245 )XpgR- >+B(b?a Ů슕+N+Kaqwc+xqmʫܬO,E:?@J5ѹ|ɊKx~ל^}.Y.m y@]([07N6!}F JjN[kgXa~.vPؾw+r+J2Wڬpjm;7 f}"x7+a]haY)JBQx怌┠{xVSǾ%c:_' qk)O͈*sZP5YfaS? KSN(^ J4lkw /Vbn?Kxh벸@DfkNYwf7ߵAϦ2rf?GxpsP1$\3(LCϛB-!> %ۅGx ʒM$Ό|koDӬ WR7# Ż]sTkfbASg~}B۽r9Jn"v/Yh7nVKӮ@U!HLjjFz` *OԿBIB؊m MSp:nm(ڥWYR z,x BE 9;OT^z&!BbxzFMUͰbo : 8(JX)RF:dg9\/p ;OhX P6ޢӽeB;$U` *aȁ3U|<3o*g d_$%̿]֙|S,\"jrX8m%@~4_hX_0^OF3;H6<& 4O4TxV陼Ciè q/7;Q\ʷǙrTX"&$14MhW+JRLX&Q_b^[%_U& i -њCՙ!25׸JN߯Q&\IH$ 5w4K_xRf/}yqbE #?_U51PSܘ^R1;ZjHd(B%"3@)l,Րb/gb/)V5 aƹE5 >/bڸ.=G[Řw_М'$)y86+ׂ\=F6ذ?6,bRfog{y"nٳiQ(gPHn#@eN[ޢZ$8|oHzLIA>-:QК<)x;IffBdNzέ4!1su~#w2WNQm6{AVeKPClfZ }\(әh:M' 5flwIDª?(y Mo!B160v` ).LsF̔צ Z}*($zMLpMpA_:r"\ @QrpTCMӔ)9"ɇoY@9`جQ"θqѺZ+Mi{l!B,5H% 4d1^q(!> N2*u )ρxVg3k c+ rI fMtNQ-zVmx#'ﳇ04R cݐGDc^p|/`DRV%Oq,@VB^{τ| @:ʟ$:J >:Yᯟ,|aA<-u? afᗺvǷ0z-SM=SKap 4aW,٬2 L='PB`)|I^mZ2٤_s#/T*q, kU3F* hnM#D.'tŃ3I9k ]?KOqwO7oo$?0$C\Q3Jj;ZŃHQN%'0% ЇײP6-9AJY@azMaJ$ oFbi r4E891܄OM"02}/j9bb ьrQ]s8'qB~=-RK->L2&( B&(@w@$a$ڰVÂQ_ =bX 4U"r|r@ܒM_,$ZҢ|2f3fuM&RqG(=#/Y ?v)L ,c f{ ;,.GĻIO2(pɿP~Hhyפw9BzDY'Dl*b:> 5 Sr|ka2óN˜rBxƠ8nZw,xo}:`~|^ >jKJ)=JQV7lyӄ)[|p/DCNW@' u6,!v;.Re$I #rl<r/nBC]FÚXS9G5 }¤-t/;"5hݷ˜1oCe/x50ЛFgg&̛g ɏ2֫UV$$A[`DOzd:)n΂Ƴ$\{=A  Y@i/.u iMUMԹ?b1\TD΃طy?3?Є4.PNa!YoAXxh:'I(DL2rvg{d=p'hC;b} O7Wl >Ǎc>F9l (3fM W51xa!JXI2[$vt4RGe< tБZ Vc$FE-hr)yl6?V<֘|X)+^"ċ' !׏j0.YL GI˜Yhzs? f} I׬9^U`)%E4BCzK+4@AI鳯o&zHX7o6il6LbՈRG3xqi5̭?c")s>zぉFӠJ\rJA\gR<UCDZ7'&{Td2E["6K;bƹp{0+ fC$]loeK#8yus E`< i~ʷ9xy :&1Ի wmIoSLʒtHHrgXNGqN7UG2H"V r=/{ub%ykf!m'բGħ"XfDFmzC>2bb]T 3‹dH6MI_"W5h-3U2\ $@gyqW!b|^ꥢ?)shUrJʕꥪ:-ŢV=8ǃ٫A☖h&InEfyPJtY(0ɫP \wARI~?;/o%/:Z?j^ud`@$X_DUG1Zr/F(xz'1Zf2 Ghvv&fp1֌H9"MȭV!p&?J1OT?A1ݮ;׷FXHs<8Tǃx}%L)Vɹ i­useMtWr NG[گ>}m#0ŭ5ݷQ)! j9P:ʡIK-`m[ډw8|6"FB?UٔK*!HM0+=)aQ_|+&=h"Ph% 1^( )޼~:GYr/zaSl:w-ʁer_kL$ avS BJKl=veE޾ԑYNzYe7RXmOU%>h(>pd"Lxs*fEi|})A/T4pdjK(5*ͼIWF3>ǝdƆKo5! \Oe:m~3v Lp ojl$Qy̗ =x] _x1zaXih-Vr~Q,%Fb$`TI4";L$\J~E9F! &0/5kKZ9-ajStgk(L}kBzB~N~`aB zϝW(bDǤ N\WIave eg.c>'ezFGH}Qp7 P[w.{aTIZm= $}pF0V"Obmk2b1Xb5~ȥW-$k:N=Y;˫E'Gƚld姚mbEQI(aAD2w^'C+:&ʴ+ 9k"8hQ/FAakJVL)O.W!TFh#kQkwam>{ۼ?w_=9B!y޺lEiz]tdkeIZWG4{âXK??Gh6DgC !ϐ XWj=*8L߈Z(b9gI'"n@Ry+hnE$l2FyY9K3=UUWʩbKs>3Kh6g| hdNLsWAKmFH.:_oާ_zdj eb{p=OߒdpkBj0*L1LH.g(ub?]$Dī[½8eA_C|67R} 1'_ET@\er]D NH;C߭;{\8=Ms5늄&' +=?O3~7?/S7~,=M@J{Rd㲋ݻq&]ae,nY.lͲ!.A-+(>Ojj^;^"Ig@(o }OY}M31kwN&o<ó+59ߍ~cFho?t ɸ͜سHXa~8HFK< ?N)l`x4:o@Wfp}m.u'mVQg]<[-bmP}8I9Б).3+\ub=hDڤw>,O;:+~j^ğ}EXǟ nӁâ7?MD"37P-("pC˰T `Wl?Ƥ>g1֠PQ{ދjΓ<"`c冥>gmIϕg^U_0fxz߂[FZY pخsi̋lHO4@quV5qq%pX:.Y]ir'ur@EBZH5ŕ9$хR_˅,kkIZbDŽ6 E¹?-a_/V+>&^.b.FKVj(Xɚ~cS9)ƴr.B-_E>7{.6R#1bWa'/C5aK'P^Dk6֊[}s9K؄-nܚ-#FTdrպj ?ָ[X`CW{&ܖu9Q8Q6jA0tRv.HxaJX9҅puܫm>c R+CIr;>?%3 i_%CKh*DD8t@`P]Nq u5MM 2 tRxlCH@ŦfzXv)1Bw'g % tW~Χ1B}m& %ZKӕjJEU4W8abvoT,W BC$|QOؑ}('vϜQ 6]ļ5 -b|=.OS억T !$nߌI/^2e&Yb%W͞j^]g܌(#`_,}ڡNRjNRWSRN75r: Xwe6͚75rlB^i#l`:9W"^{?matɍC:K0Kvㄋr|~A'T'DsF]\tK$zk _<(oӁln٭kLjq}~AԔ}tHkR!=#u½pk6{zʸxyyp2\mkkd]њFk7GSFFebT/o6nlF.yǣd1Y+k25H7O$|5'S;I,= |Z[ϲ2م-*1pqO+K09RSn?'<މL @Γh f(Aː;olXL&n!39Qc z:(y%lMލ")k4f݊ k|-W``,()E'}RHPA ,бZpb J{ʘP}ȼ]Uo48zӈ?dgdŐmt;*הyלZ}ds]{{\-osU+{4 w !Pb$+/71!I&?Rn˚dd;ILn/n+ߟiNp}ޒ>ũ7u{imfթjp`s(Շ>=?:,f3mFlvt[F!)D,/clpn1-8oC;Tq׹Ž}גuFny؍|+sUU ˭_݆]BqQbWƹF uxkZ-a; l#ImQ{٪K <;I-Z2&pM|:v P q}ĺl)b䲗{QVpi.X_Rh LJ+MJ{sYNoQ@saй!^͇=gqe/fح^s~'2WhkMuC%3V. bYZaN5x>{[flZOΰϫ'M]+ؓOlx %\ZY蚛9ڐm]hw֕a4Ș.E ނVr>̐}N9 Ф׏2c ]XӜ槭msWkPq]}ޗ8P 6b3Խ;2T#-bITӵsǦFq{+TTk@,oo@̐kWV8<<[c͔^,yi=IБ=5K4y?N߫O:곝}mM3ehRG= ԭƙ=78PmOqZryn|I>r{2X&S7z1#K3n{g=܉)WOH|Ͼ;F dDf^ǃa*2A҉rgaȥZs>|”`JoJi^3BhKc}A?^![T۹$:udݙaARmQS[܈ a퍐LC{+j<ǝ!N4n#,!2O2Jێ]#8qұ&_x?aonZ feՍ+?f:s<ˉmNQc忯Ѝ@k&K'f٩9+9,ap+(,ۙf]zf{et`w9A\`6`\r9ZU OlV }6i3~7'Ł}飻_.]w?X%cn}یh.ßSω pwZ޲qKLpclg o\. }LP, ƬI\Z8ip$G8@0Q5-h4#-qAʻG]{nA)|4c/$`244>ğSczL=e5q[2*Jy!eh%1ĞcU&"KRvԦ2{|#.W  9xvs=>np7[B,y w;3$_ctv}+w>~|]g/{}^Dw\]t]׳|'Os;Ga ey[>06f[؄H:yo iKNRc,!kl|=d??|_kV^^`{M:w?st=_"#1bS>:ױNS@%C2Iv]{}glqH֋#MR #NQL_cLo#zQ%EP |I<% I*S믱vg;wC_ݗtȈ?oWߜaEa`-&&uO% 眫ԯ>v ?G;[/;o?]ɮ"&BT.> bH, vaniuhDF.h!3"Bp!#kC},o}GiK⸠!J :FIԴzSO{/_"#1|Z}5cky6Zma:)v;!^|MXS)8Ԏ0Zs0}u$m믨{lWYhFu_"#.U%f}.cKk<}5W߾D6.P".f}:A*\ \:;!w[DFOu_1B % ƐVmozZ}z%2"O*S$>$ AIxXu#M忲Yh^Q쇻KdhNQ\r,Υ( A>aw߹DF[*:rςVIgk])Ӯs3n+J1g))Jl=z<_yhFw= _"#Ro1y +EVY\]Q433O-Tr1N$yD"Ye& ho=}oQh2*aXkyYhn+__"/*K.M PY6ٛ,oQw{OYh]m}/I@I"ޠl2mPLl4Y-g?3x%2 z !g%aPRHFw׏,N!mR)_5*{僫 &;kCBv!%2"#&sr::lXe/6zyhA#;|/mQi.HJ9=P:%("Nw,oZ ?/VB2E,HI.۰ڥ Cvaї˩p4'vGqƢV+=h^FX{DFY57  D˙(ÆWS84CǜG`Ὂs@TXuɺht"t:N_۞ׯk]qm~DFCT8 Y^stEsl3j ;=m7 KDFhW~h0:6N1IU+pԑ?sGKdD\D':xvRr6DgbbmI?yh5셋KdUMwQ(PȘ,GQ~,o!П,?NYa~J EGNzYh!5C%2?c]MΣΒw&$D0L꿲}U0%1[S\1L3Dhgu߶6wl:ԇX'H @0ڪ2,oo!KdLZޙc E{Yκ Tvi5vR{yh]ߨCE%2X'@ uPiИS=Av!컢DFL) gE;;_?m?l㏿Bu~Py3Z9d|-wuȈ]bPRG, !L@g׽%2b϶@] ?I%im:lqvd'M{yqk֞Ϭ:iuv\|?6)!NÕ|=XYaͱx}?co13V GR)vAܲNߣw5ϼ̘EEdSA"p/f8?Joc-fFHyQGBSM#VXt4V;eX'm9~&3c gIu!% )$ St-eWIwO߉Oty1CH``B)vÕ>Zv:DzIOM` (lt[NZ?WIwOc?yEbf?(!a 616ۑӲC6m5qn̿@N2{!(9ƔUʌJc .voo;_ybfo1%a?IN =@A"|eaN~A-fU~ و*. D{hl e՟wHs;t[\N}䊗wy춇ӿ8+Ch礊vXW }~_%miwk ̿aػScr(HQ:6mg?:3O`? * @HD.l"X&gv[?3cD} J5jwf$YHM;\ŧ|?KѾhfeQPSfht 8 %%GZOvg4WmL<>zw? Vrl+iNbjP\jYB?GS׿⽝-fF^\|BA;8L%h 6m4/HXk m*jĤ.r}x8׵3_C?J?sy3c_eiJzRPVXd3ݟq_%m9G;-`RHRr:&TlIO\b'hkg8xQ lugokN~:[̌QG*.^*i ?o6w/_P7ڕ Zۘ8c#S]_ Cw~L?snOدVk?=z9ۤup],}c 8k)p_'M_o23CV.*,>Z9k*RL9X |$g¿w]%-w+do2sl%-8ɉ_ՅrbcAI{_~i1#2> }s@\.`\>u俭tWv75.7p q!T}t_%M+G?d_ch?A3j+]ie:i`_=y̿&qH$HPl@PHi* CHvǴ4oj䊛o23e[N#PA&8 Y&mOM_5_o2s Y)utT8c9#ǐJaCWI?j&3O KZ[Eh*ދOPvw*iO>~6w7wёuT/ Tb {&3T˻Xd%J 9rp]ü^WIfwߏwuMfZ'gJa6|뚀 2CaݟFZO=yw79[g+2X gVľdL.~o4o'/^CMfODkD y.v0#1U9Ge/̿$@y}%jPے&M?w\Ov7`kwBe6)goEv_5}4oMGgx/gQ!yρ娌Z&M?sdf3!+ ( sX/ _%M'?q#&3W2K D)j2$hbao iljw o:̜b[6(:F6e^WIwsXo23;֖_$`0ٻD򨱸eWI{&s0&K.DJ0HLXt6ׯU߶ߎX+U`њIy~ˣ5)ݟqJwv7&=4)t%8&lɶ J{ߏ?&3gDBAkQGXS!Z~:iKv72K"L TX.Q$?hzS}}[%Mv~O?df1V=kLH\0"1<"$йY~4ozq &3Ϣ0h]e)PVl>k4okqw7!D)R*1CJ#YQ4o{~Ojd2,&J rDm\yVS ?0X_{E#Xr{!V]NE{_%Mww_o23/6}PBR}8h@˞}:imOOku7@@g V{7 QQ$@(.fх>}4oz؍MfRɡ0l x2_}Jiil9J}1R\LHV9J.'damN{n{/v7I%VK!=gȥ\3SmsSG7:̌70.7v"F)BRZ+k?o23%g"Z @h3/ԷH@*U'|XfUblJBjXoPRLSM J>T+T_"'&(QJQ(&jmϏ{l0ߐ{~֞kteʡlF&}RSn}wt?Qx)oCR쀫s)ZUxǣ%=Mkf D.&gm j$n[ ߻cfb4YK>:ȌNp&)ȶlO?Y?fwhȬUZ5NZ*>PJ٘ۋnK=wCbsiM(Tj J1*l$vg{.}Jo2+?F~d]^|`\TDXJBotW: ̓Cf \1E U0c"]ANȶ"%]\f2+\O 95̑Ctq^>O lڄ@|ui?LmN{mw>2kBVh#p1*)fhd8%]O+߯2+vuMk.|pNx9z^Yc E1Qgϙ~ƥ]{m?CfEO6y_`Ic*Έ 6Us8.p=?dVXX؋OU:.p=+OpO0:[+h6ۛ?{R)owIKGf?w 5\q5Jx4Rott<>YÿJ"hskrttc5*~e.#?_uȬ8Y}F$/B)ۢ o\[??dVos uz’]v:%=?-+YjĔLZ1[F@lwI~>w &W'H"a*RޓL?h!b̡x[U[7}o.hwqBL!䧻$97=.}/G1?fV|T\r`r"@-Ņsh7Kw菏5%el Snrfb&mٖkh|K?Z87D j5ųF \F~(_mt?1_?8y2+ڊ?P ^jkZۯ, 8%]ed7_;̊sQ'QCL9ߘ'Xoo!hWCqeKz?үg\?/!'*ٷ_#VlIfo}_a]7zfH1X䭋^'ElS`%}Y'bVQ) R O?4 U[ gt?Q>Oo2+UܴC &BpG[s`ՍqKzwY%Go+jUS4has*Mtw;Y$֒!S!,T3.3 |u7jV+s$+Woh3И.}g>?d._%JUl(%c8،]v[55ߓj)3OZ 2gN3.?Igz7?dV|WE,U"NE@Ѵ6i.YgOmȬ|C$R-PkN,[*e?7 |+!0Yb1jC&لbSCՐX.-%=O3K|7xq̬_)FGl'd%rt?Q=w Zh45)yj}M8.b_{?̊ vD1b>Bg%O?2?.;k JK1IvZ F& Xef|Kk?M8?dVﭷ੔RYLZpwIwSggzCfZ$dékH)#0I'K|߃3_Qۻ7j9kSl$;--2.}O_=?dV[ZE&FxRR3:q߸gte?vY+{s9fRN`9t' /_2+!A*z\m DݶctoT_7<:?dּ ŗ^I6i҃͘.'[O ?)185\;@3x `wIAgO훮5j̀:f~֟,g\t@g>?̚C.:+ŦX٘ F\dߗ _2+ʮXrC(!RrVM{VtW:_?1?d.-,u\|*1B.TJ-Fd>zߟjȬt*L>@K%LS+*Cf `Jv)j!KʶcNߟCcfOCs~u|" #4bGK:y8~ٴeN 8?רE F?RtD&޻j -US*o>޼ Ʌe?y|^_:]K YXT3$9+%MǙo0e.οMY g<1awTYwHwM]f1ap3W5RKNXHU`z'HvYRqɞ > ֭$=mùk'>pY@Ś찒AJja(V>kM§k\ mɅp -6pYmȅ wޅ5H6ZS]?t8~ ]fI?a}9\F6)G`l?PI??v7̂}ƜKR#C<&>!T8bMw7*˿G]6.sq]%kXsMgז}@̺xM4k]fm#ےCE_c7Mѵ?z}2 bt\RISR kHt?R?O?'[&W_m X@%V[} Su3Nmu/2xgu(ƥGA3d,xa&]xcwUB%)hNM*&I*HlEFot4yRYp_ FJ)oؾ0C4>õI*?M뿙0w,p ZL.GUm98og/Lߓ'̂_Cz {` :,FdS!(3s&oS]f_UxTR9 Am;5ĜX`E?3a~k2 Cϫw^ЪxӶ>W&zOߣ̂qdY xfXɯI?3ao?u lM%G@jEgMS]wYSZleS;YWC.і8&]3`#.sq=Dsa bFꍃB}N?;{Ib:<}3<ӧ.ͯ|+?ywǭ>i.?d]1s wxϖDCf++mt?=LWyeC8kV}V9%K|'--[Lq>/ 9J0 \p_IBBPLlOOw%Cm!y9GZlϖ84RUۤ#2?~m,8sĥ ц؇`ƛ{m̂hEY Z|UsVQpHwEw?/W?~~, $`}H1VWA*G!dMw?+wj,\\&KQs SiK?$ߌ?#2_wj}AR&0 t?o.?_]?;ec*(Y&C()e[2m.Sc.7%hJU<(u#w]fqh5٨=ٶI=?$1kt?RN?2 #U}& ޲Sq$Ɣy Ǿwf^qM:eK,9f'ZDfƉ gtg:2e8I!#rK5dCyШ'?ҏ wd#`,AgS[]f6pws>jvG[%Wļf$]_7_?e. A(jfuPHU-d HjYqgtt.`X V&ơh]m?8d1'YèO7=]fA(j|t.ŻTb,Edgֽot2i_?.ZdY8N#CFrd_/s7~ag?5C￤( 5'aώ'< //sT wRrrhৠKokH7w? 889W 5IV U?Lg.fUNSD^ - 8Mz'sL={Egr)T$k\E+f[TC &d{i,?r2T$3!bpYy&d=:eEQΔKJ0Ч jRt$Gmأ.o.gq/ <=M;b,95GTG\xN1%?vI?߼{%^{  $LjTӘ7I5q*mog?tK/{^)鳧y᧞>u'o~e?wS7Y0KHYAfL%E_jH_.B.jm4)@ ǟqu6I?;0?3eD0bL U *#5`ZOMO^~Y5r™3G)۾JrVTǟqqMY0 Cu!8? p{gQZUhT4A/sΜm "D $24!RPD -^ВQ4-!`#jb61mh[W^{swv}gϜ.ku6u'2 R+%cNPb *W#u4&]s?|f,8W]D\@R15ж%mmup'7OO >o?.GHqQM&絽 (d&fM?zTo}۵ w%]-0GYBO>+B+Iskw`g&uU&) L]w?IzGs}w wl[W5Ģ>; GE^h^sf,$s1V"\%1`0dAg?2__=Q5ؖ[2zIGsg,8}E16ȩe߾o$"u?7IGszg,#zq|VC IER V>'c6h8e.?Klkٵu&թS+=]f6s ))GAm1@ثt'ۤ׬=S5O.졖ʀT)VV;O1g<ߨof3}o}r,_J 6}^P_&3$]ÿNߋ52eGT9|}&Ne胔"+4ǿ?3U'ߟ1e.ο1*昋3rxD 8R/m|/M:o}fCA*Yg(Sp5 mmBYwI?3U'ޫr&bjar km(9eo.}_{ŭ.LX_j5IҺ?qtfNK/0e&pj[}Ȅ0(0W,מ1o.}թO} wGHE5(C,VJ+Mwon,Ln?0 h)&s=0$]٩_xY0_`%> h.t8t8 J"n7w٩?/wwږmh;"ȥU}佗TA,goN;uY0C a )g68gRF VW֞=ǿ|ë^8eOE@P.m/٥Ru"$]k'o#/2 i/ xR`#[6Igx{K]  @FDn`chhIw?sN߷]2 9zb,G@l\}{)dWwt]')o}g2 UeN$ {DQQw?sN:esM: --4bsA+֮cI7?tǝl~M:i(Jvlh~ۖl[gt?Q7IG9=|sO7.PRa.nj$6輆ܶj(TgM0/N we*hD(uV!Vu&={oy,L ,m|Y!rR`1c6w}}yx,j,>o `88S&?$6IwS'oy]f( @|m/0 TG$]_w*KQc$Φ*R{ߎۤ }at\u,p"d`)6Gh$]_ۯ{ט,S)he@S)XcII~yYpi2q`hԗ_8kҔg?I~_?2 6YPmJ@5zC4.8?mSmrYpFf"&i-# B#5?-wM?.`/xIJiڸLq0"=w]tiYYCt9e[#s{1T˿8I??2YPC`]&E:\jn֌;ө.\ 7rT0_rYi8ȃMoYp@%qX\jP&t{2 SCbPvg @M݃][98Z?Sa,T3 n?0&]2|MwA5#e2@ åIJ^ǟq? 7I~2 ?LT*%r&-%T9K[/n7I3G=3?_2 lJ+̵[D!`i`׽o.G{_b,_|U9eCh'8\Xo[R H8q#o.`_j "L>ۆ>hR+Z"[oI|c>_7mQCJ"iv%abjo.}N߇ow wazFdǘR)º-6Is'gY|3{%\"8SM_.`o]ȉRT;C)g6IwS/76eRQŘ jFH,SG0MSK2 {<@ ql?&PYz7>ة[^~+6i.οuF&K `5%N%Zd1u?$]};x2 Xjլɓ8TH@8/5zUF$]`,!I12!%u;אݎ#IJ!HM%ΚuCBRknH0jK* TRBĀS"՞Ihx)&PVS ij1Eq=gta=kfo`5 $z.}B7??dJ1m_ھ@DuTEw3;wI~^~Yq@b,}IAzK8@V@t4Mώ?I^훾?t5{]=|ד_?fĜ>!&(pN;Xn'=/Y5w pȬY\dK[gCbpxo]kf!1RrP S:5DvH1c7},_3wu2+KJz κLLj`h]kfoÏ&% 9_h j[r]fOƋ矌]?,_3̊5r9$4Hzk5h9n;Sd?_aO6XWTʀewI^Agy2?dV2/0{q*NdK8%Ϻv>O?{̊%о"9SRTkr۾4wI~{v>ҟ BBXƳK.Jy<w_{pYA1E hΧbmgcƐmX.=!f_>f(,JZ3N!fbTiv']{_=WYxc!q xS4s+ӟq5]5?fhn皂&O.tO8.= xYQJL!Ƕp*VHci.=]O<3?dV RQ#A-s6Q4ظ91se2eFEcv[KPRL>m}D/3W?8W"tLKT \TmQwI;g^{m Ʃ+p6Tk6mwI~pYu2+@${6^R 19[ʺcKzw5|u?>?dV A̭<<!q1m-6.o{>=sYq֩#oJg4ja_Xӟtإ K9܈*fHiz\Z l\t>7?dVa8UcM2FLgmh;9ߎ?{>o!MK |N䕌}p<'>x8W?.ztۛ̊?~Bs[Rl->b. l2K|7YwӓbN W0B[K.?I~?>:}o]2+z[JPϘ\t% Rmh%n>ߨѹ/!/,6+/dL59ϸ?.'A7_ɛ̊?r5rmcX5X@g4pz$o[-gw}ew!b 8`[XL0 (gqwtt}̕K4 W2*;`o{4.}YQ}ez'{WmkNJW7ANn~=o!se9'~gZ'9bSFQwI' 5^9?d̿KHS?X*I f5S,hf'],tsߚ[0?d|,+YOykDIy??}n6?dVg1W#A0 AF_U+nY.ųs?{Yoό1yA&v.W @=TN~KzKlO<5?dVw*lR:M5XO4%]O%8KCfJFPdGîm@LIp~/cf?ffТN#zoL#Tɭ3O?Y?8o?Cr)/֡ Bh?@mN{S7?dV)0@aT1p q']C?_}}Ȭ࿦'̮8Ϧ x\tOBPtn?1ctv71?dVCʹ#i1>WC$n  K??K̊`L;6ezB@-bjX.]8=!+Z!qRB8h_a[\oЧ~aȬY"6M?br%+GQ?I'8??fu/,?3.v%]Oϳw5($mDk0\lg7.}._˿~Ȭ_ aH>S19\SJkK)dߙ.}.gs5*T4j"T V+je_Ͷ?8']]?<=2WrkRUV$0\b64tUtw}׿]1_UJz3ziz1GXk=/;vI-YdnjMslɒVbQwIpg??}#\2+DD!d)V$iTLakݦOy?37 ?L}_,K4p@k1H[%{33.?-3+il LmPbvuoa]>8{b:fV}̾lPf@1>/_T!oKܾ6hm) jF4]-_7= 35FDR)+UrlR%f.}=2%ΘеʟBoſA"o>hm-CffH4]1pc#Vn%]-_ԻcfEϋ$c<q(F|5Ӧc.hUx ЩAl(րg cQ[*n"qK ??=;?dVaJ.e":mEN*h-2'] ??QjIVmIgw|7 _HRPSv GLB&h6L˶QwIg߳2+wI]l)rD $/!@e3KWfo/2+J`aAqJ[x_O?ooYUǧ(Ȳ1SLZk޻T,Қ 3buLr jJĬ4ef2%+gq1I-H4!IIr&gʳ}q߽}>g?!OJ5T6HQ#(ʶd'],o}^1?dVD 9M>"m_2'(qot?W~ȬXo+Oɑ1*'lHq>˃CfчɱNb܀% ˶FKzѭpw% 5BhB6A%?dV+X]E5@h2s^t]忿/K> ?MT4$-=39ˮ85!ӆ?.'ϥ_cC y6)PthR$pKYo?6'0vIKe4>w5o$MbV >|I3./_q=5>t}cf9?F.ROD 9 /|I?wU7?gգ~<_>y]w?|pAbomqT,ɀ9eP DcR5,Y]8K?\|_zx2+H'*![1L~$jLawIKgW/̊?sLKM %&g`qNp}xȬ%K*ݿDk-zFi%]._}n2aC 6֔WBݶst!bOD!bBs\6IgdKq}̊?+K%~y6Z >N"[ySIG}忿K'?ĥ5$@]3}\o~|nȬ8oTsg* RF%6)Ȇ#z y)]Osz2+/ T#tW+ @To6Sj0O?"?I{WxY)L6y ph4Kٶ.ީ=!6d-r(6\\ tX3.2QwIKfO| *Mr.%q5 2goJk l.}O/_o|Ȭ/`̑<4gI%Wb+dӥ w\d`-6duj.}'~ՃCfC!Sm&$jEr<.ץ?2+*%OSP SE3QKPh8_y<_??d6m4.`R f"&ņ@ى)7:?dV?Ic+jziҟjxl[iO gg_9?d.>EPɬ.G VMh4q?]sƳG?p>f.ϿD`(6m>@ZIIϸ.}Noy9?dVoeJ Rsi5t .O^kGch %5T+7ό .}~S!sy+sg9ZlL=^6PRqюv2+]Ɣx6 P~X6SO?Zgnx^2?dV%^7<2 τy2+-1`/bdR)3.Oi{s MQ+m BR%U @!xU8OzGKߧ{p,f2)d Q(nOv.'廟;?dVUc~ҳ"K4FILg\'?|̊R5XUF5SDmB.}y2+Ԥ\x@oۮ.}yʯY% ) * SvK Ր)o:gIwSg~ +XڴX̾Mϝ &Ƭmm?vIwSgw| 2ܦ\!'&qTXB%]/!/BRam?2@*QVymp1#]=̓Cgs,jR+rTN0> }忿_1=:?dV"Rdbυ}DЊ}'/4w  9VOr1'*Z(dmɎ>tMCf?.$@3% '#hB!>1m.o/_+CfV[JDXs}r]`$ m_.}{c̊?66$\pd֘%m)];_}W{Ȭ8ƹdKk9N;őh?ct߽O2+10Y$]Q%c%730n{_<#]_o3_[!dyh"TNAM ʱ؍ڱO;y_qۋ'Lp,Ij * bN߶7gtީ3G=?dVWkӀ@9n[Ō./oO2+}+% %*b Uco[}\v!b4c(sԆ'R Y:1%]Okf |̊C965KeQmK(:ǿ}ݵ!XcN8I1U0 $ q?']_o J bJ U)hbM3.2.}ڗSebg$ cq~l[Q.`?fVOu2}=1.0)i1x,>η^?~񇯺`ﾫ^w>go4+{%h=es`RMNX4(o|]1^пoCfF2 F=jRI62t=[fyYi0yjcɷISRtLjNaȃ]忷_cfE鎏˜bgڿzxL\!U!lRnuZE6=q>߯e|?;?dVGvYOc~S D4*qR^g\do_ǿ{=c~# BMN?"k/۫YqK'ҽ3-PSB_;k/_ 1b_ @lc83%m `ƘX']{_#4cf&!UB6?-fVIC(m֬Y3 m$"MRF (ImHZQB ҷ~m= RȅzB"ؠQqNߦy<7Y3~rJ#Ll &Au?1ktky}Yqg2b9*% !b)|`+Aa_aGs{!/Gh)*TCBΩ(BmME6ӘK=-YQ%Y s5I 1kxK/GcT.vK瑹|;?dV_S$RQԷq+j)mv?27?_0?dV -rI4EK9̐#h,h5cKzK_y|s!WHdsM0}%0s!m!.YeŸY1O+Z-"Fx0 l'QwI'27}SU!P2+Жte~7魃CfB^Z7X9Ϯ5uH%],_O>o7OۋRWCTl\`Y]œ/vȬK9@% $VP0KZrQ A]ڴmW1#]Y2?{>;?dV+m"dJn ,R[ök]\?vY7D& +(6)h=';K?~Yh"EyŪrkٔȱ8bϸO./+ ⃍8u ٧ȤNKMm(#mqw'KfM};̊ A`pi)R Zipj&e{Sgkoyr\5ŢKlE[-< }{Sg_Q_5?dQI`8ero8%]-_ܛ}Ȭ83VKXj+P>)dj5:GSN?rvI_9?dV!Uj 2`*G$\6>.hOCsm{molؾ| dUo˿OK KU`db- nиK/?0?dVS5l!Ex/ߋswcȬK*E:ņ5zb,m]D_<=2+V21eFx4$i?'=k!ϨO\^Lc/j(Eo'I򗮿wȬb*,CvXHlEr g.h^=?dV?)q&Li4q`l8> ]I_@sbVԔcKz?xw_tȬ NLA 1j- D<soGt?Q?k_gc)Pn.!:&D g\Kf|ݗKj@ -V xsݶ[^2+V+wX`VR X ӟq.x=߾dȬl6Q쬘 Jtj|dSBm?IKfq4&PR6*.W% We[ H`ߏ_8?dV@W$G0ɇ|ͶawI}2+9FGZĴ9Z("YI%_tǾ 6?dVmU'MqB޻z!o ӻ g\H]v>z݃CS+xK&ZC8L%sܶI`{ʧ̊_gh4$aZ*R,3ӟq9}D_g4K mM m'=;>yYW9i*q ފŴJi춝mh?{v>_2?dVUX-AԱPޱ'b8.}w}  ߰IdO&6rՂ(j J>zw~2+dk['Ns8%Nm(Ԕ63%],_CfK!sUT1b!&0 g.}OWRD*TjK6֓#OC]7w97  :%R\[]7/gɕ_1?dVr)kPqEZI vYeSoJ?cȟ &P.s4I&\1nO]~ŏ XҀ8OLѥ mO۪̊_dq h9׌VE m7n?3vn449 EtzėU'Dϸ}}o!b_pNb:h%ۈ)<']K|7_rlVŶ Dj56qKw?c셿{7{|_u}ubT8qBF{`BȠ@םGFI?&2 ABe -j9YcIsg ot=]ѻ[R0ؿ=KL\(;+5 L]۱$]k_Yp'rJ%5>YkZ\kMsTo2 ok+ת?Z(B$POGB˜`cIz~ُۧ|]fQJo``z + Iɼ]Yk- Z:>4\KTmPoC\1$=?M߹7|]f9@p+PdPDRκg`6I's&g̒8[B(Ib(\$R1Xo.}}O.dhz5|R4z}o.}O_֫^~Ew?9glmQN1empdX0эMwo};xj3s˿ǿwS.O^`7*Y%m4hEڟ;s(]^eQx %:S-;pbVۤ/s.@Pp |!B苚cW2/L wv'QC@ Xk3Y 3msa?/=s,&}VYj(ME)@e$]9vsc2o(zILm i;u Q7Id{Ӯ,I2R|#g"H> \`j~#6Iw[Og~^8e|眼'Cj3F~f%F u:6 ]m?]/ wi_J5AjQ+qot84W]f9%JYSMԌSc&ߟv?zwwH4EP`g09 V]ik8&p>NG0Rȵ]%ZUZ2_I8 Yp*(Y1WpOTB赮|7I~^]fAwDR 6 yMAلaf7IsG?7oM2qaQF| ΐ%9Lu??aoe?= 9 ύl@&Fg$={c.s:Χè" sU[H - ?,Is&O͟2 rHH$k6Em(˿n.}|O/-]fbp4R*@^[){<<|qot;~;.hpꫭ%^\2J?7m2 +TQ; x8KbI>M}ӧk?^/ .W^ǽܠY0NJ>jh@{Pu I~.`w5/`~Fy?6rߓ.k,[gҤ% ZSZXb1pvMsW&oz w+dR0p4oC+4mo w1r҂g\ 4bQ=SXcCcIs' DHё %| ? _mӟ/]fBm3i┉j]9;6Ig?NzË ږҐZxad!œ#mw\]t-k[WW1'&\e_cU~ctf]|ߜ2_)⽔xm__]f_QM+&ae\Ε*5RYwot0}YbPO `;@W=&`7_Y::4ɘJ1D=` ؔBvao.}w1kY7сZQTS(lc$+#&`՛uY2+&W+Ha=T$_ 5rf4&]?f5O}YT5 1QJJR/Kg6I#'7w6`kv^#Δ*֝V-?'|Y{l)S .@ @nem_Oo2 >`R Ukr"%PL1Y"IDRr6_̊&Wfpٲì, هRZN o:'9'Z081&\P[Cفcɧ?j./|_pȬ+#CE`\eX\l>be?w7ÃCfor1ג2is }ӟqvIwSgK|3Cfٰ @Q1ɓMj*)∶}kz}0?dVgieyz$Z}3ж?6K?oCf_JsZ.ZA%'8%]]g~4?dV zvGD&PlVUby?%]]gxS7?dVHVDT4L?%1y>ۥ{6_zCfv`ŀ H(1 x3f?.]\/~YQg"V I !ZtoT_\_v2+1[NR(bV.+ӽtag?3H#={+ѪKUh '=} |ȬIYdL;ڲ$ltvyd9f?ƒVm qINUoqwIwSgo{j?fVMMĀ"@[Gjir5p7.}R]?Cf߉̶×iW!: ՈFm?%]._wǿ~Cf_m8دʥfXb%xϸO?\G>{̊/qcQXN?j1[|$j\*l6?dEl1ia೴@6%=-Oc?>?dVRrk'@, ؖ%S4~fvIany7tȬ!"j˵b><]T9YbQwIlߋ?!C6&ŢhSïmvvJaGY; hH(6"T(8M{Z?0CfH%{N%0i,`0_?z _??dW4; $$ OU>`?7YsϜu*m+`LCZ6}]W+wȬ9-fZ!j?x1B@_QwI+aY+z߽2kj(-ĶZ@`#г?Z?|ݲ{ίpwץgn~MJ=kGGY\CTGqz*s#gu[8%],Ox|2+4U\Qήt#HjdMۮۏ=CCfElchDjzpmk|3[?']X?)>Z*m 8O\7?dV Tm6aLGVҾʶ wIeY/ }[ _Q4]A8Jj漩pO;_?1?dV#czL۪9ʚKXl{vI,vOdȬ8k̶;h"[Q}*`N'#*oot2+M}"lӀlRsf}t=}>?dV KJ*%͒蒫cȦ?ƒ=?5!/2 &a%Q,&R%]/;3+@RI9Zb#lܶfO?^v2+$*bz%Yy KYSvٱ%]s>7 X(鎿FiĜӟq5fwI~!#UѹEl}tY}\rZ]vѸKz_:Qϥӧcf? '1՜i8TgMz2Wsgp~G7?dV_|F}Lʉ22lAݶ?ǾwqYqM2/ŢErV(1{~[yO?>9?dV(OUb_\(I4 P[` d N3wIg/]?*2+2Z(XTd`:(b$ܶ?p%]_{tȬoY w6{qƤVԠMxibZEAQ-xKsM[l*bZELpbUsi@EbA!bjچ$R/=?ο {9a?kfϬ!A!G'&\ם2Mwz8!Rpf.\Ir) \IsN/}womf>+k>XkZ(@)nqMǹo.꠸R5'_rʊQ}mK׽ö?o.?S揾n,J&MIsMTk%iIz?R⯮~b,bvٴ]%&۪ %}7I#ʗ[Ϛ-b\PRZDRq&o_{.sq,Cp)w{j.5 2ǰx7IsL͗l,8H0>(H8$A0B=:3ot{88#k9cLb XRQd5t]f"kM 1rhbv&5{1sYp)\% C9L(,kM?;?{ ]f|8$mB"XX\.@4n.f?K̒bCꩄAbSR^\oMsON}OYẇҶ1gG SBvFP8&rd'n ?1eAUS3Z?Qz7mH'z]2KfTm0Á@h$f)d803?I?OuYll2)NX[ҿdg Iٯy]f1hطIE߶9TUrlY?,3M?2 %4>!䙙e0A?2ۤofY0A@kML)IKuHLC{%u# ot?9wӧŜߊE/ce m- *֩'lY{?$=3stߵo2_UgkT@#Cٳu0$]{: OY9>LNvC)5Z̅"[#M?3Oտ|Yr'gTMtjZ6KuUk@`t;Mw<=e/9Y*'acil.}/74eA4\V5>i#APKcyoms:7~̒? /5$EEuNSH%ƙ&9eo}YO9\X6ǶH938Mw?SuqYs4De$ RY?Iw|_Ow}̵zec,K 1&ogq6T_y3=3e.ο&W3KrZ5&.joO>S]f?.'TSOX۲ߕ)Xם+nMH(һ̂RN"ڠ^۾R?"o7C]fsQBȚ$`]^Iw?v3eM.: m(AUtՈZ%ʑq5G3&_ojgֱ[BT"@6 11!?c7Q&7^YYj}0R\f!Z|mpg?n.]A^WwCQ3- Ŷ(Mmɮm.}_."h48B Kj$mB@#MHLW wb$=)O rUa^v?wڂz8zme&J[DM~0Nύ!Ţ&"U u:;/l,X.84 Z5?|h/d{p?,l`]#.edhMaB(bȒsZ&`o{YpB!1V ].VqAOɭz3?}2(*c A86&]k4e[/jԆq5JWc!䃆Et0i|=e!^dj}!-9*ƒ%6ַ\zǥ/}/f,Y䝢/6j&/?ʘIQֹ+]W?]g'_vUx˥]㷽f_dn/d$| & [UB^'7I#s}e?4%Fv$PP $ͨۤ}}{};G\Dsg5@ǟqgtn~~.sqWsP'Y%Xlq&?]f pRRX*%'R8&sۃ]fD-ٔF3ij)k6x{ew0e|KεsVu.#mضkMuwM.sqKuRug-dP?,1st<pYpO[ضHC D5nV?&]_7y_5e +C[(:Q?&/~+̂$JRĻ0ƚ!un]d7I~/L̂\H5s6%crD}rnݮFlDXn~C$]Og$m *M q8 c6?>2 SP`Иm3G\Ms'sW<]fA 9FVOZX# i|&=y8&`5UU_ x^ Pm.}O߇^_;eNUR.R+G H/f|$]:YPK8d9;ߎ7 )F H3a1QPl(EִEjPm%\@=_ M IFSIؘmgxוe&_/^wfy'DW1 VcQI?]5>݃.bu1[$b V1GJAe `ڌK?Zf.eVL(R) 3YQq>hRI.iho.`1'(]k^s] h)=n|w)M|Yr$@& 6N:F\&gQsS]-9ʬ& vl(qg?s/3s oveV鞖hyMN>?}@_0w|/w֋$R,Znj1N:@VmGhu.O TkJDyuMxo4o`re.٨]2vQR< 7Nih}˜3'd0h\"g4ow5#%g]D&͹1z]d8]?k52+tNعi8?c#d8}nW]f9DaN)8E(UMwJZ0܇w8:"NÀ:Ih X čO?/x]f_&iJa) sЉ4vm|KZKhO02+`KɘT!Ј/*!bL6~S4?P/w'+RڕS& Y 5.oQwIjj]w~geV)8u2\Q\] ͑q4}5.CHJGlDHY@ސTxSKfˬ-S&_8glqx%qK?h>>f\Ω$h s iG7N%MZ?4??}˜{7)ߒr1b^.Y08>m>{eVϔ=k1>6$ɱ63&Q~ÿ}peVPCvɇ8-.`F%MK\o92+KHIL'EAq#Ӷh?ݮOGwuu4 @@:U*$KK}׼keּO}r0TF(A#WF}_5?fƟwPDpo33b}HBSt*I2(L ۾eqwIןˬMTK?)}(lhSm tNSp7Nxk4oKWߓqgοeH1,д]S((6A4oKG^wQE1%)W=M&m?q>F| AtLMM#Bz|8J79;3+"j<!P DED(ֵAuKoK\x_?}<3=Ƚ=|޹w^x~iV !zN/V*DJc.iԞ.|G/]B(V *rVN1o4ozO>.W g%s"LX{Fp1o[k0#-@/ߣ7w5gq'U{}bȆ`@B&o|ώ x=wV!X8/".hfx{4oz녯ˬO72龊l{ɫ⬳"x'}W|wRۀ+䋒2gU,DI¶c xuwb!B2`&?D2[5wIw?x*F\|Lq̬Tv_/YU 8p)O߂o1c4?p=+YK2+Q!$XdBpfm?ӟwu>0F9Cb)gl18߸K?feV?,'!V2>MdI.i?1Ϭm5* dk8,YSa[w4ofndeV.c߉HmmEA _vOj?3Kx߇ߌϬxٺڏLm@b*G)3n;3Kx}92k ƒբBJa4o= ?&%QTQ7މbTIh8>i>7 d7]zɹ.sv Gq(ҹ(kPҩ(* A̶SWW?/>=w?R?H6gBX˿)J+'i n|%MCv~ˬ8 FUĤ6eC윭rؔ0vI,뿝.s]fi&olxĬHA@ŧ.i4=Uˬy;;䅐L@5.Q)g#Jx&m}u?9w ̊& % E*A'P,*%IwϿs/Sy??|Og+tqwSJVk$pmM[Kv>qtjz/4&gfF6)r (>Dȶk??9;Ӆ)x]yĦ:+!CJ i>Ov>w]f_ OOYFmFĘa?h'M鶹s˿:2+h4X|![{Ok%Ei%-o;P?6}ҫ<2+2;VZ&*sHdECޛm?%Mw?ˬm (eg# % 6?j??X?8|deV189HjorQ4oG?O~>heV/9f1pI^rr(@lUƂvxg4oG?Y1?@ޣ>[[UE.iߞG+/wWLO*sV.A]8BvIǾ02g?.N\AlP&o]b7|Wf3+Vm>: (KC.զԿn=}OK~seV|+94؜ֶ >˶0&Z]c(%1gDG4L{&Raxg@_~˿02+ tLֲOOoqo4?P/͟+]f98")Ӥ]HΪC*IamZ%-9/ieVE`Ĩb EȚ">iZ ץ̊?XԮim]ώ`j*2zSs3vz!R j+kV@h~P1\M*M$ȥ4Mf+|@R/SiXZڡ~(D0^999rL|8^[EM?h=t7s_jn/` -h)\rcuN&_U;ڈ泝MjF/dU&>XTX"GV1I~zG]yMz'T N@a uB̎k5oKcnhq_Zbc ]Z9V6+J)x }&WS/?woR3Y2!X"Z0O gg5o{l I͸(ZT9 4,%%8c}W]q?I4#AVB)J@uXUO{}oR3g( H.i`"~2}*j?53Ǿ&5kS>l=7|/J}P`3:j_{~&5g- B ]t.%&m}wu5ɥE*I+DUuJw/.{GOׇ՝jF/'d4X2Y'_H^yL7xGߵ`X@Njex#yg DJj?05o>t7HX,T^p?G\ RfI'Z,'KbʲuGOok;ԌzO~06ɿpF砠29jK?QSOS1|c kFnXFkˀ"lJ*j'Ov]{~IK 1ZcNL) {ͲU6HS&5'FNCM̽e%Ur6s󿊚7HS~o1;%ŨT!/J׷6+T LD.{uC{eǮoR3E%dҜ P/&p 0I ?kU75;ԌQEBl ̞lmɐeuώ/?ߤfKHr*'>JCH p_h]EM?nI8Ti$轒tĚRtbE~?oR3K]^6IQ8_EMcO`MK@3@49E)Le:kvS1?GnoR3S8~%]MJ @gZtPvS/} ԌִVM9jg?1dBRhߋ^ 7~+^65cװAM4zQ{꿀gQ_Ozc/<~gu_qO}oT3_lSɹҙ#"_o7&5o1*ĀDt\(8,eY>k5oZ[n&5c.l @aTHT SQA-?]EM?=I8(qʈ\GWR"ƪ5oc>yI͸éDG "dQJЍ.0,n}Zj?O&5[s_Gc .WQv4w7tOfd؅${ZhSbt7Ua]N)([v`*eU/_ߤf!!!Q YcZQ=_E-S/A1W#dD\$U#28#5ok?{拯&5aWNXE( ((&m?ߤfj5eSA0ժ 9goVQN{nzA3#lDSK~ jUlRF^&mqȳt7?W3KaRȠk}%g¸&mqMM{Hb(xF@ c_P^BN USԌ?X%H)_EMc&5W5S*@U`UPDGbb2a=?˞ߤfD_ŌV+*76d] KY6CQv?>๹ަf˔[9rV9Q(W{˞>oWmiWw=vgזS\:U"ָPPSYxS>&5#7ځ5&\Q^!E͖ΫQ;]|]r×|^o:]|w^ߨfw`r)aE mN_EM?{_ԌY4|)&/%ز^EM?ӗ&5O Z]2l6hQ?WQ3/IkŇ$E:i--_GM?MjF_Qf`Q-Py$xԒ+*j?{gniƿt}koҮfʪTiU>̼8Wh=l>uu?Y3JY+$GNY*9HB $v׽Ot7l)Y G6HT!'S@.mAE'&9} ?zŋ;Ռ?Yk =/hR:m߉ixwm?F5ِ_ !pM?v:jgO*-j& 0X`Ast%;LUmó*v|<ߨE$%')BXu4{x/?sZx$>\?G~Q͘QbfHJ'[/6i][oo[j2(1T}-hۊ^?Qv϶ć*>g-jCxO),k"FIv(He\G-<{wW_r13‰ ! YKP_ Ȳc^￦QbV*?&&#ЫXwaw'u_{Ώu7Y"C5].xV_v}J 53GNRkQ͈VX x#YWB*zL?_E-zxg:չO:dĢRQ%0yKd}:jO}GC#rE&$S*,/r}5,?:jO=V?{|Q,1mJ 53XPt"lmmÕ#>u7?JNC({À]2K8iRO5SO{J];}fj?+*I԰0x6 kC w|A A*$\5 UW {wa:7\kKL!hX0CgOu*jgO w^[Q͈\3fEO"dh[Z7:9|۽k~Qk_ТIlkR- LF"w{u}ܙ1!B[Ve^{o uڊ&"RPRI,}Q[1 B<43; *ҧ(M̝;CEIVc~s83w^߽VQdO?:+Մ)%Tu˄!"R**n3@-M4?&>7kpo97 Z >\J-u 4[D-?i1"\|=Z5aO9>[r`EDj  4o`QO_{/?_&)ØOag.YKјP5`݂Z7ҌK wapg*awPDW}4 @|_F-?iF?eW|8_&IAǠ B8T@B_52o/4ocO<}~Ř+Xd@)K&*O'A Bm/?_R]J*mQmQ&`Hj^˨,g|;+Մ$39W=*.X~tPv?3xw=tRMS)~*߀ [CZW@ykK%3'#:+Մ?.!$9LJ93tֻ >y^/m?&\T,cѓS"~/a1}2j/2Ż_&-:btuPSdUAUUl%|tQOx~U(}(g+(k j??2j/1'~wW r6H32HP>x$uN10м#{oo]Q/_&jK,="b9C$KQQv_x7cj(IE̩LΦC[W5>.! /߸RMkP9j4*SJړxA[g/Oji<5 o*>WFy(m/c2B>_&?G4 $tȯTT->{57mQ7dNvGVMjI$-:8JW2q5ۜ˨w~cOwW cF%)D5HUVz#:XIJ[Z4q･]ϿǠ.UZyX4ke˨G#:+Մ8RLpxUD@L.QF_s?!yC}Z5)wZ6FVʥh=MکRr\@7/m2+~:+/i`)DLi.[o˩^؂E}"jk.0{⁏~]&٤]JQ $9V[?q%瞧j s 6ϻ_B lgW_0'YOE(R:{HVzZo Շ>_&lURt}(*']CT\?2jH=#}Z5e]F< S"0B{;?Q81gG;+Մ_. / *x)m!I ,m"\<7kՄ?Iąe-՘sh32k!o`SWqJ5_FgkM&\3A:TczZ0K ⃥Y()`R?!1̳k{o`S]<|op */M hcu.UL%?o_"j.0{{/kՄ >̇2DɁr!:5hLP_D-_~cj_7\5p/BGـFgE}2j~Cx`s#07dJ"+:^֭"j!?txU?E8^S@.vsh3[}2jOm?tx@tR~R]CVdxJ sl)&hU%W7˨wnc'/vW)n)$I)УM*ch=R8_dwߵjRfTM2D(c\_>goKW:+MR[rEiM)OFAYp/mB|R]L.2+ROa .re#/]fw<[:+Ք 3sb S @OUuG_}g:+`壁0\+6$Q:/4_Zz=;!Nmc ?Xj,u Y*j=xsC_2jw~̩>;_{[{?Ы_&9ᢟ-^y.S)%W1RZo?\=B}?+>K`j 9ug"A1ڦ؂~X 5Opx@pR]J5ߠ!Wr6TVVL`3]H-g?&^J57F$ G[5@ȤBK5q3UZ;gW˯z~ӟ9?ӿZM8h! rNblJZyoW87~VMaM1Hq2\|WP-mB<ڗnTSjpaTrթΆrLv{Zr~tWeNMTHBfse lw[D-?9OZ&C FF HӰ UZr;7!8uÝjP3r9D< }R>qGp!Fu*|TrtybQ#܏tS!hs \l!l|HE~Z8_d?W:+Մ?@w}2[fȠWP/-ymF?}t??_&`1&ì_pde 1p'8kMۦWZM/1''zuW dWҧlrp"*F@^M/-??=J# ~8l~I&DS=)"j3#?bTъ `t14 Et %u?ZC⡏|q[ZS&kU$#6bBA-Χ"̆F{1[\luW(mNU#T\bd:7?c I5G߫煸wWS h:aJ.@b#Bj-?Iw{:/%XRSHآ7]|>g5ost@ħ/;}!XT 6(oDG_Tl/]wf/qq@ hjfXLp^k T+4em;3WhG;ՄޚhrD~V%E% -m. ?X29Y5Xgt1KY0 * a?{jd|@z5ao5j\{ D")˵gJ\>*ҢETohB )Y{!`3cdi=([ᜢEddPRd_Ef{fFwu޾}~{=t@`ߥ/t߄>Ͽ|ĖzX{=|-??8 h ´ !P@áZЯ dϹ߆>Ͽ?H#ɪ?9O-Q0``h`m Ehm,k } js>$QdYUDr[̡?4W]D%O :K&Q4"5:Po5߆A#m4dXB0h?RxA ? 1rYX؎(kj&rrXO%-Z 93rT!g#$*?1'$ݖB0 t$. zLHp1H-lC#0:ABf}`9PP.O,Ow | 8o/B# _ @aZ?p67!D%QM0 nVi"h7EМBpdeH8i@ G98 ʏ1Jԅ9hۏ K$SLNᙁH8^UtQ4_#C_$ :t׆oB_Jſȟx[pi~{||4ȀKj`v>0ptDxP|@ .8:#8J_?k: Mějqy]CIHX-oF7M#,+{d-ӟgQgTzwk+PPzg+DWv}c=.@j[rzZ"2QR7Eu?+V8iݼȐ^]Dzٔ"“{3 33/2k +9 Żv3UiQÊ{͋:0x(UN3CIs'd hH!ޅ @XrֿYVӳ+漵N&g*kӱXpd||4ߞ1 s6$3]6D`=5̬y~h#J#Gm!:q6]]rnf03W9=x rNMRP0w';HEJI"#e=cΰX9d:ܐgjVw{a=oBn&֑'#OdǮca&^mr.n܌Ϯnf|;>t*";]=X_|mҲYK.&b7G+H4=%L7&T>^ڊ}=;71=Ny nnhb/e|: x<˗}ݪg]f.K<@iM~Hg[Zc)#1#bdEa⿗"gE}PlҚ n&iV4NU6z*C7#>e]vjߔrM e~7޻r&,8Iji|;#k'LuuZ<=t9u[3 .=^R.z$qVIqk%kQ6:F.qlz&ƇJoӉf v5;.ha`n]۽+ Ц>H]Z1zŞJfz!_WFm}j$K]KƷ T6J3ʭce鉷6NT  ^!R=2_ިK0,ZFվk&Z`?{=';ιIg n/ChntPyoUhjLvՕcʢӇ*W,5nP-/gҸ姦|]XcYfS ^8ouρy7]R5 lsBuߚ(jW\/ J3QSž6VR '[*QNHo6MP$_fnN#JQ4 W!_ˡZ &x?rJ5217X"msFGRDMIxE$L vfʟdqE/SfV>N)y}/W~-l{ZktdQ]OuY=7bbezkwk#s+MSx4pyK\l-ÙNE:VD΅;i651r(@Awktrݭ%mj\wΠS,1i6d'NBn k ˂f.۾93FiyGbW}Q2 MJcEF2A6!cAwspg2%Mۍ\ƕ9E]r{B]w w\|k,pRa)xS[tXcKRW8XL~?$II\= L4v{u;]ԛp-8Ab8h!]u*)#w$0Xg.!]^Z@@mq QwUQ[E~Z#a:#*et{"^Wb8CPjGں祅UR՚Fzcŀrwtޮx!F.`KB(y'3HhC-lW`|mhc^>M.=jYad,i?yY*fS+bj%~ MC.jCD ^z]!&ӕ=mZ1\5\\.E# cPӽVҝCi^RKۤMUwu{\H^(ixkGo'+~Wp)xXu0o;vރ`+S$O'*fdyxCoLDjq0C'Uo>4-c9 ' bxܔ]qB;e5Oho90}TrOmΦl%ި 耠ᙰ;ԏmz<4g6+3+n/fנֱo;R=VX(HCpnvt{T}IpṆWNyO(` <5TCI _MVhG6=\U:boOB\+^[V຺Og&SYd'o`%^ 4]tKM眝9"6jWy sS ߉(ȶO㦪fisKF%Z$ˋa䠡]HMgUր[H34| 1>88xmdWmI:=9U;Wb/ͨs-W9ZhruFsQ\񽇿׾Q-?鑮D2v ^߱a9]l&n۽5ܣ' 0OB$荡eE2{bz˦.ݙr=p?DlɐT$b$hQΖ/i2̙"t]d>*Xx=k\(B$R$R!}"e2#D"<"!3emF;7S,} ܕV['HWeNYN]P,5 2qؖ ;ma6{V< f{P o>!Ǫ1dR:ù`rP+4A'SN$HdRrI^xtM(PO=c:|:a|F\Pӓaf"q߿Bs++9ﹴk"yI4%kN*OKnZԝ2>cn)B7 L=@xCEqYvs Uu7k˨x?^kȤaSKeKZy[ӂU3۩%G-EBtd ["s:g]xZmp3K*3]^zF;!4񶉅B_e,7d>F8Ǿb\+>)BP>m9n_yL??yc"zFc <_qL;$y]ߊ/KN'gW*axR*iM97$79r2ȏZmYj3C"{9}sUIA"M#'D)u[Oٹyƨ~F񺡽o4 Qs.̎&3,e` KkgqlǻE?N҇e{3/1I3 gynV=8~9QwQuC >UZ3W f]( wc C2lƏauapU_C7r,?*9"-?|{r^߶rP;XOčp}-x3gqc],/ϜlU5sU(vq3o$`׏-s,ߴr IgaD)-C|䢷`(_PmJ !=h8_}8ߛ<>8wn8mM/xN7Hd|ped%S/-;HO|=APJ,LƔtFy0*6fg~~vR0 r|=eYZo (u#&#k|=`2-\wa.ad]ydww"ݙW6߷߁=fԓM̥Oe 6z8\z05f'ѱ~)䐟_" T_焞7:Mx܍[co.untf =#pmzP! l8rwuI7Gny?4s{AL߼FPOL^gJ>ڶs0C1JG.d[X3B)C/Igҳ&7&  hqz`yyc"J2E|٧LY6B[̔3Ċ^Ogw>쉮xήΰՇGWI2+ 8w^4}uKq@f'f(w*LfuˆRbZ4,<;f.CͩS%5C)7n h37g4 ̚} N4ݚPtꋻn@HwYZ>w%ixS)H=AwL =A8-]쐜oP-V7o؄y'KIW+*x,gc5t3HO#B-.! _mr͍߷1ᷜOի}gqx_P˔Ñ'sǫo*~)&zU97=SycP^ghe?R l, t{O};F2;uS: X.v92By/o]p uazܥܧn3i|1{uG/ |9G>SF[:ɗf>gya-o%ZrH4)67ٰ#7~avѱ&A,:ߟn?s;wnahQ}[QC79FQAktO?$^ȸ\Wјxٚʡ`XI!A˴ 8t}q FC:LtX6_wS:G9v"O58,:OiݐRkMU`\#m 1Z3G{꛷-c~j;e6ws p. (=r(P!2!Tj9ӜE8TnUk0+e~iZ^6Nz Jau\ᡟW~{bv]>fz|LQffaYɏnOئm}9A=8Es_ƲpsWG7Gun}{ӽ=*q=A7G6W׎\oc-oS,+)xX5~gpXҤT6 OG9~>>D2UWsUvlLEmىXY U;7W<+x|IlI[^-M/Z O 28bl3_v|!|b&U/SeT_ӅfWopDڐ}z\zŧޟk/e4_rR2v4Kc"%|)g)PP2Tzv];MZdWrwGdlEb'w} }].1(Bz)+nBdr"-/byf$KL_}UyסӐ'}f40̍;[ l s7M 8`/X6!Չ&C3,T+WHe'R/u>G`!O45H6ǵ ߐV2E~L눔 kмD낊DiܥiQf&cN>c$GYHgiÉS&nXxj4(S>j p'YY30 mtdz>d29sؔ J2/63F<ۧcbyvp/d%#fr׌.RCg9݉ƿ6_}rUo G?tۃܩ_2%0)Iθo*([5վhem_ת;;6H91+>/y]l;ά|̾-%k[]H9S/,~d. )v)9(0{y3''Yӗ|ݞJ\*@/oA1!n܍,c7LTrc5:}y9C+rz#ʺ!]_/:S%^K>9s1EO1mzEϽ߳bN=Uhy@c IbnL~L/#ލ wF$-'Y`ˤŞ^cTW^vk)=,GMuŬ ɖU[;iSYLhjX(Uu=*wJJ`XO?L y4t!ʦu<\iqeilFAͯ?1׎_GځRȏnHX{@Sψ͖wΎ.9*m³S2D`úK9BI]EG*gGz{u0lS߉% \#*ъN?}!9;M9Cb(ՠ)^,qZW*{.!{ Е; HCSkuP"+eϖ2[QK{;X)\u֑c!gTrʔHM-Y:4T"o\ؕ/ҷ2K fFab/m^hWO$TMvĺ(/MRW#F2}:eYw1WZ,k^oV.z0}dTYtlXsTڑ+YC D!G({|eܤ ]`:fTΌ-l.}q37_+0?DZ69ȵ&$hNEh u"=]-^k^RgS xt˵s%lMCٛ10.l׋MRpϜ!.j@ċw%_ϯ/J>fz`qa|N?GrDLjd&vIGPF$]WGz?@Pv6%sId(Qy<0Hvy.O1f>KG t)gH4טZ>]iapT-2ښ>{uPnkRz ֏Qh@@!gien,(I WlɭRR1 JT(Pb)47uڄҧjAAXu?x&j6I5.\ZQY^{VӿHcw+AU_ߴ)̠萋VwF>}>饣DOI}e|:5_N tʧ~B`1j(HcdY!Ւ@̼3!4[?ZxkǑ5+ŧlX>6Z~ND*W@ ._vVzf?=jP"jj\ uI&)cVΌHkZYY@|ym+O߻y!Sw$\i)>* w/\ȈG횜s(NI׫eAڦ2Qj4y"ض8\y?<qPǘ>o py>O)mpm-+E9YmTigwEɡ Tlq_] p$ףR0Kz&E{4 ѣ:y;i[K3{[/fH%o67i}B_T5,J)Z[kiM1ɨ"c0.h;Fw&O4\HsV x=pgn^T'daf'-fz?e#_aC1G%eฃ,鑴?zqV #W ڹbD,1xe"Yg^?1 6ա;ho6r :4.%IA꽫dK/m*4S]D,$P|3Ko`'/;RlOҏ;V5L_L\("g\mB;?!vO Uji-")0'𼆢O{V.v`o\?|~˛E,.O +;ԵI0?fjROʻԬ^‰rM4?Qz&ЂCMxH,0̹ nc3ReB[ܦ ['fr0gSEz9FR, zpAי~u~Q{Ԥ )?9FH-49EHyïK#;UNB7OW&b[< +pnEs=L:Y8# "[OU _l>-A9$:%.?196V_,R-KjoIO% k,]tQǁI~379RA~X*-{,\oã^P65|zReT@SZ!;a.ʉ[rS{ߕ)W<6x@^"R+$U/;wm-^499u9z\ɧB f}[w_~7hL4J-et;gBd8Ρ&+7RVNDͪKIK:UsY#m_ƩO?u瀕}w"ժkJr.,T֚E ?,TYezeǙƉ(ڱlpEc*T{֓wE\ VGK0x˶HF+*S-in*Gcm;.5[K;MhznD 8$6>HXFhl@j;4rCUݼNl"R \ 8Qg?;c&T)vHIL//_4Ӹ4,Ν'ϩG/.޼&K;XwÛGg>ȦiGZju|kd".۶ |Њڅ/:'9öJ-OQ?aq9Qh Ir w\nsc/MM kK6a[ |v@WRtcxMO%`sKk:fd R$$*tNfsBg=}M)e9 (:nQG՟Ld!덫qPY\yاV%e%٤ q&AzBry&lsIInf?~mWs@SShll]{y2piliwc"F" _,E)K}4ε>qA t+:Iߋ;OA6~k)mP8>J>-;d#h (QU;[Oi2NhUxoHLK.R: nQpAOSRQ\C*]GGA]AAfU7f3ujUpj*;hkK3͟sL?)"*ܷ4 t'[:y=<. s;rp&1\ݹ櫾oϱ"i{_03P9JC59V{.>S9Zzh|+.zjC<^;HQ^]ENZM]{wBO"VN224o 8B?]w6Vӫ5}#,:| զH~Z Si4ܱ&뮧,yک8^8'|.k{iD-O퀤>L6 ۨtx e&m:Ptsגsg;̾}-u n}SV*9hwea_7eo]szz?_v~zs_ VbjFea~v+:0;z:'!Iv TH60،CҾi[SqzN1ug:rCwCi^?uksHPW܋LwU}#sc96SfX+tZ!ȵzL״0ot;PAM1;Dt!n؊hIM IKmQ(C'}!pp^*p!٧ԂL)oywک*,?JuϤNA^@8|zMy[n&b:2-&N_mf:&gum@}ŝm-CHuaMÖ./߆4Nz)EtV7dVX5(V6ah-~I?0@xQ+9nd45Fٞn1g5U=n"G>~Ūi9EiލPP5)l|?5zCRLэz_&wk;}7v܃!,1X^Yެ# Fq U×~Lҵ[ &}Jz0>;;+JPglC׫yl}|&C+ǍVɩgh;ۜ)hbIӗiBQW:",h%E;`KEӂMWuiatl4(p]M<8;t: U  @m?xkCbdCt(*F嘼zQKׇ-xHDg42#")y>1 } uo01Uq\jB4䉶\7߰8ivO&h}CMNcH#7#Cח&Wl[J5 Pj{1F83E}8 Fe^}cuIqqVl蒑ʠ qu`PdLp]Νo>0e|#ScJ`"$D p ^ӭ z7(į /JR/αdz - a+nWY8_z~]b|GU166^g wb#}JĴ Su|RIHoZI#m 6[@e7翐}8ѹwr(vt҈h:3T㙖φ<\8NFFC }Gy?`P};Y}$C#{ʯ[E4yDyH=V3:'cTd/LG˪Vώv$EeGm[L54:5p=3Ewmn,ST)]'c6>0&dq|,?L@$ȄwbSؙz&SRY2pmsQ)Uv\Hse ƳjjF'pj7R0 p_ (G:wW+hdrs:+ibOVYfĬNrv>| :t֍Êmt16Mܖ{u%IgtfjPxVPBhk\گQf4cs:RgU6'y3? Jigv8KTY2epl=̣G%<(dKfNZPS=P3F-\eNLgr{<9Ԁzx|Gg#ӟ̚yhاתU2aFEŷEn2 t`sORůC[`-QCi]Ed AcajSc/w}/n .vqfYkjl[:ǩ!3J0֮o³3i.=`)>9yD+Xg@PEh@%mDI|ytK!oGROa&\kǯ%Oϸ%Ū(sϺ}n r~@vs|{&R|Tq c5Nh~ Łћ|-lDʜ(ƌlroz :mV}lpWoeA=SwV0K>!R90˙Ba IM4~㰘cEWŤcGxʵ$͞R|U#Õ85z]Dck?"\q趌|G^Sݴ/f.oSP6yXDjůӵ粿 X6*#Q] J^-Hs[+Z G9R VH_Cj=}Ѭ&嗍ɦ瘴Lr)ԁSݩRk#2Lpx8 GƵ|.֦s7//!/d@uqrʃOw~p䎊K'Hv}ҳ_xwk-p?@vrq9_vved"dE3_ _lUݣy6]E!||SU#1gǝ39*?/'_7ƾ}o|jنݷ;}0\c۴߽zqwKi6OA~mTWұ^>2)R(.| uw4{κ)}ʇ~M!W bgѦtI 8 :b.#RE=,&Y. t(crQ})9^Kucp١.OWlItYϏP]S-{D68cԶk+K>=?abËmqa6i 2 0e*(A#nKu Җk7,IE}ZaJ@T0eZe?^xJt;s>;I~~|T=؜)?~/n=Q QGRZ|@بO.:L\NNp90MN0k=/%HKeٻRY452(S#JC$=VdvpLIIʪ9d*^>Y(eAU9t'D7I#%9(߆g+χ"6y]2j ] E8),r>@#+t ayAcjt.,VK*Ydq O;n|֚:esr;GZѫ#<;ئ]TqF 5g?~:UNWiV d;6UY@}L*=G)t{*Sݿx/AQaཪ"ڙ{Fjѕ٫ HQ~F:bPZpBbO$G\B}0U3&ygm{KABgؖaP@(Ou/*uw ,vdruViPY[Sr'_-g(z [_ G ^js6nG:Q׸KC:Wc;3;<7 L=7s"Y>lDЊiť] @s*5sHً~!UZ7zsWxs۫Vǐ &뱳s˘Srњg' 12zՎ[\)~8""G¸HIxCٞkϗR/JJ*Kk eߴqE;~DIGgLGs)1=`RFΏMRK^ ZEzxrFDu4|O'Z'`a[LEHcඔ 7b?c {^VaQ~DzO.8֐SnVƹdk0N'I|KU-wk5yXɇL}?#)Gfnav%:7֒'pG¢N-^Qt Ugw-JrҠz{&zcX2*>>;pҭ؉麗%ZuaE 4BLk2~:odzaˆcm+#7X↟;.=R?Y tAXiۻ'. o]r484Rp0qX@ūHiGr#X~qL*F*$8 \;H9>N.\SR4h5~²z=3uX\v"eQؔo#s"TJtDrҗg#Eq?ot{zu}!aBU? ~n (VspTS{I9q*r ($2z(8Uihy<\W`UA (|ډcTUk=ůZY;:z`Nf~=My=IWDL?tbVcɭW ;Ƞ򁎜k2>bL@ lxUQ2ʫ;dktm$ ܫ;T[/oOiZLTE>=",5vc\L΀j7emwJ\ ۗu9o}꽠{sʊZ$|`T5E%6w+V(]d2WN;mwLhE=0 hlYGYb\]NVWwĸEsdNܣuKAw6}"G/HUVx'=Fkx,ƸZSݴ"O =n&m|x;X [-la4:.a" `ܲ kyzxYm;_S*A'QI%/ cHKmgW|p2k҃T<RCb>ب5 \DV4׆̪ 0UvGbBH^qߢÂ5+>tT:c'2V7^xG*N "P LkCYw#ss|R6mO@b{J"O=^WapGRTvZ9Z4* SO.ѡDwic2UPXk)/F-88ZiC3}8BmEg?n Y߲w"В,:(ceTko{mgby׎–;CU"&^ͶuQ$(9dNH_q|o=ǝ\1.UEwum~5q:'̭\{(򁢤$:MۈC%rW\;+)ӄ%JBfuX…,YYg3 G"0'>-] exڼrr)¥'%t~_f(T\!6SU˺?c|%SU1xVv _ x]{0ݏJz#Q"ѹL ;?Ό QsmQ M rVO=,mUկy1XsnN0̗sNy 7dw,FnڵuK>^rS֏&_7lx3M<5 K3|uL2wPO)ߔ܏R'? 'ܬɯ[_DOҐ[~gٳjpGsi:=?ގmXMoT2D^Y-6>x_Pt_chxC:M_PlBU_l )_Y{_@ũ,3Dʣa_]k踧q |J1 G/6LPx!ܞc<{'1ń=weO7']'fp,K<Tz=Md4 "yO {ӌk:N~^;6PW6tXM+VeݺyÛe 95֩B9ќV+ύ~G;I EhOCSJOU(x,vfw?]ă;u:oXdҵ#Rdžnݽ,灎NgQ/f3qӪǝmMzĨ{<;ۦ)J<]%E[]xZGl6є?77^esƾ.2`l@{pGYsWĞ6s&7W.O+HfҲ:83vi/oucȣ굡:N . ԈGypƵy̶Ăk/2EO_m^3r?IzHU(rGD\5؟[>Yw`V:JiJ5S ׻Ԅ^&z1Q6&4N[}K'3fѥUć|ӣ̮0']5}rbM&z+' cꜾak9|! rʉ긶?ޗ-[z>Uk1\jby4DxJ3՘(U+ K ]jDh.Q\ϧwTH~a'l˓ɅSꇋ9ϙb|*Tb @89+كcWgUt%B:P+o5 %X vE"ߧuV$LgEG¢o[aˈyQO4TP7izI'##:dFK!AwMkYyތWdX~ .1{4;y.< ﬘r\|qrc2q‰rpYgӝ̝S:Ia5R]0q4SЍu:ңyi[FGU^[^_ڵfK;i"|={:asxFPpps ,a|NuU6E8TY *!mF (~- 2|s)9JC*Y;7Ǿ(cx"d _+ݺ?Mܵw^`pTiui)X)n8 { )ȇ=,Tzp|MC0G_J͏();8㨙Cn% jzo)%+U6`2qօ;Kg[ +^8zܠ} fݦgSֲ_{;C Cm*".Ȑ8.:dTeaϑb0Z̯g!O%,P;{hzDB8 (-P|qQnlpNmG*ݿy8l8Kޝc۞lю|6>p>uo'4>ۙskGɗϟWLU|6$H+ح|,3\Y/9 oS8?=_jt{t }Nvf2^k >}u4Gטa^[.h{myոʊt; aUf,Bj(|!}5;jsQ/<|pR31io['XN80&x%Tl+I"'ݣB[;`$ᄪ~m!AejJyg#į}FtՖs󡝚 (,U^ tQ C6}oD E`dV '=lB1OFtrGNt]#{!:vMi.e׃i#'!'0Dˍ7vIDJǕqO/c2.%q/>+ڐwlfkZ^TEMctRL˚O:cW^OȭЌyrW<J6?_BRPݵ,ιoϹ{=Q2(^H9N5J|?߷YT Un]W3O>{znڃ=齞̸đeխǮjzLsFzQ bYC+iTqAsS+( FښyIdRt8]w(vo˺o]Ҁ>[ՑƀarN[?L:{Lz=]H5 BIpk&mypа-ǹL  4;sLJn_jneC]dWԠ*grBlk-2B8h65IVS5cXҐ7, ۯ_z8tVjL0?N_7),# qQ/0=iakDZץJ25TV F[~ M>Pu.߼l桉%ˀl͍ܺ5[DrYXiOAKM/nc^_xPxd`~r-Z:vr<30ـj!xAU32LHk9f?k .<y6!`'clMv-m|^vPa?wv664 c>0.Ik ).zf>W_pu? /fdhsW^9R4yzdhar{!$5 ) `]}p,CEBY8& 4(]lM͸/e^E[5t~wWsh4ssN: k/V? PU~~}Bd2D3xZ>͘8"WV2Hqk"xro~迮`'X3hm\4uzQ?7PSdΥ/|ƣ̭k^w^SȃtE1%1ˏJ~w~W gc_?.#0M_%˖C ݿg8SIGǡoN5V]vHm8{u ٷ%II\" 3ާq? hFS\r._-)0^Cy[ vUbv~f뮜õU%M(Y;һNk%UV+`z?`41vt85r+յU|N]J,tͥHHGTӅBOH0 e|˭ Qy12nᅂK_%PW?<3_pu8R}{2&.~Fю|m.nC94oi}9rx̷w#w(;7<=F:$:ܨ7KRLt+2uF/̇vǷ̭'\tt"ޅ+g9.GJ 伅M6?+ Ny5͖܌S3)x0z/z~X/"JNZsʑO/Ir_LbNxligjC$th73cLQSt`R-~ a 6c+#l7 @$]-zszB?BClb]ܴbJ)flu$ҼHkHlt@.lc@ij. 0뭓~v'{::RzYfPI <\!'1* <{6wV;{|AʜZi7!A~!?%f};ک5|_G_dK=0PrfMvHE;*`/)0™$=SopXr`3<Ҙ1z}YA*wR^GO}}B'؂t2~ϤXah-E 9=ˀ%닒ڼ5 B Tgܗ\r[ZNZ2ل&%g#ecX[2k|8}uRt''g't+yf' ?} WfאG׼Yr}_t;mm=,aƟ/zNzdВYd{zbO w swQ|rʖ]Lw0{eμ:6IW3~uk|ڕr&A9Լi *0gX\ĚFw7]S0DrJf:)m {ı2-qݕ̓48]˽#A&T;[g Tݬa|?ڇ[bB2ETt> TWYS;,7ϘiD%@yk5t)3Cq Q7YuI> D9_+vv7QzLGANɰ5 > i0 ވZjs5"׹&8VgLZ(KumIsv^8y9aߖ Yٌ.J5[I:cFf70hkmZCrHRL):ݓ[)R#_zugޏ~/i?myMUSk^mKkzk~m0SW 3 H&Sݞ49J5S"U-ernby. ^9T˙J L.$ͺ?W\08ޑtX8_v3I*yH0|H. /uP2q̤~ T#c1gz'%)v-ik?^@QXFr(&FW$83*hZXVi5JiE7C0:k*Ԟ_~mžjHn<*Y9 =OPVn#&mR"rΠ&rp3L5tB'X $^#RMGzyʳ϶*ӘY*;*vQE3K>8Omֶv4@;uS('𠓗mM?ԋI_}18;c#瘢SPK|Ƅk1ʉ%Уm[awHPAvڍ64S&4&GAMRKFD+4N)zYyMwu|slQu9U-+ڒ;-B6j>/rb =2^eЪp|6X&Y2Llu4\<C\[9ً6̍u>vep}$n{J\,zbs29Ź.%N%>FDj ~lg*ohbT7=O]#!*;?Q?^CCˡ7zI_PPeN,F]m@VCZ;pUo5ِz1w>;i#Uw ۪S;Rtlh>'OZg5y# oFX&<u;3K+!Kafrdi"fY*!9-kXPV2&J"QLQ 5zJM|[)[wĢDBJ]+}AOH6QTf_cN X*OɓSSI iI%d׹8:To&}c;{M4yf!&أ:[/)/>sd 4h!haYh*HSj/Rhﻹuʼnt>Hp2Xqyv\c.XN2ڙwd/45ԅфg=z[vn}8+{.ָhqfBߧyv:Ek^&>iF ۋ]tNk P^NnUvb 1x>E}u54%wm_ç?_ vƲ`rTFz)6Y 4#^c+),ʙTkYL'3٨% 1P{}cq^t7VôԿ1'wRpDU>QM:פ1bH>B̽PleЛlMݱd79cZyRcI}ջ;T͂%ːbJlH;Am/ׇ#un/ |\fOOu+jÄ́6NؚWtvgʾtr_Sa`$4{o6XT>'Tgv;j{7JiS Do9Q_)'WPŸZ7cf]kiw~o(exθ= WEiRƃ⯂ْFwӞa5/O؅|n",wHKej5n0U#xyDZ5"rSrއG~(Ix HpĜ|ٌq`W{9_Luksi7|)oSgsuD\bגQ` Q_%L]֭2a$*xu|JI4m3? 8owdh[&wrp'FAM3EU6;dPݩfMWP򚦷]iR3VQ9 zV=/,nCx%tf`Bik`s채#b )RS=[do수%O[!?l_q9̭+ *i}ĀEÿWfq0] Xf{wI>B1ڍב2{9Z*N  _tUs\܀gpJ]/Ћ_"?povïjyFNQ*y-(%}'4' =^  c{ܯ^te'I_@b]/>Χσ<:~ ^꽸ڢ 24f]ϑM&<Gje/{qSDڵ!8U,*ոR,</Xf|3%Ʒ-W }dPO:Zlc>v$O@S^6;2'aLzwenr'_SɲN[jhي̤x#o} Qyf eD$^pbQs_F{>zw2@i=qA$1?*kZVY;l)ut:{#raI~-wıa{b)OvaoxdYceJWI&ts pڂg:˟ |u?es٤975fj`c˓7S\bo_I+8$lTUeLU;qa9j5˕_z,K!Ij|2ݥWop߹4e7E5]%0`N\+ζs`Xx'a%߆L6B# ~@^?DX[6 c /VY!˰>'?g3oM}1k.r_:;脩izBUV4];:LcU08S/\~^ jҽ%~w qD BwP #oVz{Do8.p U?sUPxZ[?'@wup)Ni .EW->\:dnS\w&[V6D7ra8Xl3,:ap9Q"x;g 56R,Lks7`hʇ7.[NW*}vaJ^bQ_UHq% V&Z~֌uPVxZ5cSg`S2֥]Ծ FS4lW1W܇Ģ*3x͍gBZ7&9fk&;]݆k)ՁI:qjR}vJ‰T!ezSٰt/s ղ>dVL$j=cpI3y_MJf6N}_]c=mMf䯃A*&N/:ٕ=>{ses GoH&UK[ _=>]`s*PC.@ Yd?t^,U)Mz r(ͧ7(hTom+Cka+XWQsk=JU2~M8^ֳΜ!z RJ[InRxv[kxp:)?-OK6>j:8:_%Ӄq~rݼ?TtOe)j^iSj #)4isrw^իi>R3jǣOi~+45^TtIz|;W07Nٓ"nںs׼PKBBe%fg8!eӢ8pxϬ}ֻVPzV֗je&N9?Ț %().Ԗj ?;e?=4Mfu vD&BC.۳~= ]1}'*L]s% [:]{n52^DRBD嫟EEp"R{[,m΄IveC-KС/7fëjHnS$SzOmP^[gWrp_#BIfd˞wcf&%eĶom?#8Mho_O옫(K~:Yn|>"X֩F%- .KjkpW]ЀP Y-zWBUM=5N]P lӌ s _1n\[_Z ZOw)ֻuOdW@(OӔVmX|89}Y~\5Rꥊ*/TgJدQzc[6_s8g|]a5wc%Z6 ߢsRby[4^]fMء;-0;a$d)`Ǭ?ޏf/zQ< 3z:fGgLsGjRhƿXұv)EEp}Pb(OUΫ)AZأl4k}SMr 7YŪ%O2}atLYO~xk|RN{Gbîw:eCM]:9:% jF_9~=_FӰAoo<VehS~C}w/xX}Rpe*J7&E'5q6PzK|~וqI2C ?n|3q**M2tӟT~+Hո}5M0 RcNE%lۊ=z̪^X;2(g ɐu7KWۄt,wMnOF-w󛋏}v y#(,-.g)}D Nd@ol~wTi{AϤ-;R]q^ک`>0rM=-|c{BLULp?L[tY)#Un:v;]!n^^3hEkj~]"ߺ>_xRPezVl}?,a{-MK٧Y:>*\ _Z*)Y݅̍"۱:40{Pm6)@9GL<cnp;h!]gmw| [1SP+JRU{?/98Cmǫ L@G=[g4Tz]W_N|2GllM,7?ۯG8SdCŋqIK8sťz`hjM243 B vFP$A(AB P4 : o%is$q""P2 QDA(BIA`]hhjplf`I$   CAp,wR< 0$qH8MDD "B (BxNDt qӐ#"I@X ƣQ BѠ <ƓxD"H4X,Bx!adM&d '"lDBF$C&p @BhBp(C`D"h$ P5~ %@Q$8Cp<"ODD`1d2&pyFcH02KF I5rDDcB84H&d,K5Ea!?QFDBv#8$CD@ $!0D%DD Gx F aqP AA> p8 {NDn< !h%#xBapx"aHDq3d(4T"CĢ 8pTAD@Q0$P8-NBA%I( 6t {2  #pA XX4d,@CvC.lh,%p$A0A7]0$(Naga-<BcD'$dh{(@($ #E( "ap 8<#`h]0b)xHQ„bX< %1ǀ{g? @{E#/p7CP FCCx aa =< .hpPH(ð(D< C&b$^J z@H9cD2 8,)8# ($@`~!w #0E@(DBH0QXL(8l?􀐻B@@IH<t[\aAkD@p(a$ !"h@d<R'B ,N8@Шݐ$A& tH’ p.q = FF@Q_@1 $d4 XtP= = $fOY $w* P$BA@= .z( 08('(M$A1x P/vh==]@d%mH@ C@DX@E$H8 `H$lDB!xK'vC.zH4!&"q#H8"Ǒp7tW.zp0@D(h8":.B0 wC.zHDй0x"' @< ?z!n p; B@@ OƑ d"AB!Gt=df4@L#(ASD-D '"C oQd$  m`$4881 @@AbvO?z`D$ ҉A$a8"X>v H%oB(c x@w?b{`0hD$C" J`Pa2v==> !`!0 P 1G"@ 3j?z`=2 ,D@x(47<O>I(4lQ GlX }F$p@Tb8?MI]@qfP"J1@X\ ȀQ$U. JO!a#]"ǢX7 ahj8(2b0h( A pڭK@@VJ"`xq@chݐq /T(&S @c@U" ?z!#!$pyB81'FbP@hjC P H: F.z>K0@=dϱCg@!Dr{7`BP8< " I(2nH4u(7 !!{)ۙ͞7#v8rwt8J.~F G#==V O@g̣@P$y$<0h, (=Ь)JF@!8FA@#N-"A,;hc @)c AvOѳgr`@A@w^`9+ djuԱg J&KLW; \x:2%v (I@aS7D"8 ’@ X`wʊ=н8# P<am 0X(zOѳg88]4S@1&~C8JKѳgJ C"AAoE)AC:HqpѳgGYʔ(B!0@ |9$<(g= P--` ``DЖh]1=2 Ƞ7Bh`  Z@y+>{n,`s(D t,GAX4 (s왺Q@P( b$R^|͞h $n@S0$ 82!d lDW`deȌ"3Ācd<`G"0 X |2lž hK8PN2kd 7 ({b=4 'p1ў9$09aA@;XЅa(R8>g GJb%G$XO4|,{sD@*Q0D([`3Dv5$sE8x"  PX D g v!IgBԄ@x%P=1 `6 T"_sEI<{!?4ŸFfߊ$m %Guf0_/?0P\7&-SO.n5$ݓD,'Y@}Mֱu7kI*y:]ɂc[`Np8G^vM[F=vrS;i_tWw)4٥YmGF xk)c>)so%ls& lkoB5jEtD&IX@R -vdjԢbw&]ȳĸUq%}z2LFJJo (1{s'<GU ZM|'$br7y n%Re~` JBBKsu_zBd3; A8Fdd}b̿ Ԩ8Q0 x~1B*X`V^b,5N7\ tOia/ Ԩ6 T~T `I[`1u<95vdLQVªL9!|s's*gǍ[[əTd 2{aG6v]6B]b8mA,F&rFmn r;m~1SƱAy"9$2wOHnxy Ԩo@W߫u\3>ĕ3i|ۑQNPZX3OTo%J)g(d\RQ:{侀ig i<l%YmG׊=s>{7@:˥ccܛ` zkLz]Q;F[C%mGF+3­!u >ʁr1ЂIaP,_{b;8lqd|Yf%Fزs7!ul:I`RiN)ޤpocHgFu߇Ψ'K親Úެ#&?A I+è󨄃/m3S #gݲ}t(LШӀZ#S&G$Pi>b!#o1o>C05UyA_ݑ< ES?0kԨ[(i/Wst-|ۑQGvNjDcAp9_ڳ#Sni-[9MjH:E hWێlF]H օ{33SukͿͷERMo}y^; Ԩ gR\+*]uLWt9Ae6aG&/ ,$mǽ !{~8O;㫪&A2;Uw2#GW䒉gF{+‹R߳}==tݣESah[ˡ#]قۃKE4g5vMڅw$9͟&p)Pҽ o>]aֺrv|H^Mmg6iq9߃s#a|M^y]6u[E-vj{ ֨g!A57,,}/G8A$7!Za=Xbm8N'& ԨZ]X$g$%K>vdW@J>EQ 7G.=F옶b& Խx^}e.fYwz\i`'o;5tnz)q݃d=n#X3DS&qxWo0%]D0bwۑQDs&非|%ѻ8|Iwۼ ԨSUV[R!>r59=9|hj\NA㪊ZTkt .@o`׬rώeo-29 o>C4uoξ-%@CK!^Is4i1s 99 Ԩ_Tr. DZľ9߃{co>C6/{;\0rP.o-7!TGؑޜIx o>C45jrfEݪnW*9؄gFMxw]ˢ|f\Њd`u3D@<1pEC/2q Jx9o>]5|it@678$qaG?>c4l~ˋL#6>lTuZ_3`{C *k\$`dNW^̈qM}) ԽoSV~}Ex 1Wj{VYmGVm!%H ޥBQ;Г_"%?|hjjͪ0vԏ;/YRM9[quo /8@'eڕߛ$q6SKo>]3ʂg ;H6~{8?q:p X|hA*ECBg{gQXSyX)WKԍd@P5pG:{gk( |>NIq6si o>C4uJY`K$˫z7֙8U[63DS>=/@`ƑY7jVKu ֽv8Fo3䯶o>CL!})Rz͹8OF7!4 b Z@㗘;05vdjԩ<=@ [Fcp"= vMIrIaLw~jo>C*?ERI˃KMuRD vvddo/f| qjfIO~b9SwE4>Q/ Jx{-},/{3 GxE/Kuk?|hjP vȮsKiEcrńp?3$S,x$ hDByEMNVoiGY%)J=՗tk+Tv1o>C2uK^w$E:Bo>]Su#!"f6Q]\{6ag{WÛϐLݛ΍MjnZ":l_A0+\3$SܥfB&ǨJ7x1ێ,7[RwR7$_Ôx8G||{.Kی0|wT ngo,< ԽK&IsXy|mȹU3$Snr#&xXH:\?̚o;lEc9&7o>CO؋oK}MCYb^E0kaGރXP%0N48b4o>C2uBJ.B+77.I5vde:DtR/._ o>ï5'ؘPsL O[ | k#z3`5 rC)BD"Cly7!dWݤsN)]9+J`o>C2ub1AGJ:PY6|djԚCC޳mCM]䱛 syi?[ʋ2da\A ڛf?bӉ<}8vz`yH1\]Iמ?^iLM<ە^2~'%ˆvͷέh ~g.(M >.ZӅQP{OIJ.&m\)$ɜ7!Yt2hC$QU8kޑ. aXtZ6|djԁx9ppda3@(j:7In̻6zFQd\A?ϐL;G)NҚmr6\IEJkԽ%Q|0CJP*<8 Խ9[ktEe|CV33$SvRyyȻaWS }*@'7!YlS D߲%-勥.0~gHF-]ř&zɑI}׃ıYmGfGa]joʜH8 Խ/a" aLɎڔэo>C2u<Ǝ%v0zyqbKfͷ7~SI_ߐ&;N33$R0 @w͐(tmdmut<4œ7!78N-RM/{vdj-}&Hpkĥ9$HBNWOXgkwBNزdpq{|dބۂ+.݉@P# j-vcuRJRyG]?5m9etfͧeSjU/1jX&FwD4k>(end'_UG~6|3d[^#dgԄ2ϞQ~1\~6O;ʦFy6@{SӵKMMdȹp35J9[W4 M?([[ \5~vIurSJoiGX|rѝ&U65NeQX)o>C6us4 3ȽC6uo/LNX8P_t!DZ7֬|l4HkʱTJSIWJ*c*F: Ԩ s&c1;T:T: yk4@f)J\`h7|B]QF1YmGMz}W&h'2-v2o!gxeX!k|ۑ{@0dUW HK.ٹX]e3d;nSEkRDH I')|ۑ{ş4ak IU*-:w [-JD;dDKlA&$ 7RK5s|fn ~UE^ 8{2:>#SN7D1Z9Un_K.ۚϐ-[mGT*6uao>C$l:a a{,ћϐMW*.'Ll 3u@z7kĎ7!w52sHL _aFc0 Ԩ;u_ԫϬX=;mGL} kXv9g.eK|{kgHLk7|lcn%b.9N$P;?:ϐMl:ZO쯚jR{|&1KֺcgKWr 蘢)Yf?Z&+$nh1 '+ٛSw7![l= Ήvnd4T3) ԽXA-oWi퀝Ӿ Խ5[UIFMGՄ$2v/4l:s>|ljjEe)VN5Tk7![MɌ&K]qؚ35#x^>9J@83@'Ikj*Z3dSxov@_k/f,4i!o>C6u]kH{ 8Z̛ϐ XfxNhl_Gj]i'۾ Խ7I|oHZʑI}?L[w5!:0V*|E۬#Ir%O@~ѦHJS ' Ԩpf''r'5H7ךzZ`ݺyk@xlN=Ho>C6u"n&E$Tӟ:zfͷD˙(nMT);-j3dSVRX)!)~Cb`c|ۑzW%L+,vda|nzӛϐ-7cW/Բo`;e=vd5IƁwA&3&,˟k:ӛ`&9?l\dH7|oVX}?b .n} !"fd) ~OYgȦ-0.)ㅖenҾ jq6l.G>cz#n4қϐ-[$2N^ pBA,Li95|m^'`6"#t2Wfmzr k|AHC}. rG3gkt̤dH1Fw^k~zw\ {{^z %; d jG4gȶZr*?~{ i%NsM|k ]AjU$Q)AbNY0͚o;uzZ{ei֙K2R#8ZPzQ}asۚI uRpR5E7![nvo M.{%rCt@>q6|bjԫ{^L&wIzMNS0z2|357K3 xFә3A3Sۓ=kQOS PY& V%53[h  < ;¬=ci|Q87wOh5KJO nLo>C15j5ZA}X.~nd-2z]-gk2If fhX`%V7E͸_ǔ(Dsnm"ؑh}m^rbSLHoEn-|b5IؘA! Ak̚o;25205ɬbDZ{.X3S.Z@9u{i׈:"(XNizQkjjْO%_9`#f&ɵӛ`&ނ}6kL@ }: N8+A㾩Ǝ|bޭ&[_ZdFruS"7.nӛPLh UmGh5H3vR3kԨT$@"6YfT^o>C15}#IŇ2V׿33[Q~E:Hu)t|{GO)$o;2uQT[(.I/9]U̚o;25j: p՘+YR.ƶ8Go;25ꦡ oS)JƤVXAқPL2X@w([E N/H|Fl`TSGQB$ yUq. q);&SLo>C1u6X`nT'qbȌXPo>C1uo@1Z]hQs΋,+A$BΪDv4g(F p[dwbi7hlw2F)}lяm4isnH_#ibeb6SgZGHo>C15j'kFy b"q& vMWAN^u)0vYg(m龳Okw77 S yfrA?% oYmGFEuߝ\Ώr5bh"3*1ozQ5;mj!۝Cu0wta5v̚g/s5O y9cr_mGF-3I$!baID3(r}Q}ЇmQ1EBJ]Qr=|b޽qO&&/4hCjFk. Խ5RA Rn0 R˽u;o;2uo^SCvsTtZ򛕥SPL9@)49> ]ǂP؛a?y5afͷOښȏPp{A^q+o;25Y5؃+Yln>4f*Is|bjizU]HH$jV+[[{Q1M@7"k`1ԳэIo>C15jҏ];'<,]DR hޡӦ7+|8|0(ur 13S>`2][6o>C1uر6VoF7)|.31yHXĸ7X-nrw)VHRjG؁+ĴƯwۑQ_ue[9@n-R@ϯ9g(FݦF`X߲&iQQ͚o;25jr jc&4ERNێ- R%aF_Euo>Cާ,¦RL2'ku3SLC #d^D+zɸ4v=#kzf!@Pǁ a]sW&17C5uywNݛT> 3ӎfߤ]j }ju6M Sx{J`)rs}Lڝu :VӋ ԨCcSpVJ_w5C>3ٜL\~Qkd nI]3L7&UPs|ipԎҷ}?IGj*_{rFJ 6cGgkvT`$4}"'fͷYn6 [$6rRۊj\׬)o;{7"86%tY6kԨ,\> wkpksj#q7dUuI.}ۑQpU5{iK>I.XY>ێlZ$57譏(Χ 4nm35oTwO$pihƻ 5kԽE_4Y4JvcM R24k΋dծV&RpCaIzIfvF'? [~HHz $ amMEu&Sep5#wA$qx|?qAM_y~Q {%!L*bh)O7[%844c*4h7 6RKJQӵ}fɕBYvvdlZCƚ# C%%=zۑ{wd{JYǨ(YYu8l/ .cGo>C5)Yo(%"m]{؝;J3, Ԩӕ;@ɛR" ̚o;l41RS+$ɏMǮ#[fEHآxYm՛њo>]+oO⑗HSSVj,[Qܣ:=#  6P]_7FmEM3kaGF[STN;`0EuMk+=Ko;2uoݹ?0FZ$1!ުK3k8 Ԩq3d|jTR ؏nE8ێLڕ!?'?ǀlwObI67uc~Vs|nA1L=;{5sPMzWx>zM@*Bo>C$NӴQpvlsH=kmGF(:4iH*]?1dg7u*{9Fpn]8Hb8o;25j l*,3%=b)$αo>CZ܍ԈG%b$ES,8Δ [͚Q8d"/F}בs#\hpT+{ԽԢ(H6xhs6| ֽNl& 4~dwgN@R4kԨJD-j"KBxJIM)o;25j 4^-4#YĀ[Ȯ_*Jp7$nP ʓ̭R%aNJ~g 𹓵7wmO6ji p|.g84}_9_fͷYM5_5+P*.a4mPM{OFX!-y0$Is̤)o>C3( `Y!R$Vco4;G, Ԩr ,Y#xNnʤ̗o>]S^1ئH#Đo; na|ۑ{穼kb(~&'Go;ʖFtZl;oڑfxO`VR~g["5Q|h!C3!Sl3TSNLD]H,N@,1]ӎ{pzc4QUSzc@xKk>w< nlJ޵nT>7u"Z\M]x R0 3-iHR ^誘@ 6$KLn݁fP~Q_Wo^ Thh⚒izHZ>ӎ{H퀔egǁn9zgfP7YM0&Iȳ-MtxӎATN{ӥ;G3w Խ*.K1~}Ƶ'sw|fy*FB/$\x?)+/7O>vd!+ȹƎL]\I {J9}η(F#Cn㳑p9mx6פРKL,^fv~{]zu[&I1K}$AfͷVi UIE4@{j4ͱmSU:4%71gh@8X;gJ]!rS&|fjԞx=@r ] }$7i2=d?zߩHJxzk9E!sDKIHq4}w٘|fM`Lb}\^|\ct|fwtK^MߒyOLav?ֽ'BIF\4r7qL[V}HZ{YH뚳ɮ}η̷L)J1);$=Ję~34I8ݏȕa9`G\meGo; pUW޷&O՞5}$ _|*ޠRs@"̻)^34y 5] Խo<[R$T Kv]yo>C3uoJ<'s88>S7Պ,Ͽ Ԩ/Ѥ Rnc8j֩/RWmGFY8o`ěɑ7rܗ0m34S.;Hh}EM7(oSW(|Do>CZԶ4[IBJ𸔼݄9!fͷE{]f$#6oq3{H|w`77y<xi-ޔuHA݌c34[H6A΂curFiBsW|fj_.#Tp."j;h7 41ƭ}5*KUgrX*yyAjYx(Mkd&9LHyfvN)&$1jWSXz%~|ۑ{ctWOdwJc溻xяm#6~(BpsS_wF Ԩ昏kd)Ag){M|ۑ̝m9>Ԉ1. ĕfzʛ`S񜀅/4qlb+mf7axiAAg76IdtƲk(;)UzO$7GݻdؤykʛL{6.iVM{zkh|ۑQw#NI>Q I()M1Z;zQ$O PՖ]J$(wێHIF>%N'GpథYSfͷu;!dZ omCgkG8CfvNj\7w],2KRE d:c8ghV${ʑF8)P .%ǘskԨ}fcoh(߶.Qd0ib|ۑQMnڸ=R#Q347Yz]rxi4ʛLZ"QӵI$>hq>ێfNHw?P~;˛LNuD~ Nf}u.i˛в3cG9ӈq"Af34[i]y rx9Ґƙ:Xyf8dEžkU*wQ|f٤Dc@3 ,qJ5vfͧuS&v"dϾ[S&m~IYiGv>FH>ZMC뽫Sc)o>C|oW,~ unpLw&ly{9G=+ebҴdD1eiGԽO_AbjJ,J~/N ~ϧuS.ְFR%# rbYv7gv^$uhX4'Ht ]5E|g^|njRؒOq%DN@l邺گnE&5/,Y"q3 Q9qx|zbOF1bj@<^o>C7uhTw5;ƹkX5kaGET꿤 s9ێ@g= @9|yH_GЬ#SlGRL1BrRlq5&1gFHpI@SC{ fco>C75j ajfJQ:.:F]|fר\rD|?Ui|ۑ{knG2ES"`Yn6wۑ lV- 1IWhs(gg Un4Mgvwo6p$l|nj>e'2m#^6_t$$hmGFӥ$5f1 <螧 :c˛M"\sIO:!N}6 v m wMBWs6`<~l|ۑ{GE[d͈^> Խ.rV`SIR ,jћi'h+bܺtz䄕˳Go>Clu]1C%B9fS f@yQWtp:TooBȪe`SϚo;252>!vR]Cuo 4bU)YQq9]9o>C++ǩ/nH%Ĩ$a3tSV8qq5UȽܐ$r.i|K7[bS6["0+K5ˬh5 Ҝ.1r4hǗ4~92I|M05sր:%K\L{f΢ jxjO9i#S6];JM K`;VG& ֽϕbf%U$p׻q03tSYSGNV'7ֳE7 ˛l%$`.7[lwQ wdQ!<[7gkN`t fBRǹ*Z殫dsԽt i.AԺ,xq Խwtӽ0 u.%kFgV7kUz-[DdC?HmU'̚o;25]R䪲T=vI+E.!kÎ<)/ukFl]Dդ݅W6gV3|uCG䇒z13tjVS@IGGz7[2$DS2hT /{vT: / Խ5ԏ?swnQ5u|'ǽ Խ-A滰1evXs43tG|Bq,C75B`MI6n!|i\~Ϸ5hcDާ4&g!HC8f?1wJ~d8x6!!eL3:eÎLrӰOtn8 vؑؑZ);,M= [^> ٙ7QH"Fwj] _qGh]9͚o;2u\ev1: M<㬬">ێL[ȵ\!p~3$4ײr2}g`M$]wHJyī4 ŠZ⓹O>}@^"hSӖ#~լO>k,U6\Z$ j/ێL[&r FnAM GEL]> $BG҈<\4kYmGt#t>C7֏ޱЮ~ '5M/J+$< qI@eU%8|38*'5=v,WSj&e!\͇;ۑ UƎ|u:4uh&>N/)e3 ΝW"DxJf3g&P}`oIA8!LREێ,7nO+t7⒤-0R*($Ip.d͇VطO>k;hL5&T igJp.휠okJ ~XN^ 5t_OƔ0gM '> ּJ I.ތ79*ɬ#SI}bD=cHD('ێL[8D!͍bu|\짹)ұkjdXM4I*h0:PMέaQʁ:&i9{'ך8xȊGy}ߒ-?E|4wЅ*19D]E)u)shXO0}gPi'HP) %RKoOjIj'#i fSo;JoBQ"HTz OLu'5~Hu_Q¾pK374kE5q$fͷYl)v\.5M sv8X?W컿Ԩs%ï5@Uõ )L]?r[f?pNF J/x41|T>|ۑ{OvpĎɑ(K/Hb{3$޻/PwjGS-eK!5vdjԪƸb#(Rwvse> j,٣+ץY"wה5(c'L,~Xh_ Q }.9E#)9*w9vm_d `yV` k">^4 ͥYmG [/r.HH~5"4o;2uo 9o$Ddd OMjjgmGF]Z!%7l ԰jiϠ+6Y"|Ɵ^z yNؑ3Kݔ+LYN|!9ҘE!|l mSӾ862/0)m=|j̝TlW?" { v@|0gfė7AtN]:g)jug`M)+{$NnaJ;3sϠ SQoZ'I8[,= i{DP%]S|ڑ75-XԘ.iv k˜΁O>k.\h_1 8:gbug`MտH%¬Қ^~'fW~S=X@9'5 $oPoOA # s|4}3^o7s? &#IQYmGF̗D GA-G#ɨ̵DhNg`Mg_Wj$i<93.#'_'5N>d6=׸ECzo|ۑQKe'] R>3Ql_3ZS>fWQ_Oe[rڻz%;&zXpN@_ gUzºlpiXPn'5M=:?쓮租Q8*I}X vBmmξ4STO'? iuAߔJJxn@V)ێl,))Gck5bA[%ą<֔圴7j@-=M^9]r hП?i|fyCWòZ "$av?k?kߋhF-Ba Q3ؑ̚j&[iN]y|-@:[~ێLZ6]wo%I9'3xSDB-7opSV$Lz豴75n㌈ȲR/)sԮYmGF^n,wJ~W`n!9Uo;2ko`f% 썚wq3K5|oC#gq,9;YYfiC[3ڛmݛܤxΊ҈}|G,EGio>753|RI* @{;s>|ojd S IMQTKێlc^ V;Ι5#ri4WAޮ}rdI5gTЖT7)rR$/LUJFBdE\3xSVMvC%QE"1gF՝h5A-{jl,@h>7[\M*f"Dxn89qȓ:w瓛33x.\ĻEZS&?>ƍ`|ۑQkiz  $0wu/KY|Q_w^GX#@;5tێ̚ ` 9D5 _;vviڭ]>#;/gw:[>3뭽 jhr,g }%iۛM}67z5>V!j-C|lϲB0Qf RS CLS w6kr=)݂ÉO'%pؓC=zۑQgjJdPm $"X?3xS y*{1H=*%*YmGfM.GczNBtI[n,7gk8%xE~ؚ&oF Zs|o'KRؼ7T$fͷ 8.z:XI4 B Ԩ"kHPBbv6l|QZ^Ngpĩ+D'/ ? Ԩ# t01&;bZMZz{욁؛fQoXU"p{K^۲;2b}-WI9//5C׽ xtεO}~N-kR|`jw&Dж5|ײk4!ڛL:k(UNTAf{Fz}Y3Shu3Nxp>퍽 f^ꊦ ^BB3IVۺgSho>]3ՠ+ŲrT"Jyٲm8fg}BČ# -o.Bvw7N/zΧS&bq9fݸռY]k-YzQ"%r }6QngiG֨$=wcX =%~63g5 Sen .8J:qScpSmo>C05˔pU g]R&OrsOhJsH{u{N|1a|G/76LхkzBۛWqWD>Q3J7kԨKդzɄ/ku5NI;~]{Qwr@C"l9X5\fͷjIYinA80GTZM{Q 2SR5kH o1>gF=d]ƳѸь^*4hBa8g"{gʅ!3EinL{&y=aS{GvF Ԩ5o ,YE5cٲ%ݘ5vl^,YOG5kjA|4>#S&n;D>K_ebڛ`׌rt6 Sekmࠕ{f2aLOfI3=$+hTP/#SKi|$zfo$_s Խ? q+KN"i]r^Ufͷَ@vrx;ᛯkCSp6̬#Sq՜+rLŗ6Zj7!X59+MHk5ud̚Ϛ8`-Lsj i̺oU}ηnr3%J6H_r$j,7485["¢z8#.tjg-!=fg|$IGK:JQOU zf+RlCnMHSUå73;ۑ}wөbC۴7!+iN i D "ێ̚SU TasԽ&[<HA ig^{|`ޮ8T[cZ$>|m~ҡIkԽF0A5}wtCҴPS3S&>֦^@!xH2/t 5vdjYLQE95 g6;3qCES!<|<^}η5M*TT܇JGto>C$N#VQpGF[Q?eg$U zi`B(]rcGo>C0ui.Љo W-&zQ x#%뭙1( \3S.Gz.DC05j/#&-PPuF%oKo>]]Tg@oH.h ŏϷ7!7~@!tuc4-)72#κf;2`!/\]bĞopEwvD͚o;2urDdW$|`5INQ1s ""Q{84b ֽH~}RvZ՞m#>ٱxo>C05j>ܔ]L+1hbJ\i'o|js~h|3h4ʥb7=bg&`<[iNۍ(UqHJ|`IU_ݏ)$kC!$[+{2%_f❲۠?kaG{OocWd^13`T?RoKT)JY]ѹ7zgVDzGU宏 W ] No>C$G"qo685LJ|{*%\yqSQRҧj1o>C4uo)"C4uoH \&8Dh=@o!_<MdGmKA'VVNKFjf|hjԡ+w\=K:J.능c`gF>žEX $^Œ%kͷ5s?k-Y>frWj'B3DSf+QQs8Ң_Cr<Έ͉fێlݻfy H3fRU?;'rRn|hyI׸r4M!r1zi.#t!k{.ʍ7p*d2ms|hj7&MK˫qHu.݌Oy@_(-;%4yM55H4G* ;ޜ7!h (n,!8Mx{&,v$pӐ{o(&ɶYmG#2xD*ʁ:P@<m[*뚹zRk!^qi5;3D[&:^`Cݲ"}+7!5~W쇒Nx̫t$#& Y|Y;S-YfMJCy:[#;/̩❓ ]|%RGSadYgzOMAC4uZB4HeKHfNKms Խ/^^"H ?WI)LTQcb:;+RVm} nafMے,DLv}}?ACZY'L0ߏ,=t&z{kYֽjS>T >߻#͚o;2uӣԵjVΉᨌ'IH}Q\B#AR/$͢XM/ia|ۑ{LpV-;(U) ~27|hjԱu4Zs"#; &F/ v9$޼Ԭ:ȳ5~Ϳ{3DSΕIImh gG5vd\ıoNIdC45j JW>RYfnǏԨ7*8`r"sY\gUJ g[=N=4;Ac9إ+I/׼T|7!wRkQE *N^')T_:egVdɒe.r!$OhA`~|{8ںuνZ5;R|}ηu!rbAwDVqns%=\;k Ԩ30soUQgIl|p7vֱ{~ê1=f6N$=}?ҟh +~yOp|hI#RT-yt[yYOJ394#KZ$}no>ClGԩW T37uo>C45jNրqASM7+G/`o>CNo=,RG1AI^D&g#SR]=('%E1_Xx3|nkj2nSʺ4"MIrMgը}Hl'zp`&5vd=1٦4PNwkt̚o;2u+dogil Jꢷ;2$QXWJLS&; >&|dj9T>yZvyGąKOϐl84OU7S<~N^Į#%#}QMvJU{ $̚O;J]$ժ8"I*l -YiG΋ Y(e6͕H-<%[ΝI}fͧ%NƳLif /-;[3yf7!FϗJljTQpj Yf\߸Ӵm3$[8<^AKs$oeaG8|dC9*T=^)ʑ &qv]QѺEv^(5s`!k$Y;27 8UR'9qVo>C"R9fd/cgH}$tgpK[u5P:ÛϐLk&$(L^%%%;4kfײoZ MD!ͭϐLz&# 7 |> 29sa|ۑQ}Ω(=@rӾ v{2\nN8"?\ێ/{te ߛqΗN˲mG]jdՈrEr⋥8R$̚o;2uBz["ˏK=^XfHE T#dR !k5+/?mÒ̱k>D"ʒ/[[ 7U۔LZXAGRtQxv"{__O%(v`Qw=$Rs;f܆+oc2o`kSʷ{)T ; L6'n_톭IuǷɔ耷8?<AI jpKޠY-/~ʿ-6(S%HKuCbg]㲋-TG#=yo:AoLDmEԆdՁ ,CYNvlcE.($ҥ/w,7:4.#SNEY2"pǹbIf4 M E(}v5-u+Db|HI(so%됤/*1ĶZ&Y8IE5m֬xGRǪ-Ty,<I;,6|~iv4dHz8[̉w KMP kѷEڵDnA?y zͽPU&}oV^M[mz$ђnb>|o]T Cw;HfIaܩJ/f>$S!,껤%9*8$SϞ6t=nyǂ7! Sn( ,9I[:N$dUw qҴMoV9})i/p30r8WEgn9]_E:=%!O8:Iծc6oEr*=Aj Ǘ,`qlz3 ?Aw<2۶DBU]e}S )k'IҎ$OīW5Ba}ZTu04|ibe.k]YiQssү$hc]9W@֟YTEo;D7T5by 2AEj17IQ3C3OVû*UL FL-݂ƞ W&BdS0 gՀ'lATٍ}@H_鮲mo*D%-W L\Vo9WVNN\'â_mo+I=RL M+F:xx FHZz!좷4RkJ\V5^gwKKٔ͛2)^OFuk\ wCdod$7sV!~8[!u7!"yjx$}_gۢLl1Tw+ y *+_XMȦ̽ ngX -I .(Sv{ JDUk:tY*iٱ_e7)"BwۻW@$tE^c=A0}[)t^Zt'(?לMߴ(~* #Ti|"yΝ́$J澲\?{+U#)t{@xbLc>Ϥa8d{ofDiջq"O 6|Y`ҟ͢Ll c6 CM#YoIJd+]sț0SA5N:a}[};HHų,jjjI7-eS=hхqwGQo]%2Jj9kY/Kd+ES#.-L{IToD'; 34TD;^:Zk[MeR~*F~hLj7Mzn}[-tKflW-*x&'Ku(oD6!1sĪ8VQSK.([I` "[z$;/?u_}/o՟'I](BmsG?G_}|_~ٿ/_o!$='^TDq>@s/ehꏳMhQsZJc*emI 4h_{hZ2jpiJц~EV4_7ך\-RYvpBk {3YbXa  7,hI AmZ/ Gh>M@o53DW' Qzs@AAw;xx*Ѵ5+Q 3 eH:WX(ϊeHd  (6x,̥xV4) Q"{jMF\ 줠VVĺ6SŸۧ;W4aE?zb#T?uD{]0A%}^ <m?5ljyMM4BOK>nJT$<ե<&N\;6Z0դBθ LxOb!".E!2hm7FX%d 1Iӓ>M\^d ZiqX% D %ߖc5z4joXt-A 8a:/hJj59_T(o$˷/IܿT[E=<IGӬQ [%ͫ0]pgMja34)BkڇO,4eTmoU!M`ԛ\iM|x2XҴ Ƅ[1HeeհIMz. bI؉K$IG, $AhLnRϒ/aI#jSP`Qd &ϚÒ O^ѸM͂3^3tquN]Ē&=ɬUb8?j8ϱ}ɚU%aU ].lOOrAVNIqkXSjD'z̵BC3;]O mC'B>9?,itIIW3ޥt:l5srΰ>_K&Qũ]S[)C'ɭ}XҨSHRRU4%aRuuJ7ÑUs%H$7mo &7Ne,KgVߏ^9GzSM͒o5u3ޜ;`j7ۍ?Y=ҫyl\_ iͤ", ExrzXdH&.ΝrnٵqƟ4,ĕ ZP,ܹ_I?ÒFA8=9VDV'1$'ogR@| "QWY fÒ|DVK4Di Jpz\?<,i,SgzG.Dx8%z;t;e;z[?Kǔyf'4%񠑃A61 H𰤩1 \3O>OԑgR]Q<<,iIR'{p ^)z͑"0;OK y$C2Z~|[_ w-cZbWy(ғÒ 7'ԣѨ+g50g?܋-z3IV3^dTMITIDTeu! d.ŨŚbQo{#旘r蓳Òz#\ɺGwΗ'c%L^)Ɓ 16M!ulFǪ |C ]ْ띸1 1/љ&8; j -z8%$k5܂'W%u#Nגc Ooj0>uiQ7L4|:&"<DbkY&tX*b.e'I9NHWMtdzwzLepJfKjXL&xrt.&i0Iwq@R)zs}V>nsd谤1fJy( ~kF$8An|PN"zuBajkd$*E~eK/T M9DwMtcR&D.6ĥK2N=r0Jsbo9~JCm+=T®*i>ؔ^6[Nz/id)AE"0xI+1nbi[s[8>DԬ |,a' 4[/:j:7c}@fɷ2띖Tgh]ojuK]tSU= {WGCdA¸O{[YWX~F(HS{Ik=sΞ=~N2mz\4?9k+^y,i:ܯg';i? In Ӛ5cn]2? .dfcB~WϚo2e7>ʔ-!HVqLZV?J~ebY4ɐiT]lrM(ޝRU%QsrN.4f=.C%]itǥ!Н\zm _>iYiJYs, D-@-5)s^5UR8kz^Dxt/Ȩi^~kM|i z|r: ;1&Ԅ.5ێQ4`6)`"1 msݓwjX<%pԤ,7V ]3$},%/MlhiJn|ۑzrmHX3Ye;YsfͷY PpgB4p]\WwVYf#;P&ZC02{%Q컿Ȕ '';yJ >kV5|'`;>!rAx޽?j6@15:u5%37չHܬh?WOqR! K۰wo*iJq.IΒ|IX˼M ˇAT5:~^497'GA G74zhq| $pv7a\ҋlv hi&&wOe|M0hC' r4|%?xWg5vdluwK-Cڧ{ YU* 'm}zCJH(R&wp(H5ܬ#S< );:cj]S8`ێC&(WViۓo%Ҍvmhqmx3)E;$p(>5 RqTjҪ̿"y޶mTu'ה*Spd5#D1' qcm>ATIҵ{mk曌M52$ꤹ.-AcnY5vdʑ{QW9;|Iub^7zq: ?.10 7F5ӨDZ..X}η"ڑS#M`H}@p %pM"luג>mi{ߔo-4GpW+=}5}L|sSnBT@$PY R,Nқ-rϢfј@sǧ~kr7+Jӭ)ݒ 4M6)ޛ5# 'I ͯU~ yn`6kaG.]K !*نf/\~4GW2#0B"ʃFNoɚofBx7xuRclvͧíqhMb'i$qbonBs O 賝$Y:&a^QIX|Qs XlHL^s>[kZ`'f>>GL!}%a2ﾩ7=j݂8 -e,xhi*,O؋AD+:ES{T]oBpVlRaZQNWqjG%T-7C!r/{ ("[#K|6) {5$z穄<$O-I:Ŝ7G!fĀ7Yca-g]|oo;2EdaH-rulLY9!ffo;2kTū>m,6}@Rdpț͋tr˓pc<*Jm^l-S4=n8 ?)%KtAM4;bDkYMT6qu5DKD3Ŀ TkhdF2$%X ViCFS)%oM^{HF, !IϪ ԒX:y[S^W}ۼ vM7Gҭ}œ{h#6?zSfrw/5:R5~MWB} 5cU⮦+͚o;co2@Q`̿ ԨItk؈"X^ =zۑS褢K$k0_/?@r!)#SO.n5$ݓf, ޾&:훵`\N5W$[%-4۔[P.nr7yYUNRW١XC:S4$h>n]`+ )?2 ^[Ŗ7}!Q' fmpzm%̿ Y3TM̵OYJIhқL?j^liԁSQq6 ԓ3WcZ@`Dt<?) ԓ{ˣ~iNePJ'̔3œ7!z2v{ܸN[IEݢ ;u}$e{5vjḶm}¯u[ՒQxNQ5,ћL?. *ݓ-ck,oC̡kf;_s jf|+#gӬ#SyOTo%(&g(d\RQ:{kyx%YmG׊=s>{7Nr"1ekݍ ]"炖%~n fxQ_u^@t8'.AlLf3S^WTuEyVId{(YG;a!u >ʁr1ЂIaP,_{b;8lqd|Yf%Fزs7!uY:ITȮSҽI4!ǐÛL:JQOuSUaMo|ۑYϟQbayT|{qR#UO.I95nd|`j9kX"JC0u\|F$6{iÛL0{:.ŵUtoHpTlsvdpBv{l:N퇳h9oIEK{ ӕ9 L,o>C45ޫ_^ĵY=(Z0Mvđl"A3c, Ԩ]|GigIN5rhBtD͚O;ko Z@Vn]ɫ7 h}Ûm$B!#L߃s+#a|M^Nyo>C5YH/5e-c-,}/W4A$7!Za=4o-4m8N'&hf7!$Cd$'n|5M!"jt%Egv H<{[h̝"2c]|kgsM<JY>vL[Ar1|h <>2hx}S =JGs֨Wnv4|Icq:M=n#X3Do"gC:k+$^t窊amGFgͱ֛wfI¾i,yQ旭pgd>r59=9|hj\NA㪊Z4t-_KpAz=|f m ^]yg^xog_ݖ %V5e^MZLCNo>C45j`\o% S#~fjExy18^54J8}ބP:faG{sz&LO|yqd`n2[I7?|hjN:,@ pXfPĉ 5vdy7ٴt;oF7o=Û`CB')GHQӁמ NQ UHs7ՊY"&ێLݛ3DpU JC[t@+a›Mk]Hm pdd7!5M7u/D_^ b^7!5qhv-qy6f M+3D05{]pEC/2q Jxfsx욞N(&˿;'$7a_^dIa7!s42nPTX"#uSz˼ ԽoSV~}Ex 1Wj{V;Q" Ѫ-d 5l^e5RApWo>C45j I[fȁtR^ ǝ,ێLHa 2ꤴ<'D3͙yVt䰀mDH5dKܯ͵|h1Ρq7Y=J!nv=kyܛM;H{H &# ꢂ&oɹ|hev\3o#,E>\OC͙r8c<MTk7!F8jL;^fVg/ vM @%G)4fRo1w|gB) ldyuT:i$uЌ |hާ%[3%A䍤I"ץ͋|hxNt;_sZ7řGW|7!&ې> )=\J'jmzÛMti X݁b Z@㗘;05vdjԩ<=@ [Fcp"= vMIrIaL4,M7c: [|hU" 4ؽ4nvkݚd7˄Y$ AAx{KAȮ_9H64Ӌcrńp?3$S,x$ hDByEMNVoiGY%)J=5 pW۩;bL%|d1藼:*qIluCS3M3$%LĒ3oTF珽7!tsksN.bm5?̚o;lo)!;2!T?ϐ(w k{sٳa|db9Qnҍ9r.% 07!w ICݘwQB"g|Qk :{z 6un B,#Uldo-*/^|DNqA'ho5#Ӌ!O'w !ypu$a\{#{92J4lWB{1Z #5vd;)4 C25@OwGvSsD0J d5`$7]P=h~IE(2N jgHʔGB'i69nsCTG"5vdH{1ɪ٥'5UyL/p|{s&鰋!sDs̙{Z ߼Xϐ,6GoՖR\Jd3$SRL=hjRC2uK78EX<vc<~)6%itcϐLݻ&5ĝdS[1%uZێL$loHPfFZIřE|{)fHR62:kH:XaϐLd?U'Z]~&NDgm=o;25ja>}$8U$!|` '35u X!^zKlP2t88W=o>C2uoB\mAƋjn Y;wI:%q)<2:ӎ{o^wZΗF5hn;"Z5vMIN72]Cmת#Osw|{/P2SgϨsG.?}eS< Z|bͥ&v/e` v sK&C= `;}e+?}5u'u]}RkݯܔwQv6ptIM(GSYT%btJϐM rod8ioYNqћϐMŋ=+4]q,k=ͭ57!w8! ڹr,UTtҕRʘQo>C65jgœXd@n G},,C|暥5?8c{JX+g7!{?g+nW Q f|ۑ{^ߕ ډLK[Y^Y&CϐM$j@Zt}B,7!u7-\"GT]XLC|JcnDF9 e\v`gk.VMㅫw9 9Ɩm3dS2HvLN=/lEM۬#S&R.%b^}f o;2uov`*h\KXò+p&89s)XϐM[=75o,FeM>_0ؾ3d;'t+s7v"A9i|ljdӑ5Jf^ޜZžs' fK pyNuNПԤ_w{'1LgȦ=f jn~__Jk䥵lgȦܪJ6j>&& {iWAdә3dSVLM(*uMrQ.`]K' jOf5?_:wBH7i-̑Uƙ:9dOZSS7!{*Z{x4foLSy{J4^ F܋WM"ee|Q0ÓvJFc:R@L;gȦݾIĸ>~3FzwR4uH"saGfrߺIсAUᛄlv/BfͷYMS.}2į$6nFRb8C6uo վtI1TT/,u;gVgpuQt83;gw|lR'qb\ `aBM13lb>Dy vߥUM2nӛϐ0 n^sBR;7wa;o>]SwDd&%G1z_GK׻ԽV ߛ k(i XQ?%No>Cuo(WDSkO+qk3_3Bx$5Rk$J sЌi|ۑ{ӂ+K|\ʐH] DԂқϐM#{4HX#.2 r3~~khrq+I73S^|b2K:krj}ѓۤ7yqָ5l\꜡V3$(r77؞@Xz]XJ7i*7غ7@c覘ǻxLH%Ŀқ8}ΧSK'դ RW x= bj`!'ifK֦! ԨDk~BS YR"}JpKMfzQ up#kjMo>]sM4d0Dsł/9: Խ,nƥ:E uk1̟`ÎL/F#hKe@zþg/ u[m3I R )&^?X=?&^f|ۑQxaǀ/Nf#֒;Kt7u̩ۋMC`FGrJӛPLZSPȖ|*iF313L|8|0E]TUYmGVd5Oqƹ_QeM55v3Sn}4APߪ"6qus|bjEc Tn;@9@9@zYmGFM"Z)J6֦j }QI*>Ejd75V{qLsپqkGo>]SN NHģO1N"7غ7+R t D;MMqp'mcPlݻ><L'}O,˥0$`|ۑ{zB @pI*x骚f|ۑQIlt^QȒwA4=zۑQ7 5xcM1V2&Šrܦ|bjCb/bp4xAc4f|:'ɳިncuIK1Zez{OtӬJ<= Cfd܅z |{ F^FkE~z(wlmGv^dѤX " rV%2wLU `ѴOo>C15j"{k eSOcAc1rNcÎ~l3_yN՝SukDI.+H쾿Ԩ]gIƞ==[>o*P?DzQD@V8Y3STe4gk7drH -ODϚo>C1uo@vo-tN?8~'~]3# ԽY4d3 D5.I`~3͚o;25-r~ܐFQP~ӛPLlS;K3Hìhg>}񝫑}J++#o;25j]g1NR%3N"Aێ>l )P*13S{0A0|LEDoR7Zsg( R.4rN\ͭwۑ{k ڵ߬,5|bjRMq,|Px=,f|bE$ DE`RɮD.\%%0B]|bjҫHYmG >C156(4õ5IMhw l|ۑQ{P34$ܧ)b|ҍu5vm|/nanh@Ր* 4*5k&|J>5f6 `q>9]#7fj'Z$ZKuT 8p_ӛP,7{ Q28d*02ᩂY|jEeN맿r$ ߤC1.o|Q"RyNkǰM^Go>CZNQR'#[h5vd׼y8;Q{Az{̻KFvޤe7o蟆5vT-7[&u-RSc'i"UśPMݛPKce;љ^l gFR<|)dPMZ#eE=vKqf2]eE6 ֨5a68U4@MvsaGN 48WSMkeIrY{!?4Ÿݔ@h. a##3#le~)m0ی7IZ0Q-#nӜHx5vd$lՓ*%Jm+q]*HSs/5cWD:0ވ\We ۬#S pj/ޭ1í5Rr#IWސ W&z DomGF:U!.p&IԺdc9dSo;5j@ܠ>80$*Evc%`׼ySI5?IQP`׬#SgMLӜ*؍e658HЬ#;/UJZH ճ& d+3To!/G@tYTg.9UY7vd";<8'75x+o>C55j x  IE -e*ݣfBӛfF1pL&bQsm35FʵRn:eTtm߀;ErPݣ7[}cz!QLg Խn=x]cTp}Ԭ:7d7m= |jjJ{ĝCE_)e͆O]FfͷYn41RS+$ɏMǮ#[fEHآxYm՛њo>]+oO⑗HSSVj,[Qܣ:>cG{#Ar)lwoVڊg-nqOQ9tq5AJK;,ԽuFLia[,Ƅx.̬3TSvHg󩩏SI1X.c?1Do;25jWhR='PwF|jjU1C[5FC5u]yF6*NsX8F 1 j$;MFHԃ7 !]o;54Bi֡MkFPET!$;# ԨsW++95ds"y?D}ۑQkf`c(Tf)K!A=vm~nF<"-s )bqdgjuCf 9٨:r{ jžϷ7Zqm|Ɯ7ںiׄL\Uµ9hO7ՠ|*jnItzJ̚o;Zg\F,ډ(?;/Xʛfͷ5@%VM}IO3s61@`mGF-F_8K^ur7kpݣ5KEN^F~p#Լߍw~AyrY$ XOL;Y{{זdɇR}C+7e|ۑ$QU7_vJ%lὟ|{˷15%Ð3b4:gv%!,;##Rjbf7S}8Kq/C\Tԛ2gkJի7tin"9o;2uC5uo<$n>t8JVx.0Lo`~{"%)J5tTb:$Nşo>C55jyRSPפCJY4>cGo>C55j)9^gpK- 1z\ykOێxN{vS{'X;|֦HM7_4Z$rþ Խ*Q85~(*KL׬fb)kTՔX=!4ޒO;j$,:>Owtwn8fghFWS}kkhW;^LLKq-`o>Cs#*&F1 $qw`8|fjUWc&D8pV#R; e=q`pEa^ǙghV̦hR9l )r6^ĬfgPb#U(`S9ti7o>C3uRh̻uqqm7ܝ7w^ʲK&If0OͭS;2C\cGW.gȄ=>ێLZ@!7rXH\P6v v͎_kskRhP%xn&}P@3 ; ֽ.-t%pv>V @Π[ێL`w ê$" UD>vd5IضyҊ Rě_34Sv Myw3.N9A)o>C35jO d y9UR[@y>GkL4 C2 Ts%wC3utPY0N&>R./>O1o>C3u}m%/j&oɼ'by{moֽ'BIFhCo~57&ҳ=‘$5gi];o;25oR )๕bSvH{T3ghVDCqr+wr$(XsiWu^M.zV?W{vd~xKRs0xk7Yܝp[P&Ro\ Ԯngh}8$b"$oe0^*;O~{W98Yd0A.¼V|`1xghF}ٍ&M@tùU@N}J}o;25jzFǹ'#DLa#径h7uAt`Fs7d_.nX/ v(F)}b}B#R7|vٺNTǥ&4 1k(;2'|$7F⻋{ ԽS牜HKkqįC f7G*A.*us3J34S2uq<pNPChiF Ԩ?'ŐeVq4n]6wۑYsHTuV: ('% Ѩ"ᐗ7EҴ&M۹ob@7Yn6q`$bByv%O1Ջ%Wךo;2uPtnN@il4\w/bom#6~(BpsS_wF Ԩ昏kd)Ag){M|ۑ̝m9>Ԉ1. ĕfzʛ`S񜀅/4qlb+mf7axiAAg76IdtƲk(;)UzO$7GݻdؤykʛL{6.iVM{zkh|ۑQw#NI>Q I()M1Z;zQ$O PՖ]J$(wێHIF^%N'GpథYSfͷu;!dZ omCgkG8CfvNj\7w],2KRE d:134IŽRM]H#Hc95vdj>1x4wEv(2skԨOզJYm\g䨙gbc˛Ь~HTP]UhbdArV9_t4DghF-BivSӨZ$qW4ˋlmGr@]bQ3MRQogh}:"yj'a뾺~ghbƙ_ұy#i8^r3y\y{zKn9<_ޜviHLM rGwJJaǢbRpû(o>ClvKkć`i%͂d;ӎQ;ig߭)I݂W6$Ǭ#fNJ $҉xU-ΦU7[}H?:7Jf8_ ;kp3 Խpv\Ǖ21piZU2C{nާ [5WQp%vIhlcӎQXE kX#C9,[RΛ3t;/:{4w`"|g^|njRؒOq%DN@l邺ڏnE&5/,Y"q3 Q9qx|zbOF1bj@<^o>C7uhTw5;ƹkX5kƎ ;Bz.ͫCI&s"fͷy Ϊ{^`s"$y+ơYmGFَNcџoDHͫxģ7c"!l'O!GP%dm Ԩ3+EW뿵$u 1535F5d%;} HێL[_v;) >(qrQ~Y-Amբt+?rxhz˛нQUA4}v/ !lwlJ26gFSv= ?D>>dsԨ]t4f,ơgTa\犦 Ԩ1ĴUEb L/,~i&5cG A$35S +39/}AD l∍54ؙg H|!i樱6uLo ԽUHFE]h1? YŬ#S&l8=Ykb% r:3tSE|cn%k>c˛M"\sIO:!N}6 v m wMBWs6`<~l|ۑ{GE[d͈^> Խ.rV`SIR /jћh'h+bܺtz䄕˳Go>Clu]1C%B9fU f@yQWtp:TooBȪe`S5vdje| C>.Хx4v?o>C75(h5IqnomJ#]|nhŪ$wS:糺s4s>|nuW9WS_ܚKÉQI6gF;qx9j04{!I\Ӿ n:TŦl$ȷE`W;IjSɗYmGj9]b4h+/ire35azkZ/) WŭuJ3tE]Ը ԭQsҶmG=4:Lmj;dw@wڏLocGo>C75j(+7 JaI.n]$o>CI,y6ɤZC^yn4˛`ל./@̤܍sU]W*|ۑ{#'[_QtK3tSQ1StN&0ֹwn7[lJUlI q`"U 0kԨwIORة>$A=PY7vdII}-h]W5g"&.U/o>C$HϿ$p=j ?ԋH7[OU㴚ZJN:-'8ҳ|6 v͕ߒ1'!A˟yܛmxg~<gldoko>C?tK4^44DP#*|ԉfMQ~𿻶uB TJPo5V,fxQoJq &?sH}ȬECC$>19D'14kƎ~;'667&|2NehfV|nSn`;KCDsrV|Lz֨ ֩dyRsH y Z`& ’:4Gdt{3H˜Y6%!!$̫~W8>3(۔.z_/M|8lzcMЌ賕-"nC#Ywkn6r(I 0ӤNYwk݃lw))/Q,-Z7D\2FY' j!'AEjR "~qRR7ڬ3y\0 04pϦ"$iX:̚#ӳ4z],Bv8*y>otMH ZKds/S|Lݛ($#W;]5ܮi@fͷwl2fuNPqVVbbmG~Za8Db?kYSb93;U$CKluJaE-w'AB]CW@/yҩi_j'5m*. RHDٗYmGF-PKr#]7&QУ"X|k dMT#iĈKRF.5ͬ#S^ A:SXhW?CErDJ8}$J2g`MkwܪH}>rRٚ}o; )5gCH cGO>~:4uh&>N/)e3 ΝW"D╼fcM2ޒjpBء)fͷYnoХ3$K HCcO>kޫTϒ<'u i5G3HP<ΥIpnn8g`MF~yN'K-IKŋ Ǝ|43kQ)tX$N +g'5M^>rawe^W> 4V?d_u˕qoeu:}$/;)"y4\:! Hj7>vd޲B9HbG~8 ?a|ȓCոMWmv57,3Ы*) T5%sU|4wRQ r#"Mx%bIX5%f'5,W>_b.4zMiO>k+ijL {VOpcͻ$ o6Q%>5vdx?R ;'4u 㔨d|ۑ{(Ql4W:E:vͷYMZa)&I FGO>D~#r,q낢Ɖ4wġ̓`ϐQϊW" 0Mj$M쾿Ԩ{V0I(yl]=rccMWid#jx|}/\˟ȢO>k;Bv.⢔94K'3ti'HP) %RKoOjIj'#i fSo;JoBQ"HTz OLuF?$zwa_%_8ێn6鏔S ;.q9ONԨs%Ï5@Uõ )L]?r[fؑᜌ^jicѷ}T=#S@q.#PH a {\66zBvg@ݩM-eh|ۑQ";Hɯk>! |XkH:^rgq ]Ssנ 0g`M|ɪ&D)I'o~J}ηeقļ=X^y&.H隈 Cs~#[-UUiK9$$q}ηԜ7JX"xy2b2&55۳#S`RDڌ6sjXP`gP,XDK>Zz/K=<ؑ3Kݔ+LYN|!9ҘE!|l mSӾ862/0)m>|j̝TlW?" { v@|0gfė7xAtN]:g)jug`M)+{$NnaJ;3sϠ SQoZ'I8[,= i{DP%]S|ڑ75-XԘ.iv k˜΁O>k.\h_1 8:gbug`MտH%¬Қ^~'fW~S=X@9'5 $oPoOA # s|4}g$n~.7t bMFR%ێLZ/Z0P9F>Qkԓ'ϾKHxrFmg~.#''5N>d6=׸ECzo|ۑQKe'] R>3Ql3XS>fWQ_Oe[rڻz%;&zXpN@_ kUzºlpiXPn'5M=:?쓮租Q8*I}X vBmmξ4STO'? iuAߔJJxn@V)ێl,))GckX\;5jxpp m3kԨrsj4b<*ttS\;_zX4Nzţl8Y Ce> 0՞Ϸu`ӝI3#ʗxRϐ<]lkzG$iœLL wJ_מ|43kĂJQO+y4)9io>75DZzsOР?4X vp|0#+e%zaEH 욿#_t/ -7D0kƎ W3jN w k9W㻿Ԩ`ծzWV"T(ymo>75YH$r& 7eERzA :K{QF<Έ~,+r:G:Mo5vdj96"~wU CM]Ů#kh_Bިyw>?M{Hv,%}:g'+, Sshkf[{{YTx7/%h85굮4uFsԨ jScfbF nR1!sǑ̉Ci;ܜ7[nww"-r ,41nێLZà HKQ&{Y4M#w:_9ށ`!5vd$AЭvə%wX\Xcێ;MCպG`yNgcf7[Mͻ"@E Qa/ݢD?{{Q&"rPF/&*$VpۛY\:XCj V!qifͷYn7e[p8N<{cHrxGo;25,uWMɓ=w O|oj$Ve/Fi'oV2ߠWZ|ۑYӭK 䬞$](iR3=gڻN pIQE֜7[nI#2}6o#2vE  YmGFN# N.VR1MB/Pv$co>75qR83M?5v F?0Y#j=q Ih Dio>75̄s :k1-L- vaMӃ 7 8=%/m;2b}-[I9//5C׽ xtεO}~N-kR|`j.Lmk.e"-ifC7!uP݇w :gF- v/g$$|{>MAh(f쭶uxΦ&|fAMW9We!* DD5epڛLx'aGZ"]n^]O; M$Ps^q)ګy5η sgiG΋1+HUFAZYlDv oΞ[G܉Jcu.Rc(hL1(9MnPH O Ԩs.SU=*iv9GK͛|?[=S. Y.J3MpcڛH741kT [ۼ?"#6$gFy{DVd*R˖-EƬ`bb:YSj磡H5Wi5A(}w&O/|.1ko>]3jMڬ{4L=+;V6ogMȘ1=U$ &RA~w\Mfl'+7{ݬ&bgg+m]y]rI;@ R0kvû |][ZNYgfͷ#eCl vğT?[S(*Tp / v$A<t5xPk-946gF}J`|u5E&;4Ȭ#T&,pxnB.bg9bء9o;2uI(/Roq7מ7!غ+`g ֘5_,tho;2u7hFwnQvjjv|`jk($Iٞ_ێL:I4%x1~vMN j\Pk4@TH5r "Ϯ.lmGfM@vS"#y R$g&ӈUgT${7ܑVOs}{/InUc@%Ae%{$JћL{qZǷKtkbۃs ԨW{Dr\f.[{Q#M=R ]B"GG2/½٣7!Zv@lz(l(II7.A7_$D4sWGHDۛLs?1ϖmg]Z{;2`!/\]bĞopEwvD͚o;2urDdW$|`5INQ1s ""Q{84b ֽH~}RvZ՞m#>ٱxo>C05j^ܔ]L+1hbJ\i'o|js~h|3h4ʥnzLݛMyҜTߓ4*W!)`{'U}u?NP$raGo;wx=)΃k&4I]ʠӬ#[1׏]~ 7hx^-V7 p:0nMXɔ|:wnf@Z7vdw4^JN;vIu 3S vM-H"(a5{|h5Itw4^u/*]x=p3DIrt)jYs|H;7!ں7 IRU7%%}3DSVI}"p; }8>ìhjT< 4ѥmR 7!}nqK5D*sa` 83.-E_- $liGj8=Uɵ!$?8Sng"'|RV5~c|Q4u︥45p#N' "/`3DSƿeCڋtYs ԽAƚ,|}oe$l&[ogFʪ |mrՓᲮXz<|hjIc ][@u8X,i1aXC4uo5n#-=$؜a}ֽkЈ9c&+*Ucs"!@9Mg}pt!gN#J.ү5vdC:qxWNLmzMƤ2v `y52N_>n#Ѕo>C6/ޚK1%%yW!o>]&הIhUUUŒ!4UuǛ3DS:B~%ʪ[%Kq1N;|h_>i$$4d#[JIm|ۑ{kdo䈶 ^*젊rϭ8w23D[JfeZ*rW\Z` ֽPxEn~hʶgF?6S/< rj|Ȭ h_TKYSzP^V쾿΋,sjxdduITaك~3DSN=ȧۃ& &K\Q7!wM`-!IQ$2%Un$@9|h/YdV$+芤VIO ԨC1Gȝ[)AZI3gF}mIB"T& >ľ🠡 Fo vͬI~&c؞gmN s Խ5׬t|[[d^5y)LWݑfͷQZ{5VΉᨌ'IH}Q\B#AR/$͢XM/ia|ۑ{LpV-;(U) ~27|hjԱu4Zs"#; &F/ v9$޼Ԭ:ȳ5~Ϳ{3DSΕIImh gG5vd\ıoNIdNm+5, Ԩ5Xt* \Hag=1{?>#S`{{jˉ!f-jr7!&{_LxT)i3cn,;I4gkc`8c'^R!Ho>|haKE5HV8zPM| 7!ZM&K^Jȅ>@> mg hN ;jw+_8K=9vdjԅʉI|YF uΕp3DSh´ϽWE%($_ݣؑ8#j`D sښ[sMូu?^87!wH8Tj %տgK^:(C|hE֓! r%m8A<-7ۑ;uB7ALr df|ݛM5oFuxP_T :[O ˹QLP5.əwۑQKe.\^b,|3|nkj2nSʺ4"MIrMgը}Hl'zp`&5vd=1٦4PNwkt̚o;2u+dogil Jꢷ7vd4IjٯM$v|.{M7ǽ Ԩs"|^̏ UsKךo>C,?qT~PވNx:"vͧ5 /T(mS:k> a|Q2u:#V|MW)go̚O;Jv^]:D)ӵiDzl)rL6k>(Ynv6eH3Ch{i9ݚ94 Ԩ5TbWWce2Ɲms7! Z#y+ 8/3$'T ?NQ(N0sϐLz-jE ˻ X#͚#{p30)c^)uJ)vdEKf](WT= 'Xs/I2ʬ#S.d{)rP4qٓ%lƎ$p^@5KF n&Ys|vX wx9v͇Hd[Yez]j})S40h].: CNdI߶d,>GDj56"(ɷ;aѷ=YmP7n4+ŏTW3>Ee_7|IwH+y\vѷEjh@>N'8;)E[f7!ru GːqjA2tXQ0-,:t˝6KNy>TbQEG\KM}S Y?A&K ¢(}v5-u+Db|HI(so%됤/*1ĶZ&Y8ǎMsK$(X8-ʔӖ@usY5oIs6lMQ:K[~R[UÎ~E88;zCXqx-TEy^3hVƑ:Ik~7!vҦ&aU>8=/^\bakbyGkR7iOj@@c}oC2ER$l"};faLߌ(i"j 7{y7!xҤ! >KeQJBoO(]4aonl^ݘ2HMʞ +aaϛ|4x.xB)KDzHVhjOSx2KĝӷEYijV](c>PUx&}oV^M[mz$ђnb>o]T Cw;HfIaܩJf>$S!,껤%9x*8$SϞ6t=nyǂ7! Sn( ,9I[:L$dUwKiN/PN߼9})i/p30r8WEgn9]2u34)zJzC|'Fqxu]lI )['Tz#@/AYf@d[)Wydm!tX.@dSNLIj7W8 )kR.l{aDi0#^K2$Q]8'=Ӣ)l_y%IШ"rvH5?} lޤLHRubr3@ěa=ߨ'G5kh 9pZT5Vd"^0bm14tM 7"f=FH?_ ,=awem̈́ȦbnC@8E2bOwo(S!-oR`j|+ȡ-rrr,enؚԣ\,ně $b$Î nt:7.zK#uZXͥnl_u&|dԛMټ!3UNnTW:Żpz |o>DOF|S=g52'Om݌ER#x")g I?Я{GBpyL_I؇u&-TOzGѺIנRޔl@mxE*bDo2unDZNT^VOWkQ{")t' ?{ Ly;HG]5\ScѷEB7饕KxbsyܱMbJ0BxIFpXȧ+HDk+˕jIApWu71"Bw9!4LFC@豷wfF`&][C~wKFsΪ#?MfG fu9xbVsFdS&.uрHrqT<%J=ӽG?mVa]I)U΃p!͎vR$o}Υ麣BÊ$X\Qo2n)qN[%ɃOfz_•9m΢o2j NдBgWHg |58Ro(w2KMsqX)cE:Xv2Nw =>:Dߛ#wJxM@-g6 ;BJVƕv[TP}'cGsņH.M,-T3eNoZ>$]UԵi}[&uJ E'[%o;;[y$)tAM,IᧇSo2nSg{5_~Xg7S"BؤxdPHV+A[S%͹T}} I'P-nY5 F$Ee 2̩Ku4¸ ܣݨ7[.ZEƍz ||^Cӵᬗz%ؿ"ΩsrÂ7_"[͓ ݝRMrX*H/-xo)q?Qz4j&5ĊE&=-%36KR~RE`x.<_{~}˿u/M?so#LJzzQŚ{y[~ Y 7;darcs-2.10.2/tests/data/context-v1.tgz0000644000175000017500000001010612620122474021531 0ustar00guillaumeguillaume00000000000000yL\ |չ`b7&{vIB0B^Ǚ!;әEZAkVDZ{6 ,*bժ(>k{hߙ%KPMC3}|sl,dE$@8I EEyTSO\YMOU^9UVexg0rVbIYFcN s\cQ9IFRE=7-Ud?+`x_IgqT 5bM8]c2xˆ'"G3zg*΍=צi-ޕV^#_muYݵG7ӡË=jc?} 9խMxzFYu\ Ϻuϛ|k̞Q ]_S֮ ;A_r,Y)VcxB$ZdiQRL8,\Te ȪH6i)K}hWєmkl ߹|R_6xn{:;qn֎ 6n,s;c-[wUuG[~OIqR-+u&Λ9+v oΐ!ShM;!>x3?l!pE`}}sqr yEj?3OAp"˚ F  FH!R"%"KRÚ³PD@)KFi4#>?<>ӯ/ӯCm:H|}`eqp"s ʀ3Y:p%<55~xndKwV>vE|xۦ)~65{`p"ޯe@?AoZ1[uǘHY07ᡵݾ{/---f뷿ؙsfϯ‰/r<ͱ"  *(FJ(p <hBX)L' 8.A:_y8+E >NNȤ²BA`EdfiAB,Xea9hBlyOǾ2MOޟ?9n տY]G> 'Y 迿Ҥ't'PNѨ;7'MHh(O?&)GS@puF̘H *'M0a* CYQ$)H$%V4VPȱkaU Â`H^yx!iҥC9j-}sE-o45񵟼-UUԹqKߍ;is;?`ˏ_ -#o^JOnro[Z9z?n*k#Yթmc̽#,[41gȿ/ₙ=;Pzok/yb]9W8ݵioRx_p_>ǣ?2A<:No_}h- nx~&_WquiŃvyHez*4ISD*"k*< e99@ > ^۾qbU/wsGv']tkݽ%ߗ??#A=8n_ `Z6{=> s}?k ?c]uٴP3ɝ='$n-O+kT>ˣ__GWe9OXS?. `le !sl(Ç>|Ç>|Ç ?u xdarcs-2.10.2/tests/data/metadata-encoding.tgz0000644000175000017500000000612412620122474023072 0ustar00guillaumeguillaume00000000000000LP][$W M 7̐Lw׽dwL2쌚dfvTSݵut%'a]dA$Q <_"DSݞRݭssϩSU.e`Գ|xرCʿE]s,>&. cH=~Uv1"4:{e i쯨UQW 8\i]̎EH5&kr"QJbT9iuJ=:ƪ p2F_ִ_U)_Љѩ-WtS[hbKZ,S0ZSE:)$lôA!˒-BeшUGi (fڞ:8IM!D ؆@DVeU+N\ACDHM5bDPF40tbJ !rRj$҂֢)XZ s7'Ǵ ř V|Љxf*g^Nz?34ܳI;w+7XvKϞ82%;:@ y Ͽ ZJ\ .2Ƕċ3.I,g g4{|ڸc! y;TBvZ~K4{1ȑel"`y?_e)e1#^*俦?U{Ҏ(c]TwT[u`NL0R}HZKaBNw(߻h^~narS6L p%0?,dgo-SJLHT7Dǃ8%#O#Q1UKrL$u?#0yZ,k2>ngCn6Cbh;.(=!nGAcdz}Ɯ606,t}ћzD ԥGnYR'*+q*MF:IP4ON19-1 u/!A+Z,q:iG+&87-xA${sWxh_V%0 i N\ 2zm>PUoG~܃?\ IGnֺKN 3 A?mdצg@G1Ql㍖fc;#I[]mF|,l6j@bփn e ?GPvTqjaeSM'P Pm/p O]Q0:4$']`([ױB?m֩9I4p>h>q|O\O0 ZY^0g`͟Qr#BzH6N%Y l 9ꛙЂYN;j;,O< A!Lr ӹq49] Yk9|-^Rb7Q)&xg?XZ"(0xb$:i{ɬAAG{Vh="//%5xJ!7.|M9Rr:TgL.l`NdAL;QKI7̸=Ҡ$]兟G Hr`[YO[]35y݁{ 4U~/gJs%KH Ҳrfe9ۡߥYBK3AMXֱNPa,j6ym} :DfЄrO~Þͥ8 ĝP[ _zzaueH"i/0wDIӼRRS7ɩjgu;l?wUQ9E`_qb{1`$'rxb6 قbb S -L$]3lEVdlY;eOn.Ȳ`5Eò$˪ ?JZ˔%2-I=}V]Z_]y_"3w%V-Ԓw `_y_% L^'CQ9Åcy|tJ{?סG~ j/뿣۞4|4Sמu'$#߂|AEU'6}v2*HV9O%v\_e b?Lޘ7 ~%kZg;$<jok7?x1o[k}ѷ>?f}'VN%H qs?2F ;R͎{;/T_qRh?>Ё$AR-cr8?tKB#;yݷ~Ux賿;د]_oW>߭/o?wN4i_.{/GP@_T6KQ$e[%*M[Z٦!)3HM1LCV,@S C4*-e}'r_i$ʚ)bpkd)q"T{;]"?_6&Ȃ$r/QD{4xdarcs-2.10.2/tests/data/context-v2.tgz0000644000175000017500000000623212620122474021537 0ustar00guillaumeguillaume00000000000000=|L\kl-DPQ/+]{v;!5 ̝݉w̮c ZRZ WU* ?*BR-QDEڊRzlCZ(;yιqϝ8 vlTY߼*s5@/6E^iC1+F9pP[$,~xFPT&_eDGvLFKC*X?H܆?IXn4|9-A;,DP@ df25&݈`!\;ĴqDaq8EJ%Y(]I F3{^D/ybD$ Ǥ~A e/Zd:# ] v pl`XdGC=nyA`9Y.|@N4EPS5pݑ^Y膶熝PWAdBĵ>Lbr j!AQ .#4%iQW]!a)嚮>e.^݈8\@dx&rό epi"]6 W`*m<L t:aXWNR j ~p-͆E(]( xvڠ==ǁM#+G~9WS.D Z8oμbb]2>6pv8D:.d ۅPVT! !~؎ QL'IvНh UfMÔu0{ naSvˑG1L)" lIb=qKBD.y*0xmг"4Mt N-U ܅Qٴ=8”OPGD'~%vq)06 H$~6 UIt -5k r ңLn+$b̕.`Ir쌩xv)?]òRaXqk(6.ڊZSjpYg`>㩍͑vIugi 5ݞdiju]d쏍60;1qn Nf:ϭvsWgi?'M};HP 'I t4 A({{zhkS R%\* @ >A]q>]&is'sv`1s4u]4.v_N BoLϨҟ nT+@ I`[Սmɥ IȖ mM >Y[^8aƤq ա͵B:4ꏹzpc6O զU^a Q,1:e"VGkFe\pڤb~u]vO<hBD?NOvo  "4$3oOEbNnf>FWy"Kд2ckG2;vyҝO\̕5V4Y"*gʚS-Y!dpyMQ|>32@{QYlXRQ``PThH˲"pbe8ohJ2c{=kȉZ"`$NeMTM, ,oK"X$u7ЪqqXUxԀ,;=OOloUPoa4A8O9eYoxҳt75%\syEZ 2ew nz&O}Y:yDž'۵rzf'+n9+ϾW뷫v}/_ϹyR-;[gg~oq8 jLK\硟WnX|/3/|ߧ}/֮S/ʿtC ל~ߨܼ v2GnxW//*ާ3{o{ݣ?i^y Zo:w+x{۾/߹=s_>z]0v I_$2o\n8_r/ i9x߬(\'?{I'xk^Ya ~}~Ƴ}v/ ]ܴrom]̲ܟh}W#_C,)X5Cxk*ɫaMX2E8n%"bFO©K0>7BO)H/i;ķN_\6D9C-oKtK2X&HI4]%K qBWCJPy?Av%âGW8_{ko7óGͧ0QU-Ag7ٻbuԤ?v4qTvk 3ҺܗQ3j&2H(Zvxdarcs-2.10.2/tests/data/split2--darcs-1.dpatch0000644000175000017500000000126312620122474022706 0ustar00guillaumeguillaume000000000000002 patches for repository /home/ganesh/temp/empty-old: Tue Nov 16 18:32:25 GMT 2010 Ganesh Sittampalam * wibble Tue Nov 16 18:32:38 GMT 2010 Ganesh Sittampalam * 'nums' New patches: [wibble Ganesh Sittampalam **20101116183225 Ignore-this: 5e5df9907f191511650c2ed66754d17 ] { addfile ./wibble hunk ./wibble 1 +A +B +C +D } ['nums' Ganesh Sittampalam **20101116183238 Ignore-this: e865de7aa7e896c759dabccf510c59bf ] { hunk ./wibble 1 +1 A B C ( hunk ./wibble 3 +2 hunk ./wibble 5 +3 ) hunk ./wibble 7 B 3 C +4 D hunk ./wibble 9 +5 } Context: Patch bundle hash: cdfc4f7087525b0298d4f08e6e497f925f85e406 darcs-2.10.2/tests/data/braced.dpatch0000644000175000017500000000062712620122474021407 0ustar00guillaumeguillaume000000000000001 patch for repository /home/ganesh/temp/empty: Mon Oct 18 18:27:21 BST 2010 Ganesh Sittampalam * foo New patches: [foo Ganesh Sittampalam **20101018172721 Ignore-this: 5e9ee20eb359c030581f54a73186405c ] { addfile ./wibble hunk ./wibble 1 +wibble { addfile ./wobble hunk ./wobble 1 +wobble } } Context: Patch bundle hash: f427e3af1c3f5486cf570a5c7bdb826a0a2eb3f8 darcs-2.10.2/tests/data/laziness-cut.tgz0000644000175000017500000001040012620122474022137 0ustar00guillaumeguillaume00000000000000'Q] ty9 BpbcKF`,#?@X.P$[ܹsgwݙ93zy!! J(!hC94-8`^ 4ȡ-gvlk|#i>{籣^kh|2xe4R/H$7p$F(ฆ,rI;r6N(ɔA G_L*8OM SM?43O>G1bZ(mǿEUczP42jAeE`ȡ0GTi-GB|hd+)_q۴:D4EB Kn-)! & 9cӒled v zrN8тT&AtJH͐dC4Y1Elɪ5FeT0h&b$״-uYl.ˉ"TQsO@\&7H/% (Š"K)#zIG9'\!Qêi+%SY5,ÒM-KQJ,#E)mɂ +A%hذDCClIX,Y7%Wx4LKb-X 2S{h 6(X6mCGX&h/HzZeېT k ް X5y^YX$AW)j6Tǵ$Ȩ$J,vuȕʟ^ro{ڿero?uѮ%/wcwmWͺ;c[}~_6}kuo^yAZSmM߼e[On/j`S8/oMZuA5+o?{ޖ>2>8ɞ!{-p\_Tv"`S u?'0A5Qf/]\rpY7,0sǎ̒n۟puS;G)j_¶(H")DSmA"hjDTD0!""dI 7xAD^4юe2qg|T|a[w[N?^q3}})7;̛Z=})o?{mo m/79̩?:tqgt'4yɩXW9)gټ%=*GN 'ݴqN}riiܟz\ߜK|·Rt37zNM{_M8}Z0hFvS(DčP(cQ7 8u Tg#v'DF/(?czbZL՗9RP8rK#eOAdā?$0Lq$^FQOj_뿪z|̸k)<C 0$趩[DzM"آD42ET^45K6T"ƒҺ`bF&/ilh+aM x0:ʝhnZ d]dM-jD%auK=L':_Dl A1XTm! ,֑lf}08# e=]O~^ΧԨZk5{2>?̳Co:.Oge,s59'l'O8rܐC\Fy6G# H"%axny.|B}d8-69@w]E9EaX,@sqzڻuNٹmMY=Tkrl͉@ #l¢Iڂhʰ3P~\+9Lu\Zy8'\f]LE+2ؤ5s\Z$āG0ZSIdPxUg91,_!& å%' ǥ++ARZz$uҲ ʉҲ+C'J]'((-o[]NdQseIF͖V]TIĥFJnk /\m٥%e>Y¥ο, ZTT@5]#Ƕt\p$cT.vtzD`&{D>P3˚8u'JD't#*R㮌}C5@РM+!4yIMUPd`^ү k^$'z!I͝KWԂ 5or $9IS6*6Pԓ9ߴy=G`3s=Q(K{2`R?;Iw~X%fTItqmE`is <'dcA.*1մ ^^S#dAP?Zǝqe0awBlTC9l.+U-̣(x9(JeSp[8R@IXHVlA.EVl3Yºoz?3kNW{A.EiHs0J%]]Qy\hVJMEfFqEJݸ)ռh|C ^4/!*_l]`Epv%x5Ia ƲfB 0[ AdžJȐEMݰ4l c0!_dCe8'14M:@ߚF_#Zi o{3f݄So*iX:/Ȉ ST t c$EE [ - oꚎl2Oi GMG?5hlM[Hl""Ze[,Hn !bVlC԰+2j>#Ju}#;au ʛӟwlx䞝wY{zN~nl_M9gn9ܱtު/| O/M7^~rӼoxyoзȥ<+n}֔;o{>u!F5 &FFM u сqdarcs-2.10.2/tests/data/split--darcs-2.tgz0000644000175000017500000000552712620122474022175 0ustar00guillaumeguillaume000000000000001L\klGwUB%b];Hc1nƪMvٻۖgBU@ BP@"BJ Gg񣎯N.kBķg; * fTkuSuQפ@]j%ymF  G΅jBmM({.koFvvKqQom_JYQ/;˟aFWR҈Q\ ^/IVu. /|GmĘH RmYǖ4ITU42eXZJuejZ]n`C/DV}_ػW"M! 4z6/iJC:Kj AmFAˊ?I.de.p? ^UϊGV˸~Ha ]Ҷۿ`%RF I Ripp@mg!1^%Ō$ h8*;p>J J~V gϞo&&&ujo BZ8{,K&еb^!!nDAu Գ}d4{CE g2 =I/%yT>׆aV7X<U0O'D8$M 5dw!&FYC.mw 4:Ef|ZbBWhHYʸϙKvlu|o:W01EM8&0Ea;qHIt3rE0 Ua1G~?F+$%dp$|.\œuf>eшk e>(U^tF@T{8,10Q.5C?mV`Aչ捠uu-#0la9 Z JbmS(el$+H{e1)"'RHҦf8o;|GVȡv|ġɴy!ih =,c3Ye3fta&!X3㙻2^ >p XyeԶsSGJ+e)=m>Wdl[lKfiz넨vJusfBTY!0h֛Mef&0,uզ&S 1[6|\Hn]M AVrǨ|h2'[ޢ T1]&~ l~گPn}PQ{?@Yץ.;[qO1qkn1L_#}>t_}{9FN^*zcgǭ WVE!Wn/wW,;CTE4җm;W4zNUO!A~Ӹ({;:Yxdarcs-2.10.2/tests/data/oldfashioned.tgz0000644000175000017500000000651112620122474022165 0ustar00guillaumeguillaume00000000000000,zL] pR8;EXS}c\ wHB*vݒۏ%p85*U[mUG V-~V:Xjmu8=rICq޾羻=$c+j+c+;5 F16ư SbG!X66PuSq:}~cIʿ[¦h\ C_$$r)Gy# ˿8EæB#AV,2"a" 91_Sd%Mk6V4 aV,2"6$"!$3i(aY/V A1_#aN!bJђkY:"). :LGemn#بS0fSDڰyUEAEyjde #MTu~XqVKš@)!]u4 VV#ltIM7Dgj#HMEX6v :AW]E j[Z.Ws/$]_^k\'eERs ܂nQ\sb6s[]dn2wqkn%s-Nk`ѡ IK͵v,_UKruG׀Z3Y1׺3֗k3ay^mEڛ9e@1r+|1MPRGx>q/9rv kv PYIj@8EE 2mhKa(LnN)Uߐ6-^*"$vEUC eϛZnw:[* ]&V^b$]e fP4Yaz:moWu)&*7eQ15BI9s:@*\YU:_?;qsJ[Lߛnl-Yˎ=cS{t_~g|FyWٟ8{NsSEoy[?]}WmzM=nڝ)uk̞֞߭v)Q;uO&>G?b~z_<% |")2|FDD?Hܷ ?Pi+wܸkU.3}}vfٌϷ>3ki|y^~g>Y"{O>kY~]]W ֔ٻزܿ׷=3'.쒽_|'j>]Ώ?zuÑw[& >g,ʂe>(d,0u2laD)~9'ge7nsOywݿnU߃Oׇ'|gN၍wX"~Mb0wɤl[GX9ov:Gc Y-o͋昶IºwE]wt yEL9!V\t.ЩSg =zSw} ;cW~aξogNwZ7/lov}c14A(fhDcc~W:Vbh.`QɅ5b_0sPf~ld,ryKD0_xD] :sI1Xv!Nd1"$X!&8A&#: ^\:إTE"Q>Ɖ.bD9[zG_Mۥ1?e<2f ~#1?2oe$_?h=nY80J[Iuyqb%P_G󟣏a?*E</Ձ0eL?J@Qǻ_Y0L<󿉍!_7 P\Qgx>|Ç>|x'xdarcs-2.10.2/tests/data/README0000644000175000017500000000025512620122474017657 0ustar00guillaumeguillaume00000000000000 Larger or more complex pre-built repos are stored here for testing. They are stored as archives for space efficiency, and to emphasize that they are meant to be read-only. darcs-2.10.2/tests/data/simple-v1.tgz0000644000175000017500000000606612620122474021350 0ustar00guillaumeguillaume00000000000000[L[yl%Q%ڨO[Ļ޹vvB 8erқ7f@=Fn PE$V@[DAZ@!HC$m73kokѼ_w{ޛYNG" %~sD Dg|E(j*`ŏn7W=_05yK? vB]&Aŏ??'f&#(Uk"HFU^҉jEI0dbUnXWU I06bτ] CpU3B=i$ˊ7ͨ+72A)I_J577#ͱ\(ud@C3N[D7q@~?AJ%Z(jmqkP5)-gZu&$ՌuтdjG2Zsx<;Ԑ[tx@⻙Lp[`NFv7/,G/ б<&gJzY-ֱ Fq뛎@t^}FbB؉%(!.E2,P Jf#e/ EV4khŦc#baoGp={jXsF HI_Z $H%SgLTrL'A+)0P-!$%mtDwt4!cfEYmXnGN9pˉ6PѠ2w^J~K2|ƪeG]M]mEH*. PVD! > n5ی ^RO K fU”u0:aPC֊$֞&&S.9~yNT N5UL AY7d8OCfIb6bF2M{$ifU,+B ubktLOdzԬ%rWiœ+YA[iP)8Нtl~YMUЯU󳈧=uB`BHVKihhJsJEq2.cf`h qXRi T:.QA;֌D`ȴb<^=0Q٬Mp'Ims&HPs;̧zKN۱lIT wMGuJ$vU=tzVZM8@g9)r5`~^ a 1)ǘc|OlhFCEӏwccC\%XhQWmHx "* =E ltj# {2b;mFQGhᇊ0DNҎΨ,j5 4  BnX ;@ g-u[fSw?h˦nt`@ Q)-02:a"Va z7n\LIʹYlPo9^_sz#JbFSM8?9vN}$E^"<"eQW.o9yȪ$uk$/e9M^5.јy^u'{]7_՞WOXW\f/o;'sYv}.Q?̩#AIpd\mb33|BY󿆀э@"D9p?)'?#?o5Ec@* CBFyX󆢊ĐU%5 JcN/d^``-}_\#?Ԭ&74ND!jyE‹1'*"IQ8UKf_{C/ 0, d*\Y?Υ%=pOW N{k7>1{6;{_9cizUm߷yŝ |QkqӮYGz, AcO MՋ\9e_cP o7UDR=BA3xB3%U,xP \ F/RYk!eY kXƼe%R(Eu @Yw@>(W Ky#r^\NEu8!'0+ 㵬A42tk,fRt~tc47蛕{w{ڋ|}ߞe;߸3UVW^{Ż_}k~O?3Sӏٷi|ه/<WnI<鍝{|mum5zlܻ¶[՟&]{te7<Ң?,.-jp< 19'0o=ѹa8hircs{gi&IwyZgwwt_͖[w^Ɂ], Ed}h# 9Zpd$6LiGxdarcs-2.10.2/tests/data/split--darcs-1.dpatch0000644000175000017500000000062512620122474022625 0ustar00guillaumeguillaume000000000000001 patch for repository /home/ganesh/temp/empty-old: Tue Nov 16 07:15:41 GMT 2010 Ganesh Sittampalam * add files New patches: [add files Ganesh Sittampalam **20101116071541 Ignore-this: 2a86fa7deae02f1c98d578077ee5f8a9 ] { addfile ./file1 ( addfile ./file2 addfile ./file3 ) addfile ./file4 } Context: Patch bundle hash: 947100f54fce0fb3cb5debeca8702b119ee17d8a darcs-2.10.2/tests/data/context-v1.dpatch0000644000175000017500000000137212620122474022175 0ustar00guillaumeguillaume000000000000002 patches for repository /home/ganesh/darcs-comp/temp/empty: patch 573defe88544e8f75a18e530e3aeaf6608951aa1 Author: Ganesh Sittampalam Date: Thu Oct 21 18:28:18 BST 2010 * init patch c8ec7c8b2df55720ba2c3a21adb80790363f421e Author: Ganesh Sittampalam Date: Thu Oct 21 18:28:31 BST 2010 * ABC New patches: [init Ganesh Sittampalam **20101021172818 Ignore-this: 6a770d5966ed23f56e94c08977507388 ] { addfile ./wibble hunk ./wibble 1 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 } [ABC Ganesh Sittampalam **20101021172831 Ignore-this: 157403967fc6753e0f2540535937da5b ] hunk ./wibble 4 1 2 3 -4 -5 -6 +4A +5B +6C 7 8 9 Context: Patch bundle hash: 0a20411489222e188722666cf0db4c5de2539aee darcs-2.10.2/tests/data/example_binary.png0000644000175000017500000001512612620122474022507 0ustar00guillaumeguillaume00000000000000PNG  IHDRBHB#sRGBbKGD pHYs  tIME `AIDATxڽ|{[ՙ{zuKꗺ6#iƎaa`$^jBeHfHX6lTe7RT IMrv!y116/SRK?ԒZ!-{wlB׿5K Xp?)idž jadY ]PJA8lSJ XRJ5`J)@B< !d2}BqgLRJH)W,W 8u,"H;\3g8_M(cb1DQA0iP"AXtEfvv*^{?裏~5G¶mtS_WO} J)H)`9Q`1TP5~QU9 %WJ ֬YX,x\xo۶7PH~b@꫃?򗿌!:EQ(Ѡb!_Ӷm~PU{z_:u?x|}݇[neG@)@H@ Rf$V(HHI˟lٲ%$(5%.OiYmqޭ*$rq K(5|yy<7n{^zqܹwyo~+PE꫹"J%Ϻք8%I <-(laؽ{7&&&9rdۊ8z-,,lDKK <+CZwWJQw;ϡi gg y֭[o^\.Gbffկ~X,fJmRB /e(X9$ 'HQO~@HSUB@4lݺCCCw>}zuCG}t莭["H󼚪$S[(`*@!2P4oܤPK#PA5r^IJVXv-Bڷ~{׭:T-A*;=K]O ;ЛE0 m8FTAi J!rZTW !&4"#s`6@ͣ' XfZл:H)<98:r~PE-mP<.Ygq *݃H, CBS4d2^!QYIc%YJPTB `t{? )._ _А$o<,m]Xc&T\-$^zgbeaimöm=/"FG !E $BTuhj h=* xVRT6FE79`] <_FC bI@Ȃ7(šCFe^@2ą  B)@4&~׈?ev2Sk .jh-.h  s?{.\ׅRJWJU%eRꃡ/@2I 8 & =X@+ %97BҜ+\:w֗;LeƺV]"e?X 7p;44T*l6@ 3 ᴀը((A9FEetQHA {V ;JRq ֽsPkFn(PT+zACl~Ss EA:eY|})# `aat⃹AtL(!NӨþ! vM[W|ҙ7Lxpo35TyheYXvmǭG( F$)A 4d$QP!}*iT XpCK8f $~G%4%u] b ؖ (xҥȜ!yҀt2?ڵk#A&#R9.L.P ,"5f¹f@IftMks|xA$g~A!( qNȌAM `Op& (6u]LLLcZ7N+R %˜rSZXOK2@i\!~aD}vQ?n `]5!]=Ѽ1gzAJ?X#</K\$H_~Z>BئM."{[n}`zzhoofkv7`a!7ǡ$a= ϪYI$bwH&S `xxlJ)obT;|s EI z'\Y~zFxXi.MdTi"50h)8V P!@* E#JaBq)`DiA6Y{&@#$R9 oG]!r&` !Br8I߆q`;R )PH:Avmi(o߾_=zǧN[Xq!`u"uF{ z3jzn}BYxuR+ hĆ,[55 g ėqM(Σ85kP-go⡇B* @ssM$@(cEˊs ?r,R= k?C]z6 ى`]-d2/~q|[߂mۤ̑:;;C0GY?y Ǜ1r@!`Eoqӥؼy:p188gxaY'rIꬫD"mJib`((x#$k577ëW~siرcz'p뭷.qy8vI BľD"mغiVr.\JٿyjT殻RO?4VZmϞ=W'N L&s޶^]W+BJ)w ByyrrްVyk"݃i&<*PǙLj晦RP?p3,,,zcVJhœjNNN[o F?H$C8E mzfnnBlQ%U>/ u@ڶ=JvcX1F1?+q>zzllt:}RUZM *ewsss3HKK #%A)9 \iijj%D"bF!$" Xxs~-˝L&NLji]ThH9 Ҁ]$ff[(1* ݨ*X\Ӵ03 g=)esOZu1~fڶ=r*xr¯w@*`5b4iZ0i-Ƙ!ZJ)K1"#JՀ6TPQij,R+h$5ot-54Ҁ*:W PXtg佖Zf2Hpg1XZmr.*FX|gY6?c dR5BZqH(Imy&-h&$|6vI9tEA8@A(R* "SGǩowMBkzfMr~?ݽ*.VIH0I'+,+"M0,Le.BB(p${W Xî 57Igt~ξqߟ~^ۮዣ+_8=5h,& kF=ǀBj92Gc9" u %YRNdVVuH 'ɜΩLr@Rl ǦKD vbd6oǰ_8c(_l-@" 2<#X]ijjr%.@2UNI"eQ\NR$XaH/YY&|VIYTpX!%M&ڿf}Bkzш5?˲ccofSH4㒡5lf\&PK@ЗXq_;,,8)a_7_M|ۮ]mǢO/X=3/۟K7x/ۇ/;wWb?4!fXQ0/'Sp^i3FO|oXNSg߬IԷN' b6f`WSg]̾sM=w Sq_=ys9l~eaM9n^xgžw5iGWpW#w'}DZWW=)͕}m_o-uMuąLߞ=G^]vX>M.ȤC),j3ta`kG^qJĄA 0pOg [#R0,2vlշa!a \L}]"mR;mvQ#tr0݆[iA1jbW\ÅVtVt.FIu%EЫKgDKׄEóbvg-Z]8dazVK *T]w:RpjΥCˣjM.u` ΘZ='W5Z}CVg0PZ6NuMnTAmͿD]KlvrrM@ڡ-H&[Z?6uhX>qA?oXm`=E썐R j{E`Fk7ضOvTjA~4 4ihBɋfVg8[- ] .6 qq9q3n0 FC=wV.tekʣhK( :@5ٶiYMg \y[+Ty? $mD!,ApCQ(0P!hD数K*l_j` BYXpW0؀jQ x1x$(_dT;hmDcUêJ8NHnn=ް^=lӄ|_/˾S!]A5%kn*>K:,hFmoIH .MP^J$<>.)g Ijevق>R&  #i -0%>)6jeT/pD/Tzi >Q`HB ZŁ]~ 4TlG2.@+u_ AthǺo hXt*!_ ]RшrIiz^,B Md,Nv0^G2 \Pq_X:/dxxav4N nzM] hzf~&qղkRX5 V Zo0Z[h dXFq Q8vX6INF5 kβ30@3CCXe0268]<`S;Y?UiMv:%GI{i˂qcH6&ix*xYlLE2&ЏE7D&KSqI`@ΫG\ja laRWn&[BeS`o:b4DžH4mI>j.pf^L+Nط:nW#wԶ]{Dn - 0 Gvc=LT}gA&Cm`8d'8藩 Sd TAj}xLȦ0?iqp0wU z_S)&Ʉ_PG_,>Xň#F1bĈ#F1bĈ#F1bĈ#A3xdarcs-2.10.2/tests/data/simple-v2.tgz0000644000175000017500000000546612620122474021354 0ustar00guillaumeguillaume00000000000000{L\]lG(hSE*B( _wn!n:[Shk;9nCUB@*@BPԇHUH}hBJ| Kٍ/NYUnv(tMcߒ $z5d'I |!2󕡓P#IooP1c3ljsZ.? ˟bvZ u2L U}[KM URp_W IO)UubVՒ5(-hJ)N lXZSl[aCpƶ xW(&;"+ !(pYM2TM6j'5Z3#~it.L[nBBONlaz/+?MKG&w`&אָp'\hF3L_ѥvgGBa#l#(&9%Sbv 1܀4>y')&1:+FRV  Ĥ$АTMbQB c/Z5>]N}`Kb찵$Qo7CFShg01Z.Y+ B$#^pux|"M~t7 8TПOpLPM =gg񠆘Dۤ|iSht, pXK:60Ѡ103ř㌠~4kf׳6ױv;%ypZ֝ gB;Qq9O^',7RCAȄYHN@zFh` Mh3MLK_D6ړpd/tR`vlo}׌$) Ug7nڱb SцL.unf )[ƤklXB ,l+U~ 7&t7_̗2auq!\P;s={ !8w'1rj&ݠ0?f'vWqiQ Ţ،!̦6 31I^cf`X D^SaQǮ7^-/OY.00z A#3|ʁt2$PXlg~{Z眒uyKe}cf8d w,DiƓcl#80Aq0㙒dB a}PS%vs\9X_Z-;ll-4b'MӥC\r,f~ #7]N;.8\'Bcswˆp0e٠ l󞓰ڔFSsU' T֢zʖ쫫*pJ13l$fF9X) 5`~qŵE-b"Hy?Iʞc -ɎgccCO( m.yzfNǃڊ6a@s%YDAU` Ht# Gb163(@ȑX*J ~ @T0N׸=iP  H& BDG|Ch*ipk `I<"Ds][ ˁ+ A屉,b3-<.YqpepfVYjC/ ?JM9GVh1/ K/. ;|a~v:;w$LgE;IGݙ_D䠓]8|pW^\d[r`8Ѫ.,>=:W[vpkN7.ܝ \LΙR+um`4wA^-n3Ƕg} ~4a C1_]~!)?W6.?pi Q5M? \6NZs.+AWm_KGSZp #lТK)#a7~n~1A1$YJh.K+,7BjےTo5lbV3+RQ4Y)S)T!zE!J bIZK6TP$I]ӛ0U+!аh-jZCұڼ2y\??Dh 'ׅ>y>ޯ?z?ڽ5_Q^??,|k7>g^ہ''_{U?3Oy/,Im?'>}'?~u^mW7?r~?q/o~>7ݭ"q1gs#C2 YʏCwi MHp)72pkAiÁP E.nMe֍VNkb-KS-4Eٖ鲢 ? l^:~s`Rƅ.W¥(FTUմMɔ [5V6Z*똨Qjh)ՖjIds_ޖ7lUˈR?? d.[C{AW3?#no?6isRfo|Vz;K?z薳g޺ӿ}wW#SpmaF] ?!?|$t4+FK?yl4?n&w4ȓfC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@`?\xdarcs-2.10.2/tests/data/simple-v1.dpatch0000644000175000017500000000067112620122474022003 0ustar00guillaumeguillaume000000000000001 patch for repository /home/ganesh/darcs-comp/temp/empty: patch 060052b3182f512c548d15dc6789228178cd9a4e Author: Ganesh Sittampalam Date: Wed Oct 20 07:12:31 BST 2010 * wibble New patches: [wibble Ganesh Sittampalam **20101020061231 Ignore-this: f4ff110805aca7a2d8805acf18605523 ] { addfile ./wibble hunk ./wibble 1 +wibble } Context: Patch bundle hash: 3c6e5041f7e4b286c8884247a155a5d80d0dd77b darcs-2.10.2/tests/data/minimal-darcs-2_4.tgz0000644000175000017500000000656312620122474022637 0ustar00guillaumeguillaume00000000000000{.L[yl7 X |$$N8؎f;3 @ӐBUJ" U=BQBpV (m T$ffk֞w~}{Mōs b0$ȿ,ϰ '1"OJLƟw=)=V8F9(iq:I`nv8ͱiN0&I)rIg$䕔HTJ̊4#0I-jAf‭d9y6Z2&Dqz*JT))fS&ʧ| Ũ ֣:㬤 <q<F)r@&US0fRcÑQ_7U?>}?Ex_dۼ;2}ռ ~{k/zȮvU͉Ua.3tZko~ƔקO=| _o~{}sya 8Ss:>J#8#/ ɘOxbQʁQocOɎ'Vx)90:[#J<8a"$|׈cO%EI}\q^dL"7F( =RIG&||p3)헟M4bǽO޽|򎗷_p??Qn{tGXV{~ͼ4.^}{Ų.zk]tvOرE(iQSyUK Ij `r,NI&Iȩ,aVd49^"/?;m=3gf/͝vKnm7^ysK/oi~{=7/?w۞wor7{{3mҽPsłK~+U:qTL$!e^f$'F 2l*`MM1>J&i/&GY0 IRf)MaOcM K7I,E>-!|ZHYBCNN GKIܤ_M:?eb 0!(+&G g9i?I?9nz{T [[, 8J(!{YdHAMyYcǮ7yςF/tHFզ!ȨdӣܺD E)Eպtpk1oAP+8eטf?6$&@&ςVh?ͤҖ DY̢J\mF[j2D5.4Tٰ m Wh TK)4/j HN)YP|'9+]+k> ]Uhi_?)H Q_Yn~n},VYIaCEBAl#~EzH.3Y&(a:Y-ˣVxW,y5Qs;\۱ vwМmU flѽ:N kA75 yz_iu0Ԟݰ|G=1 H_b+ u5ЪawC)$<  RWaPMHF4A Qp?@zPQ&h>xK*Lj:8CXwbϣ]%tEG΃^ÜpC(;G 2O4.mZ@;԰[\PiAy=m mwAH2! x<RvO& .vA 6tNm5D[aJ:y-ujT!+TQy#`@x{X, :!L?8ki# ns[ (XuvzzbvzBa Ď;ibVP4~ 941D T?s@To8e0a̽nCUBSz+!QPqqSXwr[Q^~q\1/)fetTyߴR쳽i%]ca Q\2L\U,2HgWu 2fLUw^V u]( OuCӺd8khεÒ4%{=РoԽ:M``23],6 :J{襱aoh@@q.0* 5^ jZxrピDp:eb0F2 oI6o.̭LEp&dM5r^;U9+|VLvPЙQBsTf UoYlX$0`.[ZVZPAP:jl",a]rüOt]. GUx_U+ȢP?XqDgXV?#N{7d3}?'#1+ ^y#gqSrW3Hܶje;ŧܰkC w=kh'vj֛{_m[o3sk^ }]?޾O?w*>hxn{v'>xߜy&ywXsV=8id7-߲`Mlmvx?q>pJe68tXyhZaeAŏ25#@뉊`AթuW;?覃,` u@[9٠[ g~A1cTu=43?L:5:ځL\NdzLjս2aU,ڠmqDsAhV+QP١_kgOx&.JZS jpYUG=`FSk5]5( qu*'H Ь9]ԤiZYnkI5*hgM`spHvL+ ; iet2&m{j`yT0 Ldc"ZT($ah @+!80A\G"C<ԷEJvăAM&(E:gZԕ[-1{}*[5kb" vRsIӿ6;%bzr@]KI`Ra)Zl rG؁Toig:h=6JAvffS, x¬~ٚuz\5aJQ3H5t#rRk4ZŽCA?ucxAQ %&L?81 S-VʰQ4ޱ $JHD`%PUp4b{N $:# Gb16#(R<ȑhJ0}_ &J amviPXuĂA@0,-8}"pk `IqwtMX$]Ps JGPt:S/I%wIl4 MmpŔjᢕ=IaThU]qRpɊZR%, E-M a҄$mY視{ /J .YP Y;bZ!j]9jž u Lu#Yua |11:a"Vja,-]  Q ,3 ?9Єh"6f И rOS7Ұo?Ya53ʟiW/$fe-8#d]=|h|>>b8IIٿ8L@1'/qp% \NtSr ȲjX/pH<'26 H^u2Lfȿ^rS?A9uG O;qKooO1Ksݰ%#~7_2ձkv-}Y涗;3ozOoM=|ڒś=v|W<ֽ7ʷ?z\o_{z哻voXM_rs|䅯_?kץRx/fGc 93Cikr}q2;5IN4Q yC5^,`C5D-_(ȆZDAD(5,BW$y)v̰_hOv)?10 Xg?wz DS_'^e=WrЏ4Ǜ#?mH,E;'~v[uaw=77C_>SDžWm9߸o?ـ^mkn*6kci?. v z/"G?䅠hPrq[x% JyW^x9D-O;` 9E!D22ZvZiԇiffc_Yf/ndTD0IBK">T-W lXV9B 9σSx%'Y% ͐O?Ab?~;騱^:y/oVuz Qd{ K&4#T{Ϲvu%M H8ʳJ,EѤ $qbHT\E-D" ^úeGmDtH` r,y`,{I'9"c)TNr#{ :~_3cɣ#g( dB$&u*(1[v|2Y;GJ?-PHGgZ(T=xL(8(-FFYJhFe $e:XM{_|:;qӞ4?CTi!toN;Vd`uH$^n,㦧B; R6z듮/_J]{^cVu{ژwE^ fzVOYٯp7{OS/\݃rMȞ%?]C3 4)`_xӉJ)OKWepˢ"#.@KhΈ)EY^UQ4R%Ĕg$|e:u8 KZ?^ry.;po^}?z7{W-K T-qڷ[~W[&w߸5&zʖQo=+zz7E_znzg 6h[ZnLpuhGmz]â}UR373Oko{xg7=ʏZ,n=€A_^]¿޿t~͔z^7 kk_+/(%G~'g1#V$83t߉:ϯI6ڭ"sg]'̟m Oιoֶf[]gloUm~}B.oYؼ;')?h2A(j,@%CPhnHJ$E ɩ9F& Gv,֑XΜտ~x($)jq%cKKίq̷&aDt1Cð+jABmgLq20a(z#@u缘G=UA 6 yfD\R"i1RƗ b%y9F1+tltM;M+H4Xٴ27׵qn)nb&T&,&Tw3BalES:@9#,PbEcWNgZblzH`6+")B ƪBHꄬiűq݌ٱxl݌M/sA3#ҙd@?gS "Oԍ 5폸ܱIP(B4 vڐ F9W/*Zq01Q4qD0l#P1"ԡ:xqD H#Fӌj= :@ "J[E *W6 ;3yTx'))!a{Gf۝Yg$EUBB7[/=79Q>n2L 5@0MD=!f]̩s<3cyאY:Pa!NxM CFh@D% l&B?`Ȫ'"E"hV؎#@oP+R\j\2ڼ{>}YO$6`=JA0aԻq}2 F(`Q0 F(`Q0 F(`Q0 F(&darcs-2.10.2/tests/data/many-files--old-fashioned-inventory.tgz0000644000175000017500000025224712620122474026425 0ustar00guillaumeguillaume00000000000000zGmU7 $%Zi *BU{ Ejlڦ J&:4E@ M ċ _b˱RT$T B%b;NJ)D4yfqw8r=7M5h/z5`Z*9zB]SGܡ[+nݡpx믕 FC9F!?N=VVRB Mk;yY{!Ƙ;nK;8AQgڈ6n}c/ԟ+kpտNu7ivGܝ?k@77xÍwp}6^_W^v,P5߾yG^u=Pv9cWb2Ay@̐E tCgQd+ocW&.F?0AW}{񽷼/~=q!I _~c'ڛO ?=1?J?23(- #4eF%[_ px{߳*S|_y=}vvSZ_{Zڟ!!<A$j8K͓nCA5꿭]X_ IAg?z~Omk߳* h7}Ū 843*ꦟG+w?3j{E+s$W3e߿edzS-:X,Fh-2D}H^cQ;P 3G=&b!s-zl? 胇k ГEXiC?[ܦ:K$/?JQU 7F!ȘPQq9'נgVTϮ핛 ?#;m&:U3 ȠIF?Ugzf}Vb!?Ep< yA+kEdЉόU^ /o`fS[_9J_,E#MbIP7f|1$Јa(,³D5꿽E.WkP8//q`kg7ZZ-}y bǐS7y&Y.t6gdy MH$):s>`0pfCsFW@J/ Pinߗoyel`*}üd9$fT(_?}&/?J_RX oLe -Bp\[QqoP9A<϶ϑ JvpD4qxd dl^]Ej  J/copB!>X-JZ!l9ȑ?/jW\G Oa< !\ ;Tc(ru 8Qq9U(|?cB'O}qŭ {X3 ){fFOu(_b'u~B!>5XmyZ0-09-uF'%O5??:k/no|mP)M)%`'#02 ϋ\cWR_A/FP).2$b,jF'ɲZ0YE%kP) wo} O,Uف)d9]`8< #-y*U ""K9-G%̨Q1_Q9OT)B!>-8&|\ -OMJEt̨Qqo) %ӭ;?xS&=EH1%]^7`H^Ԩ8?͑%N UW ?>-dc@0#:N^ϙє?3jN?u(LJw߃_yB!>CB+&Qv(g?/j4,՛!/?JߴgQ`MmquK99ɚh5??J/d]PG^za0P7ϯ>F{4ՠP ̨Qqo9_7?H_(翢01he %À܃_5??J J?nOB'O}+hlAA 易!$U^qI%(ofԨ(C/h% w:6B!>U*Ǥ:bN6UQ眽B|d2 C͌v_ B?>._ OW%R…"y0YRZ5ڇ, H)wfԨ8(?CKO z ڨh* 6 R2E Mόv_U(=+$/?J_5QI`7Vh4+}4:ђEϐ*_;>.{ZB!>5(Juܧd.hG\3^Ԩ8JP9 7~ B!':N; Vc"hL3f& ev5E/P]ߏB'O_"811Chz~L[m?/j_j0T)HM2蜬qR&gb}&gQq5?uS Xѧ$/?JD4%-f w(AStӼS̨Qqn_/1o⩻ O7}p3 8`NIgFP9O %/?J27&mMҍdͭe^눘ό*iB?5.ޟ ?o\t[`bT`LG3JGt:_S?~CB'O}7y!z:,V.Ad?/jE(B_()0<ո'kX{0 0^Ԩ8?P9`IB! oٸV^'Ww[;'xCS̨Qqo4]_'7 ?>-+l [k>Qz 2 )w]WVL4"R)[Zm^kwV|[Pf?Z, bFJۤ b $E4sE "m,BM,AAM#;s !99ugŬ]ٹR:PF# r|.?h-_ߙ-D(Jt>Q %`Cșk@YzaX#z1MG__N.7^!25.+o= _*w6ۇ~eF/_S1\\1)  y9X$v:KWGy'-_e_ K ƘP3WC9W-f@E ,Z+=꿎0nc/?h-'T2>J-e_W]0:_Im^a5F/gk^Q*13sK4!p:?~=F/gkБIUPIS2 #g25ңo'.i /L|"?h-j֬b ѹ1ZJ*:y:%-z/ۅ_ZSLT2j 5SfS֢IYzq'ݻ{H;j-"T!*eOiRhfYzoH]`nC0arUV!GjEYW*/Wz]{} K?hu-]X4cBJV;KV?]?ZMF/g/Ak͠h,S !U@:HW?|U[ӕ #00g6pX;KoHuIm-<_-?h-e RюuT!V"Gg.i'W'o4?߬S3U2@MTl-T5F G(?7/ sd7 ,uii!Ey*Ӹ?W FKVC%5QjңǴǓoԫ_bâ8I:y=wo KoIEVdC.7tsa+F,=꿎rO4@{lϓ/__5fkUt ~lQBc 末_QuiOwITiF/g^j9J:k ^Ggy%K_Vb`w4?_zcp 5*hΠ )qI\;K㿝KZs߼%?h-B8K@Tq+䢏9:,=꿎??T?gj ?h-b⒲1C_EcġwxSrV9*q'-7.{w\[q)DNā%1cP\2v_q?T?gj= #7]!U ؒr6(z9Yz?EϙG_d|)#DT5kr6}G#IM^w&=A#oVM#Fp ߧ p7Lsz[zi:'/_;S7C߈W5ѳ lLփ_Qu@.ir{_/?h-}4UJ*S2Qg ޘh0$Wz?i}8#F/g >_-?h--d5H3"wgQu-]Ut{_Bީæib= s(+;K uIm.?8_z3 z3z GP2fK:r U `}G 5?[/zA#o-3}gb@ Tc`C5`Gh= NWF[@Tc!Z)p:hvY[u!'e+=꿎f9%-{J_7!g4G3q*_LVBH9ZeogRUQ%-W?O7 Ko)j`gr, @ \3b<"tD-;K?OdKZo,?8^| 7~h)iLP>QY>FFT kuIWf9O<7 K?a֫d TD͑uV,=꿆F*y%-b2w*?j-FGW[fRMG O%uɒ U,W wp;97yk_h)jjhh$Iư*UrTgQg?=G44|^z㥇^wH-?_R)%_,WЪ%w_tz \|21F lrTl!g)[zGKo [?{ ZK4!9Jmvl|T,WzGrKo E_ڛ_WšbrtiF8t$wv?a%&[޽7}ozۗ~'oz| /y㧿K?ן s>]هc Z,=n4ab~._2?_aʔ-T/@Ġ XB5V WzO>i-Eώȋn AήSX8o-)MFңGy%-_nhF_OCF/a֨!`EEç=] W+Z# w_=%Mr<."?d}!Y3 Vy )LcrA:O-tI؞[~/_Q +GD|5at J? {8ƷW['ȥɤRb1+!o9Aw_]g/O}r > M0P9d[9SZJIm]q7>&?d->``!t`% c|aS;K#&? Yӗ<4|f6&AL@N5<&[K/>6W KXG)ǢsLbM*`jTВ2UYzGuIm} z0 _.qNJCOV%]B$JQ_.ik;oCF/JT<TO1ӨGwIW_!#o= s*ۨҞ8ᬁ8K}G iseCM[c`g9ij!) ;%v_ Ӟ_LO2W4ܪRYZ]06%-+wi=opۄ_ C|&PI%=\J ?7KfV@A6&t:g_Qu O/fo:!#ogTq&e  :GwIm^{/o2JUőwn]UvR JB'Z{o1F(H PiЋb:V(*pEKrL2X*! <=`Hwc?|3.<p~}=r g5(F %+TT9_'VwIm|['w1?Mզ(UNZ(~$O1&&%DңcϴFm_^0k9w^ys%5-cQeIgx+e5E-cFD^V9PJT§PCVzyKZsf/}3w?MVC)RS/5e*%E.9DmG&sS]_a1xm І\j@!BƙdVz2>i˙f2?_IjuK`SFI`61_&?h]/0w?MERT DD$y(61jn,=꿌iGߋ?1w?JrXP I %i#?K/?&GgN=]_'kB6j˰6 2Y&#RT6Տ:(o-=꿌46_|z^[a2?_c%]Fƒ'+@g#ң?]o#a3f)%oOQPpAao+=꿌%-k~W?e55Q|@䘄, 1PZYT46 #'Ma=7:.gՇ%k`1D*$7_3.i_2?g5u.btN5>K(6l}[K/tI#$a3HBe„P ]tsQZJ:{~2|KoZ~/e2?ߓ2Ja E0]ovJ/E?&sG|oa3//_"\fm@(PbW:;0Wg+< |  la ҥ? 8do2w?MIJlS~}!KQ@ %"&@ .jGmGXCx0k6&S ΉAkWFfG|ң?_4)18{ OPHTFHY'%IEze \"%M7ꑹF[ OWnj+P&8&9ЇD2XEXzr|Ko*xf^[^e_NWa'RKeP7Gaa(UJ/=g}o2w?M.#1D $JBk*>Hm2.i3}?e+MTFFmCS"hsPG_?~%M-W O#ɨ,i,F%( |&jGXOZ?7s?_z/ a3h ^: J^jC(&T2&f?;?]_';(UQQ#]z=$>2_.i_2g{.g(A$B6(ȥ,|07._&_==?e5򿒒RPE(D _ ZUBVzz^ya3*ޚ3ԖoA(]1YQ,YXzz}J.g_MZ).V HbVXzO _{K9)>7_c4]G_e5_#щ@S!>:aK/G?y0w?EWˤh@-$e0 */ 0_>iS=ti.g5'5f<0Ն` Ƞ5>Jң?.ij#׼<a3KYkm4&(P3ge,%Mظ3w?MBZM*$b%xi!h7_?!ظCϾ0ksרJ@}(|V$,cD,h)[K/AK?d8sb2?_ \R;xіH؃2ېl61аKok7a3DW 1 Q{/ ^iDȐ"[Qe?ꗜ.g=9#i];}1!Ru X!cQ&3{_9=L> ?}ı/?}=Gn?g5ameNX6UNXe.mGh.iS^󵟻0kRxpbHG2$co+=XtImߙǎ~kv?MCy0w?MQ@k-A͟lIH J4Hl,=꿈rX4?O ޏ_e5X$~br xӦPt"gIa?f.g) W<נ6D0Y)]J/QgIa࿹d2?_K)eB!:'>do+=꿌Е9|O4?''~c2?_Uv} *%iR$QSLb_177\x0kt)H #TVƊ"2<o,]꿈 ~%M|oO _&YH>l t>GS?) Y.g_4 CP-ΨJ= n,=꿌,]#Gߛ_; OwPV(%kDA:u(lK/ъ]{S?) 姮.gJٓOA AìQe ңpM{qǎ8a3"a dr()$'mnYYǧ,,:AΤdoMuk|P^r*t$˵,(?ABhpfJ:*9fTTꇘ [ۧhg{a)u2`jіsVt *ڀ2h+# w(!}R8'~uO2T*x4rW.&5)*o_I}-™ﱗKךD ]t08M!B }eWhm6!#_\`Q[J#K*:F9*G?cS!#owMIDmrLђ;ˈyoHz7 p{CF/]Glj_v92bj4*;ˈjt\̴?_CF/1*E~1꟱:Oxr _CcWf!#_{v*aCY dKց`T8X _3}#gUgo(?d-!x@mbM`;+# o#gUgο} &U1|.(WFtYwϏ_gkREے(d[VYHJ_1u?Cgk&߳_2%US|amSؙD4CPP`yog1uw7(Tm]ꕋxb66-pI?;ˈ3$=??o;?>!#oqљ*@CQT1;ˈ_X? ]tG_g+Ɯ!(Sc}"H:M db}e7$=tɟ)!#oS!Z5 $&g=By2b^HK/MɯxDףwPL^T8-(Fdt@N WFt?GcF/is*R :N.P#U>d _.4~D[l?ߨ_N@PʦG2b oHOO Kwc8X. ѬM*Xt٥&~շ Ek.'w:\m?䠵 k }eHKk+2eW $oH4p-:?H}CKM>*?d-?_R92RP\L"WFAL?{_{]V!Y)#Zzg @Au4h1rP9M3" `AQ4)Lw%f~Y 7|?{~_3Vеx=//.:y`1m?(!G2^آoE/`Lר5mWq1X1mMv2_.s1!)O}ksHj+#4gw{;ۿX^'?_z~ϭ+o-/J{+JNŔ\mժu\ .N8y`1m? I}~[tn O/Wl JSQY+#O?Of}+>"_kpPL)&ɢ|iPu+#濍@kf[_Ptl3 XzEqce7&!y?$]z5~)#ߌ9yjFB]k ׆K([r`1m׷(sDzǓ_2kOΚٷ&7h\NdW}u>!c#3/3)#nJ&?e=_=*UK IG\KT H+KwS{]+VkU^1Ep _Vce_t{k ?e=_m*E{Б dhZK =XFi<.|_3(WGrs$c6 *h6dK|`1m.)##:%)-ޖXB:ꐁʈo?ܢLc.?O? OO_1#vU.@ (?VF'.?/|{2k翢ѓH B2b?Dp;_kA 4mLWsL-9\b,##-e)#b &1 1f&bC?WW m?Ia@\[kR tZ (ߐt:{u>z˿ Of?9OJQ1Sn&Yx6L8e++SF/TV7.A׆ UTS$2bϓG1Õ])Ly3SF/=f.n1M!\0r`1m?L!Õ])L)# Gp6"de+R[[ ?VFa!+_(锲Ggi@SF/]Ug9[w\MQjJ!*jCcenQ7Ck?^*?e=u`gPBrGd,#濍G!fG OO_09S6dJqh;XFq>'֯W{O*g;ݮ VR/ZA*:s9g0,D/-gyP]6J2Xw?u.{=|߷O>??WsίP4_"-̾oCP@ ΢~GWf'SF!|y,RبM;a?7bLH6g`zWQ+wd[X rAs)rQX1mCk;I({>aHޚd D$Oљ\b*)3&=?zk~Q+XȅYa3Fw&3G?"]?<:E1)Wj|ū}պnTcS+#WϠgQ(;k`9%j|"r fw)gk2b !zyxa)WZ(`!S\"͸ecu_ߤ?edkEbC<\(!ˈoqzHzH({ f@P\$%~J6ۆ {6_?D!3SF'ͦ60-BOI*O?VFLzHxwwvQ+Gh)S2>ZG#ؒAːo⿨`g(OO/W"T!rcÉ%Vk )ˈ_!f߳wSF5b2'/MK<)[mJp(Hz_{P({J2}Sr%!^&k_?Y)W߈oSJ-%RhCpr05M@Ȩǒ~?$=5wT2_Sg)ن5Z3T1mwM{6_?,zH<ſzQ+( JS} QjT8ʈot=9/i)W_Y66B|NjN`STW6_?I]?eyQ+swAR d#N~8qhs*[Pϐt{?SF5@YȮmd _}jP6_$!c{_kb Xs6dSbs+D,#濍2.?6k/?~߼P(7n 1cWs!Eʈoq..gߋ~u?e=d TK&4jC֕fs&[3zHz{ϳT2_S`tj!fW  \ 2bt߽fd+?e=w\( FfWeA=?&=5n[_k - >efI{et=їSF`K\Ɇ as!ט Vˈ_~]? ]gߧU2_dj̶ .'Pce7_.A?"]gWV2_> gki"@1\o~ǽSFSB$f싰3TˈoC!V9W6rE|&]InZR,#濍G5?e=]|mbȵ\}LPX1m?.ӓ…? ޤ?e=_QYs66\lc?XFywHp.SF$CbVޣ#2bvzoHp.ܿ?(OO/WphTa39Ja*`jJ$ce#t;=)\ůhO+OO/! %f/ʆbT(N)7C3=)\ySFOKL2(TKFg)@'2b.I}_~䷞R2Ͻ-P1bmdPV#իʈo?t=MO w/}Q+w?-w 1D\U SՅ$ɐ1?O*OO/i $YgS&|}5J2e;0]z`_SFddifVp"fX1L,P+#5wzR}ŏZ({R \l)a<9' @R,#濍THWI'~ߪ?e=_9N TS&19̕h*ʈo#![}(OFۘ͞Z"J,eB:>hCդ YyVoHE76" 4$f0)S:CبPd@5N/jeSoO{}i7<sùygcuQ$WF t?s!#o|5{"T-B\>}pQPʈ$!'˟?2fߪ?Gƙ Y,;9yD#iʈUGI}/8~#/CF/7+r9= JZ{TSCeW%{/T[*H $[Ķ `4Zka _=t]_pWk__. '\ RqʸFMAIחu 7?WDPָ(`|k_1uFC?,wX[ڻl &W2udumߝe'gH:a_Lx oE[=*1&А !}e!K73__:AfU\YF yoHzyG_g{uhT\ Ѥj(R rM_jyt'!#obME ۢ3_1u7V.?Zq}e oIHGlp.XJeYF_+!'_gk/FQQSRN欕v +%./9^LG Ml5zC`SV5wDѳgg1u?,uh uvրϬNZ`sDS(%[K%{yg1u,iϺ_jrNDLU^լBŴV )+#濎gZzo"?d[q+E&hM`h:Y퇞}}eWߜ?!釾CF/jd!Mlj*SD6Jy6:? -3s2*Ⱦzس!4j4cQ2ؖ_1utKע=XJMC( 'F/eLϨWOpo}!#oj"T\ jXCц3]U|F/v.?_=tǗ?,?d-" YcD4Į( WF'kF-zkCF/|/5Ujq8zk}덢kʈCZIF-צzNj^!?d['ImNxV;3y]U;ˈ? d:o_o2yD>hv\4*Tj|Urg1u?*tu!#o=PD1ibJŢs1VAGFa YFDžweiI!#o^O̾Fkx*5 YF&?$]WGfkPQ\ tzkU1!¬w^j_1cO[V,)R%RR*80-|] YF?6rHOgc!#oj8'LJN 5E YF4!å'ߧ!#ߊ׭ۖ_ )0T > Q%O}e'!="?d-?)9 L`ͦʈ-GDŽ_g{[!QM{O*Z"D\S$WFd.q>x ?d-?ߙ{P\A  yW3V+g2b/.;2ZrT\"@qIjy2b7TrHd_aӗ|CF/Ibu{pSXAi_l }eo?!^u>ڧ~]O} _g䅯?KWkJAWb-Kʣr9D9k2b۔QJ bǾvp]ɁmIFkLq jMޝX,#濎DzDztU[c(VzvVOZ;ˈbK_'6[N7х .1IeWQ;ˈ?N\.?'ߛO KwٕR󆓷ɪhL)u5g _t?oyD[\a.iTU9jO΃(%YF&oHz?_o2|MCd;="^; Le! G^s^$?d-?_6UW4S0*E1*AY:_'cF/B(Zո9xd,WFYMHd_OK#v9QgSPԄɔw_8.{ ?d-?#S[щۺ_:T1*],d;ˈ1rHO*?d-?[sbД\-k3dUI S:g1u?OeCF/\NcXrx fFP~(WI}ߵ&>'?d-oXcUGj۟5ru&ek-u&RuvF1 B]q:_y?7\iDFmK qZ,^>=O?j_o^1ۛo\}7P^sWDD/߲+Ts jf B6)Q_лl c?I Mo(?&?_rgŕ|MU>df2!Tc*oS?HC"_.Ƙ"7 FUkA/z|PH-s)CxïT(}Ze!Tߎo[pC"osdΌT d]+ѹJ0p=Z}e߷D/߰i^%IT?lH:f éN/zt_>BzydyPL-ƨHLDu %p8U/B -_/LFH-FebBQ WbY/z9eMw]!?$?_ %rDj3\"(rogt*Oo_'D/tY큫cSk3E'.4gFEŪђ1`~OG1u?`߅?F?%!P hbCpNQAU+vFa ;?]|UH-qdb#CHl!(d'c?_?^}JH-SrUcb=2Q3zᯋ;_7q_e6WJVpֿ&$gE]h7~[j0µ*pϔXk1Uc9vǧ|߾ZH ߨBIQ.蔜 ]Jl`U&_:e߅RY_2TT %טkF2MDk8U_:k߅'~UIq^UFNIO$hD_Fwv,>F`?.M% BY'/۫[eͤs~}@Ⱥx\_:?TBY'?i!Z dEvKJ2v1RwFqBY'3*?$e1s d]J";9ķA/zaJs7?7'?$?]RUX#!dCbT}c?H.4ExR̕~[$o,Ô)¤O6T $=c?.?צww|@H-{808mq.C.Kz.wF!o]h:?_WH_ u&Qœ k0Ο Eҥ\/oZi:go1yɇavdB(Gg9x`*k8H@;wfϩC"ostȾutK٪&zJ^ǜ;)fϩe?2U1X2i $Pe($Y3|#M7MOoE*%XkC-[ %(R=c@]hsjMo+{ڢ5WRhM՞:J}cjԲOSD/߲u2:+6ZD.)\wF+AgN-4}(K.2>YIQ/Stʛ>'?$?_+eЬ Jx H\sQIAwF_]hߨstɻ.9&?_YZ< ސDɺ8+=cLjmF/[uɦ2N-RKXJ`9g (=cP~߅k0GD/_aBKل"Wp96HMQdGc? M-Oo~wWH _┋h1:.1rɠ$:&d_:gӅ?j|?~[TQƇZ-{L*+Oo_w:1P߅?j_}C"os5/%rԬu`TPL cOchEwxR7^H-Vf`׊md GR@/zwC-Óߗe!Ė5>kJlRLkd}cBiFӿD/߲+QSLIke0v%P (=?-Ó7!/c1=c!!{XbR K;|߅_gD/߲/1jv6`L'"'Bt%Y4hׇ9/ÓSC"osZ+ʼnAGOZWG |,=c}hExR#w[5[]1!넧z_j(vvl7e!`1ژ L5_"MgMx'D/߰a&*ZNt>;TXbrog:c]hWy[ (Wҥ1#fR`vFQ]h{&?$e%)ZS*7cŬUZ{W_Os4?n[n赳I:V2Wg  -òOS[6X`4l3\Ce t_:߅a?_/c"os&TiP@&u::L_3G߃6~TH-:W:(V'g6foRc? Ms_a:O_eW `!8Ur~dMJ Uh;_o`>x[e) ptT d%% =c߇?XaןvC"_4`P #Zh&[}c?]hk|AH-(]u>T \qY3z .4=O|[WZCH5c8j9_p1o^`]}{"?$s X aFzqȆ#c?@}hŷ.?$?_S>xV읬h>w+߆V\t%A,#-roHzпO?CF/$ۿCUU!Eh`2b5GZ/L|%?$?d-?_}H=9TBXo?ٗV"}e G^ݿ.!#_7W`&GUX"%2bIWiSCF/WX딭2)$)TbTg1u?V3$]Ӵ_x hQ"gCJj:?roHh^x o{_T>cnR@\bAN&8;W2bNϘtOWKW 9pGDW=fW뜩)_1k?1&?} xWɔ"L_1u'[ I}&߷>/ Kהog͑mfbʈ㌜.KM zm[@d!)-(Xwg1uHzܿ?v 7?wt6&jcl*.LX:??$]ǿA1#oYU-5^Tb(ۖ33m;ˈ?rHz_/?_g;Z;+@%U"X@}e./zo~_ UFiA0xȕ#ų7 i2btWO=2JT%Y"q4:"m(1$v_wzoD'kg K& b$Ԥt˧509M,ߝe_P I}^{!#_Ogo%s.U%{ھ8"y:?NI}_O/=y Oh(6mBtе6N,#濎f;$]zד'| KPȣA 0Pf2b_+?koo|ebwO?O[.) AQPMJO:ƪz2b#Ƥ=ߥ!#op7T!Z\A2H٪*vH?ӿ 7?עb)smI\k1\ PCYF'?&=c~׿@[d&lNs5a:O,w_;$]\8O25qĄM̅$ TʈQI}_y Kwڶ%փjd8EJrg1UדDpF!#o^.D% Qjji ju}eAy?&][o{ OJvb rWT*(YFO?$]7=~!#o+w" 7͜TSnQ(j{ːZCK/NK{ )bgBHo` 2,WF(!k_N-߅_gk /:O89պ,;ˈ?U}?2Gr0Fb膫a$WFl'%KKϥ}w z?!hMBFy PZA-j-"WFOroHzO߼I[Cp5g#_*&CMT>OQrog1uwV!*c͛_Q[e_!Y p]/^jʈQW~.{J-;5ߑ_gk 7XUEOgҿ&E|O[[S.V)q0} jl\\{.rg1uDw]=  +*,0u> NѰ1TA:O?y?&]K??=!#o6ijSߖUv%rT3-s)(,#濎'Et5/v_V!#_SM`-ZZ*G^c!e8y?$]}OG _g{Tbme4k3I=`;ˈ?N?$=_o_xw2AoB5bBl,#濎4IKc%?d-?]X~!W=]C2*Yp2b?HzwW6 |0)Fà}X:Lt`+ʈ}e@~.M? K_Xbq%6cΔס*gMtDr4}eWߞH.sK-?d g+'24ڶa`œ*)k1[Ft_I=y'?uI!#_/*V4f(*ja+#濎'#.'^y JM+2Y!j 3%-eNC﹟xA!#o^޵\!@fh?ƅ_+#濎p?$]!#o阔s bNHQb;ˈM{S2XUv!T\DMa6J]4Z3W9_ Gau_CF/䬅bKmIAt}2bUu;ˈ$.a}d=S[5:8j*|#5N,#濎'5/K#)CF/Ld~qYEB Y;F9-eWNDp/_g{`#8"kP>f6915d:a 82bXϐt]X`s -+Р4!IEXsY H!3RZVCAt#Pp^ хT<3L`P)u]tzQiV >u}a7<3<߳f)#_ʅ>ŗUN(acd2??&]=yɏR;?.w1#pIX !{^\[kQ,#꿍u1"!3ӗ_/wgXyŮ\<QP u`Qm? I3V{{,*\vګLcqu$9&J.f< j)#Wƚ EnOs2 ʈ_YH:Gu)L?)#_*G$p*|"ZG D`ceDh+CsSF/{-[US0.`1eDX3+0'~"?e=W͊['V6ZT|(Og]-#꿍".?O o|_/w:[_&WRT S6<ˈo㿙rϐt=O ӿ+?e=BqhfmX c֩XQk?t=O }L;?-א:CSj#gʷ%9deD Kݙgأ?$?e=L*jcKI`k)Ɔ2o'YtҼ߇_=?`B Pb3Lke@?XtFOW;?'V{?\%aPE)h]p\^6O1*>)Lꇞ*)#Tw\PE"er0%?֘ 9XQm?CWIa;ۅ_/w]@456TT@ j2O.?{O$)#Uq5Tuʡ '2h9ˈoa#.?{_|f)#IZ Aj"Fe5%`QkQ.?{ qhsSָ/zƢ ?XF|C_|wOO_X4+L-*ԋ1KJZQ@,#O_,tD7=坯x+>r[9sϹMwox_=  bքfߐu4c9wR#O=)4[o}糄_/wf "4ƣosb%?VF󟿎zH߻\߽] w^K:ǘuk*`x@p9,#꿍c?^/W +Wm𵵊R<G_?-?e=P||Ϧh0X.|`Qm!f2_mMt&s5t E,?VFyO.?^aSF/jW5gfu`Xˑ3C{_SF/-/ xҎ*aHg]*:cdhQm.?^abޮ_/T)բF`vV'k/`b&XQMדX G'es +w$#8(!/)W=*5 3n25E7O!6Ʀ-,# Cy< Z 'g8%vx0&*c4Zg `QmhDz7羯OOWX 7`ٛ& #`XQm?.?o-%?e΄9AL6jG GeDI]_{ۅ_/w,&l\ INS0eDrϘtZ?7᧽ySF/{΍VUzPM.ʈo㿙+CGj7> OO_A]m.چ WQ,#꿍G?"]w3>M{muK&8TDu)UE_ JZI)'?VFaǤkf';_/W[}"/ Z pΦbʭN 7Gkf]=a)#kX % c1l Pʈo!?/OO_FBPlb8|w++[A?"]_e}`^SF/QTBjTk eDXǤ}y_ OO_$P {mkXQm?!?_ZbN;XFyWI}ߥGn2Erm$6c0 [ A.?i2_FS{J|rh4kCM :{oM)#$[X$5\ 3.2oߐtgGG{b&CYh j9.\.sD2 G_=^Qףg5]~S*@aVqԚ3FHeD !2 @MrŪLuAKTlMDs &Ii׳SF/;*ת)Y )K@SM2;XF'+9?$]iw_/1:Zd9ЂN;eD0 ;?%SF/k 1 #;X C,ˈ_ 1*k_/WU ђlhVcH6O?в?$]2_J`Sx89.Y2,?VF'ó OzL>G 2l+m̾AXQm? J?"]=?z@;?,w6Z;&t:iE`f$ˈo?)L}t_/wRdlE%dp\R$_. \K{,#꿍tAgw ?e=k`Ur^vU*9iMceD-.?Xy{_SF/kT>j`sl.@xceD_~w}D{MNg %A3Dh zIQwA ty_2_S@YS\#&kUBP,RdeDC?^e__y GVks Qeԡ CI,#꿍ߐt/*?e=;N6^Fb1&#$]($ʈo1(!?{g[VFI%30ÔǬ]Zsc5 VD4sP, 2I#)tFJ/:s?Ë`0E9j8ed#e탰{xwƻgg_ew[pj׉&C6Ko:?NowW t-Q5X@hlA3zIM.4]Zp_eW{;\ M{o:%WTU1st P߁KN?D/߰q&uĩ@IXyk6GTXlԱzU;Wool?O?&?$?_Md \@aZd#BJdgC"os5c*j][6:UT891u?-?Ҿo_ckBÿB:)b&.1u?B ?2?C"os]4s ٘AҕْJ^/z?_?2=.?$?!hj%4PJ5?O3:|cIƚN>_/g_/_eWbrT[2dpWSt`9g9,.4eK?jK *A!>׺jb_# =VMoS_Iӗ_ (suc -.c*wFae|ӏ!F{1l3a.MHQ{ TW=c߅={D/߲;gK.@\lʛcܰm@ =cׅ.!?$?_UZ^1#R:8 ށ+Hgo:߅?O G*c"_K(ɫ J"b6)ŝnue1Ug5_?]hk:!c%J%C 3AaZq@_cI]hӋ0~QH-u4k)z.h*&2ecɖ0r=cjy MzF _yJH-8d ձ<[9DŰwF!C4ExR{_e_j FQ*ZrA*dB5A;0]h{xF?k!RW', J6㓂]_9O>}EgxRQ$?$Os5g Ft᠏%Org:M(A<__W_*?$?_sUu(oX9\-ry0D=cGy -7cQy])P!P:}.N/z| M_O_e+WS jԎN;G5ۅ?Z'~Wc"os5Ұ,x8g(!kOJʼnwFQ(.4Ѳo_i~GH-::V51*h6C=R| M?[Ֆ T;r^Ec%Z/zOoh5Ss~MC"osUcQYkm}4l@[c*Vr):'=cπG7W_eW.wnLhg+!%g_ B-f?KC"_ѱ19hTc֒ 0;Z?ߕ^Y!NE%BAbr&&orwFAwG?_ew* xD9`JD18vQ~=<]hUs6^>Xe)M.sIAE -ؐT1Uc_oY/ÓHl=D&gL%`V8,f3z'oY/Ó߾/?$?_+u["}`Q5~<QEG_g.4 ^'^&?$?_gKbbTeP 1u| MìIaG>_=?rN#{wmQ>P( *ؤ2aX_:#MmO׈_eLrxWuJù?T hOL_:,A0ExR-?$?c}'d:ŕ(,=S]hfO oD/߲_B5UP0h@d^ZC1u?Fa0[^+?$?_5}OXc SRyvFDEwxRBtxk)8W#s:z:y4S1 -g.]\x Cgw umE*F咏d׃!Ţ-8Mc_u.4>_\tNy8$`dU$r>YO1u?ׅϼ7_zXp ʙb%F&#vFwv,f=q˻UH-;G°"g}D e{_c]h3{SOBH-5A,^2el*K~XŐ|ogWWc߇[^Л榟k}=ygDP\RS6[([kMDdIgg1$g_3~K!"j d#y Ygf}c?g_3O~LH-DBq 3&b`lqk1PA%=S߅?O8}j+a#HM.{^/z M_t'GH-{o}8b4(_wvlsD/߲kpS5sLΒu[\M}c?]h;[`ƻ_%?$sU1:HOVmH: EJ=O4A?~vQH-8E1YpjR:i,Fd\=FuVouww(?$?_ɩPSET bΨ/LcOM>|E_=d0dKIdU*`0{m C }co4?^؛9梜O !brf\Bg:]hR?,0IH-r>ݞ0j 0L_*5/we\Cw>ΔA" a'Bۺ4V] 3B\W5L$#>M_R(Lۙ0$F"PTP@CA box~03gOF`,: 5 ]$&_ňocX?Cnr_ogݩ?%_ɄX|&R c*cPkG1t =/O_;?Ba)tGޑT5dX6_?A_}y{5t곎9X+d /8Ec/B]aGkSWKϕ$!EMqjQ0E5^?#C ~Ϯ0K~FJ=?WS062C qZ>E1;SkGwcG_{mwaWX@B4 Ѥ8|bo!tX`GV)Qw~ -%R+1\nU%8y<۔c]7zo]9?wG_?%_SF=Vr !XJD[ s0FCC?cK (RZKhj&0sj ?#;S_DrAĴZRl9PCM9۪?#_>=5OG]}??W[}+TD߳;B{@okCz!*DkM_'WsWKZ>5B ƈu|] ')QjHB ,^w>(w]wD߳{- Tjflm$+ۚp(c1b?cu߿E?%_)3gq0R U*Fco$A?+D߳kB%"G[ci}28 C)%;#=?,XFDgs/)P02۬?#$zw?cSWK5PH>BI6Rm3D!3JV ~`6f}w~ߧ?%i%&'Y`;8EL@.1b?|=*)Q.54i{tIMT_4Z~?#sh]wl7^s [J=c  $&F3F`|"w0F}]wl7~Oz{͎d۝EJ'Z8 9l!l1bGfusm|;D߳k(HR Doj2ť?# gجn= )Q<%"Rrd^?#nͺ}AJ=Ibv +̓>g@.+N2P!Mn}ODߛr@\r. e\Oňo?͟kw]7{/6_ɅX-T[LNL[D,Fy~~?1GOTJ= X8ZBt"29>`6g߿Lǿ/O_cXO.]Ɯ0;P$Pkt?RwO_g/WΕJe|M 4/ G&(coLV??]tR_Jm!cʦ Zc `&1t;R߿ѧO_;0]>baOyb!dc1b~wwSW&roܼ"a?#ǫJޫ?%ߙ[6x-HL6iSWK%^5b CPk]?R/O_g/W2|VRDH!F4ĕ-ňo^)\~O~EJ=ڀ zxR+)8N:V#!t??|_@?%_`(aN&Mݏ-S.`0ƈo\!t=|p;?.D6L |AZֆXUF?#Y}sO~g??%@d Zl&$K(L?Q!.R~'~SWK=DrI%C* dcz ]y={Ԓ7 fǖ1I˛M,F!?{zu :`LkBHb$VCRTt>mim R$E K0JPВbԠl?4ͤj*{wO!9X_o˂s.?-0a3u6du<۲bATTe2Dpza3EIk/'ršBV0$XF7|?G s C#K+)r2bWԂ?"]{}6.g9z/*폔IucZF/#>7$sW={?~?^og[>|i5?_V,y[ ILוֹBme_ IOG>#xsyѧ/>;?ukUX^JC*i/Zd2b/zGwHR9o;0kT+LeOId/,o,Ctܥ Wv?M?[4wп,VPKD dVFeCwRO}_n7.g9_- 1U[I Jh!XF%C;. ''YTm,c &bb 992bWI}w?:.g V)K1d~)r.`EQ&)bo+#濌GA.?}~o} a3Y"*A@$5 u@!x<_XF}[~keԎJGIg lmi?ˈ/# C'n61w?MOw1f F 6mJBc2Q2b?C?]f_đgg2>+49z͏, MB("[1eo2 ‘xa3OT,%G$b6uOuBˈ/jt7/e2-th(ȉJ1∯o,#'>?&]Ro蕷,a3+8" _zƘL@7_O_.j7^e5?_Qhz uA&LB$do+#濌?:]/D*)( ;<&`)K5[1e?Ptw?eO}RI[bƃ/c]K]ao+c濄G&?$]йMa3wIXBH*1Z.Ĝ|2b?CgoW '; D& ,h1hb K(ʈ/ #?e5=XWW?- tvo&C Fo,#'?oO0k򿖊]LY?}bJ[1e?s/Ny '+it% PiacP$me_?J0_l>uט 5DZ PB֊ e2b(]_91hBN Vc2b'gt6.g^PJޓ1YǠR}VDe;.?C?.gn\$LE5Q_s<2?R!;;`}$a3|2&5uVXN)QBfo+#WCwv{_o.g5_UP@)- !gwc1eo?s7޳]_UQ9F.SJdS|)nXo-#濌HW\;j.gr&i &]0PJ:2?I2{Ke]F.$̖TVuE]me߈vCe9um1w?MOw(&aA26õDUgo+#濌c!Ssn_1oa3b}YM6:ZJc:_<_H~t_7~d29wxįIY_"HJM 1t6ZF 5H~1w?MOW"t@ir9SQjVF?tW7gpݍ]_g[63,tUKRio=[1eo?.?5G!.gjG`)`PZHKFhLmG2bh~t]t}5]2sI(- (=BTهx,VFISe5?ߕS"D(璯x JVyi|6:e!@;מ|5a3_1{MU([WWEPU0oc1|J??Oϝ~Gxԃ<y0kK" Bp+GԮdk,"XF_?)+ I|-O_ǟv?MO |.:鬋ZO (VF I]%-0kJޠhJl M#kr6 ZFǤ w3w?MOא%pbT?Evdo2v`H]ɓw0W-ʤSt`J"U (KH$rZ0_..]_=><ŋ wY :I1[82b>0g3]_tI%4J*=%g i(XFt~uza3' ,u4"@ |2bo5Dz?~ '+y*SV&*SPa066H=}~0kBHi㠠F.DTAgo(7_8?$=s;p]_0_T0  No,#濌ЮC ]_U3XY9K2TE}l-#濌xB~jO>] j+A 4E+E]d)Qj7_ct3w?MOwDp)u ߍOV&b<e.b G=XFLz2?/~czEQV8CEXQMWIrW'O [Qer&kb#^ʐBIrr2?c_ս?eOvcbkk~\UEyceDkw5?W *+Y-2P"Ep5rJYVeD7$]a_<}V Ց'aZw~W\ Eʈo㿂w`n?n/:ʀ_GJWq:jC,ld\bVj?VF'287$]77^2?7?'e*mY,#꿍8.g;>ʿOWUъ(LVw"b[SOD'=XF'3&]}o=S3O"RM%Jv4(߰`u 9XF|GvwQOh#~5eKDJEKH,#꿉z8Cg7Ɂ j5'g}ՓPVjE AkXQk8CoSJ%(Us#bt*ZL6Z=ˈo?gH۵y?|?eOfr2P\ E NXQm?RaH:!0O_ƒ2?79:H٤l/w噃G;+''=KYd  [ND)"$e+#꿍_`oHߞ&}2?_m…認zIfҹ$6Otٕ=)LOOf,SMAYVȐJ*c?XF'HZړ|OZ'TIꈪS&J-7,# Ǥ突=)L73?*3Wrk))r$]XJ9$ˈoL3G?S*T-5 ֥`mla)^YՆI`Qm?iDz7=+){%%l5h%s.5>WU^N IoqOkb6E̖I!h2tYEWg{6!_;kyx#){AZsr˭p!.ekceDL',?~}޻*s2IȤI:i2?wHzo-?2?/e/Ū 9gJ4Bɚ$IMɂ#gV0){WUl2%l(32?!3+{R  .l S mWJ2irp|7pϘt=)Lԛ}ʀ_s0YYsi m17RK?$]fmO ϯz?eO]VUarS(r E5?VF' |?$]O?Ia'2?/:U8Pk^y0TߣeDHHzriO _W?en%OrmSK6SDHŘ ?VFߐtƼW]%{6N'1'!E* NRE,%WU.)`Qm?!_w+o713?//ҖZU%[ 15ֱ6O#pHV=_W=WQI,LUl"gHe2؜eD()boO }2?/̂sR=(8fUK\2&.?+_=~y?eO_ޒoKd 5Qd| ,#꿍O9 I]ko|?eO_v.륌A(J3IoLP$`Q-b(ϊW_}i_hȤ[_}c>r1`VdR2?Ο/ =ii %^^3d֔XPSiO2?!b׳}ϟ KMNI&!'Jմ/df$,#꿍j~=xO{"S#.6TZ b2l4=!c=?o){P*u"Dr5?ˈ_ٟo?o/);?-W]8RmZ%icj Yg-.^r_}?ʀ_J) 9?Z}ak2o0I}^r5?= AFy/hesj7Y0kv?VFgc_9O|?en2|]HՊL3jkBT?ZC/|#ʀ9'WbaQsc5& w6Ӌt_{>2?/5jV:VMH5aclu!c?&]zy?eO_s֛cvXjq5[gceD I}^s){PI Jp: II`RkDzk|7 2?/W\RPf]!HeQEˈo1 .ޜ=j[!eV1jNT$;JX2?!ky>O?r}6Q^*ي`s :xڋ# Y:PA5RZ C0/j-5mT7- u&ɈRQz(jx^ؒ={Ş=,y}o7((ߣeXt;7wS2 r썍XPFYDɾw6OpHfy_Or )VV} rVJ2d[/| I}zW ]+5+r5\BnotVL"bs@dg?eO/$*&ae0'AZh\ˈo濴!k~S 2?k*: m,] Rw8.Vou'_3^w?eO/WEH3((VAˈoaHkf=>"ʀʢ0igXJee) k#G{K+ʀ7(WZ;}#@,\ ^zX1m?F#\=AD* +*\h0%prx Lz[kw' ʀ_P1PR3'1Ip.,-#濍G1OSu2,yIIė[Ýv*UC%K5`1࿔H\h7c){g+#+oHSFi(PΩʈo?OD\h]2?yZ)HSBxcE>:G{w6O"|?$]>O/j!ń@~ p;XF?O?_){g&]|ȉr JgKno5.P2b?Cg:g߽o 2?;%#$w$(O9ڣKˈo!Cgy3?2?{(8c6ۚۋ,IVI?VF'GfuOՄ"U)U72]^*H׹tr?VF6OIf:~{SuB:mW*H[<9%t`p5 56O?aI{u>OBEe`UqBS^#-Ww ˽ޚcɵ]U{9p1MW.?y/<ʀzrKI5r`oE+6]c{ʀw7bN"Qf2$M`:jlleh|뗂 ߉67!s"STeYty/!e?$=-w ^ ޛk>[ED]>gg-8?$]b_ySWi"\0dE·FV#JGe^GSbTcLR`EOQ>a*ˈo??#Gk?7?}-ʀ_::[PK劳դ6l%ceoI}<^U6){񿲏\8]efU(k[ VÜu2HX1mLt]]x}ÿ){_}$ֺs 5'Xw^ʪ*X1m?V3$]W?'SD{T[kQr#~vy\ \ 9(!e6Oc{);_3ՠo)mB42Y,#濍?cSs'^){,\HJcE#sJ_VˈoIz?5黾){FSo?g!YjUiaq-T?VFQb_'Sd%e9 5'Ed"xˈ%1k#){k$+j* ̉U{ ?VF'I}^3O5lMԆJ$TJ?KdsH?VF'1tKʀmW4M@`WS3?VFgt?7/O]*_[QTM!; ZpJőM.`1m?3?"]z} =]^C߫)ʙ5^3s6OtuO]lYReT,)"tGQ7N/c7$];-=_snZ_ːK,-{/RGX1࿲ o__x9% >_?\e162e_H'o{^2?ʉ HI59E],seJRT{&[1?!$>u)w3''$J,eQ Q:6OǤ[+O ʀ_TϮ N>&AV(EQI<`1mtX' ?eO/wEQ8]UcR6=sR)PQʈoфI]}R>1=Ie"+IVcR uC?VF?0]w$VIa= 2?k($ؖV +)z㥒?8'X1d7$]w$VIa#7 Zi+K6y_9f*{6O?LH F+˳j9h8 2bo I]}R ʆr )gSV6~R6O+qHz?ei&_-)wvd*֔ZKUu)fceߊҀ#W^M){SaSP UpdV`d5p`1m?HzW+w?O]Rdne(VzEzN;e;XF'1 Z)"iEgcB)d&'X1m?I}Zjʀ_dt rMI JZ塮,#?&]jUU_2?+ϭu$)H]pFuPI  .?wǿ=_TMR%KU/H5eX1mtWO/2Kq)l^r)񉪀`1m?.g 7?eOWwyԛZ)9|tUH&I?VF| I}Z=w?eO/w[B9V"ehJAˈo?c'?2?{5RRhEeee塰^j4,#濍4tk=5OeB=:< &fi7E3XB^TVEg* $-**~i- i0 x*u  _"jm jx: {7~9sq&ߵz5 җd2u_c2idLZɦqң9]rB ^xRt/9sN uJr( Tp2K<K/?M^x\t?~? uWvz$%)r% $GCs_c4?;[L*/k2rtP9JoUUң?eGo [=IdU R(Y>&R o,=꿌( Hm 5ikf cM6։a1(2h!҉9G j~襟_ɦ$^轭YxN.-a_ 6_cuIm `F_5XOI]D|0o,=꿈4cKo xgFccM.Z> oSrglB Jk*J_8`_4Ϟ}gG~,N}_~˷}oy˿zA}3gLU$""cu"mXz/X6;.M4_gk6FP2&B( 9lң濽4]jXf<0?#m%m?hqK?e??]1?Wy8m}b)AWY H*lG,k6?;?=:LyZDFÂ2VjIY0QLm,=꿌o6w%7_g+:ȉM :{'#Xc4*XzG6k8.CA*'2bY$H K/⿝KoZ|+2Fɲ JRitt\:(Xza;~2ǀ?߭\raNiq^Rr[Qe? o?z={ zJ˨uCC77t.cvm,=꿌Gh&/ˆ}vkkBI-qhixDjXz:O.i}_~A_gk CۗLArjȚxt5O?&)q><*oy>v_g5kwXRp|$/C!bңC8'm2^]_gkk7j5YRٳER9`Xz+Ood;{?1?#vU$ *cvR kj"gXz6'_|Mo_gu1,%.>h<cqn-=꿌G 6?O|=B<\]TMb+MVz9\ wHmߓ 5 2rBFi[k1WiL%Z&Xz:o=d3+"R1yK$eȬTG_g6?ݘ'_gkUY0M<OYd2MX&j׍ޭ?k0 >ْ r ^ŁRGhwIW~c2$}(Ҋ,2i U9hOK <0?࢒Y0Iz^[a$ʉ-bXXz wI'G?{{ =X;U1䜅4H9([Qe7?O_[^|ǀ?ߣIŬ;ɤ*PIZSЇb*?K_ ]|=+"TJ)C'/W᳴:7_g1Imn'm_gkT& ` IZ$ңU?3>i_7-0><{; H\> ~dN^pY*:=[QeÎ6OOg=-űSsdQI tVzGROHǀ?_sd[.fΡ0qv%lJ&2(mGߎ?IM {v7T3Dʫ䆖[u2G"GߎKo~ 1?wO"Ί\Xcpd%o,=꿌 wIM KoCkeR'S|6x G =E?^1?4ev&P6W}%lYtVzGUO=y/ǀ?_sY"Xc)t}T*EbIG>D;>ZU5+\P vyeokң68=?=W9_/IكN} Z3bMPK_WO=?u|ׇG߉oHHٺ@%C/U~SMf=4o+=l?+ߞO?1?8|p@a XrҎsɪT o+=꿌v]M__g\Y,%Jz}rƸl Vzi=g'=^ zQ8} kNY }! n-=꿌G 6?OC? 1?W"H$w 9YQ7aFK/ wImj'叼=*m0Z9E!-Uok'Ys[]Wο=js,;IZ)FrP@DxuϹ-KHdeVBɭfǻG3k6G!O(R1<DA"/ʷm eXM?Qp"@) ?G`o?Dzce?mi|a%8j+ߒ7i2m<j_g3Iamd_>CF°-l.ٲkkguj_?;s?2|kɒ5.u㠪EҶCYb~S/ {ױg'kM{gB4ԺИ2\[w֗t:?b5/fWX/Gg\XTā.cEJ.VM3?W;?8wo6wozO};|y˯Of_>oʅtIX.^.Loj_cM~U0;?`+e״STVt֕L--\jXMl-?Ia,{Vuoro؇ҷ]+"vy6QiUZ5/W? 3X/ۺ(CS:>7mmEK;.L*筫)1/{'){o'cesV”h[Ӥ+Z|IESpU+XMroOQ1?kfQ ٻrX>2UJ>B EXM ?| ?wױg_fm@mB@LEm[W6i{Z5/?Ia^z/f_kcZgL6n\+wmtalS!XXM7'S<?}?ce?޴ep*Rh}ɍєe$.WXc(??Ia^?vՐ+%=^E2Dm)RuT g_b(xw]x$:V7׬C?o\(\hbiZjnUl|ժ)1i ?~.ld_>nj֭'mmi,Eg3 ԲmC!jv}vq/5~p酽z>yi~R_z_:_/=]f>v{ﴶ]P2uv?^nǻ[x'9؝}<죟}8n/3"۽z 48wV_O]xl)6O>Hwc]ڻ]zһ?wv6<64~&孓SuٗptNgWv?q7#[jNlqx9^ڼ|~OGqw/`cߧԚwՍp-CҽHݐ>yoUpw["ni6/H;vp_'zHN8{gΜ=7uW߸t:~m޻[pH荃W$?uNm'OSʵ [[=w7鿫7R[{%gM~;{??I-;@ojRI7/vh?D3z}Rrt?~$u0Js'.6#lEZn1-v¸h-T [L1h)q8B UX^# l+*IJklˠy <;sh؃dN=ÕPH3\ B:Z9 ׂΩG[G:Z9 u&sLH3ԙj3aPg:ΌuVC묆:3Y uf Y ufXg5ԙ4ԙ4ԙ4Yce֙k4\ uZh3 BcIXg>FZh3BcyC ֙:3u6Xgl<`y:R3u6Xg=`PguC-Y`EXgi,YdubEXgk1:\u,MuѦ:lSbE)"۔XgmJ-%Y,rK uV"8A$D&qPg%2:+IYLJduV"8yaEި"oTXg7*Y`E&"TXgI*$Yd ,2I׍H4aIZD 4aE0I$ȨrhIpOq| H' -MXqa$ajk05I\Ŋ &,MXqwfD%DQH< cGaNT"( JIq܄Gr0+*-5`EQH> Ga^T"( JQ02*fqV\Ԩ Jܨ1 jt+.`t7X; $az$y$#CA #ܥ0@^ $0B$I<8'HMa$qHa$&qV\=YDS&I>iDS'I9yDS(M(.X;̔$rPI2a$0V ~+If: $3&qV\?̖$K%d|I2a7aeÈI2a$0d ~2If:$3La$0k ~6I?L$3M +.&N#'D#̜$a$3 +.!a$#lŠG9I?I"fN0s0sHD#̜$ad3'G9Y>GOBMPqObd\!fNObdl!fNObd|!fqV\>ӊ9Y?"fN0sObGMXq 3'G9Y?"fN0s~s܄0sHE:$̜,adϿcE#̜ckE:$̜,!ad3'G9Y?9nŠtH9YC"fNf ~E#̜&̜,!ad 3'tH9YC"fN9nŠtH9YC2bd1s ~9Y?̜&L9YC̜,!fN3'e9n:Fqv9YC̜ZC̜ZC̜ZC̜Z?̜&333333 +.!fN=zV\C̜ZC̜Z 3/<9nŠ˗ai9|fN-_S˗a5j9MXq3&AHStȘ9HSǘ9M(.31sj31sj31s,_1sj31sj31s0sj31sj31sj31s̜ZC̩E:d̜ZC̩E:d̜Z?9nŠtȘ9HStȘ9HS"jƊQ\fN-!c4"2fN#!c4"2fN#c7AōHӈtȘ9HӈtȘ9M!_bY0s"2fN#!c4̜Fts܄333333 3333333a42b42b42b42a42a7ae:id:id:id:idiDӘ9~3 +.ҡiD:Ԙ9H3Oc4"i̜Fst "̜FCӈt1s4fN#iDӘ9MXq5fN#ҡiD:Ԙ9~3Oc4"i̜V?s"j̜VCӊͮEaGPi vd$ޞA) Q Bl 8Eڇ3Q7gnD;ܜ;O͙h3Q7gnD;ܜw9w/vx9ps&L͙(~3Q7=8ޝ37gn/9Ls%W7gr\ݜsus&͙MW7gnrs&L͙(~3Q7gnD;ܜ;xwnD;<ܜvL?7g9͹C~qC7g9͙,~ndss&3Yܜ;g;ts&ۡ3YܜL?7g9w/vLC7g9Y,~nbss^ݜv,C7gPY(~,ps_0ܜvnB 7gPY(~!8a9 0ܜnB 7gP͹C~qpsa9 /ܜnB 7gs\Yh,ps?,~ Ys)~q~1Yd7g)nWSܜ;UܜvnB; 7gPY(~!8a9 0ܜoǹ9 0ܜnB 7Yh,psa9 /ܜnB 7=8ޝhlps6_9/ܜ;ops6ۡݜvl?7g9w/vlC7g9,~nfss_lnf;ts6ۡYܜl?7 9lnf;ts6Yܜ!8ۡݜvnFK7gQ͹C~qts6a90ݜnFK7gznoa=7gznܜo9ss6ܡ'ǻss6a9/ݜnFK7gshlts6a9/ݜnAK70ݜvnA;L7sP9(~tsГݹ90ݜnAK7sP͹C~qtsa9/ݜnAK7shtsa9/ݜnAK79hts_9/ݜnasssݜv?799,~nzrq;799,~nNnD+!8ۡsD9g}{ZܜH7'%͹C~qC7'( tsr"ݜH7'&͹CO.999DQjE9S nQ38FQj·]<8YQjfE9 V ᵨ9|K(5»Ss.J\(5gpԜRs>h Na3QjF9k N]!G;,5gpԜIRs71J(5gpԜYRs>h g38Qj~F9 .h!G;,5gphԜRs6J(5gplԜ; m3QjF9 Nn3QjF9BO.w挵͡5Ρ挵Ρ5ϡ挵ϡ|Ź=率3֐3֒38QjG9Bz;ۡ38 Rj.H9 .38 RjRsDJ\)5gYԜRsFJ\)5C/v 36RjH9{# 38Rj·_P%)5gpԜɑRs'GZy0H9wű.I999nNN#H9W]vsrݜi7''Gɑvsrrݜ;G;l7'wI]vsrrݜi7''G͹C~qvsrݜ%i7'wI]vsrݜi7]vsrݜ%i7'wIɑvsГݹ9Л$.I9KnNs_88wI]vsrݜ%i7'wIɑvs_ݜ%i7'wI]vsrݜi7=8ޝ$.I9KnN$!8a9KnN$.I9Kn9KnN$.I9Kn99^nN$.I9Kn99^nN$.I9Knzrq;7'K]vsrdܜ%7'wI͹C~qqsrdܜ%7'wI]qsrdܜ+xɸ99^2nN$.ɸ9K2nҋsdܜ/7'K]qsrdܜ%7'wI͹C~q9Z3~qn9K2nN$ܡ'ǻssrdܜ%7'wI]qsrdܜ;G;7'K]qsrdܜ%7'wI͹C~qqsrdܜ%7'wI]qsrdܜ%7=8ޝ$.ɸ9K2nN$!89K2nN$.ɸ9K2n$.ɸ9K2nN$!8ۡ$.ɸ9K2nN$!8K]qsrdܜ%7'wI]qsrdܜ+.ɸ9K2nN$.ɸ9K2n9K2nNoN'7\,;R~v\\'9S~xNܞ'9S~z\\(ߜ\9S~zr{G(WJΔߞ77(wJΔߞ7W(GHΔ~99D9Vr\:9E9Wr19FEr~;GYrܞ=^cGk~ڣ 6V{tjn؝rjX=ccGl蒍)jX5=:gcGl蠍]'{tjXU=:kcGwY/_^շoxի?|{ݛo^}ӛwytOoz_?7q;<??__Yd_9oǏ^x<ćYݏ/}>Oz~qK_?۽_]?s_\\\\\\\\\\=;P#darcs-2.10.2/tests/data/simple-v2.dpatch0000644000175000017500000000066512620122474022007 0ustar00guillaumeguillaume000000000000001 patch for repository /home/ganesh/darcs-comp/temp/empty: patch 060052b3182f512c548d15dc6789228178cd9a4e Author: Ganesh Sittampalam Date: Wed Oct 20 07:12:31 BST 2010 * wibble New patches: [wibble Ganesh Sittampalam **20101020061231 Ignore-this: f4ff110805aca7a2d8805acf18605523 ] addfile ./wibble hunk ./wibble 1 +wibble Context: Patch bundle hash: 497c8eb610ad9a25b30ceafd3b4f5c1ff744d21d darcs-2.10.2/tests/data/badrepo.tgz0000644000175000017500000000672112620122474021145 0ustar00guillaumeguillaume00000000000000d6M\ ĔF"3w,Q. Ů',_4;ݳ^/,xXhBXxA`̅cT3_w,1ݝ~^^.vƚ=HR ˱ xc5' OPH{R\>i0}׬>UٿWG7}(SW#oZmݷQWDl+fZ}{HF;d9Q KRô!}Bm;W|N_ePJAH/题b"*XX$*DR5VH{{;B5OzEqŭ?/ [$Wy?qɸbIWN܅Y=Qs;3|eo^SEG\z!/~o웦O6W8{7/+;-|OCxꤩg}xۑcn1~ȜK)lQ7.j[w0kziDyWf?d2ǂjȧiBjZ2 5ŋK >% TS$,I)`nyYG]E( ?29IQºc$,J <^CH)X>i"6$Rz #/sUY=.^ue|<_=/e?_= 7.;)W߻Q4ʼN\եWw1Q:_U$vEKIeEU/)rIHDEE?bKD_  gOfʚ7V_^O_{UaMǝ}-aIh_:pֳ?z{죛"2 HXD 5]AO l"D= ~Hb )vHI%QFQW[ʊCGqƬ{5/xcWfz<:9tgGޮ~Q?90硷zȵ39coW󚵿T,~_, ؃.x}ͅ+Բ{?Yuv=6Fş =kմyP!e?+?ULWbF- & 6 E<ϴ-o"c[qg`)aG3LZƴ +?=<=rsнoC'|&p#13>we'@EkKԛc 50^q8@ _pOsY}`HKFiӲL[mu0S_ K[uS'd` cOsMLJіD;QSȅsQb/6LJ ֊Sg Պm .&ҦQ>cZ*N?/4=8svX)s'3;Z'O3rV~F)o)uZj;<=֍bH=tzp ZHWТURUJaL.v͘6mr1TJLx 2={><mb2QUh *w/,DYD;3z83?pHx2LB7fYCC71(MV.5 ߳ wf-% I94s=L &j\cD~kԧ3ZCX@u'2f]7ڶO. .uAiwBqm(!ÎzR7놉i@~4$`Z |s0h 9̍tl=śd]A&J.V?^^}dA P?X3c/g!k(NY`rf:CCY`HЊe 3PiMf(Xš~|BLqjv,C˂o9ILsPbPv&U͊H6 g56 y 3wlls9mA#oܶ%& F+o968 x7zPAZJ sd4VKԀ`,wPUwJZXn=$j b" 1CACo,@y`.L:ID)%prNA?s35lg:~˃vMa`L|#+^:;[6*֝pq&&5Y>JH4Dl X \pa p0~/ [uasZȇ65O{y5Voîʖ2RQKpYU\P]k%-%Lp3Za';0w^;2uxw杹sth9%0iS= zNyڻk>XVM}sPRMcͦ?+Hk&;q41QsAEĔ"*/":|4O!rÒ óP6 *. _8R.rp"#u׆ue9ՃUI~1>JG'pC0%2y=A\(sNX؝h"p⛄ۮ݇0Ϛ19pp<ⷤ2i4Df2456`HvuN#k, \Ƿ>sJ|'lRp4&[4wl_ODz_?+a2qoIPd},*(>G1$F6p^ae?7_P$­-OIaCw-Tr$aϊt *tcC>axUhcfqrdRHT $膔LzRNTT ab͏ (#ˊ(&yij$8k%K8jj<$4. jRm{?VZF9`U35 ?_Պ3O=O-/o:aĖ>J3~sѷ|SuQo\~'Ϝ|t+.U_t5/mxr-jjRC 3-h ŞyC*v_"U;?y&`Z"߈"Utcc$)<(oޅ?53N:"u޷;׏s\pc89qk7o[¯=}h/r vWp Mh柸tݗqg-62x%Sc:2%/<}OAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAQHxdarcs-2.10.2/tests/data/context-v2.dpatch0000644000175000017500000000136612620122474022201 0ustar00guillaumeguillaume000000000000002 patches for repository /home/ganesh/darcs-comp/temp/empty: patch 573defe88544e8f75a18e530e3aeaf6608951aa1 Author: Ganesh Sittampalam Date: Thu Oct 21 18:28:18 BST 2010 * init patch c8ec7c8b2df55720ba2c3a21adb80790363f421e Author: Ganesh Sittampalam Date: Thu Oct 21 18:28:31 BST 2010 * ABC New patches: [init Ganesh Sittampalam **20101021172818 Ignore-this: 6a770d5966ed23f56e94c08977507388 ] addfile ./wibble hunk ./wibble 1 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 [ABC Ganesh Sittampalam **20101021172831 Ignore-this: 157403967fc6753e0f2540535937da5b ] hunk ./wibble 4 1 2 3 -4 -5 -6 +4A +5B +6C 7 8 9 Context: Patch bundle hash: 846f06469d8639ad0762c33e2030e5c24ebb1832 darcs-2.10.2/tests/data/convert/0000755000175000017500000000000012620122474020455 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/tests/data/convert/darcs1/0000755000175000017500000000000012620122474021632 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/tests/data/convert/darcs1/threewayconflict.dpatch0000644000175000017500000000155312620122474026375 0ustar00guillaumeguillaume000000000000004 patches for repository /tmp/tmp5605/temp/empty-hashed: Sat Oct 16 23:28:14 BST 2010 tester * wibble Sat Oct 16 23:28:14 BST 2010 tester * A Sat Oct 16 23:28:14 BST 2010 tester * B Sat Oct 16 23:28:14 BST 2010 tester * C New patches: [wibble tester**20101016222814 Ignore-this: c125275c671c210086eccb12de9f6c1c ] { addfile ./wibble hunk ./wibble 1 +wibble } [A tester**20101016222814 Ignore-this: 653be63c1f8a6f4bc1de1e45c0ae9084 ] hunk ./wibble 2 wibble +A [B tester**20101016222814 Ignore-this: 1a8e3f57d2baeca09f2dda003e4df58d ] merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) [C tester**20101016222814 Ignore-this: 9d40b33ef1b73b9a950f39c4e8a75dfe ] merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +C ) ) Context: Patch bundle hash: c189b5635aed28be92cfbcf0de65c0f40c79da7a darcs-2.10.2/tests/data/convert/darcs1/twowayconflict.dpatch0000644000175000017500000000117312620122474026075 0ustar00guillaumeguillaume000000000000003 patches for repository /tmp/tmp5677/temp/empty-hashed: Sat Oct 16 23:28:22 BST 2010 tester * wibble Sat Oct 16 23:28:22 BST 2010 tester * A Sat Oct 16 23:28:22 BST 2010 tester * B New patches: [wibble tester**20101016222822 Ignore-this: 88662d08dd524d92ad4cca6df0d643e4 ] { addfile ./wibble hunk ./wibble 1 +wibble } [A tester**20101016222822 Ignore-this: 2d69de402438481946682efcad5e20cd ] hunk ./wibble 2 wibble +A [B tester**20101016222822 Ignore-this: 9c8daaedcb674c022ddbcef19752d694 ] merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) Context: Patch bundle hash: 1e2ce71b56e4666c1b086b09ae351a6c3c768b8c darcs-2.10.2/tests/data/convert/darcs1/threewayanddep.dpatch0000644000175000017500000000216312620122474026025 0ustar00guillaumeguillaume000000000000005 patches for repository /tmp/tmp5530/temp/empty-hashed: Sat Oct 16 23:27:54 BST 2010 tester * wibble Sat Oct 16 23:27:54 BST 2010 tester * A1 Sat Oct 16 23:27:54 BST 2010 tester * A2 Sat Oct 16 23:27:54 BST 2010 tester * B Sat Oct 16 23:27:54 BST 2010 tester * C New patches: [wibble tester**20101016222754 Ignore-this: 355914edd0f88f0ea7c2ef60aec9c2a1 ] { addfile ./wibble hunk ./wibble 1 +wibble } [A1 tester**20101016222754 Ignore-this: 54df34ebd488b772c37c3d43a38b0bfa ] hunk ./wibble 2 wibble +A1 [A2 tester**20101016222754 Ignore-this: 4d1b08c7274743e7d0d2f210518d5a19 ] hunk ./wibble 3 wibble A1 +A2 [B tester**20101016222754 Ignore-this: 9ba51da6bb1506afa2104326cd5df54b ] merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B ) ) [C tester**20101016222754 Ignore-this: 295e8a851b7a936b3d08b0ce7eaaf2ac ] merger 0.0 ( merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B ) ) merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +C ) ) ) Context: Patch bundle hash: 3c77da1c02a49215134a9607493af93d55608f56 darcs-2.10.2/tests/data/convert/darcs1/simple.dpatch0000644000175000017500000000047312620122474024314 0ustar00guillaumeguillaume000000000000001 patch for repository /tmp/tmp5746/temp/empty-hashed: Sat Oct 16 23:28:30 BST 2010 tester * wibble New patches: [wibble tester**20101016222830 Ignore-this: f155bc27211e0233c23b8c0a757b8071 ] { addfile ./wibble hunk ./wibble 1 +wibble } Context: Patch bundle hash: 1bfa82f0941e1dcc13f9f94179dd6a7426ca0b6f darcs-2.10.2/tests/data/convert/darcs1/threewayandmultideps.dpatch0000644000175000017500000000507112620122474027264 0ustar00guillaumeguillaume000000000000007 patches for repository /tmp/tmp5411/temp/empty-hashed: Sat Oct 16 23:27:21 BST 2010 tester * wibble Sat Oct 16 23:27:21 BST 2010 tester * A1 Sat Oct 16 23:27:21 BST 2010 tester * A2 Sat Oct 16 23:27:21 BST 2010 tester * B1 Sat Oct 16 23:27:21 BST 2010 tester * B2 Sat Oct 16 23:27:21 BST 2010 tester * C1 Sat Oct 16 23:27:21 BST 2010 tester * C2 New patches: [wibble tester**20101016222721 Ignore-this: 64432ba123d81c8f0e688b44feb8f587 ] { addfile ./wibble hunk ./wibble 1 +wibble } [A1 tester**20101016222721 Ignore-this: d749f48333e6ff2e994b1df71e76933b ] hunk ./wibble 2 wibble +A1 [A2 tester**20101016222721 Ignore-this: 6f006a52975a708a8038d52e5e39ef0f ] hunk ./wibble 3 wibble A1 +A2 [B1 tester**20101016222721 Ignore-this: f4d4b5b1c73bd6fa8abe6e5e680d66a7 ] merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B1 ) ) [B2 tester**20101016222721 Ignore-this: 1d60b6c0ba913fff4d1e32ad26ae07bb ] merger 0.0 ( merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B1 ) hunk ./wibble 3 +A2 ) merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +B1 hunk ./wibble 2 +A1 ) hunk ./wibble 3 +B2 ) ) [C1 tester**20101016222721 Ignore-this: 25b6a6959d19980ad16983a542c6825 ] merger 0.0 ( merger 0.0 ( merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B1 ) hunk ./wibble 3 +A2 ) merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +B1 hunk ./wibble 2 +A1 ) hunk ./wibble 3 +B2 ) ) merger 0.0 ( merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B1 ) ) merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +C1 ) ) ) ) [C2 tester**20101016222721 Ignore-this: c16d607216c36d5f7727c64d2ec103d4 ] merger 0.0 ( merger 0.0 ( merger 0.0 ( merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B1 ) ) merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +C1 ) ) ) merger 0.0 ( merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B1 ) hunk ./wibble 3 +A2 ) merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +B1 hunk ./wibble 2 +A1 ) hunk ./wibble 3 +B2 ) ) ) merger 0.0 ( merger 0.0 ( merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +C1 ) ) merger 0.0 ( hunk ./wibble 3 +A2 merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +B1 ) ) ) merger 0.0 ( merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A1 hunk ./wibble 2 +C1 ) hunk ./wibble 3 +A2 ) merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +C1 hunk ./wibble 2 +A1 ) hunk ./wibble 3 +C2 ) ) ) ) Context: Patch bundle hash: 1069761dac242f9583871b27db2fabbd00d6f805 darcs-2.10.2/tests/data/convert/darcs1/tworesolutions.dpatch0000644000175000017500000000323412620122474026141 0ustar00guillaumeguillaume000000000000007 patches for repository /tmp/tmp6805/temp/empty-hashed: Sat Oct 16 23:34:33 BST 2010 tester * wibble Sat Oct 16 23:34:33 BST 2010 tester * A Sat Oct 16 23:34:33 BST 2010 tester * B Sat Oct 16 23:34:33 BST 2010 tester * AB Sat Oct 16 23:34:33 BST 2010 tester * C Sat Oct 16 23:34:33 BST 2010 tester * ABC Sat Oct 16 23:34:33 BST 2010 tester * D New patches: [wibble tester**20101016223433 Ignore-this: 577185c51e4839dd1041372fbfa8515b ] { addfile ./wibble hunk ./wibble 1 +wibble } [A tester**20101016223433 Ignore-this: 580c4417986d5c56590bf36f5a125f38 ] hunk ./wibble 2 wibble +A [B tester**20101016223433 Ignore-this: a9f2335fe2dc972fd0bc09edc6252256 ] merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) [AB tester**20101016223433 Ignore-this: cba095e78e2bdfe15dbdf2cb5c69cc6d ] hunk ./wibble 2 wibble +AB [C tester**20101016223433 Ignore-this: da2a7e05abed8dba0077e69e55bd926 ] merger 0.0 ( hunk ./wibble 2 +AB merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +C ) ) ) [ABC tester**20101016223433 Ignore-this: db94de3935df87d0a991c0ab6a58e5b1 ] hunk ./wibble 2 wibble +ABC [D tester**20101016223433 Ignore-this: 829adb4326b290aa6f741b3a15fbabfc ] merger 0.0 ( hunk ./wibble 2 +ABC merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +AB merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +C ) ) ) merger 0.0 ( hunk ./wibble 2 +AB merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +D ) ) ) ) ) Context: Patch bundle hash: 5fc1d0ff89472d10a0b19ae4f7849b1b99d500b4 darcs-2.10.2/tests/data/convert/darcs1/resolution.dpatch0000644000175000017500000000204212620122474025220 0ustar00guillaumeguillaume000000000000005 patches for repository /tmp/tmp6648/temp/empty-hashed: Sat Oct 16 23:32:07 BST 2010 tester * wibble Sat Oct 16 23:32:07 BST 2010 tester * A Sat Oct 16 23:32:07 BST 2010 tester * B Sat Oct 16 23:32:07 BST 2010 tester * AB Sat Oct 16 23:32:07 BST 2010 tester * C New patches: [wibble tester**20101016223207 Ignore-this: 64b5a1e603ddf61e59421bdde45b3bc ] { addfile ./wibble hunk ./wibble 1 +wibble } [A tester**20101016223207 Ignore-this: bc0d30ac5170e1a25ccb20e6cb06ac86 ] hunk ./wibble 2 wibble +A [B tester**20101016223207 Ignore-this: 3bbebcf8fa444bdcb31ab799c6754067 ] merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) [AB tester**20101016223207 Ignore-this: 8fa03d26b9dbbcdb50a323e5c58b16dd ] hunk ./wibble 2 wibble +AB [C tester**20101016223207 Ignore-this: e7c0716361e411645066f8a3c2eff769 ] merger 0.0 ( hunk ./wibble 2 +AB merger 0.0 ( merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +B ) merger 0.0 ( hunk ./wibble 2 +A hunk ./wibble 2 +C ) ) ) Context: Patch bundle hash: b23d175b10d6fdaee3bb25ac92b55723de2822cd darcs-2.10.2/tests/data/convert/darcs2/0000755000175000017500000000000012620122474021633 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/tests/data/convert/darcs2/threewayconflict.dpatch0000644000175000017500000000207312620122474026374 0ustar00guillaumeguillaume000000000000004 patches for repository /tmp/tmp5605/temp/empty-darcs2: patch 8d6bfafe7ac2a628340563d92917da9639a8d509 Author: tester Date: Sat Oct 16 23:28:14 BST 2010 * wibble patch c0a55ca9dedb993d05d2779ca4f72984e87083cd Author: tester Date: Sat Oct 16 23:28:14 BST 2010 * A patch fb027d809948379ca6357d654a6ce8cf45235dfa Author: tester Date: Sat Oct 16 23:28:14 BST 2010 * B patch 7eeb8289feadd843a19485f493235566a2c48bea Author: tester Date: Sat Oct 16 23:28:14 BST 2010 * C New patches: [wibble tester**20101016222814 Ignore-this: c125275c671c210086eccb12de9f6c1c ] addfile ./wibble hunk ./wibble 1 +wibble [A tester**20101016222814 Ignore-this: 653be63c1f8a6f4bc1de1e45c0ae9084 ] hunk ./wibble 2 wibble +A [B tester**20101016222814 Ignore-this: 1a8e3f57d2baeca09f2dda003e4df58d ] conflictor [ hunk ./wibble 2 +A ] : hunk ./wibble 2 +B [C tester**20101016222814 Ignore-this: 9d40b33ef1b73b9a950f39c4e8a75dfe ] conflictor {{ : hunk ./wibble 2 +A : hunk ./wibble 2 +B }} [] : hunk ./wibble 2 +C Context: Patch bundle hash: ba3e1ce15840fd37358fcd43c4c03273d1779153 darcs-2.10.2/tests/data/convert/darcs2/twowayconflict.dpatch0000644000175000017500000000146312620122474026100 0ustar00guillaumeguillaume000000000000003 patches for repository /tmp/tmp5677/temp/empty-darcs2: patch 8b8ee8c8e9bae5fe01abfd8c991071091241aa1f Date: Sat Oct 16 23:28:22 BST 2010 Author: tester * wibble patch 23373e39b77dbce4de67f7631221f2d873ae21df Author: tester Date: Sat Oct 16 23:28:22 BST 2010 * A patch 0058ef88cdd3606a9fbcfa00fb8b7d494db77481 Author: tester Date: Sat Oct 16 23:28:22 BST 2010 * B New patches: [wibble tester**20101016222822 Ignore-this: 88662d08dd524d92ad4cca6df0d643e4 ] addfile ./wibble hunk ./wibble 1 +wibble [A tester**20101016222822 Ignore-this: 2d69de402438481946682efcad5e20cd ] hunk ./wibble 2 wibble +A [B tester**20101016222822 Ignore-this: 9c8daaedcb674c022ddbcef19752d694 ] conflictor [ hunk ./wibble 2 +A ] : hunk ./wibble 2 +B Context: Patch bundle hash: 33bebb546403626fc8539d4709fbcdb99e47e94c darcs-2.10.2/tests/data/convert/darcs2/threewayanddep.dpatch0000644000175000017500000000243712620122474026032 0ustar00guillaumeguillaume000000000000005 patches for repository /tmp/tmp5530/temp/empty-darcs2: patch 349a0bab437265867f9af955d72127bac4cea1a6 Author: tester Date: Sat Oct 16 23:27:54 BST 2010 * wibble patch 650955997f5fac7fa2e14127a25ea5ac70f4dab0 Author: tester Date: Sat Oct 16 23:27:54 BST 2010 * A1 patch 476d8520cfc9be9b44299e6f4753de6adca83bcf Author: tester Date: Sat Oct 16 23:27:54 BST 2010 * A2 patch 4d2a18f739f8f4c384b5653a5ad03d5e77724efe Author: tester Date: Sat Oct 16 23:27:54 BST 2010 * B patch 81ba98134cf0d725e827318ca2753be4148568b7 Author: tester Date: Sat Oct 16 23:27:54 BST 2010 * C New patches: [wibble tester**20101016222754 Ignore-this: 355914edd0f88f0ea7c2ef60aec9c2a1 ] addfile ./wibble hunk ./wibble 1 +wibble [A1 tester**20101016222754 Ignore-this: 54df34ebd488b772c37c3d43a38b0bfa ] hunk ./wibble 2 wibble +A1 [A2 tester**20101016222754 Ignore-this: 4d1b08c7274743e7d0d2f210518d5a19 ] hunk ./wibble 3 wibble A1 +A2 [B tester**20101016222754 Ignore-this: 9ba51da6bb1506afa2104326cd5df54b ] conflictor [ hunk ./wibble 2 +A1 +A2 ] : hunk ./wibble 2 +B [C tester**20101016222754 Ignore-this: 295e8a851b7a936b3d08b0ce7eaaf2ac ] conflictor {{ : hunk ./wibble 2 +A1 +A2 : hunk ./wibble 2 +B }} [] : hunk ./wibble 2 +C Context: Patch bundle hash: f9974a2fdbdea580b1be0eaba951e6285f9bfb5d darcs-2.10.2/tests/data/convert/darcs2/simple.dpatch0000644000175000017500000000056512620122474024317 0ustar00guillaumeguillaume000000000000001 patch for repository /tmp/tmp5746/temp/empty-darcs2: patch 62068c47f23550e3a32aaf652d1e14e53598ba98 Author: tester Date: Sat Oct 16 23:28:30 BST 2010 * wibble New patches: [wibble tester**20101016222830 Ignore-this: f155bc27211e0233c23b8c0a757b8071 ] addfile ./wibble hunk ./wibble 1 +wibble Context: Patch bundle hash: 75ced55c52362a8b2ff171b48751d19000fe1790 darcs-2.10.2/tests/data/convert/darcs2/threewayandmultideps.dpatch0000644000175000017500000000337212620122474027267 0ustar00guillaumeguillaume000000000000007 patches for repository /tmp/tmp5411/temp/empty-darcs2: patch fd370912c8a92d249e00e7c91856ed9530d6c914 Author: tester Date: Sat Oct 16 23:27:21 BST 2010 * wibble patch ac7df6a4761de10b4c440a9adb39c4f0236cb519 Author: tester Date: Sat Oct 16 23:27:21 BST 2010 * A1 patch 121d6130551316a64fa7a061cfc44f5946213f85 Author: tester Date: Sat Oct 16 23:27:21 BST 2010 * A2 patch 513848985dfc5b5ea1533d56b597daa7317f35bc Author: tester Date: Sat Oct 16 23:27:21 BST 2010 * B1 patch 84edd5450901a4d31f1b49a9a6da4563a6ed73fe Author: tester Date: Sat Oct 16 23:27:21 BST 2010 * B2 patch bec254c63929d83d13929eec63f2e5e5a8aabbb4 Author: tester Date: Sat Oct 16 23:27:21 BST 2010 * C1 patch 0e08cbe9489dfc7f21e9528b4c6a7d06f4fec25a Author: tester Date: Sat Oct 16 23:27:21 BST 2010 * C2 New patches: [wibble tester**20101016222721 Ignore-this: 64432ba123d81c8f0e688b44feb8f587 ] addfile ./wibble hunk ./wibble 1 +wibble [A1 tester**20101016222721 Ignore-this: d749f48333e6ff2e994b1df71e76933b ] hunk ./wibble 2 wibble +A1 [A2 tester**20101016222721 Ignore-this: 6f006a52975a708a8038d52e5e39ef0f ] hunk ./wibble 3 wibble A1 +A2 [B1 tester**20101016222721 Ignore-this: f4d4b5b1c73bd6fa8abe6e5e680d66a7 ] conflictor [ hunk ./wibble 2 +A1 +A2 ] : hunk ./wibble 2 +B1 [B2 tester**20101016222721 Ignore-this: 1d60b6c0ba913fff4d1e32ad26ae07bb ] [C1 tester**20101016222721 Ignore-this: 25b6a6959d19980ad16983a542c6825 ] conflictor {{ : hunk ./wibble 2 +A1 +A2 : hunk ./wibble 2 +B1 +B2 }} [] : hunk ./wibble 2 +C1 [C2 tester**20101016222721 Ignore-this: c16d607216c36d5f7727c64d2ec103d4 ] conflictor {{ : hunk ./wibble 2 +A1 +A2 : hunk ./wibble 2 +B1 +B2 }} [] : hunk ./wibble 2 +C1 +C2 Context: Patch bundle hash: 7f2bd6324e6e1f2d4efe67f98696ca0ead048fe5 darcs-2.10.2/tests/data/convert/darcs2/tworesolutions.dpatch0000644000175000017500000000326612620122474026147 0ustar00guillaumeguillaume000000000000007 patches for repository /tmp/tmp6805/temp/empty-darcs2: patch d1638af339ea13cf23df131015309be1915ae247 Author: tester Date: Sat Oct 16 23:34:33 BST 2010 * wibble patch 687f568b2fa78eea4431b49c76524fd75cce06bf Author: tester Date: Sat Oct 16 23:34:33 BST 2010 * A patch f1859e4ecd30f209ad08440964b3fa7b7bb8318d Author: tester Date: Sat Oct 16 23:34:33 BST 2010 * B patch bb4b77fc72cf19af130db16c173f73341d847271 Author: tester Date: Sat Oct 16 23:34:33 BST 2010 * AB patch fe0a5a17610dbffc90b421d3b40a9ee30ff7e484 Author: tester Date: Sat Oct 16 23:34:33 BST 2010 * C patch 4ecd0a21ee5b7150e567a83c150810656ad76006 Author: tester Date: Sat Oct 16 23:34:33 BST 2010 * ABC patch 756f4b3ac209102b5804ad71e54852b74a7281c1 Author: tester Date: Sat Oct 16 23:34:33 BST 2010 * D New patches: [wibble tester**20101016223433 Ignore-this: 577185c51e4839dd1041372fbfa8515b ] addfile ./wibble hunk ./wibble 1 +wibble [A tester**20101016223433 Ignore-this: 580c4417986d5c56590bf36f5a125f38 ] hunk ./wibble 2 wibble +A [B tester**20101016223433 Ignore-this: a9f2335fe2dc972fd0bc09edc6252256 ] conflictor [ hunk ./wibble 2 +A ] : hunk ./wibble 2 +B [AB tester**20101016223433 Ignore-this: cba095e78e2bdfe15dbdf2cb5c69cc6d ] hunk ./wibble 2 wibble +AB [C tester**20101016223433 Ignore-this: da2a7e05abed8dba0077e69e55bd926 ] conflictor [ hunk ./wibble 2 +AB ] : hunk ./wibble 2 +C [ABC tester**20101016223433 Ignore-this: db94de3935df87d0a991c0ab6a58e5b1 ] hunk ./wibble 2 wibble +ABC [D tester**20101016223433 Ignore-this: 829adb4326b290aa6f741b3a15fbabfc ] conflictor [ hunk ./wibble 2 +ABC ] : hunk ./wibble 2 +D Context: Patch bundle hash: b0ac3265aeb09b15b7dbc1dcf9447dae35d00a86 darcs-2.10.2/tests/data/convert/darcs2/resolution.dpatch0000644000175000017500000000236212620122474025226 0ustar00guillaumeguillaume000000000000005 patches for repository /tmp/tmp6648/temp/empty-darcs2: patch c88a093ab344f21fc3af74eee6741db45df22498 Author: tester Date: Sat Oct 16 23:32:07 BST 2010 * wibble patch 9d61f1de5ae27b8f1678735b4741abe4a869d899 Author: tester Date: Sat Oct 16 23:32:07 BST 2010 * A patch 3b3282935c87c2aede246a42f5c0a926fae2be35 Author: tester Date: Sat Oct 16 23:32:07 BST 2010 * B patch bc42df597aa06b720f03367499e3dffe36baa9a4 Author: tester Date: Sat Oct 16 23:32:07 BST 2010 * AB patch 8efe5b608a6236bd136ead946ef26369207ca5ac Author: tester Date: Sat Oct 16 23:32:07 BST 2010 * C New patches: [wibble tester**20101016223207 Ignore-this: 64b5a1e603ddf61e59421bdde45b3bc ] addfile ./wibble hunk ./wibble 1 +wibble [A tester**20101016223207 Ignore-this: bc0d30ac5170e1a25ccb20e6cb06ac86 ] hunk ./wibble 2 wibble +A [B tester**20101016223207 Ignore-this: 3bbebcf8fa444bdcb31ab799c6754067 ] conflictor [ hunk ./wibble 2 +A ] : hunk ./wibble 2 +B [AB tester**20101016223207 Ignore-this: 8fa03d26b9dbbcdb50a323e5c58b16dd ] hunk ./wibble 2 wibble +AB [C tester**20101016223207 Ignore-this: e7c0716361e411645066f8a3c2eff769 ] conflictor [ hunk ./wibble 2 +AB ] : hunk ./wibble 2 +C Context: Patch bundle hash: cc43b921f6010f451b2dbe275b7fcd04c3862335 darcs-2.10.2/tests/data/many-files--darcs-2.tgz0000644000175000017500000075164612620122474023120 0ustar00guillaumeguillaume00000000000000FOGm^UvjRMCRR5!0g̙ PTcUJ NR@_$D!/uR PTЀTxH!(u ⷵUH J4;}\1[ڵߜ3ssV{[Ӯqy`[7sRR9SHh lFJsy+pwO%<?2c]n˷0ps?c=&z FL\$!;h5ORPs%?} :>v =U ?r=$"!r)& h "(Og`E?ϼec좥+rO鯗s#_}tkî'_5+6pt6K:?(C{.Y)Pt!h) cVǫ3NExQZmc e?؜ȝ+UɣPdsk"7ީ +C"W'Oa^;Gc+lN֝ADى''W}mG%L1坆$y3ں f3Οd.yZL7M+/KFh81QFVuo/k_969u=Yz5V <Q 5b\?aTqJrjB~@YJ9L2 &<2db: *?%ػvԼ=QuaY';%228g9%=7J c6XlN~?R\*/&.Fkh# *_6ʎOd75}LU/iY/ ^YD ĀH ? *_6?_hh?Z`m!ęX`ཋ1Og+#UMVEl5$8N&)sy9Q@%W3i)vXLcԃq 2u/D%K@`Of77#?RCJ$XKܐqq10j?N},? *3fBf//tI@(&5mVe!#>h_ATT#1:_j͕BUȑKE2F#g 2FF,Prs*f8(Bčj]aTJ_<Hէ' @(E>9y%<y5>C/e/2/obT}R+pP' D&_xS5D%KOd75Hէg4Ep{GYy!<@Ѻtd3J/4u߇*#UB8gd۔u/Tb{2 t^H7%Aw)g^կ>̳^{nԡ 7WG>K!I h Ǥb L7/jdF>02&0Θo-bL UkS evdszÕZd:ir)CcΑb3fZD؍g&ti^ݕW*)O3N`XRFOr?QRlyW_7Ko榭ݿ?&/e$E zӆy~X4%wOMrxQF>/v*yn1 }b^x89 ~=sU *_aG2KͶ}T}I)Ieg!r<Qwf?F1%@)yFP 10??$è;/5˕O92q{ ^s\X"9 GAT.&ye?WU}@9C0D҆B|n陗UG;-XZQ;*=HaN} se͓׿HǙ!_^Y"#iR=JM͗cz ĘG%c04ve8F%?B\[6eFEh\)VD%?f'^T:k/åIdāO1jT;jC?zo <$ȣ3m_uA@4Eg /v?p2y7?RJog-PSP1ii07d j#V0*\n?3M]_T}\| "7ZAD05@T<͵/D%2KT}g1Az{{"1P ? );pjB9Ǫ#42"h@B)Yly>'z#?èGlb#VG>( 2I!t.&ok0j?JM{J4KڀQ19z\ZF%?Bo~H;6֩C{ xL bo(/3KV+#UZ??d αXϘ[ eN_f74C?HO3cAT_Lʩ &߸?Rr aګr/, )Ye^K7JOEbyXNOlFXc`^ 1yaiZF%?E?X xԞ}@H11E70*_A+Nd75Wws/OQb< "я88 SaTW/4?Hoȫ7.grܗ{vS\f5etxwW{sb#hT`i+b%:3kY3%A Z)ԙY3555AZ_FjQKT(mOMn[_g/=ll0|ys=֚6j_hBJ*(%[M+ࣛcwo +G6o_l<3g& :KC?Q*Wo~_~]&UbExk@Hĩ[ ZSl?pqߞlnWuW Ps}-9"g&&?etlLgߪ[D-g+G77~~USx K~Ѻ.QԾB@APfcQn mwW)V@сۜI ZγR?kՔ_T:Cȉ#&29/H>soh!_5j씯y>WVK}CS@dkÜuQF?~ćnת),5ʫ ggcE.1c"Y~oh +6Olj_v-~#zɒYR%XE"jVڼx}Z50W Bm`VD_I dS\ DUHMɵ -;5GQv9}l)~ j¶)r ]e 0 ,QGc->_I"1xH,slQsRMDw3 bs52 g˨#uW )qrRo%0,Y'(=PN;qQsOe:+$_ !G9aԜ(; Ev<'QG?Pbslk~OP-Ł+>C0 , w opg+WmJ56DZ QSpH@ DR!;qQ+G6~RM9? 1$e4 <"z'ZD%j\7[oTS%A1zpQ4E n3R(fMEToSy3jO.TV S5ENa@4$?]D-3VnRMl&Dc7A.?1w 4#~oogx]5G~RDC0-_˙O# :K`)nz/{ߣprUrVfVg.$UT?[FM@3ZZozJM&b8JEq#8]-?AQs7*5g˶D&'9d2atXYg"~w5ohp}S\*5  ŋ+낁]۠VҬQG}zWr=7G÷tW),^kO8:U S!!(rem4Mq)`'Sl3s⬲P!A˨xb).RS, F%x1k]-8_-;-oK_t2CѐgMO)pX%x9vm'x+:ԔT1Σ#gz6e8kg1|՝Uj)   dFŤwO8Lek 2Uj_fHTXj0F\{ZhUjNdHD [.J`C r9?F?Qvsj-JM'a@Mٱ(1V`Ӝ?)EߴԶ#cUj yt&=$ ]q$;5.&l_LRC9+@<+H"p Vy?˨l>_хGņ0IsPMj_FM?=/?wS*bH pF'΅RoQOfRST, 5(Jɹb3#'DS4?QQ{JMXg3>='Ƴ?\:KmyG?čЅ|ӗ_7]n7sב|}:+Քن1بQO%1.tY/QO_u:G6'nxׯ:5߲8+Nt)ADLr)yNU;qt"jc~}X,!\dt!s"(,xV"j?_ܽUjW3~'ɇX N]!Eg+ͼ?E߶ĶTMFMW!I(d\)ZXw'wQv?>mׯxNMK-0X~JV٨O!?o5oh6~JMt~ '[6{^jOp""jQ#o}ӟRS(*1,(a*X߫dC04ڭo+RS" ( Q ,/~nQo>SShtڅJ-;J)RE פg5on'JM]*N(TP딴ĘYD\f_DM?_UjH V$g=.СY"jozJM%Q|M+30 * '3Qv3/ __h{]|5|:@8Z=?{*5IX,*)D^{>8sb8_[FMG*5eWY 8S8! fRm9sΙH+E|jhJjJFZiow[Va)Tp3)vA`| p̙|A!o٬Ǫ_H]`RpTE]?3|ZၑlU_Zy"AfF}JߚE> ;nK/M{qZcgߖI>x4ҨЩWZ+ѷ)rq\MCg< w[?Sk?[F|1.& 1i)47a.]kf{Ԫ6SffCYSR3'S0ƅo;GX{y}έCjMb69"Yq._ NOnxo'uzԚS(6QUѹʖ?Rk}Y٧l\\+s.O-2q7{GeCjM.s̅'5{)TcV"`HxvQ?~iHy7gX,%+m#'b0wQ{/7+__Rk[W}h2*-&lAPph3}D_\?!Osi^sȞW˔KS4ٙm0GK/YRk4~VIchR}8E]?Z{ݏӃCjbm k0e\/jc?wR{?Cj.TLkZH)Xl5O~B#ou-v"!OU0cnօ$6=;豃CjKջ(-Vw]YN~]Nz=?֜juxd(X(3958=*M?NғnRXbS&L16:]PZ!WPoxSq0xZ+^U ;0DTpS>Ny닟!&kC|d3KUizm19\GE]OW_RkAXRH)lYirY qoupus~7RkZϹjPNL!fVEM?uz?1?֜T)kXVۏBJr_Gou_.ǖC}?~q~· /~S/8%KU?hIԚBK)75tQwQU/{W_|ѫ~GpL8 Қl 1ڀ5~q+pH%¶Id TCL&\.BkJcd.}KwRkD554s"KJRWƴqzܟKoRkɔ αP6K̔*jT߸G>ߟ˲X1 irGYMj[}׋Ԛqdz'$Z_"'.Z Eq]忟' o[)!/,6&[* H9&)Ƥ/ʛ/0E]?Y<1RSa lZōvQ~7Os7_R2ORNb!)d"#m8 vvQ,4>Rk t̗R !P5.b UI?6v]3K/;mnHPj +r;j5uO.fS? c+gT!TU$L0}?>=}Hjf vRQ,BFmlzguO<Ԛ? *~z+q(d#)lnvQ,4~{qZdD1"!t*/Kny/s}EOoTk'0!)*Ylqr=H}>5ܛpL[h[ˮܖk-Fjh\rYJI'qAq >X5 bt?o?dĔlU#j`$=̯Z".bjE_Д MY}57|jj!䚵L\AqSqE]?^,wmCj߭cU `璍,1Li/0 /=oHQUGck? P+mbVۤdE]?^,0?Sg QDT d*Ԇob6`? /}u!o3hZۯֹ (V} !?c/?{˗?w9,0p>L55?;'xdzkn 5L#>/6s.d- }"ny؍.߯7.?g!o ")r|JN? 6-&¦_`]q9cj?J|ՊqYD.]@?ߟZ_pLBh@)Ż0$] CjM8{+FZ P %P"!nMu߳Ԛ0_\+0TdLq`M?QO`={mѯRk,1i9RP HXMqwu?Qs8HևBBmf͚֬ 7 j)Ѓ%jhs*hhP/眞˃SkjL<`<b@;ۧ%;d'\?{5sNoz./ k_}%YM22f=V$o.];_}]f_T!Ze$CP|*dM?v|,߆;_昸gѸ?n.}Yr?$x>aw-E1>Y8I?Y_ w% bے4j- bG?ߍI:~睧̢QSd cRs{0';mo'O{2KFA>$u B<=f?k'.d/ad2mho4X%W¨﹩[33Kjj8( R_wn?s}>.Oɖ>[FH+y#ԒH1:Cۤ?矧g>YRZ 5xsXgsE"k8ssg?Y2-T# .yC/ʂVp$]<?z/=eu`2:Ek[dFbY,m?<o2Kj) j+"Cp0&]Ó̒C0Op2$ OK]uñ$] ~̒?%\07]p H0hYtMNoa,aO(l0 8fW][_G]f?+c8hՂOP4IkX"T~I0M?0~ wW-BrR sLbiQ yG?sO߿n2K-̡ZEvAST 'dģo.?٩μc,[$ "&*k,h8mt߳S~;eޅBr:pQK6Fuw?&]KS^7e7 նȡ`Tr&,57MS~Y2cRaꔀeZ⒱wm{5.Oεm@s1w3FG?D$]nw%DŽ)UK `!OF3jj)c6xJen$]=2 9yJmCX0!ŲJȫM Su\.W+3E8IEQ7IgםW{?[^3O۟z/yۮ?q;7ipAKڞj_cII~.1otlwzU]S`Yr4kTP)Tl†jD46!='w?eYS[1rT.Rgo.}/Nߍ4ekBAPm0Sm mu`|J/Q7Is'.dY4mMrM 86d9:c?~;~m,B+ȹ@Υj[x_jR ?ٮ9 gt0q}G~~,pO j=DR8&]hۂ5I?NvՃ]fMCvӭ"?7Iwv<</{̒̍x)I1hZ+oүgÓ]w>._k4Z">cH%ۊ?gav6I~y%ې!l|FI`JRLIG/Sx.uhj,@Kd*@C, T)ȘMw[.;b1 gV"dÐm(|t4/7py,Ԫuj"TTM[k1ǶUk\w?m{᷿;̒QDCR!kR䚬Ue'GI?2J.Yp8`]P/mڐ98'+o~̒('ާ,RSJєsik%k?~L߿?}fI[M0T3k%Qۤs1pEF$]數k.͵ze >eHĠ6ͺۤ9swiYrxRŤ!RPBd5imKeo.a'w,rHJAp\V#G((X*h;ߌI 3=)n2KlP|aI$5tRuSL ģq?7IS'oYt:NhkgpOg'm{.$('NhX9V='2o.]mO+%D%V][PF0f$]۞Ww|]f)f &'C)5\m) FXuqgt]'>vYX*3Q ׶`(1{qw?Iqso w%:*RI$-H=reU?6InoO?{gA@1EZ*y#1Yp,BZss4$=ݑ?ۓ }?e,9!#|jI f0A~ oOGl,?KFþ.$޲AA"u4$]?n_s{l,ῲqJpʨ8j\ ʪ6Iwf7]~l,JPjM!19%1̪-gt='77sq5bC>j5m?ncI?YO߷w%kBN EJPjN7?>4eM%Lm}wYlt2TW=4M&?2 Đ8TMGdk+~?Mzu=.3ugs&LHz hpWd$]7O[-]f?3T%xW9hV1)9wU:s{~Y?/dÉ$*H54jm1"5֬!hR4%̚VcAZLR/%EBZb9'''Ikֶ  FAIۢ:n ͆ #"YϬIZ?ĮQZ,z(kN2i)TmſK l_~o2k‪Xhjkτ ΪgvI?O!ZN6M~A1RVFT*n5]`]g~~pȬy=֤%!b%r,[qK +cȬcaR}'e!{/0B g%]g. 5chtFFl~Z gbw7.};MnȬrn;31D΁57# [34Nw 5'+**&(em=go2'E7*IϡzH iI~?o!K SAm4e dj`SЍ.b.>?x}CfM uBшhKUc(6B)O weȬz3Mc@N)rZJ Dp3?å{6E_} 5_/.y 554طM/t]|/2k7\K`'?w\,E&c[xgt=siȬz3`[T"wQ9hr?;X.}!p,() AR2T(Qw~Y3|I5Zof2Yt1:+M~OKKl_]Cfb(H7mC[ 5[m[jN~y?%=ON_̚UnVF(&_X6UtyYgaȬQ(7$O> 8-f?  ![$ 'UA@g \q./_<{߾qȬAQ$hpH^bso}^sX3kpQ@EdWI@g%]/+^??dVN5A*Pri&X"l-B.xu?5Lbh;2Bdڮ߻}56zICXZFO~y}]Y?8S|Ȭ$'>% Ÿ⦇UY7=}Re}E==?dּm#f[% :I^˶8'][_2+/!`㧫m w#ŒϾJ۾9='8!=_a4?7̚` KM@H~.s~>fV,$$V[I$&M]kYS5\}J5&6}`K?X<?}Y/i|\2cEQ AlM$?]7]]kw}_xۯޔsއz;_x͚?X55IB)WMþ鿢qtyx;s2+ZR/`ls*@ n?wIYÿ-1"'IEkG ~?K?X<^p29*ڒ%eq80-]sϿ4?d mZkAs2T9/fnKq.ta^xaȬ:Q$N{~@[[X.}a^o{YDjqCf6,Zϡ`j@qS>h}'!f&fgJNب܊dț> !-Vjxc1X2@68#Cf! m/u!_x#m|}CfMm+~=p!Jm -:O~y}__4_2kw6T$)|2lÖ9]=h_̬ Q% \ $lJO3.]L/5j19@ S?$ R=57otd:>siȬgT(k!J)ĔJ:K#iny VLgk;cD 4mɴf.]ُ> Ť U7$F|[Ci~SDt.]7=:?dV#1<3Dgd7=g?OgY5Ckd%b*%ŵn?In|mYO8]4O PTpD_G?2kZB~l >l)Nh˶y.'ge̪6T|oQtؾ.ԶM wJGCf :Ekj%47Vo..,;7bȬxU͕,U&&[j#8t=go{_ U+ӓ_CƌLs?>?d֜ LYp(0mp'?οm\{oCf (K\mȒPl_TC*ܶ'?<7]og5?2+~VuCA G>_ߒ20nx5W1aN`\VA'?>[?<3kFu,)1ZM A`%lWz>6G!@CKNV@RE_t?.'?_2kBKµe;KUXb%%][~ _2kq^LRjֻ4 PQ| ktn>Y3#Z}fp"Fjir5\#?.}wO=Ys}+-# qL.Jmiyz|FotG{MR(F \\-DEc0,an%]v= 1?d֜ rbQ"&$m[|OqK?_7?dVV9SB5KŖT0ض'?<G%=q{o_󿎙53ƚ཈*]q]V+S9ot;?1_s閗 ' J\ `p.?e&U( }9Qs❷UodDL4A!/{Q&XW&eY̨4>y bHD >hkmUP&{k # ("8ߞ_9N{M=Yz'yKO g+>!O:5.l! ۈk@dUe}G%]Ym82k2*bjJр Gtla.m#7 usƓNIΣGr>l@M3 gk^W + bK-c +Tkxmh.}i#??d1yLNK UlTNYy?.}=O?$Ӟ?`P8GГ߸HHq=6?dm8S 2b}%45o\o'=K4?d?L~!UbvKA?GL,K_2?d֜GU4C곇ȫRᢰ?wI{/6R짿Cf?PP녱R2E:Z߸O g['̚`m`"`I@6Fdڹ!kz7 `MLΔ>?7~GYS UC[mo tnj߸f'],;?tã1fjR&djֈrI% >d{Y;bF,lU 1Z1 ht6.}O[ Ut3B  DJ?Uc6.}cg摏 5RM#[ KrRF b(iZ/yGz_?}^Yq-h΋m S%FҦ3?|7g?f[:=R%Up[" ɤMtpYxY?sreHW!_UmTضȭ|Yk`UT*QkFku:>y.}?{m!s$TR-h5Ehf7؎wI  0mH`|pةR1ݴB6C.}/nȬkB`E"S\\S [g0cot[>6?dS H(T2%6S`"f˛Yt}?2kճ~5( 8-o\O?\xe7?d"fRr z](c0.7.r7=g7?u+̚ߪ.>Kw!6o~ζz M1 wt_Zxk̚lbVXc(ri R =}DKK߷7b9,64龏ZW5k]0[bkt^Oy_!]/y0?d??FJ.mFW}(~+>x{o|Yg̘J;h@qm&:xY>xw=!fψS6fJ+5(Œ(i%]_{̓_!mDPmNa\ $Ѫ#8%]/zn26EpPb舱j6i']/ܯYqI  P1B %;3'?|U7QeZAJCY`(mbٱ%]O/7۞0?dȒT̹fŰiS!'/Xw>o9}w~YϑRKx*h#sdJu`>߯W5 \5V9BL BbF},뿙{Gcf?QsLֈR4V]6u؍]u'2+gn60D$5ٚQUƒ]tw{Y31D% -;訊kByX.]`{!'OmP0  mOuf#Xf{o2k3Zz1#!3] %}/Kw?kfﾏ[2kG5ǚr x*8ڂ QLo)n`?5' 5f`UCz9%䰭;.{y>k]Cf1S٪!+6Mo8ZM YӦ?./'_/2k?̅A i--&Wcl.'%o}YJ%;mۆkĸ̦I˟{}CfM>okf0Rx5jR1r2./_'^3?dּЧjDh2`Ĺ8cq$V'Oot_{Nj}|5p _rO\s~iЬHckISdG+m>,|Ok̚J"NĐCZ}$N M;]G_5?dm%>*ZF`lzIwe1?dV| I@\%6"ۯG4u%]#̚/GljNl)H=3?{w58UgJm2Pu‘R6F]R,_w!f5M2dzGl-ĘqSt{i>!,b$ujκ~ic 1zCݴcKz/=?_2kH9ke Cȡid}>>/?0?dqbDT(ZÌ!Soxs֋Ksw' !y?A[OH5RLȦXTa3KgO2k(%qN-!RDj qK?ͳӷ|CfMo$8 9"qd VLۮq%]ów5ztȬ+m`Jq}E b-~1ct'^8?dI}$撧{5g: ь]IӞUa5 [dM S0f`Rٶt:?dq}m?$H9J B7tw:}YDRml{cm)CAN~"8wI:Q_1fHcL,ꠞuAC]jF?;iWxSw^uw,T|lִj8<}HA=1ý{eDb+d Ag˂ùWϋ+.8`}::fBۨ}i~40g@RM.h!=t}RdWtS?]=η7_|O~EWy?˯y]͚@IhG1CDM:)Lkc)]_;\?8cfӓ-kr2/6,PS*y.}?5!%ԗX#(l|rL #WK!7*=;b*d(c'qo揽iȬI}PК(TNM8U "e4/.?/WY3G%)D&WZVdkλQk=o%?eCf X2J qj .TB n8%=_?8n3k^ 6@@)C4j5'q?7.'Umq*m- _X6(+si?KW~!_R2dP/Cj5:;[XIJ_?ϓ2IAL̹ ~[}.с( jܖ.}.}2Cf#6%/( TF,Hܦ8%]]{.Y&&k`MkrS6&ĔKʦwIgy޿5pN-u໶~ f B7Q otv;2k%Ud I%J\O K-G]Ys$iZ[J@7K_?Qn!9ouYk@քm1gw'7|_yYu?3e jڦhNć\1`G]_YsgT4Tk+F'iP5_lK?\Hqg>^7?d)bb54VA!Vv8.}). sdDSvAsl+l]m#+2kI1JT9ZDx|-77.}o).ٗCf?F!Ik$%Xh+늣6wK?\mOvӃCfT4ktNOƃM[4dsڸwI 7 UdDms23DԪO~\Kzw= UEuz: I6hBɨEh.').?GCfȈT$ %W#k.\#KzC?!G .Eq.jx MOCK nJCfM/cTT qjڿ$4c.,?SՃCf166Φ0Z gRu-lM^t}!^͡|2LF'cUJvIf}S~rȬ'RjF]afNzƠmvI{2kkdH1 q]imOS-?ca>ͿtYY5s%[2Yr[J'q[{ca~O_6?di>:\HXRպT dDN~<>{f]7?Cf?4|"lEci?@Ҷ8%]lϮO 5\I6$8Y@.xH8t~?6K|y݃Cf;10cIڦP+i0ro}_[?x2k?Zà.)CcC,I\ac.[?xoYk.؈bPD>6P ڰ?4.}ȣ|Ya(!-[JlvIwaw}Cf5jS\"kD rs?^=?d^Bh%@a)ZŚR[y']˷~=CfM"4' Yb+^Mt=n2k?*䪙fȒPK+ZI y_p?.[g5_k@4F^&'%Zmtux.=?dI9'Vg'_ I %6I+Ha?%=݉={Cfr֌)3b\ TLDСHo4cOKW1!+)٠PF]O<+5Gɦ@ YLqEAVlgsK߇^9f?t2Y hVL]ql]I>S?σCf_yz# ۲.}f/\2kDd5 PK%: Me7%]KM׾!2K)!'pRs i=K?w5$tBhK~ a * T?Kz??N?{[Y?_l$G GdSDS`F&icKi>pMCfMZB5D(qUIJMO~<>O'}`>կ!h_5UbPJRKۘ7=D_OswjuE*LP #Ȕ71>h\/{eQSI (m%DԠ-y]#tYbZTBa J /؏Oۿ6?du (Y :lG}YZд"}HXLIo]]\?4?!Vے?dj t 9LnO Hwq72IΉoDkZ5(xAW(жc??~k2kGO[JPP C !UUE9M]oW ]$o*eg5Kqm8__{2kYJ]RޗUMiT5F:?.'srZ̚.!'o (ռ&m,0+9Rke!赊RٳbBi v_Oj=WWsɓx9w^l5īNtF3MQ}z i3vﾷRkTcZ)c ߴ_1o5oO.?'w5?D؉ʜc6*υXI-a2ſn'w5Ԉ)c L5'$cP3ͨ&_^t]jMP $F'9/>@.B[m𿇚-K(Bʃ+]}q:CTɀrn_Әz׳ﶷ>-./xSsbb BJچM.j_{|O Ԛ9ke0qΨi/G_֠7&m^nZ/%o id! Z+z&m^{׿]j_`4:Y(ĨT&dZ=8y*5wQ?y Zs'"%6Qy@BދNi8׌3?zlߥC=l'EPBoRdxGMKя;]j_<Ϡ?@bLԦ ZS;ߧp ~ OKB[$p`SIM[>2}jM} )\Jrqx1P= Ax3wRe9.b(م`t6YOb ]tX}{'}^_W?o^}ow5[sB㢎-E(5m>n𿇚5/44}jMRi$))JY΄+* %n955o*K/oeow5?1!x]"˙sPԛ3Q?2}jNJ҅skà9|]O=k??qߥX CBA@ggl; wQ[OG.$`deT)&W3ACEQM[\E]jXqJ'WR`?5ykŃVIC6*x*Pd,1k5oZ>5GU"j6 ٳeN9Ua_4];]Mw5M&,$<3 ns&m_K ]jIJhTTw98|4XJHڗmz]F?w5Y\%yE `zM@wg]jф̑*>#`hVC˸EM?^YZU@5.Lb`Z%cB6>jOK~]jB*-RBvمowRv{5Ǜ]jߚ{ÙS rNSv:yhE OgG?".&.Lc1rXM ]@__g.j)᜵V"+5#{'tGM?^blZ3#fءV48VhML1m?8&mߩ)_.?ǀ1%Z\)& i R>6c.jZ k_;R+6F@H2uԳ~)p&s&m6{ɯէEBEL$ *#V)i_pEM?l÷.1'\F9#(1D$jMY5opo3?>wߥR^Ybh2h `}[MGZծ[.G)xjHʱWiFg'.j߮7knߥ?-A+/!BHY) | /M1_?85op9_aߥkS&k806b,P Nrv}åg5RksR7XMI.1$䷜]EM,?8_5i7;]jh|Ī&8"#l-?ow5)~IB`BF@4qӁwSw5fcQ?I&SA*u[0Q xߥ ɖ<@& XOatt@Ҧ??' /.>oߥO{~rIEE_lt\O3>j/׏}j orΑs(Asr&ڤmNN?lF>jOG-5._dx*5⥂փzc5od7}K9RkW4ge$<) iƒ=CGx']j'iחRAeLB3Of[5o>瞸Z?%Y%0WJk/-:$b?0}}Z!-!1{mSIL P-[`QvhwO5 *Ž5mQ.jlTJ[38QSk衦i.%&„SeM?.w5?*S!DޫRb,@ɖ5o`_zԚ6Z,࿨'/`*+6^{vQ]g}| 5W DMQYNهWMo5oO.?GԚ?%KY|cFM5o?؎z?wяʘݧPџzeCK:OeٝUVISs L)JH37bICJ "FQIkX P@*RSh--LR;wo{kB$*.Me?dH뿬?.۟w['̖Uҋ<^dkhBΧWiH?Ywٲ]<ZD"4aiԸl9]!?d}'̖@-XS%ĚcԇVY=?"C_\zzlsY).-IbҞyL'[ώWvr W%L7ng?$C\?[yl?1W%JABoܠ| KW'gsfZ'9k@}֯gT<3s)_M\9_SmSfրBɛ\Zub[%C![k򃟚2["q9w$gvb1k7:4?eՕ1]ZYvgc2X٭.CNO-b1W/ZJa5c2 |)(bo\s!ԴsT?v.\el}6_ ߾ E3h-b@sO| .ߗ>il?f^-:Ib2BN.Zqq4!CdwMO-C*@HZH YجZs ~߷>)eJjj508Qm;}dcurl)^NN,}H!/)OYMp=[kdo?չwH_9_/w;^;?eDyV-`#\ML+rw}'&̖}j >n4Q*CKIodoyL}k'iSff}Q^I9O.Fs X۾o2 X/ʁD /"@uR=e!?xP7FىeOP UZaK߸ɐǃ?gwblRB<fv\;^, EMy aYՓSf k)f&Sr˭.׺gɐk{'̖Gl4g/琓ا/ɐ7g^>?eSH%NAK#怩rKK):0d^Sf xl(DBh |T/@l:?$C_)/"Gd)\h%pZ#r[vlyŕW}ْQR }뿛 R,w=v#*|;XNlovG2ɐ)G3}I1ghZJP!Uۇ?Z?rG2jSD4_;m?fc2_oMO-[}DəK(&Kܞc2`|}9?e6V'+sJblAke]| 8؟}Sf ͨ%e326P˥߸KsH?\?)'C& ]h( oh?Ɉ[\03[ X5ʾ0>TkOu!\|_0?e61fo k+(cDֹwLFӕo-xwlz3Des,ڡO"V)w|~FϜ!WZW?}l_):Po@@&x7O i_!sf.9wʋ>kcsMZRoߵwH?\ysslG kjUID ZO5?ecI87PƾŒ3`٩g/7C2=h/glS-Q֑GWtBaWfC2/K{G&̖ƚ2_xy9ŀ D)]| :NO->Ki`*n1 |7Ɉi]/Ι-F\|%a ,,@vOɐwlBHY]saH D%LZv=gJ_.xٟ|ӑyj$G.AZ"l=!WKO)e?S_DD˭ S%=!?tMO _:~'_]6Zؼ9b`~&C2g>uSfcи߰iV_Nw#~C2yOO-o 59bV}-6vesL_W}ퟘ2[zd26Ҩ!8Z="kOc2_/g~nly}iXi[R,"$s9)O ?}k~slߌ`?s/rL1Fɻ1>9?ek XW~ B'_/ hl9$C,w}pl}Q)KЋO bleOOdJ_,?߸5?eA+IBdㆩւkHT0c2J_}sf_}/P\KMdI!}ɐ+^8?e6C(Db+n`ĻC2_gzLO t.72fIIVy'dG??)6drh u]_!cV)nw>)oDNESq^b:Րw~?dG??eCԬ9T\4KЙd6_r@t[uPRV8 <;&#߿Hq> JVr3߮~οOɐ}~ml&P BQ:"ۍjN99?$#y\e]yMO-%%K JJ)y RR/7SfK8&r!((K$8*x7_a?dGe/TJѲ%4]TI^!cO?/߿~楯2[_C'AtURn,&]dˋz'FR*j:P=QTg{_dˋw?&̖?[J`rEL1(Vt??C2 Sf?bTFM]1i Fh.=1?du)ep]jG J03U8lAk9Pu3}"ԚKI9b ^=ZSJ@qcu3/RK2(f)ƠRY!Ĕw͚e?8D]{>5/|[Ԓk|TZHH ꃆUL_nCO-*To|.:ۦjs{H !;6Q?Q߯wZrx ir pAUO?Qn_鱗w%mc>,}r.*aIbCV_1W^zZrg-X/2`% vNTYfv7Qn߉3"'\S'/o/=\|6ߩh#0W *ѩ%oUp;ڏ r(ompxWlhLi?&W_~-]jIO Pj,`hX>p5?F6wԒd(&stPua$*kU?m.}v7ZԢ?zd# fO }ڇ-;q/7>g{7_#W'>{e?jX}6m z%(Ř0ؠM88]Go]jР77Ma>V+I up={.r&"G42T1M㿛?_6ڧsm<!e- 78e|K-937~Rՠ`bnJh?ۨ?S;OS.$_eb?1xN2X(ށ:S{{OR '5'LQK3昂5h%%o.}=sLqwm]jj]  :m=78B]{'.w%?&VCj$H0E y)!yÞ Ru0?6Q:]0?%hJZ/^/ Tpj`FouAOw_RKD@j m/-Úۨo7^s.?\1!Tid y %pДPF]>RKm Qm_NXm?W|Z4\ت|q)GK$R`2eK2?7Q~3SϼM]j ߐzUt1 m#P "dCYl|LL}3]j_I0P[.x 5[aq6LywԒ?6F1dCfɲcHDv?c0TǿtZ2'K6g1xuVgSK+X1 li$Z\}px6_sa𿉺gF.$V%jΤ 8ol= V$W 7Q~Z6h9eW#s \%U? P; wK( Ȇy` Q2_=;:~+rFs\uFuS'O#4ߥKDj!qDV%,}9}?W.G?7\m?S_ wE6: !A\Z=r7?QcZa )x@V14vS.YA,9D &V(7Aa??Q_7sZPE##iudD3(?4?Q+>.dpHBbqll̥ J!U? 6&ԯw%g4`N1T\8jR`14O-9l4cz\DV=m.}n[^ZroHNQGTJ1")ZvԶ1{?Qsg]jP $JB˺8B]{S w%?gm2=HR,BV!3:<6Q4v?_?Ԓ"D&6h? i,)i^KH߭h_^k]j dgh1rp*b+M?2ߥqŌĨ7nkJ׼ &e]jdEc1ѬJ3Ӓ#fn.]_&koyԒ5gj&b\BP`ZԲ 7Q+GW wE1 䘋7lx"* Zb9VFۨf.Sa`R >\ cq.;D]?4sLOɿ^8ߥe.iȅp )΄J5AXs &1W&˿ oRZ~vliszr3Υu??/|קԒrV H !8D7ن~vTwFX#cڐjV($V4!j]7q#-Ш 41IjҖo({…~/ggsǯ hpDP'5Y# 6߯gO{R/]fqrh[V N m8I?8>|o,}E16ȩ.'Hcqotԩ̢_O \CT 5b>%c{ ztm.}fo{RL{_93Kb %)kkRpĐJZIG3=)ߗ1{Y?.+`bQK+"z+Qqym.}}K_<9eouQVɂ PlXB0R0u]o&]8?|]f_tբ? |,vV1{??ߞgW}u,?%y㢚Lk΅OkA&?ߞg_sY.XGRZ8m!{??Qgo{RO./j1'(Rt]֨.G4UtSs+YYԵ +*ڀ o<<htM8g5rmOљN)XcjI\UxM?{ύYC=D{C&T|eG~v7IKh,ȠrQ~q5yA2;[hm.};;(_/sEeWD)IWG,&p}k._CLķ|-. ό(ږ+&p.d -Kmb*&f6P m\ 7HS4YF\Ybu dM*mtI?SC_~Y?x )Vu ~*ckn}!뽬vm2߫}ů_G/^\|˻m+sWNk;͒'(U^-ljkb ŗ5{?8$]}}G~ҏ>ϟ< >KK.9}.~YLs#B*Q#J.= RL%Osom.}/׿k_,]$X}X4!WB>(j/$]sn,GHO%%obVISl5):K?v$]s?Y2'r2T$3!Ҟ 6.?2o.}O:n'Egr0@UbE5ftҩw8e`UNS D^ V`?<sn2KzȜ+AVR`tٚ$v?\?5yv,a_5SP%Z@_t]]f栙rIQjN1zÞc' s\?y85eRm)ɲ$qFɵ}9#l˪8&].O wEQ\T1Z Ke(ٙUŌI?9wN4eZ\590@@jC&Yuoes=YRBJQ5:~S8,IM1qot>1e$N4VsEQ7Iw9uY/&&>,KM*PT$HIto.}]]fCa۶,/l~5vUsne@vU!.,*@\*L̑MRWuۤS'_7g?,9)T]brAj0Yƒw?0$]0e]fI?05Q[X!%qلU6I46?y?9r_~j,S@AȚ0xBIY-kEkV8mrD'w%R5̾:6RT悇Ez7οL~.w1s7.E5ι'DL%V(=o.}LY $> #I5so.}L ?z̒hEY Z|h>r< #(R8u6x}MO2KJRchC!&f(ko.}L߯^vzg`P $Q)!)[uM.J6M*&I*Hlqϓw%?|ϑP-GA3䘔,:`VM=uYr/[&W_m̻ X@%bPS]';7IGs'˫̒?bt\ҡJ@\Cj˪@Os''Ӄ]fk?d[RQubklƶ.]x&]8?>h*؈ (i{[ 9kҤMIH|Jy Hm6RԷEVRRAnoIkňR(TEHV;?X?g̜ϞY#/ȸYk,jkDW`[((wg?xY.(.E|.1by!.u wȬK9oL `ջ TJ4Zq?..7MCfʁd)袩 r4\tǸgtSggq̬Y8RH8Ctjt3.?cf"cER4y {FwIg^sCf VDm/pTҴ33.?}٥f> 5&P1BZBjr )l?ҘOS!f)VɄΑZj&M@?]~.75CfU!e 245%P478osw2kQ0 rTf&>d%+]ߟKѹ̪_Rۖ@9PQ[l>/_?;~?2kNmL(!.ʥ:/bBY/.,?sȬ:R[:dORTRj1[tW?~YO9A`T)e'CcK{̚?m% J6&*JC%]wsCfMWR3]@ BT0@R)mEtܩO!fq.kF|3E 85]@L3..}7_2k?&&(WVȹ:UF)tW'g\]~;q1b5>H{qm70Nb &M}l#/x|ȬT' !+ZP+r8+/Ù_?5jE%+%WB6gt?S7 ߺiȬV++)jKL-"u.}{S?/2kw6*/F--Gc.x7 5?dʼnk,%ɖJi̦2Lja./O?fV?CiW(F\\Dp*X7.}io Vߣ5.>j)&(*j 1ægtSgמ2k'Vt죩ɣxPsT╶]>L[u4?d|9xjJ/$JF}A8R?2Oɷ;?d&s,;"!*krleu.YMqo UJ4Ns͞+?;rX6 G'=L_Mq[kU?C- T llC9ֳϸۛO3?dkX]%kuSt t8tf\eOYNYu@%d\I )oz7.},_o{W=ȬXwls jG˘ 3.QwIg/}o!ȱAakl2]*1gq.zM7ڶ9mr.8->޿p|32krp&TCD"!/82=z[2kI gn{.\ E I۪Pa]gqgS#2kJ| )NW%q!IޒF =c]e:+!Xk$86z\"Jƺp[K:G!_b0L&1R."vt?S/=K1Fb_7EX8'0~.}\_po~YsEl5P-&>ڨՊ< AeFt;;OETL DY&0A >BKz1,*6?d|_q>W")Ƴ({1nte?#?!f%hNF fh?i Xkmٱ%]yEuȬaPl y5őgqϺiM/Yi7`cP Ѷc6g:n.]a=viȬ)aɶ(*QhLD5qrfSӨcXw|39?d#\lkqkє0] b}ƅc.߫^ 5`iiKEm HgM2~]1,y_1?dV}JOi?[ _]rB1IfgcX^=?dVr/ڤ!_}/mɝ}En.s2+"Fe+\Qr* 6̃]sk?vY6q[jXGV09ύ?I~e=CfS[O+XICu(Mhes߸CfPsɕPsZJsm $n{K?\v.?_;?dRR9 D6a?WDNmqKCfbqepB6DhQ&?c>p//2k_O> btۯu6q'].{w2kMb$I uږRD Wig7åkgYO@2]گAIk[MȂ e_nwI+?._;מw5V%QkSC׵=a…m!g\ot?_W!̀m-SjrR)h}ʮ Ӆr?_?եseCwcȬc%)x7VxV)m0.߯y/};_7?dVc XMe>RHwu\?;̚_(ds= T']?fV6G]DAb%sjo]Ng1Y"Aԛ%A3Lrrj>"1gtvƇ4?d֜gk51Yԅl1w~ٛ!7oҤ싛M=3s>L7ox̚?ߢC!MIJ&iz%Ms_.~xˬY[(W '/(,ƃ8}\?0^3eV🲇DA[3XԎZtT4bKKfK}YSsG )ASLA{J K?j{?.fg +/u_?%.q?Iw~`ˬ_y좆Hdc,&BDߗMri}q>ML)ONaq瓲 xO?Z0O=x{Y鶟`S(!.RaN81rGtvo]v?_2j5Ʌ ]ʜP)_40.ig_?3eur6`.*&QVBXwI"u PŒҦ4 T3%M}Kg2]fM ,( TD{8ZYL*a} {FkN8eI"%b9ںȎ$mu?K?hg;^:e_teRtr*>tH%6q 5?g}檯 w5׺Y0D )L#z1КaFOO?{Eσ]f`}I\i`?]fP7^o B0*,A3$jv'M,_3xY71&@Hp׍@29?1o8&mcf?K̚r*S0:30rIc=Iw1w w5C"D19P럔 34o-g?>_qˬ\`#̥RPՉI,0Ӧ?X[~w5$bl,G]7F6ڎ]ew?5eV*LZǹҊdsӮ4h6uI>Psso̚zc&V' uI@eKKǿ}g*XEya[A;j+M._>v]fkHe7%%6b0ajå˳|̚"igR`޸ &rǩ4.iZߝo'̪gSH%]BIEA&ىE8]{%WYsѐ1ř2E`? (P.rN2͘'M.e2k}9GXB}Wm*t;xnyo2kbH|"ĖѓzgU.iz]濿vˬ9Z_WT b |q9q)MP??8eLHaFK-̅.6>iJ5?eO.jGq8ON}&mb%~GO G2+ޛh2C4ߺ.8+>OBgq%M_G?}2+ςu'\VJP.bS;ˮ. BBېvFgZ*[C1;3eV?.AHKf2?DA4oo}SK\7eV/!7&źІȩ=Oj&GgK7?P )waˬ4'gb̖; LwIj7YE-h+.PC]+WꪠU.9Pj )o.+ U.P)Z kx]oЋOdˬߡkT䀵FnI bBUBmi|%-̚"+XDJfX!m K];~.fc[-ū"&P*VX)n9?]esܻՃ]fL.uC6`JFAN??K^mg dU֝)!ج$o(󿺤K߻o2ka:h푋Ȧ(xM0]٥kgﻮw*̚l*ڨ 4)]D? O'%C g_G%Pt'M]v ]fmOO9rbFA<[8?ۥog刺O~eˬ(5 WBN@Cm?&K'C]f?@ F" ,łi$g|miyK+ <N}'CF5F㕉dǔυ%b/d_o/N/=Xמ8q_CFU?UήV' E]7yoFK@}~쿿mǬGB8Q1Fg[P*zb^86m?c{=fE5XŮVibJ[sߎ>iucOG3g{̚?Y \$.>z\6c]|Ʊ[P_2c?xSHQ4&L@XK69b]V.Y_o *׿=fMEH4dɡB0|fSY_o |Ǟ-1k146q(&imc<)?rx^z_^_WN^Ss_ N}7A>O=*0FW`'#^E46>_~+N`YsoS.ΗhCT1 !{x:|%M 8*^O^uMì_VhK۠YI/aYn Kߙo2k()_ZOs?tZy#Iy7):]_߉/?r,/i߭Wы{̚"Ƃ_Ԣ$zc˱$:?]Q?zS1+W%B~18mL*gϞ7p&?ro1k']Tc&Aeնߎ_oi?n1[N0EJNa|CM:F,d"0*jΜ9sfX3Mi霙3fIjFH rwuw[EoZ EEmwaҚs=H<\\p|y}\3i,RršgG_Lɿ?SmN|s8`هcoN Ai>{Jm_aL_ny3?bʬC- VK8>cRp=bo}wL5c)Pqԏ%/&bAy|+Bw3.SywͿ}߻quĬBz ^ϪS/\F& |7wͿ}ߟsO1kܸ&RizZj nYi|5#6g/x9?b֜i2&-(L#fjA/b+p"8|s3.mQ[_L5[BT[{L:oʿs{.W'N5ZZyb#+ESkPqexޓs8`{ucO]Xw  k]b[_#fMG')"JOTKش?%6G_n{ޛ~dĬC!)zq878UȜ|f}bodW=OYT.NZz5a.LVܔͿ. ;bĬ9sSU:5JN &;_L5ջD0'at T%JӲi/ l{nu1ki=8T0Ġp,FMHJgq?4#6g<1ԍ"ObB)A;J+&{k}ĬӜ}кd*3WKJn m9%6?y!JI)SL\q:VxTKLɬ䮭t* KYv)*SQt_]ӎ3.ǹKlR_2s~:[]n1#:pX ?Ϳ3ߥ?{0?bּ-&Hg9%GNEϸ#gV'GO$Zt flY\ \OrhOlM1k3r+mؽURN=oɧ%fG>o?Ϳ3kw]#f^~ʊ$i\79_ 4?b-Rh9 {9]bP737?rЋ?4?bhu%`TBbHm{o'&w|Z1k+'\C-\@nc;_Bʛ1wͿEw+&G̚1rc*=ShȪ_t* 㶯Ys/VJʥ257L5fZ yw_џiĬˎ{8<Վ|%OP: `۲gaqo)gCfko=jMD1"Porzwi_0{?&#fUku)BMjQ D)Ng_0|ǷMUIi.|xz$rkM DsKlm/}_ԱH|j -.5ُaok_0>8dV\+gtkd !ggq?._ȗ2?bʾ *zRzVFH|$m_ iĬyOZB@EO?5A>5Fl{AP8\{G.: W}?tgʕNGB ЦhOlY3wO՚OkR:r9 X}OlmR/}Y?g$6JoX]SvOlmxYҰ'p6ȃRc @ jmg'6 wG_zỲL0[Ҁ5T gAmL=bo3MUC(jXP5*(D.gKlm}]~Y)צ,)jNy)a)Z 3>?o73&G̚`&r/s -S V?=7N]sJOE}.r%[/Olߋoȭ#f\4Jrq| (PB3b 6zѵq%UЍoƿ喷_o?7=h_gM5R>,tNbcX\ǿ>2'&_4ȟo5[_{&I+\qܷYwͿ/W'|5/Nz^з[}bk_: KwYsשwهS?-c9P:sOlRԛYM2Ĝ$W;y $^mltCfDTXHrY;I.h*.?S#f |ԫ:X $ \cy7G?1kc }ˑ[I! A6]G7{'G̚XH]-Pz̛ }b~{ w^Woǜ֔B'^z 79ˬg}boE~81>>>gPMfY*Pt)FނRFz&! RHB *RҬ3*MRPDAZ(b$0?gw{[߽|NǧoWEa x't|kk[4y' Hx8w:TG{+΀Vb-9CKghŃ+ť:ĥ% ߠ_A.ày $A8ȅhg0s hv]6%ƸLJ,תΤ !IKL%^CXQ'|ҳ"{>pY) Mdu+1"n;*iU6. iHN_g_c%dB$,e G!%vxsJv?bpPdFi»˔RJɭ%5~&SG]8$붲Sr(om{=vۆr0dm(~9 0eȷUԇ&E--*֩VKaM#ùj&e i)$Mn azK/zƙhb)IuB*/w5!Ok\d,D=J9rlhMXqՂW3p= J Oadxnlp!j#3N?N2iV+W+2QUpZ1Fpqa–,{ܛZ lb&H'rLIwYW٩b46#g-6*e(54]Lڀqy:ŭKs!wE 86؁ʐ%xډbsmʍoeѦNLaLLɼc$i[ !%%05iX}9We%Qu>=TRcA;3k]SyovDѢc0܇۷Z2;gtb΋gvJֹS͛՛ݍ5mٗ8hswx9رL"قyR5F:p9*A )G?*J[g$Nh6Ld÷f@YXh!<W#(g])HEej/Se3KH҄^pyb!cf'sZd z+~>Sq# 5'V%PԳkc.50ɵvQ$>6yC2prd9{A4vο>MhpT Z|7{~qMrBF޲ZU?B╌狲ާ"&#u@-WT`+RӨ !U@;ͳ:Y3ٵQ2/44eJyhexxB[=Y'Kj8HLR;HP}+^s%u_ҡ_w6_:YE6zSmƟ%ϋzhӻR'm!bKw"fR[6F8ȖqL0_@$4.4^Eh1Ώn:*{X4C>'nOWqK^Oɰ^^+>h>D v%=iXxz'ӵ>']iW_׸w5b*N9= 8>k\|Ol7uXxG=Yp%q7֨ 481—Lox=S3nխw%=>3-iXc6DkrFA!J>qGVe!RU50ABT&BŮ퐪ؐfkNcڴs}_Әb:~f}彊W Ou?减:Ҟ6tf:%ĥxUvCQv_-BR;|'&~+nд )fDZcff1S3;ffffff1;'Nw+cK=]SU="dЋD*)a>lN};4N1)+w1qZB.Jat2@skߚ>@ǽfOR{ʐ]&23+"+vjiEZD{0A2^UX7n:.])# ~Y.VMZ݉te籾}SʎWAA5>$>)q j |79Xհ 8C]9 9$=͞JgõfoNVo:%c<[5`,@~e6E \'%k L(}}RVgdm{# F*Ჩ(;F兦 {3M&1ސʤ z^.xI[}azƮQ ǵf;aυ}2Pܶʒd8N@_E)HcV|M0 \vW^SKFqfZHL4}Nfle~,+82F]Zw R;QAȇ0e@u@#ӟ?^O]L*5R$"eŮ Xw5~*08E@2K^$ kb@8u/ sfEԲ}lNpGnGfclMhs:fi## ys@kn&T{;onW#>?3Nfț˂- 7eU)`C>8$ KO *: eckU4Y3ނj7 X2mR[ 7||Y~Fnc)F0*|sY&@F#ZKfcS̡urꛬBhyס~= ; oЙ+Ԥ0jd\˜P͑]-Ft ,Wr$j(SnjS^ALh  x(U2?Msx2TݻQpALu鎕T%d5bhv9w\+= `@>@߾$r'@]8.a}Aֻ،@V=, l-XbURڣF+C:VHXOeCV!Ğp<^^:dZKe>S N8{FINa`jz1{@;5,PmWPw.W؟QW* $ݷNHݢlz'Ke-T;o2%zAhSݢ|П Ȋ /THUHB *v6Nm^](ekiOFįĈ*Y\xL4{uh{2`yǢj`%]GydL^w1@rMJnQ~ @hl!PA+Gp{Qgǃ4oqZ#K@ҴiLdڏɥ]LjLwT)oO~49(Uy#yxDs;bVd|B7PR<'[~ٖH"(rrpfjIx(T/`B/S>A.u{1jWi4A}v:t]0vգ?Z:*׆2ǟ ؊öԍ2#Y?ֹ;J"4 '3 F!4wzjq DE>X0a}.)P-P4FƆJA:,ׅ!Lmr-֦ȀXiWdTͨ&LqMMBC)02-xf $Xo'=̉'"ìV;=8%Il55B{bq7'~eϹLu0WK0};ry bNn {N6k75B˳bz h{d#w M~%/0k‚xS\X$اi|v;߽5c˗@$Lgb>88TLh~`2!C[ 9ט^TdqfnZ|'si ~ 8[ J}-D{&y ֤W0*' uJWJKD?4Uy]Nɋ$uce )~{ r ' Ep/MEisNjHde1[jX ˻G84m HEc<_8핂dģ~/<^d&J^̾U5>Y.T@5m+=px{ !ulWs[MڥG%h#Aȶyfx +ϚXB_]3!Z&t5qX?_j'n 1c)a֡ &rgx8E~{%kngOHa[.xZen|qdowgXt2I&c[DNAn#7@aiv6w!l߻6&f#s;%ȜSڏeTl >yEc/CCw@QPqwµE;q=H|N:9ҩ-[Jj$])NxZ`Ìt70c*h+$/aSx5 X.>F`I#ኴ@;c Nΰ3 AA\MkٸJ0Iк#1;-}H*.c*&'fu:UUc>Szx#ȦJ˒Craqmܹm-)A5ƩJX #QɃ3SY<þ|:A[0( E~Z~~ڕc?qi/!B6Myl9t(Yi?{aq%LJǸ@t|b7 ۵ylC].u&SԅT̫cUH%A𿆃id(įc̅)c +yzq~/^gCW8}+r@T,2KEk.Q 0,`պ,ʁ!JiˆgNll7* Ȣ&1ڊ`:YOF.5~ʗU(ᢒhQW*`eQvԴn$\f7\+ۘ. o`W|Zڒ jqvd>5qY/nX^o{waL ֲf A}\ P}wR^y|"R@{`T]ȜV8YAYR T0O_LƦe 3Iq[MO2>DGn_,35Xq,-#*QXg#TpD!Lﶋz('U؁DܜQE h05TڴAZ*A'*;zf@3GZLm/%=KrjAS[Cl:3>/ӥtrOǞ[zbNT"Ц:{x%3<| u^Vޏ MW 7> ؗny8¥t~s&1#a %B4׀J祂D6Eq|22p YBW7C|>*ȃ#ПKpl- -Ò^>Tl` C\0@ X)+χ?-gȎ"N zkz0@}7S(D"tY#+$r*6!p_Hke:\R,~ G }@śpO#պ|=$6 uvc@ĵz\r!O9tt]x*rw23>s1[}?4#mz=V[>؁cfBxJWI<>i}[DJ+d8&JGJXgeoTT٦,{cAÎʕ$L'?󷦢o BRSX{j5ĵ0^| z<^kslR5OTr,ӊ8|{; w`Ji'8'4ͅZ8> O(E2g"iBioqLPIzG٢|"$8)7?e͹ ;{ X:?2]|=BQ2aǽZpm"!&u&{¡ي ($d6VG (cZ@7*`t^n,Av1~,?1H!F貍dcJ*F1w1nv^+k0_@!{ caRf\Udi%Ik%K)`FC+}80ƾ4g +20 %<$\-7^ '.kZ[n N`*S njP|D%)jaz炽JŪg/l;Jiʟyuu=t1 2%;KaքYR W %_>;8KR4{M&'aV߇Toðc (Z\*6V?^͔O,הH l<՝E Pz*6o3cQV"EUXX/؅Z ժd2|XA#"s؏鱠8Rxzi~g xTȋY0x( 7f qfO#(+j!~3Om(K\h B!_W?͑ ۍV-xƬS[T!ϻ̌x-im!'aQVEq/85c="{@o`QX+M|NS \ӯ;& T& b-`ec.Q969Gn6U.+ۥmlIK&aN|d0$[bO'G/W_s&4ƖY}͊*{w73ۿ $FTGrc H^Z}ezg"wlZyXȢ=gN`SlzHME7D*)Z d*l9~C ߓ6IYݼar|-U=r%jRMQv&Ś!yۃ`;\O#~gI|r>9Eݐ6]bALhW6/u o=@8щ(;jAzTվ-u3 3%qrҢڦ41w|#-~"'$xF)ì "Rep0&9R)Q&=uwEpw]O|H BqX&(r 7:;)>l7A'=!~EM֜] 0ƻ."d[ͥ`ivyA}323)vlPJr1 g)1X$Ň-sQr:#sBSq9o4D{@7М_K99u]y8[,n hw̡fCYMBےa#t2{ҷ1Y/4? ˪00D u?aL7 1jE,;?ì~/tIc~JXq~ڲ(zw)A}gjK ap)-fR`( p{(Rt#Zw:R92_+=Kd6}s_*R?zЖuòhJ/)e'4]y¾а]7| r1ee6+Lrms=1W|^~ Hd=7܊OBø *tzp%ps y6׋Q2!nJYf ] 0UMeRLr.=B&&㾪8[w*%-zʰLPqipqRAy"i`7!.' oP2'%NW'^{d֛ojQvBfgr$1f Y.]m2Z9Otč蔰cXm6)MCKs:kJfs+ Y g>S*R=ɈkQQ(}W= .ʛl gnjd|ax&y>O4vl62AS]:䝯BF c`S;]e1 VJK@>]b b6֊+G51. 4C–P hn'P*5}db qo&m_v=?v^E~4 WK+$E%=={\xzSЩe7n|c!xRu8ȪaK9b q[4U`=ȰPwip*Zhh5pX]b|52MN?ղfpP({lY q@9@MiQ4jxTϨ[3; tz/6>Vq9҂_O cJ (B 1+pk&nj9$ 3iVL ϓ.M)YUa ~Pdw{pqZd ' M/;3> ȓβcxׁPpa+uj"Ljjw'Ip/fezKNiiz4@.ʧ3wRqoرdI 2+%-6eh7 3Or^3lM=0,|8͖4@Z:euX'ܐO?/qkREg#W_ϨXfѵfX0KdUliwCq-i$oſ-Pf nypH.j}+{|K^>oa7<܂\Sp&'c_\|q9ؤb|Q J֒91v; f3/; F}[fT@}smJ;< i 8OBFp7Iwe\#9qȮ$p!ɢ /ֳeb]9[)Η0nWj*p؉ owQq)? Ze6h= qU1"/K 9ѹxnv|ؕ2NuH 6,ȇKUK=]X8XRsRQ%Ã?/jƈ|19+m5o/9XƱ<<¸&xb\)yIrH{i b^%7"dy Mie- +iʴr,[ =`#M,`,DcVnNqvcI~@?n$*bSќ'г-H[}U$Pٟ3 ٗ?g;ܻТȢMcvp\Nl2 GWx1[<㳺θQH(Au;^σ7Z4u`+`6R&6O.x|xtT[k/L77CĿWBL^ڍ`t%bc[9$Q\X v(+%],$mCvw]@5%rt3F@ ;1 Yp}W+dh9tf֦\RrfVb2-~,)w>ExmB-ud9ˇHT|u %_ *A'" ׎g/ᳪdwmqHM5Ylʀs~hRR{yx< aO ܢW._ŔHKN\ o_=&r,,n}ln`YW8Bl[gCt~jʣ{u;*IW O)aVEVSx;h8<.Ȟ8nE9@YqyZ#ΐFsXYs6ScA-+^#aR^uK+(O5ӄ xyIވ73$ݴ+e+KDTɛ4go1^|Sz%EiI<:( {`ͽ;NNY aJqjǴM=e!0%jMzm^ [ _&މ;*7?)es~!/]"EЉ.qӹ)}ȼlJܘ)'K@r Y,w{>s` |'_lny^72?I=MݬB8QF!H/U`_Fr5/ &'Yi(fz -#{n8ӿ޽Q!e1eSÎ޾?9)$s-?~Aťg&4j/-r7OA1]DTW42}.je7S 2s^ FIvLүv8,"O:wK!KWu#w?P&e5'w&~Gȃkbง}!qy޸YS꒑\ ,:&PDy|XR?nYip %v*SNmښSV!Ӆis(Q/o)Ĥ$٫>SSq؟ 򓢥/{+ys,d]} -Ϩ~p*"§FBm[`nLnF&lz1bΙs8 >㭡5[}6I)ޤxO5'XSg&l<QM1|v$G @7T.M)6e2j#{|JQ?fQG4,נ{Cy9UqY@$*d+X(tF~@ruG<˳^meVrw"䕮nD1rG@Ɍ2<Kevm l^3ݽOpJ_ r @+z0S_G=<{z+XۉEV{fm9m`Q/h##kIdƇdO\$԰Y`IJj'PyEw\'T-pq׏-~lP${̟by5cļ,hSςc ׭տg͹.DZn͉F\ /Fv7>*X!q"_8/|lR ,L0) ԣsRٚܦ82mjK Px9]s {MӼ7-ۏIWȚyTUk7"Q 9yr݆-9ޛgy%fȔawt-F\YEŢb/ Y@P+RFƑL ħGrVK >p\qK* (͒u|ʍ&we2nEaV~qPojS\&ޠoC>UHc V@Q$>#ه)b)lRJJG1ҕ'>Un3J#CjbV]lё3)ڷQ[UQ;G W)fwe)7'~L~PؠgЫv^:mLݗyV]/fUj51UUv$O cd 1& r%ĊH@~OiiH{ ߖO2/'|>O)j;.1#AӰ&k[KMeh58<| VȏW %sg$pnKWѻrLZ.| Y32?.7@AKƤPDEoH>ȵΕ+u#HBmvx 7%6 dWM%Iff UI88ɝin gb~l;!gq+7eVG@6B)yNģ"饋KY ߳Q+qK8sk@Z^ sS' ե`MIX)sʅM:s]Jfu=M4l| G$mlU:6\<p3)a%OIGB!z~F`~ bWD*k Rr-pu DgX(΅)fҘqG٩mL7D9;9Tu?'6㋌J{ҭڥ_DpG 5RtgVD8,6 _<$oSlծBIwyNvwX&3;ggi!U d1~;+ N!<Y)]˒9L]Nc`‡3f4TyW%POD!ŗf:58(( ].{t| ӓZiL xf$ gSᔋ) kazB( E;a J3~NS((#Qcm Ok溋AGʙrcae?q`i}vbkB\ kϞ֣U^&lm5R~V~ P~BYMDdi$P K.+ BwzP>8B2_ueJgALg$.޿|˝`Ý&~ojXEײoi[rg^O[RZ>"9wWV!I6\B9q ˧Côs6=r{A* ＣpnۢV߯CchqsCM@JS˛ZYӵ p{:d-WGPͽ,PZh's%i~WZFX$i=h~4o^ '\'z(w A$AVw|* bHgX`{!`G#l:%G6J? e :vi6콲^3;>gNHn6!;ly(D{3 fm\vJ;H~fՠH}Q)1p4IJ^~p7NJ>%0]X@("c't^^Ζ'YJ!Y& *4F.+QRKDo{O^<^bq@CdYȌHg~DC@@ |pa뚿^ NS8ۋvfX{jXj'ܨFɮŵ$%I 4@i$yCh'#`7Hvԝ5q隄M&^CKCstDD vc23M|޸d [k\hl,8#YXc?St,Ap,@/ q>w/*4p j`/U ?3A0ւ[r7eت0ys&^p1cG;:!`_^.>1.9LpQ\mS[[&4\@n]`w5g >CHAMY|̧F77\]桂q+~@ d6"5]ÉFdBG.30$x"+AE~S${p;#=IU›ySͦV?Doo06xfO"?`v甒FHL\S% ,){\)ZBH&P3 /˓mՒg3˗suSmzK'Đjp)I)dݮqd^>Pus1xB3!PuWMV|ح\f`өL\7+a^ :Jޔ<NurIF;VJ~z ͦe{ݻz|jtOU+E}ȾD)rāit!@to|BW"Ju֩ƍIvg~S .xjLUZ/o\3J?F˄Q4"Q!ѬÇepQFZui Gi*AU%c.KzW*$ Hl0U|wkfcu󧅄ς|ثdq /1G|塽T\ H\% ;?X] r1#|$JhDÆK?Ya%Is( )N*ڮ}\^>].ÛbTtC6[ސ* c<,m*e&0:`qO}3(O[\ n-Z8r_K\nh.擜*d;٧5 ^UloJ"ŽĊ{Ul)HD>P!. 0Lg7RݜVi }s7f~gl ̟[(n׏p#U"txPh&hsϹSfA< ½[- W4Gö(L`v5 THB lD^KQW/ԩf G@}|5|Vw4aU%T2Lr!SMl3ꎑ>{y7j,c2 w 2!c(ga~~dtQmw͙CFxL25 @$gM8=`Rlzid|M{:=V b2@7yr $ZR0~*YBJ.D/h}{:t:rPsfE8lb8]䬚@v$<ӥ_/kW:E., LFzω-ɂ#18adv `qL:&ni*.,YGi`9TJѮk q??׾HP3h1P_ެ*ot]i~Y:M2?>0Wgɗ;rrft~43 \R '՚׌JS.HId '+>"/jQ$u"=&=?rVCfgv&cOt|w_74-4ܜ=L Mg!hXٍڟ>/a?4gOXT |K4TgJSۀPa6B&&;j(E7[|o*[S40[ҟζjKT泥e>y01>=[&PZb2i5^șL<:)0|q&oRՇ{ 0hڟ6nT]RpyG8'3YU,q ϋQGˇM6Ktf~_X|5fxrC6q㦔MlB_v"ҨTj;߆n'Ms+o' eYd:ƍ/ y`46${#J`HU+Ģr)h@ޕ(Sc/[t^Fg{CTne ʁ r%`tgg]K2΄1ek-s} ,T2VUN4P ߚZh|aArFX`&Y Au.,;m;b^[Rb݆iJA<\O%_AϟȃdHAl/>ELaS Y嶕F9%I]{uڬ\qc-v,zB 3Y]L >Zjp6[3;L Q #3LJa/ [Ɗ :V'c抢J'JaYVS'XFYˏfEh*^J ?7Y%ӏݗv?7j[`=rX?a瀼iTu ^Z7D i~N6}M(kE哮Pcv3F6)mF`ZPMC}>4j ݥ9e6@PCGV;~^"qfTx|^Ϟ٭)vE)8R$BeZppy T *H{w~E|6 fAPcLIߕղ U䷦MG쌁.KL=c7m!rR Y]md9A#<}3),q-^:[I>ޒ4ի1`MUѳhffrbb-27=S-8}Tm,"VK[#gz _U҆crzj=E !#0qWZwbh|!.1vcYcny̨oaԘW>sG}b<8N1G r<]IEiE4m>wC 4Ou;i4Q= APwFE0zLEq͜2d:i"/n!m8Gڞ_CݢN#W$@{^by+gP7@uuZQ[c._|oTAy X~v{`e-MYY}1"ySs2G\K5?RTܖZr/3}d{7b;™(FHRǷP6pj$V;wUNEqS(AK|RA@l-*"Z Od} <}dp/,) n/iMB|ɚVg'qeD_s"٫x '-#LBɾJ1,k]څt ,G A]0FbN٭Tϒ&/%K~f3M[t s}v] Ҋm̍uOPtP@ԐJF,y (`tXtzeHA&/T_N~޹u%c|Q) ^zg6MUtkaȢބ$dtŀ VNOXqCdN[͙>DgGқCI=ޛ1κϤT}웇\SS9)ӉNZ6aJE v?GquRA5^WƢF$FU1ŗ2= ) CS^rg뾈иo_7t|";4S_EYM_ /Ek#Rt ahlH}/d`ġ{#G?5 " +]7wq48*ɡq-o&-7H$G>_(}mqb^nc?S0{1 Yc{Ru]1Ӱq_E0ux5*hp Fڀ0uEIfrfL>+f,|f< ,{{iۿPvC OPt%ĩ &@ҷР`vMfQp}q˦ײo^h JnZ{~IIUm= k֯q+eJ({`v}E5NrU)9m?˗.IZkƆ*(I[o4%󩈤z)3?X]Oɡ_, VS4%Kwÿ/Hh|/f<KeȎY'V<9ϭ51*JH~0.00Tɔ8nh/A<=:'`F!ɸy/py;^7kxu8$5'">]G٩)`\{WIplUߝ|+&`#jݮ)QMRtȫͩW]K_ %ѹϧP ,(V%܋(B11fhk-]@L3#F7b\ \2 &j]Hekh1xreDE*ɿ#݀x]?0jw+k6M(+1Frc3%w jd@ ƩIk ;Dn|I29Zb-p(HXf"a1`܊4Iu$s>t1\?dѓJkJ5MXc1?+PPq9zPz)y[@9<OY EƼvY>Pڮ5f k@Zݎk"V̼[8u L&E4?YrZ*gCqƹqFvp~ũn=:@@RwURx$YM* ao#~`<`&2 SZ^ WAN., ,aesJU$tuJmVBݚE:cjԬ7UcYV'lrÇm<R^qW:2btF-ּRIQ mM"*#"@KA޴-ș+_vv׍k`L "zDbUǕ_+?,3U"nZxZoyı}q.y~ĻZCG+QPXąH\ Ӝ MV iv駯jM^X9=7K&tD)X`|-F )@5MQ*JEeH[9_߷SVPp,nZ6+*/YplH &МM`?;鐎ЕpeZ2{ Xq:E 2;`#c()ۼNm2w=*%* + \{ah$D9(lOr2FJk_4}>3i)6yR]H$Ma݇Y445or Hj'[wD3ŷt}QʪO}aBTU3?T{`̵Y|>ڌ]ϧ54Cx[oWNuDXm&&CA/*$ Eѳf%kj6LQ]<[4/#9wώU})nYSV|gL?cW6=,g]0uU]Õ/|U_ ihęCط9{A-omf^FP{{߳ŁKv(?ʇևF t^!- {4VhslA&<Hkqx5>V6C9Mswo-[X (8ֺ"ݽQyogroE^rϏ 2WMeӍVw&TK;Yn72(6:rd XGfLgY0.K=p=\=G w)cͤO$ttXm*q=M]J2=WX6Gõ^ S`ڗ~ε=ٜ&-u/u!MBC+ [^ȉpOU%k2ٺs79脿0K)& @Q*P~fFQs0lDYV);Hvaw&5z#&`f(l90{TDYys^1 ve"̮>EhI9?8ЗLfiM"C `WmS5ӅAtDOytjz ԓ2a^2;7!e(Ϝ QLҶ[ rp2TR !@\ǻVP]c2{Gk1J;KI^O cqF(ozƾ `M6R%gl7~wtxOB?cSnOtXӟlVb8rnϢ pO YK ;a ޫo~azݜ2PhT b䋤дQdǎNiƙ#1$j ^uaݷ}C5&hWq;'/_RKLZ6cWSinj22*-u8kQL KB7:Wsk;aV4,hDw?#-`$*%s쮿Aij'#q]'zLl_ڕ`GZ 3^3X*ݜz0f}OW/^x\ 6x^; 4z;q/RP$u>9#55r9wR/r:L'dQgs|%4F SQ*a g2j]k2j 'RߣKi>K$q>?qU*4ǘ98%_ C>wֿLjC-r& BCG VQB~X*K]̸5HC>: J[A2V/CW;[iߡh#ֶ-xcJ"@uSjw\OsH1ҫmJNo\1dmGlWO(˚|p{ǜ_󮊛[Ǜb_(I7߂u4x+wu-EyNdl)*e2J[ZR5#ۤno6N"Җw/OGBk$R.uˤ1LJ_{}6=Kyb qOD0Oex7IV?]&*| &{A3ڜi,W/2u0JHb"z,{G<~{ip'C,oNa]n8o*vt*|3X#w\%'%3nOfqX' wѷSBSUe\wŨ,-ʳwj=!.;e+ ABнz*Uhy/-uMQ0dܹߓiLHLb[ՌV>K<6{3f5jqm.o o$eny )N?a1~;]Izo{ u gW y&6󽑉0?K&2LTLI ;m{&?&y֪S;TPQ7W[|;;4$L{R&ގ.=*޿k M1ue}fƒ J~ʥ%lF1v2p~m0;&sG6#ިE k2zvI[9{=pSfaW.{ uW>e),H5*[CkaAYfFA8m<ӺIcgs{EQOy}$uQ7,ÏO+4KyE.ť-g3HRJTǭ? ?P*T(cobN\yogFIOl/y_>YxXRS]F}`xTa;A 5q"06`.kfQ_%PδP<җO, eҎyM{$%tR=P6ŠN[s2-F&[zHJ֍e罨{i%Γt\wT;q/<ʓ۪mSMUtD`mؚb)g8HvTCej<.{E'VZ[]o0kRlq鎶*-k6Kvt7K)(a//[#{c# [=; q7/BK4Q*T[%xwTm堺@CA|-k7m =>\{3gse7>=n/PXtr?$UfcrĄk!ya.(@@H萹n Kr`w;QѴLe55R4ŷ&&߳3{N n;i4kQa&.?xf6iz)pY Vrus+wkV5+i?PIF7BAB 0Z=& Z?dȗOϡ8۬|+:_ bH3t?T{$8#کzL+ME~Cω(kO|*NYmr&X~ʧq$^NH)?41/b{{yBy&>1MEd70`HvO|8vaIӷ˘=˚Nb$@mw9!f8<lYgh7a(Zfr -7_(e˗BۂSGט+g,]hs5ynJA|Y܇l{-BF̳|8߯G ԏ׶S yoKCeL_p'­njz{BG5\TۥYU=gk$sN sFRIG~.-GzP+E>Nj=c59h˾ qkHFϷGY FmhTЀMybq6TF꫶QSu=,GbiC_wi;ns(NҷōJ)Y2c>6V^B<;|1~H5^֮Km&s+sr__PYE^j,7~25%kiY'?9 W)eLj7>Pzxȴm6O\g()D5?{&=Ky KN6U>`L} 23F*XWS4~\8l혓Ҭrt&Dl'A"bЭ^:=Q$D“z2m0.d\,zm"A֥Ф;˺Y:Gmpo;)u2:ejnjhq֜ڃp|]kqh.j3{Jzmc>W}CUX_Qxs&l}iFKFsGo~=w:TQ .-71< 5/"o!-+KL:'߲e^2ÿ{$m1 sGY5O/[[4fiP uDWJ-ʾ 0MB5txtE۰N5WnfY4yVdF'P׷lF9nk#xFvN@XqJzhֹbB0 ,AoH[Z?SL3du Sw@]9x~ DMU{6( ntkAo陒+7cىmN'|C A j 'ThHL;?wXMq-|K$r#' |vzfҜ'H'*f0W_ϊ'>[]lPBrϼWRU%JFLI0;R+? FOBHE4"SgS6c/ 5aвŌ333LZ 333̒ 333[=Gޙٍ"6t2ާT2,W_s/[Gܻ%ӋknB*K1 mq RCWW9EgRTiбi_S0;eaE^&’f?sPfU_u,W=P&mgN &.r7Q%@vX"(5/ =7җZ}dQ$߶$ۜfVf@+iKڪ i~RxlEH!CFֹPI "ܖ}Y  ٰC*,oMjp"UGބ:Po(Nj#qf/}p[D>J9OܖUOaWF)ϹN@ƶ3|89#k/dy@ Mr@pD9r&C",#G <Dc%I7m QCn|-w)MhD>B*Hygn"p!xaጝs9gbDW \S> 뾘uh=t*W?mK9 p{Sa~Vޯ^)h6o ^ʇT[U J`eXBUug}qZ-"#ПyS0ؖϨ7Yi` í}M>B /9TѽQ7J[bf} 4 vA=lP0Ir^dnOM LmdP {~ =}>MƗ d@+H {cO{(hD?k1f#<,'nu֞1p'-9Ί(6/-DA}`\P "m@8q*7Jt+/W$3`%j-5*QBdS9,]^F)*J'Zʬ2Q{UФ@C9M^DL[db G{+060j<*v#R7|a>}16z< G-H3yubwNuGk geުY>gǪK+RPCeزG%"!rD6 "(ڀ+ôI+:f+@t)q=F3mŁL!gưD Qꍓ@9zV_\j>3{d<΄,`X-qA")]~ߝEKN bT M扅4NqG@|sk)ǎpFӃ~\ vOCW$S֏.߾xEojU96?=^Z'z"*DLhCO`pÌBP6@(`Zg+6*I_J ˑ}4Eu3(GBofL|I-ao5:gsFF~Q|szCcUjɘXB"c^#NH:9VrqftƵS(ʡ,Í7IPptI_Vf؜>JG 'gOW@:PmMCЁUS{"nqB{?{8G? )&X ,{s<\zcP9t>9\Ũ+}lʜ( b/F?aG_Ƭj^T,ZlEpnG٣yJbXw:l>/Wqm"0p[^O;0H} )qL-rwdzҐf5/^vЖ3YP(S(bӪre|'}t \߲%X.ݠa }_^78*z|(}lh9MFqwf-,J ,$_gޚ\32\ퟧ|& o8+;?2|T04C,Bn?f::)g`'>S5݃ 9Њ'y-BHQuRTr%4 ELD- ;k;bնa0A=Hra|j9BRTlD f<M_|[X\rhhVɑM?A:S/k:x! ,@4DPcLׯtϧ oDJ<8 952c{;}0e++j8OU vc,xF~{[ ~qWXz9Xjoc@搝*%68:#"fXuu?5?vQDSwݣ;b$Mӊ&{o92-8GQ‹04PM|r7y'F0VA#8|$F*\au oW5j܇\"Չ+<'K+*Y lz`̣ (%NܼVa x)[SZ-`Ĭtbԕ^+\O7f/ݵ6!,_ɪ1`:?ON:թ(Nk4mYlH`6蒷R,JgAN[.Iu^JA(_[ 6^L AYnHݜW0/rW@wII%+I(Zbaj%K,Ʀt AQa'jL82O WM=qAg㯼uYZ=J*5kې&5kKYwrv4Me8(A**t |-[D]I^H$[?DI{ x{=*]s{ҿ6tTrKTd,O-hN:/a^LNd.c HfAHaK`dCp"[P)_ ٶdo(%{]/C }{k{)]ǫ* oH#dnG\ڜ{qԊ~J E ^<'& %&5v:LisMwzZ)۫B0\v n+c.Xђ 0noydt8=T|Vi:xﺌ?k8^ szׇrcu~W9R:*.B&gc۾A{7dZ-Uh1[sx9YFo\ZkiVSC0<+=e{ qG5=-BGGnjB)IT#ZR>#TR{հA$}]VP`gT$';kWUu0we h= mq|s(EW)Vewz~0+uI2cX,I~b,Мޮvlf<@"PPK[쎩H /p>k)cv' 8Ha,oJ׭W~=VL /''LGѿF%iԨ)B>yb& {savnMfO~y;ďNRKV>Rͣ%YTzqٌG ωLvg8_;暓tbEQ;~oHwX vK†''ޡK*4L,퀴 Oғ00~93؉du_M}IԒ#;Z7_obNkO ŷQZr5}<hV:RlBƶp5\|i*n}Ŏbb\;nUy~CERMc.}js"8auvU ߊyc e2Wܭ rQQoLXěȬ>8K 3mBfʳ`P'#kͪK4^9V=*Y֫b{'fJ4DܱG w[[?Rȑ:uЙ{瑻nods: k+9Q#Kr"|8t%&E /?Fsxw&^vɗLHz؃9F} 0ڃn~@p_rНwa7qgjfj wS? Q:6T銗M@%]=0 [P2έ[p l~'h/4R+x@i:NjhVVĽZugυhL8e vQWZ<'x~N[Pɞ ,Dy.;Pմxװ.{Cԑn Ұ<+$i]d4 5XZib_Cy z'SlQ0-nf'c@S^c&|A:Q_B"?V=u _: ,]~aQs1hoـZ#iל8Xf1-&[2<30kIRft6f(3Ek`?BR:ю^wbfX),.#XD-i߾ڃ1#^m=gz>GO^LQh$7M6}Eв*[V-DKeGh'tZ A%jQ4Nыs7_e$X\<+CYuTWɼՋ._)(LG'l( ©ZcOӿ. _V-1-yb'-*uX80uZ rʑ`6N.?Pkze`He1\0|pP~evQB`b`) ŃOMm!l ѡkh!S0 e/;YaQ{ ٛRT` yg0`tLo:\`Fg ʊ8"dYZzgkT@NG'tB|bqVs΀Cݝ&LHԙ]S/4Q)Ҋ7N;ZZWik6Ȱ??jĞ#vn#*H@c`ro~,kI&YUqYi.SLo؞E򖿀`C/lg6ÅP%a1Uřnx z9ֽOaZj?¹7fL16)~>lOX1C@fex 6 qR?jR'xJxgNv? KU`gfKXDEE_+q*Mt^n*OX\t4vi9^]Z]C$jƖN+fioF] =CIT:I:uYpq,1MA kXZda7i`%0v(#R˧o-"d(B%lj!D?ɣzoi$,"E6Em ;"HB|a5g5-ja.e)o-Sy؃Jsw?F-vK5$ [ބSH.8D&W7>[m_jAa)VYֶւ$X/~`#QܻEOk mƻswQnA/v LH_IkH]RK0{&+A_EjETV}+* o_<(BiW@N3p 6K|<7{+N;\ "dy=#YSi }ȱ&Y#0ON7^VZ!(AD/fxŒEe‡չ?6^>4T?Ʋ͸$2np׆ar3|7blA[D[._k~aR8=,kk\>"Ջqzme״#o1_(%%Z[LC8qJ_i5Hx]M2 #|\[ps8R~Hbcok]\Ŵa N:~*Y^Y"^.wTE\ȶc +h0_v̷G@9v9$XuT*tv@cwxq/>-bGTŎ^Lmop^=hBN ,`K&OgH!F (%C;~+fO'^c^^' zsd:B޸iO@z_S#UqIqZN\~.o3qUOVQy`7,#Y!Cؠ!YPwPX4.4VUCHp<Ҝ_"4`3֊YQDϺr8PHcӅDxxj# f$ mYT8L ز(uiCS1~?o> y SN uba♎ bt"CR eQo+pYW< *a0VCr <}`P^gepp5q2Ümxqc+JI'Lߙ~(Y]4Mp|ʔhuc@>x,$H:1<+H;<:ƯiwAT~D3E2Һ|c>S'L]qնm1tw83NEnfV՘r&,U8ZC%X35o`Ҫ[,*\kN+FYu&7OƪO5?#6U7λUA ԿNޣ1<&zԠ5VJg7< {`ϐZ$TzًNs n{L[¨֚N(e^$,I=3bր`Pڨو i!KwJyt.,m#/Z.d%XjQUgiN$+ӗg#aD픃m7 Rj}Ws߃nCQq-↑2Mj7f`2F#(.RwPr wR<ɏ>ė^D͸hVKnW } Kh:yoj<+Smm/2MZU]>cFpXU _4:l>^:j 5 ͺ~Mnz쏭h\>bbȼffbA;QKʺJgWad$=e[B ) _&rEB m1#FS3T փ ,){#HS(hqiD BUUD>rd ?WZ͜M2H&y[a`Ԛ=~,X}@裫hulJ"%:շV@ nNffJ%?-&*Q$ i7fmU+5n+?;*ʶ;_} |mo52kA~p2+|G upGyV_?ۯ-3/1"X9Пhr&'Hoī,"j~WL;cZ 0sa- _=)vqCK:UkJm7J2(^ eR4Y鵤d~o^sowlL} '[m');e"|fk2Ν1 My7i o+0/[m[DL=ƬuD%׫@ҧl,c9C#t>M'얚EH>eԀ FZ{לV(z;,~ vOͳ^?|7 hi~Tky*ș9$y!☙$0{܉{t$vA+*^N(N}0ұb@_-jԂ:dLyv;`hI⾀mb9De|lWl^^[{Jako?\S)c ժ;!8kN?2tڼ$@?`OhAYzmMeiS~^5lnWm=1U.M m!0(%j'[k `x$ gH1l `N_)`񜊡="R [Lq?籴۪PF%KmFѦ\0wӨx ̋q;!1Z/u7pJ$,X]H8Pmż!+ʈJUޱ.c6GQQp ["cNyUVz,'qEMwq,uj c=0ꌈ-!M!$؄xz<~713賰1s0q22ՀEϘȘؘ83 +cd[?#dVɮ]4/TcEݼGM?RS7mgʸXs5۳FoqK;?.w:xz,ڟk,yteߩ<:0:>SW8]t2`dPto5{3(&= P[:|>MYIrLy;dAyDC[}_lm^GO`l`c]vE5nx1 sfqWzvQ Q+أνV~#3NY}5Fr{n JОcj6>|VSR+BVU˼ղeHgYsu۰d 93ǚ:nf627ۿY0%gD[0/H٬6e12+yɈ6ȉdAX?-%HraEIӏl+ og5^o[F;]x<ϴuQFcPȶqnbg,pg -c2Ht4EϷ}= `:~2x<9xrӣ[+d82kʀ gBpO| NZ8>1U*eO&;l+ݲvHt:)"DTh~hgRxYl;OU$2ah5z9ө;x}-ە5ovɁ'0Fb81ys,R*A}uSD0)9z6 ?di΀f[Q*ԡNރLkb0QthфiLt8#ö5PXy3@-ljmCF5QQ"!8Jx";&Wx^ uRel9pVKнmJ8 ?aǝLs\E)+^9Qz Q돐ݖ鎩]-{ KO)3;Ѿw1}/ 9$oDjVcl*>.obs\~P=֑8HhQ4dPC쨔UO>n0C#rTKp&Lʉ]J0Zn-SV(#m*].͏MhQ_~ %[< &ù`?nu`G!bYY2uZ7 *09eanzoJs!۶*N*G["ƪq2zѯ!^^LS(|7G>zp^[~s{uSҢmuPE5Ԍ] dr71"W.!:DfSy8&%Z AyrP?4d@'~-AQҦX8lB팘dnD2k6 T h#2M~l[! rZ˟g֍@EN'W]4>UOK/gC_AxE／=^4ʻ;XQ0ez9&RR |o/l@JW"3k)T@xa4X¯2p[E."{c,+#HɗDhN\z4BơoQmz> 'i,*xhwoa ˴%9.df_G<>xNPDiFxOCG\s~f$Sg~pJ=CYHFc/ b2YE1sor=U #4!8%OTjN_ o"Fm  A s9ԍV!'3\ KRcA&z A^B݊YGTE GBAۖ}ϾGFפ\7.Zr`Tgõ.|Y!})eNF-PFW[IM넑`WrX-'n+ZgomTW&"!Oy e5wnm_&>/BM`VO~y!C27Whm\v 6g2Iog1"ϱ[fH¥ ]3ys=(+($U4Ƙ{󍖩.gb]WkyVޡoLO.f =(Eqi/)iD"rV-)}p\o0/ V4I e]4i6Fs܉I.kA^7kt D_T؝vA8# -O$K"&$1h ?áU׍o+4kfxggI2 >X*./Fap: k!T$!ܱ= X5gЅC]!͵ "ՌK{`46^FVK1R'JU#,$jHmDTLıIp$E+.I!|01u$g) s]I>™lQU[RC05S[Ԏ-ONɰw,\M3-GHԍJwMjOc)QFwK"f`W-!0+U-t}Ҕ^e8HqX ? ݅P2FtvfgYCmYPO {|`l$xCy6b[@1}p*DuHqC3BP(vk@Aߙ&F\<[8]g?96hT([r&\LKv#<5M>pڪ%Sv27]dhFWP]iqz'BےH`P*e,׍l k»[e[`|ƉOȉNM/WTm+CDU T9JC]d#7u H.JdH7o[rêR" Awge򋰧BHEpO,v{!nj9NDZ!//E&֠k7jY4$L:eUB( .7čtܽ!LB ).8E,gr%4OovZP%9:~V\H"xDD!3*8(t '\T `;5e{u fsl8;Zqfđ)W3́lPS !?e|ۿ3DdHbSFDj;Gsp[#gS6ff} g21&ښM*gvc-}uZ':V{ z6WB%!i.-lXJw@VHD';Zڅ*ә 8v6 &в}3}iڥN j${ Y`VO%c sbQE@XiW.ZcǠD,bX$Ԧ+]B1| #mGJ|n G\msС]ClQ"P+xh2OScCxT%_agL8>1I4|_a|UaJD\> |0hf)6>uI  iT\~='|uNR!nl(h"+i.Y 9W3yuOX-ZGv^v8=i533&2_[ñ/:\fk#|{"dx]30njR\ v̥MkG СvRt&JuXybssfT?.N'2pk'%G;4n,\z\k}f`VJbaB|XOÙT) ϑ빿)&QŦxw IO=Φ\3D> F&cz]3pkz Ԁ^Y2Uf!#Y(hjM}t$Wi(C [մA ?ڏ;H<vbg$ f'L7[0 0mB~^XZupXxդ~S2aŭ\-N=/)ʎF'M 7Xng.ўftMI%T ?kO8׫CXAuvdᎈX&-E;^tԐhAC taMywE>#-BC=bu>c6`I٭=Ӝ] o]}{N(ݘF@m]6;w"Ns[DVxr&CC}K@\f`=[7%Qef'_crϬBcM@շ-!wށ⦾;i@T}'E50F8$cc#*ذj&I-tɓei!aOw i;xvFk+8f:%٭d{7<9xʉl Gl?HP:^D3+jX#`V4úڄ[M5w}?sqmo p<]i]"ɑ2$.z*f[ލ#BVO dD1 xR,=}PS閛cɎk_qggL c൫PMm2׿nJ@>N3{AלА3-,5r^y {4+3ƺV8HXcQr\gR^O"A>~0A'qlfF&h⃒ۜ/$+Aܠx5Y}1Ҩ*/ĤVJ '-4xxI[ fƽ6yGɀ{kkoPպݛ3tܝqmDxN_ێYEH.֒e>v)H_:oj"}[H1ƇY%&UBy<,\dhQPqO&Q]xksp胗BNZ'˄99fu-Þ^U9 7oOncʼO7=(#L"Z_phG>P j-o4b8[>[@#n1q^*ԄM|2θW?40߈a&Izu榴`c^4q`3k[W$[ T_ૢ]dy?{-zl.^b=GtrrMȤ{{'[ǝ]\ !e6ơ gPdi5?M.Kq˶r8ldt4E ܕ^Qgxhl; e D]mt]8g}#Vh,Tef8m[-9A!jLJY7ZA"eȶz9鏔\؂`/rb1:\SNoPd:nt m QO,Z>CJaƧkh3Xj&K;lф+Q*W2`ܝt7۬ft_xi*M54Pm/\rY_y acT`,l pۚ-Vl+0_t@ L$ m96fJ1_b,eHJۄ`ٺzD/1"#Zl8Yce 4+0|2lVcU:d|ld@)|: xpGw Ε:t4L+^%5 jȊu.Z-fD-l`p&:u&1 /ɟK~ު@+![o!Z̖K uus5FT@B{}>6q2* ĦX@3$XlQ$p?fCnXGq;B9.IbX4N;@.)ҝx8Yo #D6ĕf+9x)hblhN@LOlveg:6]~]|-w14[uOy"&zGUKR臄}@B>4SZN-4$eGq;ȶ<gCvG:`*~9$3\|XZjF2Lx!^ɿzqW-%v/"-g =<,G7 (⿟J?^|;k-N s\Jp~Tc渠U4c3 -}uF&b"Z0]rLjzXkW2SȋXiʁ>^F:U)t͜Yg1AG:_^y-:+iz-3,2UbF ja?Z[m`>YҤ)_?:jbtȬd`8ߵЕz41W$@1}(7V%LE5Q OTƥ*ymF7c}:vp>79MsZu?tk!tI TY@'֛f'Yg7 6\oֻ?35Wazayk!J:Z8̇W'׭=< CeњaѪQU%ytoH,*& z Rg=QDTD)r -bSY;0hlՂY饔[1]Mt1PM=Jz{ qbl[tccci A5\9?5R?iSM+uR៻^vMI Rifq镅1ؙD М`f.KkaGu/kq ldRRTQon7ˊm}ҮS< )ԴgϧiGYoX9X Y89 8 9XY 8XY 8X  8 W+G~~ZvϚ>#c2Zx,f,,ٟg?@c?ћZ|:r/ϝ7<秉?xߌU+j׿I.?݇_ ˾}_f,C#)Kvؾu&Vk=:QX)/1:o7n !|Sَ)oXEԙX s\wֳȠiְ[Zζ?OmO;7-x; (Hd NC5hְvמBQeڏ_VmqoD5`wѵ;ȃ[ t?Ԁ-o\&g>F1O4Y97T&,&`8Ey2"J=B*=W)UZT-Ӌ , ^h4 FоÛ @U/Qg@=9̜t#0B Ehͼ /)i^_!{Z60ģHkW25Pab*ܻ$ip fg[v-ۡx =}ޘPE$&G ayGiC 4vNI֤~B{^^=1n>Nt]si>5ךC᳋c@&Nԩg2w}[t%֓'W"PC3Լf%~Wߡ_w\ܤjk8XĄhv`Y_¤C 2Kڷe*o.D1k aN[TEP[~-50B.2 I[)iFe-Zל,g)5%.;J0g=43"PFv̔ KC8)Tɖ*+pI'2&񍔎dO5w:Z`&\+;GX :dt쇞+(jR)L& = $2pƎyG$^q]WFp8 *̭hpdYDC yt*D+Q0whx ^ELִuWt:(2cj^f4oKWVuq`"I-% n/{׮ҟհB=PWv)bM(hH XxoZF1 ,FʁSB@,D̔Lj"1#wBPcpK`UUm$l7&uaq(d^60 R=)@P) i(}B]WgpFyEɤ 5]kыwRe@1.eubU&wݗZds}n'è)-֖0{O\k H>غ/n.ڱDͿC',{Wvv0zeCy' ˚J|ϞpY"Ggox݋0=mIuce|͑ZYxn^J0{Eۊ fkwL[!F QP\}M?;kuձ},h0R3+k}k( njHw}S 9Amnڒc~$7！mc*sT2,e?n*z/i#&.&k|: >`:R_0~i(an,w*x Gy)ɵ"qe,R%;2np5[GcwZj<6Ԣ4.ƣQ҉U m.Ӯs4Y9p[Z̸̿J_IhCVԬ*iD>1n5Bi{ДbfNSOYb&D('1?,~:kFz_#pY-kSK瞵Bx-!OH=."jKˊh LϿԑ;PLd'*=[A ܥO#{V7Mzwn}>6S-rDZ63$!f;hJ6L5rbt7CMBr5:Xw9 >c'O!8\=Bv5ĭQBt%~3h%1!?dZЩE~T+h)tQh13XDSCU$~ ˽-f< ^ԑQ2gao5Xz5Nqj6o'.Ma<~cOuT" -6:(DÊ4ӅP??78 !B6z÷/X|ݾPUͿm}ݲ\-%󵶃)A*HıЇS ¼`ZČ eU[*-RAxU7^P&yvx ]fJ=1NQ(G >O\+Hm%bx9W:C:USbF~h3vxq˥P+ 6=I? "ە@j1iCwN3P͠V@W'.Ժ2g4[77na*/l;c DBgX=ݑ=]`F|CvR7.i"?Jɟ) &U;MyU+~ Y0Hݕ&Y4S@#z&{Aϋ GPICq|]?/)$%dAزnoCÖZtVב[D]=iEc̄)mDFA>l9_W"3[d!YDǭ !^:a;ZAe# Gބ3٬7u iS>[O*j _t)IbS<w%dS[ ngߗ0!īQćJY*-~]s>tۆRTROOoKQmr;*Mh=Ϭ!կί #Q# W1Nѫ|p8 ]f. {\٥'fbp01|6kK1%(WDƮ#2YJ7CfHypjP11Ǝ&}$X(>P\8ǃQˆRF^hoe3׏! 6ljK <똘 Zg U|POsIi1HbfXtf#Bg !ɳڙݥgnZ,J MYEE[}N> 6)1-߳DQL,.p'̆V]ov4ƾiz&A;It e/:tw? ;E[BώQ#͝f=RL} HmiU;r653.G>rcZzWIr ZAOx|Jt$g91| "}t1)tثKt:rd#R-Ny#$arWKuBь-Ix%h\yn(t?w49o$£c #>\ ciJW w$@c҂FiANiAF %<1:}㟴 &e{TWf6x"^E17w fBS2ڊ%-+pӂJN^!D2,A +Q>= dO,}{)2pB-K`ĵW&5FRp)oz| gҰFEs=M%L/HܚQ l;4ByF[ CQW7Ԋ_BaoRd,:"F.&= {,TΙjI=2#r vuxmVx$' $|`'b&oWWk_dJ cbV{ 8[fw1E-`ugﬠ}M"ZfXDt`gM+n-KxMLasM^?XAmʳ1(bSĜcG|%I]1Ɯ M\#YAY5YA1ҟ=&Fp.ֳh~jՓHK{ +Lث;,k\q*_1-2޿>5 i兹b_BQ/B26ECEݥ}Y|2t5d7Z@:!d ]?n.!BN=sqԲKô$z3mNoM0.G{5 ;Kk ֥ YDGtӰR?"8QtZTh{jsI~Z8YJ@%gHh"+)mKڬ}&'dϱ:汿 SZt"*Zi9dis'Dzwg%>~2;P#R釾OQF%]tt@;ș+Carraoi+䝔t%p*#~ >wႠ ._6vZ%Cr7U#ogJ ~DT*+@S[!L&j`f7x^%W*,v_4YM@%*W,ЈUv%\`*|`m;I%uO8|L ';`vuas0l4沨aoywTv ס8Z1{ @QVW#| C( `G9+-~7<\=iBzОF 6|RYdaX7 gNm8aѦ9Afht 'H?sZ h}ҌJM(ۖ|7L#ԿKk+?~ 71M<8u!$ )Nn"^s:52yψ`GM ;|i>C-9^Pd;=/}{ φ2Sڵ5-,ڍ-XtNͻ2 0xބ1pnD j#{4`.2V~zNw]nLTw2d&j}c,k ~M%]SQ/ (VO#󽻀ї %h/%(* a߂s>Q5QM!pǖX0p.w%(XiS3wI ϛa\Qm2`_1.p/>xnXZߔ -Gm '64^+2i4Tʚih( '^ 5`{ Fc:KƂ$8`AC{p'!{pwy{{zVwo>wU]RW]{B'Dvn$$!v"H@ j3:7%f-"_ fvdI{jw39*;m"AcpozzK;ἂ j@ .6oeN7+*S_e  (ˆJR|5X`5˞*Y9~|Os:Vup`|` Uu7sk诅ydS.`nُ$109A.Nj콧p΀r1,8ʼn"=< G"fT̼R…uB+U z  gr Ky@+=_y qdAOo 5O]ەK]ϓlL6QyJP'Duspoi Yf鏟/?KN-lt#AbXKǺz\[4>g/i d™ʼnnU헧!A(|/E9e>[[ͦUT'('Bf@mr0EZnnYmRr{ti0'  sًV9`BaY^脄a3b]}Eci9zl`m;{:"Q kC#>۬b/XaGpTbr ҭՠaV@9şF8OSӼ_(J5 4LC+/|>'#Xc<frţx our権uP8V߉u>uDTL1;\)09A(PW*0_ pNt>-g@z,Eا }V֦񞾾 =ۚ š6i+!2VS.jrA5įD1O_ xy<p@,/v{ҕ?YT?efitk뎣5t !v;WBV'^m:V1LKS8<7ň *'֞~aN.WJ6[^%M A|߼uzػgdm'IՉ7Q,<Ť5AM,gpƾd΃O1Bԑđų2Ļb~hm݃vR\HhhɞWWԸ~tQ*FO'fܒc,ȳ}@4E, Qlz]C-{9(\NWK%.FQr*r!@Z͎E}p+T`~;_lRSS.;\>;Iv/7y4&`8a?]/m+6D תf52%J)W,ã%rb[ 甡=ojjөk&y"Z(<ݒ*j;OWc㈷[t&{)6R`6U?㢽M}P~m -igtL}oNLo^-u|] *9L$&s*N}mf|yU?bZ_pJ" X2ZТ0^.GR~oJAΨmqOp%[yl1Ws) >#b 1X&%o׋:MqQ C4!'±ErihYj]L0 &'#>ӇE{yG`QUatzj-|R=-Ԭs"vߑFwqbnxI䦱%cpXxtG%eɱ@58]U욦9{w#U`q\H9bbdZ@uYmߣb{굞|˜s?̌YiXPD )T/Jƶ@RedOig>::~UwlҟrnL诊$0 "KVX\)*B}Mr8pm9Ws|D޸/J>od9v( a+8z8pU\뾠 I~'Lz&cfv䋍?JFCFh6d'F2P?68&70N= yTUVC"amQUԀ=6 țd>j7g cb  k>[P◶NY0>({9@hovcNJ[@/}iycV Oߚf"U13։|hl+5n[7}XxZJeq圂ba(31u΁s(**keΨ;O"i4m]m,s*[v50E^/W-O.u`f8ǣhP՟;?< oZ Ҹސ@)cyH՘VI4mnroQ|Ig"ǒ6T1p- `(kNo% ՞.P7B[8J.pF#bj{zOr >@4}xXU=o{&P\05=~r(?"yd8=WE?E:G.?p[JI4k 2ge g\6Uf4[6@KbGSUbUVvR}3 Z?8&zϥ&PZmLzZIn44|r jjZ` l#&9>v C޳+65Y! 43*<}4}\W fz%1CeF>isRQYa704@:as]!>`PCو }d9 ިgӺX%EW>/IPyS>-Vǽr6l~z8#=4 LN[mes郾.EN& ڌblO!o5/=e L\J(ZAYs1d@g Qq¹<K np <\ԘbLE^[\RJqݞkZ U&'ijh4~'?vr[ݴNfzt|_U___&fӷES c-JWzAdy?XX> JEn%Gӗ+o~mѯ(7t\d-絼b6z|b>B눈$AF֬`i7h'ɀM!f5Q{yͯI"T3oHX!1 Mߟ"W۝ ~/#AiA5$siUI@4lhFnTR$Z=84BM/SKd7ii["(| KcGp| ~Ik1([O2nWQ[3qAGϪgMStJV^2&67|\ዛ쟆&Iu=g 9t۠%ϝ)jdZa֞M(N&)hn8rQu7?䲸Z?}nJdӨboxa`vfW_?sm:U}ϣwC/Q+vsρ,Ƶ Ck>:n _ 7! zkpF>0!Y= ]]dVc)ǥ1Y68bz=h!ʔE 89_qxinJQO}VAAp-R"{XX![YE:8?%TФ z4Mz..rJJV he޵ҳN'*q)}LLÊ46Ӂ{F$G[ąLoaV ?kTII<:|Zd Ï1"홑NO3RU:U)x6td.J&,#T-S6m{%<'@!"XS}hôђVds躗Ѓ(6W 4iDu$̪B.eo*^t$fпr13W- yA` "|;AE-5Ec& yg|@?XU[4' b;o s+Q)Iŧ&Eű Z$(j 8ġU3'n)ΘYB9i.G%~hoS*44`ܤf2j-=#sGo=} ?/`:*/0މQ~*R&>M{qQ[B#p!><݀νˀ'SQksuL^[ѵdN66c'kgc '] Kox 6+)qM)uR n\lĝ[0=f@D^JS>wL 4 CIJnٖ 1^|wrFI;'];Nk4ۡz kmsgNFAJg>A2k<`4՗+9J;;;o.w݃ӟc,']j,JKF!,()Ҙ:O_AjC'݀f;E"sXXt dr]Ubp.0 $-,ԚOG##N,vM˖kP݀R#_ 8GfheܐL䫷DEu=.rb+G3l[|+PmT6z.S ?)-.р M:*M<1k>|SW7Khoaf tGH‡~Y#90 )$qO 8^"R3Qfef .Z}1/Ym$`B673zo=BBE!wJn~ a%,lP3S|@;1i2i`Avz&qTLfWJ3MUح7 ?,Ϲ$F(?b$5'J9|bsXNɁ+FLx!ݙᯍ+yc ~N5R G~`˅7m?ꥃ ߧIkkǾ 1? ה}Iw$|T8sU Qwx^Z01d:G)z_צs?ʍǶ\V0 ػכQEIѪaTq$'< ve,Rkyȹ:,ΆR,ٝ_^g~ ˤpO5I3Zˉ'CEg䗾_9{!oGG`LKBKǠod`HjlJǪ`j_d32231ְ*p}soq ϠVK%3CGV_n+o_^/N}ڟ/}^;mw>c>Ϗwf2vVj͹oҭ{ڟo6}^.OOL[[MhFZ*F%8K:E!L>'kХqA5Z[f} eWm4MI4;kɬ?3qOe:m{o.(K<$Mǫn,8kuhև5CO sr._݂ǵp7PP+Qv8k)Ljj3,fB~M|!* F*6nKQ0 緊H./_xq:T(gt~! d|7#^V}DVbr;@ͤPpmT@Þ 9j,D$A 9iiʬH {zhr4X^Ϫ "p$"8{@zg= =u 1g/>(ʰj,~gfl棙b#f,fk )|5ڶ2Oˠ+gl}JSӳKápW08+kl<' oG8η=`ja%m2JnI,?逞ik?wǬNZ*/Dv]z$˷jx1ݱ. #BcȃW]:NBF8Y3dqz})Q>AI!@Eє*R^^b/B>D1PL%fĪ!9 [sѶӧRju7xNInoJ]1#KXplxx|DAax42VFw!t쯪^imWC1瑙gb*X $#_Jәï mHJ@@1IZ{1d`![H^I!;^tەnO/#9䞾Uhv`d{δ5?˽^ Csu8*qkmjSozXru r9Pgk|wHc;1ݏ̔ vAL89GT-'ҕD1˵I*\8H|6O!&s;ş g[zF0N`kdbhlh)`tNNK3=PлgX&fگ[/]B=qOIK|?u_l_l6.7S;FYSM%ɦhw}Ms p}YkBƲ\*l- (ÞeH-߷ǔ%)vNqk#(t`^c>F5|^ߴ-@V_?BxxeW茄_(޻!1 O*,+Ȍdxt_#c#xyǵb(^悔<RК6U񀥷8n H\!FƷ)E<$ CڵHPpIDiU4iiπHN>M8t>4 zɺ--"Wa d]QN.(È^ޞ}!j{b(Fɻ%Q2%?},j]P;1aiI( &߾׊1wчV3M;=F Z q;i|ٓ4IZcǓNR9phXPQ}%>)j/o@Ctw;l0þetfq]E0 l^/`2+S?H_h3!%ysQϘ<$*z0HpPӾxR ];(~GMЏXHt'C/SnV*z }& ,$=H5e^|b v-6+kBPp%u|@PztB%ڮ5>qM q1?V-KV8;ggȨPp4p@,GDZSRvkh $iP7<$!!k5\& |+t]"cvO=(gEvNV Z&V (P,xgƕ6/K.}Z:= /eP,0me~՝*;3=['NXq9=s1M.8 $Qf Ğ~Z1VDvOے*%uV4Ht eOo4H1z[WEmVGұHO9ZZR6gJoHVCǮY>Dq0䢂`ym5,U6_C-K~PDҠ:E ܣа1t^uK#GS%-2`.A c:xB.e mⱇ=e B4"^)ϔHS'\BN(N6ߍS  B ڠtub"G]r\9 9%_q@ lG{ƗVAݡ =@$J{28~!6A??1T39?eS. Qc{חGH#<;y%.sQ~CQ#Ze2/BC qA3YXjɗzD=}&CfQĄ[qWuE[+\.u\.9lAy]45-Nw;!eQC?KdN;af: ݲW,J|C 5 Oi#U+ӒMXr n _%Ls+H}OyKD_nJYREU\>([şBaPѶԋ,JC/Dz56)oڠhF>?Y4|*HcU"k< Wm˒Y]K`%mk⋒p--m63 9bκPs@|Yp [zLZW:yQj!UOUEhH)TfDJ l G,5#Kr5nI˫Cʻnc J?3-!MBEN*؜\jEŴ9ê2/'IImFB d"Yuk"1{k$1]tol8L bXySGTjt_ʠ;]woʠ?j/vCjJ~>)Z)ĩ#} |gZXE^zi7!ߣ :Ps}+HR$%y#"^aCF쑌+c4 ɆGC45\T%BJ :cXWOP/eȚ99jFĀ&dR,NWrɿ2-#A_sJP2~r-Ah)<^ʒ+ iϫ:Og*6Rwt9vczߙ3Aͤ9s|8*i"cR/ܕk2J 8`,zM֒m焃du7rV)?&kxh"{z' w!{xgT%Qa:`PY1- D6R+_ 5'U{qq9¶gG*e\*ۖv&)?ޱ8h >7>sgLA':F"xFmVB 1j#ST߿=[A)g^jNvP{b duC-Bz˩A [OܘK_/1mI$>ShfV~\;#=cKvGd٫X#xo Q& JA?D WAuS0ݮR5m,}_`x 𦍠­M&|uUL#HAGƑ EXLy7[nH7/u#q\xMWbq/AmI;6t(Οo[ K\z#PYO*c5{t+Q;z(Apt*v*4M?#Yj|xGзʌm}A^87 QɊw"Va8!/ae4)"sW~+1.(&,/Ŏ Ⱥ4v :`K#o ![Jye ܑ)0m[\TzO/@5(yH*G~q]礥07վn$toDkL'.AF~1a-mL05(/h#^.huK6{Pm3br,P4.^!h8pO7|V?-&g)78`6J>6Cք6[hK|=T>o%őu"ZF4ih0sQ;)1s톊'oA3}lxk\l!9?,SHMPA\ɡ= s|&IJڡeUG'ĹU:*V - .ǫih[\_MFNfMN1DmNlۨ4J!3ÖsB!&DtgAx]FG7['`vbhSnJN)Sh'J'*=?6;AST),;'Pc-o>ɂV%5Նf޸z=DXUk,ۢsB,hȂ.eA :qr9(Pw4GD߼.jc{m7HQc)̬9ɠ64lHbTҾ$ɂeAߒ#Hɚ[ݱqEpoYFl<'"VT^-/&$"+ؗ4dJ|j7Doq t25ohc$ehߍ49nt)3X!ѿTSvU?mqm+b"DEwMq6c#NHh#qV~PqVuYXw ;ħ,NNΥN׫gC#m@0ɣ,ӹwiLb0'q̷Va;y ( ]i|cFcu!ʱp 5zlr{4wGn3gSL$x[@FQgT*pVmuq3S_Z@l縹fqMs:vl]1'ioX9?Dszj&&yl |@{SyD_g%01't 0:C EYMgԤ  O.`ƈ7v*vLVy0st w5VbF+t.Ψulvou9' ɏ/}ngغPU/-p!,?5XݓԻ0LR~ ~w j 2^!u"`n$PgvR%joS"40G3ŴETqFW f"F/@(\M!5ZEHW/GGy\C!ݼw}TJr#(B7MФ";?iH7fc3AnHI|ɻ|o G-l5X6$7råMO/}R'5AK4AGmGƭЙ>WĹ_3J|mGz42|gpsb{;5  Ϛ϶+c ˇ 1@`C0{A8|lU_oA0Ab1 DnftwsrQV -)s;Z;;mES΀{thu"9 |:ժKE,: Q(a-^[{yUZRpdK(Q@$wO4 м|eF-2#YdQ SO)a&ZS1(afLZɠ{ӋY*zjoQoHeb5RDS8H|_"UeD$A$AIГ7HAZC=s_QyIq/"- _V&i؜΄%9".+J~'`ϴ+Z@ X&i],vYmbTnfLD^SNd'Ytb$$ Zu0cJ%v"i[C4W –9_Y}$Pa.Q:9y{F5th}iYNqNFl}\WaO(tD- [۔WƞO{OAPMO&>l4#ArXa3GvP(F»JR[g?Cf9%D&WOՋCSGH3L<[p@zhN ^n:7W0RVȜˏl,eXj9u*Od @)״wHc Ve( #Ď;M>Us .*M4d${WW8H)q9 :`Nj<*{4 ئBFuT:C}D7v5T{Zl5uŲ^V]Hv^lJ31H!8jyX۝vTm 14&ZiƅUrjx}ӍLBd,.g0irޣ8/ 0uCl1p0Ox|a0\biq>I=ZR7Q:1 m|-j|[YIYnVΩL#ʂB'QM Gj9QMR]hRvRLH\N ?avW֎(03X%-}X%n3))! *Ͽ@MARZ. Q$`6T]Ml@aZg7g gaYi:`ș"Ǻ^!Ԫu{ ݤGCI Hr[֜@κ7Gt'92z&t c1ƒnvԻt\ޮUP&쳻ݵ5&NcOw״O h ɑ.~1TVؗO,6XRDrd޺݂'S)eaF#)qa\X~l;['i돼l\<9OXYNVG޿zװa֝SSeJ=Tj>;q sC>3"#nB;0g@b.\@')9D2tQ] æˉhZA{m5bt<ږj㻻N@2o']PF]b2\i*ڥ~{Ǚ"%namʘpd"rmַZa;3@}<:ҡ} f],d(rcAMkk_ #GVGb_J>M\}2r8ټPLoMC=<4(9Z\WD#~wA'&]1d٠d1Js&ƖZp|TN$od"޽z2KMМͫ1aօv'3{;ҵDyv5K PO; ̈52PQp<w&{Oz"1QƝc8e@>fj(cB38˾zY-n"h`Z:0W-H]ύd&OUd7E\Z1?BӟέG(,#" E*"7|bQg6{T^Ș*SrJԶ܏ g !>:Jv[lOXXt,ߧ;RP|Vi;`CܝT=xG"P.)o 9)6ۥfRFlsyv ,ecODb ňNIzɖ 2aQ ;`Oul}eAjffY2b c7}_. 1hL/Ebg{sO8b3-Sb ,@7vxVI׳ͻnJg|PO^~2!SHn@G q˥&VUwi B?taagSBC,0QWH\xMd9+ĪZđ&ut(s*xS-)j2zYiP ه׏~qx[v!i0}" +[D]Y7?j'`PNAbFFV*A9v6W˯b]'Qi" .>39&CLzLo)(gܷ?bp}N;S[|L$Zh-E?ؘ#l uBkhΈ!}o B7tŇ'D 4gbɐ~p|:11>:AmJ{&΀ΐE^HjVĆ;6>oufdW,sZ{w1{CX!\JhVӈG!8Fy#f :sW8=yyhx칗Zks=B\Ό2gp~,W־4 2q,2]e|}k_sb 2}$ˍb#tl U$*wwrCC ~$waIgOS4 o`ʁ6,t2)Ӫ[ @h/8*-UuӃT> 5Y}X&VF4wu<'E0?｣jw|d!s1+e sQX:v،'M 4׫I(bl]RxxavQ|^/Sd[Xy,S$3fH-W.%WdIk7jiৎqLiΌe!BюJBU儉.;)z4 ̕ů?WtZwK:sy-',ey Amg>/9(.k*LO;\<|wAYomgג9xS( d²|ZqC/Ew+ٯf,Զ ELkhٱ7v_bb ;cBhw3 ]2$5-΀8ㄉmGs[ז;cq9ｈya -_]G;V2àͭ/cSmkX٣&A"'b| SJ3n(bKD9OwN+V-;2P|Bә UK(H_MVB:NZsݔa^,Q/{=C# Q,ĜIo Vw LmeDغ%\Tۄ4 K)J7V5T2B'96stZIsZyOr2LkcS. %v@\Uq[_QT:Z>\mh_ RO(+aAWN[ Ub(ѭ)"2[H8y9pFGk'w묃SlSd6HrvEl*`ju0^"2)/C? 8ܾ<Ă{ݽ*})$;:GdW[\gdn5bbauilbF8h|}h.kf*PW-Y:?ZNP@IZąUBYR:!E[ZƬoXPJrfXÜwIu,0=JDsqg5epjVF{M[#ٍaK,JᗊYh,Sx\"yeMFz5"N{A$a{Z헧mjN3Rj#=a OE,i>FӶ}amkAa)p~1[Rg0j&&sx4]aO}hoL9EN֙ 6a-̴왋0裬R=y |;\WɶSE^( !x f[VA)1eՏ{Sa5?ZS(&|WkP:2&Dm0LZVO 05⢢/]'Z9KBdtZլ; 8'W]1ߩRyD;Ƥ2׃yOS&6qy0y3?Nkkn9&'\u"kp|iݷ+hJ1mE1u/iy .ЮzȡagWeՐy9C̑.S|c`1E[ TVRaM;<|(LGuZ\p_.nVfyHib+8c4^[hjw0Y8wORkcޮT4ku㒑4ee H23[x$ﴑ[=w^e8\ݞ fCqsXXniElR<>]h?DN6g L@{t92G5u d-MGګX)CgT Ī:Q*UNtevg0.L]礝ۼ!}a珣zH??o`m9? KSXß}yـlQt| #8z\❓MiE~k-YBh[n2l23Wkq<]UySޝ0}~Զo0M?ݾ7I9<a) $d–klvLxA3.v/K0?!eD?21233201031ѳ//֡QӂZewfTGo B3N'i%|ukMsgWֹtyK'?8|uJ>v8U_fB!ͲYPqw/sMܬm4\V㌸/1Un\;mDZZ2SY=΋m&M'w/Zt-*_^ Y/^XX_,HT%j@Rq:J2r|7iGXi*u#R45c Si٥GiX}rq'm/cTj#hw&3=T~|n4 Uj~9qNKHk5q]ƙKAIuIikO]u ]<59]BkŠA$ƉW sNV7$ H2鹮kƏ3[mmt+=WM?jsiӞpH@$`}\O?e뷖/Ƭ&mL"1 3oz3URmTWFsh 4Ge< ooeѸ@#4t$:GaD;=>տ?EiuI-?LϘP<&.TWܴXljݝnIf:RϨЮ]q~g)=콓H^Y]lnTC6JXO8eco4\PrNR۠;oegt ƺ 'dSOS}q:rd,a3wgUOؤ>T5nתv.K{zh>%o Gн nPwx!!c wO*P^߆ B_P1B81"?vv8a"]l.AApkKo\i[rslʻi㣊`ۙ ۻr^Xqpکɻ3$RK+M{Z9<9hܙǀ E+m~Y3zx\{.`>me}*i 6O|#xΔ°4YXR$mx!AP^9x> JJ[B]Y;e>F=xFS&zjDl{ATFz:krn"bCf\-XB/V̳Lgf(;tq)R42,pC85Ml >܅";T>Ltx~[uwXuO/iMH1t!48 qt ñ!~x x?k>hp!GXOg~%@(= =^oYJ0P;(2\Gۤӫb aMCblYp_%_SlcXsk0>;H  $c|&l!IdTǷAyf=< Es駻]I>Zv3 —-wd'm(B_ғ6'}Y85S=%1 $|xBSk6M<գQ#o F*?UA7&e',}]z?͢ƇIr^_e(I>P&ڤ—?.I/X" ʵCH2zMvYo%/8onJG~9 9ϵ憛'w_a$3fi6 _܁6ټV.@]h̠_;N}6^ʕvǚJb Cd]ݰPQɘ8Bac7kXg͡ 'ܒWwmhTBcw \r WE&dm+ 5#(>g`<Lɗ;P IX& ?/˯5`5.62Gf8̈QF\N4a.V t]CP.7Zk5ݷ+΋! 1]5x:i|{ڒ5ljes27v3Є]1itJ `O/~c_Ը8<(}"mN rӈ`\X2.7jQ9tλ["QuOŽ͓` ᾎyg PۺBPC`~17 ]@v5:t׷@;}hG5O.%g2"4"c3sWUl w?e1귦[ݮ3/F~}T~/Pq/4?Tdd*sxN "s4𫟕'S$}y$s_~Eo*9˔}e߼̢=ԣYZw6Gd9.W/AbیqH}~U%"*O~zO%@G1l "pk=}q.b4%y) )-#pfޅL%?iKnK<|0rewS-H§tp@Fڤ‚ȝ]KK V?|hV,}rd}OGG^\%UdV*g+.c1Mg폺?!f?~;vt*eBsBQC sލ#kJ#L6?` (H_}o۴rM}S{`ku8.w*=~ߛ|aano^_'3joTa}I7`W~ف<Hib0rRL]`Hz_#x_CuQ4NABGpK,g̸3{fxCk7J j Zs!U n*?Okj?8t2)7ެڻ9%vsX>'L0O)E!e8Ic {vi%H3W챒I]99\m×9p$Ն~bJmw7l]3#ݨg=&_K~t՚G(9OeZs6D} ;fE.sAw'')⽩!YؑI0;7-| 0K|ѫp;Ͻ.SDû{u}RpuPuÝVGҜ8"NݑV:'/G)2}B u$[v)}&8 K_K8f5KJ>[X:ugCA&r=MT|6Hu bU=0M-Cc+C؂C!Hr28Wo~ď![i̻.(0Hf[ D6" s6yQP(YObRA?krZ5JG%u]ΧFB퍪w9zUA. $ ÊBDQ^_KAIjG8Rwd.2Fi\ TvK@s*`;ƄkqItpõTEGc'T9b VwE^4[ ?Kfa =8PVce]RNP϶~Czh%5p,4ZoLa\9|է^w͔vlc[,13:]X,EN$1HIxvܮ'n/*IsU,x "l;ghsK^#A/'SovsxYxm"|q:䎎Km#0Tz*ݑkv1A.ĒX3B;4Ҍ%Vז|$4U5~ v u e]Sy4 Y .́ެR(E)z;+v6J_m=YNu8Ko<_)_2ާ?Sh41ؿB!8ϱϻ9KϮMyqp;'ٝ{JJY=N6jZ :t!!Y_3hK.~2/E2PY(WcJ3 +l2>%9( Wj`.ja:)O/mnVOҾZf"hG\ܛf}Y0IFuk ;iȒΙ`0[&L8Jh+rI_xpSÔo눓 o=jMglx*rv\r29H$/uYJK=WJG`(a&YCn\]#7xb^Ybn%4dKL aѶ, .C/e6Rm8SkC}TuL8/ \%7 'd4Й cEwmJa&}[[j{\DMĊ _vO 7OEӿ1Y}1Μtu%GcVqjlH7XQ*4B󩫇t> Ev]fwʣ>_)j]M4# #ۙO<ƧO܏t&$Fⴣ:֞04 ?K[ǣT(TG0zXI/<%dY X>{~ ݑsK4b@~Rr \;lKQnn8a!醔E`#>T бU TP8zibo ニQ>"h=*sOERے|GU8tf^v٠O8rFFrG}1B FWfN3Fu%{8y,7lKk}%]nHH̸u$;{HKF. u40^%XxzJ>:KqPMZ5togf;lтܐUoGu=H~'/L鶓ݫ|b`?%#p*)0 iIF+ݤрل7 WC 0\S)qD_o@ǎ֤hv*g؍/uBZq o15)*Ά&@a}OrkGJ1k86t y[7Yi>vpp!Y6o#iG. K CJ|syOj݅w\&ɉ&w`d @;tʈ݂úHl!\H(㴤WZ`TE {Rp*+0 &F<.HnW={KN{DF9Lgxhߦ}T$vR^ f"ŜsDvi\>3EUx@0706 at@Sb90 dOdwSK ] L~iy$B,}C”c3ldziJB_,ji֊O+~[? iU1NXǞAC8MI FH\y:F76hd.c}y ?tSʯn:0^{࿭} \45ng(Tԯ;*6"Q^2`ic[(O&ޯ)xAӭ*rmPt&e~?9φ;&:HsBh^QGT2_X&Ԧ2uR[ZX" H/3b2N>~>f]L zEFҮ%1%b$?|{!Xj5n3~ ԵK8k*%zŢYwmTDm ?^&D_H=/eU`Q.׀L'b;a~'jg=&}*$,a_݅n9HQ;Mnf}\şFj11,$7'Qh%Fڦ w?e@;WB--G[jYarDn,>ewvÛQba\g+]'dJ6fx|}86Sȭ#IɎ0#wG+}l&:{# ۯN[|=;,0@]X[OŜ֔Ϋ6?-TJ`hg̓fƊ|@}ID[G yp}&Q*opbCE^Ò0ɣKmXWc}-jݕFSxzB;;iX#^=Aw FDfG }Rgj=BH}N>:q@ĠXTQ^0,PB"D]%pӓ?d8"j 5EʰX?uUA?WT> 4OCn,Tn4*5F7X+*GHkΣƬ½&ia>PVrmCE&k)lw6o'n1l^+/1B &uAyVU B -i JD}%L\r]. .C_E}!'lVTd"q-Fprzu0YovAmk\__kJkpxQ2fx9+fXwLsv TQ\7_i;Lֶu-QaS3|p0r_# PʟV$r\;pR`g5*}wA!o4T tt2%L-0G}_MܖAQQ(!+}ˋp4tT;[F_g:" 0 H)W [QTz ?F[| 13 0 .?!TcmyghاhCkeexd0dő(VYg@yr- 5+{-WA]0qJ򭸇ʟi\|@VLZ]>PEf[Z̍K.O3:\HiF9}jGA_n_@~q^|9]" )pa>?8BxniVi CB}'JA}p//VJ-“oACydhD+ITZKuP=Qߦ_=or=Frw^T@YLmPqe -:{VrJie9Q'A_ ~}-AP ̇]Aic(=GӠ"?\r_%+fu.@Kz"}BDp;?5BY0~F5yc~w`1~ZڸnK/ y`rlq9Ucy=WO6d^ $`{ #}.tbo.]w/PJK+{\C{,ѨTk8CRI [ i`{iѹ=Ԁh3)_4&A`~^^97+o-ȣq厁7{]3!|pW?d!裣ϴ:.FKKXA֤"Xk^5 ƅZ\\uQ*PۈUr[ڨXyn.E%C`:֫yc[ N]Y!@/z7% Sc@W5VNO玻L* n5\ б=CHFfb)9!UN..29b f[E9x\GyS뼶ڄ W׈yXW . aNwhX?BޚOMoe'΢c[jRpSw?m)҂P ChJhjw?oPCC)'=q9Vݡ/LE"ey6ԗ%Y5q lYY!kH!*UxNLDNGv%zFCQHܶnn%ۚR9f@'NdW؍lH)ߒ12h)0t)Ё5¹8Md@GϾ^"ދu(5q_}{Lk|2ؠp4B|ڹ#bN<(R93 7b9e%NI#+2RI#8I1EP ;yFۼ3l*_)aqz~ ﵇g4_Io͇@p;P+J0E?Ye/KsJd&|Xo %KZOF64֚O"̕'DVJD0x^j?^!#k%9^ƯDE3΄]CPM@fh"6&~%*"(M&(8YṲZg? 砿/&R<DI . OU ?dk ,g`jd4l֤<`2c~0AypjX*Ȏ7Ps}L[Dfq~ӫtZPEt\FZlƾPuyN^*tX.%?k=ԏ8#d$ˌ? BYbTmsi@0̀taAP9Ŷ-_ECQ|2Ii]Fowdc:j3}YYDoo^ &:Or1Ҡ:'!GS ̀Eoy vC9I?U.l!ıeg%>\CvRWWHhUQQ$}9UObE֑l:r WPO>?ho6s'!w$<@8~GsREW}g}(Bri,/_=eLR}']7/.l|V?c7oŜœvl/{bll4(vv O 'jmbޟƲ~gHf픍)'bY@7p=Liqk L~0sG^ħ:G)X,|.QD8;(5ȸ8+n84@%}Fӝ 4 ƽ,*$`l^ʡ/>%\3:"ғVW+O"'ǩd+ʖ>->F=J`8lsdBtk.Ox'loFjբyw e [88\3~{u%= ;W#މIo73H]Au",*z,3(M,K<& bkFjTbpǍj@Ruv{QZr6XID{>bz}s*`5 HG@A1]R_ّczU?b\ᜲE`he ػ%h4/_K|ɤBFWyK;izDm,Jئc>6́M+F1  &%3 a!zQG&2i)cn]mT"0\UԢ:͋*6hh[OIŅGftuu^x}U kiՀU~4$aYuս5u! s}Ȇ{g{mkNo&SfkFc3Ki3ߨ8&w;,: uiK,"aڬ5!Rqy[Dϣ@ srE¼+o츕])*ڟFLW{!Zܰh(n C;2.~9w!ӬonwC]?{JRQ/[>dQ:,ժcxFk}HRT.OUM#.,`=J˨pTa_JLGOfMj75X+ymv.n`ݘ̈́8b)K=İ-! 88; 1"pJcf tej6S< du }:dpd[Bֱ~9<# 1WZi4 8ˋx-2yZ|ÐqLLN\^9) í" RdkūRP%KұÙ})Jr5 ?=ˣhGVgz_]#;-DLùd ΗȪŲ\x댱N6(lBq+mא#P00;5o.0-H#nhYϗR>1e&RZ<&`wHksvk%h&اt6hufDO.ۺ,"kGty/m,iZԅ Bϸ #;fky*+͵?19;>` dwOS% S*K2OVlfLC @OF= \Q MXCo 8;a][ ʋpK-3.a* \ ?%@e,=\#v լ{W `aȄGNSkD~ :m|  ?ᠻ”UO$ﳬ+<^.ۿpY)*(Vc'Sk`ޯҴ?]oMHnSRn*2gwT.VyKKjP1l&sCEKk<Kbq*8UkE_?K럍`P:BT[:"es:r93L`_9>mb OlԱbWQ5yK&4Sl2F|3ñ#'`^QDY [Q}_83S߽~Cksź3n`7",M g!Mտ>Vi*lS(`4G%Lw3V .evξCdu6kݑIFs})CۉeB w*6AGy݅es Xm R}xBAq/l[Tw)ex47pH6gu(Ysn1 @ŵoyL tN/,y tIPUؿx{dkG+Y{;RJtRɢ)KPN#M_mf~F1<&~k"kWQwIS1G4NJ'#M.YdS’*nbmv?Ӓ(3t}۟K?Z Akr0P!뭨iG= fiO枕`0|Ƒ{qOJF"B6Y~eғ<ó ;Zqlmĭ?x0QYkf_ۚk.Gg"vMZ:D04>!d{gr]S~%o?VGy4=xV˿'Gꟙ2{-f~2%;EȘj_k@%]tӦz-m̨EK6c~6f6mk P`Hi@t61Ški*_f]HM}|ɽgu.wx|&W)9=߀lX~{a?D JؠM.5PDg%}.G/̖(ī4D/sm" WjV %5Ӳ+(: {= Spo*$;+ɵbK7qpEQUcY?@!@m,MY¹t/)䃉|vPae>Q6SA!:TvBk+.U4[%tvv 5dAx[užqX9Qב8R}xrjV X* y/|%hQ/DI5gYVL(~qrbƎ1J.])zszMSbQdYiQnjEIoǩ]b @>;?ph>08F^2 V<-W Wr齦ih 92+L&+{RKOk 5H$}vnh`yɅK$:si]_7v o``YU0d``|ag5TG%2uDYNRU 千Z+oO{7׹G!ot{{%xLo޵T%Vu&?MN^6a[,?)rRm4܎lHitmEE؈!LJeŖ--J!%7{Qy}3<􎑵vQV֗㛠(QC-d ?Iud@( *m(e滮r xHrhf%T|JfO8ݼO~SQz{*hY_Fz[?Ԫ+.:q lJ 2ZKv[G- 4ݧKKOe=~E*biXzfiki .>'Arj kܽ FSSjȅqcssS*o& hLs0-ܟ-'aizDFڟRYy7|I~<=7\ GtȐWZ~42p(;>W=e5R0#zySb[QG1 pEEf.p/B@V#QZvdN{{@.gV6H7M2Pn;5:H.1 Ob Ja0Al3wVio3I+UX<[sp] zJ2V,u] sr8Ndk{ΐz}^PM\i=8[ʍHi1MFPyD)Q2,&a$9-3N# pW-ޜ447 # ثxMA^z|y|.aCo/h{̃`gY[^?Fe^$>`w' {k [Q{*րxەxBdT<l^ R:TJ8o4j $vsiNij~^& "cV0JO=;لdki5g  ef#nt+A[-D"ȴmd {4됚v`n/| %n&ñѡIwJO I I]xRUCt:K;Wd%}w&ɼ@{x3:>T} %zЈfQ_`պdVaS餂ޖ%է v!%iޫ,ftÄ鳫J+x>(sk^.9VPZq8)L5 /ٹ\v[^RU^#7* jXHމXбk(z[Xkƃ9#qG]_)>OtO۳h/嬥ys8' 1tbu^BW9jbT)ʜ?O-"_0aVXa {*T#/Tow)0քO`賷_xVgfWj-12XQ|En\_&ywhp0RUB4&Ul|ޣYDZbU;|`@mԫRӫm8f,GoA}RѹQE%.[AVcKB`*R߁'.y]łYڃ:{j-!(12ѽOph'orV3a8uL4]RXh;1=B"mP 6 oB&hr0p0X_Lf9nQ'owCϵ6=N 5p}'ޓpbV>V56sBe䳦Q@`l8ά|R D oɤOBbb3`C+0O1&@8{4m */żĴPK L󧰂F/,?4 *(c yM7;!}W˪@SԗWZ#~yb颚$%zR՘ NsYs9h^1/p 8<Yn"ܞ~i 31V# U򞃊ziVaAuWUwqޏ̨1%~QT*f w61,66߀"/ ʄ况 Jk։Y} W< 1q+ FW.H|{Pi}2{6D' 2_2,|%eہrr_mý]3%{mB],JF[cb@6(n<C*v}HPڋ;&%68V$ |8e{\^ĸ+pT"ʟ8̗QG5Q>{牶[C+I=r! F6X7ѵQm9 : Nrb: OcSRusRo&t.1 iX`SOm_Ͱz@E;iW4g29P.Xun[BojcC֠>x"K3L wn]ޖz&ܙ C]t^l.@ͷRs3)6a:\!//QR& e /j(pܚISwTvh$vϗԌF%eK%Tkk:eG' I:fC΃bP2(-ɐn>O# Dx-7IQ:/R-XBaWyI4'`9tnK[6sfn:m ߂eUn-W6Nʴ2[@gIG:c'ʽ<J"u3qQ RY{Y6<8Eij/gC_`#Qw-E;,5Aԏal !Gy2xRŞjng_9a `eAqF3A3ݟME>u e$D!qB bo'Y}T=5h=qS7%^cǁn}Lf|ڼߜWh^ D"+1_B% 5$ɩ}n>.l:NnY,u&pwbaXfqd7P>'>bf/t~O%WH,o%0?K1Qbf ogB_h/h/h/h/h/h/h/h/h/h/h/h/h/h/h/h/h/h/h/h/h/9no;h(D鯨 :SWh Y1R銦7ٸyw?4 xPb~/fG7+ޒ.0mͤ܍D`Ná|۷-cI0c_Fd %BvIe5di k!Ku,C!ngߝ\9yqyB&(%JUձI&2?=X-s)ŋ x3(ݲa~^6haJ(h}7a92>]I.ܪ)3HW]WFB|H^&1#g#LR GVB&M0vfq܌Eb HMv@QՏm7EvSHZLu!2=^6e毂uTMh +2N7j_ ,ӹgFX[<TՌSɺg0MVOdSkb%vҏ4R7-=.̏b~ٯGqMX0Q7u$dљFjZ p,AHp3] XA[xn~ΫB&WLM&a:%1.4~/d&4HT ۼmJM:Q3H 1|w!hW#Pf|"Y z{m[t5fgh /%q2XK)bDebQ[}";iK\"G?v+I+:ky{oh{Ӽ->-mLok+]~/1ȏ\~-'3!0NFnҏD,e7`j6H`\32 V6f ^hȇ58tW/\b{7ɹkzNb;922:Kmn r(3L$= fmm?,wt̶v $4w뙹>GXO#]itʙEsh {ǞY:70|[/K^2{n!aH0Du,L$\#ԕ[Y:y7@&bWAQ.U# %A 3~7 k0գ}Q{S',==LSI1LѢ/gx\Ӵl$Ժ`H*ײGIrߔebŷ["2'(R0釞 z].ZoSJKp72zA4dbK}3ҩ`UbᶿK[;E˼{QheE KKE}[3]MEH{lI*>qcF±?oGdhڜlaLc=۳oy/U^#wxDHaѸ/%Tg,x6ʳֱBBz] s8_H&|Qg}N [ٙ1${hY\oW( ncAӧmJb%]mU2(L3wZa-ߞXQ~ډy^o6y ap -RƾO/֙\_ f>&*f_zJ91.VoB:iAcƞHn{w>3Z0#ez"sv7ǯ z&km*:udSW0t泩Ųdq,OdH$z>&%vcMgkVvK]X Pt/*:N@OJ~n޽v余fAGQQv1!#%(*r@i:I. ^n|C7zr{G%К3xEr7LI'`~ܳ$Eolr>@*SL8QixB#āwN1v޳dP& XX@9N`g0\5É@X#+vTj%%Q,Iesw5,"w+n땵Vq‘yurfMRW\ӕ=4}H3[hv jjfM_>}w,1GSd~ xqK]g~vOI$$(*aiKc$rKo⢑~ӌ6-MZpx^$#/b9NCot37=B&>f(lЩ6ڈ*m-J=(eW 뗘Xx-E䋯M27tbc29,)|O-4rUWxMd, %;sc=fr|}0̥x||2ݠdHsëNYh_UUw-EUvE& )%x1eyX x-kN,;}fN6t߲χ)S30 , o9gRU-\4*!U(`Yhw8d*7;C3Bfɲ E#n-G/ ~,R2,=r-),8 J2f6D?,wN0S krr@d+?$-l7W=?lC`Bc1!QR/N(o >ME${Y,w_l,ټ9_Fpɰ 8\iCS֘=lqY"Dǩ"M;,MCg,zk`7wNL}}+~`Eh%nV8O Q^s^3kHz"E(eMy;9+C~Ov;X//Lmr[~ÐfghKxKޡ cgG<7=MeqvM+jBAu=kz2ZT-tĶ G\Y+PPn-pҧar2Qjտڲ SZ%jx ̓nY^ cZTSu}raZǙhFrJQ/p Ś404sEޘ+B%6%v'< !ס4g-#Tz9e9_@qvxalr+=jb nv} ͥ+JG-u|z؝˦[o,"1ι!FGavZlUsS׻S #Y-ܴ@4n᧩]\2w՘'Ҵ_C$GѷENL+BOx8fU'ps)j *d2Z 4 gx'dH~-iAzN,7tH=M1!ٿK:6AhRR‹|ZEWP^\Rײ?ّe^K3\ L\ : >/f|5"eI~Y U,SxIFsF5~3"߁^"f->{bx֒.pjO;K/zw-5nŧY9@``DdrUFR_2LGOt3co4Kë"dѝَa a ? Wa~$:W8tU-Tb^B`Oıgp[~XUij;5B_*wzFI6W|6-qO^ܸ4#Ne<)cz a2Ɔ͒䚼4 Dy'6܅/<8풹#`u]0*i0(\/>n$9li-񐵸ϴxBRrY6A']cBV [@sN𤫚ۮ~'kr=n.>.K`Ś-x/Qt-{ZK)Wgz$? ^AMגb౔i|I/y$^1x)OIO륃mMl41˦n>r -nj"VtٺI(Rz_m~8B2|']A@9jar\7nӡD0Uf6%(cT)榖q]M ž畦M4:^lrnN#cĚ_Dwƥ;OZF ڀo}\M4p<~pdSTt.sNbKPzf|PlvତV&l  ̧>xǔG܇ 7?ALnmg,-SFS~-8q1w;1_@`XX k8%T/S[낔Oe3h߼ ɄaNm"L|\ICrcN||ǣ#qzM~/4n^R#!Elnf|}?5~(3V5J9pC(mRfCJH.A O(+l}}El$p4X#*7oUAE٣pR@%Ri0\ϡ󪞬R#Z|r"c|)2XS R-:G_SY4}JglJY rX1qCO@c(Q12{t.@e1ca߷55 9M"38m0-t:^--+X?z̼#S-qt0go')=(츜58m7p1Jcޕܛy[s0hU״Sc=< ]*L>3tr"riVc+&$1L3JcBz pZJc7P+j^ V1TU8|\:\.~ wxR2z5o^(-ddd8əGw ]Z{lj 1=HVl5P:b!r@!t[,&>3oZpi:m#1牡T$.֮3It0[HE{âf#w"|x{J3`ǻe^=wJfy7qDwXie@)s;?TXP8#d,E2)Ý#Wg쏅1jWݝlA_ojYSGס5(KRlP F_bSfR0|N!p]}<-RIxLb_"I-M2%f Z3Lb$?th7paLycEY-528%c ;ZKOZ߽Jd6O~(V 4"U|j3cl6N5{0wNtnL<&"gp'_RS[܂l|"R{XK7}A)I_+~Ԇ.&C=)?gT6~ !4նb\w#B"u!j*vp'zNӿPX2!P|zێpܚ?ꟓ>Qc7g/:ZU/K;hնP*= کap۾0m > 0sd)/C45dT.DNxWEb;g-Glok0\nJIqwˑO(woNrM/ESuT97;| Fr }i\׫aPhCEZz̓zS,)=ճ'kKMӠg1z%\R)[޾iGJ:͇zG7{Up@Gӹ  yP辑$GtU7 $JuN#NQSaͅ8 ٧ `7% eՖ!+*8)ᦴ+ťC-K4t"nrS v|~N,&V=?/W=)A‹#VwR߆14xĔl9UmnJn8n1 ]~̽h+2"po'BRp jҝ 1J қ_S: 1H.1 MPeJTE9ʫn||nAP-5~=ٚE2ۗ2yr?'D.r<|#.&yU0K&UEX1 ?$yA Ć˚"7;fq\imz' a9i҃D5B*'ZEp,s ߞ Y h|dXKEL蔭yAYVE&By.kPm\7(MC2h 8ty(O灇yz9M[A/JG-xyg0`9N*#k`Q 4}kar 4wmrȪkVG3qbrX; Fl"e`}Rpnj|fnr-q\ОSETĎy8Ds~v]?)W-NJgC3t.n)Vۥ(Z1s4!kP\[=K #,z)mb-aa,l$7 VV-@2VZ8,Ơ]vlkiƇ@ሹ񭾲.Tx۟Sg4e?KA/ŧ8iIٸJUMAi,F+fYcб۲̍ЈCmY%{7^3O>f,vzTGAMiBQU13Cz^C}y\T"Gq8G!LBV39м W˝AS?fÎS""U64 0SdYF}sm~) 58#;tK$no㔰l6r,ҭ(;꽢8R4 X,2'ɤ]^2c3Ѳ?)ʢyi2㨺Ri̹_#; u?Y&~'|c9F`&ǩ,ٖ%UHTW߭A=Ygrٌ:^ƭS t.KJk'@q Vx%GЋҼ}j2^< ~~}qޘ. Z@* ٱ.T}5}i 6սѱVnxa5JK+(#օ2 ;0t`w)>bzg*K6mؔجSIU{9 5R2yn)]0Xn_MZeO.aPF!8U g|oG"KӴ& `|@@m_L!/#ܿY@8pu|.Uz?ҩ՝3Egыzv%yt Z^ u/WX>wˏmcF0'SueDrX4B F|AI$Ey_CC]>K,ŇziLyqϾ}ȿy1_7%+K +'?v1n ^TZ=gg~Ğxƒf]7ƑOl! q#qiU=;n%djȕE0;(VHmJIg"7SK np~7C ժj58˽.W WK*N)ɑAD*GL,jw=Pn<| R 5~CJ"38cL ͻ᱑ac<&M hZ!niꈯ/3 \T9sf4_˧T Dx)l̠Bre#i8hrQЇxGt@6"vmNRNHúCN)on/)`J/i} [܋~>v woH*S?6A\28 ߋ2wfꞭ l$FeQ2 /^"*y]JEC YrT9"XJ>zs,x); J$=N)t;>'DF_=̮"M9eo<_髂@Q%QRg$;xa8봫~vEa9Jܚ]x"M'1, K 95O oH}#^zDY,,H{_R77']ߡfyN*_lc[Yw Ĺ @]Rg`.쇻RJפ zy`'͟Z}-Spٜ8l WzRޝtN` 9zdNRn d,!L?353sGTb njsj<zf?j8yAAj&mjBHb|#LCcQ90tWUl=Ͼg7QY3k̟{uZyDBHm#4e6U6m#s v DsO!JRk:Ҵ #g~4Yjh.+LJVt&i/dE 'V,WR&TG r](V0Ob9Y2z7Di3 ׽ӭO}R$bmXhqMȩn =fxnhmE. %Y*|ھx)t$ܔfm7*`t;.ӻ)0o97'-E^8&r y6Emi5lNVi/ʼXhk,@~]^T岁Ȱ3Vx_Ϫ3"~,GVc\l^a) pa$t',J/{WN[M+mI}c霾^1,ЭH?DIPhM`˟^vt!1,`A5JdԱ7T!gb٣OJ-KЌy9ճl ыWNvNe =*Za=t(|ǽ*c13s CǗ8!?J׋gC~aAܒçu՝#OҹSn"lQ&_&W2nV;?jPA^]|1VjGh5B<#c됖t[ L}%ԭ帱kI<n] Njq1>9)w;1BO4C"E?qKkq|寭Mʞ/oΨҤyn=(s![<<8}Y< +@&sTNA<^*jUࣔĮ|@)a6 -qdq] EǏKXR 4 US\Z4 M>4uRů J4 'Fꈁ %J)MjScߘ]XWJ(,(v״+,u$Ʌ3+EEyT74ksDɧ$ s!Lk͎  n"AbǴH|g}㻩G@TM2s%l-:O8Sr J_Hw)j ׿LE[*Fٲa.%b&|UdzwM' w4O4vU#\s`D^:.?&x+YJW;O֐~ͦk悝Ql9)P\=o^n}3mas.~2߽Z"VG<4qY7kx.\yꁝT5ikMB@ٮWI7"q[XBߧ XX t 0@S|bG;,LIYdsoöCSM/yS d:Ĝ$Էןy-c )t ̺ө?MY{̈́?c[E=) czuPXؘ"L ?JS ˶Go;fyDa)`3>0>K6Gn#)X'l8R(K%]RfWW m#] '51ӭC[fpb^]. K`Rk(3E6z(s[HH_9BJG[k96dG9_g201$ LZ;k%n΢#W\/̄4R% Cw^x+vD2OB+0zvfI@weGYHKYRILQr}o7CD-ʯ醱i IL:RvhGd| sDzolFeYJ2Y=|n2\Y5:=܇ Trv_G~ÎHwx=aHŊqiJ.`uʋ#W]`jOe?_Qڹ/ \#L:P,3˿װW%כǒԽHCyXQ$D?R&v-'V"ٸ8!"D#|W׬ T<TPViM.Ov71Iі1wewNP9@@a"˿z;d\A[v7:q{kkX],y,p@1=Ls|&[HPzi4L+6* Q;rsgť-vϊ#ݠ·wQOGwG ;25~+bi4 t/I]7fԏwMm[Ow`Ŏ=`fK%k3WkiQ|E'ף0q]VʣPY~SV<7]𺼈lߞ 7B# Baww@K[6xZ,M9wZ蚱(ַwrq1i}-J=@B|%=c>(>3\&k[Ugݒa6兛O⢽#l!fO IVԶ;<0|7>2 /sVy!F$PGS]ZJ}h]"?*35xVcdT/t"0D u_E gtGy`{|y`om ¨襁t|ic(K2 Gb- pYKϕ_wpP#LV(S*rt7 K>,.vB'Aug)'1Y+0Ad j+)w0It4CQ +>=7yFkLpnfL칊*kZ0~Q8S، 4 dR90Lȹ<9*r$jI{9c ܵ~uzٖL{6|p$8@2rmhM\FiK@d`KW8KגjofǓQL+h5e./뵣7؇{J8uwq?C_B@gMTDzI?<ԗZ)0jA*'mBVևd$kDi*4{HI? 7dH.v@H/$`ڿ..XrW}ҷ[]C{mӤ@P(Tt)/;4E+͟IQZPfƑ (}ftN"2vڐ!8;_doeډ_K~a6l@y,Q ?le *o*ֻ_&B|ZcnWkUtMr :үHї9w'h[[Okg)122pq)?G#w;G#w;G#w;G#w;G#w;G#w;G#w;G#w;G#w;G#w;GsOKA xo0O.Ni6>EKxRvN% 5|?͋Y] Ec9?4 ֶ_ ig%,35.aᗋy֐TXh_]u>8=iWF#b{&%9m'MGO~9пܛ\Bқ"ұSOvrz/<^UŶݶ]bGJp;Ӱ8GT(пs^m3?Kfi5q 6ʼ;(ڻ ҬH-ʼfxP]?fjGbGrTh]x{<]%vR  oi=JxQi!%mcR3,1^𲍅>d!^OF.O(QwJE#,^b@yľ֙7Kfm6VNfЏ_gX (.߹[p6U((B? )&5xFU&4;kʸ$57jqWN msUzѯ{bq9^(?)PO@Ssh g&jJޒaT Jzv7RkߏY$T3>xC aPˊR7SQPJJƴ ¹ej}"4U^Ox}=&Ya(fΘ'>0Kg:/}ښ˅wu`Oou!Zj:C#K]A "zPNm7 nKX6Q%tAs/w<=ѐDw`D;?pæt hFF.5R0Jgt-]IIڣ}5_bZ 9FGf?Γ)0CIѨvxl|cۓCN'^*%xF_69z;8DF@4BJF|eW\՞3+_ؒy&+]7<߅Zmk<<؆sU_|a0Ye 2~ |Bk8~RqT1fΙ{`:2_rg8Fue ;{ƂWF#sO0OTP+*1|>im5֚'BϾ7t,4os}'z 'r|zrg)U\*Pn{^(uו+cO' y\lErN4~wr1q}?8lqYZ0ЭЭc>6KЧl%,\7b$PrlnAOA)ɰ󮍊2~FɗO[6(/';=Zt8J2+Ozs)nޅkdxPDgU)lHUb(ߏ'%ALOi bJ LkU)͹քӁń.Ks)lh)1ԁ|LDyc3,Y*ITtqx}AUF)/)-e3;cjm-VӉ EI~n2kߝO]n/D"X@cTA֪uFM\m_U異Qۃb[~bό,.I%Sn3C{ل_UZ 杒Hf<$7e>="7Kju`=8忰џ8JH.p@apƙ<=08 ];l|WZoZ/0S:}jsn޴9KOǞ&rMjgܻnD_y'b8w:)/>uN:әpα"oN~~^:f|o;vי|wв< iǯ{ϟ78 f`˧v%ֹ|׹cg^g 'ݤ| =5 ?>;/sԁiK^}Lj3 λTϪ{wkXf_Gmbu}_o;{^ᱏ7c'?aN_y #w?_k4^w6}&#O`n5*x/&nnv,/fx]xnqik`˧Nn.XgMw;v\y 3QOek~&Omjwjo<­v3'Z[^1޽5}3js6Q?0_+|w3<)vBnsy%XO/z|ŷ dK=߸9w z3ZG_UL'=Y?Xmǟ=S`ᬹWY~YN~jz0Orߎ[cG;^eᇾzkn+< _݆]屏rCW}o=m-'gqlym6)փizX)_;tm| 7c rM|.ug~/IgwYn/–+̵en8[o@-R-~6t\w董?K/ #^yd :rZs0v̤#z=fwj}TE.zO^;='|yjn~n߅?>+vϲ;u]/uw/v;z^W5aO贗aCCṭ)[a7G4g?lE^~\g}~;qM[\>;bk/U_}"`Kg8ٻX-*3,7}ӟ;#kW&kz^oYW矿ʼno$Wƽ9n;關wY=[yG _݃\YpiƤ_>ϱk;}`g-[w0jBǯQi+;yl#\{`nеߵ]y^ӆىcxk-;~oї.>ٿ:7S޷|>եrC658r}|^N7*G|~x&K9r`Y7f.'No}`[uٓr8N#$^=Կg ?ǂы-==Kl'M6:Gzq#v|lť^y;ǿqŹw;COa ;04`.p_U?xW^_}ޫׯ.3>?|)μ#ޓO~3Wvt6mΜdOhk_$g3v>4{f{l:|[5lqG^~kק\/x\j?Xª>tG=&|wq캗u/:GtۜVM56]ik?w{ᤥc_9O}g_{3>dcVW|?읯=:c7O=*f;8x'[/O= ĸ񚹮bx?}gb3?뉻Tsoxs3ݓlgcKO*{I'zmS׾ߛC9_{]qS.E{m?}:olc}3+p3㓫dt{3cUo|:wNsg{֟璻|x./ 3f nhOW^W.Pg'}Xb_| ^xa_O~y͘'-vU6ѧt3{_ÿ콑9ɿ>lj~Ѫ^[t/7޳OlqٰWt9_{Nu[rs><G_ˈ]y|'Yz`3~}G6v,3<#7,y$˗h<ls׋Tt喚3|z>>[[vnuf=^u)ƿ٭;ӯXw|[\InyO:wxry^w'O;Nytsk˃|u.}U7qoSO^h柮ٟt6ׯKw>'Tx7/ի+9v#Y?_c'xl;133{i O?-8ڤozlqs{no]}LpݶK\k^ÈI'o'eYnλǏözr֯3 _>|Xu?Q掩|Ҟ5~'Ym짟j˙jy3`c` N n_}n#ïCn?⪏>c9ҿ]kɰv8J88Ksn>ҙwV7>:O"ߞ2n_{ŘncI02?k$,̫[~Ϧ}yl1ϯun%>ۛӬ!?{=륋ўslyʳ#W^͘cZ㙋jcFSM7KwDz>~9n~ԫ;|;&̽Ĩ:_p/|\#XrN~t?sG.o]|'?=;?}{|vsOoFmGf|G}})mO]tk^Oތ/˙b?]s7|[k>O/G~2 K~ n0{-޷<Wov;׻6|L29w;Zu+cKϟr> 8~W`qȱ|a}i7U~cGv'z5}훓͋~2O~?p= Ɯs눝yo={~5S=Ns|;w~̣=#tf%-G_s9ifُj?goqk?˩X'8b=?sǍCkC^>v&{;Ľo'} 7XlGf\{6%n[f,1b~{ fZ)1[_r= /?7/xx 3:?۟[|Gl}[:Ȏ?ť'/xavÇ}Ʒ=eߎ_dV^gmQ۽}oΣM1&qofYs>>v^s۽]~p'i>i~ɽK>=>+nj}tMv<|MNt"w}Hbȃ&ۏʟxnzyo_|8+d)I;Ҩn1bًN=sդ+͜˳87;]M w(nwk3a7ܼ/L~~<|k==n>uwZkYޮ-7+w__])ovY7/y>ů|| w?m sw=5qivzw)qSvn}/~ kݾ\w]Ι!uqòqk~E?ön[tǎ>?pex #VÉGqhܰT#}훌{{lGN+>>e?{HY}g)/?c],2mcO7ا/k~ɨ?y{9쀇]Ͻbp_g_z'Ny=l-o.ޅ} >7juYmd]Wt;p9#>y7˼]…g[`~#Js#׾Y?a6yLw=~;ry^_]zz{ƞ.~hovtZh;Gt k~Mv p7kn;p&?&ono~م-2p-ͽO5'_^yt>y->.l{a;j5\bάFo/󨹗3}ŷ@̽gQ՞p_?oɎi{{b_l_y'9~_Sӳo|W^3V^aM^M9knfݏfpk.O^c|x{t6lg_iqiԛ/<{,ƒu*s/}cƍ}fN8c2ӳ}ěS;v3Ǯ~g%2Ӌ򘇞V>'>Cf ~ύg%z+Oq=58޹sWoXrˍ^eUa+ǽ3ꌃݟ]œgt`{ w/9K x0~IӼMeisk|YO<zW9ww?g3>FOaa{ec6v1nOxɦ~y_ͬ0昇|r]62{zpr=n{+9υ׿0]N6~kփmo?fOy_.eTK^K'|v,ڼ{,ٮOy?˒lz;f}WfX{g돻ݏ%܃aS-E2:_{ȳ'ly_^ÕVyWfifՆ+GG=e;u_1z,GNrk>}&Lw?:nՓwlaz3~ӵ/p3z3ί݊w2[/zBw_syh3Κ|e:3V^yvSVrF-yKƱ_m:g? vtٿ:ϼ+,;iMr.zw/eƵ/_w0դxrدg|B7n97};O 3\dZɫλ΋S_?1G}ֽ)v{r_Gswwl1k>'ϝ1~+.+w.yXё]=|;:q moi>q_>kΛg_q/~Z 37_s̞csM{yO}rNSみ\{͏e—qdkyլ+V뉟9 ;7穷?'oŞ?i_T/޹w|'=^^0g'/y/~; ӹO:0>XzCOG Wzofen,:Q5{/?o=L3>b ɝ^{_Y駧cɾWN/og9Oϵ57_v97G/1阏mN_yI;uGtkN駙Ʊoٳ3]^΋l?~=ӏw1է Wg?ҡ0Խ_7Ҷ_V'O{yW\q/ZjT.x,=Իw_찏xojvgw}fvXj߱s]+|MF.pONs{[yOxS?{w~Q3Wח:|7|sW6oWq_i^i8o+v+e_ /<`eWeE OX—gߺ9%WZ~S1ێz߯u䛧8myߋYq{1ݾ_ݾ߮oN?/Y{d:ԢuI]EWN?p{g39q5'>qMOu>%jq9O:k=c}_`vv%;} v}7}5ͳ.sonh܏/vc{ [nFE9s}YOn++wR}dA@\fW̼҅o&o O=o’O}Imw]3^xiO'?߸j.#j5[)G,Cy[hpӖhf/_߼ֺ.t Lv;>}6'J׌Z`u.݂;_oߴ{L3Y]:hIos~EWlyww?LU3Z }~˭S׮<}Yx9]/?x?zɍO s귋6a䚷Ưu.5|#ot7 :o9&n)/:ᛧuֿཀྵ'æxžg4*=`ZϿw[{eo?1*V]QjYyz_?ws*6tW5|w|')ONZ_?#{3:o?z޿feun?a-GkϿj]{elׯ|vZم^^7MZz;m?nx?eKOz/~npјy!ۿ_wzc.;pD'j ~3  [fwtiwXy=>m=n5IGK\wڍW7|[s/tߺ]c_}s9ެ&`_k~~s~Nzc"Mw)Zq]t.Wlyw:kNX`E=g3n}=qWl=~^;w33L[w{yKjmuwۨ5nԣo}8uqz +⊦ZѶv6>(qqwMBbU! 'ȻƩ߳m ֩Ԋ wOW*UMMJZŸ:4Cy!cеVu'T ٴ&ѫ>Њ^63d4ijbbXVgqto7!aVoY2,9dinSG[[ KL]H1ghɒ`I%>}]U{ƀߥ]hRSYӴ">`!Ժ[S-mlTVCˬ; *Y2P%1_gjD[;_aU@hlh Jփ% JյS RW5XSKCKKdkCIJ'ocC4qU%"e|{%@d/j/{ *q"pd=Xҋh51V48Ha,Yqr m3CloxCS5u!t@*NiB8e멇v]^4‘)c:tζRX;,[O=d=8}SeMuA+w=\SYOTp]6.EU""|Z@8dz!"Of0Ǯ=;״FlxKGCKV#·S wU3dz!a̮n(t BKmErqۛ\! c!$|GoM7dz!qx_ɝi{BkbԄY)[O=d=eښ_06zCMW`l=jz||48>#drnl=jztG?S'Zt yt".[8F9:m5,t8C(l=bISoîh=VWptJ@LU;MzԐAs;E.Gi}rTVނ`snp01dzDj8fQGEH'!еCHۉ-[4bg˅šteF|bJ52Ioyk#0rйteF"ul~ن쭪1N)bp+[H6&P10SA3־ }2ЁOy"Wl볯^4][_5s֮l=")*qm4eյ#8xR z`oB+[ 6&#}L#Àkzl="3Xsb7>d9Μhs+CKGdSk^ʪ.^.b%8A0 WZfqs꾋on>k&niʪRijx]: JoU S4$2094&V {#>( *ВE+WkEX)Jjҹ6"kS4^ӷ O{M ?7Ǧl={|zj ='NQv}U9_@GiNY>)CTSZmؔg็,ZO-x=-0@<Wt1TQxzjKXql\= zBn%wh=ȹ3÷Y㌁P%|Q׀I˲ȜB Q_:U}wx_bZx([ȹ[X֮ks?wou]eG +,[ȹ[61*Rw|>kBkH+0 t3P B9x+%53eCfw:ՃN)3{: ~C-lϺꝲ&ZCAR2o>{ݧ@ĻHA "wTnb?U+86\ (ս*;CS 6YlS0蛶}?w=P4zӱ{x\[lz&я5vTK^h@R[px>o%sAeث'Mn(z59;P8fYDnQNY:  .YRALS, Is(`pqN&lG" b, oCyhmbf0C90=錒 J$}Eo_؆kaMbc|~,WP"C,vz;^#?E(`E#Ł\N^e9jZWQױ !Ķq=@{T#jt@.ج ɵ^,(6J)<(p+Q:%|Y~$ 큿g'խ>a`Q bˢ%ɶUjxO Fg>t&myڲjA *ٛ6X-0'p8ܺĴeق95UOW=\*l]jkH|c`>nrSu6 8̥ J,te@$W^E[G#e*CLrmGbQ{َD>,'65a1d(1I_W.(O&NٲM[ | $"8lY nE͠dugk@g ${MJUKTV/(-xNGOaG0m`̗ J3I%x =j% uӑ3_/()f5 ٙ^ƅD tNxd(RYDrx'PgсcRexTV0(O6e жk=cs_@FY#On58e dJD)`^wtIí&E='bGkW9P6}iT8,-ԏrԾ,l}SEM<(ڶ2AI򣲌A5[<"| . dTCp ,s,e9^@ϺRIl4),ۑQGHj3I:Lwm*!AJ%ɮiYF[S ش;Yx`Էq5v$ugOD Pu i \2ƕ rMŻQ@o䐲*h TN`AuC :yCPUR"r@>VϲAuS :|{LVhG,ۑQ / QP. ¤`e=zٺFl;VT:;C|4$FUCϩz%rԚ"f` @戟ޛI!YUYϠDZJ?D,z[T9xMҪMXlGbM8xyYjAZp+.ep_:QY3(CLW44@Ej-,ۑQ.k"lё|(-QKaw؞ +S XlG"G=HXIVp5CIE%*䚎 m{rY߻ƇīwMAW )NHcp$O.Qß5%FYuyOـm7%ڍ߳g2G,V_޵GV}>gв@SoXBED o 'F@{T3hV,Έľ_ְ 3%N>DH-sin5!E > *~&(SǟZ`{Lc| ?.&QYϠE޻EaH`-u7sAvY#n=w5{g4|xPw@t' ZA*5 }OABZE=v$r|Nhj;_[@bAuXұjQ_T0G>gYϠE=NF,Mlẍ ߳gk*x)@<ؘ 6o`rBz-pvRzh6`=[sxbsdU3hlOEGh"k}p09^3Zbh ;la@5C լ{4;'! @p``: Y3h؇лp XlT#Nxfَ v4x; u5vR=;Z{A iU`MMM6XKi: t/RَD;.QJȄGjP${ҔHq@=[:A9<0gXj,ug" k3,tݶ*p6U7mdjTe=9jdR,vYϠE[S'rJ5঳5ֶqe=yo.: ju ui:z-8dpmݲAmKo p8 *UBY1@XlG"GX8@ { BZ#We=\pqA*e`*plO.+QgV =TGvDTrv$`oG&%zS΀"=ـIO.tQ9;%^Q`_7@-PTYϠe;uz9 C e)/Z歅,QT" w8;(eZNSzF併/լ[["kGhAY34"j &][,jrghdG]Gye=\yF lUնkyJ֮yop*vM-EUŴW*Tue=C#<}bg ,]R_T 1©Im6%ku !HK0<l+gYЈ7B]e aNEU0Y,mP M-b0uMR DHػ ʪlkP=hD6G+*/tghD;!㗬Үu==GlU",ۑlX!+gh_@zmE;]3hw`BJ9w5W eB鵕{T#lX;> Q3 ]34"x"б.>2 ޳jG Z?uY(٣nz+`C]w 3Ɔw/fMm7FJXv0rn5D%ghD a"tDJ9>Ͳ9jΡYc}A+ߖxbb9@>gَ/{󚼸Ňli 1.!hKb͉ؑŠx:}cglDwT=/Wؑ4{6Z?NJe;yx)4 cdO |hN2zYȼwbUv9m`k&pq`v`$N| dA c8u@)VS#,ۑQ(.,LluN۪,vK5q_#Y>8.7 N@ҲXlG2mW W\T4{/-cq3a%a]Hw̗ I.@_lQu~-ܧ쬼+e=C#ވX7[&ʲ ~#  fَD;UئB}C- >e=C#rUi GZ$Uli-OĎD} ɺ'M&콬ghdO6k6LQ| tp:UifCQzG=I4Noq4{xCY#ƹk9YP`o\ISAp/F @(xzFs7(V'WH@ >,V꣩Sdr$TBidO']35UM-]貞zF Н3$,( @+ę/26N0k ;[w_JID꺕glG"GMr$pwK)! ,!wͲAK:TVS~KزH2\p;ùJ.Fx[ c^Q /ʹxVkNĎ읭D+vj)+V)hmEF',ڑyuw;o0reXe -ŚE;2"c*Nk8}g'޺g02d"Ð4'!tI22.|x6mh<Wg;8LU35}H38bNՙCk&Tw/ڑ{̀ m6hxRzE;2} ݰgWlz:EbO.{ ΃Y\W- F+Þ ñtIUu2gU35iuX2ME+Г1YZ F䨁?3K65o U5gv4!pHY lԗXS»Ćp!@ Y3? g[ժ `WY`&,ۑ{^An1x ?-bͲwXU ];7fD_]39.mZD9ώh8"!ȃY#ᄭ.*Tjac/eUae=yTu%`cuLe`Ӗ F9YIF:D aUD*q>z#r,Hg9 ~S*FVR`&WWu=g0'I;h3=k/w^)?~\ "n rM MY5\f'U |:5@lrbD߃g0"m)õ5`gGb뵊i'B=fَDޛM <= bljJ]oEN𣦬g0"MR(p6u0t߁ ,&vĚe;T̄ A,vށ?`6Dm`S3͆ Xm&dЃXs ke;=IHWX Ol"L$dt.{ѫ)!M]  1`V%ٰ\#9؇!VoraggvGZg0".C*/z^RD&9&Z9g0w+PbHSg6'^S3fw@$e8y*.,D5>؋ e=1&`2}t;t69Nni*9WAh";e7Twcz&HHjH3;NC-ѻHu [n{UPLQMY`dЗB+XÏȠ5Aiٜ|)̏f²-#bFKlQɆ8e>rCkH]ꕖjݒ! Ys :8\PS3sk8 cD+vըCTjqٔ Fj |ǡɶBْE+?@)_fY`E 0:.~zgk8k58s*t&3"bvY`E=Тi} `Zo8XV{Y`e@#4QU@sȊ500I9rq@4To+'Ȋ5f NaG0+E'reZ84e=9&]ۮ Yy5HHl\^EfS3XfO`\KNϋ7Ҷ`Z3Az`z6ͥ i݃W7)8{ޢ ;OaX\s"v$j1<>mlN]Wz}7_\'{K6e==I1T: b0fَDb#Jx 騈t6:X])z+rԖ ej #\ԈGJjJ5&"ۧf_ `1A\)Q {H.2ʶbͲ>' :@q=%6j0TQY`Eۇ Ak益X#~rT N)Q[l:gN @c>fَDL h`]$fɐ~u0'cg"GBARCc?g9G&/5"8)%i>{ ~EQY $]eI潞hгQ"#TB۔ V(,UMLNS,gY`e۷!0+<[^Ul ,ۑ{Gk#JRU."qXlG"G r8f#<,I.mH=FygَHIlDP&s}v'$z7e=9jc(5z 40FS眈 ٦髶&rv5}ՠ /+@侗H+MOk-vMOsGP~wMY`E΁O#>f卢lN,Ge=\ NAk6S$v S,{Odb;j&PƏz1){d!U?ZPkH;Jݻ.W^kD(IdQ~uf3|z100 fَDޛʧJ{C nOs! 'trͲur[\Vjحgqߔ V䨛4jY p6UJEz+rsL S77?Eخ vL Fiz+rԡs@-عZ^hP+Cmz&˲Ffd@qm Vs`E`vP6rئg"נּ9:ބ@AxQn#W3Xًܝhv,GH36v$rYepA@}"4)QT`[|zo8Ih;8JXlG"G]WF!Ԥ1*b>N稚.5vdd|U k" 8bcZozJ,8E$R y|Gqe=yo40̫R`\ـ 4v.G#MY`6(28Hڞ)TJ̬iz'E*NT}na0鐊Kkym˺CPjΓtM۲lbd<**Fzfk9F/,ڑ\8Fzg0UGq빀kvgڃgp"ﭰpxwM7q,U??kIm6M\֦oYd4ZW;ω 5B.z' lqtU.cы N䨕Ǧi{kCbhAسqgp"G͑4@9`d֔ N9aV1j<5UͽdN>DHI*ESM[:kG.Ai#S35A bn;͒hzkG @'bͲIm6AZ6춥kq]174,яzq׶6iz 5%2}YT',ۑQGhYp5h|Q}1{P e#lG'5k$2< c!x^#:r̭a[!Z`cFSe;9jԀB|!}@eׂ݈ޒgk&aŊ)y`lSW^Y#Ċß91s;vLv2kH΋+Zـ ^Yn8ix nID|S3ZC^_w dAC%<R`+֜ȖzNQģj8bx G?X%zZԕ5d |TTK`R C)*Ge;6% tR | 8DbfyMY 6"KsSѱ=ev\IVQَD[1gBrDfBGe;yIYctmgal%쨬gp2G2;^Q%}(G3e=9g*g:m)M=;eͪAvv6kHjҰ(k]WQå}=[rͲ6uH*1"umZkΔ rz*~CC /ڲK( *='bG{[G%B=g-Izb͉ؑM|Le`0EdVMs+%AY*ۑ{ 0q@ }b],Lн㥀5lz'rUɀg:Nb`99Y}/ۑQWsgQc օĘlH}ϗ N1)ꌨa.$tCSĽ)䚃rF h#`3eF9Mgp"ו(9x0`SU8)I 8Ts(pHX,`30w/ۑf#Ԧ΃"Ro7hgp"Gm_Mr& -PWב"d+e;9j 1Qȁ/$L1;$Gα5e==з(RÙtXs"v$I \G8[=v$Tˊ+M?t|P>e3#8e=ylkNAȜ˱Jp-GFF2e=yFȔ,h NIĚe;sAX~PvRP>|`vkH ن԰3y*X@ lG"Gn9Zkes35[Ge;k6`/$8M9xL  zqd|Hֱ9B}@O™s7z'7uFE>`3^Q &|5v${g7^Juت!NϲwjU[8ŤRijܠͤSjz'gP"0K[e#"5nثQ#fz'rLug2Uu:n h-˘A5kc`U =@ km"J)5v$޾m9VCrT 3Y-Gv$ (VH zsԉ;7<$ܼꚜ5;5}-q2¨gp" >RNeE8զNğe=9j8$vX8 %՜tX|j e|Žz'r'8쿦"=U0ĉrvd Oa=VJJ2e=\㦰(ܼh!|P'mA"#gp"͝H5yGjDXρHLWY#/851OcQU\f FY#/ [;SKɁw&t |̔ ^DS} x P034l+|%k1tH`ȶ Uot S3x+Vр E]l[x=qj|΢5n,).>W }WTU0ۚ3(MYeO`6Nby#mEckذ+`g=p  7 F>g" ;4.ݠ2;3e=yo`nl m:柂|ΉؑЇ 8W4+3=I&"#r9v$rԔEe. (%2v r; K ½"g}mz/ޮUJ Xa8)6@6@bͲwuLd@e rMP @ TZ~ϲɞ$sl}EiMfIÆxו ^+ MLJyLJRlxF7e=9:@l/LW$p8B#xm/{YE:{mk,\;>5k"XlG"GB3N 8k*Bm=I]i ^#R OJ((6,˨R ԰&rkH΋dbS׃7OkY1q֔XlG2GmNHDesVqe#8-䚖e!*ذ 87KA7Tek[3x6*pT7vMhZ0KPL?Biz/{hj{vMmmfp&BM1\lG"G]l ›Μ?o(vgSd`}0VY#ΞWLq)vAp|ќy!6ݖ ^ 41_g91RkvV*LM-QSPjٻsԴ!!Q:h,O|βimYJH}BWwɶg"':D&X뵫z֖ Zq[ &̞F,*{lYe۹^7X_ἳ][=LE̖ ^jY8V {L)v JqYhL]زKm6h;q4plAm8 *؉5vD!V:LS49 ls@rĚE;kXR D<cNϡuwDŖ A+"kWn0.gamYD3 \G -$3 M=*QyZf,JwD+a)],gюQ[( FPF(z j" A΋n>sXwhn Ў#=+7nz rUÖ{U< 6_Rю 7ya*Z΢ A)G:2 r>5R mD="9 aW3iz ̩5Gϭu?r{DH5>e- CդS#leh<1NFkH΋*K}?b[*Śe;9jm Yq^Yy0 HѧW$" AyTWG` ]wFFfYDpa(iX%"Gmzf6`-w{WaaXlG"/lSju b ݴبZ{َd/+USB +4s30<5˶gQe]W+gٮBwmexT3S65_Va@ ܧb[De;9JW4`KMY1sgyq+x.-jplYDشxE"C;+N=Ě5Ώ `X)sJ-_d^39t_7@@1u٨hR%gڲ!H7@2nAhܑiͱTo A余N4lplYUz`ckH6pz u͠P<AWXz r2ozX7҆lk?ˢ-Q{Chrzbg~"@'յ2 r0s:y}ЁkLx~AYY#u-xQ ζ&"Eqgz /rZف4cэ?ug?IšdD3N+[gv¤Fģ!Ⱦ @ֶY9p)1|JȡQe=C9j3m8\E~`ւU {zY#q>an@żq ^q@ Y3֔Y $5V(t1A۵e=\%.Rұ1gL?I8b][3 bETYv+#,{saMU%\mX=?JM~Q.^ϲ!Ⱦ٭uqm 5uTTTaY3fMqr->.*p*%9e=CQlVRMA{[XŜF"kH`i/18(f_:b/gY Y>zA1[ճ{@kܜD+f+J#+F`64`,N,ۑ{Gc.՝f7V!زHģ!ȼwٱof!!Ւu{js A)Ѵ喙V`tŽz r5@6Ty6we;"I}/웍;- 0^Oˤ\iMAe=\3Už0V@̠gҚ7w)F>gَD޻lSq )[^t}KuG gYD޻ӜI]+a۪2MWjlYdl.X3KmY bcm'Ěe;9j۲{'Wٖ!6jt]"QXs"v$IR@@ Qx@j^YԪ۲!Ȟ$TG`? UgbՋHز!!Y*`]G+EzG[D>zf ~9Qb43h^kkNmYDޛCp^Lsj;]wkNTפ{ddȢO-웍VRctT5߲!g,xQ!Aw+:ׄ,Q>(;۬B%E[z rԭR Yo [|f74.Pn(gَĚ2)"=&SHR$9OSc(֜ ;`acsuT l 1͕ Anb2ȪeeH脵sr"zYQ سsxl `+,Lk%;ȡ3ρRm0eO,BX19 qE=u3+,6%@3@a;c`wE=cMf+|\P/×Pee]+~& [ܵ&VX#Y廗k m62 ";-']t*۶!%;šAlxSN6EY L{Ɏ2s=SPeŢD=W3h9' Re+8vb5ˬ+XV2G5\0 N xl:@)4v^b͉ؑY=bxa5]>DHxM\Z ;jY sݲ[#e\Q`*Fb#/e::v^ ;F H8SY#־rUMZWĚE=֔\GLˬrV2H=4E=NnN.{]Ll_c M+~f o |0Q}kHSyĺJ*D=ʳbj(7bͲ71uyG(l=s8)),,ۑI5&xT`t@qG-QQ&Cp넢 BSl8dFIY3J䨓wv0-ite {e;9b0HGdkLM`9w.Jm+~&|p]+-B͠ɢE=wJp<!"#rW30u:8ܑ ֱN@TҹػgNe58,'ᘚ+kuHL19S_\Qπ5EݹToa_p-5fU~G",ۑ Ω;yMsBpՍ|8Z= 8 "7:u {/~&"pm.yA ?s[ulI-֜ IAYۥ-{cwYe;y4hpq#\&n/(w `6,넾 XSdԞ8"0L+JesE=DN~X fb]:}_Y*v똢jL_U!{9j;C="njV0s cqQπ5E cNy6dl&A=SCpkXED~uނY5m9:߷?ŸE=Y3=',FqE=++ٱmnA(0>p\gg.]L=0 ,8ѤJbͲ5/%yxD6*m)Ng'ήFlGg;.G(Q?' XS6.)2K5W9e;9jviz PψE&-pslgњflGkvc흵%vf*М}Lc?a^űmp{asBz)6"}D4hki?p,W3`MK @-/40VM3$|rQπ5el 錕X7FԵ.TJY#kHdlĢ(kvC9R7+*vy< >tI\^3!T|RumZ3+Je;lf灉n=԰[agyg"7 ݗDV`=Ή5v$rԪR8Ptcf$Ц*Q'闊z)`'SG# ٶ6 *gَD:aSΌYVRlMZ5bgBGݲ'1|&bQ Sc:_3`M1*;6aacd洦FI͉/jn=%P-隝sO=չI+AU_a$l[$\s"v$s~ڸOE9j ^4C9;Z͙so8@Sj:ke;9juĦ\u|DlD__3"G,[z! {"v2r Qce=C-s`WW5z66ə:_kHMSnN囹;2ނrmke;kb =BQ^tZw&'%5zZ#ێ޽u.Vf4C|YP˼7IP:V0Yy8ڲ}XǗ QX^ q0SPTFǕ8e=C-rȀEpubѩRY#a5k#r 5Ċug\J9;ڭ*x&Pq}`pdA5fPVz&!lh†1Wa#2Z֊_3"9t N?gK GYmÈgem{iQ3`PK86,zZ1դT x5 +O.|YPKmv]-xb9 ۶aO~**fَDàHh_=EY3"GW8/wmJ;Sܝ7e;k"*BЎ>$Φ=,N,߽lGݗ=vtS*x?c|YP˞$w[ċTnd-oQ4M/jUʃ g*4p[Y!e=CȚe΅T*'ÁxHN 3M9YY#ͮ DݠO‰Nٳ2rv$rԆ]9%m;%'e=C-r5gَm5xgN] V|ϲA@e9&׼s6 < e=e]$m+q`">Qfg筼XlG"Gm'LZUم+bj_z%sԁg6AubͲ5sp}1:s TM< ):N%pNĸAumfUh# q -~!e=9Db`xsA EW]<糬gk~+.VGfsЁXs"v$p̫Ȯ9T& N䲞Awj]acT"̴f4V8Bz%EVjC[LlT@\{$gP"Gy{@Zʀ%'pVkͰd"kHI^̶؃>S@f>^#Fjw۪o}ۏ|.~e=\SsJߤf!Ե8b3>A {/f#d$H5  b*Ren廗Hu4 V.ϻYN©xβAy︚W^=8 [;wXVXlGr# ;8|};SD8kxy&,ۑQw:*Uݠl8R\ZM_3(WJ=ݟXh_ g6kNĎt؎-ݑi"`99]4 sH[6m4Fq 5)Ul*|YϠ6WMĩ(-BXd '੍ ZA7t17GAIm6~v?zHm7`h$2ce-tAgPr#zs8L/jh966gP"Gc7=[P=>+9х&9HY#f"fpxoT\&C|%lG"sJm ,'%^Aɼwe+;xPmiaàLt(!5v$ގ#_ޅSȞv0}/Q#>:ZBPd@8+VY#6T{*vl3b| :ԏre==y9r*$grCv}679v$$2_2Q>8T:b!xgP'IT$pGlľ J[R혍M ha*#}Ʌ J[L  .-s J #֛3۵i3DFee=9jS=ŃF"mApH˞$̽q8 JGn*GDPP3h"Y! s8 ZMb͢i{!%Pm Y#z-me+n/w{ VV9z-@Ɯ,Y_w`VnZ66bm-g"Gl`7m\,#{^E, Z-c5@uȰXba6њe;kVul]&ܟgY%bGYϠE[, r߳lG2 G$ Xu;748rNS({s@{8- D&!ӶѳКe;CZuP=['7fNL[AuNao,BTہT#Щy' _o 8PlԲkWd=Czg&M\cj9G1J Bcu8e=yo62g_Q֭lKN"v Z&La#a!&D@Śe;yo8/Y v(9` O?ՑbͲwݵ;rN$ p3!6}/ۑ\D"HvxѰ[(KsH"™m"F%/? BͲAvr.&LLaޠyFKe=ˌlkv @>S{P3h6;Ә"#فhWs *,ۑXEkp}I`xPʙZi3l4*MYϠelaNu<,z}5 .9|ΉؑJOx>P7ewxl#,ۑ{oj*l 8>"׹joe=9jM0g͜#得H57řY=ܓo+9 .S3F#<261uYYٳS=e=\3]إ5L}% ,{]fҟ,e @/J{YϠeOMf{)JXR .HX'NCYϠE÷}º*kWapΒfe;9j RUQ@| Ыw)\5z-r30]m(PG¯6= }HwQsM"G'"fН|Ήؑȭ1ر|j-@Ϧ~? <_3hn8K'.}0|SSRE jAy.7MFLZV ^s,fW`+\ f@fו Zq;#V𠬿װxt "gFIePdYK*ym%28|5,mlVUlE*|&D@ū(gY ׬:q%NBd2/ag\eYϠE޻fvGĹ{l'`dž.,ۑ{ G{m-'X]!nǙ%,ۑ{T -:R1ʴmCVk='bG'f.@>M vllnPd^𸲞9jxښ).ρXCk #gQʋ"Sx.EE;k7@_XZGvYlwy !,Q#.kP-GR0hs6 boib͢5r^$;uPRkSaKIlksI5vHmvCllCT߳][^9j?ob{*RUs XnNNr9jdP+7aGjj :*Nulи^b1 sBYЈu۪h]r(9HǷ "1Gb5'bGAo 61w$v5Vp+F|ϲ" ;W-09H@Ú CZP34"̶N׾o:Sg, (dghD޻bwvɳu<0PY#7ppٶ@g9-?l QwgL ŸZ8&: 1bͲu5/X7sJ BJd-Z$<@핮89GǨuZ'lGr^䀽t:|Զ{H-Am6,D)/f9/eXlG"m\3o[O?&\5ayQ!mt"̯9Uq$9Ao4:p>Dvّ%oU8hٔDXFхG!`''GOZ%(0lk#@xoڤ;uUw/`27%/ .I!oߵ&Ab&NHZHkƤH=Cv_*Y]r^Զ&Unb'ܩ$@fdsmUakdEmsRve7Ϗ8̆rA|+,jۓ&,jET ,R3> J1шO%q?blL^Զ(Uu{ D5ڐT: GAT3HCW'V EE"ύr;q̒|rJeh,E_X"ApwWH*}S,jPRjj/,J>Ц<Bb7|ґ(euEm%/JbruVAGd.@NmR5=gGG6]XAڡ ImfȈjGEJǝYJF6SlXt7BOmR:372ITf@$81ԢEZx,"K"*rFw>WS!bx@*JQmZIIuB/j[9G,6֤> ~#i]mIH;'f[)LO9'ytՀZjמI:^kg)ozԹ<}aQ*azXQa*kTP/,J{!F+VN`DRJƬımQ$ +=tHNI;+@4_ɢYhvZ8Czǖ-JŁWZ@mHL[FOY~xӋ*ly#PvV&;a)^ިnwH`Jؓ<Ϟ.۷aS ySr)(*5PWxߩT~̀>ߎapXhf<$UOTjî ueLB/Ίǝ3’st&y u%4챛&>5ޥC`B5B2̓DzHЖv" ~ēBwWxاEirjQĕW}N]PN,wEl=Ӣb!yț(y!*} ddXBfX%oP·*Ԣ>l84/l_HQ?[*Kt>S1^Ex*jah۷{gzW dVߺ25xR7= [^!n!_yN"D~He{<4BgVY:|v2 TIb7FذaX]=#w돯¢T|w*ERo RW}T$/EbWz r| ,^"ѕr'@&]&>hA*S/j@*k'R\7)OWoq[]+zQӢD׵ׄxɕȣ9OwŢE*lKN?Jp&R {v6ۛ@"jB"U y9uenЋnأ7IlAdGڏ7-J4w0(F }j ʞF!D̩ayP p"mRtzfNQWw;ӍeSWۭK拮0or^99rL!3sY;}aQTʛޙQ Mb6 &fф&Jb$R72xqEzѓ+R JjWSS^g !D+2RB9 ~]{|v?xODp?_6wx2OM!p."շ7"aׂG/j[r [ },̕3e "I*3K- h7OGP'mzQۢTa`z8ZI>m4eXڣ,g7E*t'< < HSĜ5.EaQۢT1ӓ+74v)ϩBe=~ߩm3L6%IUۀxDѺDM+X{/L$u~1BT7:Ύig%l=ES3B4iݢ&n5"9hsVvkB7rIÓqCWJ8p Y:ES7BTq ID8O_R_<!}TZL\tlJ}uy.NL((VDC d>-$7| lI\)iw,j[Z]pTDԅ ls !&U<w| 8N4b>-J+P&B} \)keJbgYHgr-o[T /ɸX;@)^=}:*䩇$NmEmyzLvSHё"oK.} ݹIF+1s 6)/Zn%O ;EmRnM >Y?E۝ }!mGF`Bo Ÿ6~|UB4%wn H;8ȁ\"ЋOYfF$EmRn2S9uAy`\DlܣPv^nA7ÑcjwK|?l=NL{RH*] _B4Il93r Dݞ| PD wOOV6 ?r>ko}˟,'׿~Dm9W$GC_^w>qt6S*Gݖ foo echo $'A A,A\tA,A\vA' >> 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 # 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 darcs replace Y Z foo ../temp/foo darcs replace Z Q foo foo --repodir=../temp/ darcs rec -am "xyzq" # Try to "overwrite" a hunk with a replace. # # v1.0.8 accepts this without error or warning, # but should perhaps require the --force option? # # current unstable sometimes(!) fails with bug: invalid pending # which is surely a bug. # this succeeds echo "x" > foo darcs rec -am xx echo "y" > foo darcs replace --ignore-times x y foo # this fails echo "hej" > foo darcs rec -am hej echo "hopp" > foo darcs replace hej hopp foo darcs whatsnew echo "src" > foo echo "dst" >> foo darcs rec -am hop darcs replace src dst foo || true darcs replace --force src dst foo darcs whatsnew darcs whatsnew -ls cd .. rm -rf temp darcs-2.10.2/tests/pending_has_conflicts.sh0000644000175000017500000000162712620122474022751 0ustar00guillaumeguillaume00000000000000#!/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 <&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 darcs-2.10.2/tests/issue1110_get_hashed.sh0000644000175000017500000000037412620122474022232 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/add_in_subdir.sh0000644000175000017500000000055612620122474021214 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue1845-paths-working-copy.sh0000644000175000017500000000315412620122474023640 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/nfs-failure.sh0000644000175000017500000000116712620122474020640 0ustar00guillaumeguillaume00000000000000#!/bin/sh . ./lib rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init echo first > a darcs add a darcs record --pipe --all --name=first < b darcs add b darcs record --pipe --all --name=first < a darcs record -alm add_a -A x # setup test cd .. darcs get temp2 temp1 cd temp1 darcs changes --context > context touch foo bar darcs add foo bar darcs record -alm add_foo_bar -A x # Test that --to works with send --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 --mail --author=me -a --sendmail-command='grep "^To: default@email$" %<' --context context cd .. darcs-2.10.2/tests/failing-issue2243-unknown-patch-annotating-empty-first-line.sh0000644000175000017500000000251612620122474031636 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/rebase-unsuspend-to-patch.sh0000644000175000017500000000273612620122474023430 0ustar00guillaumeguillaume00000000000000#!/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 darcs changes | grep 'add foo' darcs changes | grep 'add bar' darcs changes | not grep 'add baz' darcs-2.10.2/tests/ignore-this.sh0000644000175000017500000000071612620122474020654 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init touch foo darcs add foo cat > log < out cat out grep Proceed out darcs whatsnew echo y | darcs record -a --logfile log not darcs whatsnew darcs changes > out cat out not grep 'My private secret' out darcs changes --xml > out cat out grep 'My private secret' out cd .. rm -rf temp1 darcs-2.10.2/tests/issue1913-diffing.sh0000644000175000017500000000301012620122474021464 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1913 - test for directory diffing ## ## Copyright (C) 2010 Ian Lynagh ## ## 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 foo touch foo/foofile darcs rec -l -a -m "foo patch" mkdir bar touch bar/barfile rm -r foo darcs rec -l -a -m "bar patch" not darcs whatsnew -l cd .. darcs-2.10.2/tests/failing-issue1325_pending_minimisation.sh0000644000175000017500000000354512620122474025765 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/bin/0000755000175000017500000000000012620122474016634 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/tests/bin/hspwd.hs0000644000175000017500000000015212620122474020313 0ustar00guillaumeguillaume00000000000000module Main where import System.Directory ( getCurrentDirectory ) main = getCurrentDirectory >>= putStr darcs-2.10.2/tests/bin/trackdown-bisect-helper.hs0000644000175000017500000000156512620122474023717 0ustar00guillaumeguillaume00000000000000{- Tool for construction of testing repository for test --bisect. Written by Matthias Fischmann. Usage: ./trackdown-bisect-helper '[0,1,1,1,0,0,0]' This will generate a repository in which `grep -q 1 j` will first fail three times, then succeed three times, then fail once if you unapply patches with the linear implementation. -} import Control.Monad import System.IO import System.Environment import System.Process import Data.List import Control.Exception 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 ++ "'") generate :: [Int] -> IO () generate = mapM_ (uncurry stamp) . zip [1..] main :: IO () main = do args <- getArgs let js = (read (head args)) :: [Int] generate js darcs-2.10.2/tests/bin/renameHelper.hs0000644000175000017500000001714412620122474021606 0ustar00guillaumeguillaume00000000000000-- Helper to test renaming -- -- Copyright (C) 2014 Owen Stephens -- -- Permission is hereby granted, free of charge, to any person -- obtaining a copy of this software and associated documentation -- files (the "Software"), to deal in the Software without -- restriction, including without limitation the rights to use, copy, -- modify, merge, publish, distribute, sublicense, and/or sell copies -- of the Software, and to permit persons to whom the Software is -- furnished to do so, subject to the following conditions: -- -- The above copyright notice and this permission notice shall be -- included in all copies or substantial portions of the Software. -- -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE module Main where import Data.List ( sort, groupBy ) import Data.Function ( on ) import System.FilePath ( () ) import Control.Monad ( forM, void, when, unless, forM_ ) import System.Directory ( createDirectory, removeFile, removeDirectory , doesDirectoryExist, doesFileExist ) import System.Exit ( ExitCode(..) ) import System.Process ( system ) {- N = nonexistent (unrecorded, not in working) U = unadded (unrecorded, in working) S = shadow (recorded, not in working) K = known (recorded, in working) O = OK F = Fail tgt N U S K N F1 F1 F1 F1 s U F2 F2 F2 F2 r S F3 O4 F5 O6 c K O7 F8 O9 OF10 Reasons: 1 no such source path 2 shouldn't move paths we don't manage 3 target not in WD/Repo 4 post-hoc move 5 target exists in Repo 6 target exists in WD/Repo, but could be successful post-hoc if target is made to appear deleted before the move 7 simple rename 8 target in WD 9 rename into file that has been deleted. 10 If target is dir then OK: move into dir, else Fail: target exists in WD -} data PathExistence = N | U | K | S deriving (Eq, Ord, Show) data PathType = File | Dir deriving (Eq, Ord, Show ) -- OK takes a function to modify src/tgt names, used to check for tgt existence data ExpectedResult = OK ((String, String) -> String) | Fail instance Show ExpectedResult where show (OK _) = "OK " show Fail = "FAIL" -- ExpectedResults are for: [File/File, File/Dir, Dir/File, Dir/Dir] resList :: [ (PathExistence, [(PathExistence, [ExpectedResult])]) ] resList = [ (N, [ (N, allFail) , (U, allFail) , (K, allFail) , (S, allFail) ]) , (U, [ (N, allFail) , (U, allFail) , (K, allFail) , (S, allFail) ]) , (K, [ (N, allOkSnd) , (U, allFail) , (K, [Fail, okMoveInto, Fail, okMoveInto]) , (S, allOkSnd) ]) , (S, [ (N, allFail) , (U, [okSnd, Fail, Fail, okSnd]) , (K, [okSnd, Fail, Fail, okSnd]) , (S, allFail) ]) ] where allFail = replicate 4 Fail allOkSnd = replicate 4 okSnd okSnd = OK snd okMoveInto = OK $ \(s,d) -> ds -- Add a newline, else we're not creating a valid textfile! makeAtPath File = \p -> writeFile p (p ++ "\n") makeAtPath Dir = createDirectory removeAtPath File p = do removeFile p void $ system ("echo 'Removed file " ++ p ++ "'") removeAtPath Dir p = do removeDirectory p void $ system ("echo 'Removed dir " ++ p ++ "'") expectFailure args ExitSuccess = fail $ "Unexpected success: " ++ show args expectFailure args ec = return () exists File = doesFileExist exists Dir = doesDirectoryExist checkTgtExists pathType mod src tgt args = do tgtExists <- exists pathType $ mod (src, tgt) unless tgtExists $ fail $ "Unexpected absence of move tgt: " ++ show (mod (src, tgt)) ++ " " ++ show args checkSrcDoesNotExist pathType src args = do srcExists <- exists pathType src when srcExists $ fail $ "Unexpected presence of move src: " ++ show args expectSuccess args (ExitFailure _) _ = fail $ "Unexpected failure: " ++ show args expectSuccess (U,_,_,_,_,_,_) ExitSuccess _ = return () expectSuccess args@(K, srcPathType@File, src, K, Dir, tgt, _) _ mod = do checkSrcDoesNotExist srcPathType src args -- src is a file, tgt is a dir, so src will be moved inside dir checkTgtExists File mod src tgt args expectSuccess args@(_, srcPathType, src, N, _, tgt, _) _ mod = do checkSrcDoesNotExist srcPathType src args -- tgt didn't exist so src will simply be renamed to tgt checkTgtExists srcPathType mod src tgt args expectSuccess args@(K, srcPathType, src, S, _, tgt, _) _ mod = do checkSrcDoesNotExist srcPathType src args -- tgt was shadow, so src will simply be renamed to tgt checkTgtExists srcPathType mod src tgt args expectSuccess args@(_, srcPathType, src,_, tgtPathType, tgt,_) _ mod = do checkSrcDoesNotExist srcPathType src args checkTgtExists tgtPathType mod src tgt args type RenameInfo = (PathExistence, PathType, FilePath) main = do -- Don't need to do anything with the nonexistent paths let [_, us, ks, ss] = groupBy ((==) `on` (\(x,_,_) -> x)) . sort . concatMap (\(x,y) -> [x,y]) . fst . unzip $ pathDetails -- Create all files/dirs mapM_ (\(_, ptype, p) -> makeAtPath ptype p) $ us ++ ks ++ ss -- Let darcs know about all knowns/shadows mapM_ (system . ("darcs add " ++) . unwords . map (\(_,_,x)->x)) [ks, ss] _ <- system "darcs rec -am 'add everything'" -- Remove from working all shadows mapM_ (\(_, ptype, p) -> removeAtPath ptype p) ss forM_ pathDetails $ \(( (srcType, srcPathType, srcName) , (tgtType, tgtPathType, tgtName)), expected) -> do let movePatchName = "'move " ++ srcName ++ " -> " ++ tgtName ++ "'" ec <- system $ unwords [ "darcs whatsnew" , "&& darcs move", srcName, tgtName , "&& darcs rec -a ", tgtName, srcName , "-m", movePatchName] let args = ( srcType, srcPathType, srcName , tgtType, tgtPathType, tgtName, expected) case expected of OK check -> expectSuccess args ec check Fail -> expectFailure args ec where fileDirCombos = [(a,b) | a <- [File, Dir], b <- [File, Dir]] zipErr [] [] = [] zipErr (x : xs) (y : ys) = (x, y) : zipErr xs ys zipErr _ _ = error "uneven lists in zipErr" pathDetails :: [((RenameInfo, RenameInfo), ExpectedResult)] pathDetails = concatFor resList $ \(srcType, srcResults) -> concatFor srcResults $ \(tgtType, expected) -> concatFor (zipErr fileDirCombos expected) $ \((srcPathType, tgtPathType), expectedResult) -> let nameBase = show srcType ++ show srcPathType ++ show tgtType ++ show tgtPathType srcName = nameBase ++ "-src" tgtName = nameBase ++ "-dst" src = (srcType, srcPathType, srcName) tgt = (tgtType, tgtPathType, tgtName) in [((src, tgt), expectedResult)] where concatFor = flip concatMap darcs-2.10.2/tests/issue2227-rebase-amend-record.sh0000644000175000017500000000273612620122474023672 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/rmdir-formerly-pl.sh0000644000175000017500000000117012620122474022002 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue1640_verbose_stdin.sh0000644000175000017500000000416012620122474023012 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1640 - ## ## Copyright (C) 2011 Radoslav Dorcik ## ## 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; darcs-2.10.2/tests/rebase-keeps-deps-on-amend.sh0000644000175000017500000000435012620122474023415 0ustar00guillaumeguillaume00000000000000#!/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" --ignore-times echo 'B' > B darcs add B darcs rec -am"B" --ignore-times echo 'C' > C darcs add C echo 'yyy' | darcs rec -am"C" --ignore-times --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"darcs-2.10.2/tests/rebase-apply.sh0000644000175000017500000000412512620122474021006 0ustar00guillaumeguillaume00000000000000#!/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 | grep "Rebase in progress: 2 suspended patches" echo yny | darcs rebase unsuspend | grep "We have conflicts" cat > expected < foo echo yyy | darcs amend --patch '3' echo yy | darcs rebase unsuspend | grep "We have conflicts" cat > expected < foo echo yyy | darcs amend --patch '4' cd .. darcs-2.10.2/tests/failing-issue1579_diff_opts.sh0000644000175000017500000000351712620122474023550 0ustar00guillaumeguillaume00000000000000#!/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. abort_windows # No diff command available 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 darcs-2.10.2/tests/issue1877_noisy_xml_output.sh0000644000175000017500000000352512620122474023625 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1877 - pull --dry-run --xml-output is noisy ## ## Copyright (C) 2010 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 # Another script may have left a mess. darcs init --repo R # Create our test repos. darcs init --repo S cd R echo 'Example content.' > foo darcs record -lam 'Add foo.' cd .. cd S # This does the right thing... at least until the second command is executed darcs pull --dry-run --xml-output 2>&1 ../R | not grep "Would pull" # This does not, never darcs pull --summary --dry-run --xml-output 2>&1 ../R | not grep "Would pull" # From now on, this fails too! darcs pull --dry-run --xml-output 2>&1 ../R | not grep "Would pull" cd .. darcs-2.10.2/tests/issue1473.sh0000644000175000017500000000333712620122474020075 0ustar00guillaumeguillaume00000000000000#!/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 '' darcs-2.10.2/tests/issue1737-move_args.sh0000644000175000017500000000326312620122474022056 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1737 - command line filtering on darcs move ## yields suprising results with shell globs ## ## 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 touch d.txt darcs record -lam 'Add d and d.txt' darcs move d d.txt d 2> log || : # this can happen if eg. you darcs move d* d # d.txt isn't a directory; we should probably just say that you # can't move a directory on to itself not grep "target directory d.txt" log darcs-2.10.2/tests/what_sl.sh0000644000175000017500000000042012620122474020055 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/toolbox.sh0000644000175000017500000000035212620122474020106 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib DIR="`pwd`" # 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 echo ny | darcs record cd .. rm -rf temp1 darcs-2.10.2/tests/failing-issue1396_changepref-conflict.sh0000644000175000017500000000075012620122474025465 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp1a temp1b mkdir temp1 cd temp1 darcs init darcs setpref test 'echo nothing' darcs record -am 'null pref' cd .. darcs get temp1 temp1a cd temp1a darcs setpref test 'echo a' darcs record -am 'pref a' cd .. darcs get temp1 temp1b cd temp1b darcs setpref test 'echo b' darcs record -am 'pref b' cd .. cd temp1 darcs pull -a ../temp1a --dont-allow-conflicts not darcs pull -a ../temp1b --dont-allow-conflicts cd .. rm -rf temp1 temp1a temp1b darcs-2.10.2/tests/prefs_binary.sh0000644000175000017500000000065412620122474021110 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Test that _darcs/prefs/binaries . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init mkdir d touch d/t.t darcs add d/t.t darcs record -am "initial record" echo 'some change' >> d/t.t 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 ny | darcs record --interactive > log grep binary log cd .. rm -rf temp1 darcs-2.10.2/tests/mv.sh0000644000175000017500000000161612620122474017046 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp mkdir temp cd temp darcs init echo hi world > temp.c darcs add temp.c darcs record --all -A test --name=hi echo goodbye >> temp.c darcs whatsnew darcs record -a -A au -m bye echo bar > bar.c darcs add bar.c darcs record -a -m one -A ex darcs mv bar.c zig.c darcs whatsnew darcs record -a -m two -A ex mkdir baz darcs add baz darcs whatsnew darcs record -a -m three -A ex darcs mv zig.c baz/bar.c darcs whatsnew darcs record -a -m four -A ex darcs mv baz temp darcs whatsnew darcs record -a -m five -A ex darcs mv temp temp 1> stdout 2> stderr || true grep 'Cannot rename a file or directory onto itself' stderr cd .. rm -rf temp mkdir temp cd temp darcs init echo hi world > a darcs add a darcs record --all -m lower cd .. darcs get temp temp1 cd temp darcs mv a A echo goodbye > A darcs record --all -m 'to upper' cd ../temp1 darcs pull -a cd .. rm -rf temp temp1 darcs-2.10.2/tests/rename_shouldnt_affect_prefixes.sh0000644000175000017500000000340312620122474025024 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Renaming a -> b should not affect any filenames with prefix b, when looking ## for the original name of the files in changes --xml, or when annotating. ## ## 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 'a\nb\nc' > a cp a bb darcs rec -alm 'Add a bb' darcs move a b darcs rec -am 'Move a -> b' 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. not grep "original_name='./ab'" < changes.xml # Ensure that we are able to annotate bb (if the rename has affected bb # internally, we'll not be able to annotate the file) darcs annotate bb | not grep unknown darcs-2.10.2/tests/issue2049-dir-case-change.sh0000644000175000017500000000321512620122474023000 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2049 - adding files inside a directory ## that's had a case change. ## ## This is not the exact failure reported in issue2049, ## but was reported by another user on IRC around the ## same time, and is closely related. ## ## Copyright (C) 2011 Sven Strittmatter, 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 mkdir foo touch foo/bar darcs add foo -r # two stage case change so it works on Windows mv foo fox mv fox foO touch foO/bar2 not darcs add foO/bar2 darcs-2.10.2/tests/failing-issue390_whatsnew.sh0000644000175000017500000000113612620122474023334 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory . ./lib if ! test -x "$(which strace)" then echo skipping test since strace was not found exit fi rm -rf temp mkdir temp cd temp darcs init date > file1 date > file2 darcs add file* darcs record -am "test" strace darcs whatsnew file1 &> out # we should be accessing file1 grep file1 out # but shouldn't be accessing file2 if grep file2 out then echo A whatsnew for file1 should not involve a 'stat' call to file2 exit 1 else echo Yay. We pass. fi rm -rf temp darcs-2.10.2/tests/repodir.sh0000644000175000017500000000100612620122474020061 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ### http://bugs.darcs.net/issue496 ### _darcs/prefs/defaults ignored when using --repodir ## All these commands SHOULD fail (hence leading NOTs). . lib rm -rf temp mkdir temp cd temp mkdir repo darcs initialize --repodir repo cd repo date > foo darcs add foo darcs record -a -m auth echo > _darcs/prefs/defaults ALL disable # try to disable all not darcs changes not darcs changes --repodir "`pwd`" cd .. not darcs changes --repodir repo not darcs changes --repodir "`pwd`/repo" rm -rf temp darcs-2.10.2/tests/failing-issue2017-missing-tag.sh0000644000175000017500000000506012620122474023712 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue1898-set-default-notification.sh0000644000175000017500000000407012620122474025002 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1898 - set-default mechanism ## ## 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 R0 R1 R2 S # Another script may have left a mess. darcs init --repo R0 # Create our test repos. darcs get R0 R1 darcs get R0 R2 darcs get R0 S cd S # default to no-set-default darcs push ../R1 > log grep '/R0$' _darcs/prefs/defaultrepo # notification when using no-set-default grep "set-default" log # set-default works darcs push ../R1 --set-default > log grep '/R1$' _darcs/prefs/defaultrepo # no notification when already using --set-default 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 cd .. darcs-2.10.2/tests/issue1763-pull-fails-on-non-ascii-filenames.sh0000644000175000017500000000456012620122474026375 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1763 - When you pull in a conflicting hunk ## patch to a file with a non-ASCII name, and then pull from the same ## repo again, darcs crashes. ## ## Copyright (C) 2010 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 # This test should work on Windows because the codepoints in the filename # are all <256. However an equivalent test with codepoints >=256 would # likely fail. # abort_windows rm -rf R S darcs init --repo R export LC_ALL=C function check_consistent_filename { count=`darcs changes -v | grep 'hunk .*\.lisp' | sed -e 's/.*hunk //' -e 's/.lisp.*//' | sort | uniq | wc -l` test $count -eq 1 } # Set up a repo with 3 patches to a non-ASCII-named file cd R touch kitöltés.lisp darcs rec -l -a -m "Add" echo hi >> kitöltés.lisp darcs record -a -m "First edit" cd .. rm -rf S S2 S3 darcs get R S darcs get R S2 darcs get R S3 cd R echo hi >> kitöltés.lisp darcs record -a -m "Second edit" cd .. # From another repo, pull the first two, edit, pull the third to get a # conflict, pull again to get the crash cd S echo hello >> kitöltés.lisp darcs record -a -m "My edit" darcs pull -a ../R darcs pull -a ../R check_consistent_filename cd .. # duplicates cd S2 echo hi >> kitöltés.lisp darcs record -a -m "My duplicate edit" darcs pull -a ../R darcs pull -a ../R check_consistent_filename cd .. darcs-2.10.2/tests/issue1921-missing-tag-in-apply-bundle.sh0000644000175000017500000000437012620122474025307 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Attempting to apply a patch which depends on a missing tag should not cause ## darcs to die. ## ## 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 T patch.dpatch darcs init --repo 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 get . ../S # Add the tag which we will fail on darcs tag -m 'file2 tag' # Take a copy with the tag darcs get . ../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 "tagged file2 tag" apply_output.txt grep "FATAL: Cannot apply this bundle. We are missing the above patches." apply_output.txt darcs-2.10.2/tests/failing-look_for_moves.sh0000644000175000017500000000144712620122474023060 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 mkdir temp1 temp2 cd temp1 # # exchange of dirs with contents and exchange filenames inside darcs init mkdir dir dir2 touch dir/foo dir2/foo dir2/foo2 darcs record -a -m add_files_and_dirs -A x --look-for-adds mv dir dir.tmp mv dir2 dir mv dir.tmp dir2 mv dir/foo dir/foo.tmp mv dir/foo2 dir/foo mv dir/foo.tmp dir/foo2 darcs wh --summary --look-for-moves > log 2>&1 cat > log.expected < ./dir.tmp~ ./dir2 -> ./dir ./dir.tmp~ -> ./dir2 ./dir/foo -> ./dir/foo.tmp~ ./dir/foo2 -> ./dir/foo ./dir/foo.tmp~ -> ./dir/foo2 EOF diff -u log log.expected rm log log.expected darcs record -a -m move_dirs -A x --look-for-moves darcs wh --look-for-moves --look-for-adds >log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log rm -rf * cd .. rm -rf temp1 darcs-2.10.2/tests/failing-issue2086-index-permissions.sh0000644000175000017500000000310412620122474025153 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/failing-issue1014_identical_patches.sh0000644000175000017500000000215312620122474025211 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # 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 darcs-2.10.2/tests/issue2244-dup-tag-warning.sh0000644000175000017500000000057712620122474023077 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib # Load some portability helpers. t=`(dd if=/dev/urandom count=1 | tr -cd "a-zA-Z0-9" | head -c 10)` # Create de tag name. darcs init --repo R # Create our test repos. # Test about issue 2244: darcs tag should warn about duplicate tags. cd R darcs tag "$t" darcs show tag | grep "$t" darcs tag "$t" | grep 'WARNING' cd .. darcs-2.10.2/tests/send_apply.sh0000644000175000017500000000117612620122474020563 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 cd ../temp2 darcs apply ../temp1/funpatch cd .. cmp temp1/bar temp2/bar rm -rf temp2 mkdir temp2 cd temp2 darcs init darcs apply ../temp1/funpatch ## Also test that "darcs apply" can accept a patch on stdin. darcs obl -a darcs apply < ../temp1/funpatch cd .. cmp temp1/bar temp2/bar rm -rf temp1 temp2 darcs-2.10.2/tests/failing-issue2187-apply--test-non-interactive.sh0000644000175000017500000000314312620122474026762 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2187 - "darcs apply --test 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 darcs-2.10.2/tests/EXAMPLE.sh0000644000175000017500000000320412620122474017512 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issueNNNN - ## ## 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. 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 mv d/f e/ darcs record -am 'Move d/f to e/f.' darcs push ../S -a # Try to push patches between repos. cd .. cd S darcs push ../R -a cd .. darcs-2.10.2/tests/failing-issue1819-pull-dont-allow-conflicts.sh0000644000175000017500000000151412620122474026515 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1819 - pull --dont-allow-conflicts doesn't work ## ## Dave Love , 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 .. darcs-2.10.2/tests/mv-test-suite.sh0000644000175000017500000000062412620122474021150 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/whatsnew-file.sh0000644000175000017500000000165312620122474021202 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/recordrace.sh0000644000175000017500000000046712620122474020540 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue1599-automatically-expire-unused-caches.sh0000644000175000017500000000370112620122474026766 0ustar00guillaumeguillaume00000000000000#!/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 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 export DARCS_CONNECTION_TIMEOUT=1 && 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 ] darcs-2.10.2/tests/push-formerly-pl.sh0000644000175000017500000000214112620122474021643 0ustar00guillaumeguillaume00000000000000#!/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 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 "$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 darcs-2.10.2/tests/failing-issue1928-file-dir-replace.sh0000644000175000017500000000273412620122474024613 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/unrecord-setpref.sh0000644000175000017500000000044312620122474021710 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue1446.sh0000644000175000017500000000443212620122474020072 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1446 - darcs amend-record -m foo destroys long description without warning ## ## Copyright (C) 2009 Dmitry Kurochkin ## ## 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. touch R/f darcs add f --repo R echo 'patch name' > R/patchinfo echo 'patch description' >> R/patchinfo darcs record -a --logfile=R/patchinfo --repo R darcs changes --repo R | grep 'patch name' darcs changes --repo R | grep 'patch description' echo 'y' | darcs amend-record -p 'patch name' -m 'new name' --repo R darcs changes --repo R | grep 'new name' darcs changes --repo R | grep 'patch description' echo content > R/f echo 'another name' > R/patchinfo echo 'another description' >> R/patchinfo darcs record -a --logfile=R/patchinfo --repo R darcs changes --repo R | grep 'another name' darcs changes --repo R | grep 'another description' echo 'y' | darcs amend-record -p 'another name' -m 'one more name' --repo R darcs changes --repo R | grep 'one more name' darcs changes --repo R | grep 'another description' rm -rf R/ # Clean up after ourselves. darcs-2.10.2/tests/pull_binary.sh0000644000175000017500000000311512620122474020740 0ustar00guillaumeguillaume00000000000000#!/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. . ./lib 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 yny | darcs pull --set-default ../temp1 rm foo darcs pull -a cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/lazy-optimize-reorder.sh0000644000175000017500000000213112620122474022672 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 temp2 temp3 mkdir temp1 cd temp1 darcs init --no-patch-index # this test only applies to hashed formats if cat _darcs/inventory; then exit 0; fi date > f1 darcs add f1 darcs record -am 'add f1' darcs tag -m 'tag f1' date > f2 darcs add f2 darcs record -am 'add f2' cd .. darcs get --lazy temp1 temp2 darcs get --lazy temp2 temp3 cd temp2 # Run darcs changes so we pull in the inventories (but no the patches) darcs changes # 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 cat out grep unavailable out date > f3 darcs add f3 darcs record -am 'add f3' darcs tag -m 'tag 123' cd .. cd temp3 date > f4 darcs add f4 darcs record -am 'add f4' darcs pull -av # 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 # Just a double-check: we shouldn't be able to check in this case. not darcs check cd .. rm -rf temp1 temp2 temp3 temp4 darcs-2.10.2/tests/failing-pristine-problems.sh0000644000175000017500000000356412620122474023515 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Check for correct behaviour with missing files in pristine ## ## 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 foo mkdir foo cd foo darcs init echo 'wibble' > wibble darcs rec -lam 'wibble' darcs check roothash=`darcs show pristine | grep ' ./$' | cut -d' ' -f1` wibblehash=`darcs show pristine | grep ' wibble$' | cut -d' ' -f1` rm _darcs/pristine.hashed/$roothash not darcs check not darcs check # At the time of writing this test goes wrong at the line above # I'm not 100% certain if the rest of it is right. darcs repair | grep -v 'The repository is already consistent' darcs check rm _darcs/pristine.hashed/$wibblehash not darcs check not darcs check darcs repair | grep -v 'The repository is already consistent' darcs check darcs-2.10.2/tests/unrevert-add.sh0000644000175000017500000000043712620122474021024 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/failing-issue2272-rebase-unsuspend-copes-with-unrecorded-changes.sh0000644000175000017500000000365512620122474032604 0ustar00guillaumeguillaume00000000000000#!/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 ../ darcs-2.10.2/tests/unrevert_cancel.sh0000644000175000017500000000043012620122474021574 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # From issue366 bug report . ./lib 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 yyyy | darcs revert echo ploum >> a echo nyyy | darcs unrevert cd .. rm -rf temp1 darcs-2.10.2/tests/push.sh0000644000175000017500000000044712620122474017404 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp temp_0 mkdir temp cd temp 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 cd .. rm -rf temp temp_0 darcs-2.10.2/tests/issue244_changes.sh0000644000175000017500000000045312620122474021474 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # 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 darcs-2.10.2/tests/issue2041_dont_add_symlinks.sh0000644000175000017500000000411412620122474023644 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1645 - Since Darcs does not version-contol symlinks, ## it should reject them when a user is trying to 'darcs add' them. ## Thist must hold for both file and directory symlinks. ## ## Copyright (C) 2011 Alexey Levan ## ## 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. 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 ln -s ./test-file ./test-file-link1 # relative symlink ln -s "`pwd`"/test-file ./test-file-link2 # absolute symlink not darcs add test-file-link1 # darcs must fail to add symlinks not darcs add test-file-link2 # test for directory mkdir test-dir ln -s ./test-dir ./test-dir-link1 ln -s "`pwd`"/test-dir ./test-dir-link2 not darcs add test-dir-link1 not darcs add test-dir-link2 darcs-2.10.2/tests/issue2311_posthook_for_get_should_run_in_created_repo.sh0000644000175000017500000000330412620122474031156 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/conflict-fight-failure.sh0000644000175000017500000000153512620122474022751 0ustar00guillaumeguillaume00000000000000#!/bin/env bash # # Test darcs conflict fight scenario. # # Set up two repos RA and RB. Create conflict in RB. # After resolving conflict in RB, pull new patch from RA. # Repeat, rinse. # # Author: Pekka Pessi # . ./lib record="record --ignore-time --all --author X" rm -rf RA RB mkdir RA cd RA echo 0 > file darcs init darcs add file darcs $record -m0 file cd .. darcs get RA RB # Create conflict in RB cd RB echo let it b > file darcs $record -m B cd .. for i in 1 2 3 4 5 # 6 7 8 9 10 11 12 do echo Create new patch A$i in RA cd RA echo a$i > file darcs $record -m 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 Resolve conflict and start fighting by recording B$i cd RB echo let it b > file darcs $record -m B$i cd .. done rm -rf RA RB darcs-2.10.2/tests/match.sh0000644000175000017500000000521512620122474017517 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Some tests for the '--match' flag . lib # set up the repository rm -rf temp1 # another script may have left a mess. mkdir temp1 cd temp1 darcs init cd .. # create three patches - the property we exploit to determine # if a matcher does the right thing is that each patch has a # different author cd temp1 touch bar darcs add bar darcs record -a -m "first patch" bar -A author1 echo foo > bar darcs record -a -m "\"second\" \\ patch" bar -A author2 echo blop > bar darcs record -a -m "second" bar -A author3 cd .. # ------------------------------------------------------------------- # single matchers # ------------------------------------------------------------------- cd temp1 # matching on author really matches on that, and not something else darcs changes --match='author "first patch"' > log not grep '.' log # normal changes shows both authors and patch names darcs changes > log grep author1 log grep author2 log grep author3 log grep 'first patch' log grep '"second" \\ patch' log grep -v patch log | grep second # exact darcs changes --match='exact second' > log not grep author1 log not grep author2 log grep author3 log # name darcs changes --match='name second' > log not grep author1 log grep author2 log grep author2 log # author darcs changes --match='author author1' > log grep author1 log not grep author2 log not grep author3 log #hash darcs changes --xml-output --match='exact "\"second\" \ patch"' > log hash=`grep hash log | sed -e "s/.*hash='//" -e "s/'.*//"` echo $hash darcs changes --match="hash $hash" not grep author1 log grep author2 log not grep author3 log cd .. # ------------------------------------------------------------------- # matching on combinations # # uses the setup from the atomic patches # ------------------------------------------------------------------- cd temp1 # or darcs changes --match='author author1 || author author2' > log grep author1 log grep author2 log not grep author3 log # and darcs changes --match='name second && author author2' > log not grep author1 log grep author2 log not grep author3 log # not darcs changes --match='not name second' > log grep author1 log not grep author2 log not grep author3 log # grouping darcs changes --match='(not name second) || (author author3)' > log 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 darcs-2.10.2/tests/rebase-keeps-deps.sh0000644000175000017500000000430012620122474021714 0ustar00guillaumeguillaume00000000000000#!/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" --ignore-times echo 'B' > B darcs add B darcs rec -am"B" --ignore-times echo 'C' > C darcs add C echo 'yyy' | darcs rec -am"C" --ignore-times --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"darcs-2.10.2/tests/rebase-skip-conflicts.sh0000644000175000017500000000312012620122474022603 0ustar00guillaumeguillaume00000000000000#!/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 < foo < foo < foo < foo-expected < d/f darcs record -lam 'Add d/f and e.' darcs changes --xml | not grep "\\.gz" cd .. darcs-2.10.2/tests/failing-issue2100-add-failures.sh0000644000175000017500000000313112620122474024016 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2100 - darcs add should not fail on first failure ## ## 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 mkdir d echo 'Example content.' > d/f not darcs add d/non-existent not darcs whatsnew not darcs add d/non-existent d/f > log1 2>&1 darcs whatsnew > log2 2>&1 grep "./d/non-existent does not exist" log1 not grep "addfile ./d/non-existent" log2 grep "adddir ./d" log2 grep "addfile ./d/f" log2 darcs-2.10.2/tests/set-default-hint.sh0000644000175000017500000000406212620122474021577 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test that set-default hint messages are produced at the right times ## ## 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 R1 R2 R3 # Another script may have left a mess. darcs init --repo R1 darcs get R1 R2 darcs get R1 R3 HINTSTRING="issue the same command with the --set-default flag" cd R3 for command in pull push send do opt= test "$command" = "send" && opt=-O # R1 should be the default for R3 darcs $command $opt ../R1 | not grep "$HINTSTRING" darcs $command $opt ../R2 | grep "$HINTSTRING" # can disable message on the command-line darcs $command $opt --no-set-default ../R2 | not grep "$HINTSTRING" # or using defaults echo "$command no-set-default" >> ../.darcs/defaults darcs $command $opt ../R2 | not grep "$HINTSTRING" darcs $command $opt --set-default ../R2 | not grep "$HINTSTRING" darcs $command $opt --set-default ../R1 | not grep "$HINTSTRING" done darcs-2.10.2/tests/failing-issue1363-mark-conflicts.sh0000644000175000017500000000404412620122474024410 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/issue966_diff.sh0000644000175000017500000000101712620122474021004 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 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" darcs-2.10.2/tests/utf8-display.sh0000644000175000017500000000312012620122474020745 0ustar00guillaumeguillaume00000000000000#!/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 abort_windows # TODO make this work switch_to_utf8_locale 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' darcs-2.10.2/tests/issue1977-darcs-repair.sh0000644000175000017500000000034012620122474022447 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Issue1977 darcs repair complains when there is no pristine.hashed directory . ./lib mkdir temp1 cd temp1 darcs init echo "a" > a darcs add a darcs rec -am a rm -rf _darcs/pristine.hashed/ darcs repair darcs-2.10.2/tests/devnull.sh0000644000175000017500000000255112620122474020074 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test that non-interactive darcs commands work when stdin is /dev/null ## ## 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. darcs init --repo R # Create our test repo. cd R touch wibble darcs rec -lam"wibble" < /dev/null darcs-2.10.2/tests/amend-cancelling.sh0000644000175000017500000000044612620122474021605 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # 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 -a --patch 'A' cd .. rm -rf temp1 darcs-2.10.2/tests/issue1705-show-contents-index.sh0000644000175000017500000000305712620122474024010 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1705 - 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 darcs-2.10.2/tests/failing-issue2203-only-list-toplevel-deleted-dirs.sh0000644000175000017500000000301012620122474027603 0ustar00guillaumeguillaume00000000000000#!/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 ]] darcs-2.10.2/tests/show_tags-remote.sh0000644000175000017500000000317412620122474021714 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/rebase-repull.sh0000644000175000017500000000254512620122474021170 0ustar00guillaumeguillaume00000000000000#!/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" cd .. darcs get R R2 cd R echo 'yy' | darcs rebase suspend darcs pull -a ../R2 echo 'yy' | darcs rebase obliterate darcs-2.10.2/tests/issue436.sh0000644000175000017500000000101012620122474017775 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash #pragma repo-format darcs-2 . ./lib rm -rf temp1 temp2 mkdir temp1 cd temp1 # this test fails in the darcs 1 format darcs init --darcs-2 echo A > f darcs add f darcs record --ignore-times -a -m A cd .. darcs get temp1 temp2 cd temp1 echo C > f darcs record --ignore-times -a -m A-C cd .. cd temp2 echo B > f darcs record --ignore-times -a -m A-B echo A > f darcs record --ignore-times -a -m B-A (darcs push -a || :) 2> push-result grep "Refusing to apply" push-result cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue1300_record_delete-file.sh0000644000175000017500000000351112620122474023651 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1300 - record --delete-file should only delete ## after a successful record ## ## 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 darcs add f # no test touch log echo 'no test' > f darcs record -am f --logfile log --delete-logfile test ! -e log # passing test touch log darcs setpref test 'exit 0' echo 'test pass' > f darcs record -am f --test --logfile log --delete-logfile test ! -e log # failing test touch log darcs setpref test 'exit 1' echo 'test fail' > f not darcs record -am g --test --logfile log --delete-logfile test -e log # should *not* be deleted cd .. darcs-2.10.2/tests/changes_with_move.sh0000644000175000017500000000162212620122474022112 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/split-patches.sh0000644000175000017500000000367612620122474021214 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for correct handling of Darcs v1 patches with nested { } ## ## 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. #pragma repo-format darcs-1,darcs-2 . lib # Load some portability helpers. if grep darcs-2 .darcs/defaults; then format=darcs-2 patchtype=darcs-2 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 - cd split--${format} darcs check cd .. # .dpatch tests: .dpatch files for darcs 2 split patches were # broken in darcs 2.5 (and probably always broken) so we don't # bother to test them. if [ ${patchtype} != darcs-1 ] ; then exit 0 ; fi rm -rf temp mkdir temp cd temp darcs init darcs apply $TESTDATA/split--${patchtype}.dpatch cd .. rm -rf temp2 mkdir temp2 cd temp2 darcs init darcs apply $TESTDATA/split2--${patchtype}.dpatch cd .. darcs-2.10.2/tests/ask_deps.sh0000644000175000017500000000235512620122474020216 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp mkdir temp cd temp darcs init cat > _darcs/prefs/defaults <<. ALL author test ALL ignore-times ALL ask-deps . # add three depending patches for file 'a' # expect no dependency questions # 'q' will abort and cause future failure if an unexpected dependency is asked touch a darcs add a echo q | darcs rec -am a0 darcs ann -p a0 echo 1 > a echo q | darcs rec -am a1 darcs ann -p a1 echo 2 > a echo q | darcs rec -am a2 darcs ann -p a2 # add some patches for file 'b' # expect no dependency questions for file 'b', # but every time expect questions for the three patches of file 'a' # every 'n' should continue to ask about the next patch # the first 'y' should make all following dependencies of 'a' implicit and stop asking # 'q' will abort and cause future failure if an unexpected dependency is asked touch b darcs add b # test 0 echo nnnY | tr '[A-Z]' '[a-z]' | darcs rec -am b0 darcs ann -p b0 # test 1 echo 1 > b echo nnyY | tr '[A-Z]' '[a-z]' | darcs rec -am b1 darcs ann -p b1 | grep '^\[a0' # test 2 echo 2 > b echo nyY | tr '[A-Z]' '[a-z]' | darcs rec -am b2 darcs ann -p b2 | grep '^\[a1' # test 3 echo 3 > b echo yY | tr '[A-Z]' '[a-z]' | darcs rec -am b3 darcs ann -p b3 | grep '^\[a2' cd .. rm -rf temp darcs-2.10.2/tests/issue1636-match-hunk.sh0000644000175000017500000000341612620122474022131 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1636 - primitive match type: hunk ## ## Copyright (C) Kamil Dworakowski ## ## 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 'first line' > f darcs record -lam 'one' echo 'second line' >> f darcs record -am 'two' darcs changes --match 'hunk first' > log grep one log not grep two log darcs changes --match 'hunk line' > log grep one log grep two log darcs changes --match 'hunk one' > log not grep one log # test searching for lines in the remove part of the hunk echo 'first line' > f darcs record -am 'three' darcs changes --match 'hunk second' > log grep three log grep two log not grep first log darcs-2.10.2/tests/issue184_add.sh0000644000175000017500000000047412620122474020622 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/filepath.sh0000644000175000017500000000543012620122474020216 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Some tests for proper handling of filepaths . lib DIR=`pwd` rm -rf temp1 temp2 # Make sure that init works with --repodir darcs init --repodir=temp1 test -d temp1/_darcs # add some meat to that repository cd temp1 touch baz darcs add baz darcs record -m moo -a cd .. # ---------------------------------------------------------------------- # 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 darcs get temp1 temp2 cd temp2 mkdir -p dir darcs add dir cd dir touch foo:bar darcs add --reserved-ok foo:bar cd ../.. rm -rf temp2 fi # ---------------------------------------------------------------------- # repodir stuff # ---------------------------------------------------------------------- mkdir -p temp1/non-darcs # FIXME: This test does not seem to make much sense # --repodir is not recursive not darcs get temp1/non-darcs 2> log grep "Not a repository" log rm -rf temp1/non-darcs rm -rf non-darcs # get accepts --repodir. 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 cloning" test -d temp2/_darcs # changes accepts --repodir. darcs changes --repodir=temp1 | grep -i "moo" # changes accepts absolute --repo. darcs changes --repo="${DIR}/temp1" | grep -i "moo" # changes accepts relative --repo. darcs changes --repo=temp1 | grep -i "moo" # [issue467] context --repodir darcs changes --context --repodir=temp1 | grep 'Context:' # dist accepts --repodir. darcs dist --repodir=temp1 | grep -i "Created dist" # optimize accepts --repodir. 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 baz # setpref accepts --repodir. darcs setpref --repodir=temp1 test echo | grep -i "Changing value of test" # test --linear accepts --repodir. darcs test --linear --repodir=temp1 | grep -i "Success!" # ---------------------------------------------------------------------- # converting between absolute and relative paths # ---------------------------------------------------------------------- rm -rf temp3 darcs get temp1 temp3 cd temp3 mkdir -p a/b cd .. cd temp2 echo hello 1 >> baz darcs record -m hello1 -a echo hello 2 >> baz darcs record -m hello2 -a cd .. # can handle .. path cd temp3 darcs pull ../temp2 --set-default -p1 --all | grep -i 'Finished pulling' darcs pull --dry-run | grep hello2 cd a/b #[issue268] repodir with subdir darcs pull --dry-run | grep hello2 cd .. cd .. rm -rf log temp1 temp2 temp3 darcs-2.10.2/tests/issue2049-file-in-boring-dir.sh0000644000175000017500000000257112620122474023447 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2049 - adding files inside a boring directory ## ## Copyright (C) 2011 Iago Abal, 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 mkdir foo~ touch foo~/a.txt not darcs add foo~/a.txt darcs-2.10.2/tests/get-http-packed-detect.sh0000644000175000017500000000216512620122474022653 0ustar00guillaumeguillaume00000000000000#!/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. #pragma repo-format darcs-1,darcs-2 . lib rm -rf S if grep darcs-1 .darcs/defaults; then format=hashed elif grep darcs-2 .darcs/defaults; then format=darcs-2 else format=ERROR; fi gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - cd many* 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/many-files--${format} S --verbose |grep "Cloning packed basic repository" # check that it does really not get packs when --no-packs is passed rm -rf S darcs get $baseurl/many-files--${format} S --no-packs --verbose |not grep "Cloning packed basic repository" # check that it does not clam getting packs when there are not rm -rf S rm -rf many-files--${format}/_darcs/packs/ darcs get $baseurl/many-files--${format} S --verbose |not grep "Cloning packed basic repository" darcs-2.10.2/tests/patch-index-enabled-and-disabled.sh0000644000175000017500000000444612620122474024531 0ustar00guillaumeguillaume00000000000000#!/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-status | 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-status | grep 'Patch Index is in sync with repo.' # Clean up. cd .. rm -rf R darcs-2.10.2/tests/issue2179-diff-with-dir-path.sh0000644000175000017500000000274112620122474023464 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2179 - darcs diff on a dir should diff everything in and below ## that directory. ## 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 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 darcs-2.10.2/tests/issue1749-rmdir.sh0000644000175000017500000000323612620122474021214 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issueXXX - darcs remove corrupts the patch sequence ## ## 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 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" 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 darcs-2.10.2/tests/get_tag.sh0000644000175000017500000000254012620122474020033 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 < file < file </dev/null; then cat _darcs/patches/pending exit 1 fi fi cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/rebase-remote.sh0000644000175000017500000000347712620122474021165 0ustar00guillaumeguillaume00000000000000#!/bin/sh -e ## ## Test that remote operations on rebase-in-progress repos fail ## or 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 "add foo" echo '2' > foo darcs rec -am "change foo" echo yny | darcs rebase suspend cd .. not darcs get R1 R2 mkdir R3 cd R3 darcs init not darcs pull -a ../R1 2>&1 | grep "Cannot transfer patches from a repository where a rebase is in progress" cd .. mkdir R4 cd R4 darcs init cd ../R1 darcs push -a ../R4 cd ../R4 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 "add foo" bundle.dpatch not grep "change foo" bundle.dpatch cd .. darcs-2.10.2/tests/issue1057.sh0000644000175000017500000000275312620122474020074 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/push-dry-run.sh0000644000175000017500000000104212620122474020772 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./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 cd temp2 darcs init touch x darcs add x darcs record -am "test" cd .. chmod -R u-w temp2 cd temp2 # need to capture this failure so that we can still # chmod -R u+w the directory even if we fail darcsexit=0 darcs push --dry-run ../temp1 || darcsexit=$? cd .. chmod -R u+w temp2 # so that other scripts can cleanup if [ $darcsexit -ne 0 ]; then exit $darcsexit fi darcs-2.10.2/tests/check-read-only.sh0000644000175000017500000000311512620122474021365 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue2139-mv-to-dir.sh0000644000175000017500000000320212620122474021700 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/issue588.sh0000644000175000017500000000130012620122474020007 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # For issue588, "amend-record --look-for-adds end up with two "addfile" entries" . ./lib rm -rf temp1 darcs init --repodir temp1 # Setup f with contents foo. echo foo > temp1/f darcs add --repodir temp1 f darcs rec --repodir temp1 -am p1 # Remove f, and amend p1, but only the hunk not the rmfile. # Here we use look-for-adds to trigger the bug rm temp1/f echo yyd | darcs amend-record --repodir temp1 --look-for-adds darcs changes --repodir temp1 --last 1 -v echo show the buggy pending cat temp1/_darcs/patches/pending echo bar > temp1/f echo y | darcs amend-record --repodir temp1 --all darcs changes --repodir temp1 --last 1 -v darcs check --repodir temp1 rm -rf temp1 darcs-2.10.2/tests/rebase-basic.sh0000644000175000017500000000264212620122474020744 0ustar00guillaumeguillaume00000000000000#!/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 | grep-once "Rebase in progress: 1 suspended patch" not test -f wibble echo 'yy' | darcs rebase unsuspend | grep-once "Rebase finished" test -f wibble darcs-2.10.2/tests/mark-conflicts.sh0000644000175000017500000000144212620122474021335 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Automated tests for "darcs mark-conflicts". # The builtin ! has the wrong semantics for not. not () { "$@" && exit 1 || :; } mkdir temp1 cd temp1 darcs init echo "Conflict, Base ." > child_of_conflict darcs add child_of_conflict darcs record -am 'Conflict Base' cd .. darcs get temp1 temp2 # Add and record differing lines to both repos cd temp1 echo "Conflict, Part 1." > child_of_conflict darcs record -A author -am 'Conflict Part 1' cd .. cd temp2 echo "Conflict, Part 2." > child_of_conflict darcs record -A author -am 'Conflict Part 2' cd .. cd temp1 darcs pull -a ../temp2 > log grep conflict log grep 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 darcs-2.10.2/tests/issue2271-disable-patch-index.sh0000644000175000017500000000302412620122474023666 0ustar00guillaumeguillaume00000000000000#!/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. 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 not darcs optimize disable-patch-index 2>&1 | grep 'Could not delete patch index' cd ../ darcs-2.10.2/tests/issue257.sh0000644000175000017500000000052712620122474020012 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib 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 darcs-2.10.2/tests/convert_export.sh0000644000175000017500000000374612620122474021513 0ustar00guillaumeguillaume00000000000000#!/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.' 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 darcs-2.10.2/tests/optimize.sh0000644000175000017500000000032612620122474020261 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # tests for "darcs optimize" rm -rf temp1 mkdir temp1 cd temp1 darcs init touch foo darcs add foo darcs record -a -m add_foo darcs optimize reorder| grep -i "done" cd .. rm -rf temp1 darcs-2.10.2/tests/mv_then_add.sh0000644000175000017500000000064512620122474020675 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/failing-issue2303-diagnostic-for-bad-patch-index-permissions.sh0000644000175000017500000000334712620122474031703 0ustar00guillaumeguillaume00000000000000#!/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 ../ darcs-2.10.2/tests/issue525_amend_duplicates.sh0000644000175000017500000000067612620122474023376 0ustar00guillaumeguillaume00000000000000#!/bin/sh . ./lib ## I would use the builtin !, but that has the wrong semantics. not () { "$@" && exit 1 || :; } rm -rf temp1 mkdir temp1 cd temp1 darcs init echo first > a darcs add a darcs record -am 'first' echo replace first with something else > a darcs record -am 'mistake' echo first > a echo on second thought >> a echo ya | darcs amend-record -a darcs changes --last=1 -v > output cat output not grep first output cd .. rm -rf temp1 darcs-2.10.2/tests/show-bug.sh0000644000175000017500000000076012620122474020156 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/replace_after_pending_mv.sh0000644000175000017500000000035012620122474023420 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue844_gzip_crc.sh0000644000175000017500000000043612620122474021673 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init echo > a darcs add a darcs record a -a -m "init" cd .. mkdir temp2 cd temp2 darcs init darcs pull ../temp1 -a darcs optimize compress for f in _darcs/patches/*-*; do gzip -t < "$f" done rm -rf temp1 temp2 darcs-2.10.2/tests/issue2388-optimize-fails-no-changes.sh0000644000175000017500000000236212620122474025052 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2388 - optimize fails if no patches have been recorded ## ## 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 darcs optimize clean darcs-2.10.2/tests/tentative_revert.sh0000644000175000017500000000350112620122474022011 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for clearing tentative state after a failed transaction ## ## Copyright (C) 2009 Kamil Dworakowski ## ## 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 touch R/foo darcs record --repo R -lam 'foo' touch R/bar darcs record --repo R -lam 'bar' echo "this change should stay uncommitted" >> R/foo darcs setpref --repo R test false echo 'y' | not darcs amend --repo R -am 'change everything' R/foo --test darcs setpref --repo R test true # if tentative state was not cleared, the previous changes # from failed transaction would piggy back on the next echo "xx" >> R/bar echo 'y' | darcs amend --repo R -am 'bar2' R/bar --test # should have uncommitted changes darcs wh --repo R > changes grep "this change should stay uncommitted" changes darcs-2.10.2/tests/issue1726_darcs_always-boring.sh0000644000175000017500000000464112620122474024107 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1726 - Files whose names start with "_darcs" are considered ## boring, even if they don't match anything in the boring file, and even if ## you pass --boring to the command. ## ## Copyright (C) 2009 Daniel Dickison ## ## 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 ## First test expected failures with actual _darcs files/directories function bad_add { filename="$1" touch "$filename" not darcs whatsnew -ls --boring not darcs whatsnew -ls not darcs add --boring "$filename" } touch _darcs/foo bad_add _darcs bad_add _darcs/ bad_add _darcs/foo bad_add ./_darcs bad_add ./_darcs/ bad_add ./_darcs/foo bad_add "$PWD/_darcs" bad_add "$PWD/_darcs/" bad_add "$PWD/_darcs/foo" bad_add "../${PWD##*/}/_darcs" bad_add "../${PWD##*/}/_darcs/" bad_add "../${PWD##*/}/_darcs/foo" ## Then test expected successes with files that aren't in _darcs # Passing --boring should definitely succeed. touch _darcsfoo darcs whatsnew -ls --boring darcs add --boring _darcsfoo darcs record -am 'add _darcsfoo' _darcsfoo # Without --boring, this tests the default boring file. touch _darcsbar darcs whatsnew -ls darcs add _darcsbar darcs record -am 'add _darcsbar' _darcsbar darcs-2.10.2/tests/issue458.sh0000644000175000017500000000132012620122474020005 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ### http://bugs.darcs.net/issue458 ### darcs get --set-scripts-executable ignores umask . ./lib ## Windows doesn't support proper permissions. if echo $OS | grep -i windows; then echo Windows does not support posix permissions exit 0 fi rm -rf temp mkdir temp cd temp mkdir repo1 darcs initialize --repodir repo1 printf >repo1/x '#!/bin/sh\ntrue' # make a shebang'd script darcs record --repodir repo1 -lam x x umask 077 # DENY ALL access to group, all darcs get --set-scripts-executable repo1 repo2 # remove trailing-dot for xattr ls -l repo2/x | cut -f 1 -d\ | sed -e "s/\.$//" > mode echo -rwx------ > desired-mode diff -u desired-mode mode cd .. rm -rf temp darcs-2.10.2/tests/issue1873-apply-failed-to-read-patch.sh0000644000175000017500000000337212620122474025073 0ustar00guillaumeguillaume00000000000000#!/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 --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 darcs-2.10.2/tests/match-date.sh0000644000175000017500000001405412620122474020433 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 # Some tests for the '--match' flag, specifically the date-matching fmt_offset() { if date -d "now${1}days" >& /dev/null; then date -d "now${1}days" +"%Y%m%d" elif date -v ${1}d >& /dev/null; then date -v ${1}d +"%Y%m%d" else echo "Can't do date arithmetic on this system :(" >&2 return 1 fi } reset_repo () { cd .. rm -rf temp1 mkdir temp1 cd temp1 darcs init touch bar darcs add bar } create_entry () { echo $1 >> bar echo "$1/tester/a///" | tr / \\012 | darcs record -m "does not matter" --pipe bar } create_entry_now () { echo today >> bar darcs record -m "does not matter" bar -a -A tester } # parse_date just checks for parsing, while match_date checks for an actual match. # It's better if we can use "match_date", but we have to be able to construct such a date # based on a date dynamically generated by this test script. # alternately, it might be more useful to build a random date string generator # using QuickCheck... for any n random CalendarTimes, have it generate some # possible variants and roundtrip them to see if they match parse_date () { darcs changes --match "date \"$1\"" > log not grep fancy log } match_date () { darcs changes --match "date \"$1\"" > log grep tester log not grep fancy log } nomatch_date () { darcs changes --match "date \"$1\"" > log not grep tester log not grep fancy log } mkdir temp1 cd temp1 reset_repo # this block of dates should all refer to the same thing year=1973 mm=02 dd=04 hhmmss="15:08" create_entry "$year-$mm-$dd $hhmmss" match_date "$year-$mm-$dd" match_date "$year$mm$dd" match_date "$year-$mm" match_date "$year$mm" match_date "$year" # week dates. note that 2007 was selected as it starts on Monday reset_repo create_entry "2007-01-04 15:00" match_date '2007-W01-4' nomatch_date '2007-W01-1' match_date '2007W014' match_date '2007-W01' nomatch_date '2007-W02-1' create_entry "2007-01-08 15:00" match_date '2007-W02' match_date '2007-W02-1' create_entry "2007-05-20 15:00" match_date '2007-W20' nomatch_date '2007-W21' nomatch_date '2007-W19' # ordinal dates. eh... why not? match_date '2007-004'; # fourth day of 2007 match_date '2007004' nomatch_date '2007-005' # midnight and zero reset_repo create_entry "1992-10-15 00:00" match_date '1992-10-14 24:00' match_date '1992-10-15 00:00' # all the same date/time reset_repo create_entry "1992-02-12T22:32:11" match_date '1992-02-12T22:32:11' match_date '1992-02-12 22:32:11' match_date '1992-02-12T223211.0000' # english dates - the old hard coded from < darcs 1.0.6 reset_repo year=`date +%Y` mm=`date +%m` dd=`date +%d` hhmmss=`date +%k:%M:%S` tz=`date +%z` create_entry "$(($year-1))-$mm-$dd" nomatch_date 'today' nomatch_date 'yesterday' nomatch_date 'day before yesterday' nomatch_date 'last week' nomatch_date 'last month' # note: this test might fail if you run it just before midnight reset_repo create_entry_now match_date 'today' nomatch_date 'yesterday' nomatch_date 'day before yesterday' match_date 'last week' match_date 'last month' fmt_offset -1 || exit 200 reset_repo create_entry "$(fmt_offset -350)" # english dates - new possibilities nomatch_date 'yesterday at 14:00:00' match_date 'last 3 years' match_date 'last year' nomatch_date '2 days ago' nomatch_date 'last month 13:00' nomatch_date '3 days before last week' reset_repo create_entry_now match_date 'day after yesterday' match_date 'day since yesterday' match_date 'week after last week' match_date 'week since last week' create_entry "1992-10-02 00:15" match_date '15 minutes after 1992-10-02' match_date '15 minutes since 1992-10-02' reset_repo create_entry "1992-10-02 00:15+05" # note that earlier dates will always match match_date '15 minutes after 1992-10-02 00:00+05'; # same time match_date '15 minutes after 1992-10-01 23:00+04'; # same time match_date '15 minutes since 1992-10-02 00:00+05'; # same time match_date '15 minutes since 1992-10-01 23:00+04'; # same time nomatch_date '15 minutes after 1992-10-02 01:00+05'; # 1 hour later nomatch_date '15 minutes after 1992-10-02 00:00+04'; # 1 hour later nomatch_date '1 hour, 15 minutes after 1992-10-02 00:00+05'; # 1 hour later nomatch_date '15 minutes since 1992-10-02 01:00+05'; # 1 hour later nomatch_date '15 minutes since 1992-10-02 00:00+04'; # 1 hour later nomatch_date '1 hour, 15 minutes since 1992-10-02 00:00+05'; # 1 hour later match_date '1 hour, 15 minutes after 1992-10-02 00:00+06'; # same time match_date '1 hour, 15 minutes after 1992-10-01 23:00+05'; # same time match_date '1 hour, 15 minutes since 1992-10-02 00:00+06'; # same time match_date '1 hour, 15 minutes since 1992-10-01 23:00+05'; # same time reset_repo create_entry_now create_entry 1992-10-02 00:15 # english intervals nomatch_date 'between last fortnight and day before yesterday' match_date 'between last fortnight and today' match_date 'in the last 45 seconds' match_date 'after 1992' match_date 'since 1992' # iso 8601 intervals parse_date '1992-10-02 00:00Z/1992-10-02 00:16Z' match_date '1992-10-02 00:00/1992-10-02 00:16' match_date 'between 1992-10-02 00:00 and 1992-10-12 00:16' parse_date 'P3YT3M/1992' parse_date '1992/P3Y3M4DT5H3M2S' parse_date '1992/P3Y3M' # stuff from the manual reset_repo create_entry_now nomatch_date 'between 2004-03-12 and last week' match_date 'last week' parse_date 'yesterday' parse_date 'today 14:00' nomatch_date '3 days before last year at 17:00' # We can't in general parse the raw date output by darcs. If we change the # format to not include timezone information, this would be possible. But # maybe that's not desireable. For now, we just won't test the raw date. #match_date "$raw_date" parse_date 'after 2005' parse_date 'since 2005' parse_date 'in the last 3 weeks' parse_date 'P3M/2006-03-17' parse_date '2004-01-02/2006-03-17' parse_date 'P2M6D' # cvs dates parse_date '2006/01/19 21:14:20 UTC' # We can't handle all timezones in the old style dates # so this test will not work everywhere # match_date "$year/$mm/$dd $hhmmss $tz" reset_repo create_entry '2038-01-01' match_date 'after 2037' match_date 'since 2037' rm -rf temp1 temp2 darcs-2.10.2/tests/pull.sh0000644000175000017500000000672312620122474017404 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init cd .. mkdir 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 patches to pull in' echo -- darcs pull should pull into repo specified with --repo cd ../.. # now in temp2 darcs add one; darcs record --name uno --all cd .. # now outside of any repo darcs pull --set-default --repodir temp1 --all temp2 | grep -i 'Finished pulling.' # temp2 is not relative to temp1 # set up server repo date > temp2/one/date.t darcs add --repodir ./temp2 one/date.t 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 chmod a-rwx ./temp1/one # remove all permissions not darcs pull --repodir ./temp1 -a 2> err chmod u+rwx temp1/one # restore permission cat err grep 'permission denied' err rm -rf temp1/one fi cd temp1 echo Before trying to pull from self, defaultrepo is something else not grep temp1 _darcs/prefs/defaultrepo #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 not grep temp1 _darcs/prefs/defaultrepo rm -f _darcs/prefs/defaultrepo not darcs pull 2> err grep 'please specify one' err echo . > _darcs/prefs/defaultrepo not darcs pull --debug 2> err 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 cd temp1 echo a > foo darcs record -lam AA echo b > foo darcs record -lam BB echo c > foo darcs record -lam CC 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 darcs record -am unB darcs pull -a ../temp1 2> err2 not grep 'Error applying patch' err2 cd .. cd temp1 echo -n foo > baz darcs add baz darcs record -am newbaz cd ../temp2 darcs pull -a | grep Finished echo -n bar > baz darcs record -am bazbar cd ../temp1 darcs pull ../temp2 -a echo -n bar > correct_baz diff baz correct_baz cd .. # my $test_name = "when a patch creating a directory is attempted to be applied # while a directory with that name already exists, a warning is raised, but # the pull succeeds."; mkdir temp1/newdir cd temp1 darcs add newdir darcs record -am newdir cd ../temp2 mkdir newdir darcs pull -a --set-default ../temp1 &> out2 cat out grep Backing out2 grep 'Finished pulling' out2 grep newdir out2 cd .. rm -rf temp1 temp2 # A test for issue662, which triggered: # darcs failed: Error applying hunk to file ./t.t # Error applying patch to the working directory. rm -rf tmp; darcs init --darcs-1 --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 record -am 'remote change' --ignore darcs get . tmp2 cd tmp2 darcs obliterate --last 1 --all; echo 'content: local change'> t.t darcs pull -a ../ darcs w -s darcs revert -a cd ../.. rm -rf tmp darcs-2.10.2/tests/add.sh0000644000175000017500000000032112620122474017144 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 mkdir temp1 cd temp1 darcs init touch foo bar darcs add foo bar for (( i=0 ; i < 5; i=i+1 )); do echo $i >> file-$i; darcs add file-$i done cd .. rm -rf temp1 darcs-2.10.2/tests/issue1645-ignore-symlinks-case-fold.sh0000644000175000017500000000621212620122474025054 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1645 - Since Darcs does not version-contol symlinks, ## it should not follow them, ESPECIALLY symlinks to directories ## outside the repository. All these tests are passed with darcs-2.2 ## ## See path_resolution(7) and symlink(7) for more info, especially ## the former. ## ## This only covers the case-folding test cases. ## See also the issue1645-ignore-symlinks for the main test ## ## Copyright (C) 2010 Trent W. Buck, 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 S # Another script may have left a mess. darcs init --repo R # Create our test repos. darcs init --repo S add_to_boring() { echo "$1" >> _darcs/prefs/boring } ## These are the simple does-the-wrong-thing errors. cd R 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 rm cs-test cs-Test # move file and symlink out of the way for real tests # Case 15: case-folding link to non-recorded file 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 --patches="added ./non-recorded-file2" >>log 2>&1 # 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 grep -vE "(^ *$|^\+|No changes!)" log rm Recorded-File ReCorded-File darcs-2.10.2/tests/ignoretimes.sh0000644000175000017500000000110212620122474020737 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 mkdir temp1 cd temp1 darcs init echo -e 'foo\nbar\nbaz' > f 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 darcs wh > whatsnew grep 'foo' whatsnew # the problematic unpull darcs unpull --last 1 -a --ignore-times # whatsnew will now think there are no changes without --ignore-times darcs wh > whatsnew grep 'foo' whatsnew cd .. rm -rf temp1 darcs-2.10.2/tests/failing-issue1522_trailing_slash_borkage.sh0000644000175000017500000000241212620122474026245 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/issue1041.sh0000644000175000017500000000030012620122474020047 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue2253-make-patch-index-oldfashioned.sh0000644000175000017500000000247412620122474025645 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2253 - darcs changes FILE tries (and fails) to build a patch index ## on an oldfashioned repo ## ## 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 gunzip -c $TESTDATA/oldfashioned.tgz | tar xf - cd oldfashioned darcs changes x darcs-2.10.2/tests/issue2230-invalid-context-too-late.sh0000644000175000017500000000257312620122474024716 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2230 - darcs get --context checks the validity of the context ## file too late. ## ## 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 touch fake_context.txt not darcs get --context fake_context.txt R S # The get should fail, so we shouldn't have an S repo [[ ! -e S ]] darcs-2.10.2/tests/hunk-editor.sh0000644000175000017500000000310412620122474020647 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for hunk editor ## ## 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 R # Another script may have left a mess. darcs init --repo R cd R echo 'version1' > file darcs record -lam "version1" echo 'version2' > file echo eyny | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5" cat > expected < ## ## 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-status | 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-status | 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-status | grep 'Patch Index is in sync with repo.' # test amend-record darcs push -a ../S cd ../S darcs show patch-index-status | 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-status | 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-status | grep 'Patch Index is in sync with repo.' # test clone darcs pull -a ../S darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test pull darcs obliterate -p 'Add d/f and e.' -a darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test obliterate cd ../R darcs apply -a ../S/test.dpatch darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test apply darcs unrecord -a -p 'Change d/f' darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test unrecord darcs tag -m 'tag R' darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test tag cd .. rm -rf R S T darcs-2.10.2/tests/issue1344_abort_early_cant_send.sh0000644000175000017500000000461512620122474024473 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1344 - abort early darcs send if sendmail is not ## available ## ## Copyright (C) 2010 Gabriel Kerneis ## ## 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 # The mail sending code on Windows uses the MAPI API unconditionally # so this test fails. # 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 # Skip this test if sendmail is available if which sendmail ; then echo "Sendmail found (in path), skipping test." exit 200 fi if [ -f "/usr/sbin/sendmail" -o -f "/sbin/sendmail" -o \ -f "/usr/lib/sendmail" ]; then echo "Sendmail found, skipping test." exit 200 fi DARCS_EDITOR=echo export DARCS_EDITOR mkdir temp1 temp2 cd temp2 darcs init # setup test cd ../temp1 darcs init touch foo bar 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 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 || true) | grep "No working sendmail" cd .. darcs-2.10.2/tests/get.sh0000644000175000017500000000057012620122474017201 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue1101.sh0000644000175000017500000000117612620122474020060 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib DARCS_EDITOR=echo export DARCS_EDITOR export SENDMAIL=`which true` rm -rf temp1 temp2 mkdir temp1 temp2 cd temp2 darcs init # setup test cd ../temp1 darcs init touch foo bar darcs add foo bar darcs record -a -m add_foo_bar -A x # Test that --cc is also printed as recipient in case of success darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com # Test that --cc is also printed as recipient in case of error darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/record-interactive.sh0000644000175000017500000000050312620122474022207 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/diff.sh0000644000175000017500000000076312620122474017336 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 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 temp-$$ darcs-2.10.2/tests/issue174_obliterate_before_a_tag.sh0000644000175000017500000000071112620122474024672 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # issue174: behave better when we want to obliterate a patch that comes before a tag. . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init # Setup: Create a patch, a tag and another patch. touch a.txt darcs add a.txt darcs record -am 'adding a' a.txt darcs tag "first tag"; touch b.txt darcs add b.txt darcs record --ignore-time -a -m 'adding b' b.txt darcs obliterate -p "adding a" -a > log not grep "no patch" log cd .. rm -rf temp1 darcs-2.10.2/tests/revert_interactive.sh0000644000175000017500000000201112620122474022316 0ustar00guillaumeguillaume00000000000000#!/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 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 < foo echo "nyy" | darcs revert DARCS_DONT_COLOR=1 darcs wh > whatsnew cat > correct < 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 <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 --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 --sendmail-command '../dummy-sendmail %<' ../R/patch-set1 || :; [ -f ./message ] || exit 1 darcs-2.10.2/tests/issue2333.sh0000644000175000017500000000067112620122474020067 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2333 - . lib # Load some portability helpers. require_ghc 706 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 .. darcs-2.10.2/tests/show-removed-file.sh0000644000175000017500000000353512620122474021762 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/dist.sh0000644000175000017500000000130012620122474017355 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # run darcs dist, then extract the resulting archive # and compare it to the original repository content . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init for (( i=0 ; i < 5; i=i+1 )); do echo $i >> file-$i; mkdir dir-$i; echo $i >> dir-$i/file-$i; darcs add file-$i; darcs add dir-$i/file-$i done darcs record -a -m add_foo | grep -i "finished recording" darcs dist darcs dist --zip mv temp1.tar.gz .. mv temp1.zip .. cd .. rm -rf temp1/_darcs mv temp1 temp_orig tar xzf temp1.tar.gz diff -r 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 darcs-2.10.2/tests/pull_two.sh0000644000175000017500000000073012620122474020265 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # This test script, originally written by David Roundy is in the public # domain. . ./lib 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 darcs-2.10.2/tests/issue885_get_to_match.sh0000644000175000017500000000126612620122474022537 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/add-formerly-pl.sh0000644000175000017500000000267612620122474021431 0ustar00guillaumeguillaume00000000000000#!/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 -v foo.d 2>&1 | grep -i directory # Try adding the same directory when it's already in the repo not darcs add -v 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 -v bar 2>&1 | grep -i "following file is" not darcs add -v bar baz 2>&1 | grep -i "following files are" # Make sure that messages about both files and directories say so not darcs add -v 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 -v 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 -v 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 -v notadir/notafile 2>&1 | grep -i 'does not exist' cd .. rm -rf temp1 darcs-2.10.2/tests/issue2248-rebase-zero-suspended.sh0000644000175000017500000000304112620122474024272 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/apply-hunks.sh0000644000175000017500000000155612620122474020702 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/failing-issue2186-apply--reply-ok.sh0000644000175000017500000000373212620122474024445 0ustar00guillaumeguillaume00000000000000#!/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 --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 --sendmail-command '../dummy-sendmail %<' ../R/patch-set1 [ -f ./message ] || exit 1 darcs-2.10.2/tests/issue1012_unrecord_remove.sh0000644000175000017500000000047312620122474023336 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 changes darcs unrecord -p "rm File" -a darcs changes darcs record -a -m "re-rm File" cd .. rm -rf temp1 darcs-2.10.2/tests/bad-format.sh0000644000175000017500000000134212620122474020434 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 temp2 gunzip -c $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf - mv many-files--old-fashioned-inventory temp1 echo '' > temp1/_darcs/format # ensure that we successfully get repositories even if they have a bogus # format file, as can happen if no _darcs/format is present (i.e. it's # generated by an older darcs) and an http server fails to produce a 404 # error code. This is issue757. darcs get temp1 temp2 echo intentional-error >> temp2/_darcs/format cat temp2/_darcs/format rm -rf temp1 not darcs get temp2 temp1 2> err cat err grep intentional-error err grep 'understand repository format' err rm -rf temp1 temp2 darcs-2.10.2/tests/issue1139-diff-last.sh0000644000175000017500000000064512620122474021742 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp-$$ mkdir temp-$$ cd temp-$$ 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-$$ darcs-2.10.2/tests/issue1427_apply_gz.sh0000644000175000017500000000122712620122474021775 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue2270-changes-interactive-only-to-files.sh0000644000175000017500000001034312620122474026504 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2270 - ## darcs changes 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 changes -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 changes -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 changes -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 changes -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 changes -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 changes -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 changes -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 changes -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 changes -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 changes -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 changes -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 changes -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 darcs-2.10.2/tests/addrm.sh0000644000175000017500000000041212620122474017504 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue2209-look_for_replaces.sh0000644000175000017500000001577712620122474023574 0ustar00guillaumeguillaume00000000000000#!/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 < 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 < file darcs record -al -m "add file" echo "bar" > file darcs whatsnew --look-for-replaces 2>&1 > log cat > log.expected < 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 < 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 < file darcs record -al -m "add file" echo "bar foo" > file darcs whatsnew --look-for-replaces > log cat > log.expected < file < file <&1 | tail -n +4 | grep -v "^ {\| }$" > log cat > log.expected < file < file < file <&1 | tail -n +4 | grep -v "^ {\| }$" > log cat > log.expected < file < file <&1 > log cat > log.expected < file < file <&1 | tail -n +4 | grep -v "^ {\| }$" > log cat > log.expected < file < file <&1 | tail -n +4 | grep -v "^ {\| }$" > log cat > log.expected < file < file <&1 > log cat > log.expected < file < file <&1 > log cat > log.expected < file < file <&1 > log cat > log.expected < foo darcs add foo darcs record -a -m 'foo' foo for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16; do cat foo foo > foo2; mv foo2 foo; done darcs what cd .. darcs-2.10.2/tests/pull-dont-prompt-deps.sh0000644000175000017500000000131612620122474022607 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # Check that the right patches get pulled 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 cd ../temp2 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 not grep bar toto cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue1875-honor-no-set-default.sh0000644000175000017500000000314512620122474024050 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1875 - corner cases in which darcs may accidentally ## set default even though it's not supposed to ## ## 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. darcs get R S --no-set-default not find S/_darcs/prefs/defaultrepo rm -rf S darcs init --repo S cd S darcs push ../R --dry-run not grep '/R$' _darcs/prefs/defaultrepo darcs push ../R cd .. darcs-2.10.2/tests/unrecord-remove.sh0000644000175000017500000000052012620122474021531 0ustar00guillaumeguillaume00000000000000#!/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 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 darcs-2.10.2/tests/tag.sh0000644000175000017500000000043512620122474017175 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib # Some tests for 'darcs tag' rm -rf temp1 log mkdir temp1 cd temp1 darcs init touch one darcs add one darcs record --name 'uno' --all darcs tag soup > log not grep failed log grep TAG log darcs changes --last 1 > log grep tagged log cd .. rm -rf temp1 log darcs-2.10.2/tests/failing-issue2256-diff-empty-argument.sh0000644000175000017500000000266412620122474025370 0ustar00guillaumeguillaume00000000000000#!/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 ]] darcs-2.10.2/tests/unrevert.sh0000644000175000017500000000043012620122474020267 0ustar00guillaumeguillaume00000000000000#!/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 add -A x echo goodbye world >> foo cp foo bar darcs revert -a darcs show contents foo | cmp foo - darcs unrevert -a cmp foo bar cd .. rm -rf temp1 darcs-2.10.2/tests/issue1162_add_nonexistent_slash.sh0000644000175000017500000000026412620122474024524 0ustar00guillaumeguillaume00000000000000#!/bin/sh . ./lib 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 darcs-2.10.2/tests/bad_pending_after_pull.sh0000644000175000017500000000143412620122474023071 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 not darcs whatsnew 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 not darcs whatsnew cd .. rm -fr temp1 temp2 darcs-2.10.2/tests/remove.sh0000644000175000017500000000343012620122474017715 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## ## Copyright (C) 2009 Roman Plasil ## ## 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 d e # Change the working tree. mkdir d/f d/f/g echo 'Example content.' > d/f/1.txt echo 'Example content.' > d/f/g/2.txt echo 'Example content.' > e/3.txt darcs add -r . darcs wh -s > before.lst grep -i d before.lst grep -i e before.lst grep -i d/f before.lst darcs remove -r d darcs wh -s > after.lst not grep -i d after.lst not grep -i d/f after.lst not grep -i d/f/g after.lst not grep -i d/f/g/2.txt after.lst not grep -i d/f/1.txt after.lst cd .. darcs-2.10.2/tests/rebase-pull-tag.sh0000644000175000017500000000306712620122474021412 0ustar00guillaumeguillaume00000000000000#!/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 :-( darcs-2.10.2/tests/issue2225-obliterate-not-in.sh0000644000175000017500000000342112620122474023415 0ustar00guillaumeguillaume00000000000000#!/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 ]] darcs-2.10.2/tests/issue1266_init_inside_a_repo.sh0000644000175000017500000000300712620122474023772 0ustar00guillaumeguillaume00000000000000#!/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. darcs-2.10.2/tests/issue1210-no-global-cache-in-sources.sh0000644000175000017500000000255412620122474025060 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1210 - 'global cache gets recorded in _darcs/prefs/sources' ## ## 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 cacheDir=$HOME/.darcs/cache rm -rf R S darcs init --repo R darcs get R S not grep "$cacheDir" S/_darcs/prefs/sources not grep "cache:" S/_darcs/prefs/sources darcs-2.10.2/tests/send.sh0000644000175000017500000000343112620122474017352 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib DARCS_EDITOR=echo export DARCS_EDITOR rm -rf temp1 temp2 mkdir temp1 temp2 cd temp2 darcs init # setup test cd ../temp1 darcs init touch foo bar darcs add foo bar darcs record -a -m add_foo_bar -A x # Test that a default preference value is not needed to send darcs send --author=me -a --to=random@random --sendmail-command='grep "^To: random@random$" %<' ../temp2 # Test that a default preference will be used when no --to value is specified echo "default@email" > ../temp2/_darcs/prefs/email darcs send --author=me -a --sendmail-command='grep "^To: default@email$" %<' ../temp2 # Test that the --to parameter overrides the default value in the repository darcs send --author=me -a --to=override@default --sendmail-command='grep "^To: override@default$" %<' ../temp2 darcs send --author=me -a --in-reply-to=some-thread-id --sendmail-command='grep "^In-Reply-To: some-thread-id$" %<' ../temp2 darcs send --author=me -a --in-reply-to=some-thread-id --sendmail-command='grep "^References: some-thread-id$" %<' ../temp2 # Test that the --subject parameter sets the subject # 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 # 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 # 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 cd .. cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/failing-issue1829-inconsistent-conflictor.sh0000644000175000017500000000374412620122474026371 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Leads darcs into creating an inconsistent conflictor. ## Public Domain, 2010, Ganesh Sittampalam, Ian Lynagh and 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 rm -rf r1 r2 mkdir r1 cd r1 darcs init echo Line BB > file darcs add file darcs rec -a -m "Main patch 1" echo Line DDDD >> file darcs rec -a -m "Main patch 2" echo Line A > file echo Line BB >> file echo Line CCC >> file echo Line DDDD >> file echo Line EEEEE >> file darcs rec -a -m "Main patch 3" cd .. mkdir r2 cd r2 darcs init darcs pull -a -p "Main patch 1" ../r1 echo Line TTTTTTT >> file darcs rec -a -m "Alternate patch 1" darcs pull -a -p "Main patch 2" ../r1 darcs revert -a echo Line XXXXXXXXX >> file darcs rec -a -m "Alternate patch 2" echo Line XXXXXXXXX > file darcs rec -a -m "Alternate patch 3" cd .. cd r1 darcs pull -a ../r2 darcs-2.10.2/tests/README.test_maintainers.txt0000644000175000017500000000007712620122474023136 0ustar00guillaumeguillaume00000000000000Please consult . darcs-2.10.2/tests/failing-issue2213-lastregrets-dependencies.sh0000644000175000017500000000270012620122474026447 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/issue2447-show-content-of-removed-file.sh0000644000175000017500000000360712620122474025503 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2447 - get contents of deleted file ## ## 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 echo 'example content' > f darcs add f darcs record -am '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 add d/f darcs record -am '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' darcs-2.10.2/tests/issue2312_posthooks_for_record_and_amend-record_should_receive_DARCS_PATCHES.sh0000644000175000017500000000602312620122474035003 0ustar00guillaumeguillaume00000000000000#!/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 # Load some portability helpers. # passing environment variables to posthooks isn't supported at # all in Windows abort_windows # even though the test doesn't work on Windows at the moment, # might as well future proof it by using a Haskell program instead # of a script for the post hook. cat < echo_darcs_patches.hs # create a posthoook that echos $DARCS_PATCHES import System.Environment main = do [outFile] <- getArgs darcsPatches <- getEnv "DARCS_PATCHES" writeFile outFile (darcsPatches ++ "\n") FAKE ghc --make -o echo_darcs_patches echo_darcs_patches.hs ECHO_DARCS_PATCHES=`pwd`/echo_darcs_patches 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="$ECHO_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="$ECHO_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="$ECHO_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="$ECHO_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="$ECHO_DARCS_PATCHES out" not grep msg1 out not grep msg2 out not grep msg3 out not grep "M ./new.file" out cd .. rm -rf R darcs-2.10.2/tests/issue1043_geteff_a.sh0000644000175000017500000000211312620122474021675 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 # creating the fork point mkdir temp1 cd temp1 darcs init cat > foo << FOO original - apple original - banana FOO darcs add foo darcs record -am init cd .. darcs get temp1 temp2 # do some work in the mainline cd temp1 cat > foo << FOO conflict 1 - artichoke original - banana FOO darcs record -am 'conflict 1a' cat > foo << FOO conflict 1 - artichoke conflict 1 - brocolli FOO darcs record -am 'conflict 1b' cd .. # do some work in the branch cd temp2 cat > foo << FOO conflict 2 - aardvark original - banana conflict 2 - cougar FOO darcs record -am 'conflict 2' cd .. # in the branch, pull from the mainline and resolve the conflict cd temp2 darcs pull -a ../temp1 --allow-conflicts cat > foo << FOO resolution original - apple original - banana FOO darcs record -am 'resolve conflicts 2,1a,1b' cd .. # do some extra work in the mainline cd temp1 cat > foo << FOO original - apple FOO darcs record -am 'conflict 1c' cd .. # in the branch, pull from the mainline again cd temp2 darcs pull -a ../temp1 --allow-conflicts cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue1039.sh0000644000175000017500000000242012620122474020063 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib # pull from not empty repo to empty repo rm -rf temp1 temp2 mkdir temp1 temp2 cd temp1 darcs init echo a > a darcs add a darcs record --all --name=a cd ../temp2 darcs init darcs pull --all --dont-allow-conflicts ../temp1 test `darcs changes --count` = "1" cd .. # push from not empty repo to empty repo rm -rf temp1 temp2 mkdir temp1 temp2 cd temp1 darcs init cd ../temp2 darcs init echo a > a darcs add a darcs record --all --name=a darcs push --all ../temp1 cd ../temp1 test `darcs changes --count` = "1" cd .. # send from not empty repo to not empty repo rm -rf temp1 temp2 mkdir temp1 temp2 cd temp1 darcs init echo a > a darcs add a darcs record --all --name=a for i in 1 2 3 4 5 6 7 8 9; do echo Change number $i >> a darcs record -a -m "change a $i" done cd ../temp2 darcs init echo b > b darcs add b darcs record --all --name=b for i in 1 2 3 4 5 6 7 8 9; do echo Change number $i >> b darcs record -a -m "change b $i" done 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 darcs-2.10.2/tests/amend.sh0000644000175000017500000000366312620122474017514 0ustar00guillaumeguillaume00000000000000#!/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 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 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 darcs-2.10.2/tests/look_for_add.sh0000644000175000017500000000133512620122474021044 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash cat > empty_pending < 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 cd ../temp2 darcs init darcs pull -a ../temp1 cd .. cmp temp1/dir2/foo2 temp2/dir2/foo2 cmp temp1/dir/foo temp2/dir/foo cmp temp1/foo temp2/foo rm -rf temp1 temp2 darcs-2.10.2/tests/issue595_get_permissions.sh0000644000175000017500000000253412620122474023311 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Issue595 # # A test for running "darcs get" when the parent directory has restrictive # permissions. The bug is that darcs trys to "chdir" to the current directory # using the full path. The permissions on the parent directory prevent this # from working, even though the current repo and the remote have sufficient # permissions. # # The real-world case where this would happen would be a web-server with # restrictive permissions on "/home", with a user running darcs within that. . lib abort_windows rm -rf temp1 temp2 # Set up a "remote" repo mkdir tmp_remote cd tmp_remote darcs 'init' cd .. DIR=`pwd` # Set up a directory with restrictive permissions mkdir -p tmp_restrictive/liberal cd tmp_restrictive/liberal chmod 0111 ../../tmp_restrictive # 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 darcs-2.10.2/tests/push-dont-prompt-deps.sh0000644000175000017500000000130212620122474022605 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # 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 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 darcs-2.10.2/tests/failing-issue1610_get_extra.sh0000644000175000017500000000413412620122474023533 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1610 - another bug in get_extra problem ## This is an offshoot of the issue1609 test ## ## Copyright (C) 2009 Eric Kow ## Copyright (C) 2009 Pascal Molli ## ## 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. #pragma repo-format darcs-1 . lib # Load some portability helpers. # this test is not relevant for darcs 2 repositories (not grep darcs-2 $HOME/.darcs/defaults) || exit 200 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 .. # please compare this with the issue1609 test darcs pull -a --repo S1 S2 darcs pull -a --repo S1 S3 darcs pull -a --repo S2 S1 darcs pull -a --repo S2 S3 darcs-2.10.2/tests/hidden_conflict.sh0000644000175000017500000000066412620122474021542 0ustar00guillaumeguillaume00000000000000#!/bin/sh . ./lib rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init --darcs-2 echo first > a darcs add a darcs record -am 'first' cd .. darcs get temp1 temp2 cd temp1 echo second > a darcs record -am 'first to second' echo first > a darcs record -am 'second back to first' cd .. cd temp2 echo third > a darcs record -am 'first to third' cd .. cd temp1 darcs pull -a ../temp2 | grep conflict grep third a cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/addexitval.sh0000644000175000017500000000076112620122474020551 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 $nonempty stdout # print confirmation message of added file $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 darcs-2.10.2/tests/rmconflict.sh0000644000175000017500000000054512620122474020564 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf tempA tempB mkdir tempA tempB cd tempA darcs init touch foo darcs add foo darcs record -a -m addA -A x cd ../tempB darcs init darcs pull -a ../tempA darcs remove foo # rm foo darcs record -a -m rmB -A x cd ../tempA darcs remove foo darcs record -a -m rmA -A x cd ../tempB darcs pull -a ../tempA cd .. rm -rf tempA tempB darcs-2.10.2/tests/addrace.sh0000644000175000017500000000037412620122474020007 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue1727_move_current_directory.sh0000644000175000017500000000365212620122474024753 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1727 - darcs move . target' fails as an attempt to ## write an 'invalid pending. ## ## Copyright (C) 2009 Sean Erle Johnson ## ## 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. # Create repository R darcs init --repo R # Create the test repo. cd R mkdir d # Change the working tree. # darcs move empty current directory to existing directory d not darcs move . d # darcs move empty current directory to non-existing directory e not darcs move . e # Make file to be copied echo 'main = putStrLn "Hello World"' > hello.hs # darcs move non-empty current directory to existing directory d not darcs move . d # darcs move non-empty current directory to non-existing directory e not darcs move . e mkdir e cd e not darcs move .. edarcs-2.10.2/tests/repair-clean.sh0000644000175000017500000000050112620122474020756 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/hidden_conflict2.sh0000644000175000017500000000153012620122474021615 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./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 .. # set up temp1 cd temp1 cat > A << FOO i m b v FOO darcs add A darcs record -m 'add' --all cd .. # set up temp2 cd temp2 darcs pull --all ../temp1 cat > A << FOO J i C2 m D b v FOO darcs record -m 'change2' --all cd .. # generate a conflict cd temp1 cat > A << FOO I i C1 m b FOO darcs record -m 'change1' --all darcs pull --all ../temp2 # we should have a marked conflict now. grep 'v v' A # we resolve it simply by removing conflict markers. sed -e '/\^ \^\|\*\*\|v v/d' A > temp mv temp A darcs record -m resolution --all # now mark-conflicts shouldn't find any unmarked conflicts darcs mark-conflicts | grep "No conflicts to mark" cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/failing-index-argument.sh0000644000175000017500000000324612620122474022763 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Currently tests if --index works on every command that is supposed to ## support it. The information about what command should support --index is ## taken from http://darcs.net/manual/Darcs_commands.html ## ## Copyright (C) 2011 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 # Load some portability helpers. rm -rf temp mkdir -p temp cd temp darcs init touch a 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 show contents --index 1 a #### failing tests darcs show files --index 1 a darcs dist --index 1 darcs-2.10.2/tests/printer.sh0000644000175000017500000001035312620122474020105 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Some tests for 'darcs printer (the output formating)' . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init touch a darcs add a darcs rec -a -m add env # clear all output formating environment variables for e in DARCS_DONT_ESCAPE_ISPRINT DARCS_USE_ISPRINT\ DARCS_DONT_ESCAPE_8BIT\ DARCS_DONT_ESCAPE_EXTRA DARCS_ESCAPE_EXTRA\ DARCS_DONT_ESCAPE_TRAILING_SPACES\ DARCS_DONT_COLOR DARCS_ALWAYS_COLOR DARCS_ALTERNATIVE_COLOR\ DARCS_DONT_ESCAPE_ANYTHING; do unset $e done env # make sure the locale is c export LC_ALL=C test_line () { rm -f a echo $1 > a darcs whatsnew | fgrep $2 } # First check escaping and coloring. Use whatsnew, since that is the # most common use of escapes. # test the defaults # - no color to pipe # - don't escape 7-bit ASCII printables, \n,\t and space (we can't test \n) # - escape control chars with ^ # - escape other chars with \xXX test_line " !#%&',-0123456789:;<=>"\ " !#%&',-0123456789:;<=>" test_line "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"\ "ABCDEFGHIJKLMNOPQRSTUVWXYZ_" test_line "\`abcdefghijklmnopqrstuvwxyz"\ "\`abcdefghijklmnopqrstuvwxyz" test_line "\t\"\$()*+./?\@[\\]^{|}"\ "\t\"\$()*+./?\@[\\]^{|}" # 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 '\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') '[_^[_]' test_line $(printf '\x1C') '[_^\_]' test_line $(printf '\x1D') '[_^]_]' test_line $(printf '\x1E') '[_^^_]' test_line $(printf '\x1F') '[_^__]' test_line $(printf '\x7F') '[_^?_]' # other chars are escaped with test_line $(printf '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF')\ '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' rm -rf temp1 darcs-2.10.2/tests/pending.sh0000644000175000017500000000106212620122474020043 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp temp_0 mkdir temp cd temp darcs init date > bla darcs add bla darcs record -a --name=11 echo hello > world darcs add world darcs whatsnew --dont-look-for-adds > wn1 cd .. darcs get temp cd temp_0 date > bla2 date >> bla darcs add bla2 darcs record -a --name=22 darcs push -a ../temp cd .. cd temp darcs whatsnew --dont-look-for-adds > wn2 diff wn1 wn2 darcs record -a -m 'cleaning up for new test.' date > foo.jpg darcs add foo.jpg darcs whatsnew darcs remove foo.jpg darcs whatsnew && exit 1 cd .. rm -rf temp temp0 darcs-2.10.2/tests/pull-reorder.sh0000644000175000017500000000226712620122474021043 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/issue1879-same-patchinfo-uncommon.sh0000644000175000017500000000166312620122474024634 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1879 - we should at least notice that when a patch claims ## to have the same identity (patchinfo) as one of ours, then it should not ## depend on anything we don't have. ## ## Public domain - 2010 Eric Kow . 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 touch x1 darcs add x1 darcs record -am 'x1' darcs changes --context > ctx echo hello > f echo world > x1 darcs add f darcs record -am 'hello world' darcs send -a --context ctx -o foo.dpatch ../S cd .. cd S touch x2 darcs add x2 darcs record -am 'x2' darcs changes --context > ctx # create an evil wrong patch sed -e '/Context:/,$d' -e 's/x1/x2/g' ../R/foo.dpatch > foo.dpatch cat ctx >> foo.dpatch darcs apply foo.dpatch cd .. cd R not darcs pull -a ../S 2>&1 | tee log cd .. darcs-2.10.2/tests/rebase-amend.sh0000644000175000017500000000263512620122474020751 0ustar00guillaumeguillaume00000000000000#!/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 checkdarcs-2.10.2/tests/failing-issue1190_unmarked_hunk_replace_conflict.sh0000644000175000017500000000343512620122474027766 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1190 - conflicts between HUNK and REPLACE are not ## marked by --mark-conflicts. ## ## 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 d e # Another script may have left a mess. darcs init --repo d/ printf %s\\n foo bar baz >d/f darcs record --repo d/ -lam f1 darcs get d/ e/ darcs replace --repo e/ --force bar baz f darcs record --repo e/ -lam replacement printf %s\\n foo bar quux >d/f # replace baz with quux darcs record --repo d/ -am f2 ## There ought to be a conflict here, and there is. darcs pull --repo e/ d/ -a --mark-conflicts ## The file ought to now have conflict markers in it. grep 'v v v' e/f rm -rf d/ e/ # Clean up after ourselves. darcs-2.10.2/tests/issue1987.sh0000644000175000017500000001732512620122474020111 0ustar00guillaumeguillaume00000000000000#!/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: # 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: # 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: # 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018 INV_DIR_AFTER_RECORD=$(ls -1 $INV_DIR) darcs tag -m 'Add f.' # $INV_DIR_AFTER_FST_TAG should looks like: # 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: # 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) [ "$INV_DIR_AFTER_OPTIMIZE" == "$INV_DIR_AFTER_RECORD" ] 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 copy 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 Rdarcs-2.10.2/tests/issue1932-colon-breaks-add.sh0000644000175000017500000000605612620122474023201 0ustar00guillaumeguillaume00000000000000#!/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@invalid:path || true ) > log 2>&1 [ -n "$(fgrep 'ssh: Could not resolve hostname invalid: Name or service not known' log)" ] # HTTP repo ( darcs get http://www.bogus.domain.so.it.will.surely.fail.com || true ) 2>&1 | tee log egrep 'CouldNotResolveHost|host lookup failure' log abort_windows # Windows doesn't support ':' in filenames at all # 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 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@invalid:path' log)" ] [ -n "$(grep '^A \./funny/droundy@invalid:' log)" ] [ -n "$(grep '^A \./funny/invalid:path' log)" ] darcs-2.10.2/tests/optimize_relink.sh0000644000175000017500000000253512620122474021631 0ustar00guillaumeguillaume00000000000000 #!/usr/bin/env bash # For issue600, testing optimize --relink . ./lib ## We don't support hard links on Windows. if echo $OS | grep -i windows; then echo darcs does not support hard links on Windows exit 0 fi ## compare succeeds if there are hard links compare () { echo 'use File::Basename; $res=0; while ($fn=<'$1'/*>) { $fn2="'$2'/" . basename($fn); @fd1=lstat($fn); @fd2=lstat($fn2); $res += ($fd1[1] != $fd2[1]);}; exit($res);' | perl } rm -rf temp mkdir temp cd temp mkdir x darcs init --repodir x cd x date > foo darcs add foo darcs record -a -A me -m 'addfoo' cd .. ## Does the filesystem support hard linking at all? mkdir z1 echo "hi" > z1/foo mkdir z2 if ! ln z1/foo z2/foo ; then echo No ln command for `pwd` - assuming no hard links. exit 0 fi if ! compare z1 z2 ; then echo Filesystem for `pwd` does not support hard links. exit 0 fi # workaround for SunOS cp which does not support `-a' option but also # doesn't fail when it is encountered. cp -r x y ## Now try relinking using darcs. rm -rf z 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 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 cd .. rm -rf temp darcs-2.10.2/tests/v1-braced.sh0000644000175000017500000000320112620122474020160 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for correct handling of Darcs v1 patches with nested { } ## ## 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. #pragma repo-format darcs-1 . lib # Load some portability helpers. grep darcs-1 $HOME/.darcs/defaults || exit 200 rm -rf braced gunzip -c $TESTDATA/braced.tgz | tar xf - cd braced darcs check cd .. rm -rf empty mkdir empty cd empty darcs init darcs apply $TESTDATA/braced.dpatch cd .. cd braced darcs pull -a ../empty | grep 'No remote patches to pull in' cd ../empty darcs pull -a ../braced | grep 'No remote patches to pull in' darcs-2.10.2/tests/failing-newlines.sh0000644000175000017500000000071412620122474021655 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 # set up the repository mkdir temp1 cd temp1 darcs init cd .. cd temp1 echo -n "from temp1" > one.txt darcs add one.txt darcs record -A bar -am "add one.txt" echo >> one.txt cd .. darcs get temp1 temp2 cd temp2 echo "in tmp2" >> one.txt darcs record -A bar -am "add extra line" lines_added=`darcs changes -a -v --last=1 | grep '\+' | wc -l` echo $lines_added test $lines_added -eq 1 cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue27.sh0000644000175000017500000000130112620122474017714 0ustar00guillaumeguillaume00000000000000#!/bin/sh . ./lib rm -rf temp1 temp2 mkdir temp1 temp2 cd temp1 darcs init echo first > a darcs add a darcs record --pipe --all --name=first < b darcs add b darcs record --pipe --all --name=first <> a darcs record --pipe --all --name=second <> b darcs record --pipe --all --name=second < 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 darcs-2.10.2/tests/failing-issue2219-no-working.sh0000644000175000017500000000436512620122474023575 0ustar00guillaumeguillaume00000000000000#!/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 ] # 2011-12-27: unclear on what should happen here mkdir S1 cd S1 darcs init --no-working-dir echo "bonjour" > a darcs add a darcs record -a -m 'a file' a cd .. # --no-working-dir --working-dir flags should trump each other in the # same fashion as the rest of darcs # ## 2011-12-27: fails darcs get --no-working-dir --with-working-dir R1 R3 test -e R3/a darcs get --with-working-dir --no-working-dir R1 R4 test ! -e R4 darcs-2.10.2/tests/failing-issue1317_list-options_subdir.sh0000644000175000017500000000257312620122474025576 0ustar00guillaumeguillaume00000000000000#!/bin/sh # Test for issue1317 - darcs mv --list-options returns results from root, and # not from the current directory # Copyright 2009 Marco Túlio Gontijo e Silva # 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 abcd mkdir foo darcs add foo cd foo touch abcc mkdir bar darcs mv --list-options | grep -x abcc cd ../.. rm -rf R darcs-2.10.2/tests/failing-issue1316-2.sh0000644000175000017500000000334512620122474021636 0ustar00guillaumeguillaume00000000000000#!/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. 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-rec -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 darcs-2.10.2/tests/latin9-input.sh0000644000175000017500000001550512620122474020763 0ustar00guillaumeguillaume00000000000000#!/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 # This test clobbers the global darcs author -f $HOME/.darcs/author && exit 200 rm -rf temp1 mkdir temp1 cd temp1 darcs init # Test recording non-UTF-8-encoded non-latin1 ("funny") metadata from # interactive input echo 'Selbstverstndlich berraschend' > something.txt darcs add something.txt echo 'l33tking0r@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 'Jrme Lebuf' -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 allerberraschendsten' >> something.txt echo 'darcs is soms wat naef aangaande tekstcodering' > log.txt echo 'en zulke naviteit is tegenwoordig pass, aldus iek' >> log.txt darcs record -a -A 'Jrme Lebuf' --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 iek ' rm $HOME/.darcs/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 < 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 DARCS_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 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 $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 darcs tag -A Ade -m 'Lat 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 darcs-2.10.2/tests/failing-issue2380-rename-to-deleted-file.sh0000644000175000017500000000327012620122474025704 0ustar00guillaumeguillaume00000000000000#!/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 && $( expected darcs wh > actual diff expected actual darcs rev -a [[ -e foo && -e other && $(> 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 darcs-2.10.2/tests/issue1290-diff-index.sh0000644000175000017500000000352112620122474022100 0ustar00guillaumeguillaume00000000000000#!/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' # 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 .. darcs-2.10.2/tests/issue706.sh0000644000175000017500000000037112620122474020006 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # for issue706: "Filenames with spaces issue" DARCS_EDITOR=echo export DARCS_EDITOR rm -rf temp mkdir temp cd temp darcs init touch 'A B' darcs add 'A B' darcs rec -a -m 'a b' -A me ls darcs check cd .. rm -rf temp darcs-2.10.2/tests/justrm.sh0000644000175000017500000000025412620122474017745 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue1139-diff-with-no-args.sh0000644000175000017500000000054212620122474023312 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp-$$ mkdir temp-$$ cd temp-$$ 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-$$ darcs-2.10.2/tests/rebase-move.sh0000644000175000017500000000316212620122474020627 0ustar00guillaumeguillaume00000000000000#!/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" --ignore-times echo 'wobble' > wibble darcs rec -am"wobble" --ignore-times 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 # | not grep "We have conflicts" not darcs wh darcs-2.10.2/tests/whatsnew-pending.sh0000644000175000017500000000324512620122474021706 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Ensure that darcs whatsnew 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 .. darcs-2.10.2/tests/failing-issue1401_bug_in_get_extra.sh0000644000175000017500000000364012620122474025055 0ustar00guillaumeguillaume00000000000000#!/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. #pragma repo-format darcs-2 . 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. darcs-2.10.2/tests/issue1865-get-context.sh0000644000175000017500000000062712620122474022340 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/failing-look_for_replaces1.sh0000644000175000017500000000273012620122474023602 0ustar00guillaumeguillaume00000000000000#!/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 < file < _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 clone 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 clone testrepo testrepo-push; \ darcs clone testrepo testrepo-send; \ " # ================ Settings =============== echo ${DARCS_SSH_FLAGS} echo ${DARCS_SSH} echo ${DARCS_SCP} echo ${DARCS_SFTP} # ================ 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 ] [ -f testrepo/a ] # if the above test is disabled we just init a blank repo # so that the other tests can continue if [ ! -d testrepo ]; then mkdir testrepo cd testrepo darcs init cd .. fi # ================ Checking darcs pull ================= darcs clone ${DARCS_SSH_FLAGS} testrepo testrepo-pull cd testrepo-pull echo yyy | darcs pull ${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 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" 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 # 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 # check that the bundle was created grep "add file c" mybundle.dpatch cd .. # ================ Checking darcs clone to ssh destination ==================" cd testrepo 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 ]" cd .. # ======== Checking push over ssh with a conflict =========" ${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 ob --last 1 -a echo 'change for local' > a darcs record --ignore-times -am 'change for local' darcs push -a > log 2>&1 || : grep -q 'conflicts options to apply' log cd .. cleanup darcs-2.10.2/tests/network/issue1503_prefer_local_caches_to_remote_one.sh0000644000175000017500000000262212620122474030515 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1503 - 'Prefer local caches to remote ones' ## ## 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 rm -rf S T darcs clone --lazy http://darcs.net/testing/repo1 S darcs tag --repo S -m 2 darcs clone --lazy http://darcs.net/testing/repo1 T darcs pull --repo T S -a --debug --verbose 2>&1 | tee log not grep repo1 log darcs-2.10.2/tests/network/issue2090-transfer-mode.sh0000644000175000017500000000327212620122474024324 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for darcs transfer-mode ## ## 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. echo 'Comment this line out and run the script by hand'; exit 200 . $(dirname $0)/../lib . $(dirname $0)/sshlib # Clean up after previous remote runs ${SSH} ${REMOTE} "\ rm -rf ${REMOTE_DIR}; \ mkdir ${REMOTE_DIR}; \ " # Set up a repo to test 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 clone . $REMOTE:$REMOTE_DIR/R cd .. darcs clone $REMOTE:$REMOTE_DIR/R S --debug > log 2>&1 COUNT=$(grep -c 'darcs transfer-mode' log) # with issue2090, this was 6! test $COUNT -eq 1 cleanup darcs-2.10.2/tests/network/external.sh0000644000175000017500000000140712620122474021735 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Some tests for launching external commands . lib rm -rf temp1 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' # make our ssh command one word only echo 'echo hello > fakessh' > $touch_fakessh chmod u+x $touch_fakessh # first test the DARCS_SSH environment variable not darcs clone example.com:foo grep hello fakessh rm -f fakessh # now make sure that we don't launch ssh for nothing mkdir temp1 cd temp1 darcs init cd .. darcs clone temp1 > log not grep fakessh log not darcs clone http://darcs.net/nonexistent not grep fakessh log cd .. rm -rf temp1 darcs-2.10.2/tests/network/clone.sh0000644000175000017500000000062512620122474021214 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash set -ev rm -rf temp temp2 temp3 #"$DARCS" clone http://hub.darcs.net/kowey/tabular temp darcs clone --lazy http://hub.darcs.net/kowey/tabular temp2 darcs clone --lazy --tag . http://hub.darcs.net/kowey/tabular 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 darcs-2.10.2/tests/network/lazy-clone.sh0000644000175000017500000000066612620122474022176 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash set -ev rm -rf temp temp2 temp3 darcs clone --lazy http://hub.darcs.net/kowey/tabular temp darcs clone --lazy temp temp2 rm -rf temp cd temp2 test ! -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2 darcs annotate -p 'Initial version' test -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2 cd .. rm -rf temp temp2 temp3 darcs-2.10.2/tests/network/log.sh0000644000175000017500000000071212620122474020672 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib # Demonstrates issue385 and others darcs log --repo=http://darcs.net GNUmakefile --last 300 # Test things mentioned in issue2461: # no _darcs should remain test ! -d _darcs # go to a directory where we have no write access cd / # and try again (with less patches to fetch) darcs log --repo=http://darcs.net GNUmakefile --last 3 # an absolute path should give an error not darcs log --repo=http://darcs.net /GNUmakefile --last 3 darcs-2.10.2/tests/rollback-nothing.sh0000644000175000017500000000037712620122474021664 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 yYd | tr [A-Z] [a-z] | darcs rollback --last=1 | grep 'No changes selected' cd .. rm -rf temp darcs-2.10.2/tests/issue709_pending_look-for-adds.sh0000644000175000017500000000153112620122474024235 0ustar00guillaumeguillaume00000000000000#!/bin/sh . ./lib rm -rf temp1 mkdir temp1 cd temp1 darcs init # Here we check whether recording just one of two --look-for-add # addfiles causes any trouble (which it doesn't) date > f1 date > f2 echo yyd | darcs record -l -m ff cat _darcs/patches/pending not darcs wh rm f2 # Try recording a file add without --look-for-adds, with a setpref # patch present that we don't record. darcs setpref boringfile .boring echo bar > bar darcs add bar echo yyd | darcs record -mbar cat _darcs/patches/pending darcs whatsnew -s test -z "`darcs whatsnew -s`" # Now try the same thing using --look-for-adds echo foo > foo darcs wh -l # remove any files added by profiling or hpc... rm -f darcs.tix darcs.prof echo yyd | darcs record --look-for-adds -mfoo cat _darcs/patches/pending darcs whatsnew -s test -z "`darcs whatsnew -s`" cd .. rm -rf temp1 darcs-2.10.2/tests/failing-look_for_replaces2.sh0000644000175000017500000000262612620122474023607 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Failing test for --look-for-replaces combined with --look-for-moves ## ## 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 rm -rf R mkdir R cd R darcs init cat > file < file < 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 darcs-2.10.2/tests/issue2035-malicious-subpath.sh0000644000175000017500000000244612620122474023517 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2035 - malicious subpaths ## ## 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. gunzip -c $TESTDATA/badrepo.tgz | tar xf - not darcs get badrepo darcs-2.10.2/tests/issue1078_symlink.sh0000644000175000017500000000066312620122474021643 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . 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 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 cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue2365-whatsnew-fails-get-no-working-dir.sh0000644000175000017500000000270612620122474026450 0ustar00guillaumeguillaume00000000000000#!/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 cd S not darcs whatsnew | grep "No changes" cd .. darcs-2.10.2/tests/issue1740-mv-dir.sh0000644000175000017500000000303612620122474021262 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1740 - darcs mv on directories should work after the fact ## ## 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 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" darcs-2.10.2/tests/issue2204-send-mail.sh0000644000175000017500000000376412620122474021741 0ustar00guillaumeguillaume00000000000000#!/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 < dummy-sendmail.hs import System.IO main = hGetContents stdin >>= writeFile "message" FAKE ghc -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 .. darcs-2.10.2/tests/failing-haskell_policy.sh0000644000175000017500000000313612620122474023034 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/trailing-newlines.sh0000644000175000017500000000125012620122474022051 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp && mkdir temp cd temp darcs init echo -n > no_newline echo -n > newline darcs rec -lam "empty" echo -n foo > no_newline echo foo > newline wc -l no_newline | grep 0 wc -l newline | grep 1 darcs wh > diff1 darcs rec -am "add bits" darcs revert -a | grep "no changes" echo -n > no_newline echo -n > newline darcs wh > diff2 darcs rec -lam "bar" darcs revert -a | grep "no changes" darcs check cat > diff1.expected < diff2.expected < file darcs add file mkdir dir darcs add dir darcs rec -a -m 'initial' darcs changes --verbose --patches '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 darcs-2.10.2/tests/issue53.sh0000644000175000017500000000063412620122474017723 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib if echo $OS | grep -i windows; then echo This test does not work under Windows exit 0 fi # pull from not empty repo to empty repo rm -rf temp1 mkdir temp1 cd temp1 darcs init echo a > Aux.hs not darcs add Aux.hs darcs add --reserved-ok Aux.hs echo b > foo darcs add foo darcs record -am 'two files' not darcs mv foo com1 darcs mv --reserved-ok foo com1 cd .. rm -rf temp1 darcs-2.10.2/tests/renames.sh0000644000175000017500000000232012620122474020047 0ustar00guillaumeguillaume00000000000000#!/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 runhaskell $TESTBIN/renameHelper.hs darcs-2.10.2/tests/failing-issue2208-replace-fails-with-resolving-unrecorded-change.sh0000644000175000017500000000344112620122474032534 0ustar00guillaumeguillaume00000000000000#!/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 # We can get around this by recording, then replacing and amending the patch... darcs rec -am "I don't want to have to record this!" darcs replace bar foo testing echo y | darcs amend -a # Check the workaround succeeded. darcs changes --last 1 -v | grep 'replace.*bar.*foo' darcs-2.10.2/tests/issue1618-amend-preserve-logfile.sh0000644000175000017500000000321412620122474024422 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1618 - amend should preserve the logfile ## in case of failure ## ## Copyright (C) 2009 Kamil Dworakowski ## ## 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 darcs setpref test false darcs record -am foo --no-test export DARCS_EDITOR="echo 'new log' > " echo yn | not darcs amend -p foo --edit-long-comment --test 2> out # the msg has the format: "Logfile left in filenamehere." LOGFILE=`grep "Logfile left in" out | sed "s/Logfile left in //" | sed s/.$//` echo $LOGFILE test -e "$LOGFILE" grep 'new log' $LOGFILE rm out; cd ..; rm -rf R/ darcs-2.10.2/tests/set_scripts_executable.sh0000644000175000017500000000220512620122474023162 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Some tests for the --set-scripts-executable option. . lib abort_windows rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init cat > script.pl << FOO #!/usr/bin/env perl print "Hello\n"; FOO chmod 0644 script.pl date > nonscript # pre-tests test -r script.pl test -r nonscript test ! -x script.pl test ! -x nonscript darcs add script.pl nonscript darcs record --name 'uno' --all cd .. # sans --set-scripts-executable (should not be executable) mkdir temp2 cd temp2 darcs init darcs pull -a ../temp1 # sanity check test -r script.pl test -r nonscript # nothing should be executable test ! -x script.pl test ! -x nonscript cd .. rm -rf temp2 # with --set-scripts-executable mkdir temp2 cd temp2 darcs init darcs pull -a ../temp1 --set-scripts-executable # sanity check test -r script.pl test -r nonscript # script should be executable test -x script.pl test ! -x nonscript cd .. rm -rf temp2 # now let's try the same thing with get darcs get --set-scripts-executable temp1 temp2 cd temp2 # sanity check test -r script.pl test -r nonscript # script should be executable test -x script.pl test ! -x nonscript cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/trackdown-bisect.sh0000644000175000017500000000521212620122474021663 0ustar00guillaumeguillaume00000000000000#!/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. ################################################################ . ./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 function make_repo_with_test { rm -fr temp1 mkdir temp1 ; cd temp1 ; darcs init touch ./i touch ./j darcs add ./i darcs add ./j ../trackdown-bisect-helper $1 } function cleanup_repo_after { cd .. rm -fr temp1 } # 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 # For the linear it is second last from the end, and last line # is sentence if test failed or succeed. function is_found_good_patch { if [ "$test_args" == "--linear" ]; then tail -n 2 | grep " $1\$" else tail -n 1 | grep " $1\$" fi } # Test command - Success condition is that file 'j' have one inside (1) # That means if it has zero (0) it is failing test. test_cmd='grep -q 1 j' ############################################################################# # Section with test-cases ############################################################################# # TEST01: Repo with success in the half testTrackdown() { make_repo_with_test $1 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." exit 1 fi cleanup_repo_after } # TEST01: Repo with success in the half test01() { testTrackdown '[1,1,0,0,0]' 3 } # TEST02: Repo without success condition test02() { testTrackdown '[0,0,0,0,0]' 1 } # TEST03: Repo with success condition at before last patch test03() { testTrackdown '[1,1,1,1,0]' 5 } # TEST04: Repo with success condition as first patch ever test04() { testTrackdown '[1,0,0,0,0]' 2 } ############################################# # call test-cases for linear trackdown ############################################# test_args='--linear' test01 test02 ############################################# # Call test-cases for bisect trackdown ############################################# test_args='--bisect' test01 test02 test03 test04 ############################################# # Call test-cases for backoff trackdown ############################################# test_args='--backoff' test01 test02 test03 test04 darcs-2.10.2/tests/test.sh0000644000175000017500000000343012620122474017377 0ustar00guillaumeguillaume00000000000000#!/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. darcs-2.10.2/tests/output.sh0000644000175000017500000000244012620122474017760 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 temp3 mkdir temp2 cd temp2 darcs init cd .. mkdir temp1 cd temp1 darcs init touch foo bar darcs add foo bar darcs record -a -m foobar -A author darcs send --no-minimize -a --dont-edit-description -o ../temp3 ../temp2 test -f ../temp3 darcs send --no-minimize -a --dont-edit-description -o ../temp2/patchfile ../temp2 test -f ../temp2/patchfile mkdir subdir darcs send --no-minimize -a --dont-edit-description -o subdir/../../temp2/patchfile1 ../temp2 test -f ../temp2/patchfile1 cp ../temp3 correct cd subdir darcs send --no-minimize -a --dont-edit-description -o ../patchfile ../../temp2 diff -u ../patchfile ../correct rm ../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 cat out grep foobar out cd ../.. cd temp2 darcs apply --dry-run ../temp3 > out cat out grep foobar out darcs apply --dry-run ../temp1/correct > out cat out grep foobar out darcs apply --dry-run ../temp1/patchfile > out cat out grep foobar out darcs apply --dry-run ../temp3 > out cat out grep foobar out darcs apply --dry-run ../temp3 > out cat out grep foobar out cd .. rm -rf temp1 temp2 temp3 darcs-2.10.2/tests/failing-issue1577-revert-deletes-new-files.sh0000644000175000017500000000256412620122474026331 0ustar00guillaumeguillaume00000000000000#!/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 ]] darcs-2.10.2/tests/issue194.sh0000644000175000017500000000115212620122474020005 0ustar00guillaumeguillaume00000000000000. ./lib rm -rf temp1 temp2 mkdir temp1; cd temp1 ; darcs init ; cd .. darcs get temp1 temp2 cd temp2/ ; echo 'x' > _darcs/prefs/author ; cd .. cd temp1/ ; echo 'x' > _darcs/prefs/author ; cd .. cd temp1/ touch test darcs add test ; darcs record -a -m 'test' darcs mv test best ; darcs record -a -m 'test -> best' darcs mv best test ; darcs record -a -m 'best -> test' cd .. cd temp2/ touch test2 darcs add test2 ; darcs record -a -m 'test2' darcs mv test2 best ; darcs record -a -m 'test2 -> best' darcs mv best test2 ; darcs record -a -m 'best -> test2' darcs pull ../temp1/ -a cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue381.sh0000644000175000017500000000202712620122474020005 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./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 cd temp2 darcs init cd .. cd temp1 darcs init echo Hello world > foobar darcs add foobar darcs record -a -A me -m add_foobar # Test that editor is called when --output is used with --edit-description echo This is a note > note cat > editor <> \$1 cat \$1-temp >> \$1 echo >> \$1 echo finished editing >> \$1 echo I am done running the editor EOF chmod +x editor DARCS_EDITOR='bash editor' darcs send --author=me -a --output=bundle --edit-description ../temp2 echo === beginning of bundle > === cat bundle echo === end of bundle > === grep ' add_foobar' bundle grep 'finished editing' bundle 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 darcs-2.10.2/tests/posthook.sh0000644000175000017500000000222612620122474020270 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 mkdir temp1 cd temp1 darcs init touch foo darcs add foo # Check that posthook works... darcs whatsnew -s --posthook 'touch posthook-ran' test -f posthook-ran rm posthook-ran # Check that posthook works with defaults... echo ALL --posthook touch posthook-ran > _darcs/prefs/defaults darcs whatsnew -s test -f posthook-ran rm posthook-ran 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 END cd .. cd S echo 'Example content.' > f darcs record -lam 'Add f' darcs push -a ../R | grep 'patch author' cd .. darcs-2.10.2/tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh0000644000175000017500000000656012620122474031032 0ustar00guillaumeguillaume00000000000000#!/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. 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 ]] darcs-2.10.2/tests/changes_send_context.sh0000644000175000017500000000057312620122474022612 0ustar00guillaumeguillaume00000000000000#!/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 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 darcs-2.10.2/tests/record-misc.sh0000644000175000017500000000277412620122474020641 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Some tests for 'darcs record ' . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init # issue308 - no patches and no deps for record should abort 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 # RT#231 - special message is given for nonexistent directories not darcs record -am foo not_there.txt > log grep -i 'not exist' 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 DIR="`pwd`" touch date.t darcs add date.t darcs record -a -m foo "$DIR/date.t" | grep -i 'finished recording' # issue396 - record -l "" touch 'notnull.t' darcs record -am foo -l "" notnull.t | grep -i 'finished recording' # basic record date >> date.t darcs record -a -m basic_record date.t | grep -i 'finished recording' # testing --logfile date >> date.t echo "second record\n" >> log.txt darcs record -a -m 'second record' --logfile=log.txt date.t | grep -i 'finished recording' # refuse empty patch name export DARCS_EDITOR="cat -n" date >> date.t echo "patchname" | darcs record -a -m "" | grep WARNING date >> date.t darcs record -a -m "some name" cd .. rm -rf temp1 darcs-2.10.2/tests/issue1392_authorspelling.sh0000644000175000017500000000336112620122474023212 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1392 - .authorspelling processing. ## ## Copyright (C) 2009 Tomas Caithaml ## ## 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 'Bad\, Jr. , Foo' > .authorspellings echo 'Example content.' > f darcs record -lam 'Add f.' -A 'Foo' darcs show authors | grep -q 'Bad, Jr\. ' echo 'Bad\, Jr. , ^Foo\, Jr\..*$' > .authorspellings echo 'Ex. cont.' > f darcs record -lam 'Change f.' -A 'Foo, Jr. ' darcs show authors | tee output.txt | grep -q 'Bad, Jr\. ' cd .. #--rm -rf R darcs-2.10.2/tests/issue1620-record-lies-about-leaving-logfile.sh0000644000175000017500000000313112620122474026437 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1620 - record does not really leave logfile ## after a failure ## ## Copyright (C) 2009 Kamil Dworakowski ## ## 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 export DARCS_EDITOR="echo 'a log' > " darcs init darcs setpref test false echo yy| not darcs record -m foo -a --edit-long-comment --test 2> out # the msg has the format: "Logfile left in filenamehere." LOGFILE=`grep "Logfile left in" out | sed "s/Logfile left in //" | sed s/.$//` test -e "$LOGFILE" grep 'a log' $LOGFILE rm out cd .. rm -rf R/ darcs-2.10.2/tests/repoformat.sh0000644000175000017500000000411312620122474020575 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash #pragma repo-format darcs-1,darcs-2 . lib rm -rf garbage future mkdir garbage cd garbage darcs init echo gobbledygook > _darcs/format cd .. mkdir future cd future darcs init touch titi darcs add titi darcs record -am titi cat > _darcs/format < log grep -i "can't understand repository format" log rm -rf temp1 log # pull from garbage repo mkdir temp1 cd temp1 darcs init not darcs pull ../garbage 2> log grep -i "can't understand repository format" log cd .. rm -rf temp1 # apply in garbage repo mkdir temp1 cd temp1 darcs init darcs changes --context > empty-context darcs tag -m "just a patch" 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 cd .. rm -rf temp1 bundle.dpatch # add in garbage repo cd garbage touch toto not darcs add toto 2> log grep -i "can't understand repository format" log cd .. rm -rf garbage ## future repo: we don't understand one # alternative of a line of format # only look at future vs darcs2 if grep darcs-1 .darcs/defaults; then exit 200 fi # get future repo: ok # --to-match is needed because of bug### darcs get future temp1 --to-match "name titi" cd temp1 darcs changes touch toto darcs add toto darcs record -am 'blah' cd .. rm -rf temp1 # pull from future repo: ok mkdir temp1 cd temp1 darcs init darcs pull ../future -a darcs changes | grep titi cd .. rm -rf temp1 # apply in future repo: !ok mkdir temp1 cd temp1 darcs init darcs changes --context > empty-context darcs tag -m "just a patch" darcs send -a --context=empty-context -o ../bundle.dpatch . cd ../future not darcs apply ../bundle.dpatch 2> log cat log grep -i "can't write repository format" log 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 cd .. rm -rf future #No future! darcs-2.10.2/tests/failing-issue1959-unwritable-cache.sh0000644000175000017500000000247312620122474024730 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1959 - if the index becomes unwritable, darcs should not die. ## ## 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 test > test darcs rec -alm 'testing' chmod a-w _darcs/index darcs wh darcs-2.10.2/tests/revert_unrecorded_add.sh0000644000175000017500000000017112620122474022750 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp mkdir temp cd temp darcs init echo stuff > foo darcs add foo darcs revert -a darcs-2.10.2/tests/rebase-nochanges.sh0000644000175000017500000000404212620122474021624 0ustar00guillaumeguillaume00000000000000#!/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 < 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 .. darcs-2.10.2/tests/failed-amend-should-not-break-repo.sh0000644000175000017500000000411412620122474025045 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for keeping the repository in consitent state in case ## of a test failure on amend-record. The bug was almost introduced ## when trying to fix issue 1406. ## ## Copyright (C) 2009 Kamil Dworakowski ## ## 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 # first patch: new file A touch A darcs add A darcs record -a -m 'A' # second patch: mv A to B darcs mv A B darcs record -a -m 'move' # third patch: modify B echo "content" > B darcs record -a -m 'add content' # 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. darcs setpref test false echo yy | 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. cd .. rm -rf R darcs-2.10.2/tests/issue538.sh0000644000175000017500000000607512620122474020020 0ustar00guillaumeguillaume00000000000000#!/bin/env bash # A test for issue 538 - that an executable test script will run successfully if # it is recorded with --set-scripts-executable. . ./lib if echo $OS | grep -i windows; then echo I do not know how to run a test program under windows exit 0 fi function make_repo_with_test { mkdir temp1 ; cd temp1 ; darcs init echo "#!/bin/sh" > test.sh echo "echo 'hello world'" >> test.sh darcs add test.sh darcs record --author=test@test -am test darcs setpref test './test.sh' } # test record with --set-scripts-executable rm -rf temp1 make_repo_with_test touch blaat darcs add blaat if darcs record --set-scripts-executable -A test@test -am blaat --test; then echo "ok 1" else echo "not ok 1 recording second patch failed (because test failed?)" exit 1 fi cd .. # test record without --set-scripts-executable rm -rf temp1 make_repo_with_test touch blaat darcs add blaat if darcs record --dont-set-scripts-executable -A test@test -am blaat --test; then echo "not ok 2 recording second patch succeeded though test script should not be executable" exit 1 else echo "ok 2" fi cd .. # test amend-record with --set-scripts-executable rm -rf temp1 make_repo_with_test touch blaat darcs add blaat if echo y | darcs amend-record --set-scripts-executable -A test@test -a --test; then echo "ok 3" else echo "not ok 3 amending patch failed (because test failed?)" exit 1 fi cd .. # test amend-record without --set-scripts-executable rm -rf temp1 make_repo_with_test touch blaat darcs add blaat if echo y | darcs amend-record --dont-set-scripts-executable -A test@test -a /dev/null --test; then echo "not ok 4 amending patch succeeded even though --dont-set-scripts-executable specified" exit 1 else echo "ok 4" fi cd .. # test --linear with --set-scripts-executable rm -rf temp1 make_repo_with_test if darcs test --linear --set-scripts-executable | grep 'Success!' ; then echo "ok 5" else echo "not ok 5 tracking down with --set-scripts-executable failed (because test failed?)" exit 1 fi cd .. # test --linear without --set-scripts-executable rm -rf temp1 make_repo_with_test 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" exit 1 fi cd .. # check test --linear with files that become scripts during trackdown rm -rf temp1 mkdir temp1 ; cd temp1 ; darcs init echo "#!/bin/sh" > test.sh echo "./helper.sh" >> test.sh echo "#!/bin/sh" > helper.sh echo "echo 'helper speaking'" >> helper.sh darcs add test.sh darcs add helper.sh darcs record -am 'valid helper' -A test echo 'this is definitely not a valid script' > helper.sh darcs record -am 'invalid helper' -A test darcs setpref test './test.sh' darcs test --linear --set-scripts-executable > trackdown-out if grep 'Test failed!' trackdown-out && grep 'Success!' trackdown-out ; then echo "ok 7" else echo "not ok 7 either no failure or no success (both should occur)" exit 1 fi cd .. rm -rf temp1 darcs-2.10.2/tests/issue1645-ignore-symlinks.sh0000644000175000017500000001707712620122474023234 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1645 - Since Darcs does not version-contol symlinks, ## it should not follow them, ESPECIALLY symlinks to directories ## outside the repository. All these tests are passed with darcs-2.2 ## ## See path_resolution(7) and symlink(7) for more info, especially ## the former. ## ## There's a second section to this test for systems that support ## case-folding. See issue1645-ignore-symlinks-case-fold.sh ## ## Copyright (C) 2010 Trent W. Buck, 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 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 } ## These are the simple does-the-wrong-thing errors. cd R 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 --patches="added ./non-recorded-dir" >>log 2>&1 # 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 darcs add recorded-dir 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 grep -vE "(^ *$|^\+|No changes!)" log # Case 3: looping symlink to boring dir mkdir 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 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 --patches="added ./non-recorded-dir2" >>log 2>&1 # 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 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 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 grep -vE "(^ *$|^\+|No changes!)" log rm link link2 # Case 8: symlink to non-recorded non-boring file 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 --patches="added ./non-recorded-file" >>log 2>&1 # 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 echo "some content" > recorded-file darcs add recorded-file 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 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 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 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 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 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 darcs-2.10.2/tests/failing-nice-resolutions.sh0000644000175000017500000000107512620122474023334 0ustar00guillaumeguillaume00000000000000#!/bin/sh . ./lib mkdir temp1 cd temp1 darcs init echo a > foo darcs add foo darcs record -am addfoo cd .. darcs get temp1 temp2 cd temp2 echo B > foo darcs record -am B cd ../temp1 echo b > foo darcs record -am b echo c > foo darcs record -am c cd ../temp2 darcs pull -a cat foo grep b foo && exit 1 grep a foo && exit 1 grep B foo grep c foo echo C > foo darcs record -am C cd ../temp1 echo d > foo darcs record -am d cd ../temp2 darcs pull -a cat foo grep b foo && exit 1 grep a foo && exit 1 grep B foo && exit 1 grep c foo && exit 1 grep C foo grep d foo darcs-2.10.2/tests/directory_confusion.sh0000644000175000017500000000070012620122474022504 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib T=temp rm -rf "$T" mkdir "$T" echo "$T" cd "$T" 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" darcs-2.10.2/tests/issue1105.sh0000644000175000017500000000147212620122474020063 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp mkdir temp cd temp darcs init darcs changes echo changes summary > _darcs/prefs/defaults darcs changes echo changes summary arg > _darcs/prefs/defaults not darcs changes echo ALL summary > _darcs/prefs/defaults darcs changes echo ALL summary arg > _darcs/prefs/defaults not darcs changes echo changes last 10 > _darcs/prefs/defaults darcs changes echo changes last > _darcs/prefs/defaults not darcs changes echo ALL last 10 > _darcs/prefs/defaults darcs changes echo ALL last > _darcs/prefs/defaults not darcs changes echo changes author me > _darcs/prefs/defaults not darcs changes echo changes author me > _darcs/prefs/defaults not darcs changes echo ALL author me > _darcs/prefs/defaults darcs changes echo ALL unknown > _darcs/prefs/defaults not darcs changes cd .. rm -rf temp darcs-2.10.2/tests/mergeresolved.sh0000644000175000017500000000177612620122474021276 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf fooOld tempA tempB mkdir fooOld tempA tempB cd fooOld darcs init 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 cd .. cd tempA darcs init cp ../fooOld/_darcs/prefs/defaults _darcs/prefs darcs pull ../fooOld echo A > foo darcs record -m AA cd .. cd tempB darcs init cp ../fooOld/_darcs/prefs/defaults _darcs/prefs darcs pull ../fooOld echo B > foo darcs record -m BB darcs pull ../tempA echo A > foo darcs record -m "ok A's fine." cd .. # At this point, tempB and tempA should agree--since the conflict was # resolved in favor of tempA. cmp tempB/foo tempA/foo cd tempA echo AA > foo darcs record -m "AA -- upping the ante." cd .. cd tempB darcs pull ../tempA cd .. cd tempA darcs pull ../tempB cd .. # At this point, tempB and tempA should agree since we have pulled both ways. cmp tempB/foo tempA/foo darcs-2.10.2/tests/failing-issue1461_case_folding.sh0000644000175000017500000000401612620122474024171 0ustar00guillaumeguillaume00000000000000#!/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. ## ## 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. touch casetest test -e CASETEST || exit 200 rm -rf lower upper joint # Another script may have left a mess. mkdir lower upper cd lower darcs init cat > a << EOF 1 2 3 EOF darcs add a darcs record -am 'lower init a' cd .. cd upper darcs init cat > A << EOF 1 2 3 EOF darcs add A darcs record -am 'upper init A' cd .. darcs get lower joint cd joint darcs pull -a ../upper cd .. cd lower cat > a << EOF one lower 2 3 EOF darcs record -am 'lower modify' cd .. cd upper cat > A << EOF 1 2 three upper EOF darcs record -am 'upper modify' cd .. cd joint darcs pull ../lower -a darcs pull ../upper -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 darcs-2.10.2/tests/failing-issue2138-whatsnew-s.sh0000644000175000017500000000331312620122474023573 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/overriding-defaults.sh0000644000175000017500000000271412620122474022401 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp mkdir temp cd temp darcs init darcs setpref test false darcs record --no-test -a -m 'add failing test' # should fail when test is run not darcs test # should pass with --no-test in defaults 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 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 trap "cp defaults.backup ~/.darcs/defaults" EXIT rm _darcs/prefs/defaults # --no-test works in global defaults 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 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 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 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 cd .. rm -rf temp darcs-2.10.2/tests/send-dont-prompt-deps.sh0000644000175000017500000000130012620122474022555 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # Check that the right patches get sent 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 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 not grep bar toto cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue942_push_apply_prehook.sh0000644000175000017500000000332612620122474024006 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue942 - remote apply prehook not invoked on darcs push ## We also test for posthooks along the way even though that's not part ## of the issue. ## ## 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 S # Another script may have left a mess. darcs init --repo R # Create our test repos. echo 'apply prehook touch g' >R/_darcs/prefs/defaults echo 'apply posthook touch h' >>R/_darcs/prefs/defaults darcs get R S cd S touch f darcs add f darcs record -lam 'Add f' test ! -e ../R/g test ! -e ../R/h darcs push -a test -e ../R/g test -e ../R/h darcs-2.10.2/tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh0000644000175000017500000000036012620122474030674 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/prefs.sh0000644000175000017500000000053012620122474017535 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./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 darcs record -a -m p1 -A me cd .. darcs get temp1 temp2 cmp temp1/_darcs/prefs/prefs temp2/_darcs/prefs/prefs rm -rf temp1 temp2 darcs-2.10.2/tests/whatsnew-interactive.sh0000644000175000017500000000277112620122474022602 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## ## This tests the basic fascilities of `whatsnew --interactive` ## ## Copyright (C) 2014 Daniil Frumin ## ## 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 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; darcs-2.10.2/tests/failing-issue1332_add_r_boring.sh0000644000175000017500000000324212620122474024162 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1332 - add -r ignores --boring ## ## 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 mkdir d touch core f # this is already known to work darcs add --boring core f darcs whatsnew > log 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 darcs-2.10.2/tests/issue1951-add-outside-repo.sh0000644000175000017500000001053312620122474023235 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1951 - darcs should refuse adds from outside the ## current repository ## ## 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 R2 R3 R4 R5 R6 R7 R8 R9 R10 darcs init --repo R # Create our test repos. darcs init --repo R2 darcs init --repo R3 darcs init --repo R4 darcs init --repo R5 darcs init --repo R6 darcs init --repo R7 darcs init --repo R8 darcs init --repo R9 darcs init --repo R10 # test if adding files outside the repository fails OUTSIDE=`pwd` cd R echo 'Example content.' > f echo 'Bad' > ../junk-for-issue1951 darcs add f not darcs add ../junk-for-issue1951 not darcs add $OUTSIDE/junk-for-issue1951 darcs whatsnew > log not grep junk-for-issue1951 log cd .. # test adding a file that: # * is in a subdirectory of the repository root # * is referred to with a path relative to the cwd, when the cwd is the # directory that the file is in cd R2 mkdir subdir cd subdir touch f darcs add f darcs whatsnew > log grep 'subdir/f' log cd ../.. # same as above, but now the relative path is valid both from the cwd and from # the repository root. Darcs should add the file in the cwd, not the one in the # repository root cd R3 touch f mkdir subdir cd subdir touch f darcs add f darcs whatsnew > log grep 'subdir/f' log cd ../.. # now test that adding fails on a file that # * is in the repository root # * is referred to with a path relative to the repository root, when the cwd is # not the repository root cd R4 touch myfilename mkdir subdir cd subdir not darcs add myfilename cd ../.. # test adding a file by relative path from the repo root, when the cwd is # outside the repo # It may seem counterintuitive that this succeeds and the cases above and below # do not, but that's the way it is. We use this feature ourselves in our test # suite. touch R5/myfilename darcs add --repo R5 myfilename darcs whatsnew --repo R5 > log grep 'myfilename' log not grep '\.\./myfilename' log # The case below makes the R4 case (of using a repo-root-relative path in a # subdir of the repo) look even more like the R5 case (of using a # repo-root-relative path outside the repo) by usign the --repo flag. It still # failed on darcs 2.4. cd R6 touch myfilename mkdir subdir cd subdir not darcs add --repo .. myfilename cd ../.. # Test adding a file by relative path from the repo root, when the cwd is # outside the repo, and the relative path also exists from the cwd touch myfilename touch R7/myfilename darcs add --repo R7 myfilename darcs whatsnew --repo R7 > log grep 'myfilename' log not grep '\.\.myfilename' log # Like the R4 case: try to use a path relative to the repo root from a cwd that # is a subdir of the repo root. In this case the path relative to the repo root # also includes a directory however. cd R8 mkdir subdir1 mkdir subdir2 touch subdir2/myfilename cd subdir1 not darcs add subdir2/myfilename cd ../.. # Try adding a non-repository file using a non-existent repo subdirectory name # followed by two ..'s touch myfilename cd R9 not darcs add nonexistentsubdir/../../myfilename cd .. # Try adding a non-repository file using an existing repo subdirectory name # followed by two ..'s touch myfilename cd R10 mkdir subdir not darcs add subdir/../../myfilename cd .. darcs-2.10.2/tests/issue2193-apply-runs-test-twice.sh0000644000175000017500000000325112620122474024266 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2193 - "darcs apply --test runs the test twice. ## ## 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 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 ] darcs-2.10.2/tests/push_lock.sh0000644000175000017500000000064012620122474020407 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # For issue257: push => incorrect return code when couldn't get lock . ./lib 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 darcs-2.10.2/tests/nonewline.sh0000644000175000017500000000051012620122474020412 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 mkdir temp1 temp2 cd temp1 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 darcs init darcs pull -a ../temp1 cd .. cmp temp1/foo temp2/foo rm -rf temp1 temp2 darcs-2.10.2/tests/failing-issue2308-changes-missing-amend-edit.sh0000644000175000017500000000355012620122474026561 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2308 changes aren't listed when using amend --edit ## ## 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 -e 'a\nb\nc' > file darcs rec -alm 'Add file' cat > expected < actual not diff expected actual darcs-2.10.2/tests/failing-issue1327.sh0000644000175000017500000000141712620122474021477 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # 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 yy | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB" darcs-2.10.2/tests/get-http.sh0000644000175000017500000000270012620122474020153 0ustar00guillaumeguillaume00000000000000#!/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" log darcs check darcs-2.10.2/tests/illegal_mv.sh0000644000175000017500000000050712620122474020535 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/issue1848-rollback-p.sh0000644000175000017500000000300712620122474022121 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/issue2012_send_output_no_address.sh0000644000175000017500000000315112620122474024707 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue2012 - darcs send -o shall not print a "will be sent ## to" line ## ## Copyright (C) 2010 Gabriel Kerneis ## ## 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_EDITOR=echo export DARCS_EDITOR mkdir temp1 temp2 cd temp2 darcs init echo "default@email" > _darcs/prefs/email cd .. cd temp1 darcs init touch foo bar darcs add foo bar darcs record -a -m add_foo_bar -A x darcs send -a -o test.patch ../temp2 2>&1 | not grep "Patch bundle will be sent to: default@email" darcs send -a -O ../temp2 | not grep "Patch bundle will be sent to: default@email" cd .. darcs-2.10.2/tests/failing-issue1406.sh0000644000175000017500000000436212620122474021477 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1406 - failed test on amend unrecords the ## original patch ## ## Copyright (C) 2009 Adam Vogt, Kamil Dworakowski ## ## 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 mkdir R/d/ R/e/ # Change the working tree. echo 'Example content.' >R/d/f darcs record --repo R -lam 'Add d/f and e.' darcs mv --repo R d/f e/ darcs record --repo R -am 'Move d/f to e/f.' darcs push --repo R S -a # Try to push patches between repos. darcs push --repo S R rm -rf R/ S/ # Clean up after ourselves. #!/bin/sh . ./lib rm -rf temp1 darcs init --repodir temp1 cd temp1 echo "test exit 1" > _darcs/prefs/prefs echo "a" > a darcs record --look-for-adds --no-test --all --name=p1 echo "b" >> a echo "y" | not darcs amend-record --all --patch=p1 # There should be one patch in the repo test 1 -eq `darcs changes -a --count` || exit 1 # Another check: there should be nothing new after a is restored echo "a" > a not darcs whatsnew -l cd .. rm -rf test1 darcs-2.10.2/tests/init.sh0000644000175000017500000000063212620122474017364 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init test -d _darcs not darcs init cd .. # Some tests for the repodir flag mkdir temp2 darcs init --repodir temp2 test -d temp2/_darcs # 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 darcs-2.10.2/tests/patch-index-creation.sh0000644000175000017500000000627212620122474022435 0ustar00guillaumeguillaume00000000000000#!/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 S darcs init --repo R cd R darcs show patch-index-status | 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-status | grep 'Patch Index is in sync with repo.' # init --patch-index cd .. darcs clone R S cd S darcs show patch-index-status | 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-status | grep 'Patch Index is in sync with repo.' # clone --patch-index cd .. rm -rf repo repo2 gunzip -c $TESTDATA/simple-v1.tgz | tar xf - echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 cd repo2 darcs show patch-index-status | grep 'Patch Index is not yet created.' # convert cd .. rm -rf repo repo2 gunzip -c $TESTDATA/simple-v1.tgz | tar xf - echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 --with-patch-index cd repo2 darcs show patch-index-status | 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-status | 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-status | 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-status | 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-status | grep 'Patch Index is not yet created.' # log -a file --no-patch-index cd .. rm -rf R S repo repo2 darcs-2.10.2/tests/issue1857-pristine-conversion.sh0000644000175000017500000000300012620122474024104 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1857 - upgrading the pristine format should either ## work or have no effect) even it happens before a failing operation ## ## 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 minimal-darcs-2.4 tar zx < $TESTDATA/minimal-darcs-2_4.tgz cd minimal-darcs-2.4 darcs check darcs setpref test false echo 'hi' > README not darcs record -a -m argh --test darcs check cd .. darcs-2.10.2/tests/failing-issue2234-rollback-under-tag-with-filename.sh0000644000175000017500000000332112620122474027673 0ustar00guillaumeguillaume00000000000000#!/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' darcs-2.10.2/tests/unpull.sh0000644000175000017500000000036412620122474017742 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 mkdir temp1 cd temp1 darcs init cat > f < f < /dev/null | wc -l | grep "^ *0$" darcs-2.10.2/tests/rebase-move-2.sh0000644000175000017500000000307412620122474020770 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/failing-issue2386-no-trailing-EOL.sh0000644000175000017500000000303512620122474024341 0ustar00guillaumeguillaume00000000000000#!/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 '^+$' darcs-2.10.2/tests/issue1871-record-dot.sh0000644000175000017500000000321212620122474022127 0ustar00guillaumeguillaume00000000000000#!/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 ny | darcs record echo ny | darcs record . > log not grep "None of the files" log cd .. darcs-2.10.2/tests/issue1923-cache-warning.sh0000644000175000017500000000373712620122474022605 0ustar00guillaumeguillaume00000000000000#!/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 darcs init --repo R cd R echo a > a darcs rec -lam a cd .. serve_http cat < 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 darcs-2.10.2/tests/changes-duplicate.sh0000644000175000017500000000321212620122474021776 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for patch index automation - ## ## 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. #pragma repo-format darcs-2 . lib grep darcs-2 $HOME/.darcs/defaults || exit 200 rm -rf R S 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 changes --verbose darcs changes --verbose | grep -q 'duplicate' darcs changes f --verbose | not grep -q 'duplicate' darcs-2.10.2/tests/failing-merging_newlines.sh0000644000175000017500000000167712620122474023376 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # Note that this is fixed, the lines marked # BUG HERE # should be moved back into merging_newlines.sh # trick: requiring something to fail not () { "$@" && exit 1 || :; } rm -rf temp1 temp2 # set up the repository mkdir temp1 cd temp1 darcs init cd .. 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" 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 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 # BUG HERE # after a conflict, darcs mark-conflicts should report a conflict darcs mark-conflicts > log 2>&1 cat log not grep -i 'no conflicts' log cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/issue2212-add-changes-pending-for-other-files.sh0000644000175000017500000000325712620122474026647 0ustar00guillaumeguillaume00000000000000#!/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 directory darcs revert -a touch b darcs add b rm a darcs revert b -a cat _darcs/patches/pending | not grep 'rmfile \./a' darcs-2.10.2/tests/show-authors.sh0000644000175000017500000000063312620122474021065 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 "#1 2 y" authors grep "#2 1 x" authors head -1 authors | grep y darcs show authors --verbose [[ $(darcs show authors --verbose | grep y | wc -l) -eq 2 ]] darcs-2.10.2/tests/hashed_inventory.sh0000644000175000017500000000571112620122474021775 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # We'd just use `diff -x _darcs -r' if -x was portable. diffx () { { find $1 -type f; find $2 -type f; } | sed -e '/.*\/_darcs\//d' -e 's;^[^/]*;;' | grep -v darcs.tix | sort | uniq | { while read part; do diff -c $1$part $2$part done } } makepristine () { rm -rf pristine mkdir pristine for i in `darcs show files --no-files --no-pending`; do echo mkdir -p pristine/$i; mkdir -p pristine/$i; done for i in `darcs show files --no-directories --no-pending`; do echo darcs show contents $i ">" pristine/$i; darcs show contents $i > pristine/$i; cat pristine/$i; done } mkdir temp1 cd temp1 darcs init --darcs-1 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 makepristine cd .. darcs get temp1 temp2 cd temp2 darcs changes makepristine cd .. darcs get temp1 temp3 cd temp3 darcs changes cp _darcs/hashed_inventory inv darcs optimize clean diff -c inv _darcs/hashed_inventory rm inv makepristine cd .. cat temp3/pristine/foo diffx temp2 temp3 diff -rc temp1/pristine temp3/pristine diff -rc temp2/pristine temp3/pristine cd temp1 darcs record -a -A tester -m t2 darcs push ../temp2 -a darcs push ../temp3 -a makepristine cd .. cd temp3 makepristine cd .. cd temp2 makepristine cd .. diffx temp2 temp3 diff -rc temp1/pristine temp3/pristine diff -rc temp2/pristine temp3/pristine cd temp1 date > foo darcs record -a -A tester -m t3 makepristine cd ../temp2 darcs pull -a makepristine cd ../temp3 darcs pull -a darcs check makepristine cd .. diffx temp2 temp3 diff -rc temp1/pristine temp3/pristine diff -rc temp2/pristine temp3/pristine cd temp1 darcs get . ../temp4 cd .. cd temp4 makepristine cd .. diffx temp2 temp4 diff -rc temp2/pristine temp4/pristine cd temp1 darcs tag -A tagger -m atag darcs check darcs optimize clean darcs check darcs changes | grep t1 cd .. cd temp3 date > foobarpatch darcs add foobarpatch darcs record -a -A silly -m foobarpatch darcs check darcs optimize clean darcs check darcs pull -a ../temp1 darcs check darcs optimize reorder darcs check grep 'Starting with inventory' _darcs/hashed_inventory cd .. cd temp1 darcs pull -a ../temp3 cd .. diff -c temp1/_darcs/hashed_inventory temp3/_darcs/hashed_inventory cd temp4 darcs pull -p foobarpatch -a ../temp3 darcs pull -a ../temp1 darcs optimize reorder darcs check darcs push ../temp1 cd .. diff temp1/_darcs/hashed_inventory temp4/_darcs/hashed_inventory darcs get temp1 temp5 cd temp5 darcs obliterate --last 3 -a darcs pull ../temp1 -a darcs obliterate --last 3 -a darcs pull ../temp2 -a darcs check darcs obliterate --last 3 -a darcs pull ../temp4 -a cd .. cd temp4 darcs obliterate --last 3 -a darcs pull ../temp5 -a cd .. cd temp2 darcs obliterate --last 3 -a darcs pull ../temp5 -a cd .. cd temp1 darcs obliterate --last 3 -a darcs pull ../temp5 -a cd .. darcs-2.10.2/tests/pull_compl.sh0000644000175000017500000000724712620122474020600 0ustar00guillaumeguillaume00000000000000#!/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 < 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 < p2.out diff p1.out p2.out darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out cat > p3.req < p4.out cat > p4.req < 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 < 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 darcs-2.10.2/tests/unrecord-dont-prompt.sh0000644000175000017500000000122712620122474022524 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # 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 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 darcs-2.10.2/tests/issue1739-escape-multibyte-chars-correctly.sh0000644000175000017500000000457112620122474026457 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1739 - "Char.intToDigit: not a digit" in darcs changes ## ## Copyright (C) 2010 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 # 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 echo "no locale command" exit 200 # skip test fi charmap=`locale charmap` if [ $? -ne 0 ]; then echo "couldn't determine locale character set" exit 200 # skip test fi if [ "$charmap" != "UTF-8" ]; then echo "locale character set is not UTF-8, skipping" exit 200 fi # we want escaping, otherwise output of non-ASCII characters is unreliable export DARCS_DONT_ESCAPE_ANYTHING=0 export DARCS_DONT_ESCAPE_8BIT=0 rm -rf R mkdir R cd R darcs init 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 ' -a > rec.txt darcs changes > log.txt cat log.txt grep '' log.txt grep '' log.txt grep '' log.txt # locale should not matter LC_ALL=C darcs changes > log.txt grep '' log.txt grep '' log.txt grep '' log.txt cd .. darcs-2.10.2/tests/annotate.sh0000644000175000017500000000042112620122474020226 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . lib darcs init mkdir a b touch a/a b/b darcs add --rec . darcs record -a -m ab -A test darcs annotate a/a echo x > c darcs add c darcs record -a -m foo -A 'Mark Stosberg ' darcs annotate c darcs annotate c | grep "a@b.com" cd .. rm -rf temp darcs-2.10.2/tests/failing-issue2257-impossible-obliterate-subset.sh0000644000175000017500000000435212620122474027302 0ustar00guillaumeguillaume00000000000000#!/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 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' darcs-2.10.2/tests/patch-index-log.sh0000644000175000017500000000245512620122474021411 0ustar00guillaumeguillaume00000000000000. 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 darcs-2.10.2/tests/obliterate-add.sh0000644000175000017500000000030012620122474021271 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/several_commands.sh0000644000175000017500000000060712620122474021745 0ustar00guillaumeguillaume00000000000000#!/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 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 darcs-2.10.2/tests/perms.sh0000644000175000017500000000120312620122474017542 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib uname | grep "MINGW" > /dev/null && exit 0 rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init 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 echo hello >> foo darcs record -m mod_foo cd .. darcs get --repo-name temp2 temp1 cd temp2 cp ../temp1/_darcs/prefs/defaults _darcs/prefs echo y/d/y | tr / \\012 | darcs unpull --interactive test -f foo -a ! -s foo chmod +x foo test -x foo darcs pull ../temp1 test -x foo cd .. rm -rf temp1 temp2 darcs-2.10.2/tests/xmlschema.sh0000644000175000017500000001056312620122474020406 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for XML schema - ## ## Copyright (C) 2011 Radoslav Dorcik ## ## 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. repod="$TESTDATA/../../" xsdf="$repod/contrib/darcs.xsd" tmpf="changes_tmp.xml" if [ -z "$(which xmllint)" ]; then echo this test does not work on this machine echo it needs xmllint for XML validation. exit 200 fi if [ ! -d "$repod/_darcs" ]; then echo this test does not work on this machine echo it needs source repo exit 200 fi if [ ! -f "$xsdf" ]; then echo this test does not work on this machine echo it needs $(basename $xsdf) exit 200 fi ####################################################### # Test preparation ####################################################### # Create repository with all kind of operations darcs init --repo R # Create our test repos. cd R # Add File and Dir mkdir dir1 dir2 echo "Example content." > dir1/file1 echo "Example content." > dir2/file2 darcs record -lam 'Add dir1 and dir2' # Modify (add) echo "Example content." >> dir1/file1 echo "Example content." >> dir2/file2 echo "Example content." >> dir1/file1 echo "Example content." >> dir2/file2 darcs record -lam 'Modify dir1 and dir2 (add)' # Modify (add,del) echo "Example content." > dir1/file1 echo "Example content." > dir2/file2 echo "Example contentx." >> dir1/file1 echo "Example contentx." >> dir2/file2 darcs record -lam 'Modify dir1 and dir2 (add,del)' # Replace darcs replace contentx contenty dir1/file1 dir2/file2 darcs record -lam 'Replace contentx contenty' # Modify (del) echo "Example content." > dir1/file1 echo "Example content." > dir2/file2 darcs record -lam 'Modify dir1 and dir2 (del)' # Moving darcs mv dir1 dir11 darcs mv dir2 dir22 darcs record -lam 'Move dir1 and dir2' # Remove rm -fr dir11 rm -fr dir22 darcs record -lam 'Remove dir1 and dir2' # Complex patch Replace and Modify, Add and Delete mkdir dir3 dir4 echo "Example contentx." >> dir3/file3 echo "Example contentx." >> dir3/file3 echo "Example contentx." >> dir3/file3 echo "Example contentz." >> dir3/file3 echo "Example contentx." >> dir4/file4 darcs record -lam 'Complex patch (prep)' darcs replace contentx contenty dir3/file3 mkdir dir5 echo "Example contentx." >> dir5/file4 darcs mv dir3 dir7 echo "Example contentx." >> dir7/file3 darcs record -lam 'Complex patch (done)' rm -fr dir4 cd .. ####################################################### # Testing ####################################################### # Darcs produces XMLs with non-UTF8 characters. echo '' > $tmpf darcs log -s --xml-output --repodir=R >> $tmpf xmllint --noout --schema $xsdf $tmpf || exit 1 echo '' > $tmpf darcs log --xml-output --repodir=R >> $tmpf xmllint --noout --schema $xsdf $tmpf || exit 1 exit 0; # Comment this out for next long running tests ## Next tests are disabled by default because they are long running (~10 minutes) ## But they are be helpfull for manual verifications echo '' > $tmpf darcs log --xml-output -s --repodir=$repod >> $tmpf xmllint --noout --schema $xsdf $tmpf || exit 1 darcs-2.10.2/tests/rebase-pull-reorder.sh0000644000175000017500000000136512620122474022300 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/tests/record_editor.sh0000644000175000017500000000253112620122474021245 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Some tests for 'darcs rec --edit-long-comment' . lib 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 '# Please enter' 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 '# Please enter' cd .. rm -rf temp2\ dir # make sure summaries are coalesced mkdir temp3 cd temp3 darcs init cat > file < file < 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 darcs-2.10.2/tests/issue2200-darcs-replace-no-paths.sh0000644000175000017500000000272212620122474024311 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/three_way_conflict.sh0000644000175000017500000000103612620122474022270 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib rm -rf temp1 temp2 temp3 mkdir -p temp1 temp2 temp3 cd temp1 darcs init cd ../temp2 darcs init cd ../temp3 darcs init touch foo darcs add foo darcs record -a -A author -m add darcs push -a ../temp2 darcs push -a ../temp1 echo A > foo darcs record -a -A author -m AA cd ../temp2 echo B > foo darcs record -a -A author -m BB cd ../temp1 echo C > foo darcs record -a -A author -m CC darcs pull -a ../temp2 darcs pull -a ../temp3 cd ../temp2 darcs pull -a ../temp3 darcs pull -a ../temp1 rm -rf temp1 temp2 temp3 darcs-2.10.2/tests/conflict-doppleganger.sh0000644000175000017500000000330612620122474022670 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash #pragma repo-format darcs-1,darcs-2 . lib # Tests for the doppleganger conflict bug. # For Zooko, with love # Also, for issue81. check_conflict() { cat out if test "$format" = darcs-2; then not grep 'conflict' out else grep 'conflict' out fi } # check doppleganger conflicts rm -rf tmp_dopple tmp_ganger mkdir tmp_dopple cd tmp_dopple darcs init touch a.txt darcs add a.txt darcs record -A base -am 'adding a.txt' cd .. darcs get tmp_dopple tmp_ganger for repo in tmp_dopple tmp_ganger; do echo working on $repo cd $repo echo "text which appears in both places at once" > a.txt darcs record -A $repo -am "recording an identical change in $repo" cd .. done # Now that the conflict has been set up, try pull one patch from the other. cd tmp_ganger darcs pull -a ../tmp_dopple > out check_conflict cd .. # Checking resolution dopplegangers conflicts rm -rf temp0 temp1 temp2 tmp_dopple tmp_ganger mkdir temp0 cd temp0 darcs init cd .. # Create a conflict darcs get temp0 temp1 cd temp1 darcs show repo echo temp1 > a.txt darcs add a.txt darcs record -A base -am 'adding temp1 a.txt' cd .. darcs get temp0 temp2 cd temp2 echo temp2 > a.txt darcs add a.txt darcs record -A base -am 'adding temp2 a.txt' cd .. # Resolve the conflict the same way on both sides for repo in tmp_dopple tmp_ganger; do echo working on $repo darcs get temp1 $repo cd $repo darcs pull -a ../temp2 echo "text which appears in both places at once" > a.txt darcs record -A $repo -am "recording an identical change in $repo" cd .. done # Now that the conflict has been set up, try pull one patch from the other. cd tmp_ganger darcs pull -a ../tmp_dopple > out check_conflict darcs-2.10.2/tests/issue1909-unrecord-O-misses-tag.sh0000644000175000017500000000063612620122474024165 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## issue1909: unrecord -O in tagged repo makes a busted bundle . lib rm -rf R mkdir R darcs init --repo R echo a > R/a darcs rec -lam a --repo R --ignore-times darcs tag -m T --repo R echo b > R/a darcs rec -lam b --repo R --ignore-times echo c > R/a darcs rec -lam c --repo R --ignore-times darcs unpull -p c -a --repo R -O --no-minimize cat c.dpatch grep '^\[b' c.dpatch grep TAG c.dpatch darcs-2.10.2/tests/issue1922-obliterate-o-context.sh0000644000175000017500000000333512620122474024140 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for issue1922 - obliterate -o does not give the right context ## ## 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. rm -rf x mkdir x darcs init --repo x echo a > x/a darcs rec -lam a --repo x --ig echo b > x/a darcs rec -lam b --repo x --ig echo a > x/b darcs rec -lam a2 --repo x --ig echo b > x/b darcs rec -lam b2 --repo x --ig echo c > x/a darcs rec -lam c --repo x --ig rm -f foo.dpatch darcs unpull -a -o foo.dpatch --match 'name a2' --repo x --last 3 cat foo.dpatch darcs changes --context --repo x darcs apply foo.dpatch --repo xdarcs-2.10.2/tests/amend-unrecord.sh0000644000175000017500000000420312620122474021322 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for amend --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 yyny) | darcs amend --unrecord (echo x ; echo y ; echo 2) > foo.expected darcs show contents foo | diff -q foo.expected - (echo yenyy) | DARCS_EDITOR="sed -i -e s/2/2j/" darcs amend --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 --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 - darcs-2.10.2/tests/lib0000644000175000017500000000532712620122474016564 0ustar00guillaumeguillaume00000000000000# This is a -*- sh -*- library. ## I would use the builtin !, but that has the wrong semantics. not () { "$@" && exit 1 || :; } # trick: OS-detection (if needed) abort_windows () { if echo $OS | grep -i windows; then echo This test does not work on Windows exit 200 fi } pwd() { ghc --make -o hspwd "$TESTBIN/hspwd.hs" > /dev/null "./hspwd" } which() { type -P "$@" | cut -d' ' -f 3- } # switch locale to one supporting the latin-9 (ISO 8859-15) character set if possible, otherwise skip test no_latin9_locale_warning () { echo "no ISO 8859-15 locale found, skipping test" echo "try (eg): sudo locale-gen en_US.ISO-8859-15" } switch_to_latin9_locale () { if echo $OS | grep -i windows; then chcp.com 28605 else if ! which locale ; then echo "no locale command, skipping test" exit 200 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) test -n "$latin9_locale" || (no_latin9_locale_warning; exit 200) echo "Using locale $latin9_locale" export LC_ALL=$latin9_locale echo "character encoding is now `locale charmap`" fi } # 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 chcp.com 65001 else if ! which locale ; then echo "no locale command" exit 200 # skip test fi utf8_locale=`locale -a | grep .utf8 | head -n 1` || exit 200 test -n "$utf8_locale" || exit 200 echo "Using locale $utf8_locale" export LC_ALL=$utf8_locale echo "character encoding is now `locale charmap`" fi } serve_http() { cat > light.conf < /dev/null 2>&1 || exit 200 baseurl="http://localhost:23032" } finish_http() { test -e "$1/light.pid" && kill `cat "$1/light.pid"` || true } skip-formats() { for f in "$@"; do grep $f $HOME/.darcs/defaults && exit 200 || true; done } # check that the specified string appears precisely once in the output grep-once() { grep -c "$@" | grep -w 1 } require_ghc() { test $GHC_VERSION -ge $1 || exit 200 } grep -q darcs-2 .darcs/defaults && format=darcs-2 grep -q darcs-1 .darcs/defaults && format=darcs-1 set -vex -o pipefail darcs-2.10.2/tests/gzcrcs.sh0000644000175000017500000000313212620122474017712 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash ## Test for gzcrcs command - check and repair corrupted CRCs on ## compressed files ## ## 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. # need to do this before loading lib as that sets -e darcs gzcrcs --help > /dev/null if [ $? == 2 ] ; then echo gzcrcs not supported by this darcs ; exit 0 ; fi . lib # Load some portability helpers. rm -rf maybench-crc gunzip -c $TESTDATA/maybench-crc.tgz | tar xf - cd maybench-crc not darcs gzcrcs --check darcs gzcrcs --repair darcs gzcrcs --check cd .. rm -rf maybench-crc darcs-2.10.2/tests/failing-issue1013_either_dependency.sh0000644000175000017500000000262512620122474025227 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib 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 darcs-2.10.2/tests/harness.sh0000644000175000017500000000143612620122474020067 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash . ./lib # Print some stuff out for debugging if something goes wrong: echo $HOME echo $PATH which darcs command -v darcs # Check things that should be true when all the testscripts run test -f "$HOME/lib" password="AKARABNADABARAK-KARABADANKBARAKA" grep $password "$HOME/test" || grep $password "$HOME/harness.sh" if echo $OS | grep -i windows; then if echo $OSTYPE | grep -i cygwin ; then real=$(cygpath -w $(command -v darcs.exe) | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') else real=$(cmd //c echo $(command -v darcs.exe) | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') fi wanted=$(echo "$DARCS" | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') test "$real" = "$wanted" else command -v darcs | fgrep "$DARCS" fi darcs-2.10.2/tests/get-http-packed.sh0000644000175000017500000000113312620122474021377 0ustar00guillaumeguillaume00000000000000#!/usr/bin/env bash # Written in 2010 by Petr Rockai, placed in public domain #pragma repo-format darcs-1,darcs-2 . lib rm -rf S if grep darcs-1 .darcs/defaults; then format=hashed elif grep darcs-2 .darcs/defaults; then format=darcs-2 else format=ERROR; fi gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - cd many* 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/many-files--${format} S cd S rm _darcs/prefs/sources # avoid any further contact with the original repository darcs check darcs-2.10.2/tests/issue2153-allow-skipping-backwards-through-depended_upon-patches.sh0000644000175000017500000000117012620122474032671 0ustar00guillaumeguillaume00000000000000#!/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 darcs-2.10.2/tests/failing-issue1632_changes_nonexisting.sh0000644000175000017500000000327712620122474025621 0ustar00guillaumeguillaume00000000000000#!/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 .. darcs-2.10.2/harness/0000755000175000017500000000000012620122474016365 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/harness/Darcs/0000755000175000017500000000000012620122474017421 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/harness/Darcs/Test/0000755000175000017500000000000012620122474020340 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/harness/Darcs/Test/Misc.hs0000644000175000017500000001066312620122474021575 0ustar00guillaumeguillaume00000000000000-- 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 Darcs.Util.ByteString ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex ) import Darcs.Util.Diff.Myers ( shiftBoundaries ) import qualified Data.ByteString.Char8 as BC ( unpack, pack ) import qualified Data.ByteString as B ( concat, empty ) 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 ) testSuite :: Test testSuite = testGroup "" [ byteStringUtilsTestSuite , lcsTestSuite ] -- ---------------------------------------------------------------------- -- * Darcs.Util.ByteString -- Here are a few quick tests of the shiftBoundaries function. -- ---------------------------------------------------------------------- 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 "" (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],[])] darcs-2.10.2/harness/Darcs/Test/Email.hs0000644000175000017500000001032712620122474021726 0ustar00guillaumeguillaume00000000000000-- 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 Darcs.Util.Printer ( text, renderPS, RenderMode(..) ) import Darcs.UI.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 Standard $ 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 /= ':') darcs-2.10.2/harness/Darcs/Test/Patch/0000755000175000017500000000000012620122474021377 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/harness/Darcs/Test/Patch/WithState.hs0000644000175000017500000001242312620122474023651 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} module Darcs.Test.Patch.WithState where import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Show import Test.QuickCheck ( Gen, sized, choose ) ---------------------------------------------------------------------- -- * WithState data WithState s p wX wY = WithState { wsStartState :: s wX , wsPatch :: p wX wY , wsEndState :: s wY } deriving Eq instance (Show1 s, Show2 p) => Show (WithState s 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 s, Show2 p) => Show2 (WithState s p) where showDict2 = ShowDictClass 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) 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 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) 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 wX -> Gen (Sealed (WithEndState s (p wX))) -- 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 wX . Int -> s wX -> Gen (Sealed (WithEndState s (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 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 wX) -> Gen (Sealed2 p) makeS2Gen stGen = do s <- stGen Sealed (WithEndState p _) <- arbitraryState s return $ seal2 p makeSGen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed (p wX)) makeSGen stGen = do s <- stGen Sealed (WithEndState p _) <- arbitraryState s return $ seal p makeWS2Gen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed2 (WithState s p)) makeWS2Gen stGen = do s <- stGen Sealed (WithEndState wsP _) <- arbitraryState s return $ seal2 wsP makeWSGen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed (WithState s p wX)) makeWSGen stGen = do s <- stGen Sealed (WithEndState wsP _) <- arbitraryState s return $ seal wsP instance (Show2 p, Show1 s) => Show1 ((WithState s p) wA) where showDict1 = ShowDictClass darcs-2.10.2/harness/Darcs/Test/Patch/Rebase.hs0000644000175000017500000000252712620122474023142 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE EmptyDataDecls #-} module Darcs.Test.Patch.Rebase ( testSuite ) where import Control.Monad ( unless ) import Test.Framework ( Test ) import Test.Framework.Providers.HUnit ( testCase ) import Test.HUnit ( assertFailure ) import Darcs.Patch import Darcs.Patch.Conflict import Darcs.Patch.Rebase import Darcs.Patch.Rebase.Viewing import Darcs.Patch.Type import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Show import Darcs.Test.Patch.Arbitrary.Generic testSuite :: forall p . (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType p -> [Test] testSuite pt = if hasPrimConstruct (undefined :: PrimOf p WX WX) then [ duplicateConflictedEffect pt ] else [ ] data WX duplicateConflictedEffect :: forall p . (RepoPatch p, Show2 (PrimOf p)) => PatchType 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 "./file" rebase :: RebaseChange p WX WX rebase = RCFwd (PrimFixup (invert corePrim) :>: NilFL) (fromPrim corePrim :>: NilFL) cEffect = conflictedEffect rebase cStatuses = map (\(IsC status _) -> status) cEffect darcs-2.10.2/harness/Darcs/Test/Patch/WSub.hs0000644000175000017500000001144312620122474022616 0ustar00guillaumeguillaume00000000000000{-# 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 ( coalesce ) import qualified Darcs.Patch.Witnesses.Ordered as W import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Show import Darcs.Patch.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(..) ) 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 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) wX wY) 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) wX wY) 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 wX wY) 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) 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 (RealPatch Prim) wX wY -> [Sealed2 (RealPatch Prim :> RealPatch Prim)] getPairs = map (mapSeal2 fromW) . W.getPairs . toW getTriples :: FL (RealPatch Prim) wX wY -> [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)] getTriples = map (mapSeal2 fromW) . W.getTriples . toW coalesce :: (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY) coalesce = fmap fromW . W.coalesce . toW darcs-2.10.2/harness/Darcs/Test/Patch/Examples/0000755000175000017500000000000012620122474023155 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/harness/Darcs/Test/Patch/Examples/Set1.hs0000644000175000017500000004352312620122474024334 0ustar00guillaumeguillaume00000000000000-- 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.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( unsafeUnseal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) #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) 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 ~ Prim) => Int -> String -> String -> p wX wY 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) 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 :: [(FL Patch :> FL Patch) wX wY] commutePairs = take 200 [(p1:>p2)| p1<-testPatches, p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatches, commute (p1:>p2) /= Nothing] primitiveCommutePairs :: [(FL Patch :> FL Patch) wX wY] 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:: 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) 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)), (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 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 $ 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 darcs-2.10.2/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs0000644000175000017500000006224712620122474026572 0ustar00guillaumeguillaume00000000000000-- 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 #-} 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.Patch.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.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import qualified Darcs.Test.Patch.Arbitrary.Real as W ( notDuplicatestriple ) --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, makeName, makeFile) import Darcs.Test.Patch.WithState ( WithStartState(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(FP), FilePatchType(Hunk) ) import Darcs.Util.Path ( 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 wX 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) 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 :: [(Prim :> Prim :> Prim) wX wY] primPermutables = [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"] mergeables :: [(Prim :\/: Prim) 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 Prim :\/: FL Prim) 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 Prim :> FL Prim) wX wY] commutablesFL = map mergeable2commutable mergeablesFL commutables :: [(Prim :> Prim) wX wY] commutables = map mergeable2commutable mergeables primPatches :: [Prim wX wY] primPatches = concatMap mergeable2patches mergeables where mergeable2patches (x:\/:y) = [x,y] realPatches :: [RealPatch Prim wX wY] realPatches = concatMap commutable2patches realCommutables where commutable2patches (x:>y) = [x,y] realTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) wX wY] 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) wX wY] realNonduplicateTriples = filter (notDuplicatestriple) realTriples realFLs :: [FL (RealPatch Prim) wX wY] 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) wX wY] 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) wX wY] 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) wX wY) pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y) return $ unsafeCoerceP (xx :\/: y') realIglooMergeables :: [(RealPatch Prim :\/: RealPatch Prim) wX wY] 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) wX wY] 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) wX wY) 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) darcs-2.10.2/harness/Darcs/Test/Patch/V1Model.hs0000644000175000017500000002120012620122474023175 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} -- | 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.Patch.Witnesses.Sealed ( Sealed, seal ) import Darcs.Patch.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 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 instance Show (V1Model wX) 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 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 $ 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 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 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 darcs-2.10.2/harness/Darcs/Test/Patch/Utils.hs0000644000175000017500000000203412620122474023032 0ustar00guillaumeguillaume00000000000000module 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 darcs-2.10.2/harness/Darcs/Test/Patch/Arbitrary/0000755000175000017500000000000012620122474023336 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs0000644000175000017500000003314712620122474025020 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, 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.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered 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.UI.Commands.Replace ( defaultToks ) import Darcs.Patch.Prim import Control.Applicative ( (<$>) ) import qualified Data.ByteString.Char8 as BC import Data.Maybe ( isJust ) #include "impossible.h" patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t patchFromTree = T.patchFromTree mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t mergePairFromTree = T.mergePairFromTree mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) wX -> t mergePairFromTWFP = T.mergePairFromTWFP commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) wX -> t commutePairFromTWFP = T.commutePairFromTWFP commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t commutePairFromTree = T.commutePairFromTree commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t commuteTripleFromTree = T.commuteTripleFromTree nonEmptyHunk :: (IsHunk p) => p wX wY -> Bool nonEmptyHunk p | Just (FileHunk _ _ [] []) <- isHunk p = False | otherwise = True nonEmptyHunksPair :: (IsHunk p) => (p :> p) wX wY -> Bool nonEmptyHunksPair (p1 :> p2) = nonEmptyHunk p1 && nonEmptyHunk p2 nonEmptyHunksTriple :: (IsHunk p) => (p :> p :> p) wX wY -> Bool nonEmptyHunksTriple (p1 :> p2 :> p3) = nonEmptyHunk p1 && nonEmptyHunk p2 && nonEmptyHunk p3 nonEmptyHunksFLPair :: (IsHunk p) => (FL p :> FL p) wX wY -> 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 MightBeEmptyHunk Prim where isEmptyHunk (FP _ (Hunk _ [] [])) = True isEmptyHunk _ = False instance MightHaveDuplicate Prim instance Arbitrary (Sealed2 (FL (WithState V1Model Prim))) where arbitrary = do repo <- ourSmallRepo liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo -- instance Show1 (TreeWithFlattenPos Prim) where -- showDict1 = ShowDictClass -- WithState and propFail are handy for debugging arbitrary code propFail :: Int -> Tree Prim wX -> Bool propFail n xs = sizeTree xs < n ---------------------------------------------------------------------- -- * QuickCheck generators ---------------------------------------------------------------------- -- ** FilePatchType generators aHunk :: forall wX wY . Content -> Gen (FilePatchType wX wY) 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 wX wY . Content -> Gen (FilePatchType wX wY) 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 wX wY . (AnchoredPath,File) -> Gen (Prim wX wY) aHunkP (path,file) = do Hunk pos old new <- aHunk content return $ hunk (ap2fp path) pos old new where content = fileContent file aTokReplaceP :: forall wX wY . (AnchoredPath,File) -> Gen (Prim wX wY) aTokReplaceP (path,file) = do TokReplace tokchars old new <- aTokReplace content return $ tokreplace (ap2fp path) tokchars old new where content = fileContent file anAddFileP :: forall wX wY . (AnchoredPath,Dir) -> Gen (Prim wX wY) 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 wX wY . AnchoredPath -- ^ Path of an empty file -> Prim wX wY aRmFileP path = rmfile (ap2fp path) anAddDirP :: forall wX wY . (AnchoredPath,Dir) -> Gen (Prim wX wY) 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 wX wY . AnchoredPath -- ^ Path of an empty directory -> Prim wX wY aRmDirP path = rmdir (ap2fp path) aMoveP :: forall wX wY . 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 (ap2fp oldPath) (ap2fp newPath) where existing = map fst $ dirContent dir -- | Generates any type of 'Prim' patch, except binary and setpref patches. aPrim :: forall wX wY . V1Model wX -> Gen (WithEndState V1Model (Prim wX) wY) 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 wX wY . (AnchoredPath,File) -> Gen ((Prim :> Prim) wX wY) 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 wX wY . V1Model wX -> Gen (WithEndState V1Model ((Prim :> Prim) wX) wY) 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 wX) 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) wA)) 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) wA)) where arbitrary = makeSGen ourSmallRepo instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where arbitrary = makeS2Gen ourSmallRepo instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where arbitrary = makeSGen ourSmallRepo instance Arbitrary (Sealed2 (WithState V1Model Prim)) where arbitrary = makeWS2Gen ourSmallRepo instance Arbitrary (Sealed (WithState V1Model Prim wA)) where arbitrary = makeWSGen ourSmallRepo instance Arbitrary (Sealed (WithState V1Model (FL Prim) wA)) 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 darcs-2.10.2/harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs0000644000175000017500000002413412620122474025144 0ustar00guillaumeguillaume00000000000000-- 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 #-} 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.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) ) import Darcs.Patch.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 ) import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate ) #include "impossible.h" type Patch = V1.Patch Prim class ArbitraryP p where arbitraryP :: Gen (Sealed (p wX)) {- 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 wX)) where arbitrary = arbitraryP instance Arbitrary (Sealed (FL Patch wX)) 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 instance MightHaveDuplicate (V1.Patch prim) hunkgen :: Gen (Sealed (Prim wX)) 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 wX)) 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 wY . FilePath -> FilePath -> Prim wX wY) -> Gen (Sealed (Prim wX)) 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 wX)) 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 wX)) 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 wX)) onepatchgen = oneof [simplepatchgen, mapSeal (invert . unsafeCoerceP) `fmap` simplepatchgen] norecursgen :: Int -> Gen (Sealed (FL Patch wX)) 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 wX)) 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 wX)) 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 wX)) 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 wX)) 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 wX)) 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 wX wY -> FL Patch wX wY regularizePatches patches = rpint (unsafeCoerceP NilFL) patches where -- this reverses the list, which seems odd and causes -- the witness unsafety rpint :: FL Patch wX wY -> FL Patch wA wB -> FL Patch wX wY 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 darcs-2.10.2/harness/Darcs/Test/Patch/Arbitrary/Real.hs0000644000175000017500000000604112620122474024556 0ustar00guillaumeguillaume00000000000000{-# 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.Patch.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.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Prim ( FromPrim(..) ) nontrivialReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY -> Bool nontrivialReals = nontrivialCommute nontrivialCommute :: (Patchy p, MyEq p) => (p :> p) wX wY -> 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) wX wY -> Bool nontrivialMergeReals = nontrivialMerge nontrivialMerge :: (Patchy p, MyEq 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) instance MightHaveDuplicate (RealPatch prim) where hasDuplicate = isDuplicate instance (RepoModel (ModelOf prim), ArbitraryPrim prim) => Arbitrary (Sealed2 (FL (RealPatch prim))) where arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim))) 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) wX wY -> Bool notDuplicatestriple (a :> b :> c) = not (isDuplicate a || isDuplicate b || isDuplicate c) nontrivialTriple :: PrimPatch prim => (RealPatch prim :> RealPatch prim :> RealPatch prim) 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')) darcs-2.10.2/harness/Darcs/Test/Patch/Arbitrary/PrimV3.hs0000644000175000017500000002365512620122474025025 0ustar00guillaumeguillaume00000000000000-- TODO: Remove these warning disabling flags... {-# OPTIONS_GHC -w #-} {-# LANGUAGE CPP, 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.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered 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.UI.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 "impossible.h" patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t patchFromTree = T.patchFromTree mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t mergePairFromTree = T.mergePairFromTree mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) wX -> t mergePairFromTWFP = T.mergePairFromTWFP commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) wX -> t commutePairFromTWFP = T.commutePairFromTWFP commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t commutePairFromTree = T.commutePairFromTree commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t commuteTripleFromTree = T.commuteTripleFromTree type instance ModelOf Prim = V3Model instance ArbitraryPrim Prim where runCoalesceTests _ = False hasPrimConstruct _ = False 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 wX -> Bool propFail n xs = sizeTree xs < n ---------------------------------------------------------------------- -- * QuickCheck generators aHunk :: forall wX wY . BS.ByteString -> Gen (Hunk wX wY) 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 wX wY . (UUID, Object Fail) -> Gen (Prim wX wY) aTextHunk (uuid, (Blob text _)) = do hunk <- aHunk (unFail text) return $ TextHunk uuid hunk aManifest :: forall wX wY . UUID -> Location -> Object Fail -> Gen (Prim wX wY) aManifest uuid loc (Directory dir) = do newFilename <- aFilename `notIn` (M.keys dir) return $ Manifest uuid loc aDemanifest :: forall wX wY . 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 :: forall wX wY . V3Model wX -> Gen (WithEndState V3Model (Prim wX) wY) 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 wX wY . (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY) 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 wX wY . V3Model wX -> Gen (WithEndState V3Model ((Prim :> Prim) wX) wY) 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 wX) 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) wA)) 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) wA)) where arbitrary = makeSGen ourSmallRepo instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where arbitrary = makeS2Gen ourSmallRepo instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where arbitrary = makeSGen ourSmallRepo instance Arbitrary (Sealed2 (WithState V3Model Prim)) where arbitrary = makeWS2Gen ourSmallRepo instance Arbitrary (Sealed (WithState V3Model Prim wA)) where arbitrary = makeWSGen ourSmallRepo instance Arbitrary (Sealed (WithState V3Model (FL Prim) wA)) 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 darcs-2.10.2/harness/Darcs/Test/Patch/Arbitrary/Generic.hs0000644000175000017500000002762012620122474025255 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-} {-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, ViewPatterns #-} module Darcs.Test.Patch.Arbitrary.Generic ( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim(..), NullPatch(..), RepoModel(..) , MightBeEmptyHunk(..), MightHaveDuplicate(..) , 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.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.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.Patch.Witnesses.Show --import Darcs.Util.Printer ( greenText, ($$) ) -- | Generate a patch to a certain state. class ArbitraryStateIn s p where arbitraryStateIn :: s wX -> Gen (p wX) 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) where showDict1 = ShowDictClass instance Show2 p => Show1 (TreeWithFlattenPos p) where showDict1 = ShowDictClass sizeTree :: Tree p wX -> Int sizeTree NilTree = 0 sizeTree (SeqTree _ t) = 1 + sizeTree t sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2 -- newtype G1 l p wX = G1 { _unG1 :: l (p wX) } newtype G2 l p wX wY = G2 { unG2 :: l (p wX wY) } 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'] 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 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))] class NullPatch p where nullPatch :: p wX wY -> EqCheck wX wY class MightBeEmptyHunk p where -- |V1 Prims support the value 'Hunk n [] []' that is treated specially in the -- commute code and ends up breaking certain tests by behaving anomalously. -- In practice they shouldn't appear in real repositories. For later, -- as yet unreleased patch types, we should eliminate them completely. -- An alternative to using this as a guard might be to avoid generating them. isEmptyHunk :: p wX wY -> Bool isEmptyHunk _ = False instance MightBeEmptyHunk (FL p) class MightHaveDuplicate p where -- |"duplicates" in V2 patches (RealPatch) have lots of bugs -- that break various commute/merge properties. hasDuplicate :: p wX wY -> Bool hasDuplicate _ = False instance MightHaveDuplicate p => MightHaveDuplicate (FL p) where hasDuplicate NilFL = False hasDuplicate (p :>: ps) = hasDuplicate p || hasDuplicate ps class ( ArbitraryState (ModelOf prim) prim , NullPatch prim , PrimPatch prim , RepoModel (ModelOf prim) ) => ArbitraryPrim prim where -- hooks to disable certain kinds of tests for certain kinds of patches runCoalesceTests :: prim wX wY -> Bool runCoalesceTests _ = True hasPrimConstruct :: prim wX wY -> Bool hasPrimConstruct _ = True -- 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) 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) wX -> Sealed (FL p wX) 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 wX = TWFP Int (Tree p wX) commutePairFromTWFP :: (FromPrim p, Merge p, PrimPatchBase p) => (forall wY wZ . (p :> p) wY wZ -> t) -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) wX -> 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 wY wZ . (p :> p) wY wZ -> t) -> (WithStartState model (Tree (PrimOf p)) wX -> 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 wY wZ . (p :> p :> p) wY wZ -> t) -> (WithStartState model (Tree (PrimOf p)) wX -> 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 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, Merge p, Invert p, PrimPatchBase p) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) wX -> t) mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x) mergePairFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> (WithStartState model (Tree (PrimOf p)) wX -> t) mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x) patchFromCommutePair :: (Commute p, Invert p) => (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, Invert p, PrimPatchBase p) => (forall wY wZ . p wY wZ -> t) -> (WithStartState model (Tree (PrimOf p)) wX -> 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 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 wX -> Sealed (FL (RealPatch prim) wX) flattenOneRP = flattenOne darcs-2.10.2/harness/Darcs/Test/Patch/Info.hs0000644000175000017500000001620512620122474022632 0ustar00guillaumeguillaume00000000000000-- 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 Darcs.Util.ByteString ( 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 darcs-2.10.2/harness/Darcs/Test/Patch/Properties/0000755000175000017500000000000012620122474023533 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/harness/Darcs/Test/Patch/Properties/Real.hs0000644000175000017500000000314712620122474024757 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} 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.Patch.Witnesses.Sealed( Sealed(..) ) import Darcs.Patch.V2.Real( prim2real ) import Darcs.Patch.Prim.V1 ( Prim ) #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) darcs-2.10.2/harness/Darcs/Test/Patch/Properties/V1Set1.hs0000644000175000017500000001554212620122474025121 0ustar00guillaumeguillaume00000000000000{-# 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 Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Show ( ShowPatchBasic ) import qualified Darcs.Patch.V1 as V1 ( Patch ) import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check ) import Darcs.Util.Printer ( renderPS, RenderMode(..) ) 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.Patch Prim quickmerge :: (Patchy p, Merge p) => (p :\/: p ) wX wY -> p wY wZ quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of _ :/\: p1' -> unsafeCoercePEnd p1' instance Show2 p => Show ((p :< p) wX wY) where show (x :< y) = show2 x ++ " :< " ++ show2 y instance MyEq p => Eq ((p :/\: p) wX wY) 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) wX wY, FL Patch wY wZ) -> 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) 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 `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 wX wY . (FL Patch wX wY, FL Patch wX wY) -> TestResult checkCanon (p1,p2) = if isIsEq $ eqFL p1_ p2 then if isIsEq $ eqFL p1_p p2 then succeeded else failed $ text $ "Canonization with Patience Diff failed:\n"++show p1++"canonized is\n" ++show (p1_p :: FL Patch wX wY) ++"which is not\n"++show p2 else failed $ text $ "Canonization with Myers Diff failed:\n"++show p1++"canonized is\n" ++show (p1_ :: FL Patch wX wY) ++"which is not\n"++show p2 where p1_ = mapFL_FL fromPrim $ concatFL $ mapFL_FL (canonize D.MyersDiff) $ sortCoalesceFL $ effect p1 p1_p = mapFL_FL fromPrim $ concatFL $ mapFL_FL (canonize D.PatienceDiff) $ sortCoalesceFL $ effect p1 checkCommute :: ((FL Patch:< FL Patch) wX wY, (FL Patch:< FL Patch) wX wY) -> TestResult checkCommute (p1: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) wX wY -> TestResult checkCantCommute (p1: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, 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 Standard $ 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 wX wY p . (Check p, Show2 p, Merge p, Patchy p) => (p :\/: p) wX wY -> 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 wX wY . FL Patch wX wY -> TestResult tTestCheck p = if checkAPatch p then succeeded else failed $ text $ "Failed the check: "++show p++"\n" darcs-2.10.2/harness/Darcs/Test/Patch/Properties/Generic.hs0000644000175000017500000004777212620122474025464 0ustar00guillaumeguillaume00000000000000-- 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 #-} module Darcs.Test.Patch.Properties.Generic ( invertSymmetry, inverseComposition, invertRollback, recommute, commuteInverses, effectPreserving, permutivity, partialPermutivity, patchAndInverseCommute, mergeEitherWay, show_read, mergeCommute, mergeConsistent, mergeArgumentsConsistent, coalesceEffectPreserving, coalesceCommute, 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, MightBeEmptyHunk(..), MightHaveDuplicate(..) ) import Control.Monad ( msum ) import Darcs.Patch.Witnesses.Show ( Show2(..), show2 ) import Darcs.Patch.Patchy ( Patchy, showPatch, commute, invert ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Show ( ShowPatchBasic ) 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.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:/\:)(..), lengthFL, eqFL, reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal2, Sealed2 ) import Darcs.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text, RenderMode(..) ) --import Darcs.ColorPrinter ( traceDoc ) propIsMergeable :: forall model p wX . (FromPrim p, Merge p, RepoModel model) => Sealed (WithStartState model (Tree (PrimOf p))) -> Maybe (Tree p wX) 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, MyEq p) => p wA wB -> TestResult invertSymmetry p = case invert (invert p) =\/= p of IsEq -> succeeded NotEq -> failed $ redText "p /= inv(inv(p))" inverseComposition :: (Patchy p, MyEq p) => (p :> p) wX wY -> 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, ShowPatchBasic p, RepoModel model) => WithState model 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 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, ShowPatchBasic p, MyEq p, MightHaveDuplicate p) => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY))) -> (p :> p) wA wB -> TestResult recommute c (x :> y) = case c (x :> y) of Nothing -> rejected Just (y' :> x') -- this test unfortunately fails on some V2 patches that contain duplicates -- after the commute. While in theory the underlying bug should be fixed, -- we don't know how to and even if we did, it would probably involve a repository -- migration to a new patch type. | hasDuplicate y' || hasDuplicate x' -> rejected | otherwise -> case c (y' :> x') of Nothing -> failed (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x') Just (x'' :> y'') -> 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, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p) wA wB -> 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, MightBeEmptyHunk p, RepoModel model, ApplyState p ~ RepoState model) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> WithState model (p :> p) wA wB -> TestResult effectPreserving _ (WithState _ (x :> _) _) | isEmptyHunk x = rejected effectPreserving c (WithState r (x :> y) r') = case c (x :> y) of Nothing -> rejected 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, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p) wA wB -> 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, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (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 -> 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, ShowPatchBasic p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p :> p) wA wB -> 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, ShowPatchBasic p) => (forall wX wY . p wX wY -> Maybe Doc) -> (p :\/: p) wA wB -> 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, 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' -> 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, MyEq 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 "mergeEitherWay bug" mergeCommute :: (Patchy p, MyEq p, ShowPatchBasic p, Merge p, MightHaveDuplicate p) => (p :\/: p) wX wY -> TestResult mergeCommute (x :\/: y) = case merge (x :\/: y) of y' :/\: x' -- this test unfortunately fails on some V2 patches that contain duplicates -- after the merge. While in theory the underlying bug should be fixed, -- we don't know how to and even if we did, it would probably involve a repository -- migration to a new patch type. | hasDuplicate x' || hasDuplicate y' -> rejected | otherwise -> case commute (x :> y') of Nothing -> failed $ redText "mergeCommute 1" $$ redText "x" $$ showPatch x $$ 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_ -- | coalesce effect preserving coalesceEffectPreserving :: (PrimPatch prim, RepoModel model, ApplyState prim ~ RepoState model ) => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY)) -> WithState model (prim :> prim) wA wB -> TestResult coalesceEffectPreserving 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'" coalesceCommute :: (PrimPatch prim, MightBeEmptyHunk prim) => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY)) -> (prim :> prim :> prim) wA wB -> TestResult coalesceCommute _ (a :> _ :> _) | isEmptyHunk a = rejected coalesceCommute j (a :> b :> c) = case j (b :> c) of Nothing -> rejected 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 "coalesceCommute 3" IsEq -> case j (b' :> c') of Nothing -> failed $ greenText "coalesceCommute 4" Just x'' -> case x' =\/= x'' of NotEq -> failed $ greenText "coalesceCommute 5" IsEq -> succeeded _ -> failed $ greenText "coalesceCommute 1" _ -> rejected show_read :: (Show2 p, MyEq p, ReadPatch p, ShowPatchBasic p, Patchy p) => p wA wB -> TestResult show_read p = let ps = renderPS Standard (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 : darcs-2.10.2/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs0000644000175000017500000001111412620122474027672 0ustar00guillaumeguillaume00000000000000module Darcs.Test.Patch.Properties.GenericUnwitnessed where import qualified Darcs.Test.Patch.Properties.Generic as W ( permutivity, partialPermutivity , mergeConsistent, mergeArgumentsConsistent, mergeEitherWay , mergeCommute, patchAndInverseCommute, coalesceCommute, commuteInverses , recommute , show_read ) import Darcs.Test.Patch.Arbitrary.Generic ( Tree, MightBeEmptyHunk, MightHaveDuplicate ) 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.Patch.Read ( ReadPatch ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Sealed( Sealed ) import Darcs.Patch.Merge ( Merge ) import Darcs.Patch ( Patchy ) import Darcs.Util.Printer ( Doc, redText, ($$) ) import qualified Storage.Hashed.Tree as HST ( Tree ) permutivity :: (Patchy wp, ShowPatchBasic wp, MyEq 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 partialPermutivity :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p :> p) wA wB -> TestResult partialPermutivity f = W.partialPermutivity (fmap toW . f . fromW) . toW mergeEitherWay :: (Patchy wp, ShowPatchBasic wp, MyEq wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult mergeEitherWay = W.mergeEitherWay . toW commuteInverses :: (Patchy wp, ShowPatchBasic wp, MyEq 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) . toW recommute :: (Patchy wp, ShowPatchBasic wp, MightHaveDuplicate wp, MyEq wp, WSub wp p) => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY))) -> (p :> p) wA wB -> TestResult recommute f = W.recommute (fmap toW . f . fromW) . toW mergeCommute :: (Patchy wp, MightHaveDuplicate wp, ShowPatchBasic wp, MyEq wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult mergeCommute = W.mergeCommute . toW mergeConsistent :: (Patchy wp, Merge wp, ShowPatchBasic wp, WSub wp p) => (forall wX wY . p wX wY -> Maybe Doc) -> (p :\/: p) wA wB -> TestResult mergeConsistent f = W.mergeConsistent (f . fromW) . toW mergeArgumentsConsistent :: (Patchy wp, 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 show_read :: (Patchy p, ShowPatchBasic p, ReadPatch p, MyEq p, Show2 p) => p wX wY -> TestResult show_read = W.show_read patchAndInverseCommute :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> (p :> p) wA wB -> TestResult patchAndInverseCommute f = W.patchAndInverseCommute (fmap toW . f . fromW) . toW coalesceCommute :: MightBeEmptyHunk Prim => (forall wX wY . (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY)) -> (Prim :> Prim :> Prim) wA wB -> TestResult coalesceCommute f = W.coalesceCommute (fmap toW . f . fromW) . toW consistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model) => Sealed (WithStartState model (Tree Prim)) -> TestResult consistentTreeFlattenings = (\x -> if W.propConsistentTreeFlattenings x then succeeded else failed $ redText "oops") commuteFails :: (MyEq p, Patchy p, 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" $$ showPatch x $$ redText ":> y" $$ showPatch y $$ redText "y'" $$ showPatch y' $$ redText ":> x'" $$ showPatch x' darcs-2.10.2/harness/Darcs/Test/Patch/Properties/Check.hs0000644000175000017500000000717712620122474025120 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP #-} module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where import Control.Monad ( liftM ) import Darcs.Test.Patch.Check ( PatchCheck, checkMove, removeDir, createDir, isValid, insertLine, fileEmpty, fileExists, deleteLine, modifyFile, createFile, removeFile, doCheck, 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 Darcs.Util.Path ( fn2fp ) import qualified Data.Map as M ( mapMaybe ) import Darcs.Patch ( invert, 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.Patch.Witnesses.Ordered #include "impossible.h" class Check p where checkPatch :: p wX wY -> 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 wX wY -> 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 darcs-2.10.2/harness/Darcs/Test/Patch/Properties/V1Set2.hs0000644000175000017500000003434112620122474025120 0ustar00guillaumeguillaume00000000000000-- 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 #-} 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 Darcs.Util.Printer ( renderPS, RenderMode(..) ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal, unseal, mapSeal, Sealed2(..) ) import Darcs.Patch.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 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) _ -> 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) 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 $ 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 wX wY -> Patch wX wZ -> Patch wZ wW -> 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 wX wY -> Patch wX wZ -> 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 wX wY -> Patch wX wZ -> 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 wX)] -> Sealed (FL Patch wX) mergeList patches = mapFL_FL fromPrim `mapSeal` doml NilFL patches where doml :: FL Prim wX wY -> [Sealed (FL Prim wX)] -> Sealed (FL Prim wX) 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 wX wY -> Bool propReadShow p = case readPatch $ renderPS Standard $ 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': case runWrappedCommuteFunction c (invert p2:< p1') of Succeeded (p1'': 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 -- speedyCommute will never be "nontrivial" (names, cs) = unzip . filter ((/= "speedyCommute") . fst) $ subcommutes prop_subcommute c (Sealed2 (p1 :> p2)) = nontrivial c p1 p2 ==> case runWrappedCommuteFunction c (p2:< p1) of Succeeded (p1': case runWrappedCommuteFunction c (invert p2:< p1') of Succeeded (p1'': 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 -- speedyCommute will never fail (it just returns "Unknown") (names, cs) = unzip . filter ((/= "speedyCommute") . fst) $ subcommutes prop c (Sealed2 (p1 :> p2)) = doesFail c p1 p2 ==> case runWrappedCommuteFunction c (invert p1 :< invert p2) of Failed -> True _ -> False doesFail :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool doesFail c p1 p2 = fails (runWrappedCommuteFunction c (p2:: p2 :>: NilFL) where fails Failed = True fails _ = False does :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool does c p1 p2 = succeeds (runWrappedCommuteFunction c (p2:: p2 :>: NilFL) where succeeds (Succeeded _) = True succeeds _ = False nontrivial :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool nontrivial c p1 p2 = succeeds (runWrappedCommuteFunction c (p2:: p2 :>: NilFL) where succeeds (Succeeded (p1' :< p2')) = not (p1' `unsafeCompare` p1 && p2' `unsafeCompare` p2) succeeds _ = False darcs-2.10.2/harness/Darcs/Test/Patch/RepoModel.hs0000644000175000017500000000122412620122474023620 0ustar00guillaumeguillaume00000000000000module 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 :: * -> * -> *) :: * -> * darcs-2.10.2/harness/Darcs/Test/Patch/Check.hs0000644000175000017500000003166512620122474022763 0ustar00guillaumeguillaume00000000000000-- 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.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 darcs-2.10.2/harness/Darcs/Test/Patch/V3Model.hs0000644000175000017500000001617612620122474023217 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports -fno-warn-orphans #-} {-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-} -- | 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.Patch.Witnesses.Sealed ( Sealed, seal ) import Darcs.Patch.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 wX = 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 wX 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 wX -> 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 wX -> Object Fail root (V3Model repo) = fromJust $ unFail $ getObject repo (UUID "ROOT") repoObjects :: V3Model wX -> [(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 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) 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 darcs-2.10.2/harness/Darcs/Test/Patch.hs0000644000175000017500000005010112620122474021730 0ustar00guillaumeguillaume00000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, ImpredicativeTypes #-} #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.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq ( MyEq, unsafeCompare ) import Darcs.Patch.Witnesses.Show import Darcs.Patch.Prim( PrimPatch, coalesce, FromPrim, PrimOf, PrimPatchBase ) import qualified Darcs.Patch.Prim.V1 as V1 ( Prim ) import qualified Darcs.Patch.Prim.V3 as V3 ( Prim ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Type ( PatchType(..) ) import Darcs.Patch.V1 as V1 ( Patch ) import Darcs.Patch.V2.Real ( isConsistent, isForward, RealPatch ) import Darcs.Patch.Patchy ( Commute(..), Patchy ) import Darcs.Patch.Merge( Merge ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Test.Patch.Arbitrary.Generic import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1 import Darcs.Test.Patch.Arbitrary.PrimV3() 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.WithState( WithState, 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(..) ) import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1 import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2 import qualified Darcs.Test.Patch.Properties.Generic as PropG import qualified Darcs.Test.Patch.Properties.Real as PropR import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU import qualified Darcs.Test.Patch.Rebase as Rebase import qualified Darcs.Test.Patch.WSub as WSub type instance ModelOf (FL prim) = ModelOf prim type TestGenerator thing gen = (forall t ctx . ((forall wXx wYy . thing wXx wYy -> t) -> (gen ctx -> t))) type TestCondition thing = (forall wYy wZz . thing wYy wZz -> Bool) type TestCheck thing t = (forall wYy wZz . thing wYy wZz -> t) -- arbitraryThing :: (forall wXx wYy . thing wXx wYy -> t) -> (thing wA wB -> t) arbitraryThing :: x -> TestGenerator thing (thing x) arbitraryThing _ f p = f p -- | 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" Prop1.checkCommute Ex.knownCommutes , testCases "known non-commutes" Prop1.checkCantCommute Ex.knownCantCommutes , testCases "known merges" Prop1.checkMerge Ex.knownMerges , testCases "known merges (equiv)" Prop1.checkMergeEquiv Ex.knownMergeEquivs , testCases "known canons" Prop1.checkCanon Ex.knownCanons , testCases "merge swaps" Prop1.checkMergeSwap Ex.mergePairs2 , testCases "the patch validation works" Prop1.tTestCheck Ex.validPatches , testCases "commute/recommute" (PropG.recommute commute) Ex.commutePairs , testCases "merge properties: merge either way valid" Prop1.tMergeEitherWayValid Ex.mergePairs , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs , testCases "primitive patch IO functions" (Prop1.tShowRead eqFLUnsafe) Ex.primitiveTestPatches , testCases "IO functions (test patches)" (Prop1.tShowRead eqFLUnsafe) Ex.testPatches , testCases "IO functions (named test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatchesNamed , testCases "primitive commute/recommute" (PropG.recommute commute) Ex.primitiveCommutePairs ] unit_V2P1 :: [Test] unit_V2P1 = [ testCases "coalesce commute" (PropU.coalesceCommute WSub.coalesce) 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) wX wY]) , 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) wX wY -> Maybe ((RealPatch prim :> RealPatch prim) wX wY) commuteReals = commute qc_prim :: forall prim wX wY wA 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 , MightBeEmptyHunk prim , MightHaveDuplicate prim , Show1 (prim wA) , Show1 ((prim :> prim) wA) , Show1 (WithState model prim wA) , Arbitrary (Sealed ((prim :> prim) wA)) , Arbitrary (Sealed ((prim :> prim :> prim) wA)) , Arbitrary (Sealed (prim wA)) , Arbitrary (Sealed (FL prim wA)) , Arbitrary (Sealed ((FL prim :> FL prim) wA)) , Arbitrary (Sealed (WithState model prim wA)) , Arbitrary (Sealed (WithState model (FL prim) wA)) , Arbitrary (Sealed2 (WithState model (prim :> prim))) , Arbitrary (Sealed ((WithState model (prim :> prim)) wA)) , Arbitrary (Sealed ((WithState model (FL prim :> FL prim)) wA)) ) => prim wX wY -> [Test] qc_prim p = -- The following fails because of setpref patches... -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc) (if runCoalesceTests p then [ testProperty "prim coalesce effect preserving... " (unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState model (prim :> prim)) -> TestResult) ] else []) ++ concat [ pair_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing' , pair_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing' , coalesce_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing' , nonreal_commute_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing' , nonreal_commute_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing' , patch_properties (undefined :: prim wX wA) "arbitrary" arbitraryThing' , patch_properties (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing' , patch_repo_properties (undefined :: prim wX wA) "arbitrary" arbitraryThing' , patch_repo_properties (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing' , pair_repo_properties (undefined :: prim wX wA) "arbitrary" arbitraryThing' , pair_repo_properties (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing' ] where arbitraryThing' = arbitraryThing (undefined :: wA) -- bind the witness for generator qc_V2P1 :: [Test] qc_V2P1 = [ testProperty "tree flattenings are consistent... " PropR.propConsistentTreeFlattenings , testProperty "with quickcheck that real patches are consistent... " (unseal $ P1.patchFromTree $ fromMaybe . isConsistent) -- permutivity ---------------------------------------------------------------------------- , testConditional "permutivity" (unseal $ P1.commuteTripleFromTree notDuplicatestriple) (unseal $ P1.commuteTripleFromTree $ PropG.permutivity commuteReals) , testConditional "partial permutivity" (unseal $ P1.commuteTripleFromTree notDuplicatestriple) (unseal $ P1.commuteTripleFromTree $ PropG.partialPermutivity commuteReals) , testConditional "nontrivial permutivity" (unseal $ P1.commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t)) (unseal $ P1.commuteTripleFromTree $ (PropG.permutivity commuteReals)) ] qc_V2 :: forall prim wXx wYy . (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim), Check (RealPatch prim), ArbitraryPrim prim, Show2 prim, RepoState (ModelOf prim) ~ ApplyState prim) => prim wXx wYy -> [Test] qc_V2 _ = [ testProperty "readPatch and showPatch work on RealPatch... " (unseal $ patchFromTree $ (PropG.show_read :: RealPatch prim wX wY -> TestResult)) , testProperty "readPatch and showPatch work on FL RealPatch... " (unseal2 $ (PropG.show_read :: FL (RealPatch prim) wX wY -> TestResult)) , testProperty "we can do merges using QuickCheck" (isNothing . (PropG.propIsMergeable :: Sealed (WithStartState (ModelOf prim) (Tree prim)) -> Maybe (Tree (RealPatch prim) wX))) ] ++ concat [ merge_properties (undefined :: RealPatch prim wX wY) "tree" mergePairFromTree , merge_properties (undefined :: RealPatch prim wX wY) "twfp" mergePairFromTWFP , pair_properties (undefined :: RealPatch prim wX wY) "tree" commutePairFromTree , pair_properties (undefined :: RealPatch prim wX wY) "twfp" commutePairFromTWFP , patch_properties (undefined :: RealPatch prim wX wY) "tree" patchFromTree ] 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, MightHaveDuplicate p , ShowPatchBasic p, MyEq p ) => p x y -> PropList (p :> p) gen pair_properties _ genname gen = properties gen "commute" genname [ ("recommute" , const True , PropG.recommute commute ) , ("nontrivial recommute" , nontrivialCommute, PropG.recommute commute ) , ("inverses commute" , const True , PropG.commuteInverses commute ) , ("nontrivial inverses" , nontrivialCommute, PropG.commuteInverses commute ) , ("inverse composition" , const True , PropG.inverseComposition ) ] coalesce_properties :: forall p gen x y . ( Show1 gen, Arbitrary (Sealed gen), Patchy p, PrimPatch p , ArbitraryPrim p, MightBeEmptyHunk p ) => p x y -> PropList (p :> p :> p) gen coalesce_properties p genname gen = properties gen "commute" genname (if runCoalesceTests p then [ ("coalesce commutes with commute", const True, PropG.coalesceCommute coalesce) ] else []) -- 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, ShowPatchBasic p, MyEq p) => p x y -> PropList (p :> p) gen nonreal_commute_properties _ genname gen = properties gen "commute" genname [ ("patch & inverse commute", const True , PropG.patchAndInverseCommute commute) , ("patch & inverse commute", nontrivialCommute, PropG.patchAndInverseCommute commute) ] patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, MyEq p) => p x y -> PropList p gen patch_properties _ genname gen = properties gen "patch" genname [ ("inverse . inverse is id" , const True , PropG.invertSymmetry) ] patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, ShowPatchBasic 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 , PropG.invertRollback) ] pair_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, MightBeEmptyHunk p, RepoModel (ModelOf p), RepoState (ModelOf p) ~ ApplyState p) => p x y -> PropList (WithState (ModelOf p) (p :> p)) gen pair_repo_properties _ genname gen = properties gen "patch/repo" genname [ ("commute is effect preserving" , const True , PropG.effectPreserving commute ) ] merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen) , Patchy p, MyEq p, Merge p, ShowPatchBasic p , MightHaveDuplicate p, Show2 p, Check p) => p x y -> PropList (p :\/: p) gen merge_properties _ genname gen = properties gen "merge" genname [ ("merge either way" , const True , PropG.mergeEitherWay ) , ("merge either way valid" , const True , Prop1.tMergeEitherWayValid) , ("nontrivial merge either way", nontrivialMerge, PropG.mergeEitherWay ) , ("merge commute" , const True , PropG.mergeCommute ) ] qc_V1P1 :: [Test] qc_V1P1 = [ testProperty "show and read work right" (unseal Prop2.propReadShow) ] ++ Prop2.checkSubcommutes Prop2.subcommutesInverse "patch and inverse both commute" ++ Prop2.checkSubcommutes Prop2.subcommutesNontrivialInverse "nontrivial commutes are correct" ++ Prop2.checkSubcommutes Prop2.subcommutesFailure "inverses fail" ++ [ testProperty "commuting by patch and its inverse is ok" Prop2.propCommuteInverse -- , testProperty "conflict resolution is valid... " Prop.propResolveConflictsValid , testProperty "a patch followed by its inverse is identity" Prop2.propPatchAndInverseIsIdentity , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough , testProperty "commutes are equivalent" Prop2.propCommuteEquivalency , testProperty "merges are valid" Prop2.propMergeValid , testProperty "inverses being valid" Prop2.propInverseValid , testProperty "other inverse being valid" Prop2.propOtherInverseValid -- The patch generator isn't smart enough to generate correct test cases for -- the following: (which will be obsoleted soon, anyhow) -- , testProperty "the order dependence of unravel... " Prop.propUnravelOrderIndependent -- , testProperty "the unravelling of three merges... " Prop.propUnravelThreeMerge -- , testProperty "the unravelling of a merge of a sequence... " Prop.propUnravelSeqMerge , testProperty "the order of commutes" Prop2.propCommuteEitherOrder , testProperty "commute either way" Prop2.propCommuteEitherWay , testProperty "the double commute" Prop2.propCommuteTwice , testProperty "merges commute and are well behaved" Prop2.propMergeIsCommutableAndCorrect , testProperty "merges can be swapped" Prop2.propMergeIsSwapable , testProperty "again that merges can be swapped (I'm paranoid) " Prop2.propMergeIsSwapable ] -- the following properties are disabled, because they routinely lead to -- exponential cases, making the tests run for ever and ever; nevertheless, -- we would expect them to hold {- ++ merge_properties (undefined :: V1.Patch Prim wX wY) "tree" mergePairFromTree ++ merge_properties (undefined :: V1.Patch Prim wX wY) "twfp" mergePairFromTWFP ++ commute_properties (undefined :: V1.Patch Prim wX wY) "tree" commutePairFromTree ++ commute_properties (undefined :: V1.Patch Prim wX wY) "twfp" commutePairFromTWFP -} -- tests (either QuickCheck or Unit) that should be run on any type of patch general_patchTests :: (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType p -> [Test] general_patchTests pt = [ testGroup "Rebase patches" $ Rebase.testSuite pt ] -- | 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 wX wY) , testGroup "Darcs.Patch.V1 (using Prim.V1)" $ unit_V1P1 ++ qc_V1P1 ++ general_patchTests (PatchType :: PatchType (V1.Patch V1.Prim)) , testGroup "Darcs.Patch.V2 (using Prim.V1)" $ unit_V2P1 ++ qc_V2 (undefined :: V1.Prim wX wY) ++ qc_V2P1 ++ general_patchTests (PatchType :: PatchType (RealPatch V1.Prim)) -- , testGroup "Darcs.Patch.Prim.V3" $ qc_prim (undefined :: V3.Prim wX wY) , testGroup "Darcs.Patch.V2 (using Prim.V3)" $ qc_V2 (undefined :: V3.Prim wX wY) ++ general_patchTests (PatchType :: PatchType (RealPatch V3.Prim)) , Darcs.Test.Patch.Info.testSuite ] darcs-2.10.2/harness/Darcs/Test/Util/0000755000175000017500000000000012620122474021255 5ustar00guillaumeguillaume00000000000000darcs-2.10.2/harness/Darcs/Test/Util/QuickCheck.hs0000644000175000017500000000242612620122474023627 0ustar00guillaumeguillaume00000000000000 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) darcs-2.10.2/harness/Darcs/Test/Util/TestResult.hs0000644000175000017500000000330312620122474023726 0ustar00guillaumeguillaume00000000000000 module Darcs.Test.Util.TestResult ( TestResult , succeeded , failed , rejected , (<&&>) , fromMaybe , isOk , isFailed ) where import Darcs.Util.Printer ( Doc, renderString, RenderMode(..) ) 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 Encode errorMsg}) property TestRejected = Q.property Q.rejected darcs-2.10.2/harness/test.hs0000644000175000017500000003477412620122474017717 0ustar00guillaumeguillaume00000000000000{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable, ViewPatterns, OverloadedStrings, ExtendedDefaultRules #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main ( main ) where #ifdef DISABLE_TESTING main :: IO () main = fail $ "test infrastructure not built," ++ " please pass --enable-tests to configure, then rebuild" #else import qualified Darcs.Test.Misc import qualified Darcs.Test.Patch import qualified Darcs.Test.Email import Control.Monad ( filterM ) import Control.Exception ( SomeException ) import qualified Control.Monad.Trans import Data.Text ( Text, pack, unpack ) import Data.Char ( toLower ) import Data.List ( isPrefixOf, isSuffixOf, sort ) import Data.List.Split ( splitOn ) import qualified Data.ByteString.Char8 as B import Data.Maybe ( fromMaybe ) import GHC.IO.Encoding ( textEncodingName ) import System.Console.CmdArgs hiding ( args ) 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, localeEncoding ) import Test.Framework.Providers.API ( TestResultlike(..), Testlike(..), Test, runImprovingIO, yieldImprovement, Test(..), liftIO ) import Test.Framework ( defaultMainWithArgs ) import Shelly hiding ( liftIO, run, FilePath, path ) import qualified Shelly 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 = Darcs1 | Darcs2 deriving (Show, Eq, Typeable, Data) data DiffAlgorithm = MyersDiff | PatienceDiff deriving (Show, Eq, Typeable, Data) 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 , _diffalgorithm :: DiffAlgorithm } deriving Typeable runtest' :: ShellTest -> Text -> Sh Result runtest' (ShellTest fmt _ _ dp da) srcdir = do wd <- toTextIgnore <$> pwd setenv "HOME" wd setenv "TESTDATA" (toTextIgnore (srcdir "tests" "data")) setenv "TESTBIN" (toTextIgnore (srcdir "tests" "bin")) setenv "DARCS_TESTING_PREFS_DIR" $ toTextIgnore $ wd ".darcs" setenv "EMAIL" "tester" setenv "DARCS_DONT_COLOR" "1" setenv "DARCS_DONT_ESCAPE_ANYTHING" "1" p <- get_env_text "PATH" setenv "PATH" (pack (takeDirectory dp ++ pathVarSeparator ++ unpack p)) setenv "DARCS" $ pack dp setenv "GHC_VERSION" $ pack $ show (__GLASGOW_HASKELL__ :: Int) 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 ignore-times"] ++ dcs) fmtstr = case fmt of Darcs2 -> "darcs-2" Darcs1 -> "darcs-1" dcs = [dc ++ " " ++ daf | dc <- ["revert","unrevert", "whatsnew", "record", "unpull", "obliterate", "amend-record", "mark-conflicts", "rebase", "pull", "repair", "rollback", "apply", "rebase pull", "rebase suspend", "rebase unsuspend", "rebase obliterate"] ] daf = case da of PatienceDiff -> "patience" MyersDiff -> "myers" #ifdef WIN32 pathVarSeparator = ";" #else pathVarSeparator = ":" #endif -- TODO: add a 'all' option (implement using an Enum instance)? readOptionList :: (String -> a) -> (String -> [a]) readOptionList readElem str = map readElem (splitOn "," str) readDiffAlgorithm :: String -> DiffAlgorithm readDiffAlgorithm (map toLower -> "myers") = MyersDiff readDiffAlgorithm (map toLower -> "patience") = PatienceDiff readDiffAlgorithm _ = error "Valid diff algorithms: myers, patience" readRepoFormat :: String -> Format readRepoFormat (map toLower -> "darcs-1") = Darcs1 readRepoFormat (map toLower -> "darcs-2") = Darcs2 readRepoFormat _ = error "Valid repo formats: darcs-1, darcs-2" runtest :: ShellTest -> Sh Result runtest t = withTmp $ \dir -> do cp "tests/lib" dir cp ("tests" testfile t) (dir "test") srcdir <- pwd silently $ sub $ cd dir >> runtest' t (toTextIgnore 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 (shelly $ runtest test) shellTest :: FilePath -> Format -> Maybe FilePath -> String -> DiffAlgorithm -> Test shellTest dp fmt tdir file da = Test (file ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $ ShellTest fmt file tdir dp da hasPrefix :: B.ByteString -> B.ByteString -> Maybe B.ByteString hasPrefix prefix = let len = B.length prefix in \str -> if B.take len str == prefix then Just (B.drop len str) else Nothing toString :: Shelly.FilePath -> String toString = unpack . toTextIgnore -- use of a pragma in a test script overrides the user's selection for that particular test, -- based on the assumption that the test author knows best parsePragmas :: FilePath -> FilePath -> IO (FilePath, (Maybe [DiffAlgorithm], Maybe [Format])) parsePragmas path file = do contents <- B.lines <$> B.readFile (toString $ path file) let parseLine (_diffAlgorithms, repoFormats) (hasPrefix (B.pack "#pragma diff-algorithm ") -> Just (readOptionList readDiffAlgorithm . B.unpack -> newDiffAlgorithms)) = (Just newDiffAlgorithms, repoFormats) parseLine (diffAlgorithms, _repoFormats) (hasPrefix (B.pack "#pragma repo-format ") -> Just (readOptionList readRepoFormat . B.unpack -> newRepoFormats)) = (diffAlgorithms, Just newRepoFormats) parseLine _ (hasPrefix (B.pack "#pragma ") -> Just pragma) = error $ "Unknown pragma " ++ B.unpack pragma ++ " in " ++ (toString $ path file) parseLine x _ = x pragmas = foldl parseLine (Nothing, Nothing) contents return (file, pragmas) findShell :: FilePath -> Maybe FilePath -> Bool -> [DiffAlgorithm] -> [Format] -> Sh [Test] findShell dp tdir isFailing diffAlgorithmsDefault repoFormatsDefault = do allFiles <- map (drop (length ("tests/"::String)) . toString) <$> ls (fromText "tests") let files = sort $ filter relevant $ filter (".sh" `isSuffixOf`) allFiles annotatedFiles <- Control.Monad.Trans.liftIO $ mapM (parsePragmas "tests") files return [ shellTest dp fmt tdir file da | (file, (diffAlgorithmsPragma, repoFormatsPragma)) <- annotatedFiles , fmt <- fromMaybe repoFormatsDefault repoFormatsPragma , da <- fromMaybe diffAlgorithmsDefault diffAlgorithmsPragma ] where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`) findNetwork :: FilePath -> Maybe FilePath -> [DiffAlgorithm] -> [Format] -> Sh [Test] findNetwork dp tdir diffAlgorithmsDefault repoFormatsDefault = do files <- sort <$> filter (".sh" `isSuffixOf`) <$> map (drop (length ("tests/network/"::String)) . toString) <$> ls "tests/network" annotatedFiles <- Control.Monad.Trans.liftIO $ mapM (parsePragmas "tests/network") files return [ shellTest dp fmt tdir (toString $ "network" file) da | (file, (diffAlgorithmsPragma, repoFormatsPragma)) <- annotatedFiles , fmt <- fromMaybe repoFormatsDefault repoFormatsPragma , da <- fromMaybe diffAlgorithmsDefault diffAlgorithmsPragma ] -- ---------------------------------------------------------------------- -- harness -- ---------------------------------------------------------------------- data Config = Config { failing :: Bool , shell :: Bool , network :: Bool , unit :: Bool , myers :: Bool , patience :: Bool , darcs1 :: Bool , darcs2 :: Bool , darcs :: String , tests :: [String] , testDir :: Maybe FilePath , plain :: Bool , hideSuccesses :: Bool , threads :: Int , qcCount :: Int } deriving (Data, Typeable, Eq) defaultConfig :: Annotate Ann defaultConfig = record Config{} [ failing := False += help "Run the failing (shell) tests [no]" , shell := True += help "Run the passing, non-network shell tests [yes]" , network := False += help "Run the network shell tests [no]" , unit := True += help "Run the unit tests [yes]" , myers := False += help "Use myers diff [no]" , patience := True += help "Use patience diff [yes]" += name "p" , darcs1 := False += help "Use darcs-1 repo format [no]" += name "1" , darcs2 := True += help "Use darcs-2 repo format [yes]" += name "2" , darcs := "" += help "Darcs binary path" += typ "PATH" , tests := [] += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t" , testDir := Nothing += help "Directory to run tests in" += typ "PATH" += name "d" , plain := False += help "Use plain-text output [no]" , hideSuccesses := False += help "Hide successes [no]" , threads := 1 += help "Number of threads [1]" += name "j" , qcCount := 100 += help "Number of QuickCheck iterations per test [100]" += name "q" ] += summary "Darcs test harness" += program "darcs-test" run :: Config -> IO () run conf = do let args = [ "-j", show $ threads conf ] ++ concat [ ["-t", x ] | x <- tests conf ] ++ [ "--plain" | True <- [plain conf] ] ++ [ "--hide-successes" | True <- [hideSuccesses conf] ] -- this multiplier is calibrated against the observed behaviour of the test harness - -- increase it if we see lots of "arguments exhausted" errors or similar ++ [ "--maximum-unsuitable-generated-tests", show (7 * qcCount conf) ] ++ [ "--maximum-generated-tests", show (qcCount conf) ] case testDir conf of Nothing -> return () Just d -> do e <- shelly (test_e (fromText $ pack d)) 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 (map toString 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 unless (isAbsolute $ darcsBin) $ fail ("Argument to --darcs should be an absolute path") unless (exeSuffix `isSuffixOf` darcsBin) $ putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)" putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding let repoFormat = (if darcs1 conf then (Darcs1:) else id) . (if darcs2 conf then (Darcs2:) else id) $ [] let diffAlgorithm = (if myers conf then (MyersDiff:) else id) . (if patience conf then (PatienceDiff:) else id) $ [] ftests <- shelly $ if failing conf then findShell darcsBin (testDir conf) True diffAlgorithm repoFormat else return [] stests <- shelly $ if shell conf then findShell darcsBin (testDir conf) False diffAlgorithm repoFormat else return [] utests <- if unit conf then doUnit else return [] ntests <- shelly $ if network conf then findNetwork darcsBin (testDir conf) diffAlgorithm repoFormat 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 clp <- cmdArgs_ defaultConfig run clp #endif