darcs 2.12.5 → 2.14.0

raw patch · 343 files changed

+14797/−14939 lines, 343 filesdep +stmdep +temporarydep −transformers-compatdep ~FindBindep ~HTTPdep ~HUnitsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: stm, temporary

Dependencies removed: transformers-compat

Dependency ranges changed: FindBin, HTTP, HUnit, QuickCheck, Win32, array, async, attoparsec, base, bytestring, cmdargs, containers, cryptohash, directory, fgl, filepath, graphviz, hashable, haskeline, mmap, mtl, network, old-time, parsec, process, random, shelly, tar, terminfo, test-framework, test-framework-hunit, test-framework-quickcheck2, time, transformers, unix, unix-compat, utf8-string, vector, zip-archive, zlib

API changes (from Hackage documentation)

Files

• CHANGELOG +52/−0
• Setup.hs +241/−0
• Setup.lhs +0/−382
• contrib/_darcs.zsh +26/−23
• contrib/darcs_completion +20/−5
• darcs.cabal +119/−167
• darcs/darcs.hs +9/−15
• harness/Darcs/Test/Email.hs +18/−8
• harness/Darcs/Test/HashedStorage.hs +501/−0
• harness/Darcs/Test/Misc.hs +35/−12
• harness/Darcs/Test/Misc/CommandLine.hs +41/−0
• harness/Darcs/Test/Misc/Encoding.hs +36/−0
• harness/Darcs/Test/Patch.hs +96/−84
• harness/Darcs/Test/Patch/Arbitrary/Generic.hs +3/−5
• harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs +73/−84
• harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs +154/−56
• harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs +13/−33
• harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs +3/−4
• harness/Darcs/Test/Patch/Check.hs +3/−3
• harness/Darcs/Test/Patch/Examples/Set1.hs +5/−8
• harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs +165/−174
• harness/Darcs/Test/Patch/FileUUIDModel.hs +73/−72
• harness/Darcs/Test/Patch/Info.hs +84/−58
• harness/Darcs/Test/Patch/Properties/Check.hs +30/−13
• harness/Darcs/Test/Patch/Properties/Generic.hs +265/−163
• harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs +21/−23
• harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs +14/−7
• harness/Darcs/Test/Patch/Properties/V1Set1.hs +11/−12
• harness/Darcs/Test/Patch/Properties/V1Set2.hs +46/−21
• harness/Darcs/Test/Patch/RepoModel.hs +2/−0
• harness/Darcs/Test/Patch/Selection.hs +2/−2
• harness/Darcs/Test/Patch/V1Model.hs +13/−17
• harness/Darcs/Test/Patch/WSub.hs +10/−7
• harness/Darcs/Test/Patch/WithState.hs +1/−1
• harness/Darcs/Test/Repository/Inventory.hs +159/−0
• harness/Darcs/Test/Util/TestResult.hs +22/−28
• harness/Storage/Hashed/Test.hs +0/−542
• harness/test.hs +46/−87
• release/distributed-context +1/−1
• release/distributed-version +1/−1
• src/Bundled/Posix.hsc +0/−116
• src/Darcs/Patch.hs +12/−22
• src/Darcs/Patch/Annotate.hs +112/−119
• src/Darcs/Patch/Apply.hs +3/−13
• src/Darcs/Patch/ApplyMonad.hs +4/−11
• src/Darcs/Patch/ApplyPatches.hs +4/−5
• src/Darcs/Patch/Bracketed/Instances.hs +4/−4
• src/Darcs/Patch/Bundle.hs +19/−24
• src/Darcs/Patch/Choices.hs +282/−208
• src/Darcs/Patch/Conflict.hs +26/−10
• src/Darcs/Patch/Depends.hs +53/−64
• src/Darcs/Patch/Dummy.hs +19/−11
• src/Darcs/Patch/Format.hs +5/−8
• src/Darcs/Patch/Index/Monad.hs +17/−5
• src/Darcs/Patch/Index/Types.hs +6/−17
• src/Darcs/Patch/Info.hs +115/−68
• src/Darcs/Patch/Invert.hs +5/−1
• src/Darcs/Patch/Match.hs +63/−56
• src/Darcs/Patch/Matchable.hs +4/−2
• src/Darcs/Patch/Merge.hs +54/−3
• src/Darcs/Patch/MonadProgress.hs +1/−1
• src/Darcs/Patch/Named.hs +76/−24
• src/Darcs/Patch/Named/Wrapped.hs +23/−14
• src/Darcs/Patch/OldDate.hs +0/−351
• src/Darcs/Patch/PatchInfoAnd.hs +31/−27
• src/Darcs/Patch/Patchy.hs +0/−36
• src/Darcs/Patch/Patchy/Instances.hs +0/−13
• src/Darcs/Patch/Permutations.hs +13/−16
• src/Darcs/Patch/Prim.hs +14/−15
• src/Darcs/Patch/Prim/Class.hs +35/−18
• src/Darcs/Patch/Prim/FileUUID.hs +2/−6
• src/Darcs/Patch/Prim/FileUUID/Apply.hs +67/−50
• src/Darcs/Patch/Prim/FileUUID/Commute.hs +48/−59
• src/Darcs/Patch/Prim/FileUUID/Core.hs +83/−84
• src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs +36/−13
• src/Darcs/Patch/Prim/FileUUID/Read.hs +29/−25
• src/Darcs/Patch/Prim/FileUUID/Show.hs +91/−43
• src/Darcs/Patch/Prim/V1.hs +2/−12
• src/Darcs/Patch/Prim/V1/Apply.hs +135/−69
• src/Darcs/Patch/Prim/V1/Coalesce.hs +6/−7
• src/Darcs/Patch/Prim/V1/Commute.hs +41/−53
• src/Darcs/Patch/Prim/V1/Core.hs +11/−14
• src/Darcs/Patch/Prim/V1/Read.hs +62/−58
• src/Darcs/Patch/Prim/V1/Show.hs +28/−42
• src/Darcs/Patch/Progress.hs +0/−2
• src/Darcs/Patch/Read.hs +8/−8
• src/Darcs/Patch/Rebase.hs +45/−18
• src/Darcs/Patch/Rebase/Container.hs +11/−16
• src/Darcs/Patch/Rebase/Fixup.hs +6/−6
• src/Darcs/Patch/Rebase/Item.hs +14/−13
• src/Darcs/Patch/Rebase/Name.hs +14/−18
• src/Darcs/Patch/Rebase/Viewing.hs +40/−37
• src/Darcs/Patch/RepoPatch.hs +9/−7
• src/Darcs/Patch/Set.hs +10/−10
• src/Darcs/Patch/Show.hs +37/−24
• src/Darcs/Patch/Split.hs +64/−59
• src/Darcs/Patch/Summary.hs +25/−28
• src/Darcs/Patch/TokenReplace.hs +77/−48
• src/Darcs/Patch/TouchesFiles.hs +89/−65
• src/Darcs/Patch/V1.hs +2/−3
• src/Darcs/Patch/V1/Apply.hs +4/−1
• src/Darcs/Patch/V1/Commute.hs +20/−30
• src/Darcs/Patch/V1/Core.hs +9/−5
• src/Darcs/Patch/V1/Prim.hs +116/−0
• src/Darcs/Patch/V1/Show.hs +19/−14
• src/Darcs/Patch/V1/Viewing.hs +5/−11
• src/Darcs/Patch/V2.hs +4/−4
• src/Darcs/Patch/V2/Non.hs +40/−34
• src/Darcs/Patch/V2/Prim.hs +120/−0
• src/Darcs/Patch/V2/RepoPatch.hs +84/−91
• src/Darcs/Patch/Viewing.hs +38/−33
• src/Darcs/Patch/Witnesses/Eq.hs +2/−2
• src/Darcs/Patch/Witnesses/Ordered.hs +67/−25
• src/Darcs/Patch/Witnesses/Sealed.hs +4/−4
• src/Darcs/Patch/Witnesses/Show.hs +0/−2
• src/Darcs/Patch/Witnesses/Unsafe.hs +6/−7
• src/Darcs/Patch/Witnesses/WZipper.hs +0/−2
• src/Darcs/Prelude.hs +27/−9
• src/Darcs/Repository.hs +44/−134
• src/Darcs/Repository/ApplyPatches.hs +3/−3
• src/Darcs/Repository/Cache.hs +6/−19
• src/Darcs/Repository/Clone.hs +140/−191
• src/Darcs/Repository/Create.hs +165/−0
• src/Darcs/Repository/Diff.hs +32/−8
• src/Darcs/Repository/Flags.hs +12/−0
• src/Darcs/Repository/Format.hs +3/−6
• src/Darcs/Repository/Hashed.hs +1101/−0
• src/Darcs/Repository/HashedIO.hs +57/−55
• src/Darcs/Repository/HashedRepo.hs +0/−776
• src/Darcs/Repository/Identify.hs +229/−0
• src/Darcs/Repository/Internal.hs +0/−1092
• src/Darcs/Repository/InternalTypes.hs +47/−11
• src/Darcs/Repository/Inventory.hs +239/−0
• src/Darcs/Repository/Job.hs +85/−41
• src/Darcs/Repository/Match.hs +5/−16
• src/Darcs/Repository/Merge.hs +127/−73
• src/Darcs/Repository/Motd.hs +0/−46
• src/Darcs/Repository/Old.hs +47/−33
• src/Darcs/Repository/Packs.hs +106/−13
• src/Darcs/Repository/PatchIndex.hs +198/−227
• src/Darcs/Repository/Pending.hs +281/−19
• src/Darcs/Repository/Prefs.hs +184/−51
• src/Darcs/Repository/Rebase.hs +17/−18
• src/Darcs/Repository/Repair.hs +22/−24
• src/Darcs/Repository/Resolution.hs +0/−3
• src/Darcs/Repository/State.hs +342/−246
• src/Darcs/Repository/Test.hs +15/−21
• src/Darcs/Repository/Working.hs +75/−0
• src/Darcs/UI/ApplyPatches.hs +26/−24
• src/Darcs/UI/Commands.hs +44/−226
• src/Darcs/UI/Commands/Add.hs +34/−90
• src/Darcs/UI/Commands/Amend.hs +16/−24
• src/Darcs/UI/Commands/Annotate.hs +39/−65
• src/Darcs/UI/Commands/Apply.hs +59/−127
• src/Darcs/UI/Commands/Clone.hs +64/−90
• src/Darcs/UI/Commands/Convert.hs +206/−209
• src/Darcs/UI/Commands/Diff.hs +42/−73
• src/Darcs/UI/Commands/Dist.hs +47/−75
• src/Darcs/UI/Commands/GZCRCs.hs +26/−48
• src/Darcs/UI/Commands/Help.hs +59/−46
• src/Darcs/UI/Commands/Init.hs +22/−41
• src/Darcs/UI/Commands/Log.hs +86/−115
• src/Darcs/UI/Commands/MarkConflicts.hs +253/−86
• src/Darcs/UI/Commands/Move.hs +32/−55
• src/Darcs/UI/Commands/Optimize.hs +105/−212
• src/Darcs/UI/Commands/Pull.hs +109/−236
• src/Darcs/UI/Commands/Push.hs +71/−115
• src/Darcs/UI/Commands/Rebase.hs +200/−456
• src/Darcs/UI/Commands/Record.hs +18/−53
• src/Darcs/UI/Commands/Remove.hs +23/−45
• src/Darcs/UI/Commands/Repair.hs +118/−107
• src/Darcs/UI/Commands/Replace.hs +43/−66
• src/Darcs/UI/Commands/Revert.hs +20/−42
• src/Darcs/UI/Commands/Rollback.hs +32/−56
• src/Darcs/UI/Commands/Send.hs +271/−183
• src/Darcs/UI/Commands/SetPref.hs +14/−32
• src/Darcs/UI/Commands/Show.hs +2/−4
• src/Darcs/UI/Commands/ShowAuthors.hs +17/−32
• src/Darcs/UI/Commands/ShowBug.hs +0/−80
• src/Darcs/UI/Commands/ShowContents.hs +7/−28
• src/Darcs/UI/Commands/ShowDependencies.hs +21/−45
• src/Darcs/UI/Commands/ShowFiles.hs +32/−53
• src/Darcs/UI/Commands/ShowIndex.hs +32/−50
• src/Darcs/UI/Commands/ShowPatchIndex.hs +35/−51
• src/Darcs/UI/Commands/ShowRepo.hs +60/−65
• src/Darcs/UI/Commands/ShowTags.hs +10/−27
• src/Darcs/UI/Commands/Tag.hs +49/−77
• src/Darcs/UI/Commands/Test.hs +37/−71
• src/Darcs/UI/Commands/TransferMode.hs +6/−20
• src/Darcs/UI/Commands/Unrecord.hs +103/−174
• src/Darcs/UI/Commands/Unrevert.hs +25/−56
• src/Darcs/UI/Commands/Util.hs +127/−15
• src/Darcs/UI/Commands/Util/Tree.hs +21/−26
• src/Darcs/UI/Commands/WhatsNew.hs +181/−171
• src/Darcs/UI/CommandsAux.hs +0/−3
• src/Darcs/UI/Completion.hs +185/−0
• src/Darcs/UI/Defaults.hs +4/−6
• src/Darcs/UI/Email.hs +14/−11
• src/Darcs/UI/External.hs +81/−78
• src/Darcs/UI/Flags.hs +105/−188
• src/Darcs/UI/Message/Send.hs +0/−186
• src/Darcs/UI/Options.hs +5/−14
• src/Darcs/UI/Options/All.hs +249/−124
• src/Darcs/UI/Options/Core.hs +13/−0
• src/Darcs/UI/Options/Flags.hs +3/−2
• src/Darcs/UI/Options/Matching.hs +12/−6
• src/Darcs/UI/PatchHeader.hs +25/−31
• src/Darcs/UI/PrintPatch.hs +7/−10
• src/Darcs/UI/RunCommand.hs +31/−30
• src/Darcs/UI/SelectChanges.hs +234/−315
• src/Darcs/UI/TheCommands.hs +0/−1
• src/Darcs/UI/Usage.hs +161/−22
• src/Darcs/Util/AtExit.hs +0/−2
• src/Darcs/Util/Bug.hs +0/−30
• src/Darcs/Util/ByteString.hs +141/−271
• src/Darcs/Util/CommandLine.hs +1/−22
• src/Darcs/Util/Crypt/SHA1.hs +0/−225
• src/Darcs/Util/Crypt/SHA256.hs +0/−12
• src/Darcs/Util/DateMatcher.hs +39/−1
• src/Darcs/Util/DateTime.hs +0/−1
• src/Darcs/Util/Diff/Myers.hs +0/−4
• src/Darcs/Util/Diff/Patience.hs +0/−4
• src/Darcs/Util/Download.hs +10/−12
• src/Darcs/Util/Encoding.hs +32/−12
• src/Darcs/Util/Encoding/IConv.hsc +0/−185
• src/Darcs/Util/Encoding/Win32.hs +3/−0
• src/Darcs/Util/Environment.hs +0/−15
• src/Darcs/Util/External.hs +0/−1
• src/Darcs/Util/File.hs +5/−7
• src/Darcs/Util/Global.hs +0/−2
• src/Darcs/Util/Hash.hs +235/−29
• src/Darcs/Util/Index.hs +86/−62
• src/Darcs/Util/IsoDate.hs +23/−11
• src/Darcs/Util/Lock.hs +107/−62
• src/Darcs/Util/Path.hs +30/−32
• src/Darcs/Util/Printer.hs +92/−109
• src/Darcs/Util/Printer/Color.hs +48/−52
• src/Darcs/Util/Progress.hs +1/−4
• src/Darcs/Util/Ssh.hs +6/−5
• src/Darcs/Util/Text.hs +10/−2
• src/Darcs/Util/Tree.hs +16/−17
• src/Darcs/Util/Tree/Hashed.hs +38/−39
• src/Darcs/Util/Tree/Monad.hs +17/−17
• src/Darcs/Util/Tree/Plain.hs +6/−6
• src/Darcs/Util/URL.hs +0/−4
• src/fpstring.c +0/−69
• src/fpstring.h +0/−7
• src/h_iconv.c +0/−18
• src/h_iconv.h +0/−9
• src/impossible.h +0/−8
• src/win32/System/Posix/Files.hsc +13/−10
• src/win32/System/Posix/IO.hsc +1/−1
• tests/add.sh +12/−2
• tests/apply-hunks.sh +1/−4
• tests/apply.sh +0/−1
• tests/clone.sh +16/−15
• tests/conflict-doppleganger.sh +0/−2
• tests/conflict-fight.sh +1/−6
• tests/conflict-reporting.sh +0/−3
• tests/convert-darcs2.sh +64/−0
• tests/convert.sh +0/−62
• tests/convert_export.sh +7/−0
• tests/data/many-files--darcs-2.tgz binary
• tests/data/many-files--hashed.tgz binary
• tests/diff.sh +3/−0
• tests/directory_confusion.sh +0/−23
• tests/disable.sh +1/−1
• tests/failing-issue1014_identical_patches.sh +1/−1
• tests/failing-issue1363-mark-conflicts.sh +0/−62
• tests/failing-issue1401_bug_in_get_extra.sh +2/−9
• tests/failing-issue1610_get_extra.sh +1/−4
• tests/failing-issue2138-whatsnew-s.sh +59/−0
• tests/failing-issue2208-replace-fails-with-resolving-unrecorded-change.sh +0/−53
• tests/failing-issue2243-unknown-patch-annotating-empty-first-line.sh +0/−37
• tests/failing-issue2275_follows-symlinks.sh +45/−0
• tests/failing-issue2443-timestamp_index_keeps_unrecorded_addfile.sh +35/−0
• tests/failing-issue2480-display-unicode-in-patch-content.sh +0/−9
• tests/failing-issue2548-inconsistent-pending-after-merge.sh +43/−0
• tests/failing-look_for_replaces1.sh +1/−1
• tests/failing-look_for_replaces2.sh +0/−44
• tests/filename_with_spaces.sh +10/−0
• tests/hashed_inventory.sh +1/−1
• tests/hidden_conflict.sh +4/−4
• tests/issue1162_add_nonexistent_slash.sh +0/−16
• tests/issue1344_abort_early_cant_send.sh +6/−6
• tests/issue1739-escape-multibyte-chars-correctly.sh +3/−2
• tests/issue1978.sh +0/−8
• tests/issue2138-whatsnew-s.sh +0/−59
• tests/issue2160_wrong_line_number_when_appending_empty_line.sh +19/−0
• tests/issue2208-replace-fails-with-resolving-unrecorded-change.sh +56/−0
• tests/issue2243-unknown-patch-annotating-empty-first-line.sh +37/−0
• tests/issue2262-display_of_meta_data.sh +7/−0
• tests/issue2286-metadata-encoding.sh +16/−3
• tests/issue2382-mv-dir-to-file-confuses-darcs.sh +1/−1
• tests/issue2480-display-unicode-in-patch-content.sh +9/−0
• tests/issue2512-multiple-authors-clobbered-in-global-conf.sh +47/−0
• tests/issue2526-whatsnew-boring.sh +19/−0
• tests/issue2545_command-execution-via-ssh-uri.sh +49/−0
• tests/issue2567-darcs-whatsnew-unified.sh +41/−0
• tests/issue2575-revert_during_rebase.sh +11/−0
• tests/issue2581-rebase_pull_reorder_updates_format.sh +16/−0
• tests/issue279_get_extra.sh +4/−4
• tests/issue436.sh +4/−7
• tests/lazy-optimize-reorder.sh +1/−1
• tests/log-duplicate.sh +3/−4
• tests/log.sh +10/−16
• tests/look_for_moves_and_replaces.sh +70/−0
• tests/look_for_moves_with_args.sh +50/−0
• tests/merging_newlines.sh +5/−17
• tests/network/clone-http-packed-detect.sh +7/−15
• tests/network/clone-http-packed.sh +4/−12
• tests/network/failing-issue1599-automatically-expire-unused-caches.sh +55/−0
• tests/network/issue1599-automatically-expire-unused-caches.sh +0/−55
• tests/network/issue1932-remote.sh +1/−1
• tests/network/issue2090-transfer-mode.sh +1/−2
• tests/network/issue2545_command-execution-via-ssh-uri.sh +45/−0
• tests/network/ssh.sh +0/−1
• tests/network/sshlib +11/−12
• tests/oldfashioned.sh +1/−1
• tests/printer.sh +7/−4
• tests/pull.sh +19/−0
• tests/pull_many_files.sh +0/−29
• tests/push.sh +1/−1
• tests/rebase-apply.sh +1/−1
• tests/rebase-basic.sh +1/−1
• tests/rebase-nochanges.sh +1/−2
• tests/rebase-pull.sh +1/−1
• tests/repoformat.sh +2/−6
• tests/revert.sh +87/−0
• tests/revert_interactive.sh +0/−67
• tests/revert_unrecorded_add.sh +0/−13
• tests/send-output-v1.sh +1/−3
• tests/send-output-v2.sh +1/−3
• tests/several_commands.sh +0/−25
• tests/show-bug.sh +0/−22
• tests/show_files.sh +25/−0
• tests/split-patches.sh +0/−2
• tests/switch-encoding.sh +87/−0
• tests/toolbox.sh +0/−16
• tests/utf8-display.sh +2/−1
• tests/v1-braced.sh +1/−3
• tests/whatsnew-adds-no-summary.sh +51/−0
• tests/whatsnew.sh +7/−7

@@ -1,3 +1,55 @@+Darcs 2.14.0, 4 April 2018++  * fix encoding business, make DARCS_DONT_ESCAPE_8BIT=1 default (Ben, Ganesh Sittampalam)+  * show explicit dependencies in `darcs log -s` (Gian Piero Carrubba)+  * improve bash/zsh completion (Ben, Gian Piero)+  * no longer print an error message when ctrlc'ing pager (Guillaume Hoffmann)+  * `darcs help markdown` mentions all files in `_darcs/prefs/` (Guillaume)+  * add patch index status to `show repo` command (Ben)+  * per-file conflict marking (Ben Franksen)+  * make it possible to use DARCS_SCP=rsync (Ben)+  * add --not-in-remote option to unrecord command (Ben)+  * plug memory leak and improve efficiency in annotate (Ben)+  * save unneeded FL/RL reverses in SelectChanges module (Ben)+  * optimize token replace code and --look-for-replaces (Ben)+  * no longer show conflicting files on `whatsnew -s`, will reintrodue this+    feature when it is done efficiently (Guillaume)+  * separate display and storage of patches (Ben)+  * support GHC 8.2 and GHC 8.4 (Ganesh)+  * many refactorings in Darcs.Repository modules and API (Ben, Guillaume)+  * no longer track build dependencies in Setup.hs, nor use+    alpha, beta, rc names (Guillaume)+  * refactor `pull --reorder-patches` (Ben)+  * refactor SelectChanges (Ben)+  * remove Patchy typeclass and redundant constaints where possible (Guillaume)+  * fix build with cabal new-build (Francesco Ariis)+  * unit and quickcheck tests for inventories (Ben)+  * throw out all access to bytestring internals from Darcs.Util.ByteString (Ben)+  * refactor, simplify, and document hunk application (Ben)+  * drop support of old cache location and SHA1-hashed repos (Guillaume)+  * rely on GHC's own stack traces for bug reporting (Guillaume)+  * fixed the following bugs:+    * fix mail encoding with '.' or '=' as last character (Timo von Holtz)+    * 2526: whatsnew -l --boring should list boring files (Ben)+    * 2208: replace detects existing force hunks in working (Ben)+    * 2512: author name is written to repository after multiple-choice+      prompt (Stephan-A. Posselt)+    * 2359: convert --export mishandles Unicode filenames (Ben)+    * 2545: prevent argument smuggling in SSH repository URLs (Gian Piero)+    * 2581: fix rebase pull --reorder (Ben)+    * 2575: fix unrevert with rebase (Ben)+    * 2579: allow darcs send to work even if no MTA is installed+    * 2555: include explicit dependencies in the output of `log -v` (Gian Piero)+    * 2569: decoding multibyte characters (Ben)+    * 2563: create remote repo in correct format in ssh tests (Ben)+    * 2565: create _darcs dir after searching for an existing one (Ben)+    * 2567: darcs whatsnew --unified (Ben)+    * 2566: avoid renaming across file systems (Ben)+    * 2564: delete wrong and irrelevant propConcatPS (Guillaume)+    * 2559: remove trailing empty lines in patch header edition (Guillaume)+    * 2536: mask out internal matchers in `show files` routing logic (Gian Piero)++ Darcs 2.12.5, 11 January 2017   * Bump some dependency upper bounds (Ganesh Sittampalam)

@@ -0,0 +1,241 @@+-- copyright (c) 2008 Duncan Coutts+-- portions copyright (c) 2008 David Roundy+-- portions copyright (c) 2007-2009 Judah Jacobson++import Distribution.Simple+         ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.ModuleName( toFilePath )+import Distribution.PackageDescription+         ( PackageDescription(executables, testSuites), Executable(exeName)+         , emptyBuildInfo+         , TestSuite(testBuildInfo)+         , updatePackageDescription+         , cppOptions, ccOptions+         , library, libBuildInfo, otherModules )+import Distribution.Package+         ( packageVersion )+import Distribution.Version( Version )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), absoluteInstallDirs )+import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest))+import Distribution.Simple.Setup+    (buildVerbosity, copyDest, copyVerbosity, fromFlag,+     haddockVerbosity, installVerbosity, sDistVerbosity, replVerbosity )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.System+         ( OS(Windows), buildOS )+import Distribution.Simple.Utils+    (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,+     rewriteFile )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text+         ( display )+import Control.Monad ( unless, void )++import System.Directory+    ( doesDirectoryExist, doesFileExist )+import System.IO+    ( openFile, IOMode(..) )+import System.Process (runProcess)+import Data.List( isInfixOf, lines )+import System.FilePath       ( (</>) )+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 :: IO a -> (Exception.SomeException -> IO a) -> IO a+catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException))++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks {++  buildHook = \ pkg lbi hooks flags ->+              let verb = fromFlag $ buildVerbosity flags+               in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags),++  haddockHook = \ pkg lbi hooks flags ->+                let verb = fromFlag $ haddockVerbosity flags+                 in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) ,+  replHook = \pkg lbi hooks flags args ->+                let verb = fromFlag $ replVerbosity flags+                 in commonBuildHook replHook pkg lbi hooks verb >>= (\f -> f flags args) ,+  postBuild = \ _ _ _ lbi -> buildManpage lbi,+  postCopy = \ _ flags pkg lbi ->+             installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags),+  postInst = \ _ flags pkg lbi ->+             installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest,++  sDistHook = \ pkg lbi hooks flags -> do+    let pkgVer = packageVersion pkg+        verb = fromFlag $ sDistVerbosity flags+    x <- versionPatches verb pkgVer+    y <- context verb+    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+             ,+  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 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.+              [-- 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+    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+  void $ runProcess darcs ["help","manpage"]+             Nothing Nothing Nothing (Just manpageHandle) Nothing++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)++  where+    versionStateString :: Maybe Int -> String+    versionStateString Nothing  = "unknown"+    versionStateString (Just 0) = "release"+    versionStateString (Just 1) = "+ 1 patch"+    versionStateString (Just n) = "+ " ++ show n ++ " patches"++versionPatches :: Verbosity -> Version -> IO (Maybe Int)+versionPatches verbosity darcsVersion = do+  numPatchesDarcs <- do+      out <- rawSystemStdout verbosity "darcs"+               ["log", "-a", "--from-tag", display darcsVersion, "--count"]+      case reads out of+        ((n,_):_) -> return $ Just ((n :: Int) - 1)+        _         -> return Nothing+    `catchAny` \_ -> return Nothing++  numPatchesDist <- parseFile 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 -> LocalBuildInfo+                      -> String -> String -> IO ()+generateVersionModule verbosity lbi version state = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  ctx <- context verbosity+  hash <- weakhash verbosity+  rewriteFile (dir </> "Version.hs") $ unlines+    ["module Version where"+    ,"version, weakhash, context :: String"+    ,"version = \"" ++ version ++ " (" ++ state ++ ")\""+    ,"weakhash = " ++ case hash of+                        Just x -> show x+                        Nothing -> show "not available"+    ,"context = " ++ case ctx of+                       Just x -> show x+                       Nothing -> show "context not available"+    ]++weakhash :: Verbosity -> IO (Maybe String)+weakhash verbosity = do+  inrepo <- doesDirectoryExist "_darcs"+  unless inrepo $ fail "Not a repository."+  out <- rawSystemStdout verbosity "darcs" ["show", "repo"]+  let line = filter ("Weak Hash:" `isInfixOf`) $ lines out+  return $ case (length line) of+                0 -> Nothing+                _ -> Just $ last $ words $ head line+ `catchAny` \_ -> return Nothing++context :: Verbosity -> IO (Maybe String)+context verbosity = 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

@@ -1,382 +0,0 @@-\begin{code}-{-# LANGUAGE TemplateHaskell #-}--- copyright (c) 2008 Duncan Coutts--- portions copyright (c) 2008 David Roundy--- portions copyright (c) 2007-2009 Judah Jacobson--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 lib = maybe (error "darcs library was not configured - did it end up unbuildable?") id-                          (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.-              [-- 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 <iconv.h>"-    , "int main(void) {"-    , "    iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"-    , "    return 0;"-    , "}"-    ]--\end{code}

@@ -1,35 +1,38 @@ #compdef darcs-## Darcs completion snippet for zsh.+## Darcs completion for zsh. ##+## Originally derived from a version by ## Copyright (C) 2009  Nicolas Pouillard-##-## This program is free software; you can redistribute it and/or modify-## it under the terms of the GNU General Public License as published by-## the Free Software Foundation; either version 2 of the License, or-## (at your option) any later version.-##-## This program is distributed in the hope that it will be useful,-## but WITHOUT ANY WARRANTY; without even the implied warranty of-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-## GNU General Public License for more details. +local -a darcs_options darcs_non_options darcs_arguments+ if (($CURRENT == 2)); then-  # We're completing the first word after "darcs" -- the command.-  _wanted command expl 'darcs command' \-    compadd -- $( darcs --commands )+  compadd -- $(darcs --commands) else+  case "${words[2]}"; in+    get|clone)+      _urls+      ;;+  esac   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+      _files+      ;;+    -*)+      # advanced zsh (array) parameter expansion fu:+      # - ${(f)...} means split into array elements at line endings+      #   instead of white space+      # - ${arr:#pat} drops elements matching pat from arr, whereas+      #   ${(M)arr:#pat} drops non-matching elements+      # - ${arr/pat/repl} replaces pat with repl for all elements of arr+      darcs_arguments=(${(f)"$(words[$CURRENT]=--list-options && $words 2>/dev/null)"})+      darcs_options=(${${(M)darcs_arguments:#-*}/;/:})+      _describe '' darcs_options+      ;;     *)-        _arguments '*: :($(words[$CURRENT]="--list-options" && $words))'+      darcs_arguments=(${(f)"$(words[$CURRENT]=--list-options && $words 2>/dev/null)"})+      darcs_non_options=(${darcs_arguments:#-*})+      _multi_parts -i -S ' ' / darcs_non_options       ;;   esac fi

@@ -16,9 +16,27 @@         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//./\\.}") )+    # Store the whole command line substituting the (possibly empty)+    # to-be-completed word with '--list-options'.+    local -a words=("${COMP_WORDS[@]}")+    words[$COMP_CWORD]="--list-options" +    # Options are processed from left to right, so avoid to display the help+    # page when trying to complete a command line that includes '--help'. It+    # could be tricked by things like '--repodir --hell', but, come on... you+    # don't deserve a working completion if you name a directory '--hell'.+    for w in "${words[@]}"; do+        case "$w" in+            (--he*) return 0;;+        esac+    done++    # So that the following "command-output to array" operation splits only at+    # newlines, not at each space, tab or newline.+    local IFS=$'\n'+    COMPREPLY=( $( "${words[@]}" 2>/dev/null |\+        command grep "^${cur//./\\.}" | cut -d ';' -f 1) )+ 	# Then, we adapt the resulting strings to be reusable by bash. If we don't 	# do this, in the case where we have two repositories named 	# ~/space in there-0.1 and ~/space in there-0.2, the first completion will@@ -42,11 +60,8 @@     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-

@@ -1,6 +1,6 @@ Name:           darcs-version:        2.12.5-License:        GPL+version:        2.14.0+License:        GPL-2 License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net> Maintainer:     <darcs-devel@darcs.net>@@ -33,7 +33,7 @@ Homepage:       http://darcs.net/  Build-Type:     Custom-Cabal-Version:  >= 1.16+Cabal-Version:  >= 1.24  extra-source-files:   -- C headers@@ -107,16 +107,16 @@   manual:      True   description: Build with warnings-as-errors --- 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+-- ----------------------------------------------------------------------+-- setup+-- ---------------------------------------------------------------------- -flag network-uri-  description: Get Network.URI from the network-uri package-  default: True+custom-setup+    setup-depends: base      >= 4.9 && < 4.12,+                   Cabal     >= 1.24,+                   process   >= 1.2.3.0 && < 1.7,+                   filepath  >= 1.4.1 && < 1.5.0.0,+                   directory >= 1.2.6.2 && < 1.4  -- ---------------------------------------------------------------------- -- darcs library@@ -158,10 +158,7 @@                       Darcs.Patch.MonadProgress                       Darcs.Patch.Named                       Darcs.Patch.Named.Wrapped-                      Darcs.Patch.OldDate                       Darcs.Patch.PatchInfoAnd-                      Darcs.Patch.Patchy-                      Darcs.Patch.Patchy.Instances                       Darcs.Patch.Permutations                       Darcs.Patch.Prim                       Darcs.Patch.Prim.Class@@ -208,11 +205,13 @@                       Darcs.Patch.V1.Apply                       Darcs.Patch.V1.Commute                       Darcs.Patch.V1.Core+                      Darcs.Patch.V1.Prim                       Darcs.Patch.V1.Read                       Darcs.Patch.V1.Show                       Darcs.Patch.V1.Viewing                       Darcs.Patch.V2                       Darcs.Patch.V2.Non+                      Darcs.Patch.V2.Prim                       Darcs.Patch.V2.RepoPatch                       Darcs.Patch.Witnesses.Eq                       Darcs.Patch.Witnesses.Ordered@@ -225,18 +224,19 @@                       Darcs.Repository.ApplyPatches                       Darcs.Repository.Cache                       Darcs.Repository.Clone+                      Darcs.Repository.Create                       Darcs.Repository.PatchIndex                       Darcs.Repository.Diff                       Darcs.Repository.Flags                       Darcs.Repository.Format                       Darcs.Repository.HashedIO-                      Darcs.Repository.HashedRepo-                      Darcs.Repository.Internal+                      Darcs.Repository.Hashed+                      Darcs.Repository.Inventory+                      Darcs.Repository.Identify                       Darcs.Repository.Job                       Darcs.Repository.Merge                       Darcs.Repository.InternalTypes                       Darcs.Repository.Match-                      Darcs.Repository.Motd                       Darcs.Repository.Old                       Darcs.Repository.Packs                       Darcs.Repository.Pending@@ -246,6 +246,7 @@                       Darcs.Repository.Resolution                       Darcs.Repository.State                       Darcs.Repository.Test+                      Darcs.Repository.Working                       Darcs.UI.ApplyPatches                       Darcs.UI.Commands                       Darcs.UI.Commands.Add@@ -277,7 +278,6 @@                       Darcs.UI.Commands.SetPref                       Darcs.UI.Commands.Show                       Darcs.UI.Commands.ShowAuthors-                      Darcs.UI.Commands.ShowBug                       Darcs.UI.Commands.ShowContents                       Darcs.UI.Commands.ShowDependencies                       Darcs.UI.Commands.ShowFiles@@ -293,6 +293,7 @@                       Darcs.UI.Commands.Unrecord                       Darcs.UI.Commands.Unrevert                       Darcs.UI.Commands.WhatsNew+                      Darcs.UI.Completion                       Darcs.UI.Email                       Darcs.UI.External                       Darcs.UI.Defaults@@ -311,14 +312,10 @@                       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.Compat-                      Darcs.Util.Crypt.SHA1-                      Darcs.Util.Crypt.SHA256                       Darcs.Util.DateMatcher                       Darcs.Util.DateTime                       Darcs.Util.Diff@@ -327,8 +324,8 @@                       Darcs.Util.Download                       Darcs.Util.Download.Request                       Darcs.Util.Download.HTTP+                      Darcs.Util.Encoding                       Darcs.Util.English-                      Darcs.Util.Environment                       Darcs.Util.Exception                       Darcs.Util.Exec                       Darcs.Util.External@@ -354,14 +351,11 @@                       Darcs.Util.Tree.Plain                       Darcs.Util.URL                       Darcs.Util.Workaround-                      Bundled.Posix      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@@ -382,98 +376,81 @@                       System.Posix.IO       cpp-options:    -DWIN32       c-sources:      src/win32/send_email.c-      build-depends:  Win32 >= 2.3 && < 2.4+      build-depends:  Win32 >= 2.3.1 && < 2.4     else-      other-modules:  Darcs.Util.Encoding.IConv-      c-sources:      src/h_iconv.c-      build-depends:  unix >= 2.6.0.1 && < 2.8+      build-depends:  unix >= 2.7.1.0 && < 2.8 -    build-depends:   base >= 4.8 && < 4.10,-                     binary >= 0.5 && < 0.9,-                     containers >= 0.5 && < 0.6,-                     regex-compat-tdfa >= 0.95.1 && < 0.96,-                     regex-applicative >= 0.2 && < 0.4,-                     mtl          >= 2.1.2 && < 2.3,-                     transformers >= 0.3 && < 0.4.0.0 || > 0.4.0.0 && < 0.6,-                     -- for the Control.Monad.Error -> Control.Monad.Except-                     -- transition-                     transformers-compat >= 0.4 && < 0.6,-                     parsec       >= 3.1 && < 3.2,-                     fgl          >= 5.5.0.1 && < 5.6,-                     graphviz     >= 2999.17.0.1 && < 2999.19,-                     html         >= 1.0.1.2 && < 1.1,-                     filepath     >= 1.3.0.1 && < 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.10.0.1 && < 0.13,-                     tar          >= 0.4 && < 0.6,-                     data-ordlist == 0.4.*,-                     attoparsec   >= 0.11 && < 0.14,-                     zip-archive  >= 0.2.3 && < 0.4,-                     async        >= 2.0.1.4 && < 2.2,-                     sandi        >= 0.4 && < 0.5,-                     unix-compat  >= 0.1.2 && < 0.5,-                     bytestring   >= 0.10.0.2 && < 0.11,-                     old-time     >= 1.1 && < 1.2,-                     time         >= 1.5 && < 1.8,-    -- 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-                     text         >= 1.2.1.3 && < 1.3,-                     directory    >= 1.2.0.1 && < 1.4.0.0,-                     process      >= 1.1.0.2 && < 1.5.0.0,-                     array        >= 0.4.0.1 && < 0.6,-                     random       >= 1.0.1.1 && < 1.2,-                     hashable     >= 1.1.2.5 && < 1.3,-                     mmap         >= 0.5 && < 0.6,-                     zlib         >= 0.5.4.1 && < 0.7.0.0+    build-depends:    base              >= 4.9 && < 4.12,+                      stm               >= 2.1 && < 2.5,+                      binary            >= 0.5 && < 0.9,+                      containers        >= 0.5.6.2 && < 0.6,+                      regex-compat-tdfa >= 0.95.1 && < 0.96,+                      regex-applicative >= 0.2 && < 0.4,+                      mtl               >= 2.2.1 && < 2.3,+                      transformers      >= 0.4.2.0 && < 0.6,+                      parsec            >= 3.1.9 && < 3.2,+                      fgl               >= 5.5.2.3 && < 5.6,+                      graphviz          >= 2999.18.1 && < 2999.20,+                      html              >= 1.0.1.2 && < 1.1,+                      filepath          >= 1.4.1 && < 1.5.0.0,+                      haskeline         >= 0.7.2 && < 0.8,+                      cryptohash        >= 0.11 && < 0.12,+                      base16-bytestring >= 0.1 && < 0.2,+                      utf8-string       >= 1 && < 1.1,+                      vector            >= 0.11 && < 0.13,+                      tar               >= 0.5 && < 0.6,+                      data-ordlist      == 0.4.*,+                      attoparsec        >= 0.13.0.1 && < 0.14,+                      zip-archive       >= 0.3 && < 0.4,+                      async             >= 2.0.2 && < 2.2,+                      sandi             >= 0.4 && < 0.5,+                      unix-compat       >= 0.4.2 && < 0.6,+                      bytestring        >= 0.10.6 && < 0.11,+                      old-time          >= 1.1.0.3 && < 1.2,+                      time              >= 1.5.0.1 && < 1.9,+                      text              >= 1.2.1.3 && < 1.3,+                      directory         >= 1.2.6.2 && < 1.4,+                      temporary         >= 1.2.0.4 && < 1.3,+                      process           >= 1.2.3.0 && < 1.7,+                      array             >= 0.5.1.0 && < 0.6,+                      random            >= 1.1 && < 1.2,+                      hashable          >= 1.2.3.3 && < 1.3,+                      mmap              >= 0.5.9 && < 0.6,+                      zlib              >= 0.6.1.2 && < 0.7.0.0,+                      network-uri       == 2.6.*,+                      network           == 2.6.*,+                      HTTP              >= 4000.2.20 && < 4000.4      if flag(optimize)-      ghc-options:      -O2+      ghc-options:    -O2     else-      ghc-options:      -O0+      ghc-options:    -O0      if flag(warn-as-error)-      ghc-options:      -Werror--    -- Note: "if true" works around a cabal bug with order of flag composition-    -- fixed in Cabal 1.18 https://github.com/haskell/cabal/commit/cf0cf077ab6836584fc3bf51d867e63824811d4d-    if true-      ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-dodgy-imports+      ghc-options:    -Werror -    if impl(ghc>=8.0)-      -- This warning is new in GHC 8.0 and is not easy to fix-      ghc-options:      -fno-warn-redundant-constraints+    ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs      if flag(curl)-      cpp-options:       -DHAVE_CURL-      c-sources:         src/hscurl.c-      cc-options:        -DHAVE_CURL+      cpp-options:          -DHAVE_CURL+      c-sources:            src/hscurl.c+      cc-options:           -DHAVE_CURL       if flag(pkgconfig)-        pkgconfig-depends: libcurl+        pkgconfig-depends:  libcurl       else-        extra-libraries:   curl-        includes:          curl/curl.h--    if flag(network-uri)-      build-depends:    network-uri == 2.6.*, network == 2.6.*-    else-      build-depends:    network >= 2.4.1.2 && < 2.6--    build-depends:    HTTP    >= 4000.2.8 && < 4000.4+        extra-libraries:    curl+        includes:           curl/curl.h      -- The terminfo package cannot be built on Windows.     if flag(terminfo) && !os(windows)-      build-depends:    terminfo >= 0.3 && < 0.5-      cpp-options:      -DHAVE_TERMINFO+      build-depends:  terminfo >= 0.4.0.2 && < 0.5+      cpp-options:    -DHAVE_TERMINFO -    -- if true to work around cabal bug with flag ordering-    if true-      default-extensions:+    default-extensions:         BangPatterns         PatternGuards-        GADTs+        GADTSyntax+        ExistentialQuantification         TypeOperators         FlexibleContexts         FlexibleInstances@@ -501,50 +478,29 @@   hs-source-dirs:   darcs    if flag(optimize)-    ghc-options:      -O2+    ghc-options:    -O2   else-    ghc-options:      -O0+    ghc-options:    -O0    if flag(warn-as-error)-    ghc-options:      -Werror+    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 -fno-warn-dodgy-imports+  ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs    if flag(threaded)     ghc-options:    -threaded    if flag(static)-    ghc-options: -static -optl-static -optl-pthread+    ghc-options:    -static -optl-static -optl-pthread    if flag(rts)-    ghc-options: -rtsopts--  if impl(ghc>=8.0)-    -- This warning is new in GHC 8.0 and is not easy to fix-    ghc-options:      -fno-warn-redundant-constraints+    ghc-options:    -rtsopts    -- see http://bugs.darcs.net/issue1037   cc-options:       -D_REENTRANT -  build-depends:   darcs,-                   base              >= 4.8 && < 4.10--  -- 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+  build-depends:    darcs,+                    base              >= 4.9 && < 4.12  -- ---------------------------------------------------------------------- -- unit test driver@@ -558,32 +514,33 @@   hs-source-dirs:   harness    if os(windows)-    cpp-options:   -DWIN32-    build-depends:  Win32 >= 2.2 && < 2.4+    cpp-options:    -DWIN32+    build-depends:  Win32 >= 2.3.1 && < 2.4 -  build-depends:   darcs,-                   base         >= 4.8 && < 4.10,-                   array        >= 0.4.0.1 && < 0.6,-                   bytestring   >= 0.10.0.2 && < 0.11,-                   cmdargs      >= 0.10 && < 0.11,-                   containers   >= 0.1 && < 0.6,-                   filepath     >= 1.3.0.1 && < 1.5.0.0,-                   mtl          >= 2.1 && < 2.3,-                   shelly       >= 1.6.2 && < 1.7,-                   split        >= 0.2.2 && < 0.3,-                   text         >= 1.2.1.3 && < 1.3,-                   directory    >= 1.2.0.1 && < 1.4.0.0,-                   FindBin      >= 0.0 && < 0.1,-                   QuickCheck   >= 2.6 && < 2.10,-                   HUnit        >= 1.2.5.2 && < 1.6,-                   test-framework             >= 0.4.0 && < 0.9,-                   test-framework-hunit       >= 0.2.2 && < 0.4,-                   test-framework-quickcheck2 >= 0.3 && < 0.4,-                   zip-archive  >= 0.2.3 && < 0.4+  build-depends:    darcs,+                    base         >= 4.9 && < 4.12,+                    array        >= 0.5.1.0 && < 0.6,+                    bytestring   >= 0.10.6 && < 0.11,+                    cmdargs      >= 0.10.10 && < 0.11,+                    containers   >= 0.5.6.2 && < 0.6,+                    filepath     >= 1.4.1 && < 1.5.0.0,+                    mtl          >= 2.2.1 && < 2.3,+                    shelly       >= 1.6.8 && < 1.7,+                    split        >= 0.2.2 && < 0.3,+                    text         >= 1.2.1.3 && < 1.3,+                    directory    >= 1.2.6.2 && < 1.4,+                    FindBin      >= 0.0.5 && < 0.1,+                    QuickCheck   >= 2.8.2 && < 2.11,+                    HUnit        >= 1.3 && < 1.7,+                    test-framework             >= 0.8.1.1 && < 0.9,+                    test-framework-hunit       >= 0.3.0.2 && < 0.4,+                    test-framework-quickcheck2 >= 0.3.0.3 && < 0.4,+                    zip-archive  >= 0.3 && < 0.4    -- list all unit test modules not exported by libdarcs; otherwise Cabal won't   -- include them in the tarball   other-modules:    Darcs.Test.Email+                    Darcs.Test.HashedStorage                     Darcs.Test.Patch.Check                     Darcs.Test.Patch.Examples.Set1                     Darcs.Test.Patch.Examples.Set2Unwitnessed@@ -609,37 +566,34 @@                     Darcs.Test.Patch.WithState                     Darcs.Test.Patch                     Darcs.Test.Misc+                    Darcs.Test.Misc.CommandLine+                    Darcs.Test.Misc.Encoding+                    Darcs.Test.Repository.Inventory                     Darcs.Test.Util.TestResult                     Darcs.Test.Util.QuickCheck-                    Storage.Hashed.Test    if flag(optimize)-    ghc-options:      -O2+    ghc-options:    -O2   else-    ghc-options:      -O0+    ghc-options:    -O0    if flag(warn-as-error)-    ghc-options:      -Werror+    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-options:      -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-orphans    if flag(threaded)     ghc-options:    -threaded    if flag(rts)-    ghc-options: -rtsopts+    ghc-options:    -rtsopts    -- see http://bugs.darcs.net/issue1037   cc-options:       -D_REENTRANT -  -- if true to work around cabal bug with flag ordering-  if true-    default-extensions:-      BangPatterns-      PatternGuards-      GADTs+  default-extensions:+      GADTSyntax+      ExistentialQuantification       TypeOperators       FlexibleContexts       FlexibleInstances@@ -650,5 +604,3 @@       RankNTypes       TypeFamilies       NoMonoLocalBinds--

@@ -27,27 +27,24 @@  module Main ( main ) where +import Prelude ()+import Darcs.Prelude+ 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"+import Version ( version, context, weakhash )  execExceptionHandler :: ExecException -> IO a execExceptionHandler (ExecException cmd args redirects reason) = do@@ -62,7 +59,7 @@ main = withAtexit . withSignalsHandled . handleExecFail . handleAssertFail $ do     atexit reportBadSources     setDarcsEncodings-    argv <- getArgs >>= mapM decodeString+    argv <- getArgs     here <- getCurrentDirectory     let runHelpCmd = helpCmd (here, here) [] []     -- Explicitly handle no-args and special "help" arguments.@@ -70,20 +67,17 @@         [] -> printVersion >> runHelpCmd         ["-h"] -> runHelpCmd         ["--help"] -> runHelpCmd-        ["--overview"] -> helpCmd (here, here) [Verbose] []         ["--commands"] -> listAvailableCommands         ["-v"] -> putStrLn version+        ["-V"] -> putStrLn version         ["--version"] -> putStrLn version         ["--exact-version"] -> printExactVersion-        _ -> do-            forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True-            runTheCommand commandControlList (head argv) (tail argv)+        _ -> 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 $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__ ++ "\n"+        putStrLn $ "Weak Hash: " ++ weakhash         putStrLn context-        putStrLn "Compiled with:\n"-        putStr builddeps 

@@ -21,15 +21,17 @@ -- 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,+import qualified Data.ByteString as B ( length, unpack, null, head, pack,                                         cons, empty, foldr, ByteString )-import qualified Data.ByteString.Char8 as BC ( unpack )+import qualified Data.ByteString.Char8 as BC ( unlines ) 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 )+import Test.QuickCheck ( Arbitrary(..) )+import Darcs.Util.Printer ( text, renderPS, packedString )+import Darcs.UI.Email ( makeEmail, readEmail, formatHeader, prop_qp_roundtrip )  testSuite :: Test testSuite = testGroup "Darcs.Email"@@ -38,16 +40,17 @@   , emailHeaderAsciiChars   , emailHeaderLinesStart   , emailHeaderNoEmptyLines+  , emailCodecRoundtrip   ]  -- | 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+emailParsing = testProperty "Checking that email can be parsed" $ \bs ->+    BC.unlines (B.empty:bs++[B.empty,B.empty]) ==+              readEmail (renderPS                     $ makeEmail "reponame" [] (Just (text "contents\n"))                                  Nothing-                                 (text $ unlines s) (Just "filename")))+                                 (packedString $ BC.unlines bs) (Just "filename"))  -- | Check that formatHeader never creates lines longer than 78 characters -- (excluding the carriage return and line feed)@@ -81,6 +84,13 @@       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++instance Arbitrary B.ByteString where+  arbitrary = fmap B.pack arbitrary++emailCodecRoundtrip :: Test+emailCodecRoundtrip =+    testProperty "Checking that quoted printable en- then decoding is id" $ prop_qp_roundtrip  bsLines :: B.ByteString -> [B.ByteString] bsLines = finalizeFold . B.foldr splitAtLines (B.empty, [])

@@ -0,0 +1,501 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}+module Darcs.Test.HashedStorage( tests ) where++import Prelude hiding ( filter, readFile, writeFile, lookup, (<$>) )+import qualified Prelude+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString.Char8 as BC+import System.Directory( doesFileExist, removeFile, doesDirectoryExist )+import System.FilePath( (</>) )+import Control.Monad.Identity+import Control.Monad.Trans( lift )+import Control.Applicative( (<$>) )+import Codec.Archive.Zip( extractFilesFromArchive, toArchive )++import Data.Maybe+import Data.Word+import Data.List( sort, intercalate, intersperse )++import Darcs.Util.Path hiding ( setCurrentDirectory )+import Darcs.Util.Lock ( withTempDir )+import Darcs.Util.Tree hiding ( lookup )+import Darcs.Util.Index+import Darcs.Util.Tree.Hashed+import Darcs.Util.Hash+import Darcs.Util.Tree.Monad hiding ( tree, createDirectory )+import Darcs.Util.Tree.Plain++import System.Mem( performGC )++import qualified Data.Set as S++import Test.HUnit hiding ( path )+import Test.Framework( testGroup )+import qualified Test.Framework as TF ( Test )+import Test.QuickCheck++import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2++------------------------+-- Test Data+--++blobs :: [(AnchoredPath, BLC.ByteString)]+blobs = [ (floatPath "foo_a", BLC.pack "a\n")+        , (floatPath "foo_dir/foo_a", BLC.pack "a\n")+        , (floatPath "foo_dir/foo_b", BLC.pack "b\n")+        , (floatPath "foo_dir/foo_subdir/foo_a", BLC.pack "a\n")+        , (floatPath "foo space/foo\nnewline", BLC.pack "newline\n")+        , (floatPath "foo space/foo\\backslash", BLC.pack "backslash\n")+        , (floatPath "foo space/foo_a", BLC.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 $ BLC.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 "Darcs.Util.Hash" hash+        , testGroup "Darcs.Util.Tree" tree+        , testGroup "Darcs.Util.Index" index+        , testGroup "Darcs.Util.Tree.Monad" monad+        , testGroup "Hashed Storage" hashed ]++--------------------------+-- Tests+--++hashed :: [TF.Test]+hashed = [ testCase "plain has all files" have_files+         , testCase "pristine has all files" have_pristine_files+         , testCase "pristine has no extras" pristine_no_extra+         , testCase "pristine file contents match" pristine_contents+         , testCase "plain file contents match" plain_contents+         , testCase "writePlainTree works" write_plain ]+    where+      check_file t f = assertBool+                       ("path " ++ show f ++ " is missing in tree " ++ show t)+                       (isJust $ find t f)+      check_files = forM_ files . check_file++      pristine_no_extra = extractRepoAndRun $+       do+        t <- readDarcsPristine "." >>= expand+        forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree")+                                                 (path `elem` (dirs ++ files))+      have_files = extractRepoAndRun ( readPlainTree "." >>= expand >>= check_files )+      have_pristine_files = extractRepoAndRun ( readDarcsPristine "." >>= expand >>= check_files )++      pristine_contents = extractRepoAndRun $+       do+        t <- readDarcsPristine "." >>= expand+        equals_testdata t++      plain_contents = extractRepoAndRun $+       do+        t <- expand =<< filter nondarcs `fmap` readPlainTree "."+        equals_testdata t++      write_plain = extractRepoAndRun $+       do+        orig <- readDarcsPristine "." >>= expand+        writePlainTree orig "_darcs/plain"+        t <- expand =<< readPlainTree "_darcs/plain"+        equals_testdata t++index :: [TF.Test]+index = [ testCase "index versioning" check_index_versions+        , testCase "index listing" check_index+        , testCase "index content" check_index_content+        , testProperty "xlate32" prop_xlate32+        , testProperty "xlate64" prop_xlate64+        , testProperty "align bounded" prop_align_bounded+        , testProperty "align aligned" prop_align_aligned ]+    where pristine = readDarcsPristine "." >>= expand+          build_index =+            do x <- pristine+               exist <- doesFileExist "_darcs/index"+               performGC -- required in win32 to trigger file close+               when exist $ removeFile "_darcs/index"+               idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x+               return (x, idx)+          check_index = extractRepoAndRun $+            do (pris, idx) <- build_index+               (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)+          check_blob_pair p x y =+              do a <- readBlob x+                 b <- readBlob y+                 assertEqual ("content match on " ++ show p) a b+          check_index_content = extractRepoAndRun $+            do (_, idx) <- build_index+               plain <- readPlainTree "."+               x <- sequence $ zipCommonFiles check_blob_pair plain idx+               assertBool "files match" (length x > 0)+          check_index_versions = extractRepoAndRun $+            do performGC -- required in win32 to trigger file close+               Prelude.writeFile "_darcs/index" "nonsense index... do not crash!"+               valid <- indexFormatValid "_darcs/index"+               assertBool "index format invalid" $ not valid+          prop_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)++tree :: [TF.Test]+tree = [ testCase "modifyTree" check_modify+       , testCase "complex modifyTree" check_modify_complex+       , testCase "modifyTree removal" check_modify_remove+       , testCase "expand" check_expand+       , testCase "expandPath" check_expand_path+       , testCase "expandPath of sub" check_expand_path_sub+       , testCase "diffTrees" check_diffTrees+       , testCase "diffTrees identical" check_diffTrees_ident+       , testProperty "expandPath" prop_expandPath+       , testProperty "shapeEq" prop_shape_eq+       , testProperty "expandedShapeEq" prop_expanded_shape_eq+       , testProperty "expand is identity" prop_expand_id+       , testProperty "filter True is identity" prop_filter_id+       , testProperty "filter False is empty" prop_filter_empty+       , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative+       , testProperty "restrict is a subtree of both" prop_restrict_subtree+       , testProperty "overlay keeps shape" prop_overlay_shape+       , testProperty "overlay is superset of over" prop_overlay_super ]+    where blob x = File $ Blob (return (BLC.pack x)) (sha256 $ BLC.pack x)+          name = makeName+          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 (BLC.pack "bar")+                     assertEqual "new version" y (BLC.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 (BLC.pack "bar")+                     assertEqual "old bar/foo" bar_foo (BLC.pack "bar")+                     assertEqual "new foo" foo' (BLC.pack "bar")+                     assertEqual "new bar/foo" bar_foo' (BLC.pack "bla")+                     assertBool "list has bar/foo" $+                                isJust (Prelude.lookup (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 = extractRepoAndRun $+                 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)+                    BLC.unpack foo_work_c @?= "b\n"+                    BLC.unpack foo_pris_c @?= "a\n"+                    assertEqual "working' tree is minimal" 2 (length $ list working')+                    assertEqual "pristine' tree is minimal" 2 (length $ list pristine')++          check_diffTrees_ident = do+            pristine <- readDarcsPristine "."+            (t1, t2) <- diffTrees pristine pristine+            assertBool "t1 is empty" $ null (list t1)+            assertBool "t2 is empty" $ null (list t2)++          prop_shape_eq x = no_stubs x ==> x `shapeEq` x+              where _types = x :: Tree Identity+          prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x+              where _types = x :: Tree Identity+          prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x+              where _types = x :: Tree Identity+          prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x+              where _types = x :: Tree Identity+          prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x+              where _types = x :: Tree Identity+          prop_restrict_shape_commutative (t1, t2) =+              no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==>+                  restrict t1 t2 `shapeEq` restrict t2 t1+              where _types = (t1 :: Tree Identity, t2 :: Tree Identity)+          prop_restrict_subtree (t1, t2) =+              no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==>+                  let restricted = S.fromList (map fst $ list $ restrict t1 t2)+                      orig1 = S.fromList (map fst $ list t1)+                      orig2 = S.fromList (map fst $ list t2)+                   in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2]+              where _types = (t1 :: Tree Identity, t2 :: Tree Identity)+          prop_overlay_shape (t1 :: Tree Identity, t2) =+              (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==>+              runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1+          prop_overlay_super (t1 :: Tree Identity, t2) =+              (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) && no_stubs t2 ==>+              Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2)+          prop_expandPath (TreeWithPath t p) =+              notStub $ find (runIdentity $ expandPath t p) p+            where notStub (Just (Stub _ _)) = False+                  notStub Nothing = error "Did not exist."+                  notStub _ = True++hash :: [TF.Test]+hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 ]+    where prop_base16 x = (decodeBase16 . encodeBase16) 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 $ BLC.unpack file @?= ""+                             lift $ BLC.unpack file2 @?= "foo"+          check_rename = do (_, t) <- virtualTreeMonad run testTree+                            t' <- darcsAddMissingHashes =<< expand t+                            forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) ->+                               assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash+              where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2")++----------------------------------+-- Arbitrary instances+--++instance Arbitrary BLC.ByteString where+    arbitrary = BLC.pack `fmap` arbitrary++instance Arbitrary Hash where+    arbitrary = sized hash'+        where hash' 0 = return NoHash+              hash' _ = SHA256 . BC.pack <$> sequence [ arbitrary | _ <- [1..32] :: [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 (x:_)) _ | x == makeName "_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 <- BC.readFile h_inventory+             let thelines = BC.split '\n' inv+             case thelines of+               [] -> return emptyTree+               (pris_line:_) -> do+                          let thehash = decodeDarcsHash $ BC.drop 9 pris_line+                              thesize = decodeDarcsSize $ BC.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!"++extractRepoAndRun :: IO a -> IO a+extractRepoAndRun action = do+  zipFile <- toArchive . BLC.fromStrict <$> BC.readFile "harness/hstestdata.zip"+  withTempDir "_test_playground" $ \_ -> do+    extractFilesFromArchive [] zipFile+    action

@@ -15,33 +15,45 @@ --  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.ByteString+    ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex+    , propHexConversion+    , prop_unlinesPS_linesPS_left_inverse+    , prop_linesPS_length+    , prop_unlinesPS_length+    , spec_betweenLinesPS+    , betweenLinesPS+    ) import Darcs.Util.Diff.Myers ( shiftBoundaries ) -import qualified Data.ByteString.Char8 as BC ( unpack, pack )-import qualified Data.ByteString as B ( concat, empty )+import Darcs.Test.Misc.CommandLine ( commandLineTestSuite )+import qualified Darcs.Test.Misc.Encoding as Encoding++import qualified Data.ByteString.Char8 as BC ( unpack, pack, last )+import qualified Data.ByteString as B ( ByteString, pack, empty, null )+import Data.Char ( ord ) 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 )+import Test.QuickCheck   testSuite :: Test testSuite = testGroup ""  [ byteStringUtilsTestSuite  , lcsTestSuite+ , commandLineTestSuite+ , Encoding.testSuite  ]   -- ---------------------------------------------------------------------- -- * Darcs.Util.ByteString--- Here are a few quick tests of the shiftBoundaries function. -- ----------------------------------------------------------------------  byteStringUtilsTestSuite :: Test@@ -51,16 +63,27 @@   , 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+  , testProperty "unlinesPS is left inverse of linesPS" prop_unlinesPS_linesPS_left_inverse+  , testProperty "linesPS length property" prop_linesPS_length+  , testProperty "unlinesPS length property" prop_unlinesPS_length+  , testProperty "betweenLinesPS behaves like its spec" prop_betweenLinesPS   ] -propHexConversion :: String -> Bool-propHexConversion s =-    fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s+-- tweak the probabilities in favor of newline characters+instance Arbitrary B.ByteString where+  arbitrary = fmap B.pack $ listOf $ frequency+    [ (1, return (fromIntegral (ord '\n')))+    , (4, arbitrary)+    ] -propConcatPS :: [String] -> Bool-propConcatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss)+-- betweenLinesPS and spec_betweenLinesPS are equivalent only+-- if certain conditions are met+prop_betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString -> Property+prop_betweenLinesPS start end ps =+  not (B.null start) && not (B.null end) &&+  (B.null ps || BC.last ps == '\n') ==>+  betweenLinesPS start end ps == spec_betweenLinesPS start end ps  -- ---------------------------------------------------------------------- -- * LCS

@@ -0,0 +1,41 @@+module Darcs.Test.Misc.CommandLine+  (+    commandLineTestSuite+  ) where++import Test.HUnit ( assertEqual, assertFailure )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework ( Test, testGroup )++import Darcs.Util.CommandLine ( parseCmd )++formatTable :: [(Char, String)]+formatTable = [('s',"<insert subject here>"),+               ('a',"<insert author here>"),+               ('d',"date")+              ]++testParser :: (String, ([String], Bool)) -> Test+testParser (s, ok) =+  testCase ("Parse: " ++ show s) $+    case parseCmd formatTable s of+      Left e -> assertFailure $ "Parser failed with: " ++ show e+      Right res -> assertEqual ("Parsing: " ++ show s) ok res++testCases :: [(String, ([String], Bool))]+testCases = [("a b",(["a","b"], False)),+             ("a b %<",(["a","b"], True)),+             ("a b %< ",(["a","b"], True)),+             ("\"arg0 contains spaces \\\"quotes\\\"\" b",+              (["arg0 contains spaces \"quotes\"","b"],False)),+             ("a %s %<",(["a","<insert subject here>"], True)),+             ("\"%d\"", (["date"], False)),+             ("\"d %d\"", (["d date"], False)),+             ("\\\a", (["\\\a"], False)),+             ("\"\\\a\"", (["\a"], False)),+             ("\"/foo:%d\"", (["/foo:date"], False))+            ]++commandLineTestSuite :: Test+commandLineTestSuite =+  testGroup "Darcs.Util.CommandLine" $ map testParser testCases

@@ -0,0 +1,36 @@+module Darcs.Test.Misc.Encoding ( testSuite ) where++import qualified Data.ByteString as B+import Control.Monad+import Data.Word+import System.IO.Unsafe++import Darcs.Util.Encoding++import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck++decodeThenEncode :: B.ByteString -> B.ByteString+decodeThenEncode = unsafePerformIO . (decode >=> encode)++testSuite :: Test+testSuite = testGroup "Darcs.Util.Encoding"+ [ testProperty "decode then encode roundtrips" propDecodeThenEncodeRoundTrip+ ]++-- could use the bytestring-arbitrary package,+-- but the shrinking isn't as effective as 'shrinkList shrink'+newtype MyByteString = MBS { _mbsBytes :: [Word8] }+ deriving Show++instance Arbitrary MyByteString where+  arbitrary = MBS <$> sized (\n -> vectorOf (100*n) arbitrary)+  shrink (MBS ws) = MBS <$> shrinkList shrink ws++toBS :: MyByteString -> B.ByteString+toBS (MBS ws) = B.pack ws++propDecodeThenEncodeRoundTrip :: MyByteString -> Bool+propDecodeThenEncodeRoundTrip mbs =+  let bstr = toBS mbs in decodeThenEncode bstr == bstr

@@ -1,8 +1,4 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP, ImpredicativeTypes #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE AllowAmbiguousTypes #-}-#endif+{-# LANGUAGE AllowAmbiguousTypes  #-} --  Copyright (C) 2002-2005,2007 David Roundy -- --  This program is free software; you can redistribute it and/or modify@@ -35,19 +31,21 @@  import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Eq ( MyEq, unsafeCompare )+import Darcs.Patch.Witnesses.Eq ( Eq2, 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 Darcs.Patch.Prim( PrimPatch, coalesce, FromPrim, PrimOf ) import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Type ( PatchType(..) ) import Darcs.Patch.V1 as V1 ( RepoPatchV1 )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim ) import Darcs.Patch.V2.RepoPatch ( isConsistent, isForward, RepoPatchV2 )-import Darcs.Patch.Patchy ( Commute(..), Patchy )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Merge( Merge ) import Darcs.Patch.Show ( ShowPatchBasic )-import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Apply( Apply, ApplyState )  import Darcs.Test.Patch.Arbitrary.Generic import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1@@ -76,15 +74,16 @@ import qualified Darcs.Test.Patch.WSub as WSub  -type instance ModelOf (FL prim) = ModelOf prim+type Prim1 = V1.Prim+type Prim2 = V2.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)+newtype TestGenerator thing gen = TestGenerator (forall t ctx . ((forall wXx wYy . thing wXx wYy -> t) -> (gen ctx -> t)))+newtype TestCondition thing = TestCondition (forall wYy wZz . thing wYy wZz -> Bool)+newtype TestCheck thing t = TestCheck (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+arbitraryThing _ = TestGenerator (\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.@@ -123,7 +122,7 @@   , 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 "fails" (PropU.commuteFails WSub.commute) ([] :: [(Prim2 WSub.:> Prim2) wX wY])   , testCases "read and show work on Prim" PropU.show_read ExU.primPatches   , testCases "read and show work on RepoPatchV2" PropU.show_read ExU.repov2Patches   , testCases "example flattenings work" PropU.consistentTreeFlattenings ExU.repov2PatchLoopExamples@@ -140,27 +139,16 @@   , testCases "V2 partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.repov2NonduplicateTriples   ] -instance PrimPatch prim => Check (RepoPatchV2 prim) where-  checkPatch p = return $ isNothing $ isConsistent p--instance Check FileUUID.Prim where-  checkPatch _ = return True -- XXX--commuteRepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Maybe ((RepoPatchV2 prim :> RepoPatchV2 prim) wX wY)-commuteRepoPatchV2s = 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+           , Check 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))@@ -195,12 +183,18 @@   ]       where arbitraryThing' = arbitraryThing (undefined :: wA) -- bind the witness for generator +consistentV2 :: RepoPatchV2 Prim2 wX wY -> TestResult+consistentV2 = fromMaybe . isConsistent++commuteRepoPatchV2s :: (RepoPatchV2 Prim2 :> RepoPatchV2 Prim2) wX wY -> Maybe ((RepoPatchV2 Prim2 :> RepoPatchV2 Prim2) wX wY)+commuteRepoPatchV2s = commute+ qc_V2P1 :: [Test] qc_V2P1 =   [ testProperty "tree flattenings are consistent... "-    (PropR.propConsistentTreeFlattenings :: Sealed (WithStartState (ModelOf V1.Prim) (Tree V1.Prim)) -> Bool)+    (PropR.propConsistentTreeFlattenings :: Sealed (WithStartState (ModelOf Prim2) (Tree Prim2)) -> Bool)   , testProperty "with quickcheck that RepoPatchV2 patches are consistent... "-    (unseal $ P1.patchFromTree $ fromMaybe . isConsistent)+    (unseal $ P1.patchFromTree $ consistentV2)   -- permutivity ----------------------------------------------------------------------------   , testConditional "permutivity"     (unseal $ P1.commuteTripleFromTree notDuplicatestriple)@@ -214,7 +208,7 @@   ]  qc_V2 :: forall prim wXx wYy . (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim),-                                  Check (RepoPatchV2 prim), ArbitraryPrim prim, Show2 prim,+                                  ArbitraryPrim prim, Show2 prim,                                   RepoState (ModelOf prim) ~ ApplyState prim)       => prim wXx wYy -> [Test] qc_V2 _ =@@ -228,11 +222,11 @@                      -> Maybe (Tree (RepoPatchV2 prim) wX)))   ]   ++ concat-  [ merge_properties   (undefined :: RepoPatchV2 prim wX wY) "tree" mergePairFromTree-  , merge_properties   (undefined :: RepoPatchV2 prim wX wY) "twfp" mergePairFromTWFP-  , pair_properties    (undefined :: RepoPatchV2 prim wX wY) "tree" commutePairFromTree-  , pair_properties    (undefined :: RepoPatchV2 prim wX wY) "twfp" commutePairFromTWFP-  , patch_properties   (undefined :: RepoPatchV2 prim wX wY) "tree" patchFromTree+  [ merge_properties   (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator mergePairFromTree)+  , merge_properties   (undefined :: RepoPatchV2 prim wX wY) "twfp" (TestGenerator mergePairFromTWFP)+  , pair_properties    (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator commutePairFromTree)+  , pair_properties    (undefined :: RepoPatchV2 prim wX wY) "twfp" (TestGenerator commutePairFromTWFP)+  , patch_properties   (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator patchFromTree)   ]  properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen)) =>@@ -241,86 +235,98 @@            -> String -> String            -> forall t. Testable t => [(String, TestCondition thing, TestCheck thing t)]            -> [Test]-properties gen prefix genname tests =+properties (TestGenerator gen) prefix genname tests =   [ cond name condition check | (name, condition, check) <- tests ]   where cond :: forall testable. Testable testable              => String -> TestCondition thing -> TestCheck thing testable -> Test-        cond t c p =+        cond t (TestCondition c) (TestCheck 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+                 . ( Show1 gen, Arbitrary (Sealed gen), MightHaveDuplicate p+                   , Commute p, Invert p, ShowPatchBasic p, Eq2 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            )+  [ ("recommute"              , TestCondition (const True)     , TestCheck (PropG.recommute commute)           )+  , ("nontrivial recommute"   , TestCondition nontrivialCommute, TestCheck (PropG.recommute commute)           )+  , ("inverses commute"       , TestCondition (const True)     , TestCheck (PropG.commuteInverses commute)     )+  , ("nontrivial inverses"    , TestCondition nontrivialCommute, TestCheck (PropG.commuteInverses commute)     )+  , ("inverse composition"    , TestCondition (const True)     , TestCheck PropG.inverseComposition            )   ]  coalesce_properties :: forall p gen x y-                     . ( Show1 gen, Arbitrary (Sealed gen), Patchy p, PrimPatch p+                     . ( Show1 gen, Arbitrary (Sealed gen), 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 [])+   (if runCoalesceTests p then [ ("coalesce commutes with commute", TestCondition (const True), TestCheck (PropG.coalesceCommute coalesce)) ] else [])  -- The following properties do not hold for "RepoPatchV2" patches (conflictors and -- duplicates, specifically) . nonrpv2_commute_properties :: forall p gen x y-                            . (Show1 gen, Arbitrary (Sealed gen), Patchy p, ShowPatchBasic p, MyEq p)+                            . (Show1 gen, Arbitrary (Sealed gen), Commute p, Invert p, ShowPatchBasic p, Eq2 p)                            => p x y -> PropList (p :> p) gen nonrpv2_commute_properties _ genname gen =   properties gen "commute" genname-  [ ("patch & inverse commute", const True       , PropG.patchAndInverseCommute commute)-  , ("patch & inverse commute", nontrivialCommute, PropG.patchAndInverseCommute commute)+  [ ("patch & inverse commute", TestCondition (const True)     , TestCheck (PropG.patchAndInverseCommute commute))+  , ("patch & inverse commute", TestCondition nontrivialCommute, TestCheck (PropG.patchAndInverseCommute commute))   ] -patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, MyEq p)+patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Invert p, Apply p, Eq2 p)                  => p x y -> PropList p gen patch_properties _ genname gen =   properties gen "patch" genname-  [ ("inverse . inverse is id"  , const True       , PropG.invertSymmetry)+  [ ("inverse . inverse is id"  , TestCondition (const True)     , TestCheck PropG.invertSymmetry)   ]  patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen),-                                            Patchy p, ShowPatchBasic p,+                                            Invert p, Apply 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)+  [ ("invert rollback"          , TestCondition (const True)     , TestCheck 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+  :: forall p gen x y.+     ( Show1 gen+     , Arbitrary (Sealed gen)+     , Commute p+     , Apply p+     , ShowPatchBasic 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 )-  ]+  properties+    gen+    "patch/repo"+    genname+    [ ( "commute is effect preserving"+      , TestCondition (const True)+      , TestCheck (PropG.effectPreserving commute))+    ]  merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen)-                                      , Patchy p, MyEq p, Merge p, ShowPatchBasic p+                                      , Invert p, Eq2 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        )+  [ ("merge either way"           , TestCondition (const True)   , TestCheck PropG.mergeEitherWay      )+  , ("merge either way valid"     , TestCondition (const True)   , TestCheck Prop1.tMergeEitherWayValid)+  , ("nontrivial merge either way", TestCondition nontrivialMerge, TestCheck PropG.mergeEitherWay      )+  , ("merge commute"              , TestCondition (const True)   , TestCheck PropG.mergeCommute        )   ]  qc_V1P1 :: [Test]@@ -357,10 +363,10 @@   ] -- 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.RepoPatchV1 Prim wX wY) "tree" mergePairFromTree-    ++ merge_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "twfp" mergePairFromTWFP-    ++ commute_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "tree" commutePairFromTree-    ++ commute_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "twfp" commutePairFromTWFP -}+ {- ++ merge_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "tree" mergePairFromTree+    ++ merge_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "twfp" mergePairFromTWFP+    ++ commute_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "tree" commutePairFromTree+    ++ commute_properties (undefined :: V1.RepoPatchV1 Prim1 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 rt p -> [Test]@@ -370,16 +376,22 @@  -- | 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 rt (V1.RepoPatchV1 V1.Prim))-            , testGroup "Darcs.Patch.V2 (using Prim.V1)" $-                unit_V2P1 ++ qc_V2 (undefined :: V1.Prim wX wY) ++ qc_V2P1 ++-                general_patchTests (PatchType :: PatchType rt (RepoPatchV2 V1.Prim))-            -- , testGroup "Darcs.Patch.Prim.FileUUID" $ qc_prim (undefined :: FileUUID.Prim wX wY)-            , testGroup "Darcs.Patch.V2 (using Prim.FileUUID)" $-                qc_V2 (undefined :: FileUUID.Prim wX wY) ++-                general_patchTests (PatchType :: PatchType rt (RepoPatchV2 FileUUID.Prim))-            , Darcs.Test.Patch.Info.testSuite-            , Darcs.Test.Patch.Selection.testSuite-            ]+testSuite =+  [ testGroup "Darcs.Patch.Prim.V1 for V1" $ qc_prim (undefined :: Prim1 wX wY)+    -- testing both Prim1 and Prim2 here is redundant, since they differ+    -- only in their read/show behavior, which is not tested in qc_prim;+    -- we still include them because such tests might be added in the future+  , testGroup "Darcs.Patch.Prim.V1 for V2" $ qc_prim (undefined :: Prim2 wX wY)+  , testGroup "Darcs.Patch.Prim.FileUUID" $ qc_prim (undefined :: FileUUID.Prim wX wY)+  , testGroup "Darcs.Patch.V1 (using Prim.V1)" $+      unit_V1P1 ++ qc_V1P1 +++      general_patchTests (PatchType :: PatchType rt (V1.RepoPatchV1 Prim1))+  , testGroup "Darcs.Patch.V2 (using Prim.V1)" $+      unit_V2P1 ++ qc_V2 (undefined :: Prim2 wX wY) ++ qc_V2P1 +++      general_patchTests (PatchType :: PatchType rt (RepoPatchV2 Prim2))+  , testGroup "Darcs.Patch.V2 (using Prim.FileUUID)" $+      qc_V2 (undefined :: FileUUID.Prim wX wY) +++      general_patchTests (PatchType :: PatchType rt (RepoPatchV2 FileUUID.Prim))+  , Darcs.Test.Patch.Info.testSuite+  , Darcs.Test.Patch.Selection.testSuite+  ]

@@ -1,7 +1,5 @@-{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}-{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,+{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,              FlexibleInstances, ViewPatterns #-}- module Darcs.Test.Patch.Arbitrary.Generic        ( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim(..), NullPatch(..), RepoModel(..)        , MightBeEmptyHunk(..), MightHaveDuplicate(..)@@ -24,9 +22,9 @@ import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Invert(..), Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Prim ( PrimOf, PrimPatch, PrimPatchBase, FromPrim(..), PrimConstruct( anIdentity ) )-import Darcs.Patch.Prim.V1 () import Darcs.Patch.V2 ( RepoPatchV2 ) -- XXX this is more or less a hack --import Darcs.ColorPrinter ( errorDoc ) --import Darcs.ColorPrinter ( traceDoc )

@@ -1,8 +1,9 @@--- TODO: Remove these warning disabling flags...-{-# OPTIONS_GHC -w #-}-{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} module Darcs.Test.Patch.Arbitrary.PrimFileUUID where +import Prelude ()+import Darcs.Prelude+ import qualified Darcs.Test.Patch.Arbitrary.Generic as T      ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP      , mergePairFromTree, mergePairFromTWFP@@ -18,24 +19,20 @@ import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Prim.FileUUID ()-import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Location, Hunk(..), UUID(..) )+import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Location(..), Hunk(..), UUID(..) ) import Darcs.Patch.RepoPatch ( RepoPatch )  import Darcs.Test.Patch.FileUUIDModel-import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )+import Darcs.Test.Util.QuickCheck ( 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 qualified Data.ByteString as B import Data.Maybe ( isJust ) import qualified Data.Map as M import Darcs.Util.Hash( Hash(..) ) -#include "impossible.h"- patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t patchFromTree = T.patchFromTree @@ -59,18 +56,15 @@     runCoalesceTests _ = False     hasPrimConstruct _ = False -hunkIdentity (Hunk _ old new) | old == new = unsafeCoerceP IsEq-hunkIdentity _ = NotEq+instance MightBeEmptyHunk Prim+instance MightHaveDuplicate Prim  instance NullPatch Prim where-  nullPatch (BinaryHunk _ x) = hunkIdentity x-  nullPatch (TextHunk _ x) = hunkIdentity x+  nullPatch Identity = IsEq+  nullPatch (Hunk _ (H _ old new))+    | old == new = unsafeCoerceP IsEq   nullPatch _ = NotEq -instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) where-  arbitrary = do repo <- ourSmallRepo-                 liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo- -- instance Show1 (TreeWithFlattenPos Prim) where --   showDict1 = ShowDictClass @@ -81,93 +75,83 @@ ---------------------------------------------------------------------- -- * 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+aHunk :: B.ByteString -> Gen (Hunk wX wY)+aHunk content = do+  pos <- choose (0, B.length content)+  oldLen <- choose (0, B.length content - pos)+  new <- scale (`div` 8) aContent+  let old = B.take oldLen $ B.drop pos $ content+  return $ H pos old new -aTextHunk :: forall wX wY . (UUID, Object Fail) -> Gen (Prim wX wY)+aTextHunk :: (UUID, Object Fail) -> Gen (Prim wX wY) aTextHunk (uuid, (Blob text _)) =-  do hunk <- aHunk (unFail text)-     return $ TextHunk uuid hunk+  do h <- aHunk (unFail text)+     return $ Hunk uuid h+aTextHunk _ = impossible -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+aManifest :: UUID -> (UUID, Object Fail) -> Gen (Prim wX wY)+aManifest uuid (dirId, Directory dir) =+  do filename <- aFilename `notIn` (M.keys dir)+     return $ Manifest uuid (L dirId filename)+aManifest _ _ = impossible -aDemanifest :: forall wX wY . UUID -> Location -> Gen (Prim wX wY)+aDemanifest :: UUID -> Location -> Gen (Prim wX wY) aDemanifest uuid loc = return $ Demanifest uuid loc  -- | Generates any type of 'Prim' patch, except binary and setpref patches.-aPrim :: forall wX wY . FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (Prim wX) wY)+aPrim :: FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (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+  = do mbFile <- maybeOf repoFiles -- some file, not necessarily manifested+       dir <- elements repoDirs -- some directory, not necessarily manifested+       -- note, the root directory always exists and is never manifested nor demanifested+       mbDemanifested <- maybeOf notManifested -- something manifested+       mbManifested <- maybeOf manifested -- something not manifested+       fresh <- anUUID `notIn` repoIds repo -- a fresh uuid+       let whenjust m x = if isJust m then x else 0+           whenfile = whenjust mbFile+           whendemanifested = whenjust mbDemanifested+           whenmanifested = whenjust mbManifested        patch <- frequency-                  [ ( whenfile 12, aTextHunk $ fromJust mbFile )-                  , ( 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+                  [ ( whenfile 12, aTextHunk $ fromJust mbFile ) -- edit an existing file+                  , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- edit a new file+                  , ( whendemanifested 2 -- manifest an existing object+                    , aManifest (fromJust mbDemanifested) dir+                    )+                  , ( whenmanifested 2+                    , uncurry aDemanifest $ fromJust mbManifested+                    )                   ]        let repo' = unFail $ repoApply repo patch        return $ 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)+      manifested = [ (uuid, (L dirid name)) | (dirid, Directory dir) <- repoDirs+                                          , (name, uuid) <- M.toList dir ]+      notManifested = [ uuid | (uuid, _) <- nonRootObjects+                           , not (uuid `elem` map fst manifested) ]+      repoFiles = [ (uuid, Blob x y) | (uuid, Blob x y) <- repoObjects repo ]+      repoDirs  = [ (uuid, Directory x) | (uuid, Directory x) <- repoObjects repo ]+      nonRootObjects = filter notRoot $ repoObjects repo where+        notRoot (uuid, _) = uuid == rootId  ---------------------------------------------------------------------- -- *** Pairs of primitive patches  -- Try to generate commutable pairs of hunks-hunkPair :: forall wX wY . (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY)+hunkPair :: (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY) hunkPair (uuid, (Blob file _)) =-  do h1@(Hunk l1 old1 new1) <- aHunk (unFail file)+  do h1@(H off1 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))+     H off2' old2 new2 <- aHunk content'+     let off2 = off2' + delta+     return (Hunk uuid (H off1 old1 new1) :> Hunk uuid (H off2 old2 new2))   where-     selectChunk (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+     selectChunk (H off old new) content = elements [prefix, suffix]+       where prefix = (0, B.take off content)+             suffix = (off + B.length new, B.drop (off + B.length old) content)+hunkPair _ = impossible -aPrimPair :: forall wX wY . FileUUIDModel wX -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY)+aPrimPair :: FileUUIDModel wX+          -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY) aPrimPair repo   = do mbFile <- maybeOf repoFiles        frequency@@ -183,7 +167,7 @@             )           ]   where-      repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]+      repoFiles = [ (uuid, Blob x y) | (uuid, Blob x y) <- repoObjects repo ]  ---------------------------------------------------------------------- -- Arbitrary instances@@ -193,6 +177,11 @@  instance ArbitraryState FileUUIDModel Prim where   arbitraryState s = seal <$> aPrim s+++instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) where+  arbitrary = do repo <- ourSmallRepo+                 liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo   instance Arbitrary (Sealed2 Prim) where

@@ -1,5 +1,4 @@-{-# LANGUAGE CPP, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Darcs.Test.Patch.Arbitrary.PrimV1 where  import qualified Darcs.Test.Patch.Arbitrary.Generic as T@@ -20,39 +19,44 @@ 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.Prim.V1.Core ( FilePatchType( Hunk, TokReplace ), isIdentity )+import qualified Darcs.Patch.Prim.V1.Core as Prim ( Prim( FP ) )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.FileHunk( IsHunk( isHunk ), FileHunk(..) )  import Darcs.Test.Patch.V1Model import Darcs.Util.Path+import qualified Darcs.Util.Tree as UT ( Tree ) import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )  import Darcs.UI.Commands.Replace ( defaultToks ) import Darcs.Patch.Prim+import Darcs.Patch.Apply ( ApplyState )  import qualified Data.ByteString.Char8 as BC import Data.Maybe ( isJust ) -#include "impossible.h"+type Prim1 = V1.Prim+type Prim2 = V2.Prim -patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t+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 :: (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 :: (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 :: (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 :: (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 :: (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@@ -69,33 +73,49 @@ 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+type instance ModelOf Prim1 = V1Model+type instance ModelOf Prim2 = V1Model+instance ArbitraryPrim Prim1+instance ArbitraryPrim Prim2 -instance NullPatch Prim where-  nullPatch (FP _ fp) = nullPatch fp-  nullPatch p | IsEq <- isIdentity p = IsEq+instance NullPatch Prim2 where+  nullPatch (V2.Prim (Prim.FP _ fp)) = nullPatch fp+  nullPatch p | IsEq <- isIdentity (V2.unPrim p) = IsEq   nullPatch _ = NotEq +instance NullPatch Prim1 where+  nullPatch (V1.Prim (Prim.FP _ fp)) = nullPatch fp+  nullPatch p | IsEq <- isIdentity (V1.unPrim 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+instance MightBeEmptyHunk Prim1 where+  isEmptyHunk (V1.Prim (Prim.FP _ (Hunk _ [] []))) = True   isEmptyHunk _ = False -instance MightHaveDuplicate Prim+instance MightBeEmptyHunk Prim2 where+  isEmptyHunk (V2.Prim (Prim.FP _ (Hunk _ [] []))) = True+  isEmptyHunk _ = False -instance Arbitrary (Sealed2 (FL (WithState V1Model Prim))) where+instance MightHaveDuplicate Prim1+instance MightHaveDuplicate Prim2++instance Arbitrary (Sealed2 (FL (WithState V1Model Prim1))) where   arbitrary = do repo <- ourSmallRepo                  liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo +instance Arbitrary (Sealed2 (FL (WithState V1Model Prim2))) 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 :: Int -> Tree prim wX -> Bool propFail n xs = sizeTree xs < n  ----------------------------------------------------------------------@@ -153,21 +173,21 @@ ---------------------------------------------------------------------- -- ** Prim generators -aHunkP :: forall wX wY . (AnchoredPath,File) -> Gen (Prim wX wY)+aHunkP :: forall prim wX wY . PrimPatch prim => (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 :: forall prim wX wY . PrimPatch prim => (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 :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY) anAddFileP (path,dir)   = do newFilename <- aFilename `notIn` existing        let newPath = path `appendPath` newFilename@@ -175,11 +195,11 @@   where       existing = map fst $ filterFiles $ dirContent dir -aRmFileP :: forall wX wY . AnchoredPath   -- ^ Path of an empty file-                          -> Prim wX wY+aRmFileP :: forall prim wX wY . PrimPatch prim => 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 :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY) anAddDirP (path,dir)   = do newDirname <- aDirname `notIn` existing        let newPath = path `appendPath` newDirname@@ -187,11 +207,11 @@   where       existing = map fst $ filterDirs $ dirContent dir -aRmDirP :: forall wX wY . AnchoredPath    -- ^ Path of an empty directory-                        -> Prim wX wY+aRmDirP :: forall prim wX wY . PrimPatch prim => 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 :: forall prim wX wY . PrimPatch prim => Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (prim wX wY) aMoveP nameGen oldPath (dirPath,dir)   = do newName <- nameGen `notIn` existing        let newPath = dirPath `appendPath` newName@@ -199,8 +219,9 @@   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)+-- | Generates any type of 'prim' patch, except binary and setpref patches.+aPrim :: forall prim wX wY . (PrimPatch prim, ApplyState prim ~ RepoState V1Model)+      => V1Model wX -> Gen (WithEndState V1Model (prim wX) wY) aPrim repo   = do mbFile <- maybeOf repoFiles        mbEmptyFile <- maybeOf $ filter (isEmpty . snd) repoFiles@@ -266,7 +287,7 @@ -- *** Pairs of primitive patches  -- Try to generate commutable pairs of hunks-hunkPairP :: forall wX wY . (AnchoredPath,File) -> Gen ((Prim :> Prim) wX wY)+hunkPairP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen ((prim :> prim) wX wY) hunkPairP (path,file)   = do h1@(Hunk l1 old1 new1) <- aHunk content        (delta, content') <- selectChunk h1 content@@ -284,7 +305,7 @@             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 :: forall prim wX wY . (PrimPatch prim, ArbitraryState V1Model prim, ApplyState prim ~ RepoState V1Model) => V1Model wX -> Gen (WithEndState V1Model ((prim :> prim) wX) wY) aPrimPair repo   = do mbFile <- maybeOf repoFiles        frequency@@ -337,66 +358,143 @@ ourSmallRepo :: Gen (V1Model wX) ourSmallRepo = aSmallRepo -instance ArbitraryState V1Model Prim where+instance ArbitraryState V1Model Prim1 where   arbitraryState s = seal <$> aPrim s +instance ArbitraryState V1Model Prim2 where+  arbitraryState s = seal <$> aPrim s -instance Arbitrary (Sealed2 Prim) where++instance Arbitrary (Sealed (Prim1 wA)) where+  arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed (Prim2 wA)) where+  arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 Prim1) where   arbitrary = makeS2Gen ourSmallRepo -instance Arbitrary (Sealed2 (Prim :> Prim)) where+instance Arbitrary (Sealed2 Prim2) where+  arbitrary = makeS2Gen ourSmallRepo++arbitrarySeal2 :: (PrimPatch prim, ApplyState prim ~ UT.Tree,+                   ArbitraryState V1Model prim)+               => Gen (Sealed2 (prim :> prim))+arbitrarySeal2 = do+  repo <- ourSmallRepo+  WithEndState pp _ <- aPrimPair repo+  return $ seal2 pp++arbitrarySeal :: (PrimPatch prim, ApplyState prim ~ UT.Tree,+                  ArbitraryState V1Model prim)+              => Gen (Sealed ((:>) prim prim wX))+arbitrarySeal = do+  repo <- ourSmallRepo+  WithEndState pp _ <- aPrimPair repo+  return $ seal pp++instance Arbitrary (Sealed2 (Prim1 :> Prim1)) where+  arbitrary = arbitrarySeal2++instance Arbitrary (Sealed2 (Prim2 :> Prim2)) where+  arbitrary = arbitrarySeal2++instance Arbitrary (Sealed ((Prim1 :> Prim1) wA)) where+  arbitrary = arbitrarySeal++instance Arbitrary (Sealed ((Prim2 :> Prim2) wA)) where+  arbitrary = arbitrarySeal++instance Arbitrary (Sealed2 (Prim1 :> Prim1 :> Prim1)) where+  arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((Prim1 :> Prim1 :> Prim1) a)) where+  arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (FL Prim1)) where+  arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((FL Prim1) wA)) where+  arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (FL Prim1 :> FL Prim1)) where+  arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((FL Prim1 :> FL Prim1) wA)) where+  arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V1Model Prim1)) where+  arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed (WithState V1Model Prim1 wA)) where+  arbitrary = makeWSGen ourSmallRepo++instance Arbitrary (Sealed (WithState V1Model (FL Prim1) wA)) where+  arbitrary = makeWSGen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V1Model (Prim1 :> Prim1))) where   arbitrary = do repo <- ourSmallRepo-                 WithEndState pp _ <- aPrimPair repo-                 return $ seal2 pp+                 WithEndState pp repo' <- aPrimPair repo+                 return $ seal2 $ WithState repo pp repo' -instance Arbitrary (Sealed ((Prim :> Prim) wA)) where+instance Arbitrary (Sealed (WithState V1Model (Prim1 :> Prim1) a)) where   arbitrary = do repo <- ourSmallRepo-                 WithEndState pp _ <- aPrimPair repo-                 return $ seal pp+                 WithEndState pp repo' <- aPrimPair repo+                 return $ seal $ WithState repo pp repo' -instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where++instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1))) where+  arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1 :> FL Prim1))) where+  arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed (WithState V1Model (FL Prim1 :> FL Prim1) a)) where+  arbitrary = makeWSGen ourSmallRepo++instance Arbitrary (Sealed2 (Prim2 :> Prim2 :> Prim2)) where   arbitrary = makeS2Gen ourSmallRepo -instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where+instance Arbitrary (Sealed ((Prim2 :> Prim2 :> Prim2) a)) where   arbitrary = makeSGen ourSmallRepo -instance Arbitrary (Sealed2 (FL Prim)) where+instance Arbitrary (Sealed2 (FL Prim2)) where   arbitrary = makeS2Gen ourSmallRepo -instance Arbitrary (Sealed ((FL Prim) wA)) where+instance Arbitrary (Sealed ((FL Prim2) wA)) where   arbitrary = makeSGen ourSmallRepo -instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where+instance Arbitrary (Sealed2 (FL Prim2 :> FL Prim2)) where   arbitrary = makeS2Gen ourSmallRepo -instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where+instance Arbitrary (Sealed ((FL Prim2 :> FL Prim2) wA)) where   arbitrary = makeSGen ourSmallRepo -instance Arbitrary (Sealed2 (WithState V1Model Prim)) where+instance Arbitrary (Sealed2 (WithState V1Model Prim2)) where   arbitrary = makeWS2Gen ourSmallRepo -instance Arbitrary (Sealed (WithState V1Model Prim wA)) where+instance Arbitrary (Sealed (WithState V1Model Prim2 wA)) where   arbitrary = makeWSGen ourSmallRepo -instance Arbitrary (Sealed (WithState V1Model (FL Prim) wA)) where+instance Arbitrary (Sealed (WithState V1Model (FL Prim2) wA)) where   arbitrary = makeWSGen ourSmallRepo -instance Arbitrary (Sealed2 (WithState V1Model (Prim :> Prim))) where+instance Arbitrary (Sealed2 (WithState V1Model (Prim2 :> Prim2))) 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+instance Arbitrary (Sealed (WithState V1Model (Prim2 :> Prim2) 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+instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2))) where   arbitrary = makeWS2Gen ourSmallRepo -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim :> FL Prim))) where+instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2 :> FL Prim2))) where   arbitrary = makeWS2Gen ourSmallRepo -instance Arbitrary (Sealed (WithState V1Model (FL Prim :> FL Prim) a)) where+instance Arbitrary (Sealed (WithState V1Model (FL Prim2 :> FL Prim2) a)) where   arbitrary = makeWSGen ourSmallRepo

@@ -15,20 +15,16 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}-+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}  module Darcs.Test.Patch.Arbitrary.RepoPatchV1 () where  import Prelude () import Darcs.Prelude -import System.IO.Unsafe ( unsafePerformIO ) import Test.QuickCheck 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 ) @@ -36,8 +32,8 @@                      hunk, tokreplace, binary,                      changepref, invert, merge ) import Darcs.Patch.V1 ()-import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(..) )-import Darcs.Patch.Prim.V1 ()+import Darcs.Patch.V1.Core ( RepoPatchV1(..) )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(..) ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) )@@ -49,9 +45,10 @@ import Darcs.Test.Patch.Properties.Check( checkAPatch ) import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate ) -#include "impossible.h"+type Patch = RepoPatchV1 V1.Prim -type Patch = V1.RepoPatchV1 Prim+pp :: Prim wX wY -> Patch wX wY+pp = PP . V1.Prim  class ArbitraryP p where     arbitraryP :: Gen (Sealed (p wX))@@ -112,7 +109,7 @@ instance ArbitraryP Prim where     arbitraryP = onepatchgen -instance MightHaveDuplicate (V1.RepoPatchV1 prim)+instance MightHaveDuplicate (RepoPatchV1 prim)  hunkgen :: Gen (Sealed (Prim wX)) hunkgen = do@@ -165,25 +162,18 @@ 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]+norecursgen 0 = mapSeal (\p -> pp p :>: NilFL) `fmap` onepatchgen+norecursgen n = oneof [mapSeal (\p -> 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),+arbpatch 0 = mapSeal (\p -> pp p :>: NilFL) `fmap` onepatchgen+arbpatch n = frequency [(3,mapSeal (\p -> pp p :>: NilFL) `fmap` onepatchgen),                         (2,flatcompgen n),                         (0,rawMergeGen n),                         (0,mergegen n),-                        (1,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen)+                        (1,mapSeal (\p -> 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@@ -208,16 +198,6 @@      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 @@ -225,7 +205,7 @@ flatlistgen 0 = return $ Sealed NilFL flatlistgen n = do Sealed x <- onepatchgen                    Sealed xs <- flatlistgen (n-1)-                   return (Sealed (V1.PP x :>: xs))+                   return (Sealed (pp x :>: xs))  flatcompgen :: Int -> Gen (Sealed (FL Patch wX)) flatcompgen n = do

@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} module Darcs.Test.Patch.Arbitrary.RepoPatchV2 where import Darcs.Test.Patch.Arbitrary.Generic@@ -7,7 +6,7 @@  import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Patchy, Commute(..) )+import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Prim ( PrimPatch, anIdentity ) import Darcs.Patch.V2 ( RepoPatchV2 ) import Darcs.Patch.V2.RepoPatch ( isDuplicate )@@ -22,7 +21,7 @@ nontrivialRepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool nontrivialRepoPatchV2s = nontrivialCommute -nontrivialCommute :: (Patchy p, MyEq p) => (p :> p) wX wY -> Bool+nontrivialCommute :: (Commute p, Eq2 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)@@ -31,7 +30,7 @@ nontrivialMergerepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :\/: RepoPatchV2 prim) wX wY -> Bool nontrivialMergerepoPatchV2s = nontrivialMerge -nontrivialMerge :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> Bool+nontrivialMerge :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool nontrivialMerge (x :\/: y) = case merge (x :\/: y) of                               y' :/\: x' -> not (y' `unsafeCompare` y) ||                                             not (x' `unsafeCompare` x)

@@ -15,7 +15,6 @@ -- 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,@@ -23,6 +22,9 @@                                 checkMove, modifyFile, FileContents(..)                               ) where +import Prelude ()+import Darcs.Prelude+ import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString as B (ByteString) import Data.List ( isPrefixOf, inits )@@ -32,8 +34,6 @@ 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

@@ -15,9 +15,6 @@ --  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@@ -25,6 +22,8 @@        , primitiveTestPatches, testPatches, testPatchesNamed        , primitiveCommutePairs ) where +import Prelude ()+import Darcs.Prelude import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString.Char8 as BC ( pack ) import qualified Data.ByteString as B ( empty )@@ -34,16 +33,14 @@      , 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 ( RepoPatchV1 )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) 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.RepoPatchV1 Prim+type Patch = V1.RepoPatchV1 V1.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@@ -86,7 +83,7 @@      (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 :: (FromPrim p, PrimOf p ~ V1.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) 

@@ -15,10 +15,6 @@ -- 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@@ -30,11 +26,9 @@ 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.Invert ( Invert(..) )+import Darcs.Patch.Prim ( PrimPatch, fromPrim ) import Darcs.Patch.V2 ( RepoPatchV2 )-import Darcs.Patch.V2.RepoPatch ( prim2repopatchV2 ) -- import Darcs.Test.Patch.Test () -- for instance Eq Patch -- import Darcs.Test.Patch.Examples.Set2Unwitnessed import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )@@ -45,14 +39,14 @@ import Darcs.Util.Printer.Color () -- for instance Show Doc import Darcs.Test.Patch.WSub + import qualified Darcs.Patch.Witnesses.Ordered as W ( (:>), (:\/:) ) import qualified Data.ByteString as B ( ByteString ) import Darcs.Test.Patch.V1Model ( V1Model, Content                                 , makeRepo, makeFile) import Darcs.Test.Patch.WithState ( WithStartState(..) )-import Darcs.Patch.Prim.V1.Core ( Prim(FP), FilePatchType(Hunk) )-import Darcs.Util.Path ( FileName, fp2fn, makeName )-import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim )+import Darcs.Util.Path ( makeName )+import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim, PrimConstruct(..) ) import Darcs.Patch.Merge ( Merge ) import Darcs.Test.Patch.Arbitrary.Generic     ( Tree(..)@@ -63,209 +57,210 @@     )  -- import Debug.Trace--- #include "impossible.h" +type Patch = RepoPatchV2 Prim2+ 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 :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [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))+                    (SeqTree (hunk "file" 1 [] [BC.pack "g"])+                     (SeqTree (hunk "file" 2 [] [BC.pack "j"])+                      (SeqTree (hunk "file" 1 [] [BC.pack "s"]) NilTree)))+                    (SeqTree (hunk "file" 1 [] [BC.pack "e"]) NilTree))                   ,commuteTripleFromTree seal2 $                    WithStartState (makeSimpleRepo "file" [BC.pack "j"])                    (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"]))+                    (SeqTree (hunk "file" 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))+                      (SeqTree (hunk "file" 2 [BC.pack "j"] []) NilTree)+                      (SeqTree (hunk "file" 2 [BC.pack "j"] []) NilTree)))+                    (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree))                   ]  -w_mergeExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:\/: p)]+w_mergeExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [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 :: (FromPrim p, Merge p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [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)))))),+                     (SeqTree (hunk "file" 1 [] [BC.pack "h"]) NilTree)+                     (SeqTree (hunk "file" 1 [] [BC.pack "b"])+                       (SeqTree (hunk "file" 1 [] [BC.pack "f"])+                         (SeqTree (hunk "file" 1 [] [BC.pack "v"])+                           (SeqTree (hunk "file" 2 [BC.pack "f"] []) NilTree)))))),                    commutePairFromTWFP seal2 $                    WithStartState                    (makeSimpleRepo "file" [BC.pack "f",BC.pack "s",BC.pack "d"])                    (TWFP 3                     (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "d"] [])) NilTree)+                     (SeqTree (hunk "file" 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)))))),+                      (SeqTree (hunk "file" 1 [BC.pack "f"] []) NilTree)+                      (SeqTree (hunk "file" 1 [BC.pack "f"] [])+                        (SeqTree (hunk "file" 1 [BC.pack "s",BC.pack "d"] [])+                          (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)))))), {-                   commutePairFromTWFP seal2 $                    WithStartState                    (makeSimpleRepo "file" [BC.pack "f",BC.pack "u",                                             BC.pack "s",BC.pack "d"])                    (TWFP 5                     (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 5 [] [BC.pack "x"]))-                      (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "d"] [])) NilTree))+                     (SeqTree (hunk "file" 5 [] [BC.pack "x"])+                      (SeqTree (hunk "file" 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))))))),-}+                      (SeqTree (hunk "file" 1 [BC.pack "f",BC.pack "u"] []) NilTree)+                      (SeqTree (hunk "file" 1 [BC.pack "f"] [])+                       (SeqTree (hunk "file" 1 [BC.pack "u",BC.pack "s",BC.pack "d"] [])+                        (SeqTree (hunk "file" 1 [] [BC.pack "a"])+                         (SeqTree (hunk "file" 1 [BC.pack "a"] []) NilTree))))))),-}                    commutePairFromTree seal2 $                    WithStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])                    (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n",BC.pack "t",BC.pack "h"] []))+                    (SeqTree (hunk "file" 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)))),+                    (SeqTree (hunk "file" 3 [BC.pack "h"] [])+                     (SeqTree (hunk "file" 1 [BC.pack "n"] [])+                      (SeqTree (hunk "file" 1 [BC.pack "t"] []) NilTree)))),                   commutePairFromTree seal2 $                   WithStartState (makeSimpleRepo "file" [])                   (ParTree-                   (SeqTree (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))),+                   (SeqTree (hunk "file" 1 [] [BC.pack "n"]) NilTree)+                   (SeqTree (hunk "file" 1 [] [BC.pack "i"])+                                (SeqTree (hunk "file" 1 [] [BC.pack "i"]) NilTree))),                   commutePairFromTree seal2 $                   WithStartState (makeSimpleRepo "file" [])                   (ParTree-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"]))+                   (SeqTree (hunk "file" 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)),+                       (SeqTree (hunk "file" 1 [BC.pack "c"] [BC.pack "r"]) NilTree)+                       (SeqTree (hunk "file" 1 [] [BC.pack "h"])+                        (SeqTree (hunk "file" 1 [] [BC.pack "d"]) NilTree))))+                   (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree)),                   commutePairFromTWFP seal2 $                   WithStartState (makeSimpleRepo "file" [])                   (TWFP 1                   (ParTree                    (ParTree-                    (SeqTree (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))),+                    (SeqTree (hunk "file" 1 [] [BC.pack "t"]) NilTree)+                    (SeqTree (hunk "file" 1 [] [BC.pack "t"]) NilTree))+                   (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree))),                    commutePairFromTWFP seal2 $                    WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",                                                             BC.pack "c",BC.pack "v"])                    (TWFP 4                     (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c",BC.pack "v"] []))+                     (SeqTree (hunk "file" 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))),+                         (SeqTree (hunk "file" 2 [BC.pack "r"] [])+                          (SeqTree (hunk "fi le" 1 [BC.pack "f"] []) NilTree))+                         (SeqTree (hunk "file" 1 [BC.pack "f",BC.pack "r"] [])+                          (SeqTree (hunk "file" 1 [] [BC.pack "y"]) NilTree))))+                     (SeqTree (hunk "file" 4 [BC.pack "v"] []) NilTree))),                    commutePairFromTree seal2 $                    WithStartState (makeSimpleRepo "file" [])                    (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree)+                    (SeqTree (hunk "file" 1 [] [BC.pack "z"]) NilTree)                     (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree)+                     (SeqTree (hunk "file" 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))))+                      (SeqTree (hunk "file" 1 [] [BC.pack "r"]) NilTree)+                      (SeqTree (hunk "file" 1 [] [BC.pack "d"]) NilTree))))                  , commutePairFromTree seal2 $                    WithStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])                    (ParTree                     (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t",BC.pack "r",BC.pack "h"] []))+                     (SeqTree (hunk "file" 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)))+                     (SeqTree (hunk "file" 1 [] [BC.pack "o"]) NilTree))+                    (SeqTree (hunk "file" 1 [BC.pack "t"] [])+                     (SeqTree (hunk "file" 2 [BC.pack "h"] []) NilTree)))                  , commutePairFromTWFP seal2 $                    WithStartState (makeSimpleRepo "file" []) $                    TWFP 2                    (ParTree-                    (SeqTree (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))))+                    (SeqTree (hunk "file" 1 [] [BC.pack "h"]) NilTree)+                    (SeqTree (hunk "file" 1 [] [BC.pack "y"])+                     (SeqTree (hunk "file" 2 [] [BC.pack "m"])+                      (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree))))                  , commutePairFromTree seal2 $                  WithStartState (makeSimpleRepo "file" [])                  (ParTree-                  (SeqTree (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))+                  (SeqTree (hunk "file" 1 [] [BC.pack "p"])+                   (SeqTree (hunk "file" 1 [BC.pack "p"] [])+                    (SeqTree (hunk "file" 1 [] [BC.pack "c"]) NilTree)))+                  (SeqTree (hunk "file" 1 [] [BC.pack "z"]) NilTree))                  , commutePairFromTree seal2 $                  WithStartState (makeSimpleRepo "file" [])                  (ParTree-                  (SeqTree (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))+                  (SeqTree (hunk "file" 1 [] [BC.pack "j" ])+                   (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree))+                  (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree))                  , commutePairFromTree seal2 $                  WithStartState (makeSimpleRepo "file" [])                  (ParTree-                  (SeqTree (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)))+                  (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)+                  (SeqTree (hunk "file" 1 [] [BC.pack "j" ])+                   (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree)))                  , commutePairFromTree seal2 $                  WithStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])                  (ParTree-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"]))+                  (SeqTree (hunk "file" 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))+                    (SeqTree (hunk "file" 3 [BC.pack "c"] []) NilTree)+                    (SeqTree (hunk "file" 2 [BC.pack "x"] [])+                     (SeqTree (hunk "file" 1 [] [BC.pack "j"]) NilTree))))+                  (SeqTree (hunk "file" 1 [] [BC.pack "l"]) NilTree))                  , commutePairFromTree seal2 $                  WithStartState (makeSimpleRepo "file" [])                  (ParTree-                  (SeqTree (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)))))+                  (SeqTree (hunk "file" 1 [] (packStringLetters "s")) NilTree)+                  (SeqTree (hunk "file" 1 [] (packStringLetters "k"))+                   (SeqTree (hunk "file" 1 (packStringLetters "k") [])+                    (SeqTree (hunk "file" 1 [] (packStringLetters "m"))+                     (SeqTree (hunk "file" 1 (packStringLetters "m") []) NilTree)))))                  ]  packStringLetters :: String -> [B.ByteString] packStringLetters = map (BC.pack . (:[])) -w_repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))]+w_repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim2))] w_repov2PatchLoopExamples =-    [Sealed (WithStartState (makeSimpleRepo fx_name [])+    [Sealed (WithStartState (makeSimpleRepo fx [])      $ canonizeTree      (ParTree-      (SeqTree (FP fx (Hunk 1 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd")))+      (SeqTree (hunk fx 1 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd"))        (ParTree-        (SeqTree (FP fx (Hunk 47 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh")))+        (SeqTree (hunk fx 47 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh"))          (ParTree           (ParTree            NilTree            (ParTree             (ParTree              (ParTree-              (SeqTree (FP fx (Hunk 15 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps")))+              (SeqTree (hunk fx 15 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps"))                (ParTree                 NilTree                 (ParTree-                 (SeqTree (FP fx (Hunk 40 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro")))+                 (SeqTree (hunk fx 40 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro"))                   (ParTree                    (ParTree-                    (SeqTree (FP fx (Hunk 12 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg"))) NilTree)+                    (SeqTree (hunk fx 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")))+                 (SeqTree (hunk fx 25 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe")) NilTree))))+              (SeqTree (hunk fx 56 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq")) NilTree))+             (SeqTree (hunk fx 20 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx"))+              (SeqTree (hunk fx 26 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe"))+               (SeqTree (hunk fx 39 [] (packStringLetters "ji"))                 (ParTree                  NilTree                  (ParTree@@ -273,14 +268,14 @@                   (ParTree                    (ParTree                     NilTree-                    (SeqTree (FP fx (Hunk 26 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj")))-                     (SeqTree (FP fx (Hunk 39 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp"))) NilTree)))+                    (SeqTree (hunk fx 26 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj"))+                     (SeqTree (hunk fx 39 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp")) NilTree)))                    (ParTree                     NilTree-                    (SeqTree (FP fx (Hunk 44 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy")))+                    (SeqTree (hunk fx 44 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy"))                      (ParTree                       NilTree-                      (SeqTree (FP fx (Hunk 64 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp"))) NilTree)))))))))))+                      (SeqTree (hunk fx 64 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp")) NilTree)))))))))))             (ParTree              NilTree              NilTree)))@@ -288,46 +283,42 @@         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")))+       (SeqTree (hunk fx 1 [] (packStringLetters "ti"))+        (SeqTree (hunk fx 1 (packStringLetters "t") (packStringLetters "ybcop"))+         (SeqTree (hunk fx 2 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf"))+          (SeqTree (hunk fx 15 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc"))+           (SeqTree (hunk fx 51 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw"))             (ParTree              NilTree              NilTree)))))))))]   where-      fx_name :: String-      fx_name = "F"--      fx :: FileName-      fx = fp2fn "./F"-+      fx :: String+      fx = "F" -mergeExamples :: [Sealed2 (RepoPatchV2 Prim :\/: RepoPatchV2 Prim)]+mergeExamples :: [Sealed2 (Patch :\/: Patch)] mergeExamples = map (mapSeal2 fromW) w_mergeExamples -repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))]+repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim2))] repov2PatchLoopExamples = w_repov2PatchLoopExamples -commuteExamples :: [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim)]+commuteExamples :: [Sealed2 (Patch :> Patch)] commuteExamples = map (mapSeal2 fromW) w_commuteExamples -tripleExamples :: [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim)]+tripleExamples :: [Sealed2 (Patch :> Patch :> Patch)] tripleExamples = map (mapSeal2 fromW) w_tripleExamples -notDuplicatestriple :: (RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY -> Bool+notDuplicatestriple :: (Patch :> Patch :> Patch) wX wY -> Bool notDuplicatestriple = W.notDuplicatestriple . toW  quickhunk :: PrimPatch prim => Int -> String -> String -> prim wX wY quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o)                                 (map (\c -> BC.pack [c]) n) -primPermutables :: [(Prim :> Prim :> Prim) wX wY]+primPermutables :: [(Prim2 :> Prim2 :> Prim2) wX wY] primPermutables =     [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"] -mergeables :: [(Prim :\/: Prim) wX wY]+mergeables :: [(Prim2 :\/: Prim2) wX wY] mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c",               quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c",               quickhunk 0 "" "a" :\/: quickhunk 1 "" "b",@@ -336,7 +327,7 @@               quickhunk 0 "" "a" :\/: quickhunk 1 "b" ""              ] -mergeablesFL :: [(FL Prim :\/: FL Prim) wX wY]+mergeablesFL :: [(FL Prim2 :\/: FL Prim2) wX wY] mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables ++            [] --    [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL)               --  :\/: (quickhunk 1 "a" "z" :>: NilFL),@@ -346,50 +337,50 @@ 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 :: [(FL Prim2 :> FL Prim2) wX wY] commutablesFL = map mergeable2commutable mergeablesFL-commutables :: [(Prim :> Prim) wX wY]+commutables :: [(Prim2 :> Prim2) wX wY] commutables = map mergeable2commutable mergeables -primPatches :: [Prim wX wY]+primPatches :: [Prim2 wX wY] primPatches = concatMap mergeable2patches mergeables     where mergeable2patches (x:\/:y) = [x,y] -repov2Patches :: [RepoPatchV2 Prim wX wY]+repov2Patches :: [Patch wX wY] repov2Patches = concatMap commutable2patches repov2Commutables     where commutable2patches (x:>y) = [x,y] -repov2Triples :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY]+repov2Triples :: [(Patch :> Patch :> Patch) wX wY] repov2Triples = [ob' :> oa2 :> a2'',                  oa' :> oa2 :> a2'']                ++ map unsafeUnseal2 tripleExamples                ++ map unsafeUnseal2 (concatMap getTriples repov2FLs)-    where oa = prim2repopatchV2 $ quickhunk 1 "o" "aa"+    where oa = fromPrim $ quickhunk 1 "o" "aa"           oa2 = oa-          a2 = prim2repopatchV2 $ quickhunk 2 "a34" "2xx"-          ob = prim2repopatchV2 $ quickhunk 1 "o" "bb"+          a2 = fromPrim $ quickhunk 2 "a34" "2xx"+          ob = fromPrim $ quickhunk 1 "o" "bb"           ob' :/\: oa' = merge (oa :\/: ob)           a2' :/\: _ = merge (ob' :\/: a2)           a2'' :/\: _ = merge (oa2 :\/: a2') -repov2NonduplicateTriples :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY]+repov2NonduplicateTriples :: [(Patch :> Patch :> Patch) wX wY] repov2NonduplicateTriples = filter (notDuplicatestriple) repov2Triples -repov2FLs :: [FL (RepoPatchV2 Prim) wX wY]+repov2FLs :: [FL (Patch) wX wY] repov2FLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]-    where oa = prim2repopatchV2 $ quickhunk 1 "o" "a"+    where oa = fromPrim $ quickhunk 1 "o" "a"           ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL) -repov2Commutables :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY]+repov2Commutables :: [(Patch :> Patch) wX wY] repov2Commutables = map unsafeUnseal2 commuteExamples++                      map mergeable2commutable repov2Mergeables++                      [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs repov2FLs)-    where oa = prim2repopatchV2 $ quickhunk 1 "o" "a"-          ob = prim2repopatchV2 $ quickhunk 1 "o" "b"+    where oa = fromPrim $ quickhunk 1 "o" "a"+          ob = fromPrim $ quickhunk 1 "o" "b"           _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL) -repov2Mergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY]-repov2Mergeables = map (\ (x :\/: y) -> prim2repopatchV2 x :\/: prim2repopatchV2 y) mergeables+repov2Mergeables :: [(Patch :\/: Patch) wX wY]+repov2Mergeables = map (\ (x :\/: y) -> fromPrim x :\/: fromPrim y) mergeables                         ++ repov2IglooMergeables                         ++ repov2QuickcheckMergeables                         ++ map unsafeUnseal2 mergeExamples@@ -410,16 +401,16 @@                             (ob'' :\/: og''),                             (ob'' :\/: oc''),                             (oc' :\/: od'')]-    where oa = prim2repopatchV2 $ quickhunk 1 "o" "aa"-          a2 = prim2repopatchV2 $ quickhunk 2 "a34" "2xx"-          og = prim2repopatchV2 $ quickhunk 3 "4" "g"-          ob = prim2repopatchV2 $ quickhunk 1 "o" "bb"-          b2 = prim2repopatchV2 $ quickhunk 2 "b" "2"-          oc = prim2repopatchV2 $ quickhunk 1 "o" "cc"-          od = prim2repopatchV2 $ quickhunk 7 "x" "d"-          oe = prim2repopatchV2 $ quickhunk 7 "x" "e"-          pf = prim2repopatchV2 $ quickhunk 7 "x" "f"-          od'' = prim2repopatchV2 $ quickhunk 8 "x" "d"+    where oa = fromPrim $ quickhunk 1 "o" "aa"+          a2 = fromPrim $ quickhunk 2 "a34" "2xx"+          og = fromPrim $ quickhunk 3 "4" "g"+          ob = fromPrim $ quickhunk 1 "o" "bb"+          b2 = fromPrim $ quickhunk 2 "b" "2"+          oc = fromPrim $ quickhunk 1 "o" "cc"+          od = fromPrim $ quickhunk 7 "x" "d"+          oe = fromPrim $ quickhunk 7 "x" "e"+          pf = fromPrim $ quickhunk 7 "x" "f"+          od'' = fromPrim $ quickhunk 8 "x" "d"           ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)           a2' :/\: _ = merge (ob' :\/: a2)           ob'' :/\: _ = merge (a2 :\/: ob')@@ -431,12 +422,12 @@           oc''' :/\: _ = merge (ob' :\/: oc')           oe' :/\: _ = merge (od :\/: oe)           of' :/\: _ = merge (od :\/: pf)-          pair2m :: Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim)-                 -> Maybe ((RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY)+          pair2m :: Sealed2 (Patch :> Patch)+                 -> Maybe ((Patch :\/: Patch) wX wY)           pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)                                           return $ unsafeCoerceP (xx :\/: y') -repov2IglooMergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY]+repov2IglooMergeables :: [(Patch :\/: Patch) wX wY] repov2IglooMergeables = [(a :\/: b),                     (b :\/: c),                     (a :\/: c),@@ -447,17 +438,17 @@                     (z' :\/: y'),                     (x' :\/: z'),                     (a :\/: a)]-    where a = prim2repopatchV2 $ quickhunk 1 "1" "A"-          b = prim2repopatchV2 $ quickhunk 2 "2" "B"-          c = prim2repopatchV2 $ quickhunk 3 "3" "C"-          x = prim2repopatchV2 $ quickhunk 1 "1BC" "xbc"-          y = prim2repopatchV2 $ quickhunk 1 "A2C" "ayc"-          z = prim2repopatchV2 $ quickhunk 1 "AB3" "abz"+    where a = fromPrim $ quickhunk 1 "1" "A"+          b = fromPrim $ quickhunk 2 "2" "B"+          c = fromPrim $ quickhunk 3 "3" "C"+          x = fromPrim $ quickhunk 1 "1BC" "xbc"+          y = fromPrim $ quickhunk 1 "A2C" "ayc"+          z = fromPrim $ quickhunk 1 "AB3" "abz"           x' :/\: _ = merge (a :\/: x)           y' :/\: _ = merge (b :\/: y)           z' :/\: _ = merge (c :\/: z) -repov2QuickcheckMergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY]+repov2QuickcheckMergeables :: [(Patch :\/: Patch) wX wY] repov2QuickcheckMergeables = [-- invert k1 :\/: n1                              --, invert k2 :\/: n2                                hb :\/: k@@ -467,25 +458,25 @@                              , k' :\/: k'                              , k3 :\/: k3                              ] ++ catMaybes (map pair2m pairs)-    where hb = prim2repopatchV2 $ quickhunk 0 "" "hb"-          k = prim2repopatchV2 $ quickhunk 0 "" "k"-          n = prim2repopatchV2 $ quickhunk 0 "" "n"-          b = prim2repopatchV2 $ quickhunk 1 "b" ""-          d = prim2repopatchV2 $ quickhunk 2 "" "d"+    where hb = fromPrim $ quickhunk 0 "" "hb"+          k = fromPrim $ quickhunk 0 "" "k"+          n = fromPrim $ quickhunk 0 "" "n"+          b = fromPrim $ quickhunk 1 "b" ""+          d = fromPrim $ 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 (RepoPatchV2 Prim :> RepoPatchV2 Prim)-                 -> Maybe ((RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY)+          pair2m :: Sealed2 (Patch :> Patch)+                 -> Maybe ((Patch :\/: Patch) wX wY)           pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)                                           return $ unsafeCoerceP (xx :\/: y') -          i = prim2repopatchV2 $ quickhunk 0 "" "i"-          x = prim2repopatchV2 $ quickhunk 0 "" "x"-          xi = prim2repopatchV2 $ quickhunk 0 "xi" ""+          i = fromPrim $ quickhunk 0 "" "i"+          x = fromPrim $ quickhunk 0 "" "x"+          xi = fromPrim $ quickhunk 0 "xi" ""           d3 :/\: _ = merge (xi :\/: d)           _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL) 

@@ -1,6 +1,4 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports -fno-warn-orphans #-}-{-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-}-+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-}  -- | Repository model module Darcs.Test.Patch.FileUUIDModel@@ -10,8 +8,8 @@   , emptyFile   , emptyDir   , nullRepo-  , isEmpty-  , root, repoObjects+  , root, rootId+  , repoObjects, repoIds   , aFilename, aDirname   , aLine, aContent   , aFile, aDir@@ -20,41 +18,34 @@   ) where  +import Prelude ()+import Darcs.Prelude+ 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.FileUUID.Core( UUID(..), Hunk(..), Prim(..), Object(..) )+import Darcs.Patch.Apply( applyToState )+import Darcs.Patch.Prim.FileUUID.Core( UUID(..), Object(..) ) import Darcs.Patch.Prim.FileUUID.Apply( ObjectMap(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) import Darcs.Patch.Witnesses.Show -import Darcs.Util.Path-import Darcs.Util.Tree( Tree, TreeItem )-import qualified Darcs.Util.Tree as T+import Darcs.Util.Path ( Name, unsafeMakeName ) import Darcs.Util.Hash( Hash(..) )-import Darcs.Util.Tree.Hashed ( darcsUpdateHashes )  import Control.Applicative ( (<$>) )-import Control.Arrow ( second )-import qualified Data.ByteString as BS+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, sort ) import qualified Data.Map as M import Test.QuickCheck   ( Arbitrary(..)   , Gen, choose, vectorOf, frequency, oneof )--#include "impossible.h"-+-- import Text.Show.Pretty ( ppShow )  ---------------------------------------------------------------------- -- * Model definition -newtype FileUUIDModel wX = FileUUIDModel { repoMap :: ObjectMap Fail }+newtype FileUUIDModel wX = FileUUIDModel { _repoMap :: ObjectMap Fail }  ---------------------------------------- -- Instances@@ -65,8 +56,8 @@  deriving instance Eq (Object Fail) -instance Show (FileUUIDModel x) where-  show = showModel+instance Show (FileUUIDModel wX) where+  show repo = "FileUUIDModel " ++ show (repoObjects repo)  instance Show1 FileUUIDModel where   showDict1 = ShowDictClass@@ -75,16 +66,18 @@ -- * 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+objectMap m = ObjectMap { getObject = get, putObject = put, listObjects = list }+  where list = return $ M.keys m+        put k o = return $ objectMap (M.insert k o m)+        get k = return $ M.lookup k m +{- emptyRepo :: FileUUIDModel wX-emptyRepo = FileUUIDModel (objectMap M.empty)+emptyRepo = FileUUIDModel (objectMap $ M.singleton rootId emptyDir)+-}  emptyFile :: (Monad m) => Object m-emptyFile = Blob (return BS.empty) NoHash+emptyFile = Blob (return B.empty) NoHash  emptyDir :: Object m emptyDir = Directory M.empty@@ -93,22 +86,32 @@ -- * Queries  nullRepo :: FileUUIDModel wX -> Bool-nullRepo = null . repoObjects+nullRepo repo = repoIds repo == [rootId] +rootId :: UUID+rootId = UUID "ROOT"++-- | The root directory of a repository.+root :: FileUUIDModel wX -> (UUID, Object Fail)+root (FileUUIDModel repo) = (rootId, fromJust $ unFail $ getObject repo rootId)++repoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)]+repoObjects (FileUUIDModel repo) =+    [(uuid, obj uuid) | uuid <- unFail $ listObjects repo]+  where+    obj uuid = fromJust $ unFail $ getObject repo uuid++repoIds :: FileUUIDModel wX -> [UUID]+repoIds = map fst . repoObjects+ -- | @isEmpty file@ <=> file content is empty --   @isEmpty dir@  <=> dir has no child isEmpty :: Object Fail -> Bool isEmpty (Directory d) = M.null d-isEmpty (Blob f _) = BS.null $ unFail f---- | The root directory of a repository.-root :: FileUUIDModel wX -> Object Fail-root (FileUUIDModel repo) = fromJust $ unFail $ getObject repo (UUID "ROOT")+isEmpty (Blob f _) = B.null $ unFail f -repoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)]-repoObjects (FileUUIDModel repo) = [ (id, obj id) |-                               id <- unFail $ listObjects repo, not $ isEmpty $ obj id ]-  where obj id = fromJust $ unFail $ getObject repo id+nonEmptyRepoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)]+nonEmptyRepoObjects = filter (not . isEmpty . snd) . repoObjects  ---------------------------------------------------------------------- -- * Comparing repositories@@ -125,29 +128,28 @@   -- | 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+aFilename :: Gen Name+aFilename = do+  len <- choose (1,3)+  name <- vectorOf len alpha+  return $ unsafeMakeName . BC.pack $ name ++ ".txt" -aDirname :: Gen BS.ByteString-aDirname = do len <- choose (1,maxLength)-              BC.pack <$> vectorOf len alpha-  where-      maxLength = 3+aDirname :: Gen Name+aDirname = do+  len <- choose (1,3)+  name <- vectorOf len alpha+  return $ unsafeMakeName . BC.pack $ name -aWord :: Gen BS.ByteString+aWord :: Gen B.ByteString aWord = do c <- alpha            return $ BC.pack[c] -aLine :: Gen BS.ByteString+aLine :: Gen B.ByteString aLine = do wordsNo <- choose (1,2)            ws <- vectorOf wordsNo aWord            return $ BC.unwords ws -aContent :: Gen BS.ByteString+aContent :: Gen B.ByteString aContent = bSized 0 0.5 80 $ \k ->              do n <- choose (0,k)                 BC.intercalate "\n" <$> vectorOf n aLine@@ -161,7 +163,6 @@   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@@ -175,28 +176,29 @@           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+          remaining <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files)+          return $ dir ++ remaining   anUUID :: Gen UUID-anUUID = UUID . BC.pack <$> vectorOf 32 (oneof $ map return "0123456789")+anUUID = UUID . BC.pack <$> vectorOf 4 (oneof $ map return "0123456789")  -- | @aRepo filesNo dirsNo@ produces repositories with *at most*  -- @filesNo@ files and @dirsNo@ directories.  -- The structure of the repository is aleatory.-aRepo :: Int                -- ^ Maximum number of files-        -> Int              -- ^ Maximum number of directories-        -> Gen (FileUUIDModel wX)-aRepo maxFiles maxDirs-  = do 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 $ FileUUIDModel $ objectMap $ M.fromList objectmap+aRepo :: Int                    -- ^ Maximum number of files+      -> Int                    -- ^ Maximum number of directories+      -> Gen (FileUUIDModel wX)+aRepo maxFiles maxDirs = do+  ids <- uniques (maxFiles+maxDirs) anUUID+  let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0+  filesNo <- choose (minFiles,maxFiles)+  let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0+  dirsNo <- choose (minDirs,maxDirs)+  let (dirids, ids') = splitAt dirsNo ids+      fileids = take filesNo ids'+  objectmap <- aDir (rootId : dirids) fileids+  return $ FileUUIDModel $ objectMap $ M.fromList objectmap  -- | Generate small repositories. -- Small repositories help generating (potentially) conflicting patches.@@ -206,9 +208,8 @@                   dirsNo <- frequency [(3, return 1), (1, return 0)]                   aRepo filesNo dirsNo   repoApply (FileUUIDModel state) patch = FileUUIDModel <$> applyToState patch state-  showModel model = "FileUUIDModel{\n" ++ unlines (map entry $ repoObjects model) ++ "}"-    where entry (id, obj) = show id ++ " -> " ++ show obj-  eqModel r1 r2 = repoObjects r1 == repoObjects r2+  showModel = show -- ppShow+  eqModel r1 r2 = nonEmptyRepoObjects r1 == nonEmptyRepoObjects r2  instance Arbitrary (Sealed FileUUIDModel) where   arbitrary = seal <$> aSmallRepo

@@ -20,30 +20,36 @@ 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 as B ( ByteString, pack ) import qualified Data.ByteString.Char8 as BC ( unpack )-import Data.List ( sort )+import Data.List ( sort , isPrefixOf ) 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 )+                       , Gen, suchThat, scale ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework (Test, testGroup)-import Data.List ( isPrefixOf )+-- import Text.Show.Pretty ( ppShow ) -import Darcs.Patch.Info ( PatchInfo(..), patchinfo,-                          piLog, piAuthor, piName )-import Darcs.Util.ByteString ( decodeLocale, packStringToUTF8, unpackPSFromUTF8 )+import Darcs.Patch.Info+    ( PatchInfo(..), rawPatchInfo, showPatchInfo, readPatchInfo+    , piLog, piAuthor, piName, validDate, validLog, validAuthor+    , validDatePS, validLogPS, validAuthorPS+    )+import Darcs.Patch.ReadMonads ( parseStrictly )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Util.ByteString+    ( decodeLocale, packStringToUTF8, unpackPSFromUTF8, linesPS )+import Darcs.Util.Printer ( renderPS )  testSuite :: Test testSuite = testGroup "Darcs.Patch.Info"   [ metadataDecodingTest   , metadataEncodingTest   , packUnpackTest+  , parseUnparseTest   ]  -- | A newtype wrapping String so we can make our own random generator for it.@@ -58,6 +64,9 @@ --   only UTF-8-encoded PatchInfo's. newtype UTF8PatchInfo = UTF8PatchInfo PatchInfo deriving (Eq, Ord) +-- Note that this instance only creates valid unicode strings. It does not+-- generate lone surrogates, for instance, as these would fail the+-- packUnpackTest below. instance Arbitrary UnicodeString where     -- 0x10ffff is the highest Unicode code point ; 0xd800 - 0xdfff are     -- surrogates. '\xfffd' is excluded because it is used as a marker@@ -67,80 +76,82 @@                                                    ,choose ('\xfffe', '\x10ffff')])  instance Show UTF8PatchInfo where-     showsPrec _ = withUTF8PatchInfo rawPatchInfoShow+    show = withUTF8PatchInfo rawPatchInfoShow instance Show UTF8OrNotPatchInfo where-     showsPrec _ = withUTF8OrNotPatchInfo rawPatchInfoShow+    show = 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':)+rawPatchInfoShow :: PatchInfo -> String+rawPatchInfoShow = {- ppShow -} show  instance Arbitrary UTF8PatchInfo where-    arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8Patch+    arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8PatchInfo     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))+        i <- shrink (isInverted pi)+        return (UTF8PatchInfo (rawPatchInfo sn (BC.unpack (_piDate pi)) sa sl i))  instance Arbitrary UTF8OrNotPatchInfo where-    arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8Patch,-                                                  arbitraryUnencodedPatch])+    arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8PatchInfo,+                                                  arbitraryUnencodedPatchInfo]) --- | 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.+-- Note : We must NOT use 'patchinfo' from Darcs.Patch.Info+-- with unsafePerformIO here because this breaks  the parse/unparse test+-- (the added junk will be different on each call).+arbitraryUTF8PatchInfo :: Gen PatchInfo+arbitraryUTF8PatchInfo = do+    d <- arbitrary `suchThat` validDate+    n <- (asString `fmap` arbitrary) `suchThat` validLog+    a <- (asString `fmap` arbitrary) `suchThat` validAuthor+    l <- lines `fmap` scale (* 2) arbitrary+    i <- return False+    return $ rawPatchInfo d n a l i  -- | 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+arbitraryUnencodedPatchInfo :: Gen PatchInfo+arbitraryUnencodedPatchInfo = do+    d <- arbitraryByteString `suchThat` validDatePS+    n <- arbitraryByteString `suchThat` validLogPS+    a <- arbitraryByteString `suchThat` validAuthorPS+    l <- linesPS `fmap` scale (* 2) arbitraryByteString+    i <- return False     return (PatchInfo d n a l i) -arbitraryByteString :: Gen ByteString-arbitraryByteString = (B.pack . map fromIntegral)-                          `fmap` listOf (choose (0, 255) :: Gen Int)+arbitraryByteString :: Gen B.ByteString+arbitraryByteString = B.pack <$> listOf arbitrary  -- | Test that anything produced by the 'patchinfo' function is valid UTF-8 metadataEncodingTest :: Test-metadataEncodingTest = testProperty "Testing patch metadata encoding" $-    withUTF8PatchInfo $-       \patchInfo -> encodingOK (_piAuthor patchInfo)-                     && encodingOK (_piName patchInfo)-                     && all encodingOK (_piLog patchInfo)-  where encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode+metadataEncodingTest =+    testProperty "Testing patch metadata encoding" propMetadataEncoding +propMetadataEncoding :: UTF8PatchInfo -> Bool+propMetadataEncoding (UTF8PatchInfo patchInfo) =+    encodingOK (_piAuthor patchInfo)+    && encodingOK (_piName patchInfo)+    && all encodingOK (_piLog patchInfo)+  where+    encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode+ -- | Test that metadata in patches are decoded as UTF-8 or locale depending on -- whether they're valid UTF-8. metadataDecodingTest :: Test-metadataDecodingTest = testProperty "Testing patch metadata decoding" $-    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+metadataDecodingTest = testProperty "Testing patch metadata decoding" propMetadataDecoding -isValidUTF8 :: ByteString -> Bool+propMetadataDecoding :: UTF8OrNotPatchInfo -> Bool+propMetadataDecoding (UTF8OrNotPatchInfo patchInfo) =+    utf8OrLocale (_piAuthor patchInfo) == piAuthor patchInfo+    && utf8OrLocale (_piName patchInfo) == piName patchInfo+    && map utf8OrLocale (_piLog patchInfo) `superset` piLog patchInfo+  where+    utf8OrLocale bs =+      if isValidUTF8 bs then unpackPSFromUTF8 bs else decodeLocale bs++isValidUTF8 :: B.ByteString -> Bool isValidUTF8 = not . T.any (=='\xfffd') . decodeUtf8With lenientDecode  packUnpackTest :: Test@@ -161,3 +172,18 @@ withUTF8OrNotPatchInfo :: (PatchInfo -> a) -> UTF8OrNotPatchInfo -> a withUTF8OrNotPatchInfo f mpi = case mpi of                                  UTF8OrNotPatchInfo pinf -> f pinf++parseUnparseTest :: Test+parseUnparseTest = testProperty "parse . show == id" propParseUnparse++parsePatchInfo :: B.ByteString -> Maybe PatchInfo+parsePatchInfo = fmap fst . parseStrictly readPatchInfo++unparsePatchInfo :: PatchInfo -> B.ByteString+unparsePatchInfo = renderPS . showPatchInfo ForStorage++instance Arbitrary PatchInfo where+    arbitrary = arbitraryUnencodedPatchInfo++propParseUnparse :: PatchInfo -> Bool+propParseUnparse pi = Just pi == parsePatchInfo (unparsePatchInfo pi)

@@ -1,7 +1,10 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where +import Prelude ()+import Darcs.Prelude import Control.Monad ( liftM )+import Data.Maybe ( isNothing )  import Darcs.Test.Patch.Check ( PatchCheck,                                 checkMove, removeDir, createDir,@@ -16,17 +19,20 @@ import Darcs.Util.Path ( fn2fp ) import qualified Data.Map as M ( mapMaybe ) -import Darcs.Patch ( invert,-                     effect )+import Darcs.Patch ( invert, effect, PrimPatch ) import Darcs.Patch.Invert ( Invert )-import Darcs.Patch.V1 ()-import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(..) )+import Darcs.Patch.V1 ( )+import Darcs.Patch.V1.Core ( RepoPatchV1(..) )+import Darcs.Patch.V2.RepoPatch ( RepoPatchV2, isConsistent )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) import Darcs.Patch.V1.Core ( isMerger )-import Darcs.Patch.Prim.V1 ()+import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim ) import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Witnesses.Ordered -#include "impossible.h"+type Prim1 = V1.Prim+type Prim2 = V2.Prim  class Check p where    checkPatch :: p wX wY -> PatchCheck Bool@@ -35,16 +41,27 @@    checkPatch NilFL = isValid    checkPatch (p :>: ps) = checkPatch p >> checkPatch ps +instance Check p => Check (p:>p) where+   checkPatch (p1 :> p2) = checkPatch p1 >> checkPatch p2+ checkAPatch :: (Invert p, Check p) => p wX wY -> Bool checkAPatch p = doCheck $ do _ <- checkPatch p                              checkPatch $ invert p -instance Check (V1.RepoPatchV1 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 PrimPatch prim => Check (RepoPatchV2 prim) where+  checkPatch p = return $ isNothing $ isConsistent p++instance Check (RepoPatchV1 Prim1) where+   checkPatch p | isMerger p = checkPatch $ effect p+   checkPatch (Merger _ _ _ _) = impossible+   checkPatch (Regrem _ _ _ _) = impossible+   checkPatch (PP p) = checkPatch p++deriving instance Check Prim1+deriving instance Check Prim2++instance Check FileUUID.Prim where+  checkPatch _ = return True -- XXX  instance Check Prim where 

@@ -15,10 +15,6 @@ --  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,@@ -37,21 +33,22 @@ 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.Show+    ( ShowPatchBasic, displayPatch, showPatch, ShowPatchFor(ForStorage) ) import Darcs.Patch.Prim.Class ( PrimPatch, PrimOf, FromPrim ) import Darcs.Patch ()-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Commute ( commuteFLorComplain )+import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch.Commute ( commute, commuteFL ) 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.Invert ( Invert, invert, invertFL )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), 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.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text ) --import Darcs.ColorPrinter ( traceDoc )  propIsMergeable :: forall model p wX . (FromPrim p, Merge p, RepoModel model)@@ -64,19 +61,19 @@                        _ -> Nothing  -- | invert symmetry   inv(inv(p)) = p-invertSymmetry :: (Patchy p, MyEq p) => p wA wB -> TestResult+invertSymmetry :: (Invert p, Eq2 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 :: (Invert p, Eq2 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)+invertRollback :: (Invert p, Apply p, ApplyState p ~ RepoState model, ShowPatchBasic p, RepoModel model)                 => WithState model p wA wB -> TestResult invertRollback (WithState a x b)   = case maybeFail $ repoApply b (invert x) of@@ -86,10 +83,10 @@                        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)+                                  $$ redText "with (invert x) on top:" $$ displayPatch (invert x)  -- | recommute   AB ↔ B′A′ if and only if B′A′ ↔ AB-recommute :: (Patchy p, ShowPatchBasic p, MyEq p, MightHaveDuplicate p)+recommute :: (ShowPatchBasic p, Eq2 p, MightHaveDuplicate p)           => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY)))           -> (p :> p) wA wB -> TestResult recommute c (x :> y) =@@ -103,99 +100,150 @@       | hasDuplicate y' || hasDuplicate x' -> rejected       | otherwise ->        case c (y' :> x') of-         Nothing -> failed (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x')+         Nothing -> failed (redText "failed, where x" $$ displayPatch x $$+                              redText ":> y" $$ displayPatch y $$+                              redText "y'" $$ displayPatch y' $$+                              redText ":> x'" $$ displayPatch x')          Just (x'' :> y'') ->              case y'' =/\= y of-             NotEq -> failed (redText "y'' =/\\= y failed, where x" $$ showPatch x $$-                              redText ":> y" $$ showPatch y $$-                              redText "y'" $$ showPatch y' $$-                              redText ":> x'" $$ showPatch x' $$-                              redText "x''" $$ showPatch x'' $$-                              redText ":> y''" $$ showPatch y'')+             NotEq -> failed (redText "y'' =/\\= y failed, where x" $$ displayPatch x $$+                              redText ":> y" $$ displayPatch y $$+                              redText "y'" $$ displayPatch y' $$+                              redText ":> x'" $$ displayPatch x' $$+                              redText "x''" $$ displayPatch x'' $$+                              redText ":> y''" $$ displayPatch y'')              IsEq -> case x'' =/\= x of-                     NotEq -> failed (redText "x'' /= x" $$ showPatch x'' $$ redText ":>" $$ showPatch y'')+                     NotEq -> failed (+                              redText "x'' /= x, where x" $$ displayPatch x $$+                              redText ":> y" $$ displayPatch y $$+                              redText "y'" $$ displayPatch y' $$+                              redText ":> x'" $$ displayPatch x' $$+                              redText "x''" $$ displayPatch x'' $$+                              redText ":> y''" $$ displayPatch y'')                      IsEq -> succeeded  -- | commuteInverses   AB ↔ B′A′ if and only if B⁻¹A⁻¹ ↔ A′⁻¹B′⁻¹-commuteInverses :: (Patchy p, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))-                 -> (p :> p) wA wB -> TestResult+commuteInverses :: (Invert p, ShowPatchBasic p, Eq2 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'+                            redText "x" $$ displayPatch x $$ redText "y" $$ displayPatch y $$+                            redText "y'" $$ displayPatch y' $$ redText "x'" $$ displayPatch 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')+                              redText "x" $$ displayPatch x $$+                              redText "y" $$ displayPatch y $$+                              redText "y'" $$ displayPatch y' $$+                              redText "x'" $$ displayPatch x' $$+                              redText "ix'" $$ displayPatch ix' $$+                              redText "iy'" $$ displayPatch iy' $$+                              redText "invert ix'" $$ displayPatch (invert ix') $$+                              redText "invert iy'" $$ displayPatch (invert iy')             IsEq -> case y' =\/= invert iy' of-                    NotEq -> failed $ redText "y' /= invert iy'" $$ showPatch iy' $$ showPatch y'+                    NotEq -> failed $ redText "y' /= invert iy'" $$ displayPatch iy' $$ displayPatch 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+effectPreserving+  :: ( Apply p+     , MightBeEmptyHunk p+     , RepoModel model+     , ApplyState p ~ RepoState model+     , ShowPatchBasic p+     )+  => (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'."+        Nothing ->+          failed+          $  redText "##x" $$ displayPatch x+          $$ redText "##y" $$ displayPatch y+          $$ redText "##y'" $$ displayPatch y'+          $$ redText "##x'" $$ displayPatch x'+          $$ redText "##y' is not applicable to r"+          $$ displayModel r+        Just r_y' ->+          case maybeFail $ repoApply r_y' x' of+            Nothing ->+              failed+              $  redText "##x" $$ displayPatch x+              $$ redText "##y" $$ displayPatch y+              $$ redText "##y'" $$ displayPatch y'+              $$ redText "##x'" $$ displayPatch x'+              $$ redText "##x' is not applicable to r_y'"+              $$ displayModel r_y'+            Just r_y'x' ->+              if r_y'x' `eqModel` r'+                then succeeded+                else+                  failed+                  $  redText "##x" $$ displayPatch x+                  $$ redText "##y" $$ displayPatch y+                  $$ redText "##y'" $$ displayPatch y'+                  $$ redText "##x'" $$ displayPatch x'+                  $$ redText "##r_y'x'"+                  $$ displayModel r_y'x'+                  $$ redText "##is not equal to r'"+                  $$ displayModel r'+  where+    displayModel = text . showModel  -- | 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+  :: (Invert p, ShowPatchBasic p, Eq2 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+    Nothing -> rejected+    Just (y' :> x') ->+      case c (invert x :> y') of+        Nothing ->+          failed $+          redText "-------- original (x :> y)" $$+          displayPatch x $$ redText ":>" $$ displayPatch y $$+          redText "-------- result (y' :> x')" $$+          displayPatch y' $$ redText ":>" $$ displayPatch x' $$+          redText "-------- failed commute (invert x :> y')" $$+          displayPatch (invert x) $$ redText ":>" $$ displayPatch y'+        Just (y'' :> ix') ->+          case y'' =\/= y of+            NotEq ->+              failed $ redText "y'' /= y" $$+              redText "x" $$ displayPatch x $$+              redText "y" $$ displayPatch y $$+              redText "y'" $$ displayPatch y' $$+              redText "x'" $$ displayPatch x' $$+              redText "y''" $$ displayPatch y'' $$+              redText "ix'" $$ displayPatch ix'+            IsEq ->+              case x' =\/= invert ix' of+                NotEq ->+                  failed $ redText "x' /= invert ix'" $$+                  redText "x" $$ displayPatch x $$+                  redText "y" $$ displayPatch y $$+                  redText "y'" $$ displayPatch y' $$+                  redText "x'" $$ displayPatch x' $$+                  redText "invert x" $$ displayPatch (invert x) $$+                  redText "y'" $$ displayPatch y' $$+                  redText "invert ix'" $$ displayPatch (invert ix')+                IsEq -> succeeded -permutivity :: (Patchy p, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+permutivity :: (ShowPatchBasic p, Eq2 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@@ -212,8 +260,8 @@           Just (z4 :> x4) ->             --traceDoc (greenText "third commuted" $$             --          greenText "about to commute" $$-            --          greenText "y1" $$ showPatch y1 $$-            --          greenText "z4" $$ showPatch z4) $+            --          greenText "y1" $$ displayPatch y1 $$+            --          greenText "z4" $$ displayPatch z4) $             case c (y1 :> z4) of             Nothing -> failed $ redText "permutivity2"             Just (z3_ :> y4)@@ -221,68 +269,77 @@                      --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 "x" $$ displayPatch x $$+                                         redText "y" $$ displayPatch y $$+                                         redText "z" $$ displayPatch z $$+                                         redText "z3" $$ displayPatch z3 $$                                          redText "failed commute of" $$-                                         redText "y4" $$ showPatch y4 $$-                                         redText "x4" $$ showPatch x4 $$+                                         redText "y4" $$ displayPatch y4 $$+                                         redText "x4" $$ displayPatch x4 $$                                          redText "whereas commute of x and y give" $$-                                         redText "y1" $$ showPatch y1 $$-                                         redText "x1" $$ showPatch x1+                                         redText "y1" $$ displayPatch y1 $$+                                         redText "x1" $$ displayPatch 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_+                             redText "z3" $$ displayPatch z3 $$+                             redText "z3_" $$ displayPatch 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+partialPermutivity+  :: (Invert 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 (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+            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" $$+                      displayPatch x $$+                      greenText "y" $$+                      displayPatch y $$+                      greenText "z" $$+                      displayPatch z -mergeArgumentsConsistent :: (Patchy p, ShowPatchBasic p) =>+mergeArgumentsConsistent :: (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]+    msum [(\z -> redText "mergeArgumentsConsistent x" $$ displayPatch x $$ z) `fmap` isConsistent x,+          (\z -> redText "mergeArgumentsConsistent y" $$ displayPatch y $$ z) `fmap` isConsistent y] -mergeConsistent :: (Patchy p, ShowPatchBasic p, Merge p) =>+mergeConsistent :: (ShowPatchBasic p, Merge p) =>                            (forall wX wY . p wX wY -> Maybe Doc)                         -> (p :\/: p) wA wB -> TestResult mergeConsistent isConsistent (x :\/: y) =     case merge (x :\/: y) of     y' :/\: x' ->       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']+        msum [(\z -> redText "mergeConsistent x" $$ displayPatch x $$ z) `fmap` isConsistent x,+              (\z -> redText "mergeConsistent y" $$ displayPatch y $$ z) `fmap` isConsistent y,+              (\z -> redText "mergeConsistent x'" $$ displayPatch x' $$ z $$+                     redText "where x' comes from x" $$ displayPatch x $$+                     redText "and y" $$ displayPatch y) `fmap` isConsistent x',+              (\z -> redText "mergeConsistent y'" $$ displayPatch y' $$ z) `fmap` isConsistent y'] -mergeEitherWay :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> TestResult+mergeEitherWay :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> TestResult mergeEitherWay (x :\/: y) =     case merge (x :\/: y) of     y' :/\: x' -> case merge (y :\/: x) of@@ -290,7 +347,7 @@                                  IsEq <- y'' =\/= y' -> succeeded                                | otherwise -> failed $ redText "mergeEitherWay bug" -mergeCommute :: (Patchy p, MyEq p, ShowPatchBasic p, Merge p, MightHaveDuplicate p)+mergeCommute :: (Eq2 p, ShowPatchBasic p, Merge p, MightHaveDuplicate p)              => (p :\/: p) wX wY -> TestResult mergeCommute (x :\/: y) =     case merge (x :\/: y) of@@ -303,36 +360,36 @@      | 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'+                            redText "x" $$ displayPatch x $$+                            redText "y" $$ displayPatch y $$+                            redText "x'" $$ displayPatch x' $$+                            redText "y'" $$ displayPatch y'         Just (y_ :> x'_)             | IsEq <- y_ =\/= y,               IsEq <- x'_ =\/= x' ->                       case commute (y :> x') of                       Nothing -> failed $ redText "mergeCommute 2 failed" $$-                                          redText "x" $$ showPatch x $$-                                          redText "y" $$ showPatch y $$-                                          redText "x'" $$ showPatch x' $$-                                          redText "y'" $$ showPatch y'+                                          redText "x" $$ displayPatch x $$+                                          redText "y" $$ displayPatch y $$+                                          redText "x'" $$ displayPatch x' $$+                                          redText "y'" $$ displayPatch y'                       Just (x_ :> y'_)                            | IsEq <- x_ =\/= x,                              IsEq <- y'_ =\/= y' -> succeeded                            | otherwise -> failed $ redText "mergeCommute 3" $$-                                                   redText "x" $$ showPatch x $$-                                                   redText "y" $$ showPatch y $$-                                                   redText "x'" $$ showPatch x' $$-                                                   redText "y'" $$ showPatch y' $$-                                                   redText "x_" $$ showPatch x_ $$-                                                   redText "y'_" $$ showPatch y'_+                                                   redText "x" $$ displayPatch x $$+                                                   redText "y" $$ displayPatch y $$+                                                   redText "x'" $$ displayPatch x' $$+                                                   redText "y'" $$ displayPatch y' $$+                                                   redText "x_" $$ displayPatch x_ $$+                                                   redText "y'_" $$ displayPatch y'_             | otherwise -> failed $ redText "mergeCommute 4" $$-                                    redText "x" $$ showPatch x $$-                                    redText "y" $$ showPatch y $$-                                    redText "x'" $$ showPatch x' $$-                                    redText "y'" $$ showPatch y' $$-                                    redText "x'_" $$ showPatch x'_ $$-                                    redText "y_" $$ showPatch y_+                                    redText "x" $$ displayPatch x $$+                                    redText "y" $$ displayPatch y $$+                                    redText "x'" $$ displayPatch x' $$+                                    redText "y'" $$ displayPatch y' $$+                                    redText "x'_" $$ displayPatch x'_ $$+                                    redText "y_" $$ displayPatch y_   -- | coalesce effect preserving@@ -345,9 +402,24 @@        Nothing -> rejected        Just x  -> case maybeFail $ repoApply r x of                        Nothing  -> failed $ redText "x is not applicable to r."+                                        $$ text (showModel r)+                                        $$ displayPatch x+                                        $$ redText "a:>b"+                                        $$ displayPatch a $$ displayPatch b+                                        $$ redText "r'="+                                        $$ text (showModel r')                        Just r_x -> if r_x `eqModel` r'                                       then succeeded-                                      else failed $ redText "r_x /= r'"+                                      else failed $ redText "r_x /= r', r="+                                        $$ text (showModel r)+                                        $$ redText "a:>b="+                                        $$ displayPatch a $$ displayPatch b+                                        $$ redText "x="+                                        $$ displayPatch x+                                        $$ redText "r'="+                                        $$ text (showModel r')+                                        $$ redText "r_x="+                                        $$ text (showModel r_x)  coalesceCommute           :: (PrimPatch prim, MightBeEmptyHunk prim)@@ -358,29 +430,59 @@     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"+      case commuteFL (a :> b :>: c :>: NilFL) of+        Just (b' :>: c' :>: NilFL :> a') ->+          case commuteFL (a :> x) of+            Just (x' :> a'') ->+              case a'' =/\= a' of+                NotEq ->+                  failed $ greenText "a'' =/\\= a' failed"+                    $$ display1+                    $$ display2+                IsEq ->+                  case j (b' :> c') of+                    Nothing ->+                      failed $ greenText "coalesce (b':>c') failed"+                        $$ display1+                        $$ display2+                    Just x'' ->+                      case x' =\/= x'' of+                        NotEq ->+                          failed $ greenText "x' =\\/= x'' failed"+                            $$ display1+                            $$ display2+                            $$ display3+                        IsEq -> succeeded+                      where+                        display3 = redText "## coalesce (b':>c') => x''"+                                   $$ displayPatch x''+              where+                display2 =+                     redText "## commute (a:>x) => x'" $$ displayPatch x'+                  $$ redText "## :> a''" $$ displayPatch a''+            _ -> failed $ greenText "commute a x failed" $$ display1+          where+            display1 =+                 redText "## a" $$ displayPatch a+              $$ redText "## b" $$ displayPatch b+              $$ redText "## c" $$ displayPatch c+              $$ redText "## coalesce (b:>c) => x" $$ displayPatch x+              $$ redText "## commute (a:>b:>c) => a'" $$ displayPatch a'+              $$ redText "## b'" $$ displayPatch b'+              $$ redText "## c'" $$ displayPatch c'         _ -> rejected -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)+-- note: we would normally use displayPatch in the failure message+-- but that would be very misleading here+show_read :: (Show2 p, Eq2 p, ReadPatch p, ShowPatchBasic p) => p wA wB -> TestResult+show_read p = let ps = renderPS (showPatch ForStorage p)               in case readPatch ps of-                 Nothing -> failed (redText "unable to read " $$ showPatch p)+                 Nothing -> failed (redText "unable to read " $$ showPatch ForStorage p)                  Just (Sealed p'  ) | IsEq <- p' =\/= p -> succeeded                                     | otherwise -> failed $ redText "trouble reading patch p" $$-                                                            showPatch p $$+                                                            showPatch ForStorage p $$                                                             redText "reads as p'" $$-                                                            showPatch p' $$+                                                            showPatch ForStorage p' $$                                                             redText "aka" $$                                                             greenText (show2 p) $$                                                             redText "and" $$