packages feed

darcs 2.16.5 → 2.18.1

raw patch · 431 files changed

+16663/−15570 lines, 431 filesdep +quickcheck-instancesdep +strict-identitydep +terminal-sizedep ~Win32dep ~attoparsecdep ~basesetup-changedbinary-added

Dependencies added: quickcheck-instances, strict-identity, terminal-size, tls

Dependency ranges changed: Win32, attoparsec, base, base16-bytestring, bytestring, constraints, containers, cryptonite, exceptions, fgl, filepath, hashable, http-types, leancheck, memory, mtl, regex-tdfa, tar, text, time, transformers, unix, unix-compat, vector, zlib

Files

CHANGELOG view
@@ -1,3 +1,98 @@+Darcs 2.18.1, 25 Feb 2024++  * Supports GHC 9.8 and the most recent version of other dependencies+    at the time of release, with the exception of the tls 2.0 package,+    which has been held back because of problems connecting to hub.darcs.net+    (see https://bugs.darcs.net/issue2715).++  * Substantial rewrite of the 'darcs test' command.++    The most important user visible change is that a test script can now+    return an exit code of 125 to reflect an untestable/skipped state+    (as with with "git bisect run").++    This in turn means that a group of patches can be found to be responsible+    for a failure rather than just a single one. By default, Darcs will+    try to minimise such a group by reordering patches to remove irrelevant+    ones from the initial group found from the patch ordering in the+    repository. This behaviour can be disabled with --no-shrink-failure.++  * Remove support for downloading via curl++    This is no longer particularly useful as we now use modern, maintained+    Haskell libraries for native HTTP downloading, and substantially simplifies+    this area of the code.++  * Patch index: Significant performance improvement++    The patch index is used in commands like annotate and log. A couple of+    performance improvements were made that should speed up using the patch+    index.++  * Progress reporting++    Progress reports are now provided during more long-running operations,+    including updating the "index" (a cache that speeds up detecting+    changes in the working directory), and during merge operations.++    They also behave better on Windows and when outputting long lines.++  * Other changes/fixes:+    * Use hardlinks more often to share files between repositories/caches.+    * Support --leave-test-dir for all commands that support --test+    * Avoid extraneous "repo:." entries in _darcs/prefs/sources [issue2672]+    * Add 'darcs clean' command as an alias for 'darcs revert -l'+    * 'darcs rebase unsuspend': add more patch editing options+    * Fix stale lock files after Ctrl-C+    * External merge tools: preserve output, and fail if tool does+    * Properly reference renamed files in external merge [issue189]+    * Mark conflicts properly if tag pulled at the same time [issue2682]+    * Remove the useless optimize pristine subcommand+    * 'darcs convert': honour the --compress and --diff-algorithm options+    * Fix contrib/darcs-shell [issue2646]+    * Fix 'darcs pull --dont-allow-conflicts' with external-merge [issue1819]+    * Problems with local pristine files now tell user to run+      'darcs repair' [issue1981]+    * Fix various problems with symlinks, including on Windows+    * Add --no-prefs-templates option when creating a repository+    * Allow 'darcs rebase unsuspend' when there are non-conflicting+      unrecorded changes+    * Handle broken pending patches in 'darcs check' and 'darcs repair'+    * Improve error reporting when remote _darcs/format doesn't exist+    * 'darcs optimize reorder': add --deep/--shallow options+    * 'darcs optimize compress/uncompress': also handle pristine files+    * 'darcs optimize cache': don't work with lists of darcs repos+      Instead just the global cache is cleaned by checking hard-link counts+    * Skip the pager when $DARCS_PAGER / $PAGER are set to the empty string+    * 'darcs convert export': allow relative paths for --read-marks and+      --write-marks+    * Fix 'darcs amend --unrecord' to move unrecorded changes to pending+      [issue2697]+    * Don't treat cancelling an operation as failure [issue2074]+    * Fix cloning of ssh repo when using Ctrl-C to stop getting patches+      [issue2701]+    * Don't report invalid regexes as a bug in darcs [issue2702]+    * Add short option -n for --dry-run+    * 'darcs diff': support --look-for-moves and --look-for-adds+    * Fix buffering problem with 'darcs diff' [issue2704]+    * 'darcs obliterate' and 'darcs rebase': offer to revert any conflicting+      unrecorded changes+    * Stop displaying context lines in various interactive scenarios:+      it didn't work properly and would require a lot of work to fix.+    * Improve conflict display for Rebase and V3 patches+    * Increase size limit to 100K for environment variables like+      DARCS_PATCHES_XML, and warn when it is exceeded+    * 'darcs rebase unsuspend': improve the display of dropped dependencies+    * 'darcs amend --ask-deps': also provide a way to remove dependencies+    * 'darcs push': support --reorder-patches option+    * Remove the --remote-repo option+    * Don't display hints about using --set-default+    * Conflict resolution: unrecorded changes will suppress conflict marking+      of appropriate changes [issue2708]+    * Explain what a "clean tag" is in help for tag command+    * Fix problem with naming patch bundles after patches that contain+      characters incompatible with the current locale [issue2716]+ Darcs 2.16.5, 20 Feb 2022    This release is to support newer dependencies, most importantly
README.md view
@@ -14,7 +14,7 @@ ```  with a recent cabal (version 3.2 or later is recommended). Any version of-ghc from 8.2 up to 8.10 should work.+ghc from 8.2 up to 9.4 should work.  From inside a clone or a source dist, use @@ -22,30 +22,29 @@ > cabal build ``` -or+Cabal will tell you where the resulting darcs binary is. If you'd rather+use `cabal install` and you are in a clone (not a source dist), you first have+to generate the version info, like this:  ```+> runghc release/gen-version-info.hs > cabal install ``` -If you prefer stack:--```-> stack install-```--Note that using stack will select older versions for some dependencies,-which may mean that performance is slightly less than optimal.+Building/installing with stack used to work with a few tweaks, but is no+longer officially supported due to lack of manpower. If this inconveniences+you, consider contributing patches to maintain our stack.yaml. -Running the test suite-----------------------+Testing+------- -This is optional, of course, but useful if you want to help find bugs or-before you contribute patches.+Running the test-suite is optional, of course, but useful if you want to+help find bugs or before you contribute patches. The easiest and most+flexible way to do this is  ```-> cabal build --enable-tests-> cabal test --test-show-details=direct+> cabal configure --enable-tests+> cabal run darcs-test -- [options for darcs-test, try --help] ```  Using
Setup.hs view
@@ -147,9 +147,9 @@   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+  return $ case line of+                [] -> Nothing+                x:_ -> Just $ last $ words x  `catchAny` \_ -> return Nothing  context :: Verbosity -> IO (Maybe String)
contrib/update_roundup.pl view
@@ -56,12 +56,15 @@     # Otherwise, we default to darcs-devel as the sender.      my $email = ($author =~ m/\@/) ? $author : 'darcs-devel@darcs.net'; -    my $comment = $patch->{comment} ? "\n$patch->{comment}" : '';+    my $comment = $patch->{comment};+    $comment =~ s/^Ignore-this:.*\n?//m;+    $comment =~ s/^/  /mg;      my $patch_name_minus_status = $patch_name;      $patch_name_minus_status =~ s/$issue_re(:?\s?)//; -     # Each patches can potentially update the status of a different issue, so generates a different e-mail+    # Each patch can potentially update the status of a different issue, so+    # generates a different e-mail     my $msg = MIME::Lite->new(          From     => 'noreply@darcs.net',          To      =>'bugs@lists.osuosl.org',@@ -71,8 +74,12 @@          Data     => qq!The following patch sent by $email updated issue $issue with $UPDATE_STRING -* $patch_name $comment+Hash: $patch->{hash}+Author: $patch->{author}+* $patch_name +$comment+ !      );      $msg->send;@@ -80,5 +87,3 @@      # use File::Slurp;      # write_file("msg-$patch->{hash}.out",$msg->as_string); }--
darcs.cabal view
@@ -1,6 +1,6 @@ Cabal-Version:  2.4 Name:           darcs-version:        2.16.5+version:        2.18.1 License:        GPL-2.0-or-later License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>@@ -56,7 +56,6 @@   contrib/upload.cgi    README.md-  CHANGELOG    -- release data   release/distributed-version@@ -84,20 +83,13 @@    GNUmakefile +extra-doc-files:+  CHANGELOG+ source-repository head   type:     darcs   location: http://darcs.net/ -flag curl-  description: Use libcurl for HTTP support.-  default:     False---- in future this could extend to any other external libraries,--- e.g. libiconv-flag pkgconfig-  description: Use pkgconfig to configure libcurl-  default:     False- flag static   description: Build static binary   default:     False@@ -131,8 +123,8 @@ -- ----------------------------------------------------------------------  custom-setup-    setup-depends: base      >= 4.10 && < 4.16,-                   Cabal     >= 2.4 && < 3.7,+    setup-depends: base      >= 4.10 && < 4.20,+                   Cabal     >= 2.4 && < 3.11,                    process   >= 1.2.3.0 && < 1.7,                    filepath  >= 1.4.1 && < 1.5.0.0,                    directory >= 1.2.7 && < 1.4@@ -150,6 +142,7 @@     exposed-modules:                       Darcs.Patch                       Darcs.Patch.Annotate+                      Darcs.Patch.Annotate.Class                       Darcs.Patch.Apply                       Darcs.Patch.ApplyMonad                       Darcs.Patch.Bracketed@@ -174,13 +167,14 @@                       Darcs.Patch.Invertible                       Darcs.Patch.Match                       Darcs.Patch.Merge-                      Darcs.Patch.MonadProgress                       Darcs.Patch.Named-                      Darcs.Patch.Named.Wrapped+                      Darcs.Patch.Object                       Darcs.Patch.PatchInfoAnd                       Darcs.Patch.Permutations                       Darcs.Patch.Prim+                      Darcs.Patch.Prim.Canonize                       Darcs.Patch.Prim.Class+                      Darcs.Patch.Prim.Coalesce                       Darcs.Patch.Prim.FileUUID                       Darcs.Patch.Prim.FileUUID.Apply                       Darcs.Patch.Prim.FileUUID.Coalesce@@ -206,13 +200,13 @@                       Darcs.Patch.Rebase.Change                       Darcs.Patch.Rebase.Fixup                       Darcs.Patch.Rebase.Legacy.Item+                      Darcs.Patch.Rebase.Legacy.Wrapped                       Darcs.Patch.Rebase.Name                       Darcs.Patch.Rebase.PushFixup                       Darcs.Patch.Rebase.Suspended                       Darcs.Patch.RegChars                       Darcs.Patch.Repair                       Darcs.Patch.RepoPatch-                      Darcs.Patch.RepoType                       Darcs.Patch.Set                       Darcs.Patch.Show                       Darcs.Patch.Split@@ -248,17 +242,16 @@                       Darcs.Prelude                       Darcs.Repository                       Darcs.Repository.ApplyPatches-                      Darcs.Repository.Cache                       Darcs.Repository.Clone                       Darcs.Repository.Create                       Darcs.Repository.Diff                       Darcs.Repository.Flags                       Darcs.Repository.Format                       Darcs.Repository.Hashed-                      Darcs.Repository.HashedIO                       Darcs.Repository.Identify                       Darcs.Repository.InternalTypes                       Darcs.Repository.Inventory+                      Darcs.Repository.Inventory.Format                       Darcs.Repository.Job                       Darcs.Repository.Match                       Darcs.Repository.Merge@@ -273,8 +266,9 @@                       Darcs.Repository.Repair                       Darcs.Repository.Resolution                       Darcs.Repository.State-                      Darcs.Repository.Test+                      Darcs.Repository.Transaction                       Darcs.Repository.Traverse+                      Darcs.Repository.Unrevert                       Darcs.Repository.Working                       Darcs.Test.TestOnly                       Darcs.UI.ApplyPatches@@ -320,11 +314,11 @@                       Darcs.UI.Commands.ShowTags                       Darcs.UI.Commands.Tag                       Darcs.UI.Commands.Test+                      Darcs.UI.Commands.Test.Impl                       Darcs.UI.Commands.TransferMode                       Darcs.UI.Commands.Unrecord                       Darcs.UI.Commands.Unrevert                       Darcs.UI.Commands.Util-                      Darcs.UI.Commands.Util.Tree                       Darcs.UI.Commands.WhatsNew                       Darcs.UI.Completion                       Darcs.UI.Defaults@@ -341,12 +335,16 @@                       Darcs.UI.Options.Util                       Darcs.UI.PatchHeader                       Darcs.UI.PrintPatch+                      Darcs.UI.Prompt                       Darcs.UI.RunCommand+                      Darcs.UI.RunHook                       Darcs.UI.SelectChanges+                      Darcs.UI.TestChanges                       Darcs.UI.TheCommands                       Darcs.UI.Usage                       Darcs.Util.AtExit                       Darcs.Util.ByteString+                      Darcs.Util.Cache                       Darcs.Util.CommandLine                       Darcs.Util.Compat                       Darcs.Util.DateMatcher@@ -354,19 +352,17 @@                       Darcs.Util.Diff                       Darcs.Util.Diff.Myers                       Darcs.Util.Diff.Patience-                      Darcs.Util.Download-                      Darcs.Util.Download.Request                       Darcs.Util.Encoding                       Darcs.Util.English                       Darcs.Util.Exception                       Darcs.Util.Exec-                      Darcs.Util.External                       Darcs.Util.File                       Darcs.Util.Global                       Darcs.Util.Graph                       Darcs.Util.Hash                       Darcs.Util.HTTP                       Darcs.Util.Index+                      Darcs.Util.IndexedMonad                       Darcs.Util.IsoDate                       Darcs.Util.Lock                       Darcs.Util.Parser@@ -385,6 +381,7 @@                       Darcs.Util.Tree.Monad                       Darcs.Util.Tree.Plain                       Darcs.Util.URL+                      Darcs.Util.ValidHash                       Darcs.Util.Workaround      autogen-modules:  Version@@ -411,69 +408,70 @@                       System.Posix.IO       cpp-options:    -DWIN32       c-sources:      src/win32/send_email.c-      build-depends:  Win32 >= 2.4.0 && < 2.7+      build-depends:  Win32 >= 2.4.0 && < 2.14     else-      build-depends:  unix >= 2.7.1.0 && < 2.8+      build-depends:  unix >= 2.7.1.0 && < 2.9 -    build-depends:    base              >= 4.10 && < 4.16,+    build-depends:    base              >= 4.10 && < 4.20,                       stm               >= 2.1 && < 2.6,                       binary            >= 0.5 && < 0.11,-                      containers        >= 0.5.6.2 && < 0.7,+                      containers        >= 0.5.11 && < 0.8,                       regex-base        >= 0.94.0.1 && < 0.94.1,-                      regex-tdfa        >= 1.3.1.0 && < 1.3.2,+                      regex-tdfa        >= 1.3.2 && < 1.4,                       regex-applicative >= 0.2 && < 0.4,-                      mtl               >= 2.2.1 && < 2.3,-                      transformers      >= 0.4.2.0 && < 0.6,+                      mtl               >= 2.2.1 && < 2.4,+                      transformers      >= 0.4.2.0 && < 0.7,                       parsec            >= 3.1.9 && < 3.2,-                      fgl               >= 5.5.2.3 && < 5.8,+                      fgl               >= 5.5.2.3 && < 5.9,                       html              >= 1.0.1.2 && < 1.1,-                      filepath          >= 1.4.1 && < 1.5.0.0,+                      filepath          >= 1.4.1 && < 1.6,                       haskeline         >= 0.7.2 && < 0.9,-                      memory            >= 0.14 && < 0.17,-                      cryptonite        >= 0.24 && < 0.30,-                      base16-bytestring >= 0.1.1.7 && < 1.1,+                      memory            >= 0.14 && < 0.19,+                      cryptonite        >= 0.24 && < 0.31,+                      base16-bytestring >= 1.0 && < 1.1,                       utf8-string       >= 1 && < 1.1,-                      vector            >= 0.11 && < 0.13,-                      tar               >= 0.5 && < 0.6,+                      vector            >= 0.11 && < 0.14,+                      tar               >= 0.5 && < 0.7,                       data-ordlist      == 0.4.*,-                      attoparsec        >= 0.13.0.1 && < 0.14,+                      attoparsec        >= 0.13.0.1 && < 0.15,                       zip-archive       >= 0.3 && < 0.5,                       async             >= 2.0.2 && < 2.3,-                      constraints       >= 0.11 && < 0.13,-                      unix-compat       >= 0.5 && < 0.6,-                      bytestring        >= 0.10.6 && < 0.11,+                      constraints       >= 0.11 && < 0.15,+                      unix-compat       >= 0.6 && < 0.8,+                      bytestring        >= 0.10.6 && < 0.13,                       old-time          >= 1.1.0.3 && < 1.2,-                      time              >= 1.5.0.1 && < 1.10,-                      text              >= 1.2.1.3 && < 1.3,+                      time              >= 1.9 && < 1.14,+                      text              >= 1.2.1.3 && < 2.2,                       directory         >= 1.2.7 && < 1.4,                       temporary         >= 1.2.1 && < 1.4,                       process           >= 1.2.3.0 && < 1.7,                       array             >= 0.5.1.0 && < 0.6,-                      hashable          >= 1.2.3.3 && < 1.4,+                      hashable          >= 1.2.3.3 && < 1.5,                       mmap              >= 0.5.9 && < 0.6,-                      zlib              >= 0.6.1.2 && < 0.7.0.0,+                      zlib              >= 0.6.1.2 && < 0.8,                       network-uri       >= 2.6 && < 2.8,                       network           >= 2.6 && < 3.2,                       conduit           >= 1.3.0 && < 1.4,                       http-conduit      >= 2.3 && < 2.4,-                      http-types        >= 0.12.1 && < 0.12.4+                      -- constraining indirect dependency to work around problems+                      -- connecting to hub.darcs.net - see https://bugs.darcs.net/issue2715+                      tls               < 2.0.0,+                      http-types        >= 0.12.1 && < 0.12.5,+                      exceptions        >= 0.6 && < 0.11,+                      terminal-size     >= 0.3.4 && < 0.4,+                      strict-identity   >= 0.1 && < 0.2,      if flag(warn-as-error)       ghc-options:    -Werror      ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs -    if flag(curl)-      other-modules:        Darcs.Util.Download.Curl-      cpp-options:          -DHAVE_CURL-      c-sources:            src/hscurl.c-      cc-options:           -DHAVE_CURL-      if flag(pkgconfig)-        pkgconfig-depends:  libcurl-      else-        extra-libraries:    curl-        includes:           curl/curl.h+    if impl(ghc >= 9.4.1)+      ghc-options:    -Wno-gadt-mono-local-binds +    if impl(ghc >= 9.0.1)+      ghc-options:    -Wno-star-is-type+     -- The terminfo package cannot be built on Windows.     if flag(terminfo) && !os(windows)       build-depends:  terminfo >= 0.4.0.2 && < 0.5@@ -562,7 +560,7 @@    if os(windows)     cpp-options:    -DWIN32-    build-depends:  Win32 >= 2.4.0 && < 2.7+    build-depends:  Win32    build-depends:    darcs,                     base,@@ -578,7 +576,8 @@                     directory,                     FindBin      >= 0.0.5 && < 0.1,                     QuickCheck   >= 2.13 && < 2.15,-                    leancheck    >= 0.9 && < 0.10,+                    quickcheck-instances       >= 0.3.29.1 && < 0.4,+                    leancheck    >= 0.9 && < 1.1,                     HUnit        >= 1.3 && < 1.7,                     test-framework             >= 0.8.1.1 && < 0.9,                     test-framework-hunit       >= 0.3.0.2 && < 0.4,@@ -588,8 +587,7 @@                     zip-archive,                     -- additional dependencies needed by the shelly modules                     async,-                    directory,-                    exceptions                 >= 0.6,+                    exceptions,                     monad-control              >= 0.3.2 && < 1.1,                     process,                     system-filepath            >= 0.4.7 && < 0.5,@@ -608,11 +606,13 @@   other-modules:    Darcs.Test.Email                     Darcs.Test.HashedStorage                     Darcs.Test.Patch.Check+                    Darcs.Test.Patch.Depends                     Darcs.Test.Patch.Examples.Set1                     Darcs.Test.Patch.Examples.Set2Unwitnessed                     Darcs.Test.Patch.Examples.Unwind                     Darcs.Test.Patch.WSub                     Darcs.Test.Patch.Info+                    Darcs.Test.Patch.Properties                     Darcs.Test.Patch.Properties.V1Set1                     Darcs.Test.Patch.Properties.V1Set2                     Darcs.Test.Patch.Properties.Generic@@ -623,8 +623,6 @@                     Darcs.Test.Patch.Arbitrary.Generic                     Darcs.Test.Patch.Arbitrary.Named                     Darcs.Test.Patch.Arbitrary.NamedPrim-                    Darcs.Test.Patch.Arbitrary.NamedPrimFileUUID-                    Darcs.Test.Patch.Arbitrary.NamedPrimV1                     Darcs.Test.Patch.Arbitrary.PatchTree                     Darcs.Test.Patch.Arbitrary.PrimFileUUID                     Darcs.Test.Patch.Arbitrary.PrimV1@@ -632,6 +630,7 @@                     Darcs.Test.Patch.Arbitrary.RepoPatchV1                     Darcs.Test.Patch.Arbitrary.RepoPatchV2                     Darcs.Test.Patch.Arbitrary.RepoPatchV3+                    Darcs.Test.Patch.Arbitrary.Sealed                     Darcs.Test.Patch.Arbitrary.Shrink                     Darcs.Test.Patch.Merge.Checked                     Darcs.Test.Patch.Rebase@@ -640,17 +639,26 @@                     Darcs.Test.Patch.Utils                     Darcs.Test.Patch.V1Model                     Darcs.Test.Patch.FileUUIDModel+                    Darcs.Test.Patch.Types.MergeableSequence+                    Darcs.Test.Patch.Types.Merged+                    Darcs.Test.Patch.Types.Pair+                    Darcs.Test.Patch.Types.Triple                     Darcs.Test.Patch.Unwind                     Darcs.Test.Patch.WithState                     Darcs.Test.Patch-                    Darcs.Test.Patch.RepoPatchV1                     Darcs.Test.Misc                     Darcs.Test.Misc.CommandLine                     Darcs.Test.Misc.Encoding                     Darcs.Test.Misc.Graph                     Darcs.Test.Misc.URL                     Darcs.Test.Repository.Inventory+                    Darcs.Test.Shell                     Darcs.Test.TestOnly.Instance+                    Darcs.Test.UI+                    Darcs.Test.UI.Commands.Test+                    Darcs.Test.UI.Commands.Test.Commutable+                    Darcs.Test.UI.Commands.Test.IndexedApply+                    Darcs.Test.UI.Commands.Test.Simple                     Darcs.Test.Util.TestResult                     Darcs.Test.Util.QuickCheck                     Shelly@@ -660,7 +668,13 @@   if flag(warn-as-error)     ghc-options:    -Werror -  ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-orphans+  ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs++  if impl(ghc >= 9.4.1)+    ghc-options:    -Wno-gadt-mono-local-binds++  if impl(ghc >= 9.0.1)+    ghc-options:    -Wno-star-is-type    if flag(threaded)     ghc-options:    -threaded
darcs/darcs.hs view
@@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Module      : Main@@ -32,7 +32,7 @@ import Control.Exception ( handle, ErrorCall ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs )-import System.IO ( hPutStrLn, stderr )+import System.IO ( hPutStr, stderr )  import Darcs.UI.RunCommand ( runTheCommand ) import Darcs.UI.Commands.Help ( helpCmd, listAvailableCommands, printVersion,@@ -48,15 +48,24 @@  execExceptionHandler :: ExecException -> IO a execExceptionHandler (ExecException cmd args redirects reason) = do-    putStrLn . unlines $+    hPutStr stderr . unlines $         [ "Failed to execute external command: " ++ unwords (cmd:args)         , "Lowlevel error: " ++ reason         , "Redirects: " ++ show redirects         ]     exitWith $ ExitFailure 3 +errorExceptionHandler :: ErrorCall -> IO a+errorExceptionHandler e = do+    hPutStr stderr . unlines $+        [ "This is a bug! Please report it at http://bugs.darcs.net " +++          "or via email to bugs@darcs.net:"+        , show e+        ]+    exitWith $ ExitFailure 4+ main :: IO ()-main = handleErrors . withAtexit . withSignalsHandled . handleExecFail $ do+main = handleErrors . handleExecFail . withSignalsHandled . withAtexit $ do     atexit reportBadSources     setDarcsEncodings     argv <- getArgs@@ -74,16 +83,8 @@         ["--exact-version"] -> printExactVersion         _ -> runTheCommand commandControlList (head argv) (tail argv)   where-    handleErrors =-      handle (\(e::ErrorCall) -> do-        hPutStrLn stderr $-          "This is a bug! Please report it at http://bugs.darcs.net " ++-          "or via email to bugs@darcs.net:\n" ++-          show e-        exitWith $ ExitFailure 4)+    handleErrors = handle errorExceptionHandler     handleExecFail = handle execExceptionHandler     printExactVersion =  do-        putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__ ++ "\n"         putStrLn $ "Weak Hash: " ++ weakhash         putStrLn context-
harness/Darcs/Test/Email.hs view
@@ -27,12 +27,13 @@ import Darcs.Prelude  import Data.Char ( isPrint )-import qualified Data.ByteString as B ( length, unpack, null, head, pack,+import qualified Data.ByteString as B ( length, unpack, null, head,                                         cons, empty, foldr, ByteString ) import qualified Data.ByteString.Char8 as BC ( unlines ) import Test.Framework ( Test, testGroup ) import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.QuickCheck ( Arbitrary(..) )+import Test.QuickCheck.Instances.ByteString ()+ import Darcs.Util.Printer ( text, renderPS, packedString ) import Darcs.UI.Email ( makeEmail, readEmail, formatHeader, prop_qp_roundtrip ) @@ -87,9 +88,6 @@       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 =
harness/Darcs/Test/HashedStorage.hs view
@@ -1,12 +1,13 @@+{-# OPTIONS_GHC -Wno-orphans #-} module Darcs.Test.HashedStorage ( tests, unsafeMakeName ) where  import Prelude hiding ( filter, readFile, writeFile, lookup, (<$>) ) import qualified Prelude import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Char8 as BC-import System.Directory( doesFileExist, removeFile, doesDirectoryExist )-import System.FilePath( (</>) )-import Control.Monad.Identity+import System.Directory( doesFileExist, removeFile )+import Control.Monad ( when, forM_ )+import Control.Monad.Identity ( Identity, runIdentity ) import Control.Monad.Trans( lift ) import Control.Applicative( (<$>) ) import Codec.Archive.Zip( extractFilesFromArchive, toArchive )@@ -14,8 +15,12 @@ import Data.Maybe import Data.List( sort, intercalate, intersperse ) +import Darcs.Repository.Inventory.Format ( peekPristineHash )+import Darcs.Repository.Paths ( hashedInventoryPath )++import Darcs.Util.Cache ( mkRepoCache ) import Darcs.Util.Path hiding ( setCurrentDirectory )-import Darcs.Util.Lock ( withTempDir )+import Darcs.Util.Lock ( withPermDir ) import Darcs.Util.Tree hiding ( lookup ) import Darcs.Util.Index import Darcs.Util.Tree.Hashed@@ -31,6 +36,7 @@ import Test.Framework( testGroup ) import qualified Test.Framework as TF ( Test ) import Test.QuickCheck+import Test.QuickCheck.Instances.ByteString ()  import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2@@ -40,24 +46,24 @@ --  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") ]+blobs = [ (unsafeFloatPath "foo_a", BLC.pack "a\n")+        , (unsafeFloatPath "foo_dir/foo_a", BLC.pack "a\n")+        , (unsafeFloatPath "foo_dir/foo_b", BLC.pack "b\n")+        , (unsafeFloatPath "foo_dir/foo_subdir/foo_a", BLC.pack "a\n")+        , (unsafeFloatPath "foo space/foo\nnewline", BLC.pack "newline\n")+        , (unsafeFloatPath "foo space/foo\\backslash", BLC.pack "backslash\n")+        , (unsafeFloatPath "foo space/foo_a", BLC.pack "a\n") ]  files :: [AnchoredPath] files = map fst blobs  dirs :: [AnchoredPath]-dirs = [ floatPath "foo_dir"-       , floatPath "foo_dir/foo_subdir"-       , floatPath "foo space" ]+dirs = [ unsafeFloatPath "foo_dir"+       , unsafeFloatPath "foo_dir/foo_subdir"+       , unsafeFloatPath "foo space" ]  emptyStub :: TreeItem IO-emptyStub = Stub (return emptyTree) NoHash+emptyStub = Stub (return emptyTree) Nothing  unsafeMakeName :: String -> Name unsafeMakeName = either error id . makeName@@ -66,14 +72,14 @@ testTree =     makeTree [ (unsafeMakeName "foo", emptyStub)              , (unsafeMakeName "subtree", SubTree sub)-             , (unsafeMakeName "substub", Stub getsub NoHash) ]+             , (unsafeMakeName "substub", Stub getsub Nothing) ]     where sub = makeTree [ (unsafeMakeName "stub", emptyStub)-                         , (unsafeMakeName "substub", Stub getsub2 NoHash)+                         , (unsafeMakeName "substub", Stub getsub2 Nothing)                          , (unsafeMakeName "x", SubTree emptyTree) ]           getsub = return sub           getsub2 = return $ makeTree [ (unsafeMakeName "file", File emptyBlob)                                       , (unsafeMakeName "file2",-                                         File $ Blob (return $ BLC.pack "foo") NoHash) ]+                                         File $ Blob (return $ BLC.pack "foo") Nothing) ]  equals_testdata :: Tree IO -> IO () equals_testdata t = sequence_ [@@ -149,7 +155,7 @@                exist <- doesFileExist "_darcs/index"                performGC -- required in win32 to trigger file close                when exist $ removeFile "_darcs/index"-               idx <- treeFromIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x+               idx <- treeFromIndex =<< updateIndexFrom "_darcs/index" x                return (x, idx)           check_index = extractRepoAndRun $             do (pris, idx) <- build_index@@ -196,52 +202,52 @@        , 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)+    where blob x = File $ Blob (return (BLC.pack x)) (Just $ sha256 $ BLC.pack x)           name = unsafeMakeName           check_modify =               let t = makeTree [(name "foo", blob "bar")]-                  modify = modifyTree t (floatPath "foo") (Just $ blob "bla")-               in do x <- readBlob $ fromJust $ findFile t (floatPath "foo")-                     y <- readBlob $ fromJust $ findFile modify (floatPath "foo")+                  modify = modifyTree t (unsafeFloatPath "foo") (Just $ blob "bla")+               in do x <- readBlob $ fromJust $ findFile t (unsafeFloatPath "foo")+                     y <- readBlob $ fromJust $ findFile modify (unsafeFloatPath "foo")                      assertEqual "old version" x (BLC.pack "bar")                      assertEqual "new version" y (BLC.pack "bla")                      assertBool "list has foo" $-                                isJust (Prelude.lookup (floatPath "foo") $ list modify)+                                isJust (Prelude.lookup (unsafeFloatPath "foo") $ list modify)                      length (list modify) @?= 1           check_modify_complex =               let t = makeTree [ (name "foo", blob "bar")                                , (name "bar", SubTree t1) ]                   t1 = makeTree [ (name "foo", blob "bar") ]-                  modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla")-               in do foo <- readBlob $ fromJust $ findFile t (floatPath "foo")-                     foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo")+                  modify = modifyTree t (unsafeFloatPath "bar/foo") (Just $ blob "bla")+               in do foo <- readBlob $ fromJust $ findFile t (unsafeFloatPath "foo")+                     foo' <- readBlob $ fromJust $ findFile modify (unsafeFloatPath "foo")                      bar_foo <- readBlob $ fromJust $-                                findFile t (floatPath "bar/foo")+                                findFile t (unsafeFloatPath "bar/foo")                      bar_foo' <- readBlob $ fromJust $-                                 findFile modify (floatPath "bar/foo")+                                 findFile modify (unsafeFloatPath "bar/foo")                      assertEqual "old foo" foo (BLC.pack "bar")                      assertEqual "old bar/foo" bar_foo (BLC.pack "bar")                      assertEqual "new foo" foo' (BLC.pack "bar")                      assertEqual "new bar/foo" bar_foo' (BLC.pack "bla")                      assertBool "list has bar/foo" $-                                isJust (Prelude.lookup (floatPath "bar/foo") $ list modify)+                                isJust (Prelude.lookup (unsafeFloatPath "bar/foo") $ list modify)                      assertBool "list has foo" $-                                isJust (Prelude.lookup (floatPath "foo") $ list modify)+                                isJust (Prelude.lookup (unsafeFloatPath "foo") $ list modify)                      length (list modify) @?= length (list t)           check_modify_remove =               let t1 = makeTree [(name "foo", blob "bar")]                   t2 :: Tree Identity = makeTree [ (name "foo", blob "bar")                                                  , (name "bar", SubTree t1) ]-                  modify1 = modifyTree t1 (floatPath "foo") Nothing-                  modify2 = modifyTree t2 (floatPath "bar") Nothing-                  file = findFile modify1 (floatPath "foo")-                  subtree = findTree modify2 (floatPath "bar")+                  modify1 = modifyTree t1 (unsafeFloatPath "foo") Nothing+                  modify2 = modifyTree t2 (unsafeFloatPath "bar") Nothing+                  file = findFile modify1 (unsafeFloatPath "foo")+                  subtree = findTree modify2 (unsafeFloatPath "bar")                in do assertBool "file is gone" (isNothing file)                      assertBool "subtree is gone" (isNothing subtree)            no_stubs t = null [ () | (_, Stub _ _) <- list t ]-          path = floatPath "substub/substub/file"-          badpath = floatPath "substub/substub/foo"+          path = unsafeFloatPath "substub/substub/file"+          badpath = unsafeFloatPath "substub/substub/foo"           check_expand = do             x <- expand testTree             assertBool "no stubs in testTree" $ not (no_stubs testTree)@@ -253,7 +259,7 @@             test_exp <- expand testTree             t <- expandPath testTree path             t' <- expandPath test_exp path-            t'' <- expandPath testTree $ floatPath "substub/x"+            t'' <- expandPath testTree $ unsafeFloatPath "substub/x"             assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree)             assertBool "path reachable in t" $ path `elem` (map fst $ list t)             assertBool "path reachable in t'" $ path `elem` (map fst $ list t')@@ -268,24 +274,24 @@                        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"+            t <- expandPath testTree $ unsafeFloatPath "substub"+            t' <- expandPath testTree $ unsafeFloatPath "substub/stub"+            t'' <- expandPath testTree $ unsafeFloatPath "subtree/stub"             assertBool "leaf is not a Stub" $-                isNothing (findTree testTree $ 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")+                isNothing (findTree testTree $ unsafeFloatPath "substub")+            assertBool "leaf is not a Stub" $ isJust (findTree t $ unsafeFloatPath "substub")+            assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ unsafeFloatPath "substub/stub")+            assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ unsafeFloatPath "subtree/stub")            check_diffTrees = extractRepoAndRun $                  do Prelude.writeFile "foo_dir/foo_a" "b\n"                     working_plain <- filter nondarcs `fmap` readPlainTree "."                     working <- treeFromIndex =<<-                                 updateIndexFrom "_darcs/index" darcsTreeHash working_plain+                                 updateIndexFrom "_darcs/index" 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")+                    let foo_work = findFile working' (unsafeFloatPath "foo_dir/foo_a")+                        foo_pris = findFile pristine' (unsafeFloatPath "foo_dir/foo_a")                     working' `shapeEq` pristine'                              @? show working' ++ " `shapeEq` " ++ show pristine'                     assertBool "foo_dir/foo_a is in working'" $ isJust foo_work@@ -337,34 +343,29 @@                   notStub _ = True  hash :: [TF.Test]-hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 ]-    where prop_base16 x = (decodeBase16 . encodeBase16) x == x+hash = [ testProperty "decodeBase16 . encodeBase16 == Just" prop_base16 ]+    where prop_base16 x = (decodeBase16 . encodeBase16) x == Just x  monad :: [TF.Test] monad = [ testCase "path expansion" check_virtual         , testCase "rename" check_rename ]     where check_virtual = virtualTreeMonad run testTree >> return ()-              where run = do file <- readFile (floatPath "substub/substub/file")-                             file2 <- readFile (floatPath "substub/substub/file2")+              where run = do file <- readFile (unsafeFloatPath "substub/substub/file")+                             file2 <- readFile (unsafeFloatPath "substub/substub/file2")                              lift $ BLC.unpack file @?= ""                              lift $ BLC.unpack file2 @?= "foo"           check_rename = do (_, t) <- virtualTreeMonad run testTree                             t' <- darcsAddMissingHashes =<< expand t                             forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) ->-                               assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash-              where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2")+                               assertBool ("have hash: " ++ show p) $ itemHash i /= Nothing+              where run = do rename (unsafeFloatPath "substub/substub/file") (unsafeFloatPath "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] ]+    arbitrary = mkHash . BC.pack <$> sequence (replicate 32 arbitrary)  instance (Monad m) => Arbitrary (TreeItem m) where   arbitrary = sized tree'@@ -372,14 +373,14 @@           tree' n = oneof [ file n, subtree n ]           file 0 = return (File emptyBlob)           file _ = do content <- arbitrary-                      return (File $ Blob (return content) NoHash)+                      return (File $ Blob (return content) Nothing)           subtree n = do branches <- choose (1, n)                          let sub name = do t <- tree' ((n - 1) `div` branches)                                            return (unsafeMakeName $ show name, t)                          sublist <- mapM sub [0..branches]                          oneof [ tree' 0                                , return (SubTree $ makeTree sublist)-                               , return $ (Stub $ return (makeTree sublist)) NoHash ]+                               , return $ (Stub $ return (makeTree sublist)) Nothing ]  instance (Monad m) => Arbitrary (Tree m) where   arbitrary = do item <- arbitrary@@ -468,31 +469,12 @@  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!"+  ph <- peekPristineHash <$> BC.readFile hashedInventoryPath+  readDarcsHashed (mkRepoCache dir) ph  extractRepoAndRun :: IO a -> IO a extractRepoAndRun action = do   zipFile <- toArchive . BLC.fromStrict <$> BC.readFile "harness/hstestdata.zip"-  withTempDir "_test_playground" $ \_ -> do+  withPermDir "_test_playground" $ \_ -> do     extractFilesFromArchive [] zipFile     action
harness/Darcs/Test/Misc.hs view
@@ -27,6 +27,7 @@     , prop_unlinesPS_length     , spec_betweenLinesPS     , betweenLinesPS+    , linesPS, unlinesPS     ) import Darcs.Util.Diff.Myers ( shiftBoundaries ) @@ -35,16 +36,18 @@ import qualified Darcs.Test.Misc.Graph as Graph import qualified Darcs.Test.Misc.URL as URL -import qualified Data.ByteString.Char8 as BC ( unpack, pack, snoc )-import qualified Data.ByteString as B ( ByteString, pack, empty, null )-import Data.Char ( ord )+import qualified Data.ByteString.Char8 as BC ( elem, unpack, pack )+import qualified Data.ByteString as B ( ByteString, empty, null ) import Data.Array.Base+import Data.Coerce ( coerce )+import Data.Maybe ( isJust ) import Control.Monad.ST import Test.HUnit ( assertBool, assertEqual, assertFailure ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework.Providers.HUnit ( testCase ) import Test.Framework ( Test, testGroup ) import Test.QuickCheck+import Test.QuickCheck.Instances.ByteString ()   testSuite :: Test@@ -67,32 +70,62 @@   [ testCase "UTF-8 packing and unpacking preserves 'hello world'"            (assertBool "" (unpackPSFromUTF8 (BC.pack "hello world") == "hello world"))   , testCase "Checking that hex packing and unpacking preserves 'hello world'"-           (assertEqual "" (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world"))-                           "hello world")+           (assertEqual "" (fmap BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world"))+                           (Right "hello world"))   , testProperty "Checking that hex conversion works" propHexConversion   , testProperty "unlinesPS is left inverse of linesPS" prop_unlinesPS_linesPS_left_inverse+  , testProperty "linesPS is right inverse of unlinesPS" prop_linesPS_unlinesPS_right_inverse   , testProperty "linesPS length property" prop_linesPS_length   , testProperty "unlinesPS length property" prop_unlinesPS_length   , testProperty "betweenLinesPS behaves like its spec" prop_betweenLinesPS   ] --- 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)-    ]+{- | 'SimpleLines' newtype wrapper for 'B.ByteString' tweaks the+probabilities in favor of newline characters and line collisions. With the+instance below the probability that betweenLinesPS succeeds in+prop_betweenLinesPS should be roughly 6%. --- 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)-  ==> betweenLinesPS start end (twist ps) == spec_betweenLinesPS start end (twist ps)-  where-    twist s-      | B.null s = s-      | otherwise = s `BC.snoc` '\n'+Unfortunately the QC adapter for test-framework does not display the+classification. To see it run++> ghci -isrc -iharness -XTypeSynonymInstances -XFlexibleInstances \+  -XFlexibleContexts -XRankNTypes -XBangPatterns harness/Darcs/Test/Misc.hs++and then manually issue++> quickCheck prop_betweenLinesPS+-}+newtype SimpleLines = SimpleLines { unwrapSimpleLines :: B.ByteString } deriving Show++instance Arbitrary SimpleLines where+  arbitrary = SimpleLines . BC.pack <$> listOf (elements ['a','b','\n'])++-- | A non-empty 'SimpleLines' without newlines.+newtype SimpleLine = SimpleLine B.ByteString deriving Show++instance Arbitrary SimpleLine where+  arbitrary = SimpleLine <$> (unwrapSimpleLines <$> arbitrary) `suchThat` condition+    where+      condition s = not (B.null s) && not (BC.elem '\n' s)++prop_betweenLinesPS :: SimpleLine -> SimpleLine -> SimpleLines -> Property+prop_betweenLinesPS (SimpleLine start) (SimpleLine end) (SimpleLines ps) =+  let result = betweenLinesPS start end ps in+  classify (isJust result) "non-trivial" $+  result == spec_betweenLinesPS start end ps++-- | A non-empty 'B.ByteString' without newlines.+newtype Line = Line B.ByteString deriving Show++instance Arbitrary Line where+  arbitrary = Line <$> arbitrary `suchThat` condition+    where+      condition s = not (B.null s) && not (BC.elem '\n' s)++prop_linesPS_unlinesPS_right_inverse :: [Line] -> Bool+prop_linesPS_unlinesPS_right_inverse x =+  let x' = coerce x in+    linesPS (unlinesPS x') == if null x' then [B.empty] else x'  -- ---------------------------------------------------------------------- -- * LCS
harness/Darcs/Test/Misc/Graph.hs view
@@ -3,6 +3,7 @@ is a lot more effective than randomized testing in this case because it avoids computations on large graphs. -} +{-# OPTIONS_GHC -Wno-orphans #-} module Darcs.Test.Misc.Graph ( testSuite ) where  import Darcs.Prelude
harness/Darcs/Test/Patch.hs view
@@ -15,439 +15,46 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. --- UndecidableInstances was added because GHC 8.6 needed it--- even though GHC 8.2 didn't-{-# LANGUAGE UndecidableInstances #-} module Darcs.Test.Patch ( testSuite ) where  import Darcs.Prelude -import Data.Constraint ( Dict(..) ) import Test.Framework ( Test, testGroup )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.QuickCheck( Arbitrary(..) ) -import Darcs.Test.Util.TestResult ( TestResult, maybeFailed )-import Darcs.Test.Patch.Utils-    ( PropList-    , TestCheck(..)-    , TestCondition(..)-    , TestGenerator(..)-    , properties-    , testCases-    , testConditional-    , fromNothing-    )--import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Eq ( Eq2 ) import Darcs.Patch.Witnesses.Show-import Darcs.Patch.Annotate ( Annotate )-import Darcs.Patch.FromPrim ( PrimOf, FromPrim(..) )-import Darcs.Patch.Prim ( PrimPatch, coalesce )+import Darcs.Patch.FromPrim ( PrimOf ) import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim )-import Darcs.Patch.Prim.Named ( NamedPrim )-import Darcs.Patch.V2.RepoPatch ( isConsistent, isForward, RepoPatchV2 )+import Darcs.Patch.V1 ( RepoPatchV1 )+import Darcs.Patch.V2.RepoPatch ( RepoPatchV2 ) import Darcs.Patch.V3 ( RepoPatchV3 ) import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Invert ( Invert )-import Darcs.Patch.Show ( ShowPatchBasic )-import Darcs.Patch.Apply( Apply, ApplyState )-import Darcs.Patch.Merge ( Merge )  import Darcs.Test.Patch.Arbitrary.Generic import Darcs.Test.Patch.Arbitrary.Named ()-import Darcs.Test.Patch.Arbitrary.PatchTree import Darcs.Test.Patch.Arbitrary.PrimFileUUID()-import Darcs.Test.Patch.Arbitrary.NamedPrimV1 ()-import Darcs.Test.Patch.Arbitrary.NamedPrimFileUUID () import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Arbitrary.RepoPatchV1 () import Darcs.Test.Patch.Arbitrary.RepoPatchV2 () import Darcs.Test.Patch.Arbitrary.RepoPatchV3 () import Darcs.Test.Patch.Arbitrary.PrimV1 ()-import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable ) import Darcs.Test.Patch.Merge.Checked ( CheckedMerge ) import Darcs.Test.Patch.RepoModel-import Darcs.Test.Patch.WithState-    ( ArbitraryState-    , PropagateShrink-    , ShrinkModel-    , WithState-    , arbitraryTriple-    , makeS2Gen-    , makeWS2Gen-    , wesPatch-    )+import Darcs.Test.Patch.WithState ( ShrinkModel ) +import qualified Darcs.Test.Patch.Depends import qualified Darcs.Test.Patch.Info import qualified Darcs.Test.Patch.Selection -import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU--import Darcs.Test.Patch.Properties.Check( Check(..) )-import Darcs.Test.Patch.Properties.Generic ( PatchProperty, MergeProperty, SequenceProperty )-import qualified Darcs.Test.Patch.Properties.Generic as PropG-import qualified Darcs.Test.Patch.Properties.RepoPatch as PropR-import qualified Darcs.Test.Patch.Properties.RepoPatchV3 as PropR3-import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU+import Darcs.Test.Patch.Properties  import qualified Darcs.Test.Patch.Rebase as Rebase import qualified Darcs.Test.Patch.Unwind as Unwind -import qualified Darcs.Test.Patch.WSub as WSub-- type Prim1 = V1.Prim type Prim2 = V2.Prim --- Generic Arbitrary instances---- We define them here so they don't overlap with those for RepoPatchV1,--- which use a different generator for V1Model.--type ArbitraryModel p = (RepoModel (ModelOf p), ArbitraryState p)--instance ArbitraryModel p => Arbitrary (Sealed2 (WithState (FL p))) where-  arbitrary = makeWS2Gen aSmallRepo--instance ArbitraryModel p => Arbitrary (Sealed2 (WithState (FL p :> FL p))) where-  arbitrary = makeWS2Gen aSmallRepo--instance ArbitraryModel p => Arbitrary (Sealed2 (FL p :> FL p)) where-  arbitrary = makeS2Gen aSmallRepo--instance ArbitraryModel p => Arbitrary (Sealed2 (FL p)) where-  arbitrary = makeS2Gen aSmallRepo--instance ArbitraryModel p => Arbitrary (Sealed2 (p :> p :> p)) where-  arbitrary = unseal (seal2 . wesPatch) <$> (aSmallRepo >>= arbitraryTriple)---- End generic instances--unit_V2P1 :: [Test]-unit_V2P1 =-  [ testCases "coalesce commute" (PropU.coalesceCommute WSub.coalesce) ExU.primPermutables-  , testCases "prim recommute" (PropU.recommute WSub.commute) ExU.commutables-  , testCases "square commute law" (PropU.squareCommuteLaw WSub.commute) ExU.commutables-  , testCases "prim inverses commute" (PropU.commuteInverses WSub.commute) ExU.commutables-  , testCases "FL prim recommute" (PropU.recommute WSub.commute) ExU.commutablesFL-  , testCases "FL square commute law" (PropU.squareCommuteLaw WSub.commute) ExU.commutablesFL-  , testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL-  , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(Prim2 WSub.:> Prim2) wX wY])-  , testCases "read and show work on Prim" PropU.showRead ExU.primPatches-  , testCases "read and show work on RepoPatchV2" PropU.showRead ExU.repov2Patches-  , testCases "example flattenings work" (PropR.propConsistentTreeFlattenings fromPrim2) ExU.repov2PatchLoopExamples-  , testCases "V2 merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.repov2Mergeables-  , testCases "V2 merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.repov2Mergeables-  , testCases "V2 merge output is forward" (PropU.mergeConsistent isForward) ExU.repov2Mergeables-  , testCases "V2 merge output consistent" (PropU.mergeConsistent isConsistent) ExU.repov2Mergeables-  , testCases "V2 merge either way" PropU.mergeEitherWay ExU.repov2Mergeables-  , testCases "V2 merge and commute" PropU.mergeCommute ExU.repov2Mergeables--  , testCases "V2 recommute" (PropU.recommute WSub.commute) ExU.repov2Commutables-  , testCases "V2 inverses commute" (PropU.commuteInverses WSub.commute) ExU.repov2Commutables-  , testCases "V2 permutivity" (PropU.permutivity WSub.commute) ExU.repov2NonduplicateTriples-  ]-  where-    fromPrim2 :: PropR.FromPrimT RepoPatchV2 Prim2-    fromPrim2 = fromAnonymousPrim--arbitraryThing :: TestGenerator thing (Sealed2 thing)-arbitraryThing = TestGenerator (\f p -> Just (unseal2 f p))--qc_prim :: forall prim.-           ( TestablePrim prim-           , Show2 prim-           , Show1 (ModelOf prim)-           , MightBeEmptyHunk prim-           , MightHaveDuplicate prim-           , Arbitrary (Sealed2 prim)-           , Arbitrary (Sealed2 (prim :> prim))-           , Arbitrary (Sealed2 (WithState prim))-           , Arbitrary (Sealed2 (WithState (prim :> prim)))-           ) => [Test]-qc_prim =-  -- The following fails because of setpref patches:-  -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc)-  (case runCoalesceTests @prim of-    Just Dict ->-      [ testProperty "prim coalesce effect preserving"-        (unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState (prim :> prim)) -> TestResult)-      ]-    Nothing -> [])-    ++ concat-  [ pair_properties         @prim      "arbitrary"    arbitraryThing-  , pair_properties         @(FL prim) "arbitrary FL" arbitraryThing-  , coalesce_properties     @prim      "arbitrary"    arbitraryThing-  , prim_commute_properties @prim      "arbitrary"    arbitraryThing-  , prim_commute_properties @(FL prim) "arbitrary FL" arbitraryThing-  , patch_properties        @prim      "arbitrary"    arbitraryThing-  , patch_properties        @(FL prim) "arbitrary FL" arbitraryThing-  , patch_repo_properties   @prim      "arbitrary"    arbitraryThing-  , patch_repo_properties   @(FL prim) "arbitrary FL" arbitraryThing-  , pair_repo_properties    @prim      "arbitrary"    arbitraryThing-  , pair_repo_properties    @(FL prim) "arbitrary FL" arbitraryThing-  , triple_properties       @prim      "arbitrary"    arbitraryThing-  , [ testProperty "readPatch/showPatch"-      (unseal2 $ PropG.showRead :: Sealed2 prim -> TestResult)-    , testProperty "readPatch/showPatch (FL)"-      (unseal2 $ PropG.showRead :: Sealed2 (FL prim) -> TestResult)-    ]-  ]--qc_named_prim :: forall prim.-                 ( TestablePrim prim-                 , Show2 prim-                 , Show1 (ModelOf (NamedPrim prim))-                 , MightBeEmptyHunk prim-                 , Arbitrary (Sealed2 (NamedPrim prim))-                 , Arbitrary (Sealed2 (NamedPrim prim :> NamedPrim prim))-                 , Arbitrary (Sealed2 (WithState (NamedPrim prim)))-                 , Arbitrary (Sealed2 (WithState (NamedPrim prim :> NamedPrim prim)))-                 ) => [Test]-qc_named_prim =-  qc_prim @(NamedPrim prim) ++-  [ testProperty-      "prim inverse doesn't commute"-      (unseal2 $ PropG.inverseDoesntCommute :: Sealed2 (NamedPrim prim) -> TestResult)-  ]--qc_V2 :: forall prim wXx wYy.-         ( PrimPatch prim-         , Annotate prim-         , Show1 (ModelOf prim)-         , ShrinkModel prim-         , PropagateShrink prim prim-         , ArbitraryPrim prim-         , Shrinkable prim-         , RepoState (ModelOf prim) ~ ApplyState prim-         )-      => prim wXx wYy -> [Test]-qc_V2 _ =-  [ testProperty "with quickcheck that patches are consistent"-    (withSingle consistent)-  ]-  ++ repoPatchProperties @(RepoPatchV2 prim)-  ++ concat-  [ merge_properties   @(RepoPatchV2 prim) "tree" (TestGenerator mergePairFromTree)-  , merge_properties   @(RepoPatchV2 prim) "twfp" (TestGenerator mergePairFromTWFP)-  , pair_properties    @(RepoPatchV2 prim) "tree" (TestGenerator commutePairFromTree)-  , pair_properties    @(RepoPatchV2 prim) "twfp" (TestGenerator commutePairFromTWFP)-  , patch_properties   @(RepoPatchV2 prim) "tree" (TestGenerator patchFromTree)-  , triple_properties  @(RepoPatchV2 prim) "tree" (TestGenerator commuteTripleFromTree)-  ]-  where-    consistent :: RepoPatchV2 prim wX wY -> TestResult-    consistent = maybeFailed . isConsistent--qc_V3 :: forall prim wXx wYy.-         ( PrimPatch prim-         , Annotate prim-         , Show1 (ModelOf prim)-         , ShrinkModel prim-         , PropagateShrink prim prim-         , ArbitraryPrim prim-         , Shrinkable prim-         , RepoState (ModelOf prim) ~ ApplyState prim-         )-      => prim wXx wYy-      -> [Test]-qc_V3 _ =-  [ testProperty "repo invariants"-    (withSequence (PropR3.prop_repoInvariants :: SequenceProperty (RepoPatchV3 prim)))-  ]-  ++ repoPatchProperties @(RepoPatchV3 prim)-  ++ difficultRepoPatchProperties @(RepoPatchV3 prim)--repoPatchProperties :: forall p.-                       ( ArbitraryRepoPatch p-                       , Show2 p-                       , Show1 (ModelOf p)-                       , CheckedMerge p-                       , ShrinkModel (PrimOf p)-                       , PrimBased p-                       )-                    => [Test]-repoPatchProperties =-  [ testProperty "readPatch/showPatch"-      (withSingle (PropG.showRead :: PatchProperty p))-  , testProperty "readPatch/showPatch (RL)"-      (withSequence (PropG.showRead :: SequenceProperty p))-{- we no longer support inversion for RepoPatches-  , testProperty "invert involution"-      (withSingle (PropG.invertInvolution :: PatchProperty p))-  , testProperty "inverse composition"-      (withPair (PropG.inverseComposition :: PairProperty p))--}-  , testProperty "resolutions don't conflict"-      (withSequence (PropR.propResolutionsDontConflict :: SequenceProperty p))-  ]---- | These properties regularly fail for RepoPatchV2 with the standard test--- case generator when we crank up the number of tests (to e.g. 10000).-difficultRepoPatchProperties :: forall p.-                       ( ArbitraryRepoPatch p-                       , ShrinkModel (PrimOf p)-                       , Show2 p-                       , CheckedMerge p-                       , MightHaveDuplicate p-                       , Show1 (ModelOf p)-                       , PrimBased p-                       )-                    => [Test]-difficultRepoPatchProperties =-  [ testProperty "reorderings are consistent"-      (PropR.propConsistentReorderings @p)-{- we no longer support inversion for RepoPatches-  , testProperty "inverses commute"-      (withPair (PropG.commuteInverses com))-  , testConditional "nontrivial inverses commute"-      (withPair nontrivialCommute)-      (withPair (PropG.commuteInverses com))--}-  , testProperty "recommute"-      (withPair (PropG.recommute com))-  , testConditional "nontrivial recommute"-      (fromNothing . withPair nontrivialCommute)-      (withPair (PropG.recommute com))-  , testConditional "permutivity"-      (fromNothing . withTriple notDuplicatestriple)-      (withTriple (PropG.permutivity com))-  , testConditional "nontrivial permutivity"-      (fromNothing . withTriple (\t -> nontrivialTriple t && notDuplicatestriple t))-      (withTriple (PropG.permutivity com))-  , testProperty "merge either way"-      (withFork (PropG.mergeEitherWay :: MergeProperty p))-{- this test relies on inversion and is thereore only valid for prims-  , testProperty "merge either way valid"-      (withFork (PropG.mergeEitherWayValid :: MergeProperty p))--}-  , testConditional "nontrivial merge either way"-      (fromNothing . withFork nontrivialMerge)-      (withFork (PropG.mergeEitherWay :: MergeProperty p))-  , testProperty "merge commute"-      (withFork (PropG.mergeCommute :: MergeProperty p))-  , testProperty "resolutions are invariant under reorderings"-      (withSequence (PropR.propResolutionsOrderIndependent :: SequenceProperty p))-  ]-  where-    com :: (p :> p) wA wB -> Maybe ((p :> p) wA wB)-    com = commute--pair_properties :: forall p gen-                 . ( Show gen, Arbitrary gen, MightHaveDuplicate p-                   , Commute p, Invert p, ShowPatchBasic p, Eq2 p-                   )-                => PropList (p :> p) gen-pair_properties genname gen =-  properties gen "commute" genname-  [ ("recommute"              , TestCondition (const True)     , TestCheck (PropG.recommute commute)           )-  , ("nontrivial recommute"   , TestCondition nontrivialCommute, TestCheck (PropG.recommute commute)           )-  , ("inverses commute"       , TestCondition (const True)     , TestCheck (PropG.commuteInverses commute)     )-  , ("nontrivial inverses"    , TestCondition nontrivialCommute, TestCheck (PropG.commuteInverses commute)     )-  , ("inverse composition"    , TestCondition (const True)     , TestCheck PropG.inverseComposition            )-  ]--coalesce_properties :: forall p gen-                     . ( Show gen, Arbitrary gen, TestablePrim p-                       , MightBeEmptyHunk p-                       )-                    => PropList (p :> p :> p) gen-coalesce_properties genname gen =-  properties gen "commute" genname-   (case runCoalesceTests @p of-      Just Dict -> [ ("coalesce commutes with commute", TestCondition (const True), TestCheck (PropG.coalesceCommute coalesce)) ]-      Nothing -> [])---- The following properties do not hold for "RepoPatchV2" patches (conflictors and--- duplicates, specifically) .-prim_commute_properties :: forall p gen-                            . (Show gen, Arbitrary gen, Commute p, Invert p, ShowPatchBasic p, Eq2 p)-                           => PropList (p :> p) gen-prim_commute_properties genname gen =-  properties gen "commute" genname-  [ ("square commute law", TestCondition (const True)     , TestCheck (PropG.squareCommuteLaw commute))-  , ("nontrivial square commute law", TestCondition nontrivialCommute, TestCheck (PropG.squareCommuteLaw commute))-  ]--patch_properties :: forall p gen .-                    ( Show gen-                    , Arbitrary gen-                    , Invert p-                    , Eq2 p-                    , ShowPatchBasic p-                    )-                 => PropList p gen-patch_properties genname gen =-  properties gen "patch" genname-  [ ("inverse . inverse is id"  , TestCondition (const True)     , TestCheck PropG.invertInvolution)-  ]--patch_repo_properties-  :: forall p gen-   . ( Show gen, Arbitrary gen-     , Invert p, Apply p, ShowPatchBasic p-     , RepoModel (ModelOf p)-     , RepoState (ModelOf p) ~ ApplyState p-     )-  =>  PropList (WithState p) gen-patch_repo_properties genname gen =-  properties gen "patch/repo" genname-  [ ("invert rollback"          , TestCondition (const True)     , TestCheck PropG.invertRollback)-  ]--merge_properties :: forall p gen .-                    ( Show gen, Arbitrary gen, Commute p-                    , Invert p, Eq2 p, Merge p, ShowPatchBasic p-                    , MightHaveDuplicate p, Check p-                    )-                 => PropList (p :\/: p) gen-merge_properties genname gen =-  properties gen "merge" genname-  [ ("merge either way"           , TestCondition (const True)   , TestCheck PropG.mergeEitherWay      )-  , ("merge either way valid"     , TestCondition (const True)   , TestCheck PropG.mergeEitherWayValid )-  , ("nontrivial merge either way", TestCondition nontrivialMerge, TestCheck PropG.mergeEitherWay      )-  , ("merge commute"              , TestCondition (const True)   , TestCheck PropG.mergeCommute        )-  ]--triple_properties :: forall p gen .-                     ( Show gen, Arbitrary gen, Commute p-                     , Eq2 p, ShowPatchBasic p-                     , MightHaveDuplicate p-                     )-                  => PropList (p :> p :> p) gen-triple_properties genname gen =-  properties gen "triple" genname-  [ ( "permutivity"-    , TestCondition (notDuplicatestriple)-    , TestCheck (PropG.permutivity commute) )-  , ( "nontrivial permutivity"-    , TestCondition (\t -> nontrivialTriple t && notDuplicatestriple t)-    , TestCheck (PropG.permutivity commute) )-  ]--pair_repo_properties-  :: forall p gen .-     ( Show gen-     , Arbitrary gen-     , Commute p-     , Apply p-     , ShowPatchBasic p-     , MightBeEmptyHunk p-     , RepoModel (ModelOf p)-     , RepoState (ModelOf p) ~ ApplyState p-     )-  => PropList (WithState (p :> p)) gen-pair_repo_properties genname gen =-  properties gen "patch/repo" genname-    [ ( "commute is effect preserving"-      , TestCondition (const True)-      , TestCheck (PropG.effectPreserving commute))-    ]- -- tests (either QuickCheck or Unit) that should be run on any type of patch general_patchTests   :: forall p@@ -466,8 +73,10 @@ testSuite :: [Test] testSuite =     [ primTests+    , repoPatchV1Tests     , repoPatchV2Tests     , repoPatchV3Tests+    , Darcs.Test.Patch.Depends.testSuite     , Darcs.Test.Patch.Info.testSuite     , Darcs.Test.Patch.Selection.testSuite     ]@@ -478,6 +87,11 @@       , testGroup "Prim.FileUUID" $ qc_prim @FileUUID.Prim       , testGroup "NamedPrim over V2.Prim" $ qc_named_prim @Prim2       , testGroup "NamedPrim over Prim.FileUUID" $ qc_named_prim @FileUUID.Prim+      ]+    repoPatchV1Tests = testGroup "RepoPatchV1"+      [ testGroup "using V1.Prim wrapper for Prim.V1" $+          unit_V1P1 ++ qc_V1P1 +++          general_patchTests @(RepoPatchV1 Prim1)       ]     repoPatchV2Tests = testGroup "RepoPatchV2"       [ testGroup "using V2.Prim wrapper for Prim.V1" $
harness/Darcs/Test/Patch/Arbitrary/Generic.hs view
@@ -12,36 +12,27 @@   , nontrivialTriple   , nontrivialMerge   , notDuplicatestriple-  , MergeableSequence(..)-  , arbitraryMergeableSequence-  , mergeableSequenceToRL   ) where  import Darcs.Prelude -import Control.Applicative ( (<|>) ) import Data.Constraint (Dict(..))-import Test.QuickCheck  import Darcs.Test.Patch.Arbitrary.Shrink-import Darcs.Test.Patch.Merge.Checked+import Darcs.Test.Patch.Types.Pair ( Pair(..) ) import Darcs.Test.Patch.WithState import Darcs.Test.Patch.RepoModel import Darcs.Test.Patch.V1Model-import Darcs.Test.Util.QuickCheck ( bSized )-import Darcs.Patch.Witnesses.Maybe-import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq-import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Apply ( Apply, ApplyState ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Merge ( Merge(..), mergerFLFL )+import Darcs.Patch.Merge ( Merge(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )-import Darcs.Patch.Prim ( sortCoalesceFL, PrimCanonize, PrimConstruct )+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Prim ( PrimCoalesce, PrimConstruct ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Witnesses.Show@@ -70,8 +61,8 @@   hasDuplicate NilFL = False   hasDuplicate (p :>: ps) = hasDuplicate p || hasDuplicate ps -nontrivialCommute :: (Commute p, Eq2 p) => (p :> p) wX wY -> Bool-nontrivialCommute (x :> y) =+nontrivialCommute :: (Commute p, Eq2 p) => Pair p wX wY -> Bool+nontrivialCommute (Pair (x :> y)) =   case commute (x :> y) of     Just (y' :> x') -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x)     Nothing -> False@@ -109,12 +100,12 @@     where         -- hooks to disable certain kinds of tests for certain kinds of patches -        -- These tests depend on the PrimCanonize class, which may not be+        -- These tests depend on the PrimCoalesce class, which may not be         -- implemented. By passing the implementation in explicitly only where         -- it is available, we can avoid having to have dummy instances that         -- won't be used.-        runCoalesceTests :: Maybe (Dict (PrimCanonize prim))-        default runCoalesceTests :: PrimCanonize prim => Maybe (Dict (PrimCanonize prim))+        runCoalesceTests :: Maybe (Dict (PrimCoalesce prim))+        default runCoalesceTests :: PrimCoalesce prim => Maybe (Dict (PrimCoalesce prim))         runCoalesceTests = Just Dict          -- TODO in practice both hasPrimConstruct and usesV1Model will only work for V1 prims@@ -140,27 +131,6 @@   , ArbitraryPrim prim   ) --- | A witness type that makes the result witness of merging explicit:------  wB    ----> Merged wA wB---   ^           ^---   |           |---   |           |---  wBase ----> wA------ It's quite ad hoc, for example we don't define a type for 'wBase'.-data Merged wA wB---- | A wrapper around 'merge' for FL that checks each individual merge,--- and also returns a more strongly typed witness than the usual existential.-typedMerge-  :: CheckedMerge p-  => (FL p :\/: FL p) wA wB-  -> (FL p wA (Merged wA wB), FL p wB (Merged wA wB))-typedMerge (p :\/: q) =-  case mergerFLFL (checkedMerger merge) (p :\/: q) of-    (q' :/\: p') -> (unsafeCoercePEnd q', unsafeCoercePEnd p')- -- |Given a patch type that contains mergeable patches, such as -- @RepoPatchV1 prim@ or @Named (RepoPatchV1 prim)@, construct the -- equivalent conflict-free types, e.g. @prim@ / @Named prim@ respectively.@@ -178,220 +148,3 @@   primEffect = concatFL . mapFL_FL (primEffect @p)   liftFromPrim = mapFL_FL liftFromPrim --- | This type provides a concrete, pre-merged representation of a sequence--- of patches that might have conflicts once merged. The structure also allows--- for conflict resolutions, e.g. in @SeqMS (ParMS x y) z@, @z@ could be a--- resolution patch.--- Working with the pre-merged patches makes it easier to manipulate the test--- case, e.g. for shrinking.--- Note that although MergeableSequence is parameterised on a patch type @p@--- that needs to support merging, it only explicitly contains primitive--- patches. The merged patches are constructed on-the-fly when the structure--- is used. It's necessary to fix the structure to a specific mergeable patch--- type because otherwise the merged patches could vary, invalidating the--- context of conflict resolution patches like @z@.-data MergeableSequence p wX wY where-  NilMS :: MergeableSequence p wX wX-  SeqMS-    :: MergeableSequence p wX wY-    -> OnlyPrim p wY wZ-    -> MergeableSequence p wX wZ-  ParMS-    :: MergeableSequence p wX wA-    -> MergeableSequence p wX wB-    -> MergeableSequence p wX (Merged wA wB)--instance PrimPatchBase p => PrimPatchBase (MergeableSequence p) where-  type PrimOf (MergeableSequence p) = PrimOf p--instance (CheckedMerge p, PrimBased p) => Effect (MergeableSequence p) where-  effect NilMS = NilFL-  effect (SeqMS ps p) = effect ps +>+ primEffect @p p-  effect (ParMS ms1 ms2) =-    let ps1 = mergeableSequenceToRL ms1-        ps2 = mergeableSequenceToRL ms2-    in case typedMerge (reverseRL ps1 :\/:reverseRL ps2) of-      (ps2', _) -> effect ms1 +>+ effect ps2'---instance-  ( PropagateShrink prim (OnlyPrim p)-  , CheckedMerge p, Effect p, PrimOf p ~ prim-  , Invert prim, PrimCanonize prim-  , PrimBased p-  )-  => PropagateShrink prim (MergeableSequence p) where-  -- Note that the result of propagateShrink is always either-  -- Just (Just2 _ :> _) or Nothing, so we don't need to worry about-  -- the Just (Nothing2 :> _) case in recursive calls.-  propagateShrink (prim :> NilMS) = Just (Just2 NilMS :> Just2 prim)-  propagateShrink (prim :> SeqMS ps p) = do-    Just2 ps' :> mprim' <- propagateShrink (prim :> ps)-    mp' :> mprim'' <- propagateShrinkMaybe (mprim' :> p)-    let result = case mp' of-          Just2 p' -> SeqMS ps' p'-          Nothing2 -> ps'-    return (Just2 result :> mprim'')-  propagateShrink-    ((prim :: prim wA wB) :>-       ParMS (ms1 :: MergeableSequence p wB wD1) (ms2 :: MergeableSequence p wB wD2)) = do-    Just2 (ms1' :: MergeableSequence p wA wC1) :> (mprim1' :: Maybe2 prim wC1 wD1)-      <- propagateShrink (prim :> ms1)-    Just2 (ms2' :: MergeableSequence p wA wC2) :> (mprim2' :: Maybe2 prim wC2 wD2)-      <- propagateShrink (prim :> ms2)-    let-      ms' :: MergeableSequence p wA (Merged wC1 wC2)-      ms' = parMS ms1' ms2'-      ps1  :: FL p wB wD1-      ps2  :: FL p wB wD2-      mergedps1 :: FL p wD2 (Merged wD1 wD2)-      mergedps2 :: FL p wD1 (Merged wD1 wD2)-      ps1' :: FL p wA wC1-      ps2' :: FL p wA wC2-      mergedps1' :: FL p wC2 (Merged wC1 wC2)-      mergedps2' :: FL p wC1 (Merged wC1 wC2)-      ps1  = reverseRL (mergeableSequenceToRL ms1)-      ps2  = reverseRL (mergeableSequenceToRL ms2)-      ps1' = reverseRL (mergeableSequenceToRL ms1')-      ps2' = reverseRL (mergeableSequenceToRL ms2')-      (mergedps2 , mergedps1 ) = typedMerge (ps1  :\/: ps2 )-      (mergedps2', mergedps1') = typedMerge (ps1' :\/: ps2')-      -- Unless the shrinking prim disappears on both branches of the merge,-      -- we'll need to try to recalculate it for the result of the merge - trying-      -- to use propagateShrink a second time wouldn't guarantee the right-      -- contexts. (This is a bit complicated to see, hence all the type signatures-      -- in this function.)-      recalcShrink-        :: prim wX wY-        -> FL p wY (Merged wD1 wD2)-        -> FL p wX (Merged wC1 wC2)-        -> Maybe (Maybe2 prim (Merged wC1 wC2) (Merged wD1 wD2))-      recalcShrink primIn m1 m2 =-        case sortCoalesceFL (invert (effect m2) +>+ primIn :>: effect m1) of-          NilFL -> Just Nothing2-          prim' :>: NilFL -> Just (Just2 prim')-          -- If we don't get 0 or 1 prims, we can't use this result given the type-          -- of propagateShrink as a whole. If that was changed to return an FL we-          -- could use it, but at the cost of more complexity elsewhere.-          _ -> Nothing-    mprim' :: Maybe2 prim (Merged wC1 wC2) (Merged wD1 wD2)-      <--      case (mprim1', mprim2') of-        (Nothing2, Nothing2) -> Just Nothing2-        (Just2 prim1', _) | Just prim'' <- recalcShrink prim1' mergedps2 mergedps2' -> Just prim''-        (_, Just2 prim2') | Just prim'' <- recalcShrink prim2' mergedps1 mergedps1' -> Just prim''-        _ -> Nothing-    return (Just2 ms' :> mprim')--instance (Show2 p, PrimBased p) => Show (MergeableSequence p wX wY) where-  showsPrec _d NilMS = showString "NilMS"-  showsPrec d (SeqMS ms p) =-    showParen (d > appPrec) $ showString "SeqMS " . showsPrec2 (appPrec + 1) ms . showString " " . showsPrec2 (appPrec + 1) p-  showsPrec d (ParMS ms1 ms2) =-    showParen (d > appPrec) $ showString "ParMS " . showsPrec2 (appPrec + 1) ms1 . showString " " . showsPrec2 (appPrec + 1) ms2--instance (Show2 p, PrimBased p) => Show1 (MergeableSequence p wX)-instance (Show2 p, PrimBased p) => Show2 (MergeableSequence p)--type instance ModelOf (MergeableSequence p) = ModelOf p--parMS-  :: MergeableSequence p wX wA-  -> MergeableSequence p wX wB-  -> MergeableSequence p wX (Merged wA wB)-parMS NilMS ms = unsafeCoercePEnd ms-parMS ms NilMS = unsafeCoercePEnd ms-parMS ms1 ms2 = ParMS ms1 ms2--instance Shrinkable (OnlyPrim p) => Shrinkable (MergeableSequence p) where-  shrinkInternally NilMS = []-  shrinkInternally (SeqMS ms p) =-    SeqMS ms <$> shrinkInternally p-      <|>-    flip SeqMS p <$> shrinkInternally ms-  shrinkInternally (ParMS ms1 ms2) =-    parMS ms1 <$> shrinkInternally ms2-      <|>-    flip parMS ms2 <$> shrinkInternally ms1--  shrinkAtStart NilMS = []-  shrinkAtStart (SeqMS NilMS p) = mapFlipped (SeqMS NilMS) <$> shrinkAtStart p-  shrinkAtStart (ParMS {}) = []-  shrinkAtStart (SeqMS (ParMS {}) p) = [FlippedSeal (SeqMS NilMS p)]-  shrinkAtStart (SeqMS ms p) = mapFlipped (flip SeqMS p) <$> shrinkAtStart ms--  shrinkAtEnd NilMS = []-  shrinkAtEnd (SeqMS ms p) =-    Sealed ms:map (mapSeal (SeqMS ms)) (shrinkAtEnd p)-  shrinkAtEnd (ParMS ms1 ms2) =-    do-      Sealed ms2' <- shrinkAtEnd ms2-      return $ Sealed $ parMS ms1 ms2'-     <|>-    do-      Sealed ms1' <- shrinkAtEnd ms1-      return $ Sealed $ parMS ms1' ms2--mergeableSequenceToRL-  :: (CheckedMerge p, PrimBased p)-  => MergeableSequence p wX wY-  -> RL p wX wY-mergeableSequenceToRL NilMS = NilRL-mergeableSequenceToRL (SeqMS ms p) = mergeableSequenceToRL ms :<: liftFromPrim p-mergeableSequenceToRL (ParMS ms1 ms2) =-  let-    ps1 = mergeableSequenceToRL ms1-    ps2 = mergeableSequenceToRL ms2-  in-    case typedMerge (reverseRL ps1 :\/: reverseRL ps2) of-      (ps2', _) -> ps1 +<<+ ps2'---- | Generate an arbitrary sequence of patches, using a generator--- for the underlying patch type and merging.--- The sequence uses a given start state and is bounded by a--- given depth.-arbitraryMergeableSequence-  :: forall model p wX-   . ( RepoModel model-     , CheckedMerge p-     , PrimBased p-     , Apply p, ApplyState p ~ RepoState model-     )-  => (forall wA . model wA -> Gen (Sealed (WithEndState model (OnlyPrim p wA))))-  -> model wX-  -> Int-  -> Gen (Sealed (WithEndState model (MergeableSequence p wX)))-arbitraryMergeableSequence arbitrarySingle = go-  where-    go rm depth-      | depth == 0 = return $ Sealed $ WithEndState NilMS rm-      | otherwise =-        frequency-          [ ( 1-            , do Sealed (WithEndState ms rm') <- go rm (depth - 1)-                 Sealed (WithEndState p rm'') <- arbitrarySingle rm'-                 return $ Sealed $ WithEndState (SeqMS ms p) rm'')-          , ( 3-            , do Sealed (WithEndState ms1 _) <- go rm ((depth + 1) `div` 2)-                 Sealed (WithEndState ms2 _) <- go rm (depth `div` 2)-                 let ps1 = mergeableSequenceToRL ms1-                     ps2 = mergeableSequenceToRL ms2-                 case validateMerge @p (typedMerge (reverseRL ps1 :\/:reverseRL ps2)) of-                   Nothing -> go rm depth-                   Just (ps2', _) ->-                     case repoApply rm (ps1 +>>+ ps2') of-                       OK rm' -> return $ Sealed $ WithEndState (parMS ms1 ms2) rm'-                       Failed msg -> error msg-            )-          ]--instance-  ( RepoModel model-  , Apply p, ApplyState p ~ RepoState model-  , model ~ ModelOf (OnlyPrim p)-  , model ~ ModelOf p-  , CheckedMerge p-  , PrimBased p-  )-  => ArbitraryState (MergeableSequence p) where-  arbitraryState rm = bSized 3 0.035 9 $ arbitraryMergeableSequence arbitraryState rm
harness/Darcs/Test/Patch/Arbitrary/Named.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE UndecidableInstances #-} module Darcs.Test.Patch.Arbitrary.Named   (
harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE OverloadedStrings, UndecidableInstances #-} module Darcs.Test.Patch.Arbitrary.NamedPrim ( aPatchId ) where @@ -15,6 +16,7 @@  import Darcs.Test.Patch.WithState import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Types.Pair ( Pair(..) ) import Darcs.Test.TestOnly.Instance ()  import Darcs.Patch.Witnesses.Maybe@@ -51,6 +53,14 @@     pid <- aPatchId     return $ Sealed $ WithEndState (namedPrim pid p) repo' +  arbitraryStatePair repo = do+    Sealed (WithEndState (Pair (p1:>p2)) repo') <- arbitraryStatePair repo+    pid1 <- aPatchId+    pid2 <- aPatchId+    return $ Sealed $ WithEndState (Pair (namedPrim pid1 p1 :> namedPrim pid2 p2)) repo'++instance (ArbitraryState prim, RepoModel (ModelOf prim)) => ArbitraryWS (NamedPrim prim) where+  arbitraryWS = makeWS2Gen aSmallRepo  instance PropagateShrink prim1 prim2 => PropagateShrink prim1 (PrimWithName n2 prim2) where   propagateShrink (p1 :> PrimWithName n2 p2) = do
− harness/Darcs/Test/Patch/Arbitrary/NamedPrimFileUUID.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Darcs.Test.Patch.Arbitrary.NamedPrimFileUUID () where--import Prelude ()-import Darcs.Prelude--import Test.QuickCheck--import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Prim.Named ( NamedPrim, namedPrim )-import qualified Darcs.Patch.Prim.FileUUID as FileUUID--import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.WithState-import Darcs.Test.Patch.Arbitrary.NamedPrim ( aPatchId )-import qualified Darcs.Test.Patch.Arbitrary.PrimFileUUID as FileUUID-import Darcs.Test.Patch.FileUUIDModel--type Prim = NamedPrim FileUUID.Prim--------------------------------------------------------------------------- Arbitrary instances--aPrimPair :: FileUUIDModel wX-          -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY)-aPrimPair repo = do-  WithEndState (p1:>p2) repo' <- FileUUID.aPrimPair repo-  pid1 <- aPatchId-  pid2 <- aPatchId-  return $ WithEndState (namedPrim pid1 p1 :> namedPrim pid2 p2) repo'---- use the special generator for pairs-arbitraryPair :: Gen (Sealed2 (WithState (Prim :> Prim)))-arbitraryPair = do-  repo <- aSmallRepo-  WithEndState pp repo' <- aPrimPair repo-  return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed2 Prim) where-  arbitrary = makeS2Gen aSmallRepo--instance Arbitrary (Sealed2 (Prim :> Prim)) where-  arbitrary = mapSeal2 wsPatch <$> arbitraryPair--instance Arbitrary (Sealed2 (WithState Prim)) where-  arbitrary = makeWS2Gen aSmallRepo--instance Arbitrary (Sealed2 (WithState (Prim :> Prim))) where-  arbitrary = arbitraryPair
− harness/Darcs/Test/Patch/Arbitrary/NamedPrimV1.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Darcs.Test.Patch.Arbitrary.NamedPrimV1 () where--import Prelude ()-import Darcs.Prelude--import Test.QuickCheck--import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Prim.Named ( NamedPrim, namedPrim )-import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )--import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.WithState-import Darcs.Test.Patch.Arbitrary.NamedPrim ( aPatchId )-import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as V1-import Darcs.Test.Patch.V1Model--type Prim = NamedPrim V2.Prim--------------------------------------------------------------------------- Arbitrary instances--aPrimPair :: V1Model wX-          -> Gen (WithEndState V1Model ((Prim :> Prim) wX) wY)-aPrimPair repo = do-  WithEndState (p1:>p2) repo' <- V1.aPrimPair repo-  pid1 <- aPatchId-  pid2 <- aPatchId-  return $ WithEndState (namedPrim pid1 p1 :> namedPrim pid2 p2) repo'---- use the special generator for pairs-arbitraryPair :: Gen (Sealed2 (WithState (Prim :> Prim)))-arbitraryPair = do-  repo <- aSmallRepo-  WithEndState pp repo' <- aPrimPair repo-  return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed2 Prim) where-  arbitrary = makeS2Gen aSmallRepo--instance Arbitrary (Sealed2 (Prim :> Prim)) where-  arbitrary = mapSeal2 wsPatch <$> arbitraryPair--instance Arbitrary (Sealed2 (WithState Prim)) where-  arbitrary = makeWS2Gen aSmallRepo--instance Arbitrary (Sealed2 (WithState (Prim :> Prim))) where-  arbitrary = arbitraryPair
harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE OverloadedStrings #-} module Darcs.Test.Patch.Arbitrary.PrimFileUUID where @@ -10,6 +11,7 @@  import Test.QuickCheck import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.Types.Pair ( Pair(..) ) import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Unsafe@@ -23,7 +25,6 @@ import qualified Data.ByteString as B import Data.Maybe ( fromJust, isJust ) import qualified Data.Map as M-import Darcs.Util.Hash( Hash(..) )  type instance ModelOf Prim = FileUUIDModel instance ArbitraryPrim Prim where@@ -81,7 +82,7 @@ aDemanifest uuid loc = return $ Demanifest uuid loc  -- | Generates any type of 'Prim' patch, except binary and setpref patches.-aPrim :: FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (Prim wX) wY)+aPrim :: FileUUIDModel wX -> Gen (Sealed (WithEndState FileUUIDModel (Prim wX))) aPrim repo   = do mbFile <- maybeOf repoFiles -- some file, not necessarily manifested        dir <- elements repoDirs -- some directory, not necessarily manifested@@ -95,7 +96,7 @@            whenmanifested = whenjust mbManifested        patch <- frequency                   [ ( whenfile 12, aTextHunk $ fromJust mbFile ) -- edit an existing file-                  , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- edit a new file+                  , ( 2, aTextHunk (fresh, Blob (return "") Nothing) ) -- edit a new file                   , ( whendemanifested 2 -- manifest an existing object                     , aManifest (fromJust mbDemanifested) dir                     )@@ -104,7 +105,7 @@                     )                   ]        let repo' = unFail $ repoApply repo patch-       return $ WithEndState patch repo'+       return $ seal $ WithEndState patch repo'   where       manifested = [ (uuid, (L dirid name)) | (dirid, Directory dir) <- repoDirs                                           , (name, uuid) <- M.toList dir ]@@ -133,7 +134,7 @@ hunkPair _ = error "impossible case"  aPrimPair :: FileUUIDModel wX-          -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY)+          -> Gen (Sealed (WithEndState FileUUIDModel (Pair Prim wX))) aPrimPair repo   = do mbFile <- maybeOf repoFiles        frequency@@ -141,11 +142,15 @@             , do p1 :> p2 <- hunkPair $ fromJust mbFile                  let repo'  = unFail $ repoApply repo  p1                      repo'' = unFail $ repoApply repo' p2-                 return $ WithEndState (p1 :> p2) repo''+                 return $ seal $ WithEndState (Pair (p1 :> p2)) repo''             )           , ( 1-            , do Sealed wesP <- arbitraryState repo-                 return $ unsafeCoerceP1 wesP+            , do+                -- construct the underlying pair directly to avoid any+                -- risk of indirectly calling arbitraryStatePair (which+                -- would cause a loop).+                Sealed (WithEndState pair repo') <- arbitraryState repo+                return $ seal $ WithEndState (Pair pair) repo'             )           ]   where@@ -155,24 +160,8 @@ -- Arbitrary instances  instance ArbitraryState Prim where-  arbitraryState s = seal <$> aPrim s----- use the special generator for pairs-arbitraryPair :: Gen (Sealed2 (WithState (Prim :> Prim)))-arbitraryPair = do-  repo <- aSmallRepo-  WithEndState pp repo' <- aPrimPair repo-  return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed2 Prim) where-  arbitrary = makeS2Gen aSmallRepo--instance Arbitrary (Sealed2 (Prim :> Prim)) where-  arbitrary = mapSeal2 wsPatch <$> arbitraryPair--instance Arbitrary (Sealed2 (WithState Prim)) where-  arbitrary = makeWS2Gen aSmallRepo+  arbitraryState = aPrim+  arbitraryStatePair = aPrimPair -instance Arbitrary (Sealed2 (WithState (Prim :> Prim))) where-  arbitrary = arbitraryPair+instance ArbitraryWS Prim where+  arbitraryWS = makeWS2Gen aSmallRepo
harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} module Darcs.Test.Patch.Arbitrary.PrimV1     ( aPrim     , aPrimPair@@ -19,18 +20,19 @@ import Control.Applicative ( (<|>) ) import Test.QuickCheck import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.Types.Pair ( Pair(..) ) import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), isIdentity )+import Darcs.Patch.Prim ( isIdentity )+import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ) ) import qualified Darcs.Patch.Prim.V1.Core as Prim ( Prim( FP ) ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )  import Darcs.Test.Patch.V1Model import Darcs.Util.Path-import Darcs.Util.Tree ( Tree ) import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )  import Darcs.UI.Commands.Replace ( defaultToks )@@ -203,7 +205,7 @@   n' <- shrink (BC.unpack . encodeWhiteName $ n)   guard (n' /= ".")   guard (not $ null n')-  return $ decodeWhiteName $ BC.pack n'+  either (const []) (:[]) $ decodeWhiteName $ BC.pack n'  aModelShrinkName :: V1Model wX -> [Sealed (Prim.Prim wX)] aModelShrinkName repo = do@@ -234,8 +236,8 @@   -- | 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 :: forall prim wX . (PrimPatch prim, ApplyState prim ~ RepoState V1Model)+      => V1Model wX -> Gen (Sealed (WithEndState V1Model (prim wX))) aPrim repo   = do mbFile <- maybeOf repoFiles        mbEmptyFile <- maybeOf $ filter (isEmpty . snd) repoFiles@@ -272,31 +274,13 @@                     )                   ]        let repo' = unFail $ repoApply repo patch-       return $ WithEndState patch repo'+       return $ seal $ WithEndState patch repo'   where       repoItems = list repo       repoFiles = filterFiles repoItems       repoDirs  = filterDirs repoItems       rootDir   = (anchoredRoot,root repo) -{- [COVERAGE OF aPrim]--  PLEASE,-  if you change something that may affect the coverage of aPrim then-      a) recalculate it, or if that is not possible;-      b) indicate the need to do it.--  Patch type-  -----------  42% hunk-  22% tokreplace-  14% move-   6% rmdir-   6% addfile-   6% adddir-   4% rmfile--}- ---------------------------------------------------------------------- -- *** Pairs of primitive patches @@ -324,7 +308,7 @@              , ModelOf prim ~ V1Model              )           => V1Model wX-          -> Gen (WithEndState V1Model ((prim :> prim) wX) wY)+          -> Gen (Sealed (WithEndState V1Model (Pair prim wX))) aPrimPair repo   = do mbFile <- maybeOf repoFiles        frequency@@ -332,45 +316,21 @@             , do p1 :> p2 <- hunkPairP $ fromJust mbFile                  let repo'  = unFail $ repoApply repo p1                      repo'' = unFail $ repoApply repo' p2-                 return $ WithEndState (p1 :> p2) repo''+                 return $ seal $ WithEndState (Pair (p1 :> p2)) repo''             )           , ( 1-            , do Sealed wesP <- arbitraryState repo-                 return $ unsafeCoerceP1 wesP+            , do+                -- construct the underlying pair directly to avoid any+                -- risk of indirectly calling arbitraryStatePair (which+                -- would cause a loop).+                Sealed (WithEndState pair repo') <- arbitraryState repo+                return $ seal $ WithEndState (Pair pair) repo'             )           ]   where       repoItems = list repo       repoFiles = filterFiles repoItems -{- [COVERAGE OF aPrimPair]--  PLEASE,-  if you change something that may affect the coverage of aPrimPair then-      a) recalculate it, or if that is not possible;-      b) indicate the need to do it.--  Rate of ommutable pairs-  ------------------------  67% commutable--  Commutable coverage (for 1000 tests)-  --------------------  21% hunks-B-  20% hunks-A-  14% file:>dir-  12% file:>move-   8% trivial-FP-   8% hunk:>tok-   4% hunks-D-   3% tok:>tok-   2% hunks-C-   1% move:>move-   1% dir:>move-   1% dir:>dir-   0% emptyhunk:>file--}- ---------------------------------------------------------------------- -- Arbitrary instances @@ -379,22 +339,11 @@ instance ShrinkModel Prim.Prim where   shrinkModelPatch s = aModelShrink s --- use the special generator for pairs-arbitraryPair :: ( PrimPatch prim-                 , ApplyState prim ~ Tree-                 , ArbitraryState prim-                 , ModelOf prim ~ V1Model-                 )-              => Gen (Sealed2 (WithState (prim :> prim)))-arbitraryPair = do-  repo <- aSmallRepo-  WithEndState pp repo' <- aPrimPair repo-  return $ seal2 $ WithState repo pp repo'- -- Prim1  instance ArbitraryState Prim1 where-  arbitraryState s = seal <$> aPrim s+  arbitraryState = aPrim+  arbitraryStatePair = aPrimPair  instance ShrinkModel Prim1 where   shrinkModelPatch s = map (mapSeal V1.Prim) $ shrinkModelPatch s@@ -402,23 +351,14 @@ instance PropagateShrink Prim1 Prim1 where   propagateShrink = propagatePrim --instance Arbitrary (Sealed2 Prim1) where-  arbitrary = makeS2Gen aSmallRepo--instance Arbitrary (Sealed2 (Prim1 :> Prim1)) where-  arbitrary = mapSeal2 wsPatch <$> arbitraryPair--instance Arbitrary (Sealed2 (WithState Prim1)) where-  arbitrary = makeWS2Gen aSmallRepo--instance Arbitrary (Sealed2 (WithState (Prim1 :> Prim1))) where-  arbitrary = arbitraryPair+instance ArbitraryWS Prim1 where+  arbitraryWS = makeWS2Gen aSmallRepo  -- Prim2  instance ArbitraryState Prim2 where-  arbitraryState s = seal <$> aPrim s+  arbitraryState = aPrim+  arbitraryStatePair = aPrimPair  instance ShrinkModel Prim2 where   shrinkModelPatch s = map (mapSeal V2.Prim) $ shrinkModelPatch s@@ -426,15 +366,5 @@ instance PropagateShrink Prim2 Prim2 where   propagateShrink = propagatePrim --instance Arbitrary (Sealed2 Prim2) where-  arbitrary = makeS2Gen aSmallRepo--instance Arbitrary (Sealed2 (Prim2 :> Prim2)) where-  arbitrary = mapSeal2 wsPatch <$> arbitraryPair--instance Arbitrary (Sealed2 (WithState Prim2)) where-  arbitrary = makeWS2Gen aSmallRepo--instance Arbitrary (Sealed2 (WithState (Prim2 :> Prim2))) where-  arbitrary = arbitraryPair+instance ArbitraryWS Prim2 where+  arbitraryWS = makeWS2Gen aSmallRepo
harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs view
@@ -15,9 +15,10 @@  import Darcs.Test.Patch.WithState import Darcs.Test.Patch.RepoModel-import Darcs.Test.Patch.Arbitrary.Generic-  ( mergeableSequenceToRL, MergeableSequence(..),  ArbitraryPrim(..), PrimBased )+import Darcs.Test.Patch.Arbitrary.Generic ( ArbitraryPrim(..), PrimBased ) import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.Types.MergeableSequence ( mergeableSequenceToRL, MergeableSequence(..) )+import Darcs.Test.Patch.Types.Pair ( Pair(..) ) import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Ordered hiding ( Fork ) import Darcs.Patch.Apply ( Apply(..) )@@ -52,11 +53,11 @@  withPair   :: (CheckedMerge p, PrimBased p)-  => (forall wX wY. (p :> p) wX wY -> r)+  => (forall wX wY. Pair p wX wY -> r)   -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r withPair prop (Sealed2 (WithStartState2 _ ms))   = case mergeableSequenceToRL ms of-      _ :<: pp1 :<: pp2 -> Just (prop (pp1 :> pp2))+      _ :<: pp1 :<: pp2 -> Just (prop (Pair (pp1 :> pp2)))       _ -> Nothing  withTriple
harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs view
@@ -15,52 +15,38 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE UndecidableInstances #-} module Darcs.Test.Patch.Arbitrary.RepoPatchV1 (Patch) where  import Prelude () import Darcs.Prelude -import Test.QuickCheck import Control.Exception ( try, evaluate, SomeException )-import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM ) import System.IO.Unsafe -import qualified Data.ByteString as B ( ByteString )-import qualified Data.ByteString.Char8 as BC ( pack )- import Darcs.Patch-import Darcs.Patch.Annotate import Darcs.Patch.V1 () import Darcs.Patch.V1.Core ( RepoPatchV1(..) )-import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )-import Darcs.Patch.Prim.V1.Core ( Prim(..) )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim ) import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) )-import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) -import Darcs.Util.Path  ( AnchoredPath, floatPath, catPaths ) --- This definitely feels a bit weird to be importing Properties here, and--- probably means we want to move this elsewhere, but Darcs.Test.Patch.Check is--- already taken with something apparently only semi-related-import Darcs.Test.Patch.Properties.Check( checkAPatch )-import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate, ArbitraryPrim,PrimBased(..) )+import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate, ArbitraryPrim, PrimBased(..) ) import Darcs.Test.Patch.Arbitrary.RepoPatch import Darcs.Test.Patch.Merge.Checked ( CheckedMerge(..) ) import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf )-import Darcs.Test.Patch.WithState ( PropagateShrink(..) )+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Test.Patch.WithState+  ( PropagateShrink(..)+  , ArbitraryState(..), WithEndState(..)+  )  type Patch = RepoPatchV1 V1.Prim -pp :: Prim wX wY -> Patch wX wY-pp = PP . V1.Prim--class ArbitraryP p where-    arbitraryP :: Gen (Sealed (p wX))- instance-  (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))+  (ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))   => ArbitraryRepoPatch (RepoPatchV1 prim)   where @@ -72,65 +58,6 @@       Left (_ :: SomeException) -> Nothing       Right x -> Just x -{--TODO: there is a lot of overlap in testing between between this module-and Darcs.Test.Patch.QuickCheck--This module tests Prim and V1 patches, and Darcs.Test.Patch.QuickCheck-tests Prim and V2 patches--This module's generator covers a wider set of patch types, but is less-likely to generate conflicts than Darcs.Test.Patch.QuickCheck.--Until this is cleaned up, we take some care that the Arbitrary instances-do not overlap and are only used for tests from the respective-modules.--(There are also tests in other modules that probably depend on the-Arbitrary instances in this module.)--}--instance Arbitrary (Sealed (Prim wX)) where-    arbitrary = arbitraryP--instance Arbitrary (Sealed ((Prim :> Prim) wX)) where-    arbitrary = arbitraryP--instance Arbitrary (Sealed (FL Patch wX)) where-    arbitrary = arbitraryP--instance Arbitrary (Sealed2 (Prim :> Prim)) where-    arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch)) where-    arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :\/: FL Patch)) where-    arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :> FL Patch)) where-    arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :> FL Patch :> FL Patch)) where-    arbitrary = unseal Sealed2 <$> arbitraryP---instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :> p2) where-    arbitraryP = do Sealed p1 <- arbitraryP-                    Sealed p2 <- arbitraryP-                    return (Sealed (p1 :> p2))--instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :\/: p2) where-    arbitraryP = do Sealed p1 <- arbitraryP-                    Sealed p2 <- arbitraryP-                    return (Sealed (unsafeCoercePEnd p1 :\/: p2))--instance ArbitraryP (FL Patch) where-    arbitraryP = sized arbpatch--instance ArbitraryP Prim where-    arbitraryP = onepatchgen- instance MightHaveDuplicate (RepoPatchV1 prim)  type instance ModelOf (RepoPatchV1 prim) = ModelOf prim@@ -140,154 +67,13 @@   primEffect prim = prim :>: NilFL   liftFromPrim = PP -hunkgen :: Gen (Sealed (Prim wX))-hunkgen = do-  i <- frequency [(1,choose (0,5)),(1,choose (0,35)),-                  (2,return 0),(3,return 1),(2,return 2),(1,return 3)]-  j <- frequency [(1,choose (0,5)),(1,choose (0,35)),-                  (2,return 0),(3,return 1),(2,return 2),(1,return 3)]-  if i == 0 && j == 0 then hunkgen-    else Sealed <$>-            liftM4 hunk filepathgen linenumgen-                (replicateM i filelinegen)-                (replicateM j filelinegen)--tokreplacegen :: Gen (Sealed (Prim wX))-tokreplacegen = do-  f <- filepathgen-  o <- tokengen-  n <- tokengen-  if o == n-     then return $ Sealed $ tokreplace f "A-Za-z" "old" "new"-     else return $ Sealed $ tokreplace f "A-Za-z_" o n--twofilegen :: (forall wY . AnchoredPath -> AnchoredPath -> Prim wX wY) -> Gen (Sealed (Prim wX))-twofilegen p = do-  n1 <- filepathgen-  n2 <- filepathgen-  if n1 /= n2 && checkAPatch (p n1 n2)-     then return $ Sealed $ p n1 n2-     else twofilegen p--chprefgen :: Gen (Sealed (Prim wX))-chprefgen = do-  f <- oneof [return "color", return "movie"]-  o <- tokengen-  n <- tokengen-  if o == n then return $ Sealed $ changepref f "old" "new"-            else return $ Sealed $ changepref f o n--simplepatchgen :: Gen (Sealed (Prim wX))-simplepatchgen = frequency [(1,liftM (Sealed . addfile) filepathgen),-                            (1,liftM (Sealed . adddir) filepathgen),-                            (1,liftM3 (\x y z -> Sealed (binary x y z)) filepathgen arbitrary arbitrary),-                            (1,twofilegen move),-                            (1,tokreplacegen),-                            (1,chprefgen),-                            (7,hunkgen)-                           ]--onepatchgen :: Gen (Sealed (Prim wX))-onepatchgen = oneof [simplepatchgen, mapSeal (invert . unsafeCoerceP) `fmap` simplepatchgen]--norecursgen :: Int -> Gen (Sealed (FL Patch wX))-norecursgen 0 = mapSeal (\p -> 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 -> 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 -> pp p :>: NilFL) `fmap` onepatchgen)-                       ]--rawMergeGen :: Int -> Gen (Sealed (FL Patch wX))-rawMergeGen n =   do Sealed p1 <- arbpatch len-                     Sealed p2 <- arbpatch len-                     if checkAPatch (invert p1:>:p2:>:NilFL) &&-                        checkAPatch (invert p2:>:p1:>:NilFL)-                        then case merge (p2 :\/: p1) of-                             _ :/\: p2' -> return (Sealed (unsafeCoercePStart p2'))-                        else rawMergeGen n-    where len = if n < 15 then n`div`3 else 3--mergegen :: Int -> Gen (Sealed (FL Patch wX))-mergegen n = do-  Sealed p1 <- norecursgen len-  Sealed p2 <- norecursgen len-  if checkAPatch (invert p1:>:p2:>:NilFL) &&-         checkAPatch (invert p2:>:p1:>:NilFL)-     then case merge (p2:\/:p1) of-          _ :/\: p2' ->-              if checkAPatch (p1+>+p2')-              then return $ Sealed $ p1+>+p2'-              else error "impossible case"-     else mergegen n-  where len = if n < 15 then n`div`3 else 3--instance Arbitrary B.ByteString where-    arbitrary = liftM BC.pack arbitrary--flatlistgen :: Int -> Gen (Sealed (FL Patch wX))-flatlistgen 0 = return $ Sealed NilFL-flatlistgen n = do Sealed x <- onepatchgen-                   Sealed xs <- flatlistgen (n-1)-                   return (Sealed (pp x :>: xs))--flatcompgen :: Int -> Gen (Sealed (FL Patch wX))-flatcompgen n = do-  Sealed ps <- flatlistgen n-  let myp = regularizePatches $ ps-  if checkAPatch myp-     then return $ Sealed myp-     else flatcompgen n---- resize to size 25, that means we'll get line numbers no greater--- than 1025 using QuickCheck 2.1-linenumgen :: Gen Int-linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3),-                    (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ]--tokengen :: Gen String-tokengen = oneof [return "hello", return "world", return "this",-                  return "is", return "a", return "silly",-                  return "token", return "test"]--toklinegen :: Gen String-toklinegen = liftM unwords $ replicateM 3 tokengen--filelinegen :: Gen B.ByteString-filelinegen = liftM BC.pack $-              frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen),-                         (1,return ""), (1,return "{"), (1,return "}") ]--newtype SafeChar = SS Char-instance Arbitrary SafeChar where-    arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0")--fromSafeChar :: SafeChar -> Char-fromSafeChar (SS s) = s--filepathgen :: Gen AnchoredPath-filepathgen =-  frequency-    [ (1, return $ floatPath "test")-    , (1, return $ floatPath "hello")-    , (1, return $ floatPath "world")-    , (1, floatPath `fmap` map fromSafeChar `fmap` arbitrary)-    , (1, liftM2 catPaths filepathgen filepathgen)-    ]--regularizePatches :: FL Patch wX wY -> FL Patch wX wY-regularizePatches patches = rpint (unsafeCoerceP NilFL) patches-    where -- this reverses the list, which seems odd and causes-          -- the witness unsafety-          rpint :: FL Patch wX wY -> FL Patch wA wB -> FL Patch wX wY-          rpint ok_ps NilFL = ok_ps-          rpint ok_ps (p:>:ps) =-            if checkAPatch (unsafeCoerceP p:>:ok_ps)-            then rpint (unsafeCoerceP p:>:ok_ps) ps-            else rpint ok_ps ps-+-- TODO: this instance only exists because of the history of the V1 QuickCheck tests+-- (qc_V1P1 in D.T.Patch). The QuickCheck tests for V1, V2, V3 etc should be aligned+-- and this instance removed.+instance ArbitraryState prim => ArbitraryState (RepoPatchV1 prim) where+  arbitraryState repo = do+    Sealed (WithEndState prim repo') <- arbitraryState repo+    return (Sealed (WithEndState (PP prim) repo'))+  arbitraryStatePair repo = do+    Sealed (WithEndState (Pair (prim1 :> prim2)) repo') <- arbitraryStatePair repo+    return (Sealed (WithEndState (Pair (PP prim1 :> PP prim2)) repo'))
harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE UndecidableInstances #-} module Darcs.Test.Patch.Arbitrary.RepoPatchV2 () where @@ -6,13 +7,16 @@ import Control.Exception import System.IO.Unsafe -import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate(..), PrimBased(..), ArbitraryPrim )+import Darcs.Test.Patch.Arbitrary.Generic+    ( ArbitraryPrim+    , MightHaveDuplicate(..)+    , PrimBased(..)+    ) import Darcs.Test.Patch.Arbitrary.RepoPatch import Darcs.Test.Patch.Merge.Checked ( CheckedMerge(..) ) import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf ) import Darcs.Test.Patch.WithState ( PropagateShrink ) import Darcs.Patch-import Darcs.Patch.Annotate import Darcs.Patch.V2 ( RepoPatchV2 ) import Darcs.Patch.V2.RepoPatch ( isDuplicate, RepoPatchV2(Normal) ) import Darcs.Patch.Witnesses.Ordered@@ -22,12 +26,12 @@  type instance ModelOf (RepoPatchV2 prim) = ModelOf prim -instance-  (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))-  => ArbitraryRepoPatch (RepoPatchV2 prim)-  where--    notRepoPatchV1 = Just (NotRepoPatchV1 (\case {}))+instance ( ArbitraryPrim prim+         , PrimPatch prim+         , ApplyState prim ~ RepoState (ModelOf prim)+         ) =>+         ArbitraryRepoPatch (RepoPatchV2 prim) where+  notRepoPatchV1 = Just (NotRepoPatchV1 (\case {}))  instance PrimPatch prim => CheckedMerge (RepoPatchV2 prim) where   validateMerge v =@@ -35,7 +39,8 @@       Left (_ :: SomeException) -> Nothing       Right x -> Just x -instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV2 prim) where+instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) =>+         PrimBased (RepoPatchV2 prim) where   type OnlyPrim (RepoPatchV2 prim) = prim   primEffect = (:>: NilFL)   liftFromPrim = Normal
harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE UndecidableInstances, PatternSynonyms #-} module Darcs.Test.Patch.Arbitrary.RepoPatchV3 () where @@ -11,7 +12,6 @@ import Darcs.Test.Patch.WithState ( PropagateShrink )  import Darcs.Patch-import Darcs.Patch.Annotate import Darcs.Patch.Prim.Named import Darcs.Patch.Prim.WithName import Darcs.Patch.V3 ( RepoPatchV3 )@@ -25,7 +25,7 @@ type instance ModelOf (RepoPatchV3 prim) = ModelOf prim  instance-  (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))+  (ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))   => ArbitraryRepoPatch (RepoPatchV3 prim)   where
+ harness/Darcs/Test/Patch/Arbitrary/Sealed.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Test.Patch.Arbitrary.Sealed+  ( ArbitraryS2(..)+  ) where++import Darcs.Patch.Witnesses.Sealed+  ( Sealed2(..)+  )++import Test.QuickCheck++class ArbitraryS2 p where+  arbitraryS2 :: Gen (Sealed2 p)+  shrinkS2 :: Sealed2 p -> [Sealed2 p]+  shrinkS2 _ = []++instance ArbitraryS2 p => Arbitrary (Sealed2 p) where+  arbitrary = arbitraryS2+  shrink = shrinkS2
harness/Darcs/Test/Patch/Check.hs view
@@ -188,8 +188,7 @@      -- Crude way to make it inconsistent and return false:      else assertNot $ FileEx f --- | Replaces a filename by another in all paths. Returns True if the repository---   is consistent, False if it is not.+-- | Replace a filename by another in all paths. doSwap :: AnchoredPath -> AnchoredPath -> PatchCheck () doSwap f f' = modify map_sw   where sw (FileEx a) | f  `isPrefix` a = FileEx $ movedirfilename f f' a@@ -204,10 +203,10 @@         map_sw (P ks nots) = P (map sw ks) (map sw nots)  -- | Assert a property about the repository. If the property is already present--- in the repo state, nothing changes, and the function returns True. If it is--- not present yet, it is added to the repo state, and the function is True. If--- the property is already in the list of properties that do not hold for the--- repo, the state becomes inconsistent, and the function returns false.+-- in the repo state, nothing changes, otherwise it is added to the list of+-- properties that hold for the repo state. If the property is in the list of+-- properties that do not hold for the repo, an inconsistency exception is+-- thrown. assert :: Prop -> PatchCheck () assert p = do     P ks nots <- get@@ -217,8 +216,8 @@              then isValid              else put (P (p:ks) nots) --- | Like @assert@, but negatively: state that some property must not hold for---   the current repo.+-- | Like 'assert', but negatively: state that some property must not hold for+-- the current repo. assertNot :: Prop -> PatchCheck () assertNot p = do     P ks nots <- get@@ -230,14 +229,12 @@  -- | Remove a property from the list of properties that do not hold for this -- repo (if it's there), and add it to the list of properties that hold.--- Returns False if the repo is inconsistent, True otherwise. changeToTrue :: Prop -> PatchCheck () changeToTrue p = modify filter_nots   where filter_nots (P ks nots) = P (p:ks) (filter (p /=) nots)  -- | Remove a property from the list of properties that hold for this repo (if -- it's in there), and add it to the list of properties that do not hold.--- Returns False if the repo is inconsistent, True otherwise. changeToFalse :: Prop -> PatchCheck () changeToFalse p = do     modify filter_ks
+ harness/Darcs/Test/Patch/Depends.hs view
@@ -0,0 +1,57 @@+module Darcs.Test.Patch.Depends ( testSuite ) where++import Darcs.Prelude++import Darcs.Patch.Depends+import Darcs.Patch.Set++import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..)  )++import Darcs.Patch.V2 ( RepoPatchV2 )+import qualified Darcs.Patch.V2.Prim as V2++import Darcs.Patch.Named ( infopatch )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, info )+import Darcs.Patch.Info ( PatchInfo, rawPatchInfo )+import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..) )++import Darcs.Util.Path ( unsafeFloatPath )++import Darcs.Test.TestOnly.Instance ()++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertFailure)++type Patch = RepoPatchV2 V2.Prim++testSuite :: Test+testSuite = testGroup "Darcs.Patch.Depends" $+  [ test1+  ]++data WA+data WB++test1 :: Test+test1 = testCase "findCommonWithThem: \"them\" patch contents should not be inspected" $ do+  let+    mkPatch :: PatchInfo -> FL V2.Prim wA wB -> PatchInfoAnd Patch wA wB+    mkPatch pi ps = piap pi (infopatch pi ps)++    p1info = rawPatchInfo "1999" "p1" "harness" [] False+    p1 = mkPatch p1info (V2.Prim (FP (unsafeFloatPath "foo") AddFile) :>: NilFL)+    set1 :: PatchSet Patch Origin WA+    set1 = PatchSet NilRL (NilRL :<: p1)++    p2info = rawPatchInfo "1999" "p2" "harness" [] False+    p2 = piap p2info (error "patch p2 content should not be read")+    p1' = piap p1info (error "patch p1' content should not be read")+    set2 :: PatchSet Patch Origin WB+    set2 = PatchSet NilRL (NilRL :<: p2 :<: p1')++  case findCommonWithThem set1 set2 of+    PatchSet NilRL (NilRL :<: p1res) :> NilFL+      | info p1res == p1info -> return ()+      | otherwise -> assertFailure $ "findCommonWithThem failed: got info " ++ show (info p1res)+    _ -> assertFailure $ "findCommonWithThem failed: unexpected structure"
harness/Darcs/Test/Patch/Examples/Set1.hs view
@@ -15,6 +15,7 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. +{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE OverloadedStrings #-} module Darcs.Test.Patch.Examples.Set1        ( knownCommutes, knownCantCommutes, knownMerges@@ -40,13 +41,14 @@ import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import Darcs.Test.Patch.Properties.Check( checkAPatch )+import Darcs.Test.Patch.Types.Pair ( Pair(..) ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( unseal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )-import Darcs.Util.Path ( AnchoredPath, floatPath )+import Darcs.Util.Path ( AnchoredPath, unsafeFloatPath )  instance IsString AnchoredPath where-  fromString = floatPath+  fromString = unsafeFloatPath  type Patch = V1.RepoPatchV1 V1.Prim @@ -123,20 +125,20 @@ -- the result gives us patch A and patch B again.  The set of patches (A,B) -- is chosen from the set of all pairs of test patches by selecting those which -- commute with one another.-commutePairs :: [(FL Patch :> FL Patch) wX wY]+commutePairs :: [Pair (FL Patch) wX wY] commutePairs =-  take 200 [(p1:>p2)|+  take 200 [Pair (p1:>p2)|             p1<-testPatches,             p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatches,             commute (p1:>p2) /= Nothing] -primitiveCommutePairs :: [(FL Patch :> FL Patch) wX wY]+primitiveCommutePairs :: [Pair (FL Patch) wX wY] primitiveCommutePairs =-  [(p2:>p1)|+  [Pair (p2:>p1)|    p1<-primitiveTestPatches,    p2<-primitiveTestPatches,-   commute (p2:>p1) /= Nothing,-   checkAPatch (p2:>:p1:>:NilFL)]+   checkAPatch (p2:>:p1:>:NilFL),+   commute (p2:>p1) /= Nothing]  -- ---------------------------------------------------------------------- -- * Commute tests
harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs view
@@ -16,6 +16,9 @@ -- Boston, MA 02110-1301, USA.  {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module Darcs.Test.Patch.Examples.Set2Unwitnessed        ( primPermutables, primPatches        , commutables, commutablesFL@@ -54,7 +57,7 @@ import Darcs.Test.Patch.V1Model ( V1Model, Content                                 , makeRepo, makeFile) import Darcs.Test.Patch.WithState ( WithStartState(..) )-import Darcs.Util.Path ( AnchoredPath, floatPath, makeName )+import Darcs.Util.Path ( AnchoredPath, unsafeFloatPath, makeName ) import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim ) import Darcs.Patch.Merge ( Merge ) import Darcs.Test.Patch.Arbitrary.PatchTree@@ -66,7 +69,7 @@     )  instance IsString AnchoredPath where-  fromString = floatPath+  fromString = unsafeFloatPath   -- import Debug.Trace
harness/Darcs/Test/Patch/Examples/Unwind.hs view
@@ -32,6 +32,8 @@ import Darcs.Test.Patch.Arbitrary.PrimV1 () import Darcs.Test.Patch.Arbitrary.RepoPatch import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Types.MergeableSequence+    ( MergeableSequence(..) ) import Darcs.Test.Patch.V1Model import Darcs.Test.Patch.WithState import Darcs.Test.TestOnly.Instance ()@@ -68,7 +70,7 @@  example1   :: forall p-   . (FromPrim p, PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)    => Sealed2 (WithStartState2 (MergeableSequence (Named p))) example1 =   Sealed2@@ -88,7 +90,7 @@  example2   :: forall p-   . (FromPrim p, PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)    => Sealed2 (WithStartState2 (MergeableSequence (Named p))) example2 =   let s3,s4 :: forall s . IsString s => [s]@@ -119,7 +121,7 @@  example3   :: forall p-   . (FromPrim p, PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)    => Sealed2 (WithStartState2 (MergeableSequence (Named p))) example3 =   let@@ -198,7 +200,7 @@  example4   :: forall p-   . (FromPrim p, PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)    => Sealed2 (WithStartState2 (MergeableSequence (Named p))) example4 =   case example4guts @p of
harness/Darcs/Test/Patch/FileUUIDModel.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE OverloadedStrings #-}  -- | Repository model@@ -7,7 +8,6 @@   , repoApply   , emptyFile   , emptyDir-  , nullRepo   , root, rootId   , repoObjects, repoIds   , aFilename, aDirname@@ -31,7 +31,6 @@ import Darcs.Patch.Witnesses.Show  import Darcs.Util.Path ( Name, makeName )-import Darcs.Util.Hash( Hash(..) )  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC@@ -40,7 +39,6 @@ import Test.QuickCheck   ( Arbitrary(..)   , Gen, choose, vectorOf, frequency, oneof )--- import Text.Show.Pretty ( ppShow )  ---------------------------------------------------------------------- -- * Model definition@@ -54,7 +52,11 @@   show (Directory l) = show l   show (Blob c _) = show c -deriving instance Eq (Object Fail)+instance Eq (Object Fail) where+  Blob _ (Just h1) == Blob _ (Just h2) = h1 == h2+  Blob (Right c1) _ == Blob (Right c2) _ = c1 == c2+  Directory m1 == Directory m2 = m1 == m2+  _ == _ = False  instance Show (FileUUIDModel wX) where   show repo = "FileUUIDModel " ++ show (repoObjects repo)@@ -70,13 +72,8 @@         put k o = return $ objectMap (M.insert k o m)         get k = return $ M.lookup k m -{--emptyRepo :: FileUUIDModel wX-emptyRepo = FileUUIDModel (objectMap $ M.singleton rootId emptyDir)--}- emptyFile :: (Monad m) => Object m-emptyFile = Blob (return B.empty) NoHash+emptyFile = Blob (return B.empty) Nothing  emptyDir :: Object m emptyDir = Directory M.empty@@ -84,9 +81,6 @@ ---------------------------------------------------------------------- -- * Queries -nullRepo :: FileUUIDModel wX -> Bool-nullRepo repo = repoIds repo == [rootId]- rootId :: UUID rootId = UUID "ROOT" @@ -113,9 +107,6 @@ nonEmptyRepoObjects = filter (not . isEmpty . snd) . repoObjects  ------------------------------------------------------------------------- * Comparing repositories------------------------------------------------------------------------ -- * QuickCheck generators  -- Testing code assumes that aFilename and aDirname generators @@ -154,7 +145,7 @@                 BC.intercalate "\n" <$> vectorOf n aLine  aFile :: (Monad m) => Gen (Object m)-aFile = aContent >>= \c -> return $ Blob (return c) NoHash+aFile = aContent >>= \c -> return $ Blob (return c) Nothing  aDir :: (Monad m) => [UUID] -> [UUID] -> Gen [(UUID, Object m)] aDir [] _ = return []@@ -207,7 +198,7 @@                   dirsNo <- frequency [(3, return 1), (1, return 0)]                   aRepo filesNo dirsNo   repoApply (FileUUIDModel state) patch = FileUUIDModel <$> applyToState patch state-  showModel = show -- ppShow+  showModel = show   eqModel r1 r2 = nonEmptyRepoObjects r1 == nonEmptyRepoObjects r2  instance Arbitrary (Sealed FileUUIDModel) where
harness/Darcs/Test/Patch/Info.hs view
@@ -17,6 +17,8 @@  -- | This module contains tests for the code in Darcs.Patch.Info. Most of them --   are about the UTF-8-encoding of patch metadata.++{-# OPTIONS_GHC -Wno-orphans #-} module Darcs.Test.Patch.Info ( testSuite ) where  import Prelude hiding ( pi )@@ -40,8 +42,8 @@  import Darcs.Patch.Info     ( PatchInfo(..), rawPatchInfo, showPatchInfo, readPatchInfo-    , piLog, piAuthor, piName, validDate, validLog, validAuthor-    , validDatePS, validLogPS, validAuthorPS, piDateString+    , piLog, piAuthor, piName, validLog, validAuthor+    , validLogPS, validAuthorPS, piDateString     ) import Darcs.Test.TestOnly.Instance () import Darcs.Util.Parser ( parse )@@ -49,6 +51,7 @@ import Darcs.Util.ByteString     ( decodeLocale, packStringToUTF8, unpackPSFromUTF8, linesPS ) import Darcs.Util.Printer ( renderPS )+import Darcs.Util.IsoDate (showIsoDateTime, theBeginning)  testSuite :: Test testSuite = testGroup "Darcs.Patch.Info"@@ -112,10 +115,10 @@ -- (the added junk will be different on each call). arbitraryUTF8PatchInfo :: Gen PatchInfo arbitraryUTF8PatchInfo = do-    d <- arbitrary `suchThat` validDate+    let d = showIsoDateTime theBeginning     n <- (asString `fmap` arbitrary) `suchThat` validLog     a <- (asString `fmap` arbitrary) `suchThat` validAuthor-    l <- lines `fmap` scale (* 2) arbitrary+    l <- lines `fmap` scale (* 2) (asString <$> arbitrary)     junk <- generateJunk     i <- arbitrary     return $ rawPatchInfo d n a (l ++ [junk]) i@@ -125,7 +128,7 @@ --   inverted" setting. arbitraryUnencodedPatchInfo :: Gen PatchInfo arbitraryUnencodedPatchInfo = do-    d <- arbitraryByteString `suchThat` validDatePS+    let d = BC.pack (showIsoDateTime theBeginning)     n <- arbitraryByteString `suchThat` validLogPS     a <- arbitraryByteString `suchThat` validAuthorPS     l <- linesPS `fmap` scale (* 2) arbitraryByteString
harness/Darcs/Test/Patch/Merge/Checked.hs view
@@ -11,6 +11,7 @@ import Darcs.Patch.Invert import Darcs.Patch.Merge import Darcs.Patch.Named+import Darcs.Patch.Permutations ( (=\~/=) )  import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered@@ -65,7 +66,9 @@ checkMerge (p :\/: q) (q' :/\: p')   -- TODO this check doesn't work at the moment - try to enable it and see if it makes   -- sense to keep or not.-  | False, NotEq <- (p :>: q' :>: NilFL) =\/= (q :>: p' :>: NilFL) =+  -- The convoluted guard False==True is to avoid a warning as the pattern match checker+  -- knows that False makes a guard unreachable.+  | False==True, NotEq <- (p :>: q' :>: NilFL) =\~/= (q :>: p' :>: NilFL) =       error "internal error: merge didn't produce equivalent sequences"   | NotEq <- squashes (effect p +>+ effect q' +>+ invert (effect q +>+ effect p')) =       error "internal error: merge didn't produce equivalent effects"
+ harness/Darcs/Test/Patch/Properties.hs view
@@ -0,0 +1,464 @@+--  Copyright (C) 2002-2005,2007 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++-- UndecidableInstances was added because GHC 8.6 needed it+-- even though GHC 8.2 didn't+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Properties+  ( unit_V1P1+  , unit_V2P1+  , qc_V1P1+  , qc_V2+  , qc_V3+  , qc_prim+  , qc_named_prim+  ) where++import Darcs.Prelude++import Data.Constraint ( Dict(..) )+import Data.Maybe ( fromMaybe )+import Test.Framework ( Test )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck( Arbitrary(..) )++import Darcs.Test.Util.TestResult ( TestResult, maybeFailed )+import Darcs.Test.Patch.Utils+    ( PropList+    , TestCheck(..)+    , TestCondition(..)+    , TestGenerator(..)+    , properties+    , testCases+    , testConditional+    )++import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq ( Eq2, unsafeCompare )+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.FromPrim ( PrimOf, FromPrim(..) )+import Darcs.Patch.Prim ( PrimPatch, coalesce )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim )+import Darcs.Patch.Prim.Named ( NamedPrim )+import Darcs.Patch.V1 ( RepoPatchV1 )+import Darcs.Patch.V2.RepoPatch ( isConsistent, isForward, RepoPatchV2 )+import Darcs.Patch.V3 ( RepoPatchV3 )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Apply( Apply, ApplyState )+import Darcs.Patch.Merge ( Merge )++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Named ()+import Darcs.Test.Patch.Arbitrary.PatchTree+import Darcs.Test.Patch.Arbitrary.PrimFileUUID()+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Arbitrary.RepoPatchV1 ()+import Darcs.Test.Patch.Arbitrary.RepoPatchV2 ()+import Darcs.Test.Patch.Arbitrary.RepoPatchV3 ()+import Darcs.Test.Patch.Arbitrary.PrimV1 ()+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Test.Patch.WithState+    ( PropagateShrink+    , ShrinkModel+    , WithState(..)+    , ArbitraryWS(..)+    )++import qualified Darcs.Test.Patch.Examples.Set1 as Ex+import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU++import Darcs.Test.Patch.Properties.Check( Check(..) )+import Darcs.Test.Patch.Properties.Generic ( PatchProperty, MergeProperty, SequenceProperty )+import qualified Darcs.Test.Patch.Properties.Generic as PropG+import qualified Darcs.Test.Patch.Properties.RepoPatch as PropR+import qualified Darcs.Test.Patch.Properties.RepoPatchV3 as PropR3+import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU+import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1+import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2++import Darcs.Test.Patch.Types.Triple (Triple(..))++import qualified Darcs.Test.Patch.WSub as WSub++type Prim2 = V2.Prim++unit_V1P1:: [Test]+unit_V1P1 =+  [ testCases "known commutes" Prop1.checkCommute Ex.knownCommutes+  , testCases "known non-commutes" Prop1.checkCantCommute Ex.knownCantCommutes+  , testCases "known merges" Prop1.checkMerge Ex.knownMerges+  , testCases "known merges (equiv)" Prop1.checkMergeEquiv Ex.knownMergeEquivs+  , testCases "known canons" Prop1.checkCanon Ex.knownCanons+  , testCases "merge swaps" Prop1.checkMergeSwap Ex.mergePairs2+  , testCases "the patch validation works" Prop1.tTestCheck Ex.validPatches+  , testCases "commute/recommute" (PropG.recommute commute) Ex.commutePairs+  , testCases "merge properties: merge either way valid" PropG.mergeEitherWayValid Ex.mergePairs+  , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs+  , testCases "primitive patch IO functions" (Prop1.tShowRead unsafeCompare) Ex.primitiveTestPatches+  , testCases "IO functions (test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatches+  , testCases "IO functions (named test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatchesNamed+  , testCases "primitive commute/recommute" (PropG.recommute commute) Ex.primitiveCommutePairs+  ]++unit_V2P1 :: [Test]+unit_V2P1 =+  [ testCases "coalesce commute" (PropU.coalesceCommute WSub.coalesce) ExU.primPermutables+  , testCases "prim recommute" (PropU.recommute WSub.commute) ExU.commutables+  , testCases "square commute law" (PropU.squareCommuteLaw WSub.commute) ExU.commutables+  , testCases "prim inverses commute" (PropU.commuteInverses WSub.commute) ExU.commutables+  , testCases "FL prim recommute" (PropU.recommute WSub.commute) ExU.commutablesFL+  , testCases "FL square commute law" (PropU.squareCommuteLaw WSub.commute) ExU.commutablesFL+  , testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL+  , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(Prim2 WSub.:> Prim2) wX wY])+  , testCases "read and show work on Prim" PropU.showRead ExU.primPatches+  , testCases "read and show work on RepoPatchV2" PropU.showRead ExU.repov2Patches+  , testCases "example flattenings work" (PropR.propConsistentTreeFlattenings fromPrim2) ExU.repov2PatchLoopExamples+  , testCases "V2 merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.repov2Mergeables+  , testCases "V2 merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.repov2Mergeables+  , testCases "V2 merge output is forward" (PropU.mergeConsistent isForward) ExU.repov2Mergeables+  , testCases "V2 merge output consistent" (PropU.mergeConsistent isConsistent) ExU.repov2Mergeables+  , testCases "V2 merge either way" PropU.mergeEitherWay ExU.repov2Mergeables+  , testCases "V2 merge and commute" PropU.mergeCommute ExU.repov2Mergeables++  , testCases "V2 recommute" (PropU.recommute WSub.commute) ExU.repov2Commutables+  , testCases "V2 inverses commute" (PropU.commuteInverses WSub.commute) ExU.repov2Commutables+  , testCases "V2 permutivity" (PropU.permutivity WSub.commute) ExU.repov2NonduplicateTriples+  ]+  where+    fromPrim2 :: PropR.FromPrimT RepoPatchV2 Prim2+    fromPrim2 = fromAnonymousPrim++arbitraryThing :: TestGenerator thing (Sealed2 thing)+arbitraryThing = TestGenerator (\f p -> Just (unseal2 f p))++arbitraryWSThing :: TestGenerator thing (Sealed2 (WithState thing))+arbitraryWSThing = TestGenerator (\f wsp -> Just (unseal2 (f . wsPatch) wsp))++qc_prim :: forall prim.+           ( TestablePrim prim+           , Show2 prim+           , Show1 (ModelOf prim)+           , MightBeEmptyHunk prim+           , MightHaveDuplicate prim+           , ArbitraryWS prim+           ) => [Test]+qc_prim =+  [testProperty "prim pair coverage" (unseal2 (PropG.propPrimPairCoverage @prim . wsPatch))] +++  -- The following fails because of setpref patches:+  -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc)+  (case runCoalesceTests @prim of+    Just Dict ->+      [ testProperty "prim coalesce effect preserving"+        (unseal2 $ PropG.coalesceEffectPreserving (fmap maybeToFL . coalesce) :: Sealed2 (WithState (Pair prim)) -> TestResult)+      ]+    Nothing -> [])+    ++ concat+  [ pair_properties         @prim      "arbitrary"    arbitraryWSThing+  , pair_properties         @(FL prim) "arbitrary FL" arbitraryWSThing+  , coalesce_properties     @prim      "arbitrary"    arbitraryWSThing+  , prim_commute_properties @prim      "arbitrary"    arbitraryWSThing+  , prim_commute_properties @(FL prim) "arbitrary FL" arbitraryWSThing+  , patch_properties        @prim      "arbitrary"    arbitraryWSThing+  , patch_properties        @(FL prim) "arbitrary FL" arbitraryWSThing+  , patch_repo_properties   @prim      "arbitrary"    arbitraryThing+  , patch_repo_properties   @(FL prim) "arbitrary FL" arbitraryThing+  , pair_repo_properties    @prim      "arbitrary"    arbitraryThing+  , pair_repo_properties    @(FL prim) "arbitrary FL" arbitraryThing+  , triple_properties       @prim      "arbitrary"    arbitraryWSThing+  , [ testProperty "readPatch/showPatch"+      (unseal2 $ (PropG.showRead . wsPatch) :: Sealed2 (WithState prim) -> TestResult)+    , testProperty "readPatch/showPatch (FL)"+      (unseal2 $ (PropG.showRead . wsPatch) :: Sealed2 (WithState (FL prim)) -> TestResult)+    ]+  ]++qc_named_prim :: forall prim.+                 ( TestablePrim prim+                 , Show2 prim+                 , Show1 (ModelOf (NamedPrim prim))+                 , MightBeEmptyHunk prim+                 ) => [Test]+qc_named_prim =+  qc_prim @(NamedPrim prim) +++  [ testProperty+      "prim inverse doesn't commute"+      (unseal2 $ (PropG.inverseDoesntCommute . wsPatch) :: Sealed2 (WithState (NamedPrim prim)) -> TestResult)+  ]+++qc_V1P1 :: [Test]+qc_V1P1 =+  repoPatchProperties @(RepoPatchV1 V1.Prim) +++  [ testProperty "commuting by patch and its inverse is ok" (Prop2.propCommuteInverse . mapSeal2 (getPair . wsPatch))+  , testProperty "a patch followed by its inverse is identity" (Prop2.propPatchAndInverseIsIdentity . mapSeal2 (getPair . wsPatch))+  , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough+  , testProperty "commutes are equivalent" (Prop2.propCommuteEquivalency . mapSeal2 (getPair . wsPatch))+  , testProperty "merges are valid" Prop2.propMergeValid+  , testProperty "inverses being valid" (Prop2.propInverseValid . mapSeal2 wsPatch)+  , testProperty "other inverse being valid" (Prop2.propOtherInverseValid . mapSeal2 wsPatch)+  -- The patch generator isn't smart enough to generate correct test cases for+  -- the following: (which will be obsoleted soon, anyhow)+  -- , testProperty "the order dependence of unravel" Prop.propUnravelOrderIndependent+  -- , testProperty "the unravelling of three merges" Prop.propUnravelThreeMerge+  -- , testProperty "the unravelling of a merge of a sequence" Prop.propUnravelSeqMerge+  , testProperty "the order of commutes" (Prop2.propCommuteEitherOrder . mapSeal2 (getTriple . wsPatch))+  , testProperty "commute either way" (Prop2.propCommuteEitherWay . mapSeal2 (getPair . wsPatch))+  , testProperty "the double commute" (Prop2.propCommuteTwice . mapSeal2 (getPair . wsPatch))+  , testProperty "merges commute and are well behaved" Prop2.propMergeIsCommutableAndCorrect+  , testProperty "merges can be swapped" Prop2.propMergeIsSwapable+  ]++qc_V2 :: forall prim wXx wYy.+         ( PrimPatch prim+         , Show1 (ModelOf prim)+         , ShrinkModel prim+         , PropagateShrink prim prim+         , ArbitraryPrim prim+         , RepoState (ModelOf prim) ~ ApplyState prim+         )+      => prim wXx wYy -> [Test]+qc_V2 _ =+  [ testProperty "with quickcheck that patches are consistent"+    (withSingle consistent)+  ]+  ++ repoPatchProperties @(RepoPatchV2 prim)+  ++ concat+  [ merge_properties   @(RepoPatchV2 prim) "tree" (TestGenerator mergePairFromTree)+  , merge_properties   @(RepoPatchV2 prim) "twfp" (TestGenerator mergePairFromTWFP)+  , pair_properties    @(RepoPatchV2 prim) "tree" (TestGenerator (\handle -> commutePairFromTree (handle . Pair)))+  , pair_properties    @(RepoPatchV2 prim) "twfp" (TestGenerator (\handle -> commutePairFromTWFP (handle . Pair)))+  , patch_properties   @(RepoPatchV2 prim) "tree" (TestGenerator patchFromTree)+  , triple_properties  @(RepoPatchV2 prim) "tree" (TestGenerator (\handle -> commuteTripleFromTree (handle . Triple)))+  ]+  where+    consistent :: RepoPatchV2 prim wX wY -> TestResult+    consistent = maybeFailed . isConsistent++qc_V3 :: forall prim wXx wYy.+         ( PrimPatch prim+         , Show1 (ModelOf prim)+         , ShrinkModel prim+         , PropagateShrink prim prim+         , ArbitraryPrim prim+         , RepoState (ModelOf prim) ~ ApplyState prim+         )+      => prim wXx wYy+      -> [Test]+qc_V3 _ =+  [ testProperty "repo invariants"+    (withSequence (PropR3.prop_repoInvariants :: SequenceProperty (RepoPatchV3 prim)))+  ]+  ++ repoPatchProperties @(RepoPatchV3 prim)+  ++ difficultRepoPatchProperties @(RepoPatchV3 prim)++repoPatchProperties :: forall p.+                       ( ArbitraryRepoPatch p+                       , Show2 p+                       , Show1 (ModelOf p)+                       , CheckedMerge p+                       , ShrinkModel (PrimOf p)+                       , PrimBased p+                       )+                    => [Test]+repoPatchProperties =+  [ testProperty "readPatch/showPatch"+      (withSingle (PropG.showRead :: PatchProperty p))+  , testProperty "readPatch/showPatch (RL)"+      (withSequence (PropG.showRead :: SequenceProperty p))+{- we no longer support inversion for RepoPatches+  , testProperty "invert involution"+      (withSingle (PropG.invertInvolution :: PatchProperty p))+  , testProperty "inverse composition"+      (withPair (PropG.inverseComposition :: PairProperty p))+-}+  , testProperty "resolutions don't conflict"+      (withSequence (PropR.propResolutionsDontConflict :: SequenceProperty p))+  ]++-- | These properties regularly fail for RepoPatchV2 with the standard test+-- case generator when we crank up the number of tests (to e.g. 10000).+difficultRepoPatchProperties :: forall p.+                       ( ArbitraryRepoPatch p+                       , ShrinkModel (PrimOf p)+                       , Show2 p+                       , CheckedMerge p+                       , MightHaveDuplicate p+                       , Show1 (ModelOf p)+                       , PrimBased p+                       )+                    => [Test]+difficultRepoPatchProperties =+  [ testProperty "reorderings are consistent"+      (PropR.propConsistentReorderings @p)+{- we no longer support inversion for RepoPatches+  , testProperty "inverses commute"+      (withPair (PropG.commuteInverses com))+  , testConditional "nontrivial inverses commute"+      (withPair nontrivialCommute)+      (withPair (PropG.commuteInverses com))+-}+  , testProperty "recommute"+      (withPair (PropG.recommute com))+  , testConditional "nontrivial recommute"+      (fromMaybe False . withPair nontrivialCommute)+      (withPair (PropG.recommute com))+  , testConditional "permutivity"+      (fromMaybe False . withTriple notDuplicatestriple)+      (withTriple (PropG.permutivity com))+  , testConditional "nontrivial permutivity"+      (fromMaybe False . withTriple (\t -> nontrivialTriple t && notDuplicatestriple t))+      (withTriple (PropG.permutivity com))+  , testProperty "merge either way"+      (withFork (PropG.mergeEitherWay :: MergeProperty p))+{- this test relies on inversion and is thereore only valid for prims+  , testProperty "merge either way valid"+      (withFork (PropG.mergeEitherWayValid :: MergeProperty p))+-}+  , testConditional "nontrivial merge either way"+      (fromMaybe False . withFork nontrivialMerge)+      (withFork (PropG.mergeEitherWay :: MergeProperty p))+  , testProperty "merge commute"+      (withFork (PropG.mergeCommute :: MergeProperty p))+  , testProperty "resolutions are invariant under reorderings"+      (withSequence (PropR.propResolutionsOrderIndependent :: SequenceProperty p))+  ]+  where+    com :: (p :> p) wA wB -> Maybe ((p :> p) wA wB)+    com = commute++pair_properties :: forall p gen+                 . ( Show gen, Arbitrary gen, MightHaveDuplicate p+                   , Commute p, Invert p, ShowPatchBasic p, Eq2 p+                   )+                => PropList (Pair p) gen+pair_properties genname gen =+  properties gen "commute" genname+  [ ("recommute"              , TestCondition (const True)     , TestCheck (PropG.recommute commute)           )+  , ("nontrivial recommute"   , TestCondition nontrivialCommute, TestCheck (PropG.recommute commute)           )+  , ("inverses commute"       , TestCondition (const True)     , TestCheck (PropG.commuteInverses commute)     )+  , ("nontrivial inverses"    , TestCondition nontrivialCommute, TestCheck (PropG.commuteInverses commute)     )+  , ("inverse composition"    , TestCondition (const True)     , TestCheck PropG.inverseComposition            )+  ]++coalesce_properties :: forall p gen+                     . ( Show gen, Arbitrary gen, TestablePrim p+                       , MightBeEmptyHunk p+                       )+                    => PropList (Triple p) gen+coalesce_properties genname gen =+  properties gen "commute" genname+   (case runCoalesceTests @p of+      Just Dict ->+        [ ( "coalesce commutes with commute"+          , TestCondition (const True)+          , TestCheck (PropG.coalesceCommute (fmap maybeToFL . coalesce) . getTriple))+        ]+      Nothing -> [])++-- The following properties do not hold for "RepoPatchV2" patches (conflictors and+-- duplicates, specifically) .+prim_commute_properties :: forall p gen+                            . (Show gen, Arbitrary gen, Commute p, Invert p, ShowPatchBasic p, Eq2 p)+                           => PropList (Pair p) gen+prim_commute_properties genname gen =+  properties gen "commute" genname+  [ ("square commute law", TestCondition (const True)     , TestCheck (PropG.squareCommuteLaw commute))+  , ("nontrivial square commute law", TestCondition nontrivialCommute, TestCheck (PropG.squareCommuteLaw commute))+  ]++patch_properties :: forall p gen .+                    ( Show gen+                    , Arbitrary gen+                    , Invert p+                    , Eq2 p+                    , ShowPatchBasic p+                    )+                 => PropList p gen+patch_properties genname gen =+  properties gen "patch" genname+  [ ("inverse . inverse is id"  , TestCondition (const True)     , TestCheck PropG.invertInvolution)+  ]++patch_repo_properties+  :: forall p gen+   . ( Show gen, Arbitrary gen+     , Invert p, Apply p, ShowPatchBasic p+     , RepoModel (ModelOf p)+     , RepoState (ModelOf p) ~ ApplyState p+     )+  =>  PropList (WithState p) gen+patch_repo_properties genname gen =+  properties gen "patch/repo" genname+  [ ("invert rollback"          , TestCondition (const True)     , TestCheck PropG.invertRollback)+  ]++merge_properties :: forall p gen .+                    ( Show gen, Arbitrary gen, Commute p+                    , Invert p, Eq2 p, Merge p, ShowPatchBasic p+                    , MightHaveDuplicate p, Check p+                    )+                 => PropList (p :\/: p) gen+merge_properties genname gen =+  properties gen "merge" genname+  [ ("merge either way"           , TestCondition (const True)   , TestCheck PropG.mergeEitherWay      )+  , ("merge either way valid"     , TestCondition (const True)   , TestCheck PropG.mergeEitherWayValid )+  , ("nontrivial merge either way", TestCondition nontrivialMerge, TestCheck PropG.mergeEitherWay      )+  , ("merge commute"              , TestCondition (const True)   , TestCheck PropG.mergeCommute        )+  ]++triple_properties :: forall p gen .+                     ( Show gen, Arbitrary gen, Commute p+                     , Eq2 p, ShowPatchBasic p+                     , MightHaveDuplicate p+                     )+                  => PropList (Triple p) gen+triple_properties genname gen =+  properties gen "triple" genname+  [ ( "permutivity"+    , TestCondition (notDuplicatestriple . getTriple)+    , TestCheck (PropG.permutivity commute . getTriple) )+  , ( "nontrivial permutivity"+    , TestCondition (\(Triple t) -> nontrivialTriple t && notDuplicatestriple t)+    , TestCheck (PropG.permutivity commute . getTriple) )+  ]++pair_repo_properties+  :: forall p gen .+     ( Show gen+     , Arbitrary gen+     , Commute p+     , Apply p+     , ShowPatchBasic p+     , MightBeEmptyHunk p+     , RepoModel (ModelOf p)+     , RepoState (ModelOf p) ~ ApplyState p+     )+  => PropList (WithState (Pair p)) gen+pair_repo_properties genname gen =+  properties gen "patch/repo" genname+    [ ( "commute is effect preserving"+      , TestCondition (const True)+      , TestCheck (PropG.effectPreserving commute))+    ]+
harness/Darcs/Test/Patch/Properties/Check.hs view
@@ -72,8 +72,9 @@    -- This is stupid but was designed that way ages ago:    -- empty hunks commute with everything, so the file need    -- not even exist, nor the line in the file.-   -- Perhaps we should avoid generating empty hunks.-   checkPatch (FP _ (Hunk _ [] [])) = isValid+   -- We nowadays strictly avoid generating empty hunks, in+   -- darcs itself as well as in the test case generators.+   checkPatch (FP _ (Hunk _ [] [])) = error "encountered empty hunk"    checkPatch (FP f (Hunk line old new)) = do        fileExists f        mapM_ (deleteLine f line) old
harness/Darcs/Test/Patch/Properties/Generic.hs view
@@ -36,6 +36,7 @@     , PatchProperty     , MergeProperty     , SequenceProperty+    , propPrimPairCoverage     ) where  import Darcs.Prelude@@ -62,6 +63,7 @@     , MightHaveDuplicate(..)     , TestablePrim     )+import Darcs.Test.Patch.Types.Pair ( Pair(..) ) import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check )  import Control.Monad ( msum )@@ -84,13 +86,14 @@     , (:\/:)(..)     , FL(..)     , RL(..)-    , eqFL     , mapFL     ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text, vcat ) --import Darcs.ColorPrinter ( traceDoc ) +import Test.QuickCheck (Property, checkCoverage, cover)+ type PatchProperty p = forall wA wB. p wA wB -> TestResult -- type PairProperty p = forall wA wB. (p :> p) wA wB -> TestResult type MergeProperty p = forall wA wB. (FL p :\/: FL p) wA wB -> TestResult@@ -112,12 +115,12 @@  -- | @(AB)^ = B^A^@ inverseComposition :: (Invert p, Eq2 p, ShowPatchBasic p)-                   => (p :> p) wX wY -> TestResult-inverseComposition (a :> b) =+                   => Pair p wX wY -> TestResult+inverseComposition (Pair (a :> b)) =   let ab = a:>:b:>:NilFL       iab = invert ab       ibia = invert b:>:invert a:>:NilFL-  in case eqFL iab ibia of+  in case iab =\/= ibia of     IsEq -> succeeded     NotEq ->       failed $ redText "ab^ /= b^a^, where"@@ -155,8 +158,8 @@ -- | recommute   AB ↔ B′A′ if and only if B′A′ ↔ AB recommute :: (ShowPatchBasic p, Eq2 p, MightHaveDuplicate p)           => CommuteFn p p-          -> (p :> p) wA wB -> TestResult-recommute c (x :> y) =+          -> Pair p wA wB -> TestResult+recommute c (Pair (x :> y)) =     case c (x :> y) of     Nothing -> rejected     Just (y' :> x')@@ -192,8 +195,8 @@ -- | commuteInverses   AB ↔ B′A′ if and only if B⁻¹A⁻¹ ↔ A′⁻¹B′⁻¹ commuteInverses :: (Invert p, ShowPatchBasic p, Eq2 p)                 => CommuteFn p p-                -> (p :> p) wA wB -> TestResult-commuteInverses c (x :> y) =+                -> Pair p wA wB -> TestResult+commuteInverses c (Pair (x :> y)) =     case c (x :> y) of     Nothing ->       -- check that inverse commute neither@@ -235,11 +238,11 @@      , ShowPatchBasic p      )   => CommuteFn p p-  -> WithState (p :> p) wA wB+  -> WithState (Pair p) wA wB   -> TestResult-effectPreserving _ (WithState _ (x :> _) _)+effectPreserving _ (WithState _ (Pair (x :> _)) _)   | isEmptyHunk x = rejected-effectPreserving c (WithState r (x :> y) r') =+effectPreserving c (WithState r (Pair (x :> y)) r') =   case c (x :> y) of     Nothing -> rejected     Just (y' :> x') ->@@ -282,9 +285,9 @@ squareCommuteLaw   :: (Invert p, ShowPatchBasic p, Eq2 p)   => CommuteFn p p-  -> (p :> p) wA wB+  -> Pair p wA wB   -> TestResult-squareCommuteLaw c (x :> y) =+squareCommuteLaw c (Pair (x :> y)) =   case c (x :> y) of     Nothing -> rejected     Just (y' :> x') ->@@ -507,8 +510,8 @@ coalesceEffectPreserving             :: TestablePrim prim             => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY))-            -> WithState (prim :> prim) wA wB -> TestResult-coalesceEffectPreserving j (WithState r (a :> b) r') =+            -> WithState (Pair prim) wA wB -> TestResult+coalesceEffectPreserving j (WithState r (Pair (a :> b)) r') =   case j (a :> b) of        Nothing -> rejected        Just x  -> case maybeFail $ repoApply r x of@@ -644,3 +647,25 @@     Just (ix' :> x') -> failed $ redText "x:" $$ displayPatch x       $$ redText "commutes with x^ to ix':" $$ displayPatch ix'       $$ redText "x':" $$ displayPatch x'++-- This property is just to check the coverage of pairs,+-- it doesn't test any actual property.+propPrimPairCoverage :: forall prim wX wY . (Eq2 prim, Commute prim) => Pair prim wX wY -> Property+propPrimPairCoverage (Pair pq) =+  checkCoverage $+  -- The coverage percentages should pass reliably, but+  -- could be dropped a bit if not.+  let theKind = classifyCommute pq (commute pq) in+    cover 20 (theKind == Failed) "Not Commutable" $+    cover 60 (theKind /= Failed) "Commutable" $+    cover 20 (theKind == Changed) "Representation Changed" $+    True++data CommuteKind = Failed | Unchanged | Changed+  deriving (Eq, Show)++classifyCommute :: Eq2 prim => (prim :> prim) wX wY -> Maybe ((prim :> prim) wX wY) -> CommuteKind+classifyCommute _ Nothing = Failed+classifyCommute (p :> q) (Just (q' :> p'))+  | unsafeCompare p p' && unsafeCompare q q' = Unchanged+  | otherwise = Changed
harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs view
@@ -11,6 +11,7 @@ import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate ) import Darcs.Test.Patch.Arbitrary.PrimV1 () +import Darcs.Test.Patch.Types.Pair ( Pair(..) ) import Darcs.Test.Patch.WSub import Darcs.Test.Util.TestResult @@ -35,12 +36,12 @@ commuteInverses :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p)                  => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))                  -> (p :> p) wA wB -> TestResult-commuteInverses f = W.commuteInverses (fmap toW . f . fromW) . toW+commuteInverses f = W.commuteInverses (fmap toW . f . fromW) . Pair . toW  recommute :: (ShowPatchBasic wp, MightHaveDuplicate wp, Eq2 wp, WSub wp p)           => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY)))           -> (p :> p) wA wB -> TestResult-recommute f = W.recommute (fmap toW . f . fromW) . toW+recommute f = W.recommute (fmap toW . f . fromW) . Pair . toW  mergeCommute :: ( MightHaveDuplicate wp                 , ShowPatchBasic wp@@ -69,7 +70,7 @@ squareCommuteLaw :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p) =>                              (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))                           -> (p :> p) wA wB -> TestResult-squareCommuteLaw f = W.squareCommuteLaw (fmap toW . f . fromW) . toW+squareCommuteLaw f = W.squareCommuteLaw (fmap toW . f . fromW) . Pair . toW   coalesceCommute :: (forall wX wY . (Prim2 :> Prim2) wX wY -> Maybe (FL Prim2 wX wY))
harness/Darcs/Test/Patch/Properties/RepoPatch.hs view
@@ -11,25 +11,26 @@  import Data.Maybe ( catMaybes ) -import Darcs.Test.Patch.Arbitrary.Generic-  ( MergeableSequence, mergeableSequenceToRL, PrimBased )+import Darcs.Test.Patch.Arbitrary.Generic ( PrimBased ) import Darcs.Test.Patch.Arbitrary.PatchTree   ( Tree, flattenTree, G2(..), mapTree ) import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.Types.MergeableSequence ( MergeableSequence, mergeableSequenceToRL ) import Darcs.Test.Patch.WithState import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState-                                  , Fail(..), maybeFail, ModelOf )-import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed )+                                  , Fail, maybeFail, ModelOf )+import Darcs.Test.Util.TestResult ( TestResult, failed, rejected, succeeded )  import Darcs.Util.Printer ( text, redText, ($$), vsep ) -import Darcs.Patch.Conflict ( Conflict(..), ConflictDetails(..) )+import Darcs.Patch.Conflict ( Conflict(..), ConflictDetails(..), Unravelled ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Merge ( Merge, mergeList )-import Darcs.Patch.Permutations ( permutationsRL )-import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Permutations ( permutationsRL, (=\~/=) )+import Darcs.Patch.RepoPatch ( Commute, RepoPatch ) import Darcs.Patch.Show ( displayPatch ) +import Darcs.Patch.Witnesses.Eq ( Eq2, isIsEq ) import Darcs.Patch.Witnesses.Ordered ( RL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, Sealed2(..) ) import Darcs.Patch.Witnesses.Show ( Show2 )@@ -83,37 +84,61 @@                           -> TestResult propConsistentReorderings (Sealed2 (WithStartState2 start ms)) =   case mapM (repoApply start) $ permutationsRL ps of-    Failed msg -> failed $ redText "could not apply all reorderings:" $$ text msg-    OK results -> eql results+    Left e -> failed $ redText "could not apply all reorderings:" $$ text (show e)+    Right [] -> error "we should have at least one permutation!"+    Right [_] -> rejected -- only one permutation -> nothing to test+    Right results -> eql results   where-    eql [] = succeeded+    eql [] = error "impossible"     eql [_] = succeeded     eql (r1:r2:rs)-      | r1 `eqModel` r2 =+      | r1 `eqModel` r2 = eql (r2:rs)+      | otherwise =           failed           $ redText "result states differ: r1="           $$ text (showModel r1)           $$ redText "r2="           $$ text (showModel r2)-      | otherwise = eql (r2:rs)     ps = mergeableSequenceToRL ms  -- | This property states that the standard conflict resolutions for a -- sequence of patches are independent of any reordering of the sequence. propResolutionsOrderIndependent :: RepoPatch p => RL p wX wY -> TestResult-propResolutionsOrderIndependent patches =-    eql $ map (catMaybes . map conflictMangled . resolveConflicts NilRL) $ permutationsRL patches+propResolutionsOrderIndependent ps =+    check $ map withConflictParts pss   where-    eql [] = succeeded+    withConflictParts qs =+      (Sealed qs, map conflictParts $ resolveConflicts NilRL qs)+    pss = permutationsRL ps+    check [] = error "we should have at least one permutation!"+    check [_] = rejected+    check xs = eql xs+    eql [] = error "impossible"     eql [_] = succeeded-    eql (r1:r2:rs)-      | r1 /= r2 =-          failed-            $ redText "resolutions differ: r1="-            $$ vsep (map (unseal displayPatch) r1)-            $$ redText "r2="-            $$ vsep (map (unseal displayPatch) r2)-      | otherwise = eql (r2:rs)+    eql ((ps1,r1):(ps2,r2):rs)+      | listEqBy eqUnravelled r1 r2 = eql ((ps2,r2):rs)+      | otherwise =+          failed $ vsep+            [ redText "resolutions differ: r1="+            , text (show r1)+            , redText "r2="+            , text (show r2)+            , text "for patches"+            , unseal displayPatch ps1+            , text "versus"+            , unseal displayPatch ps2+            ]++-- | Equality for 'Unravelled' is modulo order of patches.+eqUnravelled :: (Commute p, Eq2 p) => Unravelled p wX -> Unravelled p wX -> Bool+eqUnravelled = listEqBy eq where+  eq (Sealed ps) (Sealed qs) = isIsEq $ ps =\~/= qs++-- | Generic list equality with explicitly given comparison for elements.+listEqBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool+listEqBy _ [] [] = True+listEqBy eq (x:xs) (y:ys) = x `eq` y && listEqBy eq xs ys+listEqBy _ _ _ = False  -- | This property states that the standard conflict resolutions for a -- sequence of patches do not themselves conflict with each other.
harness/Darcs/Test/Patch/Properties/RepoPatchV3.hs view
@@ -13,7 +13,7 @@ import Darcs.Patch.Commute import Darcs.Patch.Ident import Darcs.Patch.Invert-import Darcs.Patch.Permutations ( headPermutationsRL )+import Darcs.Patch.Permutations ( headPermutationsRL, partitionRL' ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Show ( displayPatch, ShowPatchFor(..) ) import Darcs.Patch.Witnesses.Ordered@@ -100,9 +100,11 @@       $ text "undone patches not found in repo:"       $$ vcat (mapRL displayPatch (ps :<: p))   | otherwise =-      case commuteWhatWeCanToPostfix xids ps of-        _ :> xs ->-          case commuteRL (xs :> p) of+      case partitionRL' ((`S.member` xids) . ident) ps of+        _ :> dragged :> xs ->+          -- If there are patches that are not directly conflicting with p,+          -- but depend on ones that do, these must also commute with p.+          case commuteRL (reverseFL dragged +<+ xs :> p) of             Just (PrimP _ :> _) -> succeeded             Just _ ->               failed
harness/Darcs/Test/Patch/Properties/V1Set1.hs view
@@ -9,7 +9,7 @@ import Darcs.Patch      ( commute, invert, merge, effect      , readPatch, showPatch-     , canonize, sortCoalesceFL )+     , canonizeFL ) import Darcs.Patch.FromPrim ( fromAnonymousPrim ) import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Read ( ReadPatch )@@ -35,9 +35,6 @@ quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of                         _ :/\: p1' -> unsafeCoercePEnd p1' -instance Eq2 p => Eq ((p :/\: p) wX wY) where-   (x :/\: y) == (x' :/\: y') = isIsEq (x =\/= x') && isIsEq (y =\/= y')- -- ---------------------------------------------------------------------------- -- A number of "comparison" properties: these carry out some operation on -- inputs (first value in the pair) and compare the results with a known@@ -48,7 +45,7 @@ checkMerge (p1:\/:p2,p1') =    case merge (p1:\/:p2) of    _ :/\: p1a ->-       if isIsEq (p1a `eqFL` p1')+       if isIsEq (p1a =\/= p1')        then succeeded        else failed $ text $ "Merge gave wrong value!\n"++show p1++show p2             ++"I expected\n"++show p1'@@ -75,7 +72,7 @@         _ :/\: p1' ->             case commute (p1 :> p2') of             Just (_ :> p1'b) ->-                if not $ p1'b `eqFLUnsafe` p1'+                if not $ p1'b `unsafeCompare` p1'                 then failed $ text $ "Merge swapping problem with...\np1 "++                       show p1++"merged with\np2 "++                       show p2++"p1' is\np1' "++@@ -89,17 +86,17 @@  checkCanon :: forall wX wY . (FL Patch wX wY, FL Patch wX wY) -> TestResult checkCanon (p1,p2) =-    if isIsEq $ eqFL p1_ p2-    then if isIsEq $ eqFL p1_p p2+    if isIsEq $ p1_myers =\/= p2+    then if isIsEq $ p1_patience =\/= p2          then succeeded          else failed $ text $ "Canonization with Patience Diff failed:\n"++show p1++"canonized is\n"-               ++ show p1_p+               ++ show p1_patience                ++"which is not\n"++show p2     else failed $ text $ "Canonization with Myers Diff failed:\n"++show p1++"canonized is\n"-          ++ show p1_+          ++ show p1_myers           ++"which is not\n"++show p2-    where p1_ = mapFL_FL fromAnonymousPrim $ concatFL $ mapFL_FL (canonize D.MyersDiff) $ sortCoalesceFL $ effect p1-          p1_p = mapFL_FL fromAnonymousPrim $ concatFL $ mapFL_FL (canonize D.PatienceDiff) $ sortCoalesceFL $ effect p1+    where p1_myers = mapFL_FL fromAnonymousPrim $ canonizeFL D.MyersDiff $ effect p1+          p1_patience = mapFL_FL fromAnonymousPrim $ canonizeFL D.PatienceDiff $ effect p1  checkCommute :: ((FL Patch :> FL Patch) wX wY, (FL Patch :> FL Patch) wX wY) -> TestResult checkCommute (p2 :> p1,p1' :> p2') =
harness/Darcs/Test/Patch/Properties/V1Set2.hs view
@@ -22,11 +22,6 @@     , propCommuteEitherOrder     , propCommuteEitherWay, propCommuteTwice     , propMergeIsCommutableAndCorrect, propMergeIsSwapable--    , checkSubcommutes-    , subcommutesInverse, subcommutesNontrivialInverse, subcommutesFailure--    , propReadShow     -- TODO: these are exported temporarily to mark them as used     -- Figure out whether to enable or remove the tests.     , propUnravelThreeMerge, propUnravelSeqMerge@@ -37,28 +32,14 @@ import Darcs.Prelude  import Test.QuickCheck-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.Framework ( Test ) import Data.Maybe ( isJust )  import Darcs.Test.Patch.Properties.Check ( Check, checkAPatch ) -import Darcs.Patch ( invert, commute, merge,-                     readPatch,-                     showPatch, ShowPatchFor(..) )+import Darcs.Patch ( invert, commute, merge ) import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.V1.Commute ( unravel, merger )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.Prim.V1.Commute-    ( Perhaps(..)-    , toPerhaps-    , speedyCommute-    , cleverCommute-    , commuteFiledir-    , commuteFilepatches-    )-import Darcs.Util.Printer ( renderPS ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed@@ -69,17 +50,6 @@  import Darcs.Test.Patch.Arbitrary.RepoPatchV1 (Patch) ---- | Groups a set of tests by giving them the same prefix in their description.---   When this is called as @checkSubcommutes subcoms expl@, the prefix for a---   test becomes @"Checking " ++ expl ++ " for subcommute "@.-checkSubcommutes :: Testable a => [(String, a)] -> String-                                                 -> [Test]-checkSubcommutes subcoms expl = map check_subcommute subcoms-  where check_subcommute (name, test) =-            let testName = expl ++ " for subcommute " ++ name-            in testProperty testName test- propInverseValid :: Sealed2 (FL Patch) -> Bool propInverseValid (Sealed2 p1) = checkAPatch (invert p1:>:p1:>:NilFL) propOtherInverseValid :: Sealed2 (FL Patch) -> Bool@@ -212,11 +182,6 @@     (unravel $ unseal unsafeCoercePEnd $ merger "0.0" p2 p1) ==     (unravel $ unseal unsafeCoerceP $ merger "0.0" p1 p2) -propReadShow :: FL Patch wX wY -> Bool-propReadShow p = case readPatch $ renderPS $ showPatch ForStorage p of-                   Right (Sealed p') -> isIsEq (p' =\/= p)-                   Left _ -> False- -- |In order for merges to work right with commuted patches, inverting a patch -- past a patch and its inverse had golly well better give you the same patch -- back again.@@ -228,105 +193,3 @@                                case commute (p1' :> invert p2) of                                Nothing -> False                                Just (_ :> p1'') -> isIsEq (p1'' =/\= p1)--type CommuteProperty = Sealed2 (Prim :> Prim) -> Property--type CommuteFunction =-    forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY)--newtype WrappedCommuteFunction = WrappedCommuteFunction-    { runWrappedCommuteFunction :: CommuteFunction }--wrapCommuteFunction :: (forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY)) -> WrappedCommuteFunction-wrapCommuteFunction f = WrappedCommuteFunction $-  \(p :> q) -> do-    q' :> p' <- f (p :> q)-    return (q' :> p')--subcommutes :: [(String, WrappedCommuteFunction)]-subcommutes =-    [("speedyCommute", wrapCommuteFunction speedyCommute),-     ("commuteFiledir", wrapCommuteFunction (cleverCommute commuteFiledir)),-     ("commuteFilepatches", wrapCommuteFunction (cleverCommute commuteFilepatches)),-     ("commutex", wrapCommuteFunction (toPerhaps . commute))-    ]---subcommutesInverse :: [(String, CommuteProperty)]-subcommutesInverse = zip names (map prop_subcommute cs)-    where (names, cs) = unzip subcommutes-          prop_subcommute c (Sealed2 (p1:>p2)) =-              does c p1 p2 ==>-              case runWrappedCommuteFunction c (p1 :> p2) of-              Succeeded (p2' :> p1') ->-                  case runWrappedCommuteFunction c (p1' :> invert p2) of-                  Succeeded (ip2x' :> p1'') -> isIsEq (p1'' =/\= p1) &&-                      case runWrappedCommuteFunction c (invert p2 :> invert p1 ) of-                      Succeeded (ip1' :> ip2') ->-                          case runWrappedCommuteFunction c (invert p1 :> p2') of-                          Succeeded (p2o :> ip1o') -> isJust ((do-                                 IsEq <- return $ invert ip1' =/\= p1'-                                 IsEq <- return $ invert ip2' =/\= p2'-                                 IsEq <- return $ ip1o' =/\= ip1'-                                 IsEq <- return $ p2o =\/= p2-                                 IsEq <- return $ p1'' =/\= p1-                                 IsEq <- return $ ip2x' =\/= ip2'-                                 return ()) :: Maybe ())-                          _ -> False-                      _ -> False-                  _ -> False-              _ -> False--subcommutesNontrivialInverse :: [(String, CommuteProperty)]-subcommutesNontrivialInverse = zip names (map prop_subcommute cs)-    where -- speedyCommute will never be "nontrivial"-          (names, cs) = unzip . filter ((/= "speedyCommute") . fst) $ subcommutes-          prop_subcommute c (Sealed2 (p1 :> p2)) =-              nontrivial c p1 p2 ==>-              case runWrappedCommuteFunction c (p1 :> p2) of-              Succeeded (p2' :> p1') ->-                  case runWrappedCommuteFunction c (p1' :> invert p2) of-                  Succeeded (ip2x' :> p1'') -> isIsEq (p1'' =/\= p1) &&-                      case runWrappedCommuteFunction c (invert p2 :> invert p1) of-                      Succeeded (ip1' :> ip2') ->-                          case runWrappedCommuteFunction c (invert p1 :> p2') of-                          Succeeded (p2o :> ip1o') -> isJust ((do-                              IsEq <- return $ invert ip1' =/\= p1'-                              IsEq <- return $ invert ip2' =/\= p2'-                              IsEq <- return $ ip1o' =/\= ip1'-                              IsEq <- return $ p2o =\/= p2-                              IsEq <- return $ p1'' =/\= p1-                              IsEq <- return $ ip2x' =\/= ip2'-                              return ()) :: Maybe ())-                          _ -> False-                      _ -> False-                  _ -> False-              _ -> False--subcommutesFailure :: [(String, CommuteProperty)]-subcommutesFailure = zip names (map prop cs)-    where -- speedyCommute will never fail (it just returns "Unknown")-          (names, cs) = unzip . filter ((/= "speedyCommute") . fst) $ subcommutes-          prop c (Sealed2 (p1 :> p2)) =-              doesFail c p1 p2 ==>-                case runWrappedCommuteFunction c (invert p2 :> invert p1 ) of-                 Failed -> True-                 _ -> False--doesFail :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool-doesFail c p1 p2 =-    fails (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL)-        where fails Failed = True-              fails _ = False--does :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool-does c p1 p2 =-    succeeds (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL)-        where succeeds (Succeeded _) = True-              succeeds _ = False--nontrivial :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool-nontrivial c p1 p2 =-    succeeds (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL)-        where succeeds (Succeeded (p2' :> p1' )) = not (p1' `unsafeCompare` p1 && p2' `unsafeCompare` p2)-              succeeds _ = False
harness/Darcs/Test/Patch/Rebase.hs view
@@ -21,7 +21,7 @@ import Darcs.Test.Patch.Arbitrary.Generic import Darcs.Test.TestOnly.Instance () -import Darcs.Util.Path ( floatPath )+import Darcs.Util.Path ( unsafeFloatPath )  testSuite :: forall p . (RepoPatch p, ArbitraryPrim (PrimOf p)) => [Test] testSuite =@@ -41,7 +41,7 @@         unless (all (/= Okay) cStatuses) $             assertFailure ("unexpected conflicted effect: " ++ show cEffect)     where-        corePrim = addfile (floatPath "file")+        corePrim = addfile (unsafeFloatPath "file")         rebase :: RebaseChange (PrimOf p) WX WX         rebase =           RC (PrimFixup (invert corePrim) :>: NilFL)
harness/Darcs/Test/Patch/RepoModel.hs view
@@ -2,36 +2,20 @@  import Darcs.Prelude +import Control.Exception ( SomeException )+ import Darcs.Patch.Apply ( Apply, ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL, RL )  import Test.QuickCheck ( Gen ) -data Fail a = Failed String | OK a-  deriving (Eq, Show)--instance Functor Fail where-  fmap _ (Failed s) = Failed s-  fmap f (OK v) = OK (f v)--instance Applicative Fail where-  pure = OK-  Failed s <*> _ = Failed s-  _ <*> Failed s = Failed s-  OK f <*> OK v = OK (f v)--instance Monad Fail where-  return = OK-  Failed s >>= _ = Failed s-  OK v >>= f = f v+type Fail = Either SomeException  unFail :: Fail t -> t-unFail (OK x) = x-unFail (Failed err) = error $ "unFail failed: " ++ err+unFail = either (error.show) id  maybeFail :: Fail a -> Maybe a-maybeFail (OK x) = Just x-maybeFail _ = Nothing+maybeFail = either (const Nothing) Just  class RepoModel model where   type RepoState model :: (* -> *) -> *
− harness/Darcs/Test/Patch/RepoPatchV1.hs 
@@ -1,106 +0,0 @@---  Copyright (C) 2002-2005,2007 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Test.Patch.RepoPatchV1 ( testSuite ) where--import Darcs.Prelude--import Test.Framework ( Test, testGroup )-import Test.Framework.Providers.QuickCheck2 ( testProperty )--import Darcs.Test.Patch.Utils ( testCases )--import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Eq ( unsafeCompare )-import Darcs.Patch.V1 as V1 ( RepoPatchV1 )-import qualified Darcs.Patch.V1.Prim as V1 ( Prim )-import Darcs.Patch.Commute ( Commute(..) )--import Darcs.Test.Patch.Arbitrary.Named ()-import Darcs.Test.Patch.Arbitrary.RepoPatchV1 ()--import qualified Darcs.Test.Patch.Examples.Set1 as Ex--import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1-import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2-import qualified Darcs.Test.Patch.Properties.Generic as PropG-import Darcs.Test.Patch.Properties.GenericUnwitnessed ()--import qualified Darcs.Test.Patch.Rebase as Rebase-import qualified Darcs.Test.Patch.Unwind as Unwind--type RPV1 = V1.RepoPatchV1 V1.Prim--unit_V1P1:: [Test]-unit_V1P1 =-  [ testCases "known commutes" Prop1.checkCommute Ex.knownCommutes-  , testCases "known non-commutes" Prop1.checkCantCommute Ex.knownCantCommutes-  , testCases "known merges" Prop1.checkMerge Ex.knownMerges-  , testCases "known merges (equiv)" Prop1.checkMergeEquiv Ex.knownMergeEquivs-  , testCases "known canons" Prop1.checkCanon Ex.knownCanons-  , testCases "merge swaps" Prop1.checkMergeSwap Ex.mergePairs2-  , testCases "the patch validation works" Prop1.tTestCheck Ex.validPatches-  , testCases "commute/recommute" (PropG.recommute commute) Ex.commutePairs-  , testCases "merge properties: merge either way valid" PropG.mergeEitherWayValid Ex.mergePairs-  , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs-  , testCases "primitive patch IO functions" (Prop1.tShowRead eqFLUnsafe) Ex.primitiveTestPatches-  , testCases "IO functions (test patches)" (Prop1.tShowRead eqFLUnsafe) Ex.testPatches-  , testCases "IO functions (named test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatchesNamed-  , testCases "primitive commute/recommute" (PropG.recommute commute) Ex.primitiveCommutePairs-  ]--qc_V1P1 :: [Test]-qc_V1P1 =-  [-    testProperty "show and read work right" (unseal Prop2.propReadShow)-  ]-  ++ Prop2.checkSubcommutes Prop2.subcommutesInverse "patch and inverse both commute"-  ++ Prop2.checkSubcommutes Prop2.subcommutesNontrivialInverse "nontrivial commutes are correct"-  ++ Prop2.checkSubcommutes Prop2.subcommutesFailure "inverses fail"-  ++-  [ testProperty "commuting by patch and its inverse is ok" Prop2.propCommuteInverse-  -- , testProperty "conflict resolution is valid" Prop.propResolveConflictsValid-  , testProperty "a patch followed by its inverse is identity"-    Prop2.propPatchAndInverseIsIdentity-  , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough-  , testProperty "commutes are equivalent" Prop2.propCommuteEquivalency-  , testProperty "merges are valid" Prop2.propMergeValid-  , testProperty "inverses being valid" Prop2.propInverseValid-  , testProperty "other inverse being valid" Prop2.propOtherInverseValid-  -- The patch generator isn't smart enough to generate correct test cases for-  -- the following: (which will be obsoleted soon, anyhow)-  -- , testProperty "the order dependence of unravel" Prop.propUnravelOrderIndependent-  -- , testProperty "the unravelling of three merges" Prop.propUnravelThreeMerge-  -- , testProperty "the unravelling of a merge of a sequence" Prop.propUnravelSeqMerge-  , testProperty "the order of commutes" Prop2.propCommuteEitherOrder-  , testProperty "commute either way" Prop2.propCommuteEitherWay-  , testProperty "the double commute" Prop2.propCommuteTwice-  , testProperty "merges commute and are well behaved"-    Prop2.propMergeIsCommutableAndCorrect-  , testProperty "merges can be swapped" Prop2.propMergeIsSwapable-  , testProperty "again that merges can be swapped (I'm paranoid) " Prop2.propMergeIsSwapable-  ]--testSuite :: Test-testSuite =-  testGroup "RepoPatchV1"-    [ testGroup "using V1.Prim wrapper for Prim.V1" $-      unit_V1P1 ++ qc_V1P1 ++-      [ testGroup "Rebase patches" $ Rebase.testSuite @RPV1 ] ++-      [ testGroup "Unwind" $ Unwind.testSuite @RPV1 ]-    ]
harness/Darcs/Test/Patch/Selection.hs view
@@ -12,7 +12,6 @@  import Darcs.Patch.V2 ( RepoPatchV2 ) import qualified Darcs.Patch.V2.Prim as V2-import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) )  import Darcs.UI.SelectChanges     ( PatchSelectionOptions(..)@@ -24,7 +23,7 @@ import Darcs.Patch.Info ( rawPatchInfo ) import Darcs.UI.Options.All     ( Verbosity(..), WithSummary(..)-    , WithContext(..), SelectDeps(..), MatchFlag(..) )+    , SelectDeps(..), MatchFlag(..) )  import Darcs.Test.TestOnly.Instance () @@ -45,7 +44,7 @@        launchNuclearMissilesPatches = unsafeCoerceP $ lnmPatches [ "P " ++ show i | i <- [1..5::Int] ]        lnmPatches [] = NilFL        lnmPatches (n:names) = buildPatch n  :>: lnmPatches names-       buildPatch :: String -> PatchInfoAnd ('RepoType 'NoRebase) Patch wX wY+       buildPatch :: String -> PatchInfoAnd Patch wX wY        buildPatch name = patchInfoAndPatch (rawPatchInfo "1999" name "harness" [] False) (error "Patch content read!")        pso = PatchSelectionOptions            { verbosity = Quiet@@ -53,7 +52,6 @@            , interactive = False            , selectDeps = AutoDeps            , withSummary = NoSummary-           , withContext = NoContext            }        context = selectionConfig whch "select" pso Nothing Nothing    (unselected :> selected) <- runSelection launchNuclearMissilesPatches context
+ harness/Darcs/Test/Patch/Types/MergeableSequence.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Types.MergeableSequence+  ( MergeableSequence(..)+  , arbitraryMergeableSequence+  , mergeableSequenceToRL+  ) where++import Darcs.Prelude++import Control.Applicative ( (<|>) )+import Test.QuickCheck++import Darcs.Test.Patch.Arbitrary.Generic ( PrimBased(..) )+import Darcs.Test.Patch.Arbitrary.Shrink+import Darcs.Test.Patch.Merge.Checked+import Darcs.Test.Patch.Types.Merged ( Merged, typedMerge )+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Util.QuickCheck ( bSized )+import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )+import Darcs.Patch.Prim ( sortCoalesceFL, PrimCoalesce )+import Darcs.Patch.Witnesses.Show++-- | This type provides a concrete, pre-merged representation of a sequence+-- of patches that might have conflicts once merged. The structure also allows+-- for conflict resolutions, e.g. in @SeqMS (ParMS x y) z@, @z@ could be a+-- resolution patch.+-- Working with the pre-merged patches makes it easier to manipulate the test+-- case, e.g. for shrinking.+-- Note that although MergeableSequence is parameterised on a patch type @p@+-- that needs to support merging, it only explicitly contains primitive+-- patches. The merged patches are constructed on-the-fly when the structure+-- is used. It's necessary to fix the structure to a specific mergeable patch+-- type because otherwise the merged patches could vary, invalidating the+-- context of conflict resolution patches like @z@.+data MergeableSequence p wX wY where+  NilMS :: MergeableSequence p wX wX+  SeqMS+    :: MergeableSequence p wX wY+    -> OnlyPrim p wY wZ+    -> MergeableSequence p wX wZ+  ParMS+    :: MergeableSequence p wX wA+    -> MergeableSequence p wX wB+    -> MergeableSequence p wX (Merged wA wB)++instance PrimPatchBase p => PrimPatchBase (MergeableSequence p) where+  type PrimOf (MergeableSequence p) = PrimOf p++instance (CheckedMerge p, PrimBased p) => Effect (MergeableSequence p) where+  effect NilMS = NilFL+  effect (SeqMS ps p) = effect ps +>+ primEffect @p p+  effect (ParMS ms1 ms2) =+    let ps1 = mergeableSequenceToRL ms1+        ps2 = mergeableSequenceToRL ms2+    in case typedMerge (reverseRL ps1 :\/:reverseRL ps2) of+      (ps2', _) -> effect ms1 +>+ effect ps2'+++instance+  ( PropagateShrink prim (OnlyPrim p)+  , CheckedMerge p, Effect p, PrimOf p ~ prim+  , Invert prim, PrimCoalesce prim+  , PrimBased p+  )+  => PropagateShrink prim (MergeableSequence p) where+  -- Note that the result of propagateShrink is always either+  -- Just (Just2 _ :> _) or Nothing, so we don't need to worry about+  -- the Just (Nothing2 :> _) case in recursive calls.+  propagateShrink (prim :> NilMS) = Just (Just2 NilMS :> Just2 prim)+  propagateShrink (prim :> SeqMS ps p) = do+    Just2 ps' :> mprim' <- propagateShrink (prim :> ps)+    mp' :> mprim'' <- propagateShrinkMaybe (mprim' :> p)+    let result = case mp' of+          Just2 p' -> SeqMS ps' p'+          Nothing2 -> ps'+    return (Just2 result :> mprim'')+  propagateShrink+    ((prim :: prim wA wB) :>+       ParMS (ms1 :: MergeableSequence p wB wD1) (ms2 :: MergeableSequence p wB wD2)) = do+    Just2 (ms1' :: MergeableSequence p wA wC1) :> (mprim1' :: Maybe2 prim wC1 wD1)+      <- propagateShrink (prim :> ms1)+    Just2 (ms2' :: MergeableSequence p wA wC2) :> (mprim2' :: Maybe2 prim wC2 wD2)+      <- propagateShrink (prim :> ms2)+    let+      ms' :: MergeableSequence p wA (Merged wC1 wC2)+      ms' = parMS ms1' ms2'+      ps1  :: FL p wB wD1+      ps2  :: FL p wB wD2+      mergedps1 :: FL p wD2 (Merged wD1 wD2)+      mergedps2 :: FL p wD1 (Merged wD1 wD2)+      ps1' :: FL p wA wC1+      ps2' :: FL p wA wC2+      mergedps1' :: FL p wC2 (Merged wC1 wC2)+      mergedps2' :: FL p wC1 (Merged wC1 wC2)+      ps1  = reverseRL (mergeableSequenceToRL ms1)+      ps2  = reverseRL (mergeableSequenceToRL ms2)+      ps1' = reverseRL (mergeableSequenceToRL ms1')+      ps2' = reverseRL (mergeableSequenceToRL ms2')+      (mergedps2 , mergedps1 ) = typedMerge (ps1  :\/: ps2 )+      (mergedps2', mergedps1') = typedMerge (ps1' :\/: ps2')+      -- Unless the shrinking prim disappears on both branches of the merge,+      -- we'll need to try to recalculate it for the result of the merge - trying+      -- to use propagateShrink a second time wouldn't guarantee the right+      -- contexts. (This is a bit complicated to see, hence all the type signatures+      -- in this function.)+      recalcShrink+        :: prim wX wY+        -> FL p wY (Merged wD1 wD2)+        -> FL p wX (Merged wC1 wC2)+        -> Maybe (Maybe2 prim (Merged wC1 wC2) (Merged wD1 wD2))+      recalcShrink primIn m1 m2 =+        case sortCoalesceFL (invert (effect m2) +>+ primIn :>: effect m1) of+          NilFL -> Just Nothing2+          prim' :>: NilFL -> Just (Just2 prim')+          -- If we don't get 0 or 1 prims, we can't use this result given the type+          -- of propagateShrink as a whole. If that was changed to return an FL we+          -- could use it, but at the cost of more complexity elsewhere.+          _ -> Nothing+    mprim' :: Maybe2 prim (Merged wC1 wC2) (Merged wD1 wD2)+      <-+      case (mprim1', mprim2') of+        (Nothing2, Nothing2) -> Just Nothing2+        (Just2 prim1', _) | Just prim'' <- recalcShrink prim1' mergedps2 mergedps2' -> Just prim''+        (_, Just2 prim2') | Just prim'' <- recalcShrink prim2' mergedps1 mergedps1' -> Just prim''+        _ -> Nothing+    return (Just2 ms' :> mprim')++instance (Show2 p, PrimBased p) => Show (MergeableSequence p wX wY) where+  showsPrec _d NilMS = showString "NilMS"+  showsPrec d (SeqMS ms p) =+    showParen (d > appPrec) $ showString "SeqMS " . showsPrec2 (appPrec + 1) ms . showString " " . showsPrec2 (appPrec + 1) p+  showsPrec d (ParMS ms1 ms2) =+    showParen (d > appPrec) $ showString "ParMS " . showsPrec2 (appPrec + 1) ms1 . showString " " . showsPrec2 (appPrec + 1) ms2++instance (Show2 p, PrimBased p) => Show1 (MergeableSequence p wX)+instance (Show2 p, PrimBased p) => Show2 (MergeableSequence p)++type instance ModelOf (MergeableSequence p) = ModelOf p++parMS+  :: MergeableSequence p wX wA+  -> MergeableSequence p wX wB+  -> MergeableSequence p wX (Merged wA wB)+parMS NilMS ms = unsafeCoercePEnd ms+parMS ms NilMS = unsafeCoercePEnd ms+parMS ms1 ms2 = ParMS ms1 ms2++instance Shrinkable (OnlyPrim p) => Shrinkable (MergeableSequence p) where+  shrinkInternally NilMS = []+  shrinkInternally (SeqMS ms p) =+    SeqMS ms <$> shrinkInternally p+      <|>+    flip SeqMS p <$> shrinkInternally ms+  shrinkInternally (ParMS ms1 ms2) =+    parMS ms1 <$> shrinkInternally ms2+      <|>+    flip parMS ms2 <$> shrinkInternally ms1++  shrinkAtStart NilMS = []+  shrinkAtStart (SeqMS NilMS p) = mapFlipped (SeqMS NilMS) <$> shrinkAtStart p+  shrinkAtStart (ParMS {}) = []+  shrinkAtStart (SeqMS (ParMS {}) p) = [FlippedSeal (SeqMS NilMS p)]+  shrinkAtStart (SeqMS ms p) = mapFlipped (flip SeqMS p) <$> shrinkAtStart ms++  shrinkAtEnd NilMS = []+  shrinkAtEnd (SeqMS ms p) =+    Sealed ms:map (mapSeal (SeqMS ms)) (shrinkAtEnd p)+  shrinkAtEnd (ParMS ms1 ms2) =+    do+      Sealed ms2' <- shrinkAtEnd ms2+      return $ Sealed $ parMS ms1 ms2'+     <|>+    do+      Sealed ms1' <- shrinkAtEnd ms1+      return $ Sealed $ parMS ms1' ms2++mergeableSequenceToRL+  :: (CheckedMerge p, PrimBased p)+  => MergeableSequence p wX wY+  -> RL p wX wY+mergeableSequenceToRL NilMS = NilRL+mergeableSequenceToRL (SeqMS ms p) = mergeableSequenceToRL ms :<: liftFromPrim p+mergeableSequenceToRL (ParMS ms1 ms2) =+  let+    ps1 = mergeableSequenceToRL ms1+    ps2 = mergeableSequenceToRL ms2+  in+    case typedMerge (reverseRL ps1 :\/: reverseRL ps2) of+      (ps2', _) -> ps1 +<<+ ps2'++-- | Generate an arbitrary sequence of patches, using a generator+-- for the underlying patch type and merging.+-- The sequence uses a given start state and is bounded by a+-- given depth.+arbitraryMergeableSequence+  :: forall model p wX+   . ( RepoModel model+     , CheckedMerge p+     , PrimBased p+     , Apply p, ApplyState p ~ RepoState model+     )+  => (forall wA . model wA -> Gen (Sealed (WithEndState model (OnlyPrim p wA))))+  -> model wX+  -> Int+  -> Gen (Sealed (WithEndState model (MergeableSequence p wX)))+arbitraryMergeableSequence arbitrarySingle = go+  where+    go rm depth+      | depth == 0 = return $ Sealed $ WithEndState NilMS rm+      | otherwise =+        frequency+          [ ( 1+            , do Sealed (WithEndState ms rm') <- go rm (depth - 1)+                 Sealed (WithEndState p rm'') <- arbitrarySingle rm'+                 return $ Sealed $ WithEndState (SeqMS ms p) rm'')+          , ( 3+            , do Sealed (WithEndState ms1 _) <- go rm ((depth + 1) `div` 2)+                 Sealed (WithEndState ms2 _) <- go rm (depth `div` 2)+                 let ps1 = mergeableSequenceToRL ms1+                     ps2 = mergeableSequenceToRL ms2+                 case validateMerge @p (typedMerge (reverseRL ps1 :\/:reverseRL ps2)) of+                   Nothing -> go rm depth+                   Just (ps2', _) ->+                     return $+                       Sealed $+                       WithEndState (parMS ms1 ms2) $ unFail $ repoApply rm (ps1 +>>+ ps2')+            )+          ]++instance+  ( RepoModel model+  , Apply p, ApplyState p ~ RepoState model+  , model ~ ModelOf (OnlyPrim p)+  , model ~ ModelOf p+  , CheckedMerge p+  , PrimBased p+  )+  => ArbitraryState (MergeableSequence p) where+  arbitraryState rm = bSized 3 0.035 9 $ arbitraryMergeableSequence arbitraryState rm
+ harness/Darcs/Test/Patch/Types/Merged.hs view
@@ -0,0 +1,31 @@+module Darcs.Test.Patch.Types.Merged+  ( Merged+  , typedMerge+  ) where++import Darcs.Test.Patch.Merge.Checked+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Merge ( Merge(..), mergerFLFL )++-- | A witness type that makes the result witness of merging explicit:+--+--  wB    ----> Merged wA wB+--   ^           ^+--   |           |+--   |           |+--  wBase ----> wA+--+-- It's quite ad hoc, for example we don't define a type for 'wBase'.+data Merged wA wB++-- | A wrapper around 'merge' for FL that checks each individual merge,+-- and also returns a more strongly typed witness than the usual existential.+typedMerge+  :: CheckedMerge p+  => (FL p :\/: FL p) wA wB+  -> (FL p wA (Merged wA wB), FL p wB (Merged wA wB))+typedMerge (p :\/: q) =+  case mergerFLFL (checkedMerger merge) (p :\/: q) of+    (q' :/\: p') -> (unsafeCoercePEnd q', unsafeCoercePEnd p')+
+ harness/Darcs/Test/Patch/Types/Pair.hs view
@@ -0,0 +1,15 @@+module Darcs.Test.Patch.Types.Pair ( Pair(..) ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Show++import Darcs.Test.Patch.RepoModel++newtype Pair p wX wY = Pair { getPair :: (p :> p) wX wY }+  deriving Show++instance Show2 p => Show2 (Pair p)++type instance ModelOf (Pair p) = ModelOf p
+ harness/Darcs/Test/Patch/Types/Triple.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Types.Triple+  ( Triple(..)+  ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.WithState+    ( ArbitraryState(..)+    , WithEndState(..)+    , ArbitraryWS(..)+    , makeWS2Gen+    )++newtype Triple p wX wY = Triple { getTriple :: (p :> p :> p) wX wY }+  deriving Show++instance Show2 p => Show2 (Triple p)++type instance ModelOf (Triple p) = ModelOf p++instance ArbitraryState p => ArbitraryState (Triple p) where+  arbitraryState sIn = do+    Sealed (WithEndState p sOut) <- arbitraryState sIn+    return (Sealed (WithEndState (Triple p) sOut))++instance (RepoModel (ModelOf p), ArbitraryState p) => ArbitraryWS (Triple p) where+  arbitraryWS = makeWS2Gen aSmallRepo
harness/Darcs/Test/Patch/Utils.hs view
@@ -8,7 +8,6 @@     , PropList     , properties     , testCases-    , fromNothing     ) where  import Darcs.Prelude@@ -60,17 +59,8 @@           -> Test testCases name test datas = testCase name (mapM_ (assertNotFailed . test) datas) -class HasDefault a where-  def :: a--instance HasDefault Bool where-  def = False--instance HasDefault TestResult where-  def = rejected- newtype TestGenerator thing gen =-  TestGenerator (forall t. HasDefault t => (forall wX wY. thing wX wY -> t) -> (gen -> Maybe t))+  TestGenerator (forall t. (forall wX wY. thing wX wY -> t) -> (gen -> Maybe t))  newtype TestCondition thing =   TestCondition (forall wX wY. thing wX wY -> Bool)@@ -80,19 +70,16 @@  type PropList what gen = String -> TestGenerator what gen -> [Test] -fromNothing :: HasDefault a => Maybe a -> a-fromNothing = fromMaybe def- properties :: forall thing gen. (Show gen, Arbitrary gen)            => TestGenerator thing gen            -> String -> String-           -> forall t. (Testable t, HasDefault t) => [(String, TestCondition thing, TestCheck thing t)]+           -> forall t. (Testable t) => [(String, TestCondition thing, TestCheck thing t)]            -> [Test] properties (TestGenerator gen) prefix genname tests =   [cond name condition check | (name, condition, check) <- tests]   where     cond ::-         forall testable. (Testable testable, HasDefault testable)+         forall testable. (Testable testable)       => String       -> TestCondition thing       -> TestCheck thing testable@@ -100,5 +87,5 @@     cond t (TestCondition c) (TestCheck p) =       testConditional         (prefix ++ " (" ++ genname ++ "): " ++ t)-        (fromMaybe def . gen c)+        (fromMaybe False . gen c)         (gen p)
harness/Darcs/Test/Patch/V1Model.hs view
@@ -5,7 +5,6 @@   , makeRepo, emptyRepo   , makeFile, emptyFile   , emptyDir-  , nullRepo   , isFile, isDir   , fileContent, dirContent   , isEmpty
harness/Darcs/Test/Patch/WSub.hs view
@@ -28,6 +28,7 @@ import qualified Darcs.Patch.Witnesses.Ordered as W import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Maybe import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart, unsafeCoercePEnd ) @@ -135,5 +136,4 @@ getTriples = map (mapSeal2 fromW) . W.getTriples . toW  coalesce :: (Prim2 :> Prim2) wX wY -> Maybe (FL Prim2 wX wY)-coalesce = fmap fromW . W.coalesce . toW-+coalesce = fmap (fromW . maybeToFL) . W.coalesce . toW
harness/Darcs/Test/Patch/WithState.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE UndecidableInstances #-} module Darcs.Test.Patch.WithState where @@ -14,10 +15,12 @@ import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Show-import Test.QuickCheck ( Gen, Arbitrary(..), sized, choose )+import Test.QuickCheck ( Gen, sized, choose )  import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Arbitrary.Sealed import Darcs.Test.Patch.Arbitrary.Shrink+import Darcs.Test.Patch.Types.Pair ( Pair(..) )  import Data.Maybe @@ -45,6 +48,35 @@  instance (Show1 (ModelOf p), Show2 p) => Show2 (WithState p) +class ArbitraryWS p where+  arbitraryWS :: Gen (Sealed2 (WithState p))+  shrinkWS :: Sealed2 (WithState p) -> [Sealed2 (WithState p)]+  shrinkWS _ = []++instance ArbitraryWS p => ArbitraryS2 (WithState p) where+  arbitraryS2 = arbitraryWS+  shrinkS2 = shrinkWS++instance (ArbitraryState p1, ArbitraryState p2, ModelOf p1 ~ ModelOf p2, RepoModel (ModelOf p1)) => ArbitraryS2 (p1 :\/: p2) where+  arbitraryS2 = do+    repo <- aSmallRepo+    Sealed (WithEndState p1 _) <- arbitraryState repo+    Sealed (WithEndState p2 _) <- arbitraryState repo+    return (Sealed2 (p1 :\/: p2))++arbitraryWSPair :: (RepoModel (ModelOf p), ArbitraryState p) => Gen (Sealed2 (WithState (Pair p)))+arbitraryWSPair = do+  repo <- aSmallRepo+  Sealed (WithEndState pp repo') <- arbitraryStatePair repo+  return $ seal2 $ WithState repo pp repo'++instance (RepoModel (ModelOf p), ArbitraryState p) => ArbitraryWS (Pair p) where+  arbitraryWS = arbitraryWSPair+  shrinkWS _ = []++instance (RepoModel (ModelOf p), ArbitraryState p) => ArbitraryWS (FL p) where+  arbitraryWS = makeWS2Gen aSmallRepo+ -- | This is only used for the legacy 'Tree' based test generator, where the -- @p@ parameter gets instantiated to @'Tree' p@ (which has no definite end -- state).@@ -105,31 +137,27 @@ class ArbitraryState p where   arbitraryState :: ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (p wX))) +  -- |This member is to allow specialising generation of pairs,+  -- e.g. to increase the frequency of commutable ones.+  arbitraryStatePair :: ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (Pair p wX)))+  -- default implementation doesn't do anything special+  arbitraryStatePair s = do+    -- use the :> instance+    Sealed (WithEndState pair s') <- arbitraryState s+    return $ seal $ WithEndState (Pair pair) s'+ instance ArbitraryState p => ArbitraryState (WithState p) where   arbitraryState s = do Sealed (WithEndState x s') <- arbitraryState s                         return $ seal $ WithEndState (WithState s x s') s' -type instance ModelOf (p :> p) = ModelOf p--instance ArbitraryState p => ArbitraryState (p :> p) where-  arbitraryState s = do Sealed (WithEndState p1 s') <- arbitraryState s-                        Sealed (WithEndState p2 s'') <- arbitraryState s'-                        return $ seal $ WithEndState (p1 :> p2) s'' --{- the type instance overlaps!-type instance ModelOf (p :> p :> p) = ModelOf p--instance ArbitraryState p => ArbitraryState (p :> p :> p) where--}+-- this instance is only useful if ModelOf p ~ ModelOf q+type instance ModelOf (p :> q) = ModelOf p -arbitraryTriple :: ArbitraryState p-                => ModelOf p wX-                -> Gen (Sealed (WithEndState (ModelOf p) ((p :> p :> p) wX)))-arbitraryTriple s = do-  Sealed (WithEndState p1 s') <- arbitraryState s-  Sealed (WithEndState p2 s'') <- arbitraryState s'-  Sealed (WithEndState p3 s''') <- arbitraryState s''-  return $ seal $ WithEndState (p1 :> p2 :> p3) s'''+instance (ArbitraryState p, ArbitraryState q, ModelOf p ~ ModelOf q) => ArbitraryState (p :> q) where+  arbitraryState s = do+    Sealed (WithEndState p1 s') <- arbitraryState s+    Sealed (WithEndState p2 s'') <- arbitraryState s'+    return $ seal $ WithEndState (p1 :> p2) s''   arbitraryFL ::      ArbitraryState p@@ -144,11 +172,6 @@                                       arbitraryFL k s  -makeS2Gen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed2 p)-makeS2Gen stGen = do s <- stGen-                     Sealed (WithEndState p _) <- arbitraryState s-                     return $ seal2 p- makeSGen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed (p wX)) makeSGen stGen = do s <- stGen                     Sealed (WithEndState p _) <- arbitraryState s@@ -194,8 +217,7 @@   shrinkModelPatch :: ModelOf prim wX -> [Sealed (prim wX)]  checkOK :: Fail a -> [a]-checkOK (OK a) = [a]-checkOK (Failed _) = []+checkOK = maybe [] (\x -> [x]) . maybeFail  shrinkModel   :: forall s prim wX@@ -278,19 +300,19 @@   , Apply prim, ApplyState prim ~ RepoState s   , prim ~ PrimOf p, Invert prim, ShrinkModel prim, PropagateShrink prim p   )-  => Arbitrary (Sealed2 (WithStartState2 p)) where-  arbitrary = do+  => ArbitraryS2 (WithStartState2 p) where+  arbitraryS2 = do     repo <- aSmallRepo @s     Sealed (WithEndState p _) <- arbitraryState repo     return (Sealed2 (WithStartState2 repo p))-  shrink w@(Sealed2 (WithStartState2 repo p)) =+  shrinkS2 w@(Sealed2 (WithStartState2 repo p)) =     map (Sealed2 . WithStartState2 repo) (shrinkInternally p) ++     map (unseal (Sealed2 . WithStartState2 repo)) (shrinkAtEnd p) ++     map (unsealFlipped Sealed2) (shrinkAtStartState (WithStartState2 repo p)) ++     shrinkState @s @prim @p w  propagatePrim-  :: (Eq2 prim, PrimCanonize prim, Invert prim, Commute prim)+  :: (Eq2 prim, PrimCoalesce prim, Invert prim, Commute prim)   => (prim :> prim) wX wY -> Maybe ((Maybe2 prim :> Maybe2 prim) wX wY) propagatePrim (p1 :> p2)   | IsEq <- invert p1 =\/= p2 = Just (Nothing2 :> Nothing2)
harness/Darcs/Test/Repository/Inventory.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} module Darcs.Test.Repository.Inventory where  import Darcs.Prelude@@ -5,11 +6,10 @@ import Darcs.Repository.Inventory     ( Inventory(..)     , HeadInventory-    , ValidHash(..)+    , ValidHash     , InventoryHash     , PatchHash     , PristineHash-    , mkValidHash     , parseInventory     , showInventory     , skipPristineHash@@ -20,17 +20,21 @@     , prop_skipPokePristineHash     ) import Darcs.Patch.Info ( rawPatchInfo )+import Darcs.Util.Hash ( sha256strict ) import Darcs.Util.Printer ( renderPS )+import Darcs.Util.ValidHash ( decodeValidHash, fromHash, fromSizeAndHash )  import Darcs.Test.Patch.Info ()  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC+import Data.Maybe ( fromJust ) import Test.Framework ( Test, testGroup ) import Test.Framework.Providers.HUnit ( testCase ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.HUnit ( Assertion, (@=?) ) import Test.QuickCheck+import Test.QuickCheck.Instances.ByteString ()  testSuite :: Test testSuite = testGroup "Darcs.Repository.Inventory"@@ -41,9 +45,6 @@  , testCase "example2" (testInventory rawHeadInv2 headInv2)  ] -instance Arbitrary B.ByteString where-  arbitrary = B.pack <$> arbitrary- instance Arbitrary Inventory where   arbitrary = uncurry Inventory <$> arbitrary @@ -55,9 +56,14 @@   arbitrary = arbitraryHash  arbitraryHash :: ValidHash h => Gen h-arbitraryHash = mkValidHash <$> do-  n <- elements [64, 75] -- see D.R.Cache.okayHash-  vectorOf n $ elements $ '-' : (['0'..'9'] ++ ['a'..'f'])+arbitraryHash = do+  content       <- arbitrary+  size_prefixed <- arbitrary+  let size = B.length content+      hash = sha256strict content+  if size_prefixed && size < 1000000000+    then return (fromSizeAndHash size hash)+    else return (fromHash hash)  testInventory :: B.ByteString -> HeadInventory -> Assertion testInventory raw (hash,inv) = do@@ -66,6 +72,9 @@   Right inv @=? parseInventory rest   rest @=? renderPS (showInventory inv)   raw @=? renderPS (pokePristineHash hash rest)++mkValidHash :: ValidHash a => String -> a+mkValidHash = fromJust . decodeValidHash  headInv1 :: HeadInventory headInv1 =
+ harness/Darcs/Test/Shell.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE CPP, OverloadedStrings, ExtendedDefaultRules, RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Darcs.Test.Shell+    ( Format(..)+    , DiffAlgorithm(..)+    , UseIndex(..)+    , UseCache(..)+    , findShell+    ) where++import Darcs.Prelude++import Control.Exception ( SomeException )+import Data.Data ( Data, Typeable )+import Data.Text ( Text, pack, unpack )+import qualified Data.Text as T+import qualified Shelly ( FilePath, run )+import Shelly+    ( Sh+    , catch_sh+    , cd+    , cp+    , fromText+    , get_env_text+    , initOutputHandles+    , lastExitCode+    , lastStderr+    , mkdir+    , mkdir_p+    , onCommandHandles+    , pwd+    , setenv+    , shelly+    , silently+    , sub+    , toTextIgnore+    , withTmpDir+    , writefile+    , (</>)+    )+import qualified System.FilePath as Native ( searchPathSeparator, splitSearchPath )+import System.FilePath ( makeRelative, takeBaseName, takeDirectory )+import qualified System.FilePath.Posix as Posix ( searchPathSeparator )+import System.IO ( hSetBinaryMode )+import Test.Framework.Providers.API+    ( Test(..)+    , TestResultlike(..)+    , Testlike(..)+    , liftIO+    , runImprovingIO+    , yieldImprovement+    )++data Format = Darcs1 | Darcs2 | Darcs3 deriving (Show, Eq, Typeable, Data)+data DiffAlgorithm = Myers | Patience deriving (Show, Eq, Typeable, Data)+data UseIndex = NoIndex | WithIndex deriving (Show, Eq, Typeable, Data)+data UseCache = NoCache | WithCache deriving (Show, Eq, Typeable, Data)++data ShellTest = ShellTest+  { format :: Format+  , testfile :: FilePath+  , testdir :: Maybe FilePath -- ^ only if you want to set it explicitly+  , darcspath :: FilePath+  , diffalgorithm :: DiffAlgorithm+  , useindex :: UseIndex+  , usecache :: UseCache+  } deriving (Typeable)++data Running = Running deriving Show+data Result = Success | Skipped | Failed String++instance Show Result where+  show Success = "Success"+  show Skipped = "Skipped"+  show (Failed f) = unlines (map ("| " ++) $ lines f)++instance TestResultlike Running Result where+  testSucceeded Success = True+  testSucceeded Skipped = True+  testSucceeded _ = False++instance Testlike Running Result ShellTest where+  testTypeName _ = "Shell"+  runTest _ test =+    runImprovingIO $ do+      yieldImprovement Running+      liftIO (shelly $ runtest test)++-- | Environment variable values may need translating depending on whether we+-- are setting them directly or writing out a shell script to set them, and+-- depending on the kind of value and the platform. This type captures the+-- different kinds of values.+data EnvItem+  = EnvString String+    -- ^ A normal string that won't need conversion+  | EnvFilePath Shelly.FilePath+    -- ^ A path on disk that may need conversion for the platform+  | EnvSearchPath [Shelly.FilePath]+    -- ^ A list of paths on disk, for the PATH variable++runtest' :: ShellTest -> Text -> Sh Result+runtest' ShellTest{..} srcdir =+  do+    wd <- pwd+    p  <- unpack <$> get_env_text "PATH"+    let pathToUse =+          map (fromText . pack) $ takeDirectory darcspath : Native.splitSearchPath p+    let env =+          [ ("HOME"                      , EnvFilePath wd)+          -- in case someone has XDG_CACHE_HOME set:+          , ("XDG_CACHE_HOME"            , EnvFilePath (wd </> ".cache"))+          , ("TESTDATA", EnvFilePath (srcdir </> "tests" </> "data"))+          , ("TESTBIN", EnvFilePath (srcdir </> "tests" </> "bin"))+          , ("DARCS_TESTING_PREFS_DIR"   , EnvFilePath $ wd </> ".darcs")+          , ("EMAIL"                     , EnvString "tester")+          , ("GIT_AUTHOR_NAME"           , EnvString "tester")+          , ("GIT_AUTHOR_EMAIL"          , EnvString "tester")+          , ("GIT_COMMITTER_NAME"        , EnvString "tester")+          , ("GIT_COMMITTER_EMAIL"       , EnvString "tester")+          , ("DARCS_DONT_COLOR"          , EnvString "1")+          , ("DARCS_DONT_ESCAPE_ANYTHING", EnvString "1")+          , ("PATH"                      , EnvSearchPath pathToUse)+          -- the DARCS variable is passed to the tests purely so they can+          -- double-check that the darcs on the path is the expected one,+          -- so is passed as a string directly without any translation+          , ("DARCS"                     , EnvString darcspath)+          , ("GHC_VERSION", EnvString $ show (__GLASGOW_HASKELL__ :: Int))+          -- https://www.joshkel.com/2018/01/18/symlinks-in-windows/+          , ("MSYS"                      , EnvString "winsymlinks:nativestrict")+          ]+    -- we write the variables to a shell script and source them from there in+    -- ./lib, so that it's easy to reproduce a test failure after running the+    -- harness with -d.+    writefile "env" $ T.unlines $ map+      (\(k, v) -> T.concat ["export ", k, "=", envItemForScript v])+      env+    -- just in case the test script doesn't source ./lib:+    mapM_ (\(k, v) -> setenv k (envItemForEnv v)) env++    mkdir ".darcs"+    writefile ".darcs/defaults" defaults+    _ <-+      onCommandHandles (initOutputHandles (\h -> hSetBinaryMode h True))+        $ Shelly.run "bash" ["test"]+    return Success+  `catch_sh` \(_ :: SomeException) -> do+               code <- lastExitCode+               case code of+                 200 -> return Skipped+                 _   -> Failed <$> unpack <$> lastStderr+  where+    defaults =+      pack+        $  unlines+        $  [ "ALL " ++ fmtstr+           , "send no-edit-description"+           , "ALL " ++ uif+           , "ALL " ++ daf+           ]+        ++ ucf+    fmtstr = case format of+      Darcs3 -> "darcs-3"+      Darcs2 -> "darcs-2"+      Darcs1 -> "darcs-1"+    daf = case diffalgorithm of+      Patience -> "patience"+      Myers    -> "myers"+    uif = case useindex of+      WithIndex -> "no-ignore-times"+      NoIndex   -> "ignore-times"+    ucf = case usecache of+      WithCache -> []+      NoCache   -> ["ALL no-cache"]++    -- convert an 'EnvItem' to a string you can put in the environment directly+    envItemForEnv :: EnvItem -> Text+    envItemForEnv (EnvString   v) = pack v+    envItemForEnv (EnvFilePath v) = toTextIgnore v+    envItemForEnv (EnvSearchPath vs) =+      T.intercalate (T.singleton Native.searchPathSeparator) $ map toTextIgnore vs++    -- convert an 'EnvItem' to a string that will evaluate to the right value+    -- when embedded in a bash script+    envItemForScript :: EnvItem -> Text+    envItemForScript (EnvString   v) = quoteForShell (pack v)+    envItemForScript (EnvFilePath v) = filePathForScript v+    envItemForScript (EnvSearchPath vs) =+      -- note the use of the Posix search path separator (':') regardless of platform+      T.intercalate (T.singleton Posix.searchPathSeparator)+        $ map filePathForScript vs++    -- add quotes around a 'Shelly.FilePath'+    quotedFilePath :: Shelly.FilePath -> Text+    quotedFilePath = quoteForShell . toTextIgnore++    quoteForShell :: Text -> Text+    quoteForShell = surround '\'' . T.replace "'" "'\\''"+      where surround c t = T.cons c $ T.snoc t c++    -- convert a 'Shelly.FilePath' into a string that will evaluate to the right+    -- value when put in a bash script+    filePathForScript :: Shelly.FilePath -> Text+#ifdef WIN32+    -- we have a native Windows path, but we are going to put it in an bash+    -- script run in an environment like msys2 which works with an illusion+    -- of a Unix style filesystem. Calling cygpath at runtime does the+    -- necessary translation.+    filePathForScript v = T.concat ["$(cygpath ", quotedFilePath v, ")"]+#else+    filePathForScript v = quotedFilePath v+#endif++runtest :: ShellTest -> Sh Result+runtest test@ShellTest{..} =+  withTmp $ \dir -> do+    cp "tests/lib" dir+    cp "tests/network/sshlib" dir+    cp "tests/network/httplib" dir+    cp (fromText $ pack $ testfile) (dir </> "test")+    srcdir <- pwd+    silently $ sub $ cd dir >> runtest' test (toTextIgnore srcdir)+  where+    withTmp =+      case testdir of+        Just dir ->+          \job -> do+            let d =+                  dir </> show format </> show diffalgorithm </>+                  show useindex </>+                  show usecache </>+                  takeTestName testfile+            mkdir_p d+            job d+        Nothing -> withTmpDir++findShell+  :: FilePath+  -> [FilePath]+  -> Maybe FilePath+  -> [DiffAlgorithm]+  -> [Format]+  -> [UseIndex]+  -> [UseCache]+  -> IO [Test]+findShell dp files tdir diffAlgorithms repoFormats useindexs usecaches =+  do+    return+      [ shellTest+          ShellTest+            { format = fmt+            , testfile = file+            , testdir = tdir+            , darcspath = dp+            , diffalgorithm = da+            , useindex = ui+            , usecache = uc+            }+      | file <- files+      , fmt <- repoFormats+      , da <- diffAlgorithms+      , ui <- useindexs+      , uc <- usecaches+      ]++shellTest :: ShellTest -> Test+shellTest test@ShellTest{..} = Test name test+  where+    name =+      concat+        [ unpack (toTextIgnore (takeTestName testfile))+        , " ("+        , show format+        , ","+        , show diffalgorithm+        , ","+        , show useindex+        , ","+        , show usecache+        , ")"+        ]++takeTestName :: FilePath -> Shelly.FilePath+takeTestName n =+  let n' = makeRelative "tests" n+   in takeBaseName (takeDirectory n') </> takeBaseName n'
harness/Darcs/Test/TestOnly/Instance.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} module Darcs.Test.TestOnly.Instance where  import Darcs.Test.TestOnly
+ harness/Darcs/Test/UI.hs view
@@ -0,0 +1,11 @@+module Darcs.Test.UI ( testSuite ) where++import qualified Darcs.Test.UI.Commands.Test ( testSuite )++import Test.Framework ( Test, testGroup )++testSuite :: Test+testSuite =+  testGroup "Darcs.UI"+    [ Darcs.Test.UI.Commands.Test.testSuite+    ]
+ harness/Darcs/Test/UI/Commands/Test.hs view
@@ -0,0 +1,13 @@+module Darcs.Test.UI.Commands.Test ( testSuite ) where++import qualified Darcs.Test.UI.Commands.Test.Commutable ( testSuite )+import qualified Darcs.Test.UI.Commands.Test.Simple ( testSuite )++import Test.Framework ( Test, testGroup )++testSuite :: Test+testSuite =+  testGroup "Darcs.UI.Commands.Test"+    [ Darcs.Test.UI.Commands.Test.Simple.testSuite+    , Darcs.Test.UI.Commands.Test.Commutable.testSuite+    ]
+ harness/Darcs/Test/UI/Commands/Test/Commutable.hs view
@@ -0,0 +1,252 @@+module Darcs.Test.UI.Commands.Test.Commutable ( testSuite ) where++import Darcs.Prelude+import qualified Darcs.Util.IndexedMonad as Indexed++import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Set ( Origin )+import Darcs.Patch.Witnesses.Ordered+  ( (:>)(..) , FL(..) , RL(..) , consGapFL , mapFL , reverseFL )+import Darcs.Patch.Witnesses.Sealed+  ( Sealed(..), unseal, mapSeal, Sealed2(..)+  , FreeLeft, unFreeLeft, Gap(..)+  )++import Darcs.UI.Commands.Test.Impl+  ( TestRunner(..), TestResult(..), TestResultValid(..), TestFailure(..)+  , runStrategy, StrategyResultRaw(..)+  , PatchSeq(..), patchTreeToFL+  )+import qualified Darcs.UI.Options.All as O++import Darcs.Test.UI.Commands.Test.IndexedApply ( IndexedApply(..) )++import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.HUnit ( testCase )+import Test.HUnit ( assertEqual )++testSuite :: Test+testSuite =+  testGroup "Darcs.UI.Commands.Test.Commutable"+    [ testGroup "Generic test cases" $ map genericTestCases [O.Linear, O.Bisect, O.Backoff]+    ]+++genericTestCases :: O.TestStrategy -> Test+genericTestCases testStrategy =+  testGroup (show testStrategy) $ map (expectedResult testStrategy)+    [ ("Unminimisable sequence",+           ([StdDeps CreateTest, StdDeps BreakTest],+            Blame [1],+            Blame [1]+           )+      )+    , ("Simple minimisation",+           ([StdDeps CreateTest, StdDeps BreakCompile, StdDeps BreakTest, StdDeps FixCompile],+            Blame [1,2,3],+            Blame [2])+      )+    , ("Longer minimisation",+           ([ StdDeps CreateTest, StdDeps BreakCompile, StdDeps Irrelevant, StdDeps Irrelevant+            , StdDeps BreakTest, StdDeps Irrelevant, StdDeps Irrelevant, StdDeps FixCompile+            ],+            Blame [1..7],+            Blame [4])+      )+    , ("Simple internal dependency",+           ([ StdDeps CreateTest+            , ExtraDeps 1 [] BreakCompile+            , ExtraDeps 2 [1] Irrelevant+            , StdDeps BreakTest+            , StdDeps FixCompile+            ],+            Blame [1..4],+            Blame [3])+      )+    , ("Simple internal dependency with extra patch",+           ([ StdDeps CreateTest+            , ExtraDeps 1 [] BreakCompile+            , ExtraDeps 2 [1] Irrelevant+            , StdDeps BreakTest+            , StdDeps Irrelevant+            , StdDeps FixCompile+            ],+            Blame [1..5],+            Blame [3])+      )+    , ("Complex dependencies",+           ([ StdDeps CreateTest+            , ExtraDeps 1 []  BreakCompile+            , ExtraDeps 2 [1] Irrelevant+            , ExtraDeps 3 []  Irrelevant+            , ExtraDeps 4 [3] BreakTest+            , ExtraDeps 5 [2] Irrelevant+            , ExtraDeps 6 [2] FixCompile+            ],+            Blame [1..6],+            Blame [4])+      )+    , ("Joined blame sequence",+           ([ StdDeps CreateTest+            , ExtraDeps 1 []  BreakCompile+            , ExtraDeps 2 [1]  BreakTest+            , ExtraDeps 3 [2] FixCompile+            ],+            Blame [1,2,3],+            Blame [1,2,3])+      )+    ]+++type ExpectedResult =+  ( [WithDeps Transition]+  -- result without shrinking+  , StrategyResultRaw [Int]+  -- result with shrinking+  , StrategyResultRaw [Int]+  )++expectedResult :: O.TestStrategy -> (String, ExpectedResult) -> Test+expectedResult testStrategy (testName, (testDetails, expectedNoShrinkingResult, expectedShrinkingResult)) =+  testCase testName $ do+    let+      noShrinkingResult = runStrategyOn testStrategy O.NoShrinkFailure testDetails+      shrinkingResult = runStrategyOn testStrategy O.ShrinkFailure testDetails+    assertEqual "Unexpected result without shrinking" expectedNoShrinkingResult noShrinkingResult+    assertEqual "Unexpected result with shrinking" expectedShrinkingResult shrinkingResult+++runStrategyOn :: O.TestStrategy -> O.ShrinkFailure -> [WithDeps Transition] -> StrategyResultRaw [Int]+runStrategyOn testStrategy shrinkFailure transitions =+  let initialState = TS CompileWorking TestNonExistent+      finalState = foldl (flip applyTransition) initialState (map withDepsContents transitions) in+  unseal (fmap toPatchNums . fst . flip runTestingMonad finalState . runStrategy testStrategy shrinkFailure)+         (genPatchSequence initialState transitions)++toPatchNums :: Sealed2 (PatchSeq Patch) -> [Int]+toPatchNums (Sealed2 ps) = mapFL (\(Patch n _ _) -> n) (patchTreeToFL ps)++genPatchSequence :: TestingState -> [WithDeps Transition] -> Sealed (RL Patch Origin)+genPatchSequence initialState transitions =+  mapSeal reverseFL $ unFreeLeft $ doGen 0 initialState transitions+  where+    doGen :: Int -> TestingState -> [WithDeps Transition] -> FreeLeft (FL Patch)+    doGen _ _ [] = emptyGap NilFL+    doGen n startingState (t:ts) =+      consGapFL (patch n t)+         (doGen (n+1) (applyTransition (withDepsContents t) startingState) ts)+++data Transition =+    CreateTest | RemoveTest+  | BreakTest | FixTest+  | BreakCompile | FixCompile+  | Irrelevant+  deriving Show++type Deps = (Maybe Int, [Int])++data WithDeps a = StdDeps a | ExtraDeps Int [Int] a++withDepsContents :: WithDeps a -> a+withDepsContents (StdDeps v) = v+withDepsContents (ExtraDeps _ _ v) = v++data TestStatus = TestNonExistent | TestWorking | TestBroken+  deriving Show++data CompileStatus = CompileWorking | CompileBroken+  deriving Show++data TestingState =+  TS+  { tsCompile :: CompileStatus+  , tsTest :: TestStatus+  }+  deriving Show+++invertTransition :: Transition -> Transition+invertTransition CreateTest   = RemoveTest+invertTransition RemoveTest   = CreateTest+invertTransition BreakTest    = FixTest+invertTransition FixTest      = BreakTest+invertTransition BreakCompile = FixCompile+invertTransition FixCompile   = BreakCompile+invertTransition Irrelevant   = Irrelevant++commutableTransition :: (Transition, Transition) -> Bool+commutableTransition (Irrelevant, _) = True+commutableTransition (_, Irrelevant) = True+commutableTransition (t1, t2) = (forTest t1 && forCompile t2) || (forCompile t1 && forTest t2)+  where+    forTest CreateTest = True+    forTest RemoveTest = True+    forTest BreakTest  = True+    forTest FixTest    = True+    forTest _          = False+    forCompile BreakCompile = True+    forCompile FixCompile   = True+    forCompile _ = False++applyTransition :: Transition -> TestingState -> TestingState+applyTransition Irrelevant  s = s+applyTransition CreateTest s@TS { tsTest = TestNonExistent } = s { tsTest = TestWorking     }+applyTransition RemoveTest s@TS { tsTest = TestWorking     } = s { tsTest = TestNonExistent }+applyTransition BreakTest  s@TS { tsTest = TestWorking     } = s { tsTest = TestBroken      }+applyTransition FixTest    s@TS { tsTest = TestBroken      } = s { tsTest = TestWorking     }+applyTransition BreakCompile s@TS { tsCompile = CompileWorking } = s { tsCompile = CompileBroken  }+applyTransition FixCompile   s@TS { tsCompile = CompileBroken  } = s { tsCompile = CompileWorking }+applyTransition transition state =+  error $ "Invalid transition " ++ show transition ++ " applied to state " ++ show state++data Patch wX wY = Patch Int Deps Transition++patch :: Int -> WithDeps Transition -> Patch wX wY+patch n (StdDeps t) = Patch n (Nothing, []) t+patch n (ExtraDeps name deps t) = Patch n (Just name, deps) t++instance Invert Patch where+  invert (Patch n deps t) = Patch n deps (invertTransition t)++instance Commute Patch where+  commute (Patch n1 d1@(name1, _) t1 :> Patch n2 d2@(_, deps2) t2)+    | name1 `elem` map Just deps2 = Nothing+    | commutableTransition (t1, t2) = Just (Patch n2 d2 t2 :> Patch n1 d1 t1)+    | otherwise = Nothing++toTestResult :: TestingState -> TestResult wX+toTestResult (TS { tsCompile = CompileBroken }                           ) = Untestable+toTestResult (TS { tsCompile = CompileWorking, tsTest = TestNonExistent }) = Untestable+toTestResult (TS { tsCompile = CompileWorking, tsTest = TestWorking     }) = Testable Success+toTestResult (TS { tsCompile = CompileWorking, tsTest = TestBroken      }) = Testable (Failure (TestFailure 1))++data TestingMonad wX wY a = TestingMonad { runTestingMonad :: TestingState -> (a, TestingState) }++instance Indexed.Monad TestingMonad where+  return v = TestingMonad (\n -> (v, n))+  m >>= f = TestingMonad (\n1 -> let (a, n2) = runTestingMonad m n1 in runTestingMonad (f a) n2)+  m1 >> m2 = TestingMonad (\n1 -> let (_, n2) = runTestingMonad m1 n1 in runTestingMonad m2 n2)++instance IndexedApply Patch where+  type ApplyState Patch = TestingMonad++  apply (Patch _ _ transition) =+    TestingMonad $ \s -> ((), applyTransition transition s)++  unapply (Patch _ _ transition) =+    TestingMonad $ \s -> ((), applyTransition (invertTransition transition) s)++instance TestRunner TestingMonad where+  type ApplyPatchReqs TestingMonad p = (IndexedApply p, ApplyState p ~ TestingMonad)+  type DisplayPatchReqs TestingMonad p = p ~ Patch++  writeMsg _ = Indexed.return ()+  mentionPatch _ = Indexed.return ()+  finishedTesting v = TestingMonad (\_ -> (v, error "something tried to read final testing state"))++  getCurrentTestResult = TestingMonad (\n -> (toTestResult n, n))++  applyPatch = apply+  unapplyPatch = unapply
+ harness/Darcs/Test/UI/Commands/Test/IndexedApply.hs view
@@ -0,0 +1,36 @@+module Darcs.Test.UI.Commands.Test.IndexedApply+  ( IndexedApply(..)    +  ) where++import Darcs.Util.IndexedMonad++import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )++import Darcs.UI.Commands.Test.Impl ( PatchSeq(..) )++-- our own indexed monad Apply class+class IndexedApply p where+  type ApplyState p :: * -> * -> * -> *+  apply :: Monad (ApplyState p) => p wX wY -> ApplyState p wX wY ()+  unapply :: Monad (ApplyState p) => p wX wY -> ApplyState p wY wX ()++instance IndexedApply p => IndexedApply (FL p) where+  type ApplyState (FL p) = ApplyState p+  apply NilFL = return ()+  apply (p :>: ps) = apply p >> apply ps+  unapply NilFL = return ()+  unapply (p :>: ps) = unapply ps >> unapply p++instance IndexedApply p => IndexedApply (RL p) where+  type ApplyState (RL p) = ApplyState p+  apply NilRL = return ()+  apply (ps :<: p) = apply ps >> apply p+  unapply NilRL = return ()+  unapply (ps :<: p) = unapply p >> unapply ps++instance IndexedApply p => IndexedApply (PatchSeq p) where+  type ApplyState (PatchSeq p) = ApplyState p+  apply (Single p) = apply p+  apply (Joined p1 p2) = apply p1 >> apply p2+  unapply (Single p) = unapply p+  unapply (Joined p1 p2) = unapply p2 >> unapply p1
+ harness/Darcs/Test/UI/Commands/Test/Simple.hs view
@@ -0,0 +1,221 @@+module Darcs.Test.UI.Commands.Test.Simple ( testSuite ) where++import Darcs.Prelude+import qualified Darcs.Util.IndexedMonad as Indexed++import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Set ( Origin )+import Darcs.Patch.Witnesses.Ordered+  ( RL(..), FL(..), consGapFL, reverseFL, mapFL, (:>)(..) )+import Darcs.Patch.Witnesses.Sealed+  ( Sealed(..), unseal, mapSeal, Sealed2(..)+  , FreeLeft, unFreeLeft, Gap(..)+  )+import Darcs.Patch.Witnesses.Show ( Show2(..) )++import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands.Test.Impl+  ( TestRunner(..), TestResult(..), TestResultValid(..), TestFailure(..)+  , runStrategy, StrategyResultRaw(..)+  , PatchSeq(..), patchTreeToFL+  )++import Darcs.Test.UI.Commands.Test.IndexedApply ( IndexedApply(..) )++import Data.Constraint ( Dict(..) )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework ( Test, testGroup )+import Test.HUnit ( assertEqual )+import Test.QuickCheck ( Arbitrary(..), Gen, Property, property, Discard(..), forAll, forAllShrink )+import Test.QuickCheck.Gen ( listOf, listOf1, frequency, elements )++testSuite :: Test+testSuite =+  testGroup "Darcs.UI.Commands.Test.Simple"+    [ testGroup "Generic test cases" $ map genericTestCases [O.Linear, O.Bisect, O.Backoff]+    , testGroup "Randomised tests of linear" [linearRandomised]+    , testGroup "Randomised tests against linear" $ map genericRandomised [O.Bisect, O.Backoff]+    ]++genericTestCases :: O.TestStrategy -> Test+genericTestCases testStrategy =+  testGroup (show testStrategy) $ map (expectedResult testStrategy)+    [ ("Sequence ending in success", ((U, [S]), NoFailureOnHead))+    , ("Sequence with no passes (1)", ((U, [F]), NoPasses))+    , ("Sequence with no passes (2)", ((F, [F]), NoPasses))+    , ("Sequence with simple failure (1)", ((S, [F]), Blame [0]))+    , ("Sequence with simple failure (2)", ((S, [S,S,F,F]), Blame [2]))+    , ("Sequence with untestable states", ((S, [S,S,U,U,F,F]), Blame [2,3,4]))+    , ("Sequence with initial untestable states", ((U, [U,U,U,U,U,U,U,S,S,U,U,F,F]), Blame [9,10,11]))+    ]++type ExpectedResult = ((TestingState, [TestingState]), StrategyResultRaw [Int])++expectedResult :: O.TestStrategy -> (String, ExpectedResult) -> Test+expectedResult testStrategy (testName, (testDetails, expectedTestResult)) =+  testCase testName $ do+  -- whether we try to shrink or not is irrelevant as nothing will commute+    let result = runStrategyOn testStrategy O.NoShrinkFailure testDetails+    assertEqual "Unexpected result" expectedTestResult result++genericRandomised :: O.TestStrategy -> Test+genericRandomised testStrategy =+  testGroup (show testStrategy)+    [ testProperty "simple sequence" (simpleSequence testStrategy)+    , testProperty "multi sequence" (multiSequence testStrategy)+    ]++linearRandomised :: Test+linearRandomised =+  testGroup (show O.Linear)+    [ testProperty "blame is found when possible" (findBlame O.Linear)+    ]++simpleSequence :: O.TestStrategy -> SimpleSequenceDefinition -> Bool+simpleSequence testStrategy sequenceDef =+  let s = ssdToTestDetails sequenceDef in+  runStrategyOn O.Linear O.NoShrinkFailure s == runStrategyOn testStrategy O.NoShrinkFailure s++-- tests that if we stick multiple sequences each with a single "blame sequence"+-- together, the strategy finds one of those sequences+multiSequence :: O.TestStrategy -> Property+multiSequence testStrategy =+  forAllShrink (listOf1 arbitraryBlameSSD) shrink $ \sequenceDefs ->+    let+      allTestDetails = map ssdToTestDetails sequenceDefs+      mergeDetails (i1, s1) (i2, s2) = (i1, s1 ++ [i2] ++ s2)+      adjustedResults _ [] = Just []+      adjustedResults n (x:xs) =+        case (runStrategyOn O.Linear O.NoShrinkFailure x, adjustedResults (n + 1 + length (snd x)) xs) of+          (Blame ps, Just ys) -> Just (Blame (map (+n) ps) : ys)+          _ -> Nothing+    in+      case adjustedResults 0 allTestDetails of+        Nothing -> property Discard+        Just [] -> property Discard+        Just res -> property $+                       runStrategyOn testStrategy O.NoShrinkFailure (foldr1 mergeDetails allTestDetails) `elem` res++findBlame :: O.TestStrategy -> Property+findBlame testStrategy =+  forAll arbitraryBlameSSD $ \s ->+    case runStrategyOn testStrategy O.NoShrinkFailure (ssdToTestDetails s) of+      Blame _ -> True+      _ -> False++-- a sequence of test results guaranteed to be monotonic in success/failure+data SimpleSequenceDefinition =+  SimpleSequenceDefinition+  { successPart :: [TestingState] -- contains either S or U+  , middlePart  :: TestingState   -- either S, F or U - exists to guarantee the joined list is non-empty+  , failurePart :: [TestingState] -- contains either F or U+  }+  deriving Show++ssdToTestDetails :: SimpleSequenceDefinition -> (TestingState, [TestingState])+ssdToTestDetails ssd =+  case successPart ssd ++ [middlePart ssd] ++ failurePart ssd of+    x:xs -> (x, xs)+    _ -> error "internal error: impossible empty list in ssdToTestDetails"++instance Arbitrary SimpleSequenceDefinition where+  arbitrary = do+    s <- listOf (frequency [(1, r S), (3, r U)])+    m <- frequency [(1, r S), (5, r U), (1, r F)]+    f <- listOf (frequency [(1, r F), (3, r U)])+    return $ SimpleSequenceDefinition s m f+   where r = return++  shrink (SimpleSequenceDefinition s m f) =+    map (SimpleSequenceDefinition s m) (shrink f) +++    map (\s' -> SimpleSequenceDefinition s' m f) (shrink s)++-- an arbitrary that's guaranteed to produce a sequence that results in Blame xxx+arbitraryBlameSSD :: Gen SimpleSequenceDefinition+arbitraryBlameSSD = do+  s1 <- listOf (frequency [(1, r S), (3, r U)])+  s2 <- listOf (frequency [(1, r S), (3, r U)])+  m <- frequency [(1, r S), (5, r U), (1, r F)]+  f <- listOf (frequency [(1, r F), (3, r U)])+  return $ SimpleSequenceDefinition (s1 ++ [S] ++ s2) m (f ++ [F])+ where r = return++instance Arbitrary TestingState where+  arbitrary = elements [S, U, F]+  shrink _ = []++data TestingState = S | U | F+   deriving (Eq, Show)++data TrivialPatch wX wY = TrivialPatch Int TestingState TestingState+  deriving Show++instance Show2 TrivialPatch where+  showDict2 = Dict++runStrategyOn :: O.TestStrategy -> O.ShrinkFailure -> (TestingState, [TestingState]) -> StrategyResultRaw [Int]+runStrategyOn testStrategy shrinkFailure (initialState, patchStates) =+  let finalState = last (initialState:patchStates) in+  unseal (fmap toPatchNums . fst . flip runTestingMonad finalState . runStrategy testStrategy shrinkFailure)+         (genPatchSequence initialState patchStates)++toPatchNums :: (Sealed2 (PatchSeq TrivialPatch)) -> [Int]+toPatchNums (Sealed2 ps) = mapFL (\(TrivialPatch n _ _) -> n) (patchTreeToFL ps)++genPatchSequence :: TestingState -> [TestingState] -> Sealed (RL TrivialPatch Origin)+genPatchSequence initialState patchStates =+  mapSeal reverseFL $ unFreeLeft $ doGen 0 initialState patchStates+  where+    doGen :: Int -> TestingState -> [TestingState] -> FreeLeft (FL TrivialPatch)+    doGen _ _ [] = emptyGap NilFL+    doGen n startingState (nextState:states) =+      consGapFL (TrivialPatch n startingState nextState) (doGen (n+1) nextState states)++instance Invert TrivialPatch where+  invert (TrivialPatch num ov nv) = TrivialPatch num nv ov++instance Commute TrivialPatch where+  commute (_ :> _) = Nothing++data TestingMonad wX wY a = TestingMonad { runTestingMonad :: TestingState -> (a, TestingState) }++instance Indexed.Monad TestingMonad where+  return v = TestingMonad (\n -> (v, n))+  m >>= f = TestingMonad (\n1 -> let (a, n2) = runTestingMonad m n1 in runTestingMonad (f a) n2)+  m1 >> m2 = TestingMonad (\n1 -> let (_, n2) = runTestingMonad m1 n1 in runTestingMonad m2 n2)++toTestResult :: TestingState -> TestResult wX+toTestResult S = Testable Success+toTestResult U = Untestable+toTestResult F = Testable (Failure (TestFailure 1))++instance IndexedApply TrivialPatch where+  type ApplyState TrivialPatch = TestingMonad+  apply (TrivialPatch num old new) =+    TestingMonad $ \st ->+      if st == old+        then ((), new)+        else error $ "state mismatch for patch " ++ show num+                          ++ ", expected " ++ show old ++ ", got " ++ show st++  unapply (TrivialPatch num old new) =+    TestingMonad $ \st ->+      if st == new+        then ((), old)+        else error $ "state mismatch for patch " ++ show num+                          ++ ", expected " ++ show new ++ ", got " ++ show st++instance TestRunner TestingMonad where+  type ApplyPatchReqs TestingMonad p = (IndexedApply p, ApplyState p ~ TestingMonad)+  type DisplayPatchReqs TestingMonad p = p ~ TrivialPatch++  writeMsg _ = Indexed.return ()+  mentionPatch _ = Indexed.return ()+  finishedTesting v = TestingMonad (\_ -> (v, error "something tried to read final testing state"))++  getCurrentTestResult = TestingMonad (\n -> (toTestResult n, n))++  applyPatch = apply+  unapplyPatch = unapply
harness/test.hs view
@@ -1,238 +1,39 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable, ViewPatterns, OverloadedStrings, ExtendedDefaultRules #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main ( main, run, defaultConfig, Config(..) ) where  import Darcs.Prelude +import qualified Darcs.Test.Email+import qualified Darcs.Test.HashedStorage import qualified Darcs.Test.Misc import qualified Darcs.Test.Patch-import qualified Darcs.Test.Patch.RepoPatchV1-import qualified Darcs.Test.Email import qualified Darcs.Test.Repository.Inventory-import qualified Darcs.Test.HashedStorage+import Darcs.Test.Shell+import qualified Darcs.Test.UI import Darcs.Util.Exception ( die ) -import Control.Monad ( filterM )-import Control.Exception ( SomeException )-import Data.Text ( Text, pack, unpack )-import qualified Data.Text as T+import Control.Monad ( filterM, unless, when ) import Data.List ( isPrefixOf, isSuffixOf, sort ) import GHC.IO.Encoding ( textEncodingName ) import System.Console.CmdArgs hiding ( args ) import System.Console.CmdArgs.Explicit ( process )-import System.Directory ( doesFileExist )+import System.Directory ( doesFileExist, doesPathExist, exeExtension, listDirectory ) import System.Environment.FindBin ( getProgPath )-import System.FilePath( takeDirectory, takeBaseName, isAbsolute, makeRelative )-import qualified System.FilePath as Native ( searchPathSeparator, splitSearchPath )-import qualified System.FilePath.Posix as Posix ( searchPathSeparator )-import System.IO( hSetBinaryMode, hSetBuffering, BufferMode( NoBuffering ), stdin, stdout, stderr, localeEncoding )-import Test.Framework.Providers.API-  ( TestResultlike(..), Testlike(..), Test, runImprovingIO, yieldImprovement, Test(..), liftIO )-import Test.Framework ( defaultMainWithArgs )-import Shelly hiding ( liftIO, run, FilePath, path )-import qualified Shelly--doUnit :: IO [Test]-doUnit = return unitTests---- | TODO make runnable in parallel-doHashed :: IO [Test]-doHashed = return Darcs.Test.HashedStorage.tests---- | This is the big list of tests that will be run using testrunner.-unitTests :: [Test]-unitTests =-  [ Darcs.Test.Email.testSuite-  , Darcs.Test.Misc.testSuite-  , Darcs.Test.Repository.Inventory.testSuite-  ] ++ (Darcs.Test.Patch.RepoPatchV1.testSuite : Darcs.Test.Patch.testSuite)---- ------------------------------------------------------------------------- shell tests--- ------------------------------------------------------------------------data Format = Darcs1 | Darcs2 | Darcs3 deriving (Show, Eq, Typeable, Data)-data DiffAlgorithm = MyersDiff | PatienceDiff deriving (Show, Eq, Typeable, Data)-data Running = Running deriving Show-data Result = Success | Skipped | Failed String--instance Show Result where-  show Success = "Success"-  show Skipped = "Skipped"-  show (Failed f) = unlines (map ("| " ++) $ lines f)--instance TestResultlike Running Result where-  testSucceeded Success = True-  testSucceeded Skipped = True-  testSucceeded _ = False--data ShellTest = ShellTest { format :: Format-                           , testfile :: FilePath-                           , testdir  :: Maybe FilePath -- ^ only if you want to set it explicitly-                           , _darcspath :: FilePath-                           , diffalgorithm :: DiffAlgorithm-                           }-                 deriving Typeable---- |Environment variable values may need translating depending--- on whether we are setting them directly or writing out a shell script--- to set them, and depending on the kind of value and the platform.--- This type captures the different kinds of values.-data EnvItem-  = EnvString String  -- ^ A normal string that won't need conversion-  | EnvFilePath Shelly.FilePath -- ^ A path on disk that may need conversion for the platform-  | EnvSearchPath [Shelly.FilePath] -- ^ A list of paths on disk, for the PATH variable--runtest' :: ShellTest -> Text -> Sh Result-runtest' (ShellTest fmt _ _ dp da) srcdir =-  do wd <- pwd-     p <- unpack <$> get_env_text "PATH"-     let pathToUse = map (fromText . pack) $ takeDirectory dp:Native.splitSearchPath p-     let env =-          [ ("HOME", EnvFilePath wd)-          -- in case someone has XDG_CACHE_HOME set:-          , ("XDG_CACHE_HOME", EnvFilePath (wd </> ".cache"))-          , ("TESTDATA", EnvFilePath (srcdir </> "tests" </> "data"))-          , ("TESTBIN", EnvFilePath (srcdir </> "tests" </> "bin"))-          , ("DARCS_TESTING_PREFS_DIR", EnvFilePath $ wd </> ".darcs")-          , ("EMAIL", EnvString "tester")-          , ("GIT_AUTHOR_NAME", EnvString "tester")-          , ("GIT_AUTHOR_EMAIL", EnvString "tester")-          , ("GIT_COMMITTER_NAME", EnvString "tester")-          , ("GIT_COMMITTER_EMAIL", EnvString "tester")-          , ("DARCS_DONT_COLOR", EnvString "1")-          , ("DARCS_DONT_ESCAPE_ANYTHING", EnvString "1")-          , ("PATH", EnvSearchPath pathToUse)-          -- the DARCS variable is passed to the tests purely so they can-          -- double-check that the darcs on the path is the expected one,-          -- so is passed as a string directly without any translation-          , ("DARCS", EnvString dp)-          , ("GHC_VERSION", EnvString $ show (__GLASGOW_HASKELL__ :: Int))-          ]-     -- we write the variables to a shell script and source them from there in ./lib,-     -- so that it's easy to reproduce a test failure after running the harness with -d.-     writefile "env" $ T.unlines $-        map (\(k,v) -> T.concat ["export ", k, "=", envItemForScript v]) env-     -- just in case the test script doesn't source ./lib:-     mapM_ (\(k,v) -> setenv k (envItemForEnv v)) env--     mkdir ".darcs"-     writefile ".darcs/defaults" defaults-     _ <- onCommandHandles (initOutputHandles (\h -> hSetBinaryMode h True)) $-          Shelly.run "bash" [ "test" ]-     return Success-   `catch_sh` \(_::SomeException)-                 -> do code <- lastExitCode-                       case code of-                        200 -> return Skipped-                        _   -> Failed <$> unpack <$> lastStderr-  where defaults = pack $ unlines-          [ "ALL " ++ fmtstr-          , "send no-edit-description"-          , "ALL ignore-times"-          , "ALL " ++ daf-          ]-        fmtstr = case fmt of-                  Darcs3 -> "darcs-3"-                  Darcs2 -> "darcs-2"-                  Darcs1 -> "darcs-1"-        daf = case da of-                PatienceDiff -> "patience"-                MyersDiff -> "myers"--        -- convert an 'EnvItem' to a string you can put in the environment directly-        envItemForEnv :: EnvItem -> Text-        envItemForEnv (EnvString v) = pack v-        envItemForEnv (EnvFilePath v) = toTextIgnore v-        envItemForEnv (EnvSearchPath vs) =-          T.intercalate (T.singleton Native.searchPathSeparator) $ map toTextIgnore vs--        -- convert an 'EnvItem' to a string that will evaluate to the right value-        -- when embedded in a bash script-        envItemForScript :: EnvItem -> Text-        envItemForScript (EnvString v) = pack (show v)-        envItemForScript (EnvFilePath v) = filePathForScript v-        envItemForScript (EnvSearchPath vs) =-           -- note the use of the Posix search path separator (':') regardless of platform-           T.intercalate (T.singleton Posix.searchPathSeparator) $ map filePathForScript vs--        -- add quotes around a 'Shelly.FilePath'-        quotedFilePath :: Shelly.FilePath -> Text-        quotedFilePath = pack . show . toTextIgnore--        -- convert a 'Shelly.FilePath' into a string that will evaluate to the right-        -- value when put in a bash script-        filePathForScript :: Shelly.FilePath -> Text-#ifdef WIN32-        -- we have a native Windows path, but we are going to put it in an bash script-        -- run in an environment like msys2 which works with an illusion of a Unix style-        -- filesystem. Calling cygpath at runtime does the necessary translation.-        filePathForScript v = T.concat ["$(cygpath ", quotedFilePath v, ")"]-#else-        filePathForScript v = quotedFilePath v-#endif--takeTestName :: FilePath -> Shelly.FilePath-takeTestName n =-  let n' = makeRelative "tests" n in-    takeBaseName (takeDirectory n') </> takeBaseName n'--runtest :: ShellTest -> Sh Result-runtest t =- withTmp $ \dir -> do-  cp "tests/lib" dir-  cp "tests/network/sshlib" dir-  cp "tests/network/httplib" dir-  cp (fromText $ pack $ testfile t) (dir </> "test")-  srcdir <- pwd-  silently $ sub $ cd dir >> runtest' t (toTextIgnore srcdir)- where-  withTmp =-   case testdir t of-     Just dir -> \job -> do-       let d = (dir </> show (format t) </> show (diffalgorithm t) </> takeTestName (testfile t))-       mkdir_p d-       job d-     Nothing  -> withTmpDir--instance Testlike Running Result ShellTest where-  testTypeName _ = "Shell"-  runTest _ test = runImprovingIO $ do yieldImprovement Running-                                       liftIO (shelly $ runtest test)--shellTest :: FilePath -> Format -> Maybe FilePath -> String -> DiffAlgorithm -> Test-shellTest dp fmt tdir file da =-  Test (toString (takeTestName file) ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $-  ShellTest fmt file tdir dp da--toString :: Shelly.FilePath -> String-toString = unpack . toTextIgnore--findShell :: FilePath -> Text -> Maybe FilePath -> Bool -> [DiffAlgorithm] -> [Format] -> Sh [Test]-findShell dp sdir tdir isFailing diffAlgorithms repoFormats =-  do files <- ls (fromText sdir)-     let test_files = sort $ filter relevant $ filter (hasExt "sh") files-     return [ shellTest dp fmt tdir file da-            | file <- map toString test_files-            , fmt <- repoFormats-            , da <- diffAlgorithms ]-  where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`) . takeBaseName . toString---- ------------------------------------------------------------------------- harness--- ----------------------------------------------------------------------+import System.FilePath ( isAbsolute, takeBaseName, takeDirectory, (</>) )+import System.IO ( BufferMode(NoBuffering), hSetBuffering, localeEncoding, stdout )+import Test.Framework+    ( ColorMode(..)+    , RunnerOptions'(..)+    , Seed(..)+    , TestOptions'(..)+    , defaultMainWithOpts+    ) -data Config = Config { hashed :: Bool-                     , failing :: Bool-                     , shell :: Bool-                     , network :: Bool-                     , unit :: Bool-                     , myers :: Bool-                     , patience :: Bool-                     , darcs1 :: Bool-                     , darcs2 :: Bool-                     , darcs3 :: Bool+data Config = Config { suites :: String+                     , formats :: String+                     , diffalgs :: String+                     , index :: String+                     , cache :: String                      , full :: Bool                      , darcs :: String                      , tests :: [String]@@ -241,7 +42,7 @@                      , hideSuccesses :: Bool                      , threads :: Int                      , qcCount :: Int-                     , replay :: Maybe Integer+                     , replay :: Maybe Int                      }             deriving (Data, Typeable, Eq, Show) @@ -249,17 +50,12 @@ defaultConfigAnn :: Annotate Ann defaultConfigAnn  = record Config{}-     [ hashed        := False    += help "Run hashed-storage tests [no]"-     , failing       := False    += help "Run the failing (shell) tests [no]"-     , shell         := True     += help "Run the passing, non-network shell tests [yes]"-     , network       := True     += help "Run the network shell tests [yes]"-     , unit          := True     += help "Run the unit tests [yes]"-     , myers         := False    += help "Use myers diff [no]"-     , patience      := True     += help "Use patience diff [yes]" += name "p"-     , darcs1        := True     += help "Use darcs-1 repo format [yes]" += name "1"-     , darcs2        := True     += help "Use darcs-2 repo format [yes]" += name "2"-     , darcs3        := True     += help "Use darcs-3 repo format [yes]" += name "3"-     , full          := False    += help "Run all tests in all variants"+     [ suites        := "snu"    += help "Select which test suites to run: (s=shell, n=network, u=unit, f=failing, h=hashed) [snu]" += typ "SET"+     , formats       := "123"    += help "Select which darcs formats to test: (1=darcs-1, 2=darcs-2, 3=darcs-3) [123]" += name "f" += typ "SET"+     , diffalgs      := "p"      += help "Select which diff alorithms to use (p=patience, m=myers) [p]" += name "a" += typ "SET"+     , index         := "y"      += help "Select whether to use the index (n=no, y=yes) [y]" += typ "SET"+     , cache         := "y"      += help "Select whether to use the cache (n=no, y=yes) [y]" += typ "SET"+     , full          := False    += help "Shortcut for -s=snu -f=123 -a=mp -c=yn -i=yn"      , darcs         := ""       += help "Darcs binary path" += typ "PATH"      , tests         := []       += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t"      , testDir       := Nothing  += help "Directory to run tests in" += typ "PATH" += name "d"@@ -273,98 +69,162 @@    += program "darcs-test"  defaultConfig :: Config-Right defaultConfig = fmap cmdArgsValue $ process (cmdArgsMode_ defaultConfigAnn) []+defaultConfig =+  case process (cmdArgsMode_ defaultConfigAnn) [] of+    Right r -> cmdArgsValue r+    Left _ -> error "impossible" +-- | Find the darcs executable to test+findDarcs :: IO FilePath+findDarcs = do+  path <- getProgPath+  let darcsExe = "darcs" ++ exeExtension+      candidates =+        -- if darcs-test lives in foo/something, look for foo/darcs[.exe] for+        -- example if we've done cabal install -ftest, there'll be a darcs-test+        -- and darcs in the cabal installation folder+        [path </> darcsExe] +++        -- if darcs-test lives in foo/darcs-test/something, look for+        -- foo/darcs/darcs[.exe] for example after cabal build we can run+        -- .../build/darcs-test/darcs-test and it'll find the darcs in+        -- .../build/darcs/darcs+        [ takeDirectory path </> "darcs" </> darcsExe+        | takeBaseName path == "darcs-test"+        ] +++        -- some versions of cabal produce more complicated structures:+        -- t/darcs-test/build/darcs-test/darcs-test and x/darcs/build/darcs/darcs+        [ takeDirectory path </> ".." </> ".." </> ".." </> "x" </> "darcs" </>+            "build" </> "darcs" </> darcsExe+        | takeBaseName path == "darcs-test"+        ] +++        [ takeDirectory path </> ".." </> ".." </> ".." </> ".." </> "x" </>+            "darcs" </> "noopt" </> "build" </> "darcs" </> darcsExe+        | takeBaseName path == "darcs-test"+        ]+  availableCandidates <- filterM doesFileExist candidates+  case availableCandidates of+    (result:_) -> do+      putStrLn $ "Using darcs executable in " ++ takeDirectory result+      return result+    [] ->+      die ("No darcs specified or found nearby. Tried:\n" ++ unlines candidates)+ run :: Config -> IO () run conf = do-    let args = [ "-j", show $ threads conf ]-             ++ concat [ ["-t", x ] | x <- tests conf ]-             ++ [ "--plain" | True <- [plain conf] ]-             ++ [ "--hide-successes" | True <- [hideSuccesses conf] ]-                -- this multiplier is calibrated against the observed behaviour of the test harness --                -- increase it if we see lots of "arguments exhausted" errors or similar-             ++ [ "--maximum-unsuitable-generated-tests", show (7 * qcCount conf) ]-             ++ [ "--maximum-generated-tests", show (qcCount conf) ]-             ++ [ "--test-seed="++show seed | Just seed <- [replay conf] ]     case testDir conf of        Nothing -> return ()-       Just d  -> do e <- shelly (test_e (fromText $ pack d))-                     when e $ die ("Directory " ++ d ++ " already exists. Cowardly exiting")+       Just d  -> do+          e <- doesPathExist d+          when e $ die ("Directory " ++ d ++ " already exists. Cowardly exiting")++    let hashed   = 'h' `elem` suites conf+        failing  = 'f' `elem` suites conf+        shell    = 's' `elem` suites conf+        network  = 'n' `elem` suites conf+        unit     = 'u' `elem` suites conf++        darcs1   = '1' `elem` formats conf+        darcs2   = '2' `elem` formats conf+        darcs3   = '3' `elem` formats conf++        myers    = 'm' `elem` diffalgs conf+        patience = 'p' `elem` diffalgs conf++        noindex   = 'n' `elem` index conf+        withindex = 'y' `elem` index conf++        nocache   = 'n' `elem` cache conf+        withcache = 'y' `elem` cache conf+     darcsBin <--        case darcs conf of-            "" -> do-                path <- getProgPath-                let candidates =-                      -- if darcs-test lives in foo/something, look for foo/darcs[.exe]-                      -- for example if we've done cabal install -ftest, there'll be a darcs-test and darcs in the cabal-                      -- installation folder-                      [path </> ("darcs" ++ exeSuffix)] ++-                      -- if darcs-test lives in foo/darcs-test/something, look for foo/darcs/darcs[.exe]-                      -- for example after cabal build we can run dist/build/darcs-test/darcs-test and it'll find-                      -- the darcs in dist/build/darcs/darcs-                      [takeDirectory path </> "darcs" </> ("darcs" ++ exeSuffix) | takeBaseName path == "darcs-test" ] ++-                      -- nowadays cabal v2-build produces more complicated structures:-                      -- t/darcs-test/build/darcs-test/darcs-test and x/darcs/build/darcs/darcs-                      [takeDirectory path </> ".." </> ".." </> ".." </> "x"-                                          </> "darcs" </> "build" </> "darcs" </> ("darcs" ++ exeSuffix)-                            | takeBaseName path == "darcs-test" ] ++-                      [takeDirectory path </> ".." </> ".." </> ".." </> ".." </> "x"-                                          </> "darcs" </> "noopt" </> "build" </> "darcs" </> ("darcs" ++ exeSuffix)-                            | takeBaseName path == "darcs-test" ]-                availableCandidates <- filterM doesFileExist (map toString candidates)-                case availableCandidates of-                     (darcsBin:_) -> do-                         putStrLn $ "Using darcs executable in " ++ darcsBin-                         return darcsBin-                     [] -> die ("No darcs specified or found nearby. Tried:\n" ++ unlines (map toString candidates))-            v -> return v-    when (shell conf || network conf || failing conf) $ do+      case darcs conf of+        "" -> findDarcs+        v -> return v+    when (shell || network || failing) $ do       unless (isAbsolute $ darcsBin) $         die ("Argument to --darcs should be an absolute path")-      unless (exeSuffix `isSuffixOf` darcsBin) $-        putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)"+      unless (exeExtension `isSuffixOf` darcsBin) $+        putStrLn $+          "Warning: --darcs flag does not end with " ++ exeExtension +++          " - some tests may fail (case does matter)"      putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding -    let repoFormat    = (if darcs1 conf then (Darcs1:) else id)-                      . (if darcs2 conf then (Darcs2:) else id)-                      . (if darcs3 conf then (Darcs3:) else id)+    let repoFormat    = (if darcs1 then (Darcs1:) else id)+                      . (if darcs2 then (Darcs2:) else id)+                      . (if darcs3 then (Darcs3:) else id)                       $ []-    let diffAlgorithm = (if myers conf then (MyersDiff:) else id)-                      . (if patience conf then (PatienceDiff:) else id)+    let diffAlgorithm = (if myers then (Myers:) else id)+                      . (if patience then (Patience:) else id)                       $ []+    let useIndex      = (if noindex then (NoIndex:) else id)+                      . (if withindex then (WithIndex:) else id)+                      $ []+    let useCache      = (if nocache then (NoCache:) else id)+                      . (if withcache then (WithCache:) else id)+                      $ [] -    stests <- shelly $-      if shell conf-        then findShell darcsBin "tests" (testDir conf) (failing conf) diffAlgorithm repoFormat+    let findTestFiles dir = select . map (dir </>) <$> listDirectory dir+          where+            filter_failing =+              if failing+                then id+                else filter $ not . ("failing-" `isPrefixOf`) . takeBaseName+            select = sort . filter_failing . filter (".sh" `isSuffixOf`)++    stests <-+      if shell+        then do+          files <- findTestFiles "tests"+          findShell darcsBin files (testDir conf) diffAlgorithm+            repoFormat useIndex useCache         else return []-    utests <- if unit conf then doUnit else return []-    ntests <- shelly $ if network conf then findShell darcsBin "tests/network" (testDir conf) (failing conf) diffAlgorithm repoFormat else return []-    hstests <- if hashed conf then doHashed else return []-    defaultMainWithArgs (stests ++ utests ++ ntests ++ hstests) args-       where-          exeSuffix :: String-#ifdef WIN32-          exeSuffix = ".exe"-#else-          exeSuffix = ""-#endif+    ntests <-+      if network+        then do+          files <- findTestFiles "tests/network"+          findShell darcsBin files (testDir conf) diffAlgorithm+            repoFormat useIndex useCache+        else return []+    let utests =+          if unit then+            [ Darcs.Test.Email.testSuite+            , Darcs.Test.Misc.testSuite+            , Darcs.Test.Repository.Inventory.testSuite+            , Darcs.Test.UI.testSuite+            ] +++            Darcs.Test.Patch.testSuite+          else []+        hstests = if hashed then Darcs.Test.HashedStorage.tests else [] +    let testRunnerOptions = RunnerOptions+          { ropt_threads = Just (threads conf)+          , ropt_test_options = Just $ TestOptions+              { topt_seed = FixedSeed <$> replay conf+              , topt_maximum_generated_tests = Just (qcCount conf)+              , topt_maximum_unsuitable_generated_tests = Just (7 * qcCount conf)+              , topt_maximum_test_size = Nothing+              , topt_maximum_test_depth = Nothing+              , topt_timeout = Nothing+              }+          , ropt_test_patterns =+              if null (tests conf) then Nothing else Just (map read (tests conf))+          , ropt_xml_output = Nothing+          , ropt_xml_nested = Nothing+          , ropt_color_mode = if plain conf then Just ColorNever else Nothing+          , ropt_hide_successes = Just (hideSuccesses conf)+          , ropt_list_only = Nothing+          }+    defaultMainWithOpts (stests ++ utests ++ ntests ++ hstests) testRunnerOptions+ main :: IO ()-main = do hSetBinaryMode stdout True-          hSetBuffering stdout NoBuffering-          hSetBinaryMode stderr True-          hSetBinaryMode stdin True+main = do hSetBuffering stdout NoBuffering           clp  <- cmdArgs_ defaultConfigAnn           run $             if full clp then clp-              { hashed   = True-              , shell    = True-              , network  = True-              , unit     = True-              , myers    = True-              , patience = True-              , darcs1   = True-              , darcs2   = True+              { formats  = "123"+              , diffalgs = "mp"+              , index = "yn"+              , cache = "yn"               }             else clp
release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.16.5\nGanesh Sittampalam <ganesh@earth.li>**20220220083531\n Ignore-this: 51417cb5dd488dc0d962ffb051f63ee1\n] \n"+Just "\nContext:\n\n\n[TAG 2.18.1\nGanesh Sittampalam <ganesh@earth.li>**20240225173219\n Ignore-this: dc3a92eafcab9d4fa9f53b1811d4c99d330615a8c202bff1b77f44d551d21684eee81e96c69be62b\n] \n"
src/Darcs/Patch.hs view
@@ -18,9 +18,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  module Darcs.Patch-    ( RepoType-    , IsRepoType-    , PrimPatchBase(..)+    ( PrimPatchBase(..)     , Named     , ApplyState     , rmfile@@ -33,7 +31,7 @@     , anonymous     , binary     , description-    , showContextPatch+    , showPatchWithContext     , ShowPatchFor(..)     , showPatch     , displayPatch@@ -42,9 +40,6 @@     , changepref     , thing     , things-    , primIsAddfile-    , primIsHunk-    , primIsSetpref     , merge     , commute     , listTouchedFiles@@ -55,17 +50,14 @@     , resolveConflicts     , Effect     , effect-    , primIsBinary-    , primIsAdddir     , invert     , invertFL     , invertRL-    , dropInverses     , commuteFL     , commuteRL     , readPatch     , readPatchPartial-    , canonize+    , canonizeFL     , sortCoalesceFL     , tryToShrink     , patchname@@ -85,6 +77,7 @@     , listConflictedFiles     , isInconsistent     , module Darcs.Patch.RepoPatch+    , module Darcs.Patch.PatchInfoAnd     ) where  @@ -93,7 +86,7 @@ import Darcs.Patch.Commute ( commute, commuteFL, commuteRL ) import Darcs.Patch.Conflict ( resolveConflicts ) import Darcs.Patch.Effect ( Effect(effect) )-import Darcs.Patch.Invert ( invert, invertRL, invertFL, dropInverses )+import Darcs.Patch.Invert ( invert, invertRL, invertFL ) import Darcs.Patch.Inspect ( listTouchedFiles, hunkMatches ) import Darcs.Patch.Merge ( merge ) import Darcs.Patch.Named ( Named,@@ -103,20 +96,18 @@                            infopatch,                            patch2patchinfo, patchname, patchcontents ) import Darcs.Patch.FromPrim ( PrimPatchBase(..) )-import Darcs.Patch.Prim ( canonize,+import Darcs.Patch.Prim ( canonizeFL,                           sortCoalesceFL,                           rmdir, rmfile, tokreplace, adddir, addfile,                           binary, changepref, hunk, move,-                          primIsAdddir, primIsAddfile,-                          primIsHunk, primIsBinary, primIsSetpref,                           tryToShrink,                           PrimPatch ) import Darcs.Patch.Read ( readPatch, readPatchPartial ) import Darcs.Patch.Repair ( isInconsistent ) import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.RepoType ( RepoType, IsRepoType ) import Darcs.Patch.Show ( description, showPatch, content, displayPatch-                        , summary, summaryFL, thing, things, ShowPatchFor(..), ShowContextPatch(..) )+                        , summary, summaryFL, thing, things, ShowPatchFor(..)+                        , showPatchWithContext ) import Darcs.Patch.Summary     ( listConflictedFiles     , xmlSummary@@ -124,3 +115,8 @@     , plainSummaryPrims     ) import Darcs.Patch.TokenReplace ( forceTokReplace )+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , hopefully+    , info+    )
src/Darcs/Patch/Annotate.hs view
@@ -30,6 +30,7 @@ -- Stability   : experimental -- Portability : portable +{-# OPTIONS_GHC -Wno-orphans #-} module Darcs.Patch.Annotate     (       annotateFile@@ -43,7 +44,8 @@  import Darcs.Prelude -import Control.Monad.State ( modify, modify', when, gets, State, execState )+import Control.Monad ( when )+import Control.Monad.State ( modify, modify', gets, execState )  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC@@ -56,9 +58,10 @@  import qualified Darcs.Patch.Prim.FileUUID as FileUUID +import Darcs.Patch.Annotate.Class import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FromPrim ( PrimOf(..) )-import Darcs.Patch.Info ( PatchInfo(..), displayPatchInfo, piAuthor, makePatchname )+import Darcs.Patch.Info ( displayPatchInfo, piAuthor, makePatchname ) import Darcs.Patch.Invert ( Invert, invert ) import Darcs.Patch.Named ( patchcontents ) import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd, hopefully )@@ -74,33 +77,6 @@                      | Directory                        deriving (Show, Eq) -type AnnotateResult = V.Vector (Maybe PatchInfo, B.ByteString)--data Content2 f g-  = FileContent (f (g B.ByteString))-  | DirContent (f (g AnchoredPath))--data Annotated2 f g = Annotated2-    { annotated     :: !AnnotateResult-    , current       :: !(Content2 f g)-    , currentPath   :: (Maybe AnchoredPath)-    , currentInfo   :: PatchInfo-    }--type Content = Content2 [] ((,) Int)-type Annotated = Annotated2 [] ((,) Int)--deriving instance Eq Content-deriving instance Show Content--deriving instance Eq Annotated-deriving instance Show Annotated--type AnnotatedM = State Annotated--class Annotate p where-  annotate :: p wX wY -> AnnotatedM ()- -- |This constraint expresses what is needed for a repo patch to -- support the high-level interface to annotation -- (currently annotateFile and annotateDirectory)@@ -149,7 +125,7 @@ instance Annotate FileUUID.Prim where   annotate _ = error "annotate not implemented for FileUUID patches" -annotatePIAP :: AnnotateRP p => PatchInfoAnd rt p wX wY -> AnnotatedM ()+annotatePIAP :: AnnotateRP p => PatchInfoAnd p wX wY -> AnnotatedM () annotatePIAP =   sequence_ . mapFL annotate . invert . effect . patchcontents . hopefully @@ -198,7 +174,7 @@ complete x = V.all (isJust . fst) $ annotated x  annotate' :: AnnotateRP p-          => RL (PatchInfoAnd rt p) wX wY+          => RL (PatchInfoAnd p) wX wY           -> Annotated           -> Annotated annotate' NilRL ann = ann@@ -207,7 +183,7 @@     | otherwise = annotate' ps $ execState (annotatePIAP p) (ann { currentInfo = info p })  annotateFile :: AnnotateRP p-             => RL (PatchInfoAnd rt p) wX wY+             => RL (PatchInfoAnd p) wX wY              -> AnchoredPath              -> B.ByteString              -> AnnotateResult@@ -221,7 +197,7 @@                         }  annotateDirectory :: AnnotateRP p-                  => RL (PatchInfoAnd rt p) wX wY+                  => RL (PatchInfoAnd p) wX wY                   -> AnchoredPath                   -> [AnchoredPath]                   -> AnnotateResult
+ src/Darcs/Patch/Annotate/Class.hs view
@@ -0,0 +1,37 @@+module Darcs.Patch.Annotate.Class where++import Darcs.Prelude++import Control.Monad.State ( State )+import qualified Data.ByteString as B+import qualified Data.Vector as V++import Darcs.Patch.Info ( PatchInfo )+import Darcs.Util.Path ( AnchoredPath )++type AnnotateResult = V.Vector (Maybe PatchInfo, B.ByteString)++data Content2 f g+  = FileContent (f (g B.ByteString))+  | DirContent (f (g AnchoredPath))++data Annotated2 f g = Annotated2+  { annotated :: !AnnotateResult+  , current :: !(Content2 f g)+  , currentPath :: (Maybe AnchoredPath)+  , currentInfo :: PatchInfo+  }++type Content = Content2 [] ((,) Int)+type Annotated = Annotated2 [] ((,) Int)++deriving instance Eq Content+deriving instance Show Content++deriving instance Eq Annotated+deriving instance Show Annotated++type AnnotatedM = State Annotated++class Annotate p where+  annotate :: p wX wY -> AnnotatedM ()
src/Darcs/Patch/Apply.hs view
@@ -26,6 +26,7 @@ module Darcs.Patch.Apply     (       Apply(..)+    , ObjectIdOfPatch     , applyToPaths     , applyToTree     , applyToState@@ -35,13 +36,15 @@  import Darcs.Prelude -import Control.Exception ( catch, IOException )+import Control.Exception ( IOException )+import Control.Monad.Catch ( MonadThrow, MonadCatch(catch) )  import Darcs.Util.Path ( AnchoredPath ) import Darcs.Util.Tree ( Tree )  import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) ) import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Object ( ObjectIdOf ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )  class Apply p where@@ -65,6 +68,7 @@     unapply NilRL = return ()     unapply (ps:<:p) = unapply p >> unapply ps +type ObjectIdOfPatch p = ObjectIdOf (ApplyState p)  effectOnPaths :: (Apply p, ApplyState p ~ Tree)               => p wX wY@@ -81,7 +85,7 @@ applyToPaths pa ofpos fs = withFileNames ofpos fs (apply pa)  -- | Apply a patch to a 'Tree', yielding a new 'Tree'.-applyToTree :: (Apply p, Monad m, ApplyState p ~ Tree)+applyToTree :: (Apply p, MonadThrow m, ApplyState p ~ Tree)             => p wX wY             -> Tree m             -> m (Tree m)@@ -95,7 +99,10 @@  -- | Attempts to apply a given patch to a Tree. If the apply fails, we return -- Nothing, otherwise we return the updated Tree.-maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO-                 -> IO (Maybe (Tree IO))+maybeApplyToTree+  :: (Apply p, ApplyState p ~ Tree, MonadCatch m)+  => p wX wY+  -> Tree m+  -> m (Maybe (Tree m)) maybeApplyToTree patch tree =-    (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing)+  (Just `fmap` applyToTree patch tree) `catch` (\(_::IOException) -> return Nothing)
src/Darcs/Patch/ApplyMonad.hs view
@@ -1,6 +1,8 @@-{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-} -- Copyright (C) 2010, 2011 Petr Rockai -- -- Permission is hereby granted, free of charge, to any person@@ -23,45 +25,43 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. module Darcs.Patch.ApplyMonad-  ( ApplyMonad(..), ApplyMonadTrans(..), ApplyMonadState(..)-  , withFileNames, withFiles, ToTree(..)+  ( ApplyMonad(..), ApplyMonadTrans(..), ApplyMonadOperations+  , withFileNames   , ApplyMonadTree(..)+  , evalApplyMonad   ) where  import Darcs.Prelude  import qualified Data.ByteString      as B import qualified Data.ByteString.Lazy as BL-import qualified Data.Map             as M import qualified Darcs.Util.Tree.Monad as TM+import Darcs.Patch.Object ( ObjectIdOf ) import Darcs.Util.Tree ( Tree ) import Data.Maybe ( fromMaybe ) import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix )+import Control.Monad.Catch ( MonadThrow(..) ) import Control.Monad.State.Strict-import Control.Monad.Identity( Identity )-import Darcs.Patch.MonadProgress+import Control.Monad.StrictIdentity (StrictIdentity(..) )  import GHC.Exts ( Constraint ) -class ToTree s where-  toTree :: s m -> Tree m--instance ToTree Tree where-  toTree = id- class (Monad m, ApplyMonad state (ApplyMonadOver state m))-      => ApplyMonadTrans (state :: (* -> *) -> *) m where+      => ApplyMonadTrans state m where   type ApplyMonadOver state m :: * -> *   runApplyMonad :: (ApplyMonadOver state m) x -> state m -> m (x, state m) -instance Monad m => ApplyMonadTrans Tree m where+instance MonadThrow m => ApplyMonadTrans Tree m where   type ApplyMonadOver Tree m = TM.TreeMonad m   runApplyMonad = TM.virtualTreeMonad -class ApplyMonadState (state :: (* -> *) -> *) where-  type ApplyMonadStateOperations state :: (* -> *) -> Constraint+evalApplyMonad+  :: ApplyMonadTrans state m => ApplyMonadOver state m a -> state m -> m a+evalApplyMonad action st = fst <$> runApplyMonad action st -class Monad m => ApplyMonadTree m where+type family ApplyMonadOperations (state :: (* -> *) -> *) :: (* -> *) -> Constraint++class MonadThrow m => ApplyMonadTree m where     -- a semantic, Tree-based interface for patch application     mDoesDirectoryExist ::  AnchoredPath -> m Bool     mDoesFileExist ::  AnchoredPath -> m Bool@@ -69,46 +69,31 @@     mCreateDirectory ::  AnchoredPath -> m ()     mRemoveDirectory ::  AnchoredPath -> m ()     mCreateFile ::  AnchoredPath -> m ()-    mCreateFile f = mModifyFilePS f $ \_ -> return B.empty     mRemoveFile ::  AnchoredPath -> m ()     mRename ::  AnchoredPath -> AnchoredPath -> m ()     mModifyFilePS ::  AnchoredPath -> (B.ByteString -> m B.ByteString) -> m ()     mChangePref ::  String -> String -> String -> m ()     mChangePref _ _ _ = return () -instance ApplyMonadState Tree where-    type ApplyMonadStateOperations Tree = ApplyMonadTree+type instance ApplyMonadOperations Tree = ApplyMonadTree -class ( Monad m, Monad (ApplyMonadBase m)-      , ApplyMonadStateOperations state m, ToTree state+class ( Monad m+      , ApplyMonadOperations state m       )-       -- ApplyMonadOver (ApplyMonadBase m) ~ m is *not* required in general,-       -- since ApplyMonadBase is not injective-       => ApplyMonad (state :: (* -> *) -> *) m where-    type ApplyMonadBase m :: * -> *--    nestedApply :: m x -> state (ApplyMonadBase m) -> m (x, state (ApplyMonadBase m))-    liftApply :: (state (ApplyMonadBase m) -> (ApplyMonadBase m) x) -> state (ApplyMonadBase m)-                 -> m (x, state (ApplyMonadBase m))--    getApplyState :: m (state (ApplyMonadBase m))+      => ApplyMonad (state :: (* -> *) -> *) m | m -> state where -instance Monad m => ApplyMonad Tree (TM.TreeMonad m) where-    type ApplyMonadBase (TM.TreeMonad m) = m-    getApplyState = gets TM.tree-    nestedApply a start = lift $ runApplyMonad a start-    liftApply a start = do x <- gets TM.tree-                           lift $ runApplyMonad (lift $ a x) start+    readFilePS :: ObjectIdOf state -> m B.ByteString -instance Monad m => ApplyMonadTree (TM.TreeMonad m) where+instance MonadThrow m => ApplyMonad Tree (TM.TreeMonad m) where+    readFilePS path = mReadFilePS path +instance MonadThrow m => ApplyMonadTree (TM.TreeMonad m) where     mDoesDirectoryExist p = TM.directoryExists p     mDoesFileExist p = TM.fileExists p-    mReadFilePS p = B.concat `fmap` BL.toChunks `fmap` TM.readFile p-    mModifyFilePS p j = do have <- TM.fileExists p-                           x <- if have then B.concat `fmap` BL.toChunks `fmap` TM.readFile p-                                        else return B.empty-                           TM.writeFile p . BL.fromChunks . (:[]) =<< j x+    mReadFilePS p = BL.toStrict <$> TM.readFile p+    mModifyFilePS p j =+      TM.writeFile p . BL.fromStrict =<< j . BL.toStrict =<< TM.readFile p+    mCreateFile p = TM.writeFile p BL.empty     mCreateDirectory p = TM.createDirectory p     mRename from to = TM.rename from to     mRemoveDirectory = TM.unlink@@ -118,8 +103,19 @@ type OrigFileNameOf = (AnchoredPath, AnchoredPath) -- Touched files, new file list (after removes etc.) and rename details type FilePathMonadState = ([AnchoredPath], [AnchoredPath], [OrigFileNameOf])-type FilePathMonad = State FilePathMonadState+type FilePathMonad = StateT FilePathMonadState Pure +newtype Pure a = Pure (StrictIdentity a)+  deriving (Functor, Applicative, Monad)++runPure :: Pure a -> a+runPure (Pure (StrictIdentity x)) = x++-- With "Data.Functor.Identity" this instance would not satisfy the law+-- @throwM e >> x = throwM e@, which is why we use 'StrictIdentity'.+instance MonadThrow Pure where+  throwM e = Pure (error (show e))+ -- |trackOrigRename takes an old and new name and attempts to apply the mapping -- to the OrigFileNameOf pair. If the old name is the most up-to-date name of -- the file in question, the first element of the OFNO will match, otherwise if@@ -136,17 +132,17 @@ -- present, a new list is generated from the filesnames. withFileNames :: Maybe [OrigFileNameOf] -> [AnchoredPath] -> FilePathMonad a     -> FilePathMonadState-withFileNames mbofnos fps x = execState x ([], fps, ofnos) where+withFileNames mbofnos fps x = runPure $ execStateT x ([], fps, ofnos)+  where     ofnos = fromMaybe (map (\y -> (y, y)) fps) mbofnos  instance ApplyMonad Tree FilePathMonad where-    type ApplyMonadBase FilePathMonad = Identity-+    readFilePS = error "readFilePS not defined for FilePathMonad"  instance ApplyMonadTree FilePathMonad where     -- We can't check it actually is a directory here     mDoesDirectoryExist p = gets $ \(_, fs, _) -> p `elem` fs-+    mDoesFileExist = mDoesDirectoryExist     mCreateDirectory = mCreateFile     mCreateFile f = modify $ \(ms, fs, rns) -> (f : ms, fs, rns)     mRemoveFile f = modify $ \(ms, fs, rns) -> (f : ms, filter (/= f) fs, rns)@@ -156,30 +152,4 @@                                    , map (movedirfilename a b) fs                                    , map (trackOrigRename a b) rns)     mModifyFilePS f _ = mCreateFile f--instance MonadProgress FilePathMonad where-  runProgressActions = silentlyRunProgressActions--type RestrictedApply = State (M.Map AnchoredPath B.ByteString)--instance ApplyMonad Tree RestrictedApply where-  type ApplyMonadBase RestrictedApply = Identity--instance ApplyMonadTree RestrictedApply where-  mDoesDirectoryExist _ = return True-  mCreateDirectory _ = return ()-  mRemoveFile f = modify $ M.delete f-  mRemoveDirectory _ = return ()-  mRename a b = modify $ M.mapKeys (movedirfilename a b)-  mModifyFilePS f j = do look <- gets $ M.lookup f-                         case look of-                           Nothing -> return ()-                           Just bits -> do-                             new <- j bits-                             modify $ M.insert f new--instance MonadProgress RestrictedApply where-  runProgressActions = silentlyRunProgressActions--withFiles :: [(AnchoredPath, B.ByteString)] -> RestrictedApply a -> [(AnchoredPath, B.ByteString)]-withFiles p x = M.toList $ execState x $ M.fromList p+    mReadFilePS = error "mReadFilePS not defined for FilePathMonad"
src/Darcs/Patch/Bundle.hs view
@@ -43,12 +43,8 @@     , pack     ) -import Darcs.Patch-    ( RepoPatch-    , ApplyState-    , showPatch-    , showContextPatch-    )+import Darcs.Patch.Apply ( ApplyState, ObjectIdOfPatch )+import Darcs.Patch.ApplyMonad ( ApplyMonadTrans ) import Darcs.Patch.Bracketed ( Bracketed, unBracketedFL ) import Darcs.Patch.Commute ( Commute, commuteFL ) import Darcs.Patch.Depends ( contextPatches, splitOnTag )@@ -61,6 +57,7 @@     , showPatchInfo     ) import Darcs.Patch.Named ( Named, fmapFL_Named )+import Darcs.Patch.Object ( ObjectId ) import Darcs.Patch.PatchInfoAnd     ( PatchInfoAnd     , info@@ -70,6 +67,8 @@     ) import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL ) import Darcs.Patch.Read ( readPatch' )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Show ( showPatch, showPatchWithContext ) import Darcs.Patch.Set     ( PatchSet(..)     , SealedPatchSet@@ -113,23 +112,21 @@     , vcat     , vsep     )-import Darcs.Util.Tree( Tree )-import Darcs.Util.Tree.Monad( virtualTreeIO )   -- | A 'Bundle' is a context together with some patches. The context -- consists of unavailable patches.-data Bundle rt p wX wY where-  Bundle :: (FL (PatchInfoAnd rt p) :> FL (PatchInfoAnd rt p)) wX wY-         -> Bundle rt p wX wY+data Bundle p wX wY where+  Bundle :: (FL (PatchInfoAnd p) :> FL (PatchInfoAnd p)) wX wY+         -> Bundle p wX wY  -- | Interpret a 'Bundle' in the context of a 'PatchSet'. This means we -- match up a possible tag in the context of the 'Bundle'. This fails if -- the tag couldn't be found. interpretBundle :: Commute p-                => PatchSet rt p Origin wT-                -> Bundle rt p wA wB-                -> Either String (PatchSet rt p Origin wB)+                => PatchSet p Origin wT+                -> Bundle p wA wB+                -> Either String (PatchSet p Origin wB) interpretBundle ref (Bundle (context :> patches)) =   flip appendPSFL patches <$> interpretContext ref context @@ -142,14 +139,17 @@     sha1Show $ sha1PS $ renderPS $         vcat (mapFL (showPatch ForStorage) to_be_sent) <> newline -makeBundle :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)-           -> PatchSet rt p wStart wX -> FL (Named p) wX wY -> IO Doc-makeBundle state repo to_be_sent+makeBundle+  :: (RepoPatch p, ApplyMonadTrans (ApplyState p) IO, ObjectId (ObjectIdOfPatch p))+  => Maybe (ApplyState p IO)+  -> PatchSet p wStart wX+  -> FL (Named p) wX wY+  -> IO Doc+makeBundle mstate repo to_be_sent   | _ :> context <- contextPatches repo =     format context <$>-      case state of-        Just tree ->-          fst <$> virtualTreeIO (showContextPatch ForStorage to_be_sent) tree+      case mstate of+        Just state -> showPatchWithContext ForStorage state to_be_sent         Nothing -> return (vsep $ mapFL (showPatch ForStorage) to_be_sent)   where     format context patches =@@ -172,7 +172,7 @@   \The most likely culprit is CRLF newlines."  parseBundle :: RepoPatch p-            => B.ByteString -> Either String (Sealed (Bundle rt p wX))+            => B.ByteString -> Either String (Sealed (Bundle p wX)) parseBundle =     fmap fst . parse pUnsignedBundle . dropInitialTrash . decodeGpgClearsigned   where@@ -183,7 +183,7 @@           | B.null rest -> rest           | otherwise -> dropInitialTrash rest -pUnsignedBundle :: forall rt p wX. RepoPatch p => Parser (Sealed (Bundle rt p wX))+pUnsignedBundle :: forall p wX. RepoPatch p => Parser (Sealed (Bundle p wX)) pUnsignedBundle = pContextThenPatches <|> pPatchesThenContext   where     packBundle context patches =@@ -212,7 +212,7 @@ bundleHashName :: B.ByteString bundleHashName = BC.pack "Patch bundle hash:" -unavailablePatchesFL :: [PatchInfo] -> FL (PatchInfoAnd rt p) wX wY+unavailablePatchesFL :: [PatchInfo] -> FL (PatchInfoAnd p) wX wY unavailablePatchesFL = foldr ((:>:) . piUnavailable) (unsafeCoercePEnd NilFL)   where     piUnavailable i = patchInfoAndPatch i . unavailable $@@ -231,9 +231,9 @@ patchesName = BC.pack "New patches:"  readContextFile :: Commute p-                => PatchSet rt p Origin wX+                => PatchSet p Origin wX                 -> FilePath-                -> IO (SealedPatchSet rt p Origin)+                -> IO (SealedPatchSet p Origin) readContextFile ref = fmap Sealed . (parseAndInterpret <=< mmapFilePS)   where     parseAndInterpret =@@ -242,9 +242,9 @@ -- | Interpret a context file in the context of a 'PatchSet'. This means we -- match up a possible tag. This fails if the tag couldn't be found. interpretContext :: Commute p-                 => PatchSet rt p Origin wT-                 -> FL (PatchInfoAnd rt p) wA wB-                 -> Either String (PatchSet rt p Origin wB)+                 => PatchSet p Origin wT+                 -> FL (PatchInfoAnd p) wA wB+                 -> Either String (PatchSet p Origin wB) interpretContext ref context =   case context of     tag :>: rest@@ -257,7 +257,7 @@     _ -> Right $ PatchSet NilRL (unsafeCoercePStart (reverseFL context))  parseContextFile :: B.ByteString-                 -> Either String (FL (PatchInfoAnd rt p) wX wY)+                 -> Either String (FL (PatchInfoAnd p) wX wY) parseContextFile =     fmap fst . parse pUnsignedContext . decodeGpgClearsigned   where@@ -265,9 +265,9 @@  -- | Minimize the context of an 'FL' of patches to be packed into a bundle. minContext :: (RepoPatch p)-           => PatchSet rt p wStart wB -- context to be minimized-           -> FL (PatchInfoAnd rt p) wB wC-           -> Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) wStart)+           => PatchSet p wStart wB -- context to be minimized+           -> FL (PatchInfoAnd p) wB wC+           -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) wStart) minContext (PatchSet behindTag topCommon) to_be_sent =   case genCommuteWhatWeCanRL commuteFL (topCommon :> to_be_sent) of     (c :> to_be_sent' :> _) -> seal (PatchSet behindTag c :> to_be_sent')
src/Darcs/Patch/Commute.hs view
@@ -18,25 +18,31 @@     ( FL(..), RL(..), reverseFL, reverseRL,     (:>)(..) ) --- | Commute represents things that can be (possibly) commuted.------ Instances should obey the following laws:------ * Symmetry------   prop> commute (p:>q) == Just (q':>p') <=> commute (q':>p') == Just (p':>q)------ * If an instance @'Invert' p@ exists, then------   prop> commute (p:>q) == Just (q':>p') <=> commute (invert q:>invert p) == Just (invert p':>invert q')------ * The more general Square-Commute law------   prop> commute (p:>q) == Just (q':>p') => commute (invert p:>q') == Just (q:>invert p')------   is required to hold only for primitive patches, i.e. if there is /no/---   instance @'Merge' p@, because together with 'merge' it implies that---   any two patches commute.+{- | Class of patches that that can be commuted.++Instances should obey the following laws:++[commute-symmetry]++    prop> commute (p:>q) == Just (q':>p') <=> commute (q':>p') == Just (p':>q)++[invert-commute]++    If patches are invertible, then++    prop> commute (p:>q) == Just (q':>p') <=> commute (invert q:>invert p) == Just (invert p':>invert q')++The more general law++[square-commute]++    prop> commute (p:>q) == Just (q':>p') => commute (invert p:>q') == Just (q:>invert p')++is valid in general only provided we know (a priori) that @'commute' ('invert'+p':>'q')@ succeeds, in other words, that p and q are not in conflict with each+other. See "Darcs.Patch.CommuteNoConflicts" for an extended discussion.++-} class Commute p where     commute :: (p :> p) wX wY -> Maybe ((p :> p) wX wY)
src/Darcs/Patch/CommuteNoConflicts.hs view
@@ -5,46 +5,46 @@  import Darcs.Prelude -import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Witnesses.Ordered ( (:/\:)(..), (:>)(..), (:\/:)(..) )  -- | It is natural to think of conflicting patches @p@ and @q@ as--- a parallel pair @p:\/:q@ because this is how conflicting patches arise.+-- a parallel pair @(p':\/:'q)@ because this is how conflicting patches arise. -- But then Darcs comes along and merges them anyway by converting one of -- them to a conflictor. Thus, inside a sequence of patches we may see--- them as a sequential pair @(p:>q')@. In that case, 'commute' will always--- succeed, as expressed by the 'prop_mergeCommute' law. 'commuteNoConflicts'+-- them as a sequential pair @(p ':>' q')@. In that case, 'commute' will always+-- succeed, as expressed by the merge-commute law. 'commuteNoConflicts' -- is a restricted version of 'commute' that should fail in this case but -- otherwise give the same result as 'commute'. -- -- Primitive patch types have no conflictors, so for them we have--- @commute == commuteNoConflicts@.+-- @'commute' == 'commuteNoConflicts'@. -- -- Instances should obey the following laws: -- -- * Symmetry -----   prop> commuteNoConflicts (p:>q) == Just (q':>p') <=> commuteNoConflicts (q':>p') == Just (p':>q)+--     prop> commuteNoConflicts (p:>q) == Just (q':>p') <=> commuteNoConflicts (q':>p') == Just (p':>q) -- -- * Square-Commute (if an instance @'Invert' p@ exists) -----   prop> commuteNoConflicts (p:>q) == Just (q':>p') => commuteNoConflicts (invert p:>q') == Just (q:>invert p')+--     prop> commuteNoConflicts (p:>q) == Just (q':>p') => commuteNoConflicts (invert p:>q') == Just (q:>invert p') -- -- * 'commuteNoConflicts' is a restriction of 'commute' -----   prop> commuteNoConflicts (p:>q) == Just r => commute (p:>q) == Just r+--     prop> commuteNoConflicts (p:>q) == Just r => commute (p:>q) == Just r -- class Commute p => CommuteNoConflicts p where     commuteNoConflicts :: (p :> p) wX wY -> Maybe ((p :> p) wX wY)     -- ^ An alternative to 'commute' to be used if correctness of your code     -- depends on the validity of the square-commute law, or to determine-    -- whether patches are in conflict. A parallel pair of patches @p:\/:q@-    -- is conflicting if and only if @commuteNoConflicts(p^:>q)@ fails. Its+    -- whether patches are in conflict. A parallel pair of patches @p':\/:'q@+    -- is conflicting if and only if @'commuteNoConflicts'(p^':>'q)@ fails. Its     -- main use is so that we can define 'mergeNoConflicts' cleanly.  {- |-The non-conflicting merge of @p:\/:q@ tries to commute the inverse @p^@+The non-conflicting merge of @(p':\/:'q)@ tries to commute the inverse @p^@ of @p@ with @q@. If it succeeds then the part of the result that corresponds to @p^@ is re-inverted. This is also known as a "clean merge". @@ -55,20 +55,21 @@ Concretely, suppose we use 'commute' here and that @q@ is a conflictor that represents the primitive patch @r@ and conflicts (only) with (primitive patch) @p^@. That is, @q@ results from the conflicted-@merge(r:\/:p^)=(s:/\:q)@, where @s@ is another conflictor. Now, according-to 'prop_mergeCommute' we get @commute(p^:>q)=Just(r:>s)@, and thus-@mergeNoConflict(p:\/:q)=Just(s^:/\:r)@ in contradiction to our assumption-that @p^:\/:q@ are in conflict i.e. @mergeNoConflict(p^:\/:q)@ fails. (This-argument takes for granted that the addition of conflictors to prim patches-preserves their commute behavior. This is not yet stated as a law but all-implementations obviously adhere to it.)+@merge(r':\/:'p^)=(s':/\:'q)@, where @s@ is another conflictor. Now,+according to merge-commute we get @commute(p^':>'q)=Just(r':>'s)@, and thus+@mergeNoConflict(p':\/:'q)=Just(s^':/\:'r)@ in contradiction to our+assumption that @(p^':\/:'q@ are in conflict i.e.+@mergeNoConflict(p^':\/:'q)@ fails. (This argument takes for granted that+the addition of conflictors to prim patches preserves their commute+behavior. This is not yet stated as a law but all implementations obviously+adhere to it.)  As a side note, the fact that we now get an inverse conflictor @s^@ as part of the result leads to further problems. For instance, whether our repo is-conflicted now depends on the order of patches: @(p:>r)@ is not conflicted,-but its commute @(q:>s^)@ obviously is. In fact, @(q:>s^)@ is nothing else-but the (identity-preserving) "force-commute" of @(p:>r)@, see the thread at-https://lists.osuosl.org/pipermail/darcs-devel/2017-November/018403.html+conflicted now depends on the order of patches: @(p':>'r)@ is not conflicted,+but its commute @(q':>'s^)@ obviously is. In fact, @(q':>'s^)@ is nothing else+but the (identity-preserving) "force-commute" of @(p':>'r)@, see the thread at+<https://lists.osuosl.org/pipermail/darcs-devel/2017-November/018403.html>. -} mergeNoConflicts :: (Invert p, CommuteNoConflicts p)                  => (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)
src/Darcs/Patch/Conflict.hs view
@@ -6,16 +6,20 @@     , Unravelled     , mangleOrFail     , combineConflicts+    , findConflicting     ) where  import Darcs.Prelude +import Darcs.Patch.Commute ( Commute(..), commuteFL, commuteRL ) import Darcs.Patch.CommuteFn ( commuterIdFL ) import Darcs.Patch.CommuteNoConflicts ( CommuteNoConflicts(..) ) import Darcs.Patch.Permutations () import Darcs.Patch.FromPrim ( PrimOf ) import Darcs.Patch.Prim ( PrimMangleUnravelled(..), Mangled, Unravelled )-import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) )+import Darcs.Patch.Show ( ShowPatch(..), ShowPatchFor(ForStorage), showPatch )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..), RL(..), mapFL, (+<<+) )+import Darcs.Util.Printer ( renderString, text, vcat, ($$) )  data ConflictDetails prim wX =   ConflictDetails {@@ -23,6 +27,8 @@     conflictParts :: Unravelled prim wX   } +-- | For one conflict (a connected set of conflicting prims), store the+-- conflicting parts and, if possible, their mangled version. mangleOrFail :: PrimMangleUnravelled prim              => Unravelled prim wX -> ConflictDetails prim wX mangleOrFail parts =@@ -32,6 +38,7 @@   }  class Conflict p where+    isConflicted :: p wX wY ->  Bool     -- | The first parameter is a context containing all patches     -- preceding the ones for which we want to calculate the conflict     -- resolution, which is the second parameter.@@ -73,3 +80,43 @@           Nothing -> rest       where         rest = rcs ps (p :>: passedby)++-- | Find all patches in the context that conflict with a given patch,+-- commuting them to the head (past the patch in question).+--+-- This actually works by commuting the patch and its dependencies backward+-- until it becomes unconflicted, then minimizing the trailing patches by+-- re-commuting them backward as long as that keeps the patch unconflicted.+--+-- Precondition: the context must contain all conflicting patches.+findConflicting+  :: forall p wX wY wZ+   . (Commute p, Conflict p, ShowPatch p)+  => RL p wX wY+  -> p wY wZ+  -> (RL p :> p :> RL p) wX wZ+findConflicting context patch = go (context :> NilFL :> patch :> NilFL) where+  go :: (RL p :> FL p :> p :> FL p) wA wB -> (RL p :> p :> RL p) wA wB+  go (ctx :> deps :> p :> nondeps)+    | not (isConflicted p) = prune (ctx +<<+ deps :> p :> NilRL :> nondeps)+  go (NilRL :> deps :> p :> nondeps) =+    error $ renderString $ text "precondition violated:" $$+      vcat (mapFL (showPatch ForStorage) deps) $$+      text "===============" $$+      text "patch:" $$ (showPatch ForStorage) p $$+      text "===============" $$+      vcat (mapFL (showPatch ForStorage) nondeps)+  go (cs :<: c :> deps :> p :> nondeps) =+    case commuteFL (c :> deps) of+      Nothing -> go (cs :> c :>: deps :> p :> nondeps)+      Just (deps' :> c') ->+        case commute (c' :> p) of+          Nothing -> go (cs :> c :>: deps :> p :> nondeps)+          Just (p' :> c'') -> go (cs :> deps' :> p' :> c'' :>: nondeps)+  prune :: (RL p :> p :> RL p :> FL p) wA wB -> (RL p :> p :> RL p) wA wB+  prune (ctx :> p :> rs :> NilFL) = ctx :> p :> rs+  prune (ctx :> p :> rs :> n :>: ns)+    | Just (n' :> rs') <- commuteRL (rs :> n)+    , Just (n'' :> p') <- commute (p :> n')+    , not (isConflicted p') = prune (ctx :<: n'' :> p' :> rs' :> ns)+    | otherwise = prune (ctx :> p :> rs :<: n :> ns)
src/Darcs/Patch/Depends.hs view
@@ -39,53 +39,58 @@ module Darcs.Patch.Depends     ( getUncovered     , areUnrelatedRepos-    , findCommonAndUncommon-    , mergeThem+    , findCommon     , findCommonWithThem+    , findUncommon+    , patchSetMerge     , countUsThem     , removeFromPatchSet     , slightlyOptimizePatchset+    , fullyOptimizePatchSet     , splitOnTag     , patchSetUnion     , patchSetIntersection-    , findUncommon     , cleanLatestTag     , contextPatches     ) where  import Darcs.Prelude -import Data.List ( delete, intersect, (\\) )-import Data.Maybe ( fromMaybe )+import Control.Applicative ( (<|>) )+import Data.List ( delete, foldl1', intersect, (\\) )  import Darcs.Patch.Named ( getdeps ) import Darcs.Patch.Commute ( Commute )-import Darcs.Patch.Ident ( fastRemoveSubsequenceRL, merge2FL )-import Darcs.Patch.Info ( PatchInfo, isTag, displayPatchInfo )-import Darcs.Patch.Merge ( Merge )-import Darcs.Patch.Permutations ( partitionFL, partitionRL )-import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, hopefullyM, info )+import Darcs.Patch.Ident+    ( fastRemoveSubsequenceRL+    , findCommonRL+    , findCommonWithThemRL+    )+import Darcs.Patch.Info ( PatchInfo, isTag )+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Permutations ( partitionRL )+import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, info ) import Darcs.Patch.Set-    ( PatchSet(..)-    , Tagged(..)+    ( Origin+    , PatchSet(..)     , SealedPatchSet-    , patchSet2RL+    , Tagged(..)     , appendPSFL+    , emptyPatchSet+    , patchSet2FL+    , patchSet2RL     , patchSetSplit-    , Origin     ) import Darcs.Patch.Progress ( progressRL )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart )-import Darcs.Patch.Witnesses.Eq ( Eq2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered     ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..),-    (+<<+), mapFL, RL(..), FL(..), isShorterThanRL, breakRL,+    mapFL, RL(..), FL(..), isShorterThanRL, breakRL,     (+<+), reverseFL, reverseRL, mapRL ) import Darcs.Patch.Witnesses.Sealed     ( Sealed(..), seal ) -import Darcs.Util.Printer ( renderString, vcat )- {-| Find clean tags that are common to both argument 'PatchSet's and return a 'Fork' with the common clean tags and whatever remains of the 'PatchSet's.@@ -100,38 +105,21 @@ accessed (i.e. local), as 'taggedIntersection' does its best to reduce the number of inventories that are accessed from its second argument. -}-taggedIntersection :: forall rt p wX wY . Commute p-                   => PatchSet rt p Origin wX -> PatchSet rt p Origin wY ->-                      Fork (RL (Tagged rt p))-                           (RL (PatchInfoAnd rt p))-                           (RL (PatchInfoAnd rt p)) Origin wX wY+taggedIntersection :: forall p wX wY . Commute p+                   => PatchSet p Origin wX -> PatchSet p Origin wY ->+                      Fork (RL (Tagged p))+                           (RL (PatchInfoAnd p))+                           (RL (PatchInfoAnd p)) Origin wX wY taggedIntersection (PatchSet NilRL ps1) s2 = Fork NilRL ps1 (patchSet2RL s2) taggedIntersection s1 (PatchSet NilRL ps2) = Fork NilRL (patchSet2RL s1) ps2-taggedIntersection s1 (PatchSet (_ :<: Tagged t2 _ _) ps2)-    -- If t2 is the head of any of the Tagged sections of s1,-    -- unwrap everything in s1 after t2 and be done with it.-    | Just (PatchSet ts1 ps1) <- maybeSplitSetOnTag (info t2) s1 =-        Fork ts1 ps1 (unsafeCoercePStart ps2)-taggedIntersection s1 s2@(PatchSet (ts2 :<: Tagged t2 _ t2ps) ps2) =-    -- Same case as before but now we know that t2 is not the head of any-    -- Tagged section of s1. If t2 has already been fully retrieved, then-    -- we know that the next Tagged section of s2 is available without-    -- opening another remote inventory; in this case we recurse i.e.-    -- we unwrap t2 and its patches and continue with the next Tagged of s2.-    -- Otherwise we try to make t2 clean in s1 by looking at s1's trailing-    -- patch list, too.-    -- Question by bf: Wouldn't it be better to call splitOnTag /before/ we-    -- test if t2 has already been opened? If it succeeds, then we'd get-    -- more common Tagged sections and still don't have to open a remote-    -- inventory.-    case hopefullyM t2 of-        Just _ ->-            taggedIntersection s1 (PatchSet ts2 (t2ps :<: t2 +<+ ps2))-        Nothing ->-            case splitOnTag (info t2) s1 of-                Just (PatchSet com us) ->-                      Fork com us (unsafeCoercePStart ps2)-                Nothing -> Fork NilRL (patchSet2RL s1) (patchSet2RL s2)+taggedIntersection s1 (PatchSet (ts2 :<: Tagged t2ps t2 _) ps2) =+  -- First try to find t2 in the heads of Tagged sections of s1;+  -- if that fails, try to reorder patches in s1 so that it does;+  -- otherwise t2 does not occur in s1, so recurse with the current+  -- Tagged section of s2 unwrapped.+  case maybeSplitSetOnTag (info t2) s1 <|> splitOnTag (info t2) s1 of+    Just (PatchSet ts1 ps1) -> Fork ts1 ps1 (unsafeCoercePStart ps2)+    Nothing -> taggedIntersection s1 (PatchSet ts2 (t2ps :<: t2 +<+ ps2))  -- |'maybeSplitSetOnTag' takes a tag's 'PatchInfo', @t0@, and a 'PatchSet' and -- attempts to find @t0@ in one of the 'Tagged's in the PatchSet. If the tag is@@ -140,9 +128,9 @@ -- is returned. -- This is a simpler version of 'splitOnTag' that only looks at the heads -- of 'Tagged' sections and does not commute any patches.-maybeSplitSetOnTag :: PatchInfo -> PatchSet rt p wStart wX-                   -> Maybe (PatchSet rt p wStart wX)-maybeSplitSetOnTag t0 origSet@(PatchSet (ts :<: Tagged t _ pst) ps)+maybeSplitSetOnTag :: PatchInfo -> PatchSet p wStart wX+                   -> Maybe (PatchSet p wStart wX)+maybeSplitSetOnTag t0 origSet@(PatchSet (ts :<: Tagged pst t _) ps)     | t0 == info t = Just origSet     | otherwise = do         PatchSet ts' ps' <- maybeSplitSetOnTag t0 (PatchSet ts (pst :<: t))@@ -154,48 +142,53 @@ -- clean (and the last of the 'Tagged' list), while all patches that are not -- covered by the tag are in the trailing list of patches. -- If the tag is not in the 'PatchSet', we return 'Nothing'.-splitOnTag :: Commute p => PatchInfo -> PatchSet rt p wStart wX-           -> Maybe (PatchSet rt p wStart wX)--- If the tag we are looking for is the first Tagged tag of the patchset, just--- separate out the patchset's patches.-splitOnTag t s@(PatchSet (_ :<: Tagged hp _ _) _) | info hp == t = Just s+splitOnTag :: Commute p => PatchInfo -> PatchSet p wStart wX+           -> Maybe (PatchSet p wStart wX)+-- If the tag we are looking for is the first Tagged tag of the patchset, we+-- are done.+splitOnTag t s@(PatchSet (_ :<: Tagged _ hp _) _) | info hp == t = Just s -- If the tag is the most recent patch in the set, we check if the patch is the -- only non-depended-on patch in the set (i.e. it is a clean tag); creating a -- new Tagged out of the patches and tag, and adding it to the patchset, if -- this is the case. Otherwise, we try to make the tag clean. splitOnTag t patchset@(PatchSet ts hps@(ps :<: hp)) | info hp == t =     if getUncovered patchset == [t]-        -- If t is the only patch not covered by any tag...-        then Just $ PatchSet (ts :<: Tagged hp Nothing ps) NilRL-        else case partitionRL ((`notElem` (t : getdeps (hopefully hp))) . info) hps of-            -- Partition hps by those that are the tag and its explicit deps.+        then+          -- If t is the only patch not covered by any tag, then it is clean+          Just $ PatchSet (ts :<: Tagged ps hp Nothing) NilRL+        else+          -- Make it clean by commuting out patches not explicitly depended on+          -- by @t@; since we do this with just the trailing sequence @hps@ i.e.+          -- we don't include the tag of the next Tagged, we have to make an+          -- extra check to see if this tag is covered, too, and otherwise+          -- recurse with the next Tagged section unwrapped. Note that we cannot+          -- simply check if @t@ depends on this tag because it may depend+          -- indirectly via unclean tags contained in @hps@.+          case partitionRL ((`notElem` (t : getdeps (hopefully hp))) . info) hps of             tagAndDeps@(ds' :<: hp') :> nonDeps ->-                -- If @ds@ doesn't contain the tag of the first Tagged, that-                -- tag will also be returned by the call to getUncovered - so-                -- we need to unwrap the next Tagged in order to expose it to-                -- being partitioned out in the recursive call to splitOnTag.+                -- check if t is now fully clean                 if getUncovered (PatchSet ts tagAndDeps) == [t]-                    then let tagged = Tagged hp' Nothing ds' in+                    then let tagged = Tagged ds' hp' Nothing in                          return $ PatchSet (ts :<: tagged) nonDeps                     else do                         unfolded <- unwrapOneTagged $ PatchSet ts tagAndDeps-                        PatchSet xx yy <- splitOnTag t unfolded-                        return $ PatchSet xx (yy +<+ nonDeps)+                        PatchSet ts' ps' <- splitOnTag t unfolded+                        return $ PatchSet ts' (ps' +<+ nonDeps)             _ -> error "impossible case" -- We drop the leading patch, to try and find a non-Tagged tag. splitOnTag t (PatchSet ts (ps :<: p)) = do     PatchSet ns xs <- splitOnTag t (PatchSet ts ps)     return $ PatchSet ns (xs :<: p) -- If there are no patches left, we "unfold" the next Tagged, and try again.-splitOnTag t0 patchset@(PatchSet (_ :<: Tagged _ _ _s) NilRL) =+splitOnTag t0 patchset@(PatchSet (_ :<: Tagged _ _ _) NilRL) =     unwrapOneTagged patchset >>= splitOnTag t0 -- If we've checked all the patches, but haven't found the tag, return Nothing. splitOnTag _ (PatchSet NilRL NilRL) = Nothing  -- | Reorder a 'PatchSet' such that the latest tag becomes clean. cleanLatestTag :: Commute p-               => PatchSet rt p wStart wX-               -> PatchSet rt p wStart wX+               => PatchSet p wStart wX+               -> PatchSet p wStart wX cleanLatestTag inp@(PatchSet ts ps) =   case breakRL (isTag . info) ps of     NilRL :> _ -> inp -- no tag among the ps -> we are done@@ -204,124 +197,173 @@         Just (PatchSet ts' ps') -> PatchSet ts' (ps' +<+ right)         _ -> error "impossible case" -- because t is in left +-- | Create a 'Tagged' section for every clean tag. For unclean tags we try to+-- make them clean, but only if that doesn't make an earlier clean tag dirty.+-- This means that the operation is idempotent and in particular monotonic,+-- which justifies the "optimize" in the name.+fullyOptimizePatchSet+  :: forall p wZ . Commute p => PatchSet p Origin wZ -> PatchSet p Origin wZ+fullyOptimizePatchSet = go emptyPatchSet . patchSet2FL+  where+    go :: PatchSet p Origin wY -> FL (PatchInfoAnd p) wY wZ -> PatchSet p Origin wZ+    go s NilFL = s+    go s@(PatchSet ts ps) (q:>:qs)+      | isTag qi, getUncovered s' == [qi] =+          -- tag is clean+          go (PatchSet (ts :<: Tagged ps q Nothing) NilRL) qs+      | isTag qi, Just s'' <- makeClean s q = go s'' qs+      | otherwise = go s' qs+      where+        qi = info q+        s' = PatchSet ts (ps:<:q)++-- | Take a 'PatchSet' and an adjacent tag and try to make the tag clean+-- by commuting out trailing patches that are not covered by the tag.+makeClean+  :: Commute p+  => PatchSet p Origin wY+  -> PatchInfoAnd p wY wZ+  -> Maybe (PatchSet p Origin wZ)+makeClean (PatchSet ts ps) t =+  let ti = info t in+  case partitionRL ((`notElem` (ti : getdeps (hopefully t))) . info) (ps :<: t) of+    tagAndDeps@(ds :<: t') :> nonDeps ->+      -- check if tag really became clean+      if getUncovered (PatchSet ts tagAndDeps) == [ti]+        then Just $ PatchSet (ts :<: Tagged ds t' Nothing) nonDeps+        else Nothing+    _ -> error "imposible"+ -- |'unwrapOneTagged' unfolds a single Tagged object in a PatchSet, adding the -- tag and patches to the PatchSet's patch list.-unwrapOneTagged :: PatchSet rt p wX wY -> Maybe (PatchSet rt p wX wY)-unwrapOneTagged (PatchSet (ts :<: Tagged t _ tps) ps) =+unwrapOneTagged :: PatchSet p wX wY -> Maybe (PatchSet p wX wY)+unwrapOneTagged (PatchSet (ts :<: Tagged tps t _) ps) =     Just $ PatchSet ts (tps :<: t +<+ ps) unwrapOneTagged _ = Nothing --- | Return the 'PatchInfo' for all the patches in a 'PatchSet'--- that are not depended on by any tag (in the given 'PatchSet').+-- | Return the 'PatchInfo' for all the patches in a 'PatchSet' that are not+-- *explicitly* depended on by any tag (in the given 'PatchSet'). -- -- This is exactly the set of patches that a new tag recorded on top -- of the 'PatchSet' would explicitly depend on.-getUncovered :: PatchSet rt p wStart wX -> [PatchInfo]-getUncovered patchset = case patchset of-    (PatchSet NilRL ps) -> findUncovered (mapRL infoAndExplicitDeps ps)-    (PatchSet (_ :<: Tagged t _ _) ps) ->-        findUncovered (mapRL infoAndExplicitDeps (NilRL :<: t +<+ ps))+--+-- Note that the result is not minimal with respect to dependencies, not even+-- explicit dependencies: explicit dependencies of regular (non-tag) patches+-- are completely ignored.+getUncovered :: PatchSet p wStart wX -> [PatchInfo]+getUncovered (PatchSet tagged patches) =+  findUncovered $+    case tagged of+      NilRL -> mapRL infoAndExplicitDeps patches+      _ :<: Tagged _ t _ -> mapRL infoAndExplicitDeps patches ++ [(info t, [])]   where-    findUncovered :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo]+    -- Both findUncovered and dropDepsIn are basically graph algorithms. We+    -- present the (directed, acyclic) graph as a topologically sorted list of+    -- vertices together with the targets of their outgoing edges. The problem+    -- findUncovered solves is to find all vertices with no incoming edges.+    -- This is done by removing all vertices reachable from any vertex in the+    -- graph.+    findUncovered :: Eq a => [(a, [a])] -> [a]     findUncovered [] = []-    findUncovered ((pi, Nothing) : rest) = pi : findUncovered rest-    findUncovered ((pi, Just deps) : rest) =+    findUncovered ((pi, deps) : rest) =         pi : findUncovered (dropDepsIn deps rest) -    -- |dropDepsIn traverses the list of patches, dropping any patches that-    -- occur in the dependency list; when a patch is dropped, its dependencies-    -- are added to the dependency list used for later patches.-    dropDepsIn :: [PatchInfo] -> [(PatchInfo, Maybe [PatchInfo])]-               -> [(PatchInfo, Maybe [PatchInfo])]-    dropDepsIn [] pps = pps-    dropDepsIn _  []  = []-    dropDepsIn ds (hp : pps)-        | fst hp `elem` ds =-            let extraDeps = fromMaybe [] $ snd hp in-            dropDepsIn (extraDeps ++ delete (fst hp) ds) pps-        | otherwise = hp : dropDepsIn ds pps+    -- Remove the given list of vertices from the graph, as well as all+    -- vertices reachable from them.+    dropDepsIn :: Eq a => [a] -> [(a, [a])] -> [(a, [a])]+    dropDepsIn [] ps = ps+    dropDepsIn _  [] = []+    dropDepsIn ds (hp@(hpi,hpds) : ps)+        | hpi `elem` ds = dropDepsIn (delete hpi ds ++ hpds) ps+        | otherwise = hp : dropDepsIn ds ps -    -- |infoAndExplicitDeps returns the patch info and (for tags only) the list-    -- of explicit dependencies of a patch.-    infoAndExplicitDeps :: PatchInfoAnd rt p wX wY-                        -> (PatchInfo, Maybe [PatchInfo])+    -- The patch info together with the list of explicit dependencies in case+    -- it is a tag. This constructs one element of the graph representation.+    -- It cannot be used for the tag of a Tagged section as that may not be+    -- available in a lazy repo. That's okay because we already know it is+    -- clean, so no patches preceding it it can be uncovered.+    infoAndExplicitDeps :: PatchInfoAnd p wX wY -> (PatchInfo, [PatchInfo])     infoAndExplicitDeps p-        | isTag (info p) = (info p, getdeps `fmap` hopefullyM p)-        | otherwise = (info p, Nothing)+        | isTag (info p) = (info p, getdeps $ hopefully p)+        | otherwise = (info p, [])  -- | Create a new 'Tagged' section for the most recent clean tag found in the -- tail of un-'Tagged' patches without re-ordering patches. Note that earlier -- tags may remain un-'Tagged' even if they are actually clean.-slightlyOptimizePatchset :: PatchSet rt p wStart wX -> PatchSet rt p wStart wX+slightlyOptimizePatchset :: PatchSet p wStart wX -> PatchSet p wStart wX slightlyOptimizePatchset (PatchSet ts0 ps0) =     go $ PatchSet ts0 (progressRL "Optimizing inventory" ps0)   where-    go :: PatchSet rt p wStart wY -> PatchSet rt p wStart wY+    go :: PatchSet p wStart wY -> PatchSet p wStart wY     go (PatchSet ts NilRL) = PatchSet ts NilRL     go s@(PatchSet ts (ps :<: hp))         | isTag (info hp)         , [info hp] == getUncovered s =-            PatchSet (ts :<: Tagged hp Nothing ps) NilRL+            PatchSet (ts :<: Tagged ps hp Nothing) NilRL         | otherwise = appendPSFL (go (PatchSet ts ps)) (hp :>: NilFL) -removeFromPatchSet :: (Commute p, Eq2 p) => FL (PatchInfoAnd rt p) wX wY-                   -> PatchSet rt p wStart wY -> Maybe (PatchSet rt p wStart wX)-removeFromPatchSet bad (PatchSet ts ps) | all (`elem` mapRL info ps) (mapFL info bad) = do+removeFromPatchSet+  :: (Commute p, Eq2 p)+  => FL (PatchInfoAnd p) wX wY+  -> PatchSet p wStart wY+  -> Maybe (PatchSet p wStart wX)+removeFromPatchSet bad s@(PatchSet ts ps)+  | all (`elem` mapRL info ps) (mapFL info bad) = do     ps' <- fastRemoveSubsequenceRL (reverseFL bad) ps     return (PatchSet ts ps')-removeFromPatchSet _ (PatchSet NilRL _) = Nothing-removeFromPatchSet bad (PatchSet (ts :<: Tagged t _ tps) ps) =-    removeFromPatchSet bad (PatchSet ts (tps :<: t +<+ ps))+  | otherwise = removeFromPatchSet bad =<< unwrapOneTagged s -findCommonAndUncommon :: forall rt p wX wY . Commute p-                      => PatchSet rt p Origin wX -> PatchSet rt p Origin wY-                      -> Fork (PatchSet rt p)-                              (FL (PatchInfoAnd rt p))-                              (FL (PatchInfoAnd rt p)) Origin wX wY-findCommonAndUncommon us them = case taggedIntersection us them of+-- | The symmetric difference between two 'PatchSet's, expressed as a 'Fork'+-- consisting of the intersection 'PatchSet' and the trailing lists of+-- left-only and right-only patches.+--+-- From a purely functional point of view this is a symmetric function.+-- However, laziness effects make it asymmetric: the LHS is more likely to be+-- evaluated fully, while the RHS is evaluated as sparingly as possible. For+-- efficiency, the LHS should come from the local repo and the RHS from the+-- remote one. This asymmetry can also have a semantic effect, namely if+-- 'PatchSet's have *unavailable* patches or inventories, for instance when we+-- deal with a lazy clone of a repo that is no longer accessible. In this case+-- the order of arguments may determine whether the command fails or succeeds.+findCommon+  :: Commute p+  => PatchSet p Origin wX+  -> PatchSet p Origin wY+  -> Fork (PatchSet p) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) Origin wX wY+findCommon us them =+  case taggedIntersection us them of     Fork common us' them' ->-        case partitionFL (infoIn them') $ reverseRL us' of-            _ :> bad@(_ :>: _) :> _ ->-                error $ "Failed to commute common patches:\n"-                      ++ renderString-                          (vcat $ mapRL (displayPatchInfo . info) $ reverseFL bad)-            (common2 :> NilFL :> only_ours) ->-                case partitionFL (infoIn us') $ reverseRL them' of-                    _ :> bad@(_ :>: _) :> _ ->-                        error $ "Failed to commute common patches:\n"-                            ++ renderString (vcat $-                                mapRL (displayPatchInfo . info) $ reverseFL bad)-                    _ :> NilFL :> only_theirs ->-                        Fork (PatchSet common (reverseFL common2))-                            only_ours (unsafeCoercePStart only_theirs)-  where-    infoIn inWhat = (`elem` mapRL info inWhat) . info+      case findCommonRL us' them' of+        Fork more_common us'' them'' ->+          Fork (PatchSet common more_common) (reverseRL us'') (reverseRL them'') -findCommonWithThem :: Commute p-                   => PatchSet rt p Origin wX-                   -> PatchSet rt p Origin wY-                   -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wX-findCommonWithThem us them = case taggedIntersection us them of+findCommonWithThem+  :: Commute p+  => PatchSet p Origin wX+  -> PatchSet p Origin wY+  -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wX+findCommonWithThem us them =+  case taggedIntersection us them of     Fork common us' them' ->-        case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of-            _ :> bad@(_ :>: _) :> _ ->-                error $ "Failed to commute common patches:\n"-                      ++ renderString-                          (vcat $ mapRL (displayPatchInfo . info) $ reverseFL bad)-            common2 :> _nilfl :> only_ours ->-                PatchSet common (reverseFL common2) :> unsafeCoerceP only_ours+      case findCommonWithThemRL us' them' of+        more_common :> us'' ->+          PatchSet common more_common :> reverseRL us'' -findUncommon :: Commute p-             => PatchSet rt p Origin wX -> PatchSet rt p Origin wY-             -> (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY+findUncommon+  :: Commute p+  => PatchSet p Origin wX+  -> PatchSet p Origin wY+  -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY findUncommon us them =-    case findCommonWithThem us them of-        _common :> us' -> case findCommonWithThem them us of-            _ :> them' -> unsafeCoercePStart us' :\/: them'+  case taggedIntersection us them of+    Fork _ us' them' ->+      case (findCommonWithThemRL us' them', findCommonWithThemRL them' us') of+        (_ :> us'', _ :> them'') ->+          reverseRL us'' :\/: unsafeCoercePStart (reverseRL them'')  countUsThem :: Commute p-            => PatchSet rt p Origin wX-            -> PatchSet rt p Origin wY+            => PatchSet p Origin wX+            -> PatchSet p Origin wY             -> (Int, Int) countUsThem us them =     case taggedIntersection us them of@@ -329,52 +371,56 @@                                 tt = mapRL info them' in                             (length $ uu \\ tt, length $ tt \\ uu) -mergeThem :: (Commute p, Merge p)-          => PatchSet rt p Origin wX -> PatchSet rt p Origin wY-          -> Sealed (FL (PatchInfoAnd rt p) wX)-mergeThem us them =-    case taggedIntersection us them of-        Fork _ us' them' ->-            case merge2FL (reverseRL us') (reverseRL them') of-               them'' :/\: _ -> Sealed them''+patchSetMerge+  :: (Commute p, Merge p)+  => PatchSet p Origin wX+  -> PatchSet p Origin wY+  -> (FL (PatchInfoAnd p) :/\: FL (PatchInfoAnd p)) wX wY+patchSetMerge us them = merge (findUncommon us them) -patchSetIntersection :: Commute p-                   => [SealedPatchSet rt p Origin]-                   -> SealedPatchSet rt p Origin-patchSetIntersection [] = seal $ PatchSet NilRL NilRL-patchSetIntersection [x] = x-patchSetIntersection (Sealed y : ys) =-    case patchSetIntersection ys of-        Sealed z -> case taggedIntersection y z of-            Fork common a b -> case mapRL info a `intersect` mapRL info b of-                morecommon ->-                    case partitionRL (\e -> info e `notElem` morecommon) a of-                        commonps :> _ -> seal $ PatchSet common commonps+-- | A 'PatchSet' consisting of the patches common to all input 'PatchSet's.+-- This is *undefined* for the empty list since intersection of 'PatchSet's+-- has no unit.+patchSetIntersection+  :: Commute p => [SealedPatchSet p Origin] -> SealedPatchSet p Origin+patchSetIntersection = foldr1 go+  where+    go (Sealed ps) (Sealed acc) =+      case findCommonWithThem ps acc of+        common :> _ -> seal common -patchSetUnion :: (Commute p, Merge p, Eq2 p)-            => [SealedPatchSet rt p Origin]-            -> SealedPatchSet rt p Origin-patchSetUnion [] = seal $ PatchSet NilRL NilRL+-- | A 'PatchSet' consisting of the patches contained in any of the input+-- 'PatchSet's. The input 'PatchSet's are merged in left to right order, left+-- patches first.+patchSetUnion+  :: (Commute p, Merge p) => [SealedPatchSet p Origin] -> SealedPatchSet p Origin+-- You may consider simplifying this to a plain foldr'. However, this is+-- extremely inefficient because we have to build everything up from an empty+-- PatchSet. In principle this could be avoided by merging right patches first,+-- but then we get a failure in the conflict-chain-resolution test for darcs-1.+patchSetUnion [] = seal emptyPatchSet patchSetUnion [x] = x-patchSetUnion (Sealed y@(PatchSet tsy psy) : Sealed y2 : ys) =-    case mergeThem y y2 of-        Sealed p2 ->-            patchSetUnion $ seal (PatchSet tsy (psy +<<+ p2)) : ys+patchSetUnion xs = foldl1' go xs+  where+    go (Sealed acc) (Sealed ps) =+      case patchSetMerge acc ps of+        ps_only :/\: _ -> seal $ appendPSFL acc ps_only -areUnrelatedRepos :: Commute p-                  => PatchSet rt p Origin wX-                  -> PatchSet rt p Origin wY -> Bool+-- | Two 'PatchSet's are considered unrelated unless they share a common+-- inventory, or either 'PatchSet' has less than 5 patches, or they have at+-- least one patch in common.+areUnrelatedRepos+  :: Commute p => PatchSet p Origin wX -> PatchSet p Origin wY -> Bool areUnrelatedRepos us them =-    case taggedIntersection us them of-        Fork c u t -> checkit c u t-  where-    checkit (_ :<: Tagged{}) _ _ = False-    checkit _ u t | t `isShorterThanRL` 5 = False-                  | u `isShorterThanRL` 5 = False-                  | otherwise = null $ intersect (mapRL info u) (mapRL info t)+  case taggedIntersection us them of+    Fork NilRL u t+      | t `isShorterThanRL` 5 -> False+      | u `isShorterThanRL` 5 -> False+      | otherwise -> null $ intersect (mapRL info u) (mapRL info t)+    _ -> False  -- | Split a 'PatchSet' at the latest clean tag. The left part is what comes -- before the tag, the right part is the tag and its non-dependencies.-contextPatches :: PatchSet rt p wX wY-               -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) wX wY+contextPatches :: PatchSet p wX wY+               -> (PatchSet p :> RL (PatchInfoAnd p)) wX wY contextPatches = patchSetSplit . slightlyOptimizePatchset
src/Darcs/Patch/FileHunk.hs view
@@ -1,14 +1,14 @@ module Darcs.Patch.FileHunk-    ( FileHunk(..), IsHunk(..), showFileHunk+    ( FileHunk(..), IsHunk(..), showFileHunk, showContextFileHunk     )     where  import Darcs.Prelude -import Darcs.Util.Path ( AnchoredPath )+import Darcs.Patch.Apply ( ObjectIdOfPatch ) import Darcs.Patch.Format ( FileNameFormat ) import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Show ( formatFileName )+import Darcs.Patch.Object ( ObjectId(..) )  import Darcs.Util.Printer     ( Doc, blueText, text, lineColor, vcat, userchunkPS@@ -17,18 +17,32 @@ import qualified Data.ByteString as B ( ByteString )  -data FileHunk wX wY = FileHunk !AnchoredPath !Int [B.ByteString] [B.ByteString]+data FileHunk oid wX wY = FileHunk oid !Int [B.ByteString] [B.ByteString] -type role FileHunk nominal nominal+type role FileHunk nominal nominal nominal  class IsHunk p where-    isHunk :: p wX wY -> Maybe (FileHunk wX wY)+    isHunk :: p wX wY -> Maybe (FileHunk (ObjectIdOfPatch p) wX wY) -showFileHunk :: FileNameFormat -> FileHunk wX wY -> Doc+showFileHunk :: ObjectId oid => FileNameFormat -> FileHunk oid wX wY -> Doc showFileHunk x (FileHunk f line old new) =-           blueText "hunk" <+> formatFileName x f <+> text (show line)+           blueText "hunk" <+> formatObjectId x f <+> text (show line)         $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old))         $$ lineColor Cyan    (prefix "+" (vcat $ map userchunkPS new)) -instance Invert FileHunk where+showContextFileHunk+  :: ObjectId oid+  => FileNameFormat+  -> [B.ByteString]+  -> FileHunk oid wB wC+  -> [B.ByteString]+  -> Doc+showContextFileHunk fmt pre (FileHunk f l o n) post =+  blueText "hunk" <+> formatObjectId fmt f <+> text (show l) $$+  prefix " " (vcat $ map userchunkPS pre) $$+  lineColor Magenta (prefix "-" (vcat $ map userchunkPS o)) $$+  lineColor Cyan (prefix "+" (vcat $ map userchunkPS n)) $$+  prefix " " (vcat $ map userchunkPS post)++instance Invert (FileHunk oid) where     invert (FileHunk path line old new) = FileHunk path line new old
src/Darcs/Patch/Ident.hs view
@@ -2,21 +2,23 @@     ( Ident(..)     , SignedIdent     , PatchId+    , (=\^/=)+    , (=/^\=)     , SignedId(..)     , StorableId(..)-    , IdEq2(..)-    , merge2FL     , fastRemoveFL     , fastRemoveRL     , fastRemoveSubsequenceRL     , findCommonFL+    , findCommonRL+    , findCommonWithThemFL+    , findCommonWithThemRL     , commuteToPrefix-    , commuteToPostfix-    , commuteWhatWeCanToPostfix     -- * Properties     , prop_identInvariantUnderCommute     , prop_sameIdentityImpliesCommutable     , prop_equalImpliesSameIdentity+    , prop_sameIdentityImpliesEqual     ) where  import qualified Data.Set as S@@ -24,13 +26,11 @@ import Darcs.Prelude  import Darcs.Patch.Commute ( Commute, commute, commuteFL, commuteRL )-import Darcs.Patch.Merge ( Merge, mergeFL )-import Darcs.Patch.Permutations ( partitionFL', commuteWhatWeCanFL )+import Darcs.Patch.Permutations ( partitionFL', partitionRL' ) import Darcs.Patch.Show ( ShowPatchFor ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..), isIsEq ) import Darcs.Patch.Witnesses.Ordered-    ( (:/\:)(..)-    , (:>)(..)+    ( (:>)(..)     , (:\/:)(..)     , FL(..)     , RL(..)@@ -39,6 +39,7 @@     , (+>>+)     , mapFL     , mapRL+    , reverseFL     , reverseRL     ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd, unsafeCoercePStart )@@ -46,51 +47,90 @@ import Darcs.Util.Parser ( Parser ) import Darcs.Util.Printer ( Doc ) +-- | The reason this is not associated to class 'Ident' is that for technical+-- reasons we want to be able to define type instances for patches that don't+-- have an identity and therefore cannot be lawful members of class 'Ident'. type family PatchId (p :: * -> * -> *) -{- | Class of patches that have an identity.+{- | Class of patches that have an identity/name. -It generalizes named prim patches a la camp (see Darcs.Patch.Prim.Named) and-Named patches i.e. those with a PatchInfo.+Patches with an identity give rise to the notion of /nominal equality/,+expressed by the operators '=\^/=' and '=/^\='. -Patch identity should be invariant under commutation: if there is also an-@instance 'Commute' p@, then+Laws: -prop> commute (p :> q) == Just (q' :> p') => ident p == ident p' && ident q == ident q'+[/ident-commute/] -The converse should also be true: patches with the same identity can be-commuted (back) to the same context and then compare equal. Assuming+    Patch identity must be invariant under commutation: -@-  p :: p wX wY, (ps :> q) :: (RL p :> p) wX wZ-@+    prop> 'commute' (p :> _) == 'Just' (_ :> p') => 'ident' p == 'ident' p' -then+    and thus (via symmetry of 'commute'): -prop> ident p == ident q => commuteRL (ps :> q) == Just (p :> _)+    prop> 'commute' (_ :> q) == 'Just' (q' :> _) => 'ident' q == 'ident' q' -As a special case we get that parallel patches with the same identity are-equal: if @p :: p wX wY, q :: p wX wZ@, then+    Conversely, patches with the same identity result from a series of+    'commute's: -prop> ident p == ident q => p =\/= q == IsEq+    prop> 'ident' p == 'ident' p' => exists qs, qs' :: FL p. 'commuteFL' (p :> qs) == 'Just' (qs' :> p') -In general, comparing patches via their identity is coarser than-(structural) equality, so we only have+[/ident-compare/] -prop> unsafeCompare p q => (ident p == ident q)+    In general, comparing patches via their identity is+    weaker than (semantic) equality:++    prop> 'unsafeCompare' p q => 'ident' p == 'ident' q++    However, if the patches have a common context, then semantic and nominal+    equality should coincide, up to internal re-ordering:++    prop> p '=\~/=' q  <=> p '=\^/=' q+    prop> p '=/~\=' q  <=> p '=/^\=' q++    (Technical note: equality up to internal re-ordering is currently only+    defined for 'FL's, but it should be obvious how to generalize it.)++Taken together, these laws express the assumption that recording a patch+gives it a universally unique identity.++Note that violations of this universal property are currently not detected+in a reliable way. Fixing this is possible but far from easy.+ -} class Ord (PatchId p) => Ident p where   ident :: p wX wY -> PatchId p +type instance PatchId (FL p) = S.Set (PatchId p)+type instance PatchId (RL p) = S.Set (PatchId p)+type instance PatchId (p :> p) = S.Set (PatchId p)++instance Ident p => Ident (FL p) where+  ident = S.fromList . mapFL ident++instance Ident p => Ident (RL p) where+  ident = S.fromList . mapRL ident++instance Ident p => Ident (p :> p) where+  ident (p :> q) = S.fromList [ident p, ident q]++-- | Nominal equality for patches with an identity in the same context. Usually+-- quite a bit faster than structural equality.+(=\^/=) :: Ident p => p wA wB -> p wA wC -> EqCheck wB wC+p =\^/= q = if ident p == ident q then unsafeCoercePEnd IsEq else NotEq++(=/^\=) :: Ident p => p wA wC -> p wB wC -> EqCheck wA wB+p =/^\= q = if ident p == ident q then unsafeCoercePStart IsEq else NotEq++ {- | Signed identities.  Like for class 'Invert', we require that 'invertId' is self-inverse: -prop> invertId . invertId = id+prop> 'invertId' . 'invertId' = 'id'  We also require that inverting changes the sign: -prop> positiveId . invertId = not . positiveId+prop> 'positiveId' . 'invertId' = 'not' . 'positiveId'  Side remark: in mathematical terms, these properties can be expressed by stating that 'invertId' is an involution and that 'positiveId' is a@@ -108,7 +148,7 @@ Provided that an instance 'Invert' exists, inverting a patch inverts its identity: -prop> ident (invert p) = invertId (ident p)+prop> 'ident' ('invert' p) = 'invertId' ('ident' p)  -} type SignedIdent p = (Ident p, SignedId (PatchId p))@@ -120,60 +160,15 @@ for a patch type containing the identity.  As with all Read/Show pairs, We expect that the output of-@showId ForStorage a@ can be parsed by 'readId' to produce @a@.+@showId ForStorage x@ can be parsed by 'readId' to produce @x@:++prop> 'parse' 'readId' . 'renderPS' . 'showId' 'ForStorage' == 'id'+ -} class StorableId a where   readId :: Parser a   showId :: ShowPatchFor -> a -> Doc --- | Faster equality tests for patches with an identity.-class IdEq2 p where-  (=\^/=) :: p wA wB -> p wA wC -> EqCheck wB wC-  (=/^\=) :: p wA wC -> p wB wC -> EqCheck wA wB-  default (=\^/=) :: Ident p => p wA wB -> p wA wC -> EqCheck wB wC-  p =\^/= q = if ident p == ident q then unsafeCoercePEnd IsEq else NotEq-  default (=/^\=) :: Ident p => p wA wC -> p wB wC -> EqCheck wA wB-  p =/^\= q = if ident p == ident q then unsafeCoercePStart IsEq else NotEq---- | The 'Commute' requirement here is not technically needed but makes--- sense logically.-instance (Commute p, Ident p) => IdEq2 (FL p) where-  ps =\^/= qs-    | S.fromList (mapFL ident ps) == S.fromList (mapFL ident qs) = unsafeCoercePEnd IsEq-    | otherwise = NotEq-  ps =/^\= qs-    | S.fromList (mapFL ident ps) == S.fromList (mapFL ident qs) = unsafeCoercePStart IsEq-    | otherwise = NotEq---- | This function is similar to 'merge', but with one important--- difference: 'merge' works on patches for which there is not necessarily a--- concept of identity (e.g. primitive patches, conflictors, etc). Thus it does--- not even try to recognize patches that are common to both sequences. Instead--- these are passed on to the Merge instance for single patches. This instance--- may handle duplicate patches by creating special patches (Duplicate,--- Conflictor).--- --- We do not want this to happen for named patches, or in general for patches--- with an identity. Instead, we want to--- /discard/ one of the two duplicates, retaining only one copy. This is done--- by the fastRemoveFL calls below. We call mergeFL only after we have ensured--- that the head of the left hand side does not occur in the right hand side.-merge2FL :: (Commute p, Merge p, Ident p)-         => FL p wX wY-         -> FL p wX wZ-         -> (FL p :/\: FL p) wY wZ-merge2FL xs NilFL = NilFL :/\: xs-merge2FL NilFL ys = ys :/\: NilFL-merge2FL xs (y :>: ys)-  | Just xs' <- fastRemoveFL y xs = merge2FL xs' ys-merge2FL (x :>: xs) ys-  | Just ys' <- fastRemoveFL x ys = merge2FL xs ys'-  | otherwise =-    case mergeFL (x :\/: ys) of-      ys' :/\: x' ->-        case merge2FL xs ys' of-          ys'' :/\: xs' -> ys'' :/\: (x' :>: xs')- {-# INLINABLE fastRemoveFL #-} -- | Remove a patch from an FL of patches with an identity. The result is -- 'Just' whenever the patch has been found and removed and 'Nothing'@@ -185,6 +180,10 @@ -- two patches have the same identity, then they have originally been the same -- patch; thus being at a different position must be due to commutation, -- meaning we can commute it back.+--+-- For patch types that define semantic equality via nominal equality, this is+-- only faster than 'removeFL' if the patch does not occur in the sequence,+-- otherwise we have to perform the same number of commutations. fastRemoveFL :: forall p wX wY wZ. (Commute p, Ident p)              => p wX wY              -> FL p wX wZ@@ -234,29 +233,53 @@  -- | Find the common and uncommon parts of two lists that start in a common -- context, using patch identity for comparison. Of the common patches, only--- one is retained, the other is discarded, similar to 'merge2FL'.+-- one is retained, the other is discarded. findCommonFL :: (Commute p, Ident p)              => FL p wX wY              -> FL p wX wZ              -> Fork (FL p) (FL p) (FL p) wX wY wZ findCommonFL xs ys =-  case commuteToPrefix commonIds xs of-    Nothing -> error "failed to commute common patches (lhs)"-    Just (cxs :> xs') ->-      case commuteToPrefix commonIds ys of-        Nothing -> error "failed to commute common patches (rhs)"-        Just (cys :> ys') ->+  case findCommonWithThemFL xs ys of+    cxs :> xs' ->+      case findCommonWithThemFL ys xs of+        cys :> ys' ->           case cxs =\^/= cys of             NotEq -> error "common patches aren't equal"-            IsEq -> Fork cxs (reverseRL xs') (reverseRL ys')+            IsEq -> Fork cxs xs' ys'++findCommonWithThemFL+  :: (Commute p, Ident p) => FL p wX wY -> FL p wX wZ -> (FL p :> FL p) wX wY+findCommonWithThemFL xs ys =+  case partitionFL' ((`S.member` yids) . ident) NilRL NilRL xs of+    cxs :> NilRL :> xs' -> cxs :> reverseRL xs'+    _ -> error "failed to commute common patches"   where-    commonIds =-      S.fromList (mapFL ident xs) `S.intersection` S.fromList (mapFL ident ys)+    yids = S.fromList (mapFL ident ys) --- | Try to commute patches matching any of the 'PatchId's in the set to the--- head of an 'FL', i.e. backwards in history. It is not required that all the--- 'PatchId's are found in the sequence, but if they do then the traversal--- terminates as soon as the set is exhausted.+findCommonRL :: (Commute p, Ident p)+             => RL p wX wY+             -> RL p wX wZ+             -> Fork (RL p) (RL p) (RL p) wX wY wZ+findCommonRL xs ys =+  case findCommonWithThemRL xs ys of+    cxs :> xs' ->+      case findCommonWithThemRL ys xs of+        cys :> ys' ->+          case cxs =\^/= cys of+            NotEq -> error "common patches aren't equal"+            IsEq -> Fork cxs xs' ys'++findCommonWithThemRL+  :: (Commute p, Ident p) => RL p wX wY -> RL p wX wZ -> (RL p :> RL p) wX wY+findCommonWithThemRL xs ys =+  case partitionRL' (not . (`S.member` yids) . ident) xs of+    cxs :> NilFL :> xs' -> reverseFL cxs :> xs'+    _ -> error "failed to commute common patches"+  where+    yids = S.fromList (mapRL ident ys)++-- | Try to commute all patches matching any of the 'PatchId's in the set to the+-- head of an 'FL', i.e. backwards in history. commuteToPrefix :: (Commute p, Ident p)                 => S.Set (PatchId p) -> FL p wX wY -> Maybe ((FL p :> RL p) wX wY) commuteToPrefix is ps@@ -264,44 +287,6 @@       partitionFL' ((`S.member` is) . ident) NilRL NilRL ps = Just (prefix :> rest)   | otherwise = Nothing --- | Try to commute patches matching any of the 'PatchId's in the set to the--- head of an 'RL', i.e. forwards in history. It is not required that all the--- 'PatchId's are found in the sequence, but if they do then the traversal--- terminates as soon as the set is exhausted.-commuteToPostfix :: forall p wX wY. (Commute p, Ident p)-                 => S.Set (PatchId p) -> RL p wX wY -> Maybe ((FL p :> RL p) wX wY)-commuteToPostfix ids patches = push ids (patches :> NilFL)-  where-    push :: S.Set (PatchId p) -> (RL p :> FL p) wA wB -> Maybe ((FL p :> RL p) wA wB)-    push _ (NilRL :> left) = return (left :> NilRL) -- input RL is ehausted-    push is (ps :> left)-      | S.null is = return (ps +>>+ left :> NilRL) -- set of IDs is exhausted-    push is (ps :<: p :> left)-      | let i = ident p-      , i `S.member` is = do-          left' :> p' <- commuteFL (p :> left)-          left'' :> right <- push (S.delete i is) (ps :> left')-          return (left'' :> right :<: p')-      | otherwise = push is (ps :> p :>: left)---- | Like 'commuteToPostfix' but drag dependencies with us.-commuteWhatWeCanToPostfix :: forall p wX wY. (Commute p, Ident p)-                          => S.Set (PatchId p) -> RL p wX wY -> (FL p :> RL p) wX wY-commuteWhatWeCanToPostfix ids patches = push ids (patches :> NilFL)-  where-    push :: S.Set (PatchId p) -> (RL p :> FL p) wA wB -> (FL p :> RL p) wA wB-    push _ (NilRL :> left) = left :> NilRL -- input RL is ehausted-    push is (ps :> left)-      | S.null is = ps +>>+ left :> NilRL -- set of IDs is exhausted-    push is (ps :<: p :> left)-      | let i = ident p-      , i `S.member` is =-          case commuteWhatWeCanFL (p :> left) of-            left' :> p' :> deps ->-              case push (S.delete i is) (ps :> left') of-                left'' :> right -> left'' :> (right :<: p' +<<+ deps)-      | otherwise = push is (ps :> p :>: left)- prop_identInvariantUnderCommute :: (Commute p, Ident p)                                 => (p :> p) wX wY -> Maybe Bool prop_identInvariantUnderCommute (p :> q) =@@ -319,7 +304,14 @@   | otherwise = Nothing  prop_equalImpliesSameIdentity :: (Eq2 p, Ident p)+                              => p wA wB -> p wC wD -> Maybe Bool+prop_equalImpliesSameIdentity p q+  | p `unsafeCompare` q = Just $ ident p == ident q+  | otherwise = Nothing++-- Note the assumption of coinciding start states here!+prop_sameIdentityImpliesEqual :: (Eq2 p, Ident p)                               => (p :\/: p) wX wY -> Maybe Bool-prop_equalImpliesSameIdentity (p :\/: q)-  | IsEq <- p =\/= q = Just $ ident p == ident q+prop_sameIdentityImpliesEqual (p :\/: q)+  | ident p == ident q = Just $ isIsEq $ p =\/= q   | otherwise = Nothing
src/Darcs/Patch/Index/Monad.hs view
@@ -21,41 +21,59 @@ module Darcs.Patch.Index.Monad     ( withPatchMods     , applyToFileMods-    , makePatchID+    , FileMod(..)     ) where  import Darcs.Prelude -import Darcs.Patch.Index.Types ( PatchMod(..), PatchId(..) )-import Darcs.Patch.Info ( makePatchname, PatchInfo ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )-import Control.Monad.State+import Control.Monad ( when, forM_ )+import Control.Monad.Catch ( MonadThrow(..), SomeException )+import Control.Monad.State ( MonadState, StateT, execStateT, gets, modify ) import Control.Arrow import Darcs.Util.Path ( AnchoredPath, anchorPath, movedirfilename, isPrefix ) import qualified Data.Set as S import Data.Set ( Set ) import Darcs.Util.Tree (Tree) -newtype FileModMonad a = FMM (State (Set AnchoredPath, [PatchMod AnchoredPath]) a)+-- | This is used to track changes to files+data FileMod a+  = PTouch a+  | PCreateFile a+  | PCreateDir a+  | PRename a a+  | PRemove a+  | PDuplicateTouch a+    -- ^ this is used for duplicate patches that don't+    --   have any effect, but we still want to keep+    --   track of them+  deriving (Show, Eq, Functor)++type FileModState = (Set AnchoredPath, [FileMod AnchoredPath])++newtype FileModMonad a =+  FMM (StateT FileModState (Either SomeException) a)   deriving ( Functor            , Applicative            , Monad-           , MonadState (Set AnchoredPath, [PatchMod AnchoredPath])+           , MonadThrow+           , MonadState FileModState            )  withPatchMods :: FileModMonad a               -> Set AnchoredPath-              -> (Set AnchoredPath, [PatchMod AnchoredPath])-withPatchMods (FMM m) fps = second reverse $ execState m (fps,[])+              -> FileModState+withPatchMods (FMM m) fps =+  second reverse $+    case execStateT m (fps,[]) of+      Left e -> error (show e)+      Right r -> r  -- These instances are defined to be used only with -- apply. instance ApplyMonad Tree FileModMonad where-    type ApplyMonadBase FileModMonad = FileModMonad-    nestedApply _ _ = error "nestedApply FileModMonad"-    liftApply _ _ = error "liftApply FileModMonad"-    getApplyState = error "getApplyState FileModMonad"+    readFilePS = error "readFilePS FileModMonad"  instance ApplyMonadTree FileModMonad where     mDoesDirectoryExist d = do@@ -86,7 +104,7 @@ -- --------------------------------------------------------------------- -- State Handling Functions -addMod :: PatchMod AnchoredPath -> FileModMonad ()+addMod :: FileMod AnchoredPath -> FileModMonad () addMod pm = modify $ second (pm :)  addFile :: AnchoredPath -> FileModMonad ()@@ -106,13 +124,13 @@  errorIfPresent :: AnchoredPath -> Bool -> FileModMonad () errorIfPresent fn isFile = do-    fs <- gets fst-    when (S.member fn fs) $-        error $ unwords [ "error: patch index entry for"-                        , if isFile then "file" else "directory"-                        , anchorPath "" fn-                        , "created >1 times. Run `darcs repair` and try again."-                        ]+  fs <- gets fst+  when (S.member fn fs) $ throwM $ userError $ unwords+    [ "error: patch index entry for"+    , if isFile then "file" else "directory"+    , anchorPath "" fn+    , "created >1 times. Run `darcs repair` and try again."+    ]  remove :: AnchoredPath -> FileModMonad () remove f = addMod (PRemove f) >> modifyFps (S.delete f)@@ -120,14 +138,11 @@ modifyFps :: (Set AnchoredPath -> Set AnchoredPath) -> FileModMonad () modifyFps f = modify $ first f -makePatchID :: PatchInfo -> PatchId-makePatchID = PID . makePatchname- -------------------------------------------------------------------------------- -- | Apply a patch to set of 'AnchoredPath's, yielding the new set of--- 'AnchoredPath's and 'PatchMod's+-- 'AnchoredPath's and 'FileMod's applyToFileMods :: (Apply p, ApplyState p ~ Tree)                 => p wX wY                 -> Set AnchoredPath-                -> (Set AnchoredPath, [PatchMod AnchoredPath])+                -> FileModState applyToFileMods patch = withPatchMods (apply patch)
src/Darcs/Patch/Index/Types.hs view
@@ -19,10 +19,10 @@  import Darcs.Prelude +import Darcs.Patch.Info ( makePatchname, PatchInfo ) import Darcs.Util.Hash( SHA1, sha1short, sha1zero ) import Darcs.Util.Path ( anchorPath, AnchoredPath ) import Data.Binary ( Binary(..) )-import Data.Word ( Word32 )  -- | The FileId for a file consists of the FilePath (creation name) --   and an index. The index denotes how many files@@ -48,23 +48,12 @@ pid2string :: PatchId -> String pid2string = show . patchId --- | This is used to track changes to files-data PatchMod a-  = PTouch a-  | PCreateFile a-  | PCreateDir a-  | PRename a-            a-  | PRemove a-  | PDuplicateTouch a-    -- ^ this is used for duplicate patches that don't-    --   have any effect, but we still want to keep-    --   track of them-  deriving (Show, Eq, Functor)--short :: PatchId -> Word32-short (PID sha1) = sha1short sha1+short :: PatchId -> Int+short (PID sha1) = fromIntegral $ sha1short sha1  zero :: PatchId zero = PID sha1zero++makePatchID :: PatchInfo -> PatchId+makePatchID = PID . makePatchname
src/Darcs/Patch/Info.hs view
@@ -83,7 +83,6 @@ import System.IO.Unsafe ( unsafePerformIO ) import Darcs.Util.Hash ( sha1PS, SHA1 ) import Darcs.Util.Prompt ( promptYorn )-import Darcs.Util.Show ( appPrec )  import Darcs.Test.TestOnly ( TestOnly ) @@ -144,16 +143,7 @@               -- docs above.             , _piLegacyIsInverted :: !Bool             }-  deriving (Eq,Ord)--instance Show PatchInfo where-    showsPrec d (PatchInfo date name author log inverted) =-        showParen (d > appPrec) $-            showString "rawPatchInfo " . showsPrec (appPrec + 1) date .-            showString " " . showsPrec (appPrec + 1) name .-            showString " " . showsPrec (appPrec + 1) author .-            showString " " . showsPrec (appPrec + 1) log .-            showString " " . showsPrec (appPrec + 1) inverted+  deriving (Eq,Ord,Show)  -- Validation
src/Darcs/Patch/Invert.hs view
@@ -1,5 +1,5 @@ module Darcs.Patch.Invert-       ( Invert(..), invertFL, invertRL, dropInverses+       ( Invert(..), invertFL, invertRL        )        where @@ -7,7 +7,6 @@  import Darcs.Patch.Witnesses.Ordered     ( FL(..), RL(..), reverseFL, reverseRL, (:>)(..) )-import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq), Eq2((=\/=)) )  -- | The 'invert' operation must be self-inverse, i.e. an involution: --@@ -31,13 +30,3 @@  instance Invert p => Invert (p :> p) where   invert (a :> b) = invert b :> invert a---- | Delete the first subsequence of patches that is followed by--- an inverse subsequence, if one exists. If not return 'Nothing'.-dropInverses :: (Invert p, Eq2 p) => FL p wX wY -> Maybe (FL p wX wY)-dropInverses (x :>: y :>: z)-  | IsEq <- invert x =\/= y = Just z-  | otherwise = do-      yz <- dropInverses (y :>: z)-      dropInverses (x :>: yz)-dropInverses _ = Nothing
src/Darcs/Patch/Invertible.hs view
@@ -20,6 +20,7 @@     , Eq2(..)     , PrimPatchBase(..)     , PatchInspect(..)+    , PatchListFormat(..)     , ShowContextPatch(..)     , ShowPatch(..)     , ShowPatchBasic(..)@@ -108,5 +109,7 @@   content = withInvertible content  instance ShowContextPatch p => ShowContextPatch (Invertible p) where-  showContextPatch ForStorage = error "Invertible patches must not be stored"-  showContextPatch ForDisplay = withInvertible (showContextPatch ForDisplay)+  showPatchWithContextAndApply ForStorage = error "Invertible patches must not be stored"+  showPatchWithContextAndApply ForDisplay = withInvertible (showPatchWithContextAndApply ForDisplay)++instance PatchListFormat p => PatchListFormat (Invertible p)
src/Darcs/Patch/Match.hs view
@@ -100,17 +100,13 @@ import Data.Typeable ( Typeable )  import Darcs.Util.Path ( AbsolutePath )-import Darcs.Patch-    ( IsRepoType-    , hunkMatches-    , listTouchedFiles-    )+import Darcs.Patch ( hunkMatches, listTouchedFiles ) import Darcs.Patch.Info ( justName, justAuthor, justLog, makePatchname,                           piDate, piTag )  import qualified Data.ByteString.Char8 as BC -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, conscientiously )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) import Darcs.Patch.Set     ( Origin     , PatchSet(..)@@ -129,7 +125,6 @@     ( RL(..), FL(..), (:>)(..), reverseRL, mapRL, (+<+) ) import Darcs.Patch.Witnesses.Sealed     ( Sealed2(..), seal, seal2, unseal2, unseal )-import Darcs.Util.Printer ( text, ($$) ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )  import Darcs.Util.DateMatcher ( parseDateMatcher )@@ -144,7 +139,7 @@   , PatchId p ~ PatchInfo   ) --- | Constraint for a patch type @p@ that ensures @'PatchInfoAnd' rt p@+-- | Constraint for a patch type @p@ that ensures @'PatchInfoAnd' p@ -- is 'Matchable'. type MatchableRP p =   ( Apply p@@ -176,6 +171,7 @@     | AfterHash String     | UpToHash String     | OneTag String+    | SeveralTag String     | AfterTag String     | UpToTag String     | LastN Int@@ -276,8 +272,11 @@    "    --hash=HASH is a synonym for --matches='hash HASH'",    "    --from-patch and --to-patch are synonyms for",    "      --from-match='name... and --to-match='name...",-   "    --from-patch and --to-match can be unproblematically combined:",+   "    --from-hash and --to-hash are synonyms for",+   "      --from-match='hash...' and --to-match='hash...'",+   "    sensible combinations of --from-* and --to-* options are possible:",    "      `darcs log --from-patch='html.*docu' --to-match='date 20040212'`",+   "      `darcs log --from-hash=368089c6969 --to-patch='^fix.*renamed or moved\\.$'`",    "",    "The following primitive Boolean expressions are supported:"    ,""]@@ -461,6 +460,7 @@ nonrangeMatcher (OnePatch p:_) = strictJust $ patchmatch p nonrangeMatcher (OneHash h:_) = strictJust $ hashmatch' h nonrangeMatcher (SeveralPattern m:_) = strictJust $ matchPattern m+nonrangeMatcher (SeveralTag t:_) = strictJust $ tagmatch t nonrangeMatcher (SeveralPatch p:_) = strictJust $ patchmatch p nonrangeMatcher (_:fs) = nonrangeMatcher fs @@ -525,10 +525,10 @@ -- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its -- first matcher, ie the one that comes first dependencywise. Hence, -- patches in @matchFirstPatchset fs ps@ are the context for the ones--- we don't want.+-- we want. matchFirstPatchset :: MatchableRP p-                   => [MatchFlag] -> PatchSet rt p wStart wX-                   -> Maybe (SealedPatchSet rt p wStart)+                   => [MatchFlag] -> PatchSet p wStart wX+                   -> Maybe (SealedPatchSet p wStart) matchFirstPatchset fs patchset   | Just n <- hasLastn fs = Just $ patchSetDrop n patchset   | Just (_, b) <- hasIndexRange fs = Just $ patchSetDrop b patchset@@ -542,8 +542,8 @@ -- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its -- second matcher, ie the one that comes last dependencywise. matchSecondPatchset :: MatchableRP p-                    => [MatchFlag] -> PatchSet rt p wStart wX-                    -> Maybe (SealedPatchSet rt p wStart)+                    => [MatchFlag] -> PatchSet p wStart wX+                    -> Maybe (SealedPatchSet p wStart) matchSecondPatchset fs ps   | Just (a, _) <- hasIndexRange fs = Just $ patchSetDrop (a - 1) ps   | Just m <- secondMatcher fs =@@ -603,11 +603,11 @@ matchAPatchset   :: MatchableRP p   => Matcher-  -> PatchSet rt p wStart wX-  -> SealedPatchSet rt p wStart+  -> PatchSet p wStart wX+  -> SealedPatchSet p wStart matchAPatchset m (PatchSet NilRL NilRL) =   throw $ MatchFailure $ show m-matchAPatchset m (PatchSet (ts :<: Tagged t _ ps) NilRL) =+matchAPatchset m (PatchSet (ts :<: Tagged ps t _) NilRL) =   matchAPatchset m (PatchSet ts (ps :<: t)) matchAPatchset m (PatchSet ts (ps :<: p))   | applyMatcher m p = seal (PatchSet ts (ps :<: p))@@ -615,10 +615,10 @@  splitOnMatchingTag :: MatchableRP p                    => Matcher-                   -> PatchSet rt p wStart wX-                   -> PatchSet rt p wStart wX+                   -> PatchSet p wStart wX+                   -> PatchSet p wStart wX splitOnMatchingTag _ s@(PatchSet NilRL NilRL) = s-splitOnMatchingTag m s@(PatchSet (ts :<: Tagged t _ ps) NilRL)+splitOnMatchingTag m s@(PatchSet (ts :<: Tagged ps t _) NilRL)     | applyMatcher m t = s     | otherwise = splitOnMatchingTag m (PatchSet ts (ps:<:t)) splitOnMatchingTag m (PatchSet ts (ps:<:p))@@ -638,8 +638,8 @@ -- 'error' if there is no matching tag. getMatchingTag :: MatchableRP p                => Matcher-               -> PatchSet rt p wStart wX-               -> SealedPatchSet rt p wStart+               -> PatchSet p wStart wX+               -> SealedPatchSet p wStart getMatchingTag m ps =   case splitOnMatchingTag m ps of     PatchSet NilRL _ -> throw $ userError $ "Couldn't find a tag matching " ++ show m@@ -652,10 +652,10 @@ -- patches that are not depended on by the tag; otherwise rollback patches that -- follow the latest matching patch. rollbackToPatchSetMatch :: ( ApplyMonad (ApplyState p) m-                           , IsRepoType rt, MatchableRP p, ApplyState p ~ Tree+                           , MatchableRP p, ApplyState p ~ Tree                            )                         => PatchSetMatch-                        -> PatchSet rt p Origin wX+                        -> PatchSet p Origin wX                         -> m () rollbackToPatchSetMatch psm repo =   case psm of@@ -669,55 +669,42 @@  -- | @applyInvToMatcher@ m ps applies the inverse of the patches in @ps@, -- starting at the end, until we hit a patch that matches the 'Matcher' @m@.-applyInvToMatcher :: (IsRepoType rt, MatchableRP p, ApplyMonad (ApplyState p) m)+applyInvToMatcher :: (MatchableRP p, ApplyMonad (ApplyState p) m)                   => Matcher-                  -> PatchSet rt p Origin wX+                  -> PatchSet p Origin wX                   -> m () applyInvToMatcher m (PatchSet NilRL NilRL) =   throw $ MatchFailure $ show m-applyInvToMatcher m (PatchSet (ts :<: Tagged t _ ps) NilRL) =+applyInvToMatcher m (PatchSet (ts :<: Tagged ps t _) NilRL) =   applyInvToMatcher m (PatchSet ts (ps :<: t)) applyInvToMatcher m (PatchSet xs (ps :<: p))   | applyMatcher m p = return ()-  | otherwise = applyInvp p >> applyInvToMatcher m (PatchSet xs ps)+  | otherwise = unapply p >> applyInvToMatcher m (PatchSet xs ps)  -- | @applyNInv@ n ps applies the inverse of the last @n@ patches of @ps@.-applyNInv :: (IsRepoType rt, MatchableRP p, ApplyMonad (ApplyState p) m)-          => Int -> PatchSet rt p Origin wX -> m ()+applyNInv :: (MatchableRP p, ApplyMonad (ApplyState p) m)+          => Int -> PatchSet p Origin wX -> m () applyNInv n _ | n <= 0 = return () applyNInv _ (PatchSet NilRL NilRL) = throw $ userError "Index out of range"-applyNInv n (PatchSet (ts :<: Tagged t _ ps) NilRL) =+applyNInv n (PatchSet (ts :<: Tagged ps t _) NilRL) =   applyNInv n (PatchSet ts (ps :<: t)) applyNInv n (PatchSet xs (ps :<: p)) =-  applyInvp p >> applyNInv (n - 1) (PatchSet xs ps)---- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd--- patch', and to apply its inverse. If we fail to fetch the patch--- then we share our sorrow with the user.-applyInvp :: (Apply p, ApplyMonad (ApplyState p) m)-          => PatchInfoAnd rt p wX wY -> m ()-applyInvp = unapply . fromHopefully-    where fromHopefully = conscientiously $ \e ->-                     text "Sorry, patch not available:"-                     $$ e-                     $$ text ""-                     $$ text "If you think what you're trying to do is ok then"-                     $$ text "report this as a bug on the darcs-user list."+  unapply p >> applyNInv (n - 1) (PatchSet xs ps)  -- | matchingHead returns the repository up to some tag. The tag t is the last -- tag such that there is a patch after t that is matched by the user's query.-matchingHead :: forall rt p wR. MatchableRP p-             => [MatchFlag] -> PatchSet rt p Origin wR-             -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR+matchingHead :: forall p wR. MatchableRP p+             => [MatchFlag] -> PatchSet p Origin wR+             -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR matchingHead matchFlags set =     case mh set of         (start :> patches) -> start :> reverseRL patches   where-    mh :: forall wX . PatchSet rt p Origin wX-       -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) Origin wX+    mh :: forall wX . PatchSet p Origin wX+       -> (PatchSet p :> RL (PatchInfoAnd p)) Origin wX     mh s@(PatchSet _ x)         | or (mapRL (matchAPatch matchFlags) x) = contextPatches s-    mh (PatchSet (ts :<: Tagged t _ ps) x) =+    mh (PatchSet (ts :<: Tagged ps t _) x) =         case mh (PatchSet ts (ps :<: t)) of             (start :> patches) -> start :> patches +<+ x     mh ps = ps :> NilRL
− src/Darcs/Patch/MonadProgress.hs 
@@ -1,57 +0,0 @@---  Copyright (C) 2011 Ganesh Sittampalam------ Permission is hereby granted, free of charge, to any person--- obtaining a copy of this software and associated documentation--- files (the "Software"), to deal in the Software without--- restriction, including without limitation the rights to use, copy,--- modify, merge, publish, distribute, sublicense, and/or sell copies--- of the Software, and to permit persons to whom the Software is--- furnished to do so, subject to the following conditions:------ The above copyright notice and this permission notice shall be--- included in all copies or substantial portions of the Software.------ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,--- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF--- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND--- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS--- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN--- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN--- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE--- SOFTWARE.--module Darcs.Patch.MonadProgress-    ( MonadProgress(..)-    , ProgressAction(..)-    , silentlyRunProgressActions-    ) where--import Darcs.Prelude--import Darcs.Util.Printer ( Doc )-import Darcs.Util.Printer.Color () -- for instance Show Doc-import qualified Darcs.Util.Tree.Monad as TM---- |a monadic action, annotated with a progress message that could be printed out--- while running the action, and a message that could be printed out on error.--- Actually printing out these messages is optional to allow non-IO monads to--- just run the action.-data ProgressAction m a =-  ProgressAction-   {paAction :: m a-   ,paMessage :: Doc-   ,paOnError :: Doc-   }--class Monad m => MonadProgress m where-  -- |run a list of 'ProgressAction's. In some monads (typically IO-based ones),-  -- the progress and error messages will be used. In others they will be-  -- ignored and just the actions will be run.-  runProgressActions :: String -> [ProgressAction m ()] -> m ()---- |run a list of 'ProgressAction's without any feedback messages-silentlyRunProgressActions :: Monad m => String -> [ProgressAction m ()] -> m ()-silentlyRunProgressActions _ = mapM_ paAction--instance (Monad m) => MonadProgress (TM.TreeMonad m) where-  runProgressActions = silentlyRunProgressActions
src/Darcs/Patch/Named.hs view
@@ -15,10 +15,21 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. +-- | 'Named' patches group a set of changes with meta data ('PatchInfo') and+-- explicit dependencies (created using `darcs tag` or using --ask-deps).+--+-- While the data constructor 'NamedP' is exported for technical reasons, code+-- outside this modules should (and generally does) treat it as an abstract+-- data type. The only exception is the rebase implementation i.e. the modules+-- under "Darcs.Patch.Rebase".++{-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Named     ( Named(..)+    -- treated as abstract data type except by Darcs.Patch.Rebase     , infopatch     , adddeps+    , setinfo     , anonymous     , HasDeps(..)     , patch2patchinfo@@ -28,6 +39,7 @@     , fmapFL_Named     , mergerIdNamed     , ShowDepsFormat(..)+    , ShowWhichDeps(..)     , showDependencies     ) where @@ -37,7 +49,7 @@ import qualified Data.Set as S  import Darcs.Patch.CommuteFn ( MergeFn, commuterIdFL, mergerIdFL )-import Darcs.Patch.Conflict ( Conflict(..) )+import Darcs.Patch.Conflict ( Conflict(..), findConflicting ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(effect) ) import Darcs.Patch.FileHunk ( IsHunk(..) )@@ -45,9 +57,10 @@ import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, patchinfo,                           piName, displayPatchInfo, makePatchname ) import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) )-import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Object ( ObjectId )+import Darcs.Patch.Apply ( Apply(..), ObjectIdOfPatch ) import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Ident ( Ident(..), PatchId, IdEq2(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL ) import Darcs.Patch.Read ( ReadPatch(..) )@@ -72,8 +85,8 @@ import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered     ( (:>)(..), (:\/:)(..), (:/\:)(..)-    , FL(..), RL(..), mapFL, mapFL_FL, mapRL_RL-    , (+>+), concatRLFL, reverseFL+    , FL(..), RL(..), mapFL, mapRL, mapFL_FL, mapRL_RL+    , (+<+), (+>+), concatRLFL, reverseFL     , (+<<+), (+>>+), concatFL     ) import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal )@@ -81,7 +94,7 @@  import Darcs.Util.IsoDate ( showIsoDateTime, theBeginning ) import Darcs.Util.Printer-    ( Doc, ($$), (<+>), text, vcat, cyanText, blueText )+    ( Doc, ($$), (<+>), text, vcat, cyanText, blueText, redText )  -- | The @Named@ type adds a patch info about a patch, that is a name. data Named p wX wY where@@ -106,8 +119,6 @@ instance Ident (Named p) where     ident = patch2patchinfo -instance IdEq2 (Named p)- instance IsHunk (Named p) where     isHunk _ = Nothing @@ -154,6 +165,9 @@ adddeps :: Named p wX wY -> [PatchInfo] -> Named p wX wY adddeps (NamedP pi _ p) ds = NamedP pi ds p +setinfo :: PatchInfo -> Named p wX wY -> Named p wX wY+setinfo i (NamedP _ ds ps) = NamedP i ds ps+ -- | This slightly ad-hoc class is here so we can call 'getdeps' with patch -- types that wrap a 'Named', such as 'RebaseChange'. class HasDeps p where@@ -180,8 +194,9 @@ fmapFL_Named :: (FL p wA wB -> FL q wC wD) -> Named p wA wB -> Named q wC wD fmapFL_Named f (NamedP i deps p) = NamedP i deps (f p) -instance Eq2 (Named p) where-    unsafeCompare (NamedP n1 _ _) (NamedP n2 _ _) = n1 == n2+instance (Commute p, Eq2 p) => Eq2 (Named p) where+    unsafeCompare (NamedP n1 ds1 ps1) (NamedP n2 ds2 ps2) =+        n1 == n2 && ds1 == ds2 && unsafeCompare ps1 ps2  instance Commute p => Commute (Named p) where     commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) =@@ -215,53 +230,110 @@      p2' :/\: p1' -> NamedP n2 d2 p2' :/\: p1'  {- | This instance takes care of handling the interaction between conflict-resolution and explicit dependencies. By definition, a conflict counts as-resolved if another patch depends on it. This principle extends to explicit-dependencies between 'Named' patches, but not to (aggregate) implicit-dependencies.+resolution and explicit dependencies. A conflict involves a set of two or+more patches and the general rule is that the conflict is considered+resolved if there is another (later) patch that (transitively) depends on+each of the (mutually) conflicting patches. -This means we count any patch inside a 'Named' patch as resolved if some-later 'Named' patch depends on it explicitly. The patches contained inside a-'Named' patch that is not explicitly depended on must be commuted one by one-past those we know are resolved. It is important to realize that we must not-do this commutation at the 'Named' patch level but at the level below that.--}+This principle extends to explicit dependencies between 'Named' patches. In+particular, recording a tag has the effect of resolving any as yet+unresolved conflicts in a repo. -instance (Commute p, Conflict p) => Conflict (Named p) where-    resolveConflicts context patches =-      case separate S.empty patches NilFL NilFL of-        deps :> nondeps ->-          resolveConflicts (patchcontentsRL context +<<+ deps) (reverseFL nondeps)-      where-        -- Separate the patch contents of an 'RL' of 'Named' patches into those-        -- we regard as resolved due to explicit dependencies on the containing-        -- 'Named' patch, and any others that can be commuted past them.-        separate :: S.Set PatchInfo-                 -> RL (Named p) w1 w2-                 -> FL p w2 w3-                 -> FL p w3 w4-                 -> (FL p :> FL p) w1 w4-        separate acc_deps (ps :<: NamedP name deps contents) resolved unresolved-          | name `S.member` acc_deps =-            -- We are depended upon explicitly, so all patches in 'contents'-            -- are considered resolved.-            separate (acc_deps +| deps) ps (contents +>+ resolved) unresolved-          | otherwise =-            -- We are not explicitly depended upon, so commute as much as we-            -- can of our patch 'contents' past 'resolved', without dragging-            -- dependencies along. To use existing tools for commutation means-            -- we have to commuteWhatWeCan 'resolved' backwards through the-            -- 'contents', now /with/ dragging dependencies along.-            case genCommuteWhatWeCanRL (commuterIdFL commute)-                  (reverseFL contents :> resolved) of-              dragged :> resolved' :> more_unresolved ->-                separate (acc_deps +| deps) ps-                  (dragged +>>+ resolved') (more_unresolved +>>+ unresolved)-        separate _ NilRL resolved unresolved = resolved :> unresolved+In general a 'Named' patch contains multiple changes ( a "changeset").+Consider the named patches -        -- used to accumulate explicit dependencies-        some +| more = foldr S.insert some more+@+  Named A [] a+  Named B [] (b1;b2)+  Named C [] c+  Named D [A,B] _+@ +where, at the RepoPatch level, @a@ conflicts with @b1@, and @c@ with @b2@.+@D@ depends explicitly on both @A@ and @B@, so it fully covers the conflict+between @a@ and @b1@ and thus we would be justified to consider that+particular conflict as resolved. Unfortunately we cannot detect this at the+Named patch level because RepoPatchV1 and V2 have no notion of patch+identities. Thus, at the Named level the two underlying conflicts appear as+a single large conflict between the three named patches @A@, @B@, and @C@,+and this means that patch @D@ does /not/ count as a (partial) resolution+(even though it arguably should).++When we decide that a set of conflicting Named patches is resolved, we move+the RepoPatches contained in them to the context of the resolution. For all+other named patches, we must commute as much of their contents as possible+past the ones marked as resolved, using commutation at the RepoPatch level+(i.e. ignoring explicit dependencies). -}++instance ( Commute p+         , Conflict p+         , Summary p+         , PrimPatchBase p+         , PatchListFormat p+         , ShowPatch p+         ) =>+         Conflict (Named p) where+  isConflicted (NamedP _ _ ps) = or (mapFL isConflicted ps)+  resolveConflicts context patches =+    case separate S.empty [] context patches NilFL NilFL of+      resolved :> unresolved ->+        resolveConflicts (patchcontentsRL context +<<+ resolved) (reverseFL unresolved)+    where+      -- Separate the patch contents of an 'RL' of 'Named' patches into those+      -- we regard as resolved due to explicit dependencies and any others.+      -- Implicit dependencies are kept with the resolved patches. The first+      -- parameter accumulates the PatchInfo of patches which we consider+      -- resolved; the second one accumulates direct and indirect explicit+      -- dependencies for the patches we have traversed. The third parameter+      -- is the context, which is only needed as input to 'findConflicting'.+      separate+        :: S.Set PatchInfo    -- names of resolved Named patches so far+        -> [S.Set PatchInfo]  -- transitive explicit dependencies so far+        -> RL (Named p) w0 w1 -- context for Named patches+        -> RL (Named p) w1 w2 -- Named patches under consideration+        -> FL p w2 w3         -- result: resolved at RepoPatch layer so far+        -> FL p w3 w4         -- result: unresolved at RepoPatch layer so far+        -> (FL p :> FL p) w1 w4+      separate acc_res acc_deps ctx (ps :<: p@(NamedP name deps contents)) resolved unresolved+        | name `S.member` acc_res || isConflicted p+        , _ :> _ :> conflicting <- findConflicting (ctx +<+ ps) p+        , let conflict_ids = S.fromList $ name : mapRL ident conflicting+        , any (conflict_ids `S.isSubsetOf`) acc_deps =+          -- Either we already determined that p is considered resolved,+          -- or p is conflicted and all patches involved in the conflict are+          -- transitively explicitly depended upon by a single patch.+          -- The action is to regard everything in 'contents' as resolved.+          separate (acc_res `S.union` conflict_ids) (extend name deps acc_deps)+            ctx ps (contents +>+ resolved) unresolved+        | otherwise =+          -- Commute as much as we can of our patch 'contents' past 'resolved',+          -- without dragging dependencies along.+          -- To use existing tools for commutation means we have to+          -- commuteWhatWeCan 'resolved' backwards through the 'contents',+          -- now /with/ dragging dependencies along.+          case genCommuteWhatWeCanRL (commuterIdFL commute)+                (reverseFL contents :> resolved) of+            dragged :> resolved' :> more_unresolved ->+              separate acc_res (extend name deps acc_deps) ctx ps+                (dragged +>>+ resolved') (more_unresolved +>>+ unresolved)+      separate _ _ _ NilRL resolved unresolved = resolved :> unresolved++      -- Extend a list of sets of dependencies by adding the new list of+      -- dependencies to each set that contains the given 'name'. If 'name'+      -- does not occur in any of the sets, we add the dependencies as a new+      -- set to the list.+      -- Since we have to track whether 'name' was found in any of the input+      -- sets, this is not a straight-forward fold, so we use explicit+      -- recursion.+      extend :: Ord a => a -> [a] -> [S.Set a] -> [S.Set a]+      extend _ [] acc_deps = acc_deps+      extend name deps acc_deps = go False (S.fromList deps) acc_deps where+        go False new [] = [new]+        go True _ [] = []+        go found new (ds:dss)+          | name `S.member` ds = ds `S.union` new : go True new dss+          | otherwise = ds : go found new dss+ instance (PrimPatchBase p, Unwind p) => Unwind (Named p) where   fullUnwind (NamedP _ _ ps) = squashUnwound (mapFL_FL fullUnwind ps) @@ -291,43 +363,55 @@     $$ p showNamedPrefix f@ForDisplay n d p =     showPatchInfo f n-    $$ showDependencies ShowDepsVerbose d+    $$ showDependencies ShowNormalDeps ShowDepsVerbose d     $$ p  instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Named p) where     showPatch f (NamedP n d p) = showNamedPrefix f n d $ showPatch f p -instance (Apply p, IsHunk p, PatchListFormat p,-          ShowContextPatch p) => ShowContextPatch (Named p) where-    showContextPatch f (NamedP n d p) =-        showNamedPrefix f n d <$> showContextPatch f p+instance ( Apply p+         , IsHunk p+         , PatchListFormat p+         , ObjectId (ObjectIdOfPatch p)+         , ShowContextPatch p+         ) =>+         ShowContextPatch (Named p) where+    showPatchWithContextAndApply f (NamedP n d p) =+        showNamedPrefix f n d <$> showPatchWithContextAndApply f p -data ShowDepsFormat = ShowDepsVerbose | ShowDepsSummary-                        deriving (Eq)+data ShowDepsFormat = ShowDepsVerbose | ShowDepsSummary deriving (Eq) -showDependencies :: ShowDepsFormat -> [PatchInfo] -> Doc-showDependencies format deps = vcat (map showDependency deps)+-- | Support for rebase+data ShowWhichDeps = ShowNormalDeps | ShowDroppedDeps deriving (Eq)++showDependencies :: ShowWhichDeps -> ShowDepsFormat -> [PatchInfo] -> Doc+showDependencies which format deps = vcat (map showDependency deps)   where     showDependency d =-      mark <+>-      cyanText (show (makePatchname d)) $$ asterisk <+> text (piName d)-    mark-      | format == ShowDepsVerbose = blueText "depend"-      | otherwise = text "D"-    asterisk = text "  *"+      case format of+        ShowDepsVerbose ->+          mark which format <+> cyanText (show (makePatchname d)) $$+          text "  *" <+> text (piName d)+        ShowDepsSummary ->+          mark which format <+>+          cyanText (take 8 (show (makePatchname d))) <+> text (piName d)+    mark ShowNormalDeps ShowDepsVerbose = blueText "depend"+    mark ShowDroppedDeps ShowDepsVerbose = redText "dropped"+    mark ShowNormalDeps ShowDepsSummary = text "D"+    mark ShowDroppedDeps ShowDepsSummary = text "D!"  instance (Summary p, PatchListFormat p,           PrimPatchBase p, ShowPatch p) => ShowPatch (Named p) where     description (NamedP n _ _) = displayPatchInfo n     summary (NamedP _ ds ps) =-        showDependencies ShowDepsSummary ds $$ plainSummaryFL ps+        showDependencies ShowNormalDeps ShowDepsSummary ds $$ plainSummaryFL ps     summaryFL nps =-        showDependencies ShowDepsSummary ds $$ plainSummaryFL ps+        showDependencies ShowNormalDeps ShowDepsSummary ds $$ plainSummaryFL ps       where         ds = nubSort $ concat $ mapFL getdeps nps         ps = concatFL $ mapFL_FL patchcontents nps     content (NamedP _ ds ps) =-        showDependencies ShowDepsVerbose ds $$ displayPatch ps+        showDependencies ShowNormalDeps ShowDepsVerbose ds $$ displayPatch ps  instance Show2 p => Show1 (Named p wX)
− src/Darcs/Patch/Named/Wrapped.hs 
@@ -1,158 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Darcs.Patch.Named.Wrapped-  ( WrappedNamed(..)-  , fromRebasing-  ) where--import Darcs.Prelude--import Control.Applicative ( (<|>) )-import Data.Coerce ( coerce )--import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.Ident ( Ident(..), PatchId )-import Darcs.Patch.Format ( PatchListFormat(..), ListFormat )-import Darcs.Patch.Info ( PatchInfo, showPatchInfo )-import Darcs.Patch.FromPrim ( FromPrim, PrimPatchBase(..) )-import Darcs.Patch.Named ( Named(..), patch2patchinfo )-import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Rebase.Suspended-  ( Suspended(..)-  , addFixupsToSuspended-  , removeFixupsFromSuspended-  )-import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.RepoType-  ( RepoType(..), IsRepoType(..), SRepoType(..)-  , RebaseType(..), SRebaseType(..)-  )-import Darcs.Patch.Show ( ShowPatchBasic(..) )--import Darcs.Patch.Witnesses.Sealed ( mapSeal )-import Darcs.Patch.Witnesses.Show ( Show1, Show2 )-import Darcs.Patch.Witnesses.Ordered-  ( FL(..), mapFL_FL, (:>)(..)-  )---- |A patch that lives in a repository where an old-style rebase is in--- progress. Such a repository will consist of @Normal@ patches--- along with exactly one @Suspended@ patch.------ It is here only so that we can upgrade an old-style rebase.------ @NormalP@ represents a normal patch within a respository where a--- rebase is in progress. @NormalP p@ is given the same on-disk--- representation as @p@, so a repository can be switched into--- and out of rebasing mode simply by adding or removing a--- @RebaseP@ patch and setting the appropriate format flag.------ Note that the witnesses are such that the @RebaseP@--- patch has no effect on the context of the rest of the--- repository; in a sense the patches within it are--- dangling off to one side from the main repository.-data WrappedNamed (rt :: RepoType) p wX wY where-  NormalP :: !(Named p wX wY) -> WrappedNamed rt p wX wY-  RebaseP-    :: (PrimPatchBase p, FromPrim p, Effect p)-    => !PatchInfo-    -> !(Suspended p wX wX)-    -> WrappedNamed ('RepoType 'IsRebase) p wX wX--deriving instance Show2 p => Show (WrappedNamed rt p wX wY)--instance Show2 p => Show1 (WrappedNamed rt p wX)--instance Show2 p => Show2 (WrappedNamed rt p)--fromRebasing :: WrappedNamed rt p wX wY -> Named p wX wY-fromRebasing (NormalP n) = n-fromRebasing (RebaseP {}) = error "internal error: found rebasing internal patch"--instance PrimPatchBase p => PrimPatchBase (WrappedNamed rt p) where-  type PrimOf (WrappedNamed rt p) = PrimOf p--type instance PatchId (WrappedNamed rt p) = PatchInfo--instance Ident (WrappedNamed rt p) where-  ident (NormalP p) = patch2patchinfo p-  ident (RebaseP name _) = name--instance PatchListFormat (WrappedNamed rt p)--instance (ShowPatchBasic p, PatchListFormat p)-  => ShowPatchBasic (WrappedNamed rt p) where--  showPatch f (NormalP n) = showPatch f n-  showPatch f (RebaseP i s) = showPatchInfo f i <> showPatch f s---- This is a local hack to maintain backwards compatibility with--- the on-disk format for rebases. Previously the rebase container--- was internally represented via a 'Rebasing' type that sat *inside*--- a 'Named', and so the rebase container patch had the structure--- 'NamedP i [] (Suspendended s :>: NilFL)'. This structure was reflected--- in the way it was saved on disk.--- The easiest to read this structure is to use an intermediate type--- that reflects the old structure.--- TODO: switch to a more natural on-disk structure that directly--- saves/reads 'RebaseP'.-data ReadRebasing p wX wY where-  ReadNormal    :: p wX wY -> ReadRebasing p wX wY-  ReadSuspended :: Suspended p wX wX -> ReadRebasing p wX wX--instance ( ReadPatch p, PrimPatchBase p, FromPrim p, Effect p, PatchListFormat p-         , RepoPatch p, IsRepoType rt-         ) => ReadPatch (WrappedNamed rt p) where-  readPatch' =-    case singletonRepoType :: SRepoType rt of-      SRepoType SIsRebase ->-        let wrapNamed :: Named (ReadRebasing p) wX wY -> WrappedNamed rt p wX wY-            wrapNamed (NamedP i [] (ReadSuspended s :>: NilFL))-               = RebaseP i s-            wrapNamed (NamedP i deps ps) = NormalP (NamedP i deps (mapFL_FL unRead ps))--            unRead (ReadNormal p) = p-            unRead (ReadSuspended _) = error "unexpected suspended patch"--        in fmap (mapSeal wrapNamed) readPatch'--      _ -> fmap (mapSeal NormalP) readPatch'--instance PatchListFormat p => PatchListFormat (ReadRebasing p) where-  patchListFormat = coerce (patchListFormat :: ListFormat p)--instance (ReadPatch p, PatchListFormat p, PrimPatchBase p, RepoPatch p) => ReadPatch (ReadRebasing p) where-  readPatch' =-       mapSeal toSuspended <$> readPatch'-    <|> mapSeal ReadNormal <$> readPatch'-      where -- needed to get a suitably polymorphic type-            toSuspended :: Suspended p wX wY -> ReadRebasing p wX wY-            toSuspended (Items ps) = ReadSuspended (Items ps)--instance Apply p => Apply (WrappedNamed rt p) where-  type ApplyState (WrappedNamed rt p) = ApplyState p-  apply (NormalP n) = apply n-  -- the data type definition claims that a 'RebaseP' has no effect,-  -- so make sure it really doesn't have any-  apply (RebaseP _ _) = return ()-  unapply (NormalP n) = unapply n-  unapply (RebaseP _ _) = return ()--instance Commute p => Commute (WrappedNamed rt p) where-  commute (NormalP n1 :> NormalP n2) = do-    n2' :> n1' <- commute (n1 :> n2)-    return (NormalP n2' :> NormalP n1')--  commute (RebaseP i1 s1 :> RebaseP i2 s2) =-    -- Two rebases in sequence must have the same starting context,-    -- so they should trivially commute.-    -- This case shouldn't actually happen since each repo only has-    -- a single Suspended patch.-    return (RebaseP i2 s2 :> RebaseP i1 s1)--  commute (NormalP n1 :> RebaseP i2 s2) =-    return (RebaseP i2 (addFixupsToSuspended n1 s2) :> NormalP n1)--  commute (RebaseP i1 s1 :> NormalP n2) =-    return (NormalP n2 :> RebaseP i1 (removeFixupsFromSuspended n2 s1))
+ src/Darcs/Patch/Object.hs view
@@ -0,0 +1,49 @@+module Darcs.Patch.Object where++import Darcs.Prelude++import qualified Data.ByteString.Char8 as BC ( unpack )++import Darcs.Patch.Format ( FileNameFormat(..) )+import Darcs.Util.ByteString ( packStringToUTF8, encodeLocale )+import Darcs.Util.Path ( AnchoredPath, encodeWhite, anchorPath )+import Darcs.Util.Printer ( Doc, text, packedString )+import Darcs.Util.Tree ( Tree )++-- | Given a state type (parameterized over a monad m :: * -> *), this gives us+-- the type of the key with which we can lookup an item (or object) in the+-- state.+type family ObjectIdOf (state :: (* -> *) -> *)++-- | We require from such a key (an 'ObjectId') that it has a canonical way+-- to format itself to a 'Doc'. For historical reasons, this takes a parameter+-- of type 'FileNameFormat'.+class Eq oid => ObjectId oid where+  formatObjectId :: FileNameFormat -> oid -> Doc++type instance ObjectIdOf Tree = AnchoredPath++-- formatFileName is defined here only to avoid an import cycle++-- | Format a 'AnchoredPath' to a 'Doc' according to the given 'FileNameFormat'.+--+-- NOTE: This is not only used for display but also to format patch files. This is+--       why we have to do the white space encoding here.+--       See 'Darcs.Repository.Hashed.writePatchIfNecessary'.+--+-- Besides white space encoding, for 'FileNameFormatV2' we just pack it into a 'Doc'. For+-- 'FileNameFormatV1' we must emulate the non-standard darcs-1 encoding of file paths: it+-- is an UTF8 encoding of the raw byte stream, interpreted as code points.+--+-- See also 'Darcs.Patch.Show.readFileName'.+formatFileName :: FileNameFormat -> AnchoredPath -> Doc+formatFileName FileNameFormatV1 =+  packedString . packStringToUTF8 . BC.unpack . encodeLocale . encodeWhite . ap2fp+formatFileName FileNameFormatV2 = text . encodeWhite . ap2fp+formatFileName FileNameFormatDisplay = text . ap2fp++instance ObjectId AnchoredPath where+  formatObjectId = formatFileName++ap2fp :: AnchoredPath -> FilePath+ap2fp ap = "./" ++ anchorPath "" ap
src/Darcs/Patch/PatchInfoAnd.hs view
@@ -19,18 +19,13 @@     ( Hopefully     , PatchInfoAnd     , PatchInfoAndG-    , WPatchInfo-    , unWPatchInfo-    , compareWPatchInfo     , piap     , n2pia     , patchInfoAndPatch     , fmapPIAP     , fmapFLPIAP-    , conscientiously     , hopefully     , info-    , winfo     , hopefullyM     , createHashed     , extractHash@@ -45,40 +40,39 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import Data.Typeable ( Typeable ) -import Darcs.Util.SignalHandler ( catchNonSignal )-import Darcs.Util.Printer ( Doc, ($$), renderString, text, vcat )-import Darcs.Patch.Ident ( Ident(..), PatchId, IdEq2(..) )-import Darcs.Patch.Info ( PatchInfo, showPatchInfo, displayPatchInfo, justName )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Conflict ( Conflict(..) ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Info ( PatchInfo, displayPatchInfo, justName, showPatchInfo )+import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) ) import Darcs.Patch.Named ( Named, fmapFL_Named )-import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.FromPrim ( PrimPatchBase(..) ) import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Show ( ShowPatch(..) ) import Darcs.Patch.Repair ( Repair(..), RepairToFL )-import Darcs.Patch.RepoType ( RepoType(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowContextPatch(..) )+import Darcs.Patch.Show ( ShowPatch(..) )+import Darcs.Patch.Show ( ShowContextPatch(..), ShowPatchBasic(..) ) import Darcs.Patch.Summary ( Summary )-import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered-  ( (:/\:)(..)-  , (:>)(..)-  , (:\/:)(..)-  , FL-  , mapFL-  , mapRL_RL-  )-import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal )+    ( (:/\:)(..)+    , (:>)(..)+    , (:\/:)(..)+    , FL+    , mapFL+    , mapRL_RL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal, seal ) import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) import Darcs.Util.Exception ( prettyException )+import Darcs.Util.Printer ( Doc, renderString, text, vcat, ($$) )+import Darcs.Util.SignalHandler ( catchNonSignal )+import Darcs.Util.ValidHash ( PatchHash )  -- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a -- form adapted to darcs patches. The @C@ @(x y)@ represents the type@@ -89,7 +83,7 @@ -- @Hashed hash sh@ represents an expected hashed patch with its hash. data Hopefully a wX wY     = Hopefully (SimpleHopefully a wX wY)-    | Hashed String (SimpleHopefully a wX wY)+    | Hashed PatchHash (SimpleHopefully a wX wY)     deriving Show  -- | @SimpleHopefully@ is a variant of @Either String@ adapted for@@ -98,70 +92,54 @@ data SimpleHopefully a wX wY = Actually (a wX wY) | Unavailable String     deriving Show -type PatchInfoAnd rt p = PatchInfoAndG rt (Named p)+type PatchInfoAnd p = PatchInfoAndG (Named p)  -- | @'PatchInfoAnd' p wA wB@ represents a hope we have to get a -- patch through its info. We're not sure we have the patch, but we -- know its info.-data PatchInfoAndG (rt :: RepoType) p wA wB =+data PatchInfoAndG p wA wB =   PIAP !PatchInfo        (Hopefully p wA wB)   deriving (Show) --- | @'WPatchInfo' wA wB@ represents the info of a patch, marked with--- the patch's witnesses.-newtype WPatchInfo wA wB = WPatchInfo { unWPatchInfo :: PatchInfo }---- This is actually unsafe if we ever commute patches and then compare them--- using this function. TODO: consider adding an extra existential to WPatchInfo--- (as with LabelledPatch in Darcs.Patch.Choices)-compareWPatchInfo :: WPatchInfo wA wB -> WPatchInfo wC wD -> EqCheck (wA, wB) (wC, wD)-compareWPatchInfo (WPatchInfo x) (WPatchInfo y) = if x == y then unsafeCoerceP IsEq else NotEq--instance Eq2 WPatchInfo where-   WPatchInfo x `unsafeCompare` WPatchInfo y = x == y- fmapH :: (a wX wY -> b wW wZ) -> Hopefully a wX wY -> Hopefully b wW wZ fmapH f (Hopefully sh) = Hopefully (ff sh)     where ff (Actually a) = Actually (f a)           ff (Unavailable e) = Unavailable e-fmapH f (Hashed h sh) = Hashed h (ff sh)+fmapH f (Hashed _ sh) = Hopefully (ff sh)     where ff (Actually a) = Actually (f a)           ff (Unavailable e) = Unavailable e -info :: PatchInfoAndG rt p wA wB -> PatchInfo+info :: PatchInfoAndG p wA wB -> PatchInfo info (PIAP i _) = i -patchDesc :: forall rt p wX wY . PatchInfoAnd rt p wX wY -> String+patchDesc :: forall p wX wY . PatchInfoAnd p wX wY -> String patchDesc p = justName $ info p -winfo :: PatchInfoAnd rt p wA wB -> WPatchInfo wA wB-winfo (PIAP i _) = WPatchInfo i- -- | @'piap' i p@ creates a PatchInfoAnd containing p with info i.-piap :: PatchInfo -> p wA wB -> PatchInfoAndG rt p wA wB+piap :: PatchInfo -> p wA wB -> PatchInfoAndG p wA wB piap i p = PIAP i (Hopefully $ Actually p)  -- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch.-n2pia :: (Ident p, PatchId p ~ PatchInfo) => p wX wY -> PatchInfoAndG rt p wX wY+n2pia :: (Ident p, PatchId p ~ PatchInfo) => p wX wY -> PatchInfoAndG p wX wY n2pia x = ident x `piap` x -patchInfoAndPatch :: PatchInfo -> Hopefully p wA wB -> PatchInfoAndG rt p wA wB+patchInfoAndPatch :: PatchInfo -> Hopefully p wA wB -> PatchInfoAndG p wA wB patchInfoAndPatch =  PIAP  fmapFLPIAP :: (FL p wX wY -> FL q wX wY)-           -> PatchInfoAnd rt p wX wY -> PatchInfoAnd rt q wX wY+           -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY fmapFLPIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp)  fmapPIAP :: (p wX wY -> q wX wY)-           -> PatchInfoAndG rt p wX wY -> PatchInfoAndG rt q wX wY+           -> PatchInfoAndG p wX wY -> PatchInfoAndG q wX wY fmapPIAP f (PIAP i hp) = PIAP i (fmapH f hp)  -- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd' -- value. If it fails, it outputs an error \"failed to read patch: -- \<description of the patch>\". We get the description of the patch -- from the info part of 'hp'-hopefully :: PatchInfoAndG rt p wA wB -> p wA wB+hopefully :: PatchInfoAndG p wA wB -> p wA wB hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e  -- | Using a special exception type here means that is is treated as@@ -180,15 +158,14 @@ -- Note: this function must be lazy in its second argument, which is why we -- use a lazy pattern match. conscientiously :: (Doc -> Doc)-                -> PatchInfoAndG rt p wA wB -> p wA wB+                -> PatchInfoAndG p wA wB -> p wA wB conscientiously er ~(PIAP pinf hp) =     case hopefully2either hp of       Right p -> p       Left e -> throw $ PatchNotAvailable $ er (displayPatchInfo pinf $$ text e) --- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a--- monad instead of erroring.-hopefullyM :: PatchInfoAndG rt p wA wB -> Maybe (p wA wB)+-- | Return 'Just' the patch content or 'Nothing' if it is unavailable.+hopefullyM :: PatchInfoAndG p wA wB -> Maybe (p wA wB) hopefullyM (PIAP _ hp) = case hopefully2either hp of                               Right p -> return p                               Left _ -> Nothing@@ -203,15 +180,15 @@ actually :: a wX wY -> Hopefully a wX wY actually = Hopefully . Actually -createHashed :: String -> (String -> IO (Sealed (a wX))) -> IO (Sealed (Hopefully a wX))+createHashed :: PatchHash -> (PatchHash -> IO (Sealed (a wX))) -> IO (Sealed (Hopefully a wX)) createHashed h f = mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler)   where   f' = do Sealed x <- f h           return (Sealed (Actually x))   handler e = return $ seal $ Unavailable $ prettyException e -extractHash :: PatchInfoAndG rt p wA wB -> Either (p wA wB) String-extractHash (PIAP _ (Hashed s _)) = Right s+extractHash :: PatchInfoAndG p wA wB -> Either (p wA wB) PatchHash+extractHash (PIAP _ (Hashed sh _)) = Right sh extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp  unavailable :: String -> Hopefully a wX wY@@ -219,11 +196,11 @@  -- * Instances defined only for PatchInfoAnd -instance Show2 p => Show1 (PatchInfoAnd rt p wX)+instance Show2 p => Show1 (PatchInfoAnd p wX) -instance Show2 p => Show2 (PatchInfoAnd rt p)+instance Show2 p => Show2 (PatchInfoAnd p) -instance RepairToFL p => Repair (PatchInfoAnd rt p) where+instance RepairToFL p => Repair (PatchInfoAnd p) where     applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p                             case mp' of                               Nothing -> return Nothing@@ -231,38 +208,46 @@  -- * Instances defined for PatchInfoAndG -instance PrimPatchBase p => PrimPatchBase (PatchInfoAndG rt p) where-   type PrimOf (PatchInfoAndG rt p) = PrimOf p+instance PrimPatchBase p => PrimPatchBase (PatchInfoAndG p) where+   type PrimOf (PatchInfoAndG p) = PrimOf p --- Equality on PatchInfoAndG is solely determined by the PatchInfo--- It is a global invariant of darcs that once a patch is recorded,--- it should always have the same representation in the same context.-instance Eq2 (PatchInfoAndG rt p) where-    unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2+getHopefully :: Hopefully p wX wY -> SimpleHopefully p wX wY+getHopefully (Hashed _ x) = x+getHopefully (Hopefully x) = x -type instance PatchId (PatchInfoAndG rt p) = PatchInfo+instance Eq2 p => Eq2 (SimpleHopefully p) where+    Actually p1 `unsafeCompare` Actually p2 = p1 `unsafeCompare` p2+    _ `unsafeCompare` _ = error "cannot compare unavailable patches" -instance Ident (PatchInfoAndG rt p) where-    ident (PIAP i _) = i+instance Eq2 p => Eq2 (Hopefully p) where+    Hashed h1 _ `unsafeCompare` Hashed h2 _ = h1 == h2+    hp1 `unsafeCompare` hp2 =+      getHopefully hp1 `unsafeCompare` getHopefully hp2 -instance IdEq2 (PatchInfoAndG rt p)+instance Eq2 p => Eq2 (PatchInfoAndG p) where+    PIAP i1 p1 `unsafeCompare` PIAP i2 p2 = i1 == i2 && p1 `unsafeCompare` p2 -instance PatchListFormat (PatchInfoAndG rt p)+type instance PatchId (PatchInfoAndG p) = PatchInfo -instance ShowPatchBasic p => ShowPatchBasic (PatchInfoAndG rt p) where+instance Ident (PatchInfoAndG p) where+    ident (PIAP i _) = i++instance PatchListFormat (PatchInfoAndG p)++instance ShowPatchBasic p => ShowPatchBasic (PatchInfoAndG p) where     showPatch f (PIAP n p) =       case hopefully2either p of         Right x -> showPatch f x         Left _ -> showPatchInfo f n -instance ShowContextPatch p => ShowContextPatch (PatchInfoAndG rt p) where-  showContextPatch f (PIAP n p) =+instance ShowContextPatch p => ShowContextPatch (PatchInfoAndG p) where+  showPatchWithContextAndApply f (PIAP n p) =     case hopefully2either p of-      Right x -> showContextPatch f x+      Right x -> showPatchWithContextAndApply f x       Left _ -> return $ showPatchInfo f n  instance (Summary p, PatchListFormat p,-          ShowPatch p) => ShowPatch (PatchInfoAndG rt p) where+          ShowPatch p) => ShowPatch (PatchInfoAndG p) where     description (PIAP n _) = displayPatchInfo n     summary (PIAP _ p) =       case hopefully2either p of@@ -274,47 +259,48 @@         Right x -> content x         Left _ -> text $ "[patch content is unavailable]" -instance (PatchId p ~ PatchInfo, Commute p) => Commute (PatchInfoAndG rt p) where+instance (PatchId p ~ PatchInfo, Commute p) => Commute (PatchInfoAndG p) where     commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y)                           return $ (ident y `piap` y') :> (ident x `piap` x')  instance (PatchId p ~ PatchInfo, CleanMerge p) =>-         CleanMerge (PatchInfoAndG rt p) where+         CleanMerge (PatchInfoAndG p) where     cleanMerge (x :\/: y)       | ident x == ident y = error "cannot cleanMerge identical PatchInfoAndG"       | otherwise = do           y' :/\: x' <- cleanMerge (hopefully x :\/: hopefully y)           return $ (ident y `piap` y') :/\: (ident x `piap` x') -instance (PatchId p ~ PatchInfo, Merge p) => Merge (PatchInfoAndG rt p) where+instance (PatchId p ~ PatchInfo, Merge p) => Merge (PatchInfoAndG p) where     merge (x :\/: y)       | ident x == ident y = error "cannot merge identical PatchInfoAndG"       | otherwise =           case merge (hopefully x :\/: hopefully y) of             y' :/\: x' -> (ident y `piap` y') :/\: (ident x `piap` x') -instance PatchInspect p => PatchInspect (PatchInfoAndG rt p) where+instance PatchInspect p => PatchInspect (PatchInfoAndG p) where     listTouchedFiles = listTouchedFiles . hopefully     hunkMatches f = hunkMatches f . hopefully -instance Apply p => Apply (PatchInfoAndG rt p) where-    type ApplyState (PatchInfoAndG rt p) = ApplyState p+instance Apply p => Apply (PatchInfoAndG p) where+    type ApplyState (PatchInfoAndG p) = ApplyState p     apply = apply . hopefully-    unapply = unapply .hopefully+    unapply = unapply . hopefully  instance ( ReadPatch p, Ident p, PatchId p ~ PatchInfo-         ) => ReadPatch (PatchInfoAndG rt p) where+         ) => ReadPatch (PatchInfoAndG p) where     readPatch' = mapSeal n2pia <$> readPatch' -instance Effect p => Effect (PatchInfoAndG rt p) where+instance Effect p => Effect (PatchInfoAndG p) where     effect = effect . hopefully -instance IsHunk (PatchInfoAndG rt p) where+instance IsHunk (PatchInfoAndG p) where     isHunk _ = Nothing -instance PatchDebug p => PatchDebug (PatchInfoAndG rt p)+instance PatchDebug p => PatchDebug (PatchInfoAndG p) -instance (Commute p, Conflict p) => Conflict (PatchInfoAnd rt p) where+instance (Commute p, Conflict p, Summary p, PrimPatchBase p, PatchListFormat p, ShowPatch p) => Conflict (PatchInfoAnd p) where+    isConflicted = isConflicted . hopefully     -- Note: this relies on the laziness of 'hopefully' for efficiency     -- and correctness in the face of lazy repositories     resolveConflicts context patches =
src/Darcs/Patch/Permutations.hs view
@@ -18,28 +18,45 @@  {-# OPTIONS_GHC -fno-warn-orphans #-} -module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon,-                                  commuteWhatWeCanFL, commuteWhatWeCanRL,-                                  genCommuteWhatWeCanRL, genCommuteWhatWeCanFL,-                                  partitionFL, partitionRL, partitionFL',-                                  simpleHeadPermutationsFL, headPermutationsRL,-                                  headPermutationsFL, permutationsRL,-                                  removeSubsequenceFL, removeSubsequenceRL,-                                  partitionConflictingFL-                                ) where+module Darcs.Patch.Permutations+    ( removeFL+    , removeRL+    , removeCommon+    , commuteWhatWeCanFL+    , commuteWhatWeCanRL+    , genCommuteWhatWeCanRL+    , genCommuteWhatWeCanFL+    , partitionFL+    , partitionRL+    , partitionFL'+    , partitionRL'+    , simpleHeadPermutationsFL+    , headPermutationsRL+    , headPermutationsFL+    , permutationsRL+    , removeSubsequenceFL+    , removeSubsequenceRL+    , partitionConflictingFL+    , (=\~/=)+    , (=/~\=)+    , nubFL+    ) where  import Darcs.Prelude +import Data.List ( nubBy ) import Data.Maybe ( mapMaybe ) import Darcs.Patch.Commute ( Commute, commute, commuteFL, commuteRL )+import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Merge ( CleanMerge(..), cleanMergeFL )-import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..), isIsEq ) import Darcs.Patch.Witnesses.Ordered     ( FL(..), RL(..), (:>)(..), (:\/:)(..), (:/\:)(..)     , (+<+), (+>+)     , lengthFL, lengthRL     , reverseFL, reverseRL     )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )  -- | Split an 'FL' according to a predicate, using commutation as necessary, -- into those that satisfy the predicate and can be commuted to the left, and@@ -77,6 +94,33 @@  -- | Split an 'RL' according to a predicate, using commutation as necessary, -- into those that satisfy the predicate and can be commuted to the right, and+-- those that do not satisfy it and can be commuted to the left. Whatever+-- remains stays in the middle.+--+-- Note that the predicate @p@ should be invariant under commutation:+-- if @commute(x:>y)==Just(y':>x')@ then @p x == p x' && p y == p y'@.+partitionRL' :: forall p wX wY. Commute p+             => (forall wU wV . p wU wV -> Bool)+             -> RL p wX wY+             -> (FL p :> FL p :> RL p) wX wY+partitionRL' predicate input = go input NilFL NilFL where+  go :: RL p wA wB  -- input RL+     -> FL p wB wC  -- the "left" patches found so far+     -> FL p wC wD  -- the "middle" patches found so far+     -> (FL p :> FL p :> RL p) wA wD+  go NilRL left middle = left :> middle :> NilRL+  go (ps :<: p) left middle+    | predicate p = case commuteWhatWeCanFL (p :> left) of+        (left' :> p' :> NilFL) -> case commuteFL (p' :> middle) of+            Just (middle' :> p'') -> case go ps left' middle' of+                (a :> b :> c) -> a :> b :> c :<: p''+            Nothing -> go ps left' (p' :>: middle)+        (left' :> p' :> tomiddle) ->+            go ps left' (p' :>: tomiddle +>+ middle)+    | otherwise = go ps (p :>: left) middle++-- | Split an 'RL' according to a predicate, using commutation as necessary,+-- into those that satisfy the predicate and can be commuted to the right, and -- those that don't, i.e. either do not satisfy the predicate or cannot be -- commuted to the right. --@@ -100,31 +144,39 @@ commuteWhatWeCanFL :: Commute p => (p :> FL p) wX wY -> (FL p :> p :> FL p) wX wY commuteWhatWeCanFL = genCommuteWhatWeCanFL commute -genCommuteWhatWeCanFL :: Commute q =>-                         (forall wA wB . ((p:>q) wA wB -> Maybe ((q:>p)wA wB)))-                          -> (p :> FL q) wX wY -> (FL q :> p :> FL q) wX wY+genCommuteWhatWeCanFL :: Commute q+                      => CommuteFn p q+                      -> (p :> FL q) wX wY+                      -> (FL q :> p :> FL q) wX wY genCommuteWhatWeCanFL com (p :> x :>: xs) =-    case com (p :> x) of-    Nothing -> case commuteWhatWeCanFL (x :> xs) of-               xs1 :> x' :> xs2 -> case genCommuteWhatWeCanFL com (p :> xs1) of-                              xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2-    Just (x' :> p') -> case genCommuteWhatWeCanFL com (p' :> xs) of-                       a :> p'' :> c -> x' :>: a :> p'' :> c+  case com (p :> x) of+    Nothing ->+      case commuteWhatWeCanFL (x :> xs) of+        xs1 :> x' :> xs2 ->+          case genCommuteWhatWeCanFL com (p :> xs1) of+            xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2+    Just (x' :> p') ->+      case genCommuteWhatWeCanFL com (p' :> xs) of+        a :> p'' :> c -> x' :>: a :> p'' :> c genCommuteWhatWeCanFL _ (y :> NilFL) = NilFL :> y :> NilFL  commuteWhatWeCanRL :: Commute p => (RL p :> p) wX wY -> (RL p :> p :> RL p) wX wY commuteWhatWeCanRL = genCommuteWhatWeCanRL commute -genCommuteWhatWeCanRL :: Commute p =>-                         (forall wA wB . ((p :> q) wA wB -> Maybe ((q :> p) wA wB)))-                         -> (RL p :> q) wX wY -> (RL p :> q :> RL p) wX wY+genCommuteWhatWeCanRL :: Commute p+                      => CommuteFn p q+                      -> (RL p :> q) wX wY+                      -> (RL p :> q :> RL p) wX wY genCommuteWhatWeCanRL com (xs :<: x :> p) =-    case com (x :> p) of-    Nothing -> case commuteWhatWeCanRL (xs :> x) of-               xs1 :> x' :> xs2 -> case genCommuteWhatWeCanRL com (xs2 :> p) of-                              xs1' :> p' :> xs2' -> xs1 :<: x' +<+ xs1' :> p' :> xs2'-    Just (p' :> x') -> case genCommuteWhatWeCanRL com (xs :> p') of-                       xs1 :> p'' :> xs2 -> xs1 :> p'' :> xs2 :<: x'+  case com (x :> p) of+    Nothing ->+      case commuteWhatWeCanRL (xs :> x) of+        xs1 :> x' :> xs2 ->+          case genCommuteWhatWeCanRL com (xs2 :> p) of+            xs1' :> p' :> xs2' -> xs1 :<: x' +<+ xs1' :> p' :> xs2'+    Just (p' :> x') ->+      case genCommuteWhatWeCanRL com (xs :> p') of+        xs1 :> p'' :> xs2 -> xs1 :> p'' :> xs2 :<: x' genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL  @@ -219,40 +271,61 @@ -- | All permutations of an 'RL'. permutationsRL :: Commute p => RL p wX wY -> [RL p wX wY] permutationsRL ps =-  [qs' :<: q | qs :<: q <- headPermutationsRL ps, qs' <- permutationsRL qs]+  ps : [qs' :<: q | qs :<: q <- headPermutationsRL ps, qs' <- permutationsRL qs] -instance (Eq2 p, Commute p) => Eq2 (FL p) where-    a =\/= b | lengthFL a /= lengthFL b = NotEq-             | otherwise = cmpSameLength a b-             where cmpSameLength :: FL p wX wY -> FL p wX wZ -> EqCheck wY wZ-                   cmpSameLength (x:>:xs) xys | Just ys <- removeFL x xys = cmpSameLength xs ys-                   cmpSameLength NilFL NilFL = IsEq-                   cmpSameLength _ _ = NotEq-    xs =/\= ys = reverseFL xs =/\= reverseFL ys+-- | This commutes patches in the RHS to bring them into the same+-- order as the LHS.+(=\~/=)+  :: forall p wA wB wC+   . (Commute p, Eq2 p)+  => FL p wA wB+  -> FL p wA wC+  -> EqCheck wB wC+a =\~/= b+  | lengthFL a /= lengthFL b = NotEq+  | otherwise = cmpSameLength a b+  where+    cmpSameLength :: FL p wX wY -> FL p wX wZ -> EqCheck wY wZ+    cmpSameLength (x :>: xs) x_ys+      | Just ys <- removeFL x x_ys = cmpSameLength xs ys+    cmpSameLength NilFL NilFL = IsEq+    cmpSameLength _ _ = NotEq -instance (Eq2 p, Commute p) => Eq2 (RL p) where-    unsafeCompare = error "Buggy use of unsafeCompare on RL"-    a =/\= b | lengthRL a /= lengthRL b = NotEq-             | otherwise = cmpSameLength a b-             where cmpSameLength :: RL p wX wY -> RL p wW wY -> EqCheck wX wW-                   cmpSameLength (xs:<:x) xys | Just ys <- removeRL x xys = cmpSameLength xs ys-                   cmpSameLength NilRL NilRL = IsEq-                   cmpSameLength _ _ = NotEq-    xs =\/= ys = reverseRL xs =\/= reverseRL ys+-- | This commutes patches in the RHS to bring them into the same+-- order as the LHS.+(=/~\=)+  :: forall p wA wB wC+   . (Commute p, Eq2 p)+  => RL p wA wC+  -> RL p wB wC+  -> EqCheck wA wB+a =/~\= b+  | lengthRL a /= lengthRL b = NotEq+  | otherwise = cmpSameLength a b+  where+    cmpSameLength :: RL p wX wZ -> RL p wY wZ -> EqCheck wX wY+    cmpSameLength (xs :<: x) ys_x+      | Just ys <- removeRL x ys_x = cmpSameLength xs ys+    cmpSameLength NilRL NilRL = IsEq+    cmpSameLength _ _ = NotEq +-- | A variant of 'nub' that is based on '=\~/= i.e. ignores (internal) ordering.+nubFL :: (Commute p, Eq2 p) => [Sealed (FL p wX)] -> [Sealed (FL p wX)]+nubFL = nubBy eqSealedFL where+  eqSealedFL (Sealed ps) (Sealed qs) = isIsEq (ps =\~/= qs)+ -- | Partition a list into the patches that merge cleanly with the given -- patch and those that don't (including dependencies)-partitionConflictingFL :: (Commute p, CleanMerge p)-                       => FL p wX wY -> FL p wX wZ -> (FL p :> FL p) wX wY-partitionConflictingFL NilFL _ = NilFL :> NilFL-partitionConflictingFL (x :>: xs) ys =-  case cleanMergeFL (x :\/: ys) of-    Nothing ->-      case commuteWhatWeCanFL (x :> xs) of-        xs_ok :> x' :> xs_deps ->-          case partitionConflictingFL xs_ok ys of-            xs_clean :> xs_conflicts ->-              xs_clean :> (xs_conflicts +>+ (x' :>: xs_deps))-    Just (ys' :/\: _) ->-      case partitionConflictingFL xs ys' of-        xs_clean :> xs_conflicts -> (x :>: xs_clean) :> xs_conflicts+partitionConflictingFL+  :: forall p wX wY wZ+   . (Commute p, CleanMerge p)+  => FL p wX wY -> FL p wX wZ -> (FL p :> FL p) wX wY+partitionConflictingFL = go NilRL NilRL+  where+    go :: RL p wA wB -> RL p wB wC -> FL p wC wD -> FL p wB w -> (FL p :> FL p) wA wD+    go clean dirty NilFL _ = reverseRL clean :> reverseRL dirty+    go clean dirty (x:>:xs) ys+      | Just (x' :> dirty') <- commuteRL (dirty :> x)+      , Just (ys' :/\: _) <- cleanMergeFL (x' :\/: ys) =+        go (clean :<: x') dirty' xs ys'+      | otherwise = go clean (dirty :<: x) xs ys
src/Darcs/Patch/Prim.hs view
@@ -1,8 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim     ( PrimApply(..)-    , PrimCanonize(..)-    , PrimClassify(..)+    , PrimCoalesce(..)     , PrimConstruct(..)     , PrimDetails(..)     , PrimMangleUnravelled(..)@@ -12,12 +11,13 @@     , PrimSift(..)     , Mangled     , Unravelled+    , canonizeFL+    , coalesce     ) where  import Darcs.Patch.Prim.Class     ( PrimApply(..)-    , PrimCanonize(..)-    , PrimClassify(..)+    , PrimCoalesce(..)     , PrimConstruct(..)     , PrimDetails(..)     , PrimMangleUnravelled(..)@@ -28,3 +28,5 @@     , Mangled     , Unravelled     )+import Darcs.Patch.Prim.Canonize ( canonizeFL )+import Darcs.Patch.Prim.Coalesce ( coalesce )
+ src/Darcs/Patch/Prim/Canonize.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ViewPatterns #-}+module Darcs.Patch.Prim.Canonize ( canonizeFL ) where++import Darcs.Prelude++import qualified Data.ByteString as B (ByteString, empty)++import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )+import Darcs.Patch.Prim.Class+    ( PrimConstruct(primFromHunk)+    , PrimCoalesce(sortCoalesceFL)+    )+import Darcs.Patch.Witnesses.Ordered ( FL(..), joinGapsFL, mapFL_FL, concatFL )+import Darcs.Patch.Witnesses.Sealed ( unseal, Gap(..), unFreeLeft )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd )+import Darcs.Util.Diff ( DiffAlgorithm, getChanges )++canonizeHunk :: Gap w => DiffAlgorithm -> FileHunk oid wX wY -> w (FL (FileHunk oid))+canonizeHunk _ (FileHunk f line old new)+  | null old || null new || old == [B.empty] || new == [B.empty] =+      freeGap (FileHunk f line old new :>: NilFL)+canonizeHunk da (FileHunk f line old new) =+  makeHoley f line $ getChanges da old new++makeHoley :: Gap w+          => oid+          -> Int+          -> [(Int, [B.ByteString], [B.ByteString])]+          -> w (FL (FileHunk oid))+makeHoley f line =+  joinGapsFL . map (\(l, o, n) -> freeGap (FileHunk f (l + line) o n))++-- | It can sometimes be handy to have a canonical representation of a given+-- patch.  We achieve this by defining a canonical form for each patch type,+-- and a function 'canonize' which takes a patch and puts it into+-- canonical form.  This routine is used by the diff function to create an+-- optimal patch (based on an LCS algorithm) from a simple hunk describing the+-- old and new version of a file.+canonize :: (IsHunk prim, PrimConstruct prim)+         => DiffAlgorithm -> prim wX wY -> FL prim wX wY+canonize da p | Just fh <- isHunk p =+  mapFL_FL primFromHunk $ unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk da fh+canonize _ p = p :>: NilFL++-- | Put a sequence of primitive patches into canonical form.+--+-- Even if the patches are just hunk patches,+-- this is not necessarily the same set of results as you would get+-- if you applied the sequence to a specific tree and recalculated+-- a diff.+--+-- XXX Why not? How does it differ? The implementation for Prim.V1 does+-- sortCoalesceFL and then invokes the diff algorithm for each hunk. How can+-- that be any different to applying the sequence and then taking the diff?+-- Is this merely because diff does not sort by file path?+--+-- Besides, diff and apply /must/ be inverses in the sense that for any two+-- states {start, end}, we have+--+-- prop> diff start (apply (diff start end)) == end+canonizeFL :: (IsHunk prim, PrimCoalesce prim, PrimConstruct prim)+           => DiffAlgorithm -> FL prim wX wY -> FL prim wX wY+-- Note: it is important to first coalesce and then canonize, since+-- coalescing can produce non-canonical hunks (while hunks resulting+-- from canonizing a single hunk cannot be coalesced). See issue525,+-- in particular msg20270 for details.+canonizeFL da = concatFL . mapFL_FL (canonize da) . sortCoalesceFL
src/Darcs/Patch/Prim/Class.hs view
@@ -1,8 +1,10 @@ module Darcs.Patch.Prim.Class-    ( PrimConstruct(..), PrimCanonize(..)-    , PrimClassify(..), PrimDetails(..)+    ( PrimConstruct(..)+    , PrimCoalesce(..)+    , PrimDetails(..)     , PrimSift(..)-    , PrimShow(..), PrimRead(..)+    , PrimShow(..)+    , PrimRead(..)     , PrimApply(..)     , PrimPatch     , PrimMangleUnravelled(..)@@ -14,11 +16,12 @@  import Darcs.Prelude +import Darcs.Patch.Annotate.Class ( Annotate ) import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.FileHunk ( FileHunk, IsHunk ) import Darcs.Patch.Format ( FileNameFormat, PatchListFormat ) import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Apply ( Apply(..), ObjectIdOfPatch ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.CommuteFn ( PartialMergeFn ) import Darcs.Patch.Invert ( Invert(..) )@@ -27,21 +30,21 @@ import Darcs.Patch.Repair ( RepairToFL ) import Darcs.Patch.Show ( ShowPatch, ShowContextPatch ) import Darcs.Patch.SummaryData ( SummDetail )-import Darcs.Patch.Witnesses.Eq ( Eq2(..) )-import Darcs.Patch.Witnesses.Ordered ( FL, (:>)(..), (:\/:)(..), (:/\:)(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck )+import Darcs.Patch.Witnesses.Ordered ( (:/\:)(..), (:>)(..), (:\/:)(..), FL ) import Darcs.Patch.Witnesses.Show ( Show2 ) import Darcs.Patch.Witnesses.Sealed ( Sealed )  import Darcs.Util.Parser ( Parser ) import Darcs.Util.Path ( AnchoredPath ) import Darcs.Util.Printer ( Doc )-import qualified Darcs.Util.Diff as D ( DiffAlgorithm )  import qualified Data.ByteString as B ( ByteString )   type PrimPatch prim =-    ( Apply prim+    ( Annotate prim+    , Apply prim     , CleanMerge prim     , Commute prim     , Invert prim@@ -51,8 +54,7 @@     , RepairToFL prim     , Show2 prim     , PrimConstruct prim-    , PrimCanonize prim-    , PrimClassify prim+    , PrimCoalesce prim     , PrimDetails prim     , PrimApply prim     , PrimSift prim@@ -63,18 +65,6 @@     , PatchListFormat prim     ) -class PrimClassify prim where-   primIsAddfile :: prim wX wY -> Bool-   primIsRmfile :: prim wX wY -> Bool-   primIsAdddir :: prim wX wY -> Bool-   primIsRmdir :: prim wX wY -> Bool-   primIsMove :: prim wX wY -> Bool-   primIsHunk :: prim wX wY -> Bool-   primIsTokReplace :: prim wX wY -> Bool-   primIsBinary :: prim wX wY -> Bool-   primIsSetpref :: prim wX wY -> Bool-   is_filepatch :: prim wX wY -> Maybe AnchoredPath- class PrimConstruct prim where    addfile :: AnchoredPath -> prim wX wY    rmfile :: AnchoredPath -> prim wX wY@@ -85,79 +75,57 @@    hunk :: AnchoredPath -> Int -> [B.ByteString] -> [B.ByteString] -> prim wX wY    tokreplace :: AnchoredPath -> String -> String -> String -> prim wX wY    binary :: AnchoredPath -> B.ByteString -> B.ByteString -> prim wX wY-   primFromHunk :: FileHunk wX wY -> prim wX wY--class PrimCanonize prim where-   -- | @tryToShrink ps@ simplifies @ps@ by getting rid of self-cancellations-   --   or coalescing patches-   ---   --   Question (Eric Kow): what properties should this have?  For example,-   --   the prim1 implementation only gets rid of the first self-cancellation-   --   it finds (as far as I can tell).  Is that OK? Can we try harder?-   tryToShrink :: FL prim wX wY -> FL prim wX wY--   -- | 'sortCoalesceFL' @ps@ coalesces as many patches in @ps@ as-   --   possible, sorting the results in some standard order.-   sortCoalesceFL :: FL prim wX wY -> FL prim wX wY--   -- | It can sometimes be handy to have a canonical representation of a given-   -- patch.  We achieve this by defining a canonical form for each patch type,-   -- and a function 'canonize' which takes a patch and puts it into-   -- canonical form.  This routine is used by the diff function to create an-   -- optimal patch (based on an LCS algorithm) from a simple hunk describing the-   -- old and new version of a file.-   canonize :: D.DiffAlgorithm -> prim wX wY -> FL prim wX wY+   primFromHunk :: FileHunk (ObjectIdOfPatch prim) wX wY -> prim wX wY -   -- | 'canonizeFL' @ps@ puts a sequence of primitive patches into-   -- canonical form. Even if the patches are just hunk patches,-   -- this is not necessarily the same set of results as you would get-   -- if you applied the sequence to a specific tree and recalculated-   -- a diff.+class (Commute prim, Eq2 prim, Invert prim) => PrimCoalesce prim where+   -- | Try to shrink the input sequence by getting rid of self-cancellations+   -- and identity patches or by coalescing patches. Also sort patches+   -- according to some internally defined order (specific to the patch type)+   -- as far as possible while respecting dependencies.+   -- A result of 'Nothing' means that we could not shrink the input.    ---   -- Note that this process does not preserve the commutation behaviour-   -- of the patches and is therefore not appropriate for use when-   -- working with already recorded patches (unless doing amend-record-   -- or the like).-   canonizeFL :: D.DiffAlgorithm -> FL prim wX wY -> FL prim wX wY+   -- This method is included in the class for optimization. Instances are free+   -- to use 'Darcs.Patch.Prim.Coalesce.defaultTryToShrink'.+   tryToShrink :: FL prim wX wY -> Maybe (FL prim wX wY) -   -- | Either 'primCoalesce' or cancel inverses.+   -- | This is similar to 'tryToShrink' but always gives back a result: if the+   -- sequence could not be shrunk we merely give back a sorted version.    ---   -- prop> primCoalesce (p :> q) == Just r => apply r = apply p >> apply q-   -- prop> primCoalesce (p :> q) == Just r => lengthFL r < 2-   coalesce :: (prim :> prim) wX wY -> Maybe (FL prim wX wY)+   -- This method is included in the class for optimization. Instances are free+   -- to use 'Darcs.Patch.Prim.Coalesce.defaultSortCoalesceFL'.+   sortCoalesceFL :: FL prim wX wY -> FL prim wX wY     -- | Coalesce adjacent patches to one with the same effect.    --    -- prop> apply (primCoalesce p q) == apply p >> apply q    primCoalesce :: prim wX wY -> prim wY wZ -> Maybe (prim wX wZ) -   -- | If 'primCoalesce' is addition, then this is subtraction.+   -- | Whether prim patch has no effect at all and thus can be eliminated+   -- as far as coalescing is concerned.+   isIdentity :: prim wX wY -> EqCheck wX wY++   -- | Provide a total order between arbitrary patches that is consistent+   -- with 'Eq2':    ---   -- prop> Just r == primCoalesce p q => primDecoalesce r p == Just q-   primDecoalesce :: prim wX wZ -> prim wX wY -> Maybe (prim wY wZ)+   -- prop> unsafeCompare p q == IsEq  <=>  comparePrim p q == EQ+   comparePrim :: prim wA wB -> prim wC wD -> Ordering --- TODO This has been cut'n'pasted from Darcs.Repository.Pending.---      It is not a good interface and should be re-designed.+-- | Prim patches that support "sifting". This is the process of eliminating+-- changes from a sequence of prims that can be recovered by comparing states+-- (normally the pristine and working states), except those that other changes+-- depend on. In other words, changes to the content of (tracked) files. The+-- implementation is allowed and expected to shrink and coalesce changes in the+-- process. class PrimSift prim where-  -- | @siftForPending ps@ simplifies the candidate pending patch @ps@-  --   through a combination of looking for self-cancellations-  --   (sequences of patches followed by their inverses), coalescing,-  --   and getting rid of any hunk/binary patches we can commute out-  --   the back-  ---  --   The visual image of sifting can be quite helpful here.  We are-  --   repeatedly tapping (shrinking) the patch sequence and-  --   shaking it (sift). Whatever falls out is the pending we want-  --   to keep. We do this until the sequence looks about as clean as-  --   we can get it-  siftForPending :: FL prim wX wY -> Sealed (FL prim wX)+  -- | Whether a prim is a candidate for sifting+  primIsSiftable :: prim wX wY -> Bool  class PrimDetails prim where    summarizePrim :: prim wX wY -> [SummDetail]  class PrimShow prim where    showPrim :: FileNameFormat -> prim wA wB -> Doc-   showPrimCtx :: ApplyMonad  (ApplyState prim) m => FileNameFormat -> prim wA wB -> m Doc+   showPrimWithContextAndApply :: ApplyMonad  (ApplyState prim) m => FileNameFormat -> prim wA wB -> m Doc  class PrimRead prim where    readPrim :: FileNameFormat -> Parser (Sealed (prim wX))
+ src/Darcs/Patch/Prim/Coalesce.hs view
@@ -0,0 +1,123 @@+{- | Generic coalesce functions++Some of the algorithms in this module do complex recursive operations on+sequences of patches in order to simplify them. These algorithms require+that we know whether some intermediate step has made any progress. If not,+we want to terminate or try something different.++We capture this as an effect by tagging intermediate data with the 'Any'+monoid, a newtype wrapper for 'Bool' with disjunction as 'mappend'. The+standard @instance 'Monoid' a => 'Monad' (a,)'@ defined in the base package+then gives use the desired semantics. That is, when we sequence operations+using '>>=', the result tells us whether 'Any' of the two operations have+made progress. -}++module Darcs.Patch.Prim.Coalesce+    ( coalesce+    , defaultTryToShrink+    , defaultSortCoalesceFL+    , withAnyToMaybe+    , sortCoalesceFL2+    ) where++import Darcs.Prelude++import Data.Maybe ( fromMaybe )+import Data.Monoid ( Any(..) )++import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Prim.Class ( PrimCoalesce(..), isIdentity)+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) )++-- | Either 'primCoalesce' or cancel inverses.+--+-- prop> primCoalesce (p :> q) == Just r => apply r = apply p >> apply q+coalesce :: PrimCoalesce prim => (prim :> prim) wX wY -> Maybe (Maybe2 prim wX wY)+coalesce (p1 :> p2)+  | IsEq <- invert p1 =\/= p2 = Just Nothing2+  | otherwise = Just2 <$> primCoalesce p1 p2++defaultTryToShrink :: PrimCoalesce prim => FL prim wX wY -> Maybe (FL prim wX wY)+defaultTryToShrink = withAnyToMaybe . sortCoalesceFL2++defaultSortCoalesceFL :: PrimCoalesce prim => FL prim wX wY -> FL prim wX wY+defaultSortCoalesceFL = snd . sortCoalesceFL2++-- | Conversion between @('Any', a)@ and @'Maybe' a@.+withAnyToMaybe :: (Any, a) -> Maybe a+withAnyToMaybe (Any True, x) = Just x+withAnyToMaybe (Any False, _) = Nothing++-- | The heart of 'sortCoalesceFL'.+sortCoalesceFL2 :: PrimCoalesce prim => FL prim wX wY -> (Any, FL prim wX wY)+sortCoalesceFL2 NilFL = (Any False, NilFL)+sortCoalesceFL2 (x:>:xs) = do+  xs' <- sortCoalesceFL2 xs+  case isIdentity x of+    IsEq -> (Any True, xs')+    NotEq -> pushCoalescePatch x xs'++-- | Try to coalesce the patch with any of the elements in the sequence,+-- using commutation to push it down the list, until either+--+--  (1) @new@ is 'LT' the next member of the list (using 'comparePrim')+-- +--  (2) commutation fails or+-- +--  (3) coalescing succeeds.+--+-- In case (1) we push the patch further, trying to coalesce it with any of its+-- successors and disregarding any ordering. If this is successful, we recurse+-- with the result, otherwise we leave the patch where it was, so the sequence+-- remains sorted.+--+-- In case (3) we recursively continue with the result unless that is empty.+-- +-- The result is returned in the @('Any',)@ monad to indicate whether it was+-- able to shrink the patch sequence. To make this clear, we do /not/ track+-- whether sorting has made progress, only shrinking.+--+-- The precondition is that the input sequence is already sorted.+pushCoalescePatch+  :: forall prim wX wY wZ+   . PrimCoalesce prim+  => prim wX wY+  -> FL prim wY wZ+  -> (Any, FL prim wX wZ)+pushCoalescePatch new NilFL = (Any False, new:>:NilFL)+pushCoalescePatch new ps@(p :>: ps') =+  case coalesce (new :> p) of+    Just (Just2 new') -> (Any True, snd $ pushCoalescePatch new' ps')+    Just Nothing2 -> (Any True, ps')+    Nothing ->+      case comparePrim new p of+        LT ->+          case shrinkOne new ps of+            Just ps'' ->+              -- we have to start over here because shrinkOne may have+              -- destroyed the order+              sortCoalesceFL2 ps''+            Nothing -> (Any False, new :>: ps)+        _ ->+          case commute (new :> p) of+            Just (p' :> new') ->+              case pushCoalescePatch new' ps' of+                (Any True, r) -> (Any True, snd $ pushCoalescePatch p' r)+                (Any False, r) -> (Any False, p' :>: r)+            Nothing -> (Any False, new :>: ps)+  where+    -- Try to coalesce a patch with any element of an adjacent sequence,+    -- regardless of ordering. If successful, the result may not be+    -- sorted, even if the input was.+    shrinkOne :: prim wA wB -> FL prim wB wC -> Maybe (FL prim wA wC)+    shrinkOne _ NilFL = Nothing+    shrinkOne a (b :>: bs) =+      case coalesce (a :> b) of+        Just Nothing2 -> Just bs+        Just (Just2 ab) -> Just $ fromMaybe (ab :>: bs) $ shrinkOne ab bs+        Nothing -> do+          b' :> a' <- commute (a :> b)+          (b' :>:) <$> shrinkOne a' bs
src/Darcs/Patch/Prim/FileUUID/Apply.hs view
@@ -1,20 +1,18 @@-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.FileUUID.Apply ( hunkEdit, ObjectMap(..) ) where  import Darcs.Prelude +import Control.Monad.Catch ( MonadThrow(throwM) ) import Control.Monad.State( StateT, runStateT, gets, lift, put ) import qualified Data.ByteString as B import qualified Data.Map as M -import Debug.Trace ( trace )--- import Text.Show.Pretty ( ppShow )- import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad     ( ApplyMonad(..), ApplyMonadTrans(..)-    , ToTree(..), ApplyMonadState(..)+    , ApplyMonadOperations     ) import Darcs.Patch.Prim.Class ( PrimApply(..) ) import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..), HunkMove(..) )@@ -23,14 +21,13 @@ import Darcs.Patch.Repair ( RepairToFL(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) -import Darcs.Util.Hash( Hash(..) ) import Darcs.Util.Printer( text, packedString, ($$), renderString )   instance Apply Prim where   type ApplyState Prim = ObjectMap-  apply (Manifest i (L dirid name)) = editDirectory dirid (M.insert name i)-  apply (Demanifest _ (L dirid name)) = editDirectory dirid (M.delete name)+  apply (Manifest i (L dirid name)) = editDirectory dirid (addObject name i dirid)+  apply (Demanifest i (L dirid name)) = editDirectory dirid (delObject name i dirid)   apply (Hunk i hunk) = editFile i (hunkEdit hunk)   apply (HunkMove (HM fs ls ft lt c)) =     editFile fs (hunkEdit (H ls c B.empty)) >> editFile ft (hunkEdit (H lt B.empty c))@@ -43,55 +40,101 @@   applyPrimFL NilFL = return ()   applyPrimFL (p :>: ps) = apply p >> applyPrimFL ps -instance ToTree ObjectMap -- TODO+addObject :: Name -> UUID -> UUID -> DirContent -> Either String DirContent+addObject name obj dirid dir+  | Just obj' <- M.lookup name dir =+    Left $ unwords+      [ "##error applying patch: cannot insert"+      , show (name, obj)+      , "into directory"+      , show dirid+      , "because another object"+      , show obj'+      , "with that name already exists"+      ]+  | otherwise = Right $ M.insert name obj dir -hunkEdit :: Hunk wX wY -> FileContent -> FileContent+delObject :: Name -> UUID -> UUID -> DirContent -> Either String DirContent+delObject name obj dirid dir =+  case M.lookup name dir of+    Just obj'+      | obj == obj' -> Right $ M.delete name dir+      | otherwise ->+        Left $ unwords+          [ "##error applying patch: cannot remove"+          , show (name, obj)+          , "from directory"+          , show dirid+          , "because it contains a different object"+          , show obj'+          ]+    Nothing ->+        Left $ unwords+          [ "##error applying patch: cannot remove"+          , show (name, obj)+          , "from directory"+          , show dirid+          , "because it does not contain any object of that name"+          ]++hunkEdit :: Hunk wX wY -> FileContent -> Either String FileContent hunkEdit h@(H off old new) c   | old `B.isPrefixOf` (B.drop off c) =-      B.concat [B.take off c, new, B.drop (off + B.length old) c]-  | otherwise = error $ renderString $+      Right $ B.concat [B.take off c, new, B.drop (off + B.length old) c]+  | otherwise =+      Left $ renderString $       text "##error applying hunk:" $$ displayHunk Nothing h $$ "##to" $$       packedString c --       $$ text "##old=" <> text (ppShow old) $$ --       text "##new=" <> text (ppShow new) $$ --       text "##c=" <> text (ppShow c) -editObject :: Monad m+editObject :: MonadThrow m            => UUID-           -> (Maybe (Object m) -> Object m)+           -> (Maybe (Object m) -> Either String (Object m))            -> (StateT (ObjectMap m) m) () editObject i edit = do   load <- gets getObject   store <- gets putObject   obj <- lift $ load i-  new <- lift $ store i $ edit obj+  obj' <- liftEither $ edit obj+  new <- lift $ store i $ obj'   put new  -- a semantic, ObjectMap-based interface for patch application class ApplyMonadObjectMap m where-  editFile :: UUID -> (FileContent -> FileContent) -> m ()-  editDirectory :: UUID -> (DirContent -> DirContent) -> m ()+  editFile :: UUID -> (FileContent -> Either String FileContent) -> m ()+  editDirectory :: UUID -> (DirContent -> Either String DirContent) -> m () -instance ApplyMonadState ObjectMap where-  type ApplyMonadStateOperations ObjectMap = ApplyMonadObjectMap+type instance ApplyMonadOperations ObjectMap = ApplyMonadObjectMap -instance (Monad m) => ApplyMonad ObjectMap (StateT (ObjectMap m) m) where-  type ApplyMonadBase (StateT (ObjectMap m) m) = m+instance MonadThrow m => ApplyMonad ObjectMap (StateT (ObjectMap m) m) where+  readFilePS i = do+    load <- gets getObject+    mobj <- lift $ load i+    case mobj of+      Just (Blob readBlob _) -> lift readBlob+      Just _ -> throwM $ userError $ "readFilePS " ++ show i ++ ": object is not a file"+      Nothing -> throwM $ userError $ "readFilePS " ++ show i ++ ": no such file" -instance (Monad m) => ApplyMonadObjectMap (StateT (ObjectMap m) m) where+liftEither :: MonadThrow m => Either String a -> m a+liftEither (Left e) = throwM $ userError e+liftEither (Right v) = return v++instance MonadThrow m => ApplyMonadObjectMap (StateT (ObjectMap m) m) where   editFile i edit = editObject i edit'     where-      edit' (Just (Blob x _)) = Blob (edit `fmap` x) NoHash-      edit' Nothing = Blob (return $ edit "") NoHash-      edit' (Just d@(Directory m)) =-        trace ("\neditFile called with Directory object: " ++ show (i,m) ++ "\n") d+      edit' (Just (Blob x _)) = Right $ Blob (liftEither . edit =<< x) Nothing+      edit' Nothing = Right $ Blob (liftEither $ edit "") Nothing+      edit' (Just (Directory _)) =+        Left $ "wrong kind of object: " ++ show i ++ " is a directory, not a file"   editDirectory i edit = editObject i edit'     where-      edit' (Just (Directory x)) = Directory $ edit x-      edit' Nothing = Directory $ edit M.empty-      edit' (Just b@(Blob _ h)) =-        trace ("\neditDirectory called with File object: " ++ show (i,h) ++ "\n") b+      edit' (Just (Directory x)) = Directory <$> edit x+      edit' Nothing = Directory <$> edit M.empty+      edit' (Just (Blob _ _)) =+        Left $ "wrong kind of object: " ++ show i ++ " is a file, not a directory" -instance (Monad m) => ApplyMonadTrans ObjectMap m where+instance MonadThrow m => ApplyMonadTrans ObjectMap m where   type ApplyMonadOver ObjectMap m = StateT (ObjectMap m) m   runApplyMonad = runStateT
src/Darcs/Patch/Prim/FileUUID/Coalesce.hs view
@@ -3,11 +3,12 @@  import Darcs.Prelude -import Darcs.Patch.Prim.Class ( PrimCanonize(..), PrimSift(..) )-import Darcs.Patch.Prim.FileUUID.Core( Prim )+import Darcs.Patch.Prim.Class ( PrimCoalesce(..), PrimSift(..) )+import Darcs.Patch.Prim.FileUUID.Commute ()+import Darcs.Patch.Prim.FileUUID.Core ( Prim )  -- none of the methods are implemented-instance PrimCanonize Prim where+instance PrimCoalesce Prim where   sortCoalesceFL = id -- just so that we can use it in the tests  -- none of the methods are implemented
src/Darcs/Patch/Prim/FileUUID/Core.hs view
@@ -41,7 +41,7 @@ import Darcs.Patch.FileHunk( IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) )+import Darcs.Patch.Prim.Class ( PrimConstruct(..) ) import Darcs.Patch.Prim.FileUUID.ObjectMap  -- -----------------------------------------------------------------------------@@ -93,19 +93,6 @@ instance Show1 (Prim wX)  instance Show2 Prim---- TODO: PrimClassify doesn't make sense for FileUUID prims-instance PrimClassify Prim where-  primIsAddfile _ = False-  primIsRmfile _ = False-  primIsAdddir _ = False-  primIsRmdir _ = False-  primIsHunk _ = False-  primIsMove _ = False-  primIsBinary _ = False-  primIsTokReplace _ = False-  primIsSetpref _ = False-  is_filepatch _ = Nothing  -- TODO: PrimConstruct makes no sense for FileUUID prims instance PrimConstruct Prim where
src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs view
@@ -29,6 +29,7 @@  import Darcs.Prelude +import Darcs.Patch.Object ( ObjectIdOf ) import Darcs.Util.Hash ( Hash ) import Darcs.Util.Path ( Name ) import qualified Data.ByteString as B (ByteString)@@ -48,7 +49,7 @@  data Object (m :: * -> *)   = Directory DirContent-  | Blob (m FileContent) !Hash+  | Blob (m FileContent) !(Maybe Hash)  isBlob :: Object m -> Bool isBlob Blob{} = True@@ -63,3 +64,5 @@   , putObject :: UUID -> Object m -> m (ObjectMap m)   , listObjects :: m [UUID]   }++type instance ObjectIdOf ObjectMap = UUID
src/Darcs/Patch/Prim/FileUUID/Read.hs view
@@ -29,7 +29,9 @@       identity = lexString "identity" >> return Identity       patch x = string x >> uuid       uuid = UUID <$> lexWord-      filename = decodeWhiteName <$> lexWord+      filename = do+        word <- lexWord+        either fail return $ decodeWhiteName word       content = do         lexString "content"         len <- int
src/Darcs/Patch/Prim/FileUUID/Show.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, UndecidableInstances #-} module Darcs.Patch.Prim.FileUUID.Show     ( displayHunk )     where@@ -8,6 +8,7 @@  import qualified Data.ByteString as B +import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) import Darcs.Patch.Show     ( ShowPatchBasic(..), ShowPatch(..)@@ -35,9 +36,9 @@   showPatch fmt = showPrim (fileNameFormat fmt)  -- dummy instance, does not actually show any context-instance ShowContextPatch Prim where-  -- showContextPatch f = showPrimCtx (fileNameFormat f)-  showContextPatch f p = return $ showPatch f p+instance Apply Prim => ShowContextPatch Prim where+  -- showPatchWithContextAndApply f = showPrimWithContextAndApply (fileNameFormat f)+  showPatchWithContextAndApply f p = apply p >> return (showPatch f p)  instance ShowPatch Prim where   summary = plainSummaryPrim@@ -52,7 +53,7 @@   showPrim _ (Manifest f (L d p)) = showManifest "manifest" d f p   showPrim _ (Demanifest f (L d p)) = showManifest "demanifest" d f p   showPrim _ Identity = blueText "identity"-  showPrimCtx _ _ = error "show with context not implemented"+  showPrimWithContextAndApply _ _ = error "show with context not implemented"  showManifest :: String -> UUID -> UUID -> Name -> Doc showManifest txt dir file name =
src/Darcs/Patch/Prim/V1.hs view
@@ -1,10 +1,5 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1 ( Prim ) where -import Darcs.Prelude--import Data.Maybe ( fromMaybe )- import Darcs.Patch.Prim.V1.Apply () import Darcs.Patch.Prim.V1.Coalesce () import Darcs.Patch.Prim.V1.Commute ()@@ -13,79 +8,3 @@ import Darcs.Patch.Prim.V1.Mangle () import Darcs.Patch.Prim.V1.Read () import Darcs.Patch.Prim.V1.Show ()--import Darcs.Patch.Commute ( Commute(..), commuteFL )-import Darcs.Patch.Invert ( Invert(..), dropInverses )-import Darcs.Patch.Prim.Class-    ( PrimSift(..)-    , PrimClassify-      ( primIsHunk-      , primIsBinary-      , primIsSetpref-      , primIsAddfile-      , primIsAdddir-      )-    , PrimCanonize(tryToShrink)-    )-import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )-import Darcs.Patch.Witnesses.Ordered-    ( FL(..)-    , RL(..)-    , (:>)(..)-    , allFL-    , lengthFL-    , reverseFL-    , filterOutFLFL-    )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )--instance PrimSift Prim where-  siftForPending = v1siftForPending where--    -- | An optimized version of 'siftForPending' that avoids commutation-    -- in case all prim patches are "simple" i.e. hunk, binary, or setpref.-    -- Otherwise it returns the original sequence.-    crudeSift :: forall prim wX wY. PrimClassify prim-              => FL prim wX wY -> FL prim wX wY-    crudeSift xs =-      if isSimple xs-        then filterOutFLFL ishunkbinary xs-        else xs-      where-        ishunkbinary :: prim wA wB -> EqCheck wA wB-        ishunkbinary x-          | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq-          | otherwise = NotEq-        isSimple = allFL $ \x -> primIsHunk x || primIsBinary x || primIsSetpref x--    -- | Alternately 'sift' and 'tryToShrink' until shrinking no longer reduces-    -- the length of the sequence. Here, 'sift' means to commute hunks-    -- and binary patches to the end of the sequence and then drop them.-    v1siftForPending-      :: forall prim wX wY.-         (Commute prim, Invert prim, Eq2 prim, PrimCanonize prim, PrimClassify prim)-      => FL prim wX wY-      -> Sealed (FL prim wX)-    v1siftForPending simple_ps-      -- optimization: no need to sift if only adddir or addfile are present-      | allFL (\p -> primIsAddfile p || primIsAdddir p) oldps = seal oldps-      | otherwise =-          case sift (reverseFL oldps) NilFL of-            Sealed x ->-              let ps = tryToShrink x in-              if (lengthFL ps < lengthFL oldps)-                then v1siftForPending ps-                else seal ps-      where-        oldps = fromMaybe simple_ps $ dropInverses $ crudeSift simple_ps-        -- get rid of any hunk/binary patches that we can commute out the-        -- back (ie. we work our way backwards, pushing the patches down-        -- to the very end and popping them off; so in (addfile f :> hunk)-        -- we can nuke the hunk, but not so in (hunk :> replace)-        sift :: RL prim wA wB -> FL prim wB wC -> Sealed (FL prim wA)-        sift NilRL sofar = seal sofar-        sift (ps :<: p) sofar-          | primIsHunk p || primIsBinary p-          , Just (sofar' :> _) <- commuteFL (p :> sofar) = sift ps sofar'-          | otherwise = sift ps (p :>: sofar)
src/Darcs/Patch/Prim/V1/Apply.hs view
@@ -4,7 +4,7 @@  import Darcs.Prelude -import Control.Exception ( throw )+import Control.Monad.Catch ( MonadThrow(throwM) )  import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Repair ( RepairToFL(..) )@@ -22,7 +22,7 @@ import Darcs.Patch.ApplyMonad ( ApplyMonadTree(..) ) import Darcs.Util.Tree( Tree ) -import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, spanFL, (:>)(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), spanFL, (:>)(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart )  import Darcs.Util.ByteString ( unlinesPS )@@ -53,13 +53,13 @@     apply (FP f (TokReplace t o n)) = mModifyFilePS f doreplace         where doreplace fc =                   case tryTokReplace t (BC.pack o) (BC.pack n) fc of-                  Nothing -> throw $ userError $ "replace patch to " ++ ap2fp f+                  Nothing -> throwM $ userError $ "replace patch to " ++ ap2fp f                              ++ " couldn't apply."                   Just fc' -> return fc'     apply (FP f (Binary o n)) = mModifyFilePS f doapply         where doapply oldf = if o == oldf                              then return n-                             else throw $ userError+                             else throwM $ userError                                   $ "binary patch to " ++ ap2fp f                                   ++ " couldn't apply."     apply (DP d AddDir) = mCreateDirectory d@@ -126,25 +126,24 @@  instance PrimApply Prim where     applyPrimFL NilFL = return ()-    applyPrimFL (FP f h@(Hunk{}):>:the_ps)+    applyPrimFL (h@(FP f (Hunk{})):>:the_ps)      = case spanFL f_hunk the_ps of            (xs :> ps') ->-               do let foo = h :>: mapFL_FL (\(FP _ h') -> h') xs-                  mModifyFilePS f $ hunkmod foo+               do mModifyFilePS f $ hunkmod (h :>: xs)                   applyPrimFL ps'         where f_hunk (FP f' (Hunk{})) = f == f'               f_hunk _ = False               -- TODO there should be a HOF that abstracts               -- over this recursion scheme-              hunkmod :: Monad m => FL FilePatchType wX wY+              hunkmod :: MonadThrow m => FL Prim wX wY                       -> B.ByteString -> m B.ByteString               hunkmod NilFL content = return content-              hunkmod (Hunk line old new:>:hs) content =+              hunkmod (FP _ (Hunk line old new):>:hs) content =                   applyHunk f (line, old, new) content >>= hunkmod hs               hunkmod _ _ = error "impossible case"     applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps -applyHunk :: Monad m+applyHunk :: MonadThrow m           => AnchoredPath           -> (Int, [B.ByteString], [B.ByteString])           -> FileContents@@ -153,7 +152,7 @@   case applyHunkLines h fc of     Right fc' -> return fc'     Left msg ->-      throw $ userError $+      throwM $ userError $       "### Error applying:\n" ++ renderHunk h ++       "\n### to file " ++ ap2fp f ++ ":\n" ++ BC.unpack fc ++       "### Reason: " ++ msg
src/Darcs/Patch/Prim/V1/Coalesce.hs view
@@ -1,159 +1,62 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TupleSections #-}+ module Darcs.Patch.Prim.V1.Coalesce     ()     where  import Darcs.Prelude -import Control.Arrow ( second )-import Data.Maybe ( fromMaybe )-import Data.Map ( elems, fromListWith, mapWithKey )+import qualified Data.Map as M -import qualified Data.ByteString as B (ByteString, empty)+import qualified Data.ByteString as B ( ByteString )  import System.FilePath ( (</>) ) -import Darcs.Patch.Prim.Class ( PrimCanonize(..) )+import Darcs.Patch.Prim.Class ( PrimCoalesce(..) )+import Darcs.Patch.Prim.Coalesce import Darcs.Patch.Prim.V1.Commute ()-import Darcs.Patch.Prim.V1.Core-    ( Prim(..), FilePatchType(..), DirPatchType(..)-    , comparePrim, isIdentity-    )+import Darcs.Patch.Prim.V1.Core ( DirPatchType(..), FilePatchType(..), Prim(..) ) import Darcs.Patch.Prim.V1.Show ()-import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )-import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), (:>)(..)-    , reverseRL, mapFL, mapFL_FL-    , concatFL, lengthFL, (+>+) )-import Darcs.Patch.Witnesses.Sealed-    ( unseal, Sealed2(..), unseal2-    , Gap(..), unFreeLeft-    )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )-import Darcs.Patch.Invert ( Invert(..), dropInverses )-import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), concatFL, mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Darcs.Util.Diff ( getChanges )-import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Path ( AnchoredPath, floatPath )+import Darcs.Util.Path ( AnchoredPath, unsafeFloatPath ) -mapPrimFL :: (forall wX wY . FL Prim wX wY -> FL Prim wX wY)-             -> FL Prim wW wZ -> FL Prim wW wZ-mapPrimFL f x =--- an optimisation; break the list up into independent sublists--- and apply f to each of them-     case mapM toSimpleSealed $ mapFL Sealed2 x of-     Just sx -> concatFL $ unsealList $ elems $-                mapWithKey (\ k p -> Sealed2 (f (fromSimples k (unsealList (p []))))) $-                fromListWith (flip (.)) $-                map (\ (a,b) -> (a,(b:))) sx-     Nothing -> f x+-- | Map a monadic function over an 'FL' of 'Prim's.+--+-- Be careful which 'Monad' to choose when using this function. For instance,+-- 'Maybe' would return 'Nothing' if any of the calls failed to shrink their+-- argument, which usually not what we want. A suitable candidate is @('Any',)@.+mapPrimFL :: Monad m+          => (forall wA wB . FL Prim wA wB -> m (FL Prim wA wB))+          -> FL Prim wX wY -> m (FL Prim wX wY)+mapPrimFL f ps =+  -- an optimisation; break the list up into independent sublists+  -- and apply f to each of them+  case mapM withPathAsKey $ mapFL Sealed2 ps of+    Just pairs ->+      concatFL .+      unsealList .+      M.elems <$>+      (mapM (fmap Sealed2 . f . unsealList . ($ [])) $+      M.fromListWith (flip (.)) $ map (\(k, v) -> (k, (v :))) pairs)+    Nothing -> f ps   where-        unsealList :: [Sealed2 p] -> FL p wA wB-        unsealList = foldr ((:>:) . unseal2 unsafeCoerceP) (unsafeCoerceP NilFL)--        toSimpleSealed :: Sealed2 Prim -> Maybe (AnchoredPath, Sealed2 Simple)-        toSimpleSealed (Sealed2 p) = fmap (second Sealed2) (toSimple p)--data Simple wX wY-    = SFP !(FilePatchType wX wY)-    | SDP !(DirPatchType wX wY)-    | SCP String String String-    deriving ( Show )--toSimple :: Prim wX wY -> Maybe (AnchoredPath, Simple wX wY)-toSimple (FP a b) = Just (a, SFP b)-toSimple (DP a AddDir) = Just (a, SDP AddDir)-toSimple (DP _ RmDir) = Nothing -- ordering is trickier with rmdir present-toSimple (Move _ _) = Nothing-toSimple (ChangePref a b c) = Just (floatPath (darcsdir </> "prefs" </> "prefs"), SCP a b c)--fromSimple :: AnchoredPath -> Simple wX wY -> Prim wX wY-fromSimple a (SFP b) = FP a b-fromSimple a (SDP b) = DP a b-fromSimple _ (SCP a b c) = ChangePref a b c--fromSimples :: AnchoredPath -> FL Simple wX wY -> FL Prim wX wY-fromSimples a = mapFL_FL (fromSimple a)--tryHarderToShrink :: FL Prim wX wY -> FL Prim wX wY-tryHarderToShrink x = tryToShrink2 $ fromMaybe x (dropInverses x)--tryToShrink2 :: FL Prim wX wY -> FL Prim wX wY-tryToShrink2 psold =-    let ps = sortCoalesceFL psold-        ps_shrunk = shrinkABit ps-                    in-    if lengthFL ps_shrunk < lengthFL ps-    then tryToShrink2 ps_shrunk-    else ps_shrunk---- | @shrinkABit ps@ tries to simplify @ps@ by one patch,---   the first one we find that coalesces with its neighbour-shrinkABit :: FL Prim wX wY -> FL Prim wX wY-shrinkABit NilFL = NilFL-shrinkABit (p:>:ps) = fromMaybe (p :>: shrinkABit ps) $ tryOne NilRL p ps---- | @tryOne acc p ps@ pushes @p@ as far down @ps@ as we can go---   until we can either coalesce it with something or it can't---   go any further.  Returns @Just@ if we manage to get any---   coalescing out of this-tryOne :: RL Prim wW wX -> Prim wX wY -> FL Prim wY wZ-        -> Maybe (FL Prim wW wZ)-tryOne _ _ NilFL = Nothing-tryOne sofar p (p1:>:ps) =-    case coalesceOrCancel p p1 of-    Just p' -> Just (reverseRL sofar +>+ p' +>+ ps)-    Nothing -> case commute (p :> p1) of-               Nothing -> Nothing-               Just (p1' :> p') -> tryOne (sofar:<:p1') p' ps---- | The heart of "sortCoalesceFL"-sortCoalesceFL2 :: FL Prim wX wY -> FL Prim wX wY-sortCoalesceFL2 NilFL = NilFL-sortCoalesceFL2 (x:>:xs) | IsEq <- isIdentity x = sortCoalesceFL2 xs-sortCoalesceFL2 (x:>:xs) = either id id $ pushCoalescePatch x $ sortCoalesceFL2 xs+    unsealList :: [Sealed2 p] -> FL p wA wB+    unsealList = foldr ((:>:) . unseal2 unsafeCoerceP) (unsafeCoerceP NilFL) --- | 'pushCoalescePatch' @new ps@ is almost like @new :>: ps@ except---   as an alternative to consing, we first try to coalesce @new@ with---   the head of @ps@.  If this fails, we try again, using commutation---   to push @new@ down the list until we find a place where either---   (a) @new@ is @LT@ the next member of the list [see 'comparePrim']---   (b) commutation fails or---   (c) coalescing succeeds.---   The basic principle is to coalesce if we can and cons otherwise.------   As an additional optimization, pushCoalescePatch outputs a Left---   value if it wasn't able to shrink the patch sequence at all, and---   a Right value if it was indeed able to shrink the patch sequence.---   This avoids the O(N) calls to lengthFL that were in the older---   code.------   Also note that pushCoalescePatch is only ever used (and should---   only ever be used) as an internal function in in---   sortCoalesceFL2.-pushCoalescePatch :: Prim wX wY -> FL Prim wY wZ-                    -> Either (FL Prim wX wZ) (FL Prim wX wZ)-pushCoalescePatch new NilFL = Left (new:>:NilFL)-pushCoalescePatch new ps@(p:>:ps')-    = case coalesceOrCancel new p of-      Just (new' :>: NilFL) -> Right $ either id id $ pushCoalescePatch new' ps'-      Just NilFL -> Right ps'-      Just _ -> error "impossible case" -- coalesce either returns a singleton or empty-      Nothing -> if comparePrim new p == LT then Left (new:>:ps)-                            else case commute (new :> p) of-                                 Just (p' :> new') ->-                                     case pushCoalescePatch new' ps' of-                                     Right r -> Right $ either id id $-                                                pushCoalescePatch p' r-                                     Left r -> Left (p' :>: r)-                                 Nothing -> Left (new:>:ps)+    withPathAsKey :: Sealed2 Prim -> Maybe (AnchoredPath, Sealed2 Prim)+    withPathAsKey (Sealed2 p) = fmap (, Sealed2 p) $ getKey p -coalesceOrCancel :: Prim wX wY -> Prim wY wZ -> Maybe (FL Prim wX wZ)-coalesceOrCancel p1 p2-  | IsEq <- invert p1 =\/= p2 = Just NilFL-  | otherwise = fmap (:>: NilFL) $ coalescePair p1 p2+    getKey (FP fp _) = Just fp+    getKey (DP fp AddDir) = Just fp+    getKey (DP _ RmDir) = Nothing -- ordering is trickier with rmdir present+    getKey (Move {}) = Nothing+    getKey (ChangePref {}) = Just (unsafeFloatPath (darcsdir </> "prefs" </> "prefs"))  -- | @'coalescePair' p1 p2@ tries to combine @p1@ and @p2@ into a single --   patch. For example, two hunk patches@@ -167,37 +70,19 @@   | otherwise = coalesceFilePrim f1 p1 p2 coalescePair (Move a b) (Move b' c) | b == b' = Just $ Move a c coalescePair (FP a AddFile) (Move a' b) | a == a' = Just $ FP b AddFile-coalescePair (DP a AddDir) (Move a' b) | a == a' = Just $ DP b AddDir-coalescePair (Move a b) (FP b' RmFile) | b == b' = Just $ FP a RmFile-coalescePair (Move a b) (DP b' RmDir) | b == b' = Just $ DP a RmDir-{- we don't want to do that, of course:-coalescePair (FP a RmFile) (FP b AddFile) | a == a' = Just $ Move a' b-coalescePair (DP a RmDir) (DP b AddDir) | a == a' = Just $ Move a' b--}+coalescePair (DP a AddDir) (Move a' b)  | a == a' = Just $ DP b AddDir+coalescePair (Move a b) (FP b' RmFile)  | b == b' = Just $ FP a RmFile+coalescePair (Move a b) (DP b' RmDir)   | b == b' = Just $ DP a RmDir coalescePair (ChangePref p a b) (ChangePref p' b' c)   | p == p' && b == b' = Just $ ChangePref p a c coalescePair _ _ = Nothing --- | If 'coalescePair' is "addition" then this is "subtraction".-decoalescePair :: Prim wX wZ -> Prim wX wY -> Maybe (Prim wY wZ)--- These two cases make sense only if we decoalesce;--- they correspond to the commented two cases for coalesce above--- and are one reason we need to define this function as a primitive-decoalescePair (Move a b) (FP b' AddFile) | b == b' = Just (FP a RmFile)-decoalescePair (Move a b) (DP b' AddDir) | b == b' = Just (DP a RmDir)-decoalescePair (FP f1 p1) (FP f2 p2)-  | f1 /= f2 = Nothing-  | otherwise = decoalesceFilePrim f1 p1 p2-decoalescePair z x = coalescePair (invert x) z- coalesceFilePrim :: AnchoredPath -> FilePatchType wX wY -> FilePatchType wY wZ                  -> Maybe (Prim wX wZ) coalesceFilePrim f (Hunk line1 old1 new1) (Hunk line2 old2 new2)     = coalesceHunk f line1 old1 new1 line2 old2 new2--- Token replace patches operating right after (or before) AddFile (RmFile)+-- Token replace patches operating right after AddFile or before RmFile -- is an identity patch, as far as coalescing is concerned.--- These two cases make no sense when we decoalesce, which is the second--- reason decoalesce is defined as a primitive. coalesceFilePrim f (AddFile) (TokReplace{}) = Just $ FP f AddFile coalesceFilePrim f (TokReplace{}) (RmFile) = Just $ FP f RmFile coalesceFilePrim f (TokReplace t1 a b) (TokReplace t2 b' c)@@ -206,14 +91,6 @@     | m == m' = Just $ FP f $ Binary o n coalesceFilePrim _ _ _ = Nothing -decoalesceFilePrim :: AnchoredPath -> FilePatchType wX wZ -> FilePatchType wX wY-                   -> Maybe (Prim wY wZ)--- These two cases must fail because the token replace patches that coalesce--- has eliminated are irretrievably lost.-decoalesceFilePrim _ (AddFile) (RmFile) = Nothing-decoalesceFilePrim _ (RmFile) (TokReplace{}) = Nothing-decoalesceFilePrim f z x = coalesceFilePrim f (invert x) z- coalesceHunk :: AnchoredPath              -> Int -> [B.ByteString] -> [B.ByteString]              -> Int -> [B.ByteString] -> [B.ByteString]@@ -241,32 +118,31 @@     where lengthold2 = length old2           lengthnew1 = length new1 -canonizeHunk :: Gap w-             => D.DiffAlgorithm -> AnchoredPath -> Int -> [B.ByteString] -> [B.ByteString]-             -> w (FL Prim)-canonizeHunk _ f line old new-    | null old || null new || old == [B.empty] || new == [B.empty]-        = freeGap (FP f (Hunk line old new) :>: NilFL)-canonizeHunk da f line old new = makeHoley f line $ getChanges da old new+instance PrimCoalesce Prim where+  tryToShrink = withAnyToMaybe . mapPrimFL sortCoalesceFL2 -makeHoley :: Gap w-          => AnchoredPath -> Int -> [(Int,[B.ByteString], [B.ByteString])]-          -> w (FL Prim)-makeHoley f line =-    foldr (joinGap (:>:) . (\(l,o,n) -> freeGap (FP f (Hunk (l+line) o n)))) (emptyGap NilFL)+  sortCoalesceFL = snd . mapPrimFL sortCoalesceFL2 -instance PrimCanonize Prim where-   tryToShrink = mapPrimFL tryHarderToShrink+  primCoalesce = coalescePair -   sortCoalesceFL = mapPrimFL sortCoalesceFL2-   canonize _ p | IsEq <- isIdentity p = NilFL-   canonize da (FP f (Hunk line old new)) = unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk da f line old new-   canonize _ p = p :>: NilFL-   -- Note: it is important to first coalesce and then canonize, since-   -- coalescing can produce non-cononical hunks (while hunks resulting-   -- from canonizing a single hunk cannot be coalesced). See issue525,-   -- in particular msg20270 for details.-   canonizeFL da = concatFL . mapFL_FL (canonize da) . sortCoalesceFL-   coalesce (p1 :> p2) = coalesceOrCancel p1 p2-   primCoalesce = coalescePair-   primDecoalesce = decoalescePair+  isIdentity (FP _ (Binary old new)) | old == new = unsafeCoerceP IsEq+  isIdentity (FP _ (Hunk _ old new)) | old == new = unsafeCoerceP IsEq+  isIdentity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerceP IsEq+  isIdentity (Move old new) | old == new = unsafeCoerceP IsEq+  isIdentity _ = NotEq++  -- Basically, identical patches are equal and+  -- @Move < DP < FP < ChangePref@.+  -- Everything else is compared in dictionary order of its arguments.+  comparePrim (Move a b) (Move c d) = compare (a, b) (c, d)+  comparePrim (Move _ _) _ = LT+  comparePrim _ (Move _ _) = GT+  comparePrim (DP d1 p1) (DP d2 p2) = compare (d1, p1) $ unsafeCoerceP (d2, p2)+  comparePrim (DP _ _) _ = LT+  comparePrim _ (DP _ _) = GT+  comparePrim (FP f1 fp1) (FP f2 fp2) =+    compare (f1, fp1) $ unsafeCoerceP (f2, fp2)+  comparePrim (FP _ _) _ = LT+  comparePrim _ (FP _ _) = GT+  comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) =+    compare (c1, b1, a1) (c2, b2, a2)
src/Darcs/Patch/Prim/V1/Commute.hs view
@@ -1,13 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Prim.V1.Commute-    ( Perhaps(..)-    , toPerhaps-    , CommuteFunction-    , speedyCommute-    , cleverCommute-    , commuteFiledir-    , commuteFilepatches-    ) where+module Darcs.Patch.Prim.V1.Commute () where  import Darcs.Prelude @@ -74,7 +66,7 @@     (Succeeded x) >>= k =  k x     Failed   >>= _      =  Failed     Unknown  >>= _      =  Unknown-    return              =  Succeeded+    return              =  pure  instance Alternative Perhaps where     empty = Unknown@@ -90,10 +82,6 @@ toMaybe (Succeeded x) = Just x toMaybe _ = Nothing -toPerhaps :: Maybe a -> Perhaps a-toPerhaps (Just x) = Succeeded x-toPerhaps Nothing = Failed- cleverCommute :: CommuteFunction -> CommuteFunction cleverCommute c (p1:>p2) =     case c (p1 :> p2) of@@ -176,10 +164,6 @@ commuteFiledir _ = Unknown  type CommuteFunction = forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY)--commuteFilepatches :: CommuteFunction-commuteFilepatches (FP f1 p1 :> FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :> p2)-commuteFilepatches _ = Unknown  commuteFP :: AnchoredPath -> (FilePatchType :> FilePatchType) wX wY           -> Perhaps ((Prim :> Prim) wX wY)
src/Darcs/Patch/Prim/V1/Core.hs view
@@ -16,26 +16,26 @@ --  Boston, MA 02110-1301, USA.  module Darcs.Patch.Prim.V1.Core-       ( Prim(..),-         DirPatchType(..), FilePatchType(..),-         isIdentity,-         comparePrim,-       )-       where+    ( Prim(..)+    , DirPatchType(..)+    , FilePatchType(..)+    ) where  import Darcs.Prelude  import qualified Data.ByteString as B (ByteString)  import Darcs.Util.Path ( AnchoredPath )-import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Object ( ObjectIdOf ) import Darcs.Patch.Permutations () -- for Invert instance of FL-import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) )+import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimSift(..) )  data Prim wX wY where     Move :: !AnchoredPath -> !AnchoredPath -> Prim wX wY@@ -75,63 +75,21 @@     invert RmDir = AddDir     invert AddDir = RmDir -isIdentity :: Prim wX wY -> EqCheck wX wY-isIdentity (FP _ (Binary old new)) | old == new = unsafeCoerceP IsEq-isIdentity (FP _ (Hunk _ old new)) | old == new = unsafeCoerceP IsEq-isIdentity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerceP IsEq-isIdentity (Move old new) | old == new = unsafeCoerceP IsEq-isIdentity _ = NotEq--instance PrimClassify Prim where-   primIsAddfile (FP _ AddFile) = True-   primIsAddfile _ = False--   primIsRmfile (FP _ RmFile) = True-   primIsRmfile _ = False--   primIsAdddir (DP _ AddDir) = True-   primIsAdddir _ = False--   primIsRmdir (DP _ RmDir) = True-   primIsRmdir _ = False--   primIsMove (Move _ _) = True-   primIsMove _ = False--   primIsHunk (FP _ (Hunk _ _ _)) = True-   primIsHunk _ = False--   primIsTokReplace (FP _ (TokReplace _ _ _)) = True-   primIsTokReplace _ = False--   primIsBinary (FP _ (Binary _ _)) = True-   primIsBinary _ = False--   primIsSetpref (ChangePref _ _ _) = True-   primIsSetpref _ = False--   is_filepatch (FP f _) = Just f-   is_filepatch _ = Nothing--evalargs :: (a -> b -> c) -> a -> b -> c-evalargs f x y = (f $! x) $! y--instance PrimConstruct Prim where-   addfile f = FP f AddFile-   rmfile f = FP f RmFile-   adddir d = DP d AddDir-   rmdir d = DP d RmDir-   move old new = Move old new-   changepref p f t = ChangePref p f t-   hunk f line old new = evalargs FP f (Hunk line old new)-   tokreplace f tokchars old new =-       evalargs FP f (TokReplace tokchars old new)-   binary f old new = FP f $ Binary old new-   primFromHunk (FileHunk f line before after) = FP f (Hunk line before after)+instance ObjectIdOf (ApplyState Prim) ~ AnchoredPath => PrimConstruct Prim where+    addfile f = FP f AddFile+    rmfile f = FP f RmFile+    adddir d = DP d AddDir+    rmdir d = DP d RmDir+    move old new = Move old new+    changepref p f t = ChangePref p f t+    hunk f line old new = FP f (Hunk line old new)+    tokreplace f tokchars old new = FP f (TokReplace tokchars old new)+    binary f old new = FP f $ Binary old new+    primFromHunk (FileHunk f line before after) = FP f (Hunk line before after) -instance IsHunk Prim where-   isHunk (FP f (Hunk line before after)) = Just (FileHunk f line before after)-   isHunk _ = Nothing+instance ObjectIdOf (ApplyState Prim) ~ AnchoredPath => IsHunk Prim where+    isHunk (FP f (Hunk line before after)) = Just (FileHunk f line before after)+    isHunk _ = Nothing  instance Invert Prim where     invert (FP f p)  = FP f (invert p)@@ -168,19 +126,7 @@ instance Eq (Prim wX wY) where     (==) = unsafeCompare --- | 'comparePrim' @p1 p2@ is used to provide an arbitrary ordering between---   @p1@ and @p2@.  Basically, identical patches are equal and---   @Move < DP < FP < ChangePref@.---   Everything else is compared in dictionary order of its arguments.-comparePrim :: Prim wX wY -> Prim wW wZ -> Ordering-comparePrim (Move a b) (Move c d) = compare (a, b) (c, d)-comparePrim (Move _ _) _ = LT-comparePrim _ (Move _ _) = GT-comparePrim (DP d1 p1) (DP d2 p2) = compare (d1, p1) $ unsafeCoerceP (d2, p2)-comparePrim (DP _ _) _ = LT-comparePrim _ (DP _ _) = GT-comparePrim (FP f1 fp1) (FP f2 fp2) = compare (f1, fp1) $ unsafeCoerceP (f2, fp2)-comparePrim (FP _ _) _ = LT-comparePrim _ (FP _ _) = GT-comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2)- = compare (c1, b1, a1) (c2, b2, a2)+instance PrimSift Prim where+  primIsSiftable (FP _ (Binary _ _)) = True+  primIsSiftable (FP _ (Hunk _ _ _)) = True+  primIsSiftable _ = False
src/Darcs/Patch/Prim/V1/Mangle.hs view
@@ -9,6 +9,7 @@ import Data.Maybe ( isJust, listToMaybe ) import Data.List ( sort, intercalate, nub ) +import Darcs.Patch.Apply ( ObjectIdOfPatch ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.Inspect ( PatchInspect(listTouchedFiles) ) import Darcs.Patch.Invert ( Invert(..) )@@ -17,11 +18,10 @@     , PrimMangleUnravelled(..)     ) import Darcs.Patch.Prim.V1.Core ( Prim )+import Darcs.Patch.Prim.V1.Apply () import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), mapFL_FL_M ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal ) -import Darcs.Util.Path ( AnchoredPath )- -- | The state of a single file as far as we know it. 'Nothing' -- means we don't know the content of a particular line. newtype FileState wX = FileState { content :: [Maybe B.ByteString] }@@ -32,7 +32,7 @@  -- | Note that @applyHunk p . applyHunk (invert p) /= id@: it converts -- undefined lines ('Nothing') to defined ones ('Just' the old content of @p@).-applyHunk :: FileHunk wX wY -> FileState wX -> FileState wY+applyHunk :: FileHunk oid wX wY -> FileState wX -> FileState wY applyHunk (FileHunk _ line old new) = FileState . go . content   where     go mls =@@ -41,7 +41,7 @@           concat [before, map Just new, drop (length old) rest]  -- | Iterate 'applyHunk'.-applyHunks :: FL FileHunk wX wY -> FileState wX -> FileState wY+applyHunks :: FL (FileHunk oid) wX wY -> FileState wX -> FileState wY applyHunks NilFL = id applyHunks (p:>:ps) = applyHunks ps . applyHunk p @@ -56,18 +56,18 @@       filenames = nub . concatMap (unseal listTouchedFiles)        -- | Convert every prim in the input to a 'FileHunk', or fail.-      onlyHunks :: forall prim wX. IsHunk prim+      onlyHunks :: forall prim oid wX. (IsHunk prim, ObjectIdOfPatch prim ~ oid)                 => [Sealed (FL prim wX)]-                -> Maybe [Sealed (FL FileHunk wX)]+                -> Maybe [Sealed (FL (FileHunk oid) wX)]       onlyHunks = mapM toHunk where-        toHunk :: Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))+        toHunk :: Sealed (FL prim wA) -> Maybe (Sealed (FL (FileHunk oid) wA))         toHunk (Sealed ps) = fmap Sealed $ mapFL_FL_M isHunk ps        -- | Mangle a list of hunks, returning a single hunk.       -- Note: the input list consists of 'FL's because when commuting conflicts       -- to the head we may accumulate dependencies. In fact, the patches in all       -- of the given (mutually conflicting) 'FL's should coalesce to a single hunk.-      mangleHunks :: AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)+      mangleHunks :: oid -> [Sealed (FL (FileHunk oid) wX)] -> Sealed (FileHunk oid wX)       mangleHunks _ [] = error "mangleHunks called with empty list of alternatives"       mangleHunks path ps = Sealed (FileHunk path l old new)         where@@ -89,11 +89,11 @@        -- | Apply the patches and their inverse. This turns all lines touched       -- by the 'FL' of patches into defined lines with their "old" values.-      oldFileState :: FileState wX -> Sealed (FL FileHunk wX) -> FileState wX+      oldFileState :: FileState wX -> Sealed (FL (FileHunk oid) wX) -> FileState wX       oldFileState mls (Sealed ps) = applyHunks (ps +>+ invert ps) mls        -- | This is @flip 'applyHunks'@ under 'Sealed'.-      newFileState :: FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState+      newFileState :: FileState wX -> Sealed (FL (FileHunk oid) wX) -> Sealed FileState       newFileState mls (Sealed ps) = Sealed (applyHunks ps mls)        -- Index of the first line touched by any of the FileStates (1-based).
src/Darcs/Patch/Prim/V1/Read.hs view
@@ -9,6 +9,7 @@     , DirPatchType(..)     , FilePatchType(..)     )+import Darcs.Patch.Prim.V1.Apply ()  import Darcs.Util.Path (  ) import Darcs.Patch.Format ( FileNameFormat )@@ -119,10 +120,12 @@   _ <- lexWord   skipSpace   old <- linesStartingWith '*'+  r_old <- either fail return $ fromHex2PS $ B.concat old   _ <- lexWord   skipSpace   new <- linesStartingWith '*'-  return $ binary fi (fromHex2PS $ B.concat old) (fromHex2PS $ B.concat new)+  r_new <- either fail return $ fromHex2PS $ B.concat new+  return $ binary fi r_old r_new  readAddFile :: FileNameFormat -> Parser (Prim wX wY) readAddFile fmt = do
src/Darcs/Patch/Prim/V1/Show.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns, UndecidableInstances #-} module Darcs.Patch.Prim.V1.Show     ( showHunk )     where@@ -8,9 +8,8 @@  import Darcs.Util.ByteString ( fromPS2Hex ) import qualified Data.ByteString as B (ByteString, length, take, drop)-import qualified Data.ByteString.Char8 as BC (head) -import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Apply ( Apply(..), ObjectIdOfPatch ) import Darcs.Patch.FileHunk ( FileHunk(..), showFileHunk ) import Darcs.Patch.Format ( FileNameFormat ) import Darcs.Patch.Show ( formatFileName )@@ -27,42 +26,17 @@                  text, userchunk, invisibleText, invisiblePS, blueText,                  ($$), (<+>)                )-import Darcs.Util.Show ( appPrec, BSWrapper(..) ) import Darcs.Util.Tree ( Tree )  -deriving instance Show (Prim wX wY)- instance Show2 Prim- instance Show1 (Prim wX)--instance Show (FilePatchType wX wY) where-    showsPrec _ RmFile = showString "RmFile"-    showsPrec _ AddFile = showString "AddFile"-    showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new-        = showParen (d > appPrec) $ showString "Hunk " .-                                      showsPrec (appPrec + 1) line . showString " " .-                                      showsPrecC old . showString " " .-                                      showsPrecC new-       where showsPrecC [] = showString "[]"-             showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (appPrec + 1) (map BC.head ss)-    showsPrec d (Hunk line old new) = showParen (d > appPrec) $ showString "Hunk " .-                                      showsPrec (appPrec + 1) line . showString " " .-                                      showsPrec (appPrec + 1) (map BSWrapper old) . showString " " .-                                      showsPrec (appPrec + 1) (map BSWrapper new)-    showsPrec d (TokReplace t old new) = showParen (d > appPrec) $ showString "TokReplace " .-                                         showsPrec (appPrec + 1) t . showString " " .-                                         showsPrec (appPrec + 1) old . showString " " .-                                         showsPrec (appPrec + 1) new-    -- this case may not work usefully-    showsPrec d (Binary old new) = showParen (d > appPrec) $ showString "Binary " .-                                   showsPrec (appPrec + 1) (BSWrapper old) . showString " " .-                                   showsPrec (appPrec + 1) (BSWrapper new)-+deriving instance Show (Prim wX wY)+deriving instance Show (FilePatchType wX wY) deriving instance Show (DirPatchType wX wY) -instance ApplyState Prim ~ Tree => PrimShow Prim where+instance (Apply Prim, ApplyState Prim ~ Tree, ObjectIdOfPatch Prim ~ AnchoredPath) =>+         PrimShow Prim where   showPrim fmt (FP f AddFile) = showAddFile fmt f   showPrim fmt (FP f RmFile)  = showRmFile fmt f   showPrim fmt (FP f (Hunk line old new))  = showHunk fmt f line old new@@ -72,8 +46,13 @@   showPrim fmt (DP d RmDir)  = showRmDir fmt d   showPrim fmt (Move f f') = showMove fmt f f'   showPrim _ (ChangePref p f t) = showChangePref p f t-  showPrimCtx fmt (FP f (Hunk line old new)) = showContextHunk fmt (FileHunk f line old new)-  showPrimCtx fmt p = return $ showPrim fmt p+  showPrimWithContextAndApply fmt p@(FP f (Hunk line old new)) = do+    r <- showContextHunk fmt (FileHunk f line old new)+    apply p+    return r+  showPrimWithContextAndApply fmt p = do+    apply p+    return $ showPrim fmt p  showAddFile :: FileNameFormat -> AnchoredPath -> Doc showAddFile fmt f = blueText "addfile" <+> formatFileName fmt f
src/Darcs/Patch/Prim/WithName.hs view
@@ -14,11 +14,10 @@     , PatchId     , SignedId(..)     , StorableId(..)-    , IdEq2(..)     ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Prim.Class ( PrimApply(..), PrimClassify(..), PrimDetails(..) )+import Darcs.Patch.Prim.Class ( PrimApply(..), PrimDetails(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Merge ( CleanMerge(..) ) import Darcs.Patch.Read ( ReadPatch(..) )@@ -50,8 +49,6 @@ instance SignedId name => Ident (PrimWithName name p) where   ident = wnName -instance (SignedId name, Eq2 p) => IdEq2 (PrimWithName name p)- instance (Eq name, Eq2 p) => Eq2 (PrimWithName name p) where   PrimWithName i p =\/= PrimWithName j q     | i == j, IsEq <- p =\/= q = IsEq@@ -95,18 +92,6 @@ instance PrimApply p => PrimApply (PrimWithName name p) where   applyPrimFL = applyPrimFL . mapFL_FL wnPatch -instance PrimClassify p => PrimClassify (PrimWithName name p) where-  primIsAddfile = primIsAddfile . wnPatch-  primIsRmfile = primIsRmfile . wnPatch-  primIsAdddir = primIsAdddir . wnPatch-  primIsRmdir = primIsRmdir . wnPatch-  primIsHunk = primIsHunk . wnPatch-  primIsMove = primIsMove . wnPatch-  primIsBinary = primIsBinary . wnPatch-  primIsTokReplace = primIsTokReplace . wnPatch-  primIsSetpref = primIsSetpref . wnPatch-  is_filepatch = is_filepatch . wnPatch- instance PrimDetails p => PrimDetails (PrimWithName name p) where   summarizePrim = summarizePrim . wnPatch @@ -146,6 +131,6 @@   thing _ = "change"  instance (StorableId name, ShowContextPatch p) => ShowContextPatch (PrimWithName name p) where-  showContextPatch use (PrimWithName name p) = do-    r <- showContextPatch use p+  showPatchWithContextAndApply use (PrimWithName name p) = do+    r <- showPatchWithContextAndApply use p     return $ showId use name $$ r
src/Darcs/Patch/Progress.hs view
@@ -52,8 +52,8 @@  -- | Evaluate an 'RL' list and report progress. In addition to printing -- the number of patches we got, show the name of the last tag we got.-progressRLShowTags :: String -> RL (PatchInfoAnd rt p) wX wY-                   -> RL (PatchInfoAnd rt p) wX wY+progressRLShowTags :: String -> RL (PatchInfoAnd p) wX wY+                   -> RL (PatchInfoAnd p) wX wY progressRLShowTags _ NilRL = NilRL progressRLShowTags k xxs@(xs :<: x) =     if xxsLen < minlist@@ -62,7 +62,7 @@   where     xxsLen = lengthRL xxs -    pl :: RL (PatchInfoAnd rt p) wX wY -> RL (PatchInfoAnd rt p) wX wY+    pl :: RL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY     pl NilRL = NilRL     pl (NilRL :<: y) = unsafePerformIO $ do endTedious k                                             return (NilRL :<: y)
src/Darcs/Patch/Read.hs view
@@ -27,9 +27,10 @@ import Darcs.Prelude  import Control.Applicative ( (<|>) )-import Control.Monad ( mzero )-import qualified Data.ByteString as B ( ByteString, null )+import Control.Monad ( mzero, (<=<) )+import qualified Data.ByteString as B ( ByteString ) import qualified Data.ByteString.Char8 as BC ( ByteString, pack, stripPrefix )+import GHC.Stack ( HasCallStack )  import Darcs.Patch.Bracketed ( Bracketed(..), unBracketedFL ) import Darcs.Patch.Format@@ -45,11 +46,12 @@     , lexString     , lexWord     , parse+    , parseAll     ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) -import Darcs.Util.ByteString ( decodeLocale, dropSpace, unpackPSFromUTF8 )+import Darcs.Util.ByteString ( decodeLocale, unpackPSFromUTF8 ) import Darcs.Util.Path ( AnchoredPath, decodeWhite, floatPath )  -- | This class is used to decode patches from their binary representation.@@ -60,12 +62,7 @@ readPatchPartial = parse readPatch'  readPatch :: ReadPatch p => B.ByteString -> Either String (Sealed (p wX))-readPatch ps =-  case parse readPatch' ps of-    Left e -> Left e-    Right (p, leftover)-      | B.null (dropSpace leftover) -> Right p-      | otherwise -> Left $ unlines ["leftover:",show leftover]+readPatch = parseAll readPatch'  instance ReadPatch p => ReadPatch (Bracketed p) where     readPatch' = mapSeal Braced <$> bracketedFL readPatch' '{' '}'@@ -123,15 +120,18 @@ {-# INLINE peekfor #-}  -- See also Darcs.Patch.Show.formatFileName.-readFileName :: FileNameFormat -> Parser AnchoredPath+readFileName :: HasCallStack => FileNameFormat -> Parser AnchoredPath readFileName fmt = do   raw <- lexWord   case BC.stripPrefix (BC.pack "./") raw of     Nothing -> fail $ "invalid file path"-    Just raw' -> return $ convert fmt raw'+    Just raw' ->+      case convert fmt raw' of+        Left e -> fail e+        Right r -> return r   where     convert FileNameFormatV1 =-      floatPath . decodeWhite . decodeLocale . BC.pack . unpackPSFromUTF8+      floatPath <=< decodeWhite . decodeLocale . BC.pack . unpackPSFromUTF8     convert FileNameFormatV2 =-      floatPath . decodeWhite . decodeLocale+      floatPath <=< decodeWhite . decodeLocale     convert FileNameFormatDisplay = error "readFileName called with FileNameFormatDisplay"
src/Darcs/Patch/Rebase/Change.hs view
@@ -3,7 +3,6 @@ --  BSD3 module Darcs.Patch.Rebase.Change     ( RebaseChange(..)-    , toRebaseChanges     , extractRebaseChange     , reifyRebaseChange     , partitionUnconflicted@@ -29,7 +28,7 @@ import Darcs.Patch.Format ( PatchListFormat(..) ) import Darcs.Patch.Ident ( Ident(..), PatchId ) import Darcs.Patch.Info ( PatchInfo, patchinfo, displayPatchInfo )-import Darcs.Patch.Invert ( Invert, invert, invertFL )+import Darcs.Patch.Invert ( invert ) import Darcs.Patch.Merge ( selfMerger ) import Darcs.Patch.Named     ( Named(..)@@ -38,15 +37,16 @@     , mergerIdNamed     , patchcontents     , ShowDepsFormat(..)+    , ShowWhichDeps(..)     , showDependencies     ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, PatchInfoAndG, n2pia )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Show ( ShowPatch(..), displayPatch )+import Darcs.Patch.Show ( ShowPatch(..) ) import Darcs.Patch.Summary     ( ConflictState(..)     , IsConflictedPrim(..)@@ -71,10 +71,11 @@   , pushFixupIdMB_FLIdFLFL   ) import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(..), ShowContextPatch(..) ) import Darcs.Patch.Unwind ( Unwound(..), fullUnwind )+import Darcs.Patch.V3 ( RepoPatchV3 ) import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Show ( Show1, Show2 )@@ -82,7 +83,7 @@ import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import Darcs.Util.IsoDate ( getIsoDateTime ) import Darcs.Util.Parser ( lexString )-import Darcs.Util.Printer ( Doc, ($$), ($+$), (<+>), blueText, redText, empty, vcat )+import Darcs.Util.Printer ( Doc, ($$), (<+>), blueText )  import qualified Data.ByteString.Char8 as BC ( pack ) import Data.List ( (\\) )@@ -100,7 +101,7 @@  -- |Get hold of the 'Named' patch inside a 'RebaseChange' and wrap it in a -- 'PatchInfoAnd'.-rcToPia :: RebaseChange prim wX wY -> Sealed2 (PatchInfoAnd ('RepoType 'NoRebase) prim)+rcToPia :: RebaseChange prim wX wY -> Sealed2 (PatchInfoAnd prim) rcToPia (RC _ toEdit) = Sealed2 (n2pia toEdit)  instance PrimPatch prim => PrimPatchBase (RebaseChange prim) where@@ -143,26 +144,33 @@           unconflicted :> _ :> conflicted ->             mapFL (IsC Okay) unconflicted ++ mapFL (IsC Conflicted) conflicted -instance (ShowPatchBasic prim, Invert prim, PatchListFormat prim)-  => ShowPatchBasic (RebaseChange prim) where+instance PrimPatch prim => ShowPatchBasic (RebaseChange prim) where   showPatch ForStorage (RC fixups toedit) =     blueText "rebase-change"       <+> blueText "(" $$ showPatch ForStorage fixups $$ blueText ")"       $$ showPatch ForStorage toedit-  showPatch ForDisplay p@(RC _ (NamedP n _ _)) =-    displayPatchInfo n $$ rebaseChangeContent p+  showPatch ForDisplay rc@(RC _ (NamedP n _ _)) =+    displayPatchInfo n $$ rebaseChangeContent rc -rebaseChangeContent :: (ShowPatchBasic prim, Invert prim)-                   => RebaseChange prim wX wY -> Doc-rebaseChangeContent (RC fixups contents) =-  vcat (mapFL (showPatch ForDisplay) (patchcontents contents)) $+$-  if nullFL fixups-    then empty-    else redText "conflicts:" $+$ vcat (mapRL showFixup (invertFL fixups))-  where-    showFixup (PrimFixup p) = displayPatch p-    showFixup (NameFixup n) = displayPatch n+rebaseChangeContent+  :: forall prim wX wY . PrimPatch prim => RebaseChange prim wX wY -> Doc+rebaseChangeContent (RC fixups toedit) =+  case forceCommutes ((fixups :> WithDroppedDeps (fromPrimNamed toedit) []) ::+        (FL (RebaseFixup prim) :> WDDNamed (RepoPatchV3 prim)) wX wY) of+    WithDroppedDeps toedit' dds :> _ ->+      showDependencies ShowDroppedDeps ShowDepsVerbose dds $$+      -- eliminate leading inverse pair for display, see forceCommutePrim+      case toedit' of+        NamedP i ds (p1 :>: p2 :>: rest)+          | IsEq <- invert (effect p1) =\/= effect p2 ->+            content (NamedP i ds rest)+        _ -> content toedit' +droppedDeps :: FL (RebaseFixup prim) wX wY -> [PatchInfo]+droppedDeps NilFL = []+droppedDeps (NameFixup (AddName name) :>: fs) = name : droppedDeps fs+droppedDeps (_ :>: fs) = droppedDeps fs+ instance PrimPatch prim => ShowPatch (RebaseChange prim) where     -- This should really just call 'description' on the ToEdit patch,     -- but that introduces a spurious dependency on Summary (PrimOf p),@@ -170,18 +178,23 @@     -- the implementation from Named here.     description (RC _ (NamedP n _ _)) = displayPatchInfo n     -- TODO report conflict indicating name fixups (i.e. dropped deps)-    summary p@(RC _ (NamedP _ ds _)) =-      showDependencies ShowDepsSummary ds $$ plainSummary p+    summary p@(RC fs (NamedP _ ds _)) =+      showDependencies ShowDroppedDeps ShowDepsSummary (droppedDeps fs) $$+      showDependencies ShowNormalDeps ShowDepsSummary (ds \\ droppedDeps fs) $$+      plainSummary p     summaryFL ps =-      showDependencies ShowDepsSummary (getdepsFL ps) $$ plainSummaryFL ps+      showDependencies ShowDroppedDeps ShowDepsSummary (droppedDepsFL ps) $$+      showDependencies ShowNormalDeps ShowDepsSummary (getdepsFL ps \\ droppedDepsFL ps) $$+      plainSummaryFL ps       where         getdepsFL = nubSort . concat . mapFL getdeps+        droppedDepsFL = concat . mapFL (unseal droppedDeps . getFixups)+        getFixups (RC fs _) = Sealed fs     content = rebaseChangeContent  -- TODO this is a dummy instance that does not actually show context-instance (ShowPatchBasic prim, Invert prim, PatchListFormat prim)-  => ShowContextPatch (RebaseChange prim) where-    showContextPatch f p = return $ showPatch f p+instance PrimPatch prim => ShowContextPatch (RebaseChange prim) where+    showPatchWithContextAndApply f p = apply p >> return (showPatch f p)  instance (ReadPatch prim, PatchListFormat prim) => ReadPatch (RebaseChange prim) where   readPatch' = do@@ -191,11 +204,6 @@     lexString (BC.pack ")")     Sealed contents <- readPatch'     return $ Sealed $ RC fixups contents--toRebaseChanges-    :: FL (RebaseChange prim) wX wY-    -> FL (PatchInfoAndG ('RepoType 'IsRebase) (RebaseChange prim)) wX wY-toRebaseChanges = mapFL_FL n2pia  instance Commute prim => Commute (RebaseChange prim) where   commute (RC fixups1 edit1 :> RC fixups2 edit2) = do
src/Darcs/Patch/Rebase/Fixup.hs view
@@ -53,7 +53,7 @@   PrimFixup :: prim wX wY -> RebaseFixup prim wX wY   NameFixup :: RebaseName wX wY -> RebaseFixup prim wX wY -namedToFixups :: (PrimPatch (PrimOf p), Effect p) => Named p wX wY -> FL (RebaseFixup (PrimOf p)) wX wY+namedToFixups :: Effect p => Named p wX wY -> FL (RebaseFixup (PrimOf p)) wX wY namedToFixups (NamedP p _ contents) = NameFixup (AddName p) :>: mapFL_FL PrimFixup (effect contents)  instance Show2 prim => Show (RebaseFixup prim wX wY) where
src/Darcs/Patch/Rebase/Legacy/Item.hs view
@@ -51,18 +51,16 @@  instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p) -toRebaseChanges-  :: forall p wX wY-   . RepoPatch p-  => FL (RebaseItem p) wX wY-  -> Sealed (FL (RebaseChange (PrimOf p)) wX)+toRebaseChanges :: RepoPatch p+                => FL (RebaseItem p) wX wY+                -> Sealed (FL (RebaseChange (PrimOf p)) wX) toRebaseChanges NilFL = Sealed NilFL toRebaseChanges (Fixup f :>: ps) =     case toRebaseChanges ps of       Sealed (RC fixups toedit :>: rest) -> Sealed (RC (f :>: fixups) toedit :>: rest)       Sealed NilFL -> error "rebase chain with Fixup at end" toRebaseChanges (ToEdit te :>: ps) =-  unseal (addNamedToRebase @p D.MyersDiff te) (toRebaseChanges ps)+  unseal (addNamedToRebase D.MyersDiff te) (toRebaseChanges ps)  -- This Read instance partly duplicates the instances for RebaseFixup, -- but are left this way given this code is now here only for backwards compatibility of the on-disk
+ src/Darcs/Patch/Rebase/Legacy/Wrapped.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.Rebase.Legacy.Wrapped+  ( WrappedNamed(..)+  , fromRebasing+  ) where++import Darcs.Prelude++import Control.Applicative ( (<|>) )+import Data.Coerce ( coerce )++import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Format ( PatchListFormat(..), ListFormat )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.FromPrim ( FromPrim, PrimPatchBase(..) )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Rebase.Suspended ( Suspended, readSuspended )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL )++-- |A patch that lives in a repository where an old-style rebase is in+-- progress. Such a repository will consist of @Normal@ patches+-- along with exactly one @Suspended@ patch.+--+-- It is here only so that we can upgrade an old-style rebase.+--+-- @NormalP@ represents a normal patch within a respository where a+-- rebase is in progress. @NormalP p@ is given the same on-disk+-- representation as @p@, so a repository can be switched into+-- and out of rebasing mode simply by adding or removing a+-- @RebaseP@ patch and setting the appropriate format flag.+--+-- Note that the witnesses are such that the @RebaseP@+-- patch has no effect on the context of the rest of the+-- repository; in a sense the patches within it are+-- dangling off to one side from the main repository.+data WrappedNamed p wX wY where+  NormalP :: !(Named p wX wY) -> WrappedNamed p wX wY+  RebaseP+    :: (PrimPatchBase p, FromPrim p, Effect p)+    => !PatchInfo+    -> !(Suspended p wX)+    -> WrappedNamed p wX wX++fromRebasing :: WrappedNamed p wX wY -> Named p wX wY+fromRebasing (NormalP n) = n+fromRebasing (RebaseP {}) = error "internal error: found rebasing internal patch"++-- This is a local hack to maintain backwards compatibility with+-- the on-disk format for rebases. Previously the rebase container+-- was internally represented via a 'Rebasing' type that sat *inside*+-- a 'Named', and so the rebase container patch had the structure+-- 'NamedP i [] (Suspendended s :>: NilFL)'. This structure was reflected+-- in the way it was saved on disk.+-- The easiest to read this structure is to use an intermediate type+-- that reflects the old structure.+-- Cleaning this up is obsolete since this module is only here for upgrading+-- the legacy rebase format where the rebase patch was mixed in with regular+-- patches.+data ReadRebasing p wX wY where+  ReadNormal    :: p wX wY -> ReadRebasing p wX wY+  ReadSuspended :: Suspended p wX -> ReadRebasing p wX wX++instance RepoPatch p => ReadPatch (WrappedNamed p) where+  readPatch' = fmap (mapSeal wrapNamed) readPatch' where++    wrapNamed :: Named (ReadRebasing p) wX wY -> WrappedNamed p wX wY+    wrapNamed (NamedP i [] (ReadSuspended s :>: NilFL)) = RebaseP i s+    wrapNamed (NamedP i deps ps) = NormalP (NamedP i deps (mapFL_FL unRead ps))++    unRead (ReadNormal p) = p+    unRead (ReadSuspended _) = error "unexpected suspended patch"++instance PatchListFormat p => PatchListFormat (ReadRebasing p) where+  patchListFormat = coerce (patchListFormat :: ListFormat p)++instance RepoPatch p => ReadPatch (ReadRebasing p) where+  readPatch' =+    Sealed . ReadSuspended <$> readSuspended <|> mapSeal ReadNormal <$> readPatch'
src/Darcs/Patch/Rebase/Suspended.hs view
@@ -4,117 +4,99 @@     , countToEdit, simplifyPush, simplifyPushes     , addFixupsToSuspended, removeFixupsFromSuspended     , addToEditsToSuspended+    , readSuspended+    , showSuspended     ) where  import Darcs.Prelude  import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.Format ( PatchListFormat(..) ) import Darcs.Patch.Invert ( invert ) import Darcs.Patch.Named ( Named(..) )-import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Info ( replaceJunk )-import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim(..), FromPrim(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase(..) ) import Darcs.Patch.Read ( bracketedFL ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), namedToFixups ) import Darcs.Patch.Rebase.Name ( RebaseName(..) ) import Darcs.Patch.RepoPatch ( RepoPatch ) import qualified Darcs.Patch.Rebase.Change as Change ( simplifyPush, simplifyPushes ) import Darcs.Patch.Rebase.Change ( RebaseChange(..), addNamedToRebase )-import qualified Darcs.Patch.Rebase.Legacy.Item as Item ( toRebaseChanges, RebaseItem )-import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Util.Parser ( lexString, lexWord )+import Darcs.Patch.Rebase.Legacy.Item as Item ( toRebaseChanges )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor )+import Darcs.Util.Parser ( Parser, lexString, lexWord ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Show ( Show1, Show2 )-import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) )+import Darcs.Patch.Witnesses.Show ( Show2 )+import Darcs.Util.Printer ( Doc, vcat, text, blueText, ($$), (<+>) ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )  import Control.Applicative ( (<|>) ) import qualified Data.ByteString.Char8 as BC ( pack ) --- | A single @Suspended@ patch contains the entire rebase state, in the form--- of 'RebaseItem's.--- --- The witnesses are such that a @Suspended@ appears to have no effect.--- This behaviour is only kept so we can read old-style rebase patches,--- where the entire rebase state was kept in a single patch on disk.----data Suspended p wX wY where-    Items :: FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX wX--deriving instance (Show2 p, Show2 (PrimOf p)) => Show (Suspended p wX wY)--instance (Show2 p, Show2 (PrimOf p)) => Show1 (Suspended p wX)--instance (Show2 p, Show2 (PrimOf p)) => Show2 (Suspended p)+-- | A @Suspended@ patch contains the entire rebase state, in the form+-- of 'RebaseChange's. The end state is existientially quantified and+-- thus hidden.+data Suspended p wX where+    Items :: FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX -instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Suspended p) where-  listTouchedFiles (Items ps) = listTouchedFiles ps-  hunkMatches f (Items ps) = hunkMatches f ps+deriving instance (Show2 p, Show2 (PrimOf p)) => Show (Suspended p wX) -instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where-   showPatch f (Items ps)+showSuspended :: PrimPatchBase p+              => ShowPatchFor -> Suspended p wX -> Doc+showSuspended f (Items ps)        = blueText "rebase" <+> text "0.2" <+> blueText "{"          $$ vcat (mapFL (showPatch f) ps)          $$ blueText "}" -instance (PrimPatchBase p, PatchListFormat p, ReadPatch p, RepoPatch p) => ReadPatch (Suspended p) where-   readPatch' =+readSuspended :: forall p wX. RepoPatch p => Parser (Suspended p wX)+readSuspended =     do lexString (BC.pack "rebase")        version <- lexWord        case () of          _ | version == BC.pack "0.2" ->-              (lexString (BC.pack "{}") >> return (seal (Items NilFL)))-                <|>-                (unseal (Sealed . Items) <$> bracketedFL readPatch' '{' '}')+              (lexString (BC.pack "{}") >> return (Items NilFL))+              <|>+              (unseal Items <$> bracketedFL readPatch' '{' '}')            -- version 0.1 was a very temporary intermediate state on the way to 0.2            -- and we don't offer an upgrade path for it.            | version == BC.pack "0.0" ->-               -- Note that if we have an "old-style" rebase, i.e. the first rebase implementation in-               -- darcs, characterised by the format string "rebase-in-progress", then only version-               -- 0.0 is possible here. On the other hand, the more recent implementation could use any-               -- version including 0.0.-               -- Unlike version 0.2, version 0.0 rebase patches on disk can contain conflicts. These are-               -- removed when reading by Item.toRebaseChanges, which ultimately calls 'fullUnwind', the-               -- same machinery that is used when version 0.2 patches are created from scratch.-               let-                 itemsToSuspended :: Sealed (FL (Item.RebaseItem p) wX) -> Sealed (Suspended p wX)-                 itemsToSuspended (Sealed ps) =-                   case Item.toRebaseChanges ps of-                     Sealed ps' -> Sealed (Items ps')-               in-               (lexString (BC.pack "{}") >> return (seal (Items NilFL)))-                <|>-                itemsToSuspended <$> bracketedFL readPatch' '{' '}'+               -- Note that if we have an "old-style" rebase, i.e. the first+               -- rebase implementation in darcs, characterised by the format+               -- string "rebase-in-progress", then only version 0.0 is+               -- possible here. On the other hand, the more recent+               -- implementation could use any version including 0.0.+               -- Unlike version 0.2, version 0.0 rebase patches on disk can+               -- contain conflicts. These are removed when reading by+               -- Item.toRebaseChanges, which ultimately calls 'fullUnwind',+               -- the same machinery that is used when version 0.2 patches are+               -- created from scratch.+               (lexString (BC.pack "{}") >> return (Items NilFL))+               <|>+               (unseal Items . unseal (Item.toRebaseChanges @p) <$>+                bracketedFL readPatch' '{' '}')            | otherwise -> error $ "can't handle rebase version " ++ show version -countToEdit :: Suspended p wX wY -> Int+countToEdit :: Suspended p wX -> Int countToEdit (Items ps) = lengthFL ps -onSuspended-  :: (forall wZ . FL (RebaseChange (PrimOf p)) wY wZ -> Sealed (FL (RebaseChange (PrimOf p)) wX))-  -> Suspended p wY wY-  -> Suspended p wX wX-onSuspended f (Items ps) = unseal Items (f ps)- -- |add fixups for the name and effect of a patch to a 'Suspended' addFixupsToSuspended-  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)+  :: (PrimPatchBase p, Effect p)   => Named p wX wY-  -> Suspended p wY wY-  -> Suspended p wX wX+  -> Suspended p wY+  -> Suspended p wX addFixupsToSuspended p = simplifyPushes D.MyersDiff (namedToFixups p) --- |remove fixups (actually, add their inverse) for the name and effect of a patch to a 'Suspended'+-- | Remove fixups (actually, add their inverse) for the name and effect of+-- a patch to a 'Suspended'. removeFixupsFromSuspended-  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)+  :: (PrimPatchBase p, Effect p)   => Named p wX wY-  -> Suspended p wX wX-  -> Suspended p wY wY-removeFixupsFromSuspended p = simplifyPushes D.MyersDiff (invert (namedToFixups p))+  -> Suspended p wX+  -> Suspended p wY+removeFixupsFromSuspended p =+  simplifyPushes D.MyersDiff (invert (namedToFixups p))  -- | Add 'Named' patches for editing to a 'Suspended'. The patches to be -- suspended are renamed by replacing the junk in their 'Patchinfo'.@@ -131,29 +113,31 @@   :: RepoPatch p   => D.DiffAlgorithm   -> FL (Named p) wX wY-  -> Suspended p wY wY-  -> IO (Suspended p wX wX)+  -> Suspended p wY+  -> IO (Suspended p wX) addToEditsToSuspended _ NilFL items = return items addToEditsToSuspended da (NamedP old ds ps :>: qs) items = do-  items' <- addToEditsToSuspended da qs items+  Items items' <- addToEditsToSuspended da qs items   new <- replaceJunk old-  case simplifyPush da (NameFixup (Rename new old)) items' of-    Items items'' ->-      case addNamedToRebase da (NamedP new ds ps) items'' of-        Sealed items''' -> return $ Items items'''+  return $+    unseal Items $+    unseal (addNamedToRebase da (NamedP new ds ps)) $+    Change.simplifyPush da (NameFixup (Rename new old)) items'  simplifyPush-  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)+  :: PrimPatchBase p   => D.DiffAlgorithm   -> RebaseFixup (PrimOf p) wX wY-  -> Suspended p wY wY-  -> Suspended p wX wX-simplifyPush da fixups = onSuspended (Change.simplifyPush da fixups)+  -> Suspended p wY+  -> Suspended p wX+simplifyPush da fixups (Items ps) =+  unseal Items (Change.simplifyPush da fixups ps)  simplifyPushes-  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)+  :: PrimPatchBase p   => D.DiffAlgorithm   -> FL (RebaseFixup (PrimOf p)) wX wY-  -> Suspended p wY wY-  -> Suspended p wX wX-simplifyPushes da fixups = onSuspended (Change.simplifyPushes da fixups)+  -> Suspended p wY+  -> Suspended p wX+simplifyPushes da fixups (Items ps) =+  unseal Items (Change.simplifyPushes da fixups ps)
src/Darcs/Patch/Repair.hs view
@@ -16,19 +16,20 @@     isInconsistent :: p wX wY -> Maybe Doc     isInconsistent _ = Nothing --- |'Repair' and 'RepairToFL' deal with repairing old patches that were--- were written out due to bugs or that we no longer wish to support.--- 'Repair' is implemented by collections of patches (FL, Named, PatchInfoAnd) that--- might need repairing.+-- |'Repair' and 'RepairToFL' deal with repairing old patches that were were+-- written out due to bugs or that we no longer wish to support. 'Repair' is+-- implemented by collections of patches (FL, Named, PatchInfoAnd) that might+-- need repairing. class Repair p where-    applyAndTryToFix :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, p wX wY))+    applyAndTryToFix+      :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, p wX wY)) --- |'RepairToFL' is implemented by single patches that can be repaired (Prim, Patch, RepoPatchV2)--- There is a default so that patch types with no current legacy problems don't need to--- have an implementation.+-- |'RepairToFL' is implemented by single patches that can be repaired (Prim,+-- Patch, RepoPatchV2) There is a default so that patch types with no current+-- legacy problems don't need to have an implementation. class Apply p => RepairToFL p where-    applyAndTryToFixFL :: ApplyMonad (ApplyState p) m-                       => p wX wY -> m (Maybe (String, FL p wX wY))+    applyAndTryToFixFL+      :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, FL p wX wY))     applyAndTryToFixFL p = do apply p; return Nothing  mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b)@@ -43,12 +44,13 @@  instance RepairToFL p => Repair (FL p) where     applyAndTryToFix NilFL = return Nothing-    applyAndTryToFix (p:>:ps) = do mp <- applyAndTryToFixFL p-                                   mps <- applyAndTryToFix ps-                                   return $ case (mp,mps) of-                                            (Nothing, Nothing) -> Nothing-                                            (Just (e,p'),Nothing) -> Just (e,p'+>+ps)-                                            (Nothing, Just (e,ps')) -> Just (e,p:>:ps')-                                            (Just (e,p'), Just (es,ps')) ->-                                                Just (unlines [e,es], p'+>+ps')+    applyAndTryToFix (p :>: ps) = do+      mp <- applyAndTryToFixFL p+      mps <- applyAndTryToFix ps+      return $+        case (mp, mps) of+          (Nothing, Nothing) -> Nothing+          (Just (e, p'), Nothing) -> Just (e, p' +>+ ps)+          (Nothing, Just (e, ps')) -> Just (e, p :>: ps')+          (Just (e, p'), Just (es, ps')) -> Just (e ++ "\n" ++ es, p' +>+ ps')
− src/Darcs/Patch/RepoType.hs 
@@ -1,48 +0,0 @@-module Darcs.Patch.RepoType-  ( RepoType(..), IsRepoType(..), SRepoType(..)-  , RebaseType(..), IsRebaseType, RebaseTypeOf, SRebaseType(..)-  ) where---- |This type is intended to be used as a phantom type via--- the 'DataKinds' extension, normally as part of 'RepoType'.--- Indicates whether or not a rebase is in progress.-data RebaseType = IsRebase | NoRebase---- |A reflection of 'RebaseType' at the value level so that--- code can explicitly switch on it.-data SRebaseType (rebaseType :: RebaseType) where-  SIsRebase :: SRebaseType 'IsRebase-  SNoRebase :: SRebaseType 'NoRebase--class IsRebaseType (rebaseType :: RebaseType) where-  -- |Reflect 'RebaseType' to the value level so that-  -- code can explicitly switch on it.-  singletonRebaseType :: SRebaseType rebaseType--instance IsRebaseType 'IsRebase where-  singletonRebaseType = SIsRebase--instance IsRebaseType 'NoRebase where-  singletonRebaseType = SNoRebase---- |This type is intended to be used as a phantom type via the 'DataKinds'--- extension. It tracks different types of repositories, e.g. to--- indicate when a rebase is in progress.-data RepoType = RepoType { rebaseType :: RebaseType }---- |Extract the 'RebaseType' from a 'RepoType'-type family RebaseTypeOf (rt :: RepoType) :: RebaseType-type instance RebaseTypeOf ('RepoType rebaseType) = rebaseType--class IsRepoType (rt :: RepoType) where-  -- |Reflect 'RepoType' to the value level so that-  -- code can explicitly switch on it.-  singletonRepoType :: SRepoType rt---- |A reflection of 'RepoType' at the value level so that--- code can explicitly switch on it.-data SRepoType (repoType :: RepoType) where-  SRepoType :: SRebaseType rebaseType -> SRepoType ('RepoType rebaseType)--instance IsRebaseType rebaseType => IsRepoType ('RepoType rebaseType) where-  singletonRepoType = SRepoType singletonRebaseType
src/Darcs/Patch/Set.hs view
@@ -21,6 +21,7 @@     , SealedPatchSet     , Origin     , progressPatchSet+    , patchSetInventoryHashes     , patchSetTags     , emptyPatchSet     , appendPSFL@@ -34,7 +35,9 @@  import Darcs.Prelude import Data.Maybe ( catMaybes )+import qualified Data.Set as S +import Darcs.Patch.Ident ( Ident(..), PatchId ) import Darcs.Patch.Info ( PatchInfo, piTag ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )@@ -44,11 +47,12 @@ import Darcs.Patch.Witnesses.Show ( Show1, Show2 )  import Darcs.Util.Progress ( progress )+import Darcs.Util.ValidHash ( InventoryHash )  -- |'Origin' is a type used to represent the initial context of a repo. data Origin -type SealedPatchSet rt p wStart = Sealed ((PatchSet rt p) wStart)+type SealedPatchSet p wStart = Sealed ((PatchSet p) wStart)  -- |The patches in a repository are stored in chunks broken up at \"clean\" -- tags. A tag is clean if the only patches before it in the current@@ -65,93 +69,100 @@ -- -- The history is lazily loaded from disk so does not normally need to be all -- kept in memory.-data PatchSet rt p wStart wY where-    PatchSet :: RL (Tagged rt p) Origin wX -> RL (PatchInfoAnd rt p) wX wY-             -> PatchSet rt p Origin wY+data PatchSet p wStart wY where+    PatchSet :: RL (Tagged p) Origin wX -> RL (PatchInfoAnd p) wX wY+             -> PatchSet p Origin wY -deriving instance Show2 p => Show (PatchSet rt p wStart wY)+deriving instance Show2 p => Show (PatchSet p wStart wY) -instance Show2 p => Show1 (PatchSet rt p wStart)+instance Show2 p => Show1 (PatchSet p wStart) -instance Show2 p => Show2 (PatchSet rt p)+instance Show2 p => Show2 (PatchSet p) +type instance PatchId (PatchSet p) = S.Set PatchInfo -emptyPatchSet :: PatchSet rt p Origin Origin+instance Ident (PatchSet p) where+  ident = S.fromList . mapRL ident . patchSet2RL++emptyPatchSet :: PatchSet p Origin Origin emptyPatchSet = PatchSet NilRL NilRL  -- |A 'Tagged' is a single chunk of a 'PatchSet'. -- It has a 'PatchInfo' representing a clean tag, -- the hash of the previous inventory (if it exists), -- and the list of patches since that previous inventory.-data Tagged rt p wX wZ where-    Tagged :: PatchInfoAnd rt p wY wZ -> Maybe String-           -> RL (PatchInfoAnd rt p) wX wY -> Tagged rt p wX wZ+data Tagged p wX wZ where+    Tagged :: RL (PatchInfoAnd p) wX wY -> PatchInfoAnd p wY wZ -> Maybe InventoryHash+           -> Tagged p wX wZ -deriving instance Show2 p => Show (Tagged rt p wX wZ)+deriving instance Show2 p => Show (Tagged p wX wZ) -instance Show2 p => Show1 (Tagged rt p wX)+instance Show2 p => Show1 (Tagged p wX) -instance Show2 p => Show2 (Tagged rt p)+instance Show2 p => Show2 (Tagged p)   -- |'patchSet2RL' takes a 'PatchSet' and returns an equivalent, linear 'RL' of -- patches.-patchSet2RL :: PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX+patchSet2RL :: PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX patchSet2RL (PatchSet ts ps) = concatRL (mapRL_RL ts2rl ts) +<+ ps   where-    ts2rl :: Tagged rt p wY wZ -> RL (PatchInfoAnd rt p) wY wZ-    ts2rl (Tagged t _ ps2) = ps2 :<: t+    ts2rl :: Tagged p wY wZ -> RL (PatchInfoAnd p) wY wZ+    ts2rl (Tagged ps2 t _) = ps2 :<: t  -- |'patchSet2FL' takes a 'PatchSet' and returns an equivalent, linear 'FL' of -- patches.-patchSet2FL :: PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX+patchSet2FL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX patchSet2FL = reverseRL . patchSet2RL  -- |'appendPSFL' takes a 'PatchSet' and a 'FL' of patches that "follow" the -- PatchSet, and concatenates the patches into the PatchSet.-appendPSFL :: PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wX wY-           -> PatchSet rt p wStart wY+appendPSFL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wX wY+           -> PatchSet p wStart wY appendPSFL (PatchSet ts ps) newps = PatchSet ts (ps +<<+ newps)  -- |Runs a progress action for each tag and patch in a given PatchSet, using -- the passed progress message. Does not alter the PatchSet.-progressPatchSet :: String -> PatchSet rt p wStart wX -> PatchSet rt p wStart wX+progressPatchSet :: String -> PatchSet p wStart wX -> PatchSet p wStart wX progressPatchSet k (PatchSet ts ps) =     PatchSet (mapRL_RL progressTagged ts) (mapRL_RL prog ps)   where     prog = progress k -    progressTagged :: Tagged rt p wY wZ -> Tagged rt p wY wZ-    progressTagged (Tagged t h tps) = Tagged (prog t) h (mapRL_RL prog tps)+    progressTagged :: Tagged p wY wZ -> Tagged p wY wZ+    progressTagged (Tagged tps t h) = Tagged (mapRL_RL prog tps) (prog t) h +patchSetInventoryHashes :: PatchSet p wX wY -> [Maybe InventoryHash]+patchSetInventoryHashes (PatchSet ts _) = mapRL (\(Tagged _ _ mh) -> mh) ts+ -- | The tag names of /all/ tags of a given 'PatchSet'.-patchSetTags :: PatchSet rt p wX wY -> [String]+patchSetTags :: PatchSet p wX wY -> [String] patchSetTags = catMaybes . mapRL (piTag . info) . patchSet2RL -inOrderTags :: PatchSet rt p wS wX -> [PatchInfo]+inOrderTags :: PatchSet p wS wX -> [PatchInfo] inOrderTags (PatchSet ts _) = go ts-  where go :: RL(Tagged rt t1) wT wY -> [PatchInfo]-        go (ts' :<: Tagged t _ _) = info t : go ts'+  where go :: RL(Tagged t1) wT wY -> [PatchInfo]+        go (ts' :<: Tagged _ t _) = info t : go ts'         go NilRL = [] -patchSetSnoc :: PatchSet rt p wX wY -> PatchInfoAnd rt p wY wZ -> PatchSet rt p wX wZ+patchSetSnoc :: PatchSet p wX wY -> PatchInfoAnd p wY wZ -> PatchSet p wX wZ patchSetSnoc (PatchSet ts ps) p = PatchSet ts (ps :<: p)  -- | Split a 'PatchSet' /before/ the latest known clean tag. The left part -- is what comes before the tag, the right part is the tag and its -- non-dependencies.-patchSetSplit :: PatchSet rt p wX wY-              -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) wX wY-patchSetSplit (PatchSet (ts :<: Tagged t _ ps') ps) =+patchSetSplit :: PatchSet p wX wY+              -> (PatchSet p :> RL (PatchInfoAnd p)) wX wY+patchSetSplit (PatchSet (ts :<: Tagged ps' t _) ps) =   PatchSet ts ps' :> ((NilRL :<: t) +<+ ps) patchSetSplit (PatchSet NilRL ps) = PatchSet NilRL NilRL :> ps  -- | Drop the last @n@ patches from the given 'PatchSet'. patchSetDrop :: Int-             -> PatchSet rt p wStart wX-             -> SealedPatchSet rt p wStart+             -> PatchSet p wStart wX+             -> SealedPatchSet p wStart patchSetDrop n ps | n <= 0 = Sealed ps-patchSetDrop n (PatchSet (ts :<: Tagged t _ ps) NilRL) =+patchSetDrop n (PatchSet (ts :<: Tagged ps t _) NilRL) =   patchSetDrop n $ PatchSet ts (ps :<: t) patchSetDrop _ (PatchSet NilRL NilRL) = Sealed $ PatchSet NilRL NilRL patchSetDrop n (PatchSet ts (ps :<: _)) = patchSetDrop (n - 1) $ PatchSet ts ps
src/Darcs/Patch/Show.hs view
@@ -21,22 +21,19 @@      , ShowPatchFor(..)      , ShowPatch(..)      , ShowContextPatch(..)+     , showPatchWithContext      , formatFileName      ) where  import Darcs.Prelude -import qualified Data.ByteString.Char8 as BC ( unpack )- import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.ApplyMonad ( ApplyMonad )-import Darcs.Patch.Format ( FileNameFormat(..) )+import Darcs.Patch.ApplyMonad ( ApplyMonad, ApplyMonadTrans, evalApplyMonad )+import Darcs.Patch.Object ( formatFileName ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) -import Darcs.Util.ByteString ( packStringToUTF8, encodeLocale ) import Darcs.Util.English ( plural, Noun(Noun) )-import Darcs.Util.Path ( AnchoredPath, encodeWhite, anchorPath )-import Darcs.Util.Printer ( Doc, vcat, text, packedString )+import Darcs.Util.Printer ( Doc, vcat )  data ShowPatchFor = ForDisplay | ForStorage @@ -46,14 +43,31 @@ class ShowPatchBasic p where     showPatch :: ShowPatchFor -> p wX wY -> Doc +-- | Like 'showPatchWithContextAndApply' but without applying the patch+-- in the monad @m@.+showPatchWithContext+    :: (ApplyMonadTrans (ApplyState p) m, ShowContextPatch p)+    => ShowPatchFor+    -> ApplyState p m+    -> p wX wY+    -> m Doc+showPatchWithContext f st p =+    evalApplyMonad (showPatchWithContextAndApply f p) st+ class ShowPatchBasic p => ShowContextPatch p where-    -- | showContextPatch is used to add context to a patch, as diff-    -- -u does. Thus, it differs from showPatch only for hunks. It is-    -- used for instance before putting it into a bundle. As this-    -- unified context is not included in patch representation, this-    -- requires access to the tree.-    showContextPatch :: (ApplyMonad (ApplyState p) m)-                     => ShowPatchFor -> p wX wY -> m Doc+    -- | Show a patch with context lines added, as diff -u does. Thus, it+    -- differs from showPatch only for hunks. It is used for instance before+    -- putting it into a bundle. As this unified context is not included in+    -- patch representation, this requires access to the 'ApplyState'.+    --+    -- Note that this applies the patch in the 'ApplyMonad' given by the+    -- context. This is done in order to simplify showing multiple patches in a+    -- series, since each patch may change the context lines for later changes.+    --+    -- For a version that does not apply the patch see 'showPatchWithContext'.+    showPatchWithContextAndApply+        :: (ApplyMonad (ApplyState p) m)+        => ShowPatchFor -> p wX wY -> m Doc  -- | This class is used only for user interaction, not for storage. The default -- implementations for 'description' and 'content' are suitable only for@@ -78,23 +92,3 @@      things :: p wX wY -> String     things x = plural (Noun $ thing x) ""---- | Format a 'AnchoredPath' to a 'Doc' according to the given 'FileNameFormat'.------ NOTE: This is not only used for display but also to format patch files. This is---       why we have to do the white space encoding here.---       See 'Darcs.Repository.Hashed.writePatchIfNecessary'.------ Besides white space encoding, for 'FileNameFormatV2' we just pack it into a 'Doc'. For--- 'FileNameFormatV1' we must emulate the non-standard darcs-1 encoding of file paths: it--- is an UTF8 encoding of the raw byte stream, interpreted as code points.------ See also 'Darcs.Patch.Show.readFileName'.-formatFileName :: FileNameFormat -> AnchoredPath -> Doc-formatFileName FileNameFormatV1 = packedString . packStringToUTF8 . BC.unpack .-                            encodeLocale . encodeWhite . ap2fp-formatFileName FileNameFormatV2 = text . encodeWhite . ap2fp-formatFileName FileNameFormatDisplay = text . ap2fp--ap2fp :: AnchoredPath -> FilePath-ap2fp ap = '.' : '/' : anchorPath "" ap
src/Darcs/Patch/Split.hs view
@@ -37,11 +37,12 @@ import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed +import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.Show ( showPatch, ShowPatch(..) ) import Darcs.Patch.Invert( Invert(..), invertFL )-import Darcs.Patch.Prim ( PrimPatch, canonize, canonizeFL, primFromHunk )+import Darcs.Patch.Prim ( PrimPatch, canonizeFL, primFromHunk ) import Darcs.Util.Parser ( parse ) import Darcs.Patch.Read () import Darcs.Patch.Show ( ShowPatchFor(ForDisplay) )@@ -133,7 +134,7 @@         , ""         ] -doPrimSplit_ :: (PrimPatch prim, IsHunk p)+doPrimSplit_ :: forall prim p wX wY. (PrimPatch prim, IsHunk p, ApplyState p ~ ApplyState prim)              => D.DiffAlgorithm              -> Bool              -> [B.ByteString]@@ -157,8 +158,8 @@                      then hunk before before' +>+ hunk before' after' +>+ hunk after' after                      else hunk before after' +>+ hunk after' after)     where sep = BC.pack "=========================="-          hunk :: PrimPatch prim => [B.ByteString] -> [B.ByteString] -> FL prim wA wB-          hunk b a = canonize da (primFromHunk (FileHunk fn n b a))+          hunk :: [B.ByteString] -> [B.ByteString] -> FL prim wA wB+          hunk b a = canonizeFL da (primFromHunk (FileHunk fn n b a) :>: NilFL)           mkSep s = BC.append sep (BC.pack s)           breakSep xs = case break (sep `BC.isPrefixOf`) xs of                            (_, []) -> Nothing
src/Darcs/Patch/TokenReplace.hs view
@@ -37,9 +37,9 @@ tryTokReplace :: String -> B.ByteString -> B.ByteString               -> B.ByteString -> Maybe B.ByteString tryTokReplace tokChars old new-  | B.null old = error "tryTokInternal called with empty old token"-  | BC.any (not . isTokChar) old = error "tryTokInternal called with old non-token"-  | BC.any (not . isTokChar) new = error "tryTokInternal called with new non-token"+  | B.null old = error "tryTokReplace called with empty old token"+  | BC.any (not . isTokChar) old = error "tryTokReplace called with old non-token"+  | BC.any (not . isTokChar) new = error "tryTokReplace called with new non-token"   | otherwise = fmap B.concat . loop 0     where       isTokChar = regChars tokChars@@ -60,9 +60,9 @@ forceTokReplace :: String -> B.ByteString -> B.ByteString                 -> B.ByteString -> B.ByteString forceTokReplace tokChars old new-  | B.null old = error "tryTokInternal called with empty old token"-  | BC.any (not . isTokChar) old = error "tryTokInternal called with old non-token"-  | BC.any (not . isTokChar) new = error "tryTokInternal called with new non-token"+  | B.null old = error "forceTokReplace called with empty old token"+  | BC.any (not . isTokChar) old = error "forceTokReplace called with old non-token"+  | BC.any (not . isTokChar) new = error "forceTokReplace called with new non-token"   | otherwise = B.concat . loop 0     where       isTokChar = regChars tokChars
src/Darcs/Patch/V1.hs view
@@ -1,7 +1,5 @@ module Darcs.Patch.V1 ( RepoPatchV1 ) where -import Darcs.Patch.Annotate ()- import Darcs.Patch.V1.Apply () import Darcs.Patch.V1.Commute () import Darcs.Patch.V1.Core ( RepoPatchV1 )
src/Darcs/Patch/V1/Commute.hs view
@@ -16,6 +16,7 @@ --  Boston, MA 02110-1301, USA.  {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Darcs.Patch.V1.Commute     (@@ -31,9 +32,9 @@ import Control.Applicative ( Alternative(..) ) import Data.Maybe ( fromMaybe ) +import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdFL, commuterFLId )-import Darcs.Util.Path ( AnchoredPath ) import Darcs.Patch.Invert ( invertRL ) import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) ) import Darcs.Patch.Commute ( Commute(..) )@@ -52,15 +53,15 @@ import Darcs.Patch.Unwind ( Unwind(..), Unwound(..), mkUnwound ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Prim ( PrimPatch, is_filepatch )+import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Permutations     ( headPermutationsRL     , simpleHeadPermutationsFL     , removeFL+    , nubFL     ) import Darcs.Util.Printer ( renderString, text, vcat, ($$) ) import Darcs.Patch.V1.Show ( showPatch_ )-import Data.List ( nub ) import Data.List.Ordered ( nubSort ) import Darcs.Patch.Summary     ( Summary(..)@@ -102,7 +103,7 @@     (Succeeded x) >>= k =  k x     Failed   >>= _      =  Failed     Unknown  >>= _      =  Unknown-    return              =  Succeeded+    return              =  pure  instance Alternative Perhaps where     empty = Unknown@@ -139,15 +140,6 @@                  Failed -> Failed                  Unknown -> Unknown --- | If we have two Filepatches which modify different files, we can return a--- result early, since the patches trivially commute.-speedyCommute :: PrimPatch prim => CommuteFunction prim-speedyCommute (p1 :> p2)-    | Just m1 <- isFilepatchMerger p1-    , Just m2 <- isFilepatchMerger p2-    , m1 /= m2 = Succeeded (unsafeCoerceP p2 :> unsafeCoerceP p1)-    | otherwise = Unknown- everythingElseCommute :: forall prim . PrimPatch prim => CommuteFunction prim everythingElseCommute (PP p1 :> PP p2) = toPerhaps $ do     p2' :> p1' <- commute (p1 :> p2)@@ -199,8 +191,7 @@  instance PrimPatch prim => Commute (RepoPatchV1 prim) where     commute x = toMaybe $ msum-                  [speedyCommute x,-                   (cleverCommute mergerCommute) x,+                  [(cleverCommute mergerCommute) x,                    everythingElseCommute x                   ] @@ -215,15 +206,6 @@     hunkMatches f c@(Regrem{}) = hunkMatches f $ invert c     hunkMatches f (PP p) = hunkMatches f p -isFilepatchMerger :: PrimPatch prim => RepoPatchV1 prim wX wY -> Maybe AnchoredPath-isFilepatchMerger (PP p) = is_filepatch p-isFilepatchMerger (Merger _ _ p1 p2) = do-     f1 <- isFilepatchMerger p1-     f2 <- isFilepatchMerger p2-     if f1 == f2 then return f1 else Nothing-isFilepatchMerger (Regrem und unw p1 p2)-    = isFilepatchMerger (Merger und unw p1 p2)- commuteRecursiveMerger :: PrimPatch prim     => (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY) commuteRecursiveMerger (pA :> p@(Merger _ _ p1 p2)) = toPerhaps $@@ -345,12 +327,11 @@ putBefore _ NilFL = Just (unsafeCoerceP NilFL)  instance PrimPatch prim => CommuteNoConflicts (RepoPatchV1 prim) where-  commuteNoConflicts x =-    toMaybe $ msum [ speedyCommute x-                   , everythingElseCommute x-                   ]+  commuteNoConflicts x = toMaybe $ everythingElseCommute x  instance PrimPatch prim => Conflict (RepoPatchV1 prim) where+  isConflicted (PP _) = False+  isConflicted _ = True   resolveConflicts _ = map mangleOrFail . combineConflicts resolveOne     where       resolveOne p | isMerger p = [publicUnravel p]@@ -389,7 +370,7 @@   fromMaybe (p :>: ps') $ removeFL (invert p) ps'  unravel :: PrimPatch prim => RepoPatchV1 prim wX wY -> [Sealed (FL prim wX)]-unravel p = nub $ map (mapSeal (dropAllInverses . concatFL . mapFL_FL effect)) $+unravel p = nubFL $ map (mapSeal (dropAllInverses . concatFL . mapFL_FL effect)) $             getSupers $ map (mapSeal reverseRL) $ unseal (newUr p) $ unwind p  getSupers :: PrimPatch prim@@ -440,7 +421,8 @@     effect p@(Regrem{}) = invert $ effect $ invert p     effect (PP p) = p :>: NilFL -instance IsHunk prim => IsHunk (RepoPatchV1 prim) where+instance (PrimPatch prim, ApplyState prim ~ ApplyState (RepoPatchV1 prim)) =>+         IsHunk (RepoPatchV1 prim) where     isHunk p = do PP p' <- return p                   isHunk p'
src/Darcs/Patch/V1/Prim.hs view
@@ -33,8 +33,8 @@ import Darcs.Patch.Witnesses.Sealed ( mapSeal )  import Darcs.Patch.Prim.Class-    ( PrimConstruct(..), PrimCanonize(..)-    , PrimClassify(..), PrimDetails(..)+    ( PrimConstruct(..), PrimCoalesce(..)+    , PrimDetails(..)     , PrimShow(..), PrimRead(..)     , PrimApply(..)     , PrimSift(..)@@ -52,8 +52,7 @@     , Eq2     , PatchInspect     , PrimApply-    , PrimCanonize-    , PrimClassify+    , PrimCoalesce     , PrimConstruct     , PrimDetails     , PrimMangleUnravelled@@ -76,7 +75,7 @@   showPatch fmt = showPrim (fileNameFormat fmt) . unPrim  instance ShowContextPatch Prim where-  showContextPatch fmt = showPrimCtx (fileNameFormat fmt) . unPrim+  showPatchWithContextAndApply fmt = showPrimWithContextAndApply (fileNameFormat fmt) . unPrim  instance ShowPatch Prim where   summary = plainSummaryPrim . unPrim
src/Darcs/Patch/V1/Viewing.hs view
@@ -3,6 +3,7 @@  import Darcs.Prelude +import Darcs.Patch.Apply ( apply ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Show ( ShowPatch(..), ShowContextPatch(..), showPatch ) import Darcs.Patch.Summary ( plainSummary, plainSummaryFL )@@ -12,8 +13,8 @@ import Darcs.Patch.V1.Show ()  instance PrimPatch prim => ShowContextPatch (RepoPatchV1 prim) where-    showContextPatch f (PP p) = showContextPatch f p-    showContextPatch f p = return $ showPatch f p+    showPatchWithContextAndApply f (PP p) = showPatchWithContextAndApply f p+    showPatchWithContextAndApply f p = apply p >> return (showPatch f p)  instance PrimPatch prim => ShowPatch (RepoPatchV1 prim) where     summary = plainSummary
src/Darcs/Patch/V2.hs view
@@ -1,4 +1,3 @@ module Darcs.Patch.V2 ( RepoPatchV2 ) where -import Darcs.Patch.Annotate () import Darcs.Patch.V2.RepoPatch ( RepoPatchV2 )
src/Darcs/Patch/V2/Non.hs view
@@ -67,7 +67,7 @@ import Darcs.Patch.Read ( peekfor ) import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor ) import Darcs.Patch.Viewing ()-import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL )+import Darcs.Patch.Permutations ( (=\~/=), removeFL, commuteWhatWeCanFL ) import Darcs.Util.Printer ( Doc, empty, vcat, hiddenPrefix, blueText, ($$) ) import qualified Data.ByteString.Char8 as BC ( pack, singleton ) @@ -126,7 +126,7 @@ instance (Commute p, Eq2 p, Eq2 (PrimOf p)) => Eq (Non p wX) where     Non (cx :: FL p wX wY1) (x :: PrimOf p wY1 wZ1)      == Non (cy :: FL p wX wY2) (y :: PrimOf p wY2 wZ2) =-      case cx =\/= cy of+      case cx =\~/= cy of         IsEq -> case x =\/= y :: EqCheck wZ1 wZ2 of                   IsEq -> True                   NotEq -> False
src/Darcs/Patch/V2/Prim.hs view
@@ -33,8 +33,8 @@ import Darcs.Patch.Witnesses.Sealed ( mapSeal )  import Darcs.Patch.Prim.Class-    ( PrimConstruct(..), PrimCanonize(..)-    , PrimClassify(..), PrimDetails(..)+    ( PrimConstruct(..), PrimCoalesce(..)+    , PrimDetails(..)     , PrimShow(..), PrimRead(..)     , PrimApply(..)     , PrimSift(..)@@ -52,8 +52,7 @@     , Eq2     , PatchInspect     , PrimApply-    , PrimCanonize-    , PrimClassify+    , PrimCoalesce     , PrimConstruct     , PrimDetails     , PrimMangleUnravelled@@ -76,7 +75,7 @@   showPatch fmt = showPrim (fileNameFormat fmt) . unPrim  instance ShowContextPatch Prim where-  showContextPatch fmt = showPrimCtx (fileNameFormat fmt) . unPrim+  showPatchWithContextAndApply fmt = showPrimWithContextAndApply (fileNameFormat fmt) . unPrim  instance ShowPatch Prim where   summary = plainSummaryPrim . unPrim
src/Darcs/Patch/V2/RepoPatch.hs view
@@ -15,7 +15,9 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Darcs.Patch.V2.RepoPatch     ( RepoPatchV2(..)@@ -30,7 +32,7 @@ import Control.Monad ( mplus, liftM ) import qualified Data.ByteString.Char8 as BC ( ByteString, pack ) import Data.Maybe ( fromMaybe )-import Data.List ( partition, nub )+import Data.List ( partition ) import Data.List.Ordered ( nubSort )  import Darcs.Patch.Commute ( commuteFL, commuteRL@@ -58,7 +60,7 @@ import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL                                 , genCommuteWhatWeCanRL, removeRL, removeFL-                                , removeSubsequenceFL )+                                , removeSubsequenceFL, nubFL, (=\~/=), (=/~\=) ) import Darcs.Patch.Show     ( ShowPatch(..), ShowPatchBasic(..), ShowContextPatch(..), ShowPatchFor(..)     , displayPatch )@@ -362,12 +364,15 @@     conflictedEffect (Normal x) = [IsC Okay x]  instance PrimPatch prim => Conflict (RepoPatchV2 prim) where+    isConflicted (Conflictor {}) = True+    isConflicted (InvConflictor {}) = True+    isConflicted _ = False     resolveConflicts _ = map mangleOrFail . combineConflicts resolveOne       where         resolveOne :: RepoPatchV2 prim wX wY -> [[Sealed (FL prim wY)]]         resolveOne (Conflictor ix xx x) = [unravelled]           where-            unravelled = nub $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX+            unravelled = nubFL $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX             xIxNonXX = x : ix ++ nonxx             nonxx = nonxx_ (reverseFL $ xx2patches ix xx)         resolveOne _ = []@@ -499,12 +504,12 @@     (Normal x) =\/= (Normal y) = x =\/= y     (Conflictor cx xx x) =\/= (Conflictor cy yy y)         | map commuteOrAddIXX cx `eqSet` map commuteOrAddIYY cy-          && commuteOrAddIXX x == commuteOrAddIYY y = xx =/\= yy+          && commuteOrAddIXX x == commuteOrAddIYY y = reverseFL xx =/~\= reverseFL yy       where           commuteOrAddIXX = commutePrimsOrAddToCtx (invertFL xx)           commuteOrAddIYY = commutePrimsOrAddToCtx (invertFL yy)     (InvConflictor cx xx x) =\/= (InvConflictor cy yy y)-        | cx `eqSet` cy && x == y = xx =\/= yy+        | cx `eqSet` cy && x == y = xx =\~/= yy     _ =\/= _ = NotEq  eqSet :: Eq a => [a] -> [a] -> Bool@@ -855,8 +860,8 @@         showNon f p  instance PrimPatch prim => ShowContextPatch (RepoPatchV2 prim) where-    showContextPatch f (Normal p) = showContextPatch f p-    showContextPatch f p = return $ showPatch f p+    showPatchWithContextAndApply f (Normal p) = showPatchWithContextAndApply f p+    showPatchWithContextAndApply f p = apply p >> return (showPatch f p)  instance PrimPatch prim => ShowPatch (RepoPatchV2 prim) where     summary = plainSummary
src/Darcs/Patch/V3.hs view
@@ -3,7 +3,6 @@  import Darcs.Prelude -import Darcs.Patch.Annotate () import Darcs.Patch.FromPrim ( FromPrim(..) ) import Darcs.Patch.Prim.Named   ( PrimPatchId
src/Darcs/Patch/V3/Contexted.hs view
@@ -9,7 +9,8 @@     , ctxView     , ctxNoConflict     , ctxToFL-      -- * Construct+    , ctxDepends+      -- * Construct / Modify     , ctx     , ctxAdd     , ctxAddRL@@ -42,6 +43,7 @@ import Darcs.Patch.Inspect import Darcs.Patch.Merge ( CleanMerge(..) ) import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Permutations ( (=\~/=) ) import Darcs.Util.Parser ( Parser, lexString ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor ) import Darcs.Patch.Viewing ()@@ -76,15 +78,6 @@ -- context. (This assumes witnesses aren't coerced in an unsafe manner.) instance Ident p => Eq (Contexted p wX) where   c1 == c2 = ctxId c1 == ctxId c2-{---- Comparing the contexts is inefficient and unnecessary--- if the patches have identities, see 'prop_ctxEq'.-instance (Commute p, Eq2 p) => Eq (Contexted p wX) where-  Contexted cx x == Contexted cy y-    | IsEq <- cx =\/= cy-    , IsEq <- x =\/= y = True-    | otherwise = False--}  instance Ident p => Ord (Contexted p wX) where   cp `compare` cq = ctxId cp `compare` ctxId cq@@ -126,11 +119,12 @@ prop_ctxNotInv (Contexted (p :>: ps) _) =   invertId (ident p) `notElem` mapFL ident ps --- This property states that equal 'Contexted' patches have equal content.+-- | This property states that equal 'Contexted' patches have equal content+-- up to reorderings of the context patches. prop_ctxEq :: (Commute p, Eq2 p, Ident p) => Contexted p wX -> Contexted p wX -> Bool prop_ctxEq cp@(Contexted ps p) cq@(Contexted qs q)   | cp == cq =-      case ps =\/= qs of+      case ps =\~/= qs of         IsEq -> isIsEq (p =\/= q)         NotEq -> False prop_ctxEq _ _ = True@@ -142,6 +136,12 @@ ctxId :: Ident p => Contexted p wX -> PatchId p ctxId (Contexted _ p) = ident p +-- | Wether the first argument is contained (identity-wise) in the context of+-- the second, in other words, the second depends on the first. This does not+-- include equality, only proper dependency.+ctxDepends :: Ident p => Contexted p wX -> Contexted p wX -> Bool+ctxDepends (Contexted _ p1) (Contexted c2 _) = ident p1 `elem` mapFL ident c2+ -- | 'Contexted' patches conflict with each other if the identity of one is in -- the context of the other or they cannot be merged cleanly. ctxNoConflict :: (CleanMerge p, Commute p, Ident p)@@ -162,7 +162,7 @@ -}  -- | We sometimes want to pattern match on a 'Contexted' patch but still guard--- against violation of teh invariants. So we export a view that is isomorphic+-- against violation of the invariants. So we export a view that is isomorphic -- to the 'Contexted' type but doesn't allow to manipulate the internals. ctxView :: Contexted p wX -> Sealed ((FL p :> p) wX) ctxView (Contexted cs p) = Sealed (cs :> p)
src/Darcs/Patch/V3/Core.hs view
@@ -8,6 +8,15 @@  * minor details of merge and commute due to bug fixes +The proofs in this module assume that whenever we create a conflictor we+maintain the following invariants:++(1) A conflictor reverts a patch in its context iff it is the first patch+    that conflicts with it. This implies that any patch a conflictor reverts+    exists in its context as an unconflicted Prim.++(2) If v depends on u and p conflicts with u then it also conflicts with v.+ -}  {-# LANGUAGE ViewPatterns, PatternSynonyms #-}@@ -36,15 +45,15 @@ import Darcs.Patch.FromPrim ( ToPrim(..) ) import Darcs.Patch.Ident     ( Ident(..)-    , IdEq2(..)     , PatchId     , SignedId(..)     , StorableId(..)     , commuteToPrefix     , fastRemoveFL     , findCommonFL+    , (=\^/=)     )-import Darcs.Patch.Invert ( Invert, invert, invertFL )+import Darcs.Patch.Invert ( Invert, invert ) import Darcs.Patch.Merge     ( CleanMerge(..)     , Merge(..)@@ -52,7 +61,7 @@     , swapCleanMerge     , swapMerge     )-import Darcs.Patch.Prim ( PrimPatch, applyPrimFL )+import Darcs.Patch.Prim ( PrimPatch, applyPrimFL, sortCoalesceFL ) import Darcs.Patch.Prim.WithName ( PrimWithName, wnPatch ) import Darcs.Patch.Read ( bracketedFL ) import Darcs.Patch.Repair (RepairToFL(..), Check(..) )@@ -85,7 +94,7 @@     , ctxAddInvFL     , ctxAddFL     , commutePast-    , commutePastRL+    , ctxToFL     , ctxTouches     , ctxHunkMatches     , showCtx@@ -104,7 +113,7 @@     , reverseFL     , reverseRL     )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal ) import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP1 ) @@ -218,7 +227,7 @@     :/\:     Conflictor (invert q :>: NilFL) (S.singleton (ctx q)) (ctx p)   -- * prim patch p conflicting with conflictor on the rhs:-  -- The rhs is the first to conflict with p, so must we add invert p+  -- The rhs is the first to conflict with p, so we must add invert p   -- to its effect, and to its conflicts (adding invert r as context for p).   -- For the other branch, we add a new conflictor representing p. It   -- conflicts with q and has no effect, since q is already conflicted.@@ -233,10 +242,6 @@   -- from the effect of c2 (but still remember that we conflict with them).   -- We also record that we now conflict with c1, too, and as before keep   -- our identity unchanged. The rest consists of adapting contexts.-  ---  -- Note: we assume that the uncommon parts of the effects of both-  -- conflictors do not themselves conflict with each other, so we can-  -- use cleanMerge for them.   merge (lhs@(Conflictor com_r x cp) :\/: rhs@(Conflictor com_s y cq)) =     case findCommonFL com_r com_s of       Fork _ r s ->@@ -248,6 +253,13 @@                 y' = cp' +| S.map (ctxAddInvFL r') y             in Conflictor s' y' cq' :/\: Conflictor r' x' cp'           Nothing ->+            -- Proof that this is impossible:+            --+            -- A conflictor reverts another patch only if it is the first that+            -- conflicts with it. Thus every patch it reverts is contained in+            -- its context as an unconflicted Prim patch. This holds for both+            -- lhs and rhs, which share the same context. Thus there can be no+            -- conflict between the effects of lhs and rhs. QED             error $ renderString $ redText "uncommon effects can't be merged cleanly:"               $$ redText "lhs:" $$ displayPatch lhs               $$ redText "rhs:" $$ displayPatch rhs@@ -259,44 +271,43 @@ instance (SignedId name, StorableId name, PrimPatch prim)   => CommuteNoConflicts (RepoPatchV3 name prim) where -  -- two prim patches that commute-  commuteNoConflicts (Prim p :> Prim q)-    | Just (q' :> p') <- commute (p :> q) = Just (Prim q' :> Prim p')-  -- commute a conflictor past a prim patch where everything goes smoothly-  commuteNoConflicts (Conflictor r x cp :> Prim q)-    | Just (q' :> r') <- commuteRL (reverseFL r :> q)-    , let iq = invert q-    , Just cp' <- commutePast iq cp-    , Just x' <- S.fromList <$> mapM (commutePast iq) (S.toList x) =-        Just (Prim q' :> Conflictor (reverseRL r') x' cp')-  -- commute a prim patch past a conflictor where everything goes smoothly-  commuteNoConflicts (Prim p :> Conflictor s y cq)-    | Just (s' :> p') <- commuteFL (p :> s)-    , Just cq' <- commutePast p' cq-    , Just y' <- S.fromList <$> mapM (commutePast p') (S.toList y) =-        Just (Conflictor s' y' cq' :> Prim p')-  -- commuting a conflictor past another one-  -- e.g. [z^, {:z}, :y] :> [, {:z}, :x] where x :> y <-> y :> x+  -- The various side-conditions here include checks that the two sides+  -- are not in conflict with each other (if the rhs is a Conflictor).+  commuteNoConflicts (Prim p :> Prim q) = do+    q' :> p' <- commute (p :> q)+    return $ Prim q' :> Prim p'+  commuteNoConflicts (Conflictor r x cp :> Prim q) = do+    q' :> r' <- commuteRL (reverseFL r :> q)+    let iq = invert q+    cp' <- commutePast iq cp+    x' <- S.fromList <$> mapM (commutePast iq) (S.toList x)+    return $ Prim q' :> Conflictor (reverseRL r') x' cp'+  -- this case is completely symmetric to the previous one+  commuteNoConflicts (Prim p :> Conflictor s y cq) = do+    s' :> p' <- commuteFL (p :> s)+    cq' <- commutePast p' cq+    y' <- S.fromList <$> mapM (commutePast p') (S.toList y)+    return $ Conflictor s' y' cq' :> Prim p'   commuteNoConflicts (Conflictor com_r x cp :> Conflictor s y cq) = do-    -- com = prims in the effect of the lhs that the rhs also conflicts with+    -- com = prims in the effect of the lhs that the rhs also conflicts with;+    -- these remain on the lhs     com :> rr <- commuteToPrefix (S.map (invertId . ctxId) y) com_r     s' :> rr' <- commuteRLFL (rr :> s)-    cp' <- commutePastRL (invertFL s) cp-    cq' <- commutePastRL rr' cq-    let sq = ctxAddFL s cq-    guard (ctxNoConflict sq cp)-    let sy = S.map (ctxAddFL s) y-    guard $ all (ctxNoConflict sq) (S.difference x sy)-    guard $ all (ctxNoConflict cp) (S.difference sy x)-    return $-      Conflictor (com +>+ s') (S.map (ctxAddRL rr') y) cq'-      :>-      Conflictor (reverseRL rr') (S.map (ctxAddInvFL s) x) cp'-  commuteNoConflicts _ = Nothing+    let cp' = ctxAddInvFL s cp+        cq' = ctxAddRL rr' cq+    -- obviously p and q must not conflict, nor depend on each other+    guard (ctxNoConflict cq cp')+    let x' = S.map (ctxAddInvFL s) x+        y' = S.map (ctxAddRL rr') y+    -- somewhat less obviously, p must not conflict with the patches that only+    -- q conflicts with, nor depend on them, and vice versa+    guard $ all (ctxNoConflict cp') (S.difference y x')+    guard $ all (ctxNoConflict cq) (S.difference x' y)+    return $ Conflictor (com +>+ s') y' cq' :> Conflictor (reverseRL rr') x' cp'  -- * Commute --- commuting a conflicted merge; these cases follow directly from merge+-- | Commute conflicting patches. These cases follow directly from merge. commuteConflicting   :: (SignedId name, StorableId name, PrimPatch prim)   => CommuteFn (RepoPatchV3 name prim) (RepoPatchV3 name prim)@@ -315,7 +326,16 @@   | ident p `S.member` S.map ctxId y =       case fastRemoveFL (invert p) s of         Nothing ->-          error $ renderString $ redText "commuteConflicting: cannot remove (invert lhs):"+          -- Proof that this is impossible:+          --+          -- The case assumption (that p is in conflict with q) together+          -- with the fact that the rhs is obviously the first patch that+          -- conflicts with the lhs, imply that p^ is contained in s. It+          -- remains to be shown that p^ does not depend on any prim contained+          -- in s. Suppose there were such a prim, then p would be in conflict+          -- with it, which means p would have to be a conflictor. QED+          error $ renderString+            $ redText "commuteConflicting: cannot remove (invert lhs):"             $$ displayPatch (invert p)             $$ redText "from effect of rhs:"             $$ displayPatch s@@ -328,12 +348,24 @@ commuteConflicting (lhs@(Conflictor r x cp) :> rhs@(Conflictor NilFL y cq))   | y == S.singleton cp =       case ctxView (ctxAddFL r cq) of-        Sealed (NilFL :> cq') ->-          Just $-            Prim cq'-            :>-            Conflictor (invert cq' :>: r) (cq +| x) cp+        Sealed (NilFL :> q') ->+          Just $ Prim q' :> Conflictor (invert q' :>: r) (cq +| x) cp         Sealed (c' :> _) ->+          -- Proof that this is impossible:+          --+          -- First, it must be true that commutePastFL r cq = Just cq'. For if+          -- not, then there would be a conflict between the rhs and one of the+          -- prims that the lhs reverts, in contradiction to our case+          -- assumption that the rhs conflicts only with the lhs.+          --+          -- Second, suppose that cq' has residual nonempty context. That means+          -- there is a patch x in the history that the rhs depends on, and+          -- which is in conflict with at least one other patch y in our+          -- history (the history being the patches that precede the lhs);+          -- because otherwise cq' appended to the history would be a sequence+          -- that contains x twice without an intermediate revert. But then the+          -- rhs would also have to conflict with the patch x, again in+          -- contradiction to our case assumption. QED           error $ renderString $ redText "remaining context in commute:"             $$ displayPatch c'             $$ redText "lhs:" $$ displayPatch lhs@@ -342,23 +374,35 @@ -- also conflicts with other patches -- [com r, X, cp] [s, y=({s^cp} U Y'), cq] <-> [com s', r'Y', r'cq] [r', {cq} U s^X, s^cp] commuteConflicting (Conflictor com_r x cp :> Conflictor s y cq)-  | let is_cp = ctxAddInvFL s cp-  , is_cp `S.member` y-  , let y' = is_cp -| y =+  | let cp' = ctxAddInvFL s cp+  , cp' `S.member` y+  , let y' = cp' -| y =       case commuteToPrefix (S.map (invertId . ctxId) y') com_r of-        Nothing -> error "commuteConflicting: cannot commute common effects"+        Nothing ->+          -- Proof that the above commute must suceed:+          --+          -- Let u and v be prims that the lhs reverts, and suppose v also+          -- conflicts with the rhs. If v^ depends on u^, then u depends on v+          -- and thus u also conflicts with the rhs. Thus any v^ in com_r such+          -- that v conflicts with the rhs can depend only on other elements of+          -- com_r that also conflict with the rhs. QED+          error "commuteConflicting: cannot commute common effects"         Just (com :> rr) ->           case commuteRLFL (rr :> s) of-            Nothing -> error "commuteConflicting: cannot commute uncommon effects"+            Nothing ->+              -- Proof that the above commute must succeed:+              --+              -- This is equivalent to the statement: a prim v that conflicts+              -- only with the lhs cannot depend on another prim u that+              -- conflicts only with the rhs. Again, this is a consequence of+              -- the fact that if v depends on u and u conflicts with q, then v+              -- must also conflict with q.+              error "commuteConflicting: cannot commute uncommon effects"             Just (s' :> rr') ->               Just $-                Conflictor (com +>+ s')-                  (S.map (ctxAddRL rr') y')-                  (ctxAddRL rr' cq)+                Conflictor (com +>+ s') (S.map (ctxAddRL rr') y') (ctxAddRL rr' cq)                 :>-                Conflictor (reverseRL rr')-                  (cq +| S.map (ctxAddInvFL s) x)-                  is_cp+                Conflictor (reverseRL rr') (cq +| S.map (ctxAddInvFL s) x) cp' commuteConflicting _ = Nothing  instance (SignedId name, StorableId name, PrimPatch prim) =>@@ -458,11 +502,11 @@   summaryFL = plainSummaryFL   thing _ = "change" -instance (StorableId name, PrimPatch prim)+instance (SignedId name, StorableId name, PrimPatch prim)   => ShowContextPatch (RepoPatchV3 name prim) where -  showContextPatch f (Prim p) = showContextPatch f p-  showContextPatch f p = return $ showPatch f p+  showPatchWithContextAndApply f (Prim p) = showPatchWithContextAndApply f p+  showPatchWithContextAndApply f p = apply p >> return (showPatch f p)  -- * Read and Write @@ -487,13 +531,24 @@         where           go = (lexString (BC.pack "}}") >> pure S.empty) <|> S.insert <$> readCtx <*> go -instance (StorableId name, PrimPatch prim)+instance (SignedId name, StorableId name, PrimPatch prim)   => ShowPatchBasic (RepoPatchV3 name prim) where    showPatch fmt rp =     case rp of       Prim p -> showPatch fmt p-      Conflictor r x cp -> blueText "conflictor" <+> showContent r x cp+      Conflictor r x cp ->+        case fmt of+          ForStorage -> blueText "conflictor" <+> showContent r x cp+          ForDisplay ->+            vcat+            [ blueText "conflictor"+            , vcat (mapFL displayPatch r)+            , redText "v v v v v v v"+            , vcat [ displayCtx p $$ redText "*************" | p <- S.toList x ]+            , displayCtx cp+            , redText "^ ^ ^ ^ ^ ^ ^"+            ]     where       showContent r x cp = showEffect r <+> showCtxSet x $$ showCtx fmt cp       showEffect NilFL = blueText "[]"@@ -505,6 +560,10 @@             blueText "{{"               $$ vcat (map (showCtx fmt) (S.toAscList xs))               $$ blueText "}}"+      displayCtx c =+        -- need to use ForStorage to see the prim patch IDs+        showId ForStorage (ctxId c) $$+        unseal (showPatch ForDisplay . sortCoalesceFL . mapFL_FL wnPatch) (ctxToFL c)  -- * Local helper functions
src/Darcs/Patch/V3/Resolution.hs view
@@ -2,52 +2,21 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V3.Resolution () where -import Data.Maybe ( catMaybes )-import qualified Data.Map as M import qualified Data.Set as S-import qualified Data.Vector as V  import Darcs.Prelude+import Data.List ( partition, sort )  import Darcs.Patch.Commute ( commuteFL )-import Darcs.Patch.Conflict ( Conflict(..), ConflictDetails(..), mangleOrFail )-import Darcs.Patch.Ident-    ( Ident(..)-    , SignedId(..)-    , StorableId(..)-    , findCommonFL-    )-import Darcs.Patch.Merge ( CleanMerge(..) )+import Darcs.Patch.Conflict ( Conflict(..), mangleOrFail )+import Darcs.Patch.Ident ( Ident(..), SignedId(..), StorableId(..) ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Prim.WithName ( PrimWithName, wnPatch )-import Darcs.Patch.Show hiding ( displayPatch )-import Darcs.Patch.V3.Contexted-    ( Contexted-    , ctxId-    , ctxNoConflict-    , ctxToFL-    )-import Darcs.Patch.V3.Core ( RepoPatchV3(..), (-|) )-import Darcs.Patch.Witnesses.Ordered-    ( (:/\:)(..)-    , (:>)(..)-    , (:\/:)(..)-    , FL(..)-    , Fork(..)-    , RL(..)-    , (+>+)-    , mapFL_FL-    )+import Darcs.Patch.V3.Contexted ( Contexted, ctxDepends, ctxId, ctxToFL )+import Darcs.Patch.V3.Core ( RepoPatchV3(..), (+|), (-|) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), mapFL_FL, (:>)(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )-import Darcs.Patch.Witnesses.Show ( Show2 ) -import Darcs.Util.Graph ( Vertex, components, ltmis )-import Darcs.Util.Printer-    ( Doc-    , ($$)-    , redText-    , renderString-    )  -- * Conflict Resolution @@ -56,213 +25,204 @@ The goal is to calculate the markup for a trailing RL of patches, usually the ones we are going to add to our repo. But since in V3 we store only the direct conflicts, not the transitive set, we also require the full context-of all previous patches. This is needed because we may need to traverse a-(hopefully small, trailing) part of it in order to find out whether a-conflict with some older patch has been resolved or not.+of all previous patches.  The markup presents each /transitive/ unresolved conflict in the form of a-set of alternative changes that all apply at the end of the repo, such that-each alternative conflicts with all others. Constructing these alternatives-is the main part of the algorithm.+set of alternative changes that all apply at the end of the repo. These+alternatives form the vertices of an undirected graph, where an edge exists+between two vertices iff they conflict. We represent this graph as a list of+connected 'Component's; thus each 'Component' represents one transitive+conflict. -Our first goal is to construct what we call the /conflict graph/. Its-vertices are contexted named prims starting at the end of the repo. An edge-exists between two such vertices iff they conflict. So this is an undirected-graph.+The graph is constructed by commuting any patch that is part of a conflict+to the head. If that succeeds, the resulting conflictor gives us all+participents of the (direct) conflict in the form of contexted patches that+apply to the end of the repo. We check if there is an overlap between this+set and any already constructed components. If this is the case, we join+them into a larger component, otherwise we add a new component. If commuting+to the head fails, we only remember the set of conflicting patch names, and+use that afterwards to connect components that might otherwise appear as+unconnected. The docs for 'findComponents' explain this in greater detail. -Finding the vertices is the task of 'findVertices', see its documentation-for details about how this is done. We then call 'findEdges' which-determines the edges by calling 'conflictsWith' for each pair of vertices.-The graph is returned as a list of 'Node's, that is, vertices plus their-adjacency sets.+Each resulting 'Component' is then converted to a set of plain prim 'FL's+(removing the prim patch IDs) and passed to the mangling function to+calculate the conflict markup as a single prim patch. -Next we partition the graph into connected components, since these are what-makes up one transitive conflict.+The result differs from that for RepoPatchV1 in that we do not merge the+maximal independent (i.e. non-conflicting) sets for each component. While+the latter gives a theoretically valid and more compact presentation,+typically with fewer alternatives, it has some disadvantages in practice: -For each component we determine its maximal independent sets. These are-defined as the maximal subsets of vertices with the property that none of-its elements are adjacent to each other. This is done by the function-'alternatives'. Since none of the elements of an independent set conflict,-we can now convert them to plain FLs and merge them cleanly.+  * Merging means that a single alternative no longer corresponds to a+    single named patch in our repo. Thus, even if we annotate alternatives+    with patch names or hashes (as planned for V3), identifying which part+    of an alternative belongs to which named patch requires additional+    mental effort during manual resolution. -The result of merging all maximal independent sets in a component gives us-one set of alternatives, which is then passed as input to 'mangleUnravelled'-to generate the markup. -}+  * The same original prim is now contained in more than one alternative,+    making it harder to manually resolve the conflict in a systematic way by+    applying difference between alternatives and the baseline step by step. +-}+ instance (SignedId name, StorableId name, PrimPatch prim) =>          Conflict (RepoPatchV3 name prim) where+  isConflicted Conflictor{} = True+  isConflicted Prim{} = False   resolveConflicts context =-      resolveComponents . findEdges . findVertices context+      map resolveOne . conflictingAlternatives context     where-      resolveComponents :: [Node name prim wX] -> [ConflictDetails prim wX]-      resolveComponents = map (mangleOrFail . map mergeThem) . alternatives-      mergeThem :: [Contexted (PrimWithName name prim) wX] -> Sealed (FL prim wX)-      mergeThem = mapSeal (mapFL_FL wnPatch) . mergeList . map ctxToFL+      resolveOne = mangleOrFail . map (mapSeal (mapFL_FL wnPatch)) --- | A single 'Node' in the conflict graph. The 'neighbors' are those that we--- know are in conflict with 'self'.-data Node name prim wY = Node-  { self :: Contexted (PrimWithName name prim) wY-  , neighbors :: S.Set (Contexted (PrimWithName name prim) wY)-  }+conflictingAlternatives+  :: (SignedId name, StorableId name, PrimPatch prim)+  => RL (RepoPatchV3 name prim) wO wX+  -> RL (RepoPatchV3 name prim) wX wY+  -> [[Sealed (FL (PrimWithName name prim) wY)]]+conflictingAlternatives context =+  map (map ctxToFL . S.toList) . findComponents context -deriving instance (Show name, Show2 prim) => Show (Node name prim wY)+-- | A connected component of the conflict graph.+type Component name prim wY = S.Set (Contexted (PrimWithName name prim) wY) -{- | Find the set of vertices of the conflict graph by searching the history-for unresolved conflicts. The history is split into an initial 'RL' of-patches (the context) and a trailing 'RL' of patches we are interested in.+{- | Construct the conflict graph by searching the history for unresolved+conflicts. The history is split into an initial 'RL' of patches (the+context) and a trailing 'RL' of patches we are interested in. -We maintain the following state: a list of contexted patches, which will-become the resulting vertices of the conflict graph; and a set of patch-identifiers. The latter serves as markers for patches further back in the-past that we have become interested in during our traversal. We maintain the-invariant that this set never contains the identifier of any patch we have-already traversed.+We examine patches starting with the head and going backwards, maintaining+the following state: -Any conflictor in the trailing 'RL' is a possible candidate for a vertex;-and likewise any other patch anywhere in the history which we marked as-interesting. Every patch we encounter when traversing the history is-unmarked by removing its identifier from the marker set. The traversal-terminates when the trailing 'RL' has been fully traversed and the marker-set is empty; that is, when there are no more patches to encounter that-might interest us.+  @done@ -If we enounter a candidate, we try to commute it to the head; if that-succeeds, then its commuted version must be a conflictor. (Either it was a-conflictor to begin with, in which case it remains one; or it is a patch-that a later conflictor conflicted with, and that means it must itself-become conflicted when commuted to the head.) We then add the contexted-patch that the conflictor represents to the result. We also mark any patch-that the candidate conflicts with as interesting by adding its identifier to-the marker set. In order to maintain our invariant, we must extract the set-of conflicts from the patch /in its uncommuted form/. (If we took them from-the commuted version, then we might mark patches that we already traversed.)+    A list of 'Component's, initially empty, which will become the resulting+    conflict graph. -Candidate patches that cannot be commuted to the head are ignored. We do-this uniformly for every candidate, whether it is a 'Conflictor' or a-'Prim'. The rationale for this is that a patch that some other patch depends-on is either part of a conflict that has been resolved; or else it would be-subsumed by another patch in the same component of the conflict graph that-depends on it and therefore already has it in its context.+  @todo@ -The last point is a bit subtle. RepoPatchV1 explicitly removes any vertex-from the graph that another vertex depends on (the function there has the-beautiful and expressive name 'getSupers';-). By uniformly ignoring any-patch we cannot commute to the head we achieve the same result implicitly.--}+    A set of @name@s, initially empty, that are candidates for inspection,+    in addition to conflicted patches in the trailing 'RL'. We maintain the+    invariant that this set never contains the @name@ of any patch we have+    already traversed. -findVertices+  @res@++    A list of sets of @name@s, initially empty, with the @name@s of patches+    involved in conflicts that are (partially) resolved. Used to post+    process the result (see below).++We inspect any conflictor in the trailing 'RL', as well as any patch whose+@name@ is in @todo@ throughout the history, terminating early if the+trailing 'RL' and @todo@ are both exhausted.++For each such candidate we first try to commute it to the head.++If that succeeds, then its commuted version must be a conflictor. (Either it+was a conflictor to begin with, in which case it remains one; or it is a+patch that a later conflictor conflicted with, and that means it must itself+become conflicted when commuted to the head.) The contexted patch that the+(commuted) conflictor represents, together with its set of conflicts, is+either added as a new component to @done@, or else is joined with some+already found component.++If the commute does not succeed, then this indicates that some later patch+has resolved (parts of) the conflict. So this patch makes no direct+contribution to the confict graph. However, it may still be part of a larger+transitive conflict and not all patches involved may have been fully+resolved. (Remember that the commute rules for V3 are such that a patch+depends on a conflictor if it depends on /any/ of the patches involved in+the conflict.) To make sure that the result is independent of the order of+patches, we need to remember the set of directly conflicting patches (by+adding it to @res@). When the traversal terminates, we use this information+to join any components connected by these sets into larger components. See+the discussion below for details.++In both cases, if the patch is conflicted, we insert any patch that the+candidate conflicts with into @todo@ (and remove the patch itself). Note+that in order to maintain our invariant, we must extract the set of+conflicts from the patch /in its uncommuted form/. (If we took them from the+commuted version, then we might mark patches that we already traversed.)++The necessity to remember information about all direct conflicts until the+end, regardless of partial resolutions, can be seen with the following+example. Suppose we have patches A;B;C;D;E where E (a partial resolution)+depends (only) on C, and we have direct conflicts A/C, C/B, B/D. So D+commutes past E but conflicts only indirectly with C. Thus when we encounter+C and fail to remember the fact that it conflicts with A, we end up with two+components [{C,B},{A,D}] instead of a single transitive conflict [{A,B,C,D}]+that we would get when examining the patches in the order A;C;B;D;E.++On the other hand, suppose we have A;B;C;D;E;F, where A;B;C;D;E form a+transitive conflict chain (i.e. we have direct conflicts A/B, B/C, C/D,+D/E), and the partial resolution F depends on {B,C,D}. Note that /all/+direct conflicts involving C are resolved by F, so we expect to get the two+components {A,B} and {D,E}. Indeed, suppose the order were B;D;C;F;A;E, then+at the point after F is added we have a repo with all conflicts resolved.+Thus after adding A and E we should only see the direct conflicts of A and+E, i.e. A, B, D, and E. The slightly subtle implication is that when we+finally join components, we must do so for one conflict set at a time; it+would be wrong to first join conflict sets and then use those to join+components, since that would join {A,B} and {D,E}, even though there is no+conflict between the two sets.+-}+findComponents   :: forall name prim wO wX wY    . (SignedId name, StorableId name, PrimPatch prim)   => RL (RepoPatchV3 name prim) wO wX   -> RL (RepoPatchV3 name prim) wX wY-  -> [Contexted (PrimWithName name prim) wY]-findVertices context patches = go S.empty [] context patches NilFL where+  -> [Component name prim wY]+findComponents context patches = go S.empty [] [] context patches NilFL where   go :: S.Set name-     -> [Contexted (PrimWithName name prim) wY]+     -> [Component name prim wY]+     -> [S.Set name]      -> RL (RepoPatchV3 name prim) wO wA      -> RL (RepoPatchV3 name prim) wA wB      -> FL (RepoPatchV3 name prim) wB wY-     -> [Contexted (PrimWithName name prim) wY]-  go check done cs (ps :<: p) passedby-    | isConflicted p || ident p `S.member` check-    , Just (_ :> Conflictor _ _ cp) <- commuteFL (p :> passedby) =-        go (conflicts p <> ident p -| check) (cp : done) cs ps (p :>: passedby)+     -> [Component name prim wY]+  go todo done res cs (ps :<: p) passedby+    | isConflicted p || ident p `S.member` todo+    , Just (_ :> p') <- commuteFL (p :> passedby) =+        go (updTodo p todo) (updDone p' done) res cs ps (p :>: passedby)     | otherwise =-        go (ident p -| check) done cs ps (p :>: passedby)-  go check done _ NilRL _-    | S.null check = done-  go check done (cs :<: p) NilRL passedby-    | ident p `S.member` check-    , Just (_ :> Conflictor _ _ cp) <- commuteFL (p :> passedby) =-        go (conflicts p <> ident p -| check) (cp : done) cs NilRL (p :>: passedby)+        go (updTodo p todo) done (updRes p res) cs ps (p :>: passedby)+  go todo done res _ NilRL _+    | S.null todo = sort $ map purgeDeps $ foldr joinOverlapping done res+  go todo done res (cs :<: p) NilRL passedby+    | ident p `S.member` todo+    , Just (_ :> p') <- commuteFL (p :> passedby) =+        go (updTodo p todo) (updDone p' done) res cs NilRL (p :>: passedby)     | otherwise =-        go (ident p -| check) done cs NilRL (p :>: passedby)-  go _ _ NilRL NilRL _ = error "autsch, hit the bottom"+        go (updTodo p todo) done (updRes p res) cs NilRL (p :>: passedby)+  go _ _ _ NilRL NilRL _ = error "autsch, hit the bottom" -  isConflicted Conflictor{} = True-  isConflicted Prim{} = False+  updTodo p todo = S.map ctxId (conflicts p) <> (ident p -| todo)+  updDone p' done = joinOrAddNew (allConflicts p') done+  updRes p res = S.map ctxId (allConflicts p) : res -  conflicts (Conflictor _ x _) = S.map ctxId x+  conflicts (Conflictor _ x _) = x   conflicts _ = S.empty --- | Note that 'ctxNoConflict' also regards dependent contexted prims as--- "conflicting". That is, if @q@ depends on @p@, then--- --- prop> 'ctxNoConflict' ('ctx' p) ('ctxAdd' p ('ctx' q) == 'False'--- --- This is what we need here, too, in order to avoid conflicts between--- the separately mangled components.-conflictsWith-  :: (SignedId name, PrimPatch prim)-  => Contexted (PrimWithName name prim) wX-  -> Contexted (PrimWithName name prim) wX-  -> Bool-conflictsWith cp cq = not (ctxNoConflict cp cq)---- | Determine the conflict graph from a set of contexted prims.--- This calls 'conflictsWith' for every pair of elements and from that--- builds a list of 'Node's repesenting this graph.------ TODO: optimize this to calculate only one triangle of the adjacency--- matrix, then complete the graph by adding inverted edges.-findEdges-  :: (SignedId name, PrimPatch prim)-  => [Contexted (PrimWithName name prim) wY] -> [Node name prim wY]-findEdges = fromVertexSet . S.fromList-  where-    -- Note we could as well fold over the original input list,-    -- but going via the set has the advantage that the result is-    -- now sorted and therefore independent of the order of patches-    -- in the repo.-    fromVertexSet vs = foldr go [] vs-      where-        go cp ns = Node cp (S.filter (conflictsWith cp) vs) : ns+  allConflicts (Conflictor _ x cp) = cp +| x+  allConflicts _ = S.empty --- | The input is a list of nodes with no duplicates representing a connected--- component of the conflict graph. The list contains an element for--- each node in the graph, but the conflicts (edges) may refer to non-nodes.--- The output is a list of the maximal independent sets of the conflict graph:--- each one can be merged cleanly.-alternatives-  :: SignedId name-  => [Node name prim wX]-  -> [[[Contexted (PrimWithName name prim) wX]]]-alternatives nodes =-    map (map fromVertexSet . ltmis (True, True)) $ components graph-  where-    -- a map from indexes (of type Vertex) to nodes-    from_index = V.fromList $ map self nodes-    -- a map from prim IDs (representing nodes) to indexes-    to_index = M.fromList $ zip (map (ctxId . self) nodes) [(0::Vertex) ..]-    -- the full component of the conflict graph with each node-    -- represented by an index of type Vertex-    graph = V.fromList $ map adj_list nodes-    -- the adjacency list of a single node-    adj_list =-      catMaybes . map (flip M.lookup to_index . ctxId) . S.toList . neighbors-    fromVertexSet = map (from_index V.!)+  -- Join all components which overlap with the given set of IDs+  joinOverlapping ids cs =+    case partition (not . S.disjoint ids . S.map ctxId) cs of+      ([], to_keep) -> to_keep -- avoid adding empty components+      (to_join, to_keep) -> S.unions to_join : to_keep --- This is similar to the mergeList in Darcs.Patch.CommuteNoConflicts--- but not the same since we have PatchIds.-mergeList-  :: (SignedId name, StorableId name, PrimPatch p)-  => [Sealed (FL (PrimWithName name p) wX)] -> Sealed (FL (PrimWithName name p) wX)-mergeList = foldr mergeTwo (Sealed NilFL)-  where-    mergeTwo (Sealed ps) (Sealed qs) =-      case findCommonFL ps qs of-        Fork com ps' qs' ->-          case cleanMerge (ps' :\/: qs') of-            Just (qs'' :/\: _) -> Sealed $ com +>+ ps' +>+ qs''-            Nothing ->-              error $ renderString-                $ redText "resolutions conflict:"-                $$ displayPatch ps-                $$ redText "conflicts with"-                $$ displayPatch qs+  -- remove vertices that others depend on+  purgeDeps :: Component name prim wY -> Component name prim wY+  purgeDeps c = S.filter (\a -> not $ any (a `ctxDepends`) (a -| c)) c --- We only use displayPatch for error messages here, so it makes sense--- to use the storage format that contains the patch names.-displayPatch :: ShowPatchBasic p => p wX wY -> Doc-displayPatch p = showPatch ForStorage p+-- | Add a set to a disjoint list of sets, such that we maintain the invariant+-- that the resulting list of sets is disjoint, and such that their unions are+-- equal to the unions of the inputs.+--+-- The tricky point here is that the new set may overlap with any number of+-- list elements; we must ensure they are all joined into a single set.+joinOrAddNew :: Ord a => S.Set a -> [S.Set a] -> [S.Set a]+joinOrAddNew c [] = [c]+joinOrAddNew c (d:ds)+  | not $ all (S.disjoint d) ds = error "precondition: sets are not disjoint"+  | c `S.disjoint` d = d : joinOrAddNew c ds+  | otherwise = joinOrAddNew (c `S.union` d) ds
src/Darcs/Patch/Viewing.hs view
@@ -15,94 +15,101 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-}-+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Viewing     ( showContextHunk     ) where -import Darcs.Prelude hiding ( readFile )+import Darcs.Prelude -import Control.Applicative( (<$>) ) import qualified Data.ByteString as B ( null )-import Darcs.Util.Tree ( Tree )-import Darcs.Util.Tree.Monad ( virtualTreeMonad ) -import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.ApplyMonad ( getApplyState,-                                ApplyMonad(..), ApplyMonadTree(..), toTree )-import Darcs.Patch.FileHunk ( IsHunk(..), FileHunk(..), showFileHunk )-import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..),-                            FileNameFormat(..) )+import Darcs.Patch.Apply ( Apply(..), ObjectIdOfPatch )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )+import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..), showContextFileHunk )+import Darcs.Patch.Format ( FileNameFormat(..), ListFormat(..), PatchListFormat(..) )+import Darcs.Patch.Object ( ObjectId(..), ObjectIdOf ) import Darcs.Patch.Show-    ( ShowPatchBasic(..), ShowPatch(..)-    , formatFileName, ShowPatchFor(..), ShowContextPatch(..) )-import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), mapFL, mapFL_FL,-                                       reverseRL, concatFL )+    ( ShowContextPatch(..)+    , ShowPatch(..)+    , ShowPatchBasic(..)+    , ShowPatchFor(..)+    )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , RL(..)+    , concatFL+    , mapFL+    , mapFL_FL+    , reverseRL+    ) import Darcs.Util.ByteString ( linesPS )-import Darcs.Util.Printer ( Doc, empty, vcat, text, blueText, Color(Cyan, Magenta),-                 lineColor, ($$), (<+>), prefix, userchunkPS )+import Darcs.Util.Printer ( Doc, blueText, empty, vcat, ($$) ) -showContextSeries :: forall p m wX wY . (Apply p, ShowContextPatch p, IsHunk p,-                                         ApplyMonad (ApplyState p) m)-                  => ShowPatchFor -> FileNameFormat -> FL p wX wY -> m Doc+showContextSeries+  :: forall p m wX wY+   . ( Apply p+     , ShowContextPatch p+     , IsHunk p+     , ApplyMonad (ApplyState p) m+     , ObjectId (ObjectIdOfPatch p)+     )+  => ShowPatchFor+  -> FileNameFormat+  -> FL p wX wY+  -> m Doc showContextSeries use fmt = scs Nothing   where-    scs :: forall wWw wXx wYy . Maybe (FileHunk wWw wXx) -> FL p wXx wYy -> m Doc+    scs :: Maybe (FileHunk (ObjectIdOfPatch p) wA wB) -> FL p wB wC -> m Doc     scs pold (p :>: ps) = do-        (_, s') <- nestedApply (apply p) =<< getApplyState         case isHunk p of             Nothing -> do-                a <- showContextPatch use p-                b <- nestedApply (scs Nothing ps) s'-                return $ a $$ fst b+                a <- showPatchWithContextAndApply use p+                b <- scs Nothing ps+                return $ a $$ b             Just fh -> case ps of-                NilFL -> fst <$> liftApply (cool pold fh Nothing) s'+                NilFL -> do+                  r <- coolContextHunk fmt pold fh Nothing+                  apply p+                  return r                 (p2 :>: _) -> do-                    a <- fst <$> liftApply (cool pold fh (isHunk p2)) s'-                    b <- nestedApply (scs (Just fh) ps) s'-                    return $ a $$ fst b+                    a <- coolContextHunk fmt pold fh (isHunk p2)+                    apply p+                    b <- scs (Just fh) ps+                    return $ a $$ b     scs _ NilFL = return empty -    cool :: Maybe (FileHunk wA wB) -> FileHunk wB wC -> Maybe (FileHunk wC wD)-         -> (ApplyState p) (ApplyMonadBase m) -> (ApplyMonadBase m) Doc-    cool pold fh ps s =-        fst <$> virtualTreeMonad (coolContextHunk fmt pold fh ps) (toTree s)--showContextHunk :: (ApplyMonad Tree m) => FileNameFormat -> FileHunk wX wY -> m Doc+showContextHunk+  :: (ApplyMonad state m, oid ~ ObjectIdOf state, ObjectId oid)+  => FileNameFormat+  -> FileHunk oid wX wY+  -> m Doc showContextHunk fmt h = coolContextHunk fmt Nothing h Nothing -coolContextHunk :: (ApplyMonad Tree m)+coolContextHunk :: (ApplyMonad state m, oid ~ ObjectIdOf state, ObjectId oid)                 => FileNameFormat-                -> Maybe (FileHunk wA wB) -> FileHunk wB wC-                -> Maybe (FileHunk wC wD) -> m Doc+                -> Maybe (FileHunk oid wA wB) -> FileHunk oid wB wC+                -> Maybe (FileHunk oid wC wD) -> m Doc coolContextHunk fmt prev fh@(FileHunk f l o n) next = do-    have <- mDoesFileExist f-    f_content <- if have then Just `fmap` mReadFilePS f else return Nothing-    case linesPS `fmap` f_content of-        -- FIXME This is a weird error...-        Nothing -> return $ showFileHunk fmt fh-        Just ls ->-            let pre = take numpre $ drop (l - numpre - 1) ls-                cleanedls = case reverse ls of-                    (x : xs)-                        | B.null x -> reverse xs-                    _ -> ls-                post = take numpost $ drop (max 0 $ l+length o-1) cleanedls in-            return $-                blueText "hunk" <+> formatFileName fmt f-                    <+> text (show l)-                $$ prefix " " (vcat $ map userchunkPS pre)-                $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o))-                $$ lineColor Cyan    (prefix "+" (vcat $ map userchunkPS n))-                $$ prefix " " (vcat $ map userchunkPS post)+    ls <- linesPS <$> readFilePS f+    let pre = take numpre $ drop (l - numpre - 1) ls+        -- This removes the last line if that is empty. This is because if a+        -- file ends with a newline, this would add an unintuitive "empty last+        -- line"; in other words, we regard the newline as a terminator, not a+        -- separator. See also the long comment in Darcs.Repository.Diff.+        cleanedls = case reverse ls of+            (x : xs)+                | B.null x -> reverse xs+            _ -> ls+        post = take numpost $ drop (max 0 $ l + length o - 1) cleanedls+    return $ showContextFileHunk fmt pre fh post   where     numpre = case prev of         Just (FileHunk f' lprev _ nprev)             | f' == f && l - (lprev + length nprev + 3) < 3 && lprev < l             -> max 0 $ l - (lprev + length nprev + 3)         _ -> if l >= 4 then 3 else l - 1-     numpost = case next of         Just (FileHunk f' lnext _ _)             | f' == f && lnext < l + length n + 4 && lnext > l@@ -123,15 +130,20 @@         showPatchInternal ListFormatDefault ps = vcat (mapFL (showPatch ForStorage) ps)         showPatchInternal ListFormatV3 ps = vcat (mapFL (showPatch ForStorage) ps) -instance (Apply p, IsHunk p, PatchListFormat p, ShowContextPatch p)-        => ShowContextPatch (FL p) where-    showContextPatch ForDisplay = showContextSeries ForDisplay FileNameFormatDisplay-    showContextPatch ForStorage = showContextPatchInternal patchListFormat+instance ( Apply p+         , IsHunk p+         , PatchListFormat p+         , ShowContextPatch p+         , ObjectId (ObjectIdOfPatch p)+         ) =>+         ShowContextPatch (FL p) where+    showPatchWithContextAndApply ForDisplay = showContextSeries ForDisplay FileNameFormatDisplay+    showPatchWithContextAndApply ForStorage = showContextPatchInternal patchListFormat       where         showContextPatchInternal :: (ApplyMonad (ApplyState (FL p)) m)                                  => ListFormat p -> FL p wX wY -> m Doc         showContextPatchInternal ListFormatV1 (p :>: NilFL) =-            showContextPatch ForStorage p+            showPatchWithContextAndApply ForStorage p         showContextPatchInternal ListFormatV1 NilFL =             return $ blueText "{" $$ blueText "}"         showContextPatchInternal ListFormatV1 ps = do@@ -160,9 +172,9 @@ instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RL p) where     showPatch f = showPatch f . reverseRL -instance (ShowContextPatch p, Apply p, IsHunk p, PatchListFormat p)+instance (ShowContextPatch p, Apply p, IsHunk p, PatchListFormat p, ObjectId (ObjectIdOfPatch p))         => ShowContextPatch (RL p) where-    showContextPatch use = showContextPatch use . reverseRL+    showPatchWithContextAndApply use = showPatchWithContextAndApply use . reverseRL  instance (PatchListFormat p, ShowPatch p) => ShowPatch (RL p) where     content = content . reverseRL
src/Darcs/Patch/Witnesses/Eq.hs view
@@ -50,6 +50,8 @@     a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq              | otherwise = NotEq +    {-# MINIMAL unsafeCompare | (=\/=) | (=/\=) #-}+ infix 4 =\/=, =/\=  isIsEq :: EqCheck wA wB -> Bool
src/Darcs/Patch/Witnesses/Ordered.hs view
@@ -41,6 +41,8 @@     , foldlRL     , foldrwFL     , foldlwRL+    , foldlwFL+    , foldrwRL     , allFL     , allRL     , anyFL@@ -68,15 +70,14 @@     , spanFL     , spanFL_M     , zipWithFL-    , toFL+    , consGapFL+    , concatGapsFL+    , joinGapsFL     , mapFL_FL_M     , sequenceFL_-    , eqFL-    , eqFLUnsafe     , initsFL     -- * 'RL' only     , isShorterThanRL-    , snocRLSealed     , spanRL     , breakRL     , takeWhileRL@@ -90,10 +91,11 @@     ( FlippedSeal(..)     , flipSeal     , Sealed(..)-    , FreeLeft-    , unFreeLeft     , Sealed2(..)     , seal+    , Gap(..)+    , emptyGap+    , joinGap     ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) @@ -174,11 +176,11 @@ -- (non-haddock version) --      wZ --     :/\:--- a3 /    \ a4---   /      \+--  a3 /  \ a4+--    /    \ --  wX      wY---   \      /--- a1 \    / a2+--    \    /+--  a1 \  / a2 --     :\/: --      wZ -- @@ -233,6 +235,21 @@ instance (Eq2 a, Eq2 b) => Eq ((a :> b) wX wY) where     (==) = unsafeCompare +instance Eq2 p => Eq2 (FL p) where+  NilFL =\/= NilFL = IsEq+  a:>:as =\/= b:>:bs+    | IsEq <- a =\/= b = as =\/= bs+    | otherwise = NotEq+  _ =\/= _ = NotEq+  xs =/\= ys = reverseFL xs =/\= reverseFL ys++instance Eq2 p => Eq2 (RL p) where+  NilRL =/\= NilRL = IsEq+  as:<:a =/\= bs:<:b+    | IsEq <- a =/\= b = as =/\= bs+    | otherwise = NotEq+  _ =/\= _ = NotEq+ instance (Show2 a, Show2 b) => Show2 (a :> b)  instance (Show2 a, Show2 b) => Show ( (a :\/: b) wX wY ) where@@ -276,10 +293,12 @@ filterRL f (xs :<: x) | f x = Sealed2 x : (filterRL f xs)                       | otherwise = filterRL f xs +-- | Concatenate two 'FL's. This traverses only the left hand side. (+>+) :: FL a wX wY -> FL a wY wZ -> FL a wX wZ NilFL +>+ ys = ys (x:>:xs) +>+ ys = x :>: xs +>+ ys +-- | Concatenate two 'RL's. This traverses only the right hand side. (+<+) :: RL a wX wY -> RL a wY wZ -> RL a wX wZ xs +<+ NilRL = xs xs +<+ (ys:<:y) = xs +<+ ys :<: y@@ -398,11 +417,25 @@  -- | The analog of 'foldrwFL' for 'RL's. -- This is the "natural" fold for 'RL's i.e. the one which replaces the--- ':<:' with the passed operator.-foldlwRL :: (forall wA wB . r wA -> p wA wB -> r wB) -> r wX -> RL p wX wY -> r wY-foldlwRL _ r NilRL = r-foldlwRL f r (ps:<:p) = f (foldlwRL f r ps) p+-- ':<:' with the (flipped) passed operator.+foldlwRL :: (forall wA wB . p wA wB -> r wA -> r wB) -> RL p wX wY -> r wX -> r wY+foldlwRL _ NilRL r = r+foldlwRL f (ps:<:p) r = f p (foldlwRL f ps r) +-- | Strict left associative fold for 'FL's that transforms a witnessed state+-- in the direction of the patches. This is for apply-like functions that+-- transform the witnesses in forward direction.+foldlwFL :: (forall wA wB . p wA wB -> r wA -> r wB) -> FL p wX wY -> r wX -> r wY+foldlwFL _ NilFL r = r+foldlwFL f (p:>:ps) r = let r' = f p r in r' `seq` foldlwFL f ps r'++-- | Strict right associative fold for 'RL's that transforms a witnessed state+-- in the opposite direction of the patches. This is for unapply-like functions+-- that transform the witnesses in backward direction.+foldrwRL :: (forall wA wB . p wA wB -> r wB -> r wA) -> RL p wX wY -> r wY -> r wX+foldrwRL _ NilRL r = r+foldrwRL f (ps:<:p) r = let r' = f p r in r' `seq` foldrwRL f ps r'+ mapFL_FL :: (forall wW wY . a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ mapFL_FL _ NilFL = NilFL mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as@@ -458,13 +491,15 @@ isShorterThanRL NilRL _ = True isShorterThanRL (xs:<:_) n = isShorterThanRL xs (n-1) -snocRLSealed :: FlippedSeal (RL a) wY -> a wY wZ -> FlippedSeal (RL a) wZ-snocRLSealed (FlippedSeal as) a = flipSeal $ as :<: a+consGapFL :: Gap w => (forall wX wY. p wX wY) -> w (FL p) -> w (FL p)+consGapFL p = joinGap (:>:) (freeGap p) -toFL :: [FreeLeft a] -> Sealed (FL a wX)-toFL [] = Sealed NilFL-toFL (x:xs) = case unFreeLeft x of Sealed y -> case toFL xs of Sealed ys -> Sealed (y :>: ys)+joinGapsFL :: Gap w => [w p] -> w (FL p)+joinGapsFL = foldr (joinGap (:>:)) (emptyGap NilFL) +concatGapsFL :: Gap w => [w (FL p)] -> w (FL p)+concatGapsFL = foldr (joinGap (+>+)) (emptyGap NilFL)+ dropWhileFL :: (forall wX wY . a wX wY -> Bool) -> FL a wR wV -> FlippedSeal (FL a) wV dropWhileFL _ NilFL       = flipSeal NilFL dropWhileFL p xs@(x:>:xs')@@ -494,19 +529,6 @@ -- elements before the split point should not be touched. breakRL :: (forall wA wB . p wA wB -> Bool) -> RL p wX wY -> (RL p :> RL p) wX wY breakRL f = spanRL (not . f)---- |Check that two 'FL's are equal element by element.--- This differs from the 'Eq2' instance for 'FL' which--- uses commutation.-eqFL :: Eq2 a => FL a wX wY -> FL a wX wZ -> EqCheck wY wZ-eqFL NilFL NilFL = IsEq-eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq-eqFL _ _ = NotEq--eqFLUnsafe :: Eq2 a => FL a wX wY -> FL a wZ wW -> Bool-eqFLUnsafe NilFL NilFL = True-eqFLUnsafe (x:>:xs) (y:>:ys) = unsafeCompare x y && eqFLUnsafe xs ys-eqFLUnsafe _ _ = False  infixr 5 +>>+ infixl 5 +<<+
src/Darcs/Patch/Witnesses/Sealed.hs view
@@ -30,6 +30,7 @@     , flipSeal     , unsealFlipped     , mapFlipped+    , Dup(..)     , Gap(..)     , FreeLeft     , unFreeLeft@@ -124,6 +125,14 @@ instance Show2 a => Show (Sealed2 a) where     showsPrec d (Sealed2 x) = showParen (d > appPrec) $ showString "Sealed2 " . showsPrec2 (appPrec + 1) x +-- | Duplicate a single witness. This is for situations where a patch-like type+-- is expected, i.e. a type with two witnesses, but we have only a type with one+-- witness. Naturally, any concrete value must have both witnesses agreeing.+--+-- Note that @'Sealed' ('Dup' p wX)@ is isomorphic to @p wX@.+data Dup p wX wY where+  Dup :: p wX -> Dup p wX wX+ -- |'Poly' is similar to 'Sealed', but the type argument is -- universally quantified instead of being existentially quantified. newtype Poly a = Poly { unPoly :: forall wX . a wX }@@ -167,11 +176,21 @@ instance Gap FreeLeft where   emptyGap e = FLInternal (Poly (Compose (Sealed e)))   freeGap e =  FLInternal (Poly (Compose (Sealed e)))-  joinGap op (FLInternal p) (FLInternal q)-    = FLInternal (Poly (case unPoly p of Compose (Sealed p') -> case unPoly q of Compose (Sealed q') -> Compose (Sealed (p' `op` q'))))+  joinGap op (FLInternal p) (FLInternal q) =+    FLInternal+      (Poly+         (case unPoly p of+            Compose (Sealed p') ->+              case unPoly q of+                Compose (Sealed q') -> Compose (Sealed (p' `op` q'))))  instance Gap FreeRight where   emptyGap e = FRInternal (Poly (FlippedSeal e))   freeGap e =  FRInternal (Poly (FlippedSeal e))-  joinGap op (FRInternal p) (FRInternal q)-    = FRInternal (Poly (case unPoly q of FlippedSeal q' -> case unPoly p of FlippedSeal p' -> FlippedSeal (p' `op` q')))+  joinGap op (FRInternal p) (FRInternal q) =+    FRInternal+      (Poly+         (case unPoly q of+            FlippedSeal q' ->+              case unPoly p of+                FlippedSeal p' -> FlippedSeal (p' `op` q')))
src/Darcs/Repository.hs view
@@ -18,6 +18,7 @@  module Darcs.Repository     ( Repository+    , AccessType(..)     , repoLocation     , repoFormat     , repoPristineType@@ -35,7 +36,6 @@     , maybeIdentifyRepository     , identifyRepositoryFor     , ReadingOrWriting(..)-    , withRecorded     , withRepoLock     , withRepoLockCanFail     , withRepository@@ -45,19 +45,21 @@     , amInRepository     , amNotInRepository     , amInHashedRepository-    , replacePristine-    , readRepo+    , writePristine+    , readPatches     , prefsUrl     , addToPending-    , addPendingDiffToPending+    , unsafeAddToPending     , tentativelyAddPatch+    , tentativelyAddPatches     , tentativelyRemovePatches-    , tentativelyAddToPending-    , readTentativeRepo+    , setTentativePending+    , tentativelyRemoveFromPW     , withManualRebaseUpdate     , tentativelyMergePatches     , considerMergeToWorking     , revertRepositoryChanges+    , UpdatePending(..)     , finalizeRepositoryChanges     , createRepository     , createRepositoryV1@@ -66,38 +68,31 @@     , cloneRepository     , applyToWorking     , createPristineDirectoryTree-    , createPartialsPristineDirectoryTree     , reorderInventory     , cleanRepository     , PatchSet     , SealedPatchSet     , PatchInfoAnd-    , setScriptsExecutable+    , setAllScriptsExecutable     , setScriptsExecutablePatches-    , testTentative     , modifyCache     -- * Recorded and unrecorded and pending.-    , readRecorded+    , readPristine     , readUnrecorded     , unrecordedChanges     , readPendingAndWorking     , filterOutConflicts-    , readRecordedAndPending-    -- * Index.-    , readIndex-    , invalidateIndex+    , readPristineAndPending     ) where  import Darcs.Repository.State-    ( readRecorded+    ( readPristine     , readUnrecorded     , unrecordedChanges     , readPendingAndWorking-    , readIndex-    , invalidateIndex-    , readRecordedAndPending+    , readPristineAndPending     , filterOutConflicts-    , addPendingDiffToPending+    , unsafeAddToPending     , addToPending     ) @@ -113,26 +108,25 @@     , amInHashedRepository     ) import Darcs.Repository.Hashed-    ( readRepo-    , readTentativeRepo+    ( readPatches     , tentativelyAddPatch+    , tentativelyAddPatches     , tentativelyRemovePatches-    , revertRepositoryChanges-    , finalizeRepositoryChanges     , reorderInventory     ) import Darcs.Repository.Pristine-    ( withRecorded-    , createPristineDirectoryTree-    , createPartialsPristineDirectoryTree+    ( createPristineDirectoryTree+    , writePristine     )-import Darcs.Repository.Traverse ( cleanRepository )-import Darcs.Repository.Pending-    ( tentativelyAddToPending+import Darcs.Repository.Transaction+    ( revertRepositoryChanges+    , finalizeRepositoryChanges     )+import Darcs.Repository.Traverse ( cleanRepository )+import Darcs.Repository.Pending ( setTentativePending, tentativelyRemoveFromPW ) import Darcs.Repository.Working     ( applyToWorking-    , setScriptsExecutable+    , setAllScriptsExecutable     , setScriptsExecutablePatches     ) import Darcs.Repository.Job@@ -144,11 +138,10 @@     , withUMaskFlag     ) import Darcs.Repository.Rebase ( withManualRebaseUpdate )-import Darcs.Repository.Test ( testTentative ) import Darcs.Repository.Merge( tentativelyMergePatches                              , considerMergeToWorking                              )-import Darcs.Repository.Cache+import Darcs.Util.Cache     ( Cache     , CacheLoc(..)     , CacheType(..)@@ -160,6 +153,7 @@     ) import Darcs.Repository.InternalTypes     ( Repository+    , AccessType(..)     , PristineType(..)     , modifyCache     , repoLocation@@ -169,7 +163,6 @@     ) import Darcs.Repository.Clone     ( cloneRepository-    , replacePristine     ) import Darcs.Repository.Create     ( createRepository@@ -177,6 +170,7 @@     , createRepositoryV2     , EmptyRepository(..)     )+import Darcs.Repository.Flags ( UpdatePending(..) )  import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
src/Darcs/Repository/ApplyPatches.hs view
@@ -19,14 +19,14 @@ {-# LANGUAGE MultiParamTypeClasses #-}  module Darcs.Repository.ApplyPatches-    ( applyPatches-    , runTolerantly+    ( runTolerantly     , runSilently     , DefaultIO, runDefault     ) where  import Control.Exception ( IOException, SomeException, catch ) import Control.Monad ( unless )+import Control.Monad.Catch ( MonadThrow ) import qualified Data.ByteString as B ( empty, null, readFile ) import Data.Char ( toLower ) import Data.List ( isSuffixOf )@@ -39,87 +39,57 @@     , renamePath     ) import System.IO ( hPutStrLn, stderr )-import System.IO.Error ( catchIOError, isDoesNotExistError, isPermissionError )+import System.IO.Error+    ( catchIOError+    , isAlreadyExistsError+    , isDoesNotExistError+    , isPermissionError+    )  import Darcs.Prelude -import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )-import Darcs.Patch.Info ( displayPatchInfo )-import Darcs.Patch.MonadProgress ( MonadProgress(..), ProgressAction(..) )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )-import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) import Darcs.Repository.Prefs ( changePrefval ) import Darcs.Util.Exception ( prettyException )-import Darcs.Util.External ( backupByCopying, backupByRenaming )+import Darcs.Util.File ( backupByCopying, backupByRenaming ) import Darcs.Util.Lock ( writeAtomicFilePS )-import Darcs.Util.Path ( AnchoredPath, anchorPath )-import Darcs.Util.Printer ( hPutDocLn, renderString )-import Darcs.Util.Printer ( text, ($$) )-import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO, tediousSize )+import Darcs.Util.Path ( AnchoredPath, realPath ) import Darcs.Util.Tree ( Tree ) -applyPatches :: (MonadProgress m, ApplyMonad (ApplyState p) m, Apply p)-             => FL (PatchInfoAnd rt p) wX wY -> m ()-applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps)-  where-    doApply hp = ProgressAction { paAction = apply (hopefully hp)-                                , paMessage = displayPatchInfo (info hp)-                                , paOnError = text "Unapplicable patch:" $$-                                              displayPatchInfo (info hp)-                                }--ap2fp :: AnchoredPath -> FilePath-ap2fp = anchorPath ""- newtype DefaultIO a = DefaultIO { runDefaultIO :: IO a }-    deriving (Functor, Applicative, Monad)--instance MonadProgress DefaultIO where-  runProgressActions _ [] = return ()-  runProgressActions what items = DefaultIO $ do-    do beginTedious what-       tediousSize what (length items)-       mapM_ go items-       endTedious what-    where go item =-            do finishedOneIO what (renderString $ paMessage item)-               runDefaultIO (paAction item) `catch` \e ->-                 do hPutDocLn stderr $ paOnError item-                    ioError e+    deriving (Functor, Applicative, Monad, MonadThrow)  instance ApplyMonad Tree DefaultIO where-    type ApplyMonadBase DefaultIO = IO  instance ApplyMonadTree DefaultIO where-    mDoesDirectoryExist = DefaultIO . doesDirectoryExist . ap2fp+    mDoesDirectoryExist = DefaultIO . doesDirectoryExist . realPath     mChangePref a b c = DefaultIO $ changePrefval a b c-    mModifyFilePS f j = DefaultIO $ B.readFile (ap2fp f) >>= runDefaultIO . j >>= writeAtomicFilePS (ap2fp f)-    mCreateDirectory = DefaultIO . createDirectory . ap2fp+    mModifyFilePS f j = DefaultIO $ B.readFile (realPath f) >>= runDefaultIO . j >>= writeAtomicFilePS (realPath f)+    mCreateDirectory = DefaultIO . createDirectory . realPath     mCreateFile f = DefaultIO $-                    do exf <- doesFileExist (ap2fp f)-                       if exf then fail $ "File '"++ap2fp f++"' already exists!"-                              else do exd <- doesDirectoryExist $ ap2fp f-                                      if exd then fail $ "File '"++ap2fp f++"' already exists!"-                                             else writeAtomicFilePS (ap2fp f) B.empty+                    do exf <- doesFileExist (realPath f)+                       if exf then fail $ "File '"++realPath f++"' already exists!"+                              else do exd <- doesDirectoryExist $ realPath f+                                      if exd then fail $ "File '"++realPath f++"' already exists!"+                                             else writeAtomicFilePS (realPath f) B.empty     mRemoveFile f = DefaultIO $-                    do let fp = ap2fp f+                    do let fp = realPath f                        x <- B.readFile fp                        unless (B.null x) $                             fail $ "Cannot remove non-empty file "++fp                        removeFile fp-    mRemoveDirectory = DefaultIO . removeDirectory . ap2fp+    mRemoveDirectory = DefaultIO . removeDirectory . realPath     mRename a b = DefaultIO $ renamePath x y-      where x = ap2fp a-            y = ap2fp b+      where x = realPath a+            y = realPath b -class (Functor m, Monad m) => TolerantMonad m where+class (Functor m, MonadThrow m) => TolerantMonad m where     warning :: IO () -> m ()     runIO :: m a -> IO a     runTM :: IO a -> m a  newtype TolerantIO a = TIO { runTIO :: IO a }-    deriving (Functor, Applicative, Monad)+    deriving (Functor, Applicative, Monad, MonadThrow)  instance TolerantMonad TolerantIO where     warning io = TIO $ io `catch` \e -> hPutStrLn stderr $ "Warning: " ++ prettyException e@@ -127,7 +97,7 @@     runTM = TIO  newtype SilentIO a = SIO { runSIO :: IO a }-    deriving (Functor, Applicative, Monad)+    deriving (Functor, Applicative, Monad, MonadThrow)  instance TolerantMonad SilentIO where     warning io = SIO $ io `catch` \(_ :: SomeException) -> return ()@@ -137,6 +107,8 @@ newtype TolerantWrapper m a = TolerantWrapper { runTolerantWrapper :: m a }     deriving (Functor, Applicative, Monad, TolerantMonad) +deriving instance MonadThrow m => MonadThrow (TolerantWrapper m)+ -- | Apply patches, emitting warnings if there are any IO errors runTolerantly :: TolerantWrapper TolerantIO a -> IO a runTolerantly = runTIO . runTolerantWrapper@@ -155,7 +127,6 @@       "\npatches in your repo, and perhaps 'darcs repair' to fix them."  instance TolerantMonad m => ApplyMonad Tree (TolerantWrapper m) where-    type ApplyMonadBase (TolerantWrapper m) = IO  instance TolerantMonad m => ApplyMonadTree (TolerantWrapper m) where     mDoesDirectoryExist d = runTM $ runDefaultIO $ mDoesDirectoryExist d@@ -170,25 +141,27 @@                                  (\(e :: IOException) ->                                    if "(Directory not empty)" `isSuffixOf` show e                                    then ioError $ userError $-                                            "Not deleting " ++ ap2fp d ++ " because it is not empty."+                                            "Not deleting " ++ realPath d ++ " because it is not empty."                                    else ioError $ userError $-                                            "Not deleting " ++ ap2fp d ++ " because:\n" ++ show e)+                                            "Not deleting " ++ realPath d ++ " because:\n" ++ show e)     mRename a b = warning $ catch                           (let do_backup = if map toLower x == map toLower y-                                           then backupByCopying (ap2fp b) -- avoid making the original vanish-                                           else backupByRenaming (ap2fp b)+                                           then backupByCopying (realPath b) -- avoid making the original vanish+                                           else backupByRenaming (realPath b)                            in do_backup >> runDefaultIO (mRename a b))                           (\e -> case () of                                  _ | isPermissionError e -> ioError $ userError $                                        couldNotRename ++ "."                                    | isDoesNotExistError e -> ioError $ userError $                                        couldNotRename ++ " because " ++ x ++ " does not exist."+                                   | isAlreadyExistsError e -> ioError $ userError $+                                       couldNotRename ++ " because " ++ y ++ " already exists."                                    | otherwise -> ioError e                           )        where-        x = ap2fp a-        y = ap2fp b+        x = realPath a+        y = realPath b         couldNotRename = "Could not rename " ++ x ++ " to " ++ y  backup :: AnchoredPath -> IO ()-backup f = backupByRenaming (ap2fp f)+backup f = backupByRenaming (realPath f)
− src/Darcs/Repository/Cache.hs 
@@ -1,596 +0,0 @@-module Darcs.Repository.Cache-    ( cacheHash-    , okayHash-    , Cache-    , mkCache-    , cacheEntries-    , CacheType(..)-    , CacheLoc(..)-    , WritableOrNot(..)-    , HashedDir(..)-    , hashedDir-    , bucketFolder-    , unionCaches-    , unionRemoteCaches-    , cleanCaches-    , cleanCachesWithHint-    , fetchFileUsingCache-    , speculateFileUsingCache-    , speculateFilesUsingCache-    , writeFileUsingCache-    , peekInCache-    , repo2cache-    , writable-    , isThisRepo-    , hashedFilePath-    , allHashedDirs-    , reportBadSources-    , closestWritableDirectory-    , dropNonRepos-    ) where--import Control.Concurrent.MVar ( MVar, newMVar, modifyMVar_, readMVar )-import Control.Monad ( liftM, when, unless, filterM, forM_, mplus )-import qualified Data.ByteString as B (length, ByteString )-import Data.List ( nub, intercalate, sortBy )-import Data.Maybe ( catMaybes, fromMaybe, listToMaybe )-import System.FilePath.Posix ( (</>), joinPath, dropFileName )-import System.Directory ( createDirectoryIfMissing, removeFile, doesFileExist,-                          doesDirectoryExist, getDirectoryContents,-                          getPermissions )-import qualified System.Directory as SD ( writable )-import System.IO ( hPutStrLn, stderr )-import System.IO.Unsafe (unsafePerformIO)-import System.Posix.Files ( createLink, linkCount, getSymbolicLinkStatus )--import Darcs.Prelude--import Darcs.Util.ByteString ( gzWriteFilePS )-import Darcs.Util.Global ( darcsdir, defaultRemoteDarcsCmd )-import Darcs.Util.External ( gzFetchFilePS, fetchFilePS-                           , speculateFileOrUrl, copyFileOrUrl-                           , Cachable( Cachable ) )-import Darcs.Repository.Flags ( Compression(..) )-import Darcs.Util.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS,-                         withTemp )-import Darcs.Util.SignalHandler ( catchNonSignal )-import Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl )-import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Util.Hash ( sha256sum )-import Darcs.Util.English ( englishNum, Noun(..), Pronoun(..) )-import Darcs.Util.Exception ( catchall )-import Darcs.Util.Progress ( progressList, debugMessage )-import qualified Darcs.Util.Download as Download ( ConnectionError )--data HashedDir = HashedPristineDir-               | HashedPatchesDir-               | HashedInventoriesDir--hashedDir :: HashedDir -> String-hashedDir HashedPristineDir = "pristine.hashed"-hashedDir HashedPatchesDir = "patches"-hashedDir HashedInventoriesDir = "inventories"--allHashedDirs :: [HashedDir]-allHashedDirs = [ HashedPristineDir-                , HashedPatchesDir-                , HashedInventoriesDir-                ]--data WritableOrNot = Writable-                   | NotWritable-                   deriving ( Eq, Show )--data CacheType = Repo-               | Directory-               deriving ( Eq, Show )--data CacheLoc = Cache-    { cacheType :: !CacheType-    , cacheWritable :: !WritableOrNot-    , cacheSource :: !String-    }---- | Cache is an abstract type for hiding the underlying cache locations-newtype Cache = Ca [CacheLoc]--mkCache :: [CacheLoc] -> Cache-mkCache = Ca . sortBy compareByLocality . nub--cacheEntries :: Cache -> [CacheLoc]-cacheEntries (Ca entries) = entries--instance Eq CacheLoc where-    (Cache aTy _ aSrc) == (Cache bTy _ bSrc) = aTy == bTy && aSrc == bSrc--instance Show CacheLoc where-    show (Cache Repo Writable a) = "thisrepo:" ++ a-    show (Cache Repo NotWritable a) = "repo:" ++ a-    show (Cache Directory Writable a) = "cache:" ++ a-    show (Cache Directory NotWritable a) = "readonly:" ++ a--instance Show Cache where-    show (Ca cs) = unlines $ map show cs--unionCaches :: Cache -> Cache -> Cache-unionCaches (Ca a) (Ca b) = Ca (nub (a ++ b))---- | unionRemoteCaches merges caches. It tries to do better than just blindly---   copying remote cache entries:------   * If remote repository is accessed through network, do not copy any cache---     entries from it. Taking local entries does not make sense and using---     network entries can lead to darcs hang when it tries to get to---     unaccessible host.------   * If remote repository is local, copy all network cache entries. For local---     cache entries if the cache directory exists and is writable it is added---     as writable cache, if it exists but is not writable it is added as---     read-only cache.------   This approach should save us from bogus cache entries. One case it does---   not work very well is when you fetch from partial repository over network.---   Hopefully this is not a common case.-unionRemoteCaches :: Cache -> Cache -> String -> IO Cache-unionRemoteCaches local (Ca remote) repourl-    | isValidLocalPath repourl =  do-        f <- filtered-        return $ local `unionCaches` Ca f-    | otherwise = return local-  where-    filtered = catMaybes `fmap`-        mapM (\x -> mbGetRemoteCacheLoc x `catchall` return Nothing) remote-    mbGetRemoteCacheLoc :: CacheLoc -> IO (Maybe CacheLoc)-    mbGetRemoteCacheLoc (Cache Repo Writable _) = return Nothing-    mbGetRemoteCacheLoc c@(Cache t _ url)-        | isValidLocalPath url = do-            ex <- doesDirectoryExist url-            if ex-                then do-                    p <- getPermissions url-                    return $ Just $ if writable c && SD.writable p-                                        then c-                                        else Cache t NotWritable url-                else return Nothing-        | otherwise = return $ Just c---- | Compares two caches, a remote cache is greater than a local one.--- The order of the comparison is given by: local < http < ssh-compareByLocality :: CacheLoc -> CacheLoc -> Ordering-compareByLocality (Cache _ w x) (Cache _ z y)-    | isValidLocalPath x && isRemote y  = LT-    | isRemote x && isValidLocalPath y = GT-    | isHttpUrl x && isSshUrl y = LT-    | isSshUrl x && isHttpUrl y = GT-    | isValidLocalPath x && isWritable w-        && isValidLocalPath y && isNotWritable z = LT-    | otherwise = EQ-  where-    isRemote r = isHttpUrl r || isSshUrl r-    isWritable = (==) Writable-    isNotWritable = (==) NotWritable--repo2cache :: String -> Cache-repo2cache r = Ca [Cache Repo NotWritable r]---- | 'cacheHash' computes the cache hash (i.e. filename) of a packed string.-cacheHash :: B.ByteString -> String-cacheHash ps = if sizeStrLen > 10-                   then shaOfPs-                   else replicate (10 - sizeStrLen) '0' ++ sizeStr-                        ++ '-' : shaOfPs-  where-    sizeStr = show $ B.length ps-    sizeStrLen = length sizeStr-    shaOfPs = sha256sum ps--okayHash :: String -> Bool-okayHash s = length s `elem` [64, 75]--checkHash :: String -> B.ByteString -> Bool-checkHash h s-    | length h == 64 = sha256sum s == h-    | length h == 75 =-        B.length s == read (take 10 h) && sha256sum s == drop 11 h-    | otherwise = False---- |@fetchFileUsingCache cache dir hash@ receives a list of caches @cache@, the--- directory for which that file belongs @dir@ and the @hash@ of the file to--- fetch.  It tries to fetch the file from one of the sources, trying them in--- order one by one.  If the file cannot be fetched from any of the sources,--- this operation fails.-fetchFileUsingCache :: Cache -> HashedDir -> String-                    -> IO (String, B.ByteString)-fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere--writable :: CacheLoc -> Bool-writable (Cache _ NotWritable _) = False-writable (Cache _ Writable _) = True---- | This keeps only 'Repo' 'NotWritable' entries.-dropNonRepos :: Cache -> Cache-dropNonRepos (Ca cache) = Ca $ filter notRepo cache where-  notRepo xs = case xs of-    Cache Directory _ _ -> False-    -- we don't want to write thisrepo: entries to the disk-    Cache Repo Writable _ -> False-    _ -> True--closestWritableDirectory :: Cache -> Maybe String-closestWritableDirectory (Ca cs) =-  listToMaybe . catMaybes .flip map cs $ \case-    Cache Directory Writable x -> Just x-    _ -> Nothing--isThisRepo :: CacheLoc -> Bool-isThisRepo (Cache Repo Writable _) = True-isThisRepo _ = False--bucketFolder :: String -> String-bucketFolder f = take 2 (cleanHash f)-    where-        cleanHash fileName = case dropWhile (/= '-') fileName of-            []  -> fileName-            s   -> drop 1 s---- | @hashedFilePath cachelocation subdir hash@ returns the physical filename--- of hash @hash@ in the @subdir@ section of @cachelocation@.-hashedFilePath :: CacheLoc -> HashedDir -> String -> String-hashedFilePath (Cache Directory _ d) s f =-    joinPath [d, hashedDir s, bucketFolder f, f]-hashedFilePath (Cache Repo _ r) s f =-    joinPath [r, darcsdir, hashedDir s, f]---- | @hashedFilePathReadOnly cachelocation subdir hash@ returns the physical filename--- of hash @hash@ in the @subdir@ section of @cachelocation@.--- If directory, assume it is non-bucketed cache (old cache location).-hashedFilePathReadOnly :: CacheLoc -> HashedDir -> String -> String-hashedFilePathReadOnly (Cache Directory _ d) s f =-    d </> hashedDir s </> f-hashedFilePathReadOnly (Cache Repo _ r) s f =-    r </> darcsdir </> hashedDir s </> f---- | @peekInCache cache subdir hash@ tells whether @cache@ and contains an--- object with hash @hash@ in a writable position.  Florent: why do we want it--- to be in a writable position?-peekInCache :: Cache -> HashedDir -> String -> IO Bool-peekInCache (Ca cache) subdir f = cacheHasIt cache `catchall` return False-  where-    cacheHasIt [] = return False-    cacheHasIt (c : cs)-        | not $ writable c = cacheHasIt cs-        | otherwise = do-            ex <- doesFileExist $ hashedFilePath c subdir f-            if ex then return True else cacheHasIt cs---- | @speculateFileUsingCache cache subdirectory name@ takes note that the file--- @name@ is likely to be useful soon: pipelined downloads will add it to the--- (low-priority) queue, for the rest it is a noop.-speculateFileUsingCache :: Cache -> HashedDir -> String -> IO ()-speculateFileUsingCache c sd h = do-    debugMessage $ "Speculating on " ++ h-    copyFileUsingCache OnlySpeculate c sd h---- | Note that the files are likely to be useful soon: pipelined downloads will--- add them to the (low-priority) queue, for the rest it is a noop.-speculateFilesUsingCache :: Cache -> HashedDir -> [String] -> IO ()-speculateFilesUsingCache _ _ [] = return ()-speculateFilesUsingCache cache sd hs = do-    debugMessage $ "Thinking about speculating on " ++ unwords hs-    hs' <- filterM (fmap not . peekInCache cache sd) hs-    unless (null hs') $ do-        debugMessage $ "Speculating on " ++ unwords hs'-        copyFilesUsingCache OnlySpeculate cache sd hs'--data OrOnlySpeculate = ActuallyCopy-                     | OnlySpeculate-                     deriving ( Eq )---- | We hace a list of locations (@cache@) ordered from "closest/fastest"--- (typically, the destination repo) to "farthest/slowest" (typically,--- the source repo).--- @copyFileUsingCache@ first checks whether given file @f@ is present--- in some writeable location, if yes, do nothing. If no, it copies it--- to the last writeable location, which would be the global cache--- by default, or the destination repo if `--no-cache` is passed.--- Function does nothing if there is no writeable location at all.--- If the copy should occur between two locations of the same filesystem,--- a hard link is actually made.--- TODO document @oos@: what happens when we only speculate?-copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()-copyFileUsingCache oos (Ca cache) subdir f = do-    debugMessage $-        "I'm doing copyFileUsingCache on " ++ hashedDir subdir </> f-    Just stickItHere <- cacheLoc cache-    createDirectoryIfMissing True-        (reverse $ dropWhile (/= '/') $ reverse stickItHere)-    debugMessage $ "Will effectively do copyFileUsingCache to: " ++ show stickItHere-    filterBadSources cache >>= sfuc stickItHere-    `catchall`-    return ()-  where-    -- return last writeable cache/repo location for file.-    -- usually returns the global cache unless `--no-cache` is passed.-    cacheLoc [] = return Nothing-    cacheLoc (c : cs)-        | not $ writable c = cacheLoc cs-        | otherwise = do-            let attemptPath = hashedFilePath c subdir f-            ex <- doesFileExist attemptPath-            if ex-                then fail $ "File already present in writable location."-                else do-                    othercache <- cacheLoc cs-                    return $ othercache `mplus` Just attemptPath-    -- do the actual copy, or hard link, or put file in download queue-    sfuc _ [] = return ()-    sfuc out (c : cs)-        | not (writable c) =-            let cacheFile = hashedFilePathReadOnly c subdir f in-            if oos == OnlySpeculate-                then speculateFileOrUrl cacheFile out-                     `catchNonSignal`-                     \e -> checkCacheReachability (show e) c-                else do debugMessage $ "Copying from " ++ show cacheFile ++ " to  " ++ show out-                        copyFileOrUrl defaultRemoteDarcsCmd cacheFile out Cachable-                     `catchNonSignal`-                     (\e -> do checkCacheReachability (show e) c-                               sfuc out cs) -- try another read-only location-        | otherwise = sfuc out cs--copyFilesUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> [String]-                    -> IO ()-copyFilesUsingCache oos cache subdir hs =-    forM_ hs $ copyFileUsingCache oos cache subdir--data FromWhere = LocalOnly-               | Anywhere-               deriving ( Eq )---- | Checks if a given cache entry is reachable or not.  It receives an error--- caught during execution and the cache entry.  If the caches is not reachable--- it is blacklisted and not longer tried for the rest of the session. If it is--- reachable it is whitelisted and future errors with such cache get ignore.--- To determine reachability:---  * For a local cache, if the given source doesn't exist anymore, it is---    blacklisted.---  * For remote sources if the error is timeout, it is blacklisted, if not,---    it checks if _darcs/hashed_inventory  exist, if it does, the entry is---    whitelisted, if it doesn't, it is blacklisted.-checkCacheReachability :: String -> CacheLoc -> IO ()-checkCacheReachability e cache-    | isValidLocalPath source = doUnreachableCheck $-        checkFileReachability (doesDirectoryExist source)-    | isHttpUrl source =-        doUnreachableCheck $ do-            let err = case dropWhile (/= '(') e of-                          (_ : xs) -> fst (break (==')') xs)-                          _ -> e-            case reads err :: [(Download.ConnectionError, String)] of-                [(_, _)] -> addBadSource source-                _ -> checkFileReachability-                    (checkHashedInventoryReachability cache)-    | isSshUrl source = doUnreachableCheck $-        checkFileReachability (checkHashedInventoryReachability cache)-    | otherwise = fail $ "unknown transport protocol for: " ++ source-  where-    source = cacheSource cache--    doUnreachableCheck unreachableAction = do-        reachable <- isReachableSource-        unless (reachable source) unreachableAction--    checkFileReachability doCheck = do-        reachable <- doCheck-        if reachable-            then addReachableSource source-            else addBadSource source---- | Returns a list of reachables cache entries, removing blacklisted entries.-filterBadSources :: [CacheLoc] -> IO [CacheLoc]-filterBadSources cache = do-    badSource <- isBadSource-    return $ filter (not . badSource . cacheSource) cache---- | Checks if the _darcs/hashed_inventory exist and is reachable-checkHashedInventoryReachability :: CacheLoc -> IO Bool-checkHashedInventoryReachability cache = withTemp $ \tempout -> do-    let f = cacheSource cache </> darcsdir </> "hashed_inventory"-    copyFileOrUrl defaultRemoteDarcsCmd f tempout Cachable-    return True-    `catchNonSignal` const (return False)---- | Get contents of some hashed file taking advantage of the cache system.--- We have a list of locations (@cache@) ordered from "closest/fastest"--- (typically, the destination repo) to "farthest/slowest" (typically,--- the source repo).--- First, if possible it copies the file from remote location to local.--- Then, it reads it contents, and links the file across all writeable--- locations including the destination repository.-fetchFileUsingCachePrivate :: FromWhere -> Cache -> HashedDir -> String-                           -> IO (String, B.ByteString)-fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f = do-    when (fromWhere == Anywhere) $-        copyFileUsingCache ActuallyCopy (Ca cache) subdir f-    filterBadSources cache >>= ffuc-    `catchall` fail ("Couldn't fetch " ++ f ++ "\nin subdir "-                          ++ hashedDir subdir ++ " from sources:\n\n"-                          ++ show (Ca cache))-  where-    ffuc (c : cs)-        | not (writable c) &&-            (Anywhere == fromWhere || isValidLocalPath (hashedFilePathReadOnly c subdir f)) = do-            let cacheFile = hashedFilePathReadOnly c subdir f-            -- looks like `copyFileUsingCache` could not copy the file we wanted.-            -- this can happen if `--no-cache` is NOT passed and the global cache is not accessible-            debugMessage $ "In fetchFileUsingCachePrivate I'm directly grabbing file contents from "-                           ++ cacheFile-            x <- gzFetchFilePS cacheFile Cachable-            if not $ checkHash f x-                then do-                    x' <- fetchFilePS cacheFile Cachable-                    unless (checkHash f x') $ do-                        hPutStrLn stderr $ "Hash failure in " ++ cacheFile-                        fail $ "Hash failure in " ++ cacheFile-                    return (cacheFile, x')-                else return (cacheFile, x) -- FIXME: create links in caches-            `catchNonSignal` \e -> do-                -- something bad happened, check if cache became unaccessible and try other ones-                checkCacheReachability (show e) c-                filterBadSources cs >>= ffuc-        | writable c = let cacheFile = hashedFilePath c subdir f in do-            debugMessage $ "About to gzFetchFilePS from " ++ show cacheFile-            x1 <- gzFetchFilePS cacheFile Cachable-            debugMessage $ "gzFetchFilePS done."-            x <- if not $ checkHash f x1-                     then do-                        x2 <- fetchFilePS cacheFile Cachable-                        unless (checkHash f x2) $ do-                            hPutStrLn stderr $ "Hash failure in " ++ cacheFile-                            removeFile cacheFile-                            fail $ "Hash failure in " ++ cacheFile-                        return x2-                     else return x1-            mapM_ (tryLinking cacheFile) cs-            return (cacheFile, x)-            `catchNonSignal` \e -> do-                debugMessage "Caught exception, now attempt creating cache."-                createCache c subdir `catchall` return ()-                checkCacheReachability (show e) c-                (fname, x) <- filterBadSources cs >>= ffuc  -- fetch file from remaining locations-                debugMessage $ "Attempt creating link from: " ++ show fname ++ " to " ++ show cacheFile-                (createLink fname cacheFile >> (debugMessage "successfully created link")-                                            >> return (cacheFile, x))-                  `catchall` do-                    debugMessage $ "Attempt writing file: " ++ show cacheFile-                    -- the following block is usually when files get actually written-                    -- inside of _darcs or global cache.-                    do createDirectoryIfMissing True (dropFileName cacheFile)-                       gzWriteFilePS cacheFile x-                       debugMessage $ "successfully wrote file"-                       `catchall` return ()-                    -- above block can fail if cache is not writeable-                    return (fname, x)-        | otherwise = ffuc cs--    ffuc [] = fail $ "No sources from which to fetch file " ++ f-                          ++ "\n"++ show (Ca cache)--    tryLinking ff c@(Cache Directory Writable d) = do-        createDirectoryIfMissing False (d </> hashedDir subdir)-        createLink ff (hashedFilePath c subdir f)-        `catchall`-        return ()-    tryLinking _ _ = return ()--createCache :: CacheLoc -> HashedDir -> IO ()-createCache (Cache Directory _ d) subdir =-    createDirectoryIfMissing True (d </> hashedDir subdir)-createCache _ _ = return ()---- | @write compression filename content@ writes @content@ to the file--- @filename@ according to the policy given by @compression@.-write :: Compression -> String -> B.ByteString -> IO ()-write NoCompression = writeAtomicFilePS-write GzipCompression = gzWriteAtomicFilePS---- | @writeFileUsingCache cache compression subdir contents@ write the string--- @contents@ to the directory subdir, except if it is already in the cache, in--- which case it is a noop.  Warning (?) this means that in case of a hash--- collision, writing using writeFileUsingCache is a noop. The returned value--- is the filename that was given to the string.-writeFileUsingCache :: Cache -> Compression -> HashedDir -> B.ByteString-                    -> IO String-writeFileUsingCache (Ca cache) compr subdir ps = do-    _ <- fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash-    return hash-    `catchall`-    wfuc cache-    `catchall`-    fail ("Couldn't write " ++ hash ++ "\nin subdir "-               ++ hashedDir subdir ++ " to sources:\n\n"++ show (Ca cache))-  where-    hash = cacheHash ps-    wfuc (c : cs)-        | not $ writable c = wfuc cs-        | otherwise = do-            createCache c subdir-            -- FIXME: create links in caches-            write compr (hashedFilePath c subdir hash) ps-            return hash-    wfuc [] = fail $ "No location to write file " ++ (hashedDir subdir </> hash)--cleanCaches :: Cache -> HashedDir -> IO ()-cleanCaches c d = cleanCachesWithHint' c d Nothing--cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO ()-cleanCachesWithHint c d h = cleanCachesWithHint' c d (Just h)--cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO ()-cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs-  where-    cleanCache (Cache Directory Writable d) =-        withCurrentDirectory (d </> hashedDir subdir) (do-            fs' <- getDirectoryContents "."-            let fs = filter okayHash $ fromMaybe fs' hint-                cleanMsg = "Cleaning cache " ++ d </> hashedDir subdir-            mapM_ clean $ progressList cleanMsg fs)-        `catchall`-        return ()-    cleanCache _ = return ()-    clean f = do-        lc <- linkCount `liftM` getSymbolicLinkStatus f-        when (lc < 2) $ removeFile f-        `catchall`-        return ()---- | Prints an error message with a list of bad caches.-reportBadSources :: IO ()-reportBadSources = do-    sources <- getBadSourcesList-    let size = length sources-    unless (null sources) $ hPutStrLn stderr $-        concat [ "\nBy the way, I could not reach the following "-               , englishNum size (Noun "location") ":"-               , "\n"-               , intercalate "\n" (map ("  " ++) sources)-               , "\nUnless you plan to restore access to "-               , englishNum size It ", you should delete "-               , "the corresponding "-               , englishNum size (Noun "entry") " from _darcs/prefs/sources."-               ]---- * Global Variables--badSourcesList :: MVar [String]-badSourcesList = unsafePerformIO $ newMVar []-{-# NOINLINE badSourcesList #-}--addBadSource :: String -> IO ()-addBadSource cache = modifyMVarPure badSourcesList (cache:)--getBadSourcesList :: IO [String]-getBadSourcesList = readMVar badSourcesList--isBadSource :: IO (String -> Bool)-isBadSource = do-    badSources <- getBadSourcesList-    return (`elem` badSources)--reachableSourcesList :: MVar [String]-reachableSourcesList = unsafePerformIO $ newMVar []-{-# NOINLINE reachableSourcesList #-}--addReachableSource :: String -> IO ()-addReachableSource src = modifyMVarPure reachableSourcesList (src:)--getReachableSources :: IO [String]-getReachableSources = readMVar reachableSourcesList--isReachableSource :: IO (String -> Bool)-isReachableSource =  do-    reachableSources <- getReachableSources-    return (`elem` reachableSources)--modifyMVarPure :: MVar a -> (a -> a) -> IO ()-modifyMVarPure mvar f = modifyMVar_ mvar (return . f)
src/Darcs/Repository/Clone.hs view
@@ -1,79 +1,73 @@ module Darcs.Repository.Clone     ( cloneRepository-    , replacePristine     ) where  import Darcs.Prelude  import Control.Exception ( catch, SomeException )-import Control.Monad ( unless, void, when )+import Control.Monad ( forM, unless, void, when ) import qualified Data.ByteString.Char8 as BC import Data.List( intercalate ) import Data.Maybe( catMaybes )-import System.FilePath( (</>) )+import System.FilePath.Posix ( (</>) ) import System.Directory     ( removeFile     , listDirectory     )-import System.IO ( stderr )  import Darcs.Repository.Create     ( EmptyRepository(..)     , createRepository-    , writePristine     )-import Darcs.Repository.State ( invalidateIndex ) import Darcs.Repository.Identify ( identifyRepositoryFor, ReadingOrWriting(..) ) import Darcs.Repository.Pristine-    ( ApplyDir(..)-    , applyToTentativePristineCwd+    ( applyToTentativePristine     , createPristineDirectoryTree+    , writePristine     ) import Darcs.Repository.Hashed     ( copyHashedInventory-    , finalizeRepositoryChanges-    , finalizeTentativeChanges-    , readRepo-    , revertRepositoryChanges-    , revertTentativeChanges+    , readPatches     , tentativelyRemovePatches     , writeTentativeInventory     )+import Darcs.Repository.Transaction+    ( finalizeRepositoryChanges+    , revertRepositoryChanges+    ) import Darcs.Repository.Working-    ( setScriptsExecutable+    ( setAllScriptsExecutable     , setScriptsExecutablePatches ) import Darcs.Repository.InternalTypes     ( Repository+    , AccessType(..)     , repoLocation     , repoFormat     , repoCache     , modifyCache     ) import Darcs.Repository.Job ( withUMaskFlag )-import Darcs.Repository.Cache-    ( unionRemoteCaches-    , unionCaches+import Darcs.Util.Cache+    ( filterRemoteCaches     , fetchFileUsingCache     , speculateFileUsingCache-    , HashedDir(..)-    , repo2cache     , dropNonRepos     )  import Darcs.Repository.ApplyPatches ( runDefault ) import Darcs.Repository.Inventory-    ( peekPristineHash-    , getValidHash+    ( PatchHash+    , encodeValidHash+    , peekPristineHash     ) import Darcs.Repository.Format     ( RepoProperty ( HashedInventory, Darcs2, Darcs3 )     , RepoFormat     , formatHas-    , readProblem     ) import Darcs.Repository.Prefs ( addRepoSource, deleteSources ) import Darcs.Repository.Match ( getOnePatchset )-import Darcs.Util.External+import Darcs.Util.File     ( copyFileOrUrl     , Cachable(..)     , gzFetchFilePS@@ -87,25 +81,24 @@     , fetchAndUnpackPatches     , packsDir     )+import Darcs.Repository.Paths ( hashedInventoryPath, pristineDirPath ) import Darcs.Repository.Resolution     ( StandardResolution(..)     , patchsetConflictResolutions     , announceConflicts     ) import Darcs.Repository.Working ( applyToWorking )-import Darcs.Util.Lock ( appendTextFile, withNewDirectory )+import Darcs.Util.Lock ( writeTextFile, withNewDirectory ) import Darcs.Repository.Flags     ( UpdatePending(..)     , UseCache(..)     , RemoteDarcs (..)     , remoteDarcs-    , Compression (..)     , CloneKind (..)     , Verbosity (..)     , DryRun (..)     , UMask (..)     , SetScriptsExecutable (..)-    , RemoteRepos (..)     , SetDefault (..)     , InheritDefault (..)     , WithWorkingDir (..)@@ -113,26 +106,29 @@     , WithPatchIndex (..)     , PatchFormat (..)     , AllowConflicts(..)-    , ExternalMerge(..)+    , ResolveConflicts(..)+    , WithPrefsTemplates(..)     ) -import Darcs.Patch ( RepoPatch, IsRepoType, description )+import Darcs.Patch ( RepoPatch, description ) import Darcs.Patch.Depends ( findUncommon )-import Darcs.Patch.Set ( patchSet2RL-                       , patchSet2FL-                       , progressPatchSet-                       )+import Darcs.Patch.Invertible ( mkInvertible )+import Darcs.Patch.Set+    ( Origin+    , patchSet2FL+    , patchSet2RL+    , patchSetInventoryHashes+    , progressPatchSet+    ) import Darcs.Patch.Match ( MatchFlag(..), patchSetMatch ) import Darcs.Patch.Progress ( progressRLShowTags, progressFL ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Ordered-    ( FL(..)+    ( (:\/:)(..)+    , FL(..)     , RL(..)-    , (:\/:)(..)     , lengthFL-    , bunchFL-    , mapFL     , mapRL     , lengthRL     , nullFL@@ -141,13 +137,13 @@  import Darcs.Util.Tree( Tree, emptyTree ) -import Darcs.Util.Download ( maxPipelineLength ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.English ( englishNum, Noun(..) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.URL ( isValidLocalPath ) import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked )-import Darcs.Util.Printer ( Doc, ($$), hPutDocLn, hsep, putDocLn, text )+import Darcs.Util.Ssh ( resetSshConnections )+import Darcs.Util.Printer ( Doc, ($$), hsep, putDocLn, text ) import Darcs.Util.Printer.Color ( unsafeRenderStringColored ) import Darcs.Util.Progress     ( debugMessage@@ -166,7 +162,6 @@     -> CloneKind     -> UMask -> RemoteDarcs     -> SetScriptsExecutable-    -> RemoteRepos     -> SetDefault     -> InheritDefault     -> [MatchFlag]@@ -175,10 +170,11 @@     -> WithPatchIndex   -- use patch index     -> Bool   -- use packs     -> ForgetParent+    -> WithPrefsTemplates     -> IO ()-cloneRepository repourl mysimplename v useCache cloneKind um rdarcs sse remoteRepos+cloneRepository repourl mysimplename v useCache cloneKind um rdarcs sse                 setDefault inheritDefault matchFlags rfsource withWorkingDir-                usePatchIndex usePacks forget =+                usePatchIndex usePacks forget withPrefsTemplates =   withUMaskFlag um $ withNewDirectory mysimplename $ do       let patchfmt             | formatHas Darcs3 rfsource = PatchFormat3@@ -186,30 +182,29 @@             | otherwise                 = PatchFormat1       EmptyRepository _toRepo <-         createRepository patchfmt withWorkingDir-          (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex) useCache+          (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex)+          useCache withPrefsTemplates       debugMessage "Finished initializing new repository."-      addRepoSource repourl NoDryRun remoteRepos setDefault inheritDefault False+      addRepoSource repourl NoDryRun setDefault inheritDefault -      debugMessage "Identifying and copying repository..."+      debugMessage "Identifying remote repository..."       fromRepo <- identifyRepositoryFor Reading _toRepo useCache repourl       let fromLoc = repoLocation fromRepo-      let rffrom = repoFormat fromRepo-      case readProblem rffrom of-        Just e ->  fail $ "Incompatibility with repository " ++ fromLoc ++ ":\n" ++ e-        Nothing -> return ()+       debugMessage "Copying prefs..."       copyFileOrUrl (remoteDarcs rdarcs)         (joinUrl [fromLoc, darcsdir, "prefs", "prefs"])         (darcsdir </> "prefs/prefs") (MaxAge 600) `catchall` return ()-      debugMessage "Copying sources..."-      cache <- unionRemoteCaches (repoCache _toRepo) (repoCache fromRepo) fromLoc-      appendTextFile (darcsdir </> "prefs/sources")-                     (show $ repo2cache fromLoc `unionCaches` dropNonRepos cache)-      debugMessage "Done copying and filtering sources."-      -- put remote source last-      _toRepo <- return $-        modifyCache (const $ cache `unionCaches` repo2cache fromLoc) _toRepo-      if formatHas HashedInventory rffrom then do++      debugMessage "Filtering remote sources..."+      cache <- filterRemoteCaches (repoCache fromRepo)+      _toRepo <- return $ modifyCache (const cache) _toRepo+      writeTextFile+        (darcsdir </> "prefs/sources")+        (unlines [show $ dropNonRepos cache])+      debugMessage $ "Considering sources:\n"++show (repoCache _toRepo)++      if formatHas HashedInventory (repoFormat fromRepo) then do        debugMessage "Copying basic repository (hashed_inventory and pristine)"        if usePacks && (not . isValidLocalPath) fromLoc          then copyBasicRepoPacked    fromRepo _toRepo v rdarcs withWorkingDir@@ -222,17 +217,17 @@            then copyCompleteRepoPacked    fromRepo _toRepo v cloneKind            else copyCompleteRepoNotPacked fromRepo _toRepo v cloneKind       else-       -- old-fashioned repositories are cloned diferently since+       -- old-fashioned repositories are cloned differently since        -- we need to copy all patches first and then build pristine        copyRepoOldFashioned fromRepo _toRepo v withWorkingDir-      when (sse == YesSetScriptsExecutable) setScriptsExecutable+      when (sse == YesSetScriptsExecutable) setAllScriptsExecutable       case patchSetMatch matchFlags of        Nothing -> return ()        Just psm -> do         putInfo v $ text "Going to specified version..."         -- the following is necessary to be able to read _toRepo's patches-        _toRepo <- revertRepositoryChanges _toRepo NoUpdatePending-        patches <- readRepo _toRepo+        _toRepo <- revertRepositoryChanges _toRepo+        patches <- readPatches _toRepo         Sealed context <- getOnePatchset _toRepo psm         to_remove :\/: only_in_context <- return $ findUncommon patches context         case only_in_context of@@ -243,11 +238,9 @@               , show num_to_remove               , englishNum num_to_remove (Noun "patch") ""               ]-            invalidateIndex _toRepo             _toRepo <--              tentativelyRemovePatches _toRepo GzipCompression NoUpdatePending to_remove-            _toRepo <--              finalizeRepositoryChanges _toRepo NoUpdatePending GzipCompression+              tentativelyRemovePatches _toRepo NoUpdatePending to_remove+            _toRepo <- finalizeRepositoryChanges _toRepo NoDryRun             runDefault (unapply to_remove) `catch` \(e :: SomeException) ->                 fail ("Couldn't undo patch in working tree.\n" ++ show e)             when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches to_remove@@ -259,24 +252,24 @@               $$ description only_in_context       when (forget == YesForgetParent) deleteSources       -- check for unresolved conflicts-      patches <- readRepo _toRepo+      patches <- readPatches _toRepo       let conflicts = patchsetConflictResolutions patches-      _ <- announceConflicts "clone" YesAllowConflictsAndMark NoExternalMerge conflicts+      _ <- announceConflicts "clone" (YesAllowConflicts MarkConflicts) conflicts       Sealed mangled_res <- return $ mangled conflicts       unless (nullFL mangled_res) $         withSignalsBlocked $ void $ applyToWorking _toRepo v mangled_res  putInfo :: Verbosity -> Doc -> IO () putInfo Quiet _ = return ()-putInfo _ d = hPutDocLn stderr d+putInfo _ d = putDocLn d  putVerbose :: Verbosity -> Doc -> IO () putVerbose Verbose d = putDocLn d putVerbose _ _ = return () -copyBasicRepoNotPacked  :: forall rt p wR wU wT.-                           Repository rt p wR wU wT -- remote-                        -> Repository rt p wR wU wT -- existing empty local+copyBasicRepoNotPacked  :: forall p wU wR.+                           Repository 'RO p wU wR -- remote+                        -> Repository 'RO p wU wR -- existing empty local                         -> Verbosity                         -> RemoteDarcs                         -> WithWorkingDir@@ -287,9 +280,9 @@   putVerbose verb $ text "Writing pristine and working tree contents..."   createPristineDirectoryTree toRepo "." withWorkingDir -copyCompleteRepoNotPacked :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                        => Repository rt p wR wU wT -- remote-                        -> Repository rt p wR wU wT -- existing basic local+copyCompleteRepoNotPacked :: forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)+                        => Repository 'RO p wU wR -- remote+                        -> Repository rt p wU wR -- existing basic local                         -> Verbosity                         -> CloneKind                         -> IO ()@@ -298,13 +291,13 @@        allowCtrlC cloneKind cleanup $ do          fetchPatchesIfNecessary toRepo          pi <- doesPatchIndexExist (repoLocation toRepo)-         ps <- readRepo toRepo+         ps <- readPatches toRepo          when pi $ createPIWithInterrupt toRepo ps  copyBasicRepoPacked ::-  forall rt p wR wU wT.-     Repository rt p wR wU wT -- remote-  -> Repository rt p wR wU wT -- existing empty local repository+  forall p wU wR.+     Repository 'RO p wU wR -- remote+  -> Repository 'RO p wU wR -- existing empty local repository   -> Verbosity   -> RemoteDarcs   -> WithWorkingDir@@ -313,9 +306,9 @@   do let fromLoc = repoLocation fromRepo      let hashURL = joinUrl [fromLoc, darcsdir, packsDir, "pristine"]      mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing)-     let hiURL = joinUrl [fromLoc, darcsdir, "hashed_inventory"]+     let hiURL = fromLoc </> hashedInventoryPath      i <- gzFetchFilePS hiURL Uncachable-     let currentHash = BC.pack $ getValidHash $ peekPristineHash i+     let currentHash = BC.pack $ encodeValidHash $ peekPristineHash i      let copyNormally = copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir      case mPackHash of       Just packHash | packHash == currentHash@@ -331,25 +324,25 @@                     copyNormally  copyBasicRepoPacked2 ::-  forall rt p wR wU wT.-     Repository rt p wR wU wT -- remote-  -> Repository rt p wR wU wT -- existing empty local repository+  forall rt p wU wR.+     Repository 'RO p wU wR -- remote+  -> Repository rt p wU wR -- existing empty local repository   -> Verbosity   -> WithWorkingDir   -> IO () copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir = do   putVerbose verb $ text "Cloning packed basic repository."   -- unpack inventory & pristine cache-  cleanDir $ darcsdir </> "pristine.hashed"-  removeFile $ darcsdir </> "hashed_inventory"+  cleanDir pristineDirPath+  removeFile hashedInventoryPath   fetchAndUnpackBasic (repoCache toRepo) (repoLocation fromRepo)   putInfo verb $ text "Done fetching and unpacking basic pack."   createPristineDirectoryTree toRepo "." withWorkingDir  copyCompleteRepoPacked ::-  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wT -- remote-  -> Repository rt p wR wU wT -- existing basic local repository+  forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)+  => Repository 'RO p wU wR -- remote+  -> Repository rt p wU wR -- existing basic local repository   -> Verbosity   -> CloneKind   -> IO ()@@ -362,83 +355,83 @@       copyCompleteRepoNotPacked from to verb cloneKind  copyCompleteRepoPacked2 ::-  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wT-  -> Repository rt p wR wU wT+  forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)+  => Repository 'RO p wU wR+  -> Repository rt p wU wR   -> Verbosity   -> CloneKind   -> IO () copyCompleteRepoPacked2 fromRepo toRepo verb cloneKind = do-  us <- readRepo toRepo+  us <- readPatches toRepo   -- get old patches   let cleanup = putInfo verb $ text "Using lazy repository."   allowCtrlC cloneKind cleanup $ do     putVerbose verb $ text "Using patches pack."-    fetchAndUnpackPatches (mapRL hashedPatchFileName $ patchSet2RL us)-      (repoCache toRepo) (repoLocation fromRepo)+    is <-+      forM (patchSetInventoryHashes us) $+        maybe (fail "unexpected unhashed inventory") return+    hs <-+      forM (mapRL hashedPatchHash $ patchSet2RL us) $+        maybe (fail "unexpected unhashed patch") return+    fetchAndUnpackPatches is hs (repoCache toRepo) (repoLocation fromRepo)     pi <- doesPatchIndexExist (repoLocation toRepo)-    when pi $ createPIWithInterrupt toRepo us -- TODO or do another readRepo?+    when pi $ createPIWithInterrupt toRepo us -- TODO or do another readPatches?  cleanDir :: FilePath -> IO () cleanDir d = mapM_ (\x -> removeFile $ d </> x) =<< listDirectory d -copyRepoOldFashioned :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                        => Repository rt p wR wU wT  -- remote repo-                        -> Repository rt p wR wU wT  -- local empty repo+copyRepoOldFashioned :: forall p wU wR. (RepoPatch p, ApplyState p ~ Tree)+                        => Repository 'RO p wU wR  -- remote repo+                        -> Repository 'RO p Origin Origin -- local empty repo                         -> Verbosity                         -> WithWorkingDir                         -> IO ()-copyRepoOldFashioned fromrepository _toRepo verb withWorkingDir = do-  revertTentativeChanges-  patches <- readRepo fromrepository+copyRepoOldFashioned fromRepo _toRepo verb withWorkingDir = do+  _toRepo <- revertRepositoryChanges _toRepo+  _ <- writePristine _toRepo emptyTree+  patches <- readPatches fromRepo   let k = "Copying patch"   beginTedious k   tediousSize k (lengthRL $ patchSet2RL patches)   let patches' = progressPatchSet k patches-  writeTentativeInventory (repoCache _toRepo) GzipCompression patches'+  writeTentativeInventory _toRepo patches'   endTedious k-  finalizeTentativeChanges _toRepo GzipCompression-  -- apply all patches into current hashed repository-  _toRepo <- revertRepositoryChanges _toRepo NoUpdatePending-  local_patches <- readRepo _toRepo-  replacePristine _toRepo emptyTree+  local_patches <- readPatches _toRepo   let patchesToApply = progressFL "Applying patch" $ patchSet2FL local_patches-  sequence_ $ mapFL (applyToTentativePristineCwd ApplyNormal) $ bunchFL 100 patchesToApply-  _toRepo <- finalizeRepositoryChanges _toRepo NoUpdatePending GzipCompression-  putVerbose verb $ text "Writing pristine and working tree contents..."+  applyToTentativePristine _toRepo (mkInvertible patchesToApply)+  _toRepo <- finalizeRepositoryChanges _toRepo NoDryRun+  putVerbose verb $ text "Writing the working tree..."   createPristineDirectoryTree _toRepo "." withWorkingDir  -- | This function fetches all patches that the given repository has --   with fetchFileUsingCache.-fetchPatchesIfNecessary :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p)-                        => Repository rt p wR wU wT+fetchPatchesIfNecessary :: forall rt p wU wR. RepoPatch p+                        => Repository rt p wU wR                         -> IO () fetchPatchesIfNecessary toRepo =-  do  ps <- readRepo toRepo-      pipelineLength <- maxPipelineLength+  do  ps <- readPatches toRepo       let patches = patchSet2RL ps           ppatches = progressRLShowTags "Copying patches" patches-          (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches-          speculate | pipelineLength > 1 = [] : first : map (:[]) other-                    | otherwise = []+          (first, other) = splitAt (100 - 1) $ tail $ hashes patches+          speculate = [] : first : map (:[]) other       mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])-  where hashes :: forall wX wY . RL (PatchInfoAnd rt p) wX wY -> [String]-        hashes = catMaybes . mapRL (either (const Nothing) Just . extractHash)-        fetchAndSpeculate :: (String, [String]) -> IO ()+  where hashes :: forall wX wY . RL (PatchInfoAnd p) wX wY -> [PatchHash]+        hashes = catMaybes . mapRL hashedPatchHash+        fetchAndSpeculate :: (PatchHash, [PatchHash]) -> IO ()         fetchAndSpeculate (f, ss) = do-          _ <- fetchFileUsingCache c HashedPatchesDir f-          mapM_ (speculateFileUsingCache c HashedPatchesDir) ss+          _ <- fetchFileUsingCache c f+          mapM_ (speculateFileUsingCache c) ss         c = repoCache toRepo --- | Replace the existing pristine with a new one (loaded up in a Tree object).-replacePristine :: Repository rt p wR wU wT -> Tree IO -> IO ()-replacePristine = writePristine . repoLocation- allowCtrlC :: CloneKind -> IO () -> IO () -> IO ()-allowCtrlC CompleteClone _       action = action-allowCtrlC _             cleanup action = action `catchInterrupt` cleanup+allowCtrlC CompleteClone _ action = action+allowCtrlC _ cleanup action =+  action `catchInterrupt` do+    debugMessage "Cleanup after SIGINT in allowCtrlC"+    -- the SIGINT has also killed our running ssh connections,+    -- this will cause them to be restarted+    resetSshConnections+    cleanup -hashedPatchFileName :: PatchInfoAnd rt p wA wB -> String-hashedPatchFileName x = case extractHash x of-  Left _ -> fail "unexpected unhashed patch"-  Right h -> h+hashedPatchHash :: PatchInfoAnd p wA wB -> Maybe PatchHash+hashedPatchHash = either (const Nothing) Just . extractHash
src/Darcs/Repository/Create.hs view
@@ -3,14 +3,12 @@     , createRepositoryV1     , createRepositoryV2     , EmptyRepository(..)-    , writePristine     ) where  import Darcs.Prelude  import Control.Monad ( when ) import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC import Data.Maybe( isJust ) import System.Directory     ( createDirectory@@ -24,7 +22,6 @@  import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Set ( Origin, emptyPatchSet ) import Darcs.Patch.V1 ( RepoPatchV1 ) import Darcs.Patch.V2 ( RepoPatchV2 )@@ -32,21 +29,18 @@ import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) -import Darcs.Repository.Cache ( Cache )+import Darcs.Util.Cache ( Cache ) import Darcs.Repository.Format     ( RepoFormat     , createRepoFormat-    , writeRepoFormat+    , unsafeWriteRepoFormat     ) import Darcs.Repository.Flags-    ( UseCache(..)-    , WithWorkingDir (..)-    , WithPatchIndex (..)-    , PatchFormat (..)-    )-import Darcs.Repository.Inventory-    ( pokePristineHash-    , mkValidHash+    ( PatchFormat(..)+    , UseCache(..)+    , WithPatchIndex(..)+    , WithPrefsTemplates(..)+    , WithWorkingDir(..)     ) import Darcs.Repository.Paths     ( pristineDirPath@@ -57,8 +51,9 @@     ) import Darcs.Repository.Identify ( seekRepo ) import Darcs.Repository.InternalTypes-    ( Repository+    ( AccessType(..)     , PristineType(..)+    , Repository     , mkRepo     ) import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk )@@ -67,21 +62,15 @@     , getCaches     , prefsDirPath     )+import Darcs.Repository.Pristine ( writePristine ) -import Darcs.Util.ByteString( gzReadFilePS )-import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Hash( encodeBase16 )-import Darcs.Util.Lock-    ( writeBinFile-    , writeDocBinFile-    )-import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath )+import Darcs.Util.Lock ( writeBinFile )+import Darcs.Util.Path ( AbsoluteOrRemotePath, ioAbsoluteOrRemote ) import Darcs.Util.Tree( Tree, emptyTree )-import Darcs.Util.Tree.Hashed( writeDarcsHashed, darcsAddMissingHashes ) -createRepositoryFiles :: PatchFormat -> WithWorkingDir -> IO RepoFormat-createRepositoryFiles patchfmt withWorkingDir = do+createRepositoryFiles :: PatchFormat -> WithWorkingDir -> WithPrefsTemplates -> IO RepoFormat+createRepositoryFiles patchfmt withWorkingDir withPrefsTemplates = do   cwd <- getCurrentDirectory   x <- seekRepo   when (isJust x) $ do@@ -95,89 +84,82 @@   createDirectory patchesDirPath   createDirectory inventoriesDirPath   createDirectory prefsDirPath-  writeDefaultPrefs+  writeDefaultPrefs withPrefsTemplates   let repo_format = createRepoFormat patchfmt withWorkingDir-  writeRepoFormat repo_format formatPath+  unsafeWriteRepoFormat repo_format formatPath   -- note: all repos we create nowadays are hashed   writeBinFile hashedInventoryPath B.empty-  writePristine here emptyTree   return repo_format  data EmptyRepository where   EmptyRepository :: (RepoPatch p, ApplyState p ~ Tree)-                  => Repository ('RepoType 'NoRebase) p Origin Origin Origin+                  => Repository 'RO p Origin Origin                   -> EmptyRepository -createRepository :: PatchFormat -> WithWorkingDir -> WithPatchIndex -> UseCache+createRepository :: PatchFormat -> WithWorkingDir -> WithPatchIndex -> UseCache -> WithPrefsTemplates                  -> IO EmptyRepository-createRepository patchfmt withWorkingDir withPatchIndex useCache = do-  rfmt <- createRepositoryFiles patchfmt withWorkingDir-  cache <- getCaches useCache here-  rdir <- toPath <$> ioAbsoluteOrRemote here+createRepository patchfmt withWorkingDir withPatchIndex useCache withPrefsTemplates = do+  rfmt <- createRepositoryFiles patchfmt withWorkingDir withPrefsTemplates+  rdir <- ioAbsoluteOrRemote here+  cache <- getCaches useCache Nothing   repo@(EmptyRepository r) <- case patchfmt of     PatchFormat1 -> return $ EmptyRepository $ mkRepoV1 rdir rfmt cache     PatchFormat2 -> return $ EmptyRepository $ mkRepoV2 rdir rfmt cache     PatchFormat3 -> return $ EmptyRepository $ mkRepoV3 rdir rfmt cache+  _ <- writePristine r emptyTree   maybeCreatePatchIndex withPatchIndex r   return repo  mkRepoV1-  :: FilePath+  :: AbsoluteOrRemotePath   -> RepoFormat   -> Cache-  -> Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin+  -> Repository 'RO (RepoPatchV1 V1.Prim) Origin Origin mkRepoV1 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache  mkRepoV2-  :: FilePath+  :: AbsoluteOrRemotePath   -> RepoFormat   -> Cache-  -> Repository ('RepoType 'NoRebase) (RepoPatchV2 V2.Prim) Origin Origin Origin+  -> Repository 'RO (RepoPatchV2 V2.Prim) Origin Origin mkRepoV2 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache  mkRepoV3-  :: FilePath+  :: AbsoluteOrRemotePath   -> RepoFormat   -> Cache-  -> Repository ('RepoType 'NoRebase) (RepoPatchV3 V2.Prim) Origin Origin Origin+  -> Repository 'RO (RepoPatchV3 V2.Prim) Origin Origin mkRepoV3 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache  createRepositoryV1-  :: WithWorkingDir -> WithPatchIndex -> UseCache-  -> IO (Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin)-createRepositoryV1 withWorkingDir withPatchIndex useCache = do-  rfmt <- createRepositoryFiles PatchFormat1 withWorkingDir-  cache <- getCaches useCache here-  rdir <- toPath <$> ioAbsoluteOrRemote here+  :: WithWorkingDir -> WithPatchIndex -> UseCache -> WithPrefsTemplates+  -> IO (Repository 'RO (RepoPatchV1 V1.Prim) Origin Origin)+createRepositoryV1 withWorkingDir withPatchIndex useCache withPrefsTemplates = do+  rfmt <- createRepositoryFiles PatchFormat1 withWorkingDir withPrefsTemplates+  rdir <- ioAbsoluteOrRemote here+  cache <- getCaches useCache Nothing   let repo = mkRepoV1 rdir rfmt cache+  _ <- writePristine repo emptyTree   maybeCreatePatchIndex withPatchIndex repo   return repo  createRepositoryV2-  :: WithWorkingDir -> WithPatchIndex -> UseCache-  -> IO (Repository ('RepoType 'NoRebase) (RepoPatchV2 V2.Prim) Origin Origin Origin)-createRepositoryV2 withWorkingDir withPatchIndex useCache = do-  rfmt <- createRepositoryFiles PatchFormat2 withWorkingDir-  cache <- getCaches useCache here-  rdir <- toPath <$> ioAbsoluteOrRemote here+  :: WithWorkingDir -> WithPatchIndex -> UseCache -> WithPrefsTemplates+  -> IO (Repository 'RO (RepoPatchV2 V2.Prim) Origin Origin)+createRepositoryV2 withWorkingDir withPatchIndex useCache withPrefsTemplates = do+  rfmt <- createRepositoryFiles PatchFormat2 withWorkingDir withPrefsTemplates+  rdir <- ioAbsoluteOrRemote here+  cache <- getCaches useCache Nothing   let repo = mkRepoV2 rdir rfmt cache+  _ <- writePristine repo emptyTree   maybeCreatePatchIndex withPatchIndex repo   return repo  maybeCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree)-                      => WithPatchIndex -> Repository rt p Origin wU Origin -> IO ()+                      => WithPatchIndex -> Repository 'RO p wU Origin -> IO () maybeCreatePatchIndex NoPatchIndex _ = return () maybeCreatePatchIndex YesPatchIndex repo =   createOrUpdatePatchIndexDisk repo emptyPatchSet--writePristine :: FilePath -> Tree IO -> IO ()-writePristine dir tree =-  withCurrentDirectory dir $ do-    inv <- gzReadFilePS hashedInventoryPath-    tree' <- darcsAddMissingHashes tree-    root <- writeDarcsHashed tree' pristineDirPath-    writeDocBinFile hashedInventoryPath $-      pokePristineHash (mkValidHash $ BC.unpack $ encodeBase16 root) inv  here :: String here = "."
src/Darcs/Repository/Diff.hs view
@@ -54,7 +54,7 @@ import Darcs.Util.ByteString ( isFunky ) import Darcs.Patch  ( PrimPatch                     , hunk-                    , canonize+                    , canonizeFL                     , binary                     , addfile                     , rmfile@@ -63,7 +63,7 @@                     , invert                     ) import Darcs.Repository.Prefs ( FileType(..) )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatGapsFL, consGapFL ) import Darcs.Patch.Witnesses.Sealed ( Gap(..) ) import Darcs.Repository.Flags ( DiffAlgorithm(..) ) @@ -91,7 +91,7 @@ treeDiff da ft t1 t2 = do     (from, to) <- diffTrees t1 t2     diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to-    return $ foldr (joinGap (+>+)) (emptyGap NilFL) diffs+    return $ concatGapsFL diffs   where     -- sort into removes, changes, adds, with removes in reverse-path order     -- and everything else in forward order@@ -117,7 +117,7 @@         return $ freeGap (adddir p :>: NilFL)     diff p (Added b'@(File _)) =         do diff' <- diff p (Changed (File emptyBlob) b')-           return $ joinGap (:>:) (freeGap (addfile p)) diff'+           return $ consGapFL (addfile p) diff'     diff p (Removed a'@(File _)) =         do diff' <- diff p (Changed a' (File emptyBlob))            return $ joinGap (+>+) diff' (freeGap (rmfile p :>: NilFL))@@ -174,7 +174,7 @@                     = freeGap (line_diff p (linesB $ BLC.init a) (linesB $ BLC.init b))         | otherwise = freeGap (line_diff p (linesB a) (linesB b)) -    line_diff p a b = canonize da (hunk p 1 a b)+    line_diff p a b = canonizeFL da (hunk p 1 a b :>: NilFL)      diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) []                       | otherwise = line_diff p (linesB x) [B.empty]
src/Darcs/Repository/Flags.hs view
@@ -1,7 +1,5 @@ module Darcs.Repository.Flags-    (-      Compression (..)-    , RemoteDarcs (..)+    ( RemoteDarcs (..)     , remoteDarcs     , Reorder (..)     , Verbosity (..)@@ -13,26 +11,24 @@     , LookForReplaces (..)     , DiffAlgorithm (..)     , LookForMoves (..)+    , DiffOpts (..)     , RunTest (..)     , SetScriptsExecutable (..)     , LeaveTestDir (..)-    , RemoteRepos (..)     , SetDefault (..)     , InheritDefault (..)     , UseIndex (..)-    , ScanKnown (..)     , CloneKind (..)     , AllowConflicts (..)-    , ExternalMerge (..)+    , ResolveConflicts (..)     , WorkRepo (..)     , WantGuiPause (..)     , WithPatchIndex (..)     , WithWorkingDir (..)     , ForgetParent (..)     , PatchFormat (..)-    , IncludeBoring (..)-    , HooksConfig (..)-    , HookConfig (..)+    , WithPrefsTemplates (..)+    , OptimizeDeep (..)     ) where  import Darcs.Prelude@@ -40,14 +36,9 @@ import Darcs.Util.Diff ( DiffAlgorithm(..) ) import Darcs.Util.Global ( defaultRemoteDarcsCmd ) - data Verbosity = Quiet | NormalVerbosity | Verbose     deriving ( Eq, Show ) -data Compression = NoCompression-                 | GzipCompression-    deriving ( Eq, Show )- data WithPatchIndex = YesPatchIndex | NoPatchIndex     deriving ( Eq, Show ) @@ -74,7 +65,7 @@ data UMask = YesUMask String | NoUMask     deriving ( Eq, Show ) -data LookForAdds = YesLookForAdds | NoLookForAdds+data LookForAdds = NoLookForAdds | YesLookForAdds | EvenLookForBoring     deriving ( Eq, Show )  data LookForReplaces = YesLookForReplaces | NoLookForReplaces@@ -83,8 +74,13 @@ data LookForMoves = YesLookForMoves | NoLookForMoves     deriving ( Eq, Show ) -data IncludeBoring = YesIncludeBoring | NoIncludeBoring-    deriving ( Eq, Show )+data DiffOpts = DiffOpts+  { withIndex :: UseIndex+  , lookForAdds :: LookForAdds+  , lookForReplaces :: LookForReplaces+  , lookForMoves :: LookForMoves+  , diffAlg :: DiffAlgorithm+  } deriving Show  data RunTest = YesRunTest | NoRunTest     deriving ( Eq, Show )@@ -95,9 +91,6 @@ data LeaveTestDir = YesLeaveTestDir | NoLeaveTestDir     deriving ( Eq, Show ) -data RemoteRepos = RemoteRepos [String]-    deriving ( Eq, Show )- data SetDefault = YesSetDefault Bool | NoSetDefault Bool     deriving ( Eq, Show ) @@ -106,21 +99,16 @@  data UseIndex = UseIndex | IgnoreIndex deriving ( Eq, Show ) -data ScanKnown = ScanKnown -- ^Just files already known to darcs-               | ScanAll -- ^All files, i.e. look for new ones-               | ScanBoring -- ^All files, even boring ones-    deriving ( Eq, Show )- -- Various kinds of getting repositories data CloneKind = LazyClone       -- ^Just copy pristine and inventories                | NormalClone     -- ^First do a lazy clone then copy everything                | CompleteClone   -- ^Same as Normal but omit telling user they can interrumpt     deriving ( Eq, Show ) -data AllowConflicts = NoAllowConflicts | YesAllowConflicts | YesAllowConflictsAndMark+data AllowConflicts = NoAllowConflicts | YesAllowConflicts ResolveConflicts     deriving ( Eq, Show ) -data ExternalMerge = YesExternalMerge String | NoExternalMerge+data ResolveConflicts = NoResolveConflicts | MarkConflicts | ExternalMerge String     deriving ( Eq, Show )  data WorkRepo = WorkRepoDir String | WorkRepoPossibleURL String | WorkRepoCurrentDir@@ -138,12 +126,8 @@ data PatchFormat = PatchFormat1 | PatchFormat2 | PatchFormat3     deriving ( Eq, Show ) -data HooksConfig = HooksConfig-  { pre :: HookConfig-  , post :: HookConfig-  }+data WithPrefsTemplates =  WithPrefsTemplates | NoPrefsTemplates+    deriving ( Eq, Show ) -data HookConfig = HookConfig-  { cmd :: Maybe String-  , prompt :: Bool-  }+data OptimizeDeep = OptimizeShallow | OptimizeDeep+    deriving ( Eq, Show )
src/Darcs/Repository/Format.hs view
@@ -66,7 +66,7 @@     , identifyRepoFormat     , tryIdentifyRepoFormat     , createRepoFormat-    , writeRepoFormat+    , unsafeWriteRepoFormat     , writeProblem     , readProblem     , transferProblem@@ -77,15 +77,16 @@  import Darcs.Prelude +import Control.Exception ( try ) import Control.Monad ( mplus, (<=<) )-import qualified Data.ByteString.Char8 as BC ( split, pack, unpack, elem )-import qualified Data.ByteString  as B ( ByteString, null, empty, stripPrefix )+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString  as B import Data.List ( partition, intercalate, (\\) ) import Data.Maybe ( mapMaybe ) import Data.String ( IsString ) import System.FilePath.Posix( (</>) ) -import Darcs.Util.External+import Darcs.Util.File     ( fetchFilePS     , Cachable( Cachable )     )@@ -93,11 +94,9 @@ import qualified Darcs.Repository.Flags as F     ( WithWorkingDir (..), PatchFormat (..)  ) import Darcs.Repository.Paths ( formatPath, oldInventoryPath )-import Darcs.Util.SignalHandler ( catchNonSignal )-import Darcs.Util.Exception ( catchall, prettyException )+import Darcs.Util.Exception ( prettyException )  import Darcs.Util.ByteString ( linesPS )-import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO )  data RepoProperty = Darcs1                   | Darcs2@@ -180,23 +179,27 @@ -- resulting 'RepoFormat'. tryIdentifyRepoFormat :: String -> IO (Either String RepoFormat) tryIdentifyRepoFormat repo = do-    let k = "Identifying repository " ++ repo-    beginTedious k-    finishedOneIO k "format"-    formatInfo <- (fetchFilePS (repo </> formatPath) Cachable)-                  `catchall` (return B.empty)-    -- We use a workaround for servers that don't return a 404 on nonexistent-    -- files (we trivially check for something that looks like a HTML/XML tag).-    format <--      if B.null formatInfo || BC.elem '<' formatInfo then do-        finishedOneIO k "inventory"-        missingInvErr <- checkFile (repo </> oldInventoryPath)-        case missingInvErr of-          Nothing -> return . Right $ RF [[Darcs1]]-          Just e -> return . Left $ makeErrorMsg e-      else return . Right $ readFormat formatInfo-    endTedious k-    return format+  formatResult <-+    fetchFile formatPath >>= \case+      Left e ->+        return $ Left $ prettyException e+      Right content | BC.elem '<' content ->+        -- We use a workaround for servers that don't return a 404 on nonexistent+        -- files (we trivially check for something that looks like a HTML/XML tag).+        return $ Left $ "invalid file content of " ++ (repo </> formatPath) ++ ":\n"+          ++ BC.unpack content+      Right content ->+        return $ Right $ readFormat content+  case formatResult of+    Right _ -> return formatResult+    Left formatError ->+      fetchFile oldInventoryPath >>= \case+        Right _ ->+          return $ Right $ RF [[Darcs1]]+        Left inventoryError ->+          -- report only the formatError+          return $ Left $ makeErrorMsg $+            formatError ++ "\nAnd also:\n" ++ prettyException inventoryError   where     readFormat =       RF . map (map (readRepoProperty . fixupUnknownFormat)) . splitFormat@@ -210,15 +213,15 @@     -- split into lines, then split each non-empty line on '|'     splitFormat = map (BC.split '|') . filter (not . B.null) . linesPS -    checkFile path = (fetchFilePS path Cachable >> return Nothing)-                     `catchNonSignal`-                     (return . Just . prettyException)+    fetchFile path = try (fetchFilePS (repo </> path) Cachable) -    makeErrorMsg e =  "Not a repository: " ++ repo ++ " (" ++ e ++ ")"+    makeErrorMsg e =  "Not a repository: " ++ repo ++ ":\n" ++ e  -- | Write the repo format to the given file.-writeRepoFormat :: RepoFormat -> FilePath -> IO ()-writeRepoFormat rf loc = writeBinFile loc $ BC.pack $ show rf+-- This is unsafe because we don't check that we are allowed to write+-- to the repo.+unsafeWriteRepoFormat :: RepoFormat -> FilePath -> IO ()+unsafeWriteRepoFormat rf loc = writeBinFile loc $ BC.pack $ show rf -- note: this assumes show returns ascii  -- | Create a repo format. The first argument specifies the patch
src/Darcs/Repository/Hashed.hs view
@@ -16,12 +16,10 @@ {-# LANGUAGE OverloadedStrings #-} module Darcs.Repository.Hashed     ( revertTentativeChanges-    , revertRepositoryChanges     , finalizeTentativeChanges     , addToTentativeInventory-    , readRepo-    , readRepoHashed-    , readTentativeRepo+    , readPatches+    , readTentativePatches     , writeAndReadPatch     , writeTentativeInventory     , copyHashedInventory@@ -30,179 +28,138 @@     , tentativelyRemovePatches     , tentativelyRemovePatches_     , tentativelyAddPatch_+    , tentativelyAddPatches     , tentativelyAddPatches_-    , finalizeRepositoryChanges     , reorderInventory     , UpdatePristine(..)     , repoXor-    , upgradeOldStyleRebase     ) where  import Darcs.Prelude -import Control.Exception ( catch )-import Darcs.Util.Exception ( catchall )-import Control.Monad ( when, unless )-import Data.Maybe-import Data.List( foldl' )--import qualified Data.ByteString as B ( empty, readFile, append )-import qualified Data.ByteString.Char8 as BC ( pack )--import Darcs.Util.Hash( SHA1, sha1Xor, sha1zero )-import Darcs.Util.Prompt ( promptYorn )-import Darcs.Util.Tree ( Tree )-import Darcs.Util.SignalHandler ( withSignalsBlocked )-+import Control.Monad ( unless, when )+import Data.List ( foldl' ) import System.Directory     ( copyFile     , createDirectoryIfMissing-    , doesFileExist-    , removeFile     , renameFile     )-import System.FilePath.Posix( (</>) )+import System.FilePath.Posix ( (</>) ) import System.IO.Unsafe ( unsafeInterleaveIO )-import System.IO ( IOMode(..), hClose, hPutStrLn, openBinaryFile, stderr )-import System.IO.Error ( catchIOError, isDoesNotExistError ) -import Darcs.Util.External-    ( copyFileOrUrl-    , cloneFile-    , gzFetchFilePS-    , Cachable( Uncachable )+import Darcs.Patch ( RepoPatch, effect, invert, invertFL, readPatch )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Depends+    ( cleanLatestTag+    , removeFromPatchSet+    , slightlyOptimizePatchset+    , fullyOptimizePatchSet     )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Info ( displayPatchInfo, makePatchname, piName )+import Darcs.Patch.Invertible ( mkInvertible )+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , createHashed+    , hopefully+    , info+    , patchInfoAndPatch+    )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Rebase.Suspended+    ( addFixupsToSuspended+    , removeFixupsFromSuspended+    )+import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2RL )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , foldlwFL+    , foldrwFL+    , mapRL+    , sequenceFL_+    , (+>+)+    , (+>>+)+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+ import Darcs.Repository.Flags-    ( Compression+    ( OptimizeDeep(..)     , RemoteDarcs     , UpdatePending(..)-    , Verbosity(..)     , remoteDarcs     )- import Darcs.Repository.Format-    ( RepoProperty( HashedInventory, RebaseInProgress, RebaseInProgress_2_16 )+    ( RepoProperty(HashedInventory)     , formatHas-    , writeRepoFormat-    , addToFormat-    , removeFromFormat     )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , Repository+    , SAccessType(..)+    , repoAccessType+    , repoCache+    , repoFormat+    , repoLocation+    , unsafeCoerceR+    , withRepoDir+    )+import Darcs.Repository.Inventory+    ( peekPristineHash+    , pokePristineHash+    , readPatchesFromInventoryFile+    , showInventoryEntry+    , writeInventory+    , writePatchIfNecessary+    )+import qualified Darcs.Repository.Old as Old ( oldRepoFailMsg, readOldRepo )+import Darcs.Repository.Paths import Darcs.Repository.Pending-    ( tentativelyRemoveFromPending-    , revertPending-    , finalizePending-    , readTentativePending+    ( readTentativePending     , writeTentativePending     )-import Darcs.Repository.PatchIndex-    ( createOrUpdatePatchIndexDisk-    , doesPatchIndexExist-    ) import Darcs.Repository.Pristine-    ( ApplyDir(..)-    , applyToTentativePristine-    , applyToTentativePristineCwd+    ( applyToTentativePristine+    , convertSizePrefixedPristine     )-import Darcs.Repository.Paths import Darcs.Repository.Rebase     ( withTentativeRebase-    , createTentativeRebase-    , readTentativeRebase-    , writeTentativeRebase-    , commuteOutOldStyleRebase     )-import Darcs.Repository.State ( readRecorded, updateIndex )--import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Lock-    ( writeBinFile-    , writeDocBinFile-    , writeAtomicFilePS-    , appendDocBinFile-    , removeFileMayNotExist+import Darcs.Repository.Traverse ( cleanRepository )+import Darcs.Repository.Unrevert+    ( removeFromUnrevertContext     )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..)-                       , SealedPatchSet, Origin-                       , patchSet2RL-                       ) -import Darcs.Patch.Show ( ShowPatchFor(..) )-import qualified Darcs.Patch.Named.Wrapped as W-import Darcs.Patch.PatchInfoAnd-    ( PatchInfoAnd, PatchInfoAndG, Hopefully, patchInfoAndPatch, info-    , extractHash, createHashed, hopefully-    , fmapPIAP-    )-import Darcs.Patch ( IsRepoType, RepoPatch, showPatch-                   , commuteRL-                   , readPatch-                   , effect-                   , displayPatch-                   )--import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Bundle ( Bundle(..), makeBundle, interpretBundle, parseBundle )-import Darcs.Patch.Read ( ReadPatch )-import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset-                           , mergeThem, cleanLatestTag )-import Darcs.Patch.Info-    ( PatchInfo, displayPatchInfo, makePatchname )-import Darcs.Patch.Rebase.Suspended-    ( Suspended(..), addFixupsToSuspended, removeFixupsFromSuspended )--import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath )-import Darcs.Repository.Cache-    ( Cache-    , HashedDir(..)-    , fetchFileUsingCache-    , hashedDir-    , peekInCache-    , speculateFilesUsingCache-    , writeFileUsingCache-    )-import Darcs.Repository.Inventory-import Darcs.Repository.InternalTypes-    ( Repository-    , repoCache-    , repoFormat-    , repoLocation-    , withRepoLocation-    , unsafeCoerceR-    , unsafeCoerceT-    )-import qualified Darcs.Repository.Old as Old ( readOldRepo, oldRepoFailMsg )-import Darcs.Patch.Witnesses.Ordered-    ( (+<+), FL(..), RL(..), mapRL, foldFL_M, foldrwFL, mapRL_RL-    , (:>)(..), lengthFL, (+>+)-    , reverseFL )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )- import Darcs.Util.ByteString ( gzReadFilePS )-import Darcs.Util.Printer.Color ( debugDoc, ePutDocLn )-import Darcs.Util.Printer-    ( Doc-    , ($$)-    , (<+>)-    , hcat-    , renderPS-    , renderString-    , text+import Darcs.Util.Cache ( Cache, fetchFileUsingCache )+import Darcs.Util.File ( Cachable(Uncachable), copyFileOrUrl )+import Darcs.Util.Hash ( SHA1, sha1Xor, sha1zero )+import Darcs.Util.Lock+    ( appendDocBinFile+    , writeAtomicFilePS+    , writeDocBinFile     )-import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )-import Darcs.Patch.Progress (progressFL)-+import Darcs.Util.Printer ( renderString )+import Darcs.Util.Progress ( beginTedious, debugMessage, endTedious )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Tree ( Tree )  -- |revertTentativeChanges swaps the tentative and "real" hashed inventory -- files, and then updates the tentative pristine with the "real" inventory -- hash.-revertTentativeChanges :: IO ()-revertTentativeChanges = do-    cloneFile hashedInventoryPath tentativeHashedInventoryPath-    i <- gzReadFilePS hashedInventoryPath-    writeBinFile tentativePristinePath $-        B.append pristineName $ BC.pack $ getValidHash $ peekPristineHash i+revertTentativeChanges :: Repository 'RO p wU wR -> IO ()+revertTentativeChanges repo = do+    copyFile hashedInventoryPath tentativeHashedInventoryPath+    inv <- gzReadFilePS tentativeHashedInventoryPath+    pristineHash <- convertSizePrefixedPristine (repoCache repo) (peekPristineHash inv)+    writeDocBinFile tentativePristinePath $ pokePristineHash pristineHash mempty+{-+    -- this is not needed, as we never again access the pristine hash in+    -- tentativeHashedInventoryPath, only that in tentativePristinePath+    writeDocBinFile tentativeHashedInventoryPath $+      pokePristineHash pristineHash inv+-}  -- |finalizeTentativeChanges trys to atomically swap the tentative -- inventory/pristine pointers with the "real" pointers; it first re-reads the@@ -210,215 +167,66 @@ -- then writes out the new tentative inventory, and finally does the atomic -- swap. In general, we can't clean the pristine cache at the same time, since -- a simultaneous get might be in progress.-finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p)-                         => Repository rt p wR wU wT -> Compression -> IO ()-finalizeTentativeChanges r compr = do+finalizeTentativeChanges :: RepoPatch p+                         => Repository 'RW p wU wR -> IO ()+finalizeTentativeChanges r = do     debugMessage "Optimizing the inventory..."     -- Read the tentative patches-    ps <- readTentativeRepo r "."-    writeTentativeInventory (repoCache r) compr ps+    ps <- readTentativePatches r+    writeTentativeInventory r ps     i <- gzReadFilePS tentativeHashedInventoryPath     p <- gzReadFilePS tentativePristinePath     -- Write out the "optimised" tentative inventory.-    writeDocBinFile tentativeHashedInventoryPath $ pokePristineHash (peekPristineHash p) i+    writeDocBinFile tentativeHashedInventoryPath $+        pokePristineHash (peekPristineHash p) i     -- Atomically swap.     renameFile tentativeHashedInventoryPath hashedInventoryPath --- | Add (append) a patch to a specific inventory file.--- | Warning: this allows to add any arbitrary patch!-addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression-                       -> PatchInfoAnd rt p wX wY -> IO ()-addToSpecificInventory invPath c compr p = do-    let invFile = makeDarcsdirPath invPath-    hash <- snd <$> writePatchIfNecessary c compr p-    appendDocBinFile invFile $ showInventoryEntry (info p, hash)- -- | Add (append) a patch to the tentative inventory.--- | Warning: this allows to add any arbitrary patch! Used by convert import.-addToTentativeInventory :: RepoPatch p => Cache -> Compression-                        -> PatchInfoAnd rt p wX wY -> IO ()-addToTentativeInventory = addToSpecificInventory tentativeHashedInventory---- |writeHashFile takes a Doc and writes it as a hash-named file, returning the--- filename that the contents were written to.-writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String-writeHashFile c compr subdir d = do-    debugMessage $ "Writing hash file to " ++ hashedDir subdir-    writeFileUsingCache c compr subdir $ renderPS d---- |readRepo returns the "current" repo patchset.-readRepoHashed :: (IsRepoType rt, RepoPatch p) => Repository rt p wR wU wT-               -> String -> IO (PatchSet rt p Origin wR)-readRepoHashed = readRepoUsingSpecificInventory hashedInventory---- |readRepo returns the tentative repo patchset.-readTentativeRepo :: (IsRepoType rt, PatchListFormat p, ReadPatch p)-                  => Repository rt p wR wU wT -> String-                  -> IO (PatchSet rt p Origin wT)-readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory---- |readRepoUsingSpecificInventory uses the inventory at @invPath@ to read the--- repository @repo@.-readRepoUsingSpecificInventory :: (IsRepoType rt, PatchListFormat p, ReadPatch p)-                               => String -> Repository rt p wR wU wT-                               -> String -> IO (PatchSet rt p Origin wS)-readRepoUsingSpecificInventory invPath repo dir = do-    realdir <- toPath <$> ioAbsoluteOrRemote dir-    Sealed ps <- readRepoPrivate (repoCache repo) realdir invPath-                 `catch` \e -> do-                     hPutStrLn stderr ("Invalid repository: " ++ realdir)-                     ioError e-    return $ unsafeCoerceP ps-  where-    readRepoPrivate :: (IsRepoType rt, PatchListFormat p, ReadPatch p)-                    => Cache -> FilePath-                    -> FilePath -> IO (SealedPatchSet rt p Origin)-    readRepoPrivate cache d iname = do-      inventory <- readInventoryPrivate (d </> darcsdir </> iname)-      readRepoFromInventoryList cache inventory---- | Read a 'PatchSet' from the repository (assumed to be located at the--- current working directory) by following the chain of 'Inventory's, starting--- with the given one. The 'Cache' parameter is used to locate patches and parent--- inventories, since not all of them need be present inside the current repo.-readRepoFromInventoryList-  :: (IsRepoType rt, PatchListFormat p, ReadPatch p)-  => Cache-  -> Inventory-  -> IO (SealedPatchSet rt p Origin)-readRepoFromInventoryList cache = parseInv-  where-    parseInv :: (IsRepoType rt, PatchListFormat p, ReadPatch p)-             => Inventory-             -> IO (SealedPatchSet rt p Origin)-    parseInv (Inventory Nothing ris) =-        mapSeal (PatchSet NilRL) <$> readPatchesFromInventory cache ris-    parseInv (Inventory (Just h) []) =-        -- TODO could be more tolerant and create a larger PatchSet-        error $ "bad inventory " ++ getValidHash h ++ " (no tag) in parseInv!"-    parseInv (Inventory (Just h) (t : ris)) = do-        Sealed ts <- unseal seal <$> unsafeInterleaveIO (read_ts t h)-        Sealed ps <- unseal seal <$>-                        unsafeInterleaveIO (readPatchesFromInventory cache ris)-        return $ seal $ PatchSet ts ps--    read_ts :: (IsRepoType rt, PatchListFormat p, ReadPatch p) => InventoryEntry-            -> InventoryHash -> IO (Sealed (RL (Tagged rt p) Origin))-    read_ts tag0 h0 = do-        contents <- unsafeInterleaveIO $ readTaggedInventory h0-        let is = case contents of-                    (Inventory (Just _) (_ : ris0)) -> ris0-                    (Inventory Nothing ris0) -> ris0-                    (Inventory (Just _) []) -> error "inventory without tag!"-        Sealed ts <- unseal seal <$>-                         unsafeInterleaveIO-                            (case contents of-                                 (Inventory (Just h') (t' : _)) -> read_ts t' h'-                                 (Inventory (Just _) []) -> error "inventory without tag!"-                                 (Inventory Nothing _) -> return $ seal NilRL)-        Sealed ps <- unseal seal <$>-            unsafeInterleaveIO (readPatchesFromInventory cache is)-        Sealed tag00 <- read_tag tag0-        return $ seal $ ts :<: Tagged tag00 (Just (getValidHash h0)) ps--    read_tag :: (PatchListFormat p, ReadPatch p) => InventoryEntry-             -> IO (Sealed (PatchInfoAnd rt p wX))-    read_tag (i, h) =-        mapSeal (patchInfoAndPatch i) <$> createValidHashed h (readSinglePatch cache i)--    readTaggedInventory :: InventoryHash -> IO Inventory-    readTaggedInventory invHash = do-        (fileName, pristineAndInventory) <--            fetchFileUsingCache cache HashedInventoriesDir (getValidHash invHash)-        case parseInventory pristineAndInventory of-          Right r -> return r-          Left e -> fail $ unlines [unwords ["parse error in file", fileName],e]--readPatchesFromInventory :: ReadPatch np-                         => Cache-                         -> [InventoryEntry]-                         -> IO (Sealed (RL (PatchInfoAndG rt np) wX))-readPatchesFromInventory cache ris = read_patches (reverse ris)-  where-    read_patches [] = return $ seal NilRL-    read_patches allis@((i1, h1) : is1) =-        lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1)-                    (createValidHashed h1 (const $ speculateAndParse h1 allis i1))-      where-        rp [] = return $ seal NilRL-        rp [(i, h), (il, hl)] =-            lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)-                        (rp [(il, hl)])-                        (createValidHashed h-                            (const $ speculateAndParse h (reverse allis) i))-        rp ((i, h) : is) =-            lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)-                        (rp is)-                        (createValidHashed h (readSinglePatch cache i))--    lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ)-                -> IO (Sealed (p wX))-                -> (forall wB . IO (Sealed (q wB)))-                -> IO (Sealed (r wX))-    lift2Sealed f iox ioy = do-        Sealed x <- unseal seal <$> unsafeInterleaveIO iox-        Sealed y <- unseal seal <$> unsafeInterleaveIO ioy-        return $ seal $ f y x--    speculateAndParse h is i = speculate h is >> readSinglePatch cache i h--    speculate :: PatchHash -> [InventoryEntry] -> IO ()-    speculate pHash is = do-        already_got_one <- peekInCache cache HashedPatchesDir (getValidHash pHash)-        unless already_got_one $-            speculateFilesUsingCache cache HashedPatchesDir (map (getValidHash . snd) is)+-- Warning: this allows to add any arbitrary patch!+-- Used by convert import and 'tentativelyAddPatch_'.+addToTentativeInventory :: RepoPatch p => Cache+                        -> PatchInfoAnd p wX wY -> IO ()+addToTentativeInventory c p = do+    hash <- snd <$> writePatchIfNecessary c p+    appendDocBinFile tentativeHashedInventoryPath $ showInventoryEntry (info p, hash) -readSinglePatch :: ReadPatch p-                => Cache-                -> PatchInfo -> PatchHash -> IO (Sealed (p wX))-readSinglePatch cache i h = do-    debugDoc $ text "Reading patch file:" <+> displayPatchInfo i-    (fn, ps) <- fetchFileUsingCache cache HashedPatchesDir (getValidHash h)-    case readPatch ps of-        Right p -> return p-        Left e -> fail $ unlines-            [ "Couldn't parse file " ++ fn-            , "which is patch"-            , renderString $ displayPatchInfo i-            , e-            ]+-- | Read the recorded 'PatchSet' of a hashed 'Repository'.+readPatchesHashed :: (PatchListFormat p, ReadPatch p) => Repository rt p wU wR+                  -> IO (PatchSet p Origin wR)+readPatchesHashed repo =+  case repoAccessType repo of+    SRO -> readPatchesFromInventoryFile hashedInventoryPath repo+    SRW -> readPatchesFromInventoryFile tentativeHashedInventoryPath repo --- | Read an inventory from a file. Fails with an error message if--- file is not there or cannot be parsed.-readInventoryPrivate :: FilePath -> IO Inventory-readInventoryPrivate path = do-    inv <- skipPristineHash <$> gzFetchFilePS path Uncachable-    case parseInventory inv of-      Right r -> return r-      Left e -> fail $ unlines [unwords ["parse error in file", path],e]+-- | Read the tentative 'PatchSet' of a (hashed) 'Repository'.+readTentativePatches :: (PatchListFormat p, ReadPatch p)+                     => Repository 'RW p wU wR+                     -> IO (PatchSet p Origin wR)+readTentativePatches = readPatchesHashed  -- |Copy the hashed inventory from the given location to the given repository, -- possibly using the given remote darcs binary.-copyHashedInventory :: Repository rt p wR wU wT -> RemoteDarcs -> String -> IO ()+copyHashedInventory :: Repository 'RO p wU wR -> RemoteDarcs -> String -> IO () copyHashedInventory outrepo rdarcs inloc | remote <- remoteDarcs rdarcs = do     let outloc = repoLocation outrepo-    createDirectoryIfMissing False (outloc ++ "/" ++ inventoriesDirPath)+    createDirectoryIfMissing False (outloc </> inventoriesDirPath)     copyFileOrUrl remote (inloc </> hashedInventoryPath)                          (outloc </> hashedInventoryPath)-                  Uncachable -- no need to copy anything but hashed_inventory!+                  Uncachable     debugMessage "Done copying hashed inventory."  -- |writeAndReadPatch makes a patch lazy, by writing it out to disk (thus -- forcing it), and then re-reads the patch lazily.-writeAndReadPatch :: RepoPatch p => Cache -> Compression-                  -> PatchInfoAnd rt p wX wY -> IO (PatchInfoAnd rt p wX wY)-writeAndReadPatch c compr p = do-    (i, h) <- writePatchIfNecessary c compr p+writeAndReadPatch :: RepoPatch p => Cache+                  -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY)+writeAndReadPatch c p = do+    (i, h) <- writePatchIfNecessary c p     unsafeInterleaveIO $ readp h i   where     parse i h = do-        debugDoc $ text "Rereading patch file:" <+> displayPatchInfo i-        (fn, ps) <- fetchFileUsingCache c HashedPatchesDir (getValidHash h)+        debugMessage $ "Rereading patch file for: " ++ piName i+        (fn, ps) <- fetchFileUsingCache c h         case readPatch ps of             Right x -> return x             Left e -> fail $ unlines@@ -428,157 +236,101 @@                 , e                 ] -    readp h i = do Sealed x <- createValidHashed h (parse i)+    readp h i = do Sealed x <- createHashed h (parse i)                    return . patchInfoAndPatch i $ unsafeCoerceP x -createValidHashed :: PatchHash-                  -> (PatchHash -> IO (Sealed (a wX)))-                  -> IO (Sealed (Darcs.Patch.PatchInfoAnd.Hopefully a wX))-createValidHashed h f = createHashed (getValidHash h) (f . mkValidHash)---- | writeTentativeInventory writes @patchSet@ as the tentative inventory.-writeTentativeInventory :: RepoPatch p => Cache -> Compression-                        -> PatchSet rt p Origin wX -> IO ()-writeTentativeInventory cache compr patchSet = do+-- | Write a 'PatchSet' to the tentative inventory.+writeTentativeInventory :: RepoPatch p+                        => Repository 'RW p wU wR+                        -> PatchSet p Origin wX+                        -> IO ()+writeTentativeInventory repo patchSet = do     debugMessage "in writeTentativeInventory..."     createDirectoryIfMissing False inventoriesDirPath+    let cache = repoCache repo+        tediousName = "Writing inventory"     beginTedious tediousName-    hsh <- writeInventoryPrivate $ slightlyOptimizePatchset patchSet+    hash <-+      writeInventory tediousName cache $ slightlyOptimizePatchset patchSet     endTedious tediousName     debugMessage "still in writeTentativeInventory..."-    case hsh of-        Nothing -> writeBinFile (makeDarcsdirPath tentativeHashedInventory) B.empty-        Just h -> do-            content <- snd <$> fetchFileUsingCache cache HashedInventoriesDir h-            writeAtomicFilePS (makeDarcsdirPath tentativeHashedInventory) content-  where-    tediousName = "Writing inventory"-    writeInventoryPrivate :: RepoPatch p => PatchSet rt p Origin wX-                          -> IO (Maybe String)-    writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing-    writeInventoryPrivate (PatchSet NilRL ps) = do-        inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps-        let inventorylist = showInventoryPatches (reverse inventory)-        hash <- writeHashFile cache compr HashedInventoriesDir inventorylist-        return $ Just hash-    writeInventoryPrivate-        (PatchSet xs@(_ :<: Tagged t _ _) x) = do-        resthash <- write_ts xs-        finishedOneIO tediousName $ fromMaybe "" resthash-        inventory <- sequence $ mapRL (writePatchIfNecessary cache compr)-                                    (NilRL :<: t +<+ x)-        let inventorylist = hcat (map showInventoryEntry $ reverse inventory)-            inventorycontents =-                case resthash of-                    Just h -> text ("Starting with inventory:\n" ++ h) $$-                                  inventorylist-                    Nothing -> inventorylist-        hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents-        return $ Just hash-      where-        -- | write_ts writes out a tagged patchset. If it has already been-        -- written, we'll have the hash, so we can immediately return it.-        write_ts :: RepoPatch p => RL (Tagged rt p) Origin wX-                 -> IO (Maybe String)-        write_ts (_ :<: Tagged _ (Just h) _) = return (Just h)-        write_ts (tts :<: Tagged _ Nothing pps) =-            writeInventoryPrivate $ PatchSet tts pps-        write_ts NilRL = return Nothing---- |writeHashIfNecessary writes the patch and returns the resulting info/hash,--- if it has not already been written. If it has been written, we have the hash--- in the PatchInfoAnd, so we extract and return the info/hash.-writePatchIfNecessary :: RepoPatch p => Cache -> Compression-                      -> PatchInfoAnd rt p wX wY -> IO InventoryEntry-writePatchIfNecessary c compr hp = infohp `seq`-    case extractHash hp of-        Right h -> return (infohp, mkValidHash h)-        Left p -> do-          h <- writeHashFile c compr HashedPatchesDir (showPatch ForStorage p)-          return (infohp, mkValidHash h)-  where-    infohp = info hp+    (_filepath, content) <- fetchFileUsingCache cache hash+    writeAtomicFilePS tentativeHashedInventoryPath content  tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)-                    => Repository rt p wR wU wT-                    -> Compression-                    -> Verbosity+                    => Repository 'RW p wU wR                     -> UpdatePending-                    -> PatchInfoAnd rt p wT wY-                    -> IO (Repository rt p wR wU wY)+                    -> PatchInfoAnd p wR wY+                    -> IO (Repository 'RW p wU wY) tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine +tentativelyAddPatches :: (RepoPatch p, ApplyState p ~ Tree)+                      => Repository 'RW p wU wR+                      -> UpdatePending+                      -> FL (PatchInfoAnd p) wR wY+                      -> IO (Repository 'RW p wU wY)+tentativelyAddPatches = tentativelyAddPatches_ UpdatePristine+ data UpdatePristine = UpdatePristine                      | DontUpdatePristine                     | DontUpdatePristineNorRevert deriving Eq  tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree)                        => UpdatePristine-                       -> Repository rt p wR wU wT-                       -> Compression-                       -> Verbosity+                       -> Repository 'RW p wU wR                        -> UpdatePending-                       -> FL (PatchInfoAnd rt p) wT wY-                       -> IO (Repository rt p wR wU wY)-tentativelyAddPatches_ upr r c v upe ps =-    foldFL_M (\r' p -> tentativelyAddPatch_ upr r' c v upe p) r ps--tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)-                     => UpdatePristine-                     -> Repository rt p wR wU wT-                     -> Compression-                     -> Verbosity-                     -> UpdatePending-                     -> PatchInfoAnd rt p wT wY-                     -> IO (Repository rt p wR wU wY)-tentativelyAddPatch_ upr r compr verb upe p = do-    let r' = unsafeCoerceT r-    withTentativeRebase r r' (removeFixupsFromSuspended $ hopefully p)-    withRepoLocation r $ do-       addToTentativeInventory (repoCache r) compr p+                       -> FL (PatchInfoAnd p) wR wY+                       -> IO (Repository 'RW p wU wY)+tentativelyAddPatches_ upr r upe ps = do+    let r' = unsafeCoerceR r+    withTentativeRebase r r' (foldlwFL (removeFixupsFromSuspended . hopefully) ps)+    withRepoDir r $ do+       sequenceFL_ (addToTentativeInventory (repoCache r)) ps        when (upr == UpdatePristine) $ do-          debugMessage "Applying to pristine cache..."-          applyToTentativePristine r ApplyNormal verb p+          applyToTentativePristine r $+            mkInvertible $ progressFL "Applying to pristine" ps        when (upe == YesUpdatePending) $ do           debugMessage "Updating pending..."-          tentativelyRemoveFromPending r' (effect p)+          Sealed pend <- readTentativePending r+          writeTentativePending r' $ invertFL (effect ps) +>>+ pend        return r' -tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                         => Repository rt p wR wU wT-                         -> Compression+tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)+                     => UpdatePristine+                     -> Repository 'RW p wU wR+                     -> UpdatePending+                     -> PatchInfoAnd p wR wY+                     -> IO (Repository 'RW p wU wY)+tentativelyAddPatch_ upr r upe p =+    tentativelyAddPatches_ upr r upe (p :>: NilFL)++tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree)+                         => Repository 'RW p wU wR                          -> UpdatePending-                         -> FL (PatchInfoAnd rt p) wX wT-                         -> IO (Repository rt p wR wU wX)+                         -> FL (PatchInfoAnd p) wX wR+                         -> IO (Repository 'RW p wU wX) tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine -newtype Dup p wX = Dup { unDup :: p wX wX }--foldrwFL' :: (forall wA wB. p wA wB -> s wB wB -> s wA wA)-          -> FL p wX wY -> s wY wY -> s wX wX-foldrwFL' f ps = unDup . foldrwFL (\p -> (Dup . f p . unDup)) ps . Dup--tentativelyRemovePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+tentativelyRemovePatches_ :: (RepoPatch p, ApplyState p ~ Tree)                           => UpdatePristine-                          -> Repository rt p wR wU wT-                          -> Compression+                          -> Repository 'RW p wU wR                           -> UpdatePending-                          -> FL (PatchInfoAnd rt p) wX wT-                          -> IO (Repository rt p wR wU wX)-tentativelyRemovePatches_ upr r compr upe ps+                          -> FL (PatchInfoAnd p) wX wR+                          -> IO (Repository 'RW p wU wX)+tentativelyRemovePatches_ upr r upe ps   | formatHas HashedInventory (repoFormat r) = do-      withRepoLocation r $ do-        unless (upr == DontUpdatePristineNorRevert) $ removeFromUnrevertContext r ps-        Sealed pend <- readTentativePending r+      withRepoDir r $ do+        ref <- readTentativePatches r+        unless (upr == DontUpdatePristineNorRevert) $ removeFromUnrevertContext ref ps         debugMessage "Removing changes from tentative inventory..."-        r' <- removeFromTentativeInventory r compr ps-        withTentativeRebase r r'-          (foldrwFL' (addFixupsToSuspended . hopefully) ps)+        r' <- removeFromTentativeInventory r ps+        withTentativeRebase r r' (foldrwFL (addFixupsToSuspended . hopefully) ps)         when (upr == UpdatePristine) $-          applyToTentativePristineCwd ApplyInverted $-            progressFL "Applying inverse to pristine" ps+          applyToTentativePristine r $+            invert $ mkInvertible $ progressFL "Applying inverse to pristine" ps         when (upe == YesUpdatePending) $ do           debugMessage "Adding changes to pending..."+          Sealed pend <- readTentativePending r           writeTentativePending r' $ effect ps +>+ pend         return r'   | otherwise = fail Old.oldRepoFailMsg@@ -590,168 +342,62 @@ -- * the patches are in the repository -- -- * any necessary commutations will succeed-removeFromTentativeInventory :: forall rt p wR wU wT wX. (IsRepoType rt, RepoPatch p)-                             => Repository rt p wR wU wT-                             -> Compression-                             -> FL (PatchInfoAnd rt p) wX wT-                             -> IO (Repository rt p wR wU wX)-removeFromTentativeInventory repo compr to_remove = do+removeFromTentativeInventory :: forall p wU wR wX. RepoPatch p+                             => Repository 'RW p wU wR+                             -> FL (PatchInfoAnd p) wX wR+                             -> IO (Repository 'RW p wU wX)+removeFromTentativeInventory repo to_remove = do     debugMessage $ "Start removeFromTentativeInventory"-    allpatches :: PatchSet rt p Origin wT <- readTentativeRepo repo "."-    remaining :: PatchSet rt p Origin wX <-+    allpatches :: PatchSet p Origin wR <- readTentativePatches repo+    remaining :: PatchSet p Origin wX <-       case removeFromPatchSet to_remove allpatches of         Nothing -> error "Hashed.removeFromTentativeInventory: precondition violated"         Just r -> return r-    writeTentativeInventory (repoCache repo) compr remaining+    let repo' = unsafeCoerceR repo+    writeTentativeInventory repo' remaining     debugMessage $ "Done removeFromTentativeInventory"-    return (unsafeCoerceT repo)---- | Atomically copy the tentative state to the recorded state,--- thereby committing the tentative changes that were made so far.--- This includes inventories, pending, and the index.-finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                          => Repository rt p wR wU wT-                          -> UpdatePending-                          -> Compression-                          -> IO (Repository rt p wT wU wT)-finalizeRepositoryChanges r updatePending compr-    | formatHas HashedInventory (repoFormat r) =-        withRepoLocation r $ do-            debugMessage "Finalizing changes..."-            withSignalsBlocked $ do-                renameFile tentativeRebasePath rebasePath-                finalizeTentativeChanges r compr-                recordedState <- readRecorded r-                finalizePending r updatePending recordedState-            let r' = unsafeCoerceR r-            debugMessage "Done finalizing changes..."-            ps <- readRepo r'-            pi_exists <- doesPatchIndexExist (repoLocation r')-            when pi_exists $-              createOrUpdatePatchIndexDisk r' ps-              `catchIOError` \e ->-                hPutStrLn stderr $ "Cannot create or update patch index: "++ show e-            updateIndex r'-            return r'-    | otherwise = fail Old.oldRepoFailMsg---- TODO: rename this and document the transaction protocol (revert/finalize)--- clearly.--- |Slightly confusingly named: as well as throwing away any tentative--- changes, revertRepositoryChanges also re-initialises the tentative state.--- It's therefore used before makign any changes to the repo.-revertRepositoryChanges :: RepoPatch p-                        => Repository rt p wR wU wT-                        -> UpdatePending-                        -> IO (Repository rt p wR wU wR)-revertRepositoryChanges r upe-  | formatHas HashedInventory (repoFormat r) =-      withRepoLocation r $ do-        checkIndexIsWritable-          `catchIOError` \e -> fail (unlines ["Cannot write index", show e])-        revertPending r upe-        revertTentativeChanges-        let r' = unsafeCoerceT r-        revertTentativeRebase r'-        return r'-  | otherwise = fail Old.oldRepoFailMsg--revertTentativeRebase :: RepoPatch p => Repository rt p wR wU wR -> IO ()-revertTentativeRebase repo =-  copyFile rebasePath tentativeRebasePath-  `catchIOError` \e ->-    if isDoesNotExistError e then-      createTentativeRebase repo-    else-      fail $ show e--checkIndexIsWritable :: IO ()-checkIndexIsWritable = do-    checkWritable indexInvalidPath-    checkWritable indexPath-  where-    checkWritable path = do-      exists <- doesFileExist path-      touchFile path-      unless exists $ removeFile path-    touchFile path = openBinaryFile path AppendMode >>= hClose--removeFromUnrevertContext :: forall rt p wR wU wT wX-                           . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                          => Repository rt p wR wU wT-                          -> FL (PatchInfoAnd rt p) wX wT-                          -> IO ()-removeFromUnrevertContext _ NilFL = return () -- nothing to do-removeFromUnrevertContext r ps = do-  Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (Bundle (NilFL :> NilFL)))-  remove_from_unrevert_context_ bundle-  where unrevert_impossible =-            do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?"-               if confirmed then removeFileMayNotExist unrevertPath-                            else fail "Cancelled."-        unrevert_patch_bundle :: IO (Sealed (Bundle rt p wB))-        unrevert_patch_bundle = do pf <- B.readFile unrevertPath-                                   case parseBundle pf of-                                     Right foo -> return foo-                                     Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err-        remove_from_unrevert_context_ :: Bundle rt p wA wB -> IO ()-        remove_from_unrevert_context_ bundle =-         do debugMessage "Adjusting the context of the unrevert changes..."-            debugMessage $ "Removing "++ show (lengthFL ps) ++-                                  " patches in removeFromUnrevertContext!"-            ref <- readTentativeRepo r (repoLocation r)-            let withSinglet :: Sealed (FL ppp wXxx)-                            -> (forall wYyy . ppp wXxx wYyy -> IO ()) -> IO ()-                withSinglet (Sealed (x :>: NilFL)) j = j x-                withSinglet _ _ = return ()-            Sealed bundle_ps <- bundle_to_patchset ref bundle-            withSinglet (mergeThem ref bundle_ps) $ \h_us ->-                  case commuteRL (reverseFL ps :> h_us) of-                    Nothing -> unrevert_impossible-                    Just (us' :> _) ->-                      case removeFromPatchSet ps ref of-                      Nothing -> unrevert_impossible-                      Just common ->-                          do debugMessage "Have now found the new context..."-                             bundle' <- makeBundle Nothing common (hopefully us':>:NilFL)-                             writeDocBinFile unrevertPath bundle'-            debugMessage "Done adjusting the context of the unrevert changes!"--        bundle_to_patchset :: PatchSet rt p Origin wT-                           -> Bundle rt p wA wB-                           -> IO (SealedPatchSet rt p Origin)-        bundle_to_patchset ref bundle =-          either fail (return . Sealed) $ interpretBundle ref bundle+    return repo'  -- | Writes out a fresh copy of the inventory that minimizes the -- amount of inventory that need be downloaded when people pull from--- the repository.+-- the repository. The exact beavior depends on the 3rd parameter: ----- Specifically, it breaks up the inventory on the most recent tag.+-- For 'OptimizeShallow' it breaks up the inventory on the most recent tag. -- This speeds up most commands when run remotely, both because a -- smaller file needs to be transfered (only the most recent -- inventory).  It also gives a guarantee that all the patches prior -- to a given tag are included in that tag, so less commutation and -- history traversal is needed.  This latter issue can become very -- important in large repositories.-reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                 => Repository rt p wR wU wR-                 -> Compression+--+-- For 'OptimizeDeep', the whole repo is traversed, from oldest to newest+-- patch. Every tag we encounter is made clean, but only if that doesn't make+-- any previous clean tag unclean. Every clean tags gets its own inventory.+-- This speeds up "deep" operations, too, such as cloning a specific tag.+-- It does not necessarily make the latest tag clean, but the benefits are+-- similar to the shallow case.+reorderInventory :: (RepoPatch p, ApplyState p ~ Tree)+                 => Repository 'RW p wU wR+                 -> OptimizeDeep                  -> IO ()-reorderInventory r compr+reorderInventory r deep   | formatHas HashedInventory (repoFormat r) = do-      cleanLatestTag `fmap` readRepo r >>=-        writeTentativeInventory (repoCache r) compr-      withSignalsBlocked $ finalizeTentativeChanges r compr+      let optimize =+            case deep of+              OptimizeDeep -> fullyOptimizePatchSet+              OptimizeShallow -> cleanLatestTag+      readPatches r >>= return . optimize >>= writeTentativeInventory r+      cleanRepository r+      withSignalsBlocked $ finalizeTentativeChanges r   | otherwise = fail Old.oldRepoFailMsg --- | Read inventories and patches from a repository and return them as a+-- | Read inventories and patches from a 'Repository' and return them as a -- 'PatchSet'. Note that patches and inventories are read lazily.-readRepo :: (IsRepoType rt, RepoPatch p)-         => Repository rt p wR wU wT-         -> IO (PatchSet rt p Origin wR)-readRepo r-    | formatHas HashedInventory (repoFormat r) = readRepoHashed r (repoLocation r)+readPatches :: RepoPatch p+            => Repository rt p wU wR+            -> IO (PatchSet p Origin wR)+readPatches r+    | formatHas HashedInventory (repoFormat r) = readPatchesHashed r     | otherwise = do Sealed ps <- Old.readOldRepo (repoLocation r)                      return $ unsafeCoerceP ps @@ -762,55 +408,7 @@ -- be present twice in a repository. -- This checksum is not cryptographically secure, -- see http://robotics.stanford.edu/~xb/crypto06b/ .-repoXor :: (IsRepoType rt, RepoPatch p)-        => Repository rt p wR wU wR -> IO SHA1+repoXor :: RepoPatch p => Repository rt p wU wR -> IO SHA1 repoXor repo = do-  hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readRepo repo+  hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readPatches repo   return $ foldl' sha1Xor sha1zero hashes---- | Upgrade a possible old-style rebase in progress to the new style.-upgradeOldStyleRebase :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                      => Repository rt p wR wU wT -> Compression -> IO ()-upgradeOldStyleRebase repo compr = do-  PatchSet ts _ <- readTentativeRepo repo (repoLocation repo)-  Inventory _ invEntries <- readInventoryPrivate tentativeHashedInventoryPath-  Sealed wps <- readPatchesFromInventory (repoCache repo) invEntries-  case commuteOutOldStyleRebase wps of-    Nothing ->-      ePutDocLn $ text "Rebase is already in new style, no upgrade needed."-    Just (wps' :> wr) -> do-      -- FIXME inlining this action below where it is used-      -- results in lots of ambiguous type variable errors-      -- which is rather strange behavior of ghc IMHO-      let update_repo =-            -- low-level call, must not try to update an existing rebase patch,-            -- nor update anything else beside the inventory-            writeTentativeInventory-              (repoCache repo)-              compr-              (PatchSet ts (mapRL_RL (fmapPIAP W.fromRebasing) wps'))-      -- double check if we really have a rebase patch-      case hopefully wr of-        W.NormalP wtf ->-          error $ renderString $-            "internal error: expected rebase patch but found normal patch:"-            $$ displayPatch wtf-        W.RebaseP _ r -> do-          update_repo-          Items old_r <- readTentativeRebase (unsafeCoerceT repo)-          case old_r of-            NilFL -> do-              writeTentativeRebase (unsafeCoerceT repo) r-              _ <- finalizeRepositoryChanges repo NoUpdatePending compr-              writeRepoFormat-                ( addToFormat RebaseInProgress_2_16-                $ removeFromFormat RebaseInProgress-                $ repoFormat repo)-                formatPath-              return ()-            _ -> do-              ePutDocLn-                $  "A new-style rebase is already in progress, not overwriting it."-                $$ "This should not have happened! This is the old-style rebase I found"-                $$ "and removed from the repository:"-                $$ displayPatch wr
− src/Darcs/Repository/HashedIO.hs 
@@ -1,375 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; if not, write to the Free Software Foundation,--- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.--{-# OPTIONS_GHC -fno-warn-missing-methods #-}-{-# LANGUAGE MultiParamTypeClasses #-}---module Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,-                                   cleanHashdir, getHashedFiles,-                                   pathsAndContents-                                 ) where--import Darcs.Prelude--import Darcs.Util.Global ( darcsdir )-import qualified Data.Set as Set-import System.Directory ( getDirectoryContents, createDirectoryIfMissing )-import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift, evalStateT )-import Control.Monad ( when, void, unless, guard )-import Data.Maybe ( isJust )-import System.IO.Unsafe ( unsafeInterleaveIO )--import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache,-                                peekInCache, speculateFileUsingCache,-                                okayHash, cleanCachesWithHint, HashedDir(..), hashedDir )-import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )-import Darcs.Repository.Flags ( Compression( .. ), WithWorkingDir (..) )-import Darcs.Repository.Inventory ( PristineHash, getValidHash, mkValidHash )-import Darcs.Util.Lock ( writeAtomicFilePS, removeFileMayNotExist )-import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Util.Progress ( debugMessage, tediousSize, finishedOneIO )-import Darcs.Util.Path-    ( AnchoredPath-    , anchorPath-    , anchoredRoot-    , parent-    , breakOnDir-    , Name-    , name2fp-    , decodeWhiteName-    , encodeWhiteName-    , isMaliciousSubPath-    )--import Darcs.Util.ByteString ( linesPS, unlinesPS )-import qualified Data.ByteString       as B  (ByteString, length, empty)-import qualified Data.ByteString.Char8 as BC (unpack, pack)--import Darcs.Util.Tree.Hashed( readDarcsHashedDir, darcsLocation,-                             decodeDarcsHash, decodeDarcsSize )-import Darcs.Util.Tree( ItemType(..), Tree )--ap2fp :: AnchoredPath -> FilePath-ap2fp = anchorPath ""----- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir,--- fetching it from 'Cache' @c@ if needed. The return value is a pair of the--- absolute file path and the content.-readHashFile :: Cache -> HashedDir -> PristineHash -> IO (FilePath,B.ByteString)-readHashFile c subdir hash =-    do debugMessage $ "Reading hash file "++getValidHash hash++" from "++hashedDir subdir++"/"-       r <- fetchFileUsingCache c subdir (getValidHash hash)-       debugMessage $ "Result of reading hash file: " ++ show r-       return r---- TODO an obvious optimization would be to remember--- the current path and a stack of directories we opened.--- Then we could batch operations in the same directory and write the--- result back only when we pop a dir off teh stack.-data HashDir = HashDir { cache :: !Cache,-                         cwdHash :: !PristineHash }-type HashedIO = StateT HashDir IO--mWithSubDirectory :: Name -> HashedIO a -> HashedIO a-mWithSubDirectory dir j = do-  cwd <- readcwd-  case geta D dir cwd of-    Nothing -> fail "dir doesn't exist in mWithSubDirectory..."-    Just h -> do-      (h', x) <- withh h j-      -- update the parent object with new entry-      writecwd $ seta D dir h' cwd-      return x---- | This is withCurrentDirectory for read-only actions.-mInSubDirectory :: Name -> HashedIO a -> HashedIO a-mInSubDirectory dir j = do-  cwd <- readcwd-  case geta D dir cwd of-    Nothing -> fail "dir doesn't exist..."-    Just h -> inh h j--instance ApplyMonad Tree HashedIO where-    type ApplyMonadBase HashedIO = IO--instance ApplyMonadTree HashedIO where-    mDoesDirectoryExist path = do-      thing <- identifyThing path-      case thing of-        Just (D, _) -> return True-        _ -> return False--    mReadFilePS = readFileObject--    mCreateDirectory path = do-      h <- writeHashFile B.empty-      exists <- isJust `fmap` identifyThing path-      when exists $ fail "can't mCreateDirectory over an existing object."-      addThing path (D, h)--    mRename o n = do-      nexists <- isJust `fmap` identifyThing n-      when nexists $ fail "mRename failed..."-      mx <- identifyThing o-                     -- for backwards compatibility accept rename of nonexistent files.-      case mx of-        Nothing -> return ()-        Just x -> do-          rmThing o-          addThing n x--    mRemoveDirectory = rmThing--    mRemoveFile f = do-      x <- mReadFilePS f-      when (B.length x /= 0) $ fail $ "Cannot remove non-empty file " ++ ap2fp f-      rmThing f--readFileObject :: AnchoredPath -> HashedIO B.ByteString-readFileObject path-  | path == anchoredRoot = fail "root dir is not a file..."-  | otherwise =-      case breakOnDir path of-        Left file -> do-          cwd <- readcwd-          case geta F file cwd of-                Nothing -> fail $ "file doesn't exist..." ++ ap2fp path-                Just h -> readhash h-        Right (name, path') -> do-          mInSubDirectory name $ readFileObject path'--identifyThing :: AnchoredPath -> HashedIO (Maybe (ObjType,PristineHash))-identifyThing path-  | path == anchoredRoot = do-      h <- gets cwdHash-      return $ Just (D, h)-  | otherwise =-      case breakOnDir path of-        Left name -> getany name `fmap` readcwd-        Right (dir, path') -> do-          cwd <- readcwd-          case geta D dir cwd of-            Nothing -> return Nothing-            Just h -> inh h $ identifyThing path'--addThing :: AnchoredPath -> (ObjType,PristineHash) -> HashedIO ()-addThing path (o, h) =-  case breakOnDir path of-    Left name -> seta o name h `fmap` readcwd >>= writecwd-    Right (name,path') -> mWithSubDirectory name $ addThing path' (o,h)--rmThing :: AnchoredPath -> HashedIO ()-rmThing path = -  case breakOnDir path of-    Left name -> do-      cwd <- readcwd-      let cwd' = filter (\(_,x,_)->x/= name) cwd-      if length cwd' == length cwd - 1-        then writecwd cwd'-        else fail "obj doesn't exist in rmThing"-    Right (name,path') -> mWithSubDirectory name $ rmThing path'--readhash :: PristineHash -> HashedIO B.ByteString-readhash h = do c <- gets cache-                z <- lift $ unsafeInterleaveIO $ readHashFile c HashedPristineDir h-                let (_,out) = z-                return out--withh :: PristineHash -> HashedIO a -> HashedIO (PristineHash,a)-withh h j = do hd <- get-               put $ hd { cwdHash = h }-               x <- j-               h' <- gets cwdHash-               put hd-               return (h',x)--inh :: PristineHash -> HashedIO a -> HashedIO a-inh h j = snd `fmap` withh h j--type DirEntry = (ObjType, Name, PristineHash)--readcwd :: HashedIO [DirEntry]-readcwd = do haveitalready <- peekroot-             cwd <- gets cwdHash >>= readdir-             unless haveitalready $ speculate cwd-             return cwd-    where speculate :: [(a,b,PristineHash)] -> HashedIO ()-          speculate c = do cac <- gets cache-                           mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir (getValidHash z)) c-          peekroot :: HashedIO Bool-          peekroot = do HashDir c h <- get-                        lift $ peekInCache c HashedPristineDir (getValidHash h)--writecwd :: [DirEntry] -> HashedIO ()-writecwd c = do-  h <- writedir c-  modify $ \hd -> hd { cwdHash = h }--data ObjType = F | D deriving Eq---- | @geta objtype name direntries@ tries to find an object of type @objtype@ named @name@--- in @direntries@.-geta :: ObjType -> Name -> [DirEntry] -> Maybe PristineHash-geta o f c = do-  (o', h) <- getany f c-  guard (o == o')-  return h--getany :: Name -> [DirEntry] -> Maybe (ObjType,PristineHash)-getany _ [] = Nothing-getany f ((o,f',h):_) | f == f' = Just (o,h)-getany f (_:r) = getany f r--seta :: ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]-seta o f h [] = [(o,f,h)]-seta o f h ((_,f',_):r) | f == f' = (o,f,h):r-seta o f h (x:xs) = x : seta o f h xs--readdir :: PristineHash -> HashedIO [DirEntry]-readdir hash = do-    content <- readhash hash-    -- lift $ debugMessage  $ show x-    let r = (parseLines . linesPS) content-    --lift $ debugMessage  $ unlines $ map (\(_,path,_) -> "DEBUG readdir " ++-    --  hash ++ " entry: " ++ show path) r-    return r-  where-    parseLines (t:n:h:rest)-      | t == dirType = (D, decodeWhiteName n, mkValidHash $ BC.unpack h) : parseLines rest-      | t == fileType = (F, decodeWhiteName n, mkValidHash $ BC.unpack h) : parseLines rest-    parseLines _ = []--dirType :: B.ByteString-dirType = BC.pack "directory:"--fileType :: B.ByteString-fileType = BC.pack "file:"--writedir :: [DirEntry] -> HashedIO PristineHash-writedir c = do-  --lift $ debugMessage  $ unlines $ map (\(_,path,_) -> "DEBUG writedir entry: " ++ show path) c-  writeHashFile cps-  where-    cps = unlinesPS $ concatMap wr c ++ [B.empty]-    wr (o,d,h) = [showO o, encodeWhiteName d, BC.pack (getValidHash h)]-    showO D = dirType-    showO F = fileType--writeHashFile :: B.ByteString -> HashedIO PristineHash-writeHashFile ps = do-  c <- gets cache-  -- pristine files are always compressed-  lift $ mkValidHash <$> writeFileUsingCache c GzipCompression HashedPristineDir ps--type ProgressKey = String---- | Grab a whole pristine tree from a hash, and, if asked,---   write files in the working tree.-copyHashed :: ProgressKey -> Cache -> WithWorkingDir -> PristineHash -> IO ()-copyHashed k c wwd z = void . runStateT cph $ HashDir { cache = c, cwdHash = z }-    where cph = do cwd <- readcwd-                   lift $ tediousSize k (length cwd)-                   mapM_ cp cwd-          cp (F,n,h) = do-              ps <- readhash h-              lift $ finishedOneIO k $ name2fp n-              --lift $ debugMessage $ "DEBUG copyHashed " ++ show n-              case wwd of-                WithWorkingDir -> lift $ writeAtomicFilePS (name2fp n) ps-                NoWorkingDir   -> ps `seq` return ()-                                  -- force evaluation of ps to actually copy hashed file-          cp (D,n,h) =-              if isMaliciousSubPath (name2fp n)-                 then fail ("Caught malicious path: " ++ name2fp n)-                 else do-                 lift $ finishedOneIO k (name2fp n)-                 case wwd of-                   WithWorkingDir -> do-                     lift $ createDirectoryIfMissing False (name2fp n)-                     lift $ withCurrentDirectory (name2fp n) $ copyHashed k c WithWorkingDir h-                   NoWorkingDir ->-                     lift $ copyHashed k c NoWorkingDir h---- | Returns a list of pairs (FilePath, (strict) ByteString) of---   the pristine tree starting with the hash @root@.---   @path@ should be either "." or end with "/"---   Separator "/" is used since this function is used to generate---   zip archives from pristine trees.-pathsAndContents :: FilePath -> Cache ->  PristineHash -> IO [(FilePath,B.ByteString)]-pathsAndContents path c root = evalStateT cph HashDir { cache = c, cwdHash = root }-    where cph = do cwd <- readcwd-                   pacs <- concat <$> mapM cp cwd-                   let current = if path == "." then [] else [(path ++ "/" , B.empty)]-                   return $ current ++ pacs-          cp (F,n,h) = do-              ps <- readhash h-              let p = (if path == "." then "" else path ++ "/") ++ name2fp n-              return [(p,ps)]-          cp (D,n,h) = do-              let p = (if path == "." then "" else path) ++ name2fp n ++ "/"-              lift $ pathsAndContents p c h--copyPartialsHashed :: Cache -> PristineHash -> [AnchoredPath] -> IO ()-copyPartialsHashed c root = mapM_ (copyPartialHashed c root)--copyPartialHashed :: Cache -> PristineHash -> AnchoredPath -> IO ()-copyPartialHashed c root path = do-    case parent path of-      Nothing -> return ()-      Just super ->-        createDirectoryIfMissing True (ap2fp super)-    void $ runStateT copy HashDir {cache = c, cwdHash = root}-  where-    copy = do-      mt <- identifyThing path-      case mt of-        Just (D, h) -> do-          lift $ createDirectoryIfMissing True (ap2fp path)-          lift $-            withCurrentDirectory (ap2fp path) $ copyHashed "" c WithWorkingDir h-        Just (F, h) -> do-          ps <- readhash h-          lift $ writeAtomicFilePS (ap2fp path) ps-        Nothing -> return () -- hmm, ignore unknown paths, maybe better fail?--cleanHashdir :: Cache -> HashedDir -> [PristineHash] -> IO ()-cleanHashdir c dir hashroots =-   do -- we'll remove obsolete bits of "dir"-      debugMessage $ "Cleaning out " ++ hashedDir dir ++ "..."-      let hashdir = darcsdir ++ "/" ++ hashedDir dir ++ "/"-      hs <- set <$> getHashedFiles hashdir (map getValidHash hashroots)-      fs <- set . filter okayHash <$> getDirectoryContents hashdir-      mapM_ (removeFileMayNotExist . (hashdir++)) (unset $ fs `Set.difference` hs)-      -- and also clean out any global caches.-      debugMessage "Cleaning out any global caches..."-      cleanCachesWithHint c dir (unset $ fs `Set.difference` hs)-   where set = Set.fromList . map BC.pack-         unset = map BC.unpack . Set.toList---- | getHashedFiles returns all hash files targeted by files in hashroots in--- the hashdir directory.-getHashedFiles :: FilePath -> [String] -> IO [String]-getHashedFiles hashdir hashroots = do-  let listone h = do-        let size = decodeDarcsSize $ BC.pack h-            hash = decodeDarcsHash $ BC.pack h-        x <- readDarcsHashedDir hashdir (size, hash)-        let subs = [fst $ darcsLocation "" (s, h') | (TreeType, _, s, h') <- x]-            hashes = h : [fst $ darcsLocation "" (s, h') | (_, _, s, h') <- x]-        (hashes ++) . concat <$> mapM listone subs-  concat <$> mapM listone hashroots
src/Darcs/Repository/Identify.hs view
@@ -6,22 +6,20 @@ -}  module Darcs.Repository.Identify-    ( maybeIdentifyRepository+    ( maybeIdentifyRepository -- exported for darcsden     , identifyRepository     , identifyRepositoryFor-    , IdentifyRepo(..)+    , IdentifyRepo(..) -- exported for darcsden     , ReadingOrWriting(..)     , findRepository     , amInRepository     , amNotInRepository     , amInHashedRepository     , seekRepo-    , findAllReposInDir     ) where  import Darcs.Prelude -import Control.Monad ( forM ) import Darcs.Repository.Format ( tryIdentifyRepoFormat                                , readProblem                                , transferProblem@@ -30,9 +28,7 @@                         , setCurrentDirectory                         , createDirectoryIfMissing                         , doesFileExist-                        , listDirectory                         )-import System.FilePath.Posix ( (</>) ) import System.IO ( hPutStrLn, stderr ) import System.IO.Error ( catchIOError ) import Data.Maybe ( fromMaybe )@@ -55,47 +51,51 @@     , oldPristineDirPath     ) import Darcs.Repository.Prefs ( getCaches )-import Darcs.Repository.InternalTypes( Repository-                                     , PristineType(..)-                                     , mkRepo-                                     , repoFormat-                                     , repoPristineType-                                     )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , PristineType(..)+    , Repository+    , mkRepo+    , repoFormat+    ) import Darcs.Util.Global ( darcsdir )  import System.Mem( performGC )  -- | The status of a given directory: is it a darcs repository?-data IdentifyRepo rt p wR wU wT+data IdentifyRepo rt p wU wR     = BadRepository String -- ^ looks like a repository with some error     | NonRepository String -- ^ safest guess-    | GoodRepository (Repository rt p wR wU wT)+    | GoodRepository (Repository rt p wU wR) --- | Tries to identify the repository in a given directory-maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo rt p wR wU wT)+-- | Try to identify the repository at a given location, passed as a 'String'.+-- If the lcation is ".", then we assume we are identifying the local repository.+-- Otherwise we assume we are dealing with a remote repo, which could be a URL+-- or an absolute path.+maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo 'RO p wU wR) maybeIdentifyRepository useCache "." =     do darcs <- doesDirectoryExist darcsdir        if not darcs         then return (NonRepository $ "Missing " ++ darcsdir ++ " directory")         else do         repoFormatOrError <- tryIdentifyRepoFormat "."-        here <- toPath `fmap` ioAbsoluteOrRemote "."+        here <- ioAbsoluteOrRemote "."         case repoFormatOrError of           Left err -> return $ NonRepository err           Right rf ->               case readProblem rf of               Just err -> return $ BadRepository err               Nothing -> do pris <- identifyPristine-                            cs <- getCaches useCache here+                            cs <- getCaches useCache Nothing                             return $ GoodRepository $ mkRepo here rf pris cs maybeIdentifyRepository useCache url' =- do url <- toPath `fmap` ioAbsoluteOrRemote url'-    repoFormatOrError <- tryIdentifyRepoFormat url+ do url <- ioAbsoluteOrRemote url'+    repoFormatOrError <- tryIdentifyRepoFormat (toPath url)     case repoFormatOrError of       Left e -> return $ NonRepository e       Right rf -> case readProblem rf of                   Just err -> return $ BadRepository err-                  Nothing ->  do cs <- getCaches useCache url+                  Nothing ->  do cs <- getCaches useCache (Just url)                                  return $ GoodRepository $ mkRepo url rf NoPristine cs  identifyPristine :: IO PristineType@@ -111,7 +111,7 @@  -- | identifyRepository identifies the repo at 'url'. Warning: -- you have to know what kind of patches are found in that repo.-identifyRepository :: UseCache -> String -> IO (Repository rt p wR wU wT)+identifyRepository :: UseCache -> String -> IO (Repository 'RO p wU wR) identifyRepository useCache url =     do er <- maybeIdentifyRepository useCache url        case er of@@ -124,10 +124,10 @@ -- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url', -- but fails if it is not compatible for reading from and writing to. identifyRepositoryFor :: ReadingOrWriting-                      -> Repository rt p wR wU wT+                      -> Repository rt p wU wR                       -> UseCache                       -> String-                      -> IO (Repository rt p vR vU vT)+                      -> IO (Repository 'RO p vR vU) identifyRepositoryFor what us useCache them_loc = do   them <- identifyRepository useCache them_loc   case@@ -221,24 +221,3 @@     _ -> fromMaybe (Right ()) <$> seekRepo   `catchIOError` \e ->     return (Left (show e))---- | @findAllReposInDir topDir@ returns all paths to repositories under @topDir@.-findAllReposInDir :: FilePath -> IO [FilePath]-findAllReposInDir topDir = do-  isDir <- doesDirectoryExist topDir-  if isDir-    then do-      status <- maybeIdentifyRepository NoUseCache topDir-      case status of-        GoodRepository repo-          | HashedPristine <- repoPristineType repo -> return [topDir]-          | otherwise -> return [] -- old fashioned or broken repo-        _             -> getRecursiveDarcsRepos' topDir-    else return []-  where-    getRecursiveDarcsRepos' d = do-      names <- listDirectory d-      paths <- forM names $ \name -> do-        let path = d </> name-        findAllReposInDir path-      return (concat paths)
src/Darcs/Repository/InternalTypes.hs view
@@ -13,26 +13,35 @@ -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software Foundation, -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.-module Darcs.Repository.InternalTypes ( Repository, PristineType(..)-                                      , repoCache, modifyCache-                                      , repoFormat-                                      , repoLocation-                                      , withRepoLocation-                                      , repoPristineType-                                      , unsafeCoerceRepoType-                                      , unsafeCoercePatchType-                                      , unsafeCoerceR-                                      , unsafeCoerceU-                                      , unsafeCoerceT-                                      , mkRepo-                                      ) where+module Darcs.Repository.InternalTypes+    ( Repository+    , PristineType(..)+    , AccessType(..)+    , SAccessType(..)+    , repoAccessType+    , repoCache+    , modifyCache+    , repoFormat+    , modifyRepoFormat+    , repoLocation+    , withRepoDir+    , repoPristineType+    , unsafeCoerceRepoType+    , unsafeCoercePatchType+    , unsafeCoerceR+    , unsafeCoerceU+    , unsafeEndTransaction+    , unsafeStartTransaction+    , mkRepo+    ) where  import Darcs.Prelude -import Darcs.Repository.Cache ( Cache )-import Darcs.Repository.Format ( RepoFormat )-import Darcs.Patch ( RepoType )-import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Cache ( Cache )+import Darcs.Repository.Format ( RepoFormat, unsafeWriteRepoFormat )+import Darcs.Repository.Paths ( formatPath )+import Darcs.Util.Path ( AbsoluteOrRemotePath, toPath )+import System.Directory ( withCurrentDirectory ) import Unsafe.Coerce ( unsafeCoerce )  data PristineType@@ -41,49 +50,87 @@   | HashedPristine     deriving ( Show, Eq ) +data AccessType = RO | RW deriving (Eq)++data SAccessType (rt :: AccessType) where+  SRO :: SAccessType 'RO+  SRW :: SAccessType 'RW+ -- |A @Repository@ is a token representing the state of a repository on disk.--- It is parameterized by the patch type in the repository, and witnesses for--- the recorded state of the repository (i.e. what darcs get would retrieve),--- the unrecorded state (what's in the working tree now),--- and the tentative state, which represents work in progress that will--- eventually become the new recorded state unless something goes wrong.-data Repository (rt :: RepoType) (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate =-  Repo !String !RepoFormat !PristineType Cache deriving ( Show )+-- It is parameterized by+--+-- [@rt@] the access type (whether we are in a transaction or not),+-- [@p@]  the patch type,+-- [@wU@] the witness for the unrecorded state (what's in the working tree now).+-- [@wR@] the witness for+--+--        * the recorded state when outside a transaction, or+--        * the tentative state when inside a transaction.+data Repository (rt :: AccessType) (p :: * -> * -> *) wU wR =+  Repo !String !RepoFormat !PristineType Cache (SAccessType rt) -type role Repository nominal nominal nominal nominal nominal+type role Repository nominal nominal nominal nominal -repoLocation :: Repository rt p wR wU wT -> String-repoLocation (Repo loc _ _ _) = loc+repoLocation :: Repository rt p wU wR -> String+repoLocation (Repo loc _ _ _ _) = loc -withRepoLocation :: Repository rt p wR wU wT -> IO a -> IO a-withRepoLocation repo = withCurrentDirectory (repoLocation repo)+-- | Perform an action with the current working directory set to the+-- 'repoLocation'.+withRepoDir :: Repository rt p wU wR -> IO a -> IO a+withRepoDir repo = withCurrentDirectory (repoLocation repo) -repoFormat :: Repository rt p wR wU wT -> RepoFormat-repoFormat (Repo _ fmt _ _) = fmt+repoFormat :: Repository rt p wU wR -> RepoFormat+repoFormat (Repo _ fmt _ _ _) = fmt -repoPristineType :: Repository rt p wR wU wT -> PristineType-repoPristineType (Repo _ _ pr _) = pr+repoPristineType :: Repository rt p wU wR -> PristineType+repoPristineType (Repo _ _ pr _ _) = pr -repoCache :: Repository rt p wR wU wT -> Cache-repoCache (Repo _ _ _ c) = c+repoCache :: Repository rt p wU wR -> Cache+repoCache (Repo _ _ _ c _) = c -modifyCache :: (Cache -> Cache) -> Repository rt p wR wU wT -> Repository rt p wR wU wT-modifyCache g (Repo l f p c) = Repo l f p (g c)+modifyCache :: (Cache -> Cache) -> Repository rt p wU wR -> Repository rt p wU wR+modifyCache g (Repo l f p c a) = Repo l f p (g c) a -unsafeCoerceRepoType :: Repository rt p wR wU wT -> Repository rt' p wR wU wT+repoAccessType :: Repository rt p wU wR -> SAccessType rt+repoAccessType (Repo _ _ _ _ s) = s++unsafeCoerceRepoType :: Repository rt p wU wR -> Repository rt' p wU wR unsafeCoerceRepoType = unsafeCoerce -unsafeCoercePatchType :: Repository rt p wR wU wT -> Repository rt p' wR wU wT+unsafeCoercePatchType :: Repository rt p wU wR -> Repository rt p' wU wR unsafeCoercePatchType = unsafeCoerce -unsafeCoerceR :: Repository rt p wR wU wT -> Repository rt p wR' wU wT+unsafeCoerceR :: Repository rt p wU wR -> Repository rt p wU wR' unsafeCoerceR = unsafeCoerce -unsafeCoerceU :: Repository rt p wR wU wT -> Repository rt p wR wU' wT+unsafeCoerceU :: Repository rt p wU wR -> Repository rt p wU' wR unsafeCoerceU = unsafeCoerce -unsafeCoerceT :: Repository rt p wR wU wT -> Repository rt p wR wU wT'-unsafeCoerceT = unsafeCoerce+-- | Both 'unsafeStartTransaction' and 'unsafeEndTransaction' are "unsafe" in+-- the sense that they merely "coerce" the type but do not actually perform the+-- steps ('IO' actions) required to start or end a transaction (this is done by+-- 'revertRepositoryChanges' and 'finalizeRepositoryChanges'). Technically this+-- is not an actual coercion like with e.g. 'unsafeCoerceR', due to the+-- singleton typed member, but in practical terms it is no less unsafe, because+-- 'RO' vs. 'RW' changes whether @wR@ refers to the recorded or the tentative+-- state, respectively. In particular, you will get different results if you+-- are inside a transaction and read the patchset with a "coerced" Repository+-- of access type 'RO. The same holds for other state that is modified in a+-- transaction, like the pending patch or the rebase state.+unsafeStartTransaction :: Repository 'RO p wU wR -> Repository 'RW p wU wR+unsafeStartTransaction (Repo l f p c SRO) = Repo l f p c SRW -mkRepo :: String -> RepoFormat -> PristineType -> Cache -> Repository rt p wR wU wT-mkRepo = Repo+unsafeEndTransaction :: Repository 'RW p wU wR -> Repository 'RO p wU wR+unsafeEndTransaction (Repo l f p c SRW) = Repo l f p c SRO++mkRepo :: AbsoluteOrRemotePath -> RepoFormat -> PristineType -> Cache -> Repository 'RO p wU wR+mkRepo p f pr c = Repo (toPath p) f pr c SRO++modifyRepoFormat+  :: (RepoFormat -> RepoFormat)+  -> Repository 'RW p wU wR+  -> IO (Repository 'RW p wU wR)+modifyRepoFormat f (Repo l fmt p c a) = do+  let fmt' = f fmt+  unsafeWriteRepoFormat fmt' formatPath+  return $ Repo l fmt' p c a
src/Darcs/Repository/Inventory.hs view
@@ -1,234 +1,233 @@ module Darcs.Repository.Inventory-    ( Inventory(..)-    , HeadInventory-    , InventoryEntry-    , ValidHash(..)-    , InventoryHash-    , PatchHash-    , PristineHash-    , inventoryPatchNames-    , parseInventory-    , parseHeadInventory -- not used-    , showInventory-    , showInventoryPatches-    , showInventoryEntry-    , emptyInventory-    , pokePristineHash-    , peekPristineHash-    , skipPristineHash-    , pristineName-    -- properties-    , prop_inventoryParseShow-    , prop_peekPokePristineHash-    , prop_skipPokePristineHash+    ( module Darcs.Repository.Inventory.Format+    , readPatchesFromInventoryFile+    , readPatchesFromInventory+    , readSinglePatch+    , readOneInventory+    , writeInventory+    , writePatchIfNecessary+    , writeHashFile     ) where -import Darcs.Prelude hiding ( take )--import Control.Applicative ( optional, many )-import Control.Monad ( guard )+import Darcs.Prelude -import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC+import Control.Exception ( catch )+import Control.Monad ( unless )+import System.FilePath.Posix ( (</>) )+import System.IO ( hPutStrLn, stderr )+import System.IO.Unsafe ( unsafeInterleaveIO ) -import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo )-import Darcs.Util.Parser-    ( Parser, parse, string, skipSpace, take, takeTillChar )+import Darcs.Patch ( RepoPatch, readPatch, showPatch )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Info ( PatchInfo, displayPatchInfo, piName )+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , PatchInfoAndG+    , createHashed+    , extractHash+    , info+    , patchInfoAndPatch+    )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet, Tagged(..) ) import Darcs.Patch.Show ( ShowPatchFor(..) )-import Darcs.Repository.Cache ( okayHash )-import Darcs.Util.Hash ( sha256sum )-import Darcs.Util.Printer-    ( Doc, (<+>), ($$), hcat, text, invisiblePS, packedString, renderPS )---- * Hash validation---- TODO the ValidHash class and the newtypes for the various hashes--- really don't belong here. They should be moved to D.R.Cache or--- perhaps a separate module. Also, the validation should be extended--- see D.R.Cache.checkHash.--class ValidHash a where-  getValidHash :: a -> String-  mkValidHash :: String -> a--newtype InventoryHash = InventoryHash String-  deriving (Eq, Show)--instance ValidHash InventoryHash where-  getValidHash (InventoryHash h) = h-  mkValidHash s-    | okayHash s = InventoryHash s-    | otherwise = error "Bad inventory hash!"--newtype PatchHash = PatchHash String-  deriving (Eq, Show)--instance ValidHash PatchHash where-  getValidHash (PatchHash h) = h-  mkValidHash s-    | okayHash s = PatchHash s-    | otherwise = error "Bad patch hash!"--newtype PristineHash = PristineHash String-  deriving (Eq, Show)--instance ValidHash PristineHash where-  getValidHash (PristineHash h) = h-  mkValidHash s-    | okayHash s = PristineHash s-    | otherwise = error "Bad pristine hash!"---- * Inventories---- This type and the parser combinators for it aren't actually used. They are--- here to serve as documentation for the API we would like to use but won't--- because of efficiency: we want to be able to access the pristine hash--- without forcing a complete parse of the head inventory. Thus we retain the--- lower-level peek/poke/skip API for the pristine hash.-type HeadInventory = (PristineHash, Inventory)--data Inventory = Inventory-  { inventoryParent :: Maybe InventoryHash-  , inventoryPatches :: [InventoryEntry]-  } deriving (Eq, Show)---- The 'String' is the (hashed) patch filename.-type InventoryEntry = (PatchInfo, PatchHash)--inventoryPatchNames :: Inventory -> [String]-inventoryPatchNames = map (getValidHash . snd) . inventoryPatches--emptyInventory :: Inventory-emptyInventory = Inventory Nothing []---- * Parsing--parseHeadInventory :: B.ByteString -> Either String HeadInventory-parseHeadInventory = fmap fst . parse pHeadInv--parseInventory :: B.ByteString -> Either String Inventory-parseInventory = fmap fst . parse pInv--pHeadInv :: Parser HeadInventory-pHeadInv = (,) <$> pPristineHash <*> pInv--pPristineHash :: Parser PristineHash-pPristineHash = do-  string pristineName-  skipSpace-  pHash--pInv :: Parser Inventory-pInv = Inventory <$> pInvParent <*> pInvPatches--pInvParent :: Parser (Maybe InventoryHash)-pInvParent = optional $ do-  string parentName-  skipSpace-  pHash--pHash :: ValidHash h => Parser h-pHash = do-  hash <- BC.unpack <$> pLine-  guard (okayHash hash)-  return (mkValidHash hash)+import Darcs.Patch.Witnesses.Ordered ( RL(..), mapRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, seal, unseal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation )+import Darcs.Repository.Inventory.Format+import Darcs.Util.Cache+    ( Cache+    , fetchFileUsingCache+    , peekInCache+    , speculateFilesUsingCache+    , writeFileUsingCache+    )+import Darcs.Util.File ( Cachable(Uncachable), gzFetchFilePS )+import Darcs.Util.Printer ( Doc, renderPS, renderString, text, ($$) )+import Darcs.Util.Progress ( debugMessage, finishedOneIO ) -pLine :: Parser B.ByteString-pLine = takeTillChar '\n' <* take 1+-- | Read a 'PatchSet' starting with a specific inventory inside a 'Repository'.+readPatchesFromInventoryFile+  :: (PatchListFormat p, ReadPatch p)+  => FilePath+  -> Repository rt p wU wR+  -> IO (PatchSet p Origin wS)+readPatchesFromInventoryFile invPath repo = do+  let repodir = repoLocation repo+  Sealed ps <-+    catch+      (readInventoryPrivate (repodir </> invPath) >>=+       readPatchesFromInventory (repoCache repo))+      (\e -> hPutStrLn stderr ("Invalid repository: " ++ repodir) >> ioError e)+  return $ unsafeCoerceP ps -pInvPatches :: Parser [InventoryEntry]-pInvPatches = many pInvEntry+-- | Read a complete 'PatchSet' from a 'Cache', by following the chain of+-- 'Inventory's, starting with the given one.+readPatchesFromInventory :: (PatchListFormat p, ReadPatch p)+                         => Cache+                         -> Inventory+                         -> IO (SealedPatchSet p Origin)+readPatchesFromInventory cache = parseInv+  where+    parseInv :: (PatchListFormat p, ReadPatch p)+             => Inventory+             -> IO (SealedPatchSet p Origin)+    parseInv (Inventory Nothing ris) =+        mapSeal (PatchSet NilRL) <$> readPatchesFromInventoryEntries cache ris+    parseInv (Inventory (Just h) []) =+        -- TODO could be more tolerant and create a larger PatchSet+        error $ "bad inventory " ++ encodeValidHash h ++ " (no tag) in parseInv!"+    parseInv (Inventory (Just h) (t : ris)) = do+        Sealed ts <- delaySealed (read_ts t h)+        Sealed ps <- delaySealed (readPatchesFromInventoryEntries cache ris)+        return $ seal $ PatchSet ts ps -pInvEntry :: Parser InventoryEntry-pInvEntry = do-  info <- readPatchInfo-  skipSpace-  string hashName-  skipSpace-  hash <- pHash-  return (info, hash)+    read_ts :: (PatchListFormat p, ReadPatch p) => InventoryEntry+            -> InventoryHash -> IO (Sealed (RL (Tagged p) Origin))+    read_ts tag0 h0 = do+        contents <- unsafeInterleaveIO $ readTaggedInventory h0+        let is = case contents of+                    Inventory (Just _) (_ : ris0) -> ris0+                    Inventory Nothing ris0 -> ris0+                    Inventory (Just _) [] -> error "inventory without tag!"+        Sealed ts <-+            delaySealed $+                case contents of+                    Inventory (Just h') (t' : _) -> read_ts t' h'+                    Inventory (Just _) [] -> error "inventory without tag!"+                    Inventory Nothing _ -> return $ seal NilRL+        Sealed ps <- delaySealed (readPatchesFromInventoryEntries cache is)+        Sealed tag00 <- read_tag tag0+        return $ seal $ ts :<: Tagged ps tag00 (Just h0) --- * Showing+    read_tag :: (PatchListFormat p, ReadPatch p) => InventoryEntry+             -> IO (Sealed (PatchInfoAnd p wX))+    read_tag (i, h) =+        mapSeal (patchInfoAndPatch i) <$> createHashed h (readSinglePatch cache i) -showInventory :: Inventory -> Doc-showInventory inv =-  showParent (inventoryParent inv) <>-  showInventoryPatches (inventoryPatches inv)+    readTaggedInventory :: InventoryHash -> IO Inventory+    readTaggedInventory invHash = do+        (fileName, inventory) <- fetchFileUsingCache cache invHash+        case parseInventory inventory of+          Right r -> return r+          Left e -> fail $ unlines [unwords ["parse error in file", fileName],e] -showInventoryPatches :: [InventoryEntry] -> Doc-showInventoryPatches = hcat . map showInventoryEntry+-- | Read patches from a 'Cache' as specified by a list of 'InventoryEntry'.+readPatchesFromInventoryEntries :: ReadPatch np+                                => Cache+                                -> [InventoryEntry]+                                -> IO (Sealed (RL (PatchInfoAndG np) wX))+readPatchesFromInventoryEntries cache ris = read_patches (reverse ris)+  where+    read_patches [] = return $ seal NilRL+    read_patches allis@((i1, h1) : is1) =+        lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1)+                    (createHashed h1 (const $ speculateAndParse h1 allis i1))+      where+        rp [] = return $ seal NilRL+        rp [(i, h), (il, hl)] =+            lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)+                        (rp [(il, hl)])+                        (createHashed h+                            (const $ speculateAndParse h (reverse allis) i))+        rp ((i, h) : is) =+            lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)+                        (rp is)+                        (createHashed h (readSinglePatch cache i)) -showInventoryEntry :: InventoryEntry -> Doc-showInventoryEntry (pinf, hash) =-  showPatchInfo ForStorage pinf $$-  packedString hashName <+> text (getValidHash hash) <> packedString newline+    lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ)+                -> IO (Sealed (p wX))+                -> (forall wB . IO (Sealed (q wB)))+                -> IO (Sealed (r wX))+    lift2Sealed f iox ioy = do+        Sealed x <- delaySealed iox+        Sealed y <- delaySealed ioy+        return $ seal $ f y x -showParent :: Maybe InventoryHash -> Doc-showParent (Just (InventoryHash hash)) =-  packedString parentName $$ text hash <> packedString newline-showParent Nothing = mempty+    speculateAndParse h is i = speculate h is >> readSinglePatch cache i h --- * Accessing the pristine hash+    speculate :: PatchHash -> [InventoryEntry] -> IO ()+    speculate pHash is = do+        already_got_one <- peekInCache cache pHash+        unless already_got_one $+            speculateFilesUsingCache cache (map snd is) --- | Replace the pristine hash at the start of a raw, unparsed 'HeadInventory'--- or add it if none is present.-pokePristineHash :: PristineHash -> B.ByteString -> Doc-pokePristineHash (PristineHash h) inv =-  invisiblePS pristineName <> text h $$ invisiblePS (skipPristineHash inv)+-- | We have to unseal and then reseal, otherwise the 'unsafeInterleaveIO' has+-- no effect.+delaySealed :: IO (Sealed (p wX)) -> IO (Sealed (p wX))+delaySealed = fmap (unseal seal) . unsafeInterleaveIO -takeHash :: B.ByteString -> Maybe (String, B.ByteString)-takeHash input = do-  let (hline,rest) = BC.breakSubstring newline input-  let hash = BC.unpack hline-  guard $ okayHash hash-  return (hash, rest)+-- | Read a single patch from a 'Cache', given its 'PatchInfo' and 'PatchHash'.+-- Fails with an error message if the patch file cannot be parsed.+readSinglePatch :: ReadPatch p+                => Cache+                -> PatchInfo -> PatchHash -> IO (Sealed (p wX))+readSinglePatch cache i h = do+    debugMessage $ "Reading patch file for: " ++ piName i+    (fn, ps) <- fetchFileUsingCache cache h+    case readPatch ps of+        Right p -> return p+        Left e -> fail $ unlines+            [ "Couldn't parse file " ++ fn+            , "which is patch"+            , renderString $ displayPatchInfo i+            , e+            ] -peekPristineHash :: B.ByteString -> PristineHash-peekPristineHash inv =-  case tryDropPristineName inv of-    Just rest ->-      case takeHash rest of-        Just (h, _) -> mkValidHash h-        Nothing -> error $ "Bad hash in inventory!"-    Nothing -> mkValidHash $ sha256sum B.empty+readOneInventory :: ReadPatch p+                 => Cache -> FilePath -> IO (Sealed (RL (PatchInfoAndG p) wX))+readOneInventory cache path = do+  Inventory _ invEntries <- readInventoryPrivate path+  readPatchesFromInventoryEntries cache invEntries --- |skipPristineHash drops the 'pristine: HASH' prefix line, if present.-skipPristineHash :: B.ByteString -> B.ByteString-skipPristineHash ps =-  case tryDropPristineName ps of-    Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest-    Nothing -> ps+-- | Read an 'Inventory' from a file. Fails with an error message if+-- file is not there or cannot be parsed.+readInventoryPrivate :: FilePath -> IO Inventory+readInventoryPrivate path = do+    inv <- skipPristineHash <$> gzFetchFilePS path Uncachable+    case parseInventory inv of+      Right r -> return r+      Left e -> fail $ unlines [unwords ["parse error in file", path],e] -tryDropPristineName :: B.ByteString -> Maybe B.ByteString-tryDropPristineName input =-    if prefix == pristineName then Just rest else Nothing+writeInventory :: RepoPatch p => String -> Cache+               -> PatchSet p Origin wX -> IO InventoryHash+writeInventory tediousName cache = go   where-    (prefix, rest) = B.splitAt (B.length pristineName) input---- * Key phrases--pristineName :: B.ByteString-pristineName = BC.pack "pristine:"--parentName :: B.ByteString-parentName = BC.pack "Starting with inventory:"--hashName :: B.ByteString-hashName = BC.pack "hash:"--newline :: B.ByteString-newline = BC.pack "\n"---- * Properties+    go :: RepoPatch p => PatchSet p Origin wX -> IO InventoryHash+    go (PatchSet ts ps) = do+      entries <- sequence $ mapRL (writePatchIfNecessary cache) ps+      content <- write_ts ts entries+      writeHashFile cache content+    write_ts NilRL entries = return $ showInventoryPatches (reverse entries)+    write_ts (tts :<: Tagged tps t maybeHash) entries = do+      -- if the Tagged has a hash, then we know that it has already been+      -- written; otherwise recurse without the tag+      parenthash <- maybe (go (PatchSet tts tps)) return maybeHash+      let parenthash_str = encodeValidHash parenthash+      finishedOneIO tediousName parenthash_str+      tag_entry <- writePatchIfNecessary cache t+      return $+        text ("Starting with inventory:\n" ++ parenthash_str) $$+        showInventoryPatches (tag_entry : reverse entries) -prop_inventoryParseShow :: Inventory -> Bool-prop_inventoryParseShow inv =-  Right inv == parseInventory (renderPS (showInventory inv))+-- | Write a 'PatchInfoAnd' to disk and return an 'InventoryEntry' i.e. the+-- patch info and hash. However, if we patch already contains a hash, assume it+-- has already been written to disk at some point and merely return the info+-- and hash.+writePatchIfNecessary :: RepoPatch p => Cache+                      -> PatchInfoAnd p wX wY -> IO InventoryEntry+writePatchIfNecessary c hp = infohp `seq`+    case extractHash hp of+        Right h -> return (infohp, h)+        Left p ->+          (infohp,) <$>+            writeHashFile c (showPatch ForStorage p)+  where+    infohp = info hp -prop_peekPokePristineHash :: (PristineHash, B.ByteString) -> Bool-prop_peekPokePristineHash (hash, raw) =-  hash == peekPristineHash (renderPS (pokePristineHash hash raw))+-- | Wrapper around 'writeFileUsingCache' that takes a 'Doc' instead of a+-- 'ByteString'.+writeHashFile :: ValidHash h => Cache -> Doc -> IO h+writeHashFile c d = writeFileUsingCache c (renderPS d) -prop_skipPokePristineHash :: (PristineHash, B.ByteString) -> Bool-prop_skipPokePristineHash (hash, raw) =-  raw == skipPristineHash (renderPS (pokePristineHash hash raw))
+ src/Darcs/Repository/Inventory/Format.hs view
@@ -0,0 +1,198 @@+module Darcs.Repository.Inventory.Format+    ( Inventory(..)+    , HeadInventory+    , InventoryEntry+    , ValidHash(..) -- re-export+    , decodeValidHash -- re-export+    , encodeValidHash -- re-export+    , InventoryHash+    , PatchHash+    , PristineHash+    , inventoryPatchNames+    , parseInventory+    , parseHeadInventory -- not used+    , showInventory+    , showInventoryPatches+    , showInventoryEntry+    , emptyInventory+    , pokePristineHash+    , peekPristineHash+    , skipPristineHash+    , pristineName+    -- properties+    , prop_inventoryParseShow+    , prop_peekPokePristineHash+    , prop_skipPokePristineHash+    ) where++import Darcs.Prelude++import Control.Applicative ( optional, many )++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC++import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo )+import Darcs.Util.Parser+    ( Parser, char, parse, string, skipSpace )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Util.Printer+    ( Doc, (<+>), ($$), hcat, text, invisiblePS, packedString, renderPS )+import Darcs.Util.ValidHash+    ( InventoryHash+    , PatchHash+    , PristineHash+    , ValidHash(..)+    , calcValidHash+    , decodeValidHash+    , encodeValidHash+    , parseValidHash+    )++-- * Inventories++-- This type and the parser combinators for it aren't actually used. They are+-- here to serve as documentation for the API we would like to use but won't+-- because of efficiency: we want to be able to access the pristine hash+-- without forcing a complete parse of the head inventory. Thus we retain the+-- lower-level peek/poke/skip API for the pristine hash.+type HeadInventory = (PristineHash, Inventory)++data Inventory = Inventory+  { inventoryParent :: Maybe InventoryHash+  , inventoryPatches :: [InventoryEntry]+  } deriving (Eq, Show)++-- The 'String' is the (hashed) patch filename.+type InventoryEntry = (PatchInfo, PatchHash)++inventoryPatchNames :: Inventory -> [String]+inventoryPatchNames = map (encodeValidHash . snd) . inventoryPatches++emptyInventory :: Inventory+emptyInventory = Inventory Nothing []++-- * Parsing++parseHeadInventory :: B.ByteString -> Either String HeadInventory+parseHeadInventory = fmap fst . parse pHeadInv++parseInventory :: B.ByteString -> Either String Inventory+parseInventory = fmap fst . parse pInv++pHeadInv :: Parser HeadInventory+pHeadInv = (,) <$> pPristineHash <*> pInv++pPristineHash :: Parser PristineHash+pPristineHash = do+  string pristineName+  skipSpace+  pHash++pInv :: Parser Inventory+pInv = Inventory <$> pInvParent <*> pInvPatches++pInvParent :: Parser (Maybe InventoryHash)+pInvParent = optional $ do+  string parentName+  skipSpace+  pHash++pHash :: ValidHash h => Parser h+pHash = parseValidHash <* char '\n'++pInvPatches :: Parser [InventoryEntry]+pInvPatches = many pInvEntry++pInvEntry :: Parser InventoryEntry+pInvEntry = do+  info <- readPatchInfo+  skipSpace+  string hashName+  skipSpace+  hash <- pHash+  return (info, hash)++-- * Showing++showInventory :: Inventory -> Doc+showInventory inv =+  showParent (inventoryParent inv) <>+  showInventoryPatches (inventoryPatches inv)++showInventoryPatches :: [InventoryEntry] -> Doc+showInventoryPatches = hcat . map showInventoryEntry++showInventoryEntry :: InventoryEntry -> Doc+showInventoryEntry (pinf, hash) =+  showPatchInfo ForStorage pinf $$+  packedString hashName <+> text (encodeValidHash hash) <> packedString newline++showParent :: Maybe InventoryHash -> Doc+showParent (Just hash) =+  packedString parentName $$ text (encodeValidHash hash) <> packedString newline+showParent Nothing = mempty++-- * Accessing the pristine hash++-- | Replace the pristine hash at the start of a raw, unparsed 'HeadInventory'+-- or add it if none is present.+pokePristineHash :: PristineHash -> B.ByteString -> Doc+pokePristineHash hash inv =+  invisiblePS pristineName <> text (encodeValidHash hash) $$ invisiblePS (skipPristineHash inv)++takeHash :: B.ByteString -> Maybe (PristineHash, B.ByteString)+takeHash input = do+  let (hline,rest) = BC.breakSubstring newline input+  ph <- decodeValidHash (BC.unpack hline)+  return (ph, rest)++peekPristineHash :: B.ByteString -> PristineHash+peekPristineHash inv =+  case tryDropPristineName inv of+    Just rest ->+      case takeHash rest of+        Just (h, _) -> h+        Nothing -> error $ "Bad hash in inventory!"+    Nothing -> calcValidHash B.empty++-- |skipPristineHash drops the 'pristine: HASH' prefix line, if present.+skipPristineHash :: B.ByteString -> B.ByteString+skipPristineHash ps =+  case tryDropPristineName ps of+    Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest+    Nothing -> ps++tryDropPristineName :: B.ByteString -> Maybe B.ByteString+tryDropPristineName input =+    if prefix == pristineName then Just rest else Nothing+  where+    (prefix, rest) = B.splitAt (B.length pristineName) input++-- * Key phrases++pristineName :: B.ByteString+pristineName = BC.pack "pristine:"++parentName :: B.ByteString+parentName = BC.pack "Starting with inventory:"++hashName :: B.ByteString+hashName = BC.pack "hash:"++newline :: B.ByteString+newline = BC.pack "\n"++-- * Properties++prop_inventoryParseShow :: Inventory -> Bool+prop_inventoryParseShow inv =+  Right inv == parseInventory (renderPS (showInventory inv))++prop_peekPokePristineHash :: (PristineHash, B.ByteString) -> Bool+prop_peekPokePristineHash (hash, raw) =+  hash == peekPristineHash (renderPS (pokePristineHash hash raw))++prop_skipPokePristineHash :: (PristineHash, B.ByteString) -> Bool+prop_skipPokePristineHash (hash, raw) =+  raw == skipPristineHash (renderPS (pokePristineHash hash raw))
src/Darcs/Repository/Job.hs view
@@ -16,7 +16,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MultiWayIf #-}  module Darcs.Repository.Job     ( RepoJob(..)@@ -26,7 +26,6 @@     , withRepoLockCanFail     , withRepository     , withRepositoryLocation-    , checkRepoIsNoRebase     , withUMaskFlag     ) where @@ -41,39 +40,28 @@ import Darcs.Patch ( PrimOf ) import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.RepoType-  ( RepoType(..), SRepoType(..), IsRepoType-  , RebaseType(..), SRebaseType(..), IsRebaseType-  , singletonRepoType-  ) -import Darcs.Repository.Flags-    ( UseCache(..), UpdatePending(..), DryRun(..), UMask (..)-    )+import Darcs.Repository.Flags ( UMask(..), UseCache(..) ) import Darcs.Repository.Format     ( RepoProperty( Darcs2                   , Darcs3-                  , RebaseInProgress-                  , RebaseInProgress_2_16                   , HashedInventory                   )     , formatHas     , writeProblem     ) import Darcs.Repository.Identify ( identifyRepository )-import Darcs.Repository.Hashed( revertRepositoryChanges )+import Darcs.Repository.Transaction( revertRepositoryChanges ) import Darcs.Repository.InternalTypes     ( Repository+    , AccessType(..)     , repoFormat-    , repoLocation-    , unsafeCoerceRepoType     , unsafeCoercePatchType+    , unsafeStartTransaction     ) import Darcs.Repository.Paths ( lockPath ) import Darcs.Repository.Rebase-    ( startRebaseJob-    , rebaseJob-    , maybeDisplaySuspendedStatus+    ( displayRebaseStatus     , checkOldStyleRebaseStatus     ) import Darcs.Util.Lock ( withLock, withLockCanFail )@@ -82,7 +70,7 @@  import Control.Monad ( when ) import Control.Exception ( bracket_, finally )-import Data.List ( intercalate )+import Data.Constraint ( Dict(..) )  import Foreign.C.String ( CString, withCString ) import Foreign.C.Error ( throwErrno )@@ -110,52 +98,56 @@            (reset_umask rc)            job --- |A @RepoJob@ wraps up an action to be performed with a repository. Because repositories--- can contain different types of patches, such actions typically need to be polymorphic--- in the kind of patch they work on. @RepoJob@ is used to wrap up the polymorphism,--- and the various functions that act on a @RepoJob@ are responsible for instantiating--- the underlying action with the appropriate patch type.-data RepoJob a-    -- = RepoJob (forall p wR wU . RepoPatch p => Repository p wR wU wR -> IO a)+type Job rt p wR wU a = Repository rt p wU wR -> IO a++type TreePatch p = (RepoPatch p, ApplyState p ~ Tree)+type V1Patch p = p ~ RepoPatchV1 V1.Prim+type V2Patch p = p ~ RepoPatchV2 V2.Prim+type PrimV1Patch p = (TreePatch p, IsPrimV1 (PrimOf p))++type TreePatchJob rt a = forall p wR wU . TreePatch p => Job rt p wR wU a+type V1PatchJob rt a = forall p wR wU . V1Patch p => Job rt p wR wU a+type V2PatchJob rt a = forall p wR wU . V2Patch p => Job rt p wR wU a+type PrimV1PatchJob rt a = forall p wR wU . PrimV1Patch p => Job rt p wR wU a++-- |A @RepoJob@ wraps up an action to be performed with a repository. Because+-- repositories can contain different types of patches, such actions typically+-- need to be polymorphic in the kind of patch they work on. @RepoJob@ is used+-- to wrap up the polymorphism, and the various functions that act on a+-- @RepoJob@ are responsible for instantiating the underlying action with the+-- appropriate patch type.+data RepoJob rt a     -- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob-    =-    -- |The most common @RepoJob@; the underlying action can accept any patch type that-    -- a darcs repository may use.-      RepoJob (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-               => Repository rt p wR wU wR -> IO a)++    -- |The most common 'RepoJob'; the underlying action can accept any patch+    -- whose 'ApplyState' is 'Tree'.+    = RepoJob (TreePatchJob rt a)     -- |A job that only works on darcs 1 patches-    | V1Job (forall wR wU . Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) wR wU wR -> IO a)+    | V1Job (V1PatchJob rt a)     -- |A job that only works on darcs 2 patches-    | V2Job (forall rt wR wU . IsRepoType rt => Repository rt (RepoPatchV2 V2.Prim) wR wU wR -> IO a)-    -- |A job that works on any repository where the patch type @p@ has 'PrimOf' @p@ = 'Prim'.-    ---    -- This was added to support darcsden, which inspects the internals of V1 prim patches.-    ---    -- In future this should be replaced with a more abstract inspection API as part of 'PrimPatch'.-    | PrimV1Job (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, IsPrimV1 (PrimOf p))-               => Repository rt p wR wU wR -> IO a)-    -- A job that works on normal darcs repositories, but will want access to the rebase patch if it exists.-    | RebaseAwareJob (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO a)-    | RebaseJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)-    | OldRebaseJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)-    | StartRebaseJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)+    | V2Job (V2PatchJob rt a)+    -- |A job that works on any repository where the patch type @p@ has+    -- 'PrimOf' @p@ = 'Prim'. This was added to support darcsden, which+    -- inspects the internals of V1 prim patches. In future it should be+    -- replaced with a more abstract inspection API as part of 'PrimPatch'.+    | PrimV1Job (PrimV1PatchJob rt a)+    -- |A job that works even if there is an old-style rebase in progress.+    | OldRebaseJob (TreePatchJob rt a) -onRepoJob :: RepoJob a-          -> (forall rt p wR wU . (RepoPatch p, ApplyState p ~ Tree) => (Repository rt p wR wU wR -> IO a) -> Repository rt p wR wU wR -> IO a)-          -> RepoJob a+onRepoJob+  :: RepoJob rt1 a -- original repojob passed to withXxx+  -> (  forall p wR wU+      . TreePatch p+     => (Repository rt1 p wU wR -> IO a)+     -> (Repository rt2 p wU wR -> IO a)+     )+  -> RepoJob rt2 a -- result job takes a Repo rt2 onRepoJob (RepoJob job) f = RepoJob (f job) onRepoJob (V1Job job) f = V1Job (f job) onRepoJob (V2Job job) f = V2Job (f job) onRepoJob (PrimV1Job job) f = PrimV1Job (f job)-onRepoJob (RebaseAwareJob job) f = RebaseAwareJob (f job)-onRepoJob (RebaseJob job) f = RebaseJob (f job) onRepoJob (OldRebaseJob job) f = OldRebaseJob (f job)-onRepoJob (StartRebaseJob job) f = StartRebaseJob (f job) --- | apply a given RepoJob to a repository in the current working directory-withRepository :: UseCache -> RepoJob a -> IO a-withRepository useCache = withRepositoryLocation useCache "."- -- | This is just an internal type to Darcs.Repository.Job for -- calling runJob in a strongly-typed way data RepoPatchType p where@@ -163,201 +155,105 @@   RepoV2 :: RepoPatchType (RepoPatchV2 V2.Prim)   RepoV3 :: RepoPatchType (RepoPatchV3 V2.Prim) --- | This type allows us to check multiple patch types against the+-- | Check multiple patch types against the -- constraints required by most repository jobs-data IsTree p where-  IsTree :: (ApplyState p ~ Tree) => IsTree p--checkTree :: RepoPatchType p -> IsTree p-checkTree RepoV1 = IsTree-checkTree RepoV2 = IsTree-checkTree RepoV3 = IsTree+checkTree :: RepoPatchType p -> Dict (ApplyState p ~ Tree)+checkTree RepoV1 = Dict+checkTree RepoV2 = Dict+checkTree RepoV3 = Dict -class ApplyState p ~ Tree => IsPrimV1 p where+class IsPrimV1 p where   toPrimV1 :: p wX wY -> Prim wX wY instance IsPrimV1 V1.Prim where   toPrimV1 = V1.unPrim instance IsPrimV1 V2.Prim where   toPrimV1 = V2.unPrim --- | This type allows us to check multiple patch types against the+-- | Check multiple patch types against the -- constraints required by 'PrimV1Job'-data UsesPrimV1 p where-  UsesPrimV1 :: (ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) => UsesPrimV1 p--checkPrimV1 :: RepoPatchType p -> UsesPrimV1 p-checkPrimV1 RepoV1 = UsesPrimV1-checkPrimV1 RepoV2 = UsesPrimV1-checkPrimV1 RepoV3 = UsesPrimV1---- | apply a given RepoJob to a repository in a given url-withRepositoryLocation :: UseCache -> String -> RepoJob a -> IO a-withRepositoryLocation useCache url repojob = do-    repo <- identifyRepository useCache url--    let-        rf = repoFormat repo-        startRebase =-            case repojob of-                StartRebaseJob {} -> True-                _ -> False--        -- in order to pass SRepoType and RepoPatchType at different types, we need a polymorphic-        -- function that we call in two different ways, rather than directly varying the argument.-        runJob1-          :: IsRebaseType rebaseType-          => SRebaseType rebaseType -> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a-        runJob1 isRebase =-          if formatHas Darcs3 rf-          then runJob RepoV3 (SRepoType isRebase)-          else-            if formatHas Darcs2 rf-            then runJob RepoV2 (SRepoType isRebase)-            else runJob RepoV1 (SRepoType isRebase)--        runJob2 :: Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a-        runJob2 =-          if startRebase ||-             formatHas RebaseInProgress rf || formatHas RebaseInProgress_2_16 rf-            then runJob1 SIsRebase-            else runJob1 SNoRebase--    runJob2 repo repojob-+checkPrimV1 :: RepoPatchType p -> Dict (IsPrimV1 (PrimOf p))+checkPrimV1 RepoV1 = Dict+checkPrimV1 RepoV2 = Dict+checkPrimV1 RepoV3 = Dict  runJob-  :: forall rt p rtDummy pDummy wR wU a-   . (IsRepoType rt, RepoPatch p)+  :: forall rt p pDummy wR wU a+   . RepoPatch p   => RepoPatchType p-  -> SRepoType rt-  -> Repository rtDummy pDummy wR wU wR-  -> RepoJob a+  -> Repository rt pDummy wU wR+  -> RepoJob rt a   -> IO a-runJob patchType (SRepoType isRebase) repo repojob = do-+runJob patchType repo repojob = do   -- The actual type the repository should have is only known when   -- when this function is called, so we need to "cast" it to its proper type   let-    therepo = unsafeCoercePatchType (unsafeCoerceRepoType repo) :: Repository rt p wR wU wR--    patchTypeString :: String-    patchTypeString =-      case patchType of-        RepoV3 -> "darcs-3"-        RepoV2 -> "darcs-2"-        RepoV1 -> "darcs-1"--    repoAttributes :: [String]-    repoAttributes =-      case isRebase of-        SIsRebase -> ["rebase"]-        SNoRebase -> []--    repoAttributesString :: String-    repoAttributesString =-      case repoAttributes of-        [] -> ""-        _ -> " " ++ intercalate "+" repoAttributes--  debugMessage $ "Identified " ++ patchTypeString ++ repoAttributesString ++-                 " repo: " ++ repoLocation repo--  case repojob of-    RepoJob job ->-      case checkTree patchType of-        IsTree -> do-          checkOldStyleRebaseStatus isRebase therepo-          job therepo-            `finally`-              maybeDisplaySuspendedStatus isRebase therepo--    PrimV1Job job ->-      case checkPrimV1 patchType of-        UsesPrimV1 -> do-          checkOldStyleRebaseStatus isRebase therepo-          job therepo-            `finally`-              maybeDisplaySuspendedStatus isRebase therepo--    V2Job job ->-      case (patchType, isRebase) of-        (RepoV2, SNoRebase) -> job therepo-        (RepoV2, SIsRebase) ->-          fail "This command is not supported while a rebase is in progress."-        (RepoV1, _        ) ->-          fail $    "This repository contains darcs v1 patches,"-                 ++ " but the command requires darcs v2 patches."-        (RepoV3, _        ) ->-          fail $    "This repository contains darcs v3 patches,"-                 ++ " but the command requires darcs v2 patches."--    V1Job job ->-      case (patchType, isRebase) of-        (RepoV1, SNoRebase) -> job therepo-        (RepoV1, SIsRebase) ->-          fail "This command is not supported while a rebase is in progress."-        (RepoV2, _        ) ->-          fail $    "This repository contains darcs v2 patches,"-                 ++ " but the command requires darcs v1 patches."-        (RepoV3, _        ) ->-          fail $    "This repository contains darcs v3 patches,"-                 ++ " but the command requires darcs v1 patches."--    RebaseAwareJob job ->-      case (checkTree patchType, isRebase) of-        (IsTree, SNoRebase) -> job therepo-        (IsTree, SIsRebase) -> do-          checkOldStyleRebaseStatus isRebase therepo-          rebaseJob job therepo--    RebaseJob job ->-      case (checkTree patchType, isRebase) of-        (_     , SNoRebase) -> fail "No rebase in progress. Try 'darcs rebase suspend' first."-        (IsTree, SIsRebase) -> do-          checkOldStyleRebaseStatus isRebase therepo-          rebaseJob job therepo+    therepo = unsafeCoercePatchType repo :: Repository rt p wU wR+    incompatible want got = fail $+      "This repository contains darcs "++got++" patches,\+      \ but the command requires darcs "++want++" patches."+  Dict <- return $ checkTree patchType+  let thejob =+        case repojob of+          RepoJob job -> do+            checkOldStyleRebaseStatus therepo+            job therepo+          PrimV1Job job -> do+            Dict <- return $ checkPrimV1 patchType+            checkOldStyleRebaseStatus therepo+            job therepo+          V2Job job ->+            case patchType of+              RepoV2 -> do+                checkOldStyleRebaseStatus therepo+                job therepo+              RepoV1 -> incompatible "v2" "v1"+              RepoV3 -> incompatible "v2" "v3"+          V1Job job ->+            case patchType of+              RepoV1 -> do+                checkOldStyleRebaseStatus therepo+                job therepo+              RepoV2 -> incompatible "v1" "v2"+              RepoV3 -> incompatible "v1" "v3"+          OldRebaseJob job -> job therepo+  thejob `finally` displayRebaseStatus therepo -    OldRebaseJob job ->-      case (checkTree patchType, isRebase) of-        (_     , SNoRebase) -> fail "No rebase in progress."-        (IsTree, SIsRebase) -> do-          -- no checkOldStyleRebaseStatus, this is for 'rebase upgrade'-          job therepo-            `finally`-              maybeDisplaySuspendedStatus isRebase therepo+-- | apply a given RepoJob to a repository in a given url+withRepositoryLocation :: UseCache -> String -> RepoJob 'RO a -> IO a+withRepositoryLocation useCache url repojob = do+  repo <- identifyRepository useCache url+  let rf = repoFormat repo+  if | formatHas Darcs3 rf -> runJob RepoV3 repo repojob+     | formatHas Darcs2 rf -> runJob RepoV2 repo repojob+     | otherwise -> runJob RepoV1 repo repojob -    StartRebaseJob job ->-      case (checkTree patchType, isRebase) of-        (_     , SNoRebase) -> error "impossible case"-        (IsTree, SIsRebase) -> do-          -- no checkOldStyleRebaseStatus, startRebaseJob does that-          startRebaseJob job therepo+-- | apply a given RepoJob to a repository in the current working directory+withRepository :: UseCache -> RepoJob 'RO a -> IO a+withRepository useCache = withRepositoryLocation useCache "."  -- | Apply a given RepoJob to a repository in the current working directory. -- However, before doing the job, take the repo lock and initializes a repo--- transaction, unless this is a dry-run.-withRepoLock :: DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a-withRepoLock YesDryRun useCache _ _ repojob =-  withRepository useCache $ onRepoJob repojob $ \job repository -> job repository-withRepoLock NoDryRun useCache upe um repojob =+-- transaction.+withRepoLock :: UseCache -> UMask -> RepoJob 'RW a -> IO a+withRepoLock useCache um repojob =   withLock lockPath $     withRepository useCache $ onRepoJob repojob $ \job repository -> do       maybe (return ()) fail $ writeProblem (repoFormat repository)-      withUMaskFlag um $ revertRepositoryChanges repository upe >>= job+      withUMaskFlag um $ revertRepositoryChanges repository >>= job  -- | run a lock-taking job in an old-fashion repository. --   only used by `darcs optimize upgrade`.-withOldRepoLock :: RepoJob a -> IO a+withOldRepoLock :: RepoJob 'RW a -> IO a withOldRepoLock repojob =-    withRepository NoUseCache $ onRepoJob repojob $ \job repository ->-    withLock lockPath $ job repository+  withRepository NoUseCache $ onRepoJob repojob $ \job repository ->+    withLock lockPath $ job $ unsafeStartTransaction repository  -- | Apply a given RepoJob to a repository in the current working directory, -- taking a lock. If lock not takeable, do nothing. If old-fashioned -- repository, do nothing. The job must not touch pending or pending.tentative, -- because there is no call to revertRepositoryChanges. This entry point is -- currently only used for attemptCreatePatchIndex.-withRepoLockCanFail :: UseCache -> RepoJob () -> IO ()+withRepoLockCanFail :: UseCache -> RepoJob 'RO () -> IO () withRepoLockCanFail useCache repojob = do   eitherDone <-     withLockCanFail lockPath $@@ -372,14 +268,3 @@   case eitherDone of     Left  _ -> debugMessage "Lock could not be obtained, not doing the job."     Right _ -> return ()---- | If the 'RepoType' of the given repo indicates that we have 'NoRebase',--- then 'Just' the repo with the refined type, else 'Nothing'.--- NB The amount of types we have to import to make this simple check is ridiculous!-checkRepoIsNoRebase :: forall rt p wR wU wT. IsRepoType rt-                    => Repository rt p wR wU wT-                    -> Maybe (Repository ('RepoType 'NoRebase) p wR wU wT)-checkRepoIsNoRebase repo =-  case singletonRepoType :: SRepoType rt of-    SRepoType SNoRebase -> Just repo-    SRepoType SIsRebase -> Nothing
src/Darcs/Repository/Match.hs view
@@ -17,7 +17,7 @@  module Darcs.Repository.Match     (-      getRecordedUpToMatch+      getPristineUpToMatch     , getOnePatchset     ) where @@ -31,48 +31,42 @@     )  import Darcs.Patch.Bundle ( readContextFile )-import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( RepoPatch, IsRepoType )-import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet, patchSetDrop )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Set ( Origin, SealedPatchSet, patchSetDrop ) -import Darcs.Repository.Flags-    ( WithWorkingDir (WithWorkingDir) )-import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault ) import Darcs.Repository.InternalTypes ( Repository )-import Darcs.Repository.Hashed ( readRepo )-import Darcs.Repository.Pristine ( createPristineDirectoryTree )+import Darcs.Repository.Hashed ( readPatches )+import Darcs.Repository.Pristine ( readPristine )  import Darcs.Util.Tree ( Tree )+import Darcs.Util.Tree.Monad ( virtualTreeIO )  import Darcs.Util.Path ( toFilePath ) --- | Create a new pristine and working tree in the current working directory,--- corresponding to the state of the 'PatchSet' returned by 'getOnePatchSet'--- for the same 'PatchSetMatch'.-getRecordedUpToMatch :: (ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                     => Repository rt p wR wU wT+-- | Return the pristine tree up to the given 'PatchSetMatch'.+-- In the typical case where the match is closer to the end of the repo than+-- its beginning, this is (a lot) more efficient than applying the result of+-- 'getOnePatchset' to an empty tree.+getPristineUpToMatch :: (RepoPatch p, ApplyState p ~ Tree)+                     => Repository rt p wU wR                      -> PatchSetMatch-                     -> IO ()-getRecordedUpToMatch r = withRecordedMatch r . rollbackToPatchSetMatch+                     -> IO (Tree IO)+getPristineUpToMatch r psm = do+  ps <- readPatches r+  tree <- readPristine r+  snd <$> virtualTreeIO (rollbackToPatchSetMatch psm ps) tree -getOnePatchset :: (IsRepoType rt, RepoPatch p)-               => Repository rt p wR wU wR+-- | Return the patches up to the given 'PatchSetMatch'.+getOnePatchset :: RepoPatch p+               => Repository rt p wU wR                -> PatchSetMatch-               -> IO (SealedPatchSet rt p Origin)+               -> IO (SealedPatchSet p Origin) getOnePatchset repository pm =   case pm of-    IndexMatch n -> patchSetDrop (n-1) <$> readRepo repository-    PatchMatch m -> matchAPatchset m <$> readRepo repository-    TagMatch m -> getMatchingTag m <$> readRepo repository+    IndexMatch n -> patchSetDrop (n-1) <$> readPatches repository+    PatchMatch m -> matchAPatchset m <$> readPatches repository+    TagMatch m -> getMatchingTag m <$> readPatches repository     ContextMatch path -> do-      ref <- readRepo repository+      ref <- readPatches repository       readContextFile ref (toFilePath path)--withRecordedMatch :: (IsRepoType rt, RepoPatch p)-                  => Repository rt p wR wU wT-                  -> (PatchSet rt p Origin wR -> DefaultIO ())-                  -> IO ()-withRecordedMatch r job-    = do createPristineDirectoryTree r "." WithWorkingDir-         readRepo r >>= runDefault . job
src/Darcs/Repository/Merge.hs view
@@ -34,36 +34,31 @@     )  import Darcs.Util.Tree( Tree )-import Darcs.Util.External ( backupByCopying )+import Darcs.Util.File ( backupByCopying )  import Darcs.Patch-    ( RepoPatch, IsRepoType, PrimOf, merge+    ( RepoPatch, PrimOf, merge     , effect     , listConflictedFiles ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Ident ( merge2FL )+import Darcs.Patch.Depends ( slightlyOptimizePatchset )+import Darcs.Patch.Invertible ( mkInvertible ) import Darcs.Patch.Named ( patchcontents, anonymous ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )-import Darcs.Patch.Progress( progressFL )-import Darcs.Patch.Set ( PatchSet, Origin, patchSet2RL )+import Darcs.Patch.Progress( progressFL, progressRL )+import Darcs.Patch.Set ( PatchSet, Origin, appendPSFL, patchSet2RL ) import Darcs.Patch.Witnesses.Ordered     ( FL(..), RL(..), Fork(..), (:\/:)(..), (:/\:)(..), (+>+), (+<<+)-    , mapFL_FL, concatFL, reverseFL )+    , lengthFL, mapFL_FL, concatFL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )  import Darcs.Repository.Flags-    ( UseIndex-    , ScanKnown+    ( DiffOpts (..)     , AllowConflicts (..)+    , ResolveConflicts (..)     , Reorder (..)     , UpdatePending (..)-    , ExternalMerge (..)-    , Verbosity (..)-    , Compression (..)     , WantGuiPause (..)-    , DiffAlgorithm (..)-    , LookForMoves(..)-    , LookForReplaces(..)     ) import Darcs.Repository.Hashed     ( tentativelyAddPatches_@@ -72,15 +67,15 @@     ) import Darcs.Repository.Pristine     ( applyToTentativePristine-    , ApplyDir(..)     )-import Darcs.Repository.InternalTypes ( Repository, repoLocation )+import Darcs.Repository.InternalTypes ( AccessType(RW), Repository, repoLocation ) import Darcs.Repository.Pending ( setTentativePending ) import Darcs.Repository.Resolution-    ( externalResolution-    , standardResolution-    , StandardResolution(..)+    ( StandardResolution(..)     , announceConflicts+    , externalResolution+    , patchsetConflictResolutions+    , standardResolution     ) import Darcs.Repository.State ( unrecordedChanges, readUnrecorded ) @@ -179,7 +174,7 @@  Up to now we did not consider conflicts. Any new conflicts arising from the merges we made so far must be "resolved", that is, marked for manual-resolution, if possible, or at least reported o the user. We made two+resolution, if possible, or at least reported to the user. We made two merges, one with us and one with pw. It is important now to realize that our existing repo, and in particular the sequence us, could already be conflicted. Our job is to resolve only /new/ conflicts and not any@@ -199,7 +194,7 @@          |          U'         / \-    pw'  them''+      pw' them''       /     \      T       U     / \     /@@ -224,52 +219,58 @@ above, we set it to pw'+>+res, and again rely on sifting to commute out and drop anything we don't need. -TODO: We should return a properly coerced @Repository rt p wR wU wT@.+TODO: We should return a properly coerced @Repository 'RW p wU wR@. -} -tentativelyMergePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+tentativelyMergePatches_ :: (RepoPatch p, ApplyState p ~ Tree)                          => MakeChanges-                         -> Repository rt p wR wU wR -> String+                         -> Repository 'RW p wU wR -> String                          -> AllowConflicts-                         -> ExternalMerge -> WantGuiPause-                         -> Compression -> Verbosity -> Reorder-                         -> ( UseIndex, ScanKnown, DiffAlgorithm )-                         -> Fork (PatchSet rt p)-                                 (FL (PatchInfoAnd rt p))-                                 (FL (PatchInfoAnd rt p)) Origin wR wY+                         -> WantGuiPause+                         -> Reorder+                         -> DiffOpts+                         -> Fork (PatchSet p)+                                 (FL (PatchInfoAnd p))+                                 (FL (PatchInfoAnd p)) Origin wR wY                          -> IO (Sealed (FL (PrimOf p) wU))-tentativelyMergePatches_ mc _repo cmd allowConflicts externalMerge wantGuiPause-  compression verbosity reorder diffingOpts@(useidx, _, dflag) (Fork context us them) = do-    (them' :/\: us')-         <- return $ merge2FL (progressFL "Merging us" us)-                              (progressFL "Merging them" them)-    pw <- unrecordedChanges diffingOpts NoLookForMoves NoLookForReplaces _repo Nothing+tentativelyMergePatches_ mc _repo cmd allowConflicts wantGuiPause+  reorder diffingOpts@DiffOpts{..} (Fork context us them) = do+    (them' :/\: us') <-+      return $ merge (progressFL "Merging us" us :\/: progressFL "Merging them" them)+    pw <- unrecordedChanges diffingOpts _repo Nothing     -- Note: we use anonymous here to wrap the unrecorded changes.     -- This is benign because we only retain the effect of the results     -- of the merge (pw' and them'').     anonpw <- n2pia `fmap` anonymous pw     pw' :/\: them'' <- return $ merge (them' :\/: anonpw :>: NilFL)-    let them''content = concatFL $ progressFL "Examining patches for conflicts" $-                                mapFL_FL (patchcontents . hopefully) them''-    let conflicts =-          standardResolution-            (patchSet2RL context +<<+ us :<: anonpw)-            (reverseFL them'')-    let standard_resolution = mangled conflicts+    let them''content = concatFL $ mapFL_FL (patchcontents . hopefully) them''+        no_conflicts_in_them =+          null $ conflictedPaths $ patchsetConflictResolutions $+          slightlyOptimizePatchset (appendPSFL context them)+        conflicts =+          let us'' = us' +>+ pw' in+          -- This optimization is valid only if @them@ didn't have+          -- (unresolved) conflicts in the first place+          if lengthFL us'' < lengthFL them'' && no_conflicts_in_them then+            standardResolution+              (patchSet2RL context +<<+ them)+              (progressRL "Examining patches for conflicts" $ reverseFL us'')+          else+            standardResolution+              (patchSet2RL context +<<+ us :<: anonpw)+              (progressRL "Examining patches for conflicts" $ reverseFL them'')      debugMessage "Checking for conflicts..."-    when (allowConflicts == YesAllowConflictsAndMark) $+    when (allowConflicts == YesAllowConflicts MarkConflicts) $         mapM_ backupByCopying $         map (anchorPath (repoLocation _repo)) $         conflictedPaths conflicts      debugMessage "Announcing conflicts..."-    have_conflicts <--        announceConflicts cmd allowConflicts externalMerge conflicts+    have_conflicts <- announceConflicts cmd allowConflicts conflicts      debugMessage "Checking for unrecorded conflicts..."-    let pw'content = concatFL $ progressFL "Examining patches for conflicts" $-                                mapFL_FL (patchcontents . hopefully) pw'+    let pw'content = concatFL $ mapFL_FL (patchcontents . hopefully) pw'     case listConflictedFiles pw'content of         [] -> return ()         fs -> do@@ -286,62 +287,62 @@             exitSuccess      debugMessage "Reading working tree..."-    working <- readUnrecorded _repo useidx Nothing+    working <- readUnrecorded _repo withIndex Nothing      debugMessage "Working out conflict markup..."     Sealed resolution <--        case (externalMerge , have_conflicts) of-            (NoExternalMerge, _)       -> return $ if allowConflicts == YesAllowConflicts-                                                     then seal NilFL-                                                     else standard_resolution-            (_, False)                 -> return $ standard_resolution-            (YesExternalMerge c, True) -> externalResolution dflag working c wantGuiPause-                                             (effect us +>+ pw) (effect them) them''content+      if have_conflicts then+        case allowConflicts of+          YesAllowConflicts (ExternalMerge merge_cmd) ->+            externalResolution diffAlg working merge_cmd wantGuiPause+              (effect us +>+ pw) (effect them) them''content+          YesAllowConflicts NoResolveConflicts -> return $ seal NilFL+          YesAllowConflicts MarkConflicts -> return $ mangled conflicts+          NoAllowConflicts -> error "impossible" -- was handled in announceConflicts+      else return $ seal NilFL      debugMessage "Adding patches to the inventory and writing new pending..."     when (mc == MakeChanges) $ do-        applyToTentativePristine _repo ApplyNormal verbosity them'+        applyToTentativePristine _repo $ mkInvertible $+          progressFL "Applying patches to pristine" them'         -- these two cases result in the same trees (that's the idea of         -- merging), so we only operate on the set of patches and do the         -- adaption of pristine and pending in the common code below         _repo <- case reorder of             NoReorder -> do-                tentativelyAddPatches_ DontUpdatePristine _repo-                    compression verbosity NoUpdatePending them'+                tentativelyAddPatches_ DontUpdatePristine _repo NoUpdatePending them'             Reorder -> do                 -- we do not actually remove any effect in the end, so                 -- it would be wrong to update the unrevert bundle or                 -- the working tree or pending-                r1 <- tentativelyRemovePatches_ DontUpdatePristineNorRevert _repo-                          compression NoUpdatePending us-                r2 <- tentativelyAddPatches_ DontUpdatePristine r1-                          compression verbosity NoUpdatePending them-                tentativelyAddPatches_ DontUpdatePristine r2-                    compression verbosity NoUpdatePending us'+                _repo <- tentativelyRemovePatches_ DontUpdatePristineNorRevert _repo+                          NoUpdatePending us+                _repo <- tentativelyAddPatches_ DontUpdatePristine _repo+                          NoUpdatePending them+                tentativelyAddPatches_ DontUpdatePristine _repo NoUpdatePending us'         setTentativePending _repo (effect pw' +>+ resolution)     return $ seal (effect them''content +>+ resolution) -tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                        => Repository rt p wR wU wR -> String+tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree)+                        => Repository 'RW p wU wR -> String                         -> AllowConflicts-                        -> ExternalMerge -> WantGuiPause-                        -> Compression -> Verbosity -> Reorder-                        -> ( UseIndex, ScanKnown, DiffAlgorithm )-                        -> Fork (PatchSet rt p)-                                (FL (PatchInfoAnd rt p))-                                (FL (PatchInfoAnd rt p)) Origin wR wY+                        -> WantGuiPause+                        -> Reorder+                        -> DiffOpts+                        -> Fork (PatchSet p)+                                (FL (PatchInfoAnd p))+                                (FL (PatchInfoAnd p)) Origin wR wY                         -> IO (Sealed (FL (PrimOf p) wU)) tentativelyMergePatches = tentativelyMergePatches_ MakeChanges --considerMergeToWorking :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                       => Repository rt p wR wU wR -> String+considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree)+                       => Repository 'RW p wU wR -> String                        -> AllowConflicts-                       -> ExternalMerge -> WantGuiPause-                       -> Compression -> Verbosity -> Reorder-                       -> ( UseIndex, ScanKnown, DiffAlgorithm )-                       -> Fork (PatchSet rt p)-                               (FL (PatchInfoAnd rt p))-                               (FL (PatchInfoAnd rt p)) Origin wR wY+                       -> WantGuiPause+                       -> Reorder+                       -> DiffOpts+                       -> Fork (PatchSet p)+                               (FL (PatchInfoAnd p))+                               (FL (PatchInfoAnd p)) Origin wR wY                        -> IO (Sealed (FL (PrimOf p) wU)) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges
src/Darcs/Repository/Old.hs view
@@ -39,7 +39,7 @@ import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal ) import Darcs.Patch.Info ( PatchInfo(..), makePatchname, readPatchInfo, displayPatchInfo ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin )-import Darcs.Util.External+import Darcs.Util.File     ( gzFetchFilePS     , Cachable(..)     )@@ -50,7 +50,7 @@  import Control.Exception ( catch, IOException ) -readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet rt p Origin)+readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p Origin) readOldRepo repo_dir = do   realdir <- toPath `fmap` ioAbsoluteOrRemote repo_dir   let task = "Reading inventory of repository "++repo_dir@@ -60,7 +60,7 @@                                   ioError e)  readRepoPrivate :: RepoPatch p-                => String -> FilePath -> FilePath -> IO (SealedPatchSet rt p Origin)+                => String -> FilePath -> FilePath -> IO (SealedPatchSet p Origin) readRepoPrivate task repo_dir inventory_name = do     inventory <- gzFetchFilePS (repo_dir </> darcsdir </> inventory_name) Uncachable     finishedOneIO task inventory_name@@ -70,8 +70,8 @@     Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is)     return $ seal (PatchSet ts ps)     where read_ts :: RepoPatch p =>-                     (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd rt p wB)))-                  -> Maybe PatchInfo -> IO (Sealed (RL (Tagged rt p) Origin))+                     (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB)))+                  -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) Origin))           read_ts _ Nothing = do endTedious task                                  return $ seal NilRL           read_ts parse (Just tag0) =@@ -87,10 +87,10 @@                                   \(e :: IOException) ->                                         return $ seal $                                         patchInfoAndPatch tag0 $ unavailable $ show e-                 return $ seal $ ts :<: Tagged tag00 Nothing ps+                 return $ seal $ ts :<: Tagged ps tag00 Nothing           parse2 :: RepoPatch p                  => PatchInfo -> FilePath-                 -> IO (Sealed (PatchInfoAnd rt p wX))+                 -> IO (Sealed (PatchInfoAnd p wX))           parse2 i fn = do ps <- unsafeInterleaveIO $ gzFetchFilePS fn Cachable                            return $ patchInfoAndPatch i                              `mapSeal` hopefullyNoParseError (toPath fn) (readPatch ps)@@ -100,8 +100,8 @@           hopefullyNoParseError s (Left e) =               seal $ unavailable $ unlines ["Couldn't parse file " ++ s, e]           read_patches :: RepoPatch p =>-                          (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd rt p wB)))-                       -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd rt p) wX))+                          (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB)))+                       -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) wX))           read_patches _ [] = return $ seal NilRL           read_patches parse (i:is) =               lift2Sealed (flip (:<:))
src/Darcs/Repository/Packs.hs view
@@ -7,7 +7,7 @@  Two packs are created at the same time by 'createPacks': -  1. The basic pack, contains the latest recorded version of the working tree.+  1. The basic pack, contains the pristine tree.   2. The patches pack, contains the set of patches of the repository.  The paths of these files are @_darcs\/packs\/basic.tar.gz@ and@@ -29,7 +29,7 @@ import Codec.Compression.GZip as GZ ( compress, decompress ) import Control.Concurrent.Async ( withAsync ) import Control.Exception ( Exception, IOException, throwIO, catch, finally )-import Control.Monad ( void, when, unless )+import Control.Monad ( forM_, when ) import System.IO.Error ( isAlreadyExistsError ) import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -55,31 +55,32 @@ import Darcs.Prelude  import Darcs.Util.ByteString ( gzReadFilePS )-import Darcs.Util.Lock ( withTemp )-import Darcs.Util.External ( Cachable(..), fetchFileLazyPS )+import Darcs.Util.Cache+    ( Cache+    , bucketFolder+    , closestWritableDirectory+    , fetchFileUsingCache+    )+import Darcs.Util.File ( Cachable(..), fetchFileLazyPS, withTemp ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Progress ( debugMessage, progressList )+import Darcs.Util.ValidHash ( InventoryHash, PatchHash, encodeValidHash ) -import Darcs.Patch ( IsRepoType, RepoPatch )+import Darcs.Patch ( RepoPatch ) import Darcs.Patch.PatchInfoAnd ( extractHash ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Patch.Witnesses.Ordered ( mapFL ) import Darcs.Patch.Set ( patchSet2FL )  import Darcs.Repository.Traverse ( listInventories )-import Darcs.Repository.InternalTypes ( Repository )-import Darcs.Repository.Hashed ( readRepo )-import Darcs.Repository.Inventory ( getValidHash )-import Darcs.Repository.Format-    ( identifyRepoFormat, formatHas, RepoProperty ( HashedInventory ) )-import Darcs.Repository.Cache ( fetchFileUsingCache-                              , HashedDir(..)-                              , Cache-                              , closestWritableDirectory-                              , hashedDir-                              , bucketFolder-                              )-import Darcs.Repository.Old ( oldRepoFailMsg )+import Darcs.Repository.InternalTypes ( Repository, AccessType(RW), withRepoDir )+import Darcs.Repository.Hashed ( readPatches )+import Darcs.Repository.Paths+    ( hashedInventoryPath+    , inventoriesDirPath+    , patchesDirPath+    , pristineDirPath+    ) import Darcs.Repository.Pristine ( readHashedPristineRoot )  packsDir, basicPack, patchesPack :: String@@ -88,43 +89,43 @@ patchesPack  = "patches.tar.gz"  fetchAndUnpack :: FilePath-               -> HashedDir                -> Cache                -> FilePath                -> IO ()-fetchAndUnpack filename dir cache remote = do-  unpackTar cache dir . Tar.read . GZ.decompress =<<+fetchAndUnpack filename cache remote = do+  unpackTar cache . Tar.read . GZ.decompress =<<     fetchFileLazyPS (remote </> darcsdir </> packsDir </> filename) Uncachable -fetchAndUnpackPatches :: [String] -> Cache -> FilePath -> IO ()-fetchAndUnpackPatches paths cache remote =+fetchAndUnpackPatches :: [InventoryHash] -> [PatchHash] -> Cache -> FilePath -> IO ()+fetchAndUnpackPatches ihs phs cache remote =   -- Patches pack can miss some new patches of the repository.-  -- So we download pack asynchonously and alway do a complete pass-  -- of individual patch files.-  withAsync (fetchAndUnpack patchesPack HashedInventoriesDir cache remote) $ \_ -> do-  fetchFilesUsingCache cache HashedPatchesDir paths+  -- So we download pack asynchonously and always do a complete pass+  -- of individual patch and inventory files.+  withAsync (fetchAndUnpack patchesPack cache remote) $ \_ -> do+    forM_ ihs (fetchFileUsingCache cache)+    forM_ phs (fetchFileUsingCache cache)  fetchAndUnpackBasic :: Cache -> FilePath -> IO ()-fetchAndUnpackBasic = fetchAndUnpack basicPack HashedPristineDir+fetchAndUnpackBasic = fetchAndUnpack basicPack -unpackTar :: Exception e => Cache -> HashedDir -> Tar.Entries e -> IO ()-unpackTar _ _   Tar.Done = return ()-unpackTar _ _   (Tar.Fail e) = throwIO e-unpackTar c dir (Tar.Next e es) = case Tar.entryContent e of+unpackTar :: Exception e => Cache -> Tar.Entries e -> IO ()+unpackTar _ Tar.Done = return ()+unpackTar _ (Tar.Fail e) = throwIO e+unpackTar c (Tar.Next e es) = case Tar.entryContent e of   Tar.NormalFile bs _ -> do     let p = Tar.entryPath e     if "meta-" `isPrefixOf` takeFileName p-      then unpackTar c dir es -- just ignore them+      then unpackTar c es -- just ignore them       else do         ex <- doesFileExist p         if ex           then debugMessage $ "TAR thread: exists " ++ p ++ "\nStopping TAR thread."           else do-            if p == darcsdir </> "hashed_inventory"+            if p == hashedInventoryPath               then writeFile' Nothing p bs               else writeFile' (closestWritableDirectory c) p $ GZ.compress bs             debugMessage $ "TAR thread: GET " ++ p-            unpackTar c dir es+            unpackTar c es   _ -> fail "Unexpected non-file tar entry"  where   writeFile' Nothing path content = withTemp $ \tmp -> do@@ -142,35 +143,24 @@         -- ignore cache if we cannot link         writeFile' Nothing path content) --- | Similar to @'mapM_' ('void' 'fetchFileUsingCache')@, exepts--- it stops execution if file it's going to fetch already exists.-fetchFilesUsingCache :: Cache -> HashedDir -> [FilePath] -> IO ()-fetchFilesUsingCache cache dir = mapM_ go where-  go path = do-    ex <- doesFileExist $ darcsdir </> hashedDir dir </> path-    if ex-     then debugMessage $ "FILE thread: exists " ++ path-     else void $ fetchFileUsingCache cache dir path- -- | Create packs from the current recorded version of the repository.-createPacks :: (IsRepoType rt, RepoPatch p)-            => Repository rt p wR wU wT -> IO ()-createPacks repo = flip finally (mapM_ removeFileIfExists+createPacks :: RepoPatch p => Repository 'RW p wU wR -> IO ()+createPacks repo =+ withRepoDir repo $+  flip finally (mapM_ removeFileIfExists   [ darcsdir </> "meta-filelist-inventories"   , darcsdir </> "meta-filelist-pristine"   , basicTar <.> "part"   , patchesTar <.> "part"   ]) $ do-  rf <- identifyRepoFormat "."-  -- function is exposed in API so could be called on non-hashed repo-  unless (formatHas HashedInventory rf) $ fail oldRepoFailMsg-  createDirectoryIfMissing False (darcsdir </> packsDir)   -- pristine hash-  Just hash <- readHashedPristineRoot repo-  writeFile ( darcsdir </> packsDir </> "pristine" ) $ getValidHash hash+  hash <- readHashedPristineRoot repo+  createDirectoryIfMissing False (darcsdir </> packsDir)+  writeFile ( darcsdir </> packsDir </> "pristine" ) $ encodeValidHash hash   -- pack patchesTar-  ps <- mapFL hashedPatchFileName . progressFL "Packing patches" . patchSet2FL <$> readRepo repo-  is <- map ((darcsdir </> "inventories") </>) <$> listInventories+  ps <- mapFL hashedPatchFileName . progressFL "Packing patches" . patchSet2FL <$>+    readPatches repo+  is <- map (inventoriesDirPath </>) <$> listInventories   writeFile (darcsdir </> "meta-filelist-inventories") . unlines $     map takeFileName is   -- Note: tinkering with zlib's compression parameters does not make@@ -180,12 +170,14 @@     mapM fileEntry' ((darcsdir </> "meta-filelist-inventories") : ps ++ reverse is)   renameFile (patchesTar <.> "part") patchesTar   -- pack basicTar-  pr <- sortByMTime =<< dirContents (darcsdir </> "pristine.hashed")+  pr <- sortByMTime =<< dirContents pristineDirPath   writeFile (darcsdir </> "meta-filelist-pristine") . unlines $     map takeFileName pr   BLC.writeFile (basicTar <.> "part") . GZ.compress . Tar.write =<< mapM fileEntry' (     [ darcsdir </> "meta-filelist-pristine"-    , darcsdir </> "hashed_inventory"+    -- unclean: we should not access the non-tentative version here;+    -- will work because we do not modify the tentative state+    , hashedInventoryPath     ] ++ progressList "Packing pristine" (reverse pr))   renameFile (basicTar <.> "part") basicTar  where@@ -198,7 +190,7 @@   dirContents dir = map (dir </>) <$> listDirectory dir   hashedPatchFileName x = case extractHash x of     Left _ -> fail "unexpected unhashed patch"-    Right h -> darcsdir </> "patches" </> h+    Right h -> patchesDirPath </> encodeValidHash h   sortByMTime xs = map snd . sort <$> mapM (\x -> (\t -> (t, x)) <$>     getModificationTime x) xs   removeFileIfExists x = do
src/Darcs/Repository/PatchIndex.hs view
@@ -18,6 +18,7 @@  See <http://darcs.net/Internals/PatchIndex> for more information. -}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Darcs.Repository.PatchIndex     ( doesPatchIndexExist     , isPatchIndexDisabled@@ -37,17 +38,17 @@ import Darcs.Prelude  import Control.Exception ( catch )-import Control.Monad ( forM_, unless, when )+import Control.Monad ( forM_, unless, when, (>=>) ) import Control.Monad.State.Strict ( evalState, execState, State, gets, modify )  import Data.Binary ( Binary, encodeFile, decodeFileOrFail ) import qualified Data.ByteString as B import Data.Int ( Int8 )-import Data.List ( group, mapAccumL, sort, nub, (\\) )-import Data.Maybe ( fromJust, fromMaybe, isJust )+import Data.List ( mapAccumL, sort, nub, (\\) )+import Data.Maybe ( catMaybes, fromJust, fromMaybe )+import qualified Data.IntSet as I import qualified Data.Map as M import qualified Data.Set as S-import Data.Word ( Word32 )  import System.Directory     ( createDirectory@@ -63,7 +64,15 @@ import Darcs.Patch ( RepoPatch, listTouchedFiles ) import Darcs.Patch.Apply ( ApplyState(..) ) import Darcs.Patch.Index.Types-import Darcs.Patch.Index.Monad ( applyToFileMods, makePatchID )+    ( FileId(..)+    , PatchId+    , makePatchID+    , pid2string+    , short+    , showFileId+    , zero+    )+import Darcs.Patch.Index.Monad ( FileMod(..), applyToFileMods ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) import Darcs.Patch.Progress (progressFL )@@ -81,17 +90,19 @@  import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) ) import Darcs.Repository.InternalTypes ( Repository, repoLocation, repoFormat )+import Darcs.Repository.Paths ( hashedInventoryPath )  import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Hash ( sha256sum, showAsHex ) import Darcs.Util.Lock ( withPermDir )-import Darcs.Util.Path ( AnchoredPath, displayPath, toFilePath, isPrefix )+import Darcs.Util.Path ( AnchoredPath, displayPath, isRoot, parents, toFilePath ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.SignalHandler ( catchInterrupt ) import Darcs.Util.Tree ( Tree(..) )  type Map = M.Map type Set = S.Set+type IntSet = I.IntSet  data FileIdSpan = FidSpan   !FileId                   -- ^ the fileid has some fixed name in the@@ -105,10 +116,10 @@   !(Maybe PatchId)          -- ^ and (maybe) ending here   deriving (Show, Eq, Ord) --- | info about a given fileid, e.g.. is a file or a directory+-- | info about a given fileid data FileInfo = FileInfo-  { isFile :: Bool-  , touching :: Set Word32  -- ^ first word of patch hash+  { isFile :: Bool          -- ^ whether file or dir+  , touching :: IntSet      -- ^ first words of patch hashes   } deriving (Show, Eq, Ord)  -- | timespans where a certain filename corresponds to a file with a given id@@ -125,7 +136,7 @@   { pids :: [PatchId]     -- ^ all the 'PatchId's tracked by this patch index, with the most     -- recent patch at the head of the list (note, stored in the-    -- reverse order to this on disk for backwards compatibility+    -- reverse order on disk for backwards compatibility     -- with an older format).   , fidspans :: FileIdSpans   , fpspans :: FilePathSpans@@ -137,53 +148,62 @@ --           2 changes the pids order to newer-to-older --           3 changes FileName to AnchoredPath everywhere, which has --             different Binary (and Ord) instances+--           4 adds all parent dirs of each file or dir as+--             being touched by a patch+--           5 replaces Set Word32 with IntSet+ version :: Int8-version = 3+version = 5  type PIM a = State PatchIndex a  -- | 'applyPatchMods pmods pindex' applies a list of PatchMods to the given --   patch index pindex-applyPatchMods :: [(PatchId, [PatchMod AnchoredPath])] -> PatchIndex -> PatchIndex+applyPatchMods :: [(PatchId, [FileMod AnchoredPath])] -> PatchIndex -> PatchIndex applyPatchMods pmods pindex =   flip execState pindex $ mapM_ goList pmods- where goList :: (PatchId, [PatchMod AnchoredPath]) -> PIM ()+ where goList :: (PatchId, [FileMod AnchoredPath]) -> PIM ()        goList (pid, mods) = do            modify (\pind -> pind{pids = pid:pids pind})-           mapM_ (curry go pid) (nubSeq mods)-       -- nubSeq handles invalid patch in darcs repo:-       --   move with identical target name "rename darcs_patcher to darcs-patcher."-       nubSeq = map head . group-       go :: (PatchId, PatchMod AnchoredPath) -> PIM ()+           mapM_ (curry go pid) mods+       go :: (PatchId, FileMod AnchoredPath) -> PIM ()        go (pid, PCreateFile fn) = do          fid <- createFidStartSpan fn pid          startFpSpan fid fn pid          createInfo fid True-         insertTouch fid pid+         insertTouch pid fid+         insertParentsTouch pid fn        go (pid, PCreateDir fn) = do          fid <- createFidStartSpan fn pid          startFpSpan fid fn pid          createInfo fid False-         insertTouch fid pid+         insertTouch pid fid+         insertParentsTouch pid fn        go (pid, PTouch fn) = do          fid <- lookupFid fn-         insertTouch fid pid+         insertTouch pid fid+         insertParentsTouch pid fn        go (pid, PRename oldfn newfn) = do          fid <- lookupFid oldfn          stopFpSpan fid pid          startFpSpan fid newfn pid-         insertTouch fid pid+         insertTouch pid fid+         insertParentsTouch pid oldfn+         insertParentsTouch pid newfn          stopFidSpan oldfn pid          startFidSpan newfn pid fid        go (pid, PRemove fn) = do          fid <- lookupFid fn-         insertTouch fid pid+         insertTouch pid fid+         insertParentsTouch pid fn          stopFidSpan fn pid          stopFpSpan fid pid        go (pid, PDuplicateTouch fn) = do          fidm <- gets fidspans          case M.lookup fn fidm of-           Just (FidSpan fid _ _:_) -> insertTouch fid pid+           Just (FidSpan fid _ _:_) -> do+             insertTouch pid fid+             insertParentsTouch pid fn            Nothing -> return ()            Just [] -> error $ "applyPatchMods: impossible, no entry for "++show fn                               ++" in FileIdSpans in duplicate, empty list"@@ -235,15 +255,21 @@ -- | insert touching patchid for given file id createInfo :: FileId -> Bool -> PIM () createInfo fid isF = modify (\pind -> pind {infom=M.alter alt fid (infom pind)})-  where alt Nothing = Just (FileInfo isF S.empty)-        alt (Just _) = Just (FileInfo isF S.empty) -- forget old false positives+  where alt Nothing = Just (FileInfo isF I.empty)+        alt (Just _) = Just (FileInfo isF I.empty) -- forget old false positives  -- | insert touching patchid for given file id-insertTouch :: FileId -> PatchId -> PIM ()-insertTouch fid pid = modify (\pind -> pind {infom=M.alter alt fid (infom pind)})+insertTouch :: PatchId -> FileId -> PIM ()+insertTouch pid fid = modify (\pind -> pind {infom=M.alter alt fid (infom pind)})   where alt Nothing =  error "impossible: Fileid does not exist"-        alt (Just (FileInfo isF pids)) = Just (FileInfo isF (S.insert (short pid) pids))+        alt (Just (FileInfo isF pids)) = Just (FileInfo isF (I.insert (short pid) pids)) +-- | insert touching patchid for the parents of a given path+insertParentsTouch :: PatchId -> AnchoredPath -> PIM ()+insertParentsTouch pid path =+  forM_ (filter (not . isRoot) (parents path)) $+    lookupFid >=> insertTouch pid+ -- | lookup current fid of filepath lookupFid :: AnchoredPath -> PIM FileId lookupFid fn = do@@ -261,56 +287,20 @@     _ -> return Nothing  --- | lookup all the file ids of a given path-lookupFidf' :: AnchoredPath -> PIM [FileId]-lookupFidf' fn = do-   fidm <- gets fidspans-   case M.lookup fn fidm of-      Just spans -> return $ map (\(FidSpan fid _ _) -> fid) spans-      Nothing ->-         error $ "lookupFidf': no entry for " ++ show fn ++ " in FileIdSpans"---- |  return all fids of matching subpaths---    of the given filepath-lookupFids :: AnchoredPath -> PIM [FileId]-lookupFids fn = do-   fid_spans <- gets fidspans-   file_idss <- mapM lookupFidf' $-      filter (isPrefix fn) (fpSpans2filePaths' fid_spans)-   return $ nub $ concat file_idss---- | returns a single file id if the given path is a file---   if it is a directory, if returns all the file ids of all paths inside it,---   at any point in repository history-lookupFids' :: AnchoredPath -> PIM [FileId]-lookupFids' fn = do-  info_map <- gets infom-  fps_spans <- gets fpspans-  a <- lookupFid' fn-  if isJust a then do-                let fid = fromJust a-                case M.lookup fid info_map of-                  Just (FileInfo True _) -> return [fid]-                  Just (FileInfo False _) ->-                    let file_names = map (\(FpSpan x _ _) -> x) (fps_spans M.! fid)-                    in nub . concat <$> mapM lookupFids file_names-                  Nothing -> error "lookupFids' : could not find file"-              else return []- -- | Creates patch index that corresponds to all patches in repo. createPatchIndexDisk   :: (RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wT-  -> PatchSet rt p Origin wR+  => Repository rt p wU wR+  -> PatchSet p Origin wR   -> IO () createPatchIndexDisk repository ps = do   let patches = mapFL Sealed2 $ progressFL "Create patch index" $ patchSet2FL ps-  createPatchIndexFrom repository $ patches2patchMods patches S.empty+  createPatchIndexFrom repository $ patches2fileMods patches S.empty  -- | convert patches to patchmods-patches2patchMods :: (Apply p, PatchInspect p, ApplyState p ~ Tree)-                  => [Sealed2 (PatchInfoAnd rt p)] -> Set AnchoredPath -> [(PatchId, [PatchMod AnchoredPath])]-patches2patchMods patches fns = snd $ mapAccumL go fns patches+patches2fileMods :: (Apply p, PatchInspect p, ApplyState p ~ Tree)+                  => [Sealed2 (PatchInfoAnd p)] -> Set AnchoredPath -> [(PatchId, [FileMod AnchoredPath])]+patches2fileMods patches fns = snd $ mapAccumL go fns patches   where     go filenames (Sealed2 p) = (filenames', (pid, pmods_effect ++ pmods_dup))       where pid = makePatchID . info $ p@@ -367,8 +357,8 @@ -- | update the patch index to the current state of the repository updatePatchIndexDisk     :: (RepoPatch p, ApplyState p ~ Tree)-    => Repository rt p wR wU wT-    -> PatchSet rt p Origin wR+    => Repository rt p wU wR+    -> PatchSet p Origin wR     -> IO () updatePatchIndexDisk repo patches = do     let repodir = repoLocation repo@@ -382,7 +372,7 @@         cdir = repodir </> indexDir     -- reread to prevent holding onto patches for too long     let newpatches = drop len_common $ mapFL seal2 flpatches-        newpmods = patches2patchMods newpatches filenames+        newpmods = patches2fileMods newpatches filenames     inv_hash <- getInventoryHash repodir     storePatchIndex cdir inv_hash (applyPatchMods newpmods pindex')   where@@ -395,8 +385,8 @@  -- | 'createPatchIndexFrom repo pmods' creates a patch index from the given --   patchmods.-createPatchIndexFrom :: Repository rt p wR wU wT-                     -> [(PatchId, [PatchMod AnchoredPath])] -> IO ()+createPatchIndexFrom :: Repository rt p wU wR+                     -> [(PatchId, [FileMod AnchoredPath])] -> IO () createPatchIndexFrom repo pmods = do     inv_hash <- getInventoryHash repodir     storePatchIndex cdir inv_hash (applyPatchMods pmods emptyPatchIndex)@@ -406,7 +396,7 @@  getInventoryHash :: FilePath -> IO String getInventoryHash repodir = do-  inv <- B.readFile (repodir </> darcsdir </> "hashed_inventory")+  inv <- B.readFile (repodir </> hashedInventoryPath)   return $ sha256sum inv  -- | Load patch-index from disk along with some meta data.@@ -423,15 +413,19 @@  -- | If patch-index is useful as it is now, read it. If not, create or update it, then read it. loadSafePatchIndex :: (RepoPatch p, ApplyState p ~ Tree)-                   => Repository rt p wR wU wT-                   -> PatchSet rt p Origin wR     -- ^ PatchSet of the repository, used if we need to create the patch-index.+                   => Repository rt p wU wR+                   -> PatchSet p Origin wR     -- ^ PatchSet of the repository, used if we need to create the patch-index.                    -> IO PatchIndex loadSafePatchIndex repo ps = do    let repodir = repoLocation repo    can_use <- isPatchIndexInSync repo    (_,_,_,pi) <-      if can_use-       then loadPatchIndex repodir+       then do+          debugMessage "Loading patch index..."+          r <- loadPatchIndex repodir+          debugMessage "Done."+          return r        else do createOrUpdatePatchIndexDisk repo ps                loadPatchIndex repodir    return pi@@ -462,14 +456,16 @@ --   2. if patch index exists, update it --   3. if not, create it from scratch createOrUpdatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree)-                             => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()+                             => Repository rt p wU wR -> PatchSet p Origin wR -> IO () createOrUpdatePatchIndexDisk repo ps = do+   debugMessage "createOrUpdatePatchIndexDisk: start"    let repodir = repoLocation repo    removeFile (repodir </> darcsdir </> noPatchIndex) `catch` \(_ :: IOError) -> return ()    dpie <- doesPatchIndexExist repodir    if dpie       then updatePatchIndexDisk repo ps       else createPatchIndexDisk repo ps+   debugMessage "createOrUpdatePatchIndexDisk: done"  -- | Read-only. Checks the two following things: --@@ -478,7 +474,7 @@ -- -- Then only if it exists and it is not explicitely disabled, returns @True@, else returns @False@ -- (or an error if it exists and is explicitely disabled at the same time).-canUsePatchIndex :: Repository rt p wR wU wT -> IO Bool+canUsePatchIndex :: Repository rt p wU wR -> IO Bool canUsePatchIndex repo = do      let repodir = repoLocation repo      piExists <- doesPatchIndexExist repodir@@ -492,7 +488,7 @@ -- | Creates patch-index (ignoring whether it is explicitely disabled). --   If it is ctrl-c'ed, then aborts, delete patch-index and mark it as disabled. createPIWithInterrupt :: (RepoPatch p, ApplyState p ~ Tree)-                      => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()+                      => Repository rt p wU wR -> PatchSet p Origin wR -> IO () createPIWithInterrupt repo ps = do     let repodir = repoLocation repo     putStrLn "Creating a patch index, please wait. To stop press Ctrl-C"@@ -500,9 +496,9 @@       createPatchIndexDisk repo ps       putStrLn "Created patch index.") `catchInterrupt` (putStrLn "Patch Index Disabled" >> deletePatchIndex repodir) --- | Checks if patch-index exists and is in sync with repository (more precisely with @_darcs\/hashed_inventory@).+-- | Checks if patch-index exists and is in sync with repository. --   That is, checks if patch-index can be used as it is now.-isPatchIndexInSync :: Repository rt p wR wU wT -> IO Bool+isPatchIndexInSync :: Repository rt p wU wR -> IO Bool isPatchIndexInSync repo = do    let repodir = repoLocation repo    dpie <- doesPatchIndexExist repodir@@ -615,8 +611,8 @@            | (fid, fns) <- M.toList fpspans, FpSpan fn from mto <- fns]  dumpTouchingMap :: InfoMap -> String-dumpTouchingMap infom = unlines [showFileId fid++(if isF then "" else "/")++" -> "++ showAsHex w32-                                | (fid,FileInfo isF w32s) <- M.toList infom, w32 <- S.elems w32s]+dumpTouchingMap infom = unlines [showFileId fid++(if isF then "" else "/")++" -> "++ showAsHex (fromIntegral i)+                                | (fid,FileInfo isF w32s) <- M.toList infom, i <- I.elems w32s]  -- | return set of current filepaths in patch index fpSpans2filePaths :: FilePathSpans -> InfoMap -> [FilePath]@@ -624,14 +620,10 @@   sort [displayPath fn ++ (if isF then "" else "/") | (fid,FpSpan fn _ Nothing:_) <- M.toList fpSpans,                                                 let Just (FileInfo isF _) = M.lookup fid infom] --- | return set of current filepaths in patch index, for internal use-fpSpans2filePaths' :: FileIdSpans -> [AnchoredPath]-fpSpans2filePaths' fidSpans = [fp | (fp, _)  <- M.toList fidSpans]- -- | Checks if patch index can be created and build it with interrupt. attemptCreatePatchIndex   :: (RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()+  => Repository rt p wU wR -> PatchSet p Origin wR -> IO () attemptCreatePatchIndex repo ps = do   canCreate <- canCreatePI repo   when canCreate $ createPIWithInterrupt repo ps@@ -639,7 +631,7 @@ -- | Checks whether a patch index can (and should) be created. If we are not in -- an old-fashioned repo, and if we haven't been told not to, then we should -- create a patch index if it doesn't already exist.-canCreatePI :: Repository rt p wR wU wT -> IO Bool+canCreatePI :: Repository rt p wU wR -> IO Bool canCreatePI repo =     (not . or) <$> sequence [ doesntHaveHashedInventory (repoFormat repo)                             , isPatchIndexDisabled repodir@@ -654,12 +646,12 @@ -- disabled, silently create it. (Also, if it is out-of-sync, which should not -- happen, silently update it). getRelevantSubsequence-    :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p)+    :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p)     => Sealed ((RL a) wK)     -- ^ Sequence of patches you want to filter-    -> Repository rt p wR wU wR+    -> Repository rt p wU wR     -- ^ The repository (to attempt loading patch-index from its path)-    -> PatchSet rt p Origin wR+    -> PatchSet p Origin wR     -- ^ PatchSet of repository (in case we need to create patch-index)     -> [AnchoredPath]     -- ^ File(s) about which you want patches from given sequence@@ -669,38 +661,39 @@     pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repository ps     let fids = map (\fn -> evalState (lookupFid fn) pi) fns         pidss = map ((\(FileInfo _ a) -> a) . fromJust . (`M.lookup` infom)) fids-        pids = S.unions pidss+        pids = I.unions pidss     let flpxes = reverseRL $ unseal unsafeCoercePEnd pxes     return . seal $ keepElems flpxes NilRL pids   where-    keepElems :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p)-              => FL a wX wY -> RL a wB wX -> S.Set Word32 -> RL a wP wQ+    keepElems :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p)+              => FL a wX wY -> RL a wB wX -> IntSet -> RL a wP wQ     keepElems NilFL acc _ = unsafeCoerceP acc     keepElems (x :>: xs) acc pids-      | short (makePatchID $ info x) `S.member` pids = keepElems xs (acc :<: x) pids+      | short (makePatchID $ info x) `I.member` pids = keepElems xs (acc :<: x) pids       | otherwise = keepElems (unsafeCoerceP xs) acc pids -type PatchFilter rt p = [AnchoredPath] -> [Sealed2 (PatchInfoAnd rt p)] -> IO [Sealed2 (PatchInfoAnd rt p)]+type PatchFilter p = [AnchoredPath] -> [Sealed2 (PatchInfoAnd p)] -> IO [Sealed2 (PatchInfoAnd p)] --- | If a patch index is available, returns a filter that takes a list of files and returns---   a @PatchFilter@ that only keeps patches that modify the given list of files.---   If patch-index cannot be used, return the original input.---   If patch-index does not exist and is not explicitely disabled, silently create it.---   (Also, if it is out-of-sync, which should not happen, silently update it).+-- | If a patch index is available, returns a filter that takes a list of files+--   and returns a @PatchFilter@ that only keeps patches that modify the given+--   list of files. If patch-index cannot be used, return the original input.+--   If patch-index does not exist and is not explicitely disabled, silently+--   create it. (Also, if it is out-of-sync, which should not happen, silently+--   update it). maybeFilterPatches     :: (RepoPatch p, ApplyState p ~ Tree)-    => Repository rt p wR wU wT  -- ^ The repository-    -> PatchSet rt p Origin wR   -- ^ PatchSet of patches of repository (in case patch-index needs to be created)-    -> PatchFilter rt p          -- ^ PatchFilter ready to be used by SelectChanges.+    => Repository rt p wU wR  -- ^ The repository+    -> PatchSet p Origin wR   -- ^ PatchSet of patches of repository (in case patch-index needs to be created)+    -> PatchFilter p          -- ^ PatchFilter ready to be used by SelectChanges. maybeFilterPatches repo ps fps ops = do     usePI <- canUsePatchIndex repo     if usePI       then do         pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repo ps-        let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi)) fps-            npids = S.unions $ map (touching.fromJust.(`M.lookup` infom)) fids+        let fids = catMaybes $ map ((\fn -> evalState (lookupFid' fn) pi)) fps+            npids = I.unions $ map (touching.fromJust.(`M.lookup` infom)) fids         return $ filter-          (flip S.member npids . (unseal2 (short . makePatchID . info))) ops+          (flip I.member npids . (unseal2 (short . makePatchID . info))) ops       else return ops  -- | Dump information in patch index. Patch-index should be checked to exist beforehand. Read-only.@@ -764,7 +757,7 @@    putStrLn "infom"    putStrLn "==========="    putStrLn $ "Valid fid test: " ++ (show.and $ map (`M.member` fpspans) (M.keys infom))-   putStrLn $ "Valid pid test: " ++ (show.flip S.isSubsetOf (S.fromList $ map short pids)  . S.unions . map touching . M.elems $ infom)+   putStrLn $ "Valid pid test: " ++ (show.flip I.isSubsetOf (I.fromList $ map short pids)  . I.unions . map touching . M.elems $ infom)    where           isInOrder :: Eq a => [a] -> [a] -> Bool           isInOrder (x:xs) (y:ys) | x == y = isInOrder xs ys
src/Darcs/Repository/Paths.hs view
@@ -3,6 +3,7 @@ module Darcs.Repository.Paths where  import Darcs.Prelude+import Darcs.Util.Cache ( HashedDir(..), hashedDir ) import Darcs.Util.Global ( darcsdir ) import System.FilePath.Posix( (</>) ) @@ -12,6 +13,10 @@ -- | Location of the lock file. lockPath = makeDarcsdirPath "lock" +-- | Location of the prefs directory.+prefsDir = "prefs"+prefsDirPath = makeDarcsdirPath prefsDir+ -- | Location of the (one and only) head inventory. hashedInventory = "hashed_inventory" hashedInventoryPath = makeDarcsdirPath hashedInventory@@ -21,16 +26,16 @@ tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory  -- | Location of parent inventories.-inventoriesDir = "inventories"+inventoriesDir = hashedDir HashedInventoriesDir inventoriesDirPath = makeDarcsdirPath inventoriesDir  -- | Location of pristine trees. tentativePristinePath = makeDarcsdirPath "tentative_pristine"-pristineDir = "pristine.hashed"+pristineDir = hashedDir HashedPristineDir pristineDirPath = makeDarcsdirPath pristineDir  -- | Location of patches.-patchesDir = "patches"+patchesDir = hashedDir HashedPatchesDir patchesDirPath = makeDarcsdirPath patchesDir  -- | Location of index files.@@ -51,6 +56,7 @@  -- | Location of unrevert bundle. unrevertPath = patchesDirPath </> "unrevert"+tentativeUnrevertPath = patchesDirPath </> "unrevert.tentative"  -- | Location of old style (unhashed) files and directories. oldPristineDirPath = makeDarcsdirPath "pristine"
src/Darcs/Repository/Pending.hs view
@@ -21,94 +21,83 @@     , readTentativePending     , writeTentativePending     , siftForPending-    , tentativelyRemoveFromPending     , tentativelyRemoveFromPW     , revertPending     , finalizePending-    , makeNewPending-    , tentativelyAddToPending     , setTentativePending     ) where  import Darcs.Prelude  import Control.Applicative-import Control.Exception ( catch, IOException )-import System.Directory ( renameFile )+import System.Directory ( copyFile, renameFile ) -import Darcs.Patch-    ( PrimOf-    , RepoPatch-    , PrimPatch-    , applyToTree-    , readPatch-    )-import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, commuteFL, readPatch ) import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Permutations-    ( removeFL-    , commuteWhatWeCanFL-    , commuteWhatWeCanRL-    )+import Darcs.Patch.Invert ( invertFL )+import Darcs.Patch.Permutations ( partitionFL ) import Darcs.Patch.Prim-    ( PrimSift(siftForPending)-    , PrimCanonize(primDecoalesce)+    ( PrimCoalesce(tryToShrink)+    , PrimSift(primIsSiftable)+    , coalesce     )-import Darcs.Patch.Progress (progressFL)-import Darcs.Util.Parser ( Parser )+import Darcs.Patch.Progress ( progressFL ) import Darcs.Patch.Read ( ReadPatch(..), bracketedFL ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(ForStorage) )-import Darcs.Patch.Show ( displayPatch )-import Darcs.Patch.Witnesses.Eq ( Eq2(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) ) import Darcs.Patch.Witnesses.Ordered-    ( RL(..), FL(..), (+>+), (+>>+), (:>)(..), mapFL, reverseFL )-import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart )+    ( FL(..)+    , RL(..)+    , mapFL+    , (+>+)+    , (:>)(..)+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal ) -import Darcs.Repository.Flags ( UpdatePending (..))-import Darcs.Repository.InternalTypes ( Repository, withRepoLocation, unsafeCoerceT )-import Darcs.Repository.Paths ( pendingPath )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , Repository+    , SAccessType(..)+    , repoAccessType+    , unsafeStartTransaction+    , withRepoDir+    )+import Darcs.Repository.Paths ( pendingPath, tentativePendingPath )  import Darcs.Util.ByteString ( gzReadFilePS )-import Darcs.Util.Exception ( catchNonExistence )-import Darcs.Util.Lock  ( writeDocBinFile, removeFileMayNotExist )-import Darcs.Util.Printer ( Doc, ($$), text, vcat, (<+>), renderString )-import Darcs.Util.Progress ( debugMessage )-import Darcs.Util.Tree ( Tree )+import Darcs.Util.Exception ( catchDoesNotExistError, ifDoesNotExistError )+import Darcs.Util.Lock ( writeDocBinFile )+import Darcs.Util.Parser ( Parser )+import Darcs.Util.Printer ( Doc, text, vcat, ($$) )  -newSuffix, tentativeSuffix :: String-newSuffix = ".new"+tentativeSuffix :: String tentativeSuffix = ".tentative"  -- | Read the contents of pending.-readPending :: RepoPatch p => Repository rt p wR wU wT+readPending :: RepoPatch p => Repository rt p wU wR             -> IO (Sealed (FL (PrimOf p) wR))-readPending = readPendingFile ""+readPending repo =+  case repoAccessType repo of+    SRO -> readPendingFile "" repo+    SRW -> readPendingFile tentativeSuffix repo  -- |Read the contents of tentative pending.-readTentativePending :: RepoPatch p => Repository rt p wR wU wT-                     -> IO (Sealed (FL (PrimOf p) wT))+readTentativePending :: RepoPatch p => Repository 'RW p wU wR+                     -> IO (Sealed (FL (PrimOf p) wR)) readTentativePending = readPendingFile tentativeSuffix --- |Read the contents of tentative pending.-readNewPending :: RepoPatch p => Repository rt p wR wU wT-               -> IO (Sealed (FL (PrimOf p) wT))-readNewPending = readPendingFile newSuffix- -- |Read the pending file with the given suffix. CWD should be the repository--- directory.-readPendingFile :: ReadPatch prim => String -> Repository rt p wR wU wT+-- directory. Unsafe!+readPendingFile :: ReadPatch prim => String -> Repository rt p wU wR                 -> IO (Sealed (FL prim wX)) readPendingFile suffix _ =-  do+  ifDoesNotExistError (Sealed NilFL) $ do     let filepath = pendingPath ++ suffix     raw <- gzReadFilePS filepath     case readPatch raw of       Right p -> return (mapSeal unFLM p)       Left e -> fail $ unlines ["Corrupt pending patch: " ++ show filepath, e]-  `catchNonExistence` Sealed NilFL  -- Wrapper around FL where printed format uses { } except around singletons. -- Now that the Show behaviour of FL p can be customised (using@@ -138,232 +127,131 @@                                            text [post]  -- |Write the contents of tentative pending.-writeTentativePending :: RepoPatch p => Repository rt p wR wU wT-                      -> FL (PrimOf p) wT wY -> IO ()-writeTentativePending = writePendingFile tentativeSuffix---- |Write the contents of new pending. CWD should be the repository directory.-writeNewPending :: RepoPatch p => Repository rt p wR wU wT-                               -> FL (PrimOf p) wT wP -> IO ()-writeNewPending = writePendingFile newSuffix---- Write a pending file, with the given suffix. CWD should be the repository--- directory.-writePendingFile :: ShowPatchBasic prim => String -> Repository rt p wR wU wT-                 -> FL prim wX wY -> IO ()-writePendingFile suffix _ = writePatch name . FLM+writeTentativePending :: RepoPatch p => Repository 'RW p wU wR+                      -> FL (PrimOf p) wR wP -> IO ()+writeTentativePending _ ps =+    unseal (writePatch name . FLM) (siftForPending ps)   where-    name = pendingPath ++ suffix+    name = pendingPath ++ tentativeSuffix  writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO () writePatch f p = writeDocBinFile f $ showPatch ForStorage p <> text "\n"  -- | Remove as much as possible of the given list of prim patches from the--- pending patch. The "as much as possible" is due to --look-for-* options--- which cause changes that normally must be explicitly done by the user (such--- as add, move, and replace) to be inferred from the the diff between--- pristine and working. These changes cannot be removed from pending because--- they have never been part of it.+-- pending patch. It is used by record and amend to update pending. ----- This function is used by Darcs whenever it adds a patch to the repository--- (eg. with apply or record). Think of it as one part of transferring patches--- from pending to somewhere else.-tentativelyRemoveFromPending :: forall rt p wR wU wT wO. RepoPatch p-                             => Repository rt p wR wU wT-                             -> FL (PrimOf p) wO wT-                             -> IO ()-tentativelyRemoveFromPending r ps = do-    Sealed pend <- readTentativePending (unsafeCoerceT r :: Repository rt p wR wU wO)-    Sealed newpend <--        return $ updatePending (progressFL "Removing from pending:" ps) pend NilFL-    writeTentativePending r newpend---- | Similar to 'tentativelyRemoveFromPending', but also takes the (old)--- difference between pending and working into account. It is used by amend and--- record commands to adjust the pending patch. See the docs for--- 'updatePending' below for details.-tentativelyRemoveFromPW :: forall rt p wR wO wT wP wU. RepoPatch p-                        => Repository rt p wR wU wT-                        -> FL (PrimOf p) wO wT -- added repo changes-                        -> FL (PrimOf p) wO wP -- O = old tentative-                        -> FL (PrimOf p) wP wU -- P = (old) pending+-- The "as much as possible" is due to --look-for-* options which cause changes+-- that normally must be explicitly done by the user (such as add, move, and+-- replace) to be inferred from the the diff between pristine and working.+-- Also, before we present prims to the user to select for recording, we+-- coalesce prims from pending and working, which is reason we have to use+-- decoalescing.+tentativelyRemoveFromPW :: forall p wR wO wP wU. RepoPatch p+                        => Repository 'RW p wU wR+                        -> FL (PrimOf p) wO wR -- added repo changes+                        -> FL (PrimOf p) wO wP -- O = old recorded state+                        -> FL (PrimOf p) wP wU -- P = (old) pending state                         -> IO ()-tentativelyRemoveFromPW r changes pending working = do-    Sealed pending' <- return $-        updatePending (progressFL "Removing from pending:" changes) pending working-    writeTentativePending r pending'--{- |-@'updatePending' changes pending working@ updates @pending@ by removing the-@changes@ we added to the repository. If primitive patches were atomic, we-could assume that @changes@ is a subset of @pending +>+ working@, but alas,-they are not: before we select changes we coalesce them; and during-selection we can again arbitrarily split them (though currently this is-limited to hunks).--The algorithm is as follows. For each @x@ in @changes@ we first try to-remove it from @pending@ as is. If this fails, we commute it past @pending@,-pushing any (reverse) dependencies with it, and check if we can remove the-result from @working@.--If prim patches were atomic this check would always succeed and we would be-done now. But due to coalescing and splitting of prims it can fail, so we-must try harder: we now try to decoalesce the commuted changes from-@working@. If that fails, too, then we know that our @x@ originated from-@pending@. So we backtrack and decoalesce @x@ from @pending@. This final-step must not fail. If it does, then we have a bug because it means we-recorded a change that cannot be removed from the net effect of @pending@-and @working@.--}-updatePending :: (PrimPatch p)-              => FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)--- no changes to the repo => cancel patches in pending whose inverse are in working-updatePending NilFL ys zs = removeRLFL (reverseFL ys) zs--- pending is empty => keep it that way-updatePending _ NilFL _ = Sealed NilFL--- no working changes =>---  just prepend inverted repo changes and rely on sifting to clean up pending-updatePending xs ys NilFL = Sealed (invert xs +>+ ys)--- x can be removed from pending => continue with the rest-updatePending (x:>:xs) ys zs | Just ys' <- removeFL x ys = updatePending xs ys' zs--- x and its reverse dependencies can be commuted through pending--- *and* the result can be removed or decoalesced from working-updatePending (x:>:xs) ys zs-  | ys' :> ix' :> deps <- commuteWhatWeCanFL (invert x :> ys)-  , Just zs' <- removeFromWorking (invert (ix':>:deps)) zs = updatePending xs ys' zs'-  where-    removeFromWorking as bs = removeAllFL as bs <|> decoalesceAllFL bs as--- decoalesce x from ys and continue with the rest-updatePending (x:>:xs) ys zs =-  case decoalesceFL ys x of-    Just ys' -> updatePending xs ys' zs-    Nothing ->-      error $ renderString-        $ text "cannot eliminate repo change:"-        $$ displayPatch x-        $$ text "from pending:"-        $$ vcat (mapFL displayPatch ys)-        $$ text "or working:"-        $$ vcat (mapFL displayPatch zs)+tentativelyRemoveFromPW r changes pending _working = do+  let inverted_changes = invertFL (progressFL "Removing from pending:" changes)+  unseal (writeTentativePending r) (updatePendingRL inverted_changes pending) --- | Remove as many patches as possible of an 'RL' from an adjacent 'FL'.-removeRLFL :: (Commute p, Invert p, Eq2 p)-           => RL p wA wB -> FL p wB wC -> Sealed (FL p wA)-removeRLFL (ys:<:y) zs-  | Just zs' <- removeFL (invert y) zs = removeRLFL ys zs'-  | otherwise = case commuteWhatWeCanRL (ys :> y) of-      deps :> y' :> ys' -> mapSeal ((deps:<:y') +>>+) $ removeRLFL ys' zs-removeRLFL NilRL _ = Sealed NilFL+-- | Iterate 'updatePending' for all recorded changes.+updatePendingRL :: PrimPatch p => RL p wR wO -> FL p wO wP -> Sealed (FL p wR)+updatePendingRL NilRL ys = Sealed ys+updatePendingRL (xs :<: x) ys = unseal (updatePendingRL xs) (updatePending x ys) --- | Remove all patches of the first 'FL' from the second 'FL' or fail.-removeAllFL :: (Commute p, Invert p, Eq2 p)-            => FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)-removeAllFL (y:>:ys) zs-  | Just zs' <- removeFL y zs = removeAllFL ys zs'-  | otherwise = Nothing-removeAllFL NilFL zs = Just zs+{- | Given an (inverted) single recorded change @x@ and the old pending+@ys@, for each prim @y@ in pending either cancel @x@ against @y@, or+coalesce them. If they coalesce, either commute the result past pending, or+continue with the rest of pending. If coalescing fails, commute @x@ forward+and try again with the next prim from pending. Repeat until we reach the end+of pending or @x@ becomes stuck, in which case we keep it there. --- | Decoalesce all patches in the second 'FL' from the first 'FL' or fail.-decoalesceAllFL :: (Commute p, Invert p, PrimCanonize p)-                => FL p wA wC -> FL p wA wB -> Maybe (FL p wB wC)-decoalesceAllFL zs (y:>:ys)-  | Just zs' <- decoalesceFL zs y = decoalesceAllFL zs' ys-  | otherwise = Nothing-decoalesceAllFL zs NilFL = Just zs+The idea of this algorithm is best explained in terms of an analogy with+arithmetic, where coalescing is addition. Let's say we start out with @a@ in+pending and @b@ in working and record the coalesced @a+b@. We now want to+remove (only) the @a@ from pending. To do that we coalesce @-(a+b)+a@ and+the result (if successful) is @-b@. If this can be commuted past pending, we+are done: the part that came from pending (@a@) is removed and the other+part cancels against what remains in working. --- | Decoalesce (subtract) a single patch from an 'FL' by trying to--- decoalesce it with every element until it succeeds or we cannot--- commute it any further.-decoalesceFL :: (Commute p, Invert p, {- Eq2 p,  -}PrimCanonize p)-             => FL p wA wC -> p wA wB -> Maybe (FL p wB wC)-decoalesceFL NilFL y = Just (invert y :>: NilFL)-decoalesceFL (z :>: zs) y-  | Just z' <- primDecoalesce z y = Just (z' :>: zs)-  | otherwise = do-      z' :> iy' <- commute (invert y :> z)-      zs' <- decoalesceFL zs (invert iy')-      return (z' :>: zs')+However, we should also guard against the possibility that we recorded a+change that was coalesced from more than one prim in pending. For instance,+suppose we recorded @a+b+c@, where @a@ and @b@ are both from pending and @c@+is form working; after coalescing with @a@ we would be left with+@-(a+b+c)+a=-(b+c)@ which would then be stuck against the remaining @b@.+This is why we continue coalescing, giving us @-(b+c)+b=-c@ which we again+try to commute out etc. --- | @makeNewPending repo YesUpdatePending pendPs@ verifies that the---   @pendPs@ could be applied to pristine if we wanted to, and if so---   writes it to disk.  If it can't be applied, @pendPs@ must---   be somehow buggy, so we save it for forensics and crash.-makeNewPending :: (RepoPatch p, ApplyState p ~ Tree)-                 => Repository rt p wR wU wT-                 -> UpdatePending-                 -> FL (PrimOf p) wT wP-                 -> Tree IO  -- ^recorded state of the repository, to check if pending can be applied-                 -> IO ()-makeNewPending _                  NoUpdatePending _ _ = return ()-makeNewPending repo YesUpdatePending origp recordedState =-    withRepoLocation repo $-    do let newname = pendingPath ++ ".new"-       debugMessage $ "Writing new pending:  " ++ newname-       Sealed sfp <- return $ siftForPending origp-       writeNewPending repo sfp-       Sealed p <- readNewPending repo-       -- We don't ever use the resulting tree.-       _ <- catch (applyToTree p recordedState) $ \(err :: IOException) -> do-         let buggyname = pendingPath ++ "_buggy"-         renameFile newname buggyname-         error $ renderString-            $ text ("There was an attempt to write an invalid pending! " ++ show err)-            $$ text "If possible, please send the contents of" <+> text buggyname-            $$ text "along with a bug report."-       renameFile newname pendingPath-       debugMessage $ "Finished writing new pending:  " ++ newname+Finally, note that a change can legitimately be stuck in pending i.e. it can+neither be coalesced nor commuted further. For instance, if we have a hunk+in pending and some other prim that depends on it, such as a replace, and+the user records (only) a split-off version of the hunk but not the replace.+This will coalesce with the remaining hunk but then be stuck at the replace.+This is how it should be and thus keeping it there is the correct behavior.+-} --- | Replace the pending patch with the tentative pending.---   If @NoUpdatePending@, this merely deletes the tentative pending---   without replacing the current one.------   Question (Eric Kow): shouldn't this also delete the tentative---   pending if @YesUpdatePending@?  I'm just puzzled by the seeming---   inconsistency of the @NoUpdatePending@ doing deletion, but---   @YesUpdatePending@ not bothering.-finalizePending :: (RepoPatch p, ApplyState p ~ Tree)-                => Repository rt p wR wU wT-                -> UpdatePending-                -> Tree IO-                -> IO ()-finalizePending repo NoUpdatePending _ =-  withRepoLocation repo $ removeFileMayNotExist pendingPath-finalizePending repo upe@YesUpdatePending recordedState =-  withRepoLocation repo $ do-      Sealed tpend <- readTentativePending repo-      Sealed new_pending <- return $ siftForPending tpend-      makeNewPending repo upe new_pending recordedState+updatePending :: PrimCoalesce p => p wR wO -> FL p wO wP -> Sealed (FL p wR)+updatePending _ NilFL = Sealed NilFL+updatePending x (y :>: ys) =+  case coalesce (x :> y) of+    Just Nothing2 -> Sealed ys -- cancelled out+    Just (Just2 y') ->+      case commuteFL (y' :> ys) of+        Just (ys' :> _) -> Sealed ys' -- drop result if we can commute it past+        Nothing -> updatePending y' ys -- continue coalescing with with y'+    Nothing ->+      case commute (x :> y) of+        Just (y' :> x') -> mapSeal (y' :>:) (updatePending x' ys)+        Nothing -> Sealed (x :>: y :>: ys) -- x is stuck, keep it there -revertPending :: RepoPatch p-              => Repository rt p wR wU wT-              -> UpdatePending-              -> IO ()-revertPending r upe = do-  removeFileMayNotExist (pendingPath ++ ".tentative")-  Sealed x <- readPending r-  if upe == YesUpdatePending-    then writeTentativePending (unsafeCoerceT r) x-    else removeFileMayNotExist pendingPath+-- | Replace the pending patch with the tentative pending+finalizePending :: Repository 'RW p wU wR -> IO ()+finalizePending _ = renameFile tentativePendingPath pendingPath --- | @tentativelyAddToPending repo ps@ appends @ps@ to the pending patch.------   This fuction is unsafe because it accepts a patch that works on the---   tentative pending and we don't currently track the state of the---   tentative pending.-tentativelyAddToPending :: forall rt p wR wU wT wX wY. RepoPatch p-                        => Repository rt p wR wU wT-                        -> FL (PrimOf p) wX wY-                        -> IO ()-tentativelyAddToPending repo patch =-    withRepoLocation repo $ do-        Sealed pend <- readTentativePending repo-        writeTentativePending repo (pend +>+ unsafeCoercePStart patch)+-- | Copy the pending patch to the tentative pending, or write a new empty+-- tentative pending if regular pending does not exist.+revertPending :: RepoPatch p => Repository 'RO p wU wR -> IO ()+revertPending r =+  copyFile pendingPath tentativePendingPath `catchDoesNotExistError`+    (readPending r >>= unseal (writeTentativePending (unsafeStartTransaction r)))  -- | Overwrites the pending patch with a new one, starting at the tentative state.-setTentativePending :: forall rt p wR wU wT wP. RepoPatch p-                    => Repository rt p wR wU wT-                    -> FL (PrimOf p) wT wP+setTentativePending :: forall p wU wR wP. RepoPatch p+                    => Repository 'RW p wU wR+                    -> FL (PrimOf p) wR wP                     -> IO ()-setTentativePending repo patch = do-    Sealed prims <- return $ siftForPending patch-    withRepoLocation repo $ writeTentativePending repo prims+setTentativePending repo ps = do+    withRepoDir repo $ writeTentativePending repo ps++-- | Simplify the candidate pending patch through a combination of looking+-- for self-cancellations (sequences of patches followed by their inverses),+-- coalescing, and getting rid of any hunk or binary patches we can commute+-- out the back.+--+-- More abstractly, for an argument @p@, pristine state @R@, and working+-- state @U@, define+--+-- > unrecorded p = p +>+ diff (pureApply p R) U+--+-- Then the resulting sequence @p'@ must maintain that equality, i.e.+--+-- > unrecorded p = unrecorded (siftForPending p)+--+-- while trying to "minimize" @p@.+siftForPending+  :: (PrimCoalesce prim, PrimSift prim) => FL prim wX wY -> Sealed (FL prim wX)+siftForPending ps =+  -- Alternately 'sift' and 'tryToShrink' until shrinking no longer reduces+  -- the length of the sequence. Here, 'sift' means to commute siftable+  -- patches to the end of the sequence and then drop them.+  case sift ps of+    Sealed sifted ->+      case tryToShrink sifted of+        Nothing -> Sealed sifted+        Just shrunk -> siftForPending shrunk+  where+    sift xs =+      case partitionFL (not . primIsSiftable) xs of+        (not_siftable :> deps :> _) -> Sealed (not_siftable +>+ deps)
src/Darcs/Repository/Prefs.hs view
@@ -16,19 +16,23 @@ --  Boston, MA 02110-1301, USA.  module Darcs.Repository.Prefs-    ( addToPreflist+    ( Pref(..)+    , addToPreflist     , deleteSources     , getPreflist     , setPreflist     , getGlobal+     , environmentHelpHome-    , defaultrepo     , getDefaultRepo     , addRepoSource++    -- these are for the setpref command i.e. contents of _darcs/prefs/prefs     , getPrefval     , setPrefval     , changePrefval     , defPrefval+     , writeDefaultPrefs     , isBoring     , FileType(..)@@ -40,7 +44,7 @@     , getMotd     , showMotd     , prefsUrl-    , prefsDirPath+    , prefsDirPath --re-export     , prefsFilePath     , getPrefLines -- exported for darcsden, don't remove     -- * documentation of prefs files@@ -51,53 +55,83 @@  import Control.Exception ( catch ) import Control.Monad ( unless, when, liftM )-import Data.Char ( toUpper )-import Data.List ( nub, isPrefixOf, union, lookup )-import Data.Maybe ( isJust, fromMaybe, mapMaybe, catMaybes, maybeToList )+import Data.Char ( toLower, toUpper )+import Data.List ( isPrefixOf, union, lookup )+import Data.Maybe+    ( catMaybes+    , fromMaybe+    , isJust+    , listToMaybe+    , mapMaybe+    , maybeToList+    ) import qualified Control.Exception as C import qualified Data.ByteString       as B  ( empty, null, hPut, ByteString ) import qualified Data.ByteString.Char8 as BC ( unpack )-import System.Directory ( getAppUserDataDirectory, doesDirectoryExist,-                          createDirectory, doesFileExist )+import System.Directory+    ( createDirectory+    , doesDirectoryExist+    , doesFileExist+    , getAppUserDataDirectory+    , getHomeDirectory+    ) import System.Environment ( getEnvironment ) import System.FilePath.Posix ( normalise, dropTrailingPathSeparator, (</>) ) import System.IO.Error ( isDoesNotExistError, catchIOError ) import System.IO ( stdout, stderr ) import System.Info ( os )-import System.Posix.Files ( getFileStatus, fileOwner )+import System.Posix.Files ( fileOwner, getFileStatus, ownerModes, setFileMode ) -import Darcs.Repository.Cache ( Cache, mkCache, CacheType(..), CacheLoc(..),-                                WritableOrNot(..) )-import Darcs.Util.External ( gzFetchFilePS , fetchFilePS, Cachable(..))+import Darcs.Util.Cache+    ( Cache+    , CacheLoc(..)+    , CacheType(..)+    , WritableOrNot(..)+    , mkCache+    , parseCacheLoc+    )+import Darcs.Util.File ( Cachable(..), fetchFilePS, gzFetchFilePS ) import Darcs.Repository.Flags     ( UseCache (..)     , DryRun (..)     , SetDefault (..)     , InheritDefault (..)-    , RemoteRepos (..)+    , WithPrefsTemplates(..)     )+import Darcs.Repository.Paths ( prefsDirPath ) import Darcs.Util.Lock( readTextFile, writeTextFile )-import Darcs.Util.Exception ( catchall )+import Darcs.Util.Exception ( catchall, ifIOError ) import Darcs.Util.Global ( darcsdir, debugMessage )-import Darcs.Util.Path ( AbsolutePath, ioAbsolute, toFilePath,-                         getCurrentDirectory )+import Darcs.Util.Path+    ( AbsoluteOrRemotePath+    , getCurrentDirectory+    , toFilePath+    , toPath+    ) import Darcs.Util.Printer( hPutDocLn, text ) import Darcs.Util.Regex ( Regex, mkRegex, matchRegex ) import Darcs.Util.URL ( isValidLocalPath )-import Darcs.Util.File ( osxCacheDir, xdgCacheDir, removeFileMayNotExist )+import Darcs.Util.File ( removeFileMayNotExist )  windows,osx :: Bool windows = "mingw" `isPrefixOf` os -- GHC under Windows is compiled with mingw osx     = os == "darwin" -writeDefaultPrefs :: IO ()-writeDefaultPrefs = do-    setPreflist "boring" defaultBoring-    setPreflist "binaries" defaultBinaries-    setPreflist "motd" []+writeDefaultPrefs :: WithPrefsTemplates -> IO ()+writeDefaultPrefs withPrefsTemplates = do+    setPreflist Boring $ defaultBoring withPrefsTemplates+    setPreflist Binaries $ defaultBinaries withPrefsTemplates+    setPreflist Motd [] -defaultBoring :: [String]-defaultBoring = map ("# " ++) boringFileInternalHelp +++defaultBoring :: WithPrefsTemplates -> [String]+defaultBoring withPrefsTemplates =+  map ("# " ++) boringFileInternalHelp +++    case withPrefsTemplates of+      NoPrefsTemplates -> []+      WithPrefsTemplates -> defaultBoringTemplate++defaultBoringTemplate :: [String]+defaultBoringTemplate =     [ ""     , "### compiler and interpreter intermediate files"     , "# haskell (ghc) interfaces"@@ -112,7 +146,7 @@     , "\\.mod$"     , "# linux kernel"     , "\\.ko\\.cmd$","\\.mod\\.c$"-    , "(^|/)\\.tmp_versions($|/)"+    , "(^|/)\\.tmp_versions/"     , "# *.ko files aren't boring by default because they might"     , "# be Korean translations rather than kernel modules"     , "# \\.ko$"@@ -132,7 +166,7 @@     , "# standard cabal build dir, might not be boring for everybody"     , "# ^dist(/|$)"     , "# autotools"-    , "(^|/)autom4te\\.cache($|/)", "(^|/)config\\.(log|status)$"+    , "(^|/)autom4te\\.cache/", "(^|/)config\\.(log|status)$"     , "# microsoft web expression, visual studio metadata directories"     , "\\_vti_cnf$"     , "\\_vti_pvt$"@@ -143,30 +177,30 @@     , ""     , "### version control systems"     , "# cvs"-    , "(^|/)CVS($|/)","\\.cvsignore$"+    , "(^|/)CVS/","\\.cvsignore$"     , "# cvs, emacs locks"     , "^\\.#"     , "# rcs"-    , "(^|/)RCS($|/)", ",v$"+    , "(^|/)RCS/", ",v$"     , "# subversion"-    , "(^|/)\\.svn($|/)"+    , "(^|/)\\.svn/"     , "# mercurial"-    , "(^|/)\\.hg($|/)"+    , "(^|/)\\.hg/"     , "# git"-    , "(^|/)\\.git($|/)"+    , "(^|/)\\.git/"     , "# bzr"     , "\\.bzr$"     , "# sccs"-    , "(^|/)SCCS($|/)"+    , "(^|/)SCCS/"     , "# darcs"-    , "(^|/)"++darcsdir++"($|/)", "(^|/)\\.darcsrepo($|/)"+    , "(^|/)"++darcsdir++"/", "(^|/)\\.darcsrepo/"     , "# gnu arch"     , "(^|/)(\\+|,)"     , "(^|/)vssver\\.scc$"-    , "\\.swp$","(^|/)MT($|/)"-    , "(^|/)\\{arch\\}($|/)","(^|/).arch-ids($|/)"+    , "\\.swp$","(^|/)MT/"+    , "(^|/)\\{arch\\}/","(^|/).arch-ids/"     , "# bitkeeper"-    , "(^|/)BitKeeper($|/)","(^|/)ChangeSet($|/)"+    , "(^|/)BitKeeper/","(^|/)ChangeSet/"     , ""     , "### miscellaneous"     , "# backup files"@@ -185,14 +219,14 @@     , "# partial broken files (KIO copy operations)"     , "\\.part$"     , "# waf files, see http://code.google.com/p/waf/"-    , "(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+($|/)"+    , "(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+/"     , "(^|/)\\.lock-wscript$"     , "# mac os finder"     , "(^|/)\\.DS_Store$"     , "# emacs saved sessions (desktops)"     , "(^|.*/)\\.emacs\\.desktop(\\.lock)?$"     , " # stack"-    , "(^|/)\\.stack-work($|/)"+    , "(^|/)\\.stack-work/"     ]  boringFileInternalHelp :: [String]@@ -233,13 +267,38 @@       ]     ) -getGlobal :: String -> IO [String]+getGlobal :: Pref -> IO [String] getGlobal f = do     dir <- globalPrefsDir     case dir of-        (Just d) -> getPreffile $ d </> f+        (Just d) -> getPreffile $ d </> formatPref f         Nothing -> return [] +-- |osxCacheDir assumes @~/Library/Caches/@ exists.+osxCacheDir :: IO (Maybe FilePath)+osxCacheDir = do+    home <- getHomeDirectory+    return $ Just $ home </> "Library" </> "Caches"+    `catchall` return Nothing++-- |xdgCacheDir returns the $XDG_CACHE_HOME environment variable,+-- or @~/.cache@ if undefined. See the FreeDesktop specification:+-- http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html+xdgCacheDir :: IO (Maybe FilePath)+xdgCacheDir = do+    env <- getEnvironment+    d <- case lookup "XDG_CACHE_HOME" env of+           Just d  -> return d+           Nothing -> getAppUserDataDirectory "cache"+    exists <- doesDirectoryExist d++    -- If directory does not exist, create it with permissions 0700+    -- as specified by the FreeDesktop standard.+    unless exists $ do createDirectory d+                       setFileMode d ownerModes+    return $ Just d+    `catchall` return Nothing+ globalCacheDir :: IO (Maybe FilePath) globalCacheDir | windows   = ((</> "cache2") `fmap`) `fmap` globalPrefsDir                | osx       = ((</> "darcs") `fmap`) `fmap` osxCacheDir@@ -263,10 +322,13 @@ -- exception in (potentially) pure code, when the regexps are used. boringRegexps :: IO [Regex] boringRegexps = do-    borefile <- defPrefval "boringfile" (darcsdir ++ "/prefs/boring")-    localBores <- getPrefLines borefile `catchall` return []-    globalBores <- getGlobal "boring"+    borefile <- maybeToList <$> getPrefval "boringfile"+    localBores <-+      concat <$> safeGetPrefLines `mapM` (borefile ++ [prefsFile Boring])+    globalBores <- getGlobal Boring     liftM catMaybes $ mapM tryMakeBoringRegexp $ localBores ++ globalBores+  where+    safeGetPrefLines fileName = getPrefLines fileName `catchall` return []  isBoring :: IO (FilePath -> Bool) isBoring = do@@ -310,8 +372,15 @@ -- -- Note that while this matches .gz and .GZ, it will not match .gZ, -- i.e. it is not truly case insensitive.-defaultBinaries :: [String]-defaultBinaries = map ("# "++) binariesFileInternalHelp +++defaultBinaries :: WithPrefsTemplates -> [String]+defaultBinaries withPrefsTemplates =+  map ("# "++) binariesFileInternalHelp +++    case withPrefsTemplates of+      NoPrefsTemplates -> []+      WithPrefsTemplates -> defaultBinariesTemplate++defaultBinariesTemplate :: [String]+defaultBinariesTemplate =     [ "\\." ++ regexToMatchOrigOrUpper e ++ "$" | e <- extensions ]   where     regexToMatchOrigOrUpper e = "(" ++ e ++ "|" ++ map toUpper e ++ ")"@@ -355,54 +424,77 @@  filetypeFunction :: IO (FilePath -> FileType) filetypeFunction = do-    binsfile <- defPrefval "binariesfile" (darcsdir ++ "/prefs/binaries")-    bins <- getPrefLines binsfile-            `catch`-            (\e -> if isDoesNotExistError e then return [] else ioError e)-    gbs <- getGlobal "binaries"+    binsfile <- maybeToList <$> getPrefval "binariesfile"+    bins <-+      concat <$> safeGetPrefLines `mapM` (binsfile ++ [prefsFile Binaries])+    gbs <- getGlobal Binaries     let binaryRegexes = map mkRegex (bins ++ gbs)         isBinary f = any (\r -> isJust $ matchRegex r f) binaryRegexes         ftf f = if isBinary $ doNormalise f then BinaryFile else TextFile     return ftf+  where+    safeGetPrefLines fileName =+        getPrefLines fileName+        `catch`+        (\e -> if isDoesNotExistError e then return [] else ioError e)  findPrefsDirectory :: IO (Maybe String) findPrefsDirectory = do     inDarcsRepo <- doesDirectoryExist darcsdir     return $ if inDarcsRepo-                 then Just $ darcsdir ++ "/prefs/"+                 then Just prefsDirPath                  else Nothing  withPrefsDirectory :: (String -> IO ()) -> IO () withPrefsDirectory job = findPrefsDirectory >>= maybe (return ()) job -addToPreflist :: String -> String -> IO ()-addToPreflist pref value = withPrefsDirectory $ \prefs -> do-    hasprefs <- doesDirectoryExist prefs-    unless hasprefs $ createDirectory prefs+data Pref+  = Author+  | Binaries+  | Boring+  | Defaultrepo+  | Defaults+  | Email+  | Motd+  | Post+  | Prefs+  | Repos+  | Sources+  deriving (Eq, Ord, Read, Show)++formatPref :: Pref -> String+formatPref = map toLower . show++addToPreflist :: Pref -> String -> IO ()+addToPreflist pref value =+  withPrefsDirectory $ \prefs_dir -> do+    hasprefs <- doesDirectoryExist prefs_dir+    unless hasprefs $ createDirectory prefs_dir     pl <- getPreflist pref-    writeTextFile (prefs ++ pref) . unlines $ union [value] pl+    writeTextFile (prefs_dir </> formatPref pref) . unlines $ union [value] pl -getPreflist :: String -> IO [String]-getPreflist p = findPrefsDirectory >>=-                maybe (return []) (\prefs -> getPreffile $ prefs ++ p)+getPreflist :: Pref -> IO [String]+getPreflist pref =+  findPrefsDirectory >>=+  maybe (return []) (\prefs_dir -> getPreffile $ prefs_dir </> formatPref pref)  getPreffile :: FilePath -> IO [String] getPreffile f = do     hasprefs <- doesFileExist f     if hasprefs then getPrefLines f else return [] -setPreflist :: String -> [String] -> IO ()-setPreflist p ls = withPrefsDirectory $ \prefs -> do-    haspref <- doesDirectoryExist prefs+setPreflist :: Pref -> [String] -> IO ()+setPreflist p ls = withPrefsDirectory $ \prefs_dir -> do+    haspref <- doesDirectoryExist prefs_dir     when haspref $-        writeTextFile (prefs ++ p) (unlines ls)+        writeTextFile (prefs_dir </> formatPref p) (unlines ls)  defPrefval :: String -> String -> IO String defPrefval p d = fromMaybe d `fmap` getPrefval p  getPrefval :: String -> IO (Maybe String) getPrefval p = do-    pl <- getPreflist prefsDir+    pl <- getPreflist Prefs     return $ case map snd $ filter ((== p) . fst) $ map (break (== ' ')) pl of                  [val] -> case words val of                     [] -> Nothing@@ -411,8 +503,8 @@  setPrefval :: String -> String -> IO () setPrefval p v = do-    pl <- getPreflist prefsDir-    setPreflist prefsDir $ updatePrefVal pl p v+    pl <- getPreflist Prefs+    setPreflist Prefs $ updatePrefVal pl p v  updatePrefVal :: [String] -> String -> String -> [String] updatePrefVal prefList p newVal =@@ -420,69 +512,35 @@  changePrefval :: String -> String -> String -> IO () changePrefval p f t = do-    pl <- getPreflist prefsDir+    pl <- getPreflist Prefs     ov <- getPrefval p     let newval = maybe t (\old -> if old == f then t else old) ov-    setPreflist prefsDir $ updatePrefVal pl p newval--fixRepoPath :: String -> IO FilePath-fixRepoPath p-    | isValidLocalPath p = toFilePath `fmap` ioAbsolute p-    | otherwise = return p--defaultrepo :: RemoteRepos -> AbsolutePath -> [String] -> IO [String]-defaultrepo (RemoteRepos rrepos) _ [] =-  do case rrepos of-       [] -> maybeToList `fmap` getDefaultRepo-       rs -> mapM fixRepoPath rs-defaultrepo _ _ r = return r+    setPreflist Prefs $ updatePrefVal pl p newval  getDefaultRepo :: IO (Maybe String)-getDefaultRepo = do-    defaults <- getPreflist defaultRepoPref-    case defaults of-         [] -> return Nothing-         (d : _) -> Just `fmap` fixRepoPath d--defaultRepoPref :: String-defaultRepoPref = "defaultrepo"+getDefaultRepo = listToMaybe <$> getPreflist Defaultrepo  -- | addRepoSource adds a new entry to _darcs/prefs/repos and sets it as default --   in _darcs/prefs/defaultrepo, unless --no-set-default or --dry-run is passed, --   or it is the same repository as the current one. addRepoSource :: String               -> DryRun-              -> RemoteRepos               -> SetDefault               -> InheritDefault-              -> Bool               -> IO ()-addRepoSource r isDryRun (RemoteRepos rrepos) setDefault inheritDefault isInteractive = (do-    olddef <- getPreflist defaultRepoPref+addRepoSource r isDryRun setDefault inheritDefault =+  ifIOError () $ do+    olddef <- getDefaultRepo     newdef <- newDefaultRepo-    let shouldDoIt = null noSetDefault && greenLight-        greenLight = shouldAct && not rIsTmp && (olddef /= [newdef] || olddef == [])-    -- the nuance here is that we should only notify when the reason we're not-    -- setting default is the --no-set-default flag, not the various automatic-    -- show stoppers-    if shouldDoIt-       then setPreflist defaultRepoPref [newdef]-       else when (True `notElem` noSetDefault && greenLight && inheritDefault == NoInheritDefault) $-                putStr . unlines $ setDefaultMsg-    addToPreflist "repos" newdef) `catchall` return ()+    let shouldDoIt =+          noSetDefault && isDryRun == NoDryRun && olddef /= Just newdef+    when shouldDoIt $ setPreflist Defaultrepo [newdef]+    addToPreflist Repos newdef   where-    shouldAct = isDryRun == NoDryRun-    rIsTmp = r `elem` rrepos-    noSetDefault = case setDefault of-                       NoSetDefault x -> [x]-                       _ -> []-    setDefaultMsg =-        [ "By the way, to change the default remote repository to"-        , "      " ++ r ++ ","-        , "you can " ++-          (if isInteractive then "quit now and " else "") ++-          "issue the same command with the --set-default flag."-        ]+    noSetDefault =+      case setDefault of+        NoSetDefault _ -> False+        _ -> True     newDefaultRepo :: IO String     newDefaultRepo = case inheritDefault of       YesInheritDefault -> getRemoteDefaultRepo@@ -498,7 +556,7 @@           sameOwner r "." >>= \case             True -> do               defs <--                getPreffile (r </> darcsdir </> "prefs/defaultrepo")+                getPreffile (prefsUrl r Defaultrepo)                 `catchIOError`                 const (return [r])               case defs of@@ -508,6 +566,8 @@                 [] -> return r             False -> return r       | otherwise = return r+    -- In case r is a symbolic link we do want the target directory's+    -- status, not that of the symlink.     sameOwner p q =       (==) <$> (fileOwner <$> getFileStatus p) <*> (fileOwner <$> getFileStatus q) @@ -515,55 +575,49 @@ --   Used when cloning to a ssh destination. --   Assume the current working dir is the repository. deleteSources :: IO ()-deleteSources = do let prefsdir = darcsdir ++ "/prefs/"-                   removeFileMayNotExist (prefsdir ++ "sources")-                   removeFileMayNotExist (prefsdir ++ "repos")+deleteSources = do+  removeFileMayNotExist (prefsFile Sources)+  removeFileMayNotExist (prefsFile Repos) -getCaches :: UseCache -> String -> IO Cache-getCaches useCache repodir = do-    here <- parsehs `fmap` getPreffile sourcesFile-    there <- (parsehs . lines . BC.unpack)-             `fmap`-             (gzFetchFilePS (repodir </> sourcesFile) Cachable-              `catchall` return B.empty)+getCaches :: UseCache -> Maybe AbsoluteOrRemotePath -> IO Cache+getCaches useCache from = do+    here <- parsehs `fmap` getPreflist Sources     globalcachedir <- globalCacheDir     let globalcache = if nocache                           then []                           else case globalcachedir of                               Nothing -> []                               Just d -> [Cache Directory Writable d]-    globalsources <- parsehs `fmap` getGlobal "sources"+    globalsources <- parsehs `fmap` getGlobal Sources     thisdir <- getCurrentDirectory     let thisrepo = [Cache Repo Writable $ toFilePath thisdir]-        thatrepo = [Cache Repo NotWritable repodir]-        tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++ here-                          ++ thatrepo ++ filterExternalSources there-    return $ mkCache tempCache+    from_cache <-+      case from of+        Nothing -> return []+        Just repoloc -> do+          there <- (parsehs . lines . BC.unpack)+                 `fmap`+                 (gzFetchFilePS (prefsUrl (toPath repoloc) Sources) Cachable+                  `catchall` return B.empty)+          let thatrepo = [Cache Repo NotWritable (toPath repoloc)]+              externalSources =+                  if isValidLocalPath (toPath repoloc)+                      then there+                      else filter (not . isValidLocalPath . cacheSource) there+          return (thatrepo ++ externalSources)+    return $ mkCache (thisrepo ++ here ++ globalcache ++ globalsources ++ from_cache)   where-    sourcesFile = darcsdir ++ "/prefs/sources"--    parsehs = mapMaybe readln . noncomments--    readln l-        | "repo:" `isPrefixOf` l = Just (Cache Repo NotWritable (drop 5 l))-        | nocache = Nothing-        | "cache:" `isPrefixOf` l = Just (Cache Directory Writable (drop 6 l))-        | "readonly:" `isPrefixOf` l =-            Just (Cache Directory NotWritable (drop 9 l))-        | otherwise = Nothing-+    parsehs = filter by . mapMaybe parseCacheLoc . noncomments+    by (Cache Directory _ _) = not nocache+    by (Cache Repo Writable _) = False -- ignore thisrepo: entries+    by _ = True     nocache = useCache == NoUseCache -    filterExternalSources there =-        if isValidLocalPath repodir-            then there-            else filter (not . isValidLocalPath . cacheSource) there- -- | Fetch and return the message of the day for a given repository. getMotd :: String -> IO B.ByteString getMotd repo = fetchFilePS motdPath (MaxAge 600) `catchall` return B.empty   where-    motdPath = repo ++ "/" ++ darcsdir ++ "/prefs/motd"+    motdPath = prefsUrl repo Motd  -- | Display the message of the day for a given repository, showMotd :: String -> IO ()@@ -573,17 +627,14 @@         B.hPut stdout motd         putStrLn $ replicate 22 '*' -prefsUrl :: FilePath -> String-prefsUrl r = r ++ "/"++darcsdir++"/prefs"--prefsDir :: FilePath-prefsDir = "prefs"+prefsUrl :: String -> Pref -> String+prefsUrl repourl pref = repourl </> prefsDirPath </> formatPref pref -prefsDirPath :: FilePath-prefsDirPath = darcsdir </> prefsDir+prefsFile :: Pref -> FilePath+prefsFile pref = prefsDirPath </> formatPref pref  prefsFilePath :: FilePath-prefsFilePath = prefsDirPath </> "prefs"+prefsFilePath = prefsFile Prefs  prefsFilesHelp :: [(String,String)] prefsFilesHelp  =
src/Darcs/Repository/Pristine.hs view
@@ -1,218 +1,177 @@+{-# LANGUAGE OverloadedStrings #-} module Darcs.Repository.Pristine-    ( ApplyDir(..)-    , applyToHashedPristine-    , applyToTentativePristine-    , applyToTentativePristineCwd+    ( applyToTentativePristine     , readHashedPristineRoot     , pokePristineHash     , peekPristineHash     , createPristineDirectoryTree-    , createPartialsPristineDirectoryTree-    , withRecorded-    , withTentative+    , readPristine+    , writePristine+    , convertSizePrefixedPristine     ) where  import Darcs.Prelude -import Control.Arrow ( (&&&) )-import Control.Exception ( catch, IOException )-import Control.Monad ( when )--import qualified Data.ByteString.Char8 as BC ( unpack, pack )+import Control.Exception ( catch, IOException, throwIO ) -import System.Directory ( createDirectoryIfMissing )-import System.FilePath.Posix( (</>) )+import System.Directory ( withCurrentDirectory )+import System.FilePath.Posix ( (</>) ) import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( catchIOError ) -import Darcs.Patch ( description )+import Darcs.Patch ( PatchInfoAnd, RepoPatch, description ) import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Invertible ( Invertible ) import Darcs.Patch.Show ( ShowPatch )+import Darcs.Patch.Witnesses.Ordered ( FL ) -import Darcs.Repository.Cache ( Cache, HashedDir(..), mkCache )-import Darcs.Repository.Flags ( Verbosity(..), WithWorkingDir(..) )+import Darcs.Repository.Flags ( WithWorkingDir(..) ) import Darcs.Repository.Format ( RepoProperty(HashedInventory), formatHas )-import Darcs.Repository.HashedIO ( cleanHashdir, copyHashed, copyPartialsHashed ) import Darcs.Repository.Inventory import Darcs.Repository.InternalTypes     ( Repository+    , AccessType(..)+    , SAccessType(..)+    , repoAccessType     , repoCache     , repoFormat     , repoLocation-    , withRepoLocation+    , withRepoDir     ) import Darcs.Repository.Old ( oldRepoFailMsg ) import Darcs.Repository.Paths     ( hashedInventoryPath-    , pristineDirPath     , tentativePristinePath     )  import Darcs.Util.ByteString ( gzReadFilePS )-import Darcs.Util.External ( Cachable(Uncachable), fetchFilePS )-import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Hash ( Hash(..), encodeBase16 )+import Darcs.Util.Cache ( Cache ) import Darcs.Util.Lock ( writeDocBinFile )-import Darcs.Util.Path ( AbsolutePath, AnchoredPath, toFilePath )-import Darcs.Util.Printer ( (<+>), putDocLn, text )-import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage )-import Darcs.Util.Tree ( Tree, treeHash )+import Darcs.Util.Printer ( ($$), renderString, text )+import Darcs.Util.Tree ( Tree ) import Darcs.Util.Tree.Hashed-    ( decodeDarcsHash-    , decodeDarcsSize+    ( darcsAddMissingHashes+    , darcsTreeHash     , hashedTreeIO     , readDarcsHashed     , readDarcsHashedNosize     , writeDarcsHashed     )+import Darcs.Util.Tree.Plain ( writePlainTree )+import Darcs.Util.ValidHash ( fromHash, getSize )  -data ApplyDir = ApplyNormal | ApplyInverted---- | 'applyToHashedPristine' takes a root hash, a patch @p@ and attempts to--- apply the patch to the 'Tree' identified by @h@. If we encounter an old,--- size-prefixed pristine, we first convert it to the non-size-prefixed format,--- then apply the patch.-applyToHashedPristine :: (Apply p, ApplyState p ~ Tree)-                      => ApplyDir -> PristineHash -> p wX wY -> IO PristineHash-applyToHashedPristine dir h p = applyOrConvertOldPristineAndApply+-- | Apply a patch to the 'Tree' identified by the given root 'PristineHash',+-- then return the root hash of the result. The 'ApplyDir' argument says+-- whether to add or remove the changes. The 'Cache' argument specifies the+-- possible locations for hashed files.+applyToHashedPristine :: (Apply p, ApplyState p ~ Tree, ShowPatch p)+                      => Cache+                      -> PristineHash+                      -> p wX wY+                      -> IO PristineHash+applyToHashedPristine cache root patch = tryApply `catchIOError` annotateError   where-    applyOrConvertOldPristineAndApply =-        tryApply hash `catch` \(_ :: IOException) -> handleOldPristineAndApply--    hash = decodeDarcsHash $ BC.pack $ getValidHash h--    failOnMalformedRoot (SHA256 _) = return ()-    failOnMalformedRoot root = fail $ "Cannot handle hash: " ++ show root--    hash2root = mkValidHash . BC.unpack . encodeBase16--    tryApply :: Hash -> IO PristineHash-    tryApply root = do-        failOnMalformedRoot root+    tryApply :: IO PristineHash+    tryApply = do         -- Read a non-size-prefixed pristine, failing if we encounter one.-        tree <- readDarcsHashedNosize pristineDirPath root-        (_, updatedTree) <- case dir of-            ApplyNormal -> hashedTreeIO (apply p) tree pristineDirPath-            ApplyInverted -> hashedTreeIO (unapply p) tree pristineDirPath-        return $ hash2root $ treeHash updatedTree--    warn = "WARNING: Doing a one-time conversion of pristine format.\n"-           ++ "This may take a while. The new format is backwards-compatible."+        tree <- readDarcsHashedNosize cache root+        (_, updatedTree) <- hashedTreeIO (apply patch) tree cache+        return $ fromHash $ darcsTreeHash updatedTree -    handleOldPristineAndApply = do-        hPutStrLn stderr warn-        inv <- gzReadFilePS hashedInventoryPath-        let oldroot = BC.pack $ getValidHash $ peekPristineHash inv-            oldrootSizeandHash = (decodeDarcsSize &&& decodeDarcsHash) oldroot-        -- Read the old size-prefixed pristine tree-        old <- readDarcsHashed pristineDirPath oldrootSizeandHash-        -- Write out the pristine tree as a non-size-prefixed pristine.-        root <- writeDarcsHashed old pristineDirPath-        let newroot = hash2root root-        -- Write out the new inventory.-        writeDocBinFile hashedInventoryPath $ pokePristineHash newroot inv-        cleanHashdir (mkCache []) HashedPristineDir [newroot]-        hPutStrLn stderr "Pristine conversion done..."-        -- Retry applying the patch, which should now succeed.-        tryApply root+    annotateError e =+      throwIO $+      userError $+      renderString $+      "Cannot apply patch to pristine:" $$ (description patch) $$+      "You may want to run 'darcs repair' on the repository containing this patch." $$+      "Reason: " <> text (show e) --- | copyPristine copies a pristine tree into the current pristine dir,---   and possibly copies a clean working tree.---   The target is read from the passed-in dir/inventory name combination.-copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO ()-copyPristine cache dir iname wwd = do-    i <- fetchFilePS (dir ++ "/" ++ iname) Uncachable-    debugMessage $ "Copying hashed pristine tree: " ++ getValidHash (peekPristineHash i)-    let tediousName = "Copying pristine"-    beginTedious tediousName-    copyHashed tediousName cache wwd $ peekPristineHash i-    endTedious tediousName+convertSizePrefixedPristine :: Cache -> PristineHash -> IO PristineHash+convertSizePrefixedPristine cache ph = do+  case getSize ph of+    Nothing -> return ph+    Just _ -> do+      hPutStrLn stderr "Converting pristine..."+      -- Read the old size-prefixed pristine tree+      old <- readDarcsHashed cache ph+      -- Write out the pristine tree as a non-size-prefixed pristine+      -- and return the new root hash.+      writeDarcsHashed old cache --- |applyToTentativePristine applies a patch @p@ to the tentative pristine--- tree, and updates the tentative pristine hash-applyToTentativePristine :: (ApplyState q ~ Tree, Apply q, ShowPatch q)-                         => Repository rt p wR wU wT-                         -> ApplyDir-                         -> Verbosity-                         -> q wT wY+-- | Apply an 'FL' of 'Invertible' patches tentative pristine tree, and update+-- the tentative pristine hash. The patches need to be 'Invertible' so that we+-- can use it when removing patches from the repository, too.+applyToTentativePristine :: (ApplyState p ~ Tree, RepoPatch p)+                         => Repository 'RW p wU wR+                         -> Invertible (FL (PatchInfoAnd p)) wR wY                          -> IO ()-applyToTentativePristine r dir verb p =-  withRepoLocation r $ do-    when (verb == Verbose) $-      putDocLn $ text "Applying to pristine..." <+> description p-    applyToTentativePristineCwd dir p--applyToTentativePristineCwd :: (ApplyState p ~ Tree, Apply p)-                            => ApplyDir-                            -> p wX wY-                            -> IO ()-applyToTentativePristineCwd dir p = do+applyToTentativePristine r p = do     tentativePristine <- gzReadFilePS tentativePristinePath     -- Extract the pristine hash from the tentativePristine file, using-    -- peekPristineHash (this is valid since we normally just extract the hash from the-    -- first line of an inventory file; we can pass in a one-line file that-    -- just contains said hash).+    -- peekPristineHash (this is valid since we normally just extract the hash+    -- from the first line of an inventory file; we can pass in a one-line file+    -- that just contains said hash).     let tentativePristineHash = peekPristineHash tentativePristine-    newPristineHash <- applyToHashedPristine dir tentativePristineHash p+    newPristineHash <- applyToHashedPristine (repoCache r) tentativePristineHash p     writeDocBinFile tentativePristinePath $         pokePristineHash newPristineHash tentativePristine --- | Used by the commands dist and diff-createPartialsPristineDirectoryTree :: Repository rt p wR wU wT-                                    -> [AnchoredPath]-                                    -> FilePath-                                    -> IO ()-createPartialsPristineDirectoryTree r paths target_dir-    | formatHas HashedInventory (repoFormat r) =-        do createDirectoryIfMissing True target_dir-           withCurrentDirectory target_dir $-            copyPartialsPristine (repoCache r) (repoLocation r) hashedInventoryPath-    | otherwise = fail oldRepoFailMsg+readHashedPristineRoot :: Repository rt p wU wR -> IO PristineHash+readHashedPristineRoot r =+  withRepoDir r $+    case repoAccessType r of+      SRO -> getHash hashedInventoryPath+      SRW -> getHash tentativePristinePath -- note the asymmetry!   where-    -- |copyPartialsPristine copies the pristine entries for a given list of-    -- filepaths.-    copyPartialsPristine cache repo_loc inv_name = do-        raw_inv <- fetchFilePS (repo_loc </> inv_name) Uncachable-        copyPartialsHashed cache (peekPristineHash raw_inv) paths---- |readHashedPristineRoot attempts to read the pristine hash from the current--- inventory, returning Nothing if it cannot do so.-readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe PristineHash)-readHashedPristineRoot r = withRepoLocation r $ do-    i <- (Just <$> gzReadFilePS hashedInventoryPath)-         `catch` (\(_ :: IOException) -> return Nothing)-    return $ peekPristineHash <$> i+    getHash path =+      peekPristineHash <$>+        gzReadFilePS path `catch` (\(_ :: IOException) -> fail oldRepoFailMsg) --- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree,---   possibly writing a clean working tree in the process.-createPristineDirectoryTree :: Repository rt p wR wU wT -> FilePath -> WithWorkingDir -> IO ()-createPristineDirectoryTree r reldir wwd-    | formatHas HashedInventory (repoFormat r) =-        do createDirectoryIfMissing True reldir-           withCurrentDirectory reldir $-              copyPristine (repoCache r) (repoLocation r) hashedInventoryPath wwd-    | otherwise = fail oldRepoFailMsg+-- | Write the pristine tree into a plain directory at the given path.+createPristineDirectoryTree ::+     Repository rt p wU wR -> FilePath -> WithWorkingDir -> IO ()+createPristineDirectoryTree r _ NoWorkingDir = do+    tree <- readPristine r+    -- evaluate the tree to force copying of pristine files+    _ <- darcsAddMissingHashes tree+    return ()+createPristineDirectoryTree r dir WithWorkingDir = do+    tree <- readPristine r+    writePlainTree tree dir -withRecorded :: Repository rt p wR wU wT-             -> ((AbsolutePath -> IO a) -> IO a)-             -> (AbsolutePath -> IO a)-             -> IO a-withRecorded repository mk_dir f =-  mk_dir $ \d -> do-    createPristineDirectoryTree repository (toFilePath d) WithWorkingDir-    f d+-- | Obtains a Tree corresponding to the "recorded" state of the repository:+-- this is the same as the pristine cache, which is the same as the result of+-- applying all the repository's patches to an empty directory.+readPristine :: Repository rt p wU wR -> IO (Tree IO)+readPristine repo+  | formatHas HashedInventory (repoFormat repo) =+    case repoAccessType repo of+      SRO -> do+        inv <- gzReadFilePS $ repoLocation repo </> hashedInventoryPath+        let root = peekPristineHash inv+        readDarcsHashed (repoCache repo) root+      SRW -> do+        hash <-+          peekPristineHash <$>+            gzReadFilePS (repoLocation repo </> tentativePristinePath)+        readDarcsHashedNosize (repoCache repo) hash+  | otherwise = fail oldRepoFailMsg -withTentative :: Repository rt p wR wU wT-              -> ((AbsolutePath -> IO a) -> IO a)-              -> (AbsolutePath -> IO a)-              -> IO a-withTentative r mk_dir f-    | formatHas HashedInventory (repoFormat r) =-        mk_dir $ \d -> do copyPristine-                              (repoCache r)-                              (repoLocation r)-                              (darcsdir++"/tentative_pristine")-                              WithWorkingDir-                          f d-    | otherwise = fail oldRepoFailMsg+-- | Replace the existing pristine with a new one (loaded up in a Tree object).+-- Warning: If @rt ~ 'RO@ this overwrites the recorded state, use only when+-- creating a new repo!+writePristine :: Repository rt p wU wR -> Tree IO -> IO PristineHash+writePristine repo tree =+  withCurrentDirectory (repoLocation repo) $ do+    tree' <- darcsAddMissingHashes tree+    root <- writeDarcsHashed tree' (repoCache repo)+    -- now update the current pristine hash+    case repoAccessType repo of+      SRO -> putHash root hashedInventoryPath+      SRW -> putHash root tentativePristinePath -- note the asymmetry!+  where+    putHash root path = do+      content <- gzReadFilePS path+      writeDocBinFile path $ pokePristineHash root content+      return root
src/Darcs/Repository/Rebase.hs view
@@ -3,114 +3,105 @@ --  BSD3 {-# LANGUAGE OverloadedStrings #-} module Darcs.Repository.Rebase-    ( withManualRebaseUpdate-    , rebaseJob-    , startRebaseJob-    , maybeDisplaySuspendedStatus-    -- create/read/write rebase patch-    , readTentativeRebase+    ( -- * Create/read/write rebase patch+      readTentativeRebase     , writeTentativeRebase     , withTentativeRebase-    , createTentativeRebase     , readRebase-    , commuteOutOldStyleRebase+    , finalizeTentativeRebase+    , revertTentativeRebase+    , withManualRebaseUpdate+      -- * Handle rebase format and status+    , checkHasRebase+    , displayRebaseStatus+    , updateRebaseFormat+      -- * Handle old-style rebase+    , extractOldStyleRebase     , checkOldStyleRebaseStatus     ) where  import Darcs.Prelude -import Control.Exception (throwIO )-import Control.Monad ( unless )+import Control.Monad ( unless, void, when )+import System.Directory ( copyFile, renameFile ) import System.Exit ( exitFailure )-import System.IO.Error ( catchIOError, isDoesNotExistError )+import System.FilePath.Posix ( (</>) ) -import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Commute ( Commute(..) )-import qualified Darcs.Patch.Named.Wrapped as W+import qualified Darcs.Patch.Rebase.Legacy.Wrapped as W import Darcs.Patch.PatchInfoAnd-    ( PatchInfoAndG+    ( PatchInfoAnd+    , PatchInfoAndG+    , fmapPIAP     , hopefully     )-import Darcs.Patch.Read ( readPatch ) import Darcs.Patch.Rebase.Suspended     ( Suspended(Items)     , countToEdit+    , readSuspended+    , showSuspended     , simplifyPushes+    , removeFixupsFromSuspended     ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) import Darcs.Patch.RepoPatch ( RepoPatch, PrimOf )-import Darcs.Patch.RepoType-  ( RepoType(..), IsRepoType(..), SRepoType(..)-  , RebaseType(..), SRebaseType(..)-  )-import Darcs.Patch.Show ( displayPatch, showPatch, ShowPatchFor(ForStorage) )-import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd )+import Darcs.Patch.Show ( ShowPatchFor(ForStorage) )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..)+    , FL(..)+    , RL(..)+    , foldlwFL+    , mapRL_RL+    , (+<<+)+    )+import Darcs.Patch.Witnesses.Sealed ( Dup(..) )  import Darcs.Repository.Format     ( RepoProperty ( RebaseInProgress_2_16, RebaseInProgress )     , formatHas     , addToFormat     , removeFromFormat-    , writeRepoFormat     ) import Darcs.Repository.InternalTypes     ( Repository+    , AccessType(..)+    , modifyRepoFormat     , repoFormat-    , withRepoLocation+    , repoLocation     ) import Darcs.Repository.Paths     ( rebasePath     , tentativeRebasePath-    , formatPath     )  import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) ) import Darcs.Util.English ( englishNum, Noun(..) )+import Darcs.Util.Exception ( catchDoesNotExistError ) import Darcs.Util.Lock ( writeDocBinFile, readBinFile )-import Darcs.Util.Printer ( renderString, text, hsep, vcat, ($$) )+import Darcs.Util.Parser ( parse )+import Darcs.Util.Printer ( text, hsep, vcat ) import Darcs.Util.Printer.Color ( ePutDocLn )-import Darcs.Util.Tree ( Tree )--import Control.Exception ( finally )+import Darcs.Util.URL ( isValidLocalPath )  withManualRebaseUpdate-   :: forall rt p x wR wU wT1 wT2-    . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-   => Repository rt p wR wU wT1-   -> (Repository rt p wR wU wT1 -> IO (Repository rt p wR wU wT2, FL (RebaseFixup (PrimOf p)) wT2 wT1, x))-   -> IO (Repository rt p wR wU wT2, x)-withManualRebaseUpdate r subFunc-  | SRepoType SIsRebase <- singletonRepoType :: SRepoType rt = do-      susp <- readTentativeRebase r-      (r', fixups, x) <- subFunc r+   :: RepoPatch p+   => Repository rt p wU wR+   -> (Repository rt p wU wR -> IO (Repository rt p wU wR', FL (RebaseFixup (PrimOf p)) wR' wR, x))+   -> IO (Repository rt p wU wR', x)+withManualRebaseUpdate r subFunc = do+    susp <- readTentativeRebase r+    (r', fixups, x) <- subFunc r+    when (countToEdit susp > 0) $       -- HACK overwrite the changes that were made by subFunc       -- which may and indeed does call add/remove patch       writeTentativeRebase r' (simplifyPushes MyersDiff fixups susp)-      return (r', x)-  | otherwise = do-      (r', _, x) <- subFunc r-      return (r', x)--catchDoesNotExist :: IO a -> IO a -> IO a-catchDoesNotExist a b =-  a `catchIOError` (\e -> if isDoesNotExistError e then b else throwIO e)+    return (r', x) -checkOldStyleRebaseStatus :: RepoPatch p-                          => SRebaseType rebaseType-                          -> Repository ('RepoType rebaseType) p wR wU wR-                          -> IO ()-checkOldStyleRebaseStatus SNoRebase _    = return ()-checkOldStyleRebaseStatus SIsRebase repo = do-    -- if the format says we have a rebase in progress,-    -- but initially we have zero new-style suspended patches-    -- this means an old-style rebase is in progress-    count <--      (countToEdit <$> readRebase repo)-      `catchDoesNotExist`-      return 0-    unless (count > 0) $ do+-- | Fail if there is an old-style rebase present.+-- To be called initially for every command except rebase upgrade.+checkOldStyleRebaseStatus :: Repository rt p wU wR -> IO ()+checkOldStyleRebaseStatus repo = do+  let rf = repoFormat repo+  when (formatHas RebaseInProgress rf) $ do       ePutDocLn upgradeMsg       exitFailure   where@@ -121,127 +112,120 @@       , "older than 2.16 on this repository until the current rebase is finished."       ] --- | got a rebase operation to run where it is required that a rebase is--- already in progress-rebaseJob :: (RepoPatch p, ApplyState p ~ Tree)-          => (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)-          -> Repository ('RepoType 'IsRebase) p wR wU wR-          -> IO a-rebaseJob job repo = do-    job repo-      -- The use of finally here is because various things in job-      -- might cause an "expected" early exit leaving us needing-      -- to remove the rebase-in-progress state (e.g. when suspending,-      -- conflicts with recorded, user didn't specify any patches).-      ---      -- The better fix would be to standardise expected early exits-      -- e.g. using a layer on top of IO or a common Exception type-      -- and then just catch those.-      `finally` checkSuspendedStatus repo---- | Got a rebase operation to run where we may need to initialise the--- rebase state first. Make sure you have taken the lock before calling this.-startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree)-               => (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)-               -> Repository ('RepoType 'IsRebase) p wR wU wR-               -> IO a-startRebaseJob job repo = do-    let rf = repoFormat repo-    if formatHas RebaseInProgress rf then-      checkOldStyleRebaseStatus SIsRebase repo-    else-      unless (formatHas RebaseInProgress_2_16 rf) $-        writeRepoFormat (addToFormat RebaseInProgress_2_16 rf) formatPath-    rebaseJob job repo--checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree)-                     => Repository ('RepoType 'IsRebase) p wR wU wR-                     -> IO ()-checkSuspendedStatus _repo = do-    ps <- readTentativeRebase _repo `catchIOError` \_ -> readRebase _repo-    case countToEdit ps of-         0 -> do-               writeRepoFormat-                  (removeFromFormat RebaseInProgress_2_16 $-                    repoFormat _repo)-                  formatPath-               putStrLn "Rebase finished!"-         n -> displaySuspendedStatus n+-- | Fail unless we already have some suspended patches.+-- Not essential, since all rebase commands should be happy to work+-- with an empty rebase state.+checkHasRebase :: Repository rt p wU wR -> IO ()+checkHasRebase repo =+  unless (formatHas RebaseInProgress_2_16 $ repoFormat repo) $+    fail "No rebase in progress. Try 'darcs rebase suspend' first." -displaySuspendedStatus :: Int -> IO ()-displaySuspendedStatus count =-  ePutDocLn $ hsep-    [ "Rebase in progress:"-    , text (show count)-    , "suspended"-    , text (englishNum count (Noun "patch") "")-    ]+-- | Report the rebase status if there is (still) a rebase in progress+-- after the command has finished running.+-- To be called via 'finally' for every 'RepoJob'.+displayRebaseStatus :: RepoPatch p => Repository rt p wU wR -> IO ()+displayRebaseStatus repo = do+  -- The repoLocation may be a remote URL (e.g. darcs log). We neither can nor+  -- want to display anything in that case.+  when (isValidLocalPath $ repoLocation repo) $ do+    -- Why do we use 'readRebase' and not 'readTentativeRebase' here?+    -- There are three cases:+    -- * We had no transaction in the first place.+    -- * We had a successful transaction: then it will be finalized before we+    --   are called (because finalization is part of the RepoJob itself) and+    --   we want to report the new finalized state.+    -- * We had a transaction that was cancelled or failed: then we want to+    --   report the old (unmodified) rebase state.+    -- Thus, in all cases 'readRebase' is the correct choice. However, if there+    -- is no rebase in progress, then 'rebasePath' may not exist, so we must+    -- handle that.+    suspended <- readRebase repo `catchDoesNotExistError` return (Items NilFL)+    case countToEdit suspended of+      0 -> return ()+      count ->+        ePutDocLn $ hsep+          [ "Rebase in progress:"+          , text (show count)+          , "suspended"+          , text (englishNum count (Noun "patch") "")+          ] --- | Generic status display for non-rebase commands.-maybeDisplaySuspendedStatus :: RepoPatch p-                            => SRebaseType rebaseType-                            -> Repository ('RepoType rebaseType) p wR wU wR-                            -> IO ()-maybeDisplaySuspendedStatus SIsRebase repo = do-  ps <- readTentativeRebase repo `catchIOError` \_ -> readRebase repo-  displaySuspendedStatus (countToEdit ps)-maybeDisplaySuspendedStatus SNoRebase _    = return ()+-- | Rebase format update for all commands that modify the repo,+-- except rebase upgrade. This is called by 'finalizeRepositoryChanges'.+updateRebaseFormat :: RepoPatch p => Repository 'RW p wU wR -> IO ()+updateRebaseFormat repo = do+  let rf = repoFormat repo+      hadRebase = formatHas RebaseInProgress_2_16 rf+  suspended <-+    readTentativeRebase repo `catchDoesNotExistError` return (Items NilFL)+  case countToEdit suspended of+    0 ->+      when hadRebase $ do+        void $ modifyRepoFormat (removeFromFormat RebaseInProgress_2_16) repo+        putStrLn "Rebase finished!"+    _ ->+      unless hadRebase $+        void $ modifyRepoFormat (addToFormat RebaseInProgress_2_16) repo  withTentativeRebase   :: RepoPatch p-  => Repository rt p wR wU wT-  -> Repository rt p wR wU wY-  -> (Suspended p wT wT -> Suspended p wY wY)+  => Repository rt p wU wR+  -> Repository rt p wU wR'+  -> (Suspended p wR -> Suspended p wR')   -> IO () withTentativeRebase r r' f =   readTentativeRebase r >>= writeTentativeRebase r' . f  readTentativeRebase :: RepoPatch p-                    => Repository rt p wR wU wT -> IO (Suspended p wT wT)+                    => Repository rt p wU wR -> IO (Suspended p wR) readTentativeRebase = readRebaseFile tentativeRebasePath  writeTentativeRebase :: RepoPatch p-                     => Repository rt p wR wU wT -> Suspended p wT wT -> IO ()+                     => Repository rt p wU wR -> Suspended p wR -> IO () writeTentativeRebase = writeRebaseFile tentativeRebasePath -readRebase :: RepoPatch p => Repository rt p wR wU wR -> IO (Suspended p wR wR)+readRebase :: RepoPatch p => Repository rt p wU wR -> IO (Suspended p wR) readRebase = readRebaseFile rebasePath -createTentativeRebase :: RepoPatch p => Repository rt p wR wU wR -> IO ()-createTentativeRebase r = writeRebaseFile tentativeRebasePath r (Items NilFL :: Suspended p wR wR)+createTentativeRebase :: RepoPatch p => Repository rt p wU wR -> IO ()+createTentativeRebase r = writeRebaseFile tentativeRebasePath r (Items NilFL) +revertTentativeRebase :: RepoPatch p => Repository rt p wU wR -> IO ()+revertTentativeRebase repo =+  copyFile rebasePath tentativeRebasePath+    `catchDoesNotExistError` createTentativeRebase repo++finalizeTentativeRebase :: IO ()+finalizeTentativeRebase = renameFile tentativeRebasePath rebasePath+ -- unsafe witnesses, not exported readRebaseFile :: RepoPatch p-               => FilePath -> Repository rt p wR wU wT -> IO (Suspended p wX wX)-readRebaseFile path r =-  withRepoLocation r $ do-    parsed <- readPatch <$> readBinFile path-    case parsed of-      Left e -> fail $ unlines ["parse error in file " ++ path, e]-      Right (Sealed sp) -> return (unsafeCoercePEnd sp)+               => FilePath -> Repository rt p wU wR -> IO (Suspended p wX)+readRebaseFile path r = do+  parsed <- parse readSuspended <$> readBinFile (repoLocation r </> path)+  case parsed of+    Left e -> fail $ unlines ["parse error in file " ++ path, e]+    Right (result, _) -> return result  -- unsafe witnesses, not exported writeRebaseFile :: RepoPatch p-                => FilePath -> Repository rt p wR wU wT-                -> Suspended p wX wX -> IO ()+                => FilePath -> Repository rt p wU wR+                -> Suspended p wR -> IO () writeRebaseFile path r sp =-  withRepoLocation r $-    writeDocBinFile path (showPatch ForStorage sp)+  writeDocBinFile (repoLocation r </> path) (showSuspended ForStorage sp) -type PiaW rt p = PatchInfoAndG rt (W.WrappedNamed rt p)+type PiaW p = PatchInfoAndG (W.WrappedNamed p) -commuteOutOldStyleRebase :: RepoPatch p-                         => RL (PiaW rt p) wA wB-                         -> Maybe ((RL (PiaW rt p) :> PiaW rt p) wA wB)-commuteOutOldStyleRebase NilRL = Nothing-commuteOutOldStyleRebase (ps :<: p)-  | W.RebaseP _ _ <- hopefully p = Just (ps :> p)-  | otherwise = do-      ps' :> r <- commuteOutOldStyleRebase ps-      case commute (r :> p) of-        Just (p' :> r') -> Just (ps' :<: p' :> r')-        Nothing ->-          error $ renderString $ "internal error: cannot commute rebase patch:"-            $$ displayPatch r-            $$ text "with normal patch:"-            $$ displayPatch p+extractOldStyleRebase :: forall p wA wB. RepoPatch p+                      => RL (PiaW p) wA wB+                      -> Maybe ((RL (PatchInfoAnd p) :> Dup (Suspended p)) wA wB)+extractOldStyleRebase ps = go (ps :> NilFL) where+  go :: (RL (PiaW p) :> FL (PatchInfoAnd p)) wA wB+     -> Maybe ((RL (PatchInfoAnd p) :> Dup (Suspended p)) wA wB)+  go (NilRL :> _) = Nothing+  go (xs :<: x :> ys)+    | W.RebaseP _ r <- hopefully x = do+      let xs' = mapRL_RL (fmapPIAP W.fromRebasing) xs+          rffs = foldlwFL (removeFixupsFromSuspended . hopefully) ys+      return ((xs' +<<+ ys) :> Dup (rffs r))+    | otherwise = go (xs :> fmapPIAP W.fromRebasing x :>: ys)
src/Darcs/Repository/Repair.hs view
@@ -7,138 +7,111 @@  import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO )-import Control.Exception ( catch, finally, IOException )-import Data.Maybe ( catMaybes )+import Control.Exception ( catch, IOException ) import Data.List ( sort, (\\) ) import System.Directory     ( createDirectoryIfMissing     , getCurrentDirectory-    , removeDirectoryRecursive     , setCurrentDirectory-    )-import System.FilePath ( (</>) )-import Darcs.Util.Path( anchorPath, AbsolutePath, ioAbsolute, toFilePath )-import Darcs.Patch.PatchInfoAnd-    ( PatchInfoAnd-    , WPatchInfo-    , compareWPatchInfo-    , hopefully-    , info-    , unWPatchInfo-    , winfo+    , withCurrentDirectory     ) -import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info ) import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), lengthFL, reverseFL,-    mapRL, nullFL, (:||:)(..) )-import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft )+    ( FL(..)+    , lengthFL+    , mapFL+    , nullFL+    , reverseFL+    , reverseRL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft, unseal ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Repair ( Repair(applyAndTryToFix) ) import Darcs.Patch.Info ( displayPatchInfo )-import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2FL, patchSet2RL )-import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, isInconsistent )+import Darcs.Patch.Set ( Origin, PatchSet(..), Tagged(..), patchSet2FL )+import Darcs.Patch ( RepoPatch, PrimOf, isInconsistent ) -import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) import Darcs.Repository.Diff( treeDiff )-import Darcs.Repository.Flags ( Verbosity(..), Compression, DiffAlgorithm )-import Darcs.Repository.Format-    ( identifyRepoFormat-    , RepoProperty ( HashedInventory )-    , formatHas-    )-import Darcs.Repository.HashedIO ( cleanHashdir )-import Darcs.Repository.Hashed ( readRepo, writeAndReadPatch )+import Darcs.Repository.Flags ( Verbosity(..), DiffAlgorithm )+import Darcs.Repository.Hashed ( readPatches, writeAndReadPatch ) import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation )+import Darcs.Repository.Paths ( pristineDirPath )+import Darcs.Repository.Pending ( readPending ) import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.Repository.Pristine ( readHashedPristineRoot ) import Darcs.Repository.State-    ( readRecorded+    ( readPristine     , readIndex-    , readRecordedAndPending+    , readPristineAndPending     ) +import Darcs.Util.Cache ( Cache, mkDirCache ) import Darcs.Util.Progress     ( beginTedious-    , debugMessage     , endTedious     , finishedOneIO     , tediousSize     )-import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Util.Exception ( catchall )-import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Lock( withDelayedDir )-import Darcs.Util.Printer ( Doc, putDocLn, text, renderString )--import Darcs.Util.Hash( Hash(NoHash), encodeBase16 )+import Darcs.Util.Path( anchorPath, toFilePath )+import Darcs.Util.Printer ( putDocLn, text, renderString )+import Darcs.Util.Hash( showHash ) import Darcs.Util.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees ) import Darcs.Util.Tree.Monad( TreeIO ) import Darcs.Util.Tree.Hashed( darcsUpdateHashes, hashedTreeIO ) import Darcs.Util.Tree.Plain( readPlainTree ) import Darcs.Util.Index( treeFromIndex ) -import qualified Data.ByteString.Char8 as BC--replaceInFL :: FL (PatchInfoAnd rt a) wX wY-            -> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]-            -> FL (PatchInfoAnd rt a) wX wY-replaceInFL orig [] = orig-replaceInFL NilFL _ = error "impossible case"-replaceInFL (o:>:orig) ch@(Sealed2 (o':||:c):ch_rest)-    | IsEq <- winfo o `compareWPatchInfo` o' = c:>:replaceInFL orig ch_rest-    | otherwise = o:>:replaceInFL orig ch--applyAndFix-  :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wT-  -> Compression-  -> FL (PatchInfoAnd rt p) Origin wR-  -> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)-applyAndFix _ _ NilFL = return (NilFL, True)-applyAndFix r compr psin =-    do liftIO $ beginTedious k-       liftIO $ tediousSize k $ lengthFL psin-       (repaired, ok) <- aaf psin-       liftIO $ endTedious k-       orig <- liftIO $ patchSet2FL `fmap` readRepo r-       return (replaceInFL orig repaired, ok)-    where k = "Replaying patch"-          aaf :: FL (PatchInfoAnd rt p) wW wZ-              -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)-          aaf NilFL = return ([], True)-          aaf (p:>:ps) = do-            mp' <- applyAndTryToFix p-            case isInconsistent . hopefully $ p of-              Just err -> liftIO $ putDocLn err-              Nothing -> return ()-            let !winfp = winfo p -- assure that 'p' can be garbage collected.-            liftIO $ finishedOneIO k $ renderString $-              displayPatchInfo $ unWPatchInfo winfp-            (ps', restok) <- aaf ps-            case mp' of-              Nothing -> return (ps', restok)-              Just (e,pp) -> liftIO $ do-                putStrLn e-                p' <- withCurrentDirectory (repoLocation r) $-                  writeAndReadPatch (repoCache r) compr pp-                return (Sealed2 (winfp :||: p'):ps', False)--data RepositoryConsistency rt p wX =-    RepositoryConsistent-  | BrokenPristine (Tree IO)-  | BrokenPatches (Tree IO) (PatchSet rt p Origin wX)+applyAndFixPatchSet+  :: forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)+  => Repository rt p wU wR+  -> PatchSet p Origin wR+  -> TreeIO (PatchSet p Origin wR, Bool)+applyAndFixPatchSet r s = do+    liftIO $ beginTedious k+    liftIO $ tediousSize k $ lengthFL $ patchSet2FL s+    result <- case s of+      PatchSet ts ps -> do+        (ts', ts_ok) <- applyAndFixTagged (reverseRL ts)+        (ps', ps_ok) <- applyAndFixPatches (reverseRL ps)+        return (PatchSet (reverseFL ts') (reverseFL ps'), ts_ok && ps_ok)+    liftIO $ endTedious k+    return result+  where+    k = "Replaying patch"+    applyAndFixTagged :: FL (Tagged p) wX wY -> TreeIO (FL (Tagged p) wX wY, Bool)+    applyAndFixTagged NilFL = return (NilFL, True)+    applyAndFixTagged (Tagged ps t _ :>: ts) = do+      (ps', ps_ok) <- applyAndFixPatches (reverseRL ps)+      (ts', ts_ok) <- applyAndFixTagged ts+      return (Tagged (reverseFL ps') t Nothing :>: ts', ps_ok && ts_ok)+    applyAndFixPatches+      :: FL (PatchInfoAnd p) wX wY -> TreeIO (FL (PatchInfoAnd p) wX wY, Bool)+    applyAndFixPatches NilFL = return (NilFL, True)+    applyAndFixPatches (p :>: ps) = do+      mp' <- applyAndTryToFix p+      case isInconsistent . hopefully $ p of+        Just err -> liftIO $ putDocLn err+        Nothing -> return ()+      liftIO $ finishedOneIO k $ renderString $ displayPatchInfo $ info p+      (ps', ps_ok) <- applyAndFixPatches ps+      case mp' of+        Nothing -> return (p :>: ps', ps_ok)+        Just (e, p') ->+          liftIO $ do+            putStrLn e+            -- FIXME While this is okay semantically, it means we can't+            -- run darcs check in a read-only repo+            p'' <-+              withCurrentDirectory (repoLocation r) $+              writeAndReadPatch (repoCache r) p'+            return (p'' :>: ps', False) -checkUniqueness :: (IsRepoType rt, RepoPatch p)-                => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO ()-checkUniqueness putVerbose putInfo repository =-    do putVerbose $ text "Checking that patch names are unique..."-       r <- readRepo repository-       case hasDuplicate $ mapRL info $ patchSet2RL r of-         Nothing -> return ()-         Just pinf -> do putInfo $ text "Error! Duplicate patch name:"-                         putInfo $ displayPatchInfo pinf-                         fail "Duplicate patches found."+data RepositoryConsistency p wR = RepositoryConsistency+  { fixedPristine :: Maybe (Tree IO, Sealed (FL (PrimOf p) wR))+  , fixedPatches :: Maybe (PatchSet p Origin wR)+  , fixedPending :: Maybe (Sealed (FL (PrimOf p) wR))+  }  hasDuplicate :: Ord a => [a] -> Maybe a hasDuplicate li = hd $ sort li@@ -148,66 +121,66 @@                         | otherwise = hd (x2:xs)  replayRepository'-  :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+  :: forall rt p wR wU. (RepoPatch p, ApplyState p ~ Tree)   => DiffAlgorithm-  -> AbsolutePath-  -> Repository rt p wR wU wT-  -> Compression+  -> Cache+  -> Repository rt p wU wR   -> Verbosity-  -> IO (RepositoryConsistency rt p wR)-replayRepository' dflag whereToReplay' repo compr verbosity = do-  let whereToReplay = toFilePath whereToReplay'-      putVerbose s = when (verbosity == Verbose) $ putDocLn s+  -> IO (RepositoryConsistency p wR)+replayRepository' dflag cache repo verbosity = do+  let putVerbose s = when (verbosity == Verbose) $ putDocLn s       putInfo s = unless (verbosity == Quiet) $ putDocLn s-  checkUniqueness putVerbose putInfo repo-  createDirectoryIfMissing False whereToReplay-  putVerbose $ text "Reading recorded state..."++  putVerbose $ text "Checking that patch names are unique..."+  patches <- readPatches repo+  case hasDuplicate $ mapFL info $ patchSet2FL patches of+    Nothing -> return ()+    Just pinf -> do+      putInfo $ text "Error! Duplicate patch name:"+      putInfo $ displayPatchInfo pinf+      -- FIXME repair duplicates by re-generating their salt+      fail "Duplicate patches found."++  -- we have to read pristine before fixing patches as that updates pristine   pris <--    (readRecorded repo >>= expand >>= darcsUpdateHashes)+    (readPristine repo >>= expand >>= darcsUpdateHashes)     `catch`     \(_ :: IOException) -> return emptyTree-  putVerbose $ text "Applying patches..."-  patches <- readRepo repo-  debugMessage "Fixing any broken patches..."-  let psin = patchSet2FL patches-      repair = applyAndFix repo compr psin -  ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree whereToReplay-  debugMessage "Done fixing broken patches..."-  let newpatches = PatchSet NilRL (reverseFL ps)+  putVerbose $ text "Checking content of recorded patches..."+  ((newpatches, patches_ok), newpris) <-+    hashedTreeIO (applyAndFixPatchSet repo patches) emptyTree cache -  debugMessage "Checking pristine against slurpy"+  putVerbose $ text "Checking pristine..."   ftf <- filetypeFunction-  is_same <- do Sealed diff <- unFreeLeft `fmap` treeDiff dflag ftf pris newpris-                  :: IO (Sealed (FL (PrimOf p) wR))-                return $ nullFL diff-              `catchall` return False-  -- TODO is the latter condition needed? Does a broken patch imply pristine-  -- difference? Why, or why not?-  return (if is_same && patches_ok-     then RepositoryConsistent-     else if patches_ok-            then BrokenPristine newpris-            else BrokenPatches newpris newpatches)+  pristine_diff <- unFreeLeft `fmap` treeDiff dflag ftf pris newpris+  let pristine_ok = unseal nullFL pristine_diff -cleanupRepositoryReplay :: Repository rt p wR wU wT -> IO ()-cleanupRepositoryReplay r = do-  let c = repoCache r-  rf <- identifyRepoFormat "."-  unless (formatHas HashedInventory rf) $-         removeDirectoryRecursive $ darcsdir ++ "/pristine.hashed"-  when (formatHas HashedInventory rf) $ do-       current <- readHashedPristineRoot r-       cleanHashdir c HashedPristineDir $ catMaybes [current]+  putVerbose $ text "Checking pending patch..."+  Sealed pend <- readPending repo+  maybe_newpend <- fst <$> hashedTreeIO (applyAndTryToFix pend) newpris cache+  (newpend, pending_ok) <- convertFixed pend maybe_newpend +  return $ RepositoryConsistency+    { fixedPristine = if pristine_ok then Nothing else Just (newpris, pristine_diff)+    , fixedPatches = if patches_ok then Nothing else Just newpatches+    , fixedPending = if pending_ok then Nothing else Just (Sealed newpend)+    }++  where+    convertFixed :: a -> Maybe (String, a) -> IO (a, Bool)+    convertFixed x Nothing = return (x, True)+    convertFixed _ (Just (e, x)) = do+      unless (verbosity == Quiet) $ putStrLn e+      return (x, False)+ replayRepositoryInTemp-  :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+  :: (RepoPatch p, ApplyState p ~ Tree)   => DiffAlgorithm-  -> Repository rt p wR wU wT-  -> Compression+  -> Repository rt p wU wR   -> Verbosity-  -> IO (RepositoryConsistency rt p wR)-replayRepositoryInTemp dflag r compr verb = do+  -> IO (RepositoryConsistency p wR)+replayRepositoryInTemp dflag r verb = do   repodir <- getCurrentDirectory   {- The reason we use withDelayedDir here, instead of withTempDir, is that   replayRepository' may return a new pristine that is read from the @@ -219,32 +192,28 @@   -}   withDelayedDir "darcs-check" $ \tmpDir -> do     setCurrentDirectory repodir-    replayRepository' dflag tmpDir r compr verb+    replayRepository' dflag (mkDirCache (toFilePath tmpDir)) r verb  replayRepository-  :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+  :: (RepoPatch p, ApplyState p ~ Tree)   => DiffAlgorithm-  -> Repository rt p wR wU wT-  -> Compression+  -> Repository rt p wU wR   -> Verbosity-  -> (RepositoryConsistency rt p wR -> IO a)+  -> (RepositoryConsistency p wR -> IO a)   -> IO a-replayRepository dflag r compr verb f =-  run `finally` cleanupRepositoryReplay r-    where run = do-            createDirectoryIfMissing False $ darcsdir </> "pristine.hashed"-            hashedPristine <- ioAbsolute $ darcsdir </> "pristine.hashed"-            st <- replayRepository' dflag hashedPristine r compr verb-            f st+replayRepository dflag r verb job = do+  createDirectoryIfMissing False pristineDirPath+  st <- replayRepository' dflag (repoCache r) r verb+  job st  checkIndex   :: (RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wR+  => Repository rt p wU wR   -> Bool   -> IO Bool checkIndex repo quiet = do   index <- treeFromIndex =<< readIndex repo-  pristine <- expand =<< readRecordedAndPending repo+  pristine <- expand =<< readPristineAndPending repo   working <- expand =<< restrict pristine <$> readPlainTree "."   working_hashed <- darcsUpdateHashes working   let index_paths = [ p | (p, _) <- list index ]@@ -252,16 +221,16 @@       index_extra = index_paths \\ working_paths       working_extra = working_paths \\ index_paths       gethashes p (Just i1) (Just i2) = (p, itemHash i1, itemHash i2)-      gethashes p (Just i1) Nothing   = (p, itemHash i1, NoHash)-      gethashes p   Nothing (Just i2) = (p,      NoHash, itemHash i2)+      gethashes p (Just i1) Nothing   = (p, itemHash i1, Nothing)+      gethashes p   Nothing (Just i2) = (p,     Nothing, itemHash i2)       gethashes p   Nothing Nothing   = error $ "Bad case at " ++ show p       mismatches =         [miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2]        format paths = unlines $ map (("  " ++) . anchorPath "") paths       mismatches_disp = unlines [ anchorPath "" p ++-                                    "\n    index: " ++ BC.unpack (encodeBase16 h1) ++-                                    "\n  working: " ++ BC.unpack (encodeBase16 h2)+                                    "\n    index: " ++ showHash h1 +++                                    "\n  working: " ++ showHash h2                                   | (p, h1, h2) <- mismatches ]   unless (quiet || null index_extra) $          putStrLn $ "Extra items in index!\n" ++ format index_extra
src/Darcs/Repository/Resolution.hs view
@@ -16,6 +16,7 @@ --  Boston, MA 02110-1301, USA. module Darcs.Repository.Resolution     ( standardResolution+    , rebaseResolution     , externalResolution     , patchsetConflictResolutions     , StandardResolution(..)@@ -37,18 +38,18 @@  import Darcs.Repository.Diff( treeDiff ) import Darcs.Patch-    ( PrimOf-    , PrimPatchBase+    ( Named+    , PrimOf     , RepoPatch     , applyToTree     , effect     , effectOnPaths     , invert     , listConflictedFiles+    , patchcontents     , resolveConflicts     ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Conflict ( Conflict, ConflictDetails(..), Mangled, Unravelled ) import Darcs.Patch.Inspect ( listTouchedFiles ) import Darcs.Patch.Merge ( mergeList )@@ -60,20 +61,20 @@     , filterPaths     , toFilePath     )-import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), concatRLFL, mapRL_RL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, unFreeLeft )  import Darcs.Util.CommandLine ( parseCmd )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) import Darcs.Util.Prompt ( askEnter ) import Darcs.Patch.Set ( PatchSet(..), Origin, patchSet2RL ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Util.Exec ( exec, Redirect(..) ) import Darcs.Util.Lock ( withTempDir )-import Darcs.Util.External ( cloneTree )+import Darcs.Util.File ( copyTree ) import Darcs.Repository.Flags     ( AllowConflicts (..)-    , ExternalMerge (..)+    , ResolveConflicts (..)     , WantGuiPause (..)     , DiffAlgorithm (..)     )@@ -93,11 +94,29 @@     conflictedPaths :: [AnchoredPath]   } -standardResolution :: (Commute p, PrimPatchBase p, Conflict p)-                   => RL (PatchInfoAnd rt p) wO wX-                   -> RL (PatchInfoAnd rt p) wX wY+standardResolution :: (RepoPatch p)+                   => RL (PatchInfoAnd p) wO wX+                   -> RL (PatchInfoAnd p) wX wY                    -> StandardResolution (PrimOf p) wY standardResolution context interesting =+  mangleConflicts $ resolveConflicts context interesting++-- | Like 'standardResolution' but it doesn't use the @instance (Named p)@+-- because the traling list of patches may contain "fake" conflictors.+rebaseResolution+  :: (Conflict p, PrimPatch (PrimOf p))+  => RL (PatchInfoAnd p) wO wX+  -> RL (Named p) wX wY+  -> StandardResolution (PrimOf p) wY+rebaseResolution context interesting =+    mangleConflicts $ resolveConflicts context_patches interesting_patches+  where+    context_patches = concatRLFL (mapRL_RL (patchcontents . hopefully) context)+    interesting_patches = concatRLFL (mapRL_RL patchcontents interesting)++mangleConflicts+  :: (PrimPatch prim) => [ConflictDetails prim wX] -> StandardResolution prim wX+mangleConflicts conflicts =   case mergeList $ catMaybes $ map conflictMangled conflicts of     Right mangled -> StandardResolution {..}     Left (Sealed ps, Sealed qs) ->@@ -107,23 +126,27 @@         $$ redText "conflicts with"         $$ displayPatch qs   where-    conflicts = resolveConflicts context interesting     unmangled = map conflictParts $ filter (isNothing . conflictMangled) conflicts     conflictedPaths =       nubSort $       concatMap (unseal listTouchedFiles) (concatMap conflictParts conflicts) -warnUnmangled :: PrimPatch prim => StandardResolution prim wX -> IO ()-warnUnmangled StandardResolution {..}+warnUnmangled+  :: PrimPatch prim => Maybe [AnchoredPath] -> StandardResolution prim wX -> IO ()+warnUnmangled mpaths StandardResolution {..}   | null unmangled = return ()-  | otherwise = ePutDocLn $ showUnmangled unmangled+  | otherwise = ePutDocLn $ showUnmangled mpaths unmangled -showUnmangled :: PrimPatch prim => [Unravelled prim wX] -> Doc-showUnmangled = vcat . map showUnmangledConflict+showUnmangled+  :: PrimPatch prim => Maybe [AnchoredPath] -> [Unravelled prim wX] -> Doc+showUnmangled mpaths = vcat . map showUnmangledConflict . filter (affected mpaths)   where     showUnmangledConflict unravelled =       redText "Cannot mark these conflicting patches:" $$       showUnravelled (redText "versus") unravelled+    affected Nothing _ = True+    affected (Just paths) unravelled =+      any (`elem` paths) $ concatMap (unseal listTouchedFiles) unravelled  showUnravelled :: PrimPatch prim => Doc -> Unravelled prim wX -> Doc showUnravelled sep =@@ -132,26 +155,27 @@ announceConflicts :: PrimPatch prim                   => String                   -> AllowConflicts-                  -> ExternalMerge                   -> StandardResolution prim wX                   -> IO Bool-announceConflicts cmd allowConflicts externalMerge conflicts =+announceConflicts cmd allowConflicts conflicts =   case nubSort (conflictedPaths conflicts) of     [] -> return False     cfs -> do       ePutDocLn $ vcat $ redText         "We have conflicts in the following files:" : map (text . displayPath) cfs-      when (allowConflicts == YesAllowConflictsAndMark) $ warnUnmangled conflicts-      if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark]-              || externalMerge /= NoExternalMerge-        then return True-        else fail $+      case allowConflicts of+        NoAllowConflicts ->+          fail $           "Refusing to "++cmd++" patches leading to conflicts.\n"++           "If you would rather apply the patch and mark the conflicts,\n"++           "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++           "These can set as defaults by adding\n"++           " "++cmd++" mark-conflicts\n"++           "to "++darcsdir++"/prefs/defaults in the target repo. "+        YesAllowConflicts MarkConflicts -> do+          warnUnmangled Nothing conflicts+          return True+        _ -> return True  externalResolution :: forall p wX wY wZ wA. (RepoPatch p, ApplyState p ~ Tree.Tree)                    => DiffAlgorithm@@ -160,15 +184,15 @@                    -> WantGuiPause        -- ^ tell whether we want GUI pause                    -> FL (PrimOf p) wX wY -- ^ our effect                    -> FL (PrimOf p) wX wZ -- ^ their effect-                   -> FL p wY wA          -- ^ them merged (standard_resolution)+                   -> FL p wY wA          -- ^ them merged                    -> IO (Sealed (FL (PrimOf p) wA)) externalResolution diffa s1 c wantGuiPause p1 p2 pmerged = do  sa <- applyToTree (invert p1) s1  sm <- applyToTree pmerged s1  s2 <- applyToTree p2 sa  let nms = listConflictedFiles pmerged-     nas = effectOnPaths (invert (effect pmerged)) nms-     n1s = effectOnPaths p1 nas+     n1s = effectOnPaths (invert (effect pmerged)) nms+     nas = effectOnPaths (invert p1) n1s      n2s = effectOnPaths p2 nas      ns = zip4 (tofp nas) (tofp n1s) (tofp n2s) (tofp nms)      tofp = map (anchorPath "")@@ -189,7 +213,7 @@          setCurrentDirectory former_dir          withTempDir "cleanmerged" $ \absdc -> do            let dc = toFilePath absdc-           cloneTree dm "."+           copyTree dm "."            setCurrentDirectory former_dir            withTempDir "version2" $ \absd2 -> do              let d2 = toFilePath absd2@@ -212,7 +236,7 @@     putStrLn $ "Merging file "++fm++" by hand."     ec <- run c [('1', d1</>f1), ('2', d2</>f2), ('a', da</>fa), ('o', dm</>fm), ('%', "%")]     when (ec /= ExitSuccess) $-         putStrLn $ "External merge command exited with " ++ show ec+         fail $ "External merge command exited with " ++ show ec     when (wantGuiPause == YesWantGuiPause) $         askEnter "Hit return to move on, ^C to abort the whole operation..." @@ -223,11 +247,11 @@     Right (c2,_) -> rr c2     where rr (command:args) = do putStrLn $ "Running command '" ++                                             unwords (command:args) ++ "'"-                                 exec command args (Null,Null,Null)+                                 exec command args (Null,AsIs,AsIs)           rr [] = return ExitSuccess  patchsetConflictResolutions :: RepoPatch p-                            => PatchSet rt p Origin wX+                            => PatchSet p Origin wX                             -> StandardResolution (PrimOf p) wX patchsetConflictResolutions (PatchSet ts xs) =   -- optimization: all patches before the latest known clean tag
src/Darcs/Repository/State.hs view
@@ -27,14 +27,14 @@     -- * Diffs     , unrecordedChanges     -- * Trees-    , readRecorded, readUnrecorded, readRecordedAndPending, readWorking+    , readPristine, readUnrecorded, readPristineAndPending, readWorking     , readPendingAndWorking, readUnrecordedFiltered     -- * Index-    , readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..)+    , readIndex, updateIndex     -- * Utilities     , filterOutConflicts     -- * Pending-related functions that depend on repo state-    , addPendingDiffToPending, addToPending+    , unsafeAddToPending, addToPending     ) where  import Darcs.Prelude@@ -45,25 +45,21 @@ import Data.Ord ( comparing ) import Data.List ( sortBy, union, delete ) -import System.Directory( doesFileExist, doesDirectoryExist, renameFile )-import System.FilePath ( (<.>), (</>) )-import System.IO ( hPutStrLn, stderr )-import System.IO.Error ( catchIOError )+import System.Directory( doesFileExist, renameFile )+import System.FilePath ( (<.>) ) -import qualified Data.ByteString as B-    ( ByteString, readFile, writeFile, empty, concat )-import qualified Data.ByteString.Char8 as BC-    ( pack, unpack )+import qualified Data.ByteString as B ( ByteString, concat )+import qualified Data.ByteString.Char8 as BC ( pack, unpack ) import qualified Data.ByteString.Lazy as BL ( toChunks ) -import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL+import Darcs.Patch ( RepoPatch, PrimOf, canonizeFL                    , PrimPatch, maybeApplyToTree                    , tokreplace, forceTokReplace, move ) import Darcs.Patch.Named ( anonymous ) import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnPaths )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+)+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), consGapFL                                      , (:>)(..), reverseRL, reverseFL-                                     , mapFL, concatFL, toFL, nullFL )+                                     , mapFL, concatFL, joinGapsFL, nullFL ) import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal@@ -74,22 +70,27 @@ import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.TokenReplace ( breakToTokens, defaultToks ) -import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..)-                              , UpdatePending(..), LookForMoves(..), LookForReplaces(..) )--import Darcs.Repository.InternalTypes ( Repository, repoFormat, repoLocation )+import Darcs.Repository.Flags+    ( DiffAlgorithm(..)+    , LookForMoves(..)+    , LookForReplaces(..)+    , LookForAdds(..)+    , UseIndex(..)+    , DiffOpts(..)+    )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , Repository+    , repoFormat+    , repoLocation+    ) import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir)) import qualified Darcs.Repository.Pending as Pending import Darcs.Repository.Prefs ( filetypeFunction, isBoring )+import Darcs.Repository.Pristine ( readPristine ) import Darcs.Repository.Diff ( treeDiff )-import Darcs.Repository.Inventory ( peekPristineHash, getValidHash ) import Darcs.Repository.Paths-    ( pristineDirPath-    , hashedInventoryPath-    , oldPristineDirPath-    , oldCurrentDirPath-    , patchesDirPath-    , indexPath+    ( indexPath     , indexInvalidPath     ) @@ -103,13 +104,10 @@     , parents     , movedirfilename     )-import Darcs.Util.Hash( Hash( NoHash ) ) import Darcs.Util.Tree( Tree, restrict, FilterTree, expand, emptyTree, overlay, find                       , ItemType(..), itemType, readBlob, modifyTree, findFile, TreeItem(..)                       , makeBlobBS, expandPath ) import qualified Darcs.Util.Tree.Plain as PlainTree ( readPlainTree )-import Darcs.Util.Tree.Hashed-    ( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize ) import Darcs.Util.Index     ( Index     , indexFormatValid@@ -126,6 +124,9 @@ import Control.Monad ( unless ) import Darcs.Util.Path ( displayPath ) import Darcs.Util.Tree ( list )+#else+import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( catchIOError ) #endif  newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m }@@ -135,7 +136,7 @@ -- constructed filter will take pending into account, so the subpaths will be -- translated correctly relative to pending move patches. restrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree)-                 => Repository rt p wR wU wT -> [AnchoredPath]+                 => Repository rt p wU wR -> [AnchoredPath]                  -> IO (TreeFilter m) restrictSubpaths repo paths = do   Sealed pending <- Pending.readPending repo@@ -146,7 +147,7 @@ -- abiguous typing of @p@. restrictSubpathsAfter :: (RepoPatch p, ApplyState p ~ Tree)                       => FL (PrimOf p) wR wP-                      -> Repository rt p wR wU wT+                      -> Repository rt p wU wR                       -> [AnchoredPath]                       -> IO (TreeFilter m) restrictSubpathsAfter pending _repo paths = do@@ -158,7 +159,7 @@ -- note we assume pending starts at the recorded state maybeRestrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree)                       => FL (PrimOf p) wR wP-                      -> Repository rt p wR wU wT+                      -> Repository rt p wU wR                       -> Maybe [AnchoredPath]                       -> IO (TreeFilter m) maybeRestrictSubpaths pending repo =@@ -173,12 +174,14 @@ restrictBoring :: Tree m -> IO (TreeFilter m) restrictBoring guide = do   boring <- isBoring-  let exclude p = inDarcsdir p || boring (realPath p)+  let exclude p t = inDarcsdir p || boring (appendSlash t (realPath p))+      appendSlash TreeType fp = fp ++ "/"+      appendSlash BlobType fp = fp       restrictTree :: FilterTree t m => t m -> t m       restrictTree =-        Tree.filter $ \p _ ->+        Tree.filter $ \p i ->           case find guide p of-            Nothing -> not (exclude p)+            Nothing -> not (exclude p (itemType i))             _ -> True   return (TreeFilter restrictTree) @@ -223,38 +226,34 @@   replaces, since this implies that the index is out of date. -} unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree)-                  => (UseIndex, ScanKnown, DiffAlgorithm)-                  -> LookForMoves-                  -> LookForReplaces-                  -> Repository rt p wR wU wR+                  => DiffOpts+                  -> Repository rt p wU wR                   -> Maybe [AnchoredPath] -> IO (FL (PrimOf p) wR wU)-unrecordedChanges dopts lfm lfr r paths = do-  (pending :> working) <- readPendingAndWorking dopts lfm lfr r paths-  return $ sortCoalesceFL (pending +>+ working)+unrecordedChanges dopts@DiffOpts{..} r paths = do+  (pending :> working) <- readPendingAndWorking dopts r paths+  return $ canonizeFL diffAlg (pending +>+ working)  -- Implementation note: it is important to do things in the right order: we -- first have to read the pending patch, then detect moves, then detect adds, -- then detect replaces. readPendingAndWorking :: (RepoPatch p, ApplyState p ~ Tree)-                      => (UseIndex, ScanKnown, DiffAlgorithm)-                      -> LookForMoves-                      -> LookForReplaces-                      -> Repository rt p wR wU wR+                      => DiffOpts+                      -> Repository rt p wU wR                       -> Maybe [AnchoredPath]                       -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wR wU)-readPendingAndWorking _ _ _ r _ | formatHas NoWorkingDir (repoFormat r) = do+readPendingAndWorking _ r _ | formatHas NoWorkingDir (repoFormat r) = do   IsEq <- return $ workDirLessRepoWitness r   return (NilFL :> NilFL)-readPendingAndWorking (useidx, scan, diffalg) lfm lfr repo mbpaths = do+readPendingAndWorking DiffOpts{..} repo mbpaths = do   debugMessage "readPendingAndWorking: start"   (pending_tree, working_tree, (pending :> moves)) <--    readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths+    readPendingAndMovesAndUnrecorded repo withIndex lookForAdds lookForMoves mbpaths   debugMessage "readPendingAndWorking: after readPendingAndMovesAndUnrecorded"   (pending_tree_with_replaces, Sealed replaces) <--    getReplaces lfr diffalg repo pending_tree working_tree+    getReplaces lookForReplaces diffAlg repo pending_tree working_tree   debugMessage "readPendingAndWorking: after getReplaces"   ft <- filetypeFunction-  wrapped_diff <- treeDiff diffalg ft pending_tree_with_replaces working_tree+  wrapped_diff <- treeDiff diffAlg ft pending_tree_with_replaces working_tree   case unFreeLeft wrapped_diff of     Sealed diff -> do       debugMessage "readPendingAndWorking: done"@@ -262,14 +261,14 @@  readPendingAndMovesAndUnrecorded   :: (RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wR+  => Repository rt p wU wR   -> UseIndex-  -> ScanKnown+  -> LookForAdds   -> LookForMoves   -> Maybe [AnchoredPath]   -> IO ( Tree IO             -- pristine with (pending + moves)         , Tree IO             -- working-        , (FL (PrimOf p) :> FL (PrimOf p)) wR wU -- pending :> moves+        , (FL (PrimOf p) :> FL (PrimOf p)) wR wM -- pending :> moves         ) readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths = do   debugMessage "readPendingAndMovesAndUnrecorded: start"@@ -295,70 +294,50 @@   return     (pending_tree_with_moves, working_tree, unsafeCoercePEnd (pending :> moves)) --- | @filteredWorking useidx scan relevant index pending_tree@ reads the+-- | @filteredWorking useidx scan relevant from_index pending_tree@ reads the -- working tree and filters it according to options and @relevant@ file paths. -- The @pending_tree@ is understood to have @relevant@ already applied and is--- used (only) if @useidx == 'IgnoreIndex'@ and @scan /= 'ScanBoring'@ to act as+-- used (only) if @useidx == 'IgnoreIndex'@ and @scan /= 'EvenLookForBoring'@ to act as -- a guide for filtering the working tree.-filteredWorking :: Repository rt p wR wU wR+filteredWorking :: Repository rt p wU wR                 -> UseIndex-                -> ScanKnown+                -> LookForAdds                 -> TreeFilter IO                 -> Tree IO                 -> Tree IO                 -> IO (Tree IO)-filteredWorking repo useidx scan relevant index pending_tree =-  applyTreeFilter restrictDarcsdir <$> applyTreeFilter relevant <$> do+filteredWorking repo useidx scan relevant from_index pending_tree =+  applyTreeFilter restrictDarcsdir <$> applyTreeFilter relevant <$>     case useidx of       UseIndex ->         case scan of-          ScanKnown -> return index-          ScanAll -> do-            nonboring <- restrictBoring index+          NoLookForAdds -> return from_index+          YesLookForAdds -> do+            nonboring <- restrictBoring from_index             plain <- applyTreeFilter nonboring <$> readPlainTree repo-            return $ plain `overlay` index-          ScanBoring -> do+            return $ plain `overlay` from_index+          EvenLookForBoring -> do             plain <- readPlainTree repo-            return $ plain `overlay` index-      IgnoreIndex ->+            return $ plain `overlay` from_index+      IgnoreIndex -> do+        working <- readPlainTree repo         case scan of-          ScanKnown -> do+          NoLookForAdds -> do             guide <- expand pending_tree-            restrict guide <$> readPlainTree repo-          ScanAll -> do+            return $ restrict guide working+          YesLookForAdds -> do             guide <- expand pending_tree             nonboring <- restrictBoring guide-            applyTreeFilter nonboring <$> readPlainTree repo-          ScanBoring -> readPlainTree repo+            return $ applyTreeFilter nonboring working+          EvenLookForBoring -> return working --- | Witnesses the fact that in the absence of a working tree, we--- pretend that the working dir updates magically to the tentative state.-workDirLessRepoWitness :: Repository rt p wR wU wT -> EqCheck wU wT+-- | Witnesses the fact that in the absence of a working tree, the+-- unrecorded state cannot differ from the record state.+workDirLessRepoWitness :: Repository rt p wU wR -> EqCheck wU wR workDirLessRepoWitness r  | formatHas NoWorkingDir (repoFormat r) = unsafeCoerceP IsEq  | otherwise                             = NotEq --- | Obtains a Tree corresponding to the "recorded" state of the repository:--- this is the same as the pristine cache, which is the same as the result of--- applying all the repository's patches to an empty directory.-readRecorded :: Repository rt p wR wU wT -> IO (Tree IO)-readRecorded _repo = do-  hashed <- doesFileExist hashedInventoryPath-  if hashed-     then do inv <- B.readFile hashedInventoryPath-             let pris = peekPristineHash inv-                 hash = decodeDarcsHash $ BC.pack $ getValidHash pris-                 size = decodeDarcsSize $ BC.pack $ getValidHash pris-             when (hash == NoHash) $-                 fail $ "Bad pristine root: " ++ getValidHash pris-             readDarcsHashed pristineDirPath (size, hash)-     else do have_pristine <- doesDirectoryExist $ oldPristineDirPath-             have_current <- doesDirectoryExist $ oldCurrentDirPath-             case (have_pristine, have_current) of-               (True, _) -> PlainTree.readPlainTree $ oldPristineDirPath-               (False, True) -> PlainTree.readPlainTree $ oldCurrentDirPath-               (_, _) -> fail "No pristine tree is available!"- -- | Obtains a Tree corresponding to the "unrecorded" state of the repository: -- the modified files of the working tree plus the "pending" patch. -- The optional list of paths allows to restrict the query to a subtree.@@ -367,20 +346,20 @@ -- parts of the index do not need to go through an up-to-date check (which -- involves a relatively expensive lstat(2) per file. readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree)-               => Repository rt p wR wU wR+               => Repository rt p wU wR                -> UseIndex                -> Maybe [AnchoredPath]                -> IO (Tree IO) readUnrecorded repo useidx mbpaths = do #if TEST_INDEX-  t1 <- expand =<< readUnrecordedFiltered repo useidx ScanKnown NoLookForMoves mbpaths+  t1 <- expand =<< readUnrecordedFiltered repo useidx NoLookForAdds NoLookForMoves mbpaths   (pending_tree, Sealed pending) <- readPending repo   relevant <- maybeRestrictSubpaths pending repo mbpaths   t2 <- readIndexOrPlainTree repo useidx relevant pending_tree   assertEqualTrees "indirect" t1 "direct" t2   return t1 #else-  expand =<< readUnrecordedFiltered repo useidx ScanKnown NoLookForMoves mbpaths+  expand =<< readUnrecordedFiltered repo useidx NoLookForAdds NoLookForMoves mbpaths #endif  #if TEST_INDEX@@ -397,7 +376,7 @@ #endif  readIndexOrPlainTree :: (ApplyState p ~ Tree, RepoPatch p)-                     => Repository rt p wR wU wR+                     => Repository rt p wU wR                      -> UseIndex                      -> TreeFilter IO                      -> Tree IO@@ -425,14 +404,14 @@   expand =<< applyTreeFilter treeFilter . restrict guide <$> readPlainTree repo #endif --- | A variant of 'readUnrecorded' that takes the UseIndex and ScanKnown+-- | A variant of 'readUnrecorded' that takes the UseIndex and LookForAdds -- options into account, similar to 'readPendingAndWorking'. We are only -- interested in the resulting tree, not the patch, so the 'DiffAlgorithm' option -- is irrelevant. readUnrecordedFiltered :: (RepoPatch p, ApplyState p ~ Tree)-                       => Repository rt p wR wU wR+                       => Repository rt p wU wR                        -> UseIndex-                       -> ScanKnown+                       -> LookForAdds                        -> LookForMoves                        -> Maybe [AnchoredPath] -> IO (Tree IO) readUnrecordedFiltered repo useidx scan lfm mbpaths = do@@ -448,60 +427,55 @@    PlainTree.readPlainTree ".")  -- | Obtains the recorded 'Tree' with the pending patch applied.-readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree)-                       => Repository rt p wR wU wR -> IO (Tree IO)-readRecordedAndPending repo = fst `fmap` readPending repo+readPristineAndPending :: (RepoPatch p, ApplyState p ~ Tree)+                       => Repository rt p wU wR -> IO (Tree IO)+readPristineAndPending repo = fst `fmap` readPending repo  -- | Obtains the recorded 'Tree' with the pending patch applied, plus --   the pending patch itself. The pending patch should start at the --   recorded state (we even verify that it applies, and degrade to --   renaming pending and starting afresh if it doesn't). readPending :: (RepoPatch p, ApplyState p ~ Tree)-            => Repository rt p wR wU wR+            => Repository rt p wU wR             -> IO (Tree IO, Sealed (FL (PrimOf p) wR)) readPending repo = do-  pristine <- readRecorded repo+  pristine <- readPristine repo   Sealed pending <- Pending.readPending repo-  catch ((\t -> (t, seal pending)) <$> applyToTree pending pristine) $-    \(err :: IOException) -> do-       putStrLn $ "Yikes, pending has conflicts! " ++ show err-       putStrLn "Stashing the buggy pending as _darcs/patches/pending_buggy"-       renameFile (patchesDirPath </> "pending")-                  (patchesDirPath </> "pending_buggy")-       return (pristine, seal NilFL)---- | Mark the existing index as invalid. This has to be called whenever the--- listing of pristine+pending changes and will cause darcs to update the index.--- This will happen either when we call updateIndex in finalizeRepositoryChanges--- or else when we try to read the index the next time.--- (NB. This is about files added and removed from--- pristine: changes to file content in either pristine or working are handled--- transparently by the index reading code.)-invalidateIndex :: t -> IO ()-invalidateIndex _ = B.writeFile indexInvalidPath B.empty+  catch ((\t -> (t, seal pending)) <$> applyToTree pending pristine) $ \(e::IOException) -> do+    fail $+      "Cannot apply pending patch, please run `darcs repair`\n"+      ++ show e +-- | Open the index or re-create it in case it is invalid or non-existing. readIndex :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository rt p wR wU wR -> IO Index+          => Repository rt p wU wR -> IO Index readIndex repo = do   okay <- checkIndex   if not okay     then internalUpdateIndex repo-    else openIndex indexPath darcsTreeHash+    else openIndex indexPath  -- | Update the index so that it matches pristine+pending. If the index does -- not exist or is invalid, create a new one. Returns the updated index. internalUpdateIndex :: (RepoPatch p, ApplyState p ~ Tree)-            => Repository rt p wR wU wR -> IO Index+            => Repository rt p wU wR -> IO Index internalUpdateIndex repo = do-  pris <- readRecordedAndPending repo-  idx <- updateIndexFrom indexPath darcsTreeHash pris+  pris <-+    readPristineAndPending repo+    `catch` \(_::IOException) -> readPristine repo+  idx <- updateIndexFrom indexPath pris   removeFileMayNotExist indexInvalidPath   return idx  -- | Update the index so that it matches pristine+pending. If the index does -- not exist or is invalid, create a new one.+--+-- This has to be called whenever the listing of pristine+pending changes. Note+-- that this only concerns files added and removed or renamed: changes to file+-- content in either pristine or working are handled transparently by the index+-- reading code. updateIndex :: (RepoPatch p, ApplyState p ~ Tree)-            => Repository rt p wR wU wR -> IO ()+            => Repository rt p wU wR -> IO () updateIndex repo = do   -- call checkIndex to throw away the index if it is invalid;   -- this can happen if we are called with --ignore-times@@ -510,8 +484,9 @@   void $ internalUpdateIndex repo  -- | Check if we have a valid index. This means that the index file exists, is--- readable, and can be mmapped, /and/ that indexInvalidPath does /not/ exist.--- We do not yet remove indexInvalidPath in case updating the index fails.+-- readable, and can be mmapped. For compatibility with older darcs versions we+-- also check that indexInvalidPath does not exist. We do not yet remove+-- indexInvalidPath in case updating the index fails. checkIndex :: IO Bool checkIndex = do   invalid <- doesFileExist $ indexInvalidPath@@ -526,19 +501,22 @@ -- conflict with the recorded or unrecorded changes in a repo filterOutConflicts   :: (RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wR     -- ^Repository itself, used for grabbing+  => Repository rt p wU wR     -- ^Repository itself, used for grabbing                                   --  unrecorded changes-  -> FL (PatchInfoAnd rt p) wX wR -- ^Recorded patches from repository, starting from+  -> UseIndex                     -- ^Whether to use the index when reading+                                  --  the working state+  -> FL (PatchInfoAnd p) wX wR -- ^Recorded patches from repository, starting from                                   --  same context as the patches to filter-  -> FL (PatchInfoAnd rt p) wX wZ -- ^Patches to filter-  -> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX))+  -> FL (PatchInfoAnd p) wX wZ -- ^Patches to filter+  -> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))                                   -- ^True iff any patches were removed,                                   --  possibly filtered patches-filterOutConflicts repository us them+filterOutConflicts repository useidx us them      = do -- Note: use of anonymous is benign here since we only try to merge cleanly           unrec <- fmap n2pia . anonymous-                     =<< unrecordedChanges (UseIndex, ScanKnown, MyersDiff)-                          NoLookForMoves NoLookForReplaces repository Nothing+                     =<< unrecordedChanges+                          (DiffOpts useidx NoLookForAdds NoLookForReplaces+                          NoLookForMoves MyersDiff) repository Nothing           them' :> rest <-             return $ partitionConflictingFL them (us +>+ unrec :>: NilFL)           return (check rest, Sealed them')@@ -548,10 +526,10 @@  -- | Automatically detect file moves using the index. -- TODO: This function lies about the witnesses.-getMoves :: forall rt p wR wU wB prim.+getMoves :: forall rt p wU wR wB prim.             (RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p)          => LookForMoves-         -> Repository rt p wR wU wR+         -> Repository rt p wU wR          -> Maybe [AnchoredPath]          -> IO (FL prim wB wB) getMoves NoLookForMoves _ _ = return NilFL@@ -561,7 +539,7 @@     mkMovesFL [] = NilFL     mkMovesFL ((a,b,_):xs) = move a b :>: mkMovesFL xs -    getMovedFiles :: Repository rt p wR wU wR+    getMovedFiles :: Repository rt p wU wR                   -> Maybe [AnchoredPath]                   -> IO [(AnchoredPath, AnchoredPath, ItemType)]     getMovedFiles repo fs = do@@ -635,11 +613,11 @@ -- | Search for possible replaces between the recordedAndPending state -- and the unrecorded (or working) state. Return a Sealed FL list of -- replace patches to be applied to the recordedAndPending state.-getReplaces :: forall rt p wR wU wT+getReplaces :: forall rt p wU wR              . (RepoPatch p, ApplyState p ~ Tree)             => LookForReplaces             -> DiffAlgorithm-            -> Repository rt p wR wU wT+            -> Repository rt p wU wR             -> Tree IO -- ^ pending tree (including possibly detected moves)             -> Tree IO -- ^ working tree             -> IO (Tree IO, -- new pending tree@@ -654,7 +632,7 @@       flip runStateT pending $         forM replaces $ \(path, a, b) ->           doReplace defaultToks path (BC.unpack a) (BC.unpack b)-    return (new_pending, mapSeal concatFL $ toFL patches)+    return (new_pending, mapSeal concatFL $ unFreeLeft $ joinGapsFL patches)   where     modifiedTokens :: PrimOf p wX wY -> [(AnchoredPath, B.ByteString, B.ByteString)]     modifiedTokens p = case isHunk p of@@ -681,7 +659,7 @@           Nothing -> getForceReplace path toks old new           Just pend' -> do             put pend'-            return $ joinGap (:>:) (freeGap replacePatch) (emptyGap NilFL)+            return $ consGapFL replacePatch (emptyGap NilFL)       where         replacePatch = tokreplace path toks old new @@ -714,20 +692,15 @@                 put tree''                 return patches - -- | Add an 'FL' of patches started from the pending state to the pending patch.--- TODO: add witnesses for pending so we can make the types precise: currently--- the passed patch can be applied in any context, not just after pending.-addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree)-                        => Repository rt p wR wU wR-                        -> FreeLeft (FL (PrimOf p)) -> IO ()-addPendingDiffToPending repo newP = do+unsafeAddToPending :: (RepoPatch p, ApplyState p ~ Tree)+                   => Repository 'RW p wU wR+                   -> FreeLeft (FL (PrimOf p)) -> IO ()+unsafeAddToPending repo newP = do     (_, Sealed toPend) <- readPending repo-    invalidateIndex repo     case unFreeLeft newP of         (Sealed p) -> do-            recordedState <- readRecorded repo-            Pending.makeNewPending repo YesUpdatePending (toPend +>+ p) recordedState+            Pending.writeTentativePending repo (toPend +>+ p)  -- | Add an 'FL' of patches starting from the working state to the pending patch, -- including as much extra context as is necessary (context meaning@@ -735,17 +708,15 @@ -- changes between pending and working as is possible, and including anything -- that doesn't commute, and the patch itself in the new pending patch. addToPending :: (RepoPatch p, ApplyState p ~ Tree)-             => Repository rt p wR wU wR-             -> UseIndex -> FL (PrimOf p) wU wY -> IO ()-addToPending repo useidx p = do-   (toPend :> toUnrec) <- readPendingAndWorking (useidx, ScanKnown, MyersDiff)-      NoLookForMoves NoLookForReplaces repo Nothing-   invalidateIndex repo+             => Repository 'RW p wU wR+             -> DiffOpts+             -> FL (PrimOf p) wU wY -> IO ()+addToPending repo dopts p = do+   (toPend :> toUnrec) <-+      readPendingAndWorking dopts repo Nothing    case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of        (toP' :> p'  :> _excessUnrec) -> do-           recordedState <- readRecorded repo-           Pending.makeNewPending repo YesUpdatePending-            (toPend +>+ reverseRL toP' +>+ p') recordedState+           Pending.writeTentativePending repo (toPend +>+ reverseRL toP' +>+ p') -readPlainTree :: Repository rt p wR wU wT -> IO (Tree IO)+readPlainTree :: Repository rt p wU wR -> IO (Tree IO) readPlainTree repo  = PlainTree.readPlainTree (repoLocation repo)
− src/Darcs/Repository/Test.hs 
@@ -1,155 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Repository.Test-    ( getTest-    , runPosthook-    , runPrehook-    , testTentative-    )-where--import Darcs.Prelude--import System.Exit ( ExitCode(..) )-import System.Process ( system )-import System.IO ( hPutStrLn, stderr )-import Control.Monad ( when )--import Darcs.Repository.Flags-    ( LeaveTestDir(..)-    , Verbosity(..)-    , SetScriptsExecutable(..)-    , RunTest (..)-    , HookConfig (..)-    )-import Darcs.Repository.InternalTypes ( Repository, repoLocation )-import Darcs.Repository.Prefs ( getPrefval )-import Darcs.Repository.Pristine ( withTentative )-import Darcs.Repository.Working ( setScriptsExecutable )--import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Util.Lock ( withTempDir, withPermDir )-import Darcs.Util.Path ( AbsolutePath )-import Darcs.Util.Progress ( debugMessage )-import Darcs.Util.Prompt ( askUser )--getTest :: Verbosity -> IO (IO ExitCode)-getTest verb =- let putInfo s = when (verb /= Quiet) $ putStr s- in do- testline <- getPrefval "test"- return $-   case testline of-   Nothing -> return ExitSuccess-   Just testcode -> do-     putInfo "Running test...\n"-     runTest testcode putInfo--runPosthook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode-runPosthook (HookConfig mPostHook askPostHook) verb repodir-    = do ph <- getPosthook mPostHook askPostHook-         withCurrentDirectory repodir $ runHook verb "Posthook" ph--getPosthook :: Maybe String -> Bool -> IO (Maybe String)-getPosthook mPostHookCmd askPostHook =- case mPostHookCmd of-   Nothing -> return Nothing-   Just command ->-     if askPostHook-      then do putStr ("\nThe following command is set to execute.\n"++-                      "Execute the following command now (yes or no)?\n"++-                      command++"\n")-              yorn <- askUser ""-              case yorn of-                ('y':_) -> return $ Just command-                _ -> putStrLn "Posthook cancelled..." >> return Nothing-      else return $ Just command--runPrehook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode-runPrehook (HookConfig mPreHookCmd askPreHook) verb repodir =-    do ph <- getPrehook mPreHookCmd askPreHook-       withCurrentDirectory repodir $ runHook verb "Prehook" ph--getPrehook :: Maybe String -> Bool -> IO (Maybe String)-getPrehook mPreHookCmd askPreHook=-  case mPreHookCmd of-    Nothing -> return Nothing-    Just command ->-      if askPreHook-       then do putStr ("\nThe following command is set to execute.\n"++-                       "Execute the following command now (yes or no)?\n"++-                       command++"\n")-               yorn <- askUser ""-               case yorn of-                 ('y':_) -> return $ Just command-                 _ -> putStrLn "Prehook cancelled..." >> return Nothing-       else return $ Just command--runHook :: Verbosity -> String -> Maybe String -> IO ExitCode-runHook _ _ Nothing = return ExitSuccess-runHook verb cname (Just command) =-    do ec <- system command-       when (verb /= Quiet) $-         if ec == ExitSuccess-         then putStrLn $ cname++" ran successfully."-         else hPutStrLn stderr $ cname++" failed!"-       return ec--testTentative :: Repository rt p wR wU wT-              -> RunTest-              -> LeaveTestDir-              -> SetScriptsExecutable-              -> Verbosity-              -> IO ExitCode-testTentative = testAny withTentative--runTest :: String -> (String -> IO ()) -> IO ExitCode-runTest testcode putInfo = do-    ec <- system testcode-    if ec == ExitSuccess-      then putInfo "Test ran successfully.\n"-      else putInfo "Test failed!\n"-    return ec---testAny :: (Repository rt p wR wU wT-            -> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)-            -> (AbsolutePath -> IO ExitCode) -> IO ExitCode-           )-        -> Repository rt p wR wU wT-        -> RunTest-        -> LeaveTestDir-        -> SetScriptsExecutable-        -> Verbosity-        -> IO ExitCode-testAny withD repository doRunTest ltd sse verb =-    debugMessage "Considering whether to test..." >>-    if doRunTest == NoRunTest-      then return ExitSuccess-      else withCurrentDirectory (repoLocation repository) $ do-       let putInfo = if verb == Quiet then const (return ()) else putStrLn-       debugMessage "About to run test if it exists."-       testline <- getPrefval "test"-       case testline of-         Nothing -> return ExitSuccess-         Just testcode ->-             withD repository (wd "testing") $ \_ ->-             do putInfo "Running test...\n"-                when (sse == YesSetScriptsExecutable) setScriptsExecutable-                runTest testcode putInfo-    where wd = if ltd == YesLeaveTestDir then withPermDir else withTempDir
+ src/Darcs/Repository/Transaction.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Repository.Transaction+    ( revertRepositoryChanges+    , finalizeRepositoryChanges+    , upgradeOldStyleRebase+    ) where++import Darcs.Prelude++import Control.Monad ( unless, void, when )+import System.Directory ( doesFileExist, removeFile )+import System.IO ( IOMode(..), hClose, hPutStrLn, openBinaryFile, stderr )+import System.IO.Error ( catchIOError )++import Darcs.Patch ( ApplyState, PatchInfoAnd, RepoPatch )+import qualified Darcs.Patch.Rebase.Legacy.Wrapped as W+import Darcs.Patch.Rebase.Suspended ( Suspended(..), showSuspended )+import Darcs.Patch.Set ( Origin, PatchSet(..), Tagged(..) )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) )+import Darcs.Patch.Witnesses.Sealed ( Dup(..), Sealed(..) )++import Darcs.Repository.Flags ( DryRun(..) )+import Darcs.Repository.Format+    ( RepoProperty(HashedInventory, RebaseInProgress, RebaseInProgress_2_16)+    , addToFormat+    , formatHas+    , removeFromFormat+    )+import Darcs.Repository.Hashed+    ( finalizeTentativeChanges+    , readPatches+    , readTentativePatches+    , revertTentativeChanges+    , writeTentativeInventory+    )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , Repository+    , modifyRepoFormat+    , repoCache+    , repoFormat+    , repoLocation+    , unsafeCoerceR+    , unsafeEndTransaction+    , unsafeStartTransaction+    , withRepoDir+    )+import Darcs.Repository.Inventory ( readOneInventory )+import qualified Darcs.Repository.Old as Old ( oldRepoFailMsg )+import Darcs.Repository.PatchIndex+    ( createOrUpdatePatchIndexDisk+    , doesPatchIndexExist+    )+import Darcs.Repository.Paths+    ( indexInvalidPath+    , indexPath+    , tentativeHashedInventoryPath+    )+import Darcs.Repository.Pending ( finalizePending, revertPending )+import Darcs.Repository.Rebase+    ( extractOldStyleRebase+    , finalizeTentativeRebase+    , readTentativeRebase+    , revertTentativeRebase+    , updateRebaseFormat+    , writeTentativeRebase+    )+import Darcs.Repository.State ( updateIndex )+import Darcs.Repository.Unrevert+    ( finalizeTentativeUnrevert+    , revertTentativeUnrevert+    )++import Darcs.Util.Printer ( text, ($$) )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Tree ( Tree )+++-- TODO: rename this and document the transaction protocol (revert/finalize)+-- clearly.+-- |Slightly confusingly named: as well as throwing away any tentative+-- changes, revertRepositoryChanges also re-initialises the tentative state.+-- It's therefore used before makign any changes to the repo.+revertRepositoryChanges :: RepoPatch p+                        => Repository 'RO p wU wR+                        -> IO (Repository 'RW p wU wR)+revertRepositoryChanges r+  | formatHas HashedInventory (repoFormat r) =+      withRepoDir r $ do+        checkIndexIsWritable+          `catchIOError` \e -> fail (unlines ["Cannot write index", show e])+        revertTentativeUnrevert+        revertPending r+        revertTentativeChanges r+        let r' = unsafeCoerceR r+        revertTentativeRebase r'+        return $ unsafeStartTransaction r'+  | otherwise = fail Old.oldRepoFailMsg++-- | Atomically copy the tentative state to the recorded state,+-- thereby committing the tentative changes that were made so far.+-- This includes inventories, pending, rebase, and the index.+finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree)+                          => Repository 'RW p wU wR+                          -> DryRun+                          -> IO (Repository 'RO p wU wR)+finalizeRepositoryChanges r dryrun+    | formatHas HashedInventory (repoFormat r) =+        withRepoDir r $ do+          let r' = unsafeEndTransaction $ unsafeCoerceR r+          when (dryrun == NoDryRun) $ do+            debugMessage "Finalizing changes..."+            withSignalsBlocked $ do+                updateRebaseFormat r+                finalizeTentativeRebase+                finalizeTentativeChanges r+                finalizePending r+                finalizeTentativeUnrevert+            debugMessage "Done finalizing changes..."+            ps <- readPatches r'+            pi_exists <- doesPatchIndexExist (repoLocation r')+            when pi_exists $+              createOrUpdatePatchIndexDisk r' ps+              `catchIOError` \e ->+                hPutStrLn stderr $ "Cannot create or update patch index: "++ show e+            updateIndex r'+          return r'+    | otherwise = fail Old.oldRepoFailMsg++-- | Upgrade a possible old-style rebase in progress to the new style.+upgradeOldStyleRebase :: forall p wU wR.+                         (RepoPatch p, ApplyState p ~ Tree)+                      => Repository 'RW p wU wR -> IO ()+upgradeOldStyleRebase repo = do+  PatchSet (ts :: RL (Tagged p) Origin wX) _ <- readTentativePatches repo+  Sealed wps <-+    readOneInventory @(W.WrappedNamed p) (repoCache repo) tentativeHashedInventoryPath+  case extractOldStyleRebase wps of+    Nothing ->+      ePutDocLn $ text "No old-style rebase state found, no upgrade needed."+    Just ((ps :: RL (PatchInfoAnd p) wX wZ) :> Dup r) -> do+      -- low-level call, must not try to update an existing rebase patch,+      -- nor update anything else beside the inventory+      writeTentativeInventory repo (PatchSet ts ps)+      Items old_r <- readTentativeRebase repo+      case old_r of+        NilFL -> do+          writeTentativeRebase (unsafeCoerceR repo) r+          repo' <-+            modifyRepoFormat+              (addToFormat RebaseInProgress_2_16 . removeFromFormat RebaseInProgress)+              repo+          void $ finalizeRepositoryChanges repo' NoDryRun+        _ -> do+          ePutDocLn+            $  "A new-style rebase is already in progress, not overwriting it."+            $$ "This should not have happened! This is the old-style rebase I found"+            $$ "and removed from the repository:"+            $$ showSuspended ForDisplay r++checkIndexIsWritable :: IO ()+checkIndexIsWritable = do+    checkWritable indexInvalidPath+    checkWritable indexPath+  where+    checkWritable path = do+      exists <- doesFileExist path+      touchFile path+      unless exists $ removeFile path+    touchFile path = openBinaryFile path AppendMode >>= hClose
src/Darcs/Repository/Traverse.hs view
@@ -1,11 +1,7 @@ module Darcs.Repository.Traverse-    ( cleanInventories-    , cleanPatches-    , cleanPristine-    , cleanRepository-    , diffHashLists+    ( cleanRepository+    , cleanPristineDir     , listInventories-    , listInventoriesLocal     , listInventoriesRepoDir     , listPatchesLocalBucketed     , specialPatches@@ -17,15 +13,14 @@ import qualified Data.ByteString.Char8 as BC ( unpack, pack ) import qualified Data.Set as Set -import System.Directory ( listDirectory )+import System.Directory ( listDirectory, withCurrentDirectory ) import System.FilePath.Posix( (</>) ) -import Darcs.Repository.Cache ( HashedDir(..), bucketFolder )-import Darcs.Repository.HashedIO ( cleanHashdir ) import Darcs.Repository.Inventory     ( Inventory(..)+    , PristineHash     , emptyInventory-    , getValidHash+    , encodeValidHash     , inventoryPatchNames     , parseInventory     , peekPristineHash@@ -33,25 +28,34 @@     ) import Darcs.Repository.InternalTypes     ( Repository+    , AccessType(..)     , repoCache-    , withRepoLocation+    , withRepoDir     ) import Darcs.Repository.Paths-    ( hashedInventory-    , hashedInventoryPath+    ( tentativeHashedInventory+    , tentativePristinePath     , inventoriesDir     , inventoriesDirPath     , patchesDirPath+    , pristineDirPath     ) import Darcs.Repository.Prefs ( globalCacheDir )  import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Cache+    ( Cache+    , HashedDir(HashedPristineDir)+    , bucketFolder+    , cleanCachesWithHint+    ) import Darcs.Util.Exception ( ifDoesNotExistError ) import Darcs.Util.Global ( darcsdir, debugMessage ) import Darcs.Util.Lock ( removeFileMayNotExist )+import Darcs.Util.Tree.Hashed ( followPristineHashes )  -cleanRepository :: Repository rt p wR wU wT -> IO ()+cleanRepository :: Repository 'RW p wU wR -> IO () cleanRepository r = cleanPristine r >> cleanInventories r >> cleanPatches r  -- | The way patchfiles, inventories, and pristine trees are stored.@@ -63,12 +67,26 @@ data DirLayout = PlainLayout | BucketedLayout  -- | Remove unreferenced entries in the pristine cache.-cleanPristine :: Repository rt p wR wU wT -> IO ()-cleanPristine r = withRepoLocation r $ do+cleanPristine :: Repository 'RW p wU wR -> IO ()+cleanPristine r = withRepoDir r $ do     debugMessage "Cleaning out the pristine cache..."-    i <- gzReadFilePS hashedInventoryPath-    cleanHashdir (repoCache r) HashedPristineDir [peekPristineHash i]+    i <- gzReadFilePS tentativePristinePath+    cleanPristineDir (repoCache r) [peekPristineHash i] +cleanPristineDir :: Cache -> [PristineHash] -> IO ()+cleanPristineDir cache roots = do+    reachable <- set . map encodeValidHash <$> followPristineHashes cache roots+    files <- set <$> listDirectory pristineDirPath+    let to_remove = unset $ files `Set.difference` reachable+    withCurrentDirectory pristineDirPath $+      mapM_ removeFileMayNotExist to_remove+    -- and also clean out any global caches+    debugMessage "Cleaning out any global caches..."+    cleanCachesWithHint cache HashedPristineDir to_remove+  where+    set = Set.fromList . map BC.pack+    unset = map BC.unpack . Set.toList+ -- | Set difference between two lists of hashes. diffHashLists :: [String] -> [String] -> [String] diffHashLists xs ys = from_set $ (to_set xs) `Set.difference` (to_set ys)@@ -77,7 +95,7 @@     from_set = map BC.unpack . Set.toList  -- | Remove unreferenced files in the inventories directory.-cleanInventories :: Repository rt p wR wU wT -> IO ()+cleanInventories :: Repository 'RW p wU wR -> IO () cleanInventories _ = do     debugMessage "Cleaning out inventories..."     hs <- listInventoriesLocal@@ -95,7 +113,7 @@ specialPatches = ["unrevert", "pending", "pending.tentative"]  -- | Remove unreferenced files in the patches directory.-cleanPatches :: Repository rt p wR wU wT -> IO ()+cleanPatches :: Repository 'RW p wU wR -> IO () cleanPatches _ = do     debugMessage "Cleaning out patches..."     hs <- (specialPatches ++) <$> listPatchesLocal PlainLayout darcsdir darcsdir@@ -113,7 +131,7 @@   -> DirLayout   -> String -> String -> IO [String] listInventoriesWith readInv dirformat baseDir startDir = do-    mbStartingWithInv <- getStartingWithHash startDir hashedInventory+    mbStartingWithInv <- getStartingWithHash startDir tentativeHashedInventory     followStartingWiths mbStartingWithInv   where     getStartingWithHash dir file = inventoryParent <$> readInv (dir </> file)@@ -125,7 +143,7 @@      followStartingWiths Nothing = return []     followStartingWiths (Just hash) = do-        let startingWith = getValidHash hash+        let startingWith = encodeValidHash hash         mbNextInv <- getStartingWithHash (nextDir startingWith) startingWith         (startingWith :) <$> followStartingWiths mbNextInv @@ -167,7 +185,7 @@ -- * The third argument is the directory of the head inventory. listPatchesLocal :: DirLayout -> String -> String -> IO [String] listPatchesLocal dirformat baseDir startDir = do-  inventory <- readInventory (startDir </> hashedInventory)+  inventory <- readInventory (startDir </> tentativeHashedInventory)   followStartingWiths     (inventoryParent inventory)     (inventoryPatchNames inventory)@@ -179,7 +197,7 @@         PlainLayout -> invDir     followStartingWiths Nothing patches = return patches     followStartingWiths (Just hash) patches = do-      let startingWith = getValidHash hash+      let startingWith = encodeValidHash hash       inv <- readInventoryLocal (nextDir startingWith </> startingWith)       (patches ++) <$>         followStartingWiths (inventoryParent inv) (inventoryPatchNames inv)
+ src/Darcs/Repository/Unrevert.hs view
@@ -0,0 +1,112 @@+module Darcs.Repository.Unrevert+    ( finalizeTentativeUnrevert+    , revertTentativeUnrevert+    , writeUnrevert+    , readUnrevert+    , removeFromUnrevertContext+    ) where++import Darcs.Prelude++import Darcs.Patch ( PrimOf, RepoPatch, commuteRL )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Bundle ( interpretBundle, makeBundle, parseBundle )+import Darcs.Patch.Depends ( patchSetMerge, removeFromPatchSet )+import Darcs.Patch.Info ( patchinfo )+import Darcs.Patch.Named ( infopatch )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )+import Darcs.Patch.Set ( Origin, PatchSet, SealedPatchSet )+import Darcs.Patch.Witnesses.Ordered+    ( (:/\:)(..)+    , (:>)(..)+    , FL(..)+    , lengthFL+    , reverseFL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Repository.Paths ( tentativeUnrevertPath, unrevertPath )+import Darcs.Util.Exception ( catchDoesNotExistError, ifDoesNotExistError )+import Darcs.Util.Global ( debugMessage )+import Darcs.Util.IsoDate ( getIsoDateTime )+import Darcs.Util.Lock ( readBinFile, removeFileMayNotExist, writeDocBinFile )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Tree ( Tree )++import System.Directory ( copyFile, renameFile )+import System.Exit ( exitSuccess )++finalizeTentativeUnrevert :: IO ()+finalizeTentativeUnrevert =+  renameFile tentativeUnrevertPath unrevertPath `catchDoesNotExistError`+    removeFileMayNotExist unrevertPath++revertTentativeUnrevert :: IO ()+revertTentativeUnrevert =+  copyFile unrevertPath tentativeUnrevertPath `catchDoesNotExistError`+    removeFileMayNotExist tentativeUnrevertPath++writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree)+              => PatchSet p Origin wR+              -> FL (PrimOf p) wR wX+              -> IO ()+writeUnrevert _ NilFL = removeFileMayNotExist tentativeUnrevertPath+writeUnrevert recorded ps = do+  date <- getIsoDateTime+  info <- patchinfo date "unrevert" "anon" []+  let np = infopatch info ps+  bundle <- makeBundle Nothing recorded (np :>: NilFL)+  writeDocBinFile tentativeUnrevertPath bundle++readUnrevert :: RepoPatch p+             => PatchSet p Origin wR+             -> IO (SealedPatchSet p Origin)+readUnrevert us = do+  pf <- readBinFile tentativeUnrevertPath+        `catchDoesNotExistError` fail "There's nothing to unrevert!"+  case parseBundle pf of+      Right (Sealed bundle) -> do+        case interpretBundle us bundle of+          Left msg -> fail msg+          Right ps -> return (Sealed ps)+      Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err++removeFromUnrevertContext :: forall p wR wX. (RepoPatch p, ApplyState p ~ Tree)+                          => PatchSet p Origin wR+                          -> FL (PatchInfoAnd p) wX wR+                          -> IO ()+removeFromUnrevertContext _ NilFL = return () -- nothing to do+removeFromUnrevertContext ref ps =+  ifDoesNotExistError () $ do+    debugMessage "Reading the unrevert bundle..."+    Sealed bundle <- unrevert_patch_bundle+    debugMessage "Adjusting the context of the unrevert changes..."+    debugMessage $+      "Removing " ++ show (lengthFL ps) ++ " patches in removeFromUnrevertContext"+    Sealed bundle_ps <- bundle_to_patchset bundle+    case patchSetMerge ref bundle_ps of+      (unrevert :>: NilFL) :/\: _ -> do+        case commuteRL (reverseFL ps :> unrevert) of+          Nothing -> unrevert_impossible+          Just (unrevert' :> _) ->+            case removeFromPatchSet ps ref of+              Nothing -> unrevert_impossible+              Just common -> do+                debugMessage "Have now found the new context..."+                bundle' <- makeBundle Nothing common (hopefully unrevert' :>: NilFL)+                writeDocBinFile tentativeUnrevertPath bundle'+      _ -> return () -- TODO I guess this should be an error call+    debugMessage "Done adjusting the context of the unrevert changes"+  where+    unrevert_impossible = do+      confirmed <-+        promptYorn "This operation will make unrevert impossible!\nProceed?"+      if confirmed+        then removeFileMayNotExist tentativeUnrevertPath+        else putStrLn "Cancelled." >> exitSuccess+    unrevert_patch_bundle = do+      pf <- readBinFile tentativeUnrevertPath+      case parseBundle pf of+        Right foo -> return foo+        Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err+    bundle_to_patchset bundle =+      either fail (return . Sealed) $ interpretBundle ref bundle
src/Darcs/Repository/Working.hs view
@@ -1,11 +1,11 @@ module Darcs.Repository.Working     ( applyToWorking-    , setScriptsExecutable+    , setAllScriptsExecutable     , setScriptsExecutablePatches     )  where  import Control.Monad ( when, unless, filterM )-import System.Directory ( doesFileExist )+import System.Directory ( doesFileExist, withCurrentDirectory ) import System.IO.Error ( catchIOError )  import qualified Data.ByteString as B ( readFile@@ -15,7 +15,6 @@  import Darcs.Prelude -import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Workaround ( setExecutable ) import Darcs.Util.Tree ( Tree )@@ -27,6 +26,7 @@ import Darcs.Patch.Witnesses.Ordered     ( FL(..) ) import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Progress ( progressFL )  import Darcs.Repository.Format ( RepoProperty( NoWorkingDir ), formatHas ) import Darcs.Repository.Flags  ( Verbosity(..) )@@ -39,17 +39,19 @@ import Darcs.Repository.State ( readWorking, TreeFilter(..)  )  applyToWorking :: (ApplyState p ~ Tree, RepoPatch p)-               => Repository rt p wR wU wT+               => Repository rt p wU wR                -> Verbosity                -> FL (PrimOf p) wU wY-               -> IO (Repository rt p wR wY wT)-applyToWorking repo verb patch =+               -> IO (Repository rt p wY wR)+applyToWorking repo verb ps =   do-    unless (formatHas NoWorkingDir (repoFormat repo)) $+    unless (formatHas NoWorkingDir (repoFormat repo)) $ do+      debugMessage "Applying changes to working tree"       withCurrentDirectory (repoLocation repo) $+        let ps' = progressFL "Applying patches to working" ps in         if verb == Quiet-          then runSilently $ apply patch-          else runTolerantly $ apply patch+          then runSilently $ apply ps'+          else runTolerantly $ apply ps'     return $ unsafeCoerceU repo   `catchIOError` (\e -> fail $ "Error applying changes to working tree:\n" ++ show e) @@ -61,8 +63,8 @@     debugMessage "Making scripts executable"     mapM_ setExecutableIfScript paths -setScriptsExecutable :: IO ()-setScriptsExecutable = do+setAllScriptsExecutable :: IO ()+setAllScriptsExecutable = do     tree <- readWorking (TreeFilter id)     setScriptsExecutable_ [anchorPath "." p | (p, Tree.File _) <- Tree.list tree]
src/Darcs/UI/ApplyPatches.hs view
@@ -19,24 +19,24 @@     ) import Darcs.UI.Commands.Util ( printDryRunMessageAndExit ) import Darcs.UI.Flags-    ( DarcsFlag, verbosity, compress, reorder, allowConflicts, externalMerge-    , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive, testChanges+    ( DarcsFlag, verbosity, reorder, allowConflicts+    , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive     , xmlOutput, dryRun     ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Options ( (?) ) import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit )-import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.Repository     ( Repository+    , AccessType(..)     , tentativelyMergePatches     , finalizeRepositoryChanges     , applyToWorking-    , invalidateIndex     , setScriptsExecutablePatches     )+import Darcs.Repository.Pristine ( readPristine ) import Darcs.Repository.Job ( RepoJob(RepoJob) )-import Darcs.Patch ( RepoPatch, RepoType, IsRepoType, description )+import Darcs.Patch ( RepoPatch, description ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.FromPrim ( PrimOf ) import Darcs.Patch.Set ( PatchSet, Origin )@@ -48,75 +48,72 @@ import Darcs.Util.Printer ( vcat, text ) import Darcs.Util.Tree( Tree ) -import GHC.Exts ( Constraint )- data PatchProxy (p :: * -> * -> *) = PatchProxy  -- |This class is a hack to abstract over pull/apply and rebase pull/apply. class PatchApplier pa where -    type ApplierRepoTypeConstraint pa (rt :: RepoType) :: Constraint-     repoJob         :: pa-        -> (forall rt p wR wU-               . ( IsRepoType rt, ApplierRepoTypeConstraint pa rt-                 , RepoPatch p, ApplyState p ~ Tree-                 )-              => (PatchProxy p -> Repository rt p wR wU wR -> IO ()))-        -> RepoJob ()+        -> (forall p wR wU+               . (RepoPatch p, ApplyState p ~ Tree)+              => (PatchProxy p -> Repository 'RW p wU wR -> IO ()))+        -> RepoJob 'RW ()      applyPatches-        :: forall rt p wR wU wZ-         . ( ApplierRepoTypeConstraint pa rt, IsRepoType rt-           , RepoPatch p, ApplyState p ~ Tree-           )+        :: forall p wR wU wZ+         . (RepoPatch p, ApplyState p ~ Tree)         => pa         -> PatchProxy p         -> String         -> [DarcsFlag]-        -> Repository rt p wR wU wR-        -> Fork (PatchSet rt p)-                (FL (PatchInfoAnd rt p))-                (FL (PatchInfoAnd rt p)) Origin wR wZ+        -> Repository 'RW p wU wR+        -> Fork (PatchSet p)+                (FL (PatchInfoAnd p))+                (FL (PatchInfoAnd p)) Origin wR wZ         -> IO ()  data StandardPatchApplier = StandardPatchApplier  instance PatchApplier StandardPatchApplier where-    type ApplierRepoTypeConstraint StandardPatchApplier rt = ()     repoJob StandardPatchApplier f = RepoJob (f PatchProxy)     applyPatches StandardPatchApplier PatchProxy = standardApplyPatches -standardApplyPatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+standardApplyPatches :: (RepoPatch p, ApplyState p ~ Tree)                      => String                      -> [DarcsFlag]-                     -> Repository rt p wR wU wR-                     -> Fork (PatchSet rt p)-                             (FL (PatchInfoAnd rt p))-                             (FL (PatchInfoAnd rt p)) Origin wR wZ+                     -> Repository 'RW p wU wR+                     -> Fork (PatchSet p)+                             (FL (PatchInfoAnd p))+                             (FL (PatchInfoAnd p)) Origin wR wZ                      -> IO ()-standardApplyPatches cmdName opts _repository patches@(Fork _ _ to_be_applied) = do+standardApplyPatches cmdName opts repository patches@(Fork _ _ to_be_applied) = do+    !no_patches <- return (nullFL to_be_applied)     applyPatchesStart cmdName opts to_be_applied+    Sealed pw <- mergeAndTest cmdName opts repository patches+    applyPatchesFinish cmdName opts repository pw (not no_patches) -    Sealed pw <- tentativelyMergePatches _repository cmdName+mergeAndTest :: (RepoPatch p, ApplyState p ~ Tree)+             => String+             -> [DarcsFlag]+             -> Repository 'RW p wU wR+             -> Fork (PatchSet p)+                     (FL (PatchInfoAnd p))+                     (FL (PatchInfoAnd p)) Origin wR wZ+             -> IO (Sealed (FL (PrimOf p) wU))+mergeAndTest cmdName opts repository patches = do+    pw <- tentativelyMergePatches repository cmdName                          (allowConflicts opts)-                         (externalMerge ? opts) (wantGuiPause opts)-                         (compress ? opts) (verbosity ? opts)+                         (wantGuiPause opts)                          (reorder ? opts) (diffingOpts opts)                          patches-    invalidateIndex _repository-    testTentativeAndMaybeExit _repository-         (verbosity ? opts)-         (testChanges ? opts)-         (setScriptsExecutable ? opts)-         (isInteractive True opts)-         "those patches do not pass the tests." (cmdName ++ " them") Nothing--    applyPatchesFinish cmdName opts _repository pw (nullFL to_be_applied)+    tree <- readPristine repository+    testTentativeAndMaybeExit tree opts+        "those patches do not pass the tests." (cmdName ++ " them") Nothing+    return pw  applyPatchesStart :: (RepoPatch p, ApplyState p ~ Tree)-                  => String -> [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> IO ()+                  => String -> [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> IO () applyPatchesStart cmdName opts to_be_applied = do     printDryRunMessageAndExit cmdName         (verbosity ? opts)@@ -132,21 +129,19 @@         putVerbose opts . vcat $ mapFL description to_be_applied         setEnvDarcsPatches to_be_applied -applyPatchesFinish :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+applyPatchesFinish :: (RepoPatch p, ApplyState p ~ Tree)                    => String                    -> [DarcsFlag]-                   -> Repository rt p wR wU wR+                   -> Repository 'RW p wU wR                    -> FL (PrimOf p) wU wY                    -> Bool                    -> IO () applyPatchesFinish cmdName opts _repository pw any_applied = do     withSignalsBlocked $ do-        _repository <--            finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)+        _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)         void $ applyToWorking _repository (verbosity ? opts) pw         when (setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $             setScriptsExecutablePatches pw-        return ()     case (any_applied, reorder ? opts == O.Reorder) of         (True,True)  -> putFinished opts $ "reordering"         (False,True) -> putFinished opts $ presentParticiple cmdName ++ " and reordering"
src/Darcs/UI/Commands.hs view
@@ -21,9 +21,11 @@     , DarcsCommand(..)     , commandAlias     , commandStub-    , commandOptions-    , commandAlloptions     , withStdOpts+    , commandOptDescr+    , commandAlloptions+    , commandDefaults+    , commandCheckOptions     , disambiguateCommands     , CommandArgs(..)     , getSubcommands@@ -51,6 +53,7 @@  import Control.Monad ( when, unless ) import Data.List ( sort, isPrefixOf )+import Data.Maybe ( maybeToList ) import System.Console.GetOpt ( OptDescr ) import System.IO ( stderr ) import System.IO.Error ( catchIOError )@@ -68,15 +71,26 @@ import qualified Darcs.Repository as R ( amInHashedRepository, amInRepository                                        , amNotInRepository, findRepository ) import Darcs.Repository.Flags ( WorkRepo(..) )-import Darcs.Repository.Prefs ( defaultrepo )+import Darcs.Repository.Prefs ( getDefaultRepo ) -import Darcs.UI.Options ( DarcsOption, DarcsOptDescr, (^), optDescr, odesc, parseFlags, (?) )+import Darcs.UI.Options+    ( DarcsOptDescr+    , DarcsOption+    , OptMsg+    , defaultFlags+    , ocheck+    , odesc+    , optDescr+    , parseFlags+    , (?)+    , (^)+    ) import Darcs.UI.Options.All     ( StdCmdAction, stdCmdActions, debugging, UseCache, useCache, HooksConfig, hooks-    , Verbosity(..), DryRun(..), dryRun, newRepo, verbosity+    , Verbosity(..), DryRun(..), dryRun, newRepo, verbosity, UseIndex, useIndex, yes     ) -import Darcs.UI.Flags ( DarcsFlag, remoteRepos, workRepo, quiet, verbose )+import Darcs.UI.Flags ( DarcsFlag, workRepo, quiet, verbose ) import Darcs.UI.External ( viewDoc ) import Darcs.UI.PrintPatch ( showWithSummary ) @@ -133,10 +147,7 @@                                 -> [DarcsFlag] -> [String] -> IO [String]           , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String]                                -> IO [String]-          , commandBasicOptions :: [DarcsOptDescr DarcsFlag]-          , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]-          , commandDefaults :: [DarcsFlag]-          , commandCheckOptions :: [DarcsFlag] -> [String]+          , commandOptions :: CommandOptions           }     | SuperCommand           { commandProgramName@@ -147,26 +158,56 @@           , commandSubCommands :: [CommandControl]           } -withStdOpts :: DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c-            -> DarcsOption (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b-            -> DarcsOption a c-withStdOpts basicOpts advancedOpts =-  basicOpts ^ stdCmdActions ^ verbosity ^ advancedOpts ^ useCache ^ hooks ^ debugging+data CommandOptions = CommandOptions+  { coBasicOptions :: [DarcsOptDescr DarcsFlag]+  , coAdvancedOptions :: [DarcsOptDescr DarcsFlag]+  , coDefaults :: [DarcsFlag]+  , coCheckOptions :: [DarcsFlag] -> [OptMsg]+  } -commandAlloptions :: DarcsCommand -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])-commandAlloptions DarcsCommand { commandBasicOptions = opts1-                               , commandAdvancedOptions = opts2 } =-    ( opts1 ++ odesc stdCmdActions-    , odesc verbosity ++ opts2 ++ odesc useCache ++ odesc hooks ++ odesc debugging-    )-commandAlloptions SuperCommand { } = (odesc stdCmdActions, [])+-- | Construct 'CommandOptions' from the command specific basic and advanced+-- 'DarcsOption's+withStdOpts+  :: DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c+  -> DarcsOption+      (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag]) b+  -> CommandOptions+withStdOpts bopts aopts =+  CommandOptions+    { coBasicOptions = odesc bopts'+    , coAdvancedOptions = odesc aopts'+    , coDefaults = defaultFlags opts+    , coCheckOptions = ocheck opts+    }+  where+    aopts' = verbosity ^ aopts ^ useCache ^ useIndex ^ hooks ^ debugging+    bopts' = bopts ^ stdCmdActions+    opts = bopts' ^ aopts' ---  Obtain options suitable as input to System.Console.Getopt, including the---  --disable option (which is not listed explicitly in the DarcsCommand---  definitions).-commandOptions :: AbsolutePath -> DarcsCommand -> [OptDescr DarcsFlag]-commandOptions cwd = map (optDescr cwd) . uncurry (++) . commandAlloptions+-- | For the given 'DarcsCommand' check the given 'DarcsFlag's for+-- consistency+commandCheckOptions :: DarcsCommand -> [DarcsFlag] -> [OptMsg]+commandCheckOptions DarcsCommand {commandOptions=co} = coCheckOptions co+commandCheckOptions SuperCommand {} = ocheck stdCmdActions +-- | Built-in default values for all 'DarcsFlag's supported by the given+-- command+commandDefaults :: DarcsCommand -> [DarcsFlag]+commandDefaults DarcsCommand {commandOptions=co} = coDefaults co+commandDefaults SuperCommand {} = defaultFlags stdCmdActions++-- | Option descriptions split into basic and advanced options+commandAlloptions :: DarcsCommand+                  -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])+commandAlloptions DarcsCommand {commandOptions = co} =+  (coBasicOptions co, coAdvancedOptions co)+commandAlloptions SuperCommand {} = (odesc stdCmdActions, [])++-- | Option descriptions as required by 'System.Console.Getopt.getOpt',+-- i.e. resolved with the given 'AbsolutePath'.+commandOptDescr :: AbsolutePath -> DarcsCommand -> [OptDescr DarcsFlag]+commandOptDescr cwd = map (optDescr cwd) . uncurry (++) . commandAlloptions+ nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] nodefaults _ _ = return @@ -193,11 +234,15 @@     cmdName = unwords . map commandName . maybe id (:) msuper $ [command]  commandStub :: String -> Doc -> String -> DarcsCommand -> DarcsCommand-commandStub n h d c = c { commandName = n-                        , commandHelp = h-                        , commandDescription = d-                        , commandCommand = \_ _ _ -> viewDoc h-                        }+commandStub n h d command@DarcsCommand {} =+  command+    { commandName = n+    , commandHelp = h+    , commandDescription = d+    , commandCommand = \_ _ _ -> viewDoc h+    }+commandStub _ _ _ SuperCommand {} =+  error "commandStub called with SuperCommand argument"  superName :: Maybe (DarcsCommand) -> String superName Nothing  = ""@@ -241,6 +286,7 @@  putFinished :: [DarcsFlag] -> String -> IO () putFinished flags what =+  unless (yes (dryRun ? flags)) $     putInfo flags $ "Finished" <+> text what <> "."  putWarning :: [DarcsFlag] -> Doc -> IO ()@@ -256,7 +302,7 @@  -- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables with -- info about the given patches, for use in post-hooks.-setEnvDarcsPatches :: RepoPatch p => FL (PatchInfoAnd rt p) wX wY -> IO ()+setEnvDarcsPatches :: RepoPatch p => FL (PatchInfoAnd p) wX wY -> IO () setEnvDarcsPatches ps = do     let k = "Defining set of chosen patches"     let filepaths = map (anchorPath ".") (listTouchedFiles ps)@@ -282,10 +328,12 @@     setEnvCautiously "DARCS_FILES" $ unlines filepaths  -- | Set some environment variable to the given value, unless said value is--- longer than 10K characters, in which case do nothing.+-- longer than 100K characters, in which case do nothing. setEnvCautiously :: String -> String -> IO () setEnvCautiously e v-    | toobig (10 * 1024) v = return ()+    | toobig (100 * 1024) v =+        hPutDocLn stderr $ text $+          "Warning: not setting env var " ++ e ++ " (would exceed 100K)"     | otherwise =         setEnv e v `catchIOError` (\_ -> setEnv e (decodeLocale (packStringToUTF8 v)))   where@@ -295,8 +343,10 @@     toobig _ [] = False     toobig n (_ : xs) = toobig (n - 1) xs +-- | To use for commandArgdefaults field. defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]-defaultRepo fs = defaultrepo (remoteRepos ? fs)+defaultRepo _ _ [] = maybeToList <$> getDefaultRepo+defaultRepo _ _ args = return args  amInHashedRepository :: [DarcsFlag] -> IO (Either String ()) amInHashedRepository fs = R.amInHashedRepository (workRepo fs)
src/Darcs/UI/Commands/Add.hs view
@@ -28,12 +28,20 @@ import Darcs.Prelude  import Control.Exception ( catch, IOException )-import Control.Monad ( when, unless )+import Control.Monad ( when, unless, void ) import Data.List ( (\\), nub ) import Data.List.Ordered ( nubSort ) import Data.Maybe ( fromMaybe, isNothing, maybeToList ) import Darcs.Util.Printer ( Doc, text, vcat )-import Darcs.Util.Tree ( Tree, findTree, expand, explodePaths )+import Darcs.Util.Tree+    ( Tree+    , expand+    , explodePaths+    , findTree+    , treeHas+    , treeHasAnycase+    , treeHasDir+    ) import qualified Darcs.Util.Tree as Tree import Darcs.Util.Path     ( AbsolutePath@@ -52,34 +60,31 @@ import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts, putInfo, putWarning, putVerboseWarning     , nodefaults, amInHashedRepository)-import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase ) import Darcs.UI.Commands.Util ( doesDirectoryReallyExist ) import Darcs.UI.Completion ( unknownFileArgs ) import Darcs.UI.Flags-    ( DarcsFlag-    , includeBoring, allowCaseDifferingFilenames, allowWindowsReservedFilenames, useCache, dryRun, umask+    ( DarcsFlag, diffingOpts+    , allowCaseDifferingFilenames, allowWindowsReservedFilenames, useCache, dryRun, umask     , pathsFromArgs )-import Darcs.UI.Options-    ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O -import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.Patch ( PrimPatch, applyToTree, addfile, adddir, listTouchedFiles ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Repository.State     ( TreeFilter(..)-    , readRecordedAndPending+    , readPristineAndPending     , readWorking-    , updateIndex     ) import Darcs.Repository     ( withRepoLock     , RepoJob(..)     , addToPending+    , finalizeRepositoryChanges     ) import Darcs.Repository.Prefs ( isBoring ) import Darcs.Util.File ( getFileStatus )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL )+import Darcs.Patch.Witnesses.Ordered ( FL(..), concatGapsFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )  addDescription :: String@@ -105,7 +110,7 @@     "Darcs will ignore all files and folders that look \"boring\".  The\n" ++     "`--boring` option overrides this behaviour.\n" ++     "\n" ++-    "Darcs will not add file if another file in the same folder has the\n" +++    "Darcs will not add a file if another file in the same folder has the\n" ++     "same name, except for case.  The `--case-ok` option overrides this\n" ++     "behaviour.  Windows and OS X usually use filesystems that do not allow\n" ++     "files a folder to have the same name except for case (for example,\n" ++@@ -122,12 +127,9 @@     , commandExtraArgHelp         = [ "<FILE or DIRECTORY> ..." ]     , commandCommand              = addCmd     , commandPrereq               = amInHashedRepository-    , commandCompleteArgs  = unknownFileArgs+    , commandCompleteArgs         = unknownFileArgs     , commandArgdefaults          = nodefaults-    , commandAdvancedOptions      = odesc addAdvancedOpts-    , commandBasicOptions         = odesc addBasicOpts-    , commandDefaults             = defaultFlags addOpts-    , commandCheckOptions         = ocheck addOpts+    , commandOptions              = addOpts     }   where     addBasicOpts@@ -145,7 +147,7 @@        -> [String]        -> IO () addCmd fps opts args-  | null args = putStrLn $ "Nothing specified, nothing added." +++  | null args = putStrLn $ "Nothing specified, nothing added. " ++       "Maybe you wanted to say `darcs add --recursive .'?"   | otherwise = do       paths <- pathsFromArgs fps args@@ -155,11 +157,11 @@  addFiles :: [DarcsFlag] -> [AnchoredPath] -> IO () addFiles opts paths =-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+  withRepoLock (useCache ? opts) (umask ? opts) $   RepoJob $ \repository -> do     -- TODO do not expand here, and use findM/findIO or such later     -- (needs adding to hashed-storage first though)-    cur <- expand =<< readRecordedAndPending repository+    cur <- expand =<< readPristineAndPending repository     let parent_paths = notInTreeParents cur paths     -- (1) note, readWorking already filters out darcsdir paths     -- (2) note, filterPaths matches if path is parent /or/ child @@ -171,22 +173,25 @@                         else id) paths         all_orig_paths = map displayPath all_paths     boring <- isBoring-    let nboring s = if includeBoring opts then id else filter (not . boring . s)+    let nboring s = if O.includeBoring ? opts then id else filter (not . boring . s)     mapM_ (putWarning opts . text . ((msgSkipping msgs ++ " boring file ")++)) $         all_orig_paths \\ nboring id all_orig_paths     Sealed ps <- fmap unFreeLeft $ addp msgs opts cur $ nboring realPath all_paths     when (nullFL ps && not (null paths)) $         fail "No files were added"-    unless gotDryRun $-      do addToPending repository (O.useIndex ? opts) ps-         updateIndex repository-         putInfo opts $ vcat $ map text $ ["Finished adding:"] ++-            map displayPath (listTouchedFiles ps)+    addToPending repository (diffingOpts opts) ps+    void $ finalizeRepositoryChanges repository (O.dryRun ? opts)+    unless gotDryRun $ do+      putInfo opts $ vcat $+        map text $ ["Finished adding:"] ++ map displayPath (listTouchedFiles ps)   where     gotDryRun = dryRun ? opts == O.YesDryRun     msgs | gotDryRun = dryRunMessages          | otherwise = normalMessages +    notInTreeParents :: Tree IO -> [AnchoredPath] -> [AnchoredPath]+    notInTreeParents cur = filter (isNothing . findTree cur) . concatMap parents+ addp :: forall prim . (PrimPatch prim, ApplyState prim ~ Tree)      => AddMessages      -> [DarcsFlag]@@ -239,7 +244,7 @@        putWarning opts . text $ "WARNING: Some files were not added because they are already in the repository."        putVerboseWarning opts . text $ dupMsg ++ caseMsg        mapM_ (putVerboseWarning opts . text . displayPath) uniq_dups-    return $ foldr (joinGap (+>+)) (emptyGap NilFL) ps+    return $ concatGapsFL ps   where     addp' :: Tree IO           -> AnchoredPath@@ -330,7 +335,3 @@     , msgIs        = "would be"     , msgAre       = "would be"     }---notInTreeParents :: Tree IO -> [AnchoredPath] -> [AnchoredPath]-notInTreeParents cur = filter (isNothing . findTree cur) . concatMap parents
src/Darcs/UI/Commands/Amend.hs view
@@ -48,23 +48,27 @@     , testTentativeAndMaybeExit     ) import Darcs.UI.Completion ( modifiedFileArgs, knownFileArgs )-import Darcs.UI.Flags ( diffOpts, pathSetFromArgs )-import Darcs.UI.Options ( (^), oparse, odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Flags ( diffingOpts, pathSetFromArgs )+import Darcs.UI.Options ( Config, (?), (^) ) import qualified Darcs.UI.Options.All as O-import Darcs.UI.PatchHeader ( updatePatchHeader, AskAboutDeps(..)-                            , HijackOptions(..)-                            , runHijackT )+import Darcs.UI.PatchHeader+    ( AskAboutDeps(..)+    , HijackOptions(..)+    , patchHeaderConfig+    , runHijackT+    , updatePatchHeader+    ) -import Darcs.Repository.Flags ( UpdatePending(..), DryRun(NoDryRun) )-import Darcs.Patch ( IsRepoType, RepoPatch, description, PrimOf-                   , effect, invert, invertFL, sortCoalesceFL+import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.Patch ( RepoPatch, description, PrimOf+                   , effect, invert, invertFL, canonizeFL                    ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Depends ( patchSetUnion, findCommonWithThem )+import Darcs.Patch.Depends ( contextPatches, patchSetUnion, findCommonWithThem ) import Darcs.Patch.Info ( isTag ) import Darcs.Patch.Named ( fmapFL_Named ) import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Patch.Set ( Origin, PatchSet, patchSet2RL )+import Darcs.Patch.Set ( Origin, PatchSet ) import Darcs.Patch.Split ( primSplitter ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, patchDesc ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )@@ -72,6 +76,7 @@ import Darcs.Util.Path ( AnchoredPath ) import Darcs.Repository     ( Repository+    , AccessType(..)     , withRepoLock     , RepoJob(..)     , identifyRepositoryFor@@ -80,12 +85,12 @@     , tentativelyAddPatch     , withManualRebaseUpdate     , finalizeRepositoryChanges-    , invalidateIndex     , readPendingAndWorking-    , readRecorded-    , readRepo+    , readPristine+    , readPatches+    , tentativelyRemoveFromPW     )-import Darcs.Repository.Pending ( tentativelyRemoveFromPW )+import Darcs.Repository.Pending ( readTentativePending, writeTentativePending ) import Darcs.Repository.Prefs ( getDefaultRepo ) import Darcs.UI.SelectChanges     ( WhichChanges(..)@@ -101,7 +106,7 @@     ( FL(..), RL, (:>)(..), (+>+)     , nullFL, reverseRL, reverseFL, mapFL_FL     )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FlippedSeal(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )  import Darcs.Util.English ( anyOfClause, itemizeVertical ) import Darcs.Util.Printer ( Doc, formatWords, putDocLn, text, (<+>), ($$), ($+$) )@@ -140,30 +145,6 @@     "    darcs amend --match 'touch foo.c' bar.c"   $+$ historyEditHelp -data AmendConfig = AmendConfig-    { amendUnrecord :: Bool-    , notInRemote :: [O.NotInRemote]-    , matchFlags :: [O.MatchFlag]-    , testChanges :: O.TestChanges-    , interactive :: Maybe Bool-    , author :: Maybe String-    , selectAuthor :: Bool-    , patchname :: Maybe String-    , askDeps :: Bool-    , askLongComment :: Maybe O.AskLongComment-    , keepDate :: Bool-    , lookfor :: O.LookFor-    , _workingRepoDir :: Maybe String-    , withContext :: O.WithContext-    , diffAlgorithm :: O.DiffAlgorithm-    , verbosity :: O.Verbosity-    , compress :: O.Compression-    , useIndex :: O.UseIndex-    , umask :: O.UMask-    , sse :: O.SetScriptsExecutable-    , useCache :: O.UseCache-    }- amend :: DarcsCommand amend = DarcsCommand     {@@ -177,10 +158,7 @@     , commandPrereq               = amInHashedRepository     , commandCompleteArgs         = fileArgs     , commandArgdefaults          = nodefaults-    , commandAdvancedOptions      = odesc advancedOpts-    , commandBasicOptions         = odesc basicOpts-    , commandDefaults             = defaultFlags allOpts-    , commandCheckOptions         = ocheck allOpts+    , commandOptions              = allOpts     }   where     fileArgs fps flags args =@@ -199,99 +177,97 @@       ^ O.askDeps       ^ O.askLongComment       ^ O.keepDate-      ^ O.lookfor+      ^ O.lookforadds+      ^ O.lookforreplaces+      ^ O.lookformoves       ^ O.repoDir-      ^ O.withContext       ^ O.diffAlgorithm     advancedOpts-      = O.compress-      ^ O.useIndex-      ^ O.umask+      = O.umask       ^ O.setScriptsExecutable     allOpts = withStdOpts basicOpts advancedOpts-    config = oparse (basicOpts ^ O.verbosity ^ advancedOpts ^ O.useCache) AmendConfig-    amendCmd fps flags args = pathSetFromArgs fps args >>= doAmend (config flags)+    amendCmd fps flags args = pathSetFromArgs fps args >>= doAmend flags  amendrecord :: DarcsCommand amendrecord = commandAlias "amend-record" Nothing amend -doAmend :: AmendConfig -> Maybe [AnchoredPath] -> IO ()+doAmend :: Config -> Maybe [AnchoredPath] -> IO () doAmend cfg files =-  withRepoLock NoDryRun (useCache cfg) YesUpdatePending (umask cfg) $-      RebaseAwareJob $ \(repository :: Repository rt p wR wU wR) -> do-    patchSet <- readRepo repository-    FlippedSeal patches <- filterNotInRemote cfg repository patchSet-    withSelectedPatchFromList "amend" patches (patchSelOpts cfg) $ \ (_ :> oldp) -> do-        announceFiles (verbosity cfg) files "Amending changes in"-        -- auxiliary function needed because the witness types differ for the isTag case-        pristine <- readRecorded repository-        pending :> working <--          readPendingAndWorking-            (diffingOpts cfg)-            (O.moves (lookfor cfg))-            (O.replaces (lookfor cfg))-            repository-            files-        let go :: forall wU1 . FL (PrimOf p) wR wU1 -> IO ()-            go NilFL | not (hasEditMetadata cfg) =-              putInfo cfg "No changes!"-            go ch =-              do let selection_config =-                        selectionConfigPrim First "record"-                            (patchSelOpts cfg)-                            --([All,Unified] `intersect` opts)-                            (Just (primSplitter (diffAlgorithm cfg)))-                            files-                            (Just pristine)-                 (chosenPatches :> _) <- runInvertibleSelection ch selection_config-                 addChangesToPatch cfg repository oldp chosenPatches pending working-        if not (isTag (info oldp))-              -- amending a normal patch-           then if amendUnrecord cfg-                   then do let selection_config =-                                  selectionConfigPrim Last "unrecord"-                                      (patchSelOpts cfg)-                                      -- ([All,Unified] `intersect` opts)-                                      (Just (primSplitter (diffAlgorithm cfg)))-                                      files-                                      (Just pristine)-                           (_ :> chosenPrims) <- runInvertibleSelection (effect oldp) selection_config-                           let invPrims = reverseRL (invertFL chosenPrims)-                           addChangesToPatch cfg repository oldp invPrims pending working-                   else go (sortCoalesceFL (pending +>+ working))-              -- amending a tag-           else if hasEditMetadata cfg && isNothing files-                        -- the user is not trying to add new changes to the tag so there is-                        -- no reason to warn.-                   then go NilFL-                        -- the user is trying to add new changes to a tag.-                   else do if hasEditMetadata cfg-                                -- the user already knows that it is possible to edit tag metadata,-                                -- note that s/he is providing editing options!-                             then ePutDocLn "You cannot add new changes to a tag."-                                -- the user may not be aware that s/he can edit tag metadata.-                             else ePutDocLn "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend)."-                           go NilFL+  withRepoLock (O.useCache ? cfg) (O.umask ? cfg) $+      RepoJob $ \(repository :: Repository 'RW p wU wR) -> do+    patchSet <- readPatches repository+    _ :> candidates <- filterNotInRemote cfg repository patchSet+    withSelectedPatchFromList "amend" candidates (patchSelOpts cfg) $+     \(kept :> oldp) -> do+      announceFiles (O.verbosity ? cfg) files "Amending changes in"+      pending :> working <-+        readPendingAndWorking (diffingOpts cfg) repository files+      -- auxiliary function needed because the witness types differ for the+      -- isTag case+      let go :: FL (PrimOf p) wR wU1 -> IO ()+          go NilFL | not (hasEditMetadata cfg) = putInfo cfg "No changes!"+          go ch = do+            let selection_config =+                   selectionConfigPrim First "record"+                       (patchSelOpts cfg)+                       (Just (primSplitter (O.diffAlgorithm ? cfg)))+                       files+            (chosenPatches :> _) <- runInvertibleSelection ch selection_config+            addChangesToPatch cfg repository kept oldp chosenPatches pending working+      if not (isTag (info oldp))+        -- amending a normal patch+        then+          if O.amendUnrecord ? cfg+            then do+              let selection_config =+                    selectionConfigPrim Last "unrecord" (patchSelOpts cfg)+                      (Just (primSplitter (O.diffAlgorithm ? cfg)))+                      files+              (_ :> chosenPrims) <-+                runInvertibleSelection (effect oldp) selection_config+              let invPrims = reverseRL (invertFL chosenPrims)+              addChangesToPatch cfg repository kept oldp invPrims pending working+            else+              go (canonizeFL (O.diffAlgorithm ? cfg) (pending +>+ working))+        -- amending a tag+        else+          if hasEditMetadata cfg && isNothing files+            -- the user is not trying to add new changes to the tag so there is+            -- no reason to warn.+            then go NilFL+            -- the user is trying to add new changes to a tag.+            else do+              if hasEditMetadata cfg+                -- the user already knows that it is possible to edit tag metadata,+                -- note that s/he is providing editing options!+                then ePutDocLn "You cannot add new changes to a tag."+                -- the user may not be aware that s/he can edit tag metadata.+                else+                  ePutDocLn+                    "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend)."+              go NilFL  -addChangesToPatch :: forall rt p wR wU wT wX wY wP-                   . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                  => AmendConfig-                  -> Repository rt p wR wU wT-                  -> PatchInfoAnd rt p wX wT-                  -> FL (PrimOf p) wT wY-                  -> FL (PrimOf p) wT wP-                  -> FL (PrimOf p) wP wU-                  -> IO ()-addChangesToPatch cfg _repository oldp chs pending working =+addChangesToPatch+  :: (RepoPatch p, ApplyState p ~ Tree)+  => Config+  -> Repository 'RW p wU wR+  -> RL (PatchInfoAnd p) wC wX  -- ^ candidates for --ask-deps+  -> PatchInfoAnd p wX wR       -- ^ original patch+  -> FL (PrimOf p) wR wY        -- ^ changes to add+  -> FL (PrimOf p) wR wP        -- ^ pending+  -> FL (PrimOf p) wP wU        -- ^ working+  -> IO ()+addChangesToPatch cfg _repository context oldp chs pending working =   if nullFL chs && not (hasEditMetadata cfg)     then putInfo cfg "You don't want to record anything!"     else do-      invalidateIndex _repository+      -- remember the old pending for the amend --unrecord case, see below+      Sealed old_pending <- readTentativePending _repository       -- If a rebase is in progress, we want to manually update the rebase       -- state, using the amendments directly as rebase fixups. This is-      -- necessary because otherwise the normal commute rules for the rebase-      -- state will first remove the original patch then add the amended patch,+      -- necessary because otherwise we will first remove the original patch+      -- then add the amended patch,       -- and this can lead to more conflicts than using the amendment as a fixup       -- directly. For example, if a rename operation is amended in, the rename       -- can be propagated to any edits to the file in the rebase state, whereas@@ -306,23 +282,17 @@           _repository <-             tentativelyRemovePatches               _repository-              (compress cfg)               NoUpdatePending               (oldp :>: NilFL)           (mlogf, newp) <-             runHijackT AlwaysRequestHijackPermission $             updatePatchHeader               "amend"-              (if askDeps cfg-                 then AskAboutDeps _repository+              (if O.askDeps ? cfg+                 then AskAboutDeps context                  else NoAskAboutDeps)               (patchSelOpts cfg)-              (diffAlgorithm cfg)-              (keepDate cfg)-              (selectAuthor cfg)-              (author cfg)-              (patchname cfg)-              (askLongComment cfg)+              (patchHeaderConfig cfg)               (fmapFL_Named effect (hopefully oldp))               chs           let fixups =@@ -331,53 +301,52 @@                 NilFL           setEnvDarcsFiles newp           _repository <--            tentativelyAddPatch-              _repository-              (compress cfg)-              (verbosity cfg)-              NoUpdatePending-              newp+            tentativelyAddPatch _repository NoUpdatePending newp           return (_repository, fixups, (mlogf, newp))       let failmsg = maybe "" (\lf -> "\nLogfile left in " ++ lf ++ ".") mlogf-      testTentativeAndMaybeExit-        _repository-        (verbosity cfg)-        (testChanges cfg)-        (sse cfg)-        (isInteractive cfg)+      tp <- readPristine _repository+      testTentativeAndMaybeExit tp cfg         ("you have a bad patch: '" ++ patchDesc newp ++ "'")         "amend it"         (Just failmsg)-      tentativelyRemoveFromPW _repository chs pending working+      if O.amendUnrecord ? cfg then+        writeTentativePending _repository $ invert chs +>+ old_pending+      else+        tentativelyRemoveFromPW _repository chs pending working       _repository <--        finalizeRepositoryChanges _repository YesUpdatePending (compress cfg)+        finalizeRepositoryChanges _repository (O.dryRun ? cfg)           `clarifyErrors` failmsg-      case verbosity cfg of+      case O.verbosity ? cfg of         O.NormalVerbosity -> putDocLn "Finished amending patch."         O.Verbose -> putDocLn $ "Finished amending patch:" $$ description newp         _ -> return ()       setEnvDarcsPatches (newp :>: NilFL) -filterNotInRemote :: (IsRepoType rt, RepoPatch p)-                  => AmendConfig-                  -> Repository rt p wR wU wT-                  -> PatchSet rt p Origin wR-                  -> IO (FlippedSeal (RL (PatchInfoAnd rt p)) wR)+filterNotInRemote :: RepoPatch p+                  => Config+                  -> Repository 'RW p wU wR+                  -> PatchSet p Origin wR+                  -> IO ((PatchSet p :> RL (PatchInfoAnd p)) Origin wR) filterNotInRemote cfg repository patchSet = do-    nirs <- mapM getNotInRemotePath (notInRemote cfg)+    nirs <- mapM getNotInRemotePath (O.notInRemote ? cfg)     if null nirs       then-        return (FlippedSeal (patchSet2RL patchSet))+        -- We call contextPatches here because+        -- (a) selecting patches beyond the latest clean tag is impossible anyway+        -- (b) makes it easier to reconstruct a PatchSet w/o the selected patch+        -- (c) avoids listing the complete list of patches in the repo when user+        --     rejects the last selectable patch+        return (contextPatches patchSet)       else do         putInfo cfg $           "Determining patches not in" <+> anyOfClause nirs $$ itemizeVertical 2 nirs         Sealed thems <- patchSetUnion `fmap` mapM readNir nirs-        _ :> only_ours <- return $ findCommonWithThem patchSet thems-        return (FlippedSeal (reverseFL only_ours))+        in_remote :> only_ours <- return $ findCommonWithThem patchSet thems+        return (in_remote :> reverseFL only_ours)   where     readNir loc = do-      repo <- identifyRepositoryFor Reading repository (useCache cfg) loc-      rps <- readRepo repo+      repo <- identifyRepositoryFor Reading repository (O.useCache ? cfg) loc+      rps <- readPatches repo       return (Sealed rps)     getNotInRemotePath (O.NotInRemotePath p) = return p     getNotInRemotePath O.NotInDefaultRepo = do@@ -386,40 +355,25 @@                          ++ "repo name to --" ++ O.notInRemoteFlagName         maybe err return defaultRepo -hasEditMetadata :: AmendConfig -> Bool-hasEditMetadata cfg = isJust (author cfg)-                    || selectAuthor cfg-                    || isJust (patchname cfg)-                    || askLongComment cfg == Just O.YesEditLongComment-                    || askLongComment cfg == Just O.PromptLongComment-                    || askDeps cfg---- hasEditMetadata []                    = False--- hasEditMetadata (Author _:_)          = True--- hasEditMetadata (SelectAuthor:_)      = True--- hasEditMetadata (LogFile _:_)         = True -- ??? not listed as an option for amend--- hasEditMetadata (PatchName _:_)       = True--- hasEditMetadata (EditLongComment:_)   = True--- hasEditMetadata (PromptLongComment:_) = True--- hasEditMetadata (AskDeps:_)           = True--- hasEditMetadata (_:fs)                = hasEditMetadata fs-+hasEditMetadata :: Config -> Bool+hasEditMetadata cfg = isJust (O.author ? cfg)+                    || O.selectAuthor ? cfg+                    || isJust (O.patchname ? cfg)+                    || O.askLongComment ? cfg == Just O.YesEditLongComment+                    || O.askLongComment ? cfg == Just O.PromptLongComment+                    || O.askDeps ? cfg -patchSelOpts :: AmendConfig -> S.PatchSelectionOptions+patchSelOpts :: Config -> S.PatchSelectionOptions patchSelOpts cfg = S.PatchSelectionOptions-    { S.verbosity = verbosity cfg-    , S.matchFlags = matchFlags cfg+    { S.verbosity = O.verbosity ? cfg+    , S.matchFlags = O.matchOneNontag ? cfg     , S.interactive = isInteractive cfg     , S.selectDeps = O.PromptDeps -- option not supported, use default     , S.withSummary = O.NoSummary -- option not supported, use default-    , S.withContext = withContext cfg     } -diffingOpts :: AmendConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)-diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) O.NoIncludeBoring (diffAlgorithm cfg)--isInteractive :: AmendConfig -> Bool-isInteractive = maybe True id . interactive+isInteractive :: Config -> Bool+isInteractive cfg = maybe True id (O.interactive ? cfg) -putInfo :: AmendConfig -> Doc -> IO ()-putInfo cfg what = unless (verbosity cfg == O.Quiet) $ putDocLn what+putInfo :: Config -> Doc -> IO ()+putInfo cfg what = unless (O.verbosity ? cfg == O.Quiet) $ putDocLn what
src/Darcs/UI/Commands/Annotate.hs view
@@ -26,16 +26,15 @@ import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.External ( viewDocWith ) import Darcs.UI.Flags ( DarcsFlag, useCache, patchIndexYes, pathsFromArgs )-import Darcs.UI.Options ( (^), odesc, ocheck-                        , defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O -import Darcs.Repository.State ( readRecorded )+import Darcs.Repository.State ( readPristine ) import Darcs.Repository     ( withRepository     , withRepoLockCanFail     , RepoJob(..)-    , readRepo+    , readPatches     ) import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex ) import Darcs.Patch.Set ( patchSet2RL )@@ -79,10 +78,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = knownFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc annotateAdvancedOpts-    , commandBasicOptions = odesc annotateBasicOpts-    , commandDefaults = defaultFlags annotateOpts-    , commandCheckOptions = ocheck annotateOpts+    , commandOptions = annotateOpts     }   where     annotateBasicOpts = O.machineReadable ^ O.matchUpToOne ^ O.repoDir@@ -96,23 +92,24 @@     [path] -> do       when (patchIndexYes ? opts == O.YesPatchIndex)         $ withRepoLockCanFail (useCache ? opts)-        $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo)+        $ RepoJob (\repo -> readPatches repo >>= attemptCreatePatchIndex repo)       annotateCmd' opts path     _ -> die "Error: annotate requires a single filepath argument"  annotateCmd' :: [DarcsFlag] -> AnchoredPath -> IO () annotateCmd' opts fixed_path = withRepository (useCache ? opts) $ RepoJob $ \repository -> do   let matchFlags = parseFlags O.matchUpToOne opts-  r <- readRepo repository-  recorded <- readRecorded repository+  r <- readPatches repository+  recorded <- readPristine repository   (patches, initial, path) <-     case patchSetMatch matchFlags of       Just psm -> do         Sealed x <- getOnePatchset repository psm-        let (_, [path'], _) =-              withFileNames Nothing [fixed_path] (rollbackToPatchSetMatch psm r)-        initial <- snd `fmap` virtualTreeIO (rollbackToPatchSetMatch psm r) recorded-        return (seal $ patchSet2RL x, initial, path')+        case withFileNames Nothing [fixed_path] (rollbackToPatchSetMatch psm r) of+          (_, [path'], _) -> do+            initial <- snd `fmap` virtualTreeIO (rollbackToPatchSetMatch psm r) recorded+            return (seal $ patchSet2RL x, initial, path')+          _ -> error "impossible"       Nothing ->         return (seal $ patchSet2RL r, recorded, fixed_path)
src/Darcs/UI/Commands/Apply.hs view
@@ -35,24 +35,23 @@ import Darcs.UI.Completion ( fileArgs ) import Darcs.UI.Flags     ( DarcsFlag-    , changesReverse, verbosity, useCache, dryRun+    , changesReverse, verbosity, useCache     , reorder, umask     , fixUrl-    , withContext     )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( (^), parseFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) import Darcs.Repository     ( Repository+    , AccessType(..)     , SealedPatchSet     , withRepoLock-    , readRepo+    , readPatches     , filterOutConflicts     ) import Darcs.Patch.Set ( PatchSet, Origin )-import Darcs.Patch ( IsRepoType, RepoPatch )+import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Info ( PatchInfo, displayPatchInfo ) import Darcs.Patch.Witnesses.Ordered@@ -63,13 +62,13 @@ import qualified Data.ByteString as B (ByteString, null, init) import qualified Data.ByteString.Char8 as BC (last) -import Darcs.Util.Download ( Cachable(Uncachable) )-import Darcs.Util.External ( gzFetchFilePS )+import Darcs.Util.HTTP ( Cachable(Uncachable) )+import Darcs.Util.File ( gzFetchFilePS ) import Darcs.UI.External     ( verifyPS     ) import Darcs.UI.Email ( readEmail )-import Darcs.Patch.Depends ( findCommonAndUncommon )+import Darcs.Patch.Depends ( findCommon ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..), PatchProxy ) import Darcs.UI.SelectChanges     ( WhichChanges(..)@@ -109,30 +108,42 @@   , [ "If `--test` is supplied and a test is defined (see `darcs setpref`), the"     , "bundle will be rejected if the test fails after applying it."     ]+  , [ "Unlike most Darcs commands, `darcs apply` defaults to `--all`.  Use the"+    , "`--interactive` option to pick which patches to apply from a bundle."+    ]   , [ "A patch bundle may introduce unresolved conflicts with existing"-    , "patches or with the working tree.  By default, Darcs will add conflict"-    , "markers (see `darcs mark-conflicts`)."+    , "patches or with the working tree.  By default, Darcs will refuse to"+    , "apply conflicting patches (`--no-allow-conflicts`)."     ]-  , [ "The `--external-merge` option lets you resolve these conflicts"+  , [ "The `--mark-conflicts` option instructs Darcs to allow conflicts and"+    , "try to add conflict markup in your working tree. Note that this may"+    , "(partly) fail, because some conflicts cannot be marked, such as e.g."+    , "conflicts between two adds of the same file. In this case Darcs will"+    , "warn you and display the conflicting changes instead. When Darcs"+    , "detects conflicts with unrecorded changes, it will give you an extra"+    , "warning and prompts you to confirm that you want to continue. This is"+    , "because your original unrecorded changes cannot be automatically"+    , "restored by Darcs."+    ]+  , [ "Note that conflict markup is something Darcs adds to your working tree"+    , "files. Nevertheless, you can always re-construct it using"+    , "`darcs mark-conflicts`."+    ]+  , [ "The `--external-merge` option lets you resolve conflicts"     , "using an external merge tool.  In the option, `%a` is replaced with"     , "the common ancestor (merge base), `%1` with the first version, `%2`"     , "with the second version, and `%o` with the path where your resolved"     , "content should go.  For example, to use the xxdiff visual merge tool"     , "you'd specify: `--external-merge='xxdiff -m -O -M %o %1 %a %2'`"     ]-  , [ "The `--allow-conflicts` option will skip conflict marking; this is"-    , "useful when you want to treat a repository as just a bunch of patches,"-    , "such as using `darcs pull --union` to download of your co-workers"-    , "patches before going offline."-    ]-  , [ "This can mess up unrecorded changes in the working tree, forcing you"-    , "to resolve the conflict immediately.  To simply reject bundles that"-    , "introduce unresolved conflicts, using the `--dont-allow-conflicts`"-    , "option.  Making this the default in push-based workflows is strongly"-    , "recommended."+  , [ "The `--allow-conflicts` option allows conflicts but does not add"+    , "conflict markup. This is useful when you want to treat a repository as"+    , "just a bunch of patches, such as using `darcs pull --union` to download"+    , "all of your co-workers' patches before going offline. Again, conflict"+    , "markup can be added at any time later on using `darcs mark-conflicts`."     ]-  , [ "Unlike most Darcs commands, `darcs apply` defaults to `--all`.  Use the"-    , "`--interactive` option to pick which patches to apply from a bundle."+  , [ "For more information on conflicts in Darcs and how to resolve them,"+    , "see the help on `darcs mark-conflicts`."     ]   ] @@ -152,10 +163,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = fileArgs     , commandArgdefaults = const stdindefault-    , commandAdvancedOptions = odesc applyAdvancedOpts-    , commandBasicOptions = odesc applyBasicOpts-    , commandDefaults = defaultFlags applyOpts-    , commandCheckOptions = ocheck applyOpts+    , commandOptions = applyOpts     }   where     applyBasicOpts@@ -165,15 +173,11 @@       ^ O.dryRunXml       ^ O.matchSeveral       ^ O.conflictsNo-      ^ O.externalMerge-      ^ O.runTest-      ^ O.leaveTestDir+      ^ O.testChanges       ^ O.repoDir       ^ O.diffAlgorithm     applyAdvancedOpts-      = O.useIndex-      ^ O.compress-      ^ O.setScriptsExecutable+      = O.setScriptsExecutable       ^ O.umask       ^ O.changesReverse       ^ O.pauseForGui@@ -186,7 +190,7 @@          -> [String]          -> IO () applyCmd patchApplier (_,orig) opts args =-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+  withRepoLock (useCache ? opts) (umask ? opts) $   repoJob patchApplier $ \patchProxy repository -> do     bundle <- readBundle args     applyCmdCommon patchApplier patchProxy opts bundle repository@@ -205,23 +209,21 @@     readBundle _ = error "impossible case"  applyCmdCommon-    :: forall rt pa p wR wU-     . ( PatchApplier pa, RepoPatch p, ApplyState p ~ Tree-       , ApplierRepoTypeConstraint pa rt, IsRepoType rt-       )+    :: forall pa p wR wU+     . (PatchApplier pa, RepoPatch p, ApplyState p ~ Tree)     => pa     -> PatchProxy p     -> [DarcsFlag]     -> B.ByteString-    -> Repository rt p wR wU wR+    -> Repository 'RW p wU wR     -> IO () applyCmdCommon patchApplier patchProxy opts bundle repository = do-  us <- readRepo repository+  us <- readPatches repository   Sealed them <- either fail return =<< getPatchBundle opts us bundle-  Fork common us' them' <- return $ findCommonAndUncommon us them+  Fork common us' them' <- return $ findCommon us them    -- all patches in them' need to be available; check that-  let check :: PatchInfoAnd rt p wX wY -> Maybe PatchInfo+  let check :: PatchInfoAnd p wX wY -> Maybe PatchInfo       check p = case hopefullyM p of         Nothing -> Just (info p)         Just _ -> Nothing@@ -234,7 +236,7 @@    (hadConflicts, Sealed their_ps)     <- if O.conflictsNo ? opts == Nothing -- skip conflicts-        then filterOutConflicts repository us' them'+        then filterOutConflicts repository (O.useIndex ? opts) us' them'         else return (False, Sealed them')   when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."   when (nullFL their_ps) $@@ -251,9 +253,9 @@  getPatchBundle :: RepoPatch p                => [DarcsFlag]-               -> PatchSet rt p Origin wR+               -> PatchSet p Origin wR                -> B.ByteString-               -> IO (Either String (SealedPatchSet rt p Origin))+               -> IO (Either String (SealedPatchSet p Origin)) getPatchBundle opts us fps = do     let opt_verify = parseFlags O.verify opts     mps <- verifyPS opt_verify $ readEmail fps@@ -282,9 +284,9 @@                             | otherwise = p  parseAndInterpretBundle :: RepoPatch p-                        => PatchSet rt p Origin wR+                        => PatchSet p Origin wR                         -> B.ByteString-                        -> Either String (SealedPatchSet rt p Origin)+                        -> Either String (SealedPatchSet p Origin) parseAndInterpretBundle us content = do     Sealed bundle <- parseBundle content     Sealed <$> interpretBundle us bundle@@ -296,7 +298,6 @@     , S.interactive = maybeIsInteractive flags     , S.selectDeps = O.PromptDeps -- option not supported, use default     , S.withSummary = O.NoSummary -- option not supported, use default-    , S.withContext = withContext ? flags     }  maybeIsInteractive :: [DarcsFlag] -> Bool
src/Darcs/UI/Commands/Clone.hs view
@@ -29,6 +29,7 @@ import System.Directory ( doesDirectoryExist, doesFileExist                         , setCurrentDirectory ) import System.Exit ( ExitCode(..) )+import System.FilePath.Posix ( joinPath, splitDirectories ) import Control.Monad ( when, unless )  import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts@@ -42,10 +43,9 @@ import Darcs.UI.Flags     ( DarcsFlag     , cloneKind+    , fixUrl     , patchIndexNo     , quiet-    , remoteDarcs-    , remoteRepos     , setDefault     , setScriptsExecutable     , umask@@ -55,9 +55,12 @@     , withNewRepo     , withWorkingDir     )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( (?), (^) ) import qualified Darcs.UI.Options.All as O-import Darcs.UI.Commands.Util ( getUniqueRepositoryName )+import Darcs.UI.Commands.Util+    ( commonHelpWithPrefsTemplates+    , getUniqueRepositoryName+    ) import Darcs.Patch.Match ( MatchFlag(..) ) import Darcs.Repository ( cloneRepository ) import Darcs.Repository.Format ( identifyRepoFormat@@ -73,9 +76,9 @@ import Darcs.Repository.Prefs ( showMotd ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Printer ( Doc, formatWords, formatText, text, vsep, ($$), ($+$) )-import Darcs.Util.Path ( toPath, ioAbsoluteOrRemote, AbsolutePath )+import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Workaround ( getCurrentDirectory )-import Darcs.Util.URL ( SshFilePath(..), isSshUrl, splitSshUrl )+import Darcs.Util.URL ( SshFilePath(..), isSshUrl, splitSshUrl, sshCanonRepo ) import Darcs.Util.Exec ( exec, Redirect(..), )  cloneDescription :: String@@ -118,6 +121,7 @@   [ cloneHelpTag   , cloneHelpSSE   , cloneHelpInheritDefault+  , commonHelpWithPrefsTemplates   ]  clone :: DarcsCommand@@ -132,10 +136,7 @@     , commandPrereq = \_ -> return $ Right ()     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc cloneAdvancedOpts-    , commandBasicOptions = odesc cloneBasicOpts-    , commandDefaults = defaultFlags cloneOpts-    , commandCheckOptions = ocheck cloneOpts+    , commandOptions = cloneOpts     }   where     cloneBasicOpts@@ -146,7 +147,12 @@       ^ O.inheritDefault       ^ O.setScriptsExecutable       ^ O.withWorkingDir-    cloneAdvancedOpts = O.usePacks ^ O.patchIndexNo ^ O.umask ^ O.network+    cloneAdvancedOpts+      = O.usePacks+      ^ O.patchIndexNo+      ^ O.umask+      ^ O.remoteDarcs+      ^ O.withPrefsTemplates     cloneOpts = cloneBasicOpts `withStdOpts` cloneAdvancedOpts  get :: DarcsCommand@@ -167,10 +173,9 @@  cloneCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () cloneCmd fps opts [inrepodir, outname] = cloneCmd fps (withNewRepo outname opts) [inrepodir]-cloneCmd _ opts [inrepodir] = do+cloneCmd (_,o) opts [inrepodir] = do   debugMessage "Starting work on clone..."-  typed_repodir <- ioAbsoluteOrRemote inrepodir-  let repodir = toPath typed_repodir+  repodir <- fixUrl o inrepodir   unless (quiet opts) $ showMotd repodir   rfsource <- identifyRepoFormat repodir   debugMessage $ "Found the format of "++repodir++"..."@@ -195,14 +200,14 @@   case cloneToSSH opts of     Just repo -> do       withTempDir "clone" $ \_ -> do-         guardRemoteDirDoesNotExist repo+         prepareRemoteDir repo          putInfo opts $ text "Creating local clone..."          currentDir <- getCurrentDirectory          mysimplename <- makeRepoName True [] repodir -- give correct name to local clone          cloneRepository repodir mysimplename (verbosity ? opts) (useCache ? opts)-                         CompleteClone (umask ? opts) (remoteDarcs opts)+                         CompleteClone (umask ? opts) (O.remoteDarcs ? opts)                          (setScriptsExecutable ? opts)-                         (remoteRepos ? opts) (NoSetDefault True)+                         (NoSetDefault True)                          O.NoInheritDefault -- never inherit defaultrepo when cloning to ssh                          (map convertUpToToOne (O.matchOneContext ? opts))                          rfsource@@ -210,18 +215,24 @@                          (patchIndexNo ? opts)                          (usePacks ? opts)                          YesForgetParent+                         (O.withPrefsTemplates ? opts)          setCurrentDirectory currentDir          (scp, args) <- getSSH SCP          putInfo opts $ text $ "Transferring clone using " ++ scp ++ "..."+         -- This has the precondition that the last part of 'repo' does not+         -- exist on the remote host, but all its parent directories do,+         -- which is ensured by 'prepareRemoteDir'.+         -- Note that adding the trailing slash to the source is essential+         -- in order to allow DARCS_SCP=rsync to work the same way as scp.          r <- exec scp (args ++ ["-r", mysimplename ++ "/", repo]) (AsIs,AsIs,AsIs)          when (r /= ExitSuccess) $ fail $ "Problem during " ++ scp ++ " transfer."          putInfo opts $ text "Cloning and transferring successful."     Nothing -> do       mysimplename <- makeRepoName True opts repodir       cloneRepository repodir mysimplename (verbosity ? opts) (useCache ? opts)-                  (cloneKind ? opts) (umask ? opts) (remoteDarcs opts)+                  (cloneKind ? opts) (umask ? opts) (O.remoteDarcs ? opts)                   (setScriptsExecutable ? opts)-                  (remoteRepos ? opts) (setDefault True opts)+                  (setDefault True opts)                   (O.inheritDefault ? opts)                   (map convertUpToToOne (O.matchOneContext ? opts))                   rfsource@@ -229,6 +240,7 @@                   (patchIndexNo ? opts)                   (usePacks ? opts)                   NoForgetParent+                  (O.withPrefsTemplates ? opts)       putFinished opts "cloning"  cloneCmd _ _ _ = fail "You must provide 'clone' with either one or two arguments."@@ -236,17 +248,36 @@ cloneToSSH :: [DarcsFlag] -> Maybe String cloneToSSH fs = case O.newRepo ? fs of   Nothing -> Nothing-  Just r -> if isSshUrl r then Just r else Nothing+  Just r -> if isSshUrl r then Just (sshCanonRepo $ splitSshUrl r) else Nothing --- | Make sure we do not overwrite an existing remote directory.-guardRemoteDirDoesNotExist :: String -> IO ()-guardRemoteDirDoesNotExist rpath = do+mkRemoteDirectory :: Bool -> String -> FilePath -> IO ()+mkRemoteDirectory recursive sshUhost path = do   (ssh, ssh_args) <- getSSH SSH-  let sshfp = splitSshUrl rpath-  let ssh_cmd = "mkdir '" ++ sshRepo sshfp ++ "'"-  r <- exec ssh (ssh_args ++ [sshUhost sshfp, ssh_cmd]) (AsIs,AsIs,AsIs)+  let ssh_cmd = "mkdir " ++ (if recursive then "-p " else "") ++  "'" ++ path ++ "'"+  r <- exec ssh (ssh_args ++ [sshUhost, ssh_cmd]) (AsIs,AsIs,AsIs)   when (r /= ExitSuccess) $-    fail $ "Cannot create remote directory '"  ++ sshRepo sshfp ++ "'."+    fail $ "Cannot create remote directory '"  ++ path ++ "'."++rmRemoteDirectory :: String -> FilePath -> IO ()+rmRemoteDirectory sshUhost path = do+  (ssh, ssh_args) <- getSSH SSH+  let ssh_cmd = "rmdir '" ++ path ++ "'"+  r <- exec ssh (ssh_args ++ [sshUhost, ssh_cmd]) (AsIs,AsIs,AsIs)+  when (r /= ExitSuccess) $+    fail $ "Cannot remove remote directory '"  ++ path ++ "'."++-- | Make sure that the remote directory does not exist, but all its+-- parent directories do.+prepareRemoteDir :: String -> IO ()+prepareRemoteDir rpath = do+  let sshfp = splitSshUrl rpath+  let sshRepoParent = if length sshPathParts > 1 then joinPath (init sshPathParts) else []+        where+          sshPathParts = splitDirectories (sshRepo sshfp)++  unless (null sshRepoParent) $ mkRemoteDirectory True (sshUhost sshfp) sshRepoParent+  mkRemoteDirectory False (sshUhost sshfp) (sshRepo sshfp)+  rmRemoteDirectory (sshUhost sshfp) (sshRepo sshfp)  makeRepoName :: Bool -> [DarcsFlag] -> FilePath -> IO String makeRepoName talkative fs d =
src/Darcs/UI/Commands/Convert/Darcs2.hs view
@@ -17,8 +17,9 @@  module Darcs.UI.Commands.Convert.Darcs2 ( convertDarcs2 ) where -import Control.Monad ( when, unless )+import Control.Monad ( when, unless, void ) import qualified Data.ByteString as B+import Data.Char ( toLower ) import Data.Maybe ( catMaybes ) import Data.List ( lookup ) import System.FilePath.Posix ( (</>) )@@ -31,8 +32,8 @@ import Darcs.Patch.Info ( isTag, piRename, piTag ) import Darcs.Patch.Named ( Named(..), getdeps, patch2patchinfo, patchcontents ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia )+import Darcs.Patch.Permutations ( (=/~\=) ) import Darcs.Patch.Progress ( progressFL )-import Darcs.Patch.RepoType ( IsRepoType(..), RebaseType(..), RepoType(..) ) import Darcs.Patch.Set ( inOrderTags, patchSet2FL, patchSet2RL ) import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) import Darcs.Patch.V1.Commute ( publicUnravel )@@ -41,31 +42,30 @@ import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) import qualified Darcs.Patch.V2.RepoPatch as V2 ( RepoPatchV2(Normal) ) import Darcs.Patch.V2.RepoPatch ( mergeUnravelled )-import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=/\=) )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered     ( FL(..)-    , bunchFL     , concatFL     , foldFL_M     , mapFL_FL     , mapRL+    , reverseFL     ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), mapSeal )  import Darcs.Repository     ( RepoJob(..)     , Repository+    , AccessType(..)     , applyToWorking     , createRepositoryV2     , finalizeRepositoryChanges-    , invalidateIndex-    , readRepo+    , readPatches     , revertRepositoryChanges     , withRepositoryLocation     , withUMaskFlag     )-import qualified Darcs.Repository as R ( setScriptsExecutable )-import Darcs.Repository.Flags ( Compression(..), UpdatePending(..) )+import qualified Darcs.Repository as R ( setAllScriptsExecutable ) import Darcs.Repository.Format     ( RepoProperty(Darcs2)     , formatHas@@ -76,20 +76,21 @@  import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, putFinished, withStdOpts ) import Darcs.UI.Commands.Convert.Util ( updatePending )+import Darcs.UI.Commands.Util ( commonHelpWithPrefsTemplates ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags     ( verbosity, useCache, umask, withWorkingDir, patchIndexNo     , DarcsFlag, withNewRepo     , quiet     )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O -import Darcs.Util.External ( fetchFilePS, Cachable(Uncachable) )+import Darcs.Util.File ( fetchFilePS, Cachable(Uncachable) ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Lock ( withNewDirectory ) import Darcs.Util.Path( ioAbsoluteOrRemote, toPath, AbsolutePath )-import Darcs.Util.Printer ( Doc, text, ($$) )+import Darcs.Util.Printer ( Doc, text, ($$), ($+$) ) import Darcs.Util.Printer.Color ( traceDoc ) import Darcs.Util.Prompt ( askUser ) import Darcs.Util.Tree( Tree )@@ -99,12 +100,13 @@ type RepoPatchV2 = V2.RepoPatchV2 V2.Prim  convertDarcs2Help :: Doc-convertDarcs2Help = text $ unlines+convertDarcs2Help = text (unlines  [ "This command converts a repository that uses the old patch semantics"  , "`darcs-1` to a new repository with current `darcs-2` semantics."  , ""  , convertDarcs2Help'- ]+ ])+ $+$ commonHelpWithPrefsTemplates  -- | This part of the help is split out because it is used twice: in -- the help string, and in the prompt for confirmation.@@ -112,10 +114,14 @@ convertDarcs2Help' = unlines  [ "WARNING: the repository produced by this command is not understood by"  , "Darcs 1.x, and patches cannot be exchanged between repositories in"- , "darcs-1 and darcs-2 formats."- , ""- , "Furthermore, repositories created by different invocations of"- , "this command SHOULD NOT exchange patches."+ , "darcs-1 and darcs-2 formats. Also, you should not exchange patches"+ , "between repositories created by different invocations of this command."+ , "This means:"+ , "- Before doing this conversion, you should merge into this repo any patches"+ , "  existing elsewhere that you might want to merge in future, so that they"+ , "  will remain mergeable. (You can always remove them again after converting)."+ , "- After converting, you should tell everyone with a fork of this repo"+ , "  to discard it and make a new fork of the converted repo."  ]  convertDarcs2 :: DarcsCommand@@ -130,16 +136,12 @@     , commandPrereq = \_ -> return $ Right ()     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc convertDarcs2AdvancedOpts-    , commandBasicOptions = odesc convertDarcs2BasicOpts-    , commandDefaults = defaultFlags (convertDarcs2Opts ^ convertDarcs2SilentOpts)-    , commandCheckOptions = ocheck convertDarcs2Opts+    , commandOptions = opts     }   where-    convertDarcs2BasicOpts = O.newRepo ^ O.setScriptsExecutable ^ O.withWorkingDir-    convertDarcs2AdvancedOpts = O.network ^ O.patchIndexNo ^ O.umask-    convertDarcs2Opts = convertDarcs2BasicOpts `withStdOpts` convertDarcs2AdvancedOpts-    convertDarcs2SilentOpts = O.patchFormat+    basicOpts = O.newRepo ^ O.setScriptsExecutable ^ O.withWorkingDir+    advancedOpts = O.remoteDarcs ^ O.patchIndexNo ^ O.umask ^ O.patchFormat+    opts = basicOpts `withStdOpts` advancedOpts  toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () toDarcs2 _ opts' args = do@@ -155,21 +157,20 @@   when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."    putStrLn convertDarcs2Help'-  let vow = "I understand the consequences of my action"-  putStrLn "Please confirm that you have read and understood the above"-  vow' <- askUser ("by typing `" ++ vow ++ "': ")-  when (vow' /= vow) $ fail "User didn't understand the consequences."+  answer <- askUser ("Do you still want to proceed ? If so, please type \"yes\": ")+  when (map toLower answer /= "yes") $ fail "Ok, doing nothing."    unless (quiet opts) $ showMotd repodir    mysimplename <- makeRepoName opts repodir   withUMaskFlag (umask ? opts) $ withNewDirectory mysimplename $ do-    _repo <- createRepositoryV2-      (withWorkingDir ? opts) (patchIndexNo ? opts) (O.useCache ? opts)-    _repo <- revertRepositoryChanges _repo NoUpdatePending+    _repo <-+      createRepositoryV2 (withWorkingDir ? opts) (patchIndexNo ? opts)+        (O.useCache ? opts) (O.withPrefsTemplates ? opts)+    _repo <- revertRepositoryChanges _repo      withRepositoryLocation (useCache ? opts) repodir $ V1Job $ \other -> do-      theirstuff <- readRepo other+      theirstuff <- readPatches other       let patches = mapFL_FL (convertNamed . hopefully) $ patchSet2FL theirstuff           outOfOrderTags = catMaybes $ mapRL oot $ patchSet2RL theirstuff               where oot t = if isTag (info t) && info t `notElem` inOrderTags theirstuff@@ -184,7 +185,7 @@             let ex = mapFL_FL primV1toV2 (effect x) in             case mergeUnravelled $ map (mapSeal (mapFL_FL primV1toV2)) $ publicUnravel x of              Just (FlippedSeal y) ->-                 case effect y =/\= ex of+                 case reverseFL (effect y) =/~\= reverseFL ex of                  IsEq -> y :>: NilFL                  NotEq ->                      traceDoc (text "lossy conversion:" $$@@ -199,7 +200,7 @@           convertFL :: FL RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY           convertFL = concatFL . mapFL_FL convertOne           convertNamed :: Named RepoPatchV1 wX wY-                       -> PatchInfoAnd ('RepoType 'NoRebase) RepoPatchV2 wX wY+                       -> PatchInfoAnd RepoPatchV2 wX wY           convertNamed n = n2pia $                            NamedP                             (convertInfo $ patch2patchinfo n)@@ -208,10 +209,10 @@           convertInfo n | n `elem` inOrderTags theirstuff = n                         | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n -      -- Note: we use bunchFL so we can commit every 100 patches-      _ <- applyAll opts _repo $ bunchFL 100 $ progressFL "Converting patch" patches+      _ <- applyAll opts _repo $ progressFL "Converting patch" patches+      void $ finalizeRepositoryChanges _repo (O.dryRun ? opts)       when (parseFlags O.setScriptsExecutable opts == O.YesSetScriptsExecutable)-        R.setScriptsExecutable+        R.setAllScriptsExecutable        -- Copy over the prefs file       (fetchFilePS (repodir </> prefsFilePath) Uncachable >>= B.writeFile prefsFilePath)@@ -221,29 +222,21 @@   where     applyOne :: (RepoPatch p, ApplyState p ~ Tree)              => [DarcsFlag]-             -> W2 (Repository rt p wR) wX-             -> PatchInfoAnd rt p wX wY-             -> IO (W2 (Repository rt p wR) wY)+             -> W2 (Repository 'RW p) wX+             -> PatchInfoAnd p wX wY+             -> IO (W2 (Repository 'RW p) wY)     applyOne opts (W2 _repo) x = do-      _repo <- tentativelyAddPatch_ (updatePristine opts) _repo-        GzipCompression (verbosity ? opts) (updatePending opts) x+      _repo <-+        tentativelyAddPatch_ (updatePristine opts) _repo (updatePending opts) x       _repo <- applyToWorking _repo (verbosity ? opts) (effect x)-      invalidateIndex _repo       return (W2 _repo) -    applySome opts (W3 _repo) xs = do-      _repo <- unW2 <$> foldFL_M (applyOne opts) (W2 _repo) xs-      -- commit after applying a bunch of patches-      _repo <- finalizeRepositoryChanges _repo (updatePending opts) GzipCompression-      _repo <- revertRepositoryChanges _repo (updatePending opts)-      return (W3 _repo)--    applyAll :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+    applyAll :: (RepoPatch p, ApplyState p ~ Tree)              => [DarcsFlag]-             -> Repository rt p wX wX wX-             -> FL (FL (PatchInfoAnd rt p)) wX wY-             -> IO (Repository rt p wY wY wY)-    applyAll opts r xss = unW3 <$> foldFL_M (applySome opts) (W3 r) xss+             -> Repository 'RW p wX wX+             -> FL (PatchInfoAnd p) wX wY+             -> IO (Repository 'RW p wY wY)+    applyAll opts r xss = unW2 <$> foldFL_M (applyOne opts) (W2 r) xss      updatePristine :: [DarcsFlag] -> UpdatePristine     updatePristine opts =@@ -257,9 +250,6 @@ -- | Need this to make 'foldFL_M' work with a function that changes -- the last two (identical) witnesses at the same time. newtype W2 r wX = W2 {unW2 :: r wX wX}---- | Similarly for when the function changes all three witnesses.-newtype W3 r wX = W3 {unW3 :: r wX wX wX}  makeRepoName :: [DarcsFlag] -> FilePath -> IO String makeRepoName opts d =
src/Darcs/UI/Commands/Convert/Export.hs view
@@ -32,7 +32,7 @@ import qualified Data.ByteString.Lazy.UTF8 as BLU import Data.Char (isSpace) import Data.IORef (modifyIORef, newIORef, readIORef)-import Data.Maybe (catMaybes, fromJust)+import Data.Maybe (fromJust) import System.Time (toClockTime)  import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )@@ -58,20 +58,17 @@     , piLog     , piName     )-import Darcs.Patch.RepoType ( IsRepoType(..) ) import Darcs.Patch.Set ( patchSet2FL, inOrderTags )  import Darcs.Repository     ( RepoJob(..)     , Repository-    , readRepo+    , readPatches     , repoCache     , withRepository     )-import Darcs.Repository.Cache (HashedDir(HashedPristineDir))-import Darcs.Repository.Pristine (readHashedPristineRoot)-import Darcs.Repository.HashedIO (cleanHashdir)-import Darcs.Repository.Paths (pristineDirPath)+import Darcs.Repository.Pristine ( readHashedPristineRoot )+import Darcs.Repository.Traverse ( cleanPristineDir )  import Darcs.UI.Commands     ( DarcsCommand(..)@@ -91,14 +88,7 @@     ) import Darcs.UI.Completion (noArgs) import Darcs.UI.Flags ( DarcsFlag , useCache )-import Darcs.UI.Options-    ( (?)-    , (^)-    , defaultFlags-    , ocheck-    , odesc-    , parseFlags-    )+import Darcs.UI.Options ( parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O  import Darcs.Util.DateTime ( formatDateTime, fromClockTime )@@ -107,6 +97,7 @@     , AnchoredPath(..)     , anchorPath     , appendPath+    , toFilePath     ) import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Tree@@ -169,41 +160,38 @@     , commandPrereq = amInRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc convertExportAdvancedOpts-    , commandBasicOptions = odesc convertExportBasicOpts-    , commandDefaults = defaultFlags convertExportOpts-    , commandCheckOptions = ocheck convertExportOpts+    , commandOptions = convertExportOpts     }   where     convertExportBasicOpts = O.repoDir ^ O.marks-    convertExportAdvancedOpts = O.network+    convertExportAdvancedOpts = O.remoteDarcs     convertExportOpts = convertExportBasicOpts `withStdOpts` convertExportAdvancedOpts  fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fastExport _ opts _ = do   marks <- case parseFlags O.readMarks opts of     Nothing -> return emptyMarks-    Just f  -> readMarks f+    Just f  -> readMarks (toFilePath f)   newMarks <-     withRepository (useCache ? opts) $ RepoJob $ \repo -> fastExport' repo marks   case parseFlags O.writeMarks opts of     Nothing -> return ()-    Just f  -> writeMarks f newMarks+    Just f  -> writeMarks (toFilePath f) newMarks -fastExport' :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-            => Repository rt p r u r -> Marks -> IO Marks+fastExport' :: (RepoPatch p, ApplyState p ~ Tree)+            => Repository rt p wU wR -> Marks -> IO Marks fastExport' repo marks = do   putStrLn "progress (reading repository)"-  patchset <- readRepo repo+  patchset <- readPatches repo   marksref <- newIORef marks   let patches = patchSet2FL patchset       tags = inOrderTags patchset-      mark :: (PatchInfoAnd rt p) x y -> Int -> TreeIO ()+      mark :: (PatchInfoAnd p) x y -> Int -> TreeIO ()       mark p n = liftIO $ do putStrLn $ "mark :" ++ show n                              modifyIORef marksref $ \m -> addMark m n (patchHash p)       -- apply a single patch to build the working tree of the last exported version       checkOne :: (RepoPatch p, ApplyState p ~ Tree)-               => Int -> (PatchInfoAnd rt p) x y -> TreeIO ()+               => Int -> (PatchInfoAnd p) x y -> TreeIO ()       checkOne n p = do apply p                         unless (inOrderTag tags p ||                                 (getMark marks n == Just (patchHash p))) $@@ -211,27 +199,27 @@                                  show (getMark marks n) ++ ", got " ++ BC.unpack (patchHash p)       -- build the working tree of the last version exported by convert --export       check :: (RepoPatch p, ApplyState p ~ Tree)-            => Int -> FL (PatchInfoAnd rt p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd rt p)) y) +            => Int -> FL (PatchInfoAnd p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd p)) y)        check _ NilFL = return (1, flipSeal NilFL)       check n allps@(p:>:ps)         | n <= lastMark marks = checkOne n p >> check (next tags n p) ps         | n > lastMark marks = return (n, flipSeal allps)         | lastMark marks == 0 = return (1, flipSeal allps)         | otherwise = undefined-  ((n, patches'), tree') <- hashedTreeIO (check 1 patches) emptyTree pristineDirPath+  ((n, patches'), tree') <- hashedTreeIO (check 1 patches) emptyTree (repoCache repo)   let patches'' = unsealFlipped unsafeCoerceP patches'-  void $ hashedTreeIO (dumpPatches tags mark n patches'') tree' pristineDirPath+  void $ hashedTreeIO (dumpPatches tags mark n patches'') tree' (repoCache repo)   readIORef marksref  `finally` do   putStrLn "progress (cleaning up)"   current <- readHashedPristineRoot repo-  cleanHashdir (repoCache repo) HashedPristineDir $ catMaybes [current]+  cleanPristineDir (repoCache repo) [current]   putStrLn "progress done"  dumpPatches ::  (RepoPatch p, ApplyState p ~ Tree)             =>  [PatchInfo]-            -> (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())-            -> Int -> FL (PatchInfoAnd rt p) x y -> TreeIO ()+            -> (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ())+            -> Int -> FL (PatchInfoAnd p) x y -> TreeIO () dumpPatches _ _ _ NilFL = liftIO $ putStrLn "progress (patches converted)" dumpPatches tags mark n (p:>:ps) = do   apply p@@ -241,7 +229,7 @@              dumpFiles $ listTouchedFiles p   dumpPatches tags mark (next tags n p) ps -dumpTag :: (PatchInfoAnd rt p) x y  -> Int -> TreeIO () +dumpTag :: (PatchInfoAnd p) x y  -> Int -> TreeIO ()  dumpTag p n =   dumpBits [ BLU.fromString $ "progress TAG " ++ cleanTagName p            , BLU.fromString $ "tag " ++ cleanTagName p -- FIXME is this valid?@@ -301,8 +289,8 @@         _    -> ([c], False)  -dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())-          -> (PatchInfoAnd rt p) x y -> Int+dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ())+          -> (PatchInfoAnd p) x y -> Int           -> TreeIO () dumpPatch mark p n =   do dumpBits [ BLU.fromString $ "progress " ++ show n ++ ": " ++ piName (info p)@@ -324,7 +312,7 @@ -- john <john@home> -> john <john@home> -- john <john@home  -> john <john@home> -- <john>           -> john <unknown>-patchAuthor :: (PatchInfoAnd rt p) x y -> String+patchAuthor :: (PatchInfoAnd p) x y -> String patchAuthor p  | null author = unknownEmail "unknown"  | otherwise = case span (/='<') author of@@ -349,20 +337,20 @@    emailPad email = "<" ++ email ++ ">"    mkAuthor name email = name ++ " " ++ email -patchDate :: (PatchInfoAnd rt p) x y -> String+patchDate :: (PatchInfoAnd p) x y -> String patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime .   piDate . info -patchMessage :: (PatchInfoAnd rt p) x y -> BLU.ByteString+patchMessage :: (PatchInfoAnd p) x y -> BLU.ByteString patchMessage p = BL.concat [ BLU.fromString (piName $ info p)                            , case unlines . piLog $ info p of                                  "" -> BL.empty                                  plog -> BLU.fromString ("\n\n" ++ plog)                            ] -inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool+inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd p wX wZ -> Bool inOrderTag tags p = isTag (info p) && info p `elem` tags && nullFL (effect p) -next :: (Effect p) => [PatchInfo] -> Int ->  PatchInfoAnd rt p x y -> Int+next :: (Effect p) => [PatchInfo] -> Int ->  PatchInfoAnd p x y -> Int next tags n p = if inOrderTag tags p then n else n + 1
src/Darcs/UI/Commands/Convert/Import.hs view
@@ -48,35 +48,32 @@ import Darcs.Patch.Witnesses.Ordered     ( FL(..)     , RL(..)-    , (+<+)-    , reverseFL+    , (+<<+)     , reverseRL     ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )  import Darcs.Patch.Info ( PatchInfo, patchinfo )-import Darcs.Patch.Prim ( sortCoalesceFL )-import Darcs.Patch.RepoType ( IsRepoType(..) )+import Darcs.Patch.Prim ( canonizeFL )  import Darcs.Repository     ( EmptyRepository(..)+    , AccessType(RW)     , Repository     , cleanRepository     , createPristineDirectoryTree     , createRepository     , finalizeRepositoryChanges-    , readTentativeRepo+    , readPatches     , repoCache-    , repoLocation     , revertRepositoryChanges     , withUMaskFlag     ) import Darcs.Repository.Diff (treeDiff)-import Darcs.Repository.Flags (Compression(..), DiffAlgorithm(PatienceDiff)) import Darcs.Repository.Hashed (addToTentativeInventory)-import Darcs.Repository.Paths (pristineDirPath, tentativePristinePath)+import Darcs.Repository.Paths (tentativePristinePath) import Darcs.Repository.Prefs (FileType(..))-import Darcs.Repository.State (readRecorded)+import Darcs.Repository.State (readPristine)  import Darcs.UI.Commands     ( DarcsCommand(..)@@ -89,9 +86,8 @@     , emptyMarks     , getMark     , patchHash-    , updatePending     )-import Darcs.UI.Commands.Util.Tree (treeHasDir, treeHasFile)+import Darcs.UI.Commands.Util ( commonHelpWithPrefsTemplates ) import Darcs.UI.Completion (noArgs) import Darcs.UI.Flags     ( DarcsFlag@@ -101,13 +97,7 @@     , useCache     , withWorkingDir     )-import Darcs.UI.Options-    ( (?)-    , (^)-    , defaultFlags-    , ocheck-    , odesc-    )+import Darcs.UI.Options ( (?), (^) ) import qualified Darcs.UI.Options.All as O  import Darcs.Util.ByteString (decodeLocale, unpackPSFromUTF8)@@ -117,18 +107,18 @@     , startOfTime     ) import Darcs.Util.Global (darcsdir)-import Darcs.Util.Hash (Hash(..), encodeBase16, sha256)+import Darcs.Util.Hash (encodeBase16, sha256) import Darcs.Util.Lock (withNewDirectory) import Darcs.Util.Path     ( AbsolutePath     , AnchoredPath(..)     , appendPath-    , floatPath+    , unsafeFloatPath     , makeName     , parent     , darcsdirName     )-import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Printer ( Doc, text, ($+$) ) import qualified Darcs.Util.Tree as T import Darcs.Util.Tree     ( Tree@@ -136,6 +126,8 @@     , findTree     , listImmediate     , readBlob+    , treeHasDir+    , treeHasFile     , treeHash     ) import Darcs.Util.Tree.Hashed (darcsAddMissingHashes, hashedTreeIO)@@ -144,7 +136,7 @@   convertImportHelp :: Doc-convertImportHelp = text $ unlines+convertImportHelp = text (unlines  [ "This command imports git repositories into new darcs repositories."  , "Further options are accepted (see `darcs help init`)."  , ""@@ -156,7 +148,8 @@  , "         use at your own risks."  , ""  , "Incremental import with marksfiles is currently not supported."- ]+ ])+ $+$ commonHelpWithPrefsTemplates  convertImport :: DarcsCommand convertImport = DarcsCommand@@ -170,19 +163,20 @@     , commandPrereq = \_ -> return $ Right ()     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc convertImportAdvancedOpts-    , commandBasicOptions = odesc convertImportBasicOpts-    , commandDefaults = defaultFlags convertImportOpts-    , commandCheckOptions = ocheck convertImportOpts+    , commandOptions = opts     }   where-    convertImportBasicOpts+    basicOpts       = O.newRepo       ^ O.setScriptsExecutable       ^ O.patchFormat       ^ O.withWorkingDir-    convertImportAdvancedOpts = O.patchIndexNo ^ O.umask-    convertImportOpts = convertImportBasicOpts `withStdOpts` convertImportAdvancedOpts+    advancedOpts+      = O.diffAlgorithm+      ^ O.patchIndexNo+      ^ O.umask+      ^ O.withPrefsTemplates+    opts = basicOpts `withStdOpts` advancedOpts  type Marked = Maybe Int type Branch = B.ByteString@@ -235,19 +229,24 @@       (withWorkingDir ? opts)       (patchIndexNo ? opts)       (useCache ? opts)+      (O.withPrefsTemplates ? opts)     -- TODO implement --dry-run, which would be read-only?-    _repo <- revertRepositoryChanges _repo (updatePending opts)-    marks <- fastImport' _repo emptyMarks-    _ <- finalizeRepositoryChanges _repo (updatePending opts) GzipCompression+    _repo <- revertRepositoryChanges _repo+    marks <-+      fastImport' _repo (O.diffAlgorithm ? opts) emptyMarks     cleanRepository _repo+    _repo <- finalizeRepositoryChanges _repo (O.dryRun ? opts)     createPristineDirectoryTree _repo "." (withWorkingDir ? opts)     return marks fastImport _ _ _ = fail "I need exactly one output repository." -fastImport' :: forall rt p r u . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>-               Repository rt p r u r -> Marks -> IO ()-fastImport' repo marks = do-    pristine <- readRecorded repo+fastImport' :: forall p wU wR . (RepoPatch p, ApplyState p ~ Tree)+            => Repository 'RW p wU wR+            -> O.DiffAlgorithm+            -> Marks+            -> IO ()+fastImport' repo diffalg marks = do+    pristine <- readPristine repo     marksref <- newIORef marks     let initial = Toplevel Nothing $ BC.pack "refs/branches/master" @@ -260,7 +259,7 @@          -- sort marks into buckets, since there can be a *lot* of them         markpath :: Int -> AnchoredPath-        markpath n = floatPath (darcsdir </> "marks")+        markpath n = unsafeFloatPath (darcsdir </> "marks")                         `appendPath` (either error id $ makeName $ show (n `div` 1000))                         `appendPath` (either error id $ makeName $ show (n `mod` 1000)) @@ -277,20 +276,24 @@         addtag author msg =           do info_ <- makeinfo author msg True              gotany <- liftIO $ doesFileExist tentativePristinePath-             deps <- if gotany then liftIO $-                                      getUncovered `fmap`-                                        readTentativeRepo repo (repoLocation repo)+             deps <- if gotany then liftIO $ getUncovered `fmap` readPatches repo                                else return []              let patch :: Named p wA wA                  patch = NamedP info_ deps NilFL-             liftIO $ addToTentativeInventory (repoCache repo) GzipCompression (n2pia patch)+             liftIO $+                 addToTentativeInventory (repoCache repo) (n2pia patch)          -- processing items++        -- ugly procedure that does too many things at once:+        -- * it modifies the tree in the state by adding missing hashes+        --   but only for blobs and excluding anything under _darcs+        -- * it also returns the resulting tree with _darcs filtered out         updateHashes = do-          let nodarcs = \(AnchoredPath (x:_)) _ -> x /= darcsdirName-              hashblobs (File blob@(T.Blob con NoHash)) =+          let nodarcs = \(AnchoredPath xs) _ -> head xs /= darcsdirName+              hashblobs (File blob@(T.Blob con Nothing)) =                 do hash <- sha256 `fmap` readBlob blob-                   return $ File (T.Blob con hash)+                   return $ File (T.Blob con (Just hash))               hashblobs x = return x           tree' <- liftIO . T.partiallyUpdateTree hashblobs nodarcs =<< gets tree           modify $ \s -> s { tree = tree' }@@ -311,13 +314,13 @@                       -- Either missing (not possible) or non-empty.                       _ -> return () -        -- generate a Hunk primitive patch from diffing+        -- generate Hunk primitive patches from diffing         diffCurrent :: State p -> TreeIO (State p)         diffCurrent (InCommit mark ancestors branch start ps info_) = do           current <- updateHashes           Sealed diff <- unFreeLeft `fmap`-             liftIO (treeDiff PatienceDiff (const TextFile) start current)-          let newps = ps +<+ reverseFL diff+             liftIO (treeDiff diffalg (const TextFile) start current)+          let newps = ps +<<+ diff           return $ InCommit mark ancestors branch current newps info_         diffCurrent _ = error "This is never valid outside of a commit." @@ -329,7 +332,10 @@         process (Toplevel _ _) End = do           tree' <- (liftIO . darcsAddMissingHashes) =<< updateHashes           modify $ \s -> s { tree = tree' } -- lets dump the right tree, without _darcs-          let root = encodeBase16 $ treeHash tree'+          let root =+                case treeHash tree' of+                  Nothing -> error "tree has no hash!"+                  Just hash -> encodeBase16 hash           liftIO $ do             putStrLn "\\o/ It seems we survived. Enjoy your new repo."             B.writeFile tentativePristinePath $ BC.concat [BC.pack "pristine:", root]@@ -434,11 +440,12 @@               liftIO $ putStrLn $ "WARNING: Linearising non-linear ancestry " ++ show list            {- current <- updateHashes -} -- why not?-          (prims :: FL (PrimOf p) cX cY)  <- return $ sortCoalesceFL $ reverseRL ps+          (prims :: FL (PrimOf p) cX cY) <-+            return $ canonizeFL diffalg $ reverseRL ps           let patch :: Named p cX cY               patch = infopatch info_ prims-          liftIO $ addToTentativeInventory (repoCache repo)-                                                  GzipCompression (n2pia patch)+          liftIO $+              addToTentativeInventory (repoCache repo) (n2pia patch)           case mark of             Nothing -> return ()             Just n -> case getMark marks n of@@ -479,7 +486,7 @@                                 if xExists then return x else finder rest                         finder spaceComponents -    void $ hashedTreeIO (go initial B.empty) pristine pristineDirPath+    void $ hashedTreeIO (go initial B.empty) pristine (repoCache repo)  parseObject :: BC.ByteString -> TreeIO ( BC.ByteString, Object ) parseObject = next' mbObject@@ -612,4 +619,4 @@                fail $ "Error parsing stream. " ++ err ++ "\nContext: " ++ show ctx  decodePath :: BC.ByteString -> AnchoredPath-decodePath = floatPath . decodeLocale+decodePath = unsafeFloatPath . decodeLocale
src/Darcs/UI/Commands/Convert/Util.hs view
@@ -60,7 +60,7 @@  -- misc shared functions -patchHash :: PatchInfoAnd rt p cX cY -> BC.ByteString+patchHash :: PatchInfoAnd p cX cY -> BC.ByteString patchHash p = BC.pack $ show $ makePatchname (info p)  updatePending :: [DarcsFlag] -> UpdatePending
src/Darcs/UI/Commands/Diff.hs view
@@ -22,8 +22,9 @@ import Control.Monad ( unless, when ) import Data.Maybe ( fromMaybe ) import Data.Maybe ( isJust )-import System.Directory ( copyFile, createDirectory, findExecutable, listDirectory )+import System.Directory ( createDirectory, findExecutable, withCurrentDirectory ) import System.FilePath.Posix ( takeFileName, (</>) )+import System.IO ( hFlush, stdout )  import Darcs.Patch ( listTouchedFiles ) import Darcs.Patch.Apply ( Apply(..) )@@ -35,13 +36,10 @@ import Darcs.Patch.Set ( patchSetSnoc ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), mapFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )-import Darcs.Repository ( RepoJob(..), readRepo, withRepository )-import Darcs.Repository.Flags ( DiffAlgorithm(MyersDiff), WantGuiPause(..) )-import Darcs.Repository.Paths ( pristineDirPath )+import Darcs.Repository ( RepoJob(..), readPatches, withRepository ) import Darcs.Repository.State-    ( ScanKnown(..)-    , applyTreeFilter-    , readRecorded+    ( applyTreeFilter+    , readPristine     , restrictSubpaths     , unrecordedChanges     )@@ -53,18 +51,18 @@     ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.External ( diffProgram )-import Darcs.UI.Flags ( DarcsFlag, pathSetFromArgs, useCache, wantGuiPause )-import Darcs.UI.Options ( defaultFlags, ocheck, odesc, parseFlags, (?), (^) )+import Darcs.UI.Flags ( DarcsFlag, diffingOpts, pathSetFromArgs, useCache, wantGuiPause )+import Darcs.UI.Options ( parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O+import Darcs.Util.Cache ( mkDirCache ) import Darcs.Util.CommandLine ( parseCmd ) import Darcs.Util.Exec ( execInteractive )-import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Global ( debugMessage ) import Darcs.Util.Lock ( withTempDir ) import Darcs.Util.Path ( AbsolutePath, AnchoredPath, isPrefix, toFilePath )-import Darcs.Util.Printer ( Doc, putDoc, text, vcat )+import Darcs.Util.Printer ( Doc, putDocLn, text, vcat ) import Darcs.Util.Prompt ( askEnter )-import Darcs.Util.Tree.Hashed ( hashedTreeIO )+import Darcs.Util.Tree.Hashed ( hashedTreeIO, writeDarcsHashed ) import Darcs.Util.Tree.Plain ( writePlainTree ) import Darcs.Util.Workaround ( getCurrentDirectory ) @@ -119,19 +117,17 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = knownFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc diffAdvancedOpts-    , commandBasicOptions = odesc diffBasicOpts-    , commandDefaults = defaultFlags diffOpts-    , commandCheckOptions = ocheck diffOpts+    , commandOptions = withStdOpts diffBasicOpts diffAdvancedOpts     }   where     diffBasicOpts       = O.matchOneOrRange       ^ O.extDiff+      ^ O.lookforadds+      ^ O.lookformoves       ^ O.repoDir       ^ O.storeInMemory-    diffAdvancedOpts = O.pauseForGui ^ O.useIndex-    diffOpts = diffBasicOpts `withStdOpts` diffAdvancedOpts+    diffAdvancedOpts = O.pauseForGui  diffCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () diffCmd fps opts args@@ -145,12 +141,12 @@  doDiff :: [DarcsFlag] -> Maybe [AnchoredPath] ->  IO () doDiff opts mpaths = withRepository (useCache ? opts) $ RepoJob $ \repository -> do-  patchset <- readRepo repository+  patchset <- readPatches repository+  debugMessage "After readPatches"   -- We pass @mpaths@ here which means we get only the changes that affect the   -- given paths (if any).-  unrecorded <- unrecordedChanges (O.useIndex ? opts, ScanKnown, MyersDiff)-    O.NoLookForMoves O.NoLookForReplaces-    repository mpaths+  unrecorded <- unrecordedChanges (diffingOpts opts) repository mpaths+  debugMessage "After getting the unrecorded changes"   -- Use of 'anonymous' is unproblematic here as we don't store any patches.   -- But we must take care not to show its fake patch info to the user.   unrecorded' <- n2pia `fmap` anonymous unrecorded@@ -168,15 +164,15 @@   Sealed match <- return $     fromMaybe (seal all) $ matchSecondPatchset matchFlags patchset -  (_ :> todiff) <- return $ findCommonWithThem match ctx-  (_ :> tounapply) <- return $ findCommonWithThem all match+  _ :> todiff <- return $ findCommonWithThem match ctx+  _ :> tounapply <- return $ findCommonWithThem all match    Sealed logmatch <- return $     if secondMatch matchFlags       then seal match       else seal patchset   -- Same as @todiff@ but without trailing @unrecorded'@ changes-  (_ :> tolog) <- return $ findCommonWithThem logmatch ctx+  _ :> tolog <- return $ findCommonWithThem logmatch ctx    let touched = listTouchedFiles todiff       files = case mpaths of@@ -189,34 +185,31 @@   let thename = takeFileName formerdir   withTempDir "darcs-diff" $ \tmpdir -> do       getCurrentDirectory >>= debugMessage . ("doDiff: I am now in "++)-      let pdir = toFilePath tmpdir </> ("pristine.hashed-"++thename)-      createDirectory pdir-      let odir = toFilePath tmpdir </> ("old-"++thename)+      let tdir = toFilePath tmpdir+      let odir = tdir </> ("old-"++thename)       createDirectory odir-      let ndir = toFilePath tmpdir </> ("new-"++thename)+      let ndir = tdir </> ("new-"++thename)       createDirectory ndir        -- Prepare the (plain) trees we want to compare. Since we need to access       -- our repository, we have to restore the working directory.       withCurrentDirectory formerdir $ do-        -- Make a temporary copy of pristineDirPath where we have write access.-        -- The result (@pdirpath@) serves as our storage for hashed 'Tree' items+        -- Make sure we have at least one writable cache entry+        -- to serve as our storage for hashed 'Tree' items         -- during the 'apply' and 'unapply' operations below.-        let pdirpath = toFilePath pdir-        pfiles <- listDirectory pristineDirPath-        let copy srcdir destdir name = copyFile (srcdir</>name) (destdir</>name)-        mapM_ (copy pristineDirPath pdirpath) pfiles--        pristine <- readRecorded repository+        let cache = mkDirCache tdir+        pristine <- readPristine repository+        -- fill our temporary cache+        _ <- writeDarcsHashed pristine cache          -- @base@ will be like our working tree, /except/ that it contains only         -- the unrecorded changes that affect the given file paths, see comment         -- above when we called 'unrecordedChanges'.         base <- if secondMatch matchFlags                  then return pristine-                 else snd <$> hashedTreeIO (apply unrecorded') pristine pdirpath+                 else snd <$> hashedTreeIO (apply unrecorded') pristine cache -        newtree <- snd <$> hashedTreeIO (unapply tounapply) base pdirpath+        newtree <- snd <$> hashedTreeIO (unapply tounapply) base cache         -- @todiff@ may have our @unrecorded'@ changes as its last element. If         -- we used our full working tree as @base@, then we would now unapply         -- filtered changes from an unfiltered 'Tree', so the result would be@@ -231,12 +224,13 @@         -- below). But that may be less efficient if there are many unrecorded         -- changes but we are interested in just a small subset of the affected         -- paths.-        oldtree <- snd <$> hashedTreeIO (unapply todiff) newtree pdirpath+        oldtree <- snd <$> hashedTreeIO (unapply todiff) newtree cache          writePlainTree (applyTreeFilter relevant oldtree) (toFilePath odir)         writePlainTree (applyTreeFilter relevant newtree) (toFilePath ndir)         -- Display patch info for (only) the recorded patches that we diff-        putDoc $ vcat $ map displayPatchInfo $ reverse $ mapFL info tolog+        putDocLn $ vcat $ map displayPatchInfo $ reverse $ mapFL info tolog+        hFlush stdout        -- Call the external diff program. Note we are now back in our       -- temporary directory.@@ -249,7 +243,7 @@           cmdExists <- findExecutable d_cmd           unless (isJust cmdExists) $             fail $ d_cmd ++ " is not an executable in --diff-command"-          let pausingForGui = (wantGuiPause opts == YesWantGuiPause)+          let pausingForGui = (wantGuiPause opts == O.YesWantGuiPause)               cmdline = unwords (d_cmd : d_args)           when pausingForGui $ putStrLn $ "Running command '" ++ cmdline ++ "'"           _ <- execInteractive cmdline Nothing@@ -276,5 +270,5 @@         Right (cmd, "-rN":getDiffOpts extDiff++[f1,f2])  getDiffOpts :: O.ExternalDiff -> [String]-getDiffOpts O.ExternalDiff {O.diffOpts=os,O.diffUnified=u} = addUnified os where+getDiffOpts O.ExternalDiff {O.diffOptions=os,O.diffUnified=u} = addUnified os where   addUnified = if u then ("-u":) else id
src/Darcs/UI/Commands/Dist.hs view
@@ -30,33 +30,23 @@     , doFastZip'     ) where -import Darcs.Prelude hiding ( writeFile )+import Darcs.Prelude -import Data.ByteString.Lazy ( writeFile )-import Control.Monad ( when )-import System.Directory ( createDirectory, setCurrentDirectory )+import Control.Monad ( forM, unless, when ) import System.Process ( system ) import System.Exit ( ExitCode(..), exitWith ) import System.FilePath.Posix ( takeFileName, (</>) )  import Darcs.Util.Workaround ( getCurrentDirectory )-import Codec.Archive.Tar ( pack, write )-import Codec.Archive.Tar.Entry ( entryPath )+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar import Codec.Compression.GZip ( compress ) -import Codec.Archive.Zip ( emptyArchive, fromArchive, addEntryToArchive, toEntry )-import Darcs.Util.External ( fetchFilePS, Cachable( Uncachable ) )-import Darcs.Repository.Inventory ( peekPristineHash )-import Darcs.Repository.HashedIO ( pathsAndContents )-import Darcs.Repository.Paths ( hashedInventoryPath )+import qualified Codec.Archive.Zip as Zip import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Char8 as BLC import Darcs.UI.Flags as F ( DarcsFlag, useCache )-import qualified Darcs.UI.Flags as F ( setScriptsExecutable )-import Darcs.UI.Options-    ( (^), oid, odesc, ocheck-    , defaultFlags, parseFlags, (?)-    )+import Darcs.UI.Options ( oid, parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O  import Darcs.UI.Commands@@ -64,18 +54,18 @@     , putVerbose, putInfo     ) import Darcs.UI.Completion ( noArgs )-import Darcs.Util.Lock ( withTempDir )+import Darcs.Util.Lock ( withDelayedDir ) import Darcs.Patch.Match ( patchSetMatch )-import Darcs.Repository.Match ( getRecordedUpToMatch )-import Darcs.Repository ( withRepository, withRepositoryLocation, RepoJob(..),-                          setScriptsExecutable, repoCache,-                          createPartialsPristineDirectoryTree )+import Darcs.Repository.Match ( getPristineUpToMatch )+import Darcs.Repository ( RepoJob(..), withRepository, withRepositoryLocation ) import Darcs.Repository.Prefs ( getPrefval )+import Darcs.Repository.Pristine ( readPristine )  import Darcs.Util.DateTime ( getCurrentTime, toSeconds )-import Darcs.Util.Path ( AbsolutePath, toFilePath, anchoredRoot )-import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Path ( AbsolutePath, realPath, toFilePath ) import Darcs.Util.Printer ( Doc, text, vcat )+import qualified Darcs.Util.Tree as T+import Darcs.Util.Tree.Plain ( readPlainTree, writePlainTree )   distDescription :: String@@ -112,10 +102,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc distBasicOpts-    , commandDefaults = defaultFlags distOpts-    , commandCheckOptions = ocheck distOpts+    , commandOptions = distOpts     }   where     distBasicOpts@@ -135,38 +122,44 @@   let distname = getDistName formerdir (O.distname ? opts)   predist <- getPrefval "predist"   let resultfile = formerdir </> distname ++ ".tar.gz"-  withTempDir "darcsdist" $ \tempdir -> do-      setCurrentDirectory formerdir-      let ddir = toFilePath tempdir </> distname-      createDirectory ddir-      case patchSetMatch matchFlags of-        Just psm -> withCurrentDirectory ddir $ getRecordedUpToMatch repository psm-        Nothing -> createPartialsPristineDirectoryTree repository [anchoredRoot] (toFilePath ddir)-      ec <- case predist of Nothing -> return ExitSuccess-                            Just pd -> system pd-      if ec == ExitSuccess-        then do-          withCurrentDirectory ddir $-            when-              (F.setScriptsExecutable ? opts == O.YesSetScriptsExecutable)-              setScriptsExecutable-          doDist opts tempdir distname resultfile-        else do+  raw_tree <-+    case patchSetMatch matchFlags of+      Just psm -> getPristineUpToMatch repository psm+      Nothing -> readPristine repository+  tree <- case predist of+    Nothing -> T.expand raw_tree+    Just pd -> do+      withDelayedDir "dist" $ \d -> do+        writePlainTree raw_tree "."+        ec <- system pd+        unless (ec == ExitSuccess) $ do           putStrLn "Dist aborted due to predist failure"           exitWith ec----- | This function performs the actual distribution action itself.--- NB - it does /not/ perform the pre-dist, that should already--- have completed successfully before this is invoked.-doDist :: [DarcsFlag] -> AbsolutePath -> String -> FilePath -> IO ()-doDist opts tempdir name resultfile = do-    setCurrentDirectory (toFilePath tempdir)-    entries <- pack "." [name]-    putVerbose opts $ vcat $ map (text . entryPath) entries-    writeFile resultfile $ compress $ write entries-    putInfo opts $ text $ "Created dist as " ++ resultfile-+        T.expand =<< readPlainTree (toFilePath d)+  entries <- createEntries distname tree+  putVerbose opts $ vcat $ map (text . Tar.entryPath) entries+  BL.writeFile resultfile $ compress $ Tar.write entries+  putInfo opts $ text $ "Created dist as " ++ resultfile+  where+    createEntries top tree = do+      topentry <- Tar.directoryEntry <$> either fail return (Tar.toTarPath True top)+      rest <- forM (T.list tree) go+      return $ topentry : rest+      where+        go (_, T.Stub _ _) = error "impossible"+        go (path, T.SubTree _) = do+          tarpath <- either fail return $ Tar.toTarPath True (top </> realPath path)+          return $ Tar.directoryEntry tarpath+        go (path, T.File b) = do+          content <- T.readBlob b+          tarpath <- either fail return $ Tar.toTarPath False (top </> realPath path)+          let entry = Tar.fileEntry tarpath content+          return $+            if O.yes (O.setScriptsExecutable ? opts) &&+               executablePrefix `BL.isPrefixOf` content+              then entry {Tar.entryPermissions = Tar.executableFilePermissions}+              else entry+    executablePrefix = BLC.pack "#!"  getDistName :: FilePath -> Maybe String -> FilePath getDistName _ (Just dn) = takeFileName dn@@ -177,7 +170,7 @@   currentdir <- getCurrentDirectory   let distname = getDistName currentdir (O.distname ? opts)   let resultfile = currentdir </> distname ++ ".zip"-  doFastZip' opts currentdir (writeFile resultfile)+  doFastZip' opts currentdir (BL.writeFile resultfile)   putInfo opts $ text $ "Created " ++ resultfile  doFastZip' :: [DarcsFlag]              -- ^ Flags/options@@ -185,16 +178,23 @@            -> (BL.ByteString -> IO a)  -- ^ An action to perform on the archive contents            -> IO a doFastZip' opts path act = withRepositoryLocation (useCache ? opts) path $ RepoJob $ \repo -> do-  when (F.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $+  when (O.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $     putStrLn "WARNING: Zip archives cannot store executable flag."     let distname = getDistName path (O.distname ? opts)-  i <- fetchFilePS (path </> hashedInventoryPath) Uncachable-  pristine <- pathsAndContents (distname ++ "/") (repoCache repo) (peekPristineHash i)+  pristine <-+    T.expand =<<+    case patchSetMatch (O.matchUpToOne ? opts) of+      Just psm -> getPristineUpToMatch repo psm+      Nothing -> readPristine repo+  pathsAndContents <-+    forM (T.list pristine) $ \(p,i) -> do+      case i of+        T.Stub _ _ -> error "tree is not expanded"+        T.SubTree _ -> return (distname </> realPath p ++ "/", BL.empty)+        T.File b -> do+          content <- T.readBlob b+          return (distname </> realPath p, content)   epochtime <- toSeconds `fmap` getCurrentTime-  let entries = [ toEntry filepath epochtime (toLazy contents) | (filepath,contents) <- pristine ]-  let archive = foldr addEntryToArchive emptyArchive entries-  act (fromArchive archive)---toLazy :: B.ByteString -> BL.ByteString-toLazy bs = BL.fromChunks [bs]+  let entries = [ Zip.toEntry filepath epochtime contents | (filepath,contents) <- pathsAndContents ]+  let archive = foldr Zip.addEntryToArchive Zip.emptyArchive entries+  act (Zip.fromArchive archive)
src/Darcs/UI/Commands/GZCRCs.hs view
@@ -45,7 +45,7 @@ -- get at the caches and inspect them directly) -- Could move the relevant code into Darcs.Repository modules -- but it doesn't really seem worth it.-import Darcs.Repository.Cache+import Darcs.Util.Cache     ( allHashedDirs     , cacheEntries     , hashedFilePath@@ -58,7 +58,7 @@     , putInfo, putVerbose     ) import Darcs.UI.Completion ( noArgs )-import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( (^), oid, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) import Darcs.UI.Flags ( DarcsFlag, useCache )@@ -122,10 +122,7 @@     , commandPrereq = amInRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc gzcrcsBasicOpts-    , commandDefaults = defaultFlags gzcrcsOpts-    , commandCheckOptions = ocheck gzcrcsOpts+    , commandOptions = gzcrcsOpts     }   where     gzcrcsBasicOpts = O.gzcrcsActions ^ O.justThisRepo ^ O.repoDir@@ -137,7 +134,7 @@     Nothing -> fail "You must specify --check or --repair for gzcrcs"     Just action -> withRepository (useCache ? opts) (RepoJob (gzcrcs' action opts)) -gzcrcs' :: O.GzcrcsAction -> [DarcsFlag] -> Repository rt p wR wU wT -> IO ()+gzcrcs' :: O.GzcrcsAction -> [DarcsFlag] -> Repository rt p wU wR -> IO () gzcrcs' action opts repo = do     -- Somewhat ugly IORef use here because it's convenient, would be nicer to     -- pre-filter the list of locs to check and then decide whether to print
src/Darcs/UI/Commands/Help.hs view
@@ -27,35 +27,37 @@  import Control.Arrow ( (***) ) import Data.Char ( isAlphaNum, toLower, toUpper )+import System.Directory ( withCurrentDirectory )+import System.FilePath.Posix ( (</>) ) import Data.Either ( partitionEithers ) import Data.List ( groupBy, intercalate, lookup, nub ) import System.Exit ( exitSuccess ) import Version ( version )  import Darcs.Patch.Match ( helpOnMatchers )-import Darcs.Repository.Prefs ( environmentHelpHome, prefsFilesHelp )+import Darcs.Repository.Prefs ( environmentHelpHome, prefsDirPath, prefsFilesHelp )  import Darcs.UI.Commands     ( CommandArgs(..)     , CommandControl(..)     , DarcsCommand(..)+    , commandAlloptions     , commandName     , disambiguateCommands     , extractCommands     , getSubcommands     , nodefaults     , normalCommand+    , withStdOpts     ) import Darcs.UI.External ( viewDoc ) import Darcs.UI.Flags ( DarcsFlag, environmentHelpEmail, environmentHelpSendmail )-import Darcs.UI.Options ( defaultFlags, ocheck, oid )+import Darcs.UI.Options ( oid ) import Darcs.UI.Options.Markdown ( optionsMarkdown ) import qualified Darcs.UI.TheCommands as TheCommands import Darcs.UI.Usage ( getCommandHelp, getSuperCommandHelp, subusage, usage ) -import Darcs.Util.Download ( environmentHelpProxy, environmentHelpProxyPassword ) import Darcs.Util.English ( andClauses )-import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Lock     ( environmentHelpKeepTmpdir     , environmentHelpLocks@@ -128,10 +130,7 @@     , commandPrereq = \_ -> return $ Right ()     , commandCompleteArgs = \_ _ -> return . completeArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = []-    , commandDefaults = defaultFlags oid-    , commandCheckOptions = ocheck oid+    , commandOptions = withStdOpts oid oid     }  helpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()@@ -144,7 +143,7 @@     header = "Preference Files" $$              "================"     render (f, h) =-      let item = "_darcs/prefs/" ++ f in+      let item = prefsDirPath </> f in         text item $$ text (replicate (length item) '-') $$ text h helpCmd _ _ ("environment":vs_) =     viewDoc $ vsep (header : map render known) $+$ footer@@ -232,8 +231,6 @@  environmentHelpSsh,  environmentHelpScp,  environmentHelpSshPort,- environmentHelpProxy,- environmentHelpProxyPassword,  environmentHelpTimeout]  -- | This function is responsible for emitting a darcs "man-page", a@@ -357,7 +354,7 @@        prefFiles :: Doc       prefFiles = vcat $ map go prefsFilesHelp-        where go (f,h) = ".SS" <+> quoted("_darcs/prefs/" <> f) $$ text h+        where go (f,h) = ".SS" <+> quoted(prefsDirPath </> f) $$ text h        description = vcat         [ "Unlike conventional revision control systems, Darcs is based on tracking"@@ -389,7 +386,7 @@  , "", unlines environment ]    where       prefFiles = concatMap go prefsFilesHelp-        where go (f,h) = ["## `_darcs/prefs/" ++ f ++ "`", "", h]+        where go (f,h) = ["## `" ++ prefsDirPath </> f ++ "`", "", h]        environment :: [String]       environment = intercalate [""]@@ -413,11 +410,11 @@           unwords (commandExtraArgHelp c)           , "", commandDescription c           , "", renderString (commandHelp c)-          , "Options:", optionsMarkdown $ commandBasicOptions c-          , if null opts2 then ""-             else unlines ["Advanced Options:", optionsMarkdown opts2]+          , "Options:", optionsMarkdown bopts+          , if null aopts then ""+             else unlines ["Advanced Options:", optionsMarkdown aopts]           ]-       where opts2 = commandAdvancedOptions c+       where (bopts, aopts) = commandAlloptions c  environmentHelpEditor :: ([String], [String]) environmentHelpEditor = (["DARCS_EDITOR", "VISUAL", "EDITOR"],[@@ -432,7 +429,9 @@ environmentHelpPager = (["DARCS_PAGER", "PAGER"],[  "Darcs will invoke a pager if the output of some command is longer",  "than 20 lines. Darcs will use the pager specified by $DARCS_PAGER",- "or $PAGER.  If neither are set, `less` will be used."])+ "or $PAGER.  If neither are set, `less` will be used.  Set $DARCS_PAGER",+ "- or $PAGER if the former is not set - to the empty string in order not",+ "to use a pager."])  environmentHelpTimeout :: ([String], [String]) environmentHelpTimeout = (["DARCS_CONNECTION_TIMEOUT"],[
src/Darcs/UI/Commands/Init.hs view
@@ -31,9 +31,10 @@     , withStdOpts     , putWarning     )+import Darcs.UI.Commands.Util ( commonHelpWithPrefsTemplates ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, withNewRepo )-import Darcs.UI.Options ( defaultFlags, ocheck, odesc, (?), (^) )+import Darcs.UI.Options ( (?), (^) ) import Darcs.UI.Options.All () import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath )@@ -71,7 +72,7 @@     , "the flag `--darcs-1`, althought this is not recommended except for sharing"     , "patches with a project that uses patches in the darcs-1 semantics."     ]-  ] ++ [darcs3Warning]+  ] ++ [darcs3Warning, commonHelpWithPrefsTemplates]  darcs3Warning :: Doc darcs3Warning = formatWords@@ -94,14 +95,11 @@     , commandCommand = initializeCmd     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc initAdvancedOpts-    , commandBasicOptions = odesc initBasicOpts-    , commandDefaults = defaultFlags initOpts-    , commandCheckOptions = ocheck initOpts+    , commandOptions = initOpts     }   where     initBasicOpts = O.patchFormat ^ O.withWorkingDir ^ O.newRepo-    initAdvancedOpts = O.patchIndexNo ^ O.hashed ^ O.umask+    initAdvancedOpts = O.patchIndexNo ^ O.hashed ^ O.umask ^ O.withPrefsTemplates     initOpts = initBasicOpts `withStdOpts` initAdvancedOpts  initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()@@ -130,4 +128,5 @@           (O.withWorkingDir ? opts)           (O.patchIndexNo ? opts)           (O.useCache ? opts)+          (O.withPrefsTemplates ? opts)         putFinished opts $ "initializing repository"
src/Darcs/UI/Commands/Log.hs view
@@ -27,10 +27,11 @@  import Data.List ( intersect, find ) import Data.List.Ordered ( nubSort )-import Data.Maybe ( fromMaybe, isJust )+import Data.Maybe ( catMaybes, fromMaybe, isJust ) import Control.Arrow ( second ) import Control.Exception ( catch, IOException )-import Control.Monad.State.Strict+import Control.Monad ( when, unless )+import Control.Monad.State.Strict ( evalState, get, gets, modify )  import Darcs.UI.PrintPatch ( showFriendly ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAndG, fmapFLPIAP, hopefullyM, info )@@ -40,11 +41,11 @@ import Darcs.UI.External ( viewDocWith ) import Darcs.UI.Flags     ( DarcsFlag-    , changesReverse, onlyToFiles+    , changesReverse, onlyToFiles, diffingOpts     , useCache, maxCount, hasXmlOutput-    , verbosity, withContext, isInteractive, verbose+    , verbosity, isInteractive, verbose     , getRepourl, pathSetFromArgs )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( (^), parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path     ( SubPath@@ -56,9 +57,8 @@     ) import Darcs.Repository ( PatchInfoAnd,                           withRepositoryLocation, RepoJob(..),-                          readRepo, unrecordedChanges,+                          readPatches, unrecordedChanges,                           withRepoLockCanFail )-import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(MyersDiff) ) import Darcs.Util.Lock ( withTempDir ) import Darcs.Patch.Set ( PatchSet, patchSet2RL, Origin ) import Darcs.Patch.Format ( PatchListFormat )@@ -151,10 +151,7 @@     , commandCommand = logCmd     , commandPrereq = findRepository     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc logAdvancedOpts-    , commandBasicOptions = odesc logBasicOpts-    , commandDefaults = defaultFlags logOpts-    , commandCheckOptions = ocheck logOpts+    , commandOptions = logOpts     }   where     logBasicOpts@@ -167,7 +164,7 @@       ^ O.possiblyRemoteRepo       ^ O.repoDir       ^ O.interactive-    logAdvancedOpts = O.network ^ O.patchIndexYes+    logAdvancedOpts = O.remoteDarcs ^ O.patchIndexYes     logOpts = logBasicOpts `withStdOpts` logAdvancedOpts  logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()@@ -179,7 +176,7 @@       (fs, es) <- remoteSubPaths args []       if null es then         withTempDir "darcs.log"-          (\_ -> showLog opts $ maybeNotNull $ nubSort $ map floatSubPath fs)+          (\_ -> showLog opts $ maybeNotNull $ nubSort $ filterErrors $ map floatSubPath fs)       else         fail $ "For a remote repo I can only handle relative paths.\n"             ++ "Invalid arguments: "++unwords es@@ -188,7 +185,7 @@       unless (isInteractive False opts)         $ when (O.patchIndexNo ? opts == O.YesPatchIndex)           $ withRepoLockCanFail (useCache ? opts)-            $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo)+            $ RepoJob (\repo -> readPatches repo >>= attemptCreatePatchIndex repo)       paths <- pathSetFromArgs fps args       showLog opts paths @@ -196,6 +193,9 @@ maybeNotNull [] = Nothing maybeNotNull xs = Just xs +filterErrors :: [Either e a] -> [a]+filterErrors = catMaybes . map (either (const Nothing) Just)+ hasRemoteRepo :: [DarcsFlag] -> Bool hasRemoteRepo = isJust . getRepourl @@ -214,12 +214,12 @@   unless (O.debug ? opts) $ setProgressMode False   Sealed unrec <- case files of     Nothing -> return $ Sealed NilFL-    Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff)-                  O.NoLookForMoves O.NoLookForReplaces-                  repository files-                  `catch` \(_ :: IOException) -> return (Sealed NilFL) -- this is triggered when repository is remote+    Just _ ->+      Sealed `fmap` unrecordedChanges (diffingOpts opts) repository files `catch`+        \(_ :: IOException) ->+          return (Sealed NilFL) -- this is triggered when repository is remote   debugMessage "About to read the repository..."-  patches <- readRepo repository+  patches <- readPatches repository   debugMessage "Done reading the repository."   let recFiles = effectOnPaths (invert unrec) <$> files       filtered_changes p =@@ -242,7 +242,7 @@                     _ -> mempty             debugMessage "About to print the patches..."             let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters-            ps <- readRepo repository -- read repo again to prevent holding onto+            ps <- readPatches repository -- read repo again to prevent holding onto                                        -- values forced by filtered_changes             logOutput <- changelog opts (patchSet2RL ps) `fmap` filtered_changes patches             viewDocWith printers (header $$ logOutput)@@ -272,21 +272,21 @@                  , ApplyState p ~ Tree                  )               => AnchoredPath-              -> PatchFilter rt p-              -> PatchSet rt p Origin wY-              -> IO [Sealed2 (PatchInfoAnd rt p)]+              -> PatchFilter p+              -> PatchSet p Origin wY+              -> IO [Sealed2 (PatchInfoAnd p)] simpleLogInfo path pf ps =   map fst . liPatches <$> getLogInfo Nothing [] False (Just [path]) pf ps -getLogInfo :: forall rt p wY.+getLogInfo :: forall p wY.               ( MatchableRP p               , ApplyState p ~ Tree               )            => Maybe Int -> [MatchFlag] -> Bool            -> Maybe [AnchoredPath]-           -> PatchFilter rt p-           -> PatchSet rt p Origin wY-           -> IO (LogInfo (PatchInfoAnd rt p))+           -> PatchFilter p+           -> PatchSet p Origin wY+           -> IO (LogInfo (PatchInfoAnd p)) getLogInfo maxCountFlag matchFlags onlyToFilesFlag paths patchFilter ps =   case matchRange matchFlags ps of     Sealed2 range ->@@ -322,14 +322,14 @@ -- "Just n" -- returns at most n patches touching the file (starting from the -- beginning of the patch list). filterPatchesByNames-    :: forall rt p.+    :: forall p.        ( MatchableRP p        , ApplyState p ~ Tree        )     => Maybe Int                      -- ^ maxcount     -> [AnchoredPath]                 -- ^ paths-    -> [Sealed2 (PatchInfoAnd rt p)]  -- ^ patches-    -> LogInfo (PatchInfoAnd rt p)+    -> [Sealed2 (PatchInfoAnd p)]  -- ^ patches+    -> LogInfo (PatchInfoAnd p) filterPatchesByNames maxcount paths patches = removeNonRenames $     evalState (filterPatchesByNamesM paths patches) (maxcount, initRenames) where         removeNonRenames li = li { liRenames = removeIds (liRenames li) }@@ -363,12 +363,12 @@                                 modify $ second (const renames')                                 filterPatchesByNamesM fs' ps -changelog :: forall rt p wStart wX+changelog :: forall p wStart wX            . ( ShowPatch p, PatchListFormat p              , Summary p, HasDeps p, PrimDetails (PrimOf p)              )-          => [DarcsFlag] -> RL (PatchInfoAndG rt p) wStart wX-          -> LogInfo (PatchInfoAndG rt p)+          => [DarcsFlag] -> RL (PatchInfoAndG p) wStart wX+          -> LogInfo (PatchInfoAndG p)           -> Doc changelog opts patches li     | O.changesFormat ? opts == Just O.CountPatches =@@ -379,7 +379,7 @@     | otherwise = vsep (map (number_patch description') ps) $$ mbErr     where ps_and_fs = liPatches li           mbErr = fromMaybe mempty (liErrorMsg li)-          change_with_summary :: Sealed2 (PatchInfoAndG rt p) -> Doc+          change_with_summary :: Sealed2 (PatchInfoAndG p) -> Doc           change_with_summary (Sealed2 hp)             | Just p <- hopefullyM hp =               if O.changesFormat ? opts == Just O.MachineReadable@@ -394,7 +394,7 @@             , text "</changelog>"             ] -          xml_with_summary :: Sealed2 (PatchInfoAndG rt p) -> Doc+          xml_with_summary :: Sealed2 (PatchInfoAndG p) -> Doc           xml_with_summary (Sealed2 hp) | Just p <- hopefullyM hp =                     let                       deps = getdeps p@@ -434,10 +434,10 @@                                   Nothing -> f x                              else f x -          get_number :: Sealed2 (PatchInfoAndG re p) -> Maybe Int+          get_number :: Sealed2 (PatchInfoAndG p) -> Maybe Int           get_number (Sealed2 y) = gn 1 patches               where iy = info y-                    gn :: Int -> RL (PatchInfoAndG rt p) wStart wY -> Maybe Int+                    gn :: Int -> RL (PatchInfoAndG p) wStart wY -> Maybe Int                     gn n (bs:<:b) | seq n (info b) == iy = Just n                                   | otherwise = gn (n+1) bs                     gn _ NilRL = Nothing@@ -448,7 +448,7 @@ logContext opts = do   let repodir = fromMaybe "." $ getRepourl opts   withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do-      (_ :> ps) <- contextPatches `fmap` readRepo repository+      (_ :> ps) <- contextPatches `fmap` readPatches repository       let header = text "\nContext:\n"       viewDocWith simplePrinters $ vsep           (header : mapRL (showPatchInfo ForStorage . info) ps)@@ -474,5 +474,4 @@     , S.interactive = isInteractive False flags     , S.selectDeps = O.PromptDeps -- option not supported, use default     , S.withSummary = O.withSummary ? flags-    , S.withContext = withContext ? flags     }
src/Darcs/UI/Commands/MarkConflicts.hs view
@@ -25,12 +25,11 @@ import Data.List.Ordered ( nubSort, isect ) import Control.Monad ( when, unless, void ) -import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Path ( AbsolutePath, AnchoredPath, anchorPath ) import Darcs.Util.Printer-    ( Doc, pathlist, putDocLnWith, text, redText, debugDocLn, vsep, (<+>), ($$) )-import Darcs.Util.Printer.Color ( fancyPrinters )+    ( Doc, formatWords, pathlist, text, debugDocLn+    , vcat, vsep, (<+>), ($$) )  import Darcs.UI.Commands     ( DarcsCommand(..)@@ -45,28 +44,31 @@ import Darcs.UI.Flags     ( DarcsFlag, diffingOpts, verbosity, dryRun, umask     , useCache, pathSetFromArgs )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( (^), (?) ) import qualified Darcs.UI.Options.All as O -import Darcs.Repository.Flags ( UpdatePending (..) ) import Darcs.Repository     ( withRepoLock     , RepoJob(..)     , addToPending+    , finalizeRepositoryChanges     , applyToWorking-    , readRepo+    , readPatches     , unrecordedChanges )  import Darcs.Patch ( invert, listTouchedFiles, effectOnPaths ) import Darcs.Patch.Show import Darcs.Patch.TouchesFiles ( chooseTouching )-import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL )+import Darcs.Patch.Witnesses.Ordered ( mapFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Repository.Resolution     ( StandardResolution(..)     , patchsetConflictResolutions     , warnUnmangled     )+import Darcs.Patch.Named ( anonymous )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch.Set ( patchSetSnoc )  -- * The mark-conflicts command @@ -75,29 +77,49 @@  "Mark unresolved conflicts in working tree, for manual resolution."  markconflictsHelp :: Doc-markconflictsHelp = text $ unlines- ["Darcs requires human guidance to unify changes to the same part of a"- ,"source file.  When a conflict first occurs, darcs will add the"- ,"initial state and both choices to the working tree, delimited by the"- ,"markers `v v v`, `=====`,  `* * *` and `^ ^ ^`, as follows:"- ,""- ,"    v v v v v v v"- ,"    Initial state."- ,"    ============="- ,"    First choice."- ,"    *************"- ,"    Second choice."- ,"    ^ ^ ^ ^ ^ ^ ^"- ,""- ,"However, you might revert or manually delete these markers without"- ,"actually resolving the conflict.  In this case, `darcs mark-conflicts`"- ,"is useful to show where are the unresolved conflicts.  It is also"- ,"useful if `darcs apply` or `darcs pull` is called with"- ,"`--allow-conflicts`, where conflicts aren't marked initially."- ,""- ,"Unless you use the `--dry-run` flag, any unrecorded changes to the"- ,"affected files WILL be lost forever when you run this command!"- ,"You will be prompted for confirmation before this takes place."+markconflictsHelp = vsep $+  [ formatWords+    [ "Darcs requires human guidance to reconcile independent changes to the same"+    , "part of a file.  When a conflict first occurs, darcs will add the"+    , "initial state and all conflicting choices to the working tree, delimited"+    , " by the markers `v v v`, `=====`,  `* * *` and `^ ^ ^`, as follows:"+    ]+  , vcat $ map text+    [ "    v v v v v v v"+    , "    initial state"+    , "    ============="+    , "    first choice"+    , "    *************"+    , "    ...more choices..."+    , "    *************"+    , "    last choice"+    , "    ^ ^ ^ ^ ^ ^ ^"+    ]+  ] ++ map formatWords+  [ [ "If you happened to revert or manually delete this conflict markup without"+    , "actually resolving the conflict, `darcs mark-conflicts` can be used to"+    , "re-create it; and similarly if you have used `darcs apply` or `darcs pull`"+    , "with `--allow-conflicts`, where conflicts aren't marked initially."+    ]+  , [ "In Darcs, a conflict counts as resolved when all of the changes"+    , "involved in the conflict (which can be more than two) are depended on by"+    , "one or more later patches. If you record a resolution for a particular"+    , "conflict, `darcs mark-conflicts` will no longer mark it, indicating that"+    , "it is resolved. If you have unrecorded changes, these count as (potential)"+    , "conflict resolutions, too, just as if you had already recorded them."+    ]+  , [ "This principle extends to explicit \"semantic\" dependencies. For instance,"+    , "recording a tag will automatically mark all conflicts as resolved."+    ]+  , [ "In the above schematic example the \"initial state\" corresponds to the"+    , "recorded state of the file in your repository. That is to say, the"+    , "recorded effect of a conflict is to apply none of the conflicting changes."+    , "This is usually not a state you would regard as a successful resolution"+    , "of the conflict; but there are exceptional situations where this may be"+    , "exactly what you want. In order to tell Darcs that you want this conflict"+    , "to be regarded as resolved, use `darcs record --ask-deps` to record a"+    , "patch that explicitly depends on all patches involved in the conflict."+    ]  ]  markconflicts :: DarcsCommand@@ -112,15 +134,11 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = knownFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc markconflictsAdvancedOpts-    , commandBasicOptions = odesc markconflictsBasicOpts-    , commandDefaults = defaultFlags markconflictsOpts-    , commandCheckOptions = ocheck markconflictsOpts+    , commandOptions = markconflictsOpts     }   where     markconflictsBasicOpts-      = O.useIndex-      ^ O.repoDir+      = O.repoDir       ^ O.diffAlgorithm       ^ O.dryRunXml     markconflictsAdvancedOpts = O.umask@@ -130,7 +148,7 @@ markconflictsCmd fps opts args = do   paths <- maybeToOnly <$> pathSetFromArgs fps args   debugDocLn $ "::: paths =" <+>  (text . show) paths-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+  withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \_repository -> do  {-@@ -141,25 +159,17 @@     * read conflict resolutions that touch pre-pending argument paths     * affected paths = intersection of paths touched by resolutions                        and pre-pending argument paths-    * for these paths, revert pending changes-    * apply the (filtered, see above) conflict resolutions--    Technical side-note:-    Ghc can't handle pattern bindings for existentials. So 'let' is out,-    one has to use 'case expr of var ->' or 'do var <- return expr'.-    Case is clearer but do-notation does not increase indentation depth.-    So we use case for small-scope bindings and <-/return when the scope-    is a long do block.+    * apply the conflict resolutions for affected paths -} -    let (useidx, scan, _) = diffingOpts opts-        verb = verbosity ? opts     classified_paths <--      traverse (filterExistingPaths _repository verb useidx scan O.NoLookForMoves) paths+      traverse+        (filterExistingPaths _repository (verbosity ? opts) (diffingOpts opts))+        paths -    unrecorded <- unrecordedChanges (diffingOpts opts)-      O.NoLookForMoves O.NoLookForReplaces-      _repository (fromOnly Everything)+    unrecorded <-+      unrecordedChanges (diffingOpts opts) _repository (fromOnly Everything)+    anonpw <- n2pia `fmap` anonymous unrecorded      let forward_renames = effectOnPaths unrecorded         backward_renames = effectOnPaths (invert unrecorded)@@ -167,12 +177,12 @@         pre_pending_paths = fmap backward_renames existing_paths     debugDocLn $ "::: pre_pending_paths =" <+> (text . show) pre_pending_paths -    r <- readRepo _repository-    Sealed res <- case patchsetConflictResolutions r of+    r <- readPatches _repository+    -- by including anonpw in the patch set, we regard unrecorded changes+    -- as potential conflict resolutions "under construction"+    Sealed res <- case patchsetConflictResolutions $ patchSetSnoc r anonpw of       conflicts -> do-        -- FIXME this should warn only about unmangled conflicts-        -- involving the file paths we care about-        warnUnmangled conflicts+        warnUnmangled (fromOnly pre_pending_paths) conflicts         Sealed mangled_res <- return $ mangled conflicts         let raw_res_paths = pathSet $ listTouchedFiles mangled_res         debugDocLn $ "::: raw_res_paths =" <+>  (text . show) raw_res_paths@@ -187,47 +197,19 @@       putInfo opts "No conflicts to mark."       exitSuccess -    to_revert <- unrecordedChanges (diffingOpts opts)-      O.NoLookForMoves O.NoLookForReplaces-      _repository (fromOnly affected_paths)-     let post_pending_affected_paths = forward_renames <$> affected_paths     putInfo opts $ "Marking conflicts in:" <+> showPathSet post_pending_affected_paths <> "." -    debugDocLn $ "::: to_revert =" $$ vsep (mapFL displayPatch to_revert)     debugDocLn $ "::: res = " $$ vsep (mapFL displayPatch res)     when (O.yes (dryRun ? opts)) $ do         putInfo opts $ "Conflicts will not be marked: this is a dry run."         exitSuccess -    _repository <- case to_revert of-      NilFL -> return _repository-      _ -> do-        -- TODO:-        -- (1) create backups for all files where we revert changes-        -- (2) try to add the reverted stuff to the unrevert bundle-        -- after (1) and (2) is done we can soften the warning below-        putDocLnWith fancyPrinters $-          "Warning: This will revert all unrecorded changes in:"-          <+> showPathSet post_pending_affected_paths <> "."-          $$ redText "These changes will be LOST."-        confirmed <- promptYorn "Are you sure? "-        unless confirmed exitSuccess--{-      -- copied from Revert.hs, see comment (2) above-        debugMessage "About to write the unrevert file."-        case commute (norevert:>p) of-          Just (p':>_) -> writeUnrevert repository p' recorded NilFL-          Nothing -> writeUnrevert repository (norevert+>+p) recorded NilFL-        debugMessage "About to apply to the working tree."--}--        let to_add = invert to_revert-        addToPending _repository (O.useIndex ? opts) to_add-        applyToWorking _repository (verbosity ? opts) to_add-    withSignalsBlocked $-      do addToPending _repository (O.useIndex ? opts) res-         void $ applyToWorking _repository (verbosity ? opts) res+    addToPending _repository (diffingOpts opts) res+    withSignalsBlocked $ do+      _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+      unless (O.yes (O.dryRun ? opts)) $+        void $ applyToWorking _repository (verbosity ? opts) res     putFinished opts "marking conflicts"  -- * Generic 'PathSet' support
src/Darcs/UI/Commands/Move.hs view
@@ -19,7 +19,7 @@  import Darcs.Prelude -import Control.Monad ( when, unless, forM_, forM )+import Control.Monad ( when, unless, forM_, forM, void ) import Data.Maybe ( fromMaybe ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) @@ -31,23 +31,29 @@ import Darcs.UI.Flags     ( DarcsFlag     , allowCaseDifferingFilenames, allowWindowsReservedFilenames-    , useCache, dryRun, umask, pathsFromArgs+    , useCache, umask, pathsFromArgs     )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( (^), (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Diff ( treeDiff )-import Darcs.Repository.Flags ( UpdatePending (..), DiffAlgorithm(..) )+import Darcs.Repository.Flags ( DiffAlgorithm(..) ) import Darcs.Repository.Prefs ( filetypeFunction ) import System.Directory ( renameDirectory, renameFile )-import Darcs.Repository.State ( readRecordedAndPending, readRecorded, updateIndex )+import Darcs.Repository.State+    ( readPristine+    , readPristineAndPending+    , readUnrecordedFiltered+    ) import Darcs.Repository     ( Repository+    , AccessType(..)     , withRepoLock     , RepoJob(..)-    , addPendingDiffToPending+    , unsafeAddToPending+    , finalizeRepositoryChanges     ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )-import Darcs.Patch.Witnesses.Sealed ( emptyGap, freeGap, joinGap, FreeLeft )+import Darcs.Patch.Witnesses.Sealed ( FreeLeft, emptyGap, freeGap, joinGap ) import Darcs.Util.Global ( debugMessage ) import qualified Darcs.Patch import Darcs.Patch ( RepoPatch, PrimPatch )@@ -55,9 +61,14 @@ import Data.List.Ordered ( nubSort ) import qualified System.FilePath.Windows as WindowsFilePath -import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase, treeHasFile )-import Darcs.Util.Tree( Tree, modifyTree )-import Darcs.Util.Tree.Plain( readPlainTree )+import Darcs.Util.Tree+    ( Tree+    , modifyTree+    , treeHas+    , treeHasAnycase+    , treeHasDir+    , treeHasFile+    ) import Darcs.Util.Path     ( AbsolutePath     , AnchoredPath@@ -100,10 +111,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = knownFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc moveAdvancedOpts-    , commandBasicOptions = odesc moveBasicOpts-    , commandDefaults = defaultFlags moveOpts-    , commandCheckOptions = ocheck moveOpts+    , commandOptions = moveOpts     }   where     moveBasicOpts = O.allowProblematicFilenames ^ O.repoDir@@ -209,22 +217,33 @@     else       fail "Some of the paths you want to move aren't know to darcs. Use `darcs add` to add them first." +{-+data RepoAndState = RS+  { repo :: Repository 'RW p wU wR+  , working :: Tree IO+  , current :: Tree IO+  , recorded :: Tree IO+  }+-}+ withRepoAndState :: [DarcsFlag]-                 -> (forall rt p wR wU .+                 -> (forall p wR wU .                         (ApplyState p ~ Tree, RepoPatch p) =>-                            (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO)+                            (Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO)                                 -> IO ())                  -> IO () withRepoAndState opts f =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repo -> do-        work <- readPlainTree "."-        cur <- readRecordedAndPending repo-        recorded <- readRecorded repo+        work <-+          readUnrecordedFiltered repo (O.useIndex ? opts)+            O.EvenLookForBoring O.NoLookForMoves Nothing+        cur <- readPristineAndPending repo+        recorded <- readPristine repo         f (repo, work, cur, recorded)  simpleMove :: (RepoPatch p, ApplyState p ~ Tree)-           => Repository rt p wR wU wR+           => Repository 'RW p wU wR            -> [DarcsFlag] -> Tree IO -> Tree IO -> AnchoredPath -> AnchoredPath            -> IO () simpleMove repository opts cur work old new = do@@ -232,7 +251,7 @@     putInfo opts $ hsep $ map text ["Finished moving:", displayPath old, "to:", displayPath new]  moveToDir :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository rt p wR wU wR+          => Repository 'RW p wU wR           -> [DarcsFlag] -> Tree IO -> Tree IO -> [AnchoredPath] -> AnchoredPath           -> IO () moveToDir repository opts cur work moved finaldir = do@@ -245,7 +264,7 @@     putInfo opts $ hsep $ map text $ ["Finished moving:"] ++ map displayPath moved ++ ["to:", displayPath finaldir]  doMoves :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository rt p wR wU wR+          => Repository 'RW p wU wR           -> [DarcsFlag] -> Tree IO -> Tree IO           -> [(AnchoredPath, AnchoredPath)] -> IO () doMoves repository opts cur work moves = do@@ -258,9 +277,9 @@           pendingDiff = joinGap (+>+)             (fromMaybe (emptyGap NilFL) prePatch)             (freeGap $ Darcs.Patch.move old new :>: NilFL)-      addPendingDiffToPending repository pendingDiff       moveFileOrDir work old new-    updateIndex repository+      unsafeAddToPending repository pendingDiff+    void $ finalizeRepositoryChanges repository (O.dryRun ? opts)  -- Take the recorded/ working trees and the old and intended new filenames; -- check if the new path is safe on windows. We potentially need to create
src/Darcs/UI/Commands/Optimize.hs view
@@ -16,51 +16,41 @@ --  Boston, MA 02110-1301, USA.  {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module Darcs.UI.Commands.Optimize ( optimize ) where  import Darcs.Prelude  import Control.Monad ( when, unless, forM_ )-import Data.List ( nub )-import Data.Maybe ( fromJust, isJust ) import System.Directory     ( listDirectory     , doesDirectoryExist     , renameFile     , createDirectoryIfMissing     , removeFile-    , getHomeDirectory     , removeDirectoryRecursive+    , withCurrentDirectory     )-import qualified Data.ByteString.Char8 as BC import Darcs.UI.Commands ( DarcsCommand(..), nodefaults                          , amInHashedRepository, amInRepository, putInfo                          , normalCommand, withStdOpts ) import Darcs.UI.Completion ( noArgs )-import Darcs.Repository.Prefs ( getPreflist, getCaches, globalCacheDir )+import Darcs.Repository.Prefs ( Pref(Defaultrepo), getPreflist, globalCacheDir ) import Darcs.Repository     ( Repository+    , AccessType(RW)     , repoLocation     , withRepoLock     , RepoJob(..)-    , readRepo+    , readPatches     , reorderInventory     , cleanRepository-    , replacePristine     ) import Darcs.Repository.Job ( withOldRepoLock )-import Darcs.Repository.Identify ( findAllReposInDir )-import Darcs.Repository.Traverse-    ( diffHashLists-    , listInventoriesRepoDir-    , listPatchesLocalBucketed-    , specialPatches-    )-import Darcs.Repository.Inventory ( peekPristineHash )+import Darcs.Repository.Traverse ( specialPatches ) import Darcs.Repository.Paths     ( formatPath-    , hashedInventoryPath     , inventoriesDir     , inventoriesDirPath     , oldCheckpointDirPath@@ -75,14 +65,9 @@     , tentativePristinePath     ) import Darcs.Repository.Packs ( createPacks )-import Darcs.Repository.HashedIO ( getHashedFiles )-import Darcs.Repository.Inventory ( getValidHash )-import Darcs.Patch.Witnesses.Ordered-     ( mapFL-     , bunchFL-     , lengthRL-     )-import Darcs.Patch ( IsRepoType, RepoPatch )+import Darcs.Patch.Witnesses.Ordered ( lengthRL )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Invertible ( mkInvertible ) import Darcs.Patch.Set     ( patchSet2RL     , patchSet2FL@@ -90,7 +75,7 @@     ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Util.ByteString ( gzReadFilePS )-import Darcs.Util.Printer ( Doc, formatWords, text, wrapText, ($+$) )+import Darcs.Util.Printer ( Doc, formatWords, wrapText, ($+$) ) import Darcs.Util.Lock     ( maybeRelink     , gzWriteAtomicFilePS@@ -98,11 +83,7 @@     , removeFileMayNotExist     , writeBinFile     )-import Darcs.Util.File-    ( withCurrentDirectory-    , getRecursiveContents-    , doesDirectoryReallyExist-    )+import Darcs.Util.File ( doesDirectoryReallyExist ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Progress     ( beginTedious@@ -110,7 +91,6 @@     , tediousSize     , debugMessage     )-import Darcs.Util.Global ( darcsdir )  import System.FilePath.Posix     ( takeExtension@@ -120,19 +100,19 @@ import Text.Printf ( printf ) import Darcs.UI.Flags     (  DarcsFlag, useCache, umask )-import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck-                        , defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( DarcsOption, (?), (^) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags-    ( UpdatePending (..), DryRun ( NoDryRun ), UseCache (..), UMask (..)-    , WithWorkingDir(WithWorkingDir), PatchFormat(PatchFormat1) )+    ( PatchFormat(PatchFormat1)+    , UMask(..)+    , WithWorkingDir(WithWorkingDir)+    ) import Darcs.Patch.Progress ( progressFL )-import Darcs.Repository.Cache ( hashedDir, bucketFolder,-                                HashedDir(HashedPristineDir) )+import Darcs.Util.Cache ( allHashedDirs, bucketFolder, cleanCaches, mkDirCache ) import Darcs.Repository.Format     ( identifyRepoFormat     , createRepoFormat-    , writeRepoFormat+    , unsafeWriteRepoFormat     , formatHas     , RepoProperty ( HashedInventory )     )@@ -141,11 +121,10 @@     ( writeTentativeInventory     , finalizeTentativeChanges     )+import Darcs.Repository.InternalTypes ( repoCache, unsafeCoerceR ) import Darcs.Repository.Pristine-    ( ApplyDir(ApplyNormal)-    , applyToTentativePristineCwd+    ( applyToTentativePristine     )-import Darcs.Repository.State ( readRecorded )  import Darcs.Util.Tree     ( Tree@@ -154,12 +133,9 @@     , expand     , emptyTree     )-import Darcs.Util.Path( realPath, toFilePath, AbsolutePath )+import Darcs.Util.Path ( AbsolutePath, realPath, toFilePath ) import Darcs.Util.Tree.Plain( readPlainTree )-import Darcs.Util.Tree.Hashed-    ( writeDarcsHashed-    , decodeDarcsSize-    )+import Darcs.Util.Tree.Hashed ( writeDarcsHashed )  optimizeDescription :: String optimizeDescription = "Optimize the repository."@@ -186,7 +162,6 @@                               normalCommand optimizeCompress,                               normalCommand optimizeUncompress,                               normalCommand optimizeRelink,-                              normalCommand optimizePristine,                               normalCommand optimizeUpgrade,                               normalCommand optimizeGlobalCache                            ]@@ -210,10 +185,7 @@     , commandDescription = undefined     , commandCommand =  undefined     , commandCompleteArgs = noArgs-    , commandAdvancedOptions = odesc commonAdvancedOpts-    , commandBasicOptions = odesc commonBasicOpts-    , commandDefaults = defaultFlags commonOpts-    , commandCheckOptions = ocheck commonOpts+    , commandOptions = commonOpts     }   where     commonOpts = commonBasicOpts `withStdOpts` commonAdvancedOpts@@ -222,16 +194,16 @@ optimizeClean :: DarcsCommand optimizeClean = common     { commandName = "clean"-    , commandDescription = "garbage collect pristine, inventories and patches"+    , commandDescription = "Garbage collect pristine, inventories and patches"     , commandHelp = optimizeHelpClean     , commandCommand = optimizeCleanCmd     }  optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeCleanCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repository -> do-      cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+      cleanRepository repository       putInfo opts "Done cleaning repository!"  optimizeUpgrade :: DarcsCommand@@ -239,50 +211,34 @@     { commandName = "upgrade"     , commandHelp = wrapText 80         "Convert old-fashioned repositories to the current default hashed format."-    , commandDescription = "upgrade repository to latest compatible format"+    , commandDescription = "Upgrade repository to latest compatible format"     , commandPrereq = amInRepository     , commandCommand = optimizeUpgradeCmd+    , commandOptions =+        withStdOpts commonBasicOpts commonAdvancedOpts     }  optimizeHttp :: DarcsCommand optimizeHttp = common     { commandName = "http"     , commandHelp = optimizeHelpHttp-    , commandDescription = "optimize repository for getting over network"+    , commandDescription = "Optimize repository for getting over network"     , commandCommand = optimizeHttpCmd     }  optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeHttpCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repository -> do-      cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+      cleanRepository repository       createPacks repository       putInfo opts "Done creating packs!" -optimizePristine :: DarcsCommand-optimizePristine = common-    { commandName = "pristine"-    , commandHelp = wrapText 80 $-        "This command updates the format of `"++pristineDirPath++-        "`, which was different\nbefore darcs 2.3.1."-    , commandDescription = "optimize hashed pristine layout"-    , commandCommand = optimizePristineCmd-    }--optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-optimizePristineCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $-    RepoJob $ \repository -> do-      cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories-      doOptimizePristine opts repository-      putInfo opts "Done optimizing pristine!"- optimizeCompress :: DarcsCommand optimizeCompress = common     { commandName = "compress"     , commandHelp = optimizeHelpCompression-    , commandDescription = "compress patches and inventories"+    , commandDescription = "Compress hashed files"     , commandCommand = optimizeCompressCmd     } @@ -290,25 +246,25 @@ optimizeUncompress = common     { commandName = "uncompress"     , commandHelp = optimizeHelpCompression-    , commandDescription = "uncompress patches and inventories"+    , commandDescription = "Uncompress hashed files (for debugging)"     , commandCommand = optimizeUncompressCmd     }  optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeCompressCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repository -> do-      cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+      cleanRepository repository       optimizeCompression O.GzipCompression opts       putInfo opts "Done optimizing by compression!"  optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeUncompressCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repository -> do-      cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+      cleanRepository repository       optimizeCompression O.NoCompression opts-      putInfo opts "Done optimizing by uncompression!"+      putInfo opts "Done uncompressing hashed files."  optimizeCompression :: O.Compression -> [DarcsFlag] -> IO () optimizeCompression compression opts = do@@ -316,6 +272,8 @@     do_compress patchesDirPath     putInfo opts "Optimizing (un)compression of inventories..."     do_compress inventoriesDirPath+    putInfo opts "Optimizing (un)compression of pristine..."+    do_compress pristineDirPath     where       do_compress f = do         isd <- doesDirectoryExist f@@ -351,15 +309,15 @@  optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeEnablePatchIndexCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repository -> do-      ps <- readRepo repository+      ps <- readPatches repository       createOrUpdatePatchIndexDisk repository ps       putInfo opts "Done enabling patch index!"  optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeDisablePatchIndexCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repo -> do       deletePatchIndex (repoLocation repo)       putInfo opts "Done disabling patch index!"@@ -370,30 +328,38 @@     , commandHelp = formatWords         [ "This command moves recent patches (those not included in"         , "the latest tag) to the \"front\", reducing the amount that a typical"-        , "remote command needs to download.  It should also reduce the CPU time"-        , "needed for some operations."+        , "remote command needs to download. It should also reduce the CPU time"+        , "needed for some operations. This is the behavior with --shallow"+        , "which is the default."         ]-    , commandDescription = "reorder the patches in the repository"+        $+$ formatWords+        [ "With the --deep option it tries to optimize all tags in the whole"+        , "repository. This breaks the history of patches into smaller"+        , "bunches, which can further improve efficiency, but requires all"+        , "patches to be present. It is therefore less suitable for lazy clones."+        ]+    , commandDescription = "Reorder the patches in the repository"     , commandCommand = optimizeReorderCmd+    , commandOptions =+        withStdOpts basicOpts commonAdvancedOpts     }+  where+    basicOpts = commonBasicOpts ^ O.optimizeDeep  optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeReorderCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repository -> do-      reorderInventory repository (O.compress ? opts)+      reorderInventory repository (O.optimizeDeep ? opts)       putInfo opts "Done reordering!"  optimizeRelink :: DarcsCommand optimizeRelink = common     { commandName = "relink"     , commandHelp = optimizeHelpRelink -    , commandDescription = "relink random internal data to a sibling"+    , commandDescription = "Replace copies of hashed files with hard links"     , commandCommand = optimizeRelinkCmd-    , commandAdvancedOptions = odesc commonAdvancedOpts-    , commandBasicOptions = odesc optimizeRelinkBasicOpts-    , commandDefaults = defaultFlags optimizeRelinkOpts-    , commandCheckOptions = ocheck optimizeRelinkOpts+    , commandOptions = optimizeRelinkOpts     }   where     optimizeRelinkBasicOpts = commonBasicOpts ^ O.siblings@@ -401,9 +367,9 @@  optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeRelinkCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repository -> do-      cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+      cleanRepository repository       doRelink opts       putInfo opts "Done relinking!" @@ -425,10 +391,11 @@ optimizeHelpCompression :: Doc optimizeHelpCompression =   formatWords-  [ "By default patches are compressed with zlib (RFC 1951) to reduce"-  , "storage (and download) size.  In exceptional circumstances, it may be"-  , "preferable to avoid compression.  In this case the `--dont-compress`"-  , "option can be used (e.g. with `darcs record`) to avoid compression."+  [ "Patches, inventories, and pristine files are compressed with zlib"+  , "(RFC 1951) to reduce storage (and download) size."+  , "Older darcs versions allowed to store them"+  , "uncompressed, and darcs is still able to"+  , "read those files if they are not compressed."   ]   $+$ formatWords   [ "The `darcs optimize uncompress` and `darcs optimize compress`"@@ -451,22 +418,10 @@   , "into multiple local repositories."   ] -doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO ()-doOptimizePristine opts repo = do-    inv <- BC.readFile hashedInventoryPath-    let linesInv = BC.split '\n' inv-    case linesInv of-      [] -> return ()-      (pris_line:_) ->-          let size = decodeDarcsSize $ BC.drop 9 pris_line-           in when (isJust size) $ do putInfo opts "Optimizing hashed pristine..."-                                      readRecorded repo >>= replacePristine repo-                                      cleanRepository repo- doRelink :: [DarcsFlag] -> IO () doRelink opts =-    do let some_siblings = parseFlags O.siblings opts-       defrepolist <- getPreflist "defaultrepo"+    do let some_siblings = O.siblings ? opts+       defrepolist <- getPreflist Defaultrepo        let siblings = map toFilePath some_siblings ++ defrepolist        if null siblings           then putInfo opts "No siblings -- no relinking done."@@ -495,39 +450,34 @@   if formatHas HashedInventory rf      then putInfo opts "No action taken because this repository already is hashed."      else do putInfo opts "Upgrading to hashed..."-             withOldRepoLock $ RepoJob actuallyUpgradeFormat+             withOldRepoLock $ RepoJob $ actuallyUpgradeFormat opts  actuallyUpgradeFormat-  :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wT -> IO ()-actuallyUpgradeFormat repository = do+  :: (RepoPatch p, ApplyState p ~ Tree)+  => [DarcsFlag] -> Repository 'RW p wU wR -> IO ()+actuallyUpgradeFormat _opts _repository = do   -- convert patches/inventory-  patches <- readRepo repository+  patches <- readPatches _repository   let k = "Hashing patch"   beginTedious k   tediousSize k (lengthRL $ patchSet2RL patches)   let patches' = progressPatchSet k patches-  -- darcs optimize subcommands do not support-  -- the --no-cache option, so use default-  cache <- getCaches YesUseCache "."-  let compressDefault = O.compress ? []-  writeTentativeInventory cache compressDefault patches'+  writeTentativeInventory _repository patches'   endTedious k   -- convert pristine by applying patches   -- the faster alternative would be to copy pristine, but the apply method   -- is more reliable   -- TODO we should do both and then comapre them   let patchesToApply = progressFL "Applying patch" $ patchSet2FL patches'-  createDirectoryIfMissing False $ darcsdir </> hashedDir HashedPristineDir+  createDirectoryIfMissing False pristineDirPath   -- We ignore the returned root hash, we don't use it.-  _ <- writeDarcsHashed emptyTree $ darcsdir </> hashedDir HashedPristineDir+  _ <- writeDarcsHashed emptyTree (repoCache _repository)   writeBinFile tentativePristinePath ""-  sequence_ $-    mapFL (applyToTentativePristineCwd ApplyNormal) $-    bunchFL 100 patchesToApply+  -- we must coerce here because we just emptied out pristine+  applyToTentativePristine (unsafeCoerceR _repository) (mkInvertible patchesToApply)   -- now make it official-  finalizeTentativeChanges repository compressDefault-  writeRepoFormat (createRepoFormat PatchFormat1 WithWorkingDir) formatPath+  finalizeTentativeChanges _repository+  unsafeWriteRepoFormat (createRepoFormat PatchFormat1 WithWorkingDir) formatPath   -- clean out old-fashioned junk   debugMessage "Cleaning out old-fashioned repository files..."   removeFileMayNotExist oldInventoryPath@@ -592,10 +542,10 @@ optimizeGlobalCache :: DarcsCommand optimizeGlobalCache = common     { commandName = "cache"-    , commandExtraArgs            = -1-    , commandExtraArgHelp         = [ "<DIRECTORY> ..." ]+    , commandExtraArgs = 0+    , commandExtraArgHelp = []     , commandHelp = optimizeHelpGlobalCache-    , commandDescription = "garbage collect global cache"+    , commandDescription = "Garbage collect global cache"     , commandCommand = optimizeGlobalCacheCmd     , commandPrereq = \_ -> return $ Right ()     }@@ -603,11 +553,6 @@ optimizeHelpGlobalCache :: Doc optimizeHelpGlobalCache = formatWords   [ "This command deletes obsolete files within the global cache."-  , "It takes one or more directories as arguments, and recursively"-  , "searches all repositories within these directories. Then it deletes"-  , "all files in the global cache not belonging to these repositories."-  , "When no directory is given, it searches repositories in the user's"-  , "home directory."   ]   $+$ formatWords   [ "It also automatically migrates the global cache to the (default)"@@ -615,49 +560,9 @@   ]  optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-optimizeGlobalCacheCmd _ opts args = do+optimizeGlobalCacheCmd _ opts _ = do   optimizeBucketed opts-  home <- getHomeDirectory-  let args' = if null args then [home] else args-  cleanGlobalCache args' opts+  globalCacheDir >>= \case+    Just dir -> mapM_ (cleanCaches (mkDirCache dir)) allHashedDirs+    Nothing -> return ()   putInfo opts "Done cleaning global cache!"--cleanGlobalCache :: [String] -> [DarcsFlag] -> IO ()-cleanGlobalCache dirs opts = do-  putInfo opts "\nLooking for repositories in the following directories:"-  putInfo opts $ text $ unlines dirs-  gCacheDir' <- globalCacheDir-  repoPaths'  <- mapM findAllReposInDir dirs--  putInfo opts "Finished listing repositories."--  let repoPaths         = nub $ concat repoPaths'-      gCache            = fromJust gCacheDir'-      gCacheInvDir      = gCache </> inventoriesDir-      gCachePatchesDir  = gCache </> patchesDir-      gCachePristineDir = gCache </> pristineDir--  createDirectoryIfMissing True gCacheInvDir-  createDirectoryIfMissing True gCachePatchesDir-  createDirectoryIfMissing True gCachePristineDir--  remove listInventoriesRepoDir gCacheInvDir repoPaths-  remove (listPatchesLocalBucketed gCache . (</> darcsdir)) gCachePatchesDir repoPaths-  remove getPristine gCachePristineDir repoPaths--  where-  remove fGetFiles cacheSubDir repoPaths = do-    s1 <- mapM fGetFiles repoPaths-    s2 <- getRecursiveContents cacheSubDir-    remove' cacheSubDir s2 (concat s1)--  remove' :: String -> [String] -> [String] -> IO ()-  remove' dir s1 s2 =-    mapM_ (removeFileMayNotExist . (\hashedFile ->-      dir </> bucketFolder hashedFile </> hashedFile))-      (diffHashLists s1 s2)--  getPristine :: String -> IO [String]-  getPristine repoDir = do-    i <- gzReadFilePS (repoDir </> hashedInventoryPath)-    getHashedFiles (repoDir </> pristineDirPath) [getValidHash $ peekPristineHash i]
src/Darcs/UI/Commands/Pull.hs view
@@ -44,20 +44,20 @@     ( DarcsFlag     , fixUrl, getOutput     , changesReverse, verbosity,  dryRun, umask, useCache, selectDeps-    , remoteRepos, reorder, setDefault-    , withContext, hasXmlOutput+    , reorder, setDefault+    , hasXmlOutput     , isInteractive, quiet     )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdatePending (..) ) import Darcs.Repository     ( Repository+    , AccessType(..)     , identifyRepositoryFor     , ReadingOrWriting(..)     , withRepoLock     , RepoJob(..)-    , readRepo+    , readPatches     , modifyCache     , mkCache     , cacheEntries@@ -68,18 +68,28 @@     )  import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefully, patchDesc )-import Darcs.Patch ( IsRepoType, RepoPatch, description )+import Darcs.Patch ( RepoPatch, description ) import qualified Darcs.Patch.Bundle as Bundle ( makeBundle ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Set ( PatchSet, Origin, emptyPatchSet, SealedPatchSet ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal ) import Darcs.Patch.Witnesses.Ordered-    ( (:>)(..), (:\/:)(..), FL(..), Fork(..)+    ( (:>)(..), FL(..), Fork(..)     , mapFL, nullFL, mapFL_FL ) import Darcs.Patch.Permutations ( partitionFL )-import Darcs.Repository.Prefs ( addToPreflist, addRepoSource, getPreflist, showMotd )-import Darcs.Patch.Depends ( findUncommon, findCommonAndUncommon,-                             patchSetIntersection, patchSetUnion )+import Darcs.Repository.Prefs+    ( Pref(Defaultrepo, Repos)+    , addRepoSource+    , addToPreflist+    , getPreflist+    , showMotd+    )+import Darcs.Patch.Depends+    ( findCommon+    , findCommonWithThem+    , patchSetIntersection+    , patchSetUnion+    ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..) ) import Darcs.UI.Completion ( prefArgs ) import Darcs.UI.Commands.Util ( checkUnrelatedRepos, getUniqueDPatchName )@@ -162,12 +172,9 @@     , commandExtraArgHelp = ["[REPOSITORY]..."]     , commandCommand = fetchCmd     , commandPrereq = amInHashedRepository-    , commandCompleteArgs = prefArgs "repos"+    , commandCompleteArgs = prefArgs Repos     , commandArgdefaults = defaultRepo-    , commandAdvancedOptions = odesc advancedOpts-    , commandBasicOptions = odesc basicOpts-    , commandDefaults = defaultFlags allOpts-    , commandCheckOptions = ocheck allOpts+    , commandOptions = allOpts     }   where     basicOpts@@ -184,8 +191,7 @@       ^ O.diffAlgorithm     advancedOpts       = O.repoCombinator-      ^ O.remoteRepos-      ^ O.network+      ^ O.remoteDarcs     allOpts = basicOpts `withStdOpts` advancedOpts  pull :: DarcsCommand@@ -198,12 +204,9 @@     , commandExtraArgHelp = ["[REPOSITORY]..."]     , commandCommand = pullCmd StandardPatchApplier     , commandPrereq = amInHashedRepository-    , commandCompleteArgs = prefArgs "repos"+    , commandCompleteArgs = prefArgs Repos     , commandArgdefaults = defaultRepo-    , commandAdvancedOptions = odesc advancedOpts-    , commandBasicOptions = odesc basicOpts-    , commandDefaults = defaultFlags allOpts-    , commandCheckOptions = ocheck allOpts+    , commandOptions = allOpts     }   where     basicOpts@@ -211,8 +214,7 @@       ^ O.reorder       ^ O.interactive       ^ O.conflictsYes-      ^ O.externalMerge-      ^ O.runTest+      ^ O.testChanges       ^ O.dryRunXml       ^ O.withSummary       ^ O.selectDeps@@ -223,14 +225,11 @@       ^ O.diffAlgorithm     advancedOpts       = O.repoCombinator-      ^ O.compress-      ^ O.useIndex-      ^ O.remoteRepos       ^ O.setScriptsExecutable       ^ O.umask       ^ O.changesReverse       ^ O.pauseForGui-      ^ O.network+      ^ O.remoteDarcs     allOpts = basicOpts `withStdOpts` advancedOpts  pullCmd@@ -239,7 +238,7 @@ pullCmd patchApplier (_,o) opts repos =   do     pullingFrom <- mapM (fixUrl o) repos-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $      repoJob patchApplier $ \patchProxy initRepo -> do       let repository = modifyCache (addReposToCache pullingFrom) initRepo       Sealed fork <- fetchPatches o opts repos "pull" repository@@ -252,37 +251,37 @@  fetchCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fetchCmd (_,o) opts repos =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $+    withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $         fetchPatches o opts repos "fetch" >=> makeBundle opts -fetchPatches :: forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+fetchPatches :: (RepoPatch p, ApplyState p ~ Tree)              => AbsolutePath -> [DarcsFlag] -> [String] -> String-             -> Repository rt p wR wU wR-             -> IO (Sealed (Fork (PatchSet rt p)-                                 (FL (PatchInfoAnd rt p))-                                 (FL (PatchInfoAnd rt p)) Origin wR))-fetchPatches o opts unfixedrepodirs@(_:_) jobname repository = do+             -> Repository 'RW p wU wR+             -> IO (Sealed (Fork (PatchSet p)+                                 (FL (PatchInfoAnd p))+                                 (FL (PatchInfoAnd p)) Origin wR))+fetchPatches o opts unfixedrepourls@(_:_) jobname repository = do   here <- getCurrentDirectory-  repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl o) unfixedrepodirs+  repourls <- (nub . filter (/= here)) `fmap` mapM (fixUrl o) unfixedrepourls   -- Test to make sure we aren't trying to pull from the current repo-  when (null repodirs) $+  when (null repourls) $         fail "Can't pull from current repository!"-  old_default <- getPreflist "defaultrepo"-  when (old_default == repodirs && not (hasXmlOutput opts)) $+  old_default <- getPreflist Defaultrepo+  when (old_default == repourls && not (hasXmlOutput opts)) $       let pulling = case dryRun ? opts of                       O.YesDryRun -> "Would pull"                       O.NoDryRun -> "Pulling"-      in  putInfo opts $ text pulling <+> "from" <+> hsep (map quoted repodirs) <> "..."-  (Sealed them, Sealed compl) <- readRepos repository opts repodirs-  addRepoSource (head repodirs) (dryRun ? opts) (remoteRepos ? opts)-      (setDefault False opts) (O.inheritDefault ? opts) (isInteractive True opts)-  mapM_ (addToPreflist "repos") repodirs-  unless (quiet opts || hasXmlOutput opts) $ mapM_ showMotd repodirs-  us <- readRepo repository+      in  putInfo opts $ text pulling <+> "from" <+> hsep (map quoted repourls) <> "..."+  (Sealed them, Sealed compl) <- readRepos repository opts repourls+  addRepoSource (head repourls) (dryRun ? opts)+      (setDefault False opts) (O.inheritDefault ? opts)+  mapM_ (addToPreflist Repos) repourls+  unless (quiet opts || hasXmlOutput opts) $ mapM_ showMotd repourls+  us <- readPatches repository   checkUnrelatedRepos (parseFlags O.allowUnrelatedRepos opts) us them -  Fork common us' them' <- return $ findCommonAndUncommon us them-  _   :\/: compl' <- return $ findUncommon us compl+  Fork common us' them' <- return $ findCommon us them+  _ :> compl' <- return $ findCommonWithThem compl us    let avoided = mapFL info compl'   ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) them'@@ -297,7 +296,7 @@       vcat (mapFL description ps)   (hadConflicts, Sealed psFiltered)     <- if O.conflictsYes ? opts == Nothing-        then filterOutConflicts repository us' ps+        then filterOutConflicts repository (O.useIndex ? opts) us' ps         else return (False, Sealed ps)   when hadConflicts $ putInfo opts $ text "Skipping some patches which would cause conflicts."   when (nullFL psFiltered) $ do putInfo opts $ text "No remote patches to pull in!"@@ -311,20 +310,20 @@ fetchPatches _ _ [] jobname _ = fail $   "No default repository to " ++ jobname ++ " from, please specify one" -makeBundle :: forall rt p wR . (RepoPatch p, ApplyState p ~ Tree)+makeBundle :: forall p wR . (RepoPatch p, ApplyState p ~ Tree)            => [DarcsFlag]-           -> (Sealed (Fork (PatchSet rt p)-                      (FL (PatchInfoAnd rt p))-                      (FL (PatchInfoAnd rt p)) Origin wR))+           -> (Sealed (Fork (PatchSet p)+                      (FL (PatchInfoAnd p))+                      (FL (PatchInfoAnd p)) Origin wR))            -> IO () makeBundle opts (Sealed (Fork common _ to_be_fetched)) =     do       bundle <- Bundle.makeBundle Nothing common $                  mapFL_FL hopefully to_be_fetched-      fname <- case to_be_fetched of+      let fname = case to_be_fetched of                     (x:>:_)-> getUniqueDPatchName $ patchDesc x                     _ -> error "impossible case"-      let o = fromMaybe stdOut (getOutput opts fname)+      o <- fromMaybe (return stdOut) (getOutput opts fname)       useAbsoluteOrStd writeDocBinFile putDoc o bundle  {- Read in the specified pull-from repositories.  Perform@@ -345,13 +344,13 @@ the second patchset(s) to be complemented against Rc. -} -readRepos :: (IsRepoType rt, RepoPatch p)-          => Repository rt p wR wU wT -> [DarcsFlag] -> [String]-          -> IO (SealedPatchSet rt p Origin,SealedPatchSet rt p Origin)+readRepos :: RepoPatch p+          => Repository rt p wU wR -> [DarcsFlag] -> [String]+          -> IO (SealedPatchSet p Origin,SealedPatchSet p Origin) readRepos _ _ [] = error "impossible case" readRepos to_repo opts us =     do rs <- mapM (\u -> do r <- identifyRepositoryFor Reading to_repo (useCache ? opts) u-                            ps <- readRepo r+                            ps <- readPatches r                             return $ seal ps) us        return $ case parseFlags O.repoCombinator opts of                   O.Intersection -> (patchSetIntersection rs, seal emptyPatchSet)@@ -365,5 +364,4 @@     , S.interactive = isInteractive True flags     , S.selectDeps = selectDeps ? flags     , S.withSummary = O.withSummary ? flags-    , S.withContext = withContext ? flags     }
src/Darcs/UI/Commands/Push.hs view
@@ -38,12 +38,10 @@ import Darcs.UI.Completion ( prefArgs ) import Darcs.UI.Flags     ( DarcsFlag-    , isInteractive, verbosity, withContext-    , xmlOutput, selectDeps, applyAs, remoteDarcs-    , changesReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl )-import Darcs.UI.Options-    ( (^), odesc, ocheck-    , defaultFlags, parseFlags, (?) )+    , isInteractive, verbosity+    , xmlOutput, selectDeps, applyAs+    , changesReverse, dryRun, useCache, setDefault, fixUrl )+import Darcs.UI.Options ( (?), (^) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( DryRun (..) ) import qualified Darcs.Repository.Flags as R ( remoteDarcs )@@ -53,15 +51,19 @@     , Repository     , identifyRepositoryFor     , ReadingOrWriting(..)-    , readRepo+    , readPatches     , withRepository     )-import Darcs.Patch ( IsRepoType, RepoPatch, description )+import Darcs.Patch ( RepoPatch, description ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered     ( (:>)(..), RL, FL, nullRL,     nullFL, reverseFL, mapFL_FL, mapRL )-import Darcs.Repository.Prefs ( addRepoSource, getPreflist )+import Darcs.Repository.Prefs+    ( Pref(Defaultrepo, Repos)+    , addRepoSource+    , getPreflist+    ) import Darcs.UI.External ( signString, darcsProgram                          , pipeDoc, pipeDocSSH ) import Darcs.Util.Exception ( die )@@ -107,6 +109,14 @@     , "current repository into another repository."     ]   $+$ formatWords+    [ "The --reorder-patches option works in the same way as it does for pull"+    , "and apply: instead of placing the new patches (coming from your local"+    , "repository) on top of (i.e. after) the existing (remote) ones, it puts"+    , "the remote-only patches on top of the ones that you are pushing. This"+    , "can be useful, for instance, if you have recorded a tag locally and want"+    , "this tag to be clean in the remote repository after pushing."+    ]+  $+$ formatWords     [ "If you give the `--apply-as` flag, darcs will use `sudo` to apply the"     , "patches as a different user.  This can be useful if you want to set up a"     , "system where several users can modify the same repository, but you don't"@@ -133,12 +143,9 @@     , commandExtraArgHelp = ["[REPOSITORY]"]     , commandCommand = pushCmd     , commandPrereq = amInHashedRepository-    , commandCompleteArgs = prefArgs "repos"+    , commandCompleteArgs = prefArgs Repos     , commandArgdefaults = defaultRepo-    , commandAdvancedOptions = odesc pushAdvancedOpts-    , commandBasicOptions = odesc pushBasicOpts-    , commandDefaults = defaultFlags pushOpts-    , commandCheckOptions = ocheck pushOpts+    , commandOptions = pushOpts     }   where     pushBasicOpts@@ -152,12 +159,12 @@       ^ O.setDefault       ^ O.inheritDefault       ^ O.allowUnrelatedRepos+      ^ O.reorderPush     pushAdvancedOpts       = O.applyAs-      ^ O.remoteRepos       ^ O.changesReverse       ^ O.compress-      ^ O.network+      ^ O.remoteDarcs     pushOpts = pushBasicOpts `withStdOpts` pushAdvancedOpts  pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()@@ -169,7 +176,7 @@   when (repodir == here) $ die "Cannot push from repository to itself."   bundle <-     withRepository (useCache ? opts) $ RepoJob $ prepareBundle opts repodir-  sbundle <- signString (parseFlags O.sign opts) bundle+  sbundle <- signString (O.sign ? opts) bundle   let body =         if isValidLocalPath repodir           then sbundle@@ -183,42 +190,43 @@ pushCmd _ _ [] = die "No default repository to push to, please specify one." pushCmd _ _ _ = die "Cannot push to more than one repo." -prepareBundle :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-              => [DarcsFlag] -> String -> Repository rt p wR wU wT -> IO Doc+prepareBundle :: (RepoPatch p, ApplyState p ~ Tree)+              => [DarcsFlag] -> String -> Repository rt p wU wR -> IO Doc prepareBundle opts repodir repository = do-  old_default <- getPreflist "defaultrepo"+  old_default <- getPreflist Defaultrepo   when (old_default == [repodir]) $        let pushing = if dryRun ? opts == YesDryRun then "Would push" else "Pushing"        in  putInfo opts $ text pushing <+> "to" <+> quoted repodir <> "..."-  them <- identifyRepositoryFor Writing repository (useCache ? opts) repodir >>= readRepo-  addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts)-      (setDefault False opts) (O.inheritDefault ? opts) (isInteractive True opts)-  us <- readRepo repository-  common :> us' <- return $ findCommonWithThem us them-  prePushChatter opts us (reverseFL us') them+  them <- identifyRepositoryFor Writing repository (useCache ? opts) repodir >>= readPatches+  addRepoSource repodir (dryRun ? opts) (setDefault False opts)+      (O.inheritDefault ? opts)+  us <- readPatches repository+  common :> only_us <- return $ findCommonWithThem us them+  prePushChatter opts us (reverseFL only_us) them   let direction = if changesReverse ? opts then FirstReversed else First       selection_config = selectionConfig direction "push" (pushPatchSelOpts opts) Nothing Nothing-  runSelection us' selection_config+  runSelection only_us selection_config                    >>= bundlePatches opts common -prePushChatter :: forall rt p a wX wY wT . (RepoPatch p, ShowPatch a) =>-                 [DarcsFlag] -> PatchSet rt p Origin wX ->-                 RL a wT wX -> PatchSet rt p Origin wY -> IO ()-prePushChatter opts us us' them = do-  checkUnrelatedRepos (parseFlags O.allowUnrelatedRepos opts) us them+prePushChatter :: (RepoPatch p, ShowPatch a)+               => [DarcsFlag] -> PatchSet p Origin wX+               -> RL a wC wX -> PatchSet p Origin wY -> IO ()+prePushChatter opts us only_us them = do+  checkUnrelatedRepos (O.allowUnrelatedRepos ? opts) us them   let num_to_pull = snd $ countUsThem us them       pull_reminder = if num_to_pull > 0                       then text $ "The remote repository has " ++ show num_to_pull                       ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull."                       else empty-  putVerbose opts $ text "We have the following patches to push:" $$ vcat (mapRL description us')-  unless (nullRL us') $ putInfo opts pull_reminder-  when (nullRL us') $ do putInfo opts $ text "No recorded local patches to push!"-                         exitSuccess+  putVerbose opts $ text "We have the following patches to push:" $$ vcat (mapRL description only_us)+  unless (nullRL only_us) $ putInfo opts pull_reminder+  when (nullRL only_us) $ do+      putInfo opts $ text "No recorded local patches to push!"+      exitSuccess -bundlePatches :: forall t rt p wZ wW wA. (RepoPatch p, ApplyState p ~ Tree)-              => [DarcsFlag] -> PatchSet rt p wA wZ-              -> (FL (PatchInfoAnd rt p) :> t) wZ wW+bundlePatches :: (RepoPatch p, ApplyState p ~ Tree)+              => [DarcsFlag] -> PatchSet p wA wZ+              -> (FL (PatchInfoAnd p) :> t) wZ wW               -> IO Doc bundlePatches opts common (to_be_pushed :> _) =     do@@ -244,18 +252,17 @@        let lprot = takeWhile (/= ':') repodir            msg = text ("Pushing to "++lprot++" URLs is not supported.")        abortRun opts msg-   else when (parseFlags O.sign opts /= O.NoSign) $+   else when (O.sign ? opts /= O.NoSign) $         abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh."   pushPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions pushPatchSelOpts flags = S.PatchSelectionOptions     { S.verbosity = verbosity ? flags-    , S.matchFlags = parseFlags O.matchSeveral flags+    , S.matchFlags = O.matchSeveral ? flags     , S.interactive = isInteractive True flags     , S.selectDeps = selectDeps ? flags     , S.withSummary = O.withSummary ? flags-    , S.withContext = withContext ? flags     }  remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode@@ -266,29 +273,48 @@             | otherwise -> applyViaLocal opts repodir bundle         Just un             | isSshUrl repodir -> applyViaSshAndSudo opts (splitSshUrl repodir) un bundle-            | otherwise -> applyViaSudo un repodir bundle+            | otherwise -> applyViaSudo opts un repodir bundle -applyViaSudo :: String -> String -> Doc -> IO ExitCode-applyViaSudo user repo bundle =-    darcsProgram >>= \darcs ->-    pipeDoc "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle+applyViaSudo :: [DarcsFlag] -> String -> String -> Doc -> IO ExitCode+applyViaSudo opts user repo bundle =+  darcsProgram >>= \darcs ->+    pipeDoc "sudo" ("-u" : user : darcs : darcsArgs opts repo) bundle  applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode applyViaLocal opts repo bundle =-    darcsProgram >>= \darcs ->-    pipeDoc darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle+  darcsProgram >>= \darcs -> pipeDoc darcs (darcsArgs opts repo) bundle  applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode applyViaSsh opts repo =-    pipeDocSSH (parseFlags O.compress opts) repo-           [R.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++-                     " --repodir '"++sshRepo repo++"'"]+  pipeDocSSH+    (O.compress ? opts)+    repo+    [ unwords $+        R.remoteDarcs (O.remoteDarcs ? opts) :+        darcsArgs opts (shellQuote (sshRepo repo))+    ]  applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode applyViaSshAndSudo opts repo username =-    pipeDocSSH (parseFlags O.compress opts) repo-           ["sudo -u "++username++" "++R.remoteDarcs (remoteDarcs opts)++-                     " apply --all --repodir '"++sshRepo repo++"'"]+  pipeDocSSH+    (O.compress ? opts)+    repo+    [ unwords $+        "sudo" : "-u" : username :+        R.remoteDarcs (O.remoteDarcs ? opts) :+        darcsArgs opts (shellQuote (sshRepo repo))+    ] -applyopts :: [DarcsFlag] -> [String]-applyopts opts = if parseFlags O.debug opts then ["--debug"] else []+darcsArgs :: [DarcsFlag] -> String -> [String]+darcsArgs opts repodir = "apply" : standardFlags ++ reorderFlags ++ debugFlags+  where+    standardFlags = ["--all", "--repodir", repodir]+    reorderFlags = if O.yes (O.reorderPush ? opts) then ["--reorder-patches"] else []+    debugFlags = if O.debug ? opts then ["--debug"] else []++shellQuote :: String -> String+shellQuote s = "'" ++ escapeQuote s ++ "'"+  where+    escapeQuote [] = []+    escapeQuote cs@('\'':_) = '\\' : escapeQuote cs+    escapeQuote (c:cs) = c : escapeQuote cs
src/Darcs/UI/Commands/Rebase.hs view
@@ -11,61 +11,70 @@     , normalCommand, hiddenCommand     , commandAlias     , defaultRepo, nodefaults-    , putInfo, putVerbose+    , putInfo     , amInHashedRepository     ) import Darcs.UI.Commands.Apply ( applyCmd ) import Darcs.UI.Commands.Log ( changelog, logInfoFL ) import Darcs.UI.Commands.Pull ( pullCmd ) import Darcs.UI.Commands.Util ( historyEditHelp, preselectPatches )-import Darcs.UI.Completion ( fileArgs, prefArgs, noArgs )+import Darcs.UI.Completion ( Pref(Repos), fileArgs, prefArgs, noArgs ) import Darcs.UI.Flags     ( DarcsFlag-    , externalMerge, allowConflicts-    , compress, diffingOpts-    , dryRun, reorder, verbosity, verbose+    , allowConflicts+    , diffingOpts+    , reorder, verbosity     , useCache, wantGuiPause     , umask, changesReverse     , diffAlgorithm, isInteractive     , selectDeps, hasXmlOutput     ) import qualified Darcs.UI.Flags as Flags ( getAuthor )-import Darcs.UI.Options-    ( (^), oid, odesc, ocheck-    , defaultFlags, (?)-    )+import Darcs.UI.Options ( oid, (?), (^) ) import qualified Darcs.UI.Options.All as O-import Darcs.UI.PatchHeader ( HijackT, HijackOptions(..), runHijackT-                            , getAuthor-                            , updatePatchHeader, AskAboutDeps(..) )+import Darcs.UI.PatchHeader+    ( AskAboutDeps(..)+    , HijackOptions(..)+    , HijackT+    , editLog+    , getAuthor+    , patchHeaderConfig+    , runHijackT+    , updatePatchHeader+    ) import Darcs.Repository-    ( Repository, RepoJob(..), withRepoLock, withRepository-    , tentativelyAddPatch, finalizeRepositoryChanges-    , invalidateIndex-    , tentativelyRemovePatches, readRepo-    , tentativelyAddToPending, unrecordedChanges, applyToWorking-    , revertRepositoryChanges+    ( Repository, RepoJob(..), AccessType(..), withRepoLock, withRepository+    , tentativelyAddPatches, finalizeRepositoryChanges+    , tentativelyRemovePatches, readPatches+    , setTentativePending, unrecordedChanges, applyToWorking     )-import Darcs.Repository.Flags ( UpdatePending(..), ExternalMerge(..) )-import Darcs.Repository.Hashed ( upgradeOldStyleRebase )+import Darcs.Repository.Flags+    ( AllowConflicts(..)+    , ResolveConflicts(..)+    , UpdatePending(..)+    ) import Darcs.Repository.Merge ( tentativelyMergePatches ) import Darcs.Repository.Rebase-    ( readRebase+    ( checkHasRebase+    , readRebase     , readTentativeRebase     , writeTentativeRebase     ) import Darcs.Repository.Resolution     ( StandardResolution(..)-    , standardResolution+    , rebaseResolution     , announceConflicts     )+import Darcs.Repository.State ( updateIndex )+import Darcs.Repository.Transaction ( upgradeOldStyleRebase ) -import Darcs.Patch ( invert, effect, commute, RepoPatch, displayPatch )+import Darcs.Patch ( PrimOf, invert, effect, commute, RepoPatch ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.CommuteFn ( commuterIdFL )-import Darcs.Patch.Info ( displayPatchInfo )+import Darcs.Patch.CommuteFn ( commuterFLId, commuterIdFL )+import Darcs.Patch.Info ( displayPatchInfo, piName ) import Darcs.Patch.Match ( secondMatch, splitSecondFL )-import Darcs.Patch.Named ( Named, fmapFL_Named, patchcontents, patch2patchinfo )+import Darcs.Patch.Merge ( cleanMerge )+import Darcs.Patch.Named ( fmapFL_Named, patchcontents, patch2patchinfo ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia ) import Darcs.Patch.Prim ( canonizeFL, PrimPatch ) import Darcs.Patch.Rebase.Change@@ -73,15 +82,18 @@     , extractRebaseChange, reifyRebaseChange     , partitionUnconflicted     , WithDroppedDeps(..), WDDNamed, commuterIdWDD-    , toRebaseChanges     , simplifyPush, simplifyPushes     )-import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims )+import Darcs.Patch.Rebase.Fixup+    ( RebaseFixup(..)+    , commuteNamedFixup+    , flToNamesPrims+    ) import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed ) import Darcs.Patch.Rebase.Suspended ( Suspended(..), addToEditsToSuspended )-import Darcs.Patch.Permutations ( partitionConflictingFL )+import qualified Darcs.Patch.Rebase.Suspended as S ( simplifyPush )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanFL, partitionConflictingFL ) import Darcs.Patch.Progress ( progressRL )-import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Set ( PatchSet, Origin, patchSet2RL ) import Darcs.Patch.Split ( primSplitter ) import Darcs.UI.ApplyPatches@@ -91,6 +103,13 @@     , applyPatchesFinish     ) import Darcs.UI.External ( viewDocWith )+import Darcs.UI.PrintPatch+    ( printContent+    , printContentWithPager+    , printFriendly+    , printSummary+    )+import Darcs.UI.Prompt ( PromptChoice(..), PromptConfig(..), runPrompt ) import Darcs.UI.SelectChanges     ( runSelection, runInvertibleSelection     , selectionConfig, selectionConfigGeneric, selectionConfigPrim@@ -103,35 +122,39 @@     ( FL(..), (+>+), mapFL_FL     , concatFL, mapFL, nullFL, lengthFL, reverseFL     , (:>)(..)+    , (:\/:)(..)+    , (:/\:)(..)     , RL(..), reverseRL, mapRL_RL     , Fork(..)+    , (+>>+)     ) import Darcs.Patch.Witnesses.Sealed     ( Sealed(..), seal, unseal-    , FlippedSeal(..)     , Sealed2(..)     ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.English ( englishNum, Noun(Noun) ) import Darcs.Util.Printer-    ( text, ($$), redText+    ( text, redText+    , putDocLnWith, prefix     , simplePrinters-    , renderString     , formatWords     , formatText-    , ($+$)+    , vcat+    , ($+$), ($$)     ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Path ( AbsolutePath )  import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Tree ( Tree )-import Darcs.Util.Exception ( die ) -import Control.Monad ( when, void )+import Control.Exception ( throwIO, try )+import Control.Monad ( unless, when, void ) import Control.Monad.Trans ( liftIO )-import System.Exit ( exitSuccess )+import System.Exit ( ExitCode(ExitSuccess), exitSuccess )  rebase :: DarcsCommand rebase = SuperCommand@@ -145,6 +168,7 @@         , normalCommand apply         , normalCommand suspend         , normalCommand unsuspend+        , normalCommand edit         , hiddenCommand reify         , hiddenCommand inject         , normalCommand obliterate@@ -200,10 +224,7 @@     , commandCommand = suspendCmd     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc suspendAdvancedOpts-    , commandBasicOptions = odesc suspendBasicOpts-    , commandDefaults = defaultFlags suspendOpts-    , commandCheckOptions = ocheck suspendOpts+    , commandOptions = suspendOpts     }   where     suspendBasicOpts@@ -215,7 +236,6 @@       ^ O.diffAlgorithm     suspendAdvancedOpts       = O.changesReverse-      ^ O.useIndex       ^ O.umask     suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts     suspendDescription =@@ -223,9 +243,7 @@  suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () suspendCmd _ opts _args =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $-    StartRebaseJob $-    \_repository -> do+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do     suspended <- readTentativeRebase _repository     (_ :> candidates) <- preselectPatches opts _repository     let direction = if changesReverse ? opts then Last else LastReversed@@ -242,51 +260,51 @@     runHijackT RequestHijackPermission         $ mapM_ (getAuthor "suspend" False Nothing)         $ mapFL info psToSuspend-    _repository <- doSuspend opts _repository suspended psToSuspend-    _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)-    return ()+    (_repository, Sealed toWorking) <-+      doSuspend "suspend" opts _repository suspended psToSuspend+    withSignalsBlocked $ do+      void $ finalizeRepositoryChanges _repository (O.dryRun ? opts)+      unless (O.yes (O.dryRun ? opts)) $+        void $ applyToWorking _repository (verbosity ? opts) toWorking  doSuspend-    :: forall p wR wU wX-     . (RepoPatch p, ApplyState p ~ Tree)-    => [DarcsFlag]-    -> Repository ('RepoType 'IsRebase) p wR wU wR-    -> Suspended p wR wR-    -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wR-    -> IO (Repository ('RepoType 'IsRebase) p wR wU wX)-doSuspend opts _repository suspended psToSuspend = do-    let (_, _, da) = diffingOpts opts-    pend <- unrecordedChanges (diffingOpts opts)-      O.NoLookForMoves O.NoLookForReplaces-      _repository Nothing-    FlippedSeal psAfterPending <--        let effectPsToSuspend = effect psToSuspend in-        case commute (effectPsToSuspend :> pend) of-            Just (_ :> res) -> return (FlippedSeal res)-            Nothing -> do-                putVerbose opts $-                    let invPsEffect = invert effectPsToSuspend-                    in-                    case (partitionConflictingFL invPsEffect pend, partitionConflictingFL pend invPsEffect) of-                        (_ :> invSuspendedConflicts, _ :> pendConflicts) ->-                            let suspendedConflicts = invert invSuspendedConflicts in-                            redText "These changes in the suspended patches:" $$-                            displayPatch suspendedConflicts $$-                            redText "...conflict with these local changes:" $$-                            displayPatch pendConflicts-                fail $ "Can't suspend selected patches without reverting some unrecorded change."-                    ++ if (verbose opts) then "" else " Use --verbose to see the details."---    invalidateIndex _repository-    _repository <--      tentativelyRemovePatches _repository (compress ? opts) YesUpdatePending psToSuspend-    tentativelyAddToPending _repository $ invert $ effect psToSuspend-    new_suspended <- addToEditsToSuspended da (mapFL_FL hopefully psToSuspend) suspended-    writeTentativeRebase _repository new_suspended-    withSignalsBlocked $-      void $ applyToWorking _repository (verbosity ? opts) (invert psAfterPending)-    return _repository+    :: (RepoPatch p, ApplyState p ~ Tree)+    => String+    -> [DarcsFlag]+    -> Repository 'RW p wU wR+    -> Suspended p wR+    -> FL (PatchInfoAnd p) wX wR+    -> IO (Repository 'RW p wU wX, Sealed (FL (PrimOf p) wU))+doSuspend cmdname opts _repository suspended to_suspend = do+  unrecorded <- unrecordedChanges (diffingOpts opts) _repository Nothing+  case genCommuteWhatWeCanFL (commuterFLId commute) (effect to_suspend :> unrecorded) of+    unrecorded' :> to_suspend_after_unrecorded :> to_revert -> do+      effect_to_suspend <-+        case to_revert of+          NilFL -> return to_suspend_after_unrecorded+          _ ->+            if isInteractive True opts then do+              putStrLn $+                "These unrecorded changes conflict with the " ++ cmdname ++ ":"+              printFriendly O.Verbose O.NoSummary to_revert+              yes <- promptYorn "Do you want to revert these changes?"+              if yes then+                return $ to_suspend_after_unrecorded +>+ to_revert+              else do+                putStrLn $ "Okay, " ++ cmdname ++ " cancelled."+                exitSuccess+            else+              fail $+                "Can't suspend these patches without reverting some unrecorded changes."+      _repository <-+        tentativelyRemovePatches _repository NoUpdatePending to_suspend+      -- rely on sifting to commute out prims not belonging in pending:+      setTentativePending _repository unrecorded'+      new_suspended <-+        addToEditsToSuspended (O.diffAlgorithm ? opts)+          (mapFL_FL hopefully to_suspend) suspended+      writeTentativeRebase _repository new_suspended+      return (_repository, Sealed (invert effect_to_suspend))  unsuspend :: DarcsCommand unsuspend = DarcsCommand@@ -300,10 +318,7 @@     , commandCommand = unsuspendCmd "unsuspend" False     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc unsuspendAdvancedOpts-    , commandBasicOptions = odesc unsuspendBasicOpts-    , commandDefaults = defaultFlags unsuspendOpts-    , commandCheckOptions = ocheck unsuspendOpts+    , commandOptions = unsuspendOpts     }   where     unsuspendBasicOpts@@ -311,12 +326,14 @@       ^ O.matchSeveralOrFirst       ^ O.interactive       ^ O.withSummary-      ^ O.externalMerge-      ^ O.keepDate       ^ O.author+      ^ O.selectAuthor+      ^ O.patchname+      ^ O.askDeps+      ^ O.askLongComment+      ^ O.keepDate       ^ O.diffAlgorithm-    unsuspendAdvancedOpts = O.useIndex-    unsuspendOpts = unsuspendBasicOpts `withStdOpts` unsuspendAdvancedOpts+    unsuspendOpts = unsuspendBasicOpts `withStdOpts` oid     unsuspendDescription =       "Select suspended patches to restore to the end of the repo." @@ -332,15 +349,13 @@     , commandCommand = unsuspendCmd "reify" True     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc reifyBasicOpts-    , commandDefaults = defaultFlags reifyOpts-    , commandCheckOptions = ocheck reifyOpts+    , commandOptions = reifyOpts     }   where     reifyBasicOpts       = O.matchSeveralOrFirst       ^ O.interactive+      ^ O.withSummary       ^ O.keepDate       ^ O.author       ^ O.diffAlgorithm@@ -349,21 +364,19 @@       "Select suspended patches to restore to the end of the repo,\       \ reifying any fixup patches." -unsuspendCmd :: String -> Bool -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+unsuspendCmd :: String -> Bool -> (AbsolutePath, AbsolutePath)+             -> [DarcsFlag] -> [String] -> IO () unsuspendCmd cmd reifyFixups _ opts _args =-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $-  RebaseJob $-  \_repository -> do-    IsEq <- requireNoUnrecordedChanges _repository--    Items selects <- readTentativeRebase _repository+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    checkHasRebase _repository+    Items suspended <- readTentativeRebase _repository      let matchFlags = O.matchSeveralOrFirst ? opts     inRange :> outOfRange <-         return $             if secondMatch matchFlags then-            splitSecondFL rcToPia matchFlags selects-            else selects :> NilFL+            splitSecondFL rcToPia matchFlags suspended+            else suspended :> NilFL      offer :> dontoffer <-         return $@@ -376,7 +389,9 @@      warnSkip dontoffer -    let selection_config = selectionConfigGeneric rcToPia First "unsuspend" (patchSelOpts True opts) Nothing+    let selection_config =+          selectionConfigGeneric rcToPia First cmd+            (patchSelOpts True opts) Nothing     (chosen :> keep) <- runSelection offer selection_config     when (nullFL chosen) $ do putStrLn "No patches selected!"                               exitSuccess@@ -388,103 +403,112 @@           reifyRebaseChange author chosen         else return $ extractRebaseChange (diffAlgorithm ? opts) chosen -    let da = diffAlgorithm ? opts-        ps_to_keep = simplifyPushes da chosen_fixups $+    let ps_to_keep = simplifyPushes da chosen_fixups $                      keep +>+ reverseRL dontoffer +>+ outOfRange -    context <- readRepo _repository+    context <- readPatches _repository      let conflicts =-          standardResolution (patchSet2RL context) $+          rebaseResolution (patchSet2RL context) $           progressRL "Examining patches for conflicts" $-          mapRL_RL (n2pia . wddPatch) $+          mapRL_RL wddPatch $           reverseFL ps_to_unsuspend -    have_conflicts <- announceConflicts "unsuspend"-        (allowConflicts opts) (externalMerge ? opts) conflicts-    Sealed resolved_p <--        case (externalMerge ? opts, have_conflicts) of-            (NoExternalMerge, _) ->-                case O.conflictsYes ? opts of-                    Just O.YesAllowConflicts -> return $ seal NilFL -- i.e. don't mark them-                    _ -> return $ mangled conflicts-            (_, False) -> return $ mangled conflicts-            (YesExternalMerge _, True) ->-                error "external resolution for unsuspend not implemented yet"+    have_conflicts <- announceConflicts cmd (allowConflicts opts) conflicts+    debugMessage "Working out conflict markup..."+    Sealed resolution <-+      if have_conflicts then+        case O.conflictsYes ? opts of+          Just (YesAllowConflicts (ExternalMerge _)) ->+            error $ "external resolution for "++cmd++" not implemented yet"+          Just (YesAllowConflicts NoResolveConflicts) -> return $ seal NilFL+          Just (YesAllowConflicts MarkConflicts) -> return $ mangled conflicts+          Just NoAllowConflicts -> error "impossible" -- was handled in announceConflicts+          Nothing -> error "impossible"+      else return $ seal NilFL -    let effect_to_apply = concatFL (mapFL_FL effect ps_to_unsuspend) +>+ resolved_p-    invalidateIndex _repository-    -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord-    tentativelyAddToPending _repository effect_to_apply-    -- we can just let hijack attempts through here because we already asked about them on suspend time-    (_repository, renames) <- runHijackT IgnoreHijack $ doAdd _repository ps_to_unsuspend-    case unseal (simplifyPushes da (mapFL_FL NameFixup renames)) ps_to_keep of-      Sealed new_ps -> writeTentativeRebase _repository (Items new_ps)-    withSignalsBlocked $ do-      _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)-      void $ applyToWorking _repository (verbosity ? opts) effect_to_apply+    unrec <- unrecordedChanges (diffingOpts opts) _repository Nothing -    where doAdd :: (RepoPatch p, ApplyState p ~ Tree)-                => Repository ('RepoType 'IsRebase) p wR wU wT-                -> FL (WDDNamed p) wT wT2-                -> HijackT IO (Repository ('RepoType 'IsRebase) p wR wU wT2, FL RebaseName wT2 wT2)-          doAdd _repo NilFL = return (_repo, NilFL)-          doAdd _repo ((p :: WDDNamed p wT wU) :>:ps) = do+    -- TODO should catch logfiles (fst value from updatePatchHeader) and+    -- clean them up as in AmendRecord+    -- Note: we can allow hijack attempts here without warning the user+    -- because we already asked about that on suspend time+    (unsuspended_ps, ps_to_keep') <-+      runHijackT IgnoreHijack $ handleUnsuspend ps_to_unsuspend (unseal Items ps_to_keep)+    _repository <-+      tentativelyAddPatches _repository NoUpdatePending unsuspended_ps+    let effect_unsuspended = concatFL (mapFL_FL effect unsuspended_ps)+    case cleanMerge (effect_unsuspended :\/: unrec) of+      Nothing ->+        fail $ "Can't "++cmd++" because there are conflicting unrecorded changes."+      Just (unrec' :/\: effect_unsuspended') ->+        case cleanMerge (resolution :\/: unrec') of+          Nothing ->+            fail $ "Can't "++cmd++" because there are conflicting unrecorded changes."+          Just (unrec'' :/\: resolution') -> do+            let effect_to_apply = effect_unsuspended' +>+ resolution'+            setTentativePending _repository (resolution +>+ unrec'')+            writeTentativeRebase _repository ps_to_keep'+            withSignalsBlocked $ do+              _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+              unless (O.yes (O.dryRun ? opts)) $+                void $ applyToWorking _repository (verbosity ? opts) effect_to_apply++    where da = diffAlgorithm ? opts++          handleUnsuspend+                 :: forall p wR wT. (RepoPatch p, ApplyState p ~ Tree)+                 => FL (WDDNamed p) wR wT+                 -> Suspended p wT+                 -> HijackT IO (FL (PatchInfoAnd p) wR wT, Suspended p wT)+          handleUnsuspend NilFL to_keep = return (NilFL, to_keep)+          handleUnsuspend (p :>: ps) to_keep = do               case wddDependedOn p of                   [] -> return ()                   deps -> liftIO $ do-                      -- It might make sense to only print out this message once, but we might find-                      -- that the dropped dependencies are interspersed with other output,-                      -- e.g. if running with --ask-deps-                      putStr $ "Warning: dropping the following explicit "-                                 ++ englishNum (length deps) (Noun "dependency") ":\n\n"-                      let printIndented n =-                              mapM_ (putStrLn . (replicate n ' '++)) . lines .-                              renderString . displayPatchInfo-                      putStrLn . renderString . displayPatchInfo .-                              patch2patchinfo $ wddPatch p-                      putStr " depended on:\n"-                      mapM_ (printIndented 2) deps-                      putStr "\n"+                      -- It might make sense to only print out this message+                      -- once, but we might find that the dropped dependencies+                      -- are interspersed with other output, e.g. if running+                      -- with --ask-deps+                      let indent n = prefix (replicate n ' ')+                      putDocLnWith fancyPrinters $+                        redText ("Dropping the following explicit " +++                          englishNum (length deps) (Noun "dependency") ":") $$+                        displayPatchInfo (patch2patchinfo (wddPatch p)) $$+                        indent 1 (redText "depended on:") $$+                        indent 2 (vcat (map displayPatchInfo deps))                -- TODO should catch logfiles (fst value from updatePatchHeader)               -- and clean them up as in AmendRecord-              p' <- snd <$> updatePatchHeader "unsuspend"+              -- TODO should also ask user to supply explicit dependencies as+              -- replacements for those that have been lost (if any, see above)+              p' <- snd <$> updatePatchHeader @p cmd                       NoAskAboutDeps                       (patchSelOpts True opts)-                      (diffAlgorithm ? opts)-                      (O.keepDate ? opts)-                      (O.selectAuthor ? opts)-                      (O.author ? opts)-                      (O.patchname ? opts)-                      (O.askLongComment ? opts)+                      (patchHeaderConfig opts)                       (fmapFL_Named effect (wddPatch p)) NilFL-              _repo <--                liftIO $-                  tentativelyAddPatch _repo (compress ? opts) (verbosity ? opts) YesUpdatePending p'-              -- create a rename that undoes the change we just made, so the contexts match up-              let rename :: RebaseName wU wU+              -- Create a rename that undoes the change we just made, so that the+              -- context of patch names match up in the following sequence. We don't+              -- track patch names properly in witnesses yet and so the rename appears+              -- to have a null effect on the context.+              --   p' :: WDDNamed p wR wR2+              --   rename :: RebaseName wR2 wR2+              --   ps :: FL (WDDNamed p) wR2 wT+              let rename :: RebaseName wR2 wR2                   rename = Rename (info p') (patch2patchinfo (wddPatch p))-              -- push it through the remaining patches to fix them up-              Just (ps2 :> (rename2 :: RebaseName wV wT2)) <--                return (commuterIdFL (commuterIdWDD commuteNameNamed) (rename :> ps))-              -- assert that the rename still has a null effect on the context after commuting-              IsEq <- return (unsafeCoerceP IsEq :: EqCheck wV wT2)-              (_repo, renames) <- doAdd _repo ps2-              -- return the renames so that the suspended patch can be fixed up-              return (_repo, rename2 :>: renames)--          requireNoUnrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree)-                                     => Repository rt p wR wU wR-                                     -> IO (EqCheck wR wU)-          requireNoUnrecordedChanges repo = do-            pend <--              unrecordedChanges (diffingOpts opts)-                O.NoLookForMoves O.NoLookForReplaces-                repo Nothing-            case pend of-              NilFL -> return IsEq-              _ -> die $ "Can't "++cmd++" when there are unrecorded changes."+              -- push it through the remaining patches to fix them up, which should leave+              -- us with+              --   p' :: WDDNamed p wR wR2+              --   ps2 :: FL (WDDNamed p) wR2 wT2+              --   rename2 :: RebaseName wT2 wT2+              Just (ps2 :> (rename2 :: RebaseName wT2 wT2')) <-+                return $ commuterIdFL (commuterIdWDD commuteNameNamed) (rename :> ps)+              -- However the commute operation loses the information that the rename2 has+              -- a null effect on the context so we have to assert it manually.+              IsEq <- return (unsafeCoerceP IsEq :: EqCheck wT2 wT2')+              to_keep' <- return $ S.simplifyPush da (NameFixup rename2) to_keep+              (converted, to_keep'') <- handleUnsuspend ps2 to_keep'+              return (p' :>: converted, to_keep'')  inject :: DarcsCommand inject = DarcsCommand@@ -498,10 +522,7 @@     , commandCommand = injectCmd     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc injectBasicOpts-    , commandDefaults = defaultFlags injectOpts-    , commandCheckOptions = ocheck injectOpts+    , commandOptions = injectOpts     }   where     injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm@@ -511,45 +532,59 @@  injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () injectCmd _ opts _args =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $-    RebaseJob $-    \(_repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> do+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $+    \(_repository :: Repository 'RW p wU wR) -> do+    checkHasRebase _repository     Items selects <- readTentativeRebase _repository      -- TODO this selection doesn't need to respect dependencies     -- TODO we only want to select one patch: generalise withSelectedPatchFromList     let selection_config =           selectionConfigGeneric rcToPia First "inject into" (patchSelOpts True opts) Nothing-    (chosens :> rest_selects) <- runSelection selects selection_config+    (to_inject :> keep) <- runSelection selects selection_config -    let extractSingle :: FL (RebaseChange prim) wX wY -> (FL (RebaseFixup prim) :> Named prim) wX wY-        extractSingle (RC fixups toedit :>: NilFL) = fixups :> toedit+    let extractSingle :: FL (RebaseChange prim) wX wY -> RebaseChange prim wX wY+        extractSingle (rc :>: NilFL) = rc         extractSingle _ = error "You must select precisely one patch!" -    fixups :> toedit <- return $ extractSingle chosens+    rc <- return $ extractSingle to_inject+    Sealed new <- injectOne opts rc keep -    name_fixups :> prim_fixups <- return $ flToNamesPrims fixups+    writeTentativeRebase _repository $ Items new+    void $ finalizeRepositoryChanges _repository (O.dryRun ? opts) -    let prim_selection_config =-          selectionConfigPrim-              Last "inject" (patchSelOpts True opts)-              (Just (primSplitter (diffAlgorithm ? opts))) Nothing Nothing-    (rest_fixups :> injects) <- runInvertibleSelection prim_fixups prim_selection_config+-- | Inject fixups into a 'RebaseChange' and update the remainder of the rebase+-- state. This is in 'IO' because it involves interactive selection of the+-- fixups to inject.+-- TODO: We currently offer only prim fixups, not name fixups, for injection. I+-- think it would make sense to extend this to name fixups, so the user can+-- explicitly resolve a lost dependency in cases where is clear that it won't+-- re-appear.+injectOne+  :: (PrimPatch prim, ApplyState prim ~ Tree)+  => [DarcsFlag]+  -> RebaseChange prim wX wY+  -> FL (RebaseChange prim) wY wZ+  -> IO (Sealed (FL (RebaseChange prim) wX))+injectOne opts (RC fixups toedit) rest_suspended = do+  name_fixups :> prim_fixups <- return $ flToNamesPrims fixups+  let prim_selection_config =+        selectionConfigPrim+          Last+          "inject"+          (patchSelOpts True opts)+          (Just (primSplitter (diffAlgorithm ? opts)))+          Nothing+  (rest_fixups :> injects) <-+    runInvertibleSelection prim_fixups prim_selection_config+  let da = diffAlgorithm ? opts+      toeditNew = fmapFL_Named (canonizeFL da . (injects +>+)) toedit+  return $+    unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups)) $+    simplifyPushes da (mapFL_FL PrimFixup rest_fixups) $+    RC NilFL toeditNew :>: rest_suspended -    when (nullFL injects) $ do-        putStrLn "No changes selected!"-        exitSuccess -    -- Don't bother to update patch header since unsuspend will do that later-    let da = diffAlgorithm ? opts-        toeditNew = fmapFL_Named (canonizeFL da . (injects +>+)) toedit-    case unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups))-            $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups)-            $ RC NilFL toeditNew :>: rest_selects of-      Sealed new_ps -> writeTentativeRebase _repository (Items new_ps)-    _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)-    return ()- obliterate :: DarcsCommand obliterate = DarcsCommand     { commandProgramName = "darcs"@@ -562,10 +597,7 @@     , commandCommand = obliterateCmd     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc obliterateBasicOpts-    , commandDefaults = defaultFlags obliterateOpts-    , commandCheckOptions = ocheck obliterateOpts+    , commandOptions = obliterateOpts     }   where     obliterateBasicOpts = O.diffAlgorithm@@ -575,9 +607,8 @@  obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () obliterateCmd _ opts _args =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $-    RebaseJob $-    \(_repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    checkHasRebase _repository     Items selects <- readTentativeRebase _repository      -- TODO this selection doesn't need to respect dependencies@@ -586,30 +617,270 @@     when (nullFL chosen) $ do putStrLn "No patches selected!"                               exitSuccess -    let da = diffAlgorithm ? opts-        do_obliterate-          :: PrimPatch prim-          => FL (RebaseChange prim) wX wY-          -> FL (RebaseChange prim) wY wZ-          -> Sealed (FL (RebaseChange prim) wX)-        do_obliterate NilFL = Sealed-        do_obliterate (RC fs e :>: qs) =-          unseal (simplifyPushes da fs) .-          -- since Named doesn't have any witness context for the-          -- patch names, the AddName here will be inferred to be wX wX-          unseal (simplifyPush da (NameFixup (AddName (patch2patchinfo e)))) .-          unseal (simplifyPushes da (mapFL_FL PrimFixup (patchcontents e))) .-          do_obliterate qs+    let ps_to_keep =+          foldSealedFL (obliterateOne (diffAlgorithm ? opts)) chosen (Sealed keep)+    writeTentativeRebase _repository (unseal Items ps_to_keep) -    let ps_to_keep = do_obliterate chosen keep-    case ps_to_keep of-      Sealed new_ps -> writeTentativeRebase _repository (Items new_ps)+    void $ finalizeRepositoryChanges _repository (O.dryRun ? opts) -    _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)-    return ()-   ) :: IO ()+-- TODO: move to Darcs.Patch.Witnesses.Ordered ?+-- | Map a cons-like operation that may change the end state over an 'FL'.+-- Unfortunately this can't be generalized to 'foldrwFL', even though it has+-- exactly the same definition, because 'Sealed' doesn't have the right kind.+-- We could play with a newtype wrapper to fix this but the ensuing wrapping+-- and unwrapping would hardly make it clearer what's going on.+foldSealedFL+  :: (forall wA wB . p wA wB -> Sealed (q wB) -> Sealed (q wA))+  -> FL p wX wY -> Sealed (q wY) -> Sealed (q wX)+-- kind error: foldSealedFL = foldrwFL+foldSealedFL _ NilFL acc = acc+foldSealedFL f (p :>: ps) acc = f p (foldSealedFL f ps acc) +obliterateOne+  :: PrimPatch prim+  => O.DiffAlgorithm+  -> RebaseChange prim wX wY+  -> Sealed (FL (RebaseChange prim) wY)+  -> Sealed (FL (RebaseChange prim) wX)+obliterateOne da (RC fs e) =+  unseal (simplifyPushes da fs) .+  -- since Named doesn't have any witness context for the+  -- patch names, the AddName here will be inferred to be wX wX+  unseal (simplifyPush da (NameFixup (AddName (patch2patchinfo e)))) .+  unseal (simplifyPushes da (mapFL_FL PrimFixup (patchcontents e))) +edit :: DarcsCommand+edit = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "edit"+    , commandHelp = text description+    , commandDescription = description+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = editCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = opts+    }+  where+    basicOpts = O.diffAlgorithm ^ O.withSummary+    opts = basicOpts `withStdOpts` O.umask+    description = "Edit suspended patches."++data EditState prim wX = EditState+  { count :: Int+  , index :: Int+  , patches :: Sealed ((RL (RebaseChange prim) :> FL (RebaseChange prim)) wX)+  }++data Edit prim wX = Edit+  { eWhat :: String+  , eState :: EditState prim wX+  }++editCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+editCmd _ opts _args =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    checkHasRebase _repository+    Items items <- readTentativeRebase _repository+    let initial_state =+          EditState+            { count = lengthFL items+            , index = 0+            , patches = Sealed (NilRL :> items)+            }+    Sealed items' <- interactiveEdit opts [] initial_state []+    writeTentativeRebase _repository (Items items')+    void $ finalizeRepositoryChanges _repository (O.dryRun ? opts)++interactiveEdit+  :: (PrimPatch prim, ApplyState prim ~ Tree)+  => [DarcsFlag]+  -> [Edit prim wR]     -- ^ stack of undone edits, for redo+  -> EditState prim wR  -- ^ current state+  -> [Edit prim wR]     -- ^ stack of past edits, for undo+  -> IO (Sealed (FL (RebaseChange prim) wR))+interactiveEdit opts redos s@EditState{..} undos =+  -- invariants:+  --  * the "todo" patches are empty only if the "done" patches are; formally:+  --      case patches of Sealed (done :> todo) -> nullFL todo ==> nullRL done+  case patches of+    Sealed (_ :> NilFL) -> prompt+    Sealed (_ :> p :>: _) -> defaultPrintFriendly p >> prompt+  where+    da = diffAlgorithm ? opts++    -- helper functions+    defaultPrintFriendly =+      liftIO . printFriendly (O.verbosity ? opts) (O.withSummary ? opts)++    -- common actions+    undo =+      case undos of+        [] -> error "impossible"+        e : undos' ->+          -- pop last state from undos, push current state onto redos+          interactiveEdit opts (Edit (eWhat e) s : redos) (eState e) undos'+    redo =+      case redos of+        [] -> error "impossible"+        e : redos' ->+          -- pop last state from redos, push current state onto undos+          interactiveEdit opts redos' (eState e) (Edit (eWhat e) s : undos)+    quit = do+      putInfo opts $ text "Okay, rebase edit cancelled."+      exitSuccess+    commit =+      case patches of+        Sealed (done :> todo) -> return $ Sealed (done +>>+ todo)+    list = mapM_ (putStrLn . eWhat) (reverse undos) >> prompt+    choicesCommon =+      [ PromptChoice 'q' True quit "quit, discard all edits"+      , PromptChoice 'd' True commit "done editing, commit"+      , PromptChoice 'l' True list "list edits made so far"+      , PromptChoice 'u' (not (null undos)) undo "undo previous edit"+      , PromptChoice 'r' (not (null redos)) redo "redo previously undone edit"+      ]++    prompt =+      case patches of+        Sealed (_ :> NilFL) -> -- empty rebase state+          runPrompt PromptConfig+            { pPrompt = "No more suspended patches. What shall I do?"+            , pVerb = "rebase edit"+            , pChoices = [choicesCommon]+            , pDefault = Nothing+            }+        Sealed (done :> todo@(p :>: todo')) -> -- non-empty rebase state+          runPrompt PromptConfig+            { pPrompt = "What shall I do with this patch? " +++                  "(" ++ show (index + 1) ++ "/" ++ show count ++ ")"+            , pVerb = "rebase edit"+            , pChoices = [choicesEdit, choicesCommon, choicesView, choicesNav]+            , pDefault = Nothing+            }+          where++            choicesEdit =+              [ PromptChoice 'o' True dropit "drop (obliterate, dissolve into fixups)"+              , PromptChoice 'e' True reword "edit name and/or long comment (log)"+              , PromptChoice 's' (index > 0) squash "squash with previous patch"+              , PromptChoice 'i' can_inject inject' "inject fixups"+              -- TODO+              -- , PromptChoice 'c' True ??? "select individual changes for editing"+              ]+            choicesView =+              [ PromptChoice 'v' True view "view this patch in full"+              , PromptChoice 'p' True pager "view this patch in full with pager"+              , PromptChoice 'y' True display "view this patch"+              , PromptChoice 'x' can_summarize summary+                "view a summary of this patch"+              ]+            choicesNav =+              [ PromptChoice 'n' (index + 1 < count) next "skip to next patch"+              , PromptChoice 'k' (index > 0) prev "back up to previous patch"+              , PromptChoice 'g' (index > 0) first "start over from the first patch"+              ]++            -- helper functions+            edit' op s' = do+              let what =+                    case p of RC _ np -> op ++ " " ++ piName (patch2patchinfo np)+              -- set new state s' and push the current one onto the undo stack+              -- discarding the redo stack+              interactiveEdit opts [] s' (Edit what s : undos)+            navigate s' =+              -- set new state s' with no undo or redo stack modification+              interactiveEdit opts redos s' undos++            can_summarize = not (O.yes (O.withSummary ? opts))+            can_inject = case p of (RC NilFL _) -> False; _ -> True++            -- editing+            dropit = do+              Sealed todo'' <- return $ obliterateOne da p (Sealed todo')+              edit' "drop  " s { count = count - 1 , patches = Sealed (done :> todo'') }+            inject' = do+              result <- try $ injectOne opts p todo'+              case result of+                Left ExitSuccess -> prompt+                Left e -> throwIO e+                Right (Sealed todo'') ->+                  edit' "inject" s { patches = Sealed (done :> todo'') }+            reword = do+              Sealed todo'' <- rewordOne da p todo'+              edit' "reword" s { patches = Sealed (done :> todo'') }+            squash =+              case done of+                NilRL -> error "impossible"+                done' :<: q ->+                  case squashOne da q p todo' of+                    Just (Sealed todo'') ->+                      -- this moves back by one so the new squashed patch is+                      -- selected; useful in case you now want to edit the+                      -- comment or look at the result+                      edit' "squash" s+                        { count = count - 1+                        , index = index - 1+                        , patches = Sealed (done' :> todo'')+                        }+                    Nothing -> do+                      putStrLn "Failed to commute fixups backward, try inject first."+                      prompt++            -- viewing+            view = printContent p >> prompt+            pager = printContentWithPager p >> prompt+            display = defaultPrintFriendly p >> prompt+            summary = printSummary p >> prompt++            -- navigation+            next =+              case todo' of+                NilFL -> error "impossible"+                _ ->+                  navigate+                    s { index = index + 1, patches = Sealed (done :<: p :> todo') }+            prev =+              case done of+                NilRL -> error "impossible"+                done' :<: p' ->+                  navigate+                    s { index = index - 1, patches = Sealed (done' :> p' :>: todo) }+            first =+              navigate s { index = 0, patches = Sealed (NilRL :> done +>>+ todo) }++-- | Squash second patch with first, updating the rest of the rebase state.+-- This can fail if the second patch has fixups that don't commute with the+-- contents of the first patch.+squashOne+  :: PrimPatch prim+  => O.DiffAlgorithm+  -> RebaseChange prim wX wY+  -> RebaseChange prim wY wZ+  -> FL (RebaseChange prim) wZ wW+  -> Maybe (Sealed (FL (RebaseChange prim) wX))+squashOne da (RC fs1 e1) (RC fs2 e2) rest = do+  fs2' :> e1' <- commuterIdFL commuteNamedFixup (e1 :> fs2)+  let e1'' = fmapFL_Named (canonizeFL da . (+>+ patchcontents e2)) e1'+      e2_name_fixup = NameFixup (AddName (patch2patchinfo e2))+  return $+    case simplifyPush da e2_name_fixup rest of+      Sealed rest' -> simplifyPushes da (fs1 +>+ fs2') (RC NilFL e1'' :>: rest')++rewordOne+  :: (PrimPatch prim, ApplyState prim ~ Tree)+  => O.DiffAlgorithm+  -> RebaseChange prim wX wY+  -> FL (RebaseChange prim) wY wZ+  -> IO (Sealed (FL (RebaseChange prim) wX))+rewordOne da (RC fs e) rest = do+  e' <- editLog e+  let rename = NameFixup $ Rename (patch2patchinfo e') (patch2patchinfo e)+  case simplifyPush da rename rest of+    Sealed rest' -> return $ Sealed $ RC fs e' :>: rest'+ pull :: DarcsCommand pull = DarcsCommand     { commandProgramName = "darcs"@@ -620,12 +891,9 @@     , commandExtraArgHelp = ["[REPOSITORY]..."]     , commandCommand = pullCmd RebasePatchApplier     , commandPrereq = amInHashedRepository-    , commandCompleteArgs = prefArgs "repos"+    , commandCompleteArgs = prefArgs Repos     , commandArgdefaults = defaultRepo-    , commandAdvancedOptions = odesc pullAdvancedOpts-    , commandBasicOptions = odesc pullBasicOpts-    , commandDefaults = defaultFlags pullOpts-    , commandCheckOptions = ocheck pullOpts+    , commandOptions = pullOpts     }   where     pullBasicOpts@@ -633,8 +901,7 @@       ^ O.reorder       ^ O.interactive       ^ O.conflictsYes-      ^ O.externalMerge-      ^ O.runTest+      ^ O.testChanges       ^ O.dryRunXml       ^ O.withSummary       ^ O.selectDeps@@ -643,13 +910,10 @@       ^ O.diffAlgorithm     pullAdvancedOpts       = O.repoCombinator-      ^ O.compress-      ^ O.useIndex-      ^ O.remoteRepos       ^ O.setScriptsExecutable       ^ O.umask       ^ O.changesReverse-      ^ O.network+      ^ O.remoteDarcs     pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts     pullDescription =       "Copy and apply patches from another repository,\@@ -671,10 +935,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = fileArgs     , commandArgdefaults = const stdindefault-    , commandAdvancedOptions = odesc applyAdvancedOpts-    , commandBasicOptions = odesc applyBasicOpts-    , commandDefaults = defaultFlags applyOpts-    , commandCheckOptions = ocheck applyOpts+    , commandOptions = applyOpts     }   where     applyBasicOpts@@ -686,9 +947,7 @@       ^ O.repoDir       ^ O.diffAlgorithm     applyAdvancedOpts-      = O.useIndex-      ^ O.compress-      ^ O.setScriptsExecutable+      = O.setScriptsExecutable       ^ O.umask       ^ O.changesReverse       ^ O.pauseForGui@@ -699,9 +958,7 @@ data RebasePatchApplier = RebasePatchApplier  instance PatchApplier RebasePatchApplier where-    type ApplierRepoTypeConstraint RebasePatchApplier rt = rt ~ 'RepoType 'IsRebase--    repoJob RebasePatchApplier f = StartRebaseJob (f PatchProxy)+    repoJob RebasePatchApplier f = RepoJob (f PatchProxy)     applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd  applyPatchesForRebaseCmd@@ -709,10 +966,10 @@      . ( RepoPatch p, ApplyState p ~ Tree )     => String     -> [DarcsFlag]-    -> Repository ('RepoType 'IsRebase) p wR wU wR-    -> Fork (PatchSet ('RepoType 'IsRebase) p)-            (FL (PatchInfoAnd ('RepoType 'IsRebase) p))-            (FL (PatchInfoAnd ('RepoType 'IsRebase) p)) Origin wR wZ+    -> Repository 'RW p wU wR+    -> Fork (PatchSet p)+            (FL (PatchInfoAnd p))+            (FL (PatchInfoAnd p)) Origin wR wZ     -> IO () applyPatchesForRebaseCmd cmdName opts _repository (Fork common us' to_be_applied) = do     applyPatchesStart cmdName opts to_be_applied@@ -735,29 +992,28 @@      suspended <- readTentativeRebase _repository -    _repository <- doSuspend opts _repository suspended usToSuspend+    (_repository, Sealed toWorking) <-+      doSuspend cmdName opts _repository suspended usToSuspend     -- the new rebase patch containing the suspended patches is now in the repo     -- and the suspended patches have been removed -    -- TODO This is a nasty hack, caused by the fact that most functions-    -- in Darcs.Repository.State require the recorded state to be equal to the-    -- tentative state and thus must not be called after the repo was changed.-    _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)-    _repository <- revertRepositoryChanges _repository YesUpdatePending+    -- We must apply the suspend to working because tentativelyMergePatches+    -- calls unrecordedChanges. We also have to update the index, since that is+    -- used to filter the working tree (unless --ignore-times is in effect).+    updateIndex _repository+    _repository <- withSignalsBlocked $ do+        applyToWorking _repository (verbosity ? opts) toWorking      Sealed pw <-         tentativelyMergePatches             _repository cmdName             (allowConflicts opts)-            (externalMerge ? opts)-            (wantGuiPause opts) (compress ? opts) (verbosity ? opts)+            (wantGuiPause opts)             (reorder ? opts) (diffingOpts opts)             (Fork common (usOk +>+ usKeep) to_be_applied)-    invalidateIndex _repository      applyPatchesFinish cmdName opts _repository pw (nullFL to_be_applied) --- TODO I doubt this is right, e.g. withContext should be inherited applyPatchSelOpts :: S.PatchSelectionOptions applyPatchSelOpts = S.PatchSelectionOptions     { S.verbosity = O.NormalVerbosity@@ -765,7 +1021,6 @@     , S.interactive = True     , S.selectDeps = O.PromptDeps -- option not supported, use default     , S.withSummary = O.NoSummary-    , S.withContext = O.NoContext     }  obliteratePatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions@@ -780,7 +1035,6 @@     , S.interactive = isInteractive defInteractive flags     , S.selectDeps = selectDeps ? flags     , S.withSummary = O.withSummary ? flags-    , S.withContext = O.NoContext     }  log :: DarcsCommand@@ -795,10 +1049,7 @@     , commandCommand = logCmd     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc logAdvancedOpts-    , commandBasicOptions = odesc logBasicOpts-    , commandDefaults = defaultFlags logOpts-    , commandCheckOptions = ocheck logOpts+    , commandOptions = logOpts     }   where     logBasicOpts = O.withSummary ^ O.interactive -- False@@ -808,10 +1059,10 @@  logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () logCmd _ opts _files =-    withRepository (useCache ? opts) $-    RebaseJob $ \_repository -> do+    withRepository (useCache ? opts) $ RepoJob $ \_repository -> do+        checkHasRebase _repository         Items ps <- readRebase _repository-        let psToShow = toRebaseChanges ps+        let psToShow = mapFL_FL n2pia ps         if isInteractive False opts             then viewChanges (patchSelOpts False opts) (mapFL Sealed2 psToShow)             else do@@ -836,10 +1087,7 @@     , commandCommand = upgradeCmd     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc basicOpts-    , commandDefaults = defaultFlags opts-    , commandCheckOptions = ocheck opts+    , commandOptions = opts     }   where     basicOpts = oid@@ -852,9 +1100,8 @@  upgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () upgradeCmd _ opts _args =-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $-  OldRebaseJob $ \(_repo :: Repository ('RepoType 'IsRebase) p wR wU wR) ->-    upgradeOldStyleRebase _repo (compress ? opts)+  withRepoLock (useCache ? opts) (umask ? opts) $ OldRebaseJob $ \repo ->+    upgradeOldStyleRebase repo  {- TODO:@@ -867,18 +1114,11 @@  - warn about suspending conflicts  - indication of expected conflicts on unsuspend     - why isn't ! when you do x accurate?- - rebase pull needs more UI work-    - automatically answer yes re suspension-    - offer all patches (so they can be kept in order)-       - or perhaps rebase suspend --complement?- - make unsuspend actually display the patch helpfully like normal selection+ - rebase pull/apply should suspend patches such that their order is not changed  - amended patches will often be in both the target repo and in the rebase context, detect?  - can we be more intelligent about conflict resolutions?  - --all option to unsuspend  - review other conflict options for unsuspend- - warning message on suspend about not being able to unsuspend with unrecorded changes- - aborting during a rebase pull or rebase suspend causes it to leave the repo marked for rebase- - patch count: get English right in <n> suspended patch(es)  - darcs check should check integrity of rebase patch  - review existence of reify and inject commands - bit of an internals hack -}
src/Darcs/UI/Commands/Record.hs view
@@ -23,83 +23,86 @@     ) where  import Darcs.Prelude-import Data.Foldable ( traverse_ )  import Control.Exception ( handleJust )-import Control.Monad ( when, unless, void )+import Control.Monad ( unless, void, when ) import Data.Char ( ord )-import System.Exit ( exitFailure, exitSuccess, ExitCode(..) )+import Data.Foldable ( traverse_ ) import System.Directory ( removeFile )+import System.Exit ( ExitCode(..), exitFailure, exitSuccess ) +import Darcs.Patch ( PrimOf, RepoPatch, canonizeFL, summaryFL )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Depends ( contextPatches )+import Darcs.Patch.Info ( PatchInfo, patchinfo )+import Darcs.Patch.Named ( adddeps, infopatch ) import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Split ( primSplitter )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..), nullFL, (+>+) ) import Darcs.Repository-    ( Repository-    , withRepoLock-    , RepoJob(..)-    , tentativelyAddPatch+    ( RepoJob(..)+    , Repository+    , AccessType(..)     , finalizeRepositoryChanges-    , invalidateIndex     , readPendingAndWorking-    , readRecorded-    )-import Darcs.Repository.Pending ( tentativelyRemoveFromPW )--import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, sortCoalesceFL )-import Darcs.Patch.Named ( infopatch, adddeps )-import Darcs.Patch.Witnesses.Ordered-    ( FL(..), (:>)(..), nullFL, (+>+) )-import Darcs.Patch.Info ( PatchInfo, patchinfo )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Split ( primSplitter )-import Darcs.UI.SelectChanges-    (  WhichChanges(..)-    , selectionConfigPrim-    , runInvertibleSelection-    , askAboutDepends+    , readPristine+    , readPatches+    , tentativelyAddPatch+    , tentativelyRemoveFromPW+    , withRepoLock     )-import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )-import Darcs.Util.Path ( AnchoredPath, displayPath, AbsolutePath )+import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.UI.Commands-    ( DarcsCommand(..), withStdOpts-    , nodefaults+    ( DarcsCommand(..)+    , amInHashedRepository     , commandAlias+    , nodefaults     , setEnvDarcsFiles     , setEnvDarcsPatches-    , amInHashedRepository+    , withStdOpts     )-import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths,-                                testTentativeAndMaybeExit )+import Darcs.UI.Commands.Util+    ( announceFiles+    , filterExistingPaths+    , testTentativeAndMaybeExit+    ) import Darcs.UI.Completion ( modifiedFileArgs ) import Darcs.UI.Flags     ( DarcsFlag+    , diffingOpts     , fileHelpAuthor     , getAuthor     , getDate-    , diffOpts-    , scanKnown     , pathSetFromArgs     )-import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, oparse, defaultFlags )-import Darcs.UI.PatchHeader ( getLog )+import Darcs.UI.Options ( Config, (?), (^) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdatePending (..), DryRun(NoDryRun), ScanKnown(..) )+import Darcs.UI.PatchHeader ( getLog )+import Darcs.UI.SelectChanges+    ( WhichChanges(..)+    , askAboutDepends+    , runInvertibleSelection+    , selectionConfigPrim+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Util.Exception ( clarifyErrors )-import Darcs.Util.Prompt ( promptYorn )-import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Global ( darcsLastMessage )-import Darcs.Patch.Progress ( progressFL )+import Darcs.Util.Path ( AbsolutePath, AnchoredPath, displayPath ) import Darcs.Util.Printer     ( Doc-    , ($+$)-    , (<+>)     , formatWords     , pathlist     , putDocLn     , text     , vcat     , vsep+    , ($+$)+    , (<+>)     )-import Darcs.Util.Tree( Tree )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Tree ( Tree )  recordHelp :: Doc recordHelp =@@ -171,61 +174,6 @@     ]   ]) -recordBasicOpts :: DarcsOption a-                   (Maybe String-                    -> Maybe String-                    -> O.TestChanges-                    -> Maybe Bool-                    -> Bool-                    -> Bool-                    -> Maybe O.AskLongComment-                    -> O.LookFor-                    -> Maybe String-                    -> O.WithContext-                    -> O.DiffAlgorithm-                    -> a)-recordBasicOpts-    = O.patchname-    ^ O.author-    ^ O.testChanges-    ^ O.interactive-    ^ O.pipe-    ^ O.askDeps-    ^ O.askLongComment-    ^ O.lookfor-    ^ O.repoDir-    ^ O.withContext-    ^ O.diffAlgorithm--recordAdvancedOpts :: DarcsOption a-                      (O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> O.IncludeBoring -> a)-recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable ^ O.includeBoring--data RecordConfig = RecordConfig-    { patchname :: Maybe String-    , author :: Maybe String-    , testChanges :: O.TestChanges-    , interactive :: Maybe Bool-    , pipe :: Bool-    , askDeps :: Bool-    , askLongComment :: Maybe O.AskLongComment-    , lookfor :: O.LookFor-    , _workingRepoDir :: Maybe String-    , withContext :: O.WithContext-    , diffAlgorithm :: O.DiffAlgorithm-    , verbosity :: O.Verbosity-    , logfile :: O.Logfile-    , compress :: O.Compression-    , useIndex :: O.UseIndex-    , umask :: O.UMask-    , sse :: O.SetScriptsExecutable-    , includeBoring :: O.IncludeBoring-    , useCache :: O.UseCache-    }--recordConfig :: [DarcsFlag] -> RecordConfig-recordConfig = oparse (recordBasicOpts ^ O.verbosity ^ recordAdvancedOpts ^ O.useCache) RecordConfig- record :: DarcsCommand record = DarcsCommand     { commandProgramName = "darcs"@@ -238,55 +186,63 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = modifiedFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc recordAdvancedOpts-    , commandBasicOptions = odesc recordBasicOpts-    , commandDefaults = defaultFlags recordOpts-    , commandCheckOptions = ocheck recordOpts+    , commandOptions = allOpts     }   where-    recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts+    basicOpts+      = O.patchname+      ^ O.author+      ^ O.testChanges+      ^ O.interactive+      ^ O.pipe+      ^ O.askDeps+      ^ O.askLongComment+      ^ O.lookforadds+      ^ O.lookforreplaces+      ^ O.lookformoves+      ^ O.repoDir+      ^ O.diffAlgorithm+    advancedOpts+      = O.logfile+      ^ O.umask+      ^ O.setScriptsExecutable+    allOpts = basicOpts `withStdOpts` advancedOpts  -- | commit is an alias for record commit :: DarcsCommand commit = commandAlias "commit" Nothing record -reportNonExisting :: ScanKnown -> ([AnchoredPath], [AnchoredPath]) -> IO ()-reportNonExisting scan (paths_only_in_working, _) = do-  unless (scan /= ScanKnown || null paths_only_in_working) $  putDocLn $+reportNonExisting :: O.LookForAdds -> ([AnchoredPath], [AnchoredPath]) -> IO ()+reportNonExisting lfa (paths_only_in_working, _) = do+  unless (lfa /= O.NoLookForAdds || null paths_only_in_working) $  putDocLn $     "These paths are not yet in the repository and will be added:" <+>     pathlist (map displayPath paths_only_in_working)  recordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-recordCmd fps flags args = do-    let cfg = recordConfig flags-    checkNameIsNotOption (patchname cfg) (isInteractive cfg)-    withRepoLock NoDryRun (useCache cfg) YesUpdatePending (umask cfg) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do-      let scan = scanKnown (O.adds (lookfor cfg)) (includeBoring cfg)+recordCmd fps cfg args = do+    checkNameIsNotOption (O.patchname ? cfg) (isInteractive cfg)+    withRepoLock (O.useCache ? cfg) (O.umask ? cfg) $ RepoJob $ \(repository :: Repository 'RW p wU wR) -> do       existing_files <- do         files <- pathSetFromArgs fps args         files' <-           traverse-            (filterExistingPaths-              repository (verbosity cfg) (useIndex cfg) scan (O.moves (lookfor cfg)))-            files-        when (verbosity cfg /= O.Quiet) $-            traverse_ (reportNonExisting scan) files'+            (filterExistingPaths repository (O.verbosity ? cfg) (diffingOpts cfg)) files+        when (O.verbosity ? cfg /= O.Quiet) $+            traverse_ (reportNonExisting (O.lookforadds ? cfg)) files'         let files'' = fmap snd files'         when (files'' == Just []) $             fail "None of the files you specified exist."         return files''-      announceFiles (verbosity cfg) existing_files "Recording changes in"+      announceFiles (O.verbosity ? cfg) existing_files "Recording changes in"       debugMessage "About to get the unrecorded changes."-      changes <- readPendingAndWorking (diffingOpts cfg)-                   (O.moves (lookfor cfg)) (O.replaces (lookfor cfg))-                   repository existing_files-      debugMessage "I've got unrecorded changes."+      changes <-+        readPendingAndWorking (diffingOpts cfg) repository existing_files       case changes of-          NilFL :> NilFL | not (askDeps cfg) -> do+          NilFL :> NilFL | not (O.askDeps ? cfg) -> do               -- We need to grab any input waiting for us, since we               -- might break scripts expecting to send it to us; we               -- don't care what that input is, though.-              void (getDate (pipe cfg))+              void (getDate (O.pipe ? cfg))               putStrLn "No changes!"               exitFailure           _ -> doRecord repository cfg existing_files changes@@ -300,38 +256,44 @@         confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?"         unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure -doRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-         => Repository rt p wR wU wR -> RecordConfig -> Maybe [AnchoredPath]+doRecord :: (RepoPatch p, ApplyState p ~ Tree)+         => Repository 'RW p wU wR -> Config -> Maybe [AnchoredPath]          -> (FL (PrimOf p) :> FL (PrimOf p)) wR wU -> IO () doRecord repository cfg files pw@(pending :> working) = do-    date <- getDate (pipe cfg)-    my_author <- getAuthor (author cfg) (pipe cfg)+    debugMessage "I've got unrecorded changes."+    date <- getDate (O.pipe ? cfg)+    my_author <- getAuthor (O.author ? cfg) (O.pipe ? cfg)     debugMessage "I'm slurping the repository."-    pristine <- readRecorded repository     debugMessage "About to select changes..."-    (chs :> _ ) <- runInvertibleSelection (sortCoalesceFL $ pending +>+ working) $+    let da = O.diffAlgorithm ? cfg+    (chs :> _ ) <- runInvertibleSelection (canonizeFL da $ pending +>+ working) $                       selectionConfigPrim                           First "record" (patchSelOpts cfg)-                          (Just (primSplitter (diffAlgorithm cfg)))-                          files (Just pristine)-    when (not (askDeps cfg) && nullFL chs) $+                          (Just (primSplitter (O.diffAlgorithm ? cfg)))+                          files+    when (not (O.askDeps ? cfg) && nullFL chs) $               do putStrLn "Ok, if you don't want to record anything, that's fine!"                  exitSuccess     handleJust onlySuccessfulExits (\_ -> return ()) $-             do deps <- if askDeps cfg-                        then askAboutDepends repository chs (patchSelOpts cfg) []+             do deps <- if O.askDeps ? cfg+                        then do+                          _ :> patches <- contextPatches <$> readPatches repository+                          askAboutDepends patches chs (patchSelOpts cfg) []                         else return []-                when (askDeps cfg) $ debugMessage "I've asked about dependencies."+                when (O.askDeps ? cfg) $ debugMessage "I've asked about dependencies."                 if nullFL chs && null deps                   then putStrLn "Ok, if you don't want to record anything, that's fine!"                   else do setEnvDarcsFiles chs-                          (name, my_log, logf) <- getLog (patchname cfg) (pipe cfg) (logfile cfg) (askLongComment cfg) Nothing chs+                          (name, my_log, logf) <-+                            getLog (O.patchname ? cfg) (O.pipe ? cfg)+                              (O.logfile ? cfg) (O.askLongComment ? cfg)+                              Nothing (summaryFL chs)                           debugMessage ("Patch name as received from getLog: " ++ show (map ord name))                           doActualRecord repository cfg name date my_author my_log logf deps chs pw -doActualRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-               => Repository rt p wR wU wR-               -> RecordConfig+doActualRecord :: (RepoPatch p, ApplyState p ~ Tree)+               => Repository 'RW p wU wR+               -> Config                -> String -> String -> String                -> [String] -> Maybe String                -> [PatchInfo] -> FL (PrimOf p) wR wX@@ -340,23 +302,21 @@       (pending :> working) = do     debugMessage "Writing the patch file..."     myinfo <- patchinfo date name my_author my_log-    let mypatch = infopatch myinfo $ progressFL "Writing changes:" chs+    let mypatch = infopatch myinfo $ progressFL "Writing changes" chs     let pia = n2pia $ adddeps mypatch deps     _repository <--      tentativelyAddPatch _repository (compress cfg) (verbosity cfg)-        NoUpdatePending pia-    invalidateIndex _repository-    debugMessage "Applying to pristine..."-    testTentativeAndMaybeExit _repository (verbosity cfg) (testChanges cfg)-      (sse cfg) (isInteractive cfg) ("you have a bad patch: '" ++ name ++ "'")+      tentativelyAddPatch _repository NoUpdatePending pia+    tp <- readPristine _repository+    testTentativeAndMaybeExit tp cfg+      ("you have a bad patch: '" ++ name ++ "'")       "record it" (Just failuremessage)     tentativelyRemoveFromPW _repository chs pending working     _repository <--      finalizeRepositoryChanges _repository YesUpdatePending (compress cfg)+      finalizeRepositoryChanges _repository (O.dryRun ? cfg)       `clarifyErrors` failuremessage     debugMessage "Syncing timestamps..."     removeLogFile logf-    unless (verbosity cfg == O.Quiet) $+    unless (O.verbosity ? cfg == O.Quiet) $       putDocLn $ text $ "Finished recording patch '" ++ name ++ "'"     setEnvDarcsPatches (pia :>: NilFL)   where@@ -375,18 +335,14 @@ onlySuccessfulExits ExitSuccess = Just () onlySuccessfulExits _ = Nothing -patchSelOpts :: RecordConfig -> S.PatchSelectionOptions+patchSelOpts :: Config -> S.PatchSelectionOptions patchSelOpts cfg = S.PatchSelectionOptions-    { S.verbosity = verbosity cfg+    { S.verbosity = O.verbosity ? cfg     , S.matchFlags = []     , S.interactive = isInteractive cfg     , S.selectDeps = O.PromptDeps -- option not supported, use default     , S.withSummary = O.NoSummary -- option not supported, use default-    , S.withContext = withContext cfg     } -diffingOpts :: RecordConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)-diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) O.NoIncludeBoring (diffAlgorithm cfg)--isInteractive :: RecordConfig -> Bool-isInteractive = maybe True id . interactive+isInteractive :: Config -> Bool+isInteractive cfg = maybe True id (O.interactive ? cfg)
src/Darcs/UI/Commands/Remove.hs view
@@ -19,7 +19,7 @@  import Darcs.Prelude -import Control.Monad ( when, foldM )+import Control.Monad ( when, foldM, void ) import Darcs.UI.Commands     ( DarcsCommand(..)     , withStdOpts, nodefaults@@ -29,17 +29,18 @@     ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.Flags-    ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, quiet, pathsFromArgs )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+    ( DarcsFlag, diffingOpts+    , useCache, umask, diffAlgorithm, pathsFromArgs )+import Darcs.UI.Options ( (^), parseFlags, (?) ) import qualified Darcs.UI.Options.All as O -import Darcs.Repository.Flags ( UpdatePending (..) ) import Darcs.Repository     ( Repository     , withRepoLock     , RepoJob(..)     , addToPending-    , readRecordedAndPending+    , finalizeRepositoryChanges+    , readPristineAndPending     , readUnrecorded     ) import Darcs.Repository.Diff( treeDiff )@@ -47,7 +48,7 @@ import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile,                      listTouchedFiles ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL )+import Darcs.Patch.Witnesses.Ordered ( FL(..), concatGapsFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft ) import Darcs.Repository.Prefs ( filetypeFunction, FileType ) import Darcs.Util.Tree( Tree, TreeItem(..), explodePaths )@@ -81,14 +82,11 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = knownFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc removeAdvancedOpts-    , commandBasicOptions = odesc removeBasicOpts-    , commandDefaults = defaultFlags removeOpts-    , commandCheckOptions = ocheck removeOpts+    , commandOptions = removeOpts     }   where     removeBasicOpts = O.repoDir ^ O.recursive-    removeAdvancedOpts = O.useIndex ^ O.umask+    removeAdvancedOpts = O.umask     removeOpts = removeBasicOpts `withStdOpts` removeAdvancedOpts  removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()@@ -98,18 +96,19 @@     paths <- pathsFromArgs fps relargs     when (any isRoot paths) $         fail "Cannot remove a repository's root directory!"-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $       RepoJob $ \repository -> do-        recorded_and_pending <- readRecordedAndPending repository+        recorded_and_pending <- readPristineAndPending repository         let exploded_paths =               (if parseFlags O.recursive opts                 then reverse . explodePaths recorded_and_pending                 else id) paths         Sealed p <- makeRemovePatch opts repository exploded_paths-        -- TODO whether command fails depends on verbosity BAD BAD BAD-        when (nullFL p && not (null paths) && not (quiet opts)) $+        when (nullFL p && not (null paths)) $             fail "No files were removed."-        addToPending repository (O.useIndex ? opts) p+        addToPending repository (diffingOpts opts) p+        void $ finalizeRepositoryChanges repository+            (O.dryRun ? opts)         putInfo opts $ vcat $ map text $ ["Will stop tracking:"] ++             map displayPath (listTouchedFiles p) @@ -118,26 +117,29 @@ --   flag should be handled by the caller by adding all offspring of a directory --   to the files list. makeRemovePatch :: (RepoPatch p, ApplyState p ~ Tree)-                => [DarcsFlag] -> Repository rt p wR wU wR+                => [DarcsFlag] -> Repository rt p wU wR                 -> [AnchoredPath] -> IO (Sealed (FL (PrimOf p) wU))-makeRemovePatch opts repository files =-                          do recorded <- T.expand =<< readRecordedAndPending repository-                             unrecorded <- readUnrecorded repository (O.useIndex ? opts) $ Just files-                             ftf <- filetypeFunction-                             result <- foldM removeOnePath (ftf,recorded,unrecorded, []) files-                             case result of-                                 (_, _, _, patches) -> return $-                                                         unFreeLeft $ foldr (joinGap (+>+)) (emptyGap NilFL) $ reverse patches-    where removeOnePath (ftf, recorded, unrecorded, patches) f = do-            let recorded' = T.modifyTree recorded f Nothing-                unrecorded' = T.modifyTree unrecorded f Nothing-            local <- makeRemoveGap opts ftf recorded unrecorded unrecorded' f-            -- we can tell if the remove succeeded by looking if local is-            -- empty. If the remove succeeded, we should pass on updated-            -- recorded and unrecorded that reflect the removal-            return $ case local of-                       Just gap -> (ftf, recorded', unrecorded', gap : patches)-                       _        -> (ftf, recorded, unrecorded, patches)+makeRemovePatch opts repository files = do+  recorded <- T.expand =<< readPristineAndPending repository+  unrecorded <- readUnrecorded repository (O.useIndex ? opts) $ Just files+  ftf <- filetypeFunction+  result <- foldM removeOnePath (ftf, recorded, unrecorded, []) files+  case result of+    (_, _, _, patches) ->+      return $+      unFreeLeft $ concatGapsFL $ reverse patches+  where+    removeOnePath (ftf, recorded, unrecorded, patches) f = do+      let recorded' = T.modifyTree recorded f Nothing+          unrecorded' = T.modifyTree unrecorded f Nothing+      local <- makeRemoveGap opts ftf recorded unrecorded unrecorded' f+      -- we can tell if the remove succeeded by looking if local is+      -- empty. If the remove succeeded, we should pass on updated+      -- recorded and unrecorded that reflect the removal+      return $+        case local of+          Just gap -> (ftf, recorded', unrecorded', gap : patches)+          _ -> (ftf, recorded, unrecorded, patches)  -- | Takes a file path and returns the FL of patches to remove that, wrapped in --   a 'Gap'.
src/Darcs/UI/Commands/Repair.hs view
@@ -20,48 +20,42 @@  import Darcs.Prelude -import Control.Monad ( when, unless )-import Control.Exception ( catch, IOException )-import System.Exit ( ExitCode(..), exitWith )+import Control.Monad ( when, unless, void )+import Data.Maybe ( isJust )+import System.IO.Error ( catchIOError )+import System.Exit ( exitFailure ) import System.Directory( renameFile ) import System.FilePath ( (<.>) )  import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts, nodefaults-    , putInfo, putWarning, amInHashedRepository+    , putInfo, putVerbose, putWarning, amInHashedRepository     ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags     ( DarcsFlag, verbosity, umask, useIndex-    , useCache, compress, diffAlgorithm, quiet-    )-import Darcs.UI.Options-    ( DarcsOption, (^), oid-    , odesc, ocheck, defaultFlags, (?)+    , useCache, diffAlgorithm, quiet     )+import Darcs.UI.Options ( DarcsOption, oid, (?), (^) ) import qualified Darcs.UI.Options.All as O -import Darcs.Repository.Flags ( UpdatePending (..) ) import Darcs.Repository.Paths ( indexPath ) import Darcs.Repository.Repair     ( replayRepository, checkIndex, replayRepositoryInTemp     , RepositoryConsistency(..)     ) import Darcs.Repository-    ( Repository, withRepository, readRecorded, RepoJob(..)-    , withRepoLock, replacePristine, repoCache+    ( withRepository, RepoJob(..)+    , withRepoLock, writePristine+    , finalizeRepositoryChanges     )-import qualified Darcs.Repository.Hashed as HashedRepo-import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.Repository.Diff( treeDiff )+import Darcs.Repository.Hashed ( writeTentativeInventory )+import Darcs.Repository.Pending ( setTentativePending ) -import Darcs.Patch ( RepoPatch, PrimOf, displayPatch )-import Darcs.Patch.Witnesses.Ordered ( FL(..) )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )+import Darcs.Patch ( displayPatch )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) -import Darcs.Util.Printer ( Doc, text )-import Darcs.Util.Tree ( Tree, expand )-import Darcs.Util.Tree.Hashed ( darcsUpdateHashes )+import Darcs.Util.Printer ( Doc, text, ($$) )   repairDescription :: String@@ -82,8 +76,8 @@   \are enountered.\n"  commonBasicOpts :: DarcsOption a-                   (Maybe String -> O.UseIndex -> O.DiffAlgorithm -> a)-commonBasicOpts = O.repoDir ^ O.useIndex ^ O.diffAlgorithm+                   (Maybe String -> O.DiffAlgorithm -> a)+commonBasicOpts = O.repoDir ^ O.diffAlgorithm  repair :: DarcsCommand repair = DarcsCommand@@ -103,41 +97,43 @@     basicOpts = commonBasicOpts ^ O.dryRun     advancedOpts = O.umask     allOpts = basicOpts `withStdOpts` advancedOpts-    commandAdvancedOptions = odesc advancedOpts-    commandBasicOptions = odesc basicOpts-    commandDefaults = defaultFlags allOpts-    commandCheckOptions = ocheck allOpts+    commandOptions = allOpts  withFpsAndArgs :: (b -> d) -> a -> b -> c -> d withFpsAndArgs cmd _ opts _ = cmd opts +maybeDo :: Monad m => Maybe t -> (t -> m ()) -> m ()+maybeDo (Just x) f = f x+maybeDo Nothing _ = return ()+ repairCmd :: [DarcsFlag] -> IO () repairCmd opts   | O.yes (O.dryRun ? opts) = checkCmd opts   | otherwise =-    withRepoLock O.NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    withRepoLock (useCache ? opts) (umask ? opts) $     RepoJob $ \repo -> do-      replayRepository+      bad_replay <- replayRepository         (diffAlgorithm ? opts)         repo-        (compress ? opts)-        (verbosity ? opts) $ \state ->-        case state of-          RepositoryConsistent ->-            putInfo opts "The repository is already consistent, no changes made."-          BrokenPristine tree -> do-            putInfo opts "Fixing pristine tree..."-            replacePristine repo tree-          BrokenPatches tree newps -> do+        (verbosity ? opts) $ \RepositoryConsistency {..} -> do+          maybeDo fixedPatches $ \ps -> do             putInfo opts "Writing out repaired patches..."-            HashedRepo.writeTentativeInventory (repoCache repo) (compress ? opts) newps-            HashedRepo.finalizeTentativeChanges repo (compress ? opts)+            writeTentativeInventory repo ps+          maybeDo fixedPristine $ \(tree, Sealed diff) -> do+            putVerbose opts $ "Pristine differences:" $$ displayPatch diff             putInfo opts "Fixing pristine tree..."-            replacePristine repo tree+            void $ writePristine repo tree+          maybeDo fixedPending $ \(Sealed pend) -> do+            putInfo opts "Writing out repaired pending..."+            setTentativePending repo pend+          return $ isJust fixedPatches || isJust fixedPristine || isJust fixedPending       index_ok <- checkIndex repo (quiet opts)       unless index_ok $ do         renameFile indexPath (indexPath <.> "bad")         putInfo opts "Bad index discarded."+      if bad_replay || not index_ok+        then void $ finalizeRepositoryChanges repo (O.dryRun ? opts)+        else putInfo opts "The repository is already consistent, no changes made."  -- |check is an alias for repair, with implicit DryRun flag. check :: DarcsCommand@@ -157,48 +153,29 @@     basicOpts = commonBasicOpts     advancedOpts = oid     allOpts = basicOpts `withStdOpts` advancedOpts-    commandAdvancedOptions = odesc advancedOpts-    commandBasicOptions = odesc basicOpts-    commandDefaults = defaultFlags allOpts-    commandCheckOptions = ocheck allOpts+    commandOptions = allOpts     commandDescription = "Alias for `darcs " ++ commandName repair ++ " --dry-run'."  checkCmd :: [DarcsFlag] -> IO () checkCmd opts = withRepository (useCache ? opts) $ RepoJob $ \repository -> do-  state <- replayRepositoryInTemp (diffAlgorithm ? opts) repository (compress ? opts) (verbosity ? opts)-  failed <--    case state of-      RepositoryConsistent -> do-        putInfo opts "The repository is consistent!"-        return False-      BrokenPristine newpris -> do-        brokenPristine opts repository newpris-        return True-      BrokenPatches newpris _ -> do-        brokenPristine opts repository newpris-        putInfo opts "Found broken patches."-        return True-  bad_index <- if useIndex ? opts == O.IgnoreIndex-                 then return False-                 else not <$> checkIndex repository (quiet opts)+  RepositoryConsistency {..} <-+    replayRepositoryInTemp (diffAlgorithm ? opts) repository (verbosity ? opts)+  maybeDo fixedPatches $ \_ ->+    putInfo opts "Found broken patches."+  maybeDo fixedPristine $ \(_, Sealed diff) -> do+    putInfo opts "Found broken pristine tree."+    putVerbose opts $ "Differences:" $$ displayPatch diff+  maybeDo fixedPending $ \_ ->+    putInfo opts "Found broken pending."+  bad_index <-+    if useIndex ? opts == O.IgnoreIndex+      then return False+      else+        not <$> do+          checkIndex repository (quiet opts) `catchIOError` \e -> do+            putWarning opts ("Warning, cannot access the index:" $$ text (show e))+            return True   when bad_index $ putInfo opts "Bad index."-  exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess--brokenPristine-  :: forall rt p wR wU wT . (RepoPatch p)-  => [DarcsFlag] -> Repository rt p wR wU wT -> Tree IO -> IO ()-brokenPristine opts repository newpris = do-  putInfo opts "Looks like we have a difference..."-  mc' <--    (Just `fmap` (readRecorded repository >>= expand >>= darcsUpdateHashes))-      `catch` (\(_ :: IOException) -> return Nothing)-  case mc' of-    Nothing -> do-      putWarning opts $ "Unable to read the recorded state, try repair."-    Just mc -> do-      ftf <- filetypeFunction-      Sealed (diff :: FL (PrimOf p) wR wR2)-        <- unFreeLeft `fmap` treeDiff (diffAlgorithm ? opts) ftf newpris mc :: IO (Sealed (FL (PrimOf p) wR))-      putInfo opts $ case diff of-        NilFL -> "Nothing"-        patch -> displayPatch patch+  if isJust fixedPatches || isJust fixedPristine || isJust fixedPending || bad_index+    then exitFailure+    else putInfo opts "The repository is consistent!"
src/Darcs/UI/Commands/Replace.hs view
@@ -25,7 +25,7 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B-import Data.Char ( isSpace )+import Data.Char ( isAscii, isPrint, isSpace ) import Data.List.Ordered ( nubSort ) import Data.Maybe ( fromJust, isJust ) import Control.Monad ( unless, filterM, void, when )@@ -33,11 +33,10 @@                       , makeBlobBS ) import Darcs.Util.Path( AbsolutePath ) import Darcs.UI.Flags-    ( DarcsFlag-    , verbosity, useCache, dryRun, umask, diffAlgorithm, pathsFromArgs )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )+    ( DarcsFlag, diffingOpts+    , verbosity, useCache, umask, diffAlgorithm, pathsFromArgs )+import Darcs.UI.Options ( (^), (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.Repository.Diff( treeDiff )@@ -49,75 +48,85 @@     ( withRepoLock     , RepoJob(..)     , addToPending+    , finalizeRepositoryChanges     , applyToWorking     , readUnrecorded     ) import Darcs.Patch.TokenReplace ( defaultToks ) import Darcs.Repository.Prefs ( FileType(TextFile) ) import Darcs.Util.Path ( AnchoredPath, displayPath )-import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Printer ( Doc, formatWords, vsep ) import Darcs.Util.SignalHandler ( withSignalsBlocked )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, nullFL )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , concatFL+    , consGapFL+    , joinGapsFL+    , nullFL+    , (+>+)+    ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal )  replaceDescription :: String replaceDescription = "Substitute one word for another."  replaceHelp :: Doc-replaceHelp = text $- "In addition to line-based patches, Darcs supports a limited form of\n" ++- "lexical substitution.  Files are treated as sequences of words, and\n" ++- "each occurrence of the old word is replaced by the new word.\n" ++- "This is intended to provide a clean way to rename a function or\n" ++- "variable.  Such renamings typically affect lines all through the\n" ++- "source code, so a traditional line-based patch would be very likely to\n" ++- "conflict with other branches, requiring manual merging.\n" ++- "\n" ++- "Files are tokenized according to one simple rule: words are strings of\n" ++- "valid token characters, and everything between them (punctuation and\n" ++- -- FIXME: this heuristic is ham-fisted and silly.  Can we drop it?- "whitespace) is discarded.  By default, valid token characters are\n" ++- "letters, numbers and the underscore (i.e. `[A-Za-z0-9_]`).  However if\n" ++- "the old and/or new token contains either a hyphen or period, BOTH\n" ++- "hyphen and period are treated as valid (i.e. `[A-Za-z0-9_.-]`).\n" ++- "\n" ++- "The set of valid characters can be customized using the `--token-chars`\n" ++- "option.  The argument must be surrounded by square brackets.  If a\n" ++- "hyphen occurs between two characters in the set, it is treated as a\n" ++- "set range.  For example, in most locales `[A-Z]` denotes all uppercase\n" ++- "letters.  If the first character is a caret, valid tokens are taken to\n" ++- "be the complement of the remaining characters.  For example, `[^:\\n]`\n" ++- "could be used to match fields in the passwd(5), where records and\n" ++- "fields are separated by newlines and colons respectively.\n" ++- "\n" ++- "If you choose to use `--token-chars`, you are STRONGLY encouraged to do\n" ++- "so consistently.  The consequences of using multiple replace patches\n" ++- "with different `--token-chars` arguments on the same file are not well\n" ++- "tested nor well understood.\n" ++- "\n" ++- "By default Darcs will refuse to perform a replacement if the new token\n" ++- "is already in use, because the replacements would be not be\n" ++- "distinguishable from the existing tokens.  This behaviour can be\n" ++- "overridden by supplying the `--force` option, but an attempt to `darcs\n" ++- "rollback` the resulting patch will affect these existing tokens.\n" ++- "\n" ++- "Limitations:\n" ++- "\n" ++- "The tokenizer treats files as byte strings, so it is not possible for\n" ++- "`--token-chars` to include multi-byte characters, such as the non-ASCII\n" ++- "parts of UTF-8.  Similarly, trying to replace a \"high-bit\" character\n" ++- "from a unibyte encoding will also result in replacement of the same\n" ++- "byte in files with different encodings.  For example, an acute a from\n" ++- "ISO 8859-1 will also match an alpha from ISO 8859-7.\n" ++- "\n" ++- "Due to limitations in the patch file format, `--token-chars` arguments\n" ++- "cannot contain literal whitespace.  For example, `[^ \\n\\t]` cannot be\n" ++- "used to declare all characters except the space, tab and newline as\n" ++- "valid within a word, because it contains a literal space.\n" ++- "\n" ++- "Unlike POSIX regex(7) bracket expressions, character classes (such as\n" ++- "`[[:alnum:]]`) are NOT supported by `--token-chars`, and will be silently\n" ++- "treated as a simple set of characters.\n"+replaceHelp = vsep $ map formatWords+  [ [ "In addition to line-based patches, Darcs supports a limited form of"+    , "lexical substitution.  Files are treated as sequences of words, and"+    , "each occurrence of the old word is replaced by the new word."+    , "This is intended to provide a clean way to rename a function or"+    , "variable.  Such renamings typically affect lines all through the"+    , "source code, so a traditional line-based patch would be very likely to"+    , "conflict with other branches, requiring manual merging."+    ]+  , [ "Files are tokenized according to one simple rule: words are strings of"+    , "valid token characters, and everything between them (punctuation and"+      -- FIXME: this heuristic is ham-fisted and silly.  Can we drop it?+    , "whitespace) is discarded.  By default, valid token characters are"+    , "letters, numbers and the underscore (i.e. `[A-Za-z0-9_]`).  However if"+    , "the old and/or new token contains either a hyphen or period, BOTH"+    , "hyphen and period are treated as valid (i.e. `[A-Za-z0-9_.-]`)."+    ]+  , [ "The set of valid characters can be customized using the `--token-chars`"+    , "option.  The argument must be surrounded by square brackets.  If a"+    , "hyphen occurs between two characters in the set, it is treated as a"+    , "set range.  For example, in most locales `[A-Z]` denotes all uppercase"+    , "letters.  If the first character is a caret, valid tokens are taken to"+    , "be the complement of the remaining characters.  For example, `[^:\\n]`"+    , "could be used to match fields in the passwd(5), where records and"+    , "fields are separated by newlines and colons respectively."+    ]+  , [ "If you choose to use `--token-chars`, you are STRONGLY encouraged to do"+    , "so consistently.  The consequences of using multiple replace patches"+    , "with different `--token-chars` arguments on the same file are not well"+    , "tested nor well understood."+    ]+  , [ "By default Darcs will refuse to perform a replacement if the new token"+    , "is already in use, because the replacements would be not be"+    , "distinguishable from the existing tokens.  This behaviour can be"+    , "overridden by supplying the `--force` option, but an attempt to `darcs"+    , "rollback` the resulting patch will affect these existing tokens."+    ]+  , [ "Limitations:"+    ]+  , [ "The tokenizer treats files as byte strings, so it is not possible for"+    , "`--token-chars` to include multi-byte characters, such as the non-ASCII"+    , "parts of UTF-8.  Similarly, trying to replace a \"high-bit\" character"+    , "from a unibyte encoding will also result in replacement of the same"+    , "byte in files with different encodings.  For example, an acute a from"+    , "ISO 8859-1 will also match an alpha from ISO 8859-7."+    ]+  , [ "Due to limitations in the patch file format, `--token-chars` arguments"+    , "cannot contain literal whitespace.  For example, `[^ \\n\\t]` cannot be"+    , "used to declare all characters except the space, tab and newline as"+    , "valid within a word, because it contains a literal space."+    ]+  , [ "Unlike POSIX regex(7) bracket expressions, character classes (such as"+    , "`[[:alnum:]]`) are NOT supported by `--token-chars`, and will be silently"+    , "treated as a simple set of characters."+    ]+  ]  replace :: DarcsCommand replace = DarcsCommand@@ -134,14 +143,11 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = replaceArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc replaceAdvancedOpts-    , commandBasicOptions = odesc replaceBasicOpts-    , commandDefaults = defaultFlags replaceOpts-    , commandCheckOptions = ocheck replaceOpts+    , commandOptions = replaceOpts     }   where     replaceBasicOpts = O.tokens ^ O.forceReplace ^ O.repoDir-    replaceAdvancedOpts = O.useIndex ^ O.umask+    replaceAdvancedOpts = O.umask     replaceOpts = replaceBasicOpts `withStdOpts` replaceAdvancedOpts  replaceArgs  :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String]@@ -152,23 +158,25 @@  replaceCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () replaceCmd fps opts (old : new : args@(_ : _)) =-  withRepoLock  (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $-    \repository -> do+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $+    \_repository -> do         paths <- nubSort <$> pathsFromArgs fps args         when (null paths) $ fail "No valid repository paths were given."         toks <- chooseToks (O.tokens ? opts) old new         let checkToken tok = unless (isTok toks tok) $                                  fail $ "'" ++ tok ++ "' is not a valid token!"         mapM_ checkToken [ old, new ]-        working <- readUnrecorded repository (O.useIndex ? opts) Nothing+        working <- readUnrecorded _repository (O.useIndex ? opts) Nothing         files <- filterM (exists working) paths-        Sealed replacePs <- mapSeal concatFL . toFL <$>+        Sealed replacePs <- mapSeal concatFL . unFreeLeft . joinGapsFL <$>             mapM (doReplace toks working) files         withSignalsBlocked $ do           -- Note: addToPending takes care of commuting the replace patch and           -- everything it depends on past the diff between pending and working-          addToPending repository (O.useIndex ? opts) replacePs-          void $ applyToWorking repository (verbosity ? opts) replacePs+          addToPending _repository (diffingOpts opts) replacePs+          _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+          unless (O.yes (O.dryRun ? opts)) $+            void $ applyToWorking _repository (verbosity ? opts) replacePs   where     exists tree file = if isJust $ findFile tree file                            then return True@@ -185,7 +193,7 @@         workReplaced <- maybeApplyToTree replacePatch work         case workReplaced of           Just _ -> do-            return $ joinGap (:>:) (freeGap replacePatch) gapNilFL+            return $ consGapFL replacePatch gapNilFL           Nothing             | O.forceReplace ? opts -> getForceReplace f toks work             | otherwise -> putStrLn existsMsg >> return gapNilFL@@ -250,7 +258,11 @@     | '^' == head tok && length tok == 1 =         badTokenSpec "Must be at least one character in the complementary set"     | any isSpace t =-        badTokenSpec "Space is not allowed in the spec"+        badTokenSpec "Space is not allowed"+    | any (not . isAscii) t =+        badTokenSpec "Only ASCII characters are allowed"+    | any (not . isPrint) t =+        badTokenSpec "Only printable characters are allowed"     | any isSpace a = badTokenSpec $ spaceyToken a     | any isSpace b = badTokenSpec $ spaceyToken b     | not (isTok tok a) = badTokenSpec $ notAToken a@@ -258,7 +270,7 @@     | otherwise = return tok   where     tok = init $ tail t :: String-    badTokenSpec msg = fail $ "Bad token spec: '" ++ t ++ "' (" ++ msg ++ ")"+    badTokenSpec msg = fail $ "Bad token spec: " ++ show t ++ " (" ++ msg ++ ")"     spaceyToken x = x ++ " must not contain any space"     notAToken x = x ++ " is not a token, according to your spec"
src/Darcs/UI/Commands/Revert.hs view
@@ -16,52 +16,51 @@ --  Boston, MA 02110-1301, USA.  {-# LANGUAGE OverloadedStrings #-}-module Darcs.UI.Commands.Revert ( revert ) where+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+module Darcs.UI.Commands.Revert ( revert, clean ) where  import Darcs.Prelude -import Control.Monad ( void )+import Control.Monad ( unless, when, void )  import Darcs.UI.Flags     ( DarcsFlag     , diffAlgorithm     , diffingOpts-    , dryRun     , isInteractive     , pathSetFromArgs     , umask     , useCache-    , verbosity-    , withContext     )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( (^), (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.UI.Commands     ( DarcsCommand(..)     , amInHashedRepository+    , commandAlias     , nodefaults     , putInfo     , putFinished     , withStdOpts     )-import Darcs.UI.Commands.Util ( announceFiles )-import Darcs.UI.Commands.Unrevert ( writeUnrevert )+import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths )+import Darcs.Repository.Unrevert ( writeUnrevert ) import Darcs.UI.Completion ( modifiedFileArgs )  import Darcs.Util.Global ( debugMessage ) import Darcs.Util.Path ( AbsolutePath )-import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Printer ( Doc, formatWords, vsep ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Repository-    ( withRepoLock-    , RepoJob(..)+    ( RepoJob(..)     , addToPending+    , finalizeRepositoryChanges     , applyToWorking-    , readRecorded+    , readPatches     , unrecordedChanges+    , withRepoLock     )-import Darcs.Patch ( invert, effectOnPaths, commuteFL )+import Darcs.Patch ( invert, commuteFL ) import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL ) import Darcs.Patch.Split ( reversePrimSplitter ) import Darcs.Patch.Witnesses.Ordered@@ -71,41 +70,40 @@     , (+>>+)     , reverseFL     )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.UI.SelectChanges     ( WhichChanges(Last)     , selectionConfigPrim     , runInvertibleSelection     ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )-import Darcs.Patch.TouchesFiles ( chooseTouching )   revertDescription :: String revertDescription = "Discard unrecorded changes."  revertHelp :: Doc-revertHelp = text $- "The `darcs revert` command discards unrecorded changes the working\n" ++- "tree.  As with `darcs record`, you will be asked which hunks (changes)\n" ++- "to revert.  The `--all` switch can be used to avoid such prompting. If\n" ++- "files or directories are specified, other parts of the working tree\n" ++- "are not reverted.\n" ++- "\n" ++- "In you accidentally reverted something you wanted to keep (for\n" ++- "example, typing `darcs rev -a` instead of `darcs rec -a`), you can\n" ++- "immediately run `darcs unrevert` to restore it.  This is only\n" ++- "guaranteed to work if the repository has not changed since `darcs\n" ++- "revert` ran.\n"+revertHelp = vsep $ map formatWords+  [ [ "The `darcs revert` command discards unrecorded changes in the working"+    , "tree.  As with `darcs record`, you will be asked which hunks (changes)"+    , "to revert.  The `--all` switch can be used to avoid such prompting. If"+    , "files or directories are specified, other parts of the working tree"+    , "are not reverted."+    ]+  , [ "In you accidentally reverted something you wanted to keep (for"+    , "example, typing `darcs rev -a` instead of `darcs rec -a`), you can"+    , "immediately run `darcs unrevert` to restore it.  This is only"+    , "guaranteed to work if the repository has not changed since `darcs"+    , "revert` ran."+    ]+  ]  patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions-    { S.verbosity = verbosity ? flags+    { S.verbosity = O.verbosity ? flags     , S.matchFlags = []     , S.interactive = isInteractive True flags     , S.selectDeps = O.PromptDeps -- option not supported, use default     , S.withSummary = O.NoSummary -- option not supported, use default-    , S.withContext = withContext ? flags     }  revert :: DarcsCommand@@ -120,60 +118,98 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = modifiedFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc revertAdvancedOpts-    , commandBasicOptions = odesc revertBasicOpts-    , commandDefaults = defaultFlags revertOpts-    , commandCheckOptions = ocheck revertOpts+    , commandOptions = opts     }   where-    revertBasicOpts+    basicOpts       = O.interactive -- True       ^ O.repoDir-      ^ O.withContext       ^ O.diffAlgorithm-    revertAdvancedOpts = O.useIndex ^ O.umask-    revertOpts = revertBasicOpts `withStdOpts` revertAdvancedOpts+      ^ O.maybelookforadds O.NoLookForAdds+    advancedOpts = O.umask+    opts = withStdOpts basicOpts advancedOpts  revertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () revertCmd fps opts args =- withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $- RepoJob $ \repository -> do-  files <- pathSetFromArgs fps args-  announceFiles (verbosity ? opts) files "Reverting changes in"-  changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -})-    O.NoLookForMoves O.NoLookForReplaces repository files-  let pre_changed_files = effectOnPaths (invert changes) <$> files-  recorded <- readRecorded repository-  Sealed touching_changes <- return (chooseTouching pre_changed_files changes)-  case touching_changes of-    NilFL -> putInfo opts "There are no changes to revert!"-    _ -> do-      let selection_config = selectionConfigPrim-                                Last "revert" (patchSelOpts opts)-                                (Just (reversePrimSplitter (diffAlgorithm ? opts)))-                                pre_changed_files (Just recorded)-      norevert :> torevert <- runInvertibleSelection changes selection_config-      if nullFL torevert-       then putInfo opts $+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    existing_paths <- existingPaths _repository =<< pathSetFromArgs fps args+    announceFiles verbosity existing_paths "Reverting changes in"+    changes <- unrecordedChanges diffOpts _repository existing_paths+    case changes of+      NilFL -> putInfo opts "There are no changes to revert!"+      _ -> do+        let selection_config =+              selectionConfigPrim Last "revert" (patchSelOpts opts)+                (Just (reversePrimSplitter (diffAlgorithm ? opts)))+                existing_paths+        norevert :> torevert <- runInvertibleSelection changes selection_config+        if nullFL torevert+          then+            putInfo opts $               "If you don't want to revert after all, that's fine with me!"-       else withSignalsBlocked $ do-                 addToPending repository (O.useIndex ? opts) $ invert torevert-                 debugMessage "About to write the unrevert file."-                 {- The user has split unrecorded into the sequence 'norevert' then 'torevert',-                    which is natural as the bit we keep in unrecorded should have recorded-                    as the context.+          else do+            withSignalsBlocked $ do+              addToPending _repository diffOpts $ invert torevert+              debugMessage "About to write the unrevert file."+              {- The user has split unrecorded into the sequence 'norevert'+                 then 'torevert', which is natural as the bit we keep in+                 unrecorded should have pristine as the context. -                    But the unrevert patch also needs to have recorded as the context, not-                    unrecorded (which can be changed by the user at any time).+                 But the unrevert patch also needs to have pristine as the+                 context, not unrecorded (which can be changed by the user+                 at any time). -                    So we need to commute 'torevert' with 'norevert', and if that fails then-                    we need to keep some of 'norevert' in the actual unrevert patch so it-                    still makes sense. The use of genCommuteWhatWeCanRL minimises the amount-                    of 'norevert' that we need to keep.-                 -}-                 case genCommuteWhatWeCanRL commuteFL (reverseFL norevert :> torevert) of-                   deps :> torevert' :> _ ->-                      writeUnrevert repository (deps +>>+ torevert') recorded NilFL-                 debugMessage "About to apply to the working tree."-                 void $ applyToWorking repository (verbosity ? opts) (invert torevert)-      putFinished opts "reverting"+                 So we need to commute 'torevert' with 'norevert', and if+                 that fails then we need to keep some of 'norevert' in the+                 actual unrevert patch so it still makes sense. The use of+                 genCommuteWhatWeCanRL minimises the amount of 'norevert'+                 that we need to keep.+              -}+              case genCommuteWhatWeCanRL commuteFL (reverseFL norevert :> torevert) of+                deps :> torevert' :> _ -> do+                  recorded <- readPatches _repository+                  writeUnrevert recorded (deps +>>+ torevert')+              _repository <-+                finalizeRepositoryChanges _repository+                  (O.dryRun ? opts)+              debugMessage "About to apply to the working tree."+              unless (O.yes (O.dryRun ? opts)) $+                void $ applyToWorking _repository verbosity (invert torevert)+            putFinished opts "reverting"+  where+    verbosity = O.verbosity ? opts+    diffOpts = diffingOpts opts+    existingPaths repo paths = do+      paths' <- traverse (filterExistingPaths repo verbosity diffOpts) paths+      let paths'' = fmap snd paths'+      when (paths'' == Just []) $ fail "None of the paths you specified exist."+      return paths''++-- | An alias for 'revert -l' i.e. remove every (non-boring) file or change+-- that is not in pristine.+clean :: DarcsCommand+clean = alias+    { commandDescription = desc+    , commandHelp = vsep $ map formatWords+        [ [ "Remove unrecorded changes from the working tree."+          ]+        , [ "This is an alias for `darcs revert -l/--look-for-adds` which"+          , "means it works also on files that have not been added."+          , "You can additionally pass `--boring` to get rid of *every*"+          , "unrecorded file or directory."+          ]+        , [ "See description of `darcs revert` for more details."+          ]+        ]+    , commandOptions = opts+    }+  where+    alias = commandAlias "clean" Nothing revert+    desc = "Alias for `darcs " ++ commandName revert ++ " -l`."+    basicOpts+      = O.interactive -- True+      ^ O.repoDir+      ^ O.diffAlgorithm+      ^ O.maybelookforadds O.YesLookForAdds+    advancedOpts = O.umask+    opts = withStdOpts basicOpts advancedOpts
src/Darcs/UI/Commands/Rollback.hs view
@@ -19,37 +19,29 @@  import Darcs.Prelude -import Control.Monad ( when, void )-import Darcs.Util.Tree( Tree )+import Control.Monad ( unless, when, void ) import System.Exit ( exitSuccess ) -import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Match ( firstMatch ) import Darcs.Patch.PatchInfoAnd ( n2pia )-import Darcs.Patch ( IsRepoType, RepoPatch, invert, effect, sortCoalesceFL,-                     canonize, PrimOf )+import Darcs.Patch ( canonizeFL, effect, invert ) import Darcs.Patch.Named ( anonymous )-import Darcs.Patch.Set ( PatchSet, Origin, emptyPatchSet, patchSet2FL )+import Darcs.Patch.Set ( emptyPatchSet, patchSet2FL ) import Darcs.Patch.Split ( reversePrimSplitter )-import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), concatFL, nullFL, mapFL_FL )+import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )-import Darcs.Repository.Flags ( AllowConflicts (..), UseIndex(..), Reorder(..),-                                ScanKnown(..), UpdatePending(..), DryRun(NoDryRun))-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..),-                          applyToWorking, readRepo,-                          finalizeRepositoryChanges, tentativelyAddToPending,+import Darcs.Repository ( withRepoLock, RepoJob(..),+                          applyToWorking, readPatches,+                          finalizeRepositoryChanges, addToPending,                           considerMergeToWorking ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, setEnvDarcsPatches,                            amInHashedRepository, putInfo ) import Darcs.UI.Commands.Util ( announceFiles, getLastPatches ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.Flags ( DarcsFlag, verbosity, umask, useCache,-                        compress, externalMerge, wantGuiPause,+                        wantGuiPause, diffingOpts,                         diffAlgorithm, isInteractive, pathSetFromArgs )-import Darcs.UI.Options-    ( (^), odesc, ocheck-    , defaultFlags, parseFlags, (?)-    )+import Darcs.UI.Options ( parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.SelectChanges ( WhichChanges(..),                                 selectionConfig, selectionConfigPrim,@@ -86,7 +78,6 @@     , S.interactive = isInteractive True flags     , S.selectDeps = O.PromptDeps     , S.withSummary = O.NoSummary-    , S.withContext = O.NoContext     }  rollback :: DarcsCommand@@ -101,10 +92,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = knownFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc rollbackAdvancedOpts-    , commandBasicOptions = odesc rollbackBasicOpts-    , commandDefaults = defaultFlags rollbackOpts-    , commandCheckOptions = ocheck rollbackOpts+    , commandOptions = rollbackOpts     }   where     rollbackBasicOpts@@ -120,11 +108,11 @@     when (nullFL ps) $ putStrLn ("No " ++ what ++ " selected!") >> exitSuccess  rollbackCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-rollbackCmd fps opts args = withRepoLock NoDryRun (useCache ? opts)-    YesUpdatePending (umask ? opts) $ RepoJob $ \repository -> do+rollbackCmd fps opts args = withRepoLock (useCache ? opts)+    (umask ? opts) $ RepoJob $ \_repo -> do         files <- pathSetFromArgs fps args         announceFiles (verbosity ? opts) files "Rolling back changes in"-        allpatches <- readRepo repository+        allpatches <- readPatches _repo         let matchFlags = parseFlags O.matchSeveralOrLast opts         (_ :> patches) <- return $             if firstMatch matchFlags@@ -140,30 +128,23 @@               selectionConfigPrim                   Last "rollback" (patchSelOpts opts)                   (Just (reversePrimSplitter (diffAlgorithm ? opts)))-                  files Nothing-            hunks = concatFL . mapFL_FL (canonize $ diffAlgorithm ? opts) . sortCoalesceFL . effect-        whatToUndo <- runInvertibleSelection (hunks ps) prim_selection_context-        undoItNow opts repository allpatches whatToUndo--undoItNow :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-          => [DarcsFlag] -> Repository rt p wR wU wR-          -> PatchSet rt p Origin wR-          -> (q :> FL (PrimOf p)) wA wR -> IO ()-undoItNow opts _repo context (_ :> prims) = do-    exitIfNothingSelected prims "changes"-    -- Note: use of anonymous is unproblematic here because we-    -- only store effects by adding them to pending and working)-    rbp <- n2pia `fmap` anonymous (invert prims)-    Sealed pw <- considerMergeToWorking _repo "rollback"-                     YesAllowConflictsAndMark-                     (externalMerge ? opts) (wantGuiPause opts)-                     (compress ? opts) (verbosity ? opts) NoReorder-                     (UseIndex, ScanKnown, diffAlgorithm ? opts)-                     (Fork context NilFL (rbp :>: NilFL))-    tentativelyAddToPending _repo pw-    withSignalsBlocked $ do-        _repo <- finalizeRepositoryChanges _repo YesUpdatePending (compress ? opts)-        void $ applyToWorking _repo (verbosity ? opts) pw-    debugMessage "Finished applying unrecorded rollback patch"-    putInfo opts $ text "Changes rolled back in working tree"-+                  files+            hunks = canonizeFL (diffAlgorithm ? opts) . effect+        _ :> to_undo <- runInvertibleSelection (hunks ps) prim_selection_context+        exitIfNothingSelected to_undo "changes"+        -- Note: use of anonymous is unproblematic here because we+        -- only store effects by adding them to pending and working)+        rbp <- n2pia `fmap` anonymous (invert to_undo)+        Sealed pw <- considerMergeToWorking _repo "rollback"+                         (O.YesAllowConflicts O.MarkConflicts)+                         (wantGuiPause opts)+                         O.NoReorder+                         (diffingOpts opts)+                         (Fork allpatches NilFL (rbp :>: NilFL))+        addToPending _repo (diffingOpts opts) pw+        withSignalsBlocked $ do+            _repo <- finalizeRepositoryChanges _repo (O.dryRun ? opts)+            unless (O.yes (O.dryRun ? opts)) $+              void $ applyToWorking _repo (verbosity ? opts) pw+        debugMessage "Finished applying unrecorded rollback patch"+        putInfo opts $ text "Changes rolled back in working tree"
src/Darcs/UI/Commands/Send.hs view
@@ -43,7 +43,7 @@ import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos ) import Darcs.UI.Flags     ( DarcsFlag-    , willRemoveLogFile, changesReverse, dryRun, useCache, remoteRepos, setDefault+    , willRemoveLogFile, changesReverse, dryRun, useCache, setDefault     , fixUrl     , getCc     , getAuthor@@ -60,27 +60,25 @@     , minimize     , editDescription     )-import Darcs.UI.Options-    ( (^), odesc, ocheck-    , defaultFlags, parseFlags, (?)-    )+import Darcs.UI.Options ( (?), (^) ) import qualified Darcs.UI.Options.All as O  import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc ) import Darcs.Repository     ( Repository+    , AccessType(..)     , repoLocation     , PatchSet     , identifyRepositoryFor     , ReadingOrWriting(..)     , withRepository     , RepoJob(..)-    , readRepo-    , readRecorded+    , readPatches+    , readPristine     , prefsUrl ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( IsRepoType, RepoPatch, description, applyToTree, effect, invert )+import Darcs.Patch ( RepoPatch, description, applyToTree, effect, invert ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Ordered@@ -91,9 +89,13 @@     , minContext     , readContextFile     )-import Darcs.Repository.Prefs ( addRepoSource, getPreflist )+import Darcs.Repository.Prefs+    ( Pref(Defaultrepo, Email, Post, Repos)+    , addRepoSource+    , getPreflist+    ) import Darcs.Repository.Flags ( DryRun(..) )-import Darcs.Util.External ( fetchFilePS, Cachable(..) )+import Darcs.Util.File ( fetchFilePS, Cachable(..) ) import Darcs.UI.External     ( signString     , sendEmailDoc@@ -103,9 +105,9 @@     ) import Darcs.Util.ByteString ( mmapFilePS, isAscii ) import qualified Data.ByteString.Char8 as BC (unpack)+import Darcs.Util.File ( withOpenTemp ) import Darcs.Util.Lock-    ( withOpenTemp-    , writeDocBinFile+    ( writeDocBinFile     , readDocBinFile     , removeFileMayNotExist     )@@ -137,11 +139,10 @@ patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions     { S.verbosity = verbosity ? flags-    , S.matchFlags = parseFlags O.matchSeveral flags+    , S.matchFlags = O.matchSeveral ? flags     , S.interactive = isInteractive True flags     , S.selectDeps = selectDeps ? flags     , S.withSummary = O.withSummary ? flags-    , S.withContext = O.NoContext     }  send :: DarcsCommand@@ -154,12 +155,9 @@     , commandExtraArgHelp = ["[REPOSITORY]"]     , commandCommand = sendCmd     , commandPrereq = amInHashedRepository-    , commandCompleteArgs = prefArgs "repos"+    , commandCompleteArgs = prefArgs Repos     , commandArgdefaults = defaultRepo-    , commandAdvancedOptions = odesc sendAdvancedOpts-    , commandBasicOptions = odesc sendBasicOpts-    , commandDefaults = defaultFlags sendOpts-    , commandCheckOptions = ocheck sendOpts+    , commandOptions = sendOpts     }   where     sendBasicOpts@@ -183,17 +181,16 @@       ^ O.allowUnrelatedRepos     sendAdvancedOpts       = O.logfile-      ^ O.remoteRepos       ^ O.sendToContext        ^ O.changesReverse-      ^ O.network+      ^ O.remoteDarcs     sendOpts = sendBasicOpts `withStdOpts` sendAdvancedOpts  sendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () sendCmd fps opts [""] = sendCmd fps opts [] sendCmd (_,o) opts [unfixedrepodir] =  withRepository (useCache ? opts) $ RepoJob $-  \(repository :: Repository rt p wR wU wR) -> do+  \(repository :: Repository 'RO p wU wR) -> do   when (O.mail ? opts && dryRun ? opts == O.NoDryRun) $ do     -- If --mail is used and the user has not provided a --sendmail-command     -- and we can detect that the system has no default way to send emails, @@ -202,8 +199,8 @@     when (isNothing sm_cmd) checkDefaultSendmail   case O.sendToContext ? opts of     Just contextfile -> do-        wtds <- decideOnBehavior opts (Nothing :: Maybe (Repository rt p wR wU wR))-        ref <- readRepo repository+        wtds <- decideOnBehavior opts (Nothing :: Maybe (Repository rt p wU wR))+        ref <- readPatches repository         Sealed them <- readContextFile ref (toFilePath contextfile)         sendToThem repository opts wtds "CONTEXT" them     Nothing -> do@@ -212,29 +209,29 @@         here <- getCurrentDirectory         when (repodir == toFilePath here) $            fail cannotSendToSelf-        old_default <- getPreflist "defaultrepo"+        old_default <- getPreflist Defaultrepo         when (old_default == [repodir]) $             putInfo opts (creatingPatch repodir)         repo <- identifyRepositoryFor Reading repository (useCache ? opts) repodir-        them <- readRepo repo-        addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts)-            (setDefault False opts) (O.inheritDefault ? opts) (isInteractive True opts)+        them <- readPatches repo+        addRepoSource repodir (dryRun ? opts) (setDefault False opts)+          (O.inheritDefault ? opts)         wtds <- decideOnBehavior opts (Just repo)         sendToThem repository opts wtds repodir them sendCmd _ _ _ = error "impossible case" -sendToThem :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-           => Repository rt p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String-           -> PatchSet rt p Origin wX -> IO ()+sendToThem :: (RepoPatch p, ApplyState p ~ Tree)+           => Repository rt p wU wR -> [DarcsFlag] -> [WhatToDo] -> String+           -> PatchSet p Origin wX -> IO () sendToThem repo opts wtds their_name them = do-  us <- readRepo repo+  us <- readPatches repo   common :> us' <- return $ findCommonWithThem us them   checkUnrelatedRepos (O.allowUnrelatedRepos ? opts) us them   case us' of       NilFL -> do putInfo opts nothingSendable                   exitSuccess       _     -> putVerbose opts $ selectionIs (mapFL description us')-  pristine <- readRecorded repo+  pristine <- readPristine repo   let direction = if changesReverse ? opts then FirstReversed else First       selection_config = selectionConfig direction "send" (patchSelOpts opts) Nothing Nothing   (to_be_sent :> _) <- runSelection us' selection_config@@ -260,21 +257,21 @@   here   <- getCurrentDirectory   let make_fname (tb:>:_) = getUniqueDPatchName $ patchDesc tb       make_fname _ = error "impossible case"-  fname <- make_fname to_be_sent+  let fname = make_fname to_be_sent   let outname = case getOutput opts fname of                     Just f  -> Just f                     Nothing | O.mail ? opts -> Nothing-                            | not $ null [ p | Post p <- wtds] -> Nothing-                            | otherwise        -> Just (makeAbsoluteOrStd here fname)+                            | not $ null [ p | PostHttp p <- wtds] -> Nothing+                            | otherwise        -> Just (makeAbsoluteOrStd here <$> fname)   case outname of-    Just fname' -> writeBundleToFile opts to_be_sent bundle fname' wtds their_name-    Nothing     -> sendBundle opts to_be_sent bundle fname wtds their_name+    Just fname' -> fname' >>= \f -> writeBundleToFile opts to_be_sent bundle f wtds their_name+    Nothing     -> fname >>= \f -> sendBundle opts to_be_sent bundle f wtds their_name  -prepareBundle :: forall rt p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree)-              => [DarcsFlag] -> PatchSet rt p Origin wZ-              -> Either (FL (PatchInfoAnd rt p) wX wY)-                        (Tree IO, (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY)+prepareBundle :: forall p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree)+              => [DarcsFlag] -> PatchSet p Origin wZ+              -> Either (FL (PatchInfoAnd p) wX wY)+                        (Tree IO, (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY)               -> IO Doc prepareBundle opts common e = do   unsig_bundle <-@@ -287,78 +284,88 @@        Left to_be_sent -> makeBundle Nothing                                       (unsafeCoerceP common)                                       (mapFL_FL hopefully to_be_sent)-  signString (parseFlags O.sign opts) unsig_bundle--sendBundle :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree)-           => [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY-             -> Doc -> String -> [WhatToDo] -> String -> IO ()-sendBundle opts to_be_sent bundle fname wtds their_name=-         let-           auto_subject :: forall pp wA wB . FL (PatchInfoAnd rt pp) wA wB -> String-           auto_subject (p:>:NilFL)  = "darcs patch: " ++ trim (patchDesc p) 57-           auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 ++-                            " (and " ++ show (lengthFL ps) ++ " more)"-           auto_subject _ = error "Tried to get a name from empty patch list."-           trim st n = if length st <= n then st-                       else take (n-3) st ++ "..."-           in do-           thetargets <- getTargets wtds-           from <- getAuthor (author ? opts) False-           let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts-           (mailcontents, mailfile, mailcharset) <- getDescription opts their_name to_be_sent--           let warnMailBody = case mailfile of-                                  Just mf -> putDocLn $ emailBackedUp mf-                                  Nothing -> return ()--               warnCharset msg = do-                 confirmed <- promptYorn $ promptCharSetWarning msg-                 unless confirmed $ do-                    putDocLn charsetAborted-                    warnMailBody-                    exitSuccess--           thecharset <- case charset ? opts of-                              -- Always trust provided charset-                              providedCset@(Just _) -> return providedCset-                              Nothing ->-                                case mailcharset of-                                Nothing -> do-                                  warnCharset charsetCouldNotGuess-                                  return mailcharset-                                Just "utf-8" -> return mailcharset-                                -- Trust other cases (us-ascii)-                                Just _ -> return mailcharset--           let body = makeEmail their_name-                        (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts)-                        (Just mailcontents)-                        thecharset-                        bundle-                        (Just fname)-               contentAndBundle = Just (mailcontents, bundle)--               sendmail =-                (do-                 let to = generateEmailToString thetargets-                 sm_cmd <- getSendmailCmd opts-                 sendEmailDoc from to thesubject (getCc opts)-                               sm_cmd contentAndBundle body-                 putInfo opts (success to (getCc opts)))-                 `onException` warnMailBody+  signString (O.sign ? opts) unsig_bundle -           when (null [ p | Post p <- thetargets]) sendmail-           nbody <- withOpenTemp $ \ (fh,fn) -> do-               let to = generateEmailToString thetargets-               generateEmail fh from to thesubject (getCc opts) body-               hClose fh-               mmapFilePS fn-           forM_ [ p | Post p <- thetargets]-             (\url -> do-                putInfo opts $ postingPatch url-                postUrl url nbody "message/rfc822")-             `catch` (\(_ :: IOException) -> sendmail)-           cleanup opts mailfile+sendBundle+  :: forall p wX wY+   . (RepoPatch p, ApplyState p ~ Tree)+  => [DarcsFlag]+  -> FL (PatchInfoAnd p) wX wY+  -> Doc+  -> String+  -> [WhatToDo]+  -> String+  -> IO ()+sendBundle opts to_be_sent bundle fname wtds their_name = do+  let auto_subject :: forall pp wA wB. FL (PatchInfoAnd pp) wA wB -> String+      auto_subject (p :>: NilFL) = "darcs patch: " ++ trim (patchDesc p) 57+      auto_subject (p :>: ps) =+        "darcs patch: " +++        trim (patchDesc p) 43 ++ " (and " ++ show (lengthFL ps) ++ " more)"+      auto_subject _ = error "Tried to get a name from empty patch list."+      trim st n =+        if length st <= n+          then st+          else take (n - 3) st ++ "..."+  thetargets <- getTargets wtds+  from <- getAuthor (author ? opts) False+  let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts+  (mailcontents, mailfile, mailcharset) <-+    getDescription opts their_name to_be_sent+  let warnMailBody =+        case mailfile of+          Just mf -> putDocLn $ emailBackedUp mf+          Nothing -> return ()+      warnCharset msg = do+        confirmed <- promptYorn $ promptCharSetWarning msg+        unless confirmed $ do+          putDocLn charsetAborted+          warnMailBody+          exitSuccess+  thecharset <-+    case charset ? opts of+      -- Always trust provided charset+      providedCset@(Just _) ->+        return providedCset+      Nothing ->+        case mailcharset of+          Nothing -> do+            warnCharset charsetCouldNotGuess+            return mailcharset+          Just "utf-8" ->+            return mailcharset+          -- Trust other cases (us-ascii)+          Just _ -> return mailcharset+  let body =+        makeEmail+          their_name+          (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) .+           getInReplyTo $+           opts)+          (Just mailcontents) thecharset bundle (Just fname)+      contentAndBundle = Just (mailcontents, bundle)+      sendmail =+        (do let to = generateEmailToString thetargets+            sm_cmd <- getSendmailCmd opts+            sendEmailDoc from to thesubject (getCc opts) sm_cmd+              contentAndBundle body+            putInfo opts (success to (getCc opts)))+        `onException`+        warnMailBody+  when (null [p | PostHttp p <- thetargets]) sendmail+  nbody <-+    withOpenTemp $ \(fh, fn) -> do+      let to = generateEmailToString thetargets+      generateEmail fh from to thesubject (getCc opts) body+      hClose fh+      mmapFilePS fn+  forM_+    [p | PostHttp p <- thetargets]+    (\url -> do+       putInfo opts $ postingPatch url+       postUrl url nbody "message/rfc822") `catch`+    (\(_ :: IOException) -> sendmail)+  cleanup opts mailfile  generateEmailToString :: [WhatToDo] -> String generateEmailToString = intercalate " , " . filter (/= "") . map extractEmail@@ -371,8 +378,8 @@                                       removeFileMayNotExist mailfile cleanup _ Nothing = return () -writeBundleToFile :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree)-                  => [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> Doc ->+writeBundleToFile :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree)+                  => [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> Doc ->                     AbsolutePathOrStd -> [WhatToDo] -> String -> IO () writeBundleToFile opts to_be_sent bundle fname wtds their_name =     do (d,f,_) <- getDescription opts their_name to_be_sent@@ -385,10 +392,10 @@        cleanup opts f  data WhatToDo-    = Post String        -- ^ POST the patch via HTTP+    = PostHttp String    -- ^ POST the patch via HTTP     | SendMail String    -- ^ send patch via email -decideOnBehavior :: [DarcsFlag] -> Maybe (Repository rt p wR wU wT) -> IO [WhatToDo]+decideOnBehavior :: [DarcsFlag] -> Maybe (Repository rt p wU wR) -> IO [WhatToDo] decideOnBehavior opts remote_repo =     case the_targets of     [] -> do wtds <- case remote_repo of@@ -401,26 +408,26 @@     where the_targets = collectTargets opts           check_post the_remote_repo =                        do p <- ((readPost . BC.unpack) `fmap`-                                fetchFilePS (prefsUrl (repoLocation the_remote_repo) ++ "/post")+                                fetchFilePS (prefsUrl (repoLocation the_remote_repo) Post)                                 (MaxAge 600)) `catchall` return []                           emails <- who_to_email the_remote_repo                           return (p++emails)           readPost = map parseLine . lines where-              parseLine t = maybe (Post t) SendMail $ stripPrefix "mailto:" t+              parseLine t = maybe (PostHttp t) SendMail $ stripPrefix "mailto:" t           who_to_email repo =               do email <- (BC.unpack `fmap`-                           fetchFilePS (prefsUrl (repoLocation repo) ++ "/email")+                           fetchFilePS (prefsUrl (repoLocation repo) Email)                                        (MaxAge 600))                           `catchall` return ""                  if '@' `elem` email then return . map SendMail $ lines email                                      else return []           announce_recipients emails =             let pn (SendMail s) = s-                pn (Post p) = p+                pn (PostHttp p) = p                 msg = willSendTo (dryRun ? opts) (map pn emails)             in case dryRun ? opts of                 O.YesDryRun -> putInfo opts msg-                O.NoDryRun  -> when (null the_targets && isNothing (getOutput opts "")) $+                O.NoDryRun  -> when (null the_targets && isNothing (getOutput opts (return ""))) $                                 putInfo opts msg  getTargets :: [WhatToDo] -> IO [WhatToDo]@@ -429,11 +436,11 @@  collectTargets :: [DarcsFlag] -> [WhatToDo] collectTargets flags = [ f t | t <- O._to (O.headerFields ? flags) ] where-    f url | "http:" `isPrefixOf` url = Post url+    f url | "http:" `isPrefixOf` url = PostHttp url     f em = SendMail em  getDescription :: RepoPatch p-               => [DarcsFlag] -> String -> FL (PatchInfoAnd rt p) wX wY -> IO (Doc, Maybe String, Maybe String)+               => [DarcsFlag] -> String -> FL (PatchInfoAnd p) wX wY -> IO (Doc, Maybe String, Maybe String) getDescription opts their_name patches =     case get_filename of         Just file -> do
src/Darcs/UI/Commands/SetPref.hs view
@@ -20,16 +20,24 @@ import Darcs.Prelude  import System.Exit ( exitWith, ExitCode(..) )-import Control.Monad ( when )+import Control.Monad ( when, void ) import Data.Maybe ( fromMaybe ) -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )-import Darcs.UI.Flags ( DarcsFlag, useCache, dryRun, umask)-import Darcs.UI.Options-    ( odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Flags ( DarcsFlag, diffingOpts, useCache, umask)+import Darcs.UI.Options ( (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdatePending (..) )-import Darcs.Repository ( addToPending, withRepoLock, RepoJob(..) )+import Darcs.Repository+    ( RepoJob(..)+    , addToPending+    , finalizeRepositoryChanges+    , withRepoLock+    ) import Darcs.Patch ( changepref ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) import Darcs.Repository.Prefs ( getPrefval, changePrefval )@@ -87,10 +95,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = completeArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc setprefAdvancedOpts-    , commandBasicOptions = odesc setprefBasicOpts-    , commandDefaults = defaultFlags setprefOpts-    , commandCheckOptions = ocheck setprefOpts+    , commandOptions = setprefOpts     }   where     setprefBasicOpts = O.repoDir@@ -101,7 +106,7 @@  setprefCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () setprefCmd _ opts [pref,val] =- withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $ \repository -> do+ withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \repository -> do   when (' ' `elem` pref) $ do     putStrLn $ "'"++pref++                "' is not a valid preference name: no spaces allowed!"@@ -117,6 +122,7 @@     exitWith $ ExitFailure 1   changePrefval pref old val   putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'"-  addToPending repository (O.useIndex ? opts) (changepref pref old val :>: NilFL)+  addToPending repository (diffingOpts opts) (changepref pref old val :>: NilFL)+  void $ finalizeRepositoryChanges repository (O.dryRun ? opts) setprefCmd _ _ _ = error "impossible case"
src/Darcs/UI/Commands/ShowAuthors.hs view
@@ -32,7 +32,7 @@ import Darcs.Prelude  import Darcs.UI.Flags ( DarcsFlag, useCache, verbose )-import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( oid, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putWarning, amInRepository ) import Darcs.UI.Completion ( noArgs )@@ -40,7 +40,7 @@ import Darcs.Patch.PatchInfoAnd ( info ) import Darcs.Patch.Info ( piAuthor ) import Darcs.Patch.Set ( patchSet2RL )-import Darcs.Repository ( readRepo, withRepository, RepoJob(..) )+import Darcs.Repository ( readPatches, withRepository, RepoJob(..) ) import Darcs.Patch.Witnesses.Ordered ( mapRL ) import Darcs.Util.Lock ( readTextFile ) import Darcs.Util.Printer ( Doc, text )@@ -105,10 +105,7 @@     , commandPrereq = amInRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc showAuthorsBasicOpts-    , commandDefaults = defaultFlags showAuthorsOpts-    , commandCheckOptions = ocheck showAuthorsOpts+    , commandOptions = showAuthorsOpts     }   where     showAuthorsBasicOpts = O.repoDir@@ -116,7 +113,7 @@  authorsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () authorsCmd _ flags _ = withRepository (useCache ? flags) $ RepoJob $ \repository -> do-    patches <- readRepo repository+    patches <- readPatches repository     spellings <- compiledAuthorSpellings flags     let authors = mapRL (piAuthor . info) $ patchSet2RL patches     viewDoc $ text $ unlines $
src/Darcs/UI/Commands/ShowContents.hs view
@@ -28,13 +28,11 @@ import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, useCache, pathsFromArgs )-import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( (^), oid, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Patch.Match ( patchSetMatch )-import Darcs.Repository ( withRepository, RepoJob(..), readRecorded )-import Darcs.Util.Lock ( withDelayedDir )-import Darcs.Repository.Match ( getRecordedUpToMatch )-import Darcs.Util.Tree.Plain( readPlainTree )+import Darcs.Repository ( withRepository, RepoJob(..), readPristine )+import Darcs.Repository.Match ( getPristineUpToMatch ) import qualified Darcs.Util.Tree.Monad as TM import Darcs.Util.Path( AbsolutePath ) import Darcs.Util.Printer ( Doc, text )@@ -60,13 +58,9 @@     , commandPrereq = findRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc showContentsBasicOpts-    , commandDefaults = defaultFlags showContentsOpts-    , commandCheckOptions = ocheck showContentsOpts+    , commandOptions = showContentsOpts     }   where-    showContentsBasicOpts = O.matchUpToOne ^ O.repoDir     showContentsOpts = O.matchUpToOne ^ O.repoDir `withStdOpts` oid  showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()@@ -79,22 +73,9 @@     let readContents = do           okpaths <- filterM TM.fileExists paths           forM okpaths $ \f -> (B.concat . BL.toChunks) `fmap` TM.readFile f-        -- Note: The two calls to execReadContents below are from-        -- different working directories. This matters despite our-        -- use of virtualTreeIO.         execReadContents tree = fst `fmap` TM.virtualTreeIO readContents tree     files <--      case patchSetMatch matchFlags of-        Just psm ->-               withDelayedDir "show.contents" $ \_ -> do-                 -- this call populates our temporary directory, but note that-                 -- it does so lazily: the tree gets (partly) expanded inside-                 -- execReadContents, so it is important that we execute the-                 -- latter from the same working directory.-                 getRecordedUpToMatch repository psm-                 readPlainTree "." >>= execReadContents-        Nothing ->-               -- we can use the existing pristine tree because we don't modify-               -- anything in this case-               readRecorded repository >>= execReadContents+      (case patchSetMatch matchFlags of+        Just psm -> getPristineUpToMatch repository psm+        Nothing -> readPristine repository) >>= execReadContents     forM_ files $ B.hPut stdout
src/Darcs/UI/Commands/ShowDependencies.hs view
@@ -7,10 +7,10 @@ import Data.Maybe( fromJust, fromMaybe ) import qualified Data.Set as S -import Darcs.Repository ( RepoJob(..), readRepo, withRepositoryLocation )+import Darcs.Repository ( RepoJob(..), readPatches, withRepositoryLocation )  import Darcs.UI.Flags ( DarcsFlag, getRepourl, useCache )-import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( oid, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts ) import Darcs.UI.Commands.Util ( matchRange )@@ -85,10 +85,7 @@     , commandPrereq = findRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc showDepsBasicOpts-    , commandDefaults = defaultFlags showDepsOpts-    , commandCheckOptions = ocheck showDepsOpts+    , commandOptions = showDepsOpts     }   where     showDepsBasicOpts = O.matchRange@@ -101,7 +98,7 @@ depsCmd _ opts _ = do     let repodir = fromMaybe "." (getRepourl opts)     withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> do-        Sealed2 range <- matchRange (O.matchRange ? opts) <$> readRepo repo+        Sealed2 range <- matchRange (O.matchRange ? opts) <$> readPatches repo         beginTedious progressKey         tediousSize progressKey (lengthFL range)         putDocLn $ renderDepsGraphAsDot $ depsGraph $ reverseFL range@@ -126,10 +123,9 @@     -- all patches preceding p.     m = depsGraph ps     -- Lookup all (direct and indirect) dependencies of a patch in a given-    -- 'DepthGraph'+    -- 'DepsGraph'     allDeps j = uncurry S.union . fromJust . M.lookup j     -- Add all (direct and indirect) dependencies of a patch to a given set-    -- assuming 'm' already     addDeps j = S.insert j . S.union (allDeps j m)     -- Add direct and indirect dependencies of a patch, assuming that the     -- graph has already been constructed for all patches in the context.@@ -145,13 +141,13 @@       -- We have a new dependency which must be a direct one, so add it to       -- 'direct' and all its dependencies to 'indirect'. The invariant that       -- direct and indirect are disjoint is maintained because neither the-      -- direct and indirect deps of a patch contain its own 'PatchId'.+      -- direct nor indirect deps of a patch contain its own 'PatchId'.       | otherwise =         foldDeps qs (q :>: p_and_deps) non_deps (S.insert j direct, addDeps j indirect)       where         j = ident q --- | Render a 'DepthGraph' in the Dot Language format. This function+-- | Render a 'DepsGraph' in the Dot Language format. This function -- considers only the direct dependencies. renderDepsGraphAsDot :: M.Map PatchInfo (S.Set PatchInfo, S.Set PatchInfo) -> Doc renderDepsGraphAsDot g = vcat ["digraph {", indent body, "}"]
src/Darcs/UI/Commands/ShowFiles.hs view
@@ -18,14 +18,11 @@ module Darcs.UI.Commands.ShowFiles ( showFiles ) where  import Darcs.Prelude-import Data.Maybe ( fromJust, isJust ) -import Darcs.Patch ( IsRepoType, RepoPatch )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Match ( PatchSetMatch, patchSetMatch )-import Darcs.Repository ( RepoJob(..), Repository, withRepository )-import Darcs.Repository.Match ( getRecordedUpToMatch )-import Darcs.Repository.State ( readRecorded, readRecordedAndPending )+import Darcs.Patch.Match ( patchSetMatch )+import Darcs.Repository ( RepoJob(..), withRepository )+import Darcs.Repository.Match ( getPristineUpToMatch )+import Darcs.Repository.State ( readPristine, readPristineAndPending ) import Darcs.UI.Commands     ( DarcsCommand(..)     , amInRepository@@ -34,9 +31,8 @@     ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.Flags ( DarcsFlag, pathsFromArgs, useCache )-import Darcs.UI.Options ( defaultFlags, ocheck, odesc, oid, parseFlags, (?), (^) )+import Darcs.UI.Options ( oid, parseFlags, (?), (^) ) import qualified Darcs.UI.Options.All as O-import Darcs.Util.Lock ( withDelayedDir ) import Darcs.Util.Path     ( AbsolutePath     , AnchoredPath@@ -46,7 +42,6 @@     ) import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Tree ( Tree, TreeItem(..), expand, list )-import Darcs.Util.Tree.Plain ( readPlainTree )  showFilesDescription :: String showFilesDescription = "Show version-controlled files in the working tree."@@ -87,10 +82,7 @@     , commandPrereq = amInRepository     , commandCompleteArgs = knownFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc showFilesBasicOpts-    , commandDefaults = defaultFlags showFilesOpts-    , commandCheckOptions = ocheck showFilesOpts+    , commandOptions = showFilesOpts     }   where     showFilesBasicOpts@@ -114,15 +106,11 @@ manifestHelper opts prefixes =   fmap (map displayPath . onlysubdirs prefixes . listFilesOrDirs) $     withRepository (useCache ? opts) $ RepoJob $ \r -> do-      let mpsm = patchSetMatch matchFlags-          fUpto = isJust mpsm-          fPending = parseFlags O.pending opts-      -- this covers all 4 possibilities-      case (fUpto,fPending) of-        (True, False) -> slurpUpto (fromJust mpsm) r-        (True, True)  -> fail "can't mix match and pending flags"-        (False,False) -> expand =<< readRecorded r-        (False,True)  -> expand =<< readRecordedAndPending r -- pending is default+      case (patchSetMatch matchFlags, parseFlags O.pending opts) of+        (Nothing, False)  -> expand =<< readPristine r+        (Nothing, True)   -> expand =<< readPristineAndPending r+        (Just psm, False) -> getPristineUpToMatch r psm+        (Just _, True)    -> fail "can't mix match and pending flags"   where     matchFlags = parseFlags O.matchUpToOne opts @@ -137,11 +125,3 @@         filesDirs False True t = anchoredRoot : [p | (p, SubTree _) <- list t]         filesDirs True False t = [p | (p, File _) <- list t]         filesDirs True True t = anchoredRoot : map fst (list t)--slurpUpto :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-          => PatchSetMatch -> Repository rt p wR wU wR -> IO (Tree IO)-slurpUpto psm r = withDelayedDir "show.files" $ \_ -> do-  getRecordedUpToMatch r psm-  -- note: it is important that we expand the tree from inside the-  -- withDelayedDir action, else it has no effect.-  expand =<< readPlainTree "."
src/Darcs/UI/Commands/ShowIndex.hs view
@@ -20,6 +20,7 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Darcs.UI.Commands.ShowIndex     ( showIndex     , showPristine@@ -27,26 +28,28 @@  import Darcs.Prelude -import Control.Monad ( (>=>) ) import Darcs.UI.Flags ( DarcsFlag, useCache ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.UI.Completion ( noArgs )-import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( (^), oid, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository ( withRepository, RepoJob(..), readIndex )-import Darcs.Repository.State ( readRecorded )+import Darcs.Repository ( withRepository, RepoJob(..) )+import Darcs.Repository.State ( readPristine )+import Darcs.Repository.Paths ( indexPath ) -import Darcs.Util.Hash( encodeBase16, Hash( NoHash ) )+import Darcs.Util.Hash ( showHash ) import Darcs.Util.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )-import Darcs.Util.Index( treeFromIndex, listFileIDs )-import Darcs.Util.Path( anchorPath, AbsolutePath, floatPath )-import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Index( IndexEntry(..), dumpIndex )+import Darcs.Util.Path( anchorPath, AbsolutePath, anchoredRoot, realPath )+import Darcs.Util.Printer ( Doc, putDocLn, text, vcat )  import System.Posix.Types ( FileID ) -import qualified Data.ByteString.Char8 as BC+import Control.Monad ( (>=>) )+import Data.Int ( Int64 )+import qualified Data.Map as M ( Map, lookup ) import Data.Maybe ( fromJust )-import qualified Data.Map as M ( Map, lookup, fromList )+import Text.Printf ( printf )  showIndexHelp :: Doc showIndexHelp = text $@@ -67,10 +70,7 @@     , commandPrereq = amInRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc showIndexBasicOpts-    , commandDefaults = defaultFlags showIndexOpts-    , commandCheckOptions = ocheck showIndexOpts+    , commandOptions = showIndexOpts     }   where     showIndexBasicOpts = O.nullFlag ^ O.repoDir@@ -81,9 +81,7 @@   let line | O.nullFlag ? opts = \t -> putStr t >> putChar '\0'            | otherwise = putStrLn       output (p, i) = do-        let hash = case itemHash i of-                     NoHash -> "(no hash available)"-                     h -> BC.unpack $ encodeBase16 h+        let hash = showHash (itemHash i)             path = anchorPath "" p             isdir = case i of                       SubTree _ -> "/"@@ -93,18 +91,25 @@                        Just fileids' -> " " ++ (show $ fromJust $ M.lookup path fileids')         line $ hash ++ fileid ++ " " ++ path ++ isdir   x <- expand tree-  mapM_ output $ (floatPath ".", SubTree x) : list x+  mapM_ output $ (anchoredRoot, SubTree x) : list x  showIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-showIndexCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ \repo ->-  do index <- readIndex repo-     index_tree <- treeFromIndex index-     fileids <- (M.fromList . map (\((a,_),b) -> (anchorPath "" a,b))) <$> listFileIDs index-     dump opts (Just fileids) index_tree+showIndexCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ \_repo -> do+  entries <- dumpIndex indexPath+  putDocLn $ vcat $ header : map formatEntry entries+  where+    header =+      text $ printf "%-64s %1s %12s %20s %12s %s" "HASH" "T" "SIZE" "AUX" "FILEID" "PATH"+    formatEntry IndexEntry{..} =+      let fileid :: Int64+          fileid = fromIntegral ieFileID+          hash = showHash ieHash+      in text $ printf "%64s %c %12d %20d %12d %s"+          hash ieType ieSize ieAux fileid (realPath iePath)  showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showPristineCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $-  readRecorded >=> dump opts Nothing+  readPristine >=> dump opts Nothing  showPristineHelp :: Doc showPristineHelp = text $
src/Darcs/UI/Commands/ShowPatchIndex.hs view
@@ -7,7 +7,7 @@ import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, useCache, verbose ) import Darcs.UI.Options-    ( (^), oid, odesc, ocheck, defaultFlags, (?) )+    ( (^), oid, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) import Darcs.Repository ( withRepository, RepoJob(..), repoLocation )@@ -32,10 +32,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc showPatchIndexBasicOpts-    , commandDefaults = defaultFlags showPatchIndexOpts-    , commandCheckOptions = ocheck showPatchIndexOpts+    , commandOptions = showPatchIndexOpts     }   where     showPatchIndexBasicOpts = O.nullFlag ^ O.repoDir
src/Darcs/UI/Commands/ShowRepo.hs view
@@ -24,8 +24,8 @@ import Control.Monad ( when, unless, liftM ) import Text.Html ( tag, stringToHtml ) import Darcs.Util.Path ( AbsolutePath )-import Darcs.UI.Flags ( DarcsFlag, useCache, hasXmlOutput, verbose, enumeratePatches )-import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Flags ( DarcsFlag, useCache, hasXmlOutput, enumeratePatches )+import Darcs.UI.Options ( (^), oid, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.UI.Completion ( noArgs )@@ -37,11 +37,15 @@     , repoCache     , withRepository     , RepoJob(..)-    , readRepo )+    , readPatches ) import Darcs.Repository.Hashed( repoXor ) import Darcs.Repository.PatchIndex ( isPatchIndexDisabled, doesPatchIndexExist )-import Darcs.Repository.Prefs ( getPreflist, getMotd )-import Darcs.Patch ( IsRepoType, RepoPatch )+import Darcs.Repository.Prefs+    ( Pref(Author, Defaultrepo, Prefs)+    , getMotd+    , getPreflist+    )+import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Set ( patchSet2RL ) import Darcs.Patch.Witnesses.Ordered ( lengthRL ) import qualified Data.ByteString.Char8 as BC  (unpack)@@ -83,10 +87,7 @@     , commandPrereq = amInRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc showRepoBasicOpts-    , commandDefaults = defaultFlags showRepoOpts-    , commandCheckOptions = ocheck showRepoOpts+    , commandOptions = showRepoOpts     }   where     showRepoBasicOpts = O.repoDir ^ O.xmlOutput ^ O.enumPatches@@ -129,11 +130,10 @@ -- output a labelled text string or an XML tag and contained value.  actuallyShowRepo-  :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-  => PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO ()+  :: (RepoPatch p, ApplyState p ~ Tree)+  => PutInfo -> Repository rt p wU wR -> [DarcsFlag] -> IO () actuallyShowRepo out r opts = do   when (hasXmlOutput opts) (putStr "<repository>\n")-  when (verbose opts) (out "Show" $ show r)   out "Format" $ showInOneLine $ repoFormat r   let loc = repoLocation r   out "Root" loc@@ -152,8 +152,8 @@   showRepoMOTD out r   when (hasXmlOutput opts) (putStr "</repository>\n") -showXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-        => PutInfo -> Repository rt p wR wU wR -> IO ()+showXor :: (RepoPatch p, ApplyState p ~ Tree)+        => PutInfo -> Repository rt p wU wR -> IO () showXor out repo = do   theXor <- repoXor repo   out "Weak Hash" (show theXor)@@ -168,15 +168,15 @@  showRepoPrefs :: PutInfo -> IO () showRepoPrefs out = do-    getPreflist "prefs" >>= mapM_ prefOut-    getPreflist "author" >>= out "Author" . unlines-    getPreflist "defaultrepo" >>= out "Default Remote" . unlines+    getPreflist Prefs >>= mapM_ prefOut+    getPreflist Author >>= out "Author" . unlines+    getPreflist Defaultrepo >>= out "Default Remote" . unlines   where prefOut = uncurry out . (\(p,v) -> (p++" Pref", dropWhile isSpace v)) . break isSpace -showRepoMOTD :: PutInfo -> Repository rt p wR wU wR -> IO ()+showRepoMOTD :: PutInfo -> Repository rt p wU wR -> IO () showRepoMOTD out repo = getMotd (repoLocation repo) >>= out "MOTD" . BC.unpack  -- Support routines to provide information used by the PutInfo operations above. -numPatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO Int-numPatches r = (lengthRL . patchSet2RL) `liftM` readRepo r+numPatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wU wR -> IO Int+numPatches r = (lengthRL . patchSet2RL) `liftM` readPatches r
src/Darcs/UI/Commands/ShowTags.hs view
@@ -26,11 +26,11 @@ import System.IO ( stderr, hPutStrLn )  import Darcs.Patch.Set ( PatchSet, patchSetTags )-import Darcs.Repository ( readRepo, withRepositoryLocation, RepoJob(..) )+import Darcs.Repository ( readPatches, withRepositoryLocation, RepoJob(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, useCache, getRepourl )-import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( oid, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Printer ( Doc, formatText )@@ -59,10 +59,7 @@     , commandPrereq = findRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc showTagsBasicOpts-    , commandDefaults = defaultFlags showTagsOpts-    , commandCheckOptions = ocheck showTagsOpts+    , commandOptions = showTagsOpts     }   where     showTagsBasicOpts = O.possiblyRemoteRepo@@ -71,9 +68,9 @@ tagsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () tagsCmd _ opts _ = let repodir = fromMaybe "." (getRepourl opts) in     withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo ->-        readRepo repo >>= printTags+        readPatches repo >>= printTags   where-    printTags :: PatchSet rt p wW wZ -> IO ()+    printTags :: PatchSet p wW wZ -> IO ()     printTags = mapM_ process . patchSetTags     process :: String -> IO ()     process t = normalize t t False >>= putStrLn
src/Darcs/UI/Commands/Tag.hs view
@@ -22,78 +22,104 @@ import Control.Monad ( when ) import System.IO ( hPutStr, stderr ) +import Darcs.Patch ( RepoPatch ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Info ( patchinfo ) import Darcs.Patch.Depends ( getUncovered )-import Darcs.Patch-    ( PrimPatch, PrimOf-    , RepoPatch-    )+import Darcs.Patch.Info ( patchinfo )+import Darcs.Patch.Named ( adddeps, infopatch ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )-import Darcs.Patch.Named ( infopatch, adddeps )-import Darcs.Patch.Set-    ( emptyPatchSet, appendPSFL, patchSet2FL, patchSetTags )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) )+import Darcs.Patch.Set ( appendPSFL, emptyPatchSet, patchSet2FL, patchSetTags )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )  import Darcs.Repository-    ( withRepoLock, Repository, RepoJob(..), readRepo-    , tentativelyAddPatch, finalizeRepositoryChanges,+    ( AccessType(..)+    , RepoJob(..)+    , Repository+    , finalizeRepositoryChanges+    , readPatches+    , tentativelyAddPatch+    , withRepoLock     )-import Darcs.Repository.Flags ( UpdatePending(..), DryRun(NoDryRun) )+import Darcs.Repository.Flags ( UpdatePending(..) )  import Darcs.UI.Commands-    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putFinished )+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , putFinished+    , withStdOpts+    ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags-    ( DarcsFlag, getDate, compress, verbosity, useCache, umask, getAuthor, author )-import Darcs.UI.Options-    ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+    ( DarcsFlag+    , author+    , getAuthor+    , getDate+    , umask+    , useCache+    , verbosity+    )+import Darcs.UI.Options ( (?), (^) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( getLog ) import Darcs.UI.SelectChanges-    ( WhichChanges(..)-    , selectionConfig+    ( SelectionConfig(allowSkipAll)+    , WhichChanges(..)     , runSelection-    , SelectionConfig(allowSkipAll)+    , selectionConfig     ) import qualified Darcs.UI.SelectChanges as S  import Darcs.Util.Path ( AbsolutePath )-import Darcs.Util.Printer ( Doc, text )-import Darcs.Util.Tree( Tree )+import Darcs.Util.Printer ( Doc, formatWords, vsep )+import Darcs.Util.Tree ( Tree )   tagDescription :: String tagDescription = "Name the current repository state for future reference."  tagHelp :: Doc-tagHelp = text $- "The `darcs tag` command names the current repository state, so that it\n" ++- "can easily be referred to later.  Every *important* state should be\n" ++- "tagged; in particular it is good practice to tag each stable release\n" ++- "with a number or codename.  Advice on release numbering can be found\n" ++- "at <http://producingoss.com/en/development-cycle.html>.\n" ++- "\n" ++- "To reproduce the state of a repository `R` as at tag `t`, use the\n" ++- "command `darcs clone --tag t R`.  The command `darcs show tags` lists\n" ++- "all tags in the current repository.\n" ++- "\n" ++- "Tagging also provides significant performance benefits: when Darcs\n" ++- "reaches a shared tag that depends on all antecedent patches, it can\n" ++- "simply stop processing.\n" ++- "\n" ++- "Like normal patches, a tag has a name, an author, a timestamp and an\n" ++- "optional long description, but it does not change the working tree.\n" ++- "A tag can have any name, but it is generally best to pick a naming\n" ++- "scheme and stick to it.\n" ++- "\n" ++- "By default a tag names the entire repository state at the time the tag\n" ++- "is created. If the --ask-deps option is used, the patches to include\n" ++- "as part of the tag can be explicitly selected.\n" ++- "\n" ++- "The `darcs tag` command accepts the `--pipe` option, which behaves as\n" ++- "described in `darcs record`.\n"+tagHelp =+  vsep $ map formatWords+  [ [ "The `darcs tag` command names the current repository state, so that it"+    , "can easily be referred to later. It does so by recording a special kind"+    , "of patch that makes no changes and which explicitly depends on all"+    , "patches currently existing in the repository (except for those which"+    , "are depended upon by other tags already in the repository). In the"+    , "common case of a sequential series of tags, this means that the tag"+    , "depends on all patches since the last tag, plus that tag itself."+    ]+  , [ "Every *important* state should be"+    , "tagged; in particular it is good practice to tag each stable release"+    , "with a number or codename.  Advice on release numbering can be found"+    , "at <http://producingoss.com/en/development-cycle.html>."+    ]+  , [ "To reproduce the state of a repository `R` as at tag `t`, use the"+    , "command `darcs clone --tag t R`. Note however that tags are matched"+    , "as regular expressions, like with `--patch`. To make sure you get the"+    , "right tag it may be better to use `darcs clone --tag '^t$'`."+    , "The command `darcs show tags` lists all tags in the current repository."+    ]+  , [ "Tagging also provides significant performance benefits: when Darcs"+    , "reaches a tag that depends on all preceding patches, it can often"+    , "stop processing. A tag in such a position is called \"clean\". For"+    , "instance, operations like push and pull need to examine only patches"+    , "that come after the latest shared clean tag."+    ]+  , [ "Like normal patches, a tag has a name, an author, a timestamp and an"+    , "optional long description, but it does not change the working tree."+    , "A tag can have any name, but it is generally best to pick a naming"+    , "scheme and stick to it."+    ]+  , [ "By default a tag names the entire repository state at the time the tag"+    , "is created. If the --ask-deps option is used, the patches to include"+    , "as part of the tag can be explicitly selected."+    ]+  , [ "The `darcs tag` command accepts the `--pipe` option, which behaves as"+    , "described in `darcs record`."+    ]+  ]  tag :: DarcsCommand tag = DarcsCommand@@ -107,10 +133,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc tagAdvancedOpts-    , commandBasicOptions = odesc tagBasicOpts-    , commandDefaults = defaultFlags tagOpts-    , commandCheckOptions = ocheck tagOpts+    , commandOptions = tagOpts     }   where     tagBasicOpts@@ -120,63 +143,53 @@       ^ O.askLongComment       ^ O.askDeps       ^ O.repoDir-    tagAdvancedOpts = O.compress ^ O.umask+    tagAdvancedOpts = O.umask     tagOpts = tagBasicOpts `withStdOpts` tagAdvancedOpts  tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () tagCmd _ opts args =-  withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do-    date <- getDate (hasPipe opts)-    the_author <- getAuthor (author ? opts) (hasPipe opts)-    patches <- readRepo repository+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \(repository :: Repository 'RW p wU wR) -> do+    date <- getDate hasPipe+    the_author <- getAuthor (author ? opts) hasPipe+    patches <- readPatches repository     tags <- return $ patchSetTags patches     Sealed chosenPatches <-         if O.askDeps ? opts             then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (patchSet2FL patches)             else return $ Sealed patches     let deps = getUncovered chosenPatches-    (name, long_comment)  <- get_name_log (NilFL :: FL (PrimOf p) wA wA) args tags+    (name, long_comment)  <- get_name_log tags     myinfo <- patchinfo date name the_author long_comment     let mypatch = infopatch myinfo NilFL-    _ <- tentativelyAddPatch repository (compress ? opts) (verbosity ? opts) YesUpdatePending+    _ <- tentativelyAddPatch repository YesUpdatePending              $ n2pia $ adddeps mypatch deps-    _ <- finalizeRepositoryChanges repository YesUpdatePending (compress ? opts)+    _ <- finalizeRepositoryChanges repository (O.dryRun ? opts)     putFinished opts $ "tagging '"++name++"'"-  where  get_name_log ::(PrimPatch prim) => FL prim wA wA -> [String] -> [String] -> IO (String, [String])-         get_name_log nilFL a tags-                          = do (name, comment, _) <- getLog-                                  (case parseFlags O.patchname opts of-                                    Nothing -> Just (unwords a)-                                    Just s -> Just s)-                                  (hasPipe opts)-                                  (parseFlags O.logfile opts)-                                  (parseFlags O.askLongComment opts)-                                  Nothing nilFL-                               when (length name < 2) $ hPutStr stderr $-                                 "Do you really want to tag '"-                                 ++name++"'? If not type: darcs obliterate --last=1\n"-                               when (name `elem` tags) $-                                  putStrLn $ "WARNING: The tag "  ++ -                                             "\"" ++ name ++ "\"" ++-                                             " already exists."-                               return ("TAG " ++ name, comment)---- This may be useful for developers, but users don't care about--- internals:------ A tagged version automatically depends on all patches in the--- repository.  This allows you to later reproduce precisely that--- version.  The tag does this by depending on all patches in the--- repository, except for those which are depended upon by other tags--- already in the repository.  In the common case of a sequential--- series of tags, this means that the tag depends on all patches--- since the last tag, plus that tag itself.+  where+    get_name_log :: [String] -> IO (String, [String])+    get_name_log tags = do+      (name, comment, _) <-+        getLog+          (case O.patchname ? opts of+             Nothing+                | null args -> Nothing+                | otherwise -> Just (unwords args)+             Just s -> Just s)+          hasPipe (O.logfile ? opts) (O.askLongComment ? opts) Nothing mempty+      when (length name < 2) $+        hPutStr stderr $+        "Do you really want to tag '" +++        name ++ "'? If not type: darcs obliterate --last=1\n"+      when (name `elem` tags) $+        putStrLn $ "WARNING: The tag " ++ "\"" ++ name ++ "\"" ++ " already exists."+      return ("TAG " ++ name, comment)+    hasPipe = O.pipe ? opts  askAboutTagDepends-     :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree)+     :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree)      => [DarcsFlag]-     -> FL (PatchInfoAnd rt p) wX wY-     -> IO (Sealed (FL (PatchInfoAnd rt p) wX))+     -> FL (PatchInfoAnd p) wX wY+     -> IO (Sealed (FL (PatchInfoAnd p) wX)) askAboutTagDepends flags ps = do   let opts = S.PatchSelectionOptions              { S.verbosity = verbosity ? flags@@ -184,12 +197,8 @@              , S.interactive = True              , S.selectDeps = O.PromptDeps              , S.withSummary = O.NoSummary-             , S.withContext = O.NoContext              }   (deps:>_) <- runSelection ps $                      ((selectionConfig FirstReversed "depend on" opts Nothing Nothing)                           { allowSkipAll = False })   return $ Sealed deps--hasPipe :: [DarcsFlag] -> Bool-hasPipe = parseFlags O.pipe
src/Darcs/UI/Commands/Test.hs view
@@ -15,6 +15,8 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. +{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Test     (       test@@ -22,59 +24,47 @@  import Darcs.Prelude hiding ( init ) -import Control.Exception ( catch, IOException ) import Control.Monad( when )  import System.Process ( system ) import System.Exit ( ExitCode(..), exitWith )-import System.IO ( hFlush, stdout ) +import Darcs.Patch ( description )+import Darcs.Patch.PatchInfoAnd ( hopefully )+import Darcs.Patch.Set ( patchSet2RL )+import Darcs.Patch.Witnesses.Ordered ( mapFL, mapRL_RL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )+import Darcs.Repository+    ( RepoJob(..)+    , createPristineDirectoryTree+    , readPatches+    , setAllScriptsExecutable+    , withRepository+    )+import Darcs.Repository.Prefs ( getPrefval ) import Darcs.UI.Commands-    ( DarcsCommand(..), withStdOpts+    ( DarcsCommand(..)+    , amInHashedRepository     , nodefaults     , putInfo-    , amInHashedRepository )+    , withStdOpts+    )+import Darcs.UI.Commands.Test.Impl+    ( StrategyResultRaw(..)+    , PatchSeq(..)+    , exitCodeToTestResult+    , explanatoryTextFor+    , mkTestCmd+    , runTestable+    , patchTreeToFL+    ) import Darcs.UI.Completion ( noArgs )-import Darcs.UI.Flags ( DarcsFlag, useCache, verbosity )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Flags ( DarcsFlag, useCache )+import Darcs.UI.Options ( (^), (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Repository (-                          readRepo-                        , withRepository-                        , RepoJob(..)-                        , withRecorded-                        , setScriptsExecutablePatches-                        , setScriptsExecutable-                        )-import Darcs.Patch.Witnesses.Ordered-    ( RL(..)-    , (:>)(..)-    , (+<+)-    , reverseRL-    , splitAtRL-    , lengthRL-    , mapRL-    , mapFL-    , mapRL_RL-    )-import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )-import Darcs.Patch.ApplyMonad ( ApplyMonad )-import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Patch ( RepoPatch-                   , description-                   )-import Darcs.Patch.Named ( Named )-import Darcs.Patch.Set ( patchSet2RL )+import Darcs.Util.Lock ( withPermDir, withTempDir )+import Darcs.Util.Path ( AbsolutePath, toFilePath ) import Darcs.Util.Printer ( Doc, putDocLn, text )-import Darcs.Util.Path ( AbsolutePath )-import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault )-import Darcs.Repository.Test ( getTest )-import Darcs.Util.Lock-    ( withTempDir-    , withPermDir-    )   testDescription :: String@@ -110,6 +100,25 @@   ,"away from head, the test result changes only once from \"fail\" to"   ,"\"ok\".)  If failure is not monotonous, any one of the patches that"   ,"break the test is found at random."+  ,""+  ,"If the test command returns an exit code of 125, the repository"+  ,"state is treated as \"untestable\" - for example you might get it to"+  ,"do this for a build break or other result that isn't the actual"+  ,"problem you want to track down. This can lead to multiple patches"+  ,"being reported as the source of the failure."+  ,""+  ,"For example, if patch 1 introduces a build break, patch 2 breaks a"+  ,"test in an unrelated bit of the code, and patch 3 fixes the build"+  ,"break, then patches 1,2 and 3 would be identified as causing the"+  ,"failure."+  ,""+  ,"The `--shrink-failures` option, on by default, adds a post-processing"+  ,"step to reorder patches to try to narrow down a failure more"+  ,"precisely. In the example above, it's likely that patch 2 could be"+  ,"moved before patch 1 or after patch 3, allowing it to be identified"+  ,"as the sole cause of the failure."+  ,""+  ,"This shrinking can be disabled with `--no-shrink-failures`."  ]  test :: DarcsCommand@@ -124,241 +133,72 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc testAdvancedOpts-    , commandBasicOptions = odesc testBasicOpts-    , commandDefaults = defaultFlags testOpts-    , commandCheckOptions = ocheck testOpts+    , commandOptions = testOpts     }   where     testBasicOpts = O.testStrategy ^ O.leaveTestDir ^ O.repoDir-    testAdvancedOpts = O.setScriptsExecutable+    testAdvancedOpts = O.setScriptsExecutable ^ O.shrinkFailure     testOpts = testBasicOpts `withStdOpts` testAdvancedOpts -data TestResult = Success | Failure Int--data SearchTypeResult = AssumedMonotony | WasLinear--data StrategyResult p =-    StrategySuccess -- the initial run of the test passed-  | NoPasses-  | PassesOnHead-  | Blame SearchTypeResult (Sealed2 (Named p))-  -- these two are just for oneTest-  | RunSuccess-  | RunFailed Int---- | Functions defining a strategy for executing a test-type Strategy = forall p wX wY-               . (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)-              => [DarcsFlag]-              -> IO TestResult  -- ^ test command-              -> TestResult-              -> RL (Named p) wX wY-              -> IO (StrategyResult p)- testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () testCommand _ opts args =  withRepository (useCache ? opts) $ RepoJob $ \repository -> do-  patches <- readRepo repository-  (init,testCmd) <- case args of+  patches <- readPatches repository+  (init :: IO ExitCode,testCmd) <- case args of     [] ->-      do t <- getTest (verbosity ? opts)-         return (return ExitSuccess, exitCodeToTestResult <$> t)+      do t <- getTest+         return (return ExitSuccess, mkTestCmd (exitCodeToTestResult <$> t))     [cmd] ->       do putStrLn $ "Using test command:\n"++cmd-         return (return ExitSuccess, exitCodeToTestResult <$> system cmd)+         return (return ExitSuccess, mkTestCmd (exitCodeToTestResult <$> system cmd))     [init,cmd] ->       do putStrLn $ "Using initialization command:\n"++init          putStrLn $ "Using test command:\n"++cmd-         return (system init, exitCodeToTestResult <$> system cmd)+         return (system init, mkTestCmd (exitCodeToTestResult <$> system cmd))     _ -> fail "Test expects zero to two arguments."   let wd = case O.leaveTestDir ? opts of             O.YesLeaveTestDir -> withPermDir             O.NoLeaveTestDir -> withTempDir-  withRecorded repository (wd "testing") $ \_ -> do-    when (O.yes (O.setScriptsExecutable ? opts)) setScriptsExecutable+  wd "testing" $ \d -> do+    createPristineDirectoryTree repository (toFilePath d) O.WithWorkingDir+    when (O.yes (O.setScriptsExecutable ? opts)) setAllScriptsExecutable     _ <- init-    putInfo opts $ text "Running test...\n"-    testResult <- testCmd-    let track = chooseStrategy (O.testStrategy ? opts)-    result <- track opts testCmd testResult (mapRL_RL hopefully . patchSet2RL $ patches)+    putInfo opts "Running test...\n"+    result <-+      runTestable+        (O.setScriptsExecutable ? opts)+        testCmd+        (O.testStrategy ? opts)+        (O.shrinkFailure ? opts)+        (mapRL_RL hopefully . patchSet2RL $ patches)     case result of-      StrategySuccess -> putStrLn "Success!"       NoPasses -> putStrLn "Noone passed the test!"-      PassesOnHead -> putStrLn "Test does not fail on head."-      Blame searchTypeResult (Sealed2 p) -> do-        let extraText =-              case searchTypeResult of-                AssumedMonotony -> " (assuming monotony in the given range)"-                WasLinear -> ""-        putStrLn ("Last recent patch that fails the test" ++ extraText ++ ":")-        putDocLn (description p)-      RunSuccess -> putInfo opts $ text "Test ran successfully.\n"+      NoFailureOnHead -> putStrLn "Test does not fail on head."+      Blame (Sealed2 ps) -> do+        let extraText = explanatoryTextFor (O.testStrategy ? opts)+        case ps of+          Single p -> do+            putStrLn ("Last recent patch that fails the test" ++ extraText ++ ":")+            putDocLn (description p)+          _ -> do+            putStrLn "These patches jointly trigger the failure:"+            sequence_ $ mapFL (putDocLn . description) (patchTreeToFL ps)+      RunSuccess -> putInfo opts "Test ran successfully.\n"       RunFailed n -> do-        putInfo opts $ text "Test failed!\n"+        putInfo opts "Test failed!\n"         exitWith (ExitFailure n) -exitCodeToTestResult :: ExitCode -> TestResult-exitCodeToTestResult ExitSuccess = Success-exitCodeToTestResult (ExitFailure n) = Failure n--chooseStrategy :: O.TestStrategy -> Strategy-chooseStrategy O.Bisect = trackBisect-chooseStrategy O.Linear = trackLinear-chooseStrategy O.Backoff = trackBackoff-chooseStrategy O.Once = oneTest---- | test only the last recorded state-oneTest :: Strategy-oneTest _ _ Success _ = return RunSuccess-oneTest _ _ (Failure n)  _ = return $ RunFailed n---- | linear search (with --linear)-trackLinear :: Strategy-trackLinear _ _ Success _ = return StrategySuccess-trackLinear _ _ (Failure _) NilRL = return NoPasses-trackLinear opts testCmd (Failure _) ps = trackNextLinear opts testCmd ps--trackNextLinear-    :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)-    => [DarcsFlag]-    -> IO TestResult-    -> RL (Named p) wX wY-    -> IO (StrategyResult p)-trackNextLinear _ _ NilRL = return NoPasses-trackNextLinear opts testCmd (ps:<:p) = do-    safeUnapply p-    when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches p-    putStrLn "Trying without the patch:"-    putDocLn $ description p-    hFlush stdout-    testResult <- testCmd-    case testResult of-        Success -> return $ Blame WasLinear $ Sealed2 p-        Failure _ -> trackNextLinear opts testCmd ps---- | exponential backoff search (with --backoff)-trackBackoff :: Strategy-trackBackoff _ _ Success NilRL = return StrategySuccess-trackBackoff _ _ (Failure _) NilRL = return NoPasses-trackBackoff _ _ Success _ = return PassesOnHead-trackBackoff opts testCmd (Failure _) ps =-    trackNextBackoff opts testCmd 4 ps--trackNextBackoff :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)-                 => [DarcsFlag]-                 -> IO TestResult-                 -> Int -- ^ number of patches to skip-                 -> RL (Named p) wY wZ -- ^ patches not yet skipped-                 -> IO (StrategyResult p)-trackNextBackoff _ _ _ NilRL = return NoPasses-trackNextBackoff opts testCmd n ahead-    | n >= lengthRL ahead = initialBisect opts testCmd ahead-trackNextBackoff opts testCmd n ahead = do-    putStrLn $ "Skipping " ++ show n ++ " patches..."-    hFlush stdout-    case splitAtRL n ahead of-        ( ahead' :> skipped' ) -> do-            unapplyRL skipped'-            when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches skipped'-            testResult <- testCmd-            case testResult of-                Failure _ ->-                    trackNextBackoff opts testCmd (2*n) ahead'-                Success -> do-                    applyRL skipped'  -- offending patch is one of these-                    initialBisect opts testCmd skipped' -- bisect to find it---- | binary search (with --bisect)-trackBisect :: Strategy-trackBisect _ _ Success NilRL = return StrategySuccess-trackBisect _ _ (Failure _) NilRL = return NoPasses-trackBisect _ _ Success _ = return PassesOnHead-trackBisect opts testCmd (Failure _) ps =-    initialBisect opts testCmd ps--initialBisect ::  (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)-              => [DarcsFlag]-              -> IO TestResult-              -> RL (Named p) wX wY-              -> IO (StrategyResult p)-initialBisect opts testCmd ps =-    trackNextBisect opts currProg testCmd BisectRight (patchTreeFromRL ps)-  where-    maxProg  = 1 + round ((logBase 2 $ fromIntegral $ lengthRL ps) :: Double)-    currProg = (1, maxProg) :: BisectProgress---- | Bisect Patch Tree-data PatchTree p wX wY where-    Leaf :: p wX wY -> PatchTree p wX wY-    Fork :: PatchTree p wY wZ -> PatchTree p wX wY -> PatchTree p wX wZ---- | Direction of Bisect trackdown-data BisectDir = BisectLeft | BisectRight deriving Show---- | Progress of Bisect-type BisectProgress = (Int, Int)---- | Create Bisect PatchTree from the RL-patchTreeFromRL :: RL p wX wY -> PatchTree p wX wY-patchTreeFromRL (NilRL :<: l) = Leaf l-patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of-                       (r :> l) -> Fork (patchTreeFromRL l) (patchTreeFromRL r)---- | Convert PatchTree back to RL-patchTree2RL :: PatchTree p wX wY -> RL p wX wY-patchTree2RL (Leaf p)   = NilRL :<: p-patchTree2RL (Fork l r) = patchTree2RL r +<+ patchTree2RL l---- | Iterate the Patch Tree-trackNextBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)-                => [DarcsFlag]-                -> BisectProgress-                -> IO TestResult -- ^ test command-                -> BisectDir-                -> PatchTree (Named p) wX wY-                -> IO (StrategyResult p)-trackNextBisect opts (dnow, dtotal) testCmd dir (Fork l r) = do-  putStr $ "Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences...\n"-  hFlush stdout-  case dir of-    BisectRight -> jumpHalfOnRight opts l  -- move in temporary repo-    BisectLeft  -> jumpHalfOnLeft  opts r  -- within given direction-  testResult <- testCmd -- execute test on repo-  case testResult of-    Success -> trackNextBisect opts (dnow+1, dtotal) testCmd-                               BisectLeft l  -- continue left  (to the present)-    _       -> trackNextBisect opts (dnow+1, dtotal) testCmd-                               BisectRight r -- continue right (to the past)-trackNextBisect _ _ _ _ (Leaf p) = return (Blame AssumedMonotony (Sealed2 p))--jumpHalfOnRight :: (Apply p, PatchInspect p,-                    ApplyMonad (ApplyState p) DefaultIO)-                => [DarcsFlag] -> PatchTree p wX wY -> IO ()-jumpHalfOnRight opts l = do unapplyRL ps-                            when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches ps-  where ps = patchTree2RL l--jumpHalfOnLeft :: (Apply p, PatchInspect p,-                   ApplyMonad (ApplyState p) DefaultIO)-               => [DarcsFlag] -> PatchTree p wX wY -> IO ()-jumpHalfOnLeft opts r = do applyRL p-                           when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches p--  where p = patchTree2RL r--applyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)-        => RL p wX wY -> IO ()-applyRL   patches = sequence_ (mapFL safeApply (reverseRL patches))--unapplyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)-           => RL p wX wY -> IO ()-unapplyRL patches = sequence_ (mapRL safeUnapply patches)--safeApply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)-          => p wX wY -> IO ()-safeApply p = runDefault (apply p) `catch` \(msg :: IOException) -> fail $ "Bad patch:\n" ++ show msg--safeUnapply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)-            => p wX wY -> IO ()-safeUnapply p = runDefault (unapply p) `catch` \(msg :: IOException) -> fail $ "Bad patch:\n" ++ show msg+ where+    getTest :: IO (IO ExitCode)+    getTest = do+      testline <- getPrefval "test"+      return $+        case testline of+          Nothing -> return ExitSuccess+          Just testcode -> do+            putInfo opts "Running test...\n"+            ec <- system testcode+            if ec == ExitSuccess+              then putInfo opts "Test ran successfully.\n"+              else putInfo opts "Test failed!\n"+            return ec
+ src/Darcs/UI/Commands/Test/Impl.hs view
@@ -0,0 +1,763 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Darcs.UI.Commands.Test.Impl+    ( TestRunner(..), runStrategy+    , TestResult(..), TestResultValid(..), TestFailure(..)+    , TestingDone+    , PatchSeq(..), patchTreeToFL+    , StrategyResult, StrategyResultRaw(..)+    , explanatoryTextFor+    , runTestingEnv+    , exitCodeToTestResult+    , mkTestCmd+    , runTestable+    ) where++import Darcs.Prelude hiding ( init, Monad(..) )+import Darcs.Util.IndexedMonad++import qualified Control.Monad as Base ( Monad(..) )++import Data.Constraint ( Dict(..) )+import Data.String ( fromString )++import GHC.Exts ( Constraint )+import GHC.Show ( showSpace )++import System.Exit ( ExitCode(..) )+import System.IO ( hFlush, stdout )++import qualified Darcs.UI.Options.All as O+import Darcs.Repository ( setScriptsExecutablePatches )+import Darcs.Patch.Witnesses.Ordered+    ( RL(..)+    , FL(..)+    , (:>)(..)+    , splitAtRL+    , reverseRL+    , lengthRL+    , mapRL_RL+    , lengthFL+    , reverseFL+    , (+>+)+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )+import Darcs.Patch.Witnesses.Show+  ( Show1(..), Show2(..)+  , showsPrec2+  )+import Darcs.Patch.ApplyMonad ( ApplyMonad )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute, commute )+import Darcs.Patch.CommuteFn ( commuterIdFL )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch ( description )+import Darcs.Patch.Show ( ShowPatch )+import Darcs.Util.Printer ( putDocLn )+import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault )++-- |This type is used to track the state of the testing tree.+-- For example, 'Testing IO wX wY Int' requires that the testing+-- tree start in state 'wX', and leaves it in state 'wY'.+newtype Testing m (wX :: *) (wY :: *) a = Testing { unTesting :: m a }++-- |Once we've finished tracking down a test failure, we no longer care+-- about tracking the actual state of the testing tree. This witness+-- constant is never used in any patch, so once we use it for the state+-- of the testing tree, in practice we can no longer do anything more with+-- that tree.+--+-- We could also use some kind of existential or different monad type+-- to represent this, but it would make composing code with 'do' harder.+data TestingDone++type TestingIO = Testing IO++instance Base.Monad m => Monad (Testing m) where+  return v = Testing (Base.return v)+  Testing m >>= f = Testing (m Base.>>= unTesting . f)+  Testing m1 >> Testing m2 = Testing (m1 Base.>> m2)++instance LiftIx Testing where+  liftIx = Testing++data TestingParams =+  TestingParams+  { tpSetScriptsExecutable :: O.SetScriptsExecutable+  , tpTestCmd :: TestCmd+  }++-- |The 'Testing' monad, augmented with configuration parameters+newtype TestingEnv m wX wY a =+  TestingEnv { unTestingEnv :: ReaderT TestingParams (Testing m) wX wY a }++type TestingEnvIO = TestingEnv IO++deriving instance Base.Monad m => Monad (TestingEnv m)+deriving instance Base.Monad m => MonadReader TestingParams (TestingEnv m)++instance LiftIx TestingEnv where+  liftIx m = TestingEnv (ReaderT (\_ -> liftIx m))++runTestingEnv :: TestingParams -> TestingEnv m wA TestingDone a -> m a+runTestingEnv args = unTesting . ($ args) . runReaderT . unTestingEnv++liftTesting :: Testing m wX wY a -> TestingEnv m wX wY a+liftTesting m = TestingEnv $ ReaderT $ \_ -> m++-- |An indexed monad that can be used to run tests. 'TestingEnvIO' is+-- the only real implementation, the unit tests for testing are based on+-- mock implementations.+class Monad m => TestRunner m where+  type ApplyPatchReqs m (p :: * -> * -> *) :: Constraint+  type DisplayPatchReqs m (p :: * -> * -> *) :: Constraint++  -- |Output a message+  writeMsg :: String -> m wX wX ()++  -- |Output a message containing the name of a patch+  mentionPatch :: DisplayPatchReqs m p => p wA wB -> m wX wX ()+  +  -- |Apply a patch to the testing tree.+  applyPatch :: ApplyPatchReqs m p => p wX wY -> m wX wY ()++  -- |Unapply a patch from the testing tree+  unapplyPatch :: ApplyPatchReqs m p => p wX wY -> m wY wX ()++  -- |Get the current status (pass/skip/fail) of the testing tree,+  -- e.g. by running the test command.+  getCurrentTestResult :: m wX wX (TestResult wX)++  -- |Flag that all testing has completed.+  finishedTesting :: a -> m wX TestingDone a++type TestRunnerPatchReqs m p =+  ( -- Having to enumerate these different cases for ApplyPatchReqs is+    -- a bit ugly, but necessary because it is a type function and we+    -- don't know that ApplyPatchReqs m p => ApplyPatchReqs m (FL p), etc.+    -- In theory QuantifiedConstraints could be used to simplify this but+    -- the fact that ApplyPatchReqs is a type function makes this a bit tricky.+    ApplyPatchReqs m p, ApplyPatchReqs m (RL p), ApplyPatchReqs m (FL p)+  , ApplyPatchReqs m (PatchSeq p), ApplyPatchReqs m (RL (PatchSeq p))+  , DisplayPatchReqs m p)++type TestablePatch m p = (TestRunner m, TestRunnerPatchReqs m p, Commute p)++instance TestRunner TestingEnvIO where+  type ApplyPatchReqs TestingEnvIO p = (Apply p, ApplyMonad (ApplyState p) DefaultIO, PatchInspect p)+  type DisplayPatchReqs TestingEnvIO p = ShowPatch p++  writeMsg str = liftIx (putStrLn str Base.>> hFlush stdout)+  mentionPatch p = liftIx (putDocLn (description p) Base.>> hFlush stdout)++  applyPatch p = do+    liftTesting $ Testing $ runDefault (apply p)+    opts <- asks tpSetScriptsExecutable+    when (opts == O.YesSetScriptsExecutable) $+      liftIx $ setScriptsExecutablePatches p++  unapplyPatch p = do+    liftTesting $ Testing $ runDefault (unapply p)+    opts <- asks tpSetScriptsExecutable+    when (opts == O.YesSetScriptsExecutable) $+      liftIx $ setScriptsExecutablePatches p++  getCurrentTestResult = do+    testCmd <- asks tpTestCmd+    liftTesting $ runTestCmd testCmd++  finishedTesting r = TestingEnv $ ReaderT $ \_ -> Testing (Base.return r)++-- |The result of running a test on state 'wX' of the repository.+data TestResult wX+  = Testable (TestResultValid wX) -- ^We got a usable test result.+  | Untestable+    -- ^The test result could not be identified as either pass or fail,+    -- for example it might have been a build failure. External test+    -- scripts report this by reporting exit code 125.++-- |A usable test result, i.e. not an untestable state.+data TestResultValid wX+  = Success -- ^The test passed.+  | Failure (TestFailure wX) -- ^The test failed with the given exit code.++data TestFailure wX = TestFailure Int++exitCodeToTestResult :: ExitCode -> TestResult wX+exitCodeToTestResult ExitSuccess = Testable Success+exitCodeToTestResult (ExitFailure 125) = Untestable+exitCodeToTestResult (ExitFailure n) = Testable (Failure (TestFailure n))++-- |A 'TestCmd' runs the test on a given repository state.+data TestCmd = TestCmd (forall (wX :: *) . TestingIO wX wX (TestResult wX))++runTestCmd :: TestCmd -> TestingIO wX wX (TestResult wX)+runTestCmd (TestCmd cmd) = cmd++mkTestCmd :: (forall (wX :: *) . IO (TestResult wX)) -> TestCmd+mkTestCmd cmd = TestCmd (Testing cmd)++-- |'PatchSeq' is a sequence of patches, implemented as a binary tree,+-- balanced in an arbitrary way depending on how it happened to be constructed.+-- In the 'darcs test' implementation it is used to+-- wrap up a single patch or group of patches that might be the cause of a failure.+data PatchSeq p wX wY where+  Single :: p wX wY -> PatchSeq p wX wY+  Joined :: PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ++instance Show2 p => Show (PatchSeq p wX wY) where+  showsPrec prec (Single p) =+    showParen (prec >= 11) (showString "Darcs.UI.Commands.Test.Single " . showsPrec2 11 p)+  showsPrec prec (Joined p1 p2) =+    showParen (prec >= 11)+              (showString "Darcs.UI.Commands.Test.Joined "+                 . showsPrec2 11 p1 . showSpace . showsPrec2 11 p2)+++instance Show2 p => Show1 (PatchSeq p wX) where+  showDict1 = Dict++instance Show2 p => Show2 (PatchSeq p) where+  showDict2 = Dict++instance Apply p => Apply (PatchSeq p) where+  type ApplyState (PatchSeq p) = ApplyState p+  apply (Single p) = apply p+  apply (Joined p1 p2) = apply p1 Base.>> apply p2+  unapply (Single p) = unapply p+  unapply (Joined p1 p2) = unapply p2 Base.>> unapply p1++instance PatchInspect p => PatchInspect (PatchSeq p) where+  listTouchedFiles (Single p) = listTouchedFiles p+  listTouchedFiles (Joined p1 p2) = listTouchedFiles p1 ++ listTouchedFiles p2+  hunkMatches f (Single p) = hunkMatches f p+  hunkMatches f (Joined p1 p2) = hunkMatches f p1 || hunkMatches f p2++patchTreeToFL :: PatchSeq p wX wY -> FL p wX wY+patchTreeToFL t = go t NilFL+  where+    go :: PatchSeq p wA wB -> FL p wB wC -> FL p wA wC+    go (Single p) rest = p :>: rest+    go (Joined p1 p2) rest = go p1 (go p2 rest)++flToPatchTree :: p wX wY -> FL p wY wZ -> PatchSeq p wX wZ+flToPatchTree p NilFL = Single p+flToPatchTree p (q :>: qs) = Joined (Single p) (flToPatchTree q qs)++rlToPatchTree :: RL p wX wY -> p wY wZ -> PatchSeq p wX wZ+rlToPatchTree NilRL p = Single p+rlToPatchTree (qs :<: q) p = Joined (rlToPatchTree qs q) (Single p)++-- |The result of running a test strategy.+data StrategyResultRaw patches =+    NoPasses -- ^The chosen strategy didn't find any passing states in the repository.+  | NoFailureOnHead -- ^The test didn't fail on head so there's no failure to track down.+  | Blame patches -- ^The failure was tracked down to the given patches.+  -- these two are just for oneTest+  | RunSuccess -- ^The single test run passed.+  | RunFailed Int -- ^The single test run failed with the given exit code.+  deriving (Eq, Show, Functor)++type StrategyResult p wSuccess wFailure =+  StrategyResultRaw (PatchSeq p wSuccess wFailure)++type StrategyResultSealed p =+  StrategyResultRaw (Sealed2 (PatchSeq p))++-- |'WithResult' is a continuation passed to a test strategy indicating+-- what should be done with the final result of the strategy. This for+-- example allows a post-processing "minimise blame" pass to be run.+-- The witnesses make it hard to wrap this up in a standard abstraction.+data WithResult (m :: * -> * -> * -> *) p a =+  WithResult+  { runWithResult+      :: forall wSuccess wFailure+       . StrategyResult p wSuccess wFailure+      -> m wSuccess TestingDone a+  }++-- |After a strategy has finished, untestable states might mean that it+-- was only able to assign blame to a group of patches rather than a+-- single patch. This function tries to reorder the group of patches+-- (using commutation). The hope is that a reordered sequence will reveal+-- a testable state, allowing us to cut down the group.+--+-- The type is logically+-- something like 'StrategyResult -> m StrategyResult', but is expressed+-- as a transformation of a 'WithResult' to manage the witnesses. These+-- are complicated because we want to re-use the testing tree left by the+-- strategy.+minimiseBlame :: forall m p a . TestablePatch m p => WithResult m p a -> WithResult m p a+minimiseBlame (WithResult finalRunner) =+  WithResult $ \result ->+    case result of+      Blame p -> doMinimiseFwd NilRL (patchTreeToFL p)+      _ -> finalRunner result+  where+    -- This minimisation code is a bit ad-hoc and almost certainly+    -- doesn't find every possible minimisation (which might require+    -- an exponential search). It also doesn't cache anything and+    -- therefore may do some repeated shuffling.+    +    -- The witnesses do guarantee that it is+    -- correct and the implementation is structured to guarantee+    -- termination.++    -- The overall algorithm is to work through the sequence from left+    -- to right, treating each patch in turn as a 'focus'. We then try+    -- to commute the focus with the patches to the left of it, and test+    -- each new intermediate state this produces.+    --+    -- If we do find a testable intermediate state, we can chop the sequence+    -- at that state.++    -- In 'doMinimiseFwd kept rest', 'kept' are the patches that we+    -- have looked at already, and 'rest' are the ones still to be+    -- processed.+    doMinimiseFwd+      :: RL p wSuccess wFocus+      -> FL p wFocus wFailure+      -> m wFocus TestingDone a++    doMinimiseFwd kept (focus :>: rest) = do+      -- Call 'doMinimiseRev' to work on the first of the so-far-unprocessed+      -- patches. In the end 'doMinimiseRev' will call back to 'doMinimiseFwd',+      -- and either 'focus' will have been moved into 'kept' or dropped entirely+      -- because the sequence has been cut down.+      --+      -- Whilst 'kept' marks the patches that have already been visited,+      -- 'doMinimiseRev' will still try to commute them with the 'focus' patch.+      doMinimiseRev kept (focus :>: NilFL :> NilFL :> rest)++    doMinimiseFwd (kept :<: final) NilFL = do+      -- This unapply is only needed because WithResult+      -- is based around leaving the test tree in the 'wSuccess'+      -- state in case something else needs it.+      -- In practice no more tests will be run after we finish minimising blame,+      -- so it's wasted work.+      -- It could probably be removed by making the type of WithResult+      -- more sophisticated somehow, but it's not clear the complexity+      -- is worth it.+      unapplyPatch (kept :<: final)+      finalRunner (Blame (rlToPatchTree kept final))++    doMinimiseFwd NilRL NilFL = error "internal error: trying to minimise an empty sequence"++    -- In 'doMinimiseRev tocommute (focus :> ps :> qs)':+    --   - 'qs' are the patches that are yet to be processed. They will just be sent+    --     back to 'doMinimiseFwd' unless we end up dropping them entirely.+    --   - 'ps' are patches we have managed to commute with 'focus' but still produced+    --     untestable states.+    --   - 'focus' are the patches we are trying to move around to see if it helps+    --     find a testable state. It starts out as a singleton but gains more patches+    --     as commutes fail.+    --   - 'tocommute' are the patches we still need to commute with the 'focus'.+    doMinimiseRev+      :: RL p wSuccess wFocus+      -> (FL p :> FL p :> FL p) wFocus wFailure+      -> m wFocus TestingDone a++    doMinimiseRev NilRL (focus :> ps :> qs) = do+      -- We've run out of things to commute, so pass everything that we+      -- looked at back to 'doMinimiseFwd' as the 'kept' parameter.+      let kept = reverseFL (focus +>+ ps)+      applyPatch kept+      doMinimiseFwd kept qs++    doMinimiseRev (tocommute :<: p) (focus :> ps :> qs) = do+      unapplyPatch p+      case commuterIdFL commute (p :> focus) of+        Nothing ->+          -- if we can't commute just attach it to the focus+          doMinimiseRev tocommute (p :>: focus :> ps :> qs)+        Just (focus' :> p') -> do+          applyPatch focus'+          testResult <- getCurrentTestResult+          case testResult of+            Untestable -> do+              -- The newly commuted state is also untestable, leave the patch we+              -- just commuted in 'ps' and keep working on the focus.+              unapplyPatch focus'+              doMinimiseRev tocommute (focus' :> p' :>: ps :> qs)+            -- Since we got a result, we can chop the sequence here, we just need+            -- to decide which part to keep.+            -- The full sequence after the commute is kept ; focus' | p' ; ps ; qs+            Testable Success -> doMinimiseRev NilRL (NilFL :> p' :>: ps :> qs)+            Testable (Failure _) -> do+              unapplyPatch focus'+              doMinimiseRev tocommute (focus' :> NilFL :> NilFL)++-- |StrategyDone captures the final result of running a "test strategy" like+-- bisect, backoff, linear or once. It has a slightly complicated type because of the+-- witnesses and because we may want to run a continuation afterwards to minimise+-- the result. Essentially it is just a 'StrategyResult'.+type StrategyDone m p wY = forall a . WithResult m p a ->  m wY TestingDone a++-- |Report that the strategy has finished with the given result.+strategyDone :: StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess+strategyDone result withResult = runWithResult withResult result++-- |The implementation type for a given "test strategy" like bisect, backoff, linear or once.+-- It is given a sequence of patches we might want to search inside to identify the cause of+-- a test failure, and also passed the initial testing result for the end of that sequence.+type Strategy+   = forall m p wOlder wNewer+   . TestablePatch m p+  => TestResult wNewer+  -> RL p wOlder wNewer+  -> StrategyDone m p wNewer++-- runStrategy orchestrates the whole process of isolating patches+-- triggering the failure.+runStrategy+  :: TestablePatch m p+  => O.TestStrategy+  -> O.ShrinkFailure+  -> RL p wOlder wNewer+  -> m wNewer TestingDone (StrategyResultSealed p)+runStrategy strategy shrinkFailure patches = do+  -- The starting point is a full patch sequence 'RL p wStart wEnd' with the+  -- testing tree in state 'wEnd'. We get the initial testing result for that+  -- state as 'Strategy' requires it.+  testResult <- getCurrentTestResult+  -- We narrow down the failure via a strategy (linear/bisect/backoff). If we+  -- find patches to blame, this has type 'Testing p wSuccess wFailure', leaving the testing+  -- tree in state 'wSuccess'.+  -- If the strategy is "one test" then the result is just success/failure.+  chooseStrategy strategy testResult patches $+    -- What to do with the result of the strategy is passed as a continuation to the strategy.+    -- First we try to minimise any patches to blame, resulting in 'Testing p wSuccess2 wFailure2'.+    -- The testing tree is left in state 'wSuccess2' although we don't actually care about+    -- it any more.+    (if shrinkFailure == O.ShrinkFailure then minimiseBlame else id) $+    -- Finally the result is wrapped up in a Sealed2 and returned.+    WithResult (finishedTesting . fmap Sealed2)++runTestable+  :: ( Commute p+     , TestRunner (TestingEnv m)+     , TestRunnerPatchReqs (TestingEnv m) p+     )+  => O.SetScriptsExecutable+  -> TestCmd+  -> O.TestStrategy+  -> O.ShrinkFailure+  -> RL p wStart wA+  -> m (StrategyResultSealed p)+runTestable sse tcmd strategy shrinkFailure ps =+  runTestingEnv (TestingParams sse tcmd) $ runStrategy strategy shrinkFailure ps++chooseStrategy :: O.TestStrategy -> Strategy+chooseStrategy O.Bisect = trackBisect+chooseStrategy O.Linear = trackLinear+chooseStrategy O.Backoff = trackBackoff+chooseStrategy O.Once = oneTest++explanatoryTextFor :: O.TestStrategy -> String+explanatoryTextFor strategy =+  case strategy of+    O.Bisect -> assumedMonotony+    O.Backoff -> assumedMonotony+    O.Linear -> wasLinear+    O.Once -> wasLinear -- this case won't actually be reached+  where+    -- We did a bisection type search so a given patch that causes+    -- the failure is only the most recent if there is actually only+    -- one transition from "passed" to "failed" in the repository history.+    assumedMonotony = " (assuming monotony in the given range)"+    -- We did a linear search so the patch we found is definitely the+    -- most recent to have triggered a failure.+    wasLinear = ""++-- | test only the last recorded state+oneTest :: Strategy+oneTest (Testable Success) _ = strategyDone RunSuccess+oneTest Untestable  _ = strategyDone $ RunFailed 125+oneTest (Testable (Failure (TestFailure n)))  _ = strategyDone $ RunFailed n++-- | linear search (with --linear)+trackLinear :: Strategy+trackLinear (Testable (Failure _)) ps = trackNextLinear NilFL ps+trackLinear _ _ = strategyDone NoFailureOnHead++-- |The guts of tracking down a test failure by linear search+-- Precondition: 'wZ' is a failing state and any states+-- in the (possibly empty) range of states '[wY, wZ)' are untestable.+trackNextLinear+  :: TestablePatch m p+  => FL p wY wZ -- ^a buffer of patches that start with an untestable state+  -> RL p wX wY -- ^patches we haven't visited yet+  -> StrategyDone m p wY+trackNextLinear _ NilRL withResult = strategyDone NoPasses withResult+trackNextLinear untestables (ps:<:p) withResult = do+  unapplyPatch p+  writeMsg "Trying without the patch:"+  mentionPatch p+  testResult <- getCurrentTestResult+  case testResult of+    -- If the test passes we're done.+    Testable Success -> strategyDone (Blame (flToPatchTree p untestables)) withResult+    -- If the test fails then we can drop the 'untestables' buffer and keep going.+    Testable (Failure _) -> trackNextLinear NilFL ps withResult+    -- If the state is untestable then we add to the 'untestables' buffer and keep going.+    Untestable -> trackNextLinear (p :>: untestables) ps withResult++-- |A 'TestingState' is used to keep track of the set of patches+-- a search strategy is currently working on, split at a given point+-- with an explicit witness for that intermediate point (the 'focus'),+-- so we can connect it to the state of the testing tree.+data TestingState p wOlder wFocus wNewer where+  TestingState+    :: RL (PatchSeq p) wOlder wFocus+    -> FL (PatchSeq p) wFocus wNewer+    -> TestingState p wOlder wFocus wNewer++lengthTS :: TestingState p wX wZ wY -> Int+lengthTS (TestingState ps1 ps2) = lengthRL ps1 + lengthFL ps2++lengthsTS :: TestingState p wX wZ wY -> (Int, Int)+lengthsTS (TestingState ps1 ps2) = (lengthFL ps2, lengthRL ps1)++-- |Exponential backoff search (with --backoff): first search backwards looking for+-- a successful state, then bisect between that successful state and the current (failed)+-- state.+trackBackoff :: Strategy+trackBackoff (Testable (Failure tf)) ps =+  -- 4 is an arbitrary choice for how far to start jumping backwards+  trackNextBackoff tf 4 (mapRL_RL Single ps)+trackBackoff _ _ = strategyDone NoFailureOnHead++-- |Precondition: the test fails at 'wNewer'.+trackNextBackoff+  :: TestablePatch m p+  => TestFailure wNewer -- ^Failure witness+  -> Int -- ^Number of patches to skip.+  -> RL (PatchSeq p) wOlder wNewer -- ^Patches not yet skipped.+  -> StrategyDone m p wNewer++-- Normal base case: we've run out of patches.+trackNextBackoff _ _ NilRL withResult = strategyDone NoPasses withResult++-- Edge case: if there's just one patch left then either the test+-- passes before this patch and we can blame it, or we've run out of+-- places to look for success.+trackNextBackoff _ _ (NilRL :<: p) withResult = do+  unapplyPatch p+  testResult <- getCurrentTestResult+  case testResult of+    Testable Success -> strategyDone (Blame p) withResult+    _ -> strategyDone NoPasses withResult++-- There's more than one patch to go.+trackNextBackoff tf n ahead withResult = do+  case splitAtRL n ahead of+    ahead' :> skipped' -> do+      writeMsg $ "Skipping " ++ show n ++ " patches..."++show (lengthRL skipped', lengthRL ahead')+      unapplyPatch skipped'+      -- After backing off by n more patches, look for a testable state, working through the skipped+      -- patches if necessary because the current state isn't testable.+      findTestableTowardsNewer (Failure tf) (TestingState ahead' (reverseRL skipped')) $+        \testResult (TestingState ahead'' skipped'') ->+        case testResult of+          -- Another failure, keep going. Note that it's possible that+          -- findTestableTowardsNewer will have to go all the way to the end of+          -- skipped', leaving us in the same testing position as before, but+          -- the backoff count is doubled so we'll still make progress.+          Failure tf2 -> trackNextBackoff tf2 (2*n) ahead'' withResult+          -- Found a success state, so now we can start the bisect.+          Success -> initialBisect (TestingState NilRL skipped'') withResult++-- |Given a patch sequence which has a valid test result at the end ('wNewer'),+-- try to find another point with a valid test result, starting from 'wFocus' and+-- jumping towards 'wNewer' if necessary.+findTestableTowardsNewer+  :: TestablePatch m p+  => TestResultValid wNewer+  -> TestingState p wOlder wFocus wNewer+  -> (forall wFocus2+       . TestResultValid wFocus2+      -> TestingState p wOlder wFocus2 wNewer+      -> m wFocus2 wResult a+     )+  -> m wFocus wResult a++findTestableTowardsNewer newerResult ts@(TestingState _ NilFL) cont = cont newerResult ts+findTestableTowardsNewer newerResult ts@(TestingState older (p :>: ps)) cont = do+  focusResult <- getCurrentTestResult+  case focusResult of+    Testable res -> cont res ts+    Untestable -> do+      writeMsg $ "Found untestable state " ++ show (lengthsTS ts)+      applyPatch p+      let+        -- The 'wB' state is untestable, so try to attach the patches on either side of+        -- it together into the same 'PatchSeq' so we don't try it again.+        joinT :: RL (PatchSeq p) wA wB -> PatchSeq p wB wC -> RL (PatchSeq p) wA wC+        -- If we don't have any patches on the left, we can't do anything.+        joinT NilRL x = NilRL :<: x+        -- Otherwise peel off the first patch on the left and attach it to the patch on the right.+        joinT (ys :<: y) x = ys :<: Joined y x+      moveHalfNewer (TestingState (joinT older p) ps) $ \tsNew ->+        findTestableTowardsNewer newerResult tsNew cont+++-- |Binary search (with --bisect): bisect from the start of the repository.+-- This strategy is a bit dubious as the test probably doesn't actually pass+-- at the start of the repository so the hope is that at some point during the+-- bisect we will come across a passing state. The two different entry points into+-- 'initialBisect' (trackBisect and trackBackoff) also complicate the set of cases+-- we have to consider.+trackBisect :: Strategy+trackBisect (Testable (Failure _)) ps = initialBisect (TestingState (mapRL_RL Single ps) NilFL)+trackBisect _ _ = strategyDone NoFailureOnHead++-- |Progress of Bisect: current step, currently predicted total steps.+-- The total steps prediction will increase if we run into untestable states.+type BisectProgress = (Int, Int)++-- |Launch a bisect. Precondition: the test fails at 'wNewer'.+-- If called via backoff, then the test also passes at 'wOlder',+-- but there is no guarantee if bisect is called directly. +initialBisect+  :: TestablePatch m p+  => TestingState p wOlder wFocus wNewer+  -> StrategyDone m p wFocus+initialBisect ps = trackNextBisect currProg ps+  where+    flooredLength = lengthTS ps `min` 1+    maxProg  = 1 + round ((logBase 2 $ fromIntegral flooredLength) :: Double)+    currProg = (1, maxProg) :: BisectProgress++-- |Given a testing state, work out what to do next.+-- Precondition: the test fails at 'wNewer'.+trackNextBisect+  :: forall m p wOlder wNewer wFocus+   . TestablePatch m p+  => BisectProgress+  -> TestingState p wOlder wFocus wNewer+  -> StrategyDone m p wFocus++trackNextBisect _ (TestingState NilRL NilFL) withResult = strategyDone NoPasses withResult++-- With these two cases we're down to a single patch, so either it's to blame+-- or there are no passing states found (subject to the limitations of the bisect strategy -+-- not every state was visited).+trackNextBisect _ (TestingState NilRL (p :>: NilFL)) withResult = checkAndReturnFinalBisectResult p withResult+trackNextBisect _ (TestingState (NilRL :<: p) NilFL) withResult = do+  unapplyPatch p+  checkAndReturnFinalBisectResult p withResult++-- More than one patch left. Find the middle of the TestingState and work from that.+trackNextBisect (dnow, dtotal) ps withResult = do+  writeMsg $ "Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences..." ++ show (lengthsTS ps)+  moveToMiddle ps (\ts -> runNextBisect (dnow, dtotal) ts withResult)++-- |Once we only have one patch left in bisect, we need to check that the test passes before the patch.+-- This is not guaranteed when bisect is called directly from the command-line. If we changed the UI to+-- ensure that bisect was only launched with both a passing and a failing state, we could strengthen+-- the precondition of 'initialBisect' and things it calls, and this function would be unnecessary.+-- Precondition: the test fails at 'wNewer'.+checkAndReturnFinalBisectResult+  :: TestablePatch m p+  => PatchSeq p wOlder wNewer+  -> StrategyDone m p wOlder+checkAndReturnFinalBisectResult p withResult = do+  testResult <- getCurrentTestResult+  case testResult of+    Testable Success -> strategyDone (Blame p) withResult+    _ -> strategyDone NoPasses withResult++-- |The guts of bisection. Normally it will be passed an evenly split+-- 'TestingState older newer' with the focus in the middle, but if we find an+-- untestable state then we will start jumping around to find something testable.+-- Preconditions: 'older' is non-empty; the test fails at wNewer.+runNextBisect+  :: forall m p wOlder wNewer wFocus+   . TestablePatch m p+  => BisectProgress+  -> TestingState p wOlder wFocus wNewer+  -> StrategyDone m p wFocus+runNextBisect (dnow, dtotal) (TestingState older newer) withResult = do+  testResult <- getCurrentTestResult+  case testResult of++    -- The standard case for bisect: we have a result for the focus and we use it to pick+    -- either the left or right half.+    Testable result -> do+      let doNext newState = trackNextBisect (dnow+1, dtotal) newState withResult+      case result of+        Success   -> doNext (TestingState NilRL newer) -- continue left  (to the present)+        Failure _ -> doNext (TestingState older NilFL) -- continue right (to the past)++    -- If we couldn't test the bisect state then we need to move around to try to find+    -- a testable state.+    Untestable -> do+      writeMsg $ "Found untestable state " ++ show (lengthsTS (TestingState older newer))+      case (older, newer) of+        (NilRL, _) -> error "internal error: older bisect state reached 0 patches (runNextBisect)"+        -- Although 'newer' can become empty, the precondition that the test fails at wNewer means+        -- we shouldn't get here.+        -- TODO the user might supply an unreliable test script, maybe we should deal with the NilFL+        -- case before running the test.+        (_, NilFL) -> error "internal error: newer bisect state reached 0 patches (runNextBisect)"+        (older' :<: p1, p2 :>: newer') -> do+          applyPatch p2+          moveHalfNewer (TestingState (older' :<: Joined p1 p2) newer') $+            \ts -> runNextBisect (dnow+1, dtotal+1) ts withResult++-- |Given a 'TestingState older newer', move the focus to the middle of 'newer',+-- updating the testing tree to match, and call the given continuation.+moveHalfNewer+  :: forall m p wOlder wNewer wFocus wResult a+   . TestablePatch m p+  => TestingState p wOlder wFocus wNewer+  -> (forall wFocus2 . TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)+  -> m wFocus wResult a++moveHalfNewer (TestingState older newer) f = doMove older (lengthFL newer `div` 2, newer)+  where+    doMove+      :: forall wFocus2+       . RL (PatchSeq p) wOlder wFocus2+      -> (Int, FL (PatchSeq p) wFocus2 wNewer)+      -> m wFocus2 wResult a++    doMove ps1 (0, ps2) = f (TestingState ps1 ps2)+    doMove _ (_, NilFL) = error "impossible: exhausted newer patches (moveHalfNewer)"+    doMove ps1 (n, p :>: ps2) = do+      applyPatch p+      doMove (ps1 :<: p) (n-1, ps2)++-- |Given a 'TestingState older newer', move the focus to the middle of+-- 'older +>+ newer', updating the testing tree to match, and call the given+-- continuation.+moveToMiddle+  :: forall m p wOlder wNewer wFocus wResult a+   . TestablePatch m p+  => TestingState p wOlder wFocus wNewer+  -> (forall wFocus2 . TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)+  -> m wFocus wResult a++moveToMiddle (TestingState older newer) f = doMove (lengthRL older, older) (lengthFL newer, newer)+  where+    doMove+      :: forall wFocus2+       . (Int, RL (PatchSeq p) wOlder wFocus2)+      -> (Int, FL (PatchSeq p) wFocus2 wNewer)+      -> m wFocus2 wResult a++    doMove (len1, ps1) (len2, ps2) | abs (len1 - len2) <= 1 = f (TestingState ps1 ps2)++    doMove (len1, ps1 :<: p1) (len2, ps2) | len1 > len2 = do+      unapplyPatch p1+      doMove (len1-1, ps1) (len2+1, p1 :>: ps2)++    doMove (len1, ps1) (len2, p2 :>: ps2) = do -- len2 > len1+      applyPatch p2+      doMove (len1+1, ps1 :<: p2) (len2-1, ps2)++    -- these cases should only be reachable if the lengths get out of sync+    doMove (_, NilRL) _ = error "internal error: right bisect state reached 0 patches (moveToMiddle)"+    doMove _ (_, NilFL) = error "internal error: left bisect state reached 0 patches (moveToMiddle)"
src/Darcs/UI/Commands/TransferMode.hs view
@@ -20,15 +20,15 @@  import Darcs.Prelude +import System.Directory ( withCurrentDirectory ) import Control.Exception ( catch ) import System.IO ( stdout, hFlush ) -import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Exception ( prettyException ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag )-import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags )+import Darcs.UI.Options ( oid ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Progress ( setProgressMode )@@ -65,10 +65,7 @@     , commandCommand = transferModeCmd     , commandPrereq = amInRepository     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions = odesc transferModeBasicOpts-    , commandDefaults = defaultFlags transferModeOpts-    , commandCheckOptions = ocheck transferModeOpts+    , commandOptions = transferModeOpts     }   where     transferModeBasicOpts = O.repoDir
src/Darcs/UI/Commands/Unrecord.hs view
@@ -16,6 +16,7 @@ --  Boston, MA 02110-1301, USA.  {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module Darcs.UI.Commands.Unrecord     ( unrecord@@ -23,64 +24,84 @@     , obliterate     ) where -import Control.Monad ( when, void )-import Data.Maybe( fromJust, isJust )-import Darcs.Util.Tree( Tree )-import System.Exit ( exitSuccess )- import Darcs.Prelude -import Darcs.Patch ( RepoPatch, invert, commute, effect )-import Darcs.Patch.Apply( ApplyState )+import Control.Monad ( unless, void, when )+import Darcs.Util.Tree ( Tree )+import Data.Maybe ( fromJust, isJust )+import System.Directory ( doesPathExist )+import System.Exit ( exitSuccess )++import Darcs.Patch ( RepoPatch, commute, effect, invert )+import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Bundle ( makeBundle, minContext )+import Darcs.Patch.CommuteFn ( commuterFLId ) import Darcs.Patch.Depends ( removeFromPatchSet ) import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc )-import Darcs.Patch.Set ( PatchSet, Origin )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanFL )+import Darcs.Patch.Set ( Origin, PatchSet )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, nullFL, (:>)(..), (+>+) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )-import Darcs.Patch.Witnesses.Ordered ( (:>)(..), mapFL_FL, nullFL, FL(..) )-import Darcs.Util.Path( useAbsoluteOrStd, AbsolutePath, toFilePath, doesPathExist )-import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked ) import Darcs.Repository     ( PatchInfoAnd     , RepoJob(..)     , applyToWorking     , finalizeRepositoryChanges-    , invalidateIndex-    , readRepo-    , tentativelyAddToPending+    , readPatches+    , setTentativePending     , tentativelyRemovePatches     , unrecordedChanges     , withRepoLock     )-import Darcs.Repository.Flags( UseIndex(..), ScanKnown(..), UpdatePending(..), DryRun(NoDryRun) )-import Darcs.Util.Lock( writeDocBinFile )-import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias-                         , putVerbose-                         , setEnvDarcsPatches, amInHashedRepository-                         , putInfo, putFinished )+import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , commandAlias+    , nodefaults+    , putFinished+    , putInfo+    , putVerbose+    , setEnvDarcsPatches+    , withStdOpts+    ) import Darcs.UI.Commands.Util     ( getUniqueDPatchName-    , printDryRunMessageAndExit-    , preselectPatches     , historyEditHelp+    , preselectPatches+    , printDryRunMessageAndExit     ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags-    ( DarcsFlag, changesReverse, compress, verbosity, getOutput-    , useCache, dryRun, umask, minimize-    , diffAlgorithm, xmlOutput, isInteractive, selectDeps )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+    ( DarcsFlag+    , changesReverse+    , diffingOpts+    , dryRun+    , getOutput+    , isInteractive+    , minimize+    , selectDeps+    , umask+    , useCache+    , verbosity+    , xmlOutput+    )+import Darcs.UI.Options ( (?), (^) ) import qualified Darcs.UI.Options.All as O-import Darcs.UI.SelectChanges ( WhichChanges(..),-                                selectionConfig, runSelection )-import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.UI.PrintPatch ( printFriendly )+import Darcs.UI.SelectChanges ( WhichChanges(..), runSelection, selectionConfig )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Util.English ( presentParticiple )-import Darcs.Util.Printer ( Doc, formatWords, text, putDoc, sentence, (<+>), ($+$) )+import Darcs.Util.Lock ( writeDocBinFile )+import Darcs.Util.Path ( AbsolutePath, toFilePath, useAbsoluteOrStd )+import Darcs.Util.Printer ( Doc, formatWords, putDoc, sentence, text, ($+$), (<+>) ) import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked )  unrecordDescription :: String unrecordDescription =-    "Remove recorded patches without changing the working tree."+  "Remove recorded patches without changing the working tree."  unrecordHelp :: Doc unrecordHelp = formatWords@@ -103,10 +124,7 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc unrecordAdvancedOpts-    , commandBasicOptions = odesc unrecordBasicOpts-    , commandDefaults = defaultFlags unrecordOpts-    , commandCheckOptions = ocheck unrecordOpts+    , commandOptions = unrecordOpts     }   where     unrecordBasicOpts@@ -116,52 +134,47 @@       ^ O.interactive -- True       ^ O.repoDir     unrecordAdvancedOpts-      = O.compress-      ^ O.umask+      = O.umask       ^ O.changesReverse     unrecordOpts = unrecordBasicOpts `withStdOpts` unrecordAdvancedOpts  unrecordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unrecordCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $-        RepoJob $ \_repository -> do-            (_ :> removal_candidates) <- preselectPatches opts _repository-            let direction = if changesReverse ? opts then Last else LastReversed-                selection_config =-                  selectionConfig direction "unrecord" (patchSelOpts opts) Nothing Nothing-            (_ :> to_unrecord) <- runSelection removal_candidates selection_config-            when (nullFL to_unrecord) $ do-                putInfo opts "No patches selected!"-                exitSuccess-            putVerbose opts $-                text "About to write out (potentially) modified patches..."-            setEnvDarcsPatches to_unrecord-            invalidateIndex _repository-            _repository <- tentativelyRemovePatches _repository (compress ? opts)-                     YesUpdatePending to_unrecord-            _ <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)-            putInfo opts "Finished unrecording."+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    (_ :> removal_candidates) <- preselectPatches opts _repository+    let direction = if changesReverse ? opts then Last else LastReversed+        selection_config =+          selectionConfig direction "unrecord" (patchSelOpts opts) Nothing Nothing+    (_ :> to_unrecord) <- runSelection removal_candidates selection_config+    when (nullFL to_unrecord) $ do+      putInfo opts "No patches selected!"+      exitSuccess+    putVerbose opts $+      text "About to write out (potentially) modified patches..."+    setEnvDarcsPatches to_unrecord+    _repository <-+      tentativelyRemovePatches _repository YesUpdatePending to_unrecord+    _ <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+    putInfo opts "Finished unrecording."  unpullDescription :: String unpullDescription =-    "Opposite of pull; unsafe if patch is not in remote repository."+  "Opposite of pull; unsafe if patch is not in remote repository."  unpullHelp :: Doc-unpullHelp = text $ "Unpull is an alias for what is nowadays called `obliterate`."+unpullHelp =+  text $ "Unpull is an alias for what is nowadays called `obliterate`."  unpull :: DarcsCommand-unpull = (commandAlias "unpull" Nothing obliterate)-             { commandHelp = unpullHelp-             , commandDescription = unpullDescription-             , commandCommand = unpullCmd-             }--unpullCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-unpullCmd = genericObliterateCmd "unpull"+unpull =+  (commandAlias "unpull" Nothing obliterate)+    { commandHelp = unpullHelp+    , commandDescription = unpullDescription+    , commandCommand = obliterateCmd "unpull"+    }  obliterateDescription :: String-obliterateDescription =-    "Delete selected patches from the repository."+obliterateDescription = "Delete selected patches from the repository."  obliterateHelp :: Doc obliterateHelp = formatWords@@ -186,14 +199,11 @@     , commandDescription = obliterateDescription     , commandExtraArgs = 0     , commandExtraArgHelp = []-    , commandCommand = obliterateCmd+    , commandCommand = obliterateCmd "obliterate"     , commandPrereq = amInHashedRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc obliterateAdvancedOpts-    , commandBasicOptions = odesc obliterateBasicOpts-    , commandDefaults = defaultFlags obliterateOpts-    , commandCheckOptions = ocheck obliterateOpts+    , commandOptions = obliterateOpts     }   where     obliterateBasicOpts@@ -208,104 +218,104 @@       ^ O.diffAlgorithm       ^ O.dryRunXml     obliterateAdvancedOpts-      = O.compress-      ^ O.useIndex-      ^ O.umask+      = O.umask       ^ O.changesReverse     obliterateOpts = obliterateBasicOpts `withStdOpts` obliterateAdvancedOpts -obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-obliterateCmd = genericObliterateCmd "obliterate"---- | genericObliterateCmd is the function that executes the "obliterate" and--- "unpull" commands. The first argument is the name under which the command is--- invoked (@unpull@ or @obliterate@).-genericObliterateCmd :: String-                     -> (AbsolutePath, AbsolutePath)-                     -> [DarcsFlag]-                     -> [String]-                     -> IO ()-genericObliterateCmd cmdname _ opts _ =-    let cacheOpt = useCache ? opts-        verbOpt = verbosity ? opts-    in withRepoLock (dryRun ? opts) cacheOpt YesUpdatePending (umask ? opts) $-        RepoJob $ \_repository -> do-            -- FIXME we may need to honour --ignore-times here, although this-            -- command does not take that option (yet)-            pend <- unrecordedChanges (UseIndex, ScanKnown, diffAlgorithm ? opts)-              O.NoLookForMoves O.NoLookForReplaces _repository Nothing-            (_ :> removal_candidates) <- preselectPatches opts _repository--            let direction = if changesReverse ? opts then Last else LastReversed-                selection_config =-                  selectionConfig direction cmdname (patchSelOpts opts) Nothing Nothing-            (_ :> removed) <--                runSelection removal_candidates selection_config-            when (nullFL removed) $ do-                putInfo opts "No patches selected!"-                exitSuccess-            case commute (effect removed :> pend) of-                Nothing -> fail $ "Can't " ++ cmdname-                                  ++ " patch without reverting some "-                                  ++ "unrecorded change."-                Just (_ :> p_after_pending) -> do-                    printDryRunMessageAndExit "obliterate"-                      verbOpt-                      (O.withSummary ? opts)-                      (dryRun ? opts)-                      (xmlOutput ? opts)-                      (isInteractive True opts)-                      removed-                    setEnvDarcsPatches removed-                    when (isJust $ getOutput opts "") $-                        -- The call to preselectPatches above may have-                        -- unwrapped the latest clean tag. If we don't want to-                        -- remove it, we lost information about that tag being-                        -- clean, so we have to access it's inventory. To avoid-                        -- that, and thus preserve laziness, we re-read our-                        -- original patchset and use that to create the context-                        -- for the bundle.-                        readRepo _repository >>= savetoBundle opts removed-                    invalidateIndex _repository-                    _repository <- tentativelyRemovePatches _repository-                        (compress ? opts) YesUpdatePending removed-                    tentativelyAddToPending _repository $ invert $ effect removed-                    withSignalsBlocked $ do-                        _repository <- finalizeRepositoryChanges _repository-                                        YesUpdatePending (compress ? opts)-                        debugMessage "Applying patches to working tree..."-                        void $ applyToWorking _repository verbOpt (invert p_after_pending)-                    putFinished opts (presentParticiple cmdname)+obliterateCmd+  :: String -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+obliterateCmd cmdname _ opts _ = do+  let verbOpt = verbosity ? opts+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    unrecorded <- unrecordedChanges (diffingOpts opts) _repository Nothing+    (_ :> removal_candidates) <- preselectPatches opts _repository+    let direction = if changesReverse ? opts then Last else LastReversed+        selection_config =+          selectionConfig direction cmdname (patchSelOpts opts) Nothing Nothing+    (_ :> removed) <- runSelection removal_candidates selection_config+    when (nullFL removed) $ do+      putInfo opts "No patches selected!"+      exitSuccess+    case genCommuteWhatWeCanFL (commuterFLId commute) (effect removed :> unrecorded) of+      unrecorded' :> removed_after_unrecorded :> to_revert -> do+        effect_removed <-+          case to_revert of+            NilFL -> return removed_after_unrecorded+            _ ->+              if isInteractive True opts then do+                putStrLn $+                  "These unrecorded changes conflict with the " ++ cmdname ++ ":"+                printFriendly O.Verbose O.NoSummary to_revert+                yes <- promptYorn "Do you want to revert these unrecorded changes?"+                if yes then+                  return $ removed_after_unrecorded +>+ to_revert+                else do+                  putStrLn $ "Okay, " ++ cmdname ++ " cancelled."+                  exitSuccess+              else+                fail $+                  "Can't " ++ cmdname +++                    " these patches without reverting some unrecorded changes."+        printDryRunMessageAndExit+          "obliterate" verbOpt (O.withSummary ? opts) (dryRun ? opts)+          (xmlOutput ? opts) (isInteractive True opts) removed+        setEnvDarcsPatches removed+        when (isJust $ getOutput opts (return "")) $+          -- The call to preselectPatches above may have unwrapped the latest+          -- clean tag. If we don't want to remove it, we lost information+          -- about that tag being clean, so we have to access it's inventory.+          -- To avoid that, and thus preserve laziness, we re-read our original+          -- patchset and use that to create the context for the bundle.+          readPatches _repository >>= savetoBundle opts removed+        _repository <-+          tentativelyRemovePatches _repository NoUpdatePending removed+        -- rely on sifting to commute out prims not belonging in pending:+        setTentativePending _repository unrecorded'+        withSignalsBlocked $ do+          _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+          debugMessage "Applying patches to working tree..."+          unless (O.yes (O.dryRun ? opts)) $+            void $ applyToWorking _repository verbOpt (invert effect_removed)+        putFinished opts (presentParticiple cmdname) -savetoBundle :: (RepoPatch p, ApplyState p ~ Tree)-             => [DarcsFlag]-             -> FL (PatchInfoAnd rt p) wX wR-             -> PatchSet rt p Origin wR-             -> IO ()+savetoBundle+  :: (RepoPatch p, ApplyState p ~ Tree)+  => [DarcsFlag]+  -> FL (PatchInfoAnd p) wX wR+  -> PatchSet p Origin wR+  -> IO () savetoBundle _ NilFL _ = return () savetoBundle opts removed@(x :>: _) orig = do-    let kept = fromJust $ removeFromPatchSet removed orig-        genFullBundle = makeBundle Nothing kept (mapFL_FL hopefully removed)-    bundle <- if not (minimize ? opts)-               then genFullBundle-               else do putInfo opts "Minimizing context, to generate bundle with full context hit ctrl-C..."-                       ( case minContext kept removed of-                           Sealed (kept' :> removed') -> makeBundle Nothing kept' (mapFL_FL hopefully removed') )-                      `catchInterrupt` genFullBundle-    filename <- getUniqueDPatchName (patchDesc x)-    let Just outname = getOutput opts filename-    exists <- useAbsoluteOrStd (doesPathExist . toFilePath) (return False) outname-    when exists $ fail $ "Directory or file named '" ++ (show outname) ++ "' already exists."-    useAbsoluteOrStd writeDocBinFile putDoc outname bundle-    putInfo opts $ sentence $-      useAbsoluteOrStd (("Saved patch bundle" <+>) . text . toFilePath) (text "stdout") outname+  let kept = fromJust $ removeFromPatchSet removed orig+      genFullBundle = makeBundle Nothing kept (mapFL_FL hopefully removed)+  bundle <-+    if not (minimize ? opts)+      then genFullBundle+      else do+        putInfo opts+          "Minimizing context, to generate bundle with full context hit ctrl-C..."+        (case minContext kept removed of+          Sealed (kept' :> removed') ->+            makeBundle Nothing kept' (mapFL_FL hopefully removed'))+          `catchInterrupt` genFullBundle+  let filename = getUniqueDPatchName (patchDesc x)+  outname <- fromJust (getOutput opts filename)+  exists <- useAbsoluteOrStd (doesPathExist . toFilePath) (return False) outname+  when exists $+    fail $ "Directory or file named '" ++ (show outname) ++ "' already exists."+  useAbsoluteOrStd writeDocBinFile putDoc outname bundle+  putInfo opts $ sentence $+    useAbsoluteOrStd+      (("Saved patch bundle" <+>) . text . toFilePath)+      (text "stdout")+      outname  patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions-patchSelOpts flags = S.PatchSelectionOptions+patchSelOpts flags =+  S.PatchSelectionOptions     { S.verbosity = verbosity ? flags-    , S.matchFlags = parseFlags O.matchSeveralOrLast flags+    , S.matchFlags = O.matchSeveralOrLast ? flags     , S.interactive = isInteractive True flags     , S.selectDeps = selectDeps ? flags     , S.withSummary = O.withSummary ? flags-    , S.withContext = O.NoContext     }
src/Darcs/UI/Commands/Unrevert.hs view
@@ -15,61 +15,62 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -module Darcs.UI.Commands.Unrevert ( unrevert, writeUnrevert ) where+module Darcs.UI.Commands.Unrevert ( unrevert ) where  import Darcs.Prelude -import System.Exit ( exitSuccess )-import Darcs.Util.Tree( Tree )+import Control.Monad ( unless, when, void ) +import Darcs.Patch ( commute )+import Darcs.Patch.Depends ( findCommon )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..), (+>+) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Repository+    ( RepoJob(..)+    , applyToWorking+    , considerMergeToWorking+    , finalizeRepositoryChanges+    , readPatches+    , addToPending+    , unrecordedChanges+    , withRepoLock+    )+import Darcs.Repository.Flags+    ( AllowConflicts(..)+    , ResolveConflicts(..)+    , Reorder(..)+    , WantGuiPause(..)+    )+import Darcs.Repository.Unrevert ( readUnrevert, writeUnrevert ) import Darcs.UI.Commands     ( DarcsCommand(..)-    , withStdOpts-    , nodefaults     , amInHashedRepository+    , nodefaults     , putFinished+    , withStdOpts     ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags-    ( diffingOpts, verbosity, useCache, umask, compress, diffAlgorithm-    , isInteractive, withContext )-import Darcs.Repository.Flags-    ( UseIndex(..), ScanKnown (..), Reorder(..), AllowConflicts(..), ExternalMerge(..)-    , WantGuiPause(..), UpdatePending(..), DryRun(NoDryRun) )+    ( diffingOpts+    , isInteractive+    , umask+    , useCache+    , verbosity+    ) import Darcs.UI.Flags ( DarcsFlag )-import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Options ( (?), (^) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..),-                          considerMergeToWorking,-                          tentativelyAddToPending, finalizeRepositoryChanges,-                          readRepo,-                          readRecorded,-                          applyToWorking, unrecordedChanges )-import Darcs.Repository.Paths ( unrevertPath )-import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, commute )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Info ( patchinfo )-import Darcs.Patch.Named ( infopatch )-import Darcs.Patch.Set ( PatchSet, Origin )-import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )-import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), (+>+) ) import Darcs.UI.SelectChanges     ( WhichChanges(First)     , runInvertibleSelection     , selectionConfigPrim     )-import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )-import qualified Data.ByteString as B-import Darcs.Util.Lock ( writeDocBinFile, removeFileMayNotExist )-import Darcs.Patch.Depends ( mergeThem )-import Darcs.Util.Exception ( catchall )-import Darcs.Util.Prompt ( askUser )-import Darcs.Patch.Bundle ( parseBundle, interpretBundle, makeBundle )-import Darcs.Util.IsoDate ( getIsoDateTime )-import Darcs.Util.SignalHandler ( withSignalsBlocked )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Progress ( debugMessage )-import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.SignalHandler ( withSignalsBlocked )  unrevertDescription :: String unrevertDescription =@@ -92,7 +93,6 @@     , S.interactive = isInteractive True flags     , S.selectDeps = O.PromptDeps -- option not supported, use default     , S.withSummary = O.NoSummary -- option not supported, use default-    , S.withContext = withContext ? flags     }  unrevert :: DarcsCommand@@ -107,77 +107,44 @@     , commandPrereq = amInHashedRepository     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc unrevertAdvancedOpts-    , commandBasicOptions = odesc unrevertBasicOpts-    , commandDefaults = defaultFlags unrevertOpts-    , commandCheckOptions = ocheck unrevertOpts+    , commandOptions = unrevertOpts     }   where     unrevertBasicOpts-      = O.useIndex-      ^ O.interactive -- True+      = O.interactive -- True       ^ O.repoDir-      ^ O.withContext       ^ O.diffAlgorithm     unrevertAdvancedOpts = O.umask     unrevertOpts = unrevertBasicOpts `withStdOpts` unrevertAdvancedOpts  unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unrevertCmd _ opts [] =- withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $ \_repository -> do-  us <- readRepo _repository-  Sealed them <- unrevertPatchBundle us-  recorded <- readRecorded _repository-  unrecorded <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -})-    O.NoLookForMoves O.NoLookForReplaces _repository Nothing-  Sealed h_them <- return $ mergeThem us them+ withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+  us <- readPatches _repository+  Sealed them <- readUnrevert us+  unrecorded <- unrecordedChanges (diffingOpts opts) _repository Nothing   Sealed pw <- considerMergeToWorking _repository "unrevert"-                      YesAllowConflictsAndMark-                      NoExternalMerge NoWantGuiPause-                      (compress ? opts) (verbosity ? opts) NoReorder-                      ( UseIndex, ScanKnown, diffAlgorithm ? opts )-                      (Fork us NilFL h_them)+                      (YesAllowConflicts MarkConflicts)+                      NoWantGuiPause+                      NoReorder+                      (diffingOpts opts)+                      (findCommon us them)   let selection_config =         selectionConfigPrim             First "unrevert" (patchSelOpts opts)-            Nothing Nothing (Just recorded)-  (p :> skipped) <- runInvertibleSelection pw selection_config-  tentativelyAddToPending _repository p-  withSignalsBlocked $-      do _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)-         _ <- applyToWorking _repository (verbosity ? opts) p-         debugMessage "I'm about to writeUnrevert."-         writeUnrevert _repository skipped recorded (unrecorded+>+p)+            Nothing Nothing+  (to_unrevert :> to_keep) <- runInvertibleSelection pw selection_config+  addToPending _repository (diffingOpts opts) to_unrevert+  recorded <- readPatches _repository+  debugMessage "I'm about to writeUnrevert."+  case commute ((unrecorded +>+ to_unrevert) :> to_keep) of+    Nothing -> do+      yes <- promptYorn "You will not be able to undo this operation! Proceed?"+      when yes $ writeUnrevert recorded NilFL -- i.e. remove unrevert+    Just (to_keep' :> _) -> writeUnrevert recorded to_keep'+  withSignalsBlocked $ do+    _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+    unless (O.yes (O.dryRun ? opts)) $+      void $ applyToWorking _repository (verbosity ? opts) to_unrevert   putFinished opts "unreverting" unrevertCmd _ _ _ = error "impossible case"--writeUnrevert :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-              => Repository rt p wR wU wT -> FL (PrimOf p) wX wY-              -> Tree IO -> FL (PrimOf p) wR wX -> IO ()-writeUnrevert _ NilFL _ _ = removeFileMayNotExist unrevertPath-writeUnrevert repository ps recorded pend =-  case commute (pend :> ps) of-    Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? "-                  case really of ('y':_) -> return ()-                                 _ -> exitSuccess-                  writeUnrevert repository NilFL recorded pend-    Just (p' :> _) -> do-        rep <- readRepo repository-        date <- getIsoDateTime-        info <- patchinfo date "unrevert" "anon" []-        let np = infopatch info p'-        bundle <- makeBundle (Just recorded) rep (np :>: NilFL)-        writeDocBinFile unrevertPath bundle--unrevertPatchBundle :: RepoPatch p-                    => PatchSet rt p Origin wR-                    -> IO (SealedPatchSet rt p Origin)-unrevertPatchBundle us = do-  pf <- B.readFile unrevertPath-        `catchall` fail "There's nothing to unrevert!"-  case parseBundle pf of-      Right (Sealed bundle) -> do-        case interpretBundle us bundle of-          Left msg -> fail msg-          Right ps -> return (Sealed ps)-      Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
src/Darcs/UI/Commands/Util.hs view
@@ -29,19 +29,21 @@     , getLastPatches     , matchRange     , historyEditHelp+    , commonHelpWithPrefsTemplates     ) where  import Control.Monad ( when, unless )  import Darcs.Prelude +import Control.Exception ( catch ) import Data.Char ( isAlpha, toLower, isDigit, isSpace ) import Data.Maybe ( fromMaybe )  import System.Exit ( ExitCode(..), exitWith, exitSuccess ) import System.Posix.Files ( isDirectory ) -import Darcs.Patch ( IsRepoType, RepoPatch, xmlSummary )+import Darcs.Patch ( RepoPatch, xmlSummary ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Depends     ( areUnrelatedRepos@@ -66,23 +68,23 @@     ( ReadingOrWriting(..)     , Repository     , identifyRepositoryFor-    , readRecorded-    , readRepo-    , testTentative+    , readPristine+    , readPatches     ) import Darcs.Repository.Prefs ( getDefaultRepo, globalPrefsDirDoc ) import Darcs.Repository.State ( readUnrecordedFiltered )  import Darcs.UI.Commands ( putInfo )-import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Flags ( DarcsFlag, isInteractive ) import Darcs.UI.PrintPatch ( showFriendly ) import Darcs.UI.Options ( (?) ) import Darcs.UI.Options.All-    ( Verbosity(..), SetScriptsExecutable, TestChanges (..)-    , RunTest(..), LeaveTestDir(..), UseIndex, ScanKnown(..)-    , WithSummary(..), DryRun(..), XmlOutput(..), LookForMoves+    ( Verbosity(..)+    , DiffOpts(..)+    , WithSummary(..), DryRun(..), XmlOutput(..)     ) import qualified Darcs.UI.Options.All as O+import Darcs.UI.TestChanges ( testTree )  import Darcs.Util.English ( anyOfClause, itemizeVertical ) import Darcs.Util.Exception ( clarifyErrors )@@ -105,26 +107,22 @@     text message <> text ":" <+> pathlist (map displayPath paths) announceFiles _ _ _ = return () -testTentativeAndMaybeExit :: Repository rt p wR wU wT-                          -> Verbosity-                          -> TestChanges-                          -> SetScriptsExecutable-                          -> Bool+testTentativeAndMaybeExit :: Tree IO+                          -> [DarcsFlag]                           -> String-                          -> String -> Maybe String -> IO ()-testTentativeAndMaybeExit repo verb test sse interactive failMessage confirmMsg withClarification = do-    let (rt,ltd) = case test of-          NoTestChanges    -> (NoRunTest, YesLeaveTestDir)-          YesTestChanges x -> (YesRunTest, x)-    testResult <- testTentative repo rt ltd sse verb-    unless (testResult == ExitSuccess) $ do-        let doExit = maybe id (flip clarifyErrors) withClarification $-                        exitWith testResult-        unless interactive doExit-        putStrLn $ "Looks like " ++ failMessage-        let prompt = "Shall I " ++ confirmMsg ++ " anyway?"-        yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])-        unless (yn == 'y') doExit+                          -> String+                          -> Maybe String+                          -> IO ()+testTentativeAndMaybeExit tree opts failMessage confirmMsg withClarification = do+  testResult <- testTree opts tree+  unless (testResult == ExitSuccess) $ do+    let doExit =+          maybe id (flip clarifyErrors) withClarification $ exitWith testResult+    unless (isInteractive True opts) doExit+    putStrLn $ "Looks like " ++ failMessage+    let prompt = "Shall I " ++ confirmMsg ++ " anyway?"+    yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])+    unless (yn == 'y') doExit  -- | @'printDryRunMessageAndExit' action flags patches@ prints a string -- representing the action that would be taken if the @--dry-run@ option had@@ -136,17 +134,17 @@                           => String                           -> Verbosity -> WithSummary -> DryRun -> XmlOutput                           -> Bool -- interactive-                          -> FL (PatchInfoAnd rt p) wX wY+                          -> FL (PatchInfoAnd p) wX wY                           -> IO () printDryRunMessageAndExit action v s d x interactive patches = do     when (d == YesDryRun) $ do-        putInfoX $ hsep [ "Would", text action, "the following changes:" ]+        putInfoX $ hsep [ "Would", text action, "the following patches:" ]         putDocLnWith fancyPrinters put_mode         putInfoX $ text ""         putInfoX $ text "Making no changes: this is a dry run."         exitSuccess     when (not interactive && s == YesSummary) $ do-        putInfoX $ hsep [ "Will", text action, "the following changes:" ]+        putInfoX $ hsep [ "Will", text action, "the following patches:" ]         putDocLn put_mode   where     put_mode = if x == YesXml@@ -173,16 +171,15 @@ -- The result is a pair of path lists: those that exist only in the working tree, -- and those that exist in pristine or working. filterExistingPaths :: (RepoPatch p, ApplyState p ~ Tree)-                    => Repository rt p wR wU wR+                    => Repository rt p wU wR                     -> Verbosity-                    -> UseIndex-                    -> ScanKnown-                    -> LookForMoves+                    -> DiffOpts                     -> [AnchoredPath]                     -> IO ([AnchoredPath],[AnchoredPath])-filterExistingPaths repo verb useidx scan lfm paths = do-      pristine <- readRecorded repo-      working <- readUnrecordedFiltered repo useidx scan lfm (Just paths)+filterExistingPaths repo verb DiffOpts{..} paths = do+      pristine <- readPristine repo+      working <-+        readUnrecordedFiltered repo withIndex lookForAdds lookForMoves (Just paths)       let check = virtualTreeIO $ mapM exists paths       (in_pristine, _) <- check pristine       (in_working, _) <- check working@@ -190,7 +187,10 @@           paths_in_neither      = [ p | (p,False,False) <- paths_with_info ]           paths_only_in_working = [ p | (p,False,True) <- paths_with_info ]           paths_in_either       = [ p | (p,inp,inw) <- paths_with_info, inp || inw ]-          or_not_added          = if scan == ScanKnown then " or not added " else " "+          or_not_added =+            if lookForAdds == O.NoLookForAdds+              then " or not added "+              else " "       unless (verb == Quiet || null paths_in_neither) $ putDocLn $         "Ignoring non-existing" <> or_not_added <> "paths:" <+>         pathlist (map displayPath paths_in_neither)@@ -205,13 +205,19 @@                  n ++"'"  getUniqueDPatchName :: FilePath -> IO FilePath-getUniqueDPatchName name = getUniquePathName False (const "") buildName+getUniqueDPatchName name =+  catch+    (getUniquePathName False (const "") buildName)+    (\(e :: IOError) ->+      fail $ "Error constructing filename corresponding to " ++ show name ++ ": " ++ show e +++             "\nConsider using '-o' to specify an output filename."+    )   where     buildName i =       if i == -1 then patchFilename name else patchFilename $ name++"_"++show i  -- |patchFilename maps a patch description string to a safe (lowercased, spaces--- removed and ascii-only characters) patch filename.+-- removed and only letters/digits) patch filename. patchFilename :: String -> String patchFilename the_summary = name ++ ".dpatch"   where@@ -226,8 +232,8 @@  checkUnrelatedRepos :: RepoPatch p                     => Bool-                    -> PatchSet rt p Origin wX-                    -> PatchSet rt p Origin wY+                    -> PatchSet p Origin wX+                    -> PatchSet p Origin wY                     -> IO () checkUnrelatedRepos allowUnrelatedRepos us them =     when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $@@ -235,10 +241,10 @@             unless confirmed $ putStrLn "Cancelled." >> exitSuccess  -- | Get the union of the set of patches in each specified location-remotePatches :: (IsRepoType rt, RepoPatch p)+remotePatches :: RepoPatch p               => [DarcsFlag]-              -> Repository rt p wX wU wT -> [O.NotInRemote]-              -> IO (SealedPatchSet rt p Origin)+              -> Repository rt p wU wR -> [O.NotInRemote]+              -> IO (SealedPatchSet p Origin) remotePatches opts repository nirs = do     nirsPaths <- mapM getNotInRemotePath nirs     putInfo opts $@@ -248,7 +254,7 @@   where     readNir n = do         r <- identifyRepositoryFor Reading repository (O.useCache ? opts) n-        rps <- readRepo r+        rps <- readPatches r         return (Sealed rps)      getNotInRemotePath :: O.NotInRemote -> IO String@@ -260,20 +266,20 @@         maybe err return defaultRepo  getLastPatches :: RepoPatch p-               => [O.MatchFlag] -> PatchSet rt p Origin wR-               -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR+               => [O.MatchFlag] -> PatchSet p Origin wR+               -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR getLastPatches matchFlags ps =   case matchFirstPatchset matchFlags ps of     Just (Sealed p1s) -> findCommonWithThem ps p1s     Nothing -> error "precondition: getLastPatches requires a firstMatch"  preselectPatches-  :: (IsRepoType rt, RepoPatch p)+  :: RepoPatch p   => [DarcsFlag]-  -> Repository rt p wR wU wT-  -> IO ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR)+  -> Repository rt p wU wR+  -> IO ((PatchSet p :> FL (PatchInfoAnd p)) Origin wR) preselectPatches opts repo = do-  allpatches <- readRepo repo+  allpatches <- readPatches repo   let matchFlags = O.matchSeveralOrLast ? opts   case O.notInRemote ? opts of     [] -> do@@ -290,8 +296,8 @@  matchRange :: MatchableRP p            => [MatchFlag]-           -> PatchSet rt p Origin wY-           -> Sealed2 (FL (PatchInfoAnd rt p))+           -> PatchSet p Origin wY+           -> Sealed2 (FL (PatchInfoAnd p)) matchRange matchFlags ps =   case (sp1s, sp2s) of     (Sealed p1s, Sealed p2s) ->@@ -328,4 +334,15 @@   , "by using an appropriate `--match` option with the `author` keyword."   , "For instance, you could add something like `<cmd> match Your Name`"   , "to your `" ++ globalPrefsDirDoc ++ "defaults`."+  ]++commonHelpWithPrefsTemplates :: Doc+commonHelpWithPrefsTemplates = formatWords+  [ "Initialize and clone commands create the preferences files in"+  , "_darcs/prefs/ directory of the newly created repository. With option"+  , "--with-prefs-templates `boring` and `binaries` preferences files will be"+  , "filled with default templates. If you want to leave these files empty"+  , "use --no-prefs-templates option. If you prefer to keep the relevant"+  , "settings globally, it will be convenient to add 'ALL no-prefs-templates'"+  , "to your ~/darcs/defaults file."   ]
− src/Darcs/UI/Commands/Util/Tree.hs 
@@ -1,61 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.UI.Commands.Util.Tree-    ( -    -- * Tree lookup.-      treeHas-    , treeHasDir-    , treeHasFile-    , treeHasAnycase-    ) where--import Darcs.Prelude--import Data.List ( find )--import Darcs.Util.Path ( AnchoredPath(..), eqAnycase )-import Darcs.Util.Tree ( Tree, TreeItem(..), listImmediate )-import qualified Darcs.Util.Tree.Monad as TM-    ( directoryExists-    , exists-    , fileExists-    , virtualTreeMonad-    )--treeHasAnycase :: Monad m-               => Tree m-               -> AnchoredPath-               -> m Bool-treeHasAnycase tree (AnchoredPath names) = go names (SubTree tree)-  where-    go [] _ = return True-    go ns (Stub mkTree _) = mkTree >>= go ns . SubTree-    go _ (File _) = return False-    go (n:ns) (SubTree t) =-      case find (eqAnycase n . fst) (listImmediate t) of-        Nothing -> return False-        Just (_,i) -> go ns i--treeHas :: Monad m => Tree m -> AnchoredPath -> m Bool-treeHas tree path = fst `fmap` TM.virtualTreeMonad (TM.exists path) tree--treeHasDir :: Monad m => Tree m -> AnchoredPath -> m Bool-treeHasDir tree path = fst `fmap` TM.virtualTreeMonad (TM.directoryExists path) tree--treeHasFile :: Monad m => Tree m -> AnchoredPath -> m Bool-treeHasFile tree path = fst `fmap` TM.virtualTreeMonad (TM.fileExists path) tree
src/Darcs/UI/Commands/WhatsNew.hs view
@@ -16,6 +16,7 @@ --  Boston, MA 02110-1301, USA.  {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Darcs.UI.Commands.WhatsNew     ( whatsnew     , status@@ -26,11 +27,12 @@ import Control.Monad ( void, when ) import Control.Monad.Reader ( runReaderT ) import Control.Monad.State ( evalStateT, liftIO )+import Data.Maybe ( isJust ) import System.Exit ( ExitCode (..), exitSuccess, exitWith )  import Darcs.Patch     ( PrimOf, PrimPatch, RepoPatch-    , applyToTree, plainSummaryPrims, primIsHunk+    , applyToTree, plainSummaryPrims     ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Choices ( mkPatchChoices, labelPatches, unLabel )@@ -55,8 +57,8 @@     , unFreeLeft     ) import Darcs.Repository-    ( RepoJob (..), Repository-    , readRecorded+    ( RepoJob (..), Repository, AccessType(RO)+    , readPristine     , unrecordedChanges, withRepository     ) import Darcs.Repository.Diff ( treeDiff )@@ -70,15 +72,13 @@ import Darcs.UI.External ( viewDocWith ) import Darcs.UI.Flags     ( DarcsFlag, diffAlgorithm-    , withContext, useCache, pathSetFromArgs+    , useCache, pathSetFromArgs     , verbosity, isInteractive-    , lookForAdds, lookForMoves, lookForReplaces-    , scanKnown, useIndex, diffingOpts+    , diffingOpts     )-import Darcs.UI.Options-    ( DarcsOption, (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( (^), parseFlags, (?), oid ) import qualified Darcs.UI.Options.All as O-import Darcs.UI.PrintPatch ( contextualPrintPatch )+import Darcs.UI.PrintPatch ( contextualPrintPatchWithPager ) import Darcs.UI.SelectChanges     ( InteractiveSelectionM, KeyPress (..)     , WhichChanges (..)@@ -94,16 +94,13 @@ import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.Path ( AbsolutePath, AnchoredPath ) import Darcs.Util.Printer-    ( Doc, formatWords, putDocLn, renderString+    ( Doc, formatWords, putDocLn, putDocLnWith, renderString     , text, vcat, ($+$)     ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Prompt ( PromptConfig (..), promptChar ) import Darcs.Util.Tree ( Tree ) -commonAdvancedOpts :: DarcsOption a (O.UseIndex -> O.IncludeBoring -> a)-commonAdvancedOpts = O.useIndex ^ O.includeBoring- patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions     { S.verbosity = verbosity ? flags@@ -111,7 +108,6 @@     , S.interactive = isInteractive True flags     , S.selectDeps = O.PromptDeps -- option not supported, use default     , S.withSummary = getSummary flags-    , S.withContext = withContext ? flags     }  -- lookForAdds and machineReadable set YesSummary@@ -122,7 +118,7 @@   Just O.NoSummary -> O.NoSummary   Just O.YesSummary -> O.YesSummary   Nothing-    | O.yes (lookForAdds flags) -> O.YesSummary+    | O.yes (O.lookforadds ? flags) -> O.YesSummary     | O.machineReadable ? flags -> O.YesSummary     | otherwise -> O.NoSummary @@ -138,21 +134,20 @@     , commandPrereq = amInRepository     , commandCompleteArgs = modifiedFileArgs     , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc commonAdvancedOpts-    , commandBasicOptions = odesc whatsnewBasicOpts-    , commandDefaults = defaultFlags whatsnewOpts-    , commandCheckOptions = ocheck whatsnewOpts+    , commandOptions = whatsnewOpts     }   where     whatsnewBasicOpts       = O.maybeSummary Nothing       ^ O.withContext       ^ O.machineReadable-      ^ O.lookfor+      ^ O.maybelookforadds O.NoLookForAdds+      ^ O.lookforreplaces+      ^ O.lookformoves       ^ O.diffAlgorithm       ^ O.repoDir       ^ O.interactive -- False-    whatsnewOpts = whatsnewBasicOpts `withStdOpts` commonAdvancedOpts+    whatsnewOpts = withStdOpts whatsnewBasicOpts oid  whatsnewDescription :: String whatsnewDescription = "List unrecorded changes in the working tree."@@ -191,8 +186,10 @@   $+$ formatWords   [ "By default, `darcs whatsnew` uses Darcs' internal format for changes."   , "To see some context (unchanged lines) around each change, use the"-  , "`--unified` option.  To view changes in conventional `diff` format, use"-  , "the `darcs diff` command; but note that `darcs whatsnew` is faster."+  , "`--unified` option. (This option has no effect in interactive mode.)"+  , "To view changes in conventional `diff` format, use"+  , "the `darcs diff` command; but note that `darcs diff` cannot properly"+  , "display changes when file renames are involved."   ]   $+$ formatWords   [ "This command exits unsuccessfully (returns a non-zero exit status) if"@@ -201,14 +198,12 @@  whatsnewCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () whatsnewCmd fps opts args =-   withRepository (useCache ? opts) $ RepoJob $ \(repo :: Repository rt p wR wU wR) -> do-    let scan = scanKnown (lookForAdds opts) (O.includeBoring ? opts)+   withRepository (useCache ? opts) $ RepoJob $ \(repo :: Repository 'RO p wU wR) -> do     existing_files <- do       files <- pathSetFromArgs fps args-      files' <- traverse-        (filterExistingPaths-          repo (verbosity ? opts) (useIndex ? opts) scan (lookForMoves opts))-        files+      files' <-+        traverse+          (filterExistingPaths repo (verbosity ? opts) (diffingOpts opts)) files       let files'' = fmap snd files'       when (files'' == Just []) $         fail "None of the files you specified exist."@@ -217,12 +212,10 @@     -- get all unrecorded changes, possibly including unadded or even boring     -- files if the appropriate options were supplied     Sealed allInterestingChanges <--      filteredUnrecordedChanges (diffingOpts opts)-        (lookForMoves opts) (lookForReplaces opts)-        repo existing_files+      filteredUnrecordedChanges (diffingOpts opts) repo existing_files      -- get the recorded state-    pristine <- readRecorded repo+    pristine <- readPristine repo      -- the case --look-for-adds and --summary must be handled specially     -- in order to distinguish added and unadded files@@ -235,9 +228,9 @@       if haveLookForAddsAndSummary         then           -- do *not* look for adds here:-          filteredUnrecordedChanges (O.useIndex ? opts, O.ScanKnown, O.diffAlgorithm ? opts)-            (lookForMoves opts) (lookForReplaces opts)-            repo existing_files+          let dopts = diffingOpts opts+          in filteredUnrecordedChanges+                dopts {O.lookForAdds = O.NoLookForAdds} repo existing_files         else return (Sealed NilFL)     Sealed unaddedNewPathsPs <-       if haveLookForAddsAndSummary@@ -255,8 +248,7 @@     announceFiles (verbosity ? opts) existing_files "What's new in"     if maybeIsInteractive opts       then-        runInteractive (interactiveHunks pristine) (patchSelOpts opts)-          pristine allInterestingChanges+        runInteractive interactiveHunks (patchSelOpts opts) allInterestingChanges       else         if haveLookForAddsAndSummary           then do@@ -266,12 +258,12 @@             printChanges pristine allInterestingChanges   where     haveSummary = O.yes (getSummary opts)-    haveLookForAddsAndSummary = haveSummary && O.yes (lookForAdds opts)+    haveLookForAddsAndSummary = haveSummary && O.yes (O.lookforadds ? opts)      -- Filter out hunk patches (leaving add patches) and return the tree     -- resulting from applying the filtered patches to the pristine tree.     applyAddPatchesToPristine ps pristine = do-        adds :> _ <- return $ partitionRL primIsHunk $ reverseFL ps+        adds :> _ <- return $ partitionRL (isJust . isHunk) $ reverseFL ps         applyToTree (reverseRL adds) pristine      exitOnNoChanges :: FL p wX wY -> IO ()@@ -303,40 +295,37 @@                  -> IO ()     printChanges pristine changes         | haveSummary = putDocLn $ plainSummaryPrims machineReadable changes-        | O.yes (withContext ? opts) = contextualPrintPatch pristine changes+        | O.yes (O.withContext ? opts) = contextualPrintPatchWithPager pristine changes         | otherwise = printPatchPager changes      where machineReadable = parseFlags O.machineReadable opts      -- return the unrecorded changes that affect an optional list of paths.     filteredUnrecordedChanges :: forall rt p wR wU. (RepoPatch p, ApplyState p ~ Tree)-                              => (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)-                              -> O.LookForMoves-                              -> O.LookForReplaces-                              -> Repository rt p wR wU wR+                              => O.DiffOpts+                              -> Repository rt p wU wR                               -> Maybe [AnchoredPath]                               -> IO (Sealed (FL (PrimOf p) wR))-    filteredUnrecordedChanges diffing lfm lfr repo paths =-        chooseTouching paths <$> unrecordedChanges diffing lfm lfr repo paths+    filteredUnrecordedChanges diffing repo paths =+        chooseTouching paths <$> unrecordedChanges diffing repo paths  -- | Runs the 'InteractiveSelectionM' code runInteractive :: InteractiveSelectionM p wX wY () -- Selection to run                -> S.PatchSelectionOptions-               -> Tree IO         -- Pristine                -> FL p wX wY      -- A list of patches                -> IO ()-runInteractive i patchsel pristine ps' = do+runInteractive i patchsel ps' = do     let lps' = labelPatches Nothing ps'         choices' = mkPatchChoices lps'         ps = evalStateT i (initialSelectionState lps' choices')     void $       runReaderT ps $-        selectionConfigPrim First "view" patchsel Nothing Nothing (Just pristine)+        selectionConfigPrim First "view" patchsel Nothing Nothing  -- | The interactive part of @darcs whatsnew@ interactiveHunks :: (IsHunk p, ShowPatch p, ShowContextPatch p, Commute p,                      PatchInspect p, PrimDetails p, ApplyState p ~ Tree)-                 => Tree IO -> InteractiveSelectionM p wX wY ()-interactiveHunks pristine = do+                 => InteractiveSelectionM p wX wY ()+interactiveHunks = do     c <- currentPatch     case c of         Nothing -> liftIO $ putStrLn "No more changes!"@@ -350,14 +339,14 @@                 (PromptConfig thePrompt (keysFor basic_options) (keysFor adv_options)                  (Just 'n') "?h")         case yorn of-            -- View change in context-            'v' -> liftIO (contextualPrintPatch pristine (unLabel lp))+            -- View change+            'v' -> liftIO (printPatch (unLabel lp))                    >> repeatThis lp             -- View summary of the change             'x' -> liftIO (putDocLn $ summary $ unLabel lp)                    >> repeatThis lp             -- View change and move on-            'y' -> liftIO (contextualPrintPatch pristine (unLabel lp))+            'y' -> liftIO (printPatch (unLabel lp))                    >> decide True lp >> next_hunk             -- Go to the next patch             'n' -> decide False lp >> next_hunk@@ -381,15 +370,16 @@             _ -> do liftIO . putStrLn $                         helpFor "whatsnew" basic_options adv_options                     repeatThis lp-    start_over = backAll >> interactiveHunks pristine-    next_hunk  = skipOne >> skipMundane >> interactiveHunks pristine-    prev_hunk  = backOne >> interactiveHunks pristine+    start_over = backAll >> interactiveHunks+    next_hunk  = skipOne >> skipMundane >> interactiveHunks+    prev_hunk  = backOne >> interactiveHunks     options_yn =-        [ KeyPress 'v' "view this change in a context"-        , KeyPress 'y' "view this change in a context and go to the next one"-        , KeyPress 'n' "skip this change and its dependencies" ]+        [ KeyPress 'v' "view this change"+        , KeyPress 'y' "view this change and go to the next one"+        , KeyPress 'n' "skip this change and its dependencies"+        ]     optionsView =-        [ KeyPress 'p' "view this change in context wih pager "+        [ KeyPress 'p' "view this change with pager"         , KeyPress 'x' "view a summary of this change"         ]     optionsNav =@@ -405,15 +395,15 @@ printPatchPager :: ShowPatchBasic p => p wX wY -> IO () printPatchPager = viewDocWith fancyPrinters . displayPatch +printPatch :: ShowPatchBasic p => p wX wY -> IO ()+printPatch = putDocLnWith fancyPrinters . displayPatch+ -- | An alias for 'whatsnew', with implicit @-l@ (and thus implicit @-s@) -- flags. We override the default description, to include these flags. status :: DarcsCommand status = statusAlias     { commandDescription = statusDesc-    , commandAdvancedOptions = odesc commonAdvancedOpts-    , commandBasicOptions = odesc statusBasicOpts-    , commandDefaults = defaultFlags statusOpts-    , commandCheckOptions = ocheck statusOpts+    , commandOptions = statusOpts     }   where     statusAlias = commandAlias "status" Nothing whatsnew@@ -422,13 +412,13 @@       = O.maybeSummary (Just O.YesSummary)       ^ O.withContext       ^ O.machineReadable-      ^ O.lookforadds O.YesLookForAdds+      ^ O.maybelookforadds O.YesLookForAdds       ^ O.lookforreplaces       ^ O.lookformoves       ^ O.diffAlgorithm       ^ O.repoDir       ^ O.interactive-    statusOpts = statusBasicOpts `withStdOpts` commonAdvancedOpts+    statusOpts = withStdOpts statusBasicOpts oid  maybeIsInteractive :: [DarcsFlag] -> Bool maybeIsInteractive = maybe False id . parseFlags O.interactive
src/Darcs/UI/Completion.hs view
@@ -1,8 +1,13 @@ -- | How to complete arguments {-# LANGUAGE NamedFieldPuns #-} module Darcs.UI.Completion-    ( fileArgs, knownFileArgs, unknownFileArgs, modifiedFileArgs-    , noArgs, prefArgs+    ( fileArgs+    , knownFileArgs+    , unknownFileArgs+    , modifiedFileArgs+    , noArgs+    , Pref(..) -- re-export+    , prefArgs     ) where  import Darcs.Prelude@@ -17,14 +22,14 @@     ( UseCache(..)     ) import Darcs.Repository.Prefs-    ( getPreflist+    ( Pref(..), getPreflist     ) import Darcs.Repository.Job     ( RepoJob(..)     , withRepository     ) import Darcs.Repository.State-    ( readRecordedAndPending+    ( readPristineAndPending     , readUnrecordedFiltered     , unrecordedChanges     , restrictDarcsdir@@ -34,6 +39,7 @@  import Darcs.UI.Flags ( DarcsFlag ) import qualified Darcs.UI.Flags as Flags+import Darcs.UI.Options ( (?) ) import qualified Darcs.UI.Options.All as O  import Darcs.Util.File@@ -43,7 +49,7 @@     ( darcsdir     ) import Darcs.Util.Path-    ( AnchoredPath, anchorPath+    ( AnchoredPath, realPath     , AbsolutePath, toPath, floatSubPath, makeSubPathOf     ) import Darcs.Util.Tree as Tree@@ -54,7 +60,6 @@  -- | Return all files available under the original working -- directory regardless of their repo state.--- Subdirectories get a separator (slash) appended. fileArgs :: (AbsolutePath, AbsolutePath)          -> [DarcsFlag]          -> [String]@@ -66,53 +71,44 @@  -- | Return all files available under the original working directory that -- are unknown to darcs but could be added.--- Subdirectories get a separator (slash) appended. unknownFileArgs :: (AbsolutePath, AbsolutePath)                 -> [DarcsFlag]                 -> [String]                 -> IO [FilePath] unknownFileArgs fps flags args = notYetListed args $ do-  let sk = if Flags.includeBoring flags then O.ScanBoring else O.ScanAll-      lfm = Flags.lookForMoves flags-      lfr = Flags.lookForReplaces flags-  RepoTrees {have, known} <- repoTrees O.UseIndex sk lfm lfr+  let lfa = if O.includeBoring ? flags then O.EvenLookForBoring else O.YesLookForAdds+      dopts = Flags.diffingOpts flags+  RepoTrees {have, known} <- repoTrees dopts {O.lookForAdds = lfa}   known_paths <- listHere known fps   have_paths <- listHere have fps-  return $ map anchoredToFilePath $ nubSort have_paths `minus` nubSort known_paths+  return $+    map anchoredToFilePath $ nubSort have_paths `minus` nubSort known_paths  -- | Return all files available under the original working directory that -- are known to darcs (either recorded or pending).--- Subdirectories get a separator (slash) appended. knownFileArgs :: (AbsolutePath, AbsolutePath)               -> [DarcsFlag]               -> [String]               -> IO [FilePath] knownFileArgs fps flags args = notYetListed args $ do-  let (ui, sk, _) = Flags.diffingOpts flags-      lfm = Flags.lookForMoves flags-      lfr = Flags.lookForReplaces flags-  RepoTrees {known} <- repoTrees ui sk lfm lfr+  RepoTrees {known} <- repoTrees (Flags.diffingOpts flags)   map anchoredToFilePath <$> listHere known fps  -- | Return all files available under the original working directory that -- are modified (relative to the recorded state).--- Subdirectories get a separator (slash) appended. modifiedFileArgs :: (AbsolutePath, AbsolutePath)                  -> [DarcsFlag]                  -> [String]                  -> IO [FilePath] modifiedFileArgs fps flags args = notYetListed args $ do-  let (ui, sk, _) = Flags.diffingOpts flags-      lfm = Flags.lookForMoves flags-      lfr = Flags.lookForReplaces flags-  RepoTrees {new} <- repoTrees ui sk lfm lfr+  RepoTrees {new} <- repoTrees (Flags.diffingOpts flags)   case uncurry makeSubPathOf fps of     Nothing -> return []     Just here ->-      return $ mapMaybe (stripPathPrefix (toPath here)) $ map (anchorPath "") new+      return $ mapMaybe (stripPathPrefix (toPath here)) $ map realPath new  -- | Return the available prefs of the given kind.-prefArgs :: String+prefArgs :: Pref          -> (AbsolutePath, AbsolutePath)          -> [DarcsFlag]          -> [String]@@ -131,17 +127,14 @@   , new :: [AnchoredPath] -- ^ unrecorded paths   } -repoTrees :: O.UseIndex -> O.ScanKnown -> O.LookForMoves -> O.LookForReplaces-          -> IO (RepoTrees IO)-repoTrees ui sk lfm lfr = do+repoTrees :: O.DiffOpts -> IO (RepoTrees IO)+repoTrees dopts@O.DiffOpts {..} = do   inDarcsRepo <- doesDirectoryReallyExist darcsdir   if inDarcsRepo then     withRepository NoUseCache $ RepoJob $ \r -> do-      known <- readRecordedAndPending r-      have <- readUnrecordedFiltered r ui sk lfm Nothing-      -- we are only interested in the affected paths so the diff-      -- algorithm is irrelevant-      new <- listTouchedFiles <$> unrecordedChanges (ui, sk, O.MyersDiff) lfm lfr r Nothing+      known <- readPristineAndPending r+      have <- readUnrecordedFiltered r withIndex lookForAdds lookForMoves Nothing+      new <- listTouchedFiles <$> unrecordedChanges dopts r Nothing       return $ RepoTrees {..}   else     return RepoTrees {have = emptyTree, known = emptyTree, new = []}@@ -149,7 +142,7 @@ -- this is for completion which should give us everything under the original wd subtreeHere :: Tree IO -> (AbsolutePath, AbsolutePath) -> IO (Maybe (Tree IO)) subtreeHere tree fps =-  case floatSubPath <$> uncurry makeSubPathOf fps of+  case either error id . floatSubPath <$> uncurry makeSubPathOf fps of     Nothing -> do       return Nothing -- here is no subtree of the repo     Just here -> do@@ -168,8 +161,7 @@ listItems = map (\(p, i) -> (p, itemType i)) . Tree.list  anchoredToFilePath :: (AnchoredPath, ItemType) -> [Char]-anchoredToFilePath (path, TreeType) = anchorPath "" path -- ++ "/"-anchoredToFilePath (path, BlobType) = anchorPath "" path+anchoredToFilePath (path, _) = realPath path  stripPathPrefix :: FilePath -> FilePath -> Maybe FilePath stripPathPrefix = stripPrefix . addSlash where
src/Darcs/UI/Defaults.hs view
@@ -3,7 +3,8 @@ import Darcs.Prelude  import Control.Monad.Writer-import Data.Char ( isSpace )+import Data.Char ( isLetter, isSpace )+import Data.Either ( partitionEithers ) import Data.Functor.Compose ( Compose(..) ) import Data.List ( nub ) import Data.Maybe ( catMaybes )@@ -11,14 +12,19 @@ import System.Console.GetOpt import Text.Regex.Applicative     ( (<|>)-    , match, many, some+    , match, many, some, sym     , psym, anySym, string )  import Darcs.UI.Flags ( DarcsFlag )-import Darcs.UI.Options ( DarcsOptDescr )+import Darcs.UI.Options ( DarcsOptDescr, OptMsg(..), withDashes )  import Darcs.UI.Commands-    ( DarcsCommand(..), commandAlloptions, extractAllCommands+    ( DarcsCommand+    , commandAlloptions+    , commandCheckOptions+    , commandDefaults+    , commandName+    , extractAllCommands     ) import Darcs.UI.TheCommands ( commandControlList ) import Darcs.Util.Path ( AbsolutePath )@@ -50,15 +56,17 @@ -- Errors encountered during processing of command line or defaults flags -- are formatted and added as (separate) strings to the list of error messages -- that are returned together with the resulting flag list.-applyDefaults :: Maybe String -- ^ maybe name of super command-              -> DarcsCommand -- ^ the darcs command-              -> AbsolutePath -- ^ the original working directory, i.e.-                              --   the one from which darcs was invoked-              -> [String]     -- ^ lines from user defaults-              -> [String]     -- ^ lines from repo defaults-              -> [DarcsFlag]  -- ^ flags from command line-              -> ([DarcsFlag], [String]) -- new flags and errors-applyDefaults msuper cmd cwd user repo flags = runWriter $ do+applyDefaults+  :: Maybe String -- ^ maybe name of super command+  -> DarcsCommand -- ^ the darcs command+  -> AbsolutePath -- ^ the original working directory, i.e.+                  --   the one from which darcs was invoked+  -> [String]     -- ^ lines from user defaults+  -> [String]     -- ^ lines from repo defaults+  -> [DarcsFlag]  -- ^ flags from command line+  -> ([DarcsFlag], ([String], [String])) -- new flags, warnings, errors+applyDefaults msuper cmd cwd user repo flags =+  splitMessages $ runWriter $ do     cl_flags  <- runChecks "Command line" check_opts flags     user_defs <- get_flags "User defaults" user     repo_defs <- get_flags "Repo defaults" repo@@ -69,6 +77,7 @@     check_opts = commandCheckOptions cmd     opts = uncurry (++) $ commandAlloptions cmd     get_flags source = parseDefaults source cwd cmd_name opts check_opts+    splitMessages (r,ms) = (r,partitionOptMsgs ms)  -- | Name of a normal command, or name of super and sub command. data CmdName = NormalCmd String | SuperCmd String String@@ -83,11 +92,20 @@ showCmdName (SuperCmd super sub) = unwords [super,sub] showCmdName (NormalCmd name) = name -runChecks :: String -> ([DarcsFlag] -> [String]) -> [DarcsFlag] -> Writer [String] [DarcsFlag]+runChecks :: String -> ([DarcsFlag] -> [OptMsg]) -> [DarcsFlag] -> Writer [OptMsg] [DarcsFlag] runChecks source check fs = do-  tell $ map ((source++": ")++) $ check fs+  tell $ map (mapOptMsg ((source++": ")++)) $ check fs   return fs +mapOptMsg :: (String -> String) -> OptMsg -> OptMsg+mapOptMsg f (OptWarning s) = OptWarning (f s)+mapOptMsg f (OptError s) = OptError (f s)++partitionOptMsgs :: [OptMsg] -> ([String], [String])+partitionOptMsgs = partitionEithers . map toEither where+  toEither (OptWarning s) = Left s+  toEither (OptError s) = Right s+ -- | Parse a list of lines from a defaults file, returning a list of 'DarcsFlag', -- given the current working directory, the command name, and a list of 'DarcsOption' -- for the command.@@ -107,9 +125,9 @@               -> AbsolutePath               -> CmdName               -> [DarcsOptDescr DarcsFlag]-              -> ([DarcsFlag] -> [String])+              -> ([DarcsFlag] -> [OptMsg])               -> [String]-              -> Writer [String] [DarcsFlag]+              -> Writer [OptMsg] [DarcsFlag] parseDefaults source cwd cmd opts check_opts def_lines = do     cmd_flags <- flags_for (M.keys opt_map) cmd_defs >>=       runChecks (source++" for command '"++showCmdName cmd++"'") check_opts@@ -122,11 +140,11 @@     all_defs = parseDefaultsLines (NormalCmd "ALL") def_lines     to_flag all_switches (switch,arg) =       if switch `notElem` all_switches then do-        tell [source++": command '"++showCmdName cmd+        tell [ OptWarning $ source++": command '"++showCmdName cmd              ++"' has no option '"++switch++"'."]         return Nothing       else-        mapErrors ((source++" for command '"++showCmdName cmd++"':"):)+        mapErrors ((OptWarning $ source++" for command '"++showCmdName cmd++"':"):)           $ defaultToFlag cwd opt_map (switch,arg)     -- the catMaybes filters out options that are not defined     -- for this command@@ -154,33 +172,17 @@ parseDefaultsLines :: CmdName -> [String] -> [Default] parseDefaultsLines cmd = catMaybes . map matchLine   where-    matchLine = match $ (,) <$> (match_cmd cmd *> spaces *> opt_dashes *> word) <*> rest+    matchLine = match $ (,) <$> (match_cmd cmd *> spaces *> option) <*> rest     match_cmd (NormalCmd name) = string name     match_cmd (SuperCmd super sub) = string super *> spaces *> string sub-    opt_dashes = string "--" <|> pure ""-    word = some $ psym (not.isSpace)+    option = short <|> long+    short = (\c1 c2 -> [c1,c2]) <$> sym '-' <*> psym isLetter+    long = (++) <$> opt_dashes <*> word+    opt_dashes = string "--" <|> pure "--"+    word = (:) <$> psym isLetter <*> many (psym (not.isSpace))     spaces = some $ psym isSpace     rest = spaces *> many anySym <|> pure "" -{- $note-This definition is a bit simpler, and doesn't need Text.Regex.Applicative,-but it has two disadvantages over the one above:-- * Flag arguments are split and joined again with words/unwords, which means-   that whitespace inside an argument is not preserved literally.-- * It is less easily extendable with new syntax.--> parseDefaultsLines :: CmdName -> [String] -> [(String, String)]-> parseDefaultsLines name entries = case name of->     SuperCmd super sub -> [ mk_def d as | (s:c:d:as) <- map words entries, s == super, c == sub ]->     NormalCmd cmd ->      [ mk_def d as | (c:d:as) <- map words entries, c == cmd ]->   where->     mk_def d as = (drop_dashes d, unwords as)->     drop_dashes ('-':'-':switch) = switch->     drop_dashes switch = switch--}- -- | Search an option list for a switch. If found, apply the flag constructor -- from the option to the arg, if any. The first parameter is the current working -- directory, which, depending on the option type, may be needed to create a flag@@ -190,7 +192,7 @@ defaultToFlag :: AbsolutePath               -> OptionMap               -> Default-              -> Writer [String] (Maybe DarcsFlag)+              -> Writer [OptMsg] (Maybe DarcsFlag) defaultToFlag cwd opts (switch, arg) = case M.lookup switch opts of     -- This case is not impossible! A default flag defined for ALL commands     -- is not necessarily defined for the concrete command in question.@@ -200,7 +202,9 @@     getArgDescr (Option _ _ a _) = a     flag_from (NoArg mkFlag) = do       if not (null arg) then do-        tell ["'"++switch++"' takes no argument, but '"++arg++"' argument given."]+        tell+          [ OptWarning $+            "'"++switch++"' takes no argument, but '"++arg++"' argument given." ]         return Nothing       else         return $ Just $ mkFlag cwd@@ -208,27 +212,28 @@       return $ Just $ mkFlag (if null arg then Nothing else Just arg) cwd     flag_from (ReqArg mkFlag _) = do       if null arg then do-        tell ["'"++switch++"' requires an argument, but no "++"argument given."]+        tell+          [ OptError $+            "'"++switch++"' requires an argument, but no argument given." ]         return Nothing       else         return $ Just $ mkFlag arg cwd --- | Get all the longSwitches from a list of options.-optionSwitches :: [DarcsOptDescr DarcsFlag] -> [String]-optionSwitches = concatMap sel where-  sel (Compose (Option _ switches _ _)) = switches+-- | Get all the flag names from an options+optionSwitches :: DarcsOptDescr DarcsFlag -> [String]+optionSwitches (Compose (Option short long _ _)) = withDashes short long --- | A finite map from long switches to 'DarcsOptDescr's.+-- | A finite map from flag names to 'DarcsOptDescr's. type OptionMap = M.Map String (DarcsOptDescr DarcsFlag)  -- | Build an 'OptionMap' from a list of 'DarcsOption's. optionMap :: [DarcsOptDescr DarcsFlag] -> OptionMap optionMap = M.fromList . concatMap sel where   add_option opt switch = (switch, opt)-  sel o@(Compose (Option _ switches _ _)) = map (add_option o) switches+  sel o = map (add_option o) (optionSwitches o)  -- | List of option switches of all commands (except help but that has no options). allOptionSwitches :: [String]-allOptionSwitches = nub $ optionSwitches $+allOptionSwitches = nub $ concatMap optionSwitches $   concatMap (uncurry (++) . commandAlloptions) $             extractAllCommands commandControlList
src/Darcs/UI/External.hs view
@@ -30,7 +30,6 @@ #ifndef WIN32 import Control.Monad ( liftM2 ) #endif-import Control.Concurrent.MVar ( MVar ) import System.Exit ( ExitCode(..) ) import System.Environment     ( getEnv@@ -41,7 +40,6 @@     ( Handle     , hClose     , hIsTerminalDevice-    , hPutStr     , stderr     , stdout     )@@ -49,7 +47,6 @@ import System.FilePath.Posix ( (</>) ) #endif import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) )-import System.Process.Internals ( ProcessHandle )  #ifndef WIN32 import GHC.IO.Encoding@@ -64,8 +61,10 @@ import GHC.IO.Exception ( IOErrorType(ResourceVanished) ) #ifdef WIN32 import Foreign.C ( withCString )+import Foreign.C.String ( CString ) import Foreign.Ptr ( nullPtr )-import Darcs.Util.Lock ( canonFilename, writeDocBinFile )+import Darcs.Util.Lock ( writeDocBinFile )+import System.Directory ( canonicalizePath ) #endif  import Darcs.UI.Options.All ( Sign(..), Verify(..), Compression(..) )@@ -80,11 +79,8 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import Darcs.Util.Lock-    ( withTemp-    , withNamedTemp-    , withOpenTemp-    )+import Darcs.Util.File ( withOpenTemp, withTemp )+import Darcs.Util.Lock ( withNamedTemp ) import Darcs.Util.Ssh ( getSSH, SSHCmd(..) ) import Darcs.Util.CommandLine ( parseCmd, addUrlencoded ) #ifndef WIN32@@ -107,7 +103,6 @@     , simplePrinters     , text     )-import qualified Darcs.Util.Ratified as Ratified import Darcs.UI.Email ( formatHeader )  #ifndef WIN32@@ -224,7 +219,7 @@                hPutDoc h body                hClose h                writeDocBinFile "mailed_patch" body-               cfn <- canonFilename fn+               cfn <- canonicalizePath fn                withCString cfn $ \pcfn ->                 c_send_email fp tp ccp sp nullPtr pcfn   when (r /= 0) $ do@@ -267,7 +262,9 @@   case parseCmd (addUrlencoded ftable) scmd of     Right (arg0:opts, wantstdin) ->       let stdin = if wantstdin then File fn else Null-      in exec arg0 opts (stdin, Null, AsIs)+      in do+        debugMessage $ unwords $ "execSendmail:" : map show (arg0 : opts)+        exec arg0 opts (stdin, Null, AsIs)     Right ([], _) ->       fail $ "Invalid sendmail-command "++show scmd     Left e ->@@ -285,31 +282,24 @@ #endif  execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString-execPSPipe c args ps = fmap renderPS-                     $ execDocPipe c args-                     $ packedString ps--execAndGetOutput :: FilePath -> [String] -> Doc-                 -> IO (ProcessHandle, MVar (), B.ByteString)-execAndGetOutput c args instr = do-       (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing-       _ <- forkIO $ hPutDoc i instr >> hClose i-       mvare <- newEmptyMVar-       _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed-                hPutStr stderr)-               `finally` putMVar mvare ())-       out <- B.hGetContents o-       return (pid, mvare, out)+execPSPipe command args input =+  withoutProgress $ do+    (hi, ho, he, pid) <- runInteractiveProcess command args Nothing Nothing+    _ <- forkIO $ B.hPut hi input >> hClose hi+    done <- newEmptyMVar+    _ <- forkIO $ (B.hGetContents he >>= B.hPut stderr) `finally` putMVar done ()+    output <- B.hGetContents ho+    rval <- waitForProcess pid+    takeMVar done+    case rval of+      ExitFailure ec ->+        fail $+        "External program '" ++ command ++ "' failed with exit code " ++ show ec+      ExitSuccess -> return output  execDocPipe :: String -> [String] -> Doc -> IO Doc-execDocPipe c args instr = withoutProgress $ do-       (pid, mvare, out) <- execAndGetOutput c args instr-       rval <- waitForProcess pid-       takeMVar mvare-       case rval of-         ExitFailure ec ->fail $ "External program '"++c++-                          "' failed with exit code "++ show ec-         ExitSuccess -> return $ packedString out+execDocPipe command args input =+  packedString <$> execPSPipe command args (renderPS input)  signString :: Sign -> Doc -> IO Doc signString NoSign d = return d@@ -404,12 +394,11 @@      then do mbViewerPlusArgs <- getViewer              case mbViewerPlusArgs of                   Just viewerPlusArgs -> do-                    let (viewer : args) = words viewerPlusArgs-                    pipeDocToPager viewer args pr msg+                    case words viewerPlusArgs of+                      [] -> pipeDocToPager "" [] pr msg+                      (viewer : args) -> pipeDocToPager viewer args pr msg                   Nothing -> return $ ExitFailure 127 -- No such command-               -- TEMPORARY passing the -K option should be removed as soon as-               -- we can use the delegate_ctrl_c feature in process-               `ortryrunning` pipeDocToPager  "less" ["-RK"] pr msg+               `ortryrunning` pipeDocToPager  "less" ["-R"] pr msg                `ortryrunning` pipeDocToPager  "more" [] pr msg #ifdef WIN32                `ortryrunning` pipeDocToPager  "more.com" [] pr msg
src/Darcs/UI/Flags.hs view
@@ -22,17 +22,10 @@ -- renamed and the re-exports from "Darcs.UI.Options.All" removed. module Darcs.UI.Flags     ( F.DarcsFlag-    , remoteDarcs     , diffingOpts-    , diffOpts-    , scanKnown     , wantGuiPause     , isInteractive     , willRemoveLogFile-    , includeBoring-    , lookForAdds-    , lookForMoves-    , lookForReplaces     , setDefault     , allowConflicts     , hasXmlOutput@@ -41,7 +34,6 @@     , verbose     , enumeratePatches -    , fixRemoteRepos     , fixUrl     , pathsFromArgs     , pathSetFromArgs@@ -62,12 +54,10 @@     , withNewRepo      -- * Re-exports-    , O.compress     , O.diffAlgorithm     , O.reorder     , O.minimize     , O.editDescription-    , O.externalMerge     , O.maxCount     , O.matchAny     , O.withContext@@ -82,12 +72,10 @@     , O.useIndex     , O.umask     , O.dryRun-    , O.runTest     , O.testChanges     , O.setScriptsExecutable     , O.withWorkingDir     , O.leaveTestDir-    , O.remoteRepos     , O.cloneKind     , O.patchIndexNo     , O.patchIndexYes@@ -111,19 +99,17 @@     , isNothing     , catMaybes     )-import Control.Monad ( unless )-import System.Directory ( doesDirectoryExist, createDirectory )+import Control.Monad ( void, unless )+import System.Directory ( createDirectory, doesDirectoryExist, withCurrentDirectory ) import System.FilePath.Posix ( (</>) ) import System.Environment ( lookupEnv )+import System.Posix.Files ( getSymbolicLinkStatus ) --- Use of RemoteRepo data constructor is harmless here, if not ideal.--- See haddocks for fixRemoteRepos below for details.-import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(RemoteRepo) )+import qualified Darcs.UI.Options.Flags as F ( DarcsFlag ) import Darcs.UI.Options ( Config, (?), (^), oparse, parseFlags, unparseOpt ) import qualified Darcs.UI.Options.All as O -import Darcs.Util.Exception ( catchall )-import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Exception ( catchall, ifDoesNotExistError ) import Darcs.Util.Prompt     ( askUser     , askUserListItem@@ -131,7 +117,8 @@ import Darcs.Util.Lock ( writeTextFile ) import Darcs.Repository.Flags ( WorkRepo(..) ) import Darcs.Repository.Prefs-    ( getPreflist+    ( Pref(Author)+    , getPreflist     , getGlobal     , globalPrefsDirDoc     , globalPrefsDir@@ -141,13 +128,14 @@ import Darcs.Util.Path     ( AbsolutePath     , AbsolutePathOrStd-    , toFilePath-    , makeSubPathOf-    , ioAbsolute-    , makeAbsoluteOrStd     , AnchoredPath     , floatSubPath     , inDarcsdir+    , ioAbsolute+    , makeAbsolute+    , makeAbsoluteOrStd+    , makeRelativeTo+    , toFilePath     ) import Darcs.Util.Printer ( pathlist, putDocLn, text, ($$), (<+>) ) import Darcs.Util.Printer.Color ( ePutDocLn )@@ -159,25 +147,17 @@ quiet :: Config -> Bool quiet = (== O.Quiet) . parseFlags O.verbosity -remoteDarcs :: Config -> O.RemoteDarcs-remoteDarcs = O.remoteDarcs . parseFlags O.network- enumeratePatches :: Config -> Bool enumeratePatches = (== O.YesEnumPatches) . parseFlags O.enumPatches -diffOpts :: O.UseIndex -> O.LookForAdds -> O.IncludeBoring -> O.DiffAlgorithm -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)-diffOpts use_index look_for_adds include_boring diff_alg =-    (use_index, scanKnown look_for_adds include_boring, diff_alg)---- | Non-trivial interaction between options.-scanKnown :: O.LookForAdds -> O.IncludeBoring -> O.ScanKnown-scanKnown O.NoLookForAdds _ = O.ScanKnown-scanKnown O.YesLookForAdds O.NoIncludeBoring = O.ScanAll-scanKnown O.YesLookForAdds O.YesIncludeBoring = O.ScanBoring--diffingOpts :: Config -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)-diffingOpts flags = diffOpts (O.useIndex ? flags) (lookForAdds flags)-    (parseFlags O.includeBoring flags) (O.diffAlgorithm ? flags)+diffingOpts :: Config -> O.DiffOpts+diffingOpts flags =+  O.DiffOpts+    (O.useIndex ? flags)+    (O.lookforadds ? flags)+    (O.lookforreplaces ? flags)+    (O.lookformoves ? flags)+    (O.diffAlgorithm ? flags)  -- | This will become dis-entangled as soon as we inline these functions. wantGuiPause :: Config -> O.WantGuiPause@@ -187,7 +167,10 @@     else O.NoWantGuiPause   where     hasDiffCmd = isJust . O.diffCmd . parseFlags O.extDiff-    hasExternalMerge = (/= O.NoExternalMerge) . parseFlags O.externalMerge+    hasExternalMerge flags =+      case O.conflictsNo ? flags of+        Just (O.YesAllowConflicts (O.ExternalMerge _)) -> True+        _ -> False     hasPause = (== O.YesWantGuiPause) . parseFlags O.pauseForGui  -- | Non-trivial interaction between options. Explicit @-i@ or @-a@ dominates,@@ -206,20 +189,6 @@ willRemoveLogFile :: Config -> Bool willRemoveLogFile = O._rmlogfile . parseFlags O.logfile -includeBoring :: Config -> Bool-includeBoring cfg = case parseFlags O.includeBoring cfg of-  O.NoIncludeBoring -> False-  O.YesIncludeBoring -> True--lookForAdds :: Config -> O.LookForAdds-lookForAdds = O.adds . parseFlags O.lookfor--lookForReplaces :: Config -> O.LookForReplaces-lookForReplaces = O.replaces . parseFlags O.lookfor--lookForMoves :: Config -> O.LookForMoves-lookForMoves = O.moves . parseFlags O.lookfor- setDefault :: Bool -> Config -> O.SetDefault setDefault defYes = maybe def noDef . parseFlags O.setDefault where   def = if defYes then O.YesSetDefault False else O.NoSetDefault False@@ -228,21 +197,14 @@ allowConflicts :: Config -> O.AllowConflicts allowConflicts = maybe O.NoAllowConflicts id . parseFlags O.conflictsNo --- | Ugly. The alternative is to put the remoteRepos accessor into the IO monad,--- which is hardly better.--- However, accessing the flag list directly here is benign, as we only map--- over the list and don't change the order.-fixRemoteRepos :: AbsolutePath -> Config -> IO Config-fixRemoteRepos d = mapM fixRemoteRepo where-  fixRemoteRepo (F.RemoteRepo p) = F.RemoteRepo `fmap` fixUrl d p-  fixRemoteRepo f = return f---- | 'fixUrl' takes a String that may be a file path or a URL.--- It returns either the URL, or an absolute version of the path.+-- | The first argument is an 'AbsolutePath', the second a 'String' that may be+-- a file path or a URL. It returns either the URL, or an absolute version of+-- the path, interpreted relative to the first argument. fixUrl :: AbsolutePath -> String -> IO String-fixUrl d f = if isValidLocalPath f-                then toFilePath `fmap` withCurrentDirectory d (ioAbsolute f)-                else return f+fixUrl d f =+  if isValidLocalPath f+    then withCurrentDirectory (toFilePath d) (toFilePath <$> ioAbsolute f)+    else return f  -- TODO move the following four functions somewhere else, -- they have nothing to do with flags@@ -301,12 +263,19 @@     -- special case here because fixit otherwise converts     -- "" to (SubPath "."), which is a valid path     fixit "" = return Nothing-    fixit p = do ap <- withCurrentDirectory o $ ioAbsolute p-                 case makeSubPathOf r ap of-                   Just sp -> return $ Just $ floatSubPath sp-                   Nothing -> do-                     absolutePathByRepodir <- withCurrentDirectory r $ ioAbsolute p-                     return $ floatSubPath <$> makeSubPathOf r absolutePathByRepodir+    fixit p = do+      -- raise an exception if the given path has a trailing pathSeparator+      -- but refers to an existing non-directory+      ifDoesNotExistError () $ void (getSymbolicLinkStatus p)+      msp <- makeRelativeTo r (makeAbsolute o p)+      case msp of+        Just sp -> return $ floatIt sp+        Nothing -> do+          msp' <- makeRelativeTo r (makeAbsolute r p)+          case msp' of+            Nothing -> return Nothing+            Just sp' -> return $ floatIt sp'+    floatIt = either (const Nothing) Just . floatSubPath  -- | 'getRepourl' takes a list of flags and returns the url of the -- repository specified by @Repodir \"directory\"@ in that list of flags, if any.@@ -415,8 +384,8 @@ -- possibilities when reading from global preferences. getEasyAuthor :: IO [String] getEasyAuthor =-  firstNotNullIO [ (take 1 . nonblank) `fmap` getPreflist "author"-                 , nonblank    `fmap` getGlobal "author"+  firstNotNullIO [ (take 1 . nonblank) `fmap` getPreflist Author+                 , nonblank    `fmap` getGlobal Author                  , maybeToList `fmap` lookupEnv "DARCS_EMAIL"                  , maybeToList `fmap` lookupEnv "EMAIL"                  ]@@ -460,11 +429,13 @@     Nothing -> lookupEnv "SENDMAIL"     justcmd -> return justcmd --- | Accessor for output option-getOutput :: Config -> FilePath -> Maybe AbsolutePathOrStd+-- | Accessor for output option. Takes and returns IO actions+-- so that the default value is only calculated if needed,+-- as it might involve filesystem actions that can fail.+getOutput :: Config -> IO FilePath -> Maybe (IO AbsolutePathOrStd) getOutput fs fp = fmap go (parseFlags O.output fs) where-  go (O.Output ap)         = ap-  go (O.OutputAutoName ap) = makeAbsoluteOrStd ap fp+  go (O.Output ap)         = return ap+  go (O.OutputAutoName ap) = makeAbsoluteOrStd ap <$> fp  -- |'getSubject' takes a list of flags and returns the subject of the mail -- to be sent by @darcs send@. Looks for a subject specified by
src/Darcs/UI/Options.hs view
@@ -5,6 +5,7 @@     , DarcsOptDescr     , optDescr     , Config+    , withDashes     ) where  import Darcs.Prelude@@ -14,7 +15,7 @@  import Darcs.UI.Options.All ( DarcsOption ) import Darcs.UI.Options.Core-import Darcs.UI.Options.Util ( DarcsOptDescr, Flag, PrimDarcsOption )+import Darcs.UI.Options.Util ( DarcsOptDescr, Flag, PrimDarcsOption, withDashes ) import Darcs.Util.Path ( AbsolutePath )  -- | Instantiate a 'DarcsOptDescr' with an 'AbsolutePath'
src/Darcs/UI/Options/All.hs view
@@ -42,8 +42,8 @@     , verbosity     , timings     , debugging-    , HooksConfig (..) -- re-export-    , HookConfig (..) -- re-export+    , HooksConfig (..)+    , HookConfig (..)     , preHook     , postHook     , hooks@@ -71,8 +71,6 @@      -- local or remote repo(s)     , repoDir-    , RemoteRepos (..) -- re-export-    , remoteRepos     , possiblyRemoteRepo     , newRepo     , NotInRemote (..)@@ -88,6 +86,8 @@     , setDefault     , InheritDefault (..) -- re-export     , inheritDefault+    , WithPrefsTemplates (..) -- re-export+    , withPrefsTemplates      -- patch meta-data     , patchname@@ -99,20 +99,18 @@     , logfile      -- looking for changes-    , LookFor (..)+    , UseIndex (..) -- re-export+    , includeBoring     , LookForAdds (..) -- re-export     , LookForMoves (..) -- re-export     , LookForReplaces (..) -- re-export-    , lookfor+    , DiffOpts (..)     , lookforadds+    , maybelookforadds     , lookforreplaces     , lookformoves      -- files to consider-    , UseIndex (..) -- re-export-    , ScanKnown (..) -- re-export-    , IncludeBoring (..)-    , includeBoring     , allowProblematicFilenames     , allowCaseDifferingFilenames     , allowWindowsReservedFilenames@@ -132,7 +130,6 @@     , TestChanges (..)     , testChanges     , RunTest (..) -- re-export-    , runTest     , LeaveTestDir (..) -- re-export     , leaveTestDir @@ -156,12 +153,12 @@     , AllowConflicts (..) -- re-export     , conflictsNo     , conflictsYes-    , ExternalMerge (..) -- re-export-    , externalMerge+    , ResolveConflicts (..) -- re-export     , reorder+    , reorderPush      -- optimizations-    , Compression (..) -- re-export+    , Compression (..)     , compress     , usePacks     , WithPatchIndex (..) -- re-export@@ -170,6 +167,8 @@     , Reorder (..) -- re-export     , minimize     , storeInMemory+    , OptimizeDeep (..)+    , optimizeDeep      -- miscellaneous     , Output (..)@@ -178,8 +177,7 @@     , withSummary     , maybeSummary     , RemoteDarcs (..) -- re-export-    , NetworkOptions (..)-    , network+    , remoteDarcs     , UMask (..) -- re-export     , umask     , SetScriptsExecutable (..) -- re-export@@ -221,6 +219,8 @@     -- test     , TestStrategy (..)     , testStrategy+    , ShrinkFailure (..)+    , shrinkFailure      -- show files/index     , files@@ -243,8 +243,7 @@ import Darcs.Prelude  import Darcs.Repository.Flags-    ( Compression (..)-    , RemoteDarcs (..)+    ( RemoteDarcs (..)     , Reorder (..)     , Verbosity (..)     , UseCache (..)@@ -254,24 +253,22 @@     , LookForMoves (..)     , LookForReplaces (..)     , DiffAlgorithm (..)+    , DiffOpts (..)     , RunTest (..)     , SetScriptsExecutable (..)     , LeaveTestDir (..)-    , RemoteRepos (..)     , SetDefault (..)     , InheritDefault (..)     , UseIndex (..)-    , ScanKnown (..)     , CloneKind (..)-    , ExternalMerge (..)     , AllowConflicts (..)+    , ResolveConflicts (..)     , WantGuiPause (..)     , WithPatchIndex (..)     , WithWorkingDir (..)     , PatchFormat (..)-    , IncludeBoring (..)-    , HooksConfig (..)-    , HookConfig (..)+    , WithPrefsTemplates(..)+    , OptimizeDeep(..)     )  import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) )@@ -283,8 +280,7 @@ -- * Type instantiations  -- | 'DarcsOption' instantiates the first two type parameters of 'OptSpec' to--- what we need in darcs. The first parameter is instantiated to--- The flag type is instantiate to 'Flag'.+-- what we need in darcs. type DarcsOption = OptSpec DarcsOptDescr Flag  type RawDarcsOption = forall v. v -> RawOptSpec Flag v@@ -319,6 +315,7 @@ instance YesNo LookForAdds where   yes NoLookForAdds = False   yes YesLookForAdds = True+  yes EvenLookForBoring = True  instance YesNo LookForReplaces where   yes NoLookForReplaces = False@@ -328,10 +325,6 @@   yes NoLookForMoves = False   yes YesLookForMoves = True -instance YesNo IncludeBoring where-  yes NoIncludeBoring = False-  yes YesIncludeBoring = True- instance YesNo RunTest where   yes NoRunTest = False   yes YesRunTest = True@@ -366,6 +359,10 @@   yes NoInheritDefault = False   yes YesInheritDefault = True +instance YesNo WithPrefsTemplates where+  yes NoPrefsTemplates = False+  yes WithPrefsTemplates = True+ -- * Root command  -- | Options for darcs iself that act like sub-commands.@@ -402,9 +399,6 @@ debug :: PrimDarcsOption Bool debug = singleNoArg [] ["debug"] F.Debug "enable general debug output" -debugHttp :: PrimDarcsOption Bool-debugHttp = singleNoArg [] ["debug-http"] F.DebugHTTP "debug output from libcurl"- verbosity :: PrimDarcsOption Verbosity verbosity = withDefault NormalVerbosity   [ RawNoArg ['q'] ["quiet"] F.Quiet Quiet "suppress informational output"@@ -415,11 +409,21 @@ timings :: PrimDarcsOption Bool timings = singleNoArg [] ["timings"] F.Timings "provide debugging timings information" -debugging :: DarcsOption a (Bool -> Bool -> Bool -> a)-debugging = debug ^ debugHttp ^ timings+debugging :: DarcsOption a (Bool -> Bool -> a)+debugging = debug ^ timings  -- ** Hooks +data HooksConfig = HooksConfig+  { pre :: HookConfig+  , post :: HookConfig+  }++data HookConfig = HookConfig+  { cmd :: Maybe String+  , prompt :: Bool+  }+ hooks :: DarcsOption a (HooksConfig -> a) hooks = imap (Iso fw bw) $ preHook ^ postHook where   fw k (HooksConfig pr po) = k pr po@@ -497,7 +501,7 @@  dryRun :: PrimDarcsOption DryRun dryRun = withDefault NoDryRun-  [ RawNoArg [] ["dry-run"] F.DryRun YesDryRun "don't actually take the action" ]+  [ RawNoArg ['n'] ["dry-run"] F.DryRun YesDryRun "don't actually take the action" ]  dryRunXml :: DarcsOption a (DryRun -> XmlOutput -> a) dryRunXml = dryRun ^ xmlOutput@@ -573,13 +577,6 @@   where arg (F.WorkRepoUrl s) = Just s         arg _ = Nothing -remoteRepos :: PrimDarcsOption RemoteRepos-remoteRepos = (imap . cps) (Iso fw bw) $ multiStrArg [] ["remote-repo"] F.RemoteRepo mkV "URL"-    "specify the remote repository URL to work with"-  where mkV fs = [ s | F.RemoteRepo s <- fs ]-        fw ss = RemoteRepos ss-        bw (RemoteRepos ss) = ss- notInRemoteFlagName :: String notInRemoteFlagName = "not-in-remote" @@ -636,6 +633,12 @@   [ RawNoArg [] ["inherit-default"] F.InheritDefault YesInheritDefault "inherit default repository"   , RawNoArg [] ["no-inherit-default"] F.NoInheritDefault NoInheritDefault "don't inherit default repository" ] +withPrefsTemplates :: PrimDarcsOption WithPrefsTemplates+withPrefsTemplates = withDefault WithPrefsTemplates+  [ RawNoArg [] ["with-prefs-templates"] F.WithPrefsTemplates WithPrefsTemplates "create template-filled preferences"+  , RawNoArg [] ["no-prefs-templates"] F.NoPrefsTemplates NoPrefsTemplates "create empty preferences"+  ]+ -- * Specifying patch meta-data  patchname :: PrimDarcsOption (Maybe String)@@ -695,23 +698,17 @@  -- * Looking for changes -data LookFor = LookFor-  { adds :: LookForAdds-  , replaces :: LookForReplaces-  , moves :: LookForMoves-  }--lookfor :: PrimDarcsOption LookFor-lookfor = imap (Iso fw bw) (lookforadds NoLookForAdds ^ lookforreplaces ^ lookformoves) where-  fw k (LookFor a r m) = k a r m-  bw k a r m = k (LookFor a r m)+lookforadds :: PrimDarcsOption LookForAdds+lookforadds = maybelookforadds NoLookForAdds -lookforadds :: LookForAdds -> PrimDarcsOption LookForAdds-lookforadds def = withDefault def-  [ RawNoArg ['l'] ["look-for-adds"] F.LookForAdds YesLookForAdds-    "look for (non-boring) files that could be added"-  , RawNoArg [] ["dont-look-for-adds","no-look-for-adds"] F.NoLookForAdds NoLookForAdds-    "don't look for any files that could be added" ]+maybelookforadds :: LookForAdds -> PrimDarcsOption LookForAdds+maybelookforadds def = withDefault def+  [ RawNoArg [] ["dont-look-for-adds","no-look-for-adds"] F.NoLookForAdds NoLookForAdds+    "don't look for files that could be added"+  , RawNoArg ['l'] ["look-for-adds"] F.LookForAdds YesLookForAdds+    "look for files that could be added"+  , RawNoArg [] ["boring"] F.Boring EvenLookForBoring+    "look for any file that could be added, even boring files" ]  lookforreplaces :: PrimDarcsOption LookForReplaces lookforreplaces = withDefault NoLookForReplaces@@ -738,10 +735,10 @@   bw UseIndex = False   bw IgnoreIndex = True -includeBoring :: PrimDarcsOption IncludeBoring-includeBoring = withDefault NoIncludeBoring-  [ RawNoArg [] ["boring"] F.Boring YesIncludeBoring "don't skip boring files"-  , RawNoArg [] ["no-boring"] F.SkipBoring NoIncludeBoring "skip boring files" ]+includeBoring :: PrimDarcsOption Bool+includeBoring = withDefault False+  [ RawNoArg [] ["boring"] F.Boring True "don't skip boring files"+  , RawNoArg [] ["no-boring"] F.SkipBoring False "skip boring files" ]  allowProblematicFilenames :: DarcsOption a (Bool -> Bool -> a) allowProblematicFilenames = allowCaseDifferingFilenames ^ allowWindowsReservedFilenames@@ -808,7 +805,7 @@  data ExternalDiff = ExternalDiff   { diffCmd :: Maybe String-  , diffOpts :: [String]+  , diffOptions :: [String]   , diffUnified :: Bool   } deriving (Eq, Show) @@ -833,19 +830,19 @@   [ RawNoArg ['u'] ["unified"] F.Unified True "pass -u option to diff"   , RawNoArg  [] ["no-unified"] F.NonUnified False "output patch in diff's dumb format" ] --- * Runnign tests+-- * Running tests  data TestChanges = NoTestChanges | YesTestChanges LeaveTestDir deriving (Eq)  testChanges :: PrimDarcsOption TestChanges-testChanges = imap (Iso fw bw) $ runTest ^ leaveTestDir where+testChanges = imap (Iso fw bw) $ __runTest ^ leaveTestDir where   fw k NoTestChanges = k NoRunTest NoLeaveTestDir   fw k (YesTestChanges ltd) = k YesRunTest ltd   bw k NoRunTest _ = k NoTestChanges   bw k YesRunTest ltd = k (YesTestChanges ltd) -runTest :: PrimDarcsOption RunTest-runTest = withDefault NoRunTest+__runTest :: PrimDarcsOption RunTest+__runTest = withDefault NoRunTest   [ RawNoArg [] ["test"] F.Test YesRunTest "run the test script"   , RawNoArg [] ["no-test"] F.NoTest NoRunTest "don't run the test script" ] @@ -976,33 +973,27 @@ conflictsNo :: PrimDarcsOption (Maybe AllowConflicts) conflictsNo = conflicts NoAllowConflicts --- | pull, rebase pull: default to 'YesAllowConflictsAndMark'+-- | pull, rebase pull: default to 'YesAllowConflicts' 'MarkConflicts' conflictsYes :: PrimDarcsOption (Maybe AllowConflicts)-conflictsYes = conflicts YesAllowConflictsAndMark+conflictsYes = conflicts (YesAllowConflicts MarkConflicts)  conflicts :: AllowConflicts -> PrimDarcsOption (Maybe AllowConflicts) conflicts def = withDefault (Just def)   [ RawNoArg [] ["mark-conflicts"]-      F.MarkConflicts (Just YesAllowConflictsAndMark) "mark conflicts"+      F.MarkConflicts (Just (YesAllowConflicts MarkConflicts)) "mark conflicts"   , RawNoArg [] ["allow-conflicts"]-      F.AllowConflicts (Just YesAllowConflicts) "allow conflicts, but don't mark them"+      F.AllowConflicts (Just (YesAllowConflicts NoResolveConflicts))+      "allow conflicts, but don't mark them"+  , RawStrArg [] ["external-merge"]+    F.ExternalMerge (\f -> [s | F.ExternalMerge s <- [f]])+    (Just . YesAllowConflicts . ExternalMerge)+    (\v -> [s | Just (YesAllowConflicts (ExternalMerge s)) <- [v]])+    "COMMAND" "use external tool to merge conflicts"   , RawNoArg [] ["dont-allow-conflicts","no-allow-conflicts","no-resolve-conflicts"]       F.NoAllowConflicts (Just NoAllowConflicts) "fail if there are patches that would create conflicts"   , RawNoArg [] ["skip-conflicts"]       F.SkipConflicts Nothing "filter out any patches that would create conflicts" ] --- Technically not an isomorphism.-externalMerge :: PrimDarcsOption ExternalMerge-externalMerge = imap (Iso fw bw) $ singleStrArg [] ["external-merge"] F.ExternalMerge arg-    "COMMAND" "use external tool to merge conflicts"-  where-    arg (F.ExternalMerge s) = Just s-    arg _ = Nothing-    bw k (Just s) = k (YesExternalMerge s)-    bw k Nothing = k NoExternalMerge-    fw k (YesExternalMerge s) = k (Just s)-    fw k NoExternalMerge = k Nothing- -- | pull, apply, rebase pull, rebase apply reorder :: PrimDarcsOption Reorder reorder = withDefault NoReorder@@ -1011,8 +1002,20 @@   , RawNoArg [] ["no-reorder-patches"] F.NoReorder NoReorder     "put remote-only patches on top of local ones" ] +-- | push; same as 'reorder' but with help descriptions swapped+reorderPush :: PrimDarcsOption Reorder+reorderPush = withDefault NoReorder+  [ RawNoArg [] ["reorder-patches"] F.Reorder Reorder+    "put remote-only patches on top of local ones"+  , RawNoArg [] ["no-reorder-patches"] F.NoReorder NoReorder+    "put local-only patches on top of remote ones" ]+ -- * Optimizations +data Compression = NoCompression | GzipCompression+  deriving ( Eq, Show )++-- | push compress :: PrimDarcsOption Compression compress = withDefault GzipCompression   [ RawNoArg [] ["compress"] F.Compress GzipCompression "compress patch data"@@ -1043,6 +1046,13 @@   , RawNoArg [] ["no-store-in-memory"] F.ApplyOnDisk False     "do patch application on disk" ] +optimizeDeep :: PrimDarcsOption OptimizeDeep+optimizeDeep = withDefault OptimizeShallow+  [ RawNoArg [] ["deep"] F.OptimizeDeep OptimizeDeep+    "also optimize clean tags in the complete history"+  , RawNoArg [] ["shallow"] F.OptimizeShallow OptimizeShallow+    "only reorder recent patches (works with lazy repo)" ]+ -- * Output  data Output = Output AbsolutePathOrStd@@ -1091,25 +1101,17 @@   [ RawNoArg ['s'] ["summary"] F.Summary (Just YesSummary) "summarize changes"   , RawNoArg [] ["no-summary"] F.NoSummary (Just NoSummary) "don't summarize changes" ] --- | TODO: reconsider this grouping of options-data NetworkOptions = NetworkOptions-  { noHttpPipelining :: Bool-  , remoteDarcs :: RemoteDarcs }--networkIso :: Iso (Bool -> Maybe String -> a) (NetworkOptions -> a)-networkIso = Iso fw bw where-  fw k (NetworkOptions x (RemoteDarcs y)) = k x (Just y)-  fw k (NetworkOptions x DefaultRemoteDarcs) = k x Nothing-  bw k x (Just y) = k (NetworkOptions x (RemoteDarcs y))-  bw k x Nothing = k (NetworkOptions x DefaultRemoteDarcs)--network :: PrimDarcsOption NetworkOptions-network = imap networkIso-  $ singleNoArg [] ["no-http-pipelining"] F.NoHTTPPipelining "disable HTTP pipelining"-  ^ singleStrArg [] ["remote-darcs"] F.RemoteDarcsOpt arg "COMMAND"+remoteDarcs :: PrimDarcsOption RemoteDarcs+remoteDarcs = imap (Iso fw bw)+  $ singleStrArg [] ["remote-darcs"] F.RemoteDarcsOpt arg "COMMAND"     "name of the darcs executable on the remote server"-  where arg (F.RemoteDarcsOpt s) = Just s-        arg _ = Nothing+  where+    arg (F.RemoteDarcsOpt s) = Just s+    arg _ = Nothing+    fw k (RemoteDarcs y) = k (Just y)+    fw k DefaultRemoteDarcs = k Nothing+    bw k (Just y) = k (RemoteDarcs y)+    bw k Nothing = k DefaultRemoteDarcs  umask :: PrimDarcsOption UMask umask = (imap . cps) (Iso fw bw) $ singleStrArg [] ["umask"] F.UMask arg "UMASK"@@ -1164,17 +1166,17 @@  -- ** convert import/export -marks :: DarcsOption a (Maybe String -> Maybe String -> a)+marks :: DarcsOption a (Maybe AbsolutePath -> Maybe AbsolutePath -> a) marks = readMarks ^ writeMarks -readMarks :: PrimDarcsOption (Maybe String)-readMarks = singleStrArg [] ["read-marks"] F.ReadMarks arg+readMarks :: PrimDarcsOption (Maybe AbsolutePath)+readMarks = singleAbsPathArg [] ["read-marks"] F.ReadMarks arg     "FILE" "continue conversion, previously checkpointed by --write-marks"   where arg (F.ReadMarks s) = Just s         arg _ = Nothing -writeMarks :: PrimDarcsOption (Maybe String)-writeMarks = singleStrArg [] ["write-marks"] F.WriteMarks arg+writeMarks :: PrimDarcsOption (Maybe AbsolutePath)+writeMarks = singleAbsPathArg [] ["write-marks"] F.WriteMarks arg     "FILE" "checkpoint conversion to continue it later"   where arg (F.WriteMarks s) = Just s         arg _ = Nothing@@ -1249,6 +1251,16 @@   , RawNoArg [] ["linear"] F.Linear Linear "locate the most recent version lacking an error"   , RawNoArg [] ["backoff"] F.Backoff Backoff "exponential backoff search"   , RawNoArg [] ["bisect"] F.Bisect Bisect "binary instead of linear search" ]++data ShrinkFailure = ShrinkFailure | NoShrinkFailure deriving (Eq, Show)++shrinkFailure :: PrimDarcsOption ShrinkFailure+shrinkFailure = withDefault ShrinkFailure+  [ RawNoArg [] ["shrink-failure"] F.ShrinkFailure ShrinkFailure+      "try to cut down the set of patches causing a test failure"+  , RawNoArg [] ["no-shrink-failure"] F.NoShrinkFailure NoShrinkFailure+      "don't try to cut down the set of patches causing a test failure"+  ]  -- ** show files
src/Darcs/UI/Options/Core.hs view
@@ -37,6 +37,8 @@  -- * Option specifications +data OptMsg = OptWarning String | OptError String+ {-| A type for option specifications.  It consists of four components: a parser, an unparser, a checker, and a list@@ -130,7 +132,7 @@   , oparse :: b -> ([f] -> a)     -- ^ Convert flag list to option value, in CPS. Note: as a pure     -- function, it is not supposed to fail.-  , ocheck :: [f] -> [String]+  , ocheck :: [f] -> [OptMsg]     -- ^ Check for erros in a flag list, returns error messages.   , odesc :: [d f]     -- ^ Descriptions, one for each flag that makes up the option.@@ -284,7 +286,7 @@  -- | See 'oappend' and 'oempty'. instance Monoid (PrimOptSpec d f a [v]) where-  mappend = oappend+  mappend = (<>)   mempty = oempty  -- | Parse a list of flags against a primitive option spec, returning the
src/Darcs/UI/Options/Flags.hs view
@@ -20,13 +20,14 @@                | Subject String | InReplyTo String | Charset String                | SendmailCmd String | Author String | SelectAuthor | PatchName String                | OnePatch String | SeveralPatch String-               | OneHash String                | AfterPatch String | UpToPatch String-               | AfterHash String | UpToHash String-               | TagName String | LastN String | MaxCount String+               | OnePattern String | SeveralPattern String+               | AfterPattern String | UpToPattern String+               | OneHash String | AfterHash String | UpToHash String+               | OneTag String | SeveralTag String | AfterTag String | UpToTag String+               | LastN String | MaxCount String                | IndexRange String | OneIndex String                | NumberPatches-               | OneTag String | AfterTag String | UpToTag String                | GenContext | Context AbsolutePath | Count                | LogFile AbsolutePath | RmLogFile | DontRmLogFile                | DistName String | DistZip | All@@ -55,7 +56,7 @@                | AllowWindowsReserved | DontAllowWindowsReserved                | DontGrabDeps | DontPromptForDependencies | PromptForDependencies                | Compress | NoCompress | UnCompress-               | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String+               | WorkRepoDir String | WorkRepoUrl String                | NewRepo String                | NotInRemote (Maybe String)                | Reply String | ApplyAs String@@ -69,14 +70,13 @@                | DiffFlags String                | XMLOutput                | ForceReplace-               | OnePattern String | SeveralPattern String-               | AfterPattern String | UpToPattern String                | NonApply | NonVerify | NonForce                | DryRun                | InheritDefault | NoInheritDefault                | SetDefault | NoSetDefault                | Disable | SetScriptsExecutable | DontSetScriptsExecutable                | Once | Linear | Backoff | Bisect+               | ShrinkFailure | NoShrinkFailure                | Hashed -- deprecated flag, here to output an error message                | UseFormat1 | UseFormat2 | UseFormat3                | UseNoWorkingDir | UseWorkingDir@@ -92,10 +92,12 @@                | NoCache                | AllowUnrelatedRepos                | Check | Repair | JustThisRepo-               | ReadMarks String | WriteMarks String+               | ReadMarks AbsolutePath | WriteMarks AbsolutePath                | NullFlag                | NoAmendUnrecord | AmendUnrecord                | PatchIndexFlag                | NoPatchIndexFlag                | EnumPatches | NoEnumPatches+               | WithPrefsTemplates | NoPrefsTemplates+               | OptimizeDeep | OptimizeShallow                  deriving ( Eq, Show )
src/Darcs/UI/Options/Matching.hs view
@@ -128,7 +128,7 @@   oparse k fs = k [ UpToHash s | F.UpToHash s <- fs ]   ocheck _ = []   odesc = [ strArg [] ["to-hash"] F.UpToHash "HASH"-    "select changes up to a patch with HASH" ]+    "select changes up to a patch whose hash prefix matches HASH" ]  context = OptSpec {..} where   ounparse k mfs = k [ F.Context p | Context p <- mfs ]@@ -163,7 +163,7 @@   oparse k fs = k [ AfterHash s | F.AfterHash s <- fs ]   ocheck _ = []   odesc = [ strArg [] ["from-hash"] F.AfterHash "HASH"-    "select changes starting with a patch with HASH" ]+    "select changes starting with a patch whose hash prefix matches HASH" ]  fromTag = OptSpec {..} where   ounparse k mfs = k [ F.AfterTag s | AfterTag s <- mfs ]@@ -179,10 +179,10 @@   odesc = [ strArg ['t'] ["tag"] F.OneTag "REGEXP" "select tag matching REGEXP" ]  tags = OptSpec {..} where-  ounparse k mfs = k [ F.OneTag s | OneTag s <- mfs ]-  oparse k fs = k [ OneTag s | F.OneTag s <- fs ]+  ounparse k mfs = k [ F.SeveralTag s | SeveralTag s <- mfs ]+  oparse k fs = k [ SeveralTag s | F.SeveralTag s <- fs ]   ocheck _ = []-  odesc = [ strArg ['t'] ["tags"] F.OneTag "REGEXP" "select tags matching REGEXP" ]+  odesc = [ strArg ['t'] ["tags"] F.SeveralTag "REGEXP" "select tags matching REGEXP" ]  patch = OptSpec {..} where   ounparse k mfs = k [ F.OnePatch s | OnePatch s <- mfs ]@@ -203,7 +203,7 @@   oparse k fs = k [ OneHash s | F.OneHash s <- fs ]   ocheck _ = []   odesc = [ strArg ['h'] ["hash"] F.OneHash "HASH"-    "select a single patch with HASH" ]+    "select a single patch whose hash prefix matches HASH" ]  match = OptSpec {..} where   ounparse k mfs = k [ F.OnePattern s | OnePattern s <- mfs ]
src/Darcs/UI/Options/Util.hs view
@@ -28,11 +28,10 @@     , parseIndexRangeArg     , showIntArg     , showIndexRangeArg+    , withDashes     -- * Re-exports     , AbsolutePath     , AbsolutePathOrStd-    , makeAbsolute-    , makeAbsoluteOrStd     ) where  import Darcs.Prelude@@ -130,14 +129,18 @@   imap (Iso fw bw) (RawAbsPathOrStdArg s l mkF unF mkV unV n h) = RawAbsPathOrStdArg s l mkF unF (fw . mkV) (unV . bw) n h   imap (Iso fw bw) (RawOptAbsPathArg s l mkF unF mkV unV d n h) = RawOptAbsPathArg s l mkF unF (fw . mkV) (unV . bw) d n h --- | Get the long switch names from a raw option. Used to construct error messages.+-- | Get the short and long switch names from a raw option.+-- Used to construct error and warning messages. switchNames :: RawOptSpec f v -> [String]-switchNames (RawNoArg _ l _ _ _)                 = l-switchNames (RawStrArg _ l _ _ _ _ _ _)          = l-switchNames (RawAbsPathArg _ l _ _ _ _ _ _)      = l-switchNames (RawAbsPathOrStdArg _ l _ _ _ _ _ _) = l-switchNames (RawOptAbsPathArg _ l _ _ _ _ _ _ _) = l+switchNames (RawNoArg s l _ _ _)                 = withDashes s l+switchNames (RawStrArg s l _ _ _ _ _ _)          = withDashes s l+switchNames (RawAbsPathArg s l _ _ _ _ _ _)      = withDashes s l+switchNames (RawAbsPathOrStdArg s l _ _ _ _ _ _) = withDashes s l+switchNames (RawOptAbsPathArg s l _ _ _ _ _ _ _) = withDashes s l +withDashes :: [Char] -> [String] -> [String]+withDashes short long = map (\c -> ['-',c]) short ++ map ("--" ++) long+ -- | Given a list of 'RawOptSpec', find all flags that match a given value. rawUnparse :: Eq v => [RawOptSpec f v] -> v -> [f] rawUnparse ropts val =@@ -197,7 +200,11 @@   ocheck fs = case map snd (rawParse ropts fs) of     [] -> [] -- error "this should not happen"     [_] -> []-    ropts' -> ["conflicting options: " ++ intercalate ", " (map (intercalate "/" . switchNames) ropts')]+    ropts' ->+      [ OptError $+        "conflicting options: " +++        intercalate ", " (map (intercalate "/" . switchNames) ropts')+      ]   odesc = map (addDefaultHelp dval) ropts  -- * Simple primitive scalar valued options@@ -273,9 +280,14 @@ deprecated comments ropts = OptSpec {..} where   ounparse k _ = k []   oparse k _ = k ()-  ocheck fs = case map snd (rawParse ropts fs) of-    [] -> []-    ropts' -> ("deprecated option(s): " ++ intercalate ", " (concatMap switchNames ropts')) : comments+  ocheck fs =+    case map snd (rawParse ropts fs) of+      [] -> []+      ropts' ->+        map OptWarning $+          ( "deprecated option(s): " +++            intercalate ", " (concatMap switchNames ropts')+          ) : comments   odesc = map noDefaultHelp ropts   noDefaultHelp (RawNoArg s l f _ h) = noArg s l f h   noDefaultHelp (RawStrArg s l mkF _ _ _ a h) = strArg s l mkF a h
src/Darcs/UI/PatchHeader.hs view
@@ -1,38 +1,45 @@ module Darcs.UI.PatchHeader     ( getLog     , getAuthor+    , editLog     , updatePatchHeader, AskAboutDeps(..)+    , PatchHeaderConfig+    , patchHeaderConfig     , HijackT, HijackOptions(..)     , runHijackT     ) where  import Darcs.Prelude -import Darcs.Patch-    ( IsRepoType, RepoPatch, PrimPatch, PrimOf-    , summaryFL-    )+import Darcs.Patch ( PrimOf, RepoPatch, summaryFL ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Info ( PatchInfo,-                          piAuthor, piName, piLog, piDateString,-                          patchinfo-                        )+import Darcs.Patch.Info+    ( PatchInfo+    , patchinfo+    , piAuthor+    , piDateString+    , piLog+    , piName+    ) import Darcs.Patch.Named-   ( Named, patchcontents, patch2patchinfo, infopatch, getdeps, adddeps-   )+    ( Named+    , adddeps+    , getdeps+    , infopatch+    , patch2patchinfo+    , patchcontents+    , setinfo+    ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) import Darcs.Patch.Prim ( canonizeFL ) -import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (+>+) ) -import Darcs.Repository ( Repository )-import Darcs.Util.Lock-    ( readTextFile-    , writeTextFile-    )+import Darcs.Util.Lock ( readTextFile, writeTextFile )  import Darcs.UI.External ( editFile ) import Darcs.UI.Flags ( getEasyAuthor, promptAuthor, getDate )+import Darcs.UI.Options ( Config, (?) ) import qualified Darcs.UI.Options.All as O import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.UI.SelectChanges ( askAboutDepends )@@ -42,7 +49,7 @@ import Darcs.Util.Global ( darcsLastMessage ) import Darcs.Util.Path ( FilePathLike, toFilePath ) import Darcs.Util.Prompt ( PromptConfig(..), askUser, promptChar, promptYorn )-import Darcs.Util.Printer ( text, ($$), vcat, prefixLines, renderString )+import Darcs.Util.Printer ( Doc, text, ($+$), vcat, prefixLines, renderString ) import qualified Darcs.Util.Ratified as Ratified ( hGetContents )  import Darcs.Util.Tree ( Tree )@@ -81,13 +88,12 @@ -- It ensures the patch name is not empty nor starts with the prefix TAG. -- -- The last result component is a possible path to a temporary file that should be removed later.-getLog :: forall prim wX wY . PrimPatch prim-       => Maybe String                          -- ^ patchname option+getLog :: Maybe String                          -- ^ patchname option        -> Bool                                  -- ^ pipe option        -> O.Logfile                             -- ^ logfile option        -> Maybe O.AskLongComment                -- ^ askLongComment option        -> Maybe (String, [String])              -- ^ possibly an existing patch name and long description-       -> FL prim wX wY                         -- ^ changes to record+       -> Doc                                   -- ^ summary of changes to record        -> IO (String, [String], Maybe String)   -- ^ patch name, long description and possibly the path                                                 --   to the temporary file that should be removed later getLog m_name has_pipe log_file ask_long m_old chs =@@ -206,62 +212,93 @@   append_info f oldname = do     fc <- readTextFile f     writeTextFile f $ renderString-       $ vcat (map text $ if null fc then [oldname] else fc)-      $$ text "# Please enter the patch name in the first line, and"-      $$ text "# optionally, a long description in the following lines."-      $$ text "#"-      $$ text "# Lines starting with '#' will be ignored."-      $$ text "#"-      $$ text "#"-      $$ text "# Summary of selected changes:"-      $$ text "#"-      $$ prefixLines (text "#") (summaryFL chs)+      $ vcat (map text $ if null fc then [oldname] else fc)+      $+$ vcat+        [ text "# Please enter the patch name in the first line, and"+        , text "# optionally, a long description in the following lines."+        , text "#"+        , text "# Lines starting with '#' will be ignored."+        , text "#"+        , text "#"+        , text "# Summary of selected changes:"+        , text "#"+        , prefixLines (text "#") chs+        ] --- |specify whether to ask about dependencies with respect to a particular repository, or not-data AskAboutDeps rt p wR wU wT = AskAboutDeps (Repository rt p wR wU wT) | NoAskAboutDeps+editLog :: Named prim wX wY -> IO (Named prim wX wY)+editLog p = do+  let pi = patch2patchinfo p+  (name, log, _) <-+    getLog Nothing False (O.Logfile Nothing False)+      (Just O.YesEditLongComment) (Just (piName pi, piLog pi)) mempty+  pi' <- patchinfo (piDateString pi) name (piAuthor pi) log+  return $ setinfo pi' p +-- | Specify whether to ask about dependencies with respect to a particular+-- 'PatchSet', or not+data AskAboutDeps p wX where+  AskAboutDeps :: (RL (PatchInfoAnd p) w wX) -> AskAboutDeps p wX+  NoAskAboutDeps :: AskAboutDeps p wX+ -- | Run a job that involves a hijack confirmation prompt. -- --   See 'RequestHijackPermission' for initial values runHijackT :: Monad m => HijackOptions -> HijackT m a -> m a runHijackT = flip evalStateT +data PatchHeaderConfig = PatchHeaderConfig+  { diffAlgorithm :: D.DiffAlgorithm+  , keepDate :: Bool+  , selectAuthor :: Bool+  , author :: Maybe String+  , patchname :: Maybe String+  , askLongComment :: Maybe O.AskLongComment+  }++patchHeaderConfig :: Config -> PatchHeaderConfig+patchHeaderConfig cfg = PatchHeaderConfig+  { diffAlgorithm   = O.diffAlgorithm ? cfg+  , keepDate        = O.keepDate ? cfg+  , selectAuthor    = O.selectAuthor ? cfg+  , author          = O.author ? cfg+  , patchname       = O.patchname ? cfg+  , askLongComment  = O.askLongComment ? cfg+  }+ -- | Update the metadata for a patch. --   This potentially involves a bit of interactivity, so we may return @Nothing@ --   if there is cause to abort what we're doing along the way-updatePatchHeader :: forall rt p wX wY wR wU wT . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+updatePatchHeader :: forall p wX wY wZ . (RepoPatch p, ApplyState p ~ Tree)                   => String -- ^ verb: command name-                  -> AskAboutDeps rt p wR wU wT+                  -> AskAboutDeps p wX                   -> S.PatchSelectionOptions-                  -> D.DiffAlgorithm-                  -> Bool -- keepDate-                  -> Bool -- selectAuthor-                  -> Maybe String -- author-                  -> Maybe String -- patchname-                  -> Maybe O.AskLongComment-                  -> Named (PrimOf p) wT wX-                  -- ^ patch to edit, must be conflict-free as conflicts can't be preserved when changing-                  -- the identity of a patch. If necessary this can be achieved by calling @fmapFL_Named effect@-                  -- on an @Named p@ first, but some callers might already have @Named (PrimOf p)@ available.-                  -> FL (PrimOf p) wX wY -- ^new primitives to add-                  -> HijackT IO (Maybe String, PatchInfoAnd rt p wT wY)-updatePatchHeader verb ask_deps pSelOpts da nKeepDate nSelectAuthor nAuthor nPatchname nAskLongComment oldp chs = do+                  -> PatchHeaderConfig+                  -> Named (PrimOf p) wX wY+                  -- ^ patch to edit, must be conflict-free as conflicts can't+                  -- be preserved when changing the identity of a patch. If+                  -- necessary this can be achieved by calling @fmapFL_Named+                  -- effect@ on an @Named p@ first, but some callers might+                  -- already have @Named (PrimOf p)@ available.+                  -> FL (PrimOf p) wY wZ -- ^new primitives to add+                  -> HijackT IO (Maybe String, PatchInfoAnd p wX wZ)+updatePatchHeader verb ask_deps pSelOpts PatchHeaderConfig{..} oldp chs = do -    let newchs = canonizeFL da (patchcontents oldp +>+ chs)+    let newchs = canonizeFL diffAlgorithm (patchcontents oldp +>+ chs)      let old_pdeps = getdeps oldp     newdeps <-         case ask_deps of-           AskAboutDeps repository -> liftIO $ askAboutDepends repository newchs pSelOpts old_pdeps+           AskAboutDeps patches ->+              liftIO $ askAboutDepends patches newchs pSelOpts old_pdeps            NoAskAboutDeps -> return old_pdeps      let old_pinf = patch2patchinfo oldp         prior    = (piName old_pinf, piLog old_pinf)-    date <- if nKeepDate then return (piDateString old_pinf) else liftIO $ getDate False-    new_author <- getAuthor verb nSelectAuthor nAuthor old_pinf+    date <- if keepDate then return (piDateString old_pinf) else liftIO $ getDate False+    new_author <- getAuthor verb selectAuthor author old_pinf     liftIO $ do         (new_name, new_log, mlogf) <- getLog-            nPatchname False (O.Logfile Nothing False) nAskLongComment (Just prior) chs+            patchname False (O.Logfile Nothing False) askLongComment (Just prior) (summaryFL chs)         new_pinf <- patchinfo date new_name new_author new_log         let newp = n2pia (adddeps (infopatch new_pinf newchs) newdeps)         return (mlogf, newp)
src/Darcs/UI/PrintPatch.hs view
@@ -16,7 +16,7 @@ -- Boston, MA 02110-1301, USA.  module Darcs.UI.PrintPatch-    ( contextualPrintPatch+    ( contextualPrintPatchWithPager     , printContent     , printContentWithPager     , printFriendly@@ -27,23 +27,25 @@  import Darcs.Prelude -import Darcs.Patch ( description, showContextPatch, content, summary )+import Darcs.Patch ( description, content, summary ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Show ( ShowContextPatch, ShowPatch, ShowPatchFor(ForDisplay) )+import Darcs.Patch.ApplyMonad ( ApplyMonadTrans )+import Darcs.Patch.Show+    ( ShowContextPatch+    , ShowPatch+    , ShowPatchFor(ForDisplay)+    , showPatchWithContext+    ) import Darcs.UI.External ( viewDocWith )-import Darcs.UI.Options.All ( Verbosity(..), WithContext(..), WithSummary(..) )+import Darcs.UI.Options.All ( Verbosity(..), WithSummary(..) ) import Darcs.Util.Printer ( Doc, prefix, putDocLnWith, ($$) ) import Darcs.Util.Printer.Color ( fancyPrinters )-import Darcs.Util.Tree ( Tree )-import Darcs.Util.Tree.Monad ( virtualTreeIO )  -- | @'printFriendly' opts patch@ prints @patch@ in accordance with the flags -- in opts, ie, whether @--verbose@ or @--summary@ were passed at the -- command-line.-printFriendly :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) => Maybe (Tree IO)-              -> Verbosity -> WithSummary -> WithContext -> p wX wY -> IO ()-printFriendly (Just pristine) _ _ YesContext = contextualPrintPatch pristine-printFriendly _ v s _ = putDocLnWith fancyPrinters . showFriendly v s+printFriendly :: ShowPatch p => Verbosity -> WithSummary -> p wX wY -> IO ()+printFriendly v s = putDocLnWith fancyPrinters . showFriendly v s  -- | @'showFriendly' flags patch@ returns a 'Doc' representing the right -- way to show @patch@ given the list @flags@ of flags darcs was invoked with.@@ -67,10 +69,12 @@ printContentWithPager :: ShowPatch p => p wX wY -> IO () printContentWithPager = viewDocWith fancyPrinters . prefix "    " . content --- | 'contextualPrintPatch' prints a patch, together with its context, on--- standard output.-contextualPrintPatch :: (ShowContextPatch p, ApplyState p ~ Tree) => Tree IO-                     -> p wX wY -> IO ()-contextualPrintPatch s p = do-    (contextedPatch, _) <- virtualTreeIO (showContextPatch ForDisplay p) s-    putDocLnWith fancyPrinters contextedPatch+-- | Print a patch, together with its context, on standard output, using a+-- pager.+contextualPrintPatchWithPager+  :: (ApplyMonadTrans (ApplyState p) IO, ShowContextPatch p)+  => ApplyState p IO+  -> p wX wY+  -> IO ()+contextualPrintPatchWithPager s p = do+    showPatchWithContext ForDisplay s p >>= viewDocWith fancyPrinters
+ src/Darcs/UI/Prompt.hs view
@@ -0,0 +1,51 @@+-- | A more high-level API for what "Darcs.Util.Prompt" offers+module Darcs.UI.Prompt+    ( PromptChoice(..)+    , PromptConfig(..)+    , runPrompt+    ) where++import Darcs.Prelude+import Data.List ( find, intercalate )+import qualified Darcs.Util.Prompt as P++data PromptChoice a = PromptChoice+  { pcKey :: Char+  , pcWhen :: Bool+  , pcAction :: IO a+  , pcHelp :: String+  }++data PromptConfig a = PromptConfig+  { pPrompt :: String               -- what to ask the user+  , pVerb :: String                 -- command (what we are doing)+  , pChoices :: [[PromptChoice a]]  -- list of choice groups+  , pDefault :: Maybe Char          -- default choice, capitalized+  }++-- | Generate the help string from a verb and list of choice groups+helpFor :: String -> [[PromptChoice a]] -> String+helpFor jn choices =+  unlines $+    [ "How to use " ++ jn ++ ":" ] +++    intercalate [""] (map (map help . filter pcWhen) choices) +++    [ ""+    , "?: show this help"+    , ""+    , "<Space>: accept the current default (which is capitalized)"+    ]+  where+    help i = pcKey i : (": " ++ pcHelp i)++lookupAction :: Char -> [PromptChoice a] -> Maybe (IO a)+lookupAction key choices = pcAction <$> find ((==key).pcKey) choices++runPrompt :: PromptConfig a -> IO a+runPrompt pcfg@PromptConfig{..} = do+  let choices = filter pcWhen $ concat pChoices+  key <-+    P.promptChar $+      P.PromptConfig pPrompt (map pcKey choices) [] Nothing "?h"+  case lookupAction key choices of+    Just action -> action+    Nothing -> putStrLn (helpFor pVerb pChoices) >> runPrompt pcfg
src/Darcs/UI/RunCommand.hs view
@@ -26,6 +26,7 @@ import Darcs.Prelude  import Control.Monad ( unless, when )+import Data.List ( intercalate ) import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),                               OptDescr( Option ),                               getOpt )@@ -34,12 +35,12 @@ import Darcs.UI.Options ( (^), odesc, oparse, parseFlags, optDescr, (?) ) import Darcs.UI.Options.All     ( stdCmdActions, StdCmdAction(..)-    , debugging, verbosity, Verbosity(..), network, NetworkOptions(..)+    , debugging, verbosity, Verbosity(..)     , HooksConfig(..), hooks )  import Darcs.UI.Defaults ( applyDefaults ) import Darcs.UI.External ( viewDoc )-import Darcs.UI.Flags ( DarcsFlag, matchAny, fixRemoteRepos, withNewRepo )+import Darcs.UI.Flags ( DarcsFlag, matchAny, withNewRepo ) import Darcs.UI.Commands     ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub )     , CommandControl@@ -51,7 +52,7 @@     , commandExtraArgs     , commandArgdefaults     , commandCompleteArgs-    , commandOptions+    , commandOptDescr     , commandName     , disambiguateCommands     , getSubcommands@@ -60,6 +61,7 @@     ) import Darcs.UI.Commands.GZCRCs ( doCRCWarnings ) import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH )+import Darcs.UI.RunHook ( runPosthook, runPrehook ) import Darcs.UI.Usage     ( getCommandHelp     , getCommandMiniHelp@@ -67,10 +69,8 @@     )  import Darcs.Patch.Match ( checkMatchSyntax )-import Darcs.Repository.Prefs ( getGlobal, getPreflist )-import Darcs.Repository.Test ( runPosthook, runPrehook )+import Darcs.Repository.Prefs ( Pref(Defaults), getGlobal, getPreflist ) import Darcs.Util.AtExit ( atexit )-import Darcs.Util.Download ( setDebugHTTP, disableHTTPPipelining ) import Darcs.Util.Exception ( die ) import Darcs.Util.Global ( setDebugMode, setTimingsMode ) import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute )@@ -92,7 +92,7 @@         die "Are you sure you didn't mean --all rather than -all?" runCommand msuper cmd args = do   old_wd <- getCurrentDirectory-  let options = commandOptions old_wd cmd+  let options = commandOptDescr old_wd cmd   case fixupMsgs $ getOpt Permute options args of     (cmdline_flags,orig_extra,getopt_errs) -> do       -- FIXME This code is highly order-dependent because of hidden state: the@@ -105,9 +105,9 @@       prereq_errors <- commandPrereq cmd cmdline_flags       -- we must get the cwd again because commandPrereq has the side-effect of changing it.       new_wd <- getCurrentDirectory-      user_defs <- getGlobal   "defaults"-      repo_defs <- getPreflist "defaults"-      let (flags,flag_errors) =+      user_defs <- getGlobal Defaults+      repo_defs <- getPreflist Defaults+      let (flags, (flag_warnings, flag_errors)) =             applyDefaults (fmap commandName msuper) cmd old_wd user_defs repo_defs cmdline_flags       case parseFlags stdCmdActions flags of         Just Help -> viewDoc $ getCommandHelp msuper cmd@@ -122,11 +122,14 @@             "Unable to '" ++ "darcs " ++ superName msuper ++ commandName cmd ++             "' here:\n" ++ complaint           Right () -> do-            ePutDocLn $ vcat $ map text $ getopt_errs ++ flag_errors-            extra <- commandArgdefaults cmd flags old_wd orig_extra-            case extraArgumentsError extra cmd msuper of-              Nothing     -> runWithHooks cmd (new_wd, old_wd) flags extra-              Just msg    -> die msg+            ePutDocLn $ vcat $ map text $ flag_warnings+            case getopt_errs ++ flag_errors of+              [] -> do+                extra <- commandArgdefaults cmd flags old_wd orig_extra+                case extraArgumentsError extra cmd msuper of+                  Nothing     -> runWithHooks cmd (new_wd, old_wd) flags extra+                  Just msg    -> die msg+              errors -> fail $ intercalate "\n" errors  fixupMsgs :: (a, b, [String]) -> (a, b, [String]) fixupMsgs (fs,as,es) = (fs,as,map (("command line: "++).chompTrailingNewline) es)@@ -140,26 +143,23 @@ runWithHooks cmd (new_wd, old_wd) flags extra = do    checkMatchSyntax $ matchAny ? flags    -- set any global variables-   oparse (verbosity ^ debugging ^ network) setGlobalVariables flags+   oparse (verbosity ^ debugging) setGlobalVariables flags    -- actually run the command and its hooks    let hooksCfg = parseFlags hooks flags    let verb = parseFlags verbosity flags    preHookExitCode <- runPrehook (pre hooksCfg) verb new_wd    if preHookExitCode /= ExitSuccess       then exitWith preHookExitCode-      else do fixedFlags <- fixRemoteRepos old_wd flags-              phDir <- getPosthookDir new_wd cmd fixedFlags extra-              commandCommand cmd (new_wd, old_wd) fixedFlags extra+      else do phDir <- getPosthookDir new_wd cmd flags extra+              commandCommand cmd (new_wd, old_wd) flags extra               postHookExitCode <- runPosthook (post hooksCfg) verb phDir               exitWith postHookExitCode -setGlobalVariables :: Verbosity -> Bool -> Bool -> Bool -> NetworkOptions -> IO ()-setGlobalVariables verb debug debugHttp timings net = do+setGlobalVariables :: Verbosity -> Bool -> Bool -> IO ()+setGlobalVariables verb debug timings = do   when timings setTimingsMode   when debug setDebugMode-  when debugHttp setDebugHTTP   when (verb == Quiet) $ setProgressMode False-  when (noHttpPipelining net) disableHTTPPipelining   unless (verb == Quiet) $ atexit $ doCRCWarnings (verb == Verbose)  -- | Returns the working directory for the posthook. For most commands, the
+ src/Darcs/UI/RunHook.hs view
@@ -0,0 +1,71 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.RunHook+    ( runPosthook+    , runPrehook+    )+where++import Darcs.Prelude++import System.Directory ( withCurrentDirectory )+import System.Exit ( ExitCode(..) )+import System.Process ( system )+import System.IO ( hPutStrLn, stderr )+import Control.Monad ( when )++import Darcs.UI.Options.All ( HookConfig(..), Verbosity(..) )++import Darcs.Util.Path ( AbsolutePath, toFilePath )+import Darcs.Util.Prompt ( promptYorn )++runPosthook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode+runPosthook (HookConfig mPostHook askPostHook) verb repodir+    = do ph <- getHook "Posthook" mPostHook askPostHook+         withCurrentDirectory (toFilePath repodir) $ runHook verb "Posthook" ph++runPrehook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode+runPrehook (HookConfig mPreHookCmd askPreHook) verb repodir =+    do ph <- getHook "Prehook" mPreHookCmd askPreHook+       withCurrentDirectory (toFilePath repodir) $ runHook verb "Prehook" ph++getHook :: String -> Maybe String -> Bool -> IO (Maybe String)+getHook name mPostHookCmd askHook =+ case mPostHookCmd of+   Nothing -> return Nothing+   Just command ->+     if askHook+      then do yorn <-+                promptYorn+                  ("The following command is set to execute:\n"++command+++                   "\nExecute this command now?")+              if yorn+                then return $ Just command+                else putStrLn (name ++ " cancelled...") >> return Nothing+      else return $ Just command++runHook :: Verbosity -> String -> Maybe String -> IO ExitCode+runHook _ _ Nothing = return ExitSuccess+runHook verb cname (Just command) =+    do ec <- system command+       when (verb /= Quiet) $+         if ec == ExitSuccess+         then putStrLn $ cname++" ran successfully."+         else hPutStrLn stderr $ cname++" failed!"+       return ec+
src/Darcs/UI/SelectChanges.hs view
@@ -66,12 +66,12 @@     , modify, runStateT, state     ) import Control.Monad.Trans ( liftIO )-import Data.List ( intercalate, union )+import Data.List ( intercalate, union, (\\) ) import Data.Maybe ( isJust ) import System.Exit ( exitSuccess )  import Darcs.Patch-    ( IsRepoType, RepoPatch, PrimOf+    ( RepoPatch, PrimOf     , commuteFL, invert     , listTouchedFiles     )@@ -90,7 +90,6 @@     , labelPatches     ) import Darcs.Patch.Commute ( Commute )-import Darcs.Patch.Depends ( contextPatches ) import Darcs.Patch.Ident ( Ident(..), PatchId ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Inspect ( PatchInspect )@@ -103,7 +102,7 @@     , matchAPatch     ) import Darcs.Patch.Named ( adddeps, anonymous )-import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia ) import Darcs.Patch.Permutations ( commuteWhatWeCanRL ) import Darcs.Patch.Show ( ShowPatch, ShowContextPatch ) import Darcs.Patch.Split ( Splitter(..) )@@ -117,17 +116,16 @@     ) import Darcs.Patch.Witnesses.Sealed     ( FlippedSeal (..), Sealed2 (..)-    , flipSeal, seal2, unseal2+    , seal2, unseal2     ) import Darcs.Patch.Witnesses.WZipper     ( FZipper (..), focus, jokers, left, right     , rightmost, toEnd, toStart     )-import Darcs.Repository ( Repository, repoLocation, readTentativeRepo ) import Darcs.UI.External ( editText ) import Darcs.UI.Options.All     ( Verbosity(..), WithSummary(..)-    , WithContext(..), SelectDeps(..), MatchFlag )+    , SelectDeps(..), MatchFlag ) import Darcs.UI.PrintPatch     ( printContent     , printContentWithPager@@ -139,7 +137,7 @@ import Darcs.Util.Path ( AnchoredPath ) import Darcs.Util.Printer ( putDocLnWith, greenText, vcat ) import Darcs.Util.Printer.Color ( fancyPrinters )-import Darcs.Util.Prompt ( PromptConfig (..), askUser, promptChar )+import Darcs.Util.Prompt ( PromptConfig (..), promptYorn, promptChar ) import Darcs.Util.Tree ( Tree )  @@ -192,7 +190,6 @@   , interactive :: Bool   , selectDeps :: SelectDeps   , withSummary :: WithSummary-  , withContext :: WithContext   }  -- | All the static settings for selecting patches.@@ -203,7 +200,6 @@       , matchCriterion :: MatchCriterion p       , jobname :: String       , allowSkipAll :: Bool-      , pristine :: Maybe (Tree IO)       , whichChanges :: WhichChanges       } @@ -213,16 +209,14 @@                     -> PatchSelectionOptions                     -> Maybe (Splitter prim)                     -> Maybe [AnchoredPath]-                    -> Maybe (Tree IO)                     -> SelectionConfig prim-selectionConfigPrim whch jn o spl fs p =+selectionConfigPrim whch jn o spl fs =  PSC { opts = o      , splitter = spl      , files = fs      , matchCriterion = triv      , jobname = jn      , allowSkipAll = True-     , pristine = p      , whichChanges = whch      } @@ -241,7 +235,6 @@      , matchCriterion = iswanted seal2 (matchFlags o)      , jobname = jn      , allowSkipAll = True-     , pristine = Nothing      , whichChanges = whch      } @@ -260,7 +253,6 @@      , matchCriterion = iswanted extract (matchFlags o)      , jobname = jn      , allowSkipAll = True-     , pristine = Nothing      , whichChanges = whch      } @@ -432,14 +424,14 @@ withSelectedPatchFromList     :: (Commute p, Matchable p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)     => String   -- name of calling command (always "amend" as of now)-    -> RL p wO wR+    -> RL p wX wY     -> PatchSelectionOptions-    -> (forall wA . (FL p :> p) wA wR -> IO ())+    -> ((RL p :> p) wX wY -> IO ())     -> IO () withSelectedPatchFromList jn patches o job = do     sp <- wspfr jn (matchAPatch $ matchFlags o) patches NilFL     case sp of-        Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected')+        Just (skipped :> selected') -> job (skipped :> selected')         Nothing ->             putStrLn $ "Cancelling " ++ jn ++ " since no patch was selected." @@ -453,13 +445,13 @@ -- | This ensures that the selected patch commutes freely with the skipped -- patches, including pending and also that the skipped sequences has an -- ending context that matches the recorded state, z, of the repository.-wspfr :: forall p wX wY wU.+wspfr :: forall p wX wY wZ.          (Commute p, Matchable p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)       => String       -> (forall wA wB . p wA wB -> Bool)       -> RL p wX wY-      -> FL (WithSkipped p) wY wU-      -> IO (Maybe (FlippedSeal (FL p :> p) wU))+      -> FL (WithSkipped p) wY wZ+      -> IO (Maybe ((RL p :> p) wX wZ)) wspfr _ _ NilRL _ = return Nothing wspfr jn matches remaining@(pps:<:p) skipped     | not $ matches p = wspfr jn matches pps@@ -480,7 +472,7 @@                                  , pDefault = Just 'n'                                  , pHelp = "?h" }               case yorn of-                'y' -> return $ Just $ flipSeal $ skipped' :> p'+                'y' -> return $ Just $ (pps +<<+ skipped') :> p'                 'n' -> nextPatch                 'j' -> nextPatch                 'k' -> previousPatch remaining skipped@@ -496,10 +488,9 @@         repeatThis   where prompt' = "Shall I " ++ jn ++ " this patch?"         nextPatch = wspfr jn matches pps (WithSkipped SkippedManually p:>:skipped)-        previousPatch :: RL p wX wQ-                      -> FL (WithSkipped p) wQ wU-                      -> IO (Maybe (FlippedSeal-                              (FL p :> p) wU))+        previousPatch :: RL p wA wB+                      -> FL (WithSkipped p) wB wC+                      -> IO (Maybe ((RL p :> p) wA wC))         previousPatch remaining' NilFL = wspfr jn matches remaining' NilFL         previousPatch remaining' (WithSkipped sk prev :>: skipped'') =             case sk of@@ -519,7 +510,7 @@                      , KeyPress 'q' ("cancel " ++ jn)                     ]]         defaultPrintFriendly =-          printFriendly Nothing NormalVerbosity NoSummary NoContext+          printFriendly NormalVerbosity NoSummary  -- | Runs a function on the underlying @PatchChoices@ object liftChoices :: StateT (PatchChoices p wX wY) Identity a@@ -676,7 +667,7 @@ -- it. decide :: Commute p        => Bool-       -> LabelledPatch p wT wU+       -> LabelledPatch p wA wB        -> InteractiveSelectionM p wX wY () decide takeOrDrop lp = do     whch <- asks whichChanges@@ -765,10 +756,8 @@ askConfirmation = do     jn <- asks jobname     liftIO $ when (jn `elem` ["unpull", "unrecord", "obliterate"]) $ do-               yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? "-               case yorn of-                 ('y':_) -> return ()-                 _ -> exitSuccess+               yes <- promptYorn $ "Really " ++ jn ++ " all undecided patches?"+               unless yes exitSuccess  -- | The singular form of the noun for items of type @p@. thing :: (ShowPatch p) => InteractiveSelectionM p wX wY String@@ -808,8 +797,7 @@                                    }  -- | Ask the user what to do with the next patch.-textSelectOne :: ( Commute p, ShowPatch p, ShowContextPatch p, PatchInspect p-                 , ApplyState p ~ Tree )+textSelectOne :: ( Commute p, ShowPatch p, PatchInspect p )               => InteractiveSelectionM p wX wY Bool textSelectOne = do  c <- currentPatch@@ -866,21 +854,27 @@                  liftIO . putStrLn $ helpFor jn basicOptions advancedOptions                  return False -lastQuestion :: (Commute p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)+lastQuestion :: (Commute p, ShowPatch p)              => InteractiveSelectionM p wX wY Bool lastQuestion = do   jn <- asks jobname-  theThings <-things+  theThings <- things   aThing <- thing   let (basicOptions, advancedOptions) = optionsLast jn aThing-  yorn <- liftIO . promptChar $+  num <- numSelected+  if num == 0 then do+    liftIO $ putStrLn "Nothing selected."+    return True+  else do+    yorn <- liftIO . promptChar $             PromptConfig { pPrompt = "Do you want to "++capitalize jn++                                       " these "++theThings++"?"                          , pBasicCharacters = "yglqk"                          , pAdvancedCharacters = "dan"                          , pDefault = Just 'y'                          , pHelp = "?h"}-  case yorn of c | c `elem` "yda" -> return True+    case yorn of+               c | c `elem` "yda" -> return True                  | c `elem` "qn" -> liftIO $                                     do putStrLn $ jn ++" cancelled."                                        exitSuccess@@ -892,17 +886,22 @@                     basicOptions advancedOptions                  return False +numSelected :: Commute p => InteractiveSelectionM p wX wY Int+numSelected = do+  w <- asks whichChanges+  (first_chs :> _ :> last_chs) <- getChoices <$> gets choices+  return $+    if backward w then lengthFL last_chs else lengthFL first_chs+ -- | Shows the current patch as it should be seen by the user.-printCurrent :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)-             => InteractiveSelectionM p wX wY ()+printCurrent :: ShowPatch p => InteractiveSelectionM p wX wY () printCurrent = do   o <- asks opts-  pr <- asks pristine   c <- currentPatch   case c of     Nothing -> return ()     Just (Sealed2 lp) ->-      liftIO $ printFriendly pr (verbosity o) (withSummary o) (withContext o) $ unLabel lp+      liftIO $ printFriendly (verbosity o) (withSummary o) $ unLabel lp  -- | The interactive part of @darcs changes@ textView :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)@@ -916,7 +915,7 @@       repeatThis -- prompt the user     where         defaultPrintFriendly =-          unseal2 (printFriendly Nothing (verbosity o) (withSummary o) (withContext o))+          unseal2 (printFriendly (verbosity o) (withSummary o))         prev_patch :: IO ()         prev_patch = case ps_done of                        [] -> repeatThis@@ -1007,7 +1006,7 @@       _nevermind_ jn = "Will not ask whether to " ++ jn ++ " "       _these_ n  = show n ++ " already decided " ++ _elem_ n ""       _elem_ n = englishNum n (Noun "patch")-      showskippedpatch :: ShowPatch p => FL (LabelledPatch p) wY wT -> IO ()+      showskippedpatch :: ShowPatch p => FL (LabelledPatch p) wY wZ -> IO ()       showskippedpatch =         putDocLnWith fancyPrinters . vcat . mapFL (showFriendly NormalVerbosity NoSummary . unLabel) @@ -1024,31 +1023,60 @@ getDefault False InFirst = 'y' getDefault False InLast  = 'n' -askAboutDepends :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                => Repository rt p wR wU wT -> FL (PrimOf p) wT wY-                -> PatchSelectionOptions-                -> [PatchInfo] -> IO [PatchInfo]-askAboutDepends repository pa' ps_opts olddeps = do+-- | For a given sequence of preceding patches to choose from, and a sequence+-- of prims which will become a new named patch, let the user select a subset+-- such that the new patch will explicitly depend on them. The patches offered+-- include only those that the new patch does not already depend on. To support+-- amend, we pass in the old dependencies, too.+askAboutDepends+  :: (RepoPatch p, ApplyState p ~ Tree)+  => RL (PatchInfoAnd p) wX wR  -- ^ patches to choose from+  -> FL (PrimOf p) wR wT        -- ^ tentative content of new patch+  -> PatchSelectionOptions+  -> [PatchInfo]                -- ^ old explicit dependencies+  -> IO [PatchInfo]+askAboutDepends to_ask pa' ps_opts olddeps = do   -- Ideally we'd just default the olddeps to yes but still ask about them.   -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would-  -- have to have this support added first.-  pset <- readTentativeRepo repository (repoLocation repository)-  -- Let the user select only from patches after the last clean tag.-  -- We do this for efficiency, otherwise independentPatchIds can-  -- take a /very/ long time to finish. The limitation this imposes-  -- is a bit arbitrary from a user perspective. Note however that-  -- contextPatches at least gives us this latest clean tag to select.-  _ :> untagged <- return $ contextPatches pset-  -- Note: using anonymous here seems to be safe since we don't store any patches+  -- have to have this support added first. This is not easy to do, though.++  -- As a cheap alternative we do two selection passes: one where the user can+  -- drop old dependencies and one where they can add new ones.+  _ :> to_drop <-+    runSelection (reverseRL to_ask) $+      -- An explicit dependency that we /drop/ can be commuted to the right+      -- i.e. forward in the history without dragging others with them, thus we+      -- use LastReversed. We also use a custom match criterion to offer only+      -- patches we do explicitly depend on.+      selectionConfigDepends LastReversed "drop dependency on" (`elem` olddeps)+  let keep = olddeps \\ mapFL info to_drop+      dropped = olddeps \\ keep+  -- Note: using anonymous here is safe since we don't store any patches   -- and only return a list of PatchInfo-  pa <- n2pia . flip adddeps olddeps <$> anonymous pa'+  pa <- n2pia . flip adddeps keep <$> anonymous pa'   -- get rid of all (implicit and explicit) dependencies of pa-  _ :> _ :> non_deps <- return $ commuteWhatWeCanRL (untagged :> pa)+  _ :> _ :> non_deps <- return $ commuteWhatWeCanRL (to_ask :> pa)   candidates :> _ <-     runSelection (reverseRL non_deps) $-      selectionConfig FirstReversed "depend on" ps_opts-        { matchFlags = [], interactive = True } Nothing Nothing-  return $ olddeps `union` independentPatchIds (reverseFL candidates)+      -- Adding explicit dependencies should drag dependent patches with them+      -- (though they will be filtered out later), so we use FirstReversed. The+      -- matcher is there so we don't re-offer dependencies we dropped in the+      -- previous run.+      selectionConfigDepends FirstReversed "depend on" (`notElem` dropped)+  return $ keep `union` independentPatchIds (reverseFL candidates)+  where+    selectionConfigDepends whch name matchFn =+      PSC+        { opts = ps_opts {matchFlags = [], interactive = True}+        , splitter = Nothing+        , files = Nothing+        , matchCriterion =+            MatchCriterion+              {mcHasNonrange = True, mcFunction = matchFn . info}+        , jobname = name+        , allowSkipAll = True+        , whichChanges = whch+        }  -- | From an 'RL' of patches select the identities of those that are -- not depended upon by later patches.
+ src/Darcs/UI/TestChanges.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.TestChanges ( testTree ) where++import Darcs.Prelude++import System.Exit ( ExitCode(..) )+import System.Process ( system )++import Darcs.UI.Commands ( putInfo )+import Darcs.UI.Options ( Config, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Prefs ( getPrefval )+import Darcs.Repository.Working ( setAllScriptsExecutable )++import Darcs.Util.Lock ( withTempDir, withPermDir )+import Darcs.Util.Path ( toPath )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Tree ( Tree )+import Darcs.Util.Tree.Plain ( writePlainTree )++testTree :: Config -> Tree IO -> IO ExitCode+testTree cfg tree = do+  debugMessage "Considering whether to test..."+  ifRunTest (O.testChanges ? cfg) $ \leaveTestDir -> do+    debugMessage "About to run test if it exists."+    testline <- getPrefval "test"+    case testline of+      Nothing -> return ExitSuccess+      Just testcode -> do+        withDir leaveTestDir "testing" $ \dir -> do+          writePlainTree tree (toPath dir)+          putInfo cfg "Running test..."+          sse (O.setScriptsExecutable ? cfg)+          ec <- system testcode+          putInfo cfg $+            if ec == ExitSuccess+              then "Test ran successfully."+              else "Test failed!"+          return ec+  where+    withDir O.YesLeaveTestDir = withPermDir+    withDir O.NoLeaveTestDir = withTempDir+    sse O.YesSetScriptsExecutable = setAllScriptsExecutable+    sse O.NoSetScriptsExecutable = return ()+    ifRunTest (O.YesTestChanges leaveTestDir) test = test leaveTestDir+    ifRunTest O.NoTestChanges _ = return ExitSuccess
src/Darcs/UI/TheCommands.hs view
@@ -40,7 +40,7 @@ import Darcs.UI.Commands.Remove ( remove, rm, unadd ) import Darcs.UI.Commands.Repair ( repair, check ) import Darcs.UI.Commands.Replace ( replace )-import Darcs.UI.Commands.Revert ( revert )+import Darcs.UI.Commands.Revert ( revert, clean ) import Darcs.UI.Commands.Rollback ( rollback ) import Darcs.UI.Commands.Send ( send ) import Darcs.UI.Commands.SetPref ( setpref )@@ -83,6 +83,7 @@     , normalCommand rollback     , normalCommand unrecord     , normalCommand obliterate, hiddenCommand unpull+    , normalCommand clean     , commandGroup "Direct modification of the repository:"     , normalCommand tag     , normalCommand setpref
src/Darcs/Util/AtExit.hs view
@@ -28,31 +28,22 @@ -- features, such as exit handlers.  These features slightly break the Haskellian -- purity of darcs, in favour of programming convenience. -module Darcs.Util.AtExit-    (-      atexit-    , withAtexit-    ) where+module Darcs.Util.AtExit ( atexit , withAtexit ) where  import Darcs.Prelude  import Control.Concurrent.MVar-import Control.Exception-    ( bracket_, catch, SomeException-    , mask-    )-import System.IO.Unsafe (unsafePerformIO)-import System.IO ( hPutStrLn, stderr, hPrint )+import Control.Exception ( SomeException, catch, finally )+import System.IO ( hPrint, hPutStrLn, stderr )+import System.IO.Unsafe ( unsafePerformIO )  atexitActions :: MVar (Maybe [IO ()]) atexitActions = unsafePerformIO (newMVar (Just [])) {-# NOINLINE atexitActions #-} - -- | Registers an IO action to run just before darcs exits. Useful for removing -- temporary files and directories, for example. Referenced in Issue1914.-atexit :: IO ()-       -> IO ()+atexit :: IO () -> IO () atexit action =     modifyMVar_ atexitActions $ \ml ->         case ml of@@ -62,16 +53,14 @@                 hPutStrLn stderr "It's too late to use atexit"                 return Nothing - withAtexit :: IO a -> IO a-withAtexit = bracket_ (return ()) exit+withAtexit job = job `finally` runAtexitActions   where-    exit = mask $ \unmask -> do+    runAtexitActions = do         Just actions <- swapMVar atexitActions Nothing         -- from now on atexit will not register new actions-        mapM_ (runAction unmask) actions-    runAction unmask action =-        catch (unmask action) $ \(exn :: SomeException) -> do+        mapM_ runAction actions+    runAction action =+        catch action $ \(exn :: SomeException) -> do             hPutStrLn stderr "Exception thrown by an atexit registered action:"             hPrint stderr exn-
src/Darcs/Util/ByteString.hs view
@@ -63,6 +63,7 @@ import Data.ByteString (intercalate) import qualified Data.ByteString.Base16     as B16 +import System.Directory ( getFileSize ) import System.IO ( withFile, IOMode(ReadMode)                  , hSeek, SeekMode(SeekFromEnd,AbsoluteSeek)                  , openBinaryFile, hClose, Handle, hGetChar@@ -75,7 +76,6 @@ import Data.Word                ( Word8 ) import Data.Int                 ( Int32, Int64 ) import Data.List                ( intersperse )-import Control.Exception ( throw ) import Control.Monad            ( when ) import Control.Monad.ST.Lazy    ( ST ) @@ -89,7 +89,6 @@ import System.IO.MMap( mmapFileByteString ) #endif import System.Mem( performGC )-import System.Posix.Files( fileSize, getSymbolicLinkStatus )  ------------------------------------------------------------------------ -- A locale-independent isspace(3) so patches are interpreted the same everywhere.@@ -155,15 +154,17 @@ -- linesPS and unlinesPS  {-# INLINE linesPS #-}+-- | Split the input into lines, that is, sections separated by '\n' bytes,+-- unless it is empty, in which case the result has one empty line. linesPS :: B.ByteString -> [B.ByteString] linesPS ps      | B.null ps = [B.empty]      | otherwise = BC.split '\n' ps  {-# INLINE unlinesPS #-}+-- | Concatenate the inputs with '\n' bytes in interspersed. unlinesPS :: [B.ByteString] -> B.ByteString-unlinesPS [] = B.empty-unlinesPS x  = B.concat $ intersperse (BC.singleton '\n') x+unlinesPS = B.concat . intersperse (BC.singleton '\n')  -- properties of linesPS and unlinesPS @@ -281,7 +282,7 @@ readSegment (f,range) = do     bs <- tryToRead        `catchIOError` (\_ -> do-                     size <- fileSize `fmap` getSymbolicLinkStatus f+                     size <- getFileSize f                      if size == 0                         then return B.empty                         else performGC >> tryToRead)@@ -315,7 +316,7 @@ mmapFilePS f =   mmapFileByteString f Nothing    `catchIOError` (\_ -> do-                     size <- fileSize `fmap` getSymbolicLinkStatus f+                     size <- getFileSize f                      if size == 0                         then return B.empty                         else performGC >> mmapFileByteString f Nothing)@@ -330,43 +331,53 @@ -- ------------------------------------------------------------------------- -- fromHex2PS -fromHex2PS :: B.ByteString -> B.ByteString+fromHex2PS :: B.ByteString -> Either String B.ByteString fromHex2PS s =   case B16.decode s of-#if MIN_VERSION_base16_bytestring(1,0,0)-    Right result -> result-    Left msg -> throw $ userError $ "fromHex2PS: input is not hex encoded: "++msg-#else-    (result, rest) | B.null rest -> result-    _ -> throw $ userError $ "fromHex2PS: input is not hex encoded"-#endif+    Right result -> Right result+    Left msg -> Left $ "fromHex2PS: input is not hex encoded: "++msg  propHexConversion :: B.ByteString -> Bool-propHexConversion x = fromHex2PS (fromPS2Hex x) == x+propHexConversion x = fromHex2PS (fromPS2Hex x) == Right x  -- ------------------------------------------------------------------------- -- betweenLinesPS  -- | Return the B.ByteString between the two lines given,--- or Nothing if they do not appear.+-- or Nothing if either of them does not appear.+--+-- Precondition: the first two arguments (start and end line)+-- must be non-empty and contain no newline bytes. betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString                -> Maybe B.ByteString-betweenLinesPS start end ps =-  case B.breakSubstring start_line ps of-    (before_start, at_start)-      | not (B.null at_start)-      , B.null before_start || BC.last before_start == '\n' ->-          case B.breakSubstring end_line (B.drop (B.length start_line) at_start) of-            (before_end, at_end)-              | not (B.null at_end)-              , B.null before_end || BC.last before_end == '\n' -> Just before_end-              | otherwise -> Nothing-      | otherwise -> Nothing+betweenLinesPS start end ps = do+  at_start <- findLine 0 start ps+  at_end <- findLine 0 end (B.drop (at_start + B.length start) ps)+  -- the "drop 1" eliminates the newline after start+  -- (a trailing newline before end, if present, is retained)+  return $ B.drop 1 $ B.take at_end $ B.drop (at_start + B.length start) ps   where-    start_line = BC.snoc start '\n'-    end_line = BC.snoc end '\n'+    -- find index of substring x if it is a full line+    findLine i x s =+      case B.breakSubstring x s of+        (before, at)+          | B.null at -> Nothing -- not found at all+          | not (B.null after) && BC.head after /= '\n' -> do+              -- found but not followed by newline+              next_nl <- BC.elemIndex '\n' after+              findLine (i + i_after + next_nl) x (B.drop next_nl after)+          | not (B.null before) && BC.last before /= '\n' ->+              -- found, followed by newline but not preceded by newline+              findLine (i + i_after) x after+          | otherwise -> Just (i + i_before)+          where+            after = B.drop l_x at+            l_x = B.length x+            i_before = B.length before+            i_after = i_before + l_x --- | Simpler but less efficient variant of 'betweenLinesPS'.+-- | Simpler but less efficient variant of 'betweenLinesPS'. Note+-- that this is only equivalent under the stated preconditions. spec_betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString                     -> Maybe B.ByteString spec_betweenLinesPS start end ps =@@ -374,7 +385,7 @@     (_, _:after_start) ->       case break (end ==) after_start of         (before_end, _:_) ->-          Just $ BC.unlines before_end+          Just $ if null before_end then B.empty else BC.unlines before_end         _ -> Nothing     _ -> Nothing
+ src/Darcs/Util/Cache.hs view
@@ -0,0 +1,583 @@+module Darcs.Util.Cache+    ( Cache+    , mkCache+    , mkDirCache+    , mkRepoCache+    , cacheEntries+    , CacheType(..)+    , CacheLoc(..)+    , WritableOrNot(..)+    , HashedDir(..)+    , hashedDir+    , bucketFolder+    , filterRemoteCaches+    , cleanCaches+    , cleanCachesWithHint+    , fetchFileUsingCache+    , speculateFileUsingCache+    , speculateFilesUsingCache+    , writeFileUsingCache+    , peekInCache+    , parseCacheLoc+    , showCacheLoc+    , writable+    , isThisRepo+    , hashedFilePath+    , allHashedDirs+    , reportBadSources+    , closestWritableDirectory+    , dropNonRepos+    ) where++import Control.Concurrent.MVar ( MVar, modifyMVar_, newMVar, readMVar )+import Control.Monad ( filterM, forM_, liftM, mplus, unless, when )+import qualified Data.ByteString as B ( ByteString )+import Data.List ( intercalate, nub, sortBy )+import Data.Maybe ( catMaybes, fromMaybe, listToMaybe )+import System.Directory+    ( createDirectoryIfMissing+    , doesDirectoryExist+    , doesFileExist+    , getDirectoryContents+    , getPermissions+    , removeFile+    , withCurrentDirectory+    )+import qualified System.Directory as SD ( writable )+import System.FilePath.Posix ( dropFileName, joinPath, (</>) )+import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( isAlreadyExistsError )+import System.IO.Unsafe ( unsafePerformIO )+import System.Posix.Files ( createLink, getSymbolicLinkStatus, linkCount )+import Text.Regex.Applicative ( anySym, many, match, string, (<|>) )++import Darcs.Prelude++import Darcs.Util.ByteString ( gzWriteFilePS )+import Darcs.Util.English ( Noun(..), Pronoun(..), englishNum )+import Darcs.Util.Exception ( catchall, handleOnly )+import Darcs.Util.File+    ( Cachable(Cachable)+    , copyFileOrUrl+    , fetchFilePS+    , gzFetchFilePS+    , speculateFileOrUrl+    , withTemp+    )+import Darcs.Util.Global ( darcsdir, defaultRemoteDarcsCmd )+import Darcs.Util.Lock ( gzWriteAtomicFilePS )+import Darcs.Util.Progress ( debugMessage, progressList )+import Darcs.Util.URL ( isHttpUrl, isSshUrl, isValidLocalPath )+import Darcs.Util.ValidHash+    ( ValidHash(..)+    , HashedDir(..)+    , checkHash+    , encodeValidHash+    , okayHash+    , calcValidHash+    )++-- * Caches++hashedDir :: HashedDir -> FilePath+hashedDir HashedPristineDir = "pristine.hashed"+hashedDir HashedPatchesDir = "patches"+hashedDir HashedInventoriesDir = "inventories"++allHashedDirs :: [HashedDir]+allHashedDirs = [ HashedPristineDir+                , HashedPatchesDir+                , HashedInventoriesDir+                ]++data WritableOrNot = Writable+                   | NotWritable+                   deriving ( Eq, Show )++data CacheType = Repo+               | Directory+               deriving ( Eq, Show )++data CacheLoc = Cache+    { cacheType :: !CacheType+    , cacheWritable :: !WritableOrNot+    , cacheSource :: !String+    }++-- | Cache is an abstract type for hiding the underlying cache locations+newtype Cache = Ca [CacheLoc]++-- | Smart constructor for 'Cache'.+mkCache :: [CacheLoc] -> Cache+mkCache = Ca . nub . sortBy compareByLocality++mkDirCache :: FilePath -> Cache+mkDirCache dir = mkCache [Cache Directory Writable dir]++mkRepoCache :: FilePath -> Cache+mkRepoCache dir = mkCache [Cache Repo Writable dir]++cacheEntries :: Cache -> [CacheLoc]+cacheEntries (Ca entries) = entries++-- | Note: this non-structural instance ignores the 'cacheWritable' field. This+-- is so that when we 'nub' a list of locations we retain only one (the first)+-- variant.+instance Eq CacheLoc where+    (Cache aTy _ aSrc) == (Cache bTy _ bSrc) = aTy == bTy && aSrc == bSrc++showCacheLoc :: CacheLoc -> String+showCacheLoc (Cache Repo Writable a) = "thisrepo:" ++ a+showCacheLoc (Cache Repo NotWritable a) = "repo:" ++ a+showCacheLoc (Cache Directory Writable a) = "cache:" ++ a+showCacheLoc (Cache Directory NotWritable a) = "readonly:" ++ a++instance Show Cache where+    show (Ca cs) = intercalate "\n" $ map showCacheLoc cs++parseCacheLoc :: String -> Maybe CacheLoc+parseCacheLoc = match reCacheLoc+  where+    reCacheLoc =+      Cache Repo Writable <$> (string "thisrepo:" *> rest) <|>+      Cache Repo NotWritable <$> (string "repo:" *> rest) <|>+      Cache Directory Writable <$> (string "cache:" *> rest) <|>+      Cache Directory NotWritable <$> (string "readonly:" *> rest)+    rest = many anySym++-- | Filter caches for remote repos. This affects only entries that are locally+-- valid paths (i.e. not network URLs): they are removed if non-existent, or+-- demoted to NotWritable if they are not actually writable in the file system.+filterRemoteCaches :: Cache -> IO Cache+filterRemoteCaches (Ca remote) = mkCache . catMaybes <$> filtered+  where+    filtered = mapM (\x -> mbGetRemoteCacheLoc x `catchall` return Nothing) remote+    mbGetRemoteCacheLoc :: CacheLoc -> IO (Maybe CacheLoc)+    mbGetRemoteCacheLoc c@(Cache t _ url)+        | isValidLocalPath url = do+            ex <- doesDirectoryExist url+            if ex+                then do+                    p <- getPermissions url+                    return $ Just $ if writable c && SD.writable p+                                        then c+                                        else Cache t NotWritable url+                else return Nothing+        | otherwise = return $ Just c++-- | Compares two caches, a remote cache is greater than a local one.+-- The order of the comparison is given by: local < http < ssh+compareByLocality :: CacheLoc -> CacheLoc -> Ordering+compareByLocality (Cache _ w x) (Cache _ z y)+    | isValidLocalPath x && isRemote y  = LT+    | isRemote x && isValidLocalPath y = GT+    | isHttpUrl x && isSshUrl y = LT+    | isSshUrl x && isHttpUrl y = GT+    | isValidLocalPath x && isWritable w+        && isValidLocalPath y && isNotWritable z = LT+    | otherwise = EQ+  where+    isRemote r = isHttpUrl r || isSshUrl r+    isWritable = (==) Writable+    isNotWritable = (==) NotWritable++-- |@fetchFileUsingCache cache dir hash@ receives a list of caches @cache@, the+-- directory for which that file belongs @dir@ and the @hash@ of the file to+-- fetch.  It tries to fetch the file from one of the sources, trying them in+-- order one by one.  If the file cannot be fetched from any of the sources,+-- this operation fails. Otherwise we return the path where we found the file+-- and its content.+fetchFileUsingCache :: ValidHash h => Cache -> h+                    -> IO (FilePath, B.ByteString)+fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere++writable :: CacheLoc -> Bool+writable (Cache _ NotWritable _) = False+writable (Cache _ Writable _) = True++-- | This keeps only 'Repo' 'NotWritable' entries.+dropNonRepos :: Cache -> Cache+dropNonRepos (Ca cache) = Ca $ filter notRepo cache where+  notRepo xs = case xs of+    Cache Directory _ _ -> False+    -- we don't want to write thisrepo: entries to the disk+    Cache Repo Writable _ -> False+    _ -> True++closestWritableDirectory :: Cache -> Maybe String+closestWritableDirectory (Ca cs) =+  listToMaybe . catMaybes .flip map cs $ \case+    Cache Directory Writable x -> Just x+    _ -> Nothing++isThisRepo :: CacheLoc -> Bool+isThisRepo (Cache Repo Writable _) = True+isThisRepo _ = False++bucketFolder :: FilePath -> FilePath+bucketFolder f = take 2 (cleanHash f)+    where+        cleanHash fileName = case dropWhile (/= '-') fileName of+            []  -> fileName+            s   -> drop 1 s++-- | The full filepath of a simple file name inside a given 'CacheLoc'+-- under 'HashedDir'.+hashedFilePath :: CacheLoc -> HashedDir -> FilePath -> FilePath+hashedFilePath (Cache Directory Writable d) s f =+    joinPath [d, hashedDir s, bucketFolder f, f]+hashedFilePath (Cache Directory NotWritable d) s f =+    joinPath [d, hashedDir s, f]+hashedFilePath (Cache Repo _ r) s f =+    joinPath [r, darcsdir, hashedDir s, f]++-- | Return whether the 'Cache' contains a file with the given hash in a+-- writable position.+peekInCache :: ValidHash h => Cache -> h -> IO Bool+peekInCache (Ca cache) sh = cacheHasIt cache `catchall` return False+  where+    subdir = dirofValidHash sh+    cacheHasIt [] = return False+    cacheHasIt (c : cs)+        | not $ writable c = cacheHasIt cs+        | otherwise = do+            ex <- doesFileExist $ hashedFilePath c subdir (encodeValidHash sh)+            if ex then return True else cacheHasIt cs++-- | Add pipelined downloads to the (low-priority) queue, for the rest it is a noop.+speculateFileUsingCache :: ValidHash h => Cache -> h -> IO ()+speculateFileUsingCache c hash = do+    let filename = encodeValidHash hash+    debugMessage $ "Speculating on " ++ filename+    copyFileUsingCache OnlySpeculate c (dirofValidHash hash) filename++-- | Do 'speculateFilesUsingCache' for files not already in a writable cache+-- position.+speculateFilesUsingCache :: ValidHash h => Cache -> [h] -> IO ()+speculateFilesUsingCache _ [] = return ()+speculateFilesUsingCache cache hs = do+    hs' <- filterM (fmap not . peekInCache cache) hs+    forM_ hs' $ speculateFileUsingCache cache++data OrOnlySpeculate = ActuallyCopy+                     | OnlySpeculate+                     deriving ( Eq, Show )++-- | If the first parameter of type 'OrOnlySpeculate' is 'ActuallyCopy', try to+-- ensure that a file with the given name (hash) exists in a writable location+-- (which means in particular that it is stored in the local file system). If+-- it is 'OnlySpeculate', then merely schedule download of that file into such+-- a location (the actual download will be executed asynchronously).+--+-- If the file is already present in some writeable location, or if there is no+-- writable location at all, this procedure does nothing.+--+-- If the copy should occur between two locations of the same filesystem, a+-- hard link is made.+--+-- If the first parameter is 'ActuallyCopy', use 'copyFileOrUrl' and try to+-- find the file in any non-writable location. Otherwise ('OnlySpeculate'), use+-- 'speculateFileOrUrl' and try only the first non-writable location (which+-- makes sense since 'speculateFileOrUrl' is asynchronous and thus can't fail+-- in any interesting way).+copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> FilePath -> IO ()+copyFileUsingCache oos (Ca cache) subdir f = do+    debugMessage $ unwords ["copyFileUsingCache:", show oos, hashedDir subdir, f]+    Just stickItHere <- cacheLoc cache+    createDirectoryIfMissing True (dropFileName stickItHere)+    filterBadSources cache >>= sfuc stickItHere+    `catchall`+    return ()+  where+    -- Return last writeable cache/repo location for file 'f'.+    -- Usually returns the global cache unless `--no-cache` is passed.+    -- Throws exception if file already exists in a writable location.+    cacheLoc [] = return Nothing+    cacheLoc (c : cs)+        | not $ writable c = cacheLoc cs+        | otherwise = do+            let attemptPath = hashedFilePath c subdir f+            ex <- doesFileExist attemptPath+            if ex+                then fail "File already present in writable location."+                else do+                    othercache <- cacheLoc cs+                    return $ othercache `mplus` Just attemptPath+    -- Do the actual copy, or hard link, or put file in download queue. This+    -- tries to find the file in all non-writable locations, in order, unless+    -- we have OnlySpeculate.+    sfuc _ [] = return ()+    sfuc out (c : cs)+        | not (writable c) =+            let cacheFile = hashedFilePath c subdir f in+            case oos of+                OnlySpeculate ->+                     speculateFileOrUrl cacheFile out+                     `catchall`+                     checkCacheReachability c+                ActuallyCopy ->+                     do debugMessage $+                          "Copying from " ++ show cacheFile ++ " to  " ++ show out+                        copyFileOrUrl defaultRemoteDarcsCmd cacheFile out Cachable+                     `catchall`+                     (do checkCacheReachability c+                         sfuc out cs) -- try another read-only location+        | otherwise = sfuc out cs++data FromWhere = LocalOnly+               | Anywhere+               deriving ( Eq )++-- | Checks if a given cache entry is reachable or not.  It receives an error+-- caught during execution and the cache entry.  If the caches is not reachable+-- it is blacklisted and not longer tried for the rest of the session. If it is+-- reachable it is whitelisted and future errors with such cache get ignore.+-- To determine reachability:+--  * For a local cache, if the given source doesn't exist anymore, it is+--    blacklisted.+--  * For remote sources if the error is timeout, it is blacklisted, if not,+--    it checks if _darcs/hashed_inventory  exist, if it does, the entry is+--    whitelisted, if it doesn't, it is blacklisted.+checkCacheReachability :: CacheLoc -> IO ()+checkCacheReachability cache+    | isValidLocalPath source = doUnreachableCheck $+        checkFileReachability (doesDirectoryExist source)+    | isHttpUrl source = doUnreachableCheck $+        checkFileReachability (checkHashedInventoryReachability cache)+    | isSshUrl source = doUnreachableCheck $+        checkFileReachability (checkHashedInventoryReachability cache)+    | otherwise = fail $ "unknown transport protocol for: " ++ source+  where+    source = cacheSource cache++    doUnreachableCheck unreachableAction = do+        reachable <- isReachableSource+        unless (reachable source) unreachableAction++    checkFileReachability doCheck = do+        reachable <- doCheck+        if reachable+            then addReachableSource source+            else addBadSource source++-- | Returns a list of reachables cache entries, removing blacklisted entries.+filterBadSources :: [CacheLoc] -> IO [CacheLoc]+filterBadSources cache = do+    badSource <- isBadSource+    return $ filter (not . badSource . cacheSource) cache++-- | Checks if the _darcs/hashed_inventory exist and is reachable+checkHashedInventoryReachability :: CacheLoc -> IO Bool+checkHashedInventoryReachability cache = withTemp $ \tempout -> do+    let f = cacheSource cache </> darcsdir </> "hashed_inventory"+    copyFileOrUrl defaultRemoteDarcsCmd f tempout Cachable+    return True+    `catchall` return False++-- | Get contents of some hashed file taking advantage of the cache system.+-- We have a list of locations (@cache@) ordered from "closest/fastest"+-- (typically, the destination repo) to "farthest/slowest" (typically,+-- the source repo).+-- First, if possible it copies the file from remote location to local.+-- Then, it reads it contents, and links the file across all writeable+-- locations including the destination repository.+fetchFileUsingCachePrivate :: ValidHash h => FromWhere -> Cache -> h+                           -> IO (FilePath, B.ByteString)+fetchFileUsingCachePrivate fromWhere (Ca cache) hash = do+    when (fromWhere == Anywhere) $+        copyFileUsingCache ActuallyCopy (Ca cache) subdir filename+    filterBadSources cache >>= ffuc+  where+    filename = encodeValidHash hash+    subdir = dirofValidHash hash+    ffuc (c : cs)+        | not (writable c) &&+            (Anywhere == fromWhere || isValidLocalPath cacheFile) = do+            -- Looks like `copyFileUsingCache` could not copy the file we+            -- wanted. This can happen if `--no-cache` is NOT passed and the+            -- global cache is not accessible.+            debugMessage $+              "In fetchFileUsingCachePrivate I'm directly grabbing file contents from "+              ++ cacheFile+            x <- gzFetchFilePS cacheFile Cachable+            if not $ checkHash hash x+                then do+                    x' <- fetchFilePS cacheFile Cachable+                    unless (checkHash hash x') $ do+                        hPutStrLn stderr $ "Hash failure in " ++ cacheFile+                        fail $ "Hash failure in " ++ cacheFile+                    return (cacheFile, x')+                else return (cacheFile, x) -- FIXME: create links in caches+            `catchall` do+                -- something bad happened, check if cache became unaccessible+                -- and try other ones+                checkCacheReachability c+                filterBadSources cs >>= ffuc+        | writable c = do+            debugMessage $ "About to gzFetchFilePS from " ++ show cacheFile+            x1 <- gzFetchFilePS cacheFile Cachable+            debugMessage "gzFetchFilePS done."+            x <- if not $ checkHash hash x1+                     then do+                        x2 <- fetchFilePS cacheFile Cachable+                        unless (checkHash hash x2) $ do+                            hPutStrLn stderr $ "Hash failure in " ++ cacheFile+                            removeFile cacheFile+                            fail $ "Hash failure in " ++ cacheFile+                        return x2+                     else return x1+            -- Linking is optional here; the catchall prevents darcs from+            -- failing if repo and cache are on different file systems.+            mapM_ (tryLinking cacheFile filename subdir) cs `catchall` return ()+            return (cacheFile, x)+            `catchall` do+                debugMessage "Caught exception, now attempt creating cache."+                createCache c subdir filename `catchall` return ()+                checkCacheReachability c+                -- fetch file from remaining locations+                (fname, x) <- filterBadSources cs >>= ffuc+                debugMessage $+                  "Attempt creating link from: " ++ show fname ++ " to " ++ show cacheFile+                (createLink fname cacheFile >> debugMessage "successfully created link"+                                            >> return (cacheFile, x))+                  `catchall` do+                    debugMessage $ "Attempt writing file: " ++ show cacheFile+                    -- the following block is usually when files get actually written+                    -- inside of _darcs or global cache.+                    do createDirectoryIfMissing True (dropFileName cacheFile)+                       gzWriteFilePS cacheFile x+                       debugMessage "successfully wrote file"+                       `catchall` return ()+                    -- above block can fail if cache is not writeable+                    return (fname, x)+        | otherwise = ffuc cs+        where+          cacheFile = hashedFilePath c subdir filename++    ffuc [] = fail ("Couldn't fetch " ++ filename ++ "\nin subdir "+                          ++ hashedDir subdir ++ " from sources:\n"+                          ++ show (Ca cache)+                          ++ if subdir == HashedPristineDir+                             then "\nRun `darcs repair` to fix this problem."+                             else "")++tryLinking :: FilePath -> FilePath -> HashedDir -> CacheLoc -> IO ()+tryLinking source filename subdir c =+  when (writable c) $ do+    createCache c subdir filename+    let target = hashedFilePath c subdir filename+    debugMessage $ "Linking " ++ source ++ " to " ++ target+    handleOnly isAlreadyExistsError (return ()) $ createLink source target++createCache :: CacheLoc -> HashedDir -> FilePath -> IO ()+createCache (Cache Directory _ d) subdir filename =+    createDirectoryIfMissing True (d </> hashedDir subdir </> bucketFolder filename)+createCache _ _ _ = return ()++-- | Write file content, except if it is already in the cache, in+-- which case merely create a hard link to that file. The returned value+-- is the size and hash of the content.+writeFileUsingCache+  :: ValidHash h => Cache -> B.ByteString -> IO h+writeFileUsingCache (Ca cache) content = do+    debugMessage $ "writeFileUsingCache "++filename+    (fn, _) <- fetchFileUsingCachePrivate LocalOnly (Ca cache) hash+    mapM_ (tryLinking fn filename subdir) cache+    return hash+    `catchall`+    wfuc cache+    `catchall`+    fail ("Couldn't write " ++ filename ++ "\nin subdir "+               ++ hashedDir subdir ++ " to sources:\n\n"++ show (Ca cache))+  where+    subdir = dirofValidHash hash+    hash = calcValidHash content+    filename = encodeValidHash hash+    wfuc (c : cs)+        | not $ writable c = wfuc cs+        | otherwise = do+            createCache c subdir filename+            let cacheFile = hashedFilePath c subdir filename+            gzWriteAtomicFilePS cacheFile content+            -- create links in all other writable locations+            debugMessage $ "writeFileUsingCache remaining sources:\n"++show (Ca cs)+            -- Linking is optional here; the catchall prevents darcs from+            -- failing if repo and cache are on different file systems.+            mapM_ (tryLinking cacheFile filename subdir) cs `catchall` return ()+            return hash+    wfuc [] = fail $ "No location to write file " ++ (hashedDir subdir </> filename)++cleanCaches :: Cache -> HashedDir -> IO ()+cleanCaches c d = cleanCachesWithHint' c d Nothing++cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO ()+cleanCachesWithHint c d h = cleanCachesWithHint' c d (Just h)++cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO ()+cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs+  where+    cleanCache (Cache Directory Writable d) =+        withCurrentDirectory (d </> hashedDir subdir) (do+            fs' <- getDirectoryContents "."+            let fs = filter okayHash $ fromMaybe fs' hint+                cleanMsg = "Cleaning cache " ++ d </> hashedDir subdir+            mapM_ clean $ progressList cleanMsg fs)+        `catchall`+        return ()+    cleanCache _ = return ()+    clean f = do+        lc <- linkCount `liftM` getSymbolicLinkStatus f+        when (lc < 2) $ removeFile f+        `catchall`+        return ()++-- | Prints an error message with a list of bad caches.+reportBadSources :: IO ()+reportBadSources = do+    sources <- getBadSourcesList+    let size = length sources+    unless (null sources) $ hPutStrLn stderr $+        concat [ "\nBy the way, I could not reach the following "+               , englishNum size (Noun "location") ":"+               , "\n"+               , intercalate "\n" (map ("  " ++) sources)+               , "\nUnless you plan to restore access to "+               , englishNum size It ", you should delete "+               , "the corresponding "+               , englishNum size (Noun "entry") " from _darcs/prefs/sources."+               ]++-- * Global Variables++badSourcesList :: MVar [String]+badSourcesList = unsafePerformIO $ newMVar []+{-# NOINLINE badSourcesList #-}++addBadSource :: String -> IO ()+addBadSource cache = modifyMVarPure badSourcesList (cache:)++getBadSourcesList :: IO [String]+getBadSourcesList = readMVar badSourcesList++isBadSource :: IO (String -> Bool)+isBadSource = do+    badSources <- getBadSourcesList+    return (`elem` badSources)++reachableSourcesList :: MVar [String]+reachableSourcesList = unsafePerformIO $ newMVar []+{-# NOINLINE reachableSourcesList #-}++addReachableSource :: String -> IO ()+addReachableSource src = modifyMVarPure reachableSourcesList (src:)++getReachableSources :: IO [String]+getReachableSources = readMVar reachableSourcesList++isReachableSource :: IO (String -> Bool)+isReachableSource =  do+    reachableSources <- getReachableSources+    return (`elem` reachableSources)++modifyMVarPure :: MVar a -> (a -> a) -> IO ()+modifyMVarPure mvar f = modifyMVar_ mvar (return . f)
src/Darcs/Util/Compat.hs view
@@ -2,15 +2,20 @@  module Darcs.Util.Compat     ( stdoutIsAPipe-    , canonFilename     , maybeRelink     , atomicCreate     , sloppyAtomicCreate     ) where -import Darcs.Prelude+#ifdef WIN32+#define USE_CREAT+#else+#if MIN_VERSION_unix(2,8,0)+#define USE_CREAT+#endif+#endif -import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Prelude  import Control.Monad ( unless ) import Foreign.C.Types ( CInt(..) )@@ -20,25 +25,14 @@ import System.IO.Error ( mkIOError, alreadyExistsErrorType ) import System.Posix.Files ( stdFileMode ) import System.Posix.IO ( openFd, closeFd,+#ifdef USE_CREAT+                         creat,+#endif                          defaultFileFlags, exclusive,                          OpenMode(WriteOnly) )  import Darcs.Util.SignalHandler ( stdoutIsAPipe ) -canonFilename :: FilePath -> IO FilePath-canonFilename f@(_:':':_) = return f -- absolute windows paths-canonFilename f@('/':_) = return f-canonFilename ('.':'/':f) = do cd <- getCurrentDirectory-                               return $ cd ++ "/" ++ f-canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of-                  "" -> fmap (++('/':f)) getCurrentDirectory-                  rd -> withCurrentDirectory rd $-                          do fd <- getCurrentDirectory-                             return $ fd ++ "/" ++ simplefilename-    where-    simplefilename = reverse $ takeWhile (/='/') $ reverse f-- foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink     :: CString -> CString -> CInt -> IO CInt @@ -63,7 +57,11 @@  sloppyAtomicCreate :: FilePath -> IO () sloppyAtomicCreate fp+#ifdef USE_CREAT+    = do fd <- openFd fp WriteOnly flags {creat = Just stdFileMode}+#else     = do fd <- openFd fp WriteOnly (Just stdFileMode) flags+#endif          closeFd fd   where flags = defaultFileFlags { exclusive = True }
− src/Darcs/Util/Download.hs 
@@ -1,346 +0,0 @@-{-# LANGUAGE CPP #-}---- |--- Module      : Darcs.Util.Download--- Copyright   : 2008 Dmitry Kurochkin <dmitry.kurochkin@gmail.com>--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Darcs.Util.Download-    ( setDebugHTTP-    , disableHTTPPipelining-    , maxPipelineLength-    , Cachable(Cachable, Uncachable, MaxAge)-    , environmentHelpProxy-    , environmentHelpProxyPassword-    , ConnectionError-#ifdef HAVE_CURL-    , copyUrl-    , copyUrlFirst-    , waitUrl-#endif-    ) where--import Data.IORef ( newIORef, readIORef, writeIORef, IORef )-import System.IO.Unsafe ( unsafePerformIO )--import Darcs.Prelude--import Darcs.Util.Download.Request-    ( Cachable(Cachable,MaxAge,Uncachable)-    , ConnectionError-    )--#ifdef HAVE_CURL-import Control.Arrow ( (&&&) )-import Control.Concurrent ( forkIO )-import Control.Concurrent.STM.TChan-  ( isEmptyTChan, newTChanIO, readTChan, writeTChan, TChan )-import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, modifyMVar, newEmptyMVar,-                                 newMVar, putMVar, readMVar, withMVar, MVar )-import Control.Monad ( unless, when )-import Control.Monad.State ( evalStateT, get, modify, put, StateT )-import Control.Monad.STM ( atomically )-import Control.Monad.Trans ( liftIO )-import Data.Map ( Map )-import qualified Data.Map as Map-import Data.Tuple ( swap )-import System.Directory ( copyFile, renameFile )-import Crypto.Random ( seedNew, seedToInteger )--import Darcs.Util.AtExit ( atexit )-import Darcs.Util.File ( removeFileMayNotExist )-import Numeric ( showHex )-import Darcs.Util.Progress ( debugMessage )--import Darcs.Util.Download.Request-import qualified Darcs.Util.Download.Curl as Curl-#endif--{-# NOINLINE maxPipelineLengthRef #-}-maxPipelineLengthRef :: IORef Int-maxPipelineLengthRef = unsafePerformIO $ do-    enabled <- pipeliningEnabled-#ifdef HAVE_CURL-    unless enabled $ debugMessage $-        "Warning: pipelining is disabled, because libcurl version darcs was "-        ++ "compiled with is too old (< 7.19.1)"-#endif-    newIORef $ if enabled then 100 else 1--maxPipelineLength :: IO Int-maxPipelineLength = readIORef maxPipelineLengthRef--#ifdef HAVE_CURL-{-# NOINLINE urlNotifications #-}-urlNotifications :: MVar (Map String (MVar (Maybe String)))-urlNotifications = unsafePerformIO $ newMVar Map.empty--{-# NOINLINE urlChan #-}-urlChan :: TChan UrlRequest-urlChan = unsafePerformIO $ do-    ch <- newTChanIO-    _ <- forkIO (urlThread ch)-    return ch--type UrlM a = StateT UrlState IO a--urlThread :: TChan UrlRequest -> IO ()-urlThread ch = do-    junk <- flip showHex "" <$> seedToInteger <$> seedNew-    evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk)-  where-    urlThread' :: UrlM ()-    urlThread' = do-        empty <- liftIO $ atomically $ isEmptyTChan ch-        (l, w) <- (pipeLength &&& waitToStart) `fmap` get-        -- If we've got UrlRequests waiting on the chan, or there's nothing-        -- waiting to start and nothing already downloading, we just block-        -- waiting for more UrlRequests.-        reqs <- if not empty || (nullQ w && l == 0)-                    then liftIO readAllRequests-                    else return []-        mapM_ addReq reqs-        checkWaitToStart-        waitNextUrl-        urlThread'--    readAllRequests :: IO [UrlRequest]-    readAllRequests = do-        r <- atomically $ readTChan ch-        debugMessage $ "URL.urlThread (" ++ url r ++ "\n"++-                       "-> " ++ file r ++ ")"-        empty <- atomically $ isEmptyTChan ch-        reqs <- if not empty-                then readAllRequests-                else return []-        return (r : reqs)--    -- | addReq adds a UrlRequest to the current downloads, being careful to-    -- update the lists of target filenames if the url is already being-    -- downloaded.-    addReq :: UrlRequest -> UrlM ()-    addReq (UrlRequest u f c p) = do-        d <- liftIO (alreadyDownloaded u)-        if d-            then dbg "Ignoring UrlRequest of URL that is already downloaded."-            else do-            (ip, wts) <- (inProgress &&& waitToStart) `fmap` get-            case Map.lookup u ip of-                Nothing -> modify $ \st ->-                    st { inProgress = Map.insert u (f, [], c) ip-                       , waitToStart = addUsingPriority p u wts }-                Just (f', fs', c') -> do-                    let new_c = minCachable c c'-                    when (c /= c') $ do-                        let new_p = Map.insert u (f', fs', new_c) ip-                        modify (\s -> s { inProgress = new_p })-                        dbg $ "Changing " ++ u ++ " request cachability from "-                              ++ show c ++ " to " ++ show new_c-                    when (u `elemQ` wts && p == High) $ do-                        modify $ \s ->-                            s { waitToStart = pushQ u (deleteQ u wts) }-                        dbg $ "Moving " ++ u ++ " to head of download queue."-                    if f `notElem` (f' : fs')-                        then do-                            let new_ip = Map.insert u (f', f : fs', new_c) ip-                            modify (\s -> s { inProgress = new_ip })-                            dbg "Adding new file to existing UrlRequest."-                        else dbg $ "Ignoring UrlRequest of file that's "-                                   ++ "already queued."--    alreadyDownloaded :: String -> IO Bool-    alreadyDownloaded u = do-        n <- withMVar urlNotifications $ return . Map.lookup u-        maybe (return True) (\v -> not `fmap` isEmptyMVar v) n---- |'checkWaitToStart' will inspect the current waiting-to-start queue, if the--- pipe isn't full,-checkWaitToStart :: UrlM ()-checkWaitToStart = do-    st <- get-    let l = pipeLength st-    mpl <- liftIO maxPipelineLength-    when (l < mpl) $-        case readQ (waitToStart st) of-            Nothing -> return ()-            Just (u, rest) -> do-                case Map.lookup u (inProgress st) of-                    Nothing -> error $ "bug in URL.checkWaitToStart " ++ u-                    Just (f, _, c) -> do-                        dbg $ "URL.requestUrl (" ++ u ++ "\n"-                              ++ "-> " ++ f ++ ")"-                        let f_new = createDownloadFileName f st-                        err <- liftIO $ requestUrl u f_new c-                        if null err-                            then do-                                -- waitNextUrl might never return this url as-                                -- complete/failed, so being careful, we should-                                -- try and delete the corresponding file atexit-                                liftIO $ atexit (removeFileMayNotExist f_new)-                                -- We've started off another download, so the-                                -- pipline length should increase.-                                put $ st { waitToStart = rest-                                         , pipeLength = l + 1 }-                            else do-                                dbg $ "Failed to start download URL " ++ u-                                      ++ ": " ++ err-                                liftIO $ do-                                    removeFileMayNotExist f_new-                                    downloadComplete u err-                                put $ st { waitToStart = rest }-                checkWaitToStart--copyUrlFirst :: String -> FilePath -> Cachable -> IO ()-copyUrlFirst = copyUrlWithPriority High--copyUrl :: String -> FilePath -> Cachable -> IO ()-copyUrl = copyUrlWithPriority Low--copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()-copyUrlWithPriority p u f c = do-    debugMessage $ "URL.copyUrlWithPriority (" ++ u ++ "\n"-                   ++ "-> " ++ f ++ ")"-    v <- newEmptyMVar-    old_mv <- modifyMVar urlNotifications (return . swap . Map.insertLookupWithKey (\_k _n old -> old) u v)-    case old_mv of-        Nothing -> atomically $ writeTChan urlChan $ UrlRequest u f c p -- ok, new URL-        Just _  -> debugMessage $ "URL.copyUrlWithPriority already in progress, skip (" ++ u ++ "\n" ++ "-> " ++ f ++ ")"--createDownloadFileName :: FilePath -> UrlState -> FilePath-createDownloadFileName f st = f ++ "-new_" ++ randomJunk st--waitNextUrl :: UrlM ()-waitNextUrl = do-    st <- get-    let l = pipeLength st-    when (l > 0) $ do-        dbg "URL.waitNextUrl start"-        (u, e, ce) <- liftIO waitNextUrl'-        let p = inProgress st-        liftIO $ case Map.lookup u p of-            Nothing ->-                -- A url finished downloading, but we don't have a record of it-                error $ "bug in URL.waitNextUrl: " ++ u-            Just (f, fs, _) -> if null e-                then do -- Succesful download-                    renameFile (createDownloadFileName f st) f-                    mapM_ (safeCopyFile st f) fs-                    downloadComplete u e-                    debugMessage $-                        "URL.waitNextUrl succeeded: " ++ u ++ " " ++ f-                else do -- An error while downloading-                    removeFileMayNotExist (createDownloadFileName f st)-                    downloadComplete u (maybe e show ce)-                    debugMessage $-                        "URL.waitNextUrl failed: " ++ u ++ " " ++ f ++ " " ++ e-        unless (null u) . put $ st { inProgress = Map.delete u p-                                   , pipeLength = l - 1 }-  where-    safeCopyFile st f t = do-        let new_t = createDownloadFileName t st-        copyFile f new_t-        renameFile new_t t--downloadComplete :: String -> String -> IO ()-downloadComplete u e = do-    r <- withMVar urlNotifications (return . Map.lookup u)-    case r of-        Just notifyVar ->-            putMVar notifyVar $ if null e then Nothing else Just e-        Nothing -> debugMessage $ "downloadComplete URL '" ++ u-                                  ++ "' downloaded several times"--waitUrl :: String -> IO ()-waitUrl u = do-    debugMessage $ "URL.waitUrl " ++ u-    r <- withMVar urlNotifications (return . Map.lookup u)-    case r of-        Nothing  -> return () -- file was already downloaded-        Just var -> do-            mbErr <- readMVar var-            modifyMVar_ urlNotifications (return . Map.delete u)-            flip (maybe (return ())) mbErr $ \e -> do-                debugMessage $ "Failed to download URL " ++ u ++ ": " ++ e-                fail e--dbg :: String -> StateT a IO ()-dbg = liftIO . debugMessage--requestUrl :: String -> FilePath -> Cachable -> IO String-requestUrl = Curl.requestUrl--waitNextUrl' :: IO (String, String, Maybe ConnectionError)-waitNextUrl' = Curl.waitNextUrl--minCachable :: Cachable -> Cachable -> Cachable-minCachable Uncachable _          = Uncachable-minCachable _          Uncachable = Uncachable-minCachable (MaxAge a) (MaxAge b) = MaxAge $ min a b-minCachable (MaxAge a) _          = MaxAge a-minCachable _          (MaxAge b) = MaxAge b-minCachable _          _          = Cachable-#endif--disableHTTPPipelining :: IO ()-disableHTTPPipelining = writeIORef maxPipelineLengthRef 1--setDebugHTTP :: IO ()-pipeliningEnabled :: IO Bool--#ifdef HAVE_CURL--setDebugHTTP = Curl.setDebugHTTP-pipeliningEnabled = Curl.pipeliningEnabled--#else--setDebugHTTP = return ()-pipeliningEnabled = return True--#endif---- Usage of these environment variables happens in C code, so the--- closest to "literate" user documentation is here, where the--- offending function 'curl_request_url' is imported.-environmentHelpProxy :: ([String], [String])-environmentHelpProxy =-    ( [ "HTTP_PROXY", "HTTPS_PROXY", "FTP_PROXY", "ALL_PROXY", "NO_PROXY"]-    , [ "If Darcs was built with libcurl, the environment variables"-      , "HTTP_PROXY, HTTPS_PROXY and FTP_PROXY can be set to the URL of a"-      , "proxy in the form"-      , ""-      , "    [protocol://]<host>[:port]"-      , ""-      , "In which case libcurl will use the proxy for the associated protocol"-      , "(HTTP, HTTPS and FTP). The environment variable ALL_PROXY can be used"-      , "to set a single proxy for all libcurl requests."-      , ""-      , "If the environment variable NO_PROXY is a comma-separated list of"-      , "host names, access to those hosts will bypass proxies defined by the"-      , "above variables. For example, it is quite common to avoid proxying"-      , "requests to machines on the local network with"-      , ""-      , "    NO_PROXY=localhost,*.localdomain"-      , ""-      , "For compatibility with lynx et al, lowercase equivalents of these"-      , "environment variables (e.g. $http_proxy) are also understood and are"-      , "used in preference to the uppercase versions."-      , ""-      , "If Darcs was not built with libcurl, all these environment variables"-      , "are silently ignored, and there is no way to use a web proxy."-      ]-    )--environmentHelpProxyPassword :: ([String], [String])-environmentHelpProxyPassword =-    ( [ "DARCS_PROXYUSERPWD" ]-    , [ "If Darcs was built with libcurl, and you are using a web proxy that"-      , "requires authentication, you can set the $DARCS_PROXYUSERPWD"-      , "environment variable to the username and password expected by the"-      , "proxy, separated by a colon.  This environment variable is silently"-      , "ignored if Darcs was not built with libcurl."-      ]-    )
− src/Darcs/Util/Download/Curl.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module Darcs.Util.Download.Curl where--#ifdef HAVE_CURL--import Darcs.Prelude--import Control.Exception ( bracket )-import Control.Monad ( when )-import Foreign.C.Types ( CLong(..), CInt(..) )--import Darcs.Util.Progress ( debugMessage )--import Darcs.Util.Download.Request--import Foreign.C.String ( withCString, peekCString, CString )-import Foreign.Ptr-import Foreign.Marshal.Alloc-import Foreign.Storable--setDebugHTTP :: IO ()-setDebugHTTP = curl_enable_debug--requestUrl :: String -> FilePath -> Cachable -> IO String-requestUrl u f cache =-  withCString u $ \ustr ->-  withCString f $ \fstr ->-  bracket malloc free $ \ errorPointer -> do-    e <- curl_request_url ustr fstr (cachableToInt cache) errorPointer >>= peekCString-    errorNum <- peek errorPointer-    when (errorNum == 90 ) $ debugMessage "The environment variable DARCS_CONNECTION_TIMEOUT is not a number"-    return e--waitNextUrl :: IO (String, String, Maybe ConnectionError)-waitNextUrl =-  bracket malloc free $ \ errorPointer ->-  bracket malloc free $ \ httpErrorPointer -> do-    e <- curl_wait_next_url errorPointer httpErrorPointer >>= peekCString-    ce <- do-           errorNum <- peek errorPointer-           if null e then return Nothing-             else return $-              case errorNum of-                6  -> Just CouldNotResolveHost-                7  -> Just CouldNotConnectToServer-                28 -> Just OperationTimeout-                _  -> Nothing-    u <- curl_last_url >>= peekCString-    httpErrorCode <- peek httpErrorPointer-    let detailedErrorMessage = if httpErrorCode > 0-                               then e ++ " " ++ show httpErrorCode-                               else e-    return (u, detailedErrorMessage, ce)--pipeliningEnabled :: IO Bool-pipeliningEnabled = do-  r <- curl_pipelining_enabled-  return $ r /= 0--cachableToInt :: Cachable -> CInt-cachableToInt Cachable = -1-cachableToInt Uncachable = 0-cachableToInt (MaxAge n) = n--foreign import ccall "hscurl.h curl_request_url"-  curl_request_url :: CString -> CString -> CInt -> Ptr CInt -> IO CString--foreign import ccall "hscurl.h curl_wait_next_url"-  curl_wait_next_url :: Ptr CInt -> Ptr CLong-> IO CString--foreign import ccall "hscurl.h curl_last_url"-  curl_last_url :: IO CString--foreign import ccall "hscurl.h curl_enable_debug"-  curl_enable_debug :: IO ()--foreign import ccall "hscurl.h curl_pipelining_enabled"-  curl_pipelining_enabled :: IO CInt--#endif
− src/Darcs/Util/Download/Request.hs 
@@ -1,109 +0,0 @@-module Darcs.Util.Download.Request-    ( UrlRequest(..)-    , Cachable(..)-    , UrlState(..)-    , Q(..)-    , readQ-    , insertQ-    , pushQ-    , addUsingPriority-    , deleteQ-    , elemQ-    , emptyQ-    , nullQ-    , Priority(..)-    , ConnectionError(..)-    ) where--import Darcs.Prelude--import Data.List ( delete )-import Data.Map ( Map )-import Foreign.C.Types ( CInt )--data Priority = High-              | Low-              deriving Eq--data Cachable = Cachable-              | Uncachable-              | MaxAge !CInt-              deriving (Show, Eq)---- | A UrlRequest object contains a url to get, the file into which the--- contents at the given url should be written, the cachability of this request--- and the request's priority.-data UrlRequest = UrlRequest-    { url :: String-    , file :: FilePath-    , cachable :: Cachable-    , priority :: Priority-    }--type InProgressStatus = ( FilePath -- FilePath to write url contents into-                        , [FilePath] -- Extra paths to copy complete file into-                        , Cachable -- Cachable status-                        )---- | A UrlState object contains a map of url -> InProgressStatus, a Q of urls--- waiting to be started, the current pipe length and the unique junk to--- create unique filenames.-data UrlState = UrlState-    { inProgress :: Map String InProgressStatus-    , waitToStart :: Q String-    , pipeLength :: Int-    , randomJunk :: String-    }---- |Q represents a prioritised queue, with two-tier priority. The left list--- contains higher priority items than the right list.-data Q a = Q [a] [a]---- |'readQ' will try and take an element from the Q, preferring elements from--- the high priority list.-readQ :: Q a -> Maybe (a, Q a)-readQ (Q (x : xs) ys) = return (x, Q xs ys)-readQ (Q [] ys) = do-    x : xs <- return $ reverse ys-    return (x, Q xs [])---- | Return a function for adding an element based on the priority.-addUsingPriority :: Priority -> a -> Q a -> Q a-addUsingPriority High = pushQ-addUsingPriority Low = insertQ---- |'insertQ' inserts a low priority item into a Q.-insertQ :: a -> Q a -> Q a-insertQ y (Q xs ys) = Q xs (y:ys)---- |'pushQ' inserts a high priority item into a Q.-pushQ :: a -> Q a -> Q a-pushQ x (Q xs ys) = Q (x:xs) ys---- |'deleteQ' removes any instances of a given element from the Q.-deleteQ :: Eq a => a -> Q a -> Q a-deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys)---- |'deleteQ' checks for membership in a Q.-elemQ :: Eq a => a -> Q a -> Bool-elemQ x (Q xs ys) = x `elem` xs || x `elem` ys---- |'emptyQ' is an empty Q.-emptyQ :: Q a-emptyQ = Q [] []---- |'nullQ' checks if the Q contains no items.-nullQ :: Q a -> Bool-nullQ (Q [] []) = True-nullQ _         = False---- | Data type to represent a connection error.--- The following are the codes from libcurl--- which map to each of the constructors:--- * 6  -> CouldNotResolveHost : The remote host was not resolved.--- * 7  -> CouldNotConnectToServer : Failed to connect() to host or proxy.--- * 28 -> OperationTimeout: the specified time-out period was reached.-data ConnectionError = CouldNotResolveHost-                     | CouldNotConnectToServer-                     | OperationTimeout-                     deriving (Eq, Read, Show)
src/Darcs/Util/Exception.hs view
@@ -1,13 +1,14 @@ module Darcs.Util.Exception     ( firstJustIO     , catchall-    , catchNonExistence     , clarifyErrors     , prettyException     , prettyError     , die     , handleOnly     , handleOnlyIOError+    , catchDoesNotExistError+    , handleDoesNotExistError     , ifIOError     , ifDoesNotExistError     ) where@@ -33,18 +34,11 @@     , isUserError     ) +import Darcs.Util.Global ( debugMessage ) import Darcs.Util.SignalHandler ( catchNonSignal ) -catchall :: IO a-         -> IO a-         -> IO a-a `catchall` b = a `catchNonSignal` (\_ -> b)--catchNonExistence :: IO a -> a -> IO a-catchNonExistence job nonexistval =-    catch job $-    \e -> if isDoesNotExistError e then return nonexistval-                                   else ioError e+catchall :: IO a -> IO a -> IO a+a `catchall` b = a `catchNonSignal` (\e -> debugMessage ("catchall: "++show e) >> b)  -- | The firstJustM returns the first Just entry in a list of monadic -- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence@@ -97,6 +91,14 @@ -- normally don't want to handle such errors. handleOnlyIOError :: IO a -> IO a -> IO a handleOnlyIOError = handleOnly (not . isUserError)++-- | Handle only non-existence.+handleDoesNotExistError :: IO a -> IO a -> IO a+handleDoesNotExistError = handleOnly isDoesNotExistError++-- | Handle only non-existence.+catchDoesNotExistError :: IO a -> IO a -> IO a+catchDoesNotExistError = flip handleDoesNotExistError  -- | Like 'handleOnlyIOError' but restricted to returning a given value. ifIOError :: a -> IO a -> IO a
− src/Darcs/Util/External.hs 
@@ -1,176 +0,0 @@-{-# LANGUAGE CPP #-}-module Darcs.Util.External-    ( cloneTree-    , cloneFile-    , fetchFilePS-    , fetchFileLazyPS-    , gzFetchFilePS-    , speculateFileOrUrl-    , copyFileOrUrl-    , Cachable(..)-    , backupByRenaming-    , backupByCopying-    ) where--import Control.Exception ( catch, IOException )--import System.Posix.Files-    ( getSymbolicLinkStatus-    , isRegularFile-    , isDirectory-    , createLink-    )-import System.Directory-    ( createDirectory-    , listDirectory-    , doesDirectoryExist-    , doesFileExist-    , renameFile-    , renameDirectory-    , copyFile-    )--import System.FilePath.Posix ( (</>), normalise )-import System.IO.Error ( isDoesNotExistError )-import Control.Monad-    ( unless-    , when-    , zipWithM_-    )--import Darcs.Prelude--import Darcs.Util.Global ( defaultRemoteDarcsCmd )-import Darcs.Util.Download ( Cachable(..) )-#ifdef HAVE_CURL-import Darcs.Util.Download ( copyUrl, copyUrlFirst, waitUrl )-#endif-import qualified Darcs.Util.HTTP as HTTP-import Darcs.Util.URL-    ( isValidLocalPath-    , isHttpUrl-    , isSshUrl-    , splitSshUrl-    )-import Darcs.Util.Exception ( catchall )-import Darcs.Util.Lock ( withTemp )-import Darcs.Util.Ssh ( copySSH )-import Darcs.Util.ByteString ( gzReadFilePS )-import qualified Data.ByteString as B (ByteString, readFile )-import qualified Data.ByteString.Lazy as BL--import Network.URI-    ( parseURI-    , uriScheme-    )--copyFileOrUrl :: String    -- ^ remote darcs executable-              -> FilePath  -- ^ path representing the origin file or URL-              -> FilePath  -- ^ destination path-              -> Cachable  -- ^ tell whether file to copy is cachable-              -> IO ()-copyFileOrUrl _    fou out _     | isValidLocalPath fou = copyLocal fou out-copyFileOrUrl _    fou out cache | isHttpUrl  fou = copyRemote fou out cache-copyFileOrUrl rd   fou out _     | isSshUrl  fou = copySSH rd (splitSshUrl fou) out-copyFileOrUrl _    fou _   _     = fail $ "unknown transport protocol: " ++ fou--copyLocal  :: String -> FilePath -> IO ()-copyLocal fou out = createLink fou out `catchall` cloneFile fou out--cloneTree :: FilePath -> FilePath -> IO ()-cloneTree source dest =- do fs <- getSymbolicLinkStatus source-    if isDirectory fs then do-        fps <- listDirectory source-        zipWithM_ cloneSubTree (map (source </>) fps) (map (dest </>) fps)-     else fail ("cloneTree: Bad source " ++ source)-   `catch` \(_ :: IOException) -> fail ("cloneTree: Bad source " ++ source)--cloneSubTree :: FilePath -> FilePath -> IO ()-cloneSubTree source dest =- do fs <- getSymbolicLinkStatus source-    if isDirectory fs then do-        createDirectory dest-        fps <- listDirectory source-        zipWithM_ cloneSubTree (map (source </>) fps) (map (dest </>) fps)-     else if isRegularFile fs then-        cloneFile source dest-     else fail ("cloneSubTree: Bad source "++ source)-    `catch` (\e -> unless (isDoesNotExistError e) $ ioError e)--cloneFile :: FilePath -> FilePath -> IO ()-cloneFile = copyFile--backupByRenaming :: FilePath -> IO ()-backupByRenaming = backupBy rename- where rename x y = do-         isD <- doesDirectoryExist x-         if isD then renameDirectory x y else renameFile x y--backupByCopying :: FilePath -> IO ()-backupByCopying = backupBy copy- where-  copy x y = do-    isD <- doesDirectoryExist x-    if isD then do createDirectory y-                   cloneTree (normalise x) (normalise y)-           else copyFile x y--backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()-backupBy backup f =-           do hasBF <- doesFileExist f-              hasBD <- doesDirectoryExist f-              when (hasBF || hasBD) $ helper 0-  where-  helper :: Int -> IO ()-  helper i = do existsF <- doesFileExist next-                existsD <- doesDirectoryExist next-                if existsF || existsD-                   then helper (i + 1)-                   else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"-                           backup f next-             where next = f ++ suffix-                   suffix = ".~" ++ show i ++ "~"--copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a-copyAndReadFile readfn fou _ | isValidLocalPath fou = readfn fou-copyAndReadFile readfn fou cache = withTemp $ \t -> do-  copyFileOrUrl defaultRemoteDarcsCmd fou t cache-  readfn t---- | @fetchFile fileOrUrl cache@ returns the content of its argument (either a--- file or an URL). If it has to download an url, then it will use a cache as--- required by its second argument.------ We always use default remote darcs, since it is not fatal if the remote--- darcs does not exist or is too old -- anything that supports transfer-mode--- should do, and if not, we will fall back to SFTP or SCP.-fetchFilePS :: String -> Cachable -> IO B.ByteString-fetchFilePS = copyAndReadFile (B.readFile)---- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument--- (either a file or an URL). Warning: this function may constitute a fd leak;--- make sure to force consumption of file contents to avoid that. See--- "fetchFilePS" for details.-fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString-fetchFileLazyPS x c = case parseURI x of-  Just x' | uriScheme x' == "http:" -> HTTP.copyRemoteLazy x c-  _ -> copyAndReadFile BL.readFile x c--gzFetchFilePS :: String -> Cachable -> IO B.ByteString-gzFetchFilePS = copyAndReadFile gzReadFilePS--speculateFileOrUrl :: String -> FilePath -> IO ()-speculateFileOrUrl fou out | isHttpUrl fou = speculateRemote fou out-                           | otherwise = return ()--copyRemote :: String -> FilePath -> Cachable -> IO ()-speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable--#ifdef HAVE_CURL-copyRemote u v cache = copyUrlFirst u v cache >> waitUrl u-speculateRemote u v = copyUrl u v Cachable-#else-copyRemote = HTTP.copyRemote-speculateRemote = HTTP.speculateRemote-#endif
src/Darcs/Util/File.hs view
@@ -1,92 +1,78 @@-{-# LANGUAGE CPP #-} module Darcs.Util.File-    (-    -- * Files and directories+    ( -- * Files and directories       getFileStatus-    , withCurrentDirectory     , doesDirectoryReallyExist     , removeFileMayNotExist     , getRecursiveContents     , getRecursiveContentsFullPath-    -- * OS-dependent special directories-    , xdgCacheDir-    , osxCacheDir+    , copyTree+      -- * Fetching files+    , fetchFilePS+    , fetchFileLazyPS+    , gzFetchFilePS+    , speculateFileOrUrl+    , copyFileOrUrl+    , Cachable(..)+      -- * Backup+    , backupByRenaming+    , backupByCopying+      -- * Temporary files+    , withTemp+    , withOpenTemp     ) where  import Darcs.Prelude--import Control.Exception ( bracket )-import Control.Monad ( when, unless, forM )--import Data.List ( lookup )--import System.Environment ( getEnvironment )-import System.Directory ( removeFile, getHomeDirectory,-                          getAppUserDataDirectory, doesDirectoryExist,-                          createDirectory, listDirectory )-import System.IO.Error ( catchIOError )-import System.Posix.Files( getSymbolicLinkStatus, FileStatus, isDirectory )-#ifndef WIN32-import System.Posix.Files( setFileMode, ownerModes )-#endif-import System.FilePath.Posix ( (</>) )--import Darcs.Util.Exception ( catchall, catchNonExistence )-import Darcs.Util.Path( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )+import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Exception ( catchall, ifDoesNotExistError )+import Darcs.Util.Global ( defaultRemoteDarcsCmd )+import Darcs.Util.HTTP ( Cachable(..) )+import qualified Darcs.Util.HTTP as HTTP+import Darcs.Util.Path ( FilePathLike, toFilePath )+import Darcs.Util.Ssh ( copySSH )+import Darcs.Util.URL ( isHttpUrl, isSshUrl, isValidLocalPath, splitSshUrl ) -withCurrentDirectory :: FilePathLike p-                     => p-                     -> IO a-                     -> IO a-withCurrentDirectory name m =-    bracket-        (do cwd <- getCurrentDirectory-            when (toFilePath name /= "") (setCurrentDirectory name)-            return cwd)-        (\oldwd -> setCurrentDirectory oldwd `catchall` return ())-        (const m)+import Control.Exception ( IOException, bracket, catch )+import Control.Monad ( forM, unless, when, zipWithM_ )+import qualified Data.ByteString as B ( ByteString, readFile )+import qualified Data.ByteString.Lazy as BL+import Network.URI ( parseURI, uriScheme )+import System.Directory+    ( copyFile+    , createDirectory+    , doesDirectoryExist+    , doesFileExist+    , listDirectory+    , removeFile+    , renameDirectory+    , renameFile+    )+import System.FilePath.Posix ( normalise, (</>) )+import System.IO ( Handle, hClose, openBinaryTempFile )+import System.IO.Error ( catchIOError, isDoesNotExistError )+import System.Posix.Files+    ( FileStatus+    , createLink+    , getSymbolicLinkStatus+    , isDirectory+    , isRegularFile+    ) +-- | Badly named, since it is actually 'getSymbolicLinkStatus', with all+-- 'IOError's turned into 'Nothing'. getFileStatus :: FilePath -> IO (Maybe FileStatus) getFileStatus f =   Just `fmap` getSymbolicLinkStatus f `catchIOError` (\_-> return Nothing) +-- | Whether a path is an existing directory, but not a symlink to one. doesDirectoryReallyExist :: FilePath -> IO Bool doesDirectoryReallyExist f =-    catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False+    ifDoesNotExistError False (isDirectory `fmap` getSymbolicLinkStatus f) +-- | Variant of 'removeFile' that doesn't throw exception when file does not exist. removeFileMayNotExist :: FilePathLike p => p -> IO ()-removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) ()---- |osxCacheDir assumes @~/Library/Caches/@ exists.-osxCacheDir :: IO (Maybe FilePath)-osxCacheDir = do-    home <- getHomeDirectory-    return $ Just $ home </> "Library" </> "Caches"-    `catchall` return Nothing---- |xdgCacheDir returns the $XDG_CACHE_HOME environment variable,--- or @~/.cache@ if undefined. See the FreeDesktop specification:--- http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html-xdgCacheDir :: IO (Maybe FilePath)-xdgCacheDir = do-    env <- getEnvironment-    d <- case lookup "XDG_CACHE_HOME" env of-           Just d  -> return d-           Nothing -> getAppUserDataDirectory "cache"-    exists <- doesDirectoryExist d--    -- If directory does not exist, create it with permissions 0700-    -- as specified by the FreeDesktop standard.-    unless exists $ do createDirectory d-#ifndef WIN32-    -- see http://bugs.darcs.net/issue2334-                       setFileMode d ownerModes-#endif-    return $ Just d-    `catchall` return Nothing+removeFileMayNotExist f = ifDoesNotExistError () (removeFile $ toFilePath f) --- |getRecursiveContents returns all files under topdir that aren't--- directories.+-- | Return all files under given directory that aren't directories. getRecursiveContents :: FilePath -> IO [FilePath] getRecursiveContents topdir = do   entries <- listDirectory topdir@@ -98,9 +84,8 @@       else return [name]   return (concat paths) --- |getRecursiveContentsFullPath returns all files under topdir--- that aren't directories.--- Unlike getRecursiveContents this function returns the full path.+-- | Return all files under given directory that aren't directories.+-- Unlike 'getRecursiveContents' this function returns the full path. getRecursiveContentsFullPath :: FilePath -> IO [FilePath] getRecursiveContentsFullPath topdir = do   entries <- listDirectory topdir@@ -111,3 +96,140 @@       then getRecursiveContentsFullPath path       else return [path]   return (concat paths)++-- | Very much darcs-specific copying procedure. For local files it tries+-- to hard-link, falling back to normal copy if it fails. Remote URLs are+-- downloaded using either HTTP or SSH. For SSH, this tries to use the+-- given remote darcs command to invoke it's transfer-mode command.+copyFileOrUrl :: String    -- ^ remote darcs executable+              -> String    -- ^ path representing the origin file or URL+              -> FilePath  -- ^ destination path+              -> Cachable  -- ^ tell whether file to copy is cachable+              -> IO ()+copyFileOrUrl _    fou out _     | isValidLocalPath fou = copyLocal fou out+copyFileOrUrl _    fou out cache | isHttpUrl fou = HTTP.copyRemote fou out cache+copyFileOrUrl rd   fou out _     | isSshUrl fou = copySSH rd (splitSshUrl fou) out+copyFileOrUrl _    fou _   _     = fail $ "unknown transport protocol: " ++ fou++-- | Hard-link file, falling back to normal copying it that fails.+copyLocal  :: String -> FilePath -> IO ()+copyLocal fou out = createLink fou out `catchall` copyFile fou out++-- | Recursively copy a directory, where the target directory is supposed to+-- already exist.+copyTree :: FilePath -> FilePath -> IO ()+copyTree source dest =+ do fs <- getSymbolicLinkStatus source+    if isDirectory fs then do+        fps <- listDirectory source+        zipWithM_ copySubTree (map (source </>) fps) (map (dest </>) fps)+     else fail ("copyTree: Bad source " ++ source)+   `catch` \(_ :: IOException) -> fail ("copyTree: Bad source " ++ source)++-- | Recursively copy a directory, where the target directory does not yet+-- exist but it's parent does.+copySubTree :: FilePath -> FilePath -> IO ()+copySubTree source dest =+ do fs <- getSymbolicLinkStatus source+    if isDirectory fs then do+        createDirectory dest+        fps <- listDirectory source+        zipWithM_ copySubTree (map (source </>) fps) (map (dest </>) fps)+     else if isRegularFile fs then+        copyFile source dest+     else fail ("copySubTree: Bad source "++ source)+    `catch` (\e -> unless (isDoesNotExistError e) $ ioError e)++backupByRenaming :: FilePath -> IO ()+backupByRenaming = backupBy rename+ where rename x y = do+         isD <- doesDirectoryExist x+         if isD then renameDirectory x y else renameFile x y++backupByCopying :: FilePath -> IO ()+backupByCopying = backupBy copy+ where+  copy x y = do+    isD <- doesDirectoryExist x+    if isD then do createDirectory y+                   copyTree (normalise x) (normalise y)+           else copyFile x y++backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()+backupBy backup f =+           do hasBF <- doesFileExist f+              hasBD <- doesDirectoryExist f+              when (hasBF || hasBD) $ helper 0+  where+  helper :: Int -> IO ()+  helper i = do existsF <- doesFileExist next+                existsD <- doesDirectoryExist next+                if existsF || existsD+                   then helper (i + 1)+                   else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"+                           backup f next+             where next = f ++ suffix+                   suffix = ".~" ++ show i ++ "~"++-- | Generic file fetching support function that takes care of downloading+-- remote files to a temporary location if necessary before invoking the actual+-- reading procedure.+copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a+copyAndReadFile readfn fou _ | isValidLocalPath fou = readfn fou+copyAndReadFile readfn fou cache = withTemp $ \t -> do+  copyFileOrUrl defaultRemoteDarcsCmd fou t cache+  readfn t++-- | @fetchFilePS fileOrUrl cache@ returns the content of its argument (either a+-- file or an URL). If it has to download an url, then it will use a cache as+-- required by its second argument.+--+-- We always use default remote darcs, since it is not fatal if the remote+-- darcs does not exist or is too old -- anything that supports transfer-mode+-- should do, and if not, we will fall back to SFTP or SCP.+fetchFilePS :: String -> Cachable -> IO B.ByteString+fetchFilePS = copyAndReadFile B.readFile++-- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument+-- (either a file or an URL). Warning: this function may constitute a fd leak;+-- make sure to force consumption of file contents to avoid that. See+-- "fetchFilePS" for details.+fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString+fetchFileLazyPS x c =+  case parseURI x of+    Just x'+      | let s = uriScheme x'+      , s == "http:" || s == "https:" -> HTTP.copyRemoteLazy x c+    _ -> copyAndReadFile BL.readFile x c++-- | Like 'fetchFilePS' but transparently handle gzip compressed files.+gzFetchFilePS :: String -> Cachable -> IO B.ByteString+gzFetchFilePS = copyAndReadFile gzReadFilePS++-- | Initiate background file download for the given file path or URL+-- to the given location.+speculateFileOrUrl :: String -> FilePath -> IO ()+speculateFileOrUrl fou out+  | isHttpUrl fou = HTTP.speculateRemote fou out+  | otherwise = return ()++-- | Invoke the given action on a file that is temporarily created+-- in the current directory, and removed afterwards.+withTemp :: (FilePath -> IO a) -> IO a+withTemp = bracket get_empty_file removeFileMayNotExist+  where+    get_empty_file = do+      (f, h) <- openBinaryTempFile "." "darcs"+      hClose h `catchall` return ()+      return f++-- | Invoke the given action on a file that is temporarily created and opened+-- in the current directory, and closed and removed afterwards.+withOpenTemp :: ((Handle, FilePath) -> IO a) -> IO a+withOpenTemp = bracket get_empty_file cleanup+  where+    cleanup (h, f) = do+      hClose h `catchall` return ()+      removeFileMayNotExist f+    get_empty_file = swap `fmap` openBinaryTempFile "." "darcs"+    swap (a, b) = (b, a)
src/Darcs/Util/Global.hs view
@@ -29,14 +29,11 @@ -- purity of darcs, in favour of programming convenience.  module Darcs.Util.Global-    (-      timingsMode-    , setTimingsMode+    ( setTimingsMode     , whenDebugMode     , withDebugMode     , setDebugMode     , debugMessage-    , putTiming     , addCRCWarning     , getCRCWarnings     , resetCRCWarnings@@ -51,11 +48,13 @@ import Darcs.Prelude  import Control.Monad ( when )-import Data.IORef ( modifyIORef, IORef, newIORef, readIORef, writeIORef )-import System.IO.Unsafe (unsafePerformIO)-import System.IO ( hPutStrLn, hPutStr, stderr )-import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.Time.Clock.System ( getSystemTime, systemToTAITime )+import Data.Time.Clock.TAI ( AbsoluteTime, diffAbsoluteTime )+import Data.Time.Format ( defaultTimeLocale, formatTime ) import System.FilePath.Posix ( combine, (<.>) )+import System.IO ( hPutStr, hPutStrLn, stderr )+import System.IO.Unsafe ( unsafePerformIO )   -- Write-once-read-many global variables make it easier to implement flags, such@@ -86,24 +85,24 @@   putTiming :: IO ()-putTiming = when timingsMode $ do-    t <- getClockTime >>= toCalendarTime-    hPutStr stderr (calendarTimeToString t++": ")-+putTiming = do+  readIORef _timingsMode >>= \case+    Nothing -> return ()+    Just start -> do+      now <- systemToTAITime <$> getSystemTime+      hPutStr stderr (format (diffAbsoluteTime now start))+  where+    -- mm:ss.micros, similar to `ts -s "%m:%.S"`+    format = formatTime defaultTimeLocale "%02m:%06ES " -_timingsMode :: IORef Bool-_timingsMode = unsafePerformIO $ newIORef False+_timingsMode :: IORef (Maybe AbsoluteTime)+_timingsMode = unsafePerformIO $ newIORef Nothing {-# NOINLINE _timingsMode #-} - setTimingsMode :: IO ()-setTimingsMode = writeIORef _timingsMode True---timingsMode :: Bool-timingsMode = unsafePerformIO $ readIORef _timingsMode-{-# NOINLINE timingsMode #-}-+setTimingsMode = do+  start <- systemToTAITime <$> getSystemTime+  writeIORef _timingsMode (Just start)  type CRCWarningList = [FilePath] _crcWarningList :: IORef CRCWarningList
src/Darcs/Util/HTTP.hs view
@@ -1,4 +1,10 @@-module Darcs.Util.HTTP ( copyRemote, copyRemoteLazy, speculateRemote, postUrl ) where+module Darcs.Util.HTTP+    ( Cachable(..)+    , copyRemote+    , copyRemoteLazy+    , speculateRemote+    , postUrl+    ) where  import Control.Concurrent.Async ( async, cancel, poll ) import Control.Exception ( catch )@@ -9,6 +15,9 @@ import qualified Data.ByteString.Char8 as BC  import Data.Conduit.Combinators ( sinkLazy )++import Foreign.C.Types ( CInt )+ import Network.HTTP.Simple     ( HttpException(..)     , Request@@ -18,8 +27,14 @@     , getResponseBody     , setRequestHeaders     , setRequestMethod+    , setRequestResponseTimeout     )-import Network.HTTP.Conduit ( parseUrlThrow )+import Network.HTTP.Conduit+    ( ResponseTimeout+    , parseUrlThrow+    , responseTimeoutDefault+    , responseTimeoutMicro+    ) import Network.HTTP.Types.Header     ( hCacheControl     , hPragma@@ -29,25 +44,43 @@     ) import Numeric ( showHex ) import System.Directory ( renameFile )+import System.Environment ( lookupEnv )+import Text.Read ( readMaybe )  import Darcs.Prelude  import Darcs.Util.AtExit ( atexit )-import Darcs.Util.Download.Request ( Cachable(..) ) import Darcs.Util.Global ( debugMessage ) +data Cachable+  = Cachable+  | Uncachable+  | MaxAge !CInt+  deriving (Show, Eq)++darcsResponseTimeout :: IO ResponseTimeout+darcsResponseTimeout =+  lookupEnv "DARCS_CONNECTION_TIMEOUT" >>= \case+    Just s | Just n <- readMaybe s ->+      return $ responseTimeoutMicro $ 1000000 * n+    _ -> return responseTimeoutDefault -- 30 s, seems a bit long+ copyRemote :: String -> FilePath -> Cachable -> IO () copyRemote url path cachable = do+  debugMessage $ "copyRemote: " ++ url   junk <- flip showHex "" <$> seedToInteger <$> seedNew   let tmppath = path ++ ".new_" ++ junk+  tmo <- darcsResponseTimeout   handleHttpAndUrlExn url-    (httpBS . addCacheControl cachable >=> B.writeFile tmppath . getResponseBody)+    (httpBS . setRequestResponseTimeout tmo . addCacheControl cachable >=>+     B.writeFile tmppath . getResponseBody)   renameFile tmppath path  -- TODO instead of producing a lazy ByteString we should re-write the -- consumer (Darcs.Repository.Packs) to use proper streaming (e.g. conduit) copyRemoteLazy :: String -> Cachable -> IO (BL.ByteString)-copyRemoteLazy url cachable =+copyRemoteLazy url cachable = do+  debugMessage $ "copyRemoteLazy: " ++ url   handleHttpAndUrlExn url     (flip httpSink (const sinkLazy) . addCacheControl cachable)
src/Darcs/Util/Hash.hs view
@@ -1,11 +1,10 @@ --  Copyright (C) 2009-2011 Petr Rockai BSD3 --  Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li> -{-# LANGUAGE CPP #-} module Darcs.Util.Hash     ( Hash(..)-    , encodeBase16, decodeBase16, sha256, sha256sum, rawHash-    , match+    , encodeBase16, decodeBase16, sha256, sha256strict, sha256sum, rawHash, mkHash+    , match, encodeHash, decodeHash, showHash     -- SHA1 related (patch metadata hash)     , sha1PS, SHA1(..), showAsHex, sha1Xor, sha1zero, sha1short     , sha1Show, sha1Read@@ -17,6 +16,7 @@  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Base16 as B16 @@ -31,44 +31,53 @@ import Darcs.Prelude  -data Hash = SHA256 !B.ByteString-          | NoHash-            deriving (Show, Eq, Ord, Read)+newtype Hash = SHA256 BS.ShortByteString+  deriving (Show, Eq, Ord, Read) +decodeHash :: String -> Maybe Hash+decodeHash = decodeBase16 . BC.pack++encodeHash :: Hash -> String+encodeHash = BC.unpack . encodeBase16+ -- | Produce a base16 (ascii-hex) encoded string from a hash. This can be -- turned back into a Hash (see "decodeBase16". This is a loss-less process. encodeBase16 :: Hash -> B.ByteString-encodeBase16 (SHA256 bs) = B16.encode bs-encodeBase16 NoHash = B.empty+encodeBase16 (SHA256 bs) = B16.encode (BS.fromShort bs)  -- | Take a base16-encoded string and decode it as a "Hash". If the string is--- malformed, yields NoHash.-decodeBase16 :: B.ByteString -> Hash+-- malformed, yields Nothing.+decodeBase16 :: B.ByteString -> Maybe Hash decodeBase16 bs   | B.length bs == 64-#if MIN_VERSION_base16_bytestring(1,0,0)-  , Right dbs <- B16.decode bs = SHA256 dbs-#else-  , (dbs, rest) <- B16.decode bs, B.null rest = SHA256 dbs-#endif-  | otherwise = NoHash+  , Right dbs <- B16.decode bs = Just (SHA256 (BS.toShort dbs))+  | otherwise = Nothing  -- | Compute a sha256 of a (lazy) ByteString. sha256 :: BL.ByteString -> Hash-sha256 bits = SHA256 (convert (H.hashlazy bits :: H.Digest H.SHA256))+sha256 bits = SHA256 (BS.toShort (convert (H.hashlazy bits :: H.Digest H.SHA256)))  -- | Same as previous but general purpose. sha256sum :: B.ByteString -> String sha256sum = BC.unpack . B16.encode . convert . H.hashWith H.SHA256 +sha256strict :: B.ByteString -> Hash+sha256strict = SHA256 . BS.toShort . convert . H.hashWith H.SHA256+ rawHash :: Hash -> B.ByteString-rawHash NoHash = error "Cannot obtain raw hash from NoHash."-rawHash (SHA256 s) = s+rawHash (SHA256 s) = BS.fromShort s -match :: Hash -> Hash -> Bool-NoHash `match` _ = False-_ `match` NoHash = False-x `match` y = x == y+mkHash :: B.ByteString -> Hash+mkHash = SHA256 . BS.toShort++match :: Maybe Hash -> Maybe Hash -> Bool+Nothing `match` _ = False+_ `match` Nothing = False+Just x `match` Just y = x == y++showHash :: Maybe Hash -> String+showHash (Just h) = encodeHash h+showHash Nothing = "(no hash available)"  data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32   deriving (Eq,Ord)
src/Darcs/Util/Index.hs view
@@ -1,14 +1,14 @@ --  Copyright (C) 2009-2011 Petr Rockai --            (C) 2013 Jose Neder --  BSD3-{-# LANGUAGE CPP, MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses #-}  -- | This module contains plain tree indexing code. The index itself is a -- CACHE: you should only ever use it as an optimisation and never as a primary -- storage. In practice, this means that when we change index format, the -- application is expected to throw the old index away and build a fresh -- index. Please note that tracking index validity is out of scope for this--- library: this is responsibility of your application. It is advisable that in+-- module: this is responsibility of your application. It is advisable that in -- your validity tracking code, you also check for format validity (see -- 'indexFormatValid') and scrap and re-create index when needed. --@@ -19,7 +19,7 @@ -- file's content. It also contains the fileid to track moved files. -- -- There are two entry types, a file entry and a directory entry. Both have a--- common binary format (see 'Item'). The on-disk format is best described by+-- common binary format (see 'Item'). The on-disk format is described by -- the section /Index format/ below. -- -- For each file, the index has a copy of the file's last modification@@ -27,7 +27,7 @@ -- that when file size and timestamp of a file in working tree matches those in -- the index, we assume that the hash stored in the index for given file is -- valid. These hashes are then exposed in the resulting 'Tree' object, and can--- be leveraged by eg.  'diffTrees' to compare many files quickly.+-- be leveraged by eg. 'diffTrees' to compare many files quickly. -- -- You may have noticed that we also keep hashes of directories. These are -- assumed to be valid whenever the complete subtree has been valid. At any@@ -52,10 +52,11 @@ -- -- The index starts with a header consisting of a 4 bytes magic word, followed -- by a 4 byte word to indicate the endianness of the encoding. This word--- should, when read directly from the mmapped file, be equal to 1. After the--- header comes the actual content of the index, which is organised into--- \"lines\" where each line describes a single indexed item. It consists of+-- should, when read directly from the mmapped file, be equal to 1. --+-- After the header comes the actual content of the index, which is a+-- sequence of 'Item's. An 'Item' consists of:+-- -- * size: item size, 8 bytes -- * aux: timestamp (for file) or offset to sibling (for dir), 8 bytes -- * fileid: inode or fhandle of the item, 8 bytes@@ -65,12 +66,17 @@ --   * type: 'D' or 'F', one byte --   * path: flattened path, variable >= 0 -- * null: terminating null byte+-- * alignment padding: 0 to 3 bytes ----- With directories, the aux holds the offset of the next sibling line in the+-- Each 'Item' is 4 byte aligned. Thus the descriptor length must be+-- rounded up to get the position of the next item using 'align'. Similar,+-- when determining the aux (offset to sibling) for dir items.+--+-- With directories, the aux holds the offset of the next sibling item in the -- index, so we can efficiently skip reading the whole subtree starting at a--- given directory (by just seeking aux bytes forward). The lines are+-- given directory (by just seeking aux bytes forward). The items are -- pre-ordered with respect to directory structure -- the directory comes first--- and after it come all its items. Cf. 'openIndex''.+-- and after it come all its items. Cf. 'openIndex'. -- -- For files, the aux field holds a timestamp. --@@ -79,18 +85,16 @@ -- and a ByteString for the rest (iHashAndDescriptor), up to but not including -- the terminating null byte. ----- Comments by bf:+-- TODO -- -- The null byte terminator seems useless. ----- We could as well use just a single ByteString to represent an item; or even--- a single raw pointer, since finalizers are needed only when we copy hash and--- path back to the program as ByteStrings.+-- We could as well use a single plain pointer for the item. The dumpIndex+-- function demonstrates how this could be done. ----- An alternative representation could be to store the fixed-size fields (i.e--- everything except the path) as an unboxed array of records (structs). The--- paths would then be stored in a bidirectional map between item indices and--- paths.+-- Another possible improvement is to store only the Name of an item, not the+-- full path. We need to keep track of the current path anyway when traversing+-- the index.  module Darcs.Util.Index     ( openIndex@@ -101,6 +105,8 @@     , Index     , filter     , getFileID+    , IndexEntry(..)+    , dumpIndex     -- for testing     , align     ) where@@ -109,17 +115,21 @@  import Darcs.Util.ByteString ( readSegment, decodeLocale ) import qualified Darcs.Util.File ( getFileStatus )-import Darcs.Util.Hash( sha256, rawHash )+import Darcs.Util.Global ( debugMessage )+import Darcs.Util.Hash ( Hash(..), mkHash, rawHash, sha256 ) import Darcs.Util.Tree+import Darcs.Util.Tree.Hashed ( darcsTreeHash ) import Darcs.Util.Path-    ( AnchoredPath-    , anchorPath+    ( AnchoredPath(..)+    , realPath     , anchoredRoot     , Name     , rawMakeName     , appendPath     , flatten     )+import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO )+ import Control.Monad( when ) import Control.Exception( catch, throw, SomeException, Exception ) @@ -129,47 +139,35 @@ import Data.ByteString.Internal     ( c2w     , fromForeignPtr-    , memcpy     , nullForeignPtr     , toForeignPtr     )+import qualified Data.ByteString.Short.Internal as BS  import Data.Int( Int64, Int32 )+import Data.Word( Word8 ) import Data.IORef( )-import Data.Maybe( fromJust, isJust, fromMaybe )+import Data.Maybe( fromJust, isJust, isNothing ) import Data.Typeable( Typeable ) +import Foreign.Marshal.Utils ( copyBytes ) import Foreign.Storable import Foreign.ForeignPtr( ForeignPtr, withForeignPtr, castForeignPtr ) import Foreign.Ptr( Ptr, plusPtr )  import System.IO ( hPutStrLn, stderr )-import System.IO.MMap( mmapFileForeignPtr, Mode(..) )-import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist )+import System.IO.MMap( mmapFileForeignPtr, mmapWithFilePtr, Mode(..) )+import System.Directory( doesFileExist, getCurrentDirectory ) import System.Directory( renameFile ) import System.FilePath( (<.>) ) -#ifdef WIN32-import System.Win32.File-    ( BY_HANDLE_FILE_INFORMATION(..)-    , closeHandle-    , createFile-    , fILE_FLAG_BACKUP_SEMANTICS-    , fILE_SHARE_NONE-    , gENERIC_NONE-    , getFileInformationByHandle-    , oPEN_EXISTING-    )-#else-import qualified System.Posix.Files as F ( getSymbolicLinkStatus, fileID )-#endif-+import qualified System.Posix.Files as F ( fileID ) import System.FilePath ( (</>) ) import qualified System.Posix.Files as F-    ( modificationTime, fileSize, isDirectory, isSymbolicLink+    ( modificationTimeHiRes, fileSize, isDirectory, isSymbolicLink     , FileStatus     )-import System.Posix.Types ( FileID, EpochTime, FileOffset )+import System.Posix.Types ( FileID, FileOffset )  -------------------------- -- Indexed trees@@ -189,7 +187,7 @@                  } deriving Show  index_version :: B.ByteString-index_version = BC.pack "HSI6"+index_version = BC.pack "HSI7"  -- | Stored to the index to verify we are on the same endianness when reading -- it back. We will treat the index as invalid in this case so user code will@@ -206,7 +204,7 @@ size_size = 8 -- file/directory size (Int64) size_aux = 8 -- aux (Int64) size_fileid = 8 -- fileid (inode or fhandle FileID)-size_dsclen = 4 -- this many bytes store the length of the path+size_dsclen = 4 -- this many bytes store the length of the descriptor size_hash = 32 -- hash representation size_type, size_null :: Int size_type = 1 -- ItemType: 'D' for directory, 'F' for file@@ -225,17 +223,17 @@   size_size + size_aux + size_fileid + size_dsclen + size_hash +   size_type + B.length (flatten apath) + size_null -itemSize, itemNext :: Item -> Int+itemSize :: Item -> Int itemSize i =   size_size + size_aux + size_fileid + size_dsclen +-  (B.length $ iHashAndDescriptor i)--- The "+ 1" is for the null byte at the end, which is /not/--- contained in iDescriptor!-itemNext i = align 4 (itemSize i + 1)+  (B.length $ iHashAndDescriptor i) + size_null +itemNext :: Item -> Int+itemNext i = align 4 (itemSize i)+ -- iDescriptor is: --  * one byte for type of item ('D' or 'F')---  * flattened path+--  * flattened path (w/o terminating null byte) iHash, iDescriptor :: Item -> B.ByteString iDescriptor = unsafeDrop size_hash . iHashAndDescriptor iHash = B.take size_hash . iHashAndDescriptor@@ -256,9 +254,11 @@  type FileStatus = Maybe F.FileStatus --- TODO: upgrade to modificationTimeHiRes for nanosecond resolution-modificationTime :: FileStatus -> EpochTime-modificationTime = maybe 0 F.modificationTime+-- We deal with hi res timestamps by noting that the actual resolution is in+-- nanoseconds. If we count the nanoseconds since the epoch we will overflow+-- (1<<63)/(1e9*60*60*24*366) =~ 290 years after the epoch. Comfortable.+modificationTime :: FileStatus -> Int64+modificationTime = maybe 0 (truncate . (*1e9) . F.modificationTimeHiRes)  fileSize :: FileStatus -> FileOffset fileSize = maybe 0 F.fileSize@@ -269,6 +269,9 @@ isDirectory :: FileStatus -> Bool isDirectory = maybe False F.isDirectory +fileID :: FileStatus -> FileID+fileID = maybe 0 F.fileID+ -- | Lay out the basic index item structure in memory. The memory location is -- given by a ForeignPointer () and an offset. The path and type given are -- written out, and a corresponding Item is given back. The remaining bits of@@ -284,10 +287,8 @@       (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc   withForeignPtr fp $ \p ->     withForeignPtr dsc_fp $ \dsc_p -> do-      fileid <- fromMaybe 0 <$> getFileID apath-      pokeByteOff p (off + off_fileid) (fromIntegral fileid :: Int64)       pokeByteOff p (off + off_dsclen) (fromIntegral dsc_len :: Int32)-      memcpy+      copyBytes         (plusPtr p $ off + off_dsc)         (plusPtr dsc_p dsc_start)         (fromIntegral dsc_len)@@ -307,31 +308,33 @@           fromForeignPtr             (castForeignPtr fp)             (off + off_hash)-            -- The "- 1" here means we do /not/ include the null byte!-            -- This is why we have to add 1 when we determine the-            -- size, see 'itemSize' and 'itemNext' above.-            (size_hash + nl - 1)+            -- Note that iHashAndDescriptor does not include the terminating+            -- null byte, so we have to subtract its size here.+            (size_hash + nl - size_null)     return $! Item {iBase = plusPtr p off, iHashAndDescriptor = dsc} --- | Update an existing item with new hash and optionally mtime (give Nothing--- when updating directory entries).+-- | Update an existing 'Item' with new size and hash. The hash must be+-- not be 'Nothing'. updateItem :: Item -> Int64 -> Hash -> IO ()-updateItem item _ NoHash =-    fail $ "Index.update NoHash: " ++ iPath item updateItem item size hash =     do poke (iSize item) size        unsafePokeBS (iHash item) (rawHash hash)  updateFileID :: Item -> FileID -> IO ()-updateFileID item fileid = poke (iFileID item) $ fromIntegral fileid+updateFileID item fileid = poke (iFileID item) fileid+ updateAux :: Item -> Int64 -> IO ()-updateAux item aux = poke (iAux item) $ aux-updateTime :: forall a.(Enum a) => Item -> a -> IO ()-updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime)+updateAux item aux = poke (iAux item) aux -iHash' :: Item -> Hash-iHash' i = SHA256 (iHash i)+updateTime :: Item -> Int64 -> IO ()+updateTime item mtime = updateAux item mtime +iHash' :: Item -> Maybe Hash+iHash' i = let ih = iHash i in if ih == nullHash then Nothing else Just (mkHash ih)++nullHash :: B.ByteString+nullHash = B.replicate size_hash 0+ -- | Gives a ForeignPtr to mmapped index, which can be used for reading and -- updates. The req_size parameter, if non-0, expresses the requested size of -- the index file. mmapIndex will grow the index if it is smaller than this.@@ -350,7 +353,6 @@  data IndexM m = Index { mmap :: (ForeignPtr ())                       , basedir :: FilePath-                      , hashtree :: Tree m -> Hash                       , predicate :: AnchoredPath -> TreeItem m -> Bool }               | EmptyIndex @@ -383,14 +385,84 @@   -- ^ The item extracted.   } -readItem :: Index -> State -> IO Result-readItem index state = do-  item <- peekItem (mmap index) (start state)-  res' <- if itemIsDir item-              then readDir  index state item-              else readFile index state item-  return res'+readItem :: String -> Index -> State -> IO Result+readItem progressKey index state = do+    item <- peekItem (mmap index) (start state)+    res' <- if itemIsDir item+                then readDir  item+                else readFile item+    finishedOneIO progressKey (iPath item)+    return res'+  where +    readDir item = do+      following <- fromIntegral <$> peek (iAux item)+      st <- getFileStatus (iPath item)+      let exists = fileExists st && isDirectory st+      fileid <- peek $ iFileID item+      when (fileid == 0) $ updateFileID item (fileID st)+      let substate = substateof item state+          want =+            exists && (predicate index) (path substate) (Stub undefined Nothing)+          oldhash = iHash' item+          subs off =+             case compare off following of+               LT -> do+                 result <- readItem progressKey index $ substate { start = off }+                 rest <- subs $ next result+                 return $! (nameof (resitem result) substate, result) : rest+               EQ -> return []+               GT ->+                 fail $+                   "Offset mismatch at " ++ show off +++                   " (ends at " ++ show following ++ ")"+      inferiors <- if want then subs $ start substate+                           else return []+      let we_changed = or [ changed x | (_, x) <- inferiors ] || nullleaf+          nullleaf = null inferiors && isNothing oldhash+          tree' =+            -- Note the partial pattern match on 'Just n' below is justified+            -- as we are traversing sub items here, which means 'Nothing' is+            -- impossible, see 'substateof' for details.+            makeTree+              [ (n, fromJust $ treeitem s)+              | (Just n, s) <- inferiors, isJust $ treeitem s ]+          treehash = if we_changed then Just (darcsTreeHash tree') else oldhash+          tree = tree' { treeHash = treehash }+      when (exists && we_changed) $+          -- fromJust is justified because we_changed implies (isJust treehash)+          updateItem item 0 (fromJust treehash)+      return $ Result { changed = not exists || we_changed+                      , next = following+                      , treeitem = if want then Just $ SubTree tree+                                           else Nothing+                      , resitem = item }++    readFile item = do+           st <- getFileStatus (iPath item)+           mtime <- fromIntegral <$> (peek $ iAux item)+           size <- peek $ iSize item+           fileid <- peek $ iFileID item+           let mtime' = modificationTime st+               size' = fromIntegral $ fileSize st+               readblob = readSegment (basedir index </> (iPath item), Nothing)+               exists = fileExists st && not (isDirectory st)+               we_changed = mtime /= mtime' || size /= size'+               hash = iHash' item+           when (exists && we_changed) $+                do hash' <- sha256 `fmap` readblob+                   updateItem item size' hash'+                   updateTime item mtime'+                   when (fileid == 0) $ updateFileID item (fileID st)+           return $ Result { changed = not exists || we_changed+                           , next = start state + itemNext item+                           , treeitem =+                              if exists+                                then Just $ File $ Blob readblob hash+                                else Nothing+                           , resitem = item }++ data CorruptIndex = CorruptIndex String deriving (Eq, Typeable) instance Exception CorruptIndex instance Show CorruptIndex where show (CorruptIndex s) = s@@ -433,77 +505,6 @@   where     myname = nameof item state -readDir :: Index -> State -> Item -> IO Result-readDir index state item = do-       following <- fromIntegral <$> peek (iAux item)-       st <- getFileStatus (iPath item)-       let exists = fileExists st && isDirectory st-       fileid <- fromIntegral <$> (peek $ iFileID item)-       fileid' <- fromMaybe fileid <$> (getFileID' $ iPath item)-       when (fileid == 0) $ updateFileID item fileid'-       let substate = substateof item state--           want = exists && (predicate index) (path substate) (Stub undefined NoHash)-           oldhash = iHash' item--           subs off =-              case compare off following of-                LT -> do-                  result <- readItem index $ substate { start = off }-                  rest <- subs $ next result-                  return $! (nameof (resitem result) substate, result) : rest-                EQ -> return []-                GT ->-                  fail $-                    "Offset mismatch at " ++ show off ++-                    " (ends at " ++ show following ++ ")"--       inferiors <- if want then subs $ start substate-                            else return []--       let we_changed = or [ changed x | (_, x) <- inferiors ] || nullleaf-           nullleaf = null inferiors && oldhash == nullsha-           nullsha = SHA256 (B.replicate 32 0)-           tree' =-             -- Note the partial pattern match on 'Just n' below is justified-             -- as we are traversing sub items here, which means 'Nothing' is-             -- impossible, see 'substateof' for details.-             makeTree-               [ (n, fromJust $ treeitem s)-               | (Just n, s) <- inferiors, isJust $ treeitem s ]-           treehash = if we_changed then hashtree index tree' else oldhash-           tree = tree' { treeHash = treehash }--       when (exists && we_changed) $ updateItem item 0 treehash-       return $ Result { changed = not exists || we_changed-                       , next = following-                       , treeitem = if want then Just $ SubTree tree-                                            else Nothing-                       , resitem = item }--readFile :: Index -> State -> Item -> IO Result-readFile index state item = do-       st <- getFileStatus (iPath item)-       mtime <- fromIntegral <$> (peek $ iAux item)-       size <- peek $ iSize item-       fileid <- fromIntegral <$> (peek $ iFileID item)-       fileid' <- fromMaybe fileid <$> (getFileID' $ iPath item)-       let mtime' = modificationTime st-           size' = fromIntegral $ fileSize st-           readblob = readSegment (basedir index </> (iPath item), Nothing)-           exists = fileExists st && not (isDirectory st)-           we_changed = mtime /= mtime' || size /= size'-           hash = iHash' item-       when (exists && we_changed) $-            do hash' <- sha256 `fmap` readblob-               updateItem item size' hash'-               updateTime item mtime'-               when (fileid == 0) $ updateFileID item fileid'-       return $ Result { changed = not exists || we_changed-                       , next = start state + itemNext item-                       , treeitem = if exists then Just $ File $ Blob readblob hash else Nothing-                       , resitem = item }- -- * Reading (only) file IDs from the index  -- FIXME this seems copy-pasted from the code above and then adapted@@ -541,7 +542,7 @@  readDirFileIDs :: Index -> State -> Item -> IO ResultF readDirFileIDs index state item =-    do fileid <- fromIntegral <$> (peek $ iFileID item)+    do fileid <- peek $ iFileID item        following <- fromIntegral <$> peek (iAux item)        let substate = substateof item state            subs off =@@ -562,7 +563,7 @@  readFileFileID :: Index -> State -> Item -> IO ResultF readFileFileID _ state item =-    do fileid' <- fromIntegral <$> (peek $ iFileID item)+    do fileid' <- peek $ iFileID item        let myname = nameof item state        return $ ResultF { nextF = start state + itemNext item                         , resitemF = item@@ -570,25 +571,14 @@  -- * Reading and writing 'Tree's from/to the index --- | Read an index and build up a 'Tree' object from it, referring to current--- working directory. The initial Index object returned by openIndex is not--- directly useful. However, you can use 'Tree.filter' on it. Either way, to--- obtain the actual Tree object, call update.------ The usual use pattern is this:------ > do (idx, update) <- openIndex--- >    tree <- update =<< filter predicate idx------ The resulting tree will be fully expanded.-openIndex :: FilePath -> (Tree IO -> Hash) -> IO Index-openIndex indexpath ht = do+-- | Initialize an 'Index' from the given index file.+openIndex :: FilePath -> IO Index+openIndex indexpath = do   (mmap_ptr, mmap_size) <- mmapIndex indexpath 0   base <- getCurrentDirectory   return $ if mmap_size == 0 then EmptyIndex                              else Index { mmap = mmap_ptr                                         , basedir = base-                                        , hashtree = ht                                         , predicate = \_ _ -> True }  formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()@@ -600,24 +590,29 @@     where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4           create (File _) path' off =                do i <- createItem BlobType path' mmap_ptr off-                  let flatpath = anchorPath "" path'+                  -- TODO calling getFileStatus here is both slightly+                  -- inefficient and slightly race-prone+                  st <- getFileStatus (iPath i)+                  updateFileID i (fileID st)                   case find old path' of                     Nothing -> return ()-                    -- TODO calling getFileStatus here is both slightly-                    -- inefficient and slightly race-prone-                    Just ti -> do st <- getFileStatus flatpath-                                  let hash = itemHash ti+                    Just ti -> do let hash = itemHash ti                                       mtime = modificationTime st                                       size = fileSize st-                                  updateItem i (fromIntegral size) hash+                                  -- TODO prove that isNothing hash is impossible+                                  updateItem i (fromIntegral size) (fromJust hash)                                   updateTime i mtime                   return $ off + itemNext i           create (SubTree s) path' off =                do i <- createItem TreeType path' mmap_ptr off+                  st <- getFileStatus (iPath i)+                  updateFileID i (fileID st)                   case find old path' of                     Nothing -> return ()-                    Just ti | itemHash ti == NoHash -> return ()-                            | otherwise -> updateItem i 0 $ itemHash ti+                    Just ti ->+                      case itemHash ti of+                        Nothing -> return ()+                        Just h -> updateItem i 0 h                   let subs [] = return $ off + itemNext i                       subs ((name,x):xs) = do                         let path'' = path' `appendPath` name@@ -629,12 +624,14 @@           create (Stub _ _) path' _ =                fail $ "Cannot create index from stubbed Tree at " ++ show path' --- | Will add and remove files in index to make it match the 'Tree' object--- given (it is an error for the 'Tree' to contain a file or directory that--- does not exist in a plain form in current working directory).-updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index-updateIndexFrom indexpath hashtree' ref =-    do old_tree <- treeFromIndex =<< openIndex indexpath hashtree'+-- | Add and remove entries in the given 'Index' to make it match the given+-- 'Tree'. If an object in the 'Tree' does not exist in the current working+-- directory, its index entry will have zero hash, size, aux, and fileID. For+-- the hash this translates to 'Nothing', see 'iHash''.+updateIndexFrom :: FilePath -> Tree IO -> IO Index+updateIndexFrom indexpath ref =+    do debugMessage "Updating the index ..."+       old_tree <- treeFromIndex =<< openIndex indexpath        reference <- expand ref        let len_root = itemAllocSize anchoredRoot            len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ]@@ -647,16 +644,24 @@        when exist $ renameFile indexpath (indexpath <.> "old")        (mmap_ptr, _) <- mmapIndex indexpath len        formatIndex mmap_ptr old_tree reference-       openIndex indexpath hashtree'+       debugMessage "Done updating the index, reopening it ..."+       openIndex indexpath --- | Read the index, starting with the root, to create a 'Tree'.+-- | Read an 'Index', starting with the root, to create a 'Tree'. treeFromIndex :: Index -> IO (Tree IO) treeFromIndex EmptyIndex = return emptyTree treeFromIndex index =     do let initial = State { start = size_header                            , dirlength = 0                            , path = anchoredRoot }-       res <- readItem index initial+           -- This is not a typo! As a side-effect of reading a tree from the+           -- index, it also gets updated and this is what can take a long time+           -- since it may involve reading all files in the working tree that+           -- are also in pristine+pending (to compute their hashes)+           progressKey = "Updating the index"+       beginTedious progressKey+       res <- readItem progressKey index initial+       endTedious progressKey        case treeitem res of          Just (SubTree tree) -> return $ filter (predicate index) tree          _ -> fail "Unexpected failure in treeFromIndex!"@@ -680,30 +685,9 @@  -- * Getting the file ID from a path --- | For a given file or folder path, get the corresponding fileID from the--- filesystem.+-- | For a given path, get the corresponding fileID from the filesystem. getFileID :: AnchoredPath -> IO (Maybe FileID)-getFileID = getFileID' . anchorPath ""--getFileID' :: FilePath -> IO (Maybe FileID)-getFileID' fp = do-  file_exists <- doesFileExist fp-  dir_exists <- doesDirectoryExist fp-  if file_exists || dir_exists-#ifdef WIN32-    then do-      h <--        createFile fp gENERIC_NONE fILE_SHARE_NONE Nothing-        oPEN_EXISTING fILE_FLAG_BACKUP_SEMANTICS Nothing-      fhnumber <--        (Just . fromIntegral . bhfiFileIndex) <$> getFileInformationByHandle h-      closeHandle h-      return fhnumber-#else-    then (Just . F.fileID) <$> F.getSymbolicLinkStatus fp-#endif-    else return Nothing-+getFileID p = fmap F.fileID <$> getFileStatus (realPath p)  -- * Low-level utilities @@ -716,7 +700,8 @@             ++ show len_from ++ " /= to = " ++ show len_to        withForeignPtr fp_from $ \p_from ->          withForeignPtr fp_to $ \p_to ->-           memcpy (plusPtr p_to off_to)+           copyBytes+                  (plusPtr p_to off_to)                   (plusPtr p_from off_from)                   (fromIntegral len_to) @@ -735,3 +720,49 @@           hPutStrLn stderr $ "Warning: ignoring symbolic link " ++ path           return Nothing     _ -> return mst++data IndexEntry = IndexEntry+  { ieSize :: Int64+  , ieAux :: Int64+  , ieFileID :: FileID+  , ieHash :: Maybe Hash+  , ieType :: Char+  , iePath :: AnchoredPath+  }++dumpIndex :: FilePath -> IO [IndexEntry]+dumpIndex indexpath =+  mmapWithFilePtr indexpath ReadOnly Nothing $ \(ptr, size) -> do+    magic <- BS.createFromPtr ptr 4+    when (magic /= BS.toShort index_version) $ fail "index format is invalid"+    readEntries (size - size_header) (ptr `plusPtr` size_header)+  where+    readEntries s _ | s < (next 0) = return []+    readEntries s p = do+      (entry, fwd) <- readEntry p+      entries <- readEntries (s - fwd) (p `plusPtr` fwd)+      return (entry : entries)+    readEntry p = do+      ieSize <- peekByteOff p off_size+      ieAux <- peekByteOff p off_aux+      ieFileID <- peekByteOff p off_fileid+      ieHash <- do+        h <- BS.createFromPtr (p `plusPtr` off_hash) size_hash+        return $ if h == shortNullHash then Nothing else Just (SHA256 h)+      dsclen :: Int32 <- peekByteOff p off_dsclen+      ieType <- b2c <$> peekByteOff p off_dsc+      path <-+        BS.fromShort <$>+        BS.createFromPtr (p `plusPtr` off_path) (fromIntegral dsclen - size_type - size_null)+      iePath <-+        either fail return $ AnchoredPath <$> mapM rawMakeName (BC.split '/' (fixRoot path))+      return (IndexEntry {..}, next (B.length path))+    b2c :: Word8 -> Char+    b2c = toEnum . fromIntegral+    off_path = off_dsc + size_type+    next pathlen =+      align 4 $ size_size + size_aux + size_fileid + size_hash + size_dsclen+              + size_type + pathlen + size_null+    fixRoot s | s == BC.pack "." = BC.empty+    fixRoot s = s+    shortNullHash = BS.toShort nullHash
+ src/Darcs/Util/IndexedMonad.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+module Darcs.Util.IndexedMonad+  ( Monad(..), LiftIx(..), when, ifThenElse+  , MonadReader(..), ReaderT(..), asks+  ) where++import Darcs.Prelude hiding ( Monad(..) )++-- This is required to implement the "if then else" syntax+-- because we are using RebindableSyntax.+-- It doesn't currently exist anywhere standard: see+-- https://gitlab.haskell.org/ghc/ghc/-/issues/18081+-- It doesn't strictly belong in this module but in practice+-- we only use RebindableSyntax to allow us to use the+-- indexed monad class.+ifThenElse :: Bool -> a -> a -> a+ifThenElse True  t _ = t+ifThenElse False _ e = e++-- At the moment the code is organised into different modules partially to+-- separate it by which Monad class we want (normal or indexed). Once qualified+-- do-notation is available (i.e. min GHC is 9.0) we can stop doing that.+-- |An alternative monad class, indexed by a "from" and "to" state.+class Monad m where+  return :: a -> m i i a+  (>>=) :: m i j a -> (a -> m j k b) -> m i k b+  (>>) :: m i j a -> m j k b -> m i k b++when :: Monad m => Bool -> m i i () -> m i i ()+when b m = if b then m else return ()++-- |A class for indexed monad transformers, going from normal Haskell monads+-- into our indexed monads.+class LiftIx t where+  liftIx :: m a -> t m i i a++-- |An indexed version of the standard 'MonadReader' class+class Monad m => MonadReader r m | m -> r where+  ask :: m i i r+  local :: (r -> r) -> m i i a -> m i i a++asks :: MonadReader r m => (r -> a) -> m i i a+asks f = ask >>= \r -> return (f r)++-- |An indexed version of the standard 'ReaderT' transformer+newtype ReaderT r m i j a = ReaderT { runReaderT :: r -> m i j a }++instance Monad m => Monad (ReaderT r m) where+  return v = ReaderT (\_ -> return v)+  ReaderT m >>= f = ReaderT (\r -> m r >>= \a -> runReaderT (f a) r)+  ReaderT m >> ReaderT n = ReaderT (\r -> m r >> n r)++instance Monad m => MonadReader r (ReaderT r m) where+  ask = ReaderT return+  local f (ReaderT m) = ReaderT (m . f)
src/Darcs/Util/Lock.hs view
@@ -19,8 +19,6 @@     ( withLock     , withLockCanFail     , environmentHelpLocks-    , withTemp-    , withOpenTemp     , withTempDir     , withPermDir     , withDelayedDir@@ -39,7 +37,6 @@     , gzWriteAtomicFilePSs     , gzWriteDocFile     , removeFileMayNotExist-    , canonFilename     , maybeRelink     , tempdirLoc     , environmentHelpTmpdir@@ -54,8 +51,8 @@ import Data.Maybe ( fromJust, isJust, listToMaybe ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO-    ( withFile, withBinaryFile, openBinaryTempFile-    , hClose, Handle, hPutStr, hSetEncoding+    ( withFile, withBinaryFile+    , Handle, hPutStr, hSetEncoding     , IOMode(WriteMode, AppendMode), hFlush, stdout     ) import System.IO.Error@@ -68,25 +65,25 @@     , bracket     , throwIO     , catch-    , try     , SomeException     ) import System.Directory-    ( removePathForcibly-    , doesFileExist+    ( doesFileExist     , doesDirectoryExist     , createDirectory     , getTemporaryDirectory+    , makeAbsolute     , removePathForcibly     , renameFile     , renameDirectory     ) import System.FilePath.Posix ( splitDirectories, splitFileName )+import System.Directory ( withCurrentDirectory ) import System.Environment ( lookupEnv ) import System.IO.Temp ( createTempDirectory )  import Control.Concurrent ( threadDelay )-import Control.Monad ( unless, when, liftM )+import Control.Monad ( unless, when )  import System.Posix.Files ( fileMode, getFileStatus, setFileMode ) @@ -97,8 +94,7 @@     ( firstJustIO     , catchall     )-import Darcs.Util.File ( withCurrentDirectory-                       , removeFileMayNotExist )+import Darcs.Util.File ( removeFileMayNotExist ) import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath,                         getCurrentDirectory, setCurrentDirectory ) @@ -110,8 +106,7 @@ import Darcs.Util.AtExit ( atexit ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Compat-    ( canonFilename-    , maybeRelink+    ( maybeRelink     , atomicCreate     , sloppyAtomicCreate     )@@ -119,7 +114,7 @@ import Darcs.Util.Prompt ( askUser )  withLock :: String -> IO a -> IO a-withLock s job = bracket (getlock s 30) releaseLock (\_ -> job)+withLock s job = bracket (getLock s 30) releaseLock (const job)  releaseLock :: String -> IO () releaseLock = removeFileMayNotExist@@ -128,23 +123,23 @@ -- Otherwise, just gives up without doing the task withLockCanFail :: String -> IO a -> IO (Either () a) withLockCanFail s job =-  bracket (takeLock s)+  bracket (takeLock s `catchall` return False)           (\l -> when l $ releaseLock s)-          (\l -> if l then liftM Right job+          (\l -> if l then Right <$> job                       else return $ Left ()) -getlock :: String -> Int -> IO String-getlock l 0 = do yorn <- askUser $ "Couldn't get lock "++l++". Abort (yes or anything else)? "+getLock :: String -> Int -> IO String+getLock l 0 = do yorn <- askUser $ "Couldn't get lock "++l++". Abort (yes or anything else)? "                  case yorn of                     ('y':_) -> exitWith $ ExitFailure 1-                    _ -> getlock l 30-getlock lbad tl = do l <- canonFilename lbad+                    _ -> getLock l 30+getLock lbad tl = do l <- makeAbsolute lbad                      gotit <- takeLock l                      if gotit then return l                               else do putStrLn $ "Waiting for lock "++l                                       hFlush stdout -- for Windows                                       threadDelay 2000000-                                      getlock l (tl - 1)+                                      getLock l (tl - 1)   takeLock :: FilePathLike p => p -> IO Bool@@ -175,39 +170,16 @@  "",  "you may want to try to export DARCS_SLOPPY_LOCKS=True."]) --- |'withTemp' safely creates an empty file (not open for writing) and--- returns its name.------ The temp file operations are rather similar to the locking operations, in--- that they both should always try to clean up, so exitWith causes trouble.-withTemp :: (FilePath -> IO a) -> IO a-withTemp = bracket get_empty_file removeFileMayNotExist-    where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs"-                              hClose h-                              return f---- |'withOpenTemp' creates a temporary file, and opens it.--- Both of them run their argument and then delete the file.  Also,--- both of them (to my knowledge) are not susceptible to race conditions on--- the temporary file (as long as you never delete the temporary file; that--- would reintroduce a race condition).-withOpenTemp :: ((Handle, FilePath) -> IO a) -> IO a-withOpenTemp = bracket get_empty_file cleanup-    where cleanup (h,f) = do _ <- try (hClose h) :: IO (Either SomeException ())-                             removeFileMayNotExist f-          get_empty_file = invert `fmap` openBinaryTempFile "." "darcs"-          invert (a,b) = (b,a)- tempdirLoc :: IO FilePath-tempdirLoc = liftM fromJust $-    firstJustIO [ liftM (Just . head . words) (readFile (darcsdir++"/prefs/tmpdir")) >>= chkdir,+tempdirLoc = fromJust <$>+    firstJustIO [ fmap (Just . head . words) (readFile (darcsdir++"/prefs/tmpdir")) >>= chkdir,                   lookupEnv "DARCS_TMPDIR" >>= chkdir,                   getTemporaryDirectory >>= chkdir . Just,                   getCurrentDirectorySansDarcs,                   return $ Just "."  -- always returns a Just                 ]     where chkdir Nothing = return Nothing-          chkdir (Just d) = liftM (\e -> if e then Just (d++"/") else Nothing) $ doesDirectoryExist d+          chkdir (Just d) = (\e -> if e then Just (d++"/") else Nothing) <$> doesDirectoryExist d  environmentHelpTmpdir :: ([String], [String]) environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [@@ -262,7 +234,7 @@               debugMessage $ unwords ["atexit: renaming",path,"to",toDelete path]               renameDirectory path (toDelete path)               debugMessage $ unwords ["atexit: deleting",toDelete path]-              removePathForcibly (toDelete path)+              removePathForcibly (toDelete path) `catchIOError` const (return ())  environmentHelpKeepTmpdir :: ([String], [String]) environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[@@ -309,7 +281,7 @@  withNamedTemp :: FilePath -> (FilePath -> IO a) -> IO a withNamedTemp n f = do-    debugMessage $ "withNamedTemp: " ++ show n+    when False $ debugMessage $ "withNamedTemp: " ++ show n     bracket (worldReadableTemp n) removeFileMayNotExist f  readBinFile :: FilePathLike p => p -> IO B.ByteString@@ -402,5 +374,5 @@ withNewDirectory name action = do   createDirectory name   withCurrentDirectory name action `catch` \e -> do-    removePathForcibly name `catchIOError` (const $ return ())+    removePathForcibly name `catchIOError` const (return ())     throwIO (e :: SomeException)
src/Darcs/Util/Parser.hs view
@@ -11,15 +11,21 @@     , linesStartingWith     , linesStartingWithEndingWith     , lexWord+    , A.lookAhead+    , many     , option     , optional     , parse+    , parseAll     , skipSpace     , skipWhile     , string     , take     , takeTill     , takeTillChar+    , unsigned+    , withPath+    , (<|>)     ) where  import Control.Applicative ( empty, many, optional, (<|>) )@@ -27,10 +33,23 @@ import Darcs.Prelude hiding ( lex, take )  import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Combinator as A import Data.Attoparsec.ByteString.Char8 hiding ( parse, char, string ) import qualified Data.Attoparsec.ByteString.Char8 as AC import qualified Data.ByteString as B +withPath :: FilePath -> Either String a -> Either String a+withPath fp (Left s) = Left ("in file: "++fp++": "++s)+withPath _ r = r++parseAll :: Parser a -> B.ByteString -> Either String a+parseAll p bs =+  case parse p bs of+    Left e -> Left e+    Right (r, leftover)+      | B.null (B.dropWhile isSpace_w8 leftover) -> Right r+      | otherwise -> Left $ "leftover: " ++ show leftover+ parse :: Parser a -> B.ByteString -> Either String (a, B.ByteString) parse p bs =   case AC.parse p bs of@@ -73,6 +92,10 @@ {-# INLINE int #-} int :: Parser Int int = lex (signed decimal)++{-# INLINE unsigned #-}+unsigned :: Integral a => Parser a+unsigned = lex decimal  {-# INLINE takeTillChar #-} takeTillChar :: Char -> Parser B.ByteString
src/Darcs/Util/Path.hs view
@@ -46,15 +46,13 @@     , makeSubPathOf     , simpleSubPath     , floatSubPath+    , makeRelativeTo     -- * Miscellaneous     , FilePathOrURL(..)     , FilePathLike(toFilePath)     , getCurrentDirectory     , setCurrentDirectory     , getUniquePathName-    , doesPathExist-    -- * Check for malicious paths-    , isMaliciousSubPath     -- * Tree filtering.     , filterPaths     -- * AnchoredPaths: relative paths within a Tree. All paths are@@ -70,7 +68,6 @@     , appendPath     , anchorPath     , isPrefix-    , breakOnDir     , movedirfilename     , parent     , parents@@ -82,40 +79,32 @@     , realPath     , isRoot     , darcsdirName-    -- * Unsafe AnchoredPath functions.     , floatPath+    -- * Unsafe AnchoredPath functions.+    , unsafeFloatPath     ) where  import Darcs.Prelude -import Data.List-    ( isPrefixOf-    , isSuffixOf-    , stripPrefix-    , intersect-    , inits-    )-import Data.Char ( isSpace, chr, ord, toLower )-import Data.Typeable ( Typeable )-import Control.Exception ( tryJust, bracket_, throw, Exception )-import Control.Monad ( when )-import System.IO.Error ( isDoesNotExistError )--import qualified Darcs.Util.Workaround as Workaround ( getCurrentDirectory )-import qualified System.Directory ( setCurrentDirectory )-import System.Directory ( doesDirectoryExist, doesFileExist )-import qualified System.FilePath.Posix as FilePath ( (</>), normalise, isRelative )-import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )-import System.FilePath( splitDirectories, normalise, dropTrailingPathSeparator )-import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )--import Darcs.Util.ByteString ( encodeLocale, decodeLocale )+import Control.Exception ( bracket_ )+import Control.Monad ( when, (<=<) )+import Darcs.Util.ByteString ( decodeLocale, encodeLocale )+import Data.Binary+import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString       as B+import Data.Char ( chr, isSpace, ord, toLower )+import Data.List ( inits, isPrefixOf, isSuffixOf, stripPrefix )+import GHC.Stack ( HasCallStack )+import qualified System.Directory ( setCurrentDirectory )+import System.Directory ( doesDirectoryExist, doesPathExist )+import qualified System.FilePath as NativeFilePath+import qualified System.FilePath.Posix as FilePath+import System.Posix.Files ( fileID, getFileStatus, isDirectory ) -import Data.Binary+import Darcs.Util.Exception ( ifDoesNotExistError ) import Darcs.Util.Global ( darcsdir )-import Darcs.Util.URL ( isAbsolute, isRelative, isSshNopath )+import Darcs.Util.URL ( isAbsolute, isHttpUrl, isRelative, isSshNopath, isSshUrl )+import qualified Darcs.Util.Workaround as Workaround ( getCurrentDirectory )   -- Utilities for use by command implementations@@ -151,18 +140,18 @@ -- | 'decodeWhite' interprets the Darcs-specific \"encoded\" filenames --   produced by 'encodeWhite' -----   > decodeWhite "hello\32\there"  == "hello there"---   > decodeWhite "hello\92\there"  == "hello\there"---   > decodeWhite "hello\there"   == error "malformed filename"-decodeWhite :: String -> FilePath+--   > decodeWhite "hello\32\there"  == Right "hello there"+--   > decodeWhite "hello\92\there"  == Right "hello\there"+--   > decodeWhite "hello\there"   == Left "malformed filename"+decodeWhite :: String -> Either String FilePath decodeWhite cs_ = go cs_ [] False- where go "" acc True  = reverse acc -- if there was a replace, use new string-       go "" _   False = cs_         -- if not, use input string+ where go "" acc True  = Right (reverse acc) -- if there was a replace, use new string+       go "" _   False = Right cs_         -- if not, use input string        go ('\\':cs) acc _ =          case break (=='\\') cs of            (theord, '\\':rest) ->              go rest (chr (read theord) :acc) True-           _ -> error "malformed filename"+           _ -> Left $ "malformed filename: " ++ cs_        go (c:cs) acc modified = go cs (c:acc) modified  class FilePathOrURL a where@@ -187,28 +176,21 @@   toPath (AbsolutePath x) = x instance FilePathOrURL SubPath where   toPath (SubPath x) = x-instance CharLike c => FilePathOrURL [c] where-  toPath = toFilePath- instance FilePathOrURL AbsoluteOrRemotePath where   toPath (AbsP a) = toPath a   toPath (RmtP r) = r+instance FilePathOrURL FilePath where+  toPath = id  instance FilePathLike AbsolutePath where   toFilePath (AbsolutePath x) = x instance FilePathLike SubPath where   toFilePath (SubPath x) = x--class CharLike c where-  toChar :: c -> Char--instance CharLike Char where-  toChar = id--instance CharLike c => FilePathLike [c] where-  toFilePath = map toChar+instance FilePathLike FilePath where+  toFilePath = id --- | Make the second path relative to the first, if possible+-- | Make the second path relative to the first, if possible.+-- Note that this returns an empty 'SubPath' if the inputs are equal. makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =  -- The slash prevents "foobar" from being treated as relative to "foo"@@ -216,30 +198,16 @@     then Just $ SubPath $ drop (length p1 + 1) p2     else Nothing -simpleSubPath :: FilePath -> Maybe SubPath+simpleSubPath :: HasCallStack => FilePath -> Maybe SubPath simpleSubPath x | null x = error "simpleSubPath called with empty path"                 | isRelative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x                 | otherwise = Nothing --- | Ensure directory exists and is not a symbolic link.-doesDirectoryReallyExist :: FilePath -> IO Bool-doesDirectoryReallyExist f = do-    x <- tryJust (\x -> if isDoesNotExistError x then Just () else Nothing) $-        isDirectory <$> getSymbolicLinkStatus f-    return $ case x of-        Left () -> False-        Right y -> y--doesPathExist :: FilePath -> IO Bool-doesPathExist p = do-   dir_exists <- doesDirectoryExist p-   file_exists <- doesFileExist p-   return $ dir_exists || file_exists- -- | Interpret a possibly relative path wrt the current working directory.+-- This also canonicalizes the path, resolving symbolic links etc. ioAbsolute :: FilePath -> IO AbsolutePath ioAbsolute dir =-    do isdir <- doesDirectoryReallyExist dir+    do isdir <- doesDirectoryExist dir        here <- getCurrentDirectory        if isdir          then bracket_ (setCurrentDirectory dir)@@ -254,6 +222,36 @@                                else ioAbsolute super_dir                     return $ makeAbsolute abs_dir file +-- | The first argument must be the absolute path of a @directory@, the second+-- is an arbitrary absolute @path@. Find the longest prefix of @path@ that+-- points to the same @directory@; if there is none, return 'Nothing', else+-- return 'Just' the remainder.+makeRelativeTo :: HasCallStack => AbsolutePath -> AbsolutePath -> IO (Maybe SubPath)+makeRelativeTo (AbsolutePath dir) (AbsolutePath path) = do+  dir_stat <- getFileStatus dir+  let dir_id = fileID dir_stat+  when (not (isDirectory dir_stat)) $+    error $ "makeRelativeTo called with non-dir " ++ dir+  findParent dir_id path []+  where+    findParent dir_id ap acc = do+      map_stat <- ifDoesNotExistError Nothing (Just <$> getFileStatus ap)+      case map_stat of+        Just ap_stat | fileID ap_stat == dir_id -> do+          -- found ancestor that matches dir+          return $ Just $ SubPath $ FilePath.joinPath acc+        _ -> do+          -- recurse+          let (parent_,child) =+                -- splitFileName only does what one expects if there is no+                -- trailing path separator+                NativeFilePath.splitFileName $+                  NativeFilePath.dropTrailingPathSeparator ap+          if null child then+            return Nothing+          else+            findParent dir_id parent_ (child:acc)+ -- | Take an absolute path and a string representing a (possibly relative) -- path and combine them into an absolute path. If the second argument is -- already absolute, then the first argument gets ignored. This function also@@ -339,11 +337,13 @@ -- | Normalize the path separator to Posix style (slash, not backslash). -- This only affects Windows systems. pathToPosix :: FilePath -> FilePath-pathToPosix = map convert where #ifdef WIN32+pathToPosix = map convert where   convert '\\' = '/'-#endif   convert c = c+#else+pathToPosix = id+#endif  -- | Reduce multiple leading slashes to one. This only affects Posix systems. normSlashes :: FilePath -> FilePath@@ -356,48 +356,11 @@ getCurrentDirectory :: IO AbsolutePath getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory -setCurrentDirectory :: FilePathLike p => p -> IO ()-setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath--{-|-  What is a malicious path?--  A spoofed path is a malicious path.--  1. Darcs only creates explicitly relative paths (beginning with @\".\/\"@),-     so any not explicitly relative path is surely spoofed.--  2. Darcs normalizes paths so they never contain @\"\/..\/\"@, so paths with-     @\"\/..\/\"@ are surely spoofed.--  A path to a darcs repository's meta data can modify \"trusted\" patches or-  change safety defaults in that repository, so we check for paths-  containing @\"\/_darcs\/\"@ which is the entry to darcs meta data.--  To do?--  * How about get repositories?--  * Would it be worth adding a --semi-safe-paths option for allowing-    changes to certain preference files (_darcs\/prefs\/) in sub-    repositories'?--  TODO:-    Properly review the way we handle paths on Windows - it's not enough-    to just use the OS native concept of path separator. Windows often-    accepts both path separators, and repositories always use the UNIX-    separator anyway.--}--isMaliciousSubPath :: String -> Bool-isMaliciousSubPath fp =-    not (FilePath.isRelative fp) || isGenerallyMalicious fp--isGenerallyMalicious :: String -> Bool-isGenerallyMalicious fp =-    splitDirectories fp `contains_any` [ "..", darcsdir ]- where-    contains_any a b = not . null $ intersect a b+setCurrentDirectory :: HasCallStack => FilePathLike p => p -> IO ()+setCurrentDirectory path+  | isHttpUrl (toFilePath path) || isSshUrl (toFilePath path) =+    error $ "setCurrentDirectory " ++ toFilePath path+setCurrentDirectory path = System.Directory.setCurrentDirectory (toFilePath path)  -- | Iteratively tries find first non-existing path generated by -- buildName, it feeds to buildName the number starting with -1.  When@@ -428,7 +391,7 @@ -- usually used to refer to a location within a Tree, but a relative filesystem -- path works just as well. These are either constructed from individual name -- components (using "appendPath", "catPaths" and "makeName"), or converted--- from a FilePath ("floatPath" -- but take care when doing that).+-- from a FilePath ("unsafeFloatPath" -- but take care when doing that). newtype AnchoredPath = AnchoredPath [Name] deriving (Binary, Eq, Show, Ord)  -- | Check whether a path is a prefix of another path.@@ -450,20 +413,11 @@ parent (AnchoredPath []) = Nothing parent (AnchoredPath x) = Just (AnchoredPath (init x)) --- | List all parents of a given path. foo/bar/baz -> [.,foo, foo/bar]+-- | List all (proper) parents of a given path. foo/bar/baz -> [.,foo, foo/bar] parents :: AnchoredPath -> [AnchoredPath] parents (AnchoredPath []) = [] -- root has no parents parents (AnchoredPath xs) = map AnchoredPath $ inits $ init xs --- | If the patch is under a directory, split into Right of the first component--- (which must be a directory name) and the rest of teh path. Otherwise--- return Left of the single component.--- This function is *undefined* on the root path (which has no components).-breakOnDir :: AnchoredPath -> Either Name (Name, AnchoredPath)-breakOnDir (AnchoredPath []) = error "breakOnDir called on root"-breakOnDir (AnchoredPath (n:[])) = Left n-breakOnDir (AnchoredPath (n:ns)) = Right (n, AnchoredPath ns)- -- | Take a "root" directory and an anchored path and produce a full -- 'FilePath'. Moreover, you can use @anchorPath \"\"@ to get a relative -- 'FilePath'.@@ -479,31 +433,31 @@ flatten (AnchoredPath []) = BC.singleton '.' flatten (AnchoredPath p) = BC.intercalate (BC.singleton '/') [n | (Name n) <- p] --- | Make a 'Name' from a 'String'. If the input 'String'--- is invalid, that is, "", ".", "..", or contains a '/', return 'Left'--- with an error message.+-- | Make a 'Name' from a 'String'. May fail if the input 'String'+-- is invalid, that is, "", ".", "..", or contains a '/'. makeName :: String -> Either String Name makeName = rawMakeName . encodeLocale --- | Make a 'Name' from a 'String'. If the input 'String'--- is invalid, that is, "", ".", "..", or contains a '/', call error.-internalMakeName :: String -> Name-internalMakeName = either error id . rawMakeName . encodeLocale- -- | Take a relative FilePath and turn it into an AnchoredPath. This is a--- partial function. Basically, by using floatPath, you are testifying that the+-- partial function. Basically, by using unsafeFloatPath, you are testifying that the -- argument is a path relative to some common root -- i.e. the root of the -- associated "Tree" object. In particular, the input path may not contain any -- ocurrences of "." or ".." after normalising. You should sanitize any -- FilePaths before you declare them "good" by converting into AnchoredPath -- (using this function), especially if the FilePath come from any external -- source (command line, file, environment, network, etc)-floatPath :: FilePath -> AnchoredPath-floatPath =-    AnchoredPath . map internalMakeName . filter sensible .-    splitDirectories . normalise . dropTrailingPathSeparator+unsafeFloatPath :: HasCallStack => FilePath -> AnchoredPath+unsafeFloatPath = either error id . floatPath++floatPath :: FilePath -> Either String AnchoredPath+floatPath path = do+    r <- mapM makeName (prepare path)+    return (AnchoredPath r)   where     sensible s = s `notElem` ["", "."]+    prepare = filter sensible .+      NativeFilePath.splitDirectories . NativeFilePath.normalise .+      NativeFilePath.dropTrailingPathSeparator  anchoredRoot :: AnchoredPath anchoredRoot = AnchoredPath []@@ -545,14 +499,9 @@ encodeWhiteName :: Name -> B.ByteString encodeWhiteName = encodeLocale . encodeWhite . decodeLocale . unName -data CorruptPatch = CorruptPatch String deriving (Eq, Typeable)-instance Exception CorruptPatch-instance Show CorruptPatch where show (CorruptPatch s) = s--decodeWhiteName :: B.ByteString -> Name+decodeWhiteName :: B.ByteString -> Either String Name decodeWhiteName =-  either (throw . CorruptPatch) id .-  rawMakeName . encodeLocale . decodeWhite . decodeLocale+  rawMakeName . encodeLocale <=< decodeWhite . decodeLocale  -- | The effect of renaming on paths. -- The first argument is the old path, the second is the new path,@@ -570,9 +519,8 @@ filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool filterPaths files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files - -- | Transform a SubPath into an AnchoredPath.-floatSubPath :: SubPath -> AnchoredPath+floatSubPath :: SubPath -> Either String AnchoredPath floatSubPath = floatPath . toFilePath  -- | Is the given path in (or equal to) the _darcs metadata directory?@@ -581,7 +529,7 @@ inDarcsdir _ = False  darcsdirName :: Name-darcsdirName = internalMakeName darcsdir+darcsdirName = either error id (makeName darcsdir)  isRoot :: AnchoredPath -> Bool isRoot (AnchoredPath xs) = null xs
src/Darcs/Util/Printer.hs view
@@ -318,9 +318,8 @@ invisiblePS :: B.ByteString -> Doc invisiblePS = invisiblePrintable . PS --- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'.------ Rrrright. And what, please is that supposed to mean?+-- | Create a 'Doc' representing a user chunk from a 'B.ByteString';+-- see 'userchunk' for details. userchunkPS :: B.ByteString -> Doc userchunkPS = userchunkPrintable . PS @@ -344,7 +343,18 @@ hiddenText :: String -> Doc hiddenText = hiddenPrintable . S --- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@+-- | Create a 'Doc' containing a userchunk from a @String@.+--+-- Userchunks are used for printing arbitrary bytes stored in prim patches:+--+--  * old and new preference values in ChangePref prims+--  * tokenChars, old token and new token in TokReplace prims+--  * old and new content lines in Hunk prims+--+-- In colored mode they are printed such that trailing whitespace before the+-- end of a line is made visible by marking the actual line ending with a red+-- '$' char (unless DARCS_DONT_ESCAPE_TRAILING_SPACES or even+-- DARCS_DONT_ESCAPE_ANYTHING are set in the environment). userchunk :: String -> Doc userchunk = userchunkPrintable . S @@ -394,7 +404,7 @@ hiddenPrintable :: Printable -> Doc hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st --- | Creates... WTF is a userchunk???+-- | Creates a userchunk from any 'Printable'; see 'userchunk' for details. userchunkPrintable :: Printable -> Doc userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st @@ -445,7 +455,7 @@ -- | 'mappend' ('<>') is concatenation, 'mempty' is the 'empty' 'Doc' instance Monoid Doc where   mempty = empty-  mappend = append+  mappend = (<>)  -- | Concatenation of two 'Doc's append :: Doc -> Doc -> Doc
src/Darcs/Util/Printer/Color.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} module Darcs.Util.Printer.Color-    ( unsafeRenderStringColored, traceDoc, debugDoc, fancyPrinters+    ( unsafeRenderStringColored, traceDoc, fancyPrinters     , environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite     , ePutDocLn     ) where@@ -14,7 +14,6 @@     , renderStringWith, prefix     , hPutDocLnWith     )-import Darcs.Util.Global ( whenDebugMode, putTiming )  import Debug.Trace ( trace ) import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr )@@ -41,11 +40,6 @@ -- silenced even when --quiet is in effect. ePutDocLn :: Doc -> IO () ePutDocLn = hPutDocLnWith fancyPrinters stderr--debugDoc :: Doc -> IO ()-debugDoc m = whenDebugMode $ do-  putTiming-  hPutDocLnWith fancyPrinters stderr m  traceDoc :: Doc -> a -> a traceDoc = trace . unsafeRenderStringColored
src/Darcs/Util/Progress.hs view
@@ -13,6 +13,8 @@       beginTedious     , endTedious     , tediousSize+    , withProgress+    , withSizedProgress     , debugMessage     , withoutProgress     , progress@@ -29,7 +31,7 @@  import Control.Arrow ( second ) import Control.Exception ( bracket )-import Control.Monad ( when, unless, void )+import Control.Monad ( when, void ) import Control.Concurrent ( forkIO, threadDelay )  import Data.Char ( toLower )@@ -37,12 +39,11 @@ import Data.Maybe ( isJust ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) -import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn,-                   hSetBuffering, hIsTerminalDevice,-                   Handle, BufferMode(LineBuffering) )+import qualified System.Console.Terminal.Size as TS ( size, width )+import System.IO ( hFlush, stdout ) import System.IO.Unsafe ( unsafePerformIO ) -import Darcs.Util.Global ( withDebugMode, debugMessage, putTiming )+import Darcs.Util.Global ( debugMessage )   data ProgressData = ProgressData@@ -80,34 +81,24 @@               -> ProgressData               -> IO () printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =-    myput output output-  where-    output = k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued. " ++ l+    putCr (k ++ " ... " ++ show s ++ " done, " ++ show (t - s) ++ " queued. " ++ l) printProgress k (ProgressData {latest=Just l}) =-    myput (k ++ " " ++ l) k+    putCr (k ++ " ... " ++ l) printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =-    myput (k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued")-          (k ++ " " ++ show s)+    putCr (k ++ " ... " ++ show s ++ " done, " ++ show (t - s) ++ " queued") printProgress k (ProgressData {sofar=s}) =-    myput (k ++ " " ++ show s) k---myput :: String -> String -> IO ()-myput l s = withDebugMode $ \debugMode ->-    if debugMode-      then putTiming >> hPutStrLn stderr l-      else-        if '\n' `elem` l-          then myput (takeWhile (/= '\n') l) s-          else putTiming >> if length l < 80-                              then simpleput l-                              else simpleput (take 80 s)+    putCr (k ++ " ... " ++ show s) +putCr :: String -> IO ()+putCr = unsafePerformIO mkPutCr+{-# NOINLINE putCr #-} -simpleput :: String -> IO ()-simpleput = unsafePerformIO $ mkhPutCr stderr-{-# NOINLINE simpleput #-}+withProgress :: String -> (String -> IO a) -> IO a+withProgress k = bracket (beginTedious k >> return k) endTedious +withSizedProgress :: String -> Int -> (String -> IO a) -> IO a+withSizedProgress k n =+  bracket (beginTedious k >> tediousSize k n >> return k) endTedious  -- | @beginTedious k@ starts a tedious process and registers it in -- '_progressData' with the key @k@. A tedious process is one for which we want@@ -132,7 +123,7 @@ endTedious k = whenProgressMode $ do     p <- getProgressData k     modifyIORef _progressData (second $ delete k)-    when (isJust p) $ debugMessage $ "Done " ++ map toLower k+    when (isJust p) $ putCr $ k ++ " ... done"   tediousSize :: String@@ -184,9 +175,7 @@ progressIO k = do     updateProgressData k $ \p ->         p { sofar = sofar p + 1, latest = Nothing }-    putDebug k "" - progressKeepLatest :: String                    -> a                    -> a@@ -197,9 +186,7 @@ progressKeepLatestIO "" = return () progressKeepLatestIO k = do     updateProgressData k (\p -> p {sofar = sofar p + 1})-    putDebug k "" - finishedOne :: String -> String -> a -> a finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a @@ -209,21 +196,10 @@ finishedOneIO k l = do     updateProgressData k (\p -> p { sofar = sofar p + 1,                                     latest = Just l })-    putDebug k l  -putDebug :: String-         -> String-         -> IO ()-putDebug _ _ = return ()---putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k---putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l-- _progressMode :: IORef Bool-_progressMode = unsafePerformIO $ do-    hSetBuffering stderr LineBuffering-    newIORef True+_progressMode = unsafePerformIO $ newIORef True {-# NOINLINE _progressMode #-}  _progressData :: IORef (String, Map String ProgressData)@@ -232,21 +208,18 @@     newIORef ("", empty) {-# NOINLINE _progressData #-} -mkhPutCr :: Handle-         -> IO (String -> IO ())-mkhPutCr fe = do-    isTerm <- hIsTerminalDevice fe-    stdoutIsTerm <- hIsTerminalDevice stdout-    return $-        if isTerm-          then \s -> do-              hPutStr fe $ '\r':s ++ "\r"-              hFlush fe-              let spaces = '\r':replicate (length s) ' ' ++ "\r"-              hPutStr fe spaces-              when stdoutIsTerm $ putStr spaces-          else \s -> unless (null s) $ do hPutStrLn fe s-                                          hFlush fe+mkPutCr :: IO (String -> IO ())+mkPutCr =+  TS.size >>= \case+    Nothing ->+      -- stdout is not a terminal+      return $ \_ -> return ()+    Just window -> do+      let limitToWidth = take (TS.width window - 1)+      return $ \s -> do+        putStr $ '\r':limitToWidth s ++ "\r"+        hFlush stdout+        putStr $ '\r':limitToWidth ((replicate (length s)) ' ') ++ "\r"  setProgressMode :: Bool -> IO () setProgressMode = writeIORef _progressMode
src/Darcs/Util/Regex.hs view
@@ -1,4 +1,5 @@ -- | This module is a subset of the defunct regex-compat-tdfa.+{-# LANGUAGE CPP #-} module Darcs.Util.Regex     ( Regex     , mkRegex@@ -8,20 +9,44 @@  import Darcs.Prelude +import Control.Exception ( throw )+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif import Text.Regex.Base     ( RegexContext(matchM)-    , RegexMaker(makeRegexOpts)+    , RegexMaker(makeRegexOptsM)     , defaultCompOpt     , defaultExecOpt     )-import Text.Regex.TDFA (Regex, caseSensitive, multiline, newSyntax)+import Text.Regex.TDFA ( Regex, caseSensitive, multiline, newSyntax ) +-- | The "sane" API for regex ('makeRegexOptM') requires 'MonadFail'+-- but we want a pure one for compatibility with e.g. "Darcs.Patch.Match".+newtype RegexFail a = RegexFail { runRegexFail :: Either String a }+  -- The subtlety here is that only in base-4.13.0 the fail method+  -- in class Monad was removed. For earlier versions, regex-tdfa+  -- calls the fail from class Monad, not the one from class MonadFail.+#if MIN_VERSION_base(4,13,0)+  deriving (Functor, Applicative, Monad)+#else+  deriving (Functor, Applicative)++instance Monad RegexFail where+  RegexFail (Left e) >>= _ = RegexFail (Left e)+  RegexFail (Right r) >>= k = k r+  fail = RegexFail . Left+#endif++instance MonadFail RegexFail where+  fail = RegexFail . Left+ -- | Makes a regular expression with the default options (multi-line, -- case-sensitive).  The syntax of regular expressions is -- otherwise that of @egrep@ (i.e. POSIX \"extended\" regular -- expressions). mkRegex :: String -> Regex-mkRegex s = makeRegexOpts opt defaultExecOpt s+mkRegex s = mkRegexInternal opt s   where     opt = defaultCompOpt {newSyntax = True, multiline = True} @@ -39,7 +64,13 @@                 { multiline    = (if single_line then True else False)                 , caseSensitive = (if case_sensitive then True else False)                 , newSyntax     = True }-    in makeRegexOpts opt defaultExecOpt s+    in mkRegexInternal opt s++mkRegexInternal :: RegexMaker p compOpt execOpt String => compOpt -> String -> p+mkRegexInternal opt s =+  case runRegexFail (makeRegexOptsM opt defaultExecOpt s) of+    Left e -> throw (userError ("Invalid regular expression:\n" ++ e))+    Right r -> r  -- | Match a regular expression against a string matchRegex ::
src/Darcs/Util/Show.hs view
@@ -1,18 +1,6 @@-module Darcs.Util.Show-    ( appPrec, BSWrapper(..)-    ) where+module Darcs.Util.Show ( appPrec ) where  import Darcs.Prelude -import qualified Data.ByteString as B- appPrec :: Int appPrec = 10--newtype BSWrapper = BSWrapper B.ByteString--instance Show BSWrapper where-    showsPrec d (BSWrapper bs) =-        showParen (d > appPrec) $-            showString "Data.ByteString.Char8.pack " .-            showsPrec (appPrec + 1) bs
src/Darcs/Util/SignalHandler.hs view
@@ -29,7 +29,7 @@ import System.Exit ( exitWith, ExitCode ( ExitFailure ) ) import Control.Concurrent ( ThreadId, myThreadId ) import Control.Exception-            ( catch, throw, throwTo, mask,+            ( catch, throwIO, throwTo, mask,               Exception(..), SomeException(..), IOException ) import System.Posix.Files ( getFdStatus, isNamedPipe ) import System.Posix.IO ( stdOutput )@@ -109,13 +109,13 @@     where handler' se =            case fromException se :: Maybe SignalException of              Nothing -> handler se-             Just _ -> throw se+             Just _ -> throwIO se  catchInterrupt :: IO a -> IO a -> IO a catchInterrupt job handler =     job `catchSignal` h         where h s | s == sigINT = handler-                  | otherwise   = throw (SignalException s)+                  | otherwise   = throwIO (SignalException s)  tryNonSignal :: IO a -> IO (Either SomeException a) tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e)@@ -125,7 +125,7 @@   where handler' ioe          | isUserError ioe                       = handler (ioeGetErrorString ioe)          | ioeGetFileName ioe == Just "<stdout>" = handler ("STDOUT" ++ ioeGetErrorString ioe)-         | otherwise                             = throw ioe+         | otherwise                             = throwIO ioe  withSignalsBlocked :: IO a -> IO a withSignalsBlocked job = mask (\unmask -> job >>= \r ->
src/Darcs/Util/Ssh.hs view
@@ -27,6 +27,7 @@     , environmentHelpScp     , environmentHelpSshPort     , transferModeHeader+    , resetSshConnections     ) where  import Darcs.Prelude@@ -36,7 +37,7 @@  import Control.Concurrent.MVar ( MVar, newMVar, withMVar, modifyMVar, modifyMVar_ ) import Control.Exception ( throwIO, catch, catchJust, SomeException )-import Control.Monad ( unless, (>=>) )+import Control.Monad ( forM_, unless, void, (>=>) )  import qualified Data.ByteString as B (ByteString, hGet, writeFile ) @@ -44,7 +45,13 @@  import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush ) import System.IO.Unsafe ( unsafePerformIO )-import System.Process ( runInteractiveProcess, readProcessWithExitCode )+import System.Process+    ( ProcessHandle+    , readProcessWithExitCode+    , runInteractiveProcess+    , terminateProcess+    , waitForProcess+    )  import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.URL ( SshFilePath, sshFilePathOf, sshUhost, sshRepo, sshFile )@@ -122,6 +129,7 @@     { inp :: !Handle     , out :: !Handle     , err :: !Handle+    , proc :: !ProcessHandle     }  -- | Identifier (key) for a connection.@@ -177,14 +185,14 @@   let sshargs = sshargs_ ++ ["--", sshUhost sshfp, rdarcs,                              "transfer-mode", "--repodir", sshRepo sshfp]   debugMessage $ "Exec: " ++ showCommandLine (sshcmd:sshargs)-  (i,o,e,_) <- runInteractiveProcess sshcmd sshargs Nothing Nothing+  (i,o,e,ph) <- runInteractiveProcess sshcmd sshargs Nothing Nothing   do     hSetBinaryMode i True     hSetBinaryMode o True     l <- hGetLine o     unless (l == transferModeHeader) $       fail "Couldn't start darcs transfer-mode on server"-    return $ Just C { inp = i, out = o, err = e }+    return $ Just C { inp = i, out = o, err = e, proc = ph }     `catchNonSignal` \exn -> do       debugMessage $ "Failed to start ssh connection: " ++ prettyException exn       debugMessage $ unlines@@ -194,6 +202,20 @@                     ]       return Nothing +-- | Terminate all child processes that run a remote "darcs transfer-mode" and+-- remove them from the 'sshConnections', causing subsequent 'copySSH' calls to+-- start a fresh child.+resetSshConnections :: IO ()+resetSshConnections =+  modifyMVar_ sshConnections $ \cmap -> do+    forM_ cmap $ \case+      Just mvarc -> do+        withMVar mvarc $ \C{ proc = ph } -> do+          terminateProcess ph+          void $ waitForProcess ph+      Nothing -> return ()+    return empty+ -- | Mark any connection associated with the given ssh file path -- as failed, so it won't be tried again. dropSshConnection :: RepoId -> IO ()@@ -319,8 +341,11 @@     "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",     "The commands invoked can be customized with the environment variables",     "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",-    "If the remote end allows only sftp, try setting DARCS_SCP=sftp."])-+    "If the remote end allows only sftp, try setting DARCS_SCP=sftp.",+    "",+    "scp is also used by `darcs clone` if the destination is a remote ssh",+    "directory. This operation can be made quite a bit faster by setting",+    "DARCS_SCP=rsync."])  environmentHelpSshPort :: ([String], [String]) environmentHelpSshPort = (["SSH_PORT"], [
src/Darcs/Util/Tree.hs view
@@ -6,7 +6,7 @@ -- | The abstract representation of a Tree and useful abstract utilities to -- handle those. module Darcs.Util.Tree-    ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..)+    ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash     , makeTree, makeTreeWithHash, emptyTree, emptyBlob, makeBlob, makeBlobBS      -- * Unfolding stubbed (lazy) Trees.@@ -20,7 +20,8 @@     , items, list, listImmediate, treeHash     , lookup, find, findFile, findTree, itemHash, itemType     , zipCommonFiles, zipFiles, zipTrees, diffTrees-    , explodePath, explodePaths+    , explodePath, explodePaths, locate, isDir+    , treeHas, treeHasDir, treeHasFile, treeHasAnycase      -- * Files (Blobs).     , readBlob@@ -50,16 +51,17 @@ import Data.Maybe( catMaybes, isNothing ) import Data.Either( lefts, rights ) import Data.List( union, sort )-import Control.Monad( filterM )+import qualified Data.List+import Control.Monad( filterM, join )  -------------------------------- -- Tree, Blob and friends -- -data Blob m = Blob !(m BL.ByteString) !Hash+data Blob m = Blob !(m BL.ByteString) !(Maybe Hash) data TreeItem m = File !(Blob m)                 | SubTree !(Tree m)-                | Stub !(m (Tree m)) !Hash+                | Stub !(m (Tree m)) !(Maybe Hash)  data ItemType = TreeType | BlobType deriving (Show, Eq, Ord) @@ -81,13 +83,13 @@                    -- | Get hash of a Tree. This is guaranteed to uniquely                    -- identify the Tree (including any blob content), as far as                    -- cryptographic hashes are concerned. Sha256 is recommended.-                   , treeHash :: !Hash }+                   , treeHash :: !(Maybe Hash) }  listImmediate :: Tree m -> [(Name, TreeItem m)] listImmediate = M.toList . items  -- | Get a hash of a TreeItem. May be Nothing.-itemHash :: TreeItem m -> Hash+itemHash :: TreeItem m -> Maybe Hash itemHash (File (Blob _ h)) = h itemHash (SubTree t) = treeHash t itemHash (Stub _ h) = h@@ -99,24 +101,24 @@  emptyTree :: Tree m emptyTree = Tree { items = M.empty-                 , treeHash = NoHash }+                 , treeHash = Nothing }  emptyBlob :: (Monad m) => Blob m-emptyBlob = Blob (return BL.empty) NoHash+emptyBlob = Blob (return BL.empty) Nothing  makeBlob :: (Monad m) => BL.ByteString -> Blob m-makeBlob str = Blob (return str) (sha256 str)+makeBlob str = Blob (return str) (Just $ sha256 str)  makeBlobBS :: (Monad m) => B.ByteString -> Blob m-makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (sha256 s)+makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (Just $ sha256 s)  makeTree :: [(Name,TreeItem m)] -> Tree m makeTree l = Tree { items = M.fromList l-                  , treeHash = NoHash }+                  , treeHash = Nothing }  makeTreeWithHash :: [(Name,TreeItem m)] -> Hash -> Tree m makeTreeWithHash l h = Tree { items = M.fromList l-                            , treeHash = h }+                            , treeHash = Just h }  ----------------------------------- -- Tree access and lookup@@ -160,6 +162,45 @@                     concat [ paths subt (appendPath p subn)                              | (subn, SubTree subt) <- listImmediate t ] +-- | Like 'find' but monadic and thus able to expand 'Stub's on the way.+locate :: Monad m => Tree m -> AnchoredPath -> m (Maybe (TreeItem m))+locate tree (AnchoredPath names) = go names (SubTree tree)+  where+    go [] i = return (Just i)+    go _ (File _) = return Nothing+    go ns (Stub mkTree _) = mkTree >>= go ns . SubTree+    go (n:ns) (SubTree t) =+      case lookup t n of+        Nothing -> return Nothing+        Just i -> go ns i++isDir :: TreeItem m -> Bool+isDir (File _) = False+isDir _ = True++treeHasAnycase :: Monad m+               => Tree m+               -> AnchoredPath+               -> m Bool+treeHasAnycase tree (AnchoredPath names) = go names (SubTree tree)+  where+    go [] _ = return True+    go ns (Stub mkTree _) = mkTree >>= go ns . SubTree+    go _ (File _) = return False+    go (n:ns) (SubTree t) =+      case Data.List.find (eqAnycase n . fst) (listImmediate t) of+        Nothing -> return False+        Just (_,i) -> go ns i++treeHas :: Monad m => Tree m -> AnchoredPath -> m Bool+treeHas tree path = maybe False (const True) <$> locate tree path++treeHasDir :: Monad m => Tree m -> AnchoredPath -> m Bool+treeHasDir tree path = maybe False isDir <$> locate tree path++treeHasFile :: Monad m => Tree m -> AnchoredPath -> m Bool+treeHasFile tree path = maybe False (not . isDir) <$> locate tree path+ -- | Like 'explodePath' but for multiple paths. explodePaths :: Tree IO -> [AnchoredPath] -> [AnchoredPath] explodePaths tree paths = concatMap (explodePath tree) paths@@ -171,16 +212,19 @@ explodePath tree path =   path : maybe [] (map (catPaths path . fst) . list) (findTree tree path) -expandUpdate :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)-expandUpdate update t_ = go (AnchoredPath []) t_-    where go path t = do-            let subtree (name, sub) = do tree <- go (path `appendPath` name) =<< unstub sub-                                         return (name, SubTree tree)-            expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isSub item ]-            let orig_map = M.filter (not . isSub) (items t)-                expanded_map = M.fromList expanded-                tree = t { items = M.union orig_map expanded_map }-            update path tree+expandUpdate+  :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)+expandUpdate update = go (AnchoredPath [])+  where+    go path t = do+      let subtree (name, sub) = do+            tree <- go (path `appendPath` name) =<< unstub sub+            return (name, SubTree tree)+      expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isDir item ]+      let orig_map     = M.filter (not . isDir) (items t)+          expanded_map = M.fromList expanded+          tree         = t { items = M.union orig_map expanded_map }+      update path tree  -- | Expand a stubbed Tree into a one with no stubs in it. You might want to -- filter the tree before expanding to save IO. This is the basic@@ -196,7 +240,7 @@ expandPath t (AnchoredPath []) = return t expandPath t (AnchoredPath (n:rest)) =   case lookup t n of-    (Just item) | isSub item -> amend t n rest =<< unstub item+    (Just item) | isDir item -> amend t n rest =<< unstub item     _ -> return t -- fail $ "Descent error in expandPath: " ++ show path_     where           amend t' name rest' sub = do@@ -209,7 +253,7 @@ -- where there are problems. The first argument is the hashing function -- used to create the tree. checkExpand :: (TreeItem IO -> IO Hash) -> Tree IO-            -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))+            -> IO (Either [(AnchoredPath, Maybe Hash, Maybe Hash)] (Tree IO)) checkExpand hashFunc t = go (AnchoredPath []) t     where       go path t_ = do@@ -225,22 +269,22 @@                               Left problems -> Left problems                               Right tree -> Right (name, SubTree tree)             badBlob (_, f@(File (Blob _ h))) =-              fmap (/= h) (hashFunc f `catch` (\(_ :: IOException) -> return NoHash))+              fmap (/= h) (fmap Just (hashFunc f) `catch` (\(_ :: IOException) -> return Nothing))             badBlob _ = return False             render (name, f@(File (Blob _ h))) = do               h' <- (Just <$> hashFunc f) `catch` \(_ :: IOException) -> return Nothing               return (path `appendPath` name, h, h')-            render (name, _) = return (path `appendPath` name, NoHash, Nothing)-        subs <- mapM subtree [ x | x@(_, item) <- listImmediate t_, isSub item ]+            render (name, _) = return (path `appendPath` name, Nothing, Nothing)+        subs <- mapM subtree [ x | x@(_, item) <- listImmediate t_, isDir item ]         badBlobs <- filterM badBlob (listImmediate t) >>= mapM render         let problems = badBlobs ++ concat (lefts subs)         if null problems          then do-           let orig_map = M.filter (not . isSub) (items t)+           let orig_map = M.filter (not . isDir) (items t)                expanded_map = M.fromList $ rights subs                tree = t_ {items = orig_map `M.union` expanded_map}            h' <- hashFunc (SubTree t_)-           if h' `match` treeHash t_+           if Just h' `match` treeHash t_             then return $ Right tree             else return $ Left [(path, treeHash t_, Just h')]          else return $ Left problems@@ -253,17 +297,15 @@     filter :: (AnchoredPath -> TreeItem m -> Bool) -> a m -> a m  instance (Monad m) => FilterTree Tree m where-    filter predicate t_ = filter' t_ (AnchoredPath [])-        where filter' t path = t { items = M.mapMaybeWithKey (wibble path) $ items t }+    filter predicate = filter' (AnchoredPath [])+        where filter' path t = t { items = M.mapMaybeWithKey (wibble path) $ items t }               wibble path name item =                   let npath = path `appendPath` name in                       if predicate npath item                          then Just $ filterSub npath item                          else Nothing-              filterSub npath (SubTree t) = SubTree $ filter' t npath-              filterSub npath (Stub stub h) =-                  Stub (do x <- stub-                           return $ filter' x npath) h+              filterSub npath (SubTree t) = SubTree (filter' npath t)+              filterSub npath (Stub stub _) = Stub (filter' npath <$> stub) Nothing               filterSub _ x = x  -- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a@@ -378,15 +420,13 @@ modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m modifyTree t_ p_ i_ = snd $ go t_ p_ i_   where fix t unmod items' = (unmod, t { items = (countmap items':: Int) `seq` items'-                                       , treeHash = if unmod then treeHash t else NoHash })+                                       , treeHash = if unmod then treeHash t else Nothing })          go t (AnchoredPath []) (Just (SubTree sub)) = (treeHash t `match` treeHash sub, sub)          go t (AnchoredPath [n]) (Just item) = fix t unmod items'             where !items' = M.insert n item (items t)-                  !unmod = itemHash item `match` case lookup t n of-                                             Nothing -> NoHash-                                             Just i -> itemHash i+                  !unmod = itemHash item `match` join (fmap itemHash (lookup t n))          go t (AnchoredPath [n]) Nothing = fix t unmod items'             where !items' = M.delete n (items t)@@ -400,7 +440,7 @@                   !sub' = case lookup t n of                     Just (SubTree s) -> let (mod', sub'') = subtree s in (mod', SubTree sub'')                     Just (Stub s _) -> (False, Stub (do x <- s-                                                        return $! snd $! subtree x) NoHash)+                                                        return $! snd $! subtree x) Nothing)                     Nothing -> (False, SubTree $! snd $! subtree emptyTree)                     _ -> error $ "Modify tree at " ++ show path @@ -417,7 +457,7 @@ updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m updateSubtrees fun t =     fun $ t { items = M.mapWithKey (curry $ snd . update) $ items t-            , treeHash = NoHash }+            , treeHash = Nothing }   where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s)         update (k, File f) = (k, File f)         update (_, Stub _ _) = error "Stubs not supported in updateTreePostorder"@@ -433,7 +473,7 @@   where go path t = do           items' <- M.fromList <$> mapM (maybeupdate path) (listImmediate t)           subtree <- fun . SubTree $ t { items = items'-                                       , treeHash = NoHash }+                                       , treeHash = Nothing }           case subtree of             SubTree t'' -> return t''             _ -> error "function passed to partiallyUpdateTree changed SubTree to something else"@@ -449,40 +489,39 @@ -- object, nor it is allowed for the overlay to add new objects to base.  This -- means that the overlay Tree should be a subset of the base Tree (although -- any extraneous items will be ignored by the implementation).-overlay :: (Monad m) => Tree m -> Tree m -> Tree m-overlay base over = Tree { items = M.fromList immediate-                         , treeHash = NoHash }-    where immediate = [ (n, get n) | (n, _) <- listImmediate base ]-          get n = case (M.lookup n $ items base, M.lookup n $ items over) of-                    (Just (File _), Just f@(File _)) -> f-                    (Just (SubTree b), Just (SubTree o)) -> SubTree $ overlay b o-                    (Just (Stub b _), Just (SubTree o)) -> Stub (flip overlay o `fmap` b) NoHash-                    (Just (SubTree b), Just (Stub o _)) -> Stub (overlay b `fmap` o) NoHash-                    (Just (Stub b _), Just (Stub o _)) -> Stub (do o' <- o-                                                                   b' <- b-                                                                   return $ overlay b' o') NoHash-                    (Just x, _) -> x-                    (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "."+overlay :: Applicative m => Tree m -> Tree m -> Tree m+overlay base over = Tree {items = M.fromList immediate, treeHash = Nothing}+  where+    immediate = [(n, get n) | (n, _) <- listImmediate base]+    get n =+      case (M.lookup n $ items base, M.lookup n $ items over) of+        (Just (File _), Just f@(File _)) -> f+        (Just (SubTree b), Just (SubTree o)) -> SubTree $ overlay b o+        (Just (Stub b _), Just (SubTree o)) -> Stub (overlay <$> b <*> pure o) Nothing+        (Just (SubTree b), Just (Stub o _)) -> Stub (overlay <$> pure b <*> o) Nothing+        (Just (Stub b _), Just (Stub o _)) -> Stub (overlay <$> b <*> o) Nothing+        (Just x, _) -> x+        (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "." +-- | Calculate and insert hashes for all 'TreeItem's contained in a 'Tree',+-- including the argument 'Tree' itself. If necessary, this expands 'Stub's. addMissingHashes :: (Monad m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m)-addMissingHashes make = updateTree update -- use partiallyUpdateTree here-    where update (SubTree t) = make (SubTree t) >>= \x -> return $ SubTree (t { treeHash = x })-          update (File blob@(Blob con NoHash)) =-              do hash <- make $ File blob-                 return $ File (Blob con hash)-          update (Stub s NoHash) = update . SubTree =<< s+addMissingHashes make = updateTree update+    where update item@(SubTree t) = do+              hash <- make item+              return $ SubTree (t { treeHash = Just hash })+          update item@(File (Blob con Nothing)) = do+              hash <- make item+              return $ File (Blob con (Just hash))+          update (Stub s Nothing) = update . SubTree =<< s           update x = return x ------- Private utilities shared among multiple functions. --------+-- ---- Private utilities shared among multiple functions. --------  unstub :: (Monad m) => TreeItem m -> m (Tree m) unstub (Stub s _) = s unstub (SubTree s) = return s unstub _ = return emptyTree--isSub :: TreeItem m -> Bool-isSub (File _) = False-isSub _ = True  -- Properties
src/Darcs/Util/Tree/Hashed.hs view
@@ -18,36 +18,36 @@     -- * Interact with hashed tree     , hashedTreeIO     -- * Other-    , readDarcsHashedDir     , readDarcsHashedNosize     , darcsAddMissingHashes-    , darcsLocation     , darcsTreeHash-    , decodeDarcsHash-    , decodeDarcsSize     , darcsUpdateHashes+    , followPristineHashes     ) where -import System.FilePath ( (</>) )--import System.Directory( doesFileExist )-import Codec.Compression.GZip( decompress, compress )- import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString as B -import Data.List( sortBy )-import Data.Maybe( fromJust, isJust )-import Control.Monad.State.Strict (liftIO,when,unless)+import Data.List ( sortBy )+import Data.Maybe ( fromMaybe )  import Darcs.Prelude -import Darcs.Util.ByteString (FileSegment, readSegment)-import Darcs.Util.Hash (Hash(..), decodeBase16, encodeBase16, sha256)-import Darcs.Util.Path (Name, decodeWhiteName, encodeWhiteName)-import Darcs.Util.Progress (debugMessage)+import Darcs.Util.Cache+    ( Cache+    , fetchFileUsingCache+    , writeFileUsingCache+    )+import Darcs.Util.Hash+    ( Hash+    , encodeBase16+    , encodeHash+    , sha256+    , showHash+    )+import Darcs.Util.Parser+import Darcs.Util.Path ( Name, decodeWhiteName, encodeWhiteName )+import Darcs.Util.Progress ( debugMessage, finishedOneIO, withSizedProgress ) import Darcs.Util.Tree     ( Blob(..)     , ItemType(..)@@ -63,96 +63,86 @@     , updateSubtrees     , updateTree     )-import Darcs.Util.Tree.Monad (TreeIO, runTreeMonad)-------------------------------------------------------------------------- Utilities for coping with the darcs directory format.-----decodeDarcsHash :: BC.ByteString -> Hash-decodeDarcsHash bs = case BC.split '-' bs of-                       [s, h] | BC.length s == 10 -> decodeBase16 h-                       _ -> decodeBase16 bs--decodeDarcsSize :: BC.ByteString -> Maybe Int-decodeDarcsSize bs = case BC.split '-' bs of-                       [s, _] | BC.length s == 10 ->-                                  case reads (BC.unpack s) of-                                    [(x, _)] -> Just x-                                    _ -> Nothing-                       _ -> Nothing--darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment-darcsLocation dir (s,h) = case hash of-                            "" -> error "darcsLocation: invalid hash"-                            _ -> (dir </> prefix s ++ hash, Nothing)-    where prefix Nothing = ""-          prefix (Just s') = formatSize s' ++ "-"-          formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n-          hash = showHash h+import Darcs.Util.Tree.Monad ( TreeIO, runTreeMonad )+import Darcs.Util.ValidHash+    ( PristineHash+    , decodeValidHash+    , encodeValidHash+    , fromHash+    , getHash+    , getSize+    )  ---------------------------------------------- -- Darcs directory format. -- -darcsFormatDir :: Tree m -> Maybe BLC.ByteString-darcsFormatDir t = BLC.fromChunks . concat <$>-                       mapM string (sortBy cmp $ listImmediate t)-    where cmp (a, _) (b, _) = compare a b-          string (name, item) =-              do header <- case item of-                             File _ -> Just $ BC.pack "file:\n"-                             _ -> Just $ BC.pack "directory:\n"-                 hash <- case itemHash item of-                           NoHash -> Nothing-                           x -> Just $ encodeBase16 x-                 return   [ header-                          , encodeWhiteName name-                          , BC.singleton '\n'-                          , hash, BC.singleton '\n' ]+-- Precondition: all (immediate) items in the tree have hashes+darcsFormatDir :: Tree m -> BL.ByteString+darcsFormatDir =+  BL.fromChunks . map formatItem . sortBy cmp . listImmediate+  where+    cmp (a, _) (b, _) = compare a b+    formatItem (name, item) = BC.unlines+      [ case item of+          File _ -> kwFile+          _      -> kwDir+      , encodeWhiteName name+      , case itemHash item of+          Nothing -> error "precondition of darcsFormatDir"+          Just h  -> encodeBase16 h+      ] -darcsParseDir :: BLC.ByteString -> [(ItemType, Name, Maybe Int, Hash)]-darcsParseDir content = parse (BLC.split '\n' content)-    where-      parse (t:n:h':r) = (header t,-                          decodeWhiteName $ B.concat $ BL.toChunks n,-                          decodeDarcsSize hash,-                          decodeDarcsHash hash) : parse r-          where hash = BC.concat $ BLC.toChunks h'-      parse _ = []-      header x-          | x == BLC.pack "file:" = BlobType-          | x == BLC.pack "directory:" = TreeType-          | otherwise = error $ "Error parsing darcs hashed dir: " ++ BLC.unpack x+darcsParseDir+  :: FilePath -> BC.ByteString -> Either String [(ItemType, Name, PristineHash)]+darcsParseDir path = withPath path . parseAll (many pDir)+  where+    pDir = do+      t <- pHeader+      char '\n'+      n <- pName+      char '\n'+      h <- pHash+      char '\n'+      return (t, n, h)+    pHeader = (BlobType <$ string kwFile) <|> (TreeType <$ string kwDir)+    pName   = do+      name <- takeTillChar '\n'+      either fail return (decodeWhiteName name)+    pHash = do+      hash <- takeTillChar '\n'+      maybe (fail "expected valid hash") return (decodeValidHash (BC.unpack hash)) +kwFile, kwDir :: BC.ByteString+kwFile = BC.pack "file:"+kwDir = BC.pack "directory:"+ ---------------------------------------- -- Utilities. --  -- | Compute a darcs-compatible hash value for a tree-like structure. darcsTreeHash :: Tree m -> Hash-darcsTreeHash t = case darcsFormatDir t of-                    Nothing -> NoHash-                    Just x -> sha256 x---- The following two are mostly for experimental use in Packed.+darcsTreeHash = sha256 . darcsFormatDir  darcsUpdateDirHashes :: Tree m -> Tree m darcsUpdateDirHashes = updateSubtrees update-    where update t = t { treeHash = darcsTreeHash t }+    where update t = t { treeHash = Just (darcsTreeHash t) } -darcsUpdateHashes :: (Monad m) => Tree m -> m (Tree m)+darcsUpdateHashes :: Monad m => Tree m -> m (Tree m) darcsUpdateHashes = updateTree update-    where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t }+    where update (SubTree t) =+              -- why not recursively ensure that hashes exist here?+              return . SubTree $ t { treeHash = Just (darcsTreeHash t) }           update (File blob@(Blob con _)) =               do hash <- sha256 <$> readBlob blob-                 return $ File (Blob con hash)+                 return $ File (Blob con (Just hash))           update stub = return stub -darcsHash :: (Monad m) => TreeItem m -> m Hash-darcsHash (SubTree t) = return $ darcsTreeHash t+darcsHash :: Monad m => TreeItem m -> m Hash+darcsHash (SubTree t) = return (darcsTreeHash t) darcsHash (File blob) = sha256 <$> readBlob blob-darcsHash _ = return NoHash+darcsHash (Stub unstub _) = darcsTreeHash <$> unstub  darcsAddMissingHashes :: (Monad m) => Tree m -> m (Tree m) darcsAddMissingHashes = addMissingHashes darcsHash@@ -161,103 +151,115 @@ -- Reading darcs pristine data -- --- | Read and parse a darcs-style hashed directory listing from a given @dir@+-- | Read and parse a darcs-style hashed directory listing from a given @cache@ -- and with a given @hash@.-readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]-readDarcsHashedDir dir h = do-  debugMessage $ "readDarcsHashedDir: " ++ dir ++ " " ++ showHash (snd h)-  exist <- doesFileExist $ fst (darcsLocation dir h)-  unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h)-  compressed <- readSegment $ darcsLocation dir h-  let content = decompress compressed-  return $ if BLC.null compressed-              then []-              else darcsParseDir content+readDarcsHashedDir :: Cache+                   -> PristineHash+                   -> IO [(ItemType, Name, PristineHash)]+readDarcsHashedDir cache ph = do+  debugMessage $ "readDarcsHashedDir: " ++ encodeValidHash ph+  (file, content) <- fsReadHashedFile cache ph+  either fail return $ darcsParseDir file content --- | Read in a darcs-style hashed tree. This is mainly useful for reading--- \"pristine.hashed\". You need to provide the root hash you are interested in--- (found in _darcs/hashed_inventory).-readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO)-readDarcsHashed' _ _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash"-readDarcsHashed' sizefail dir root@(_, hash) = do-  items' <- readDarcsHashedDir dir root+-- | Read a darcs-style hashed tree.+readDarcsHashed' :: Bool -> Cache -> PristineHash -> IO (Tree IO)+readDarcsHashed' sizefail cache root = do+  items' <- readDarcsHashedDir cache root   subs <- sequence [-           do when (sizefail && isJust s) $-                fail ("Unexpectedly encountered size-prefixed hash in " ++ dir)+           do let h = getHash ph+              case getSize ph of+                Just _ | sizefail ->+                  fail ("Unexpectedly encountered size-prefixed hash in " ++ encodeValidHash root)+                _ -> return ()               case tp of                 BlobType -> return (d, File $-                                       Blob (readBlob' (s, h)) h)+                                       Blob (readBlob' ph) (Just h))                 TreeType ->-                  do let t = readDarcsHashed dir (s, h)-                     return (d, Stub t h)-           | (tp, d, s, h) <- items' ]-  return $ makeTreeWithHash subs hash-    where readBlob' = fmap decompress . readSegment . darcsLocation dir+                  do let t = readDarcsHashed cache ph+                     return (d, Stub t (Just h))+           | (tp, d, ph) <- items' ]+  return $ makeTreeWithHash subs (getHash root)+    where readBlob' = fmap (BL.fromStrict . snd) . fsReadHashedFile cache -readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO)+readDarcsHashed :: Cache -> PristineHash -> IO (Tree IO) readDarcsHashed = readDarcsHashed' False -readDarcsHashedNosize :: FilePath -> Hash -> IO (Tree IO)-readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash)+readDarcsHashedNosize :: Cache -> PristineHash -> IO (Tree IO)+readDarcsHashedNosize = readDarcsHashed' True  ---------------------------------------------------- -- Writing darcs-style hashed trees. --  -- | Write a Tree into a darcs-style hashed directory.-writeDarcsHashed :: Tree IO -> FilePath -> IO Hash-writeDarcsHashed tree' dir =-    do debugMessage $ "writeDarcsHashed " ++ dir-       t <- darcsUpdateDirHashes <$> expand tree'-       sequence_ [ dump =<< readBlob b | (_, File b) <- list t ]-       let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ]-       _ <- mapM (dump . fromJust) dirs-       return $ darcsTreeHash t-    where dump bits =-              do let name = dir </> BC.unpack (encodeBase16 $ sha256 bits)-                 exist <- doesFileExist name-                 unless exist $ BL.writeFile name (compress bits)+writeDarcsHashed :: Tree IO -> Cache -> IO PristineHash+writeDarcsHashed tree' cache = do+  debugMessage "writeDarcsHashed"+  t <- darcsUpdateDirHashes <$> expand tree'+  let items = list t+  withSizedProgress "Getting pristine" (length items) $ \k -> do+    sequence_ [readAndWriteBlob k b | (_, File b) <- items]+    let dirs = darcsFormatDir t : [darcsFormatDir d | (_, SubTree d) <- items]+    mapM_ (dump k) dirs+  return (fromHash (darcsTreeHash t))+  where+    readAndWriteBlob k b = readBlob b >>= dump k+    dump k x = fsCreateHashedFile cache x >>= finishedOneIO k . encodeValidHash --- | Create a hashed file from a 'FilePath' and content. In case the file exists--- it is kept untouched and is assumed to have the right content. XXX Corrupt--- files should be probably renamed out of the way automatically or something--- (probably when they are being read though).-fsCreateHashedFile :: FilePath -> BLC.ByteString -> TreeIO ()-fsCreateHashedFile fn content =-    liftIO $ do-      debugMessage $ "fsCreateHashedFile " ++ fn-      exist <- doesFileExist fn-      unless exist $ BL.writeFile fn content+-- | Create a hashed file from a 'Cache' and file content. In case the file+-- exists it is kept untouched and is assumed to have the right content.+fsCreateHashedFile :: Cache -> BL.ByteString -> IO PristineHash+fsCreateHashedFile cache content =+  writeFileUsingCache cache (BL.toStrict content) --- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed--- to be fully available from the @directory@, and any changes will be written--- out to same. Please note that actual filesystem files are never removed.+fsReadHashedFile :: Cache -> PristineHash -> IO (FilePath, BC.ByteString)+fsReadHashedFile = fetchFileUsingCache++-- | Run a 'TreeIO' @action@ in a hashed setting. Any changes will be written+-- out to the cache. Please note that actual filesystem files are never removed. hashedTreeIO :: TreeIO a -- ^ action              -> Tree IO -- ^ initial-             -> FilePath -- ^ directory+             -> Cache              -> IO (a, Tree IO)-hashedTreeIO action t dir =-    runTreeMonad action t darcsHash updateItem-    where updateItem _ (File b) = File <$> updateFile b-          updateItem _ (SubTree s) = SubTree <$> updateSub s-          updateItem _ x = return x+hashedTreeIO action tree cache = runTreeMonad action tree (const dumpItem)+  where+    dumpItem (File b) = File <$> dumpFile b+    dumpItem (Stub unstub _) = SubTree <$> (unstub >>= dumpTree)+    dumpItem (SubTree s) = SubTree <$> dumpTree s -          updateFile b@(Blob _ !h) = do-            liftIO $ debugMessage $ "hashedTreeIO.updateFile: " ++ showHash h-            content <- liftIO $ readBlob b-            let fn = dir </> showHash h-                nblob = Blob (decompress <$> rblob) h-                rblob = BL.fromChunks . return <$> B.readFile fn-                newcontent = compress content-            fsCreateHashedFile fn newcontent-            return nblob-          updateSub s = do-            let !hash = treeHash s-                Just dirdata = darcsFormatDir s-                fn = dir </> showHash hash-            liftIO $ debugMessage $ "hashedTreeIO.updateSub: " ++ showHash hash-            fsCreateHashedFile fn (compress dirdata)-            return s+    -- This code is somewhat tricky. The original Tree may have come from+    -- anywhere e.g. a plain Tree. So when we modify the content of a+    -- file, we not only write a new hashed file, but also modify the+    -- Blob itself, so that the embedded read action read this new hashed+    -- file.+    dumpFile :: Blob IO -> IO (Blob IO)+    dumpFile (Blob getBlob mhash) = do+      content <- getBlob+      let hash = fromMaybe (sha256 content) mhash+      debugMessage $ "hashedTreeIO.dumpFile: old hash=" ++ encodeHash hash+      let getBlob' =+            BL.fromStrict . snd <$>+            fsReadHashedFile cache (fromHash hash)+      nhash <- fsCreateHashedFile cache content+      debugMessage $ "hashedTreeIO.dumpFile: new hash=" ++ encodeValidHash nhash+      return $ Blob getBlob' (Just hash) -showHash :: Hash -> String-showHash = BC.unpack . encodeBase16+    dumpTree :: Tree IO -> IO (Tree IO)+    dumpTree t = do+      debugMessage $ "hashedTreeIO.dumpTree: old hash=" ++ showHash (treeHash t)+      t' <- darcsAddMissingHashes t+      nhash <- fsCreateHashedFile cache (darcsFormatDir t')+      debugMessage $ "hashedTreeIO.dumpTree: new hash=" ++ encodeValidHash nhash+      return t'++-- | Return all 'PristineHash'es reachable from the given root set, which must+-- consist of directory hashes only.+followPristineHashes :: Cache -> [PristineHash] -> IO [PristineHash]+followPristineHashes cache = followAll+  where+    followAll roots = concat <$> mapM followOne roots+    followOne root = do+      x <- readDarcsHashedDir cache root+      let subs   = [ ph | (TreeType, _, ph) <- x ]+          hashes = root : [ ph | (_, _, ph) <- x ]+      (hashes ++) <$> followAll subs
src/Darcs/Util/Tree/Monad.hs view
@@ -2,13 +2,17 @@ -- --  BSD3 --- | A monadic interface to Tree mutation. The main idea is to--- simulate IO-ish manipulation of real filesystem (that's the state part of--- the monad), and to keep memory usage down by reasonably often dumping the--- intermediate data to disk and forgetting it. The monad interface itself is--- generic, and a number of actual implementations can be used. This module--- provides just 'virtualTreeIO' that never writes any changes, but may trigger--- filesystem reads as appropriate.+{- | A monad transformer for 'Tree' mutation. The main idea is to simulate+IO-ish manipulation of real filesystem (that's the state part of the monad),+and to keep memory usage down by reasonably often dumping the intermediate+data to disk and forgetting it.++The implementation is configured by passing a procedure of type 'DumpItem'+to 'runTreeMonad'.++This module provides the pre-configured 'virtualTreeIO' that never+writes any changes, but may trigger filesystem reads as appropriate. -}+ module Darcs.Util.Tree.Monad     ( -- * 'TreeMonad'       TreeMonad@@ -35,9 +39,7 @@  import Darcs.Prelude hiding ( readFile, writeFile ) -import Control.Exception ( throw )--import Darcs.Util.Path+import Darcs.Util.Path ( AnchoredPath, anchoredRoot, displayPath, movedirfilename ) import Darcs.Util.Tree  import Data.List( sortBy )@@ -45,9 +47,14 @@ import Data.Maybe( isNothing, isJust )  import qualified Data.ByteString.Lazy as BL-import Control.Monad.RWS.Strict+import Control.Monad ( forM_, when, unless )+import Control.Monad.Catch ( MonadThrow(..) )+import Control.Monad.RWS.Strict (RWST, runRWST, ask, gets, lift, modify) import qualified Data.Map as M +import System.IO.Error ( ioeSetErrorString, mkIOError )+import GHC.IO.Exception ( IOErrorType(..) )+ -- | Keep track of the size and age of changes to the tree. type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age @@ -60,23 +67,19 @@   , maxage :: !Int64   } -data TreeEnv m = TreeEnv-  { updateHash :: TreeItem m -> m Hash-  , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)-  }+-- | A procedure for dumping a single 'TreeItem' to disk. If the implementation+-- uses item 'Hash'es, it is also responsible to ensure that its 'Hash' is+-- up-to-date. It is not allowed to make any changes to the actual content of+-- the 'TreeItem'.+type DumpItem m = AnchoredPath -> TreeItem m -> m (TreeItem m)  -- | A monad transformer that adds state of type 'TreeState' and an environment--- of type 'AnchoredPath' (for the current directory).-type TreeMonad m = RWST (TreeEnv m) () (TreeState m) m+-- of type 'DumpItem'.+type TreeMonad m = RWST (DumpItem m) () (TreeState m) m  -- | 'TreeMonad' specialized to 'IO' type TreeIO = TreeMonad IO -initialEnv :: (TreeItem m -> m Hash)-           -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))-           -> TreeEnv m-initialEnv uh u = TreeEnv {updateHash = uh, update = u}- initialState :: Tree m -> TreeState m initialState t =   TreeState {tree = t, changed = M.empty, changesize = 0, maxage = 0}@@ -85,24 +88,19 @@ flush = do changed' <- map fst . M.toList <$> gets changed            dirs' <- gets tree >>= \t -> return [ path | (path, SubTree _) <- list t ]            modify $ \st -> st { changed = M.empty, changesize = 0 }-           forM_ (changed' ++ dirs' ++ [AnchoredPath []]) flushItem+           forM_ (changed' ++ dirs' ++ [anchoredRoot]) flushItem -runTreeMonad' :: Monad m => TreeMonad m a -> TreeEnv m -> TreeState m -> m (a, Tree m)+runTreeMonad' :: Monad m => TreeMonad m a -> DumpItem m -> TreeState m -> m (a, Tree m) runTreeMonad' action initEnv initState = do   (out, final, _) <- runRWST action initEnv initState   return (out, tree final) -runTreeMonad :: Monad m-             => TreeMonad m a-             -> Tree m-             -> (TreeItem m -> m Hash)-             -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))-             -> m (a, Tree m)-runTreeMonad action t uh u = do+runTreeMonad :: Monad m => TreeMonad m a -> Tree m -> DumpItem m -> m (a, Tree m)+runTreeMonad action t dump = do   let action' = do x <- action                    flush                    return x-  runTreeMonad' action' (initialEnv uh u) (initialState t)+  runTreeMonad' action' dump (initialState t)  -- | Run a 'TreeMonad' action without storing any changes. This is useful for -- running monadic tree mutations for obtaining the resulting 'Tree' (as opposed@@ -110,8 +108,7 @@ -- read and write -- reads are passed through to the actual filesystem, but the -- writes are held in memory in the form of a modified 'Tree'. virtualTreeMonad :: Monad m => TreeMonad m a -> Tree m -> m (a, Tree m)-virtualTreeMonad action t =-  runTreeMonad action t (\_ -> return NoHash) (\_ x -> return x)+virtualTreeMonad action t = runTreeMonad action t (const return)  -- | 'virtualTreeMonad' specialized to 'IO' virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)@@ -141,12 +138,7 @@               => AnchoredPath -> AnchoredPath -> TreeMonad m () renameChanged from to = modify $ \st -> st {changed = rename' $ changed st}   where-    rename' = M.fromList . map renameone . M.toList-    renameone (x, d)-      | from `isPrefix` x = (to `catPaths` relative from x, d)-      | otherwise = (x, d)-    relative (AnchoredPath from') (AnchoredPath x) =-      AnchoredPath $ drop (length from') x+    rename' = M.mapKeys (movedirfilename from to)  -- | Replace an item with a new version without modifying the content of the -- tree. This does not do any change tracking. Ought to be only used from a@@ -154,26 +146,19 @@ -- is that an existing in-memory Blob is replaced with a one referring to an -- on-disk file. replaceItem :: Monad m-            => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()+            => AnchoredPath -> TreeItem m -> TreeMonad m () replaceItem path item = do-  modify $ \st -> st { tree = modifyTree (tree st) path item }--flushItem :: forall m. Monad m => AnchoredPath -> TreeMonad m ()-flushItem path =-  do current <- gets tree-     case find current path of-       Nothing -> return () -- vanished, do nothing-       Just x -> do y <- fixHash x-                    new <- asks update >>= ($ y) . ($ path)-                    replaceItem path (Just new)-    where fixHash :: TreeItem m -> TreeMonad m (TreeItem m)-          fixHash f@(File (Blob con NoHash)) = do-            hash <- asks updateHash >>= \x -> lift $ x f-            return $ File $ Blob con hash-          fixHash (SubTree s) | treeHash s == NoHash =-            asks updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s)-          fixHash x = return x+  modify $ \st -> st { tree = modifyTree (tree st) path (Just item) } +-- | Flush a single item to disk. This is the only procedure that (directly)+-- uses the Reader part of the environment (the procedure of type @'DumpItem' m@).+flushItem :: forall m . Monad m => AnchoredPath -> TreeMonad m ()+flushItem path = do+  current <- gets tree+  dumpItem <- ask+  case find current path of+    Nothing -> return () -- vanished, do nothing+    Just item -> lift (dumpItem path item) >>= replaceItem path  -- | If buffers are becoming large, sync, otherwise do nothing. flushSome :: Monad m => TreeMonad m ()@@ -199,47 +184,67 @@        t' <- lift $ expandPath t p        modify $ \st -> st { tree = t' } +findItem :: Monad m => AnchoredPath -> TreeMonad m (Maybe (TreeItem m))+findItem path = do+  expandTo path+  tr <- gets tree+  return $ find tr path+ -- | Check for existence of a file. fileExists :: Monad m => AnchoredPath -> TreeMonad m Bool-fileExists p =-    do expandTo p-       (isJust . (`findFile` p)) <$> gets tree+fileExists p = do+  item <- findItem p+  case item of+    Just (File{}) -> return True+    _ -> return False  -- | Check for existence of a directory. directoryExists :: Monad m => AnchoredPath -> TreeMonad m Bool-directoryExists p =-    do expandTo p-       (isJust . (`findTree` p)) <$> gets tree+directoryExists p = do+  item <- findItem p+  case item of+    Just (SubTree{}) -> return True+    _ -> return False  -- | Check for existence of a node (file or directory, doesn't matter).-exists :: Monad m => AnchoredPath -> TreeMonad m Bool-exists p =-    do expandTo p-       isJust . (`find` p) <$> gets tree+exists :: MonadThrow m => AnchoredPath -> TreeMonad m Bool+exists p = isJust <$> findItem p  -- | Grab content of a file in the current Tree at the given path.-readFile :: Monad m => AnchoredPath -> TreeMonad m BL.ByteString-readFile p =-    do expandTo p-       t <- gets tree-       let f = findFile t p-       case f of-         Nothing -> throw $ userError $ "No such file " ++ displayPath p-         Just x -> lift (readBlob x)+readFile :: MonadThrow m => AnchoredPath -> TreeMonad m BL.ByteString+readFile p = do+  f <- findItem p+  case f of+    Just (File x) -> lift (readBlob x)+    Just _ ->+      throwM $+        flip ioeSetErrorString "is a directory" $+        mkIOError InappropriateType "readFile" Nothing (Just (displayPath p))+    Nothing ->+      throwM $+        mkIOError NoSuchThing "readFile" Nothing (Just (displayPath p))  -- | Change content of a file at a given path. The change will be -- eventually flushed to disk, but might be buffered for some time.-writeFile :: Monad m => AnchoredPath -> BL.ByteString -> TreeMonad m ()-writeFile p con =-    do expandTo p-       modifyItem p (Just blob)-       flushSome-    where blob = File $ Blob (return con) hash-          hash = NoHash -- we would like to say "sha256 con" here, but due-                        -- to strictness of Hash in Blob, this would often-                        -- lead to unnecessary computation which would then-                        -- be discarded anyway; we rely on the sync-                        -- implementation to fix up any NoHash occurrences+writeFile :: MonadThrow m => AnchoredPath -> BL.ByteString -> TreeMonad m ()+writeFile p con = do+  item <- findItem p+  case item of+    Just (SubTree _) ->+      throwM $+      flip ioeSetErrorString "is a directory" $+      mkIOError InappropriateType "writeFile" Nothing (Just (displayPath p))+    _ ->+      -- note that writing to a non-existing file is allowed,+      -- in fact there is no primitive for creating a file+      modifyItem p (Just blob)+  flushSome+  where+    blob = File $ Blob (return con) Nothing+    -- we would like to say "sha256 con" here, but due to strictness of Hash in+    -- Blob, this would often lead to unnecessary computation which would then+    -- be discarded anyway; we rely on the sync implementation to fix up any+    -- Nothing occurrences  -- | Create a directory. createDirectory :: Monad m => AnchoredPath -> TreeMonad m ()@@ -254,30 +259,32 @@        modifyItem p Nothing  -- | Rename the item at a path.-rename :: Monad m => AnchoredPath -> AnchoredPath -> TreeMonad m ()-rename from to =-    do expandTo from-       expandTo to-       tr <- gets tree-       let item = find tr from-           found_to = find tr to-       unless (isNothing found_to) $-              throw $ userError $ "Error renaming: destination " ++ displayPath to ++ " exists."-       if isJust item then do-              modifyItem from Nothing-              modifyItem to item-              renameChanged from to-       else-        throw $ userError $ "Error renaming: source " ++ displayPath from ++ " does not exist."+rename :: MonadThrow m => AnchoredPath -> AnchoredPath -> TreeMonad m ()+rename from to = do+  item <- findItem from+  found_to <- findItem to+  unless (isJust item) $+    throwM $+      mkIOError NoSuchThing "rename" Nothing (Just (displayPath from))+  unless (isNothing found_to) $+    throwM $+      mkIOError AlreadyExists "rename" Nothing (Just (displayPath to))+  modifyItem from Nothing+  modifyItem to item+  renameChanged from to  -- | Copy an item from some path to another path.-copy :: Monad m => AnchoredPath -> AnchoredPath -> TreeMonad m ()-copy from to =-    do expandTo from-       expandTo to-       tr <- gets tree-       let item = find tr from-       unless (isNothing item) $ modifyItem to item+-- Doing this with a SubTree is weird... it means copy recursively,+-- but with lazy copy-on-write semantics. What happens when we flush that?+-- Seems to work, though, as it is used in Darcs.UI.Commands.Convert.Import+copy :: MonadThrow m => AnchoredPath -> AnchoredPath -> TreeMonad m ()+copy from to = do+  expandTo to+  item <- findItem from+  when (isNothing item) $+    throwM $+    mkIOError NoSuchThing "copy" Nothing (Just (displayPath from))+  modifyItem to item  findM' :: forall m a . Monad m        => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a
src/Darcs/Util/Tree/Plain.hs view
@@ -29,16 +29,18 @@ import Data.Maybe( catMaybes ) import qualified Data.ByteString.Lazy as BL import System.FilePath( (</>) )-import System.Directory ( listDirectory, createDirectoryIfMissing )+import System.Directory+    ( createDirectoryIfMissing+    , listDirectory+    , withCurrentDirectory+    ) import System.Posix.Files     ( getSymbolicLinkStatus, isDirectory, isRegularFile, FileStatus )  import Darcs.Prelude  import Darcs.Util.Path-import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.ByteString ( readSegment )-import Darcs.Util.Hash( Hash( NoHash) ) import Darcs.Util.Tree( Tree(), TreeItem(..)                           , Blob(..), makeTree                           , list, readBlob, expand )@@ -57,8 +59,8 @@   let subs = catMaybes [        let name = either error id $ makeName name'         in case status of-             _ | isDirectory status -> Just (name, Stub (readPlainTree (dir </> name')) NoHash)-             _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name') NoHash)+             _ | isDirectory status -> Just (name, Stub (readPlainTree (dir </> name')) Nothing)+             _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name') Nothing)              _ -> Nothing             | (name', status) <- items ]   return $ makeTree subs
src/Darcs/Util/URL.hs view
@@ -50,7 +50,8 @@  module Darcs.Util.URL (     isValidLocalPath, isHttpUrl, isSshUrl, isRelative, isAbsolute,-    isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, sshFilePathOf, splitSshUrl+    isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, sshFilePathOf, splitSshUrl,+    sshCanonRepo   ) where  import Darcs.Prelude@@ -66,6 +67,7 @@     , pathSeparators     ) import System.FilePath ( (</>) )+import System.FilePath.Posix ( joinPath, splitDirectories )  isRelative :: String -> Bool isRelative "" = error "Empty filename in isRelative"@@ -133,3 +135,15 @@  sshFilePathOf :: SshFilePath -> String sshFilePathOf (SshFP uhost dir file) = uhost ++ ":" ++ (dir </> darcsdir </> file)++-- | Return a canonical representation of an SSH repo in the format uhost:path+-- Notably, this means the returned string does not contain:+--   - an "ssh://" prefix+--   - any redundant slashes (including all trailing ones)+sshCanonRepo :: SshFilePath -> String+sshCanonRepo (SshFP uhost repo _) =+  uhost ++ ":" ++ (joinPath $ map canondir $ splitDirectories repo)+  where+    canondir [] = ""+    canondir (x:xs) | x == '/' = "/"+                    | otherwise = (x:xs)
+ src/Darcs/Util/ValidHash.hs view
@@ -0,0 +1,177 @@+module Darcs.Util.ValidHash+    ( ValidHash(..)+    , InventoryHash+    , PatchHash+    , PristineHash+    , HashedDir(..)+    , encodeValidHash+    , decodeValidHash+    , parseValidHash+    , getHash+    , getSize+    , fromHash+    , fromSizeAndHash+    , checkHash+    , okayHash -- only used for garbage collection+    ) where++import qualified Data.ByteString as B+import Data.Maybe ( isJust )+import Text.Read ( readMaybe )++import Prelude ( (^) )+import Darcs.Prelude++import Darcs.Util.Hash ( Hash, decodeBase16, decodeHash, encodeHash, sha256strict )+import qualified Darcs.Util.Parser as P++-- | Semantically, this is the type of hashed objects. Git has a type tag+-- inside the hashed file itself, whereas in Darcs the type is determined+-- by the subdirectory.+data HashedDir+  = HashedPristineDir+  | HashedPatchesDir+  | HashedInventoriesDir+  deriving (Eq)++-- | External API for the various hash types.+class (Eq h, IsSizeHash h) => ValidHash h where+  -- | The 'HashedDir' belonging to this type of hash+  dirofValidHash :: h -> HashedDir+  -- | Compute hash from file content.+  calcValidHash :: B.ByteString -> h+  -- default definitions+  calcValidHash content = fromSizeAndHash (B.length content) (sha256strict content)++newtype InventoryHash = InventoryHash SizeHash+  deriving (Eq, Show, IsSizeHash)++instance ValidHash InventoryHash where+  dirofValidHash _ = HashedInventoriesDir++newtype PatchHash = PatchHash SizeHash+  deriving (Eq, Show, IsSizeHash)++instance ValidHash PatchHash where+  dirofValidHash _ = HashedPatchesDir++newtype PristineHash = PristineHash SizeHash+  deriving (Eq, Show, IsSizeHash)++instance ValidHash PristineHash where+  dirofValidHash _ = HashedPristineDir+  -- note: not the default definition here+  calcValidHash = fromHash . sha256strict++encodeValidHash :: ValidHash h => h -> String+encodeValidHash = encodeSizeHash . getSizeHash++decodeValidHash :: ValidHash h => String -> Maybe h+decodeValidHash = fmap fromSizeHash . decodeSizeHash++parseValidHash :: ValidHash h => P.Parser h+parseValidHash = fromSizeHash <$> parseSizeHash++getHash :: ValidHash h => h -> Hash+getHash sh =+  case getSizeHash sh of+    (NoSize h) -> h+    (WithSize _ h) -> h++getSize :: ValidHash h => h -> Maybe Int+getSize sh =+  case getSizeHash sh of+    (NoSize _) -> Nothing+    (WithSize s _) -> Just s++fromHash :: ValidHash h => Hash -> h+fromHash h = fromSizeHash (NoSize h)++numSizeDigits :: Int+numSizeDigits = 10++sizeLimit :: Int+sizeLimit = 10 ^ numSizeDigits++fromSizeAndHash :: ValidHash h => Int -> Hash -> h+fromSizeAndHash size hash =+  fromSizeHash $ if size < sizeLimit then WithSize size hash else NoSize hash++-- | Check that the given 'String' is an encoding of some 'ValidHash'.+okayHash :: String -> Bool+okayHash = isJust . decodeSizeHash++-- | Verify file content against a given 'ValidHash'.+checkHash :: ValidHash h => h -> B.ByteString -> Bool+checkHash vh content =+  -- It is tempting to simplify this to+  --   vh == calcValidHash content+  -- However, since we need to check old-style (sized) pristine hashes,+  -- this would require a non-standard Eq instance for SizeHash.+  case getSizeHash vh of+    NoSize h -> h == hash+    WithSize s h -> s == size && h == hash+  where+    hash = sha256strict content+    size = B.length content++-- * Internal definitions, not exported++-- | Combined size and hash, where the size is optional.+-- The invariant for a valid @'WithSize' size _@ is that+--+-- > size >=0 and size < 'sizeLimit'+data SizeHash+  = WithSize !Int !Hash+  | NoSize !Hash+  deriving (Eq, Show)++-- | Methods to wrap and unwrap 'ValidHash'es+class IsSizeHash h where+  getSizeHash :: h -> SizeHash+  fromSizeHash :: SizeHash -> h++-- This instance is only there so we can derive the instances above+instance IsSizeHash SizeHash where+  getSizeHash = id+  fromSizeHash = id++{-+-- This non-standard Eq instance would allow us to implement 'checkHash'+-- using equality with a freshly calculated hash.+instance Eq SizeHash where+  NoSize h1 == NoSize h2 = h1 == h2+  WithSize s1 h1 == WithSize s2 h2 = s1 == s2 && h1 == h2+  NoSize h1 == WithSize _ h2 = h1 == h2+  WithSize _ h1 == NoSize h2 = h1 == h2+-}++encodeSizeHash :: SizeHash -> String+encodeSizeHash (NoSize hash) = encodeHash hash+encodeSizeHash (WithSize size hash) =+    padZero (show size) ++ '-' : encodeHash hash+  where padZero s = replicate (numSizeDigits - length s) '0' ++ s++decodeSizeHash :: String -> Maybe SizeHash+decodeSizeHash s =+  case splitAt numSizeDigits s of+    (sizeStr, '-':hashStr)+      | Just size <- decodeSize sizeStr -> WithSize size <$> decodeHash hashStr+    _ -> NoSize <$> decodeHash s+  where+    decodeSize :: String -> Maybe Int+    decodeSize ss =+      case readMaybe ss of+        Just size | size >= 0 && size < sizeLimit -> Just size+        _ -> Nothing++parseSizeHash :: P.Parser SizeHash+parseSizeHash =+    (WithSize <$> pSize <*> pNoSize) P.<|> (NoSize <$> pNoSize)+  where+    pSize = do+      P.lookAhead (P.take numSizeDigits >> P.char '-')+      P.unsigned <* P.char '-'+    pNoSize = do+      x <- P.take 64+      maybe (fail "expecting b16-encoded sha256 hash") return (decodeBase16 x)
src/Darcs/Util/Workaround.hs view
@@ -27,7 +27,7 @@  #ifdef WIN32 -import qualified System.Directory ( getCurrentDirectory )+import qualified System.Directory ( getCurrentDirectory, canonicalizePath )  #else @@ -96,7 +96,7 @@ -- getCurrentDirectory and translates '\\' to '/' getCurrentDirectory :: IO FilePath getCurrentDirectory = do-    d <- System.Directory.getCurrentDirectory+    d <- System.Directory.getCurrentDirectory >>= System.Directory.canonicalizePath     return $ map rb d   where     rb '\\' = '/'
− src/hscurl.c 
@@ -1,360 +0,0 @@-#include "hscurl.h"--#include <curl/curl.h>-#include <errno.h>-#include <stdio.h>-#include <stdlib.h>-#include <string.h>--#include "cabal_macros.h"--#if LIBCURL_VERSION_NUM >= 0x071301-/* enable pipelining for libcurl >= 7.19.1 */-#define ENABLE_PIPELINING-#endif--enum RESULT_CODES-  {-    RESULT_OK = 0,-    RESULT_MALLOC_FAIL,-    RESULT_SELECT_FAIL,-    RESULT_MULTI_INIT_FAIL,-    RESULT_EASY_INIT_FAIL,-    RESULT_SLIST_APPEND_FAIL,-    RESULT_MULTI_INFO_READ_FAIL,-    RESULT_UNKNOWN_MESSAGE,-    RESULT_FILE_OPEN_FAIL-  };--static const char *error_strings[] =-  {-    "",-    "malloc() failed",-    "select() failed",-    "curl_multi_init() failed",-    "curl_easy_init() failed",-    "curl_slist_append() failed",-    "curl_multi_info_read() failed",-    "curl_multi_info_read() returned unknown message",-    "fopen() failed"-  };--struct UrlData-{-  char *url;-  FILE *file;-  struct curl_slist *headers;-};--static int debug = 0;-static const char user_agent[] =-  "darcs/" CURRENT_PACKAGE_VERSION " libcurl/" LIBCURL_VERSION;--static const char *proxypass;-static int init_done = 0;-static CURLM *multi = NULL;-static int msgs_in_queue = 0;-static char *last_url = NULL;--static const char *perform()-{-  int error;-  int running_handles, running_handles_last;-  fd_set fd_read, fd_write, fd_except;-  int max_fd;-  long timeout;-  struct timeval tval;--  error = curl_multi_perform(multi, &running_handles);-  if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-    return curl_multi_strerror(error);--  running_handles_last = running_handles;-  while (running_handles_last > 0)-    {-      while (error == CURLM_CALL_MULTI_PERFORM)-        error = curl_multi_perform(multi, &running_handles);--      if (error != CURLM_OK)-        return curl_multi_strerror(error);--      if (running_handles < running_handles_last)-        break;--      FD_ZERO(&fd_read);-      FD_ZERO(&fd_write);-      FD_ZERO(&fd_except);--      error = curl_multi_fdset(multi, &fd_read, &fd_write, &fd_except, &max_fd);-      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-        return curl_multi_strerror(error);--#ifdef CURL_MULTI_TIMEOUT-      error = curl_multi_timeout(multi, &timeout);-      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-        return curl_multi_strerror(error);--      if (timeout == -1)-#endif-        timeout = 100;--      tval.tv_sec = timeout / 1000;-      tval.tv_usec = timeout % 1000 * 1000;--      while (select(max_fd + 1, &fd_read, &fd_write, &fd_except, &tval) < 0)-        if (errno != EINTR)-          {-            if (debug)-              perror(error_strings[RESULT_SELECT_FAIL]);-            return error_strings[RESULT_SELECT_FAIL];-          }--      error = CURLM_CALL_MULTI_PERFORM;-    }--  return NULL;-}--const char *curl_request_url(const char *url,-                             const char *filename,-                             int cache_time,-                             int* errorCode)-{-  int error;-  *errorCode = -1;--  if (init_done == 0)-    {-      error = curl_global_init(CURL_GLOBAL_ALL);-      if (error != CURLE_OK)-        return curl_easy_strerror(error);-      proxypass = getenv("DARCS_PROXYUSERPWD");-      init_done = 1;-    }--  if (multi == NULL)-    {-      multi = curl_multi_init();-      if (multi == NULL)-        return error_strings[RESULT_MULTI_INIT_FAIL];-#ifdef ENABLE_PIPELINING-      error = curl_multi_setopt(multi, CURLMOPT_PIPELINING, 1);-      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-        return curl_multi_strerror(error);-#endif-    }--  CURL *easy = curl_easy_init();-  if (easy == NULL)-    return error_strings[RESULT_EASY_INIT_FAIL];--  if (debug)-    {-      error = curl_easy_setopt(easy, CURLOPT_VERBOSE, 1);-      if (error != CURLE_OK)-        return curl_easy_strerror(error);-    }--  struct UrlData *url_data = malloc(sizeof(struct UrlData));-  if (url_data == NULL)-    return error_strings[RESULT_MALLOC_FAIL];--  url_data->url = strdup(url);-  if (url_data->url == NULL)-    return error_strings[RESULT_MALLOC_FAIL];--  url_data->file = fopen(filename,"wb");-  if (url_data->file == NULL)-    {-      if (debug)-        perror(error_strings[RESULT_FILE_OPEN_FAIL]);-      return error_strings[RESULT_FILE_OPEN_FAIL];-    }--  error = set_time_out(easy, errorCode);-  if (error != CURLE_OK ){-    *errorCode = error;-    return curl_easy_strerror(error);-  }--  error = curl_easy_setopt(easy, CURLOPT_PRIVATE, url_data);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_URL, url_data->url);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--#ifdef CURLOPT_WRITEDATA-  error = curl_easy_setopt(easy, CURLOPT_WRITEDATA, url_data->file);-#else-  error = curl_easy_setopt(easy, CURLOPT_FILE, url_data->file);-#endif-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_USERAGENT, user_agent);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_FOLLOWLOCATION, 1);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_FAILONERROR, 1);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_HTTPAUTH, CURLAUTH_ANY);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  /* libcurl currently always sends Pragma: no-cache, but never-     Cache-Control, which is contradictory.  We override both, just to-     be sure. */-  url_data->headers = curl_slist_append(NULL, "Accept: */*");-  if(cache_time == 0)-    {-      url_data->headers =-        curl_slist_append(url_data->headers, "Pragma: no-cache");-      url_data->headers =-        curl_slist_append(url_data->headers, "Cache-Control: no-cache");-    }-  else if(cache_time > 0)-    {-      /* This won't work well with HTTP/1.0 proxies. */-      char buf[40];-      snprintf(buf, sizeof(buf), "Cache-Control: max-age=%d", cache_time);-      buf[sizeof(buf) - 1] = '\n';-      url_data->headers = curl_slist_append(url_data->headers, "Pragma:");-      url_data->headers = curl_slist_append(url_data->headers, buf);-    }-  else-    {-      url_data->headers = curl_slist_append(url_data->headers, "Pragma:");-      url_data->headers = curl_slist_append(url_data->headers, "Cache-Control:");-    }-  if (url_data->headers == NULL)-    return error_strings[RESULT_SLIST_APPEND_FAIL];--  error = curl_easy_setopt(easy, CURLOPT_HTTPHEADER, url_data->headers);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  if (proxypass && *proxypass)-    {-      error = curl_easy_setopt(easy, CURLOPT_PROXYUSERPWD, proxypass);-      if (error != CURLE_OK)-        return curl_easy_strerror(error);-    }--  error = curl_multi_add_handle(multi, easy);-  if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-    return curl_multi_strerror(error);--  return error_strings[RESULT_OK];-}--const char *curl_wait_next_url(int* errorCode, long* httpErrorCode)-{-  *errorCode = -1;-  *httpErrorCode = -1;--  if (last_url != NULL)-    {-      free(last_url);-      last_url = NULL;-    }--  if (msgs_in_queue == 0)-    {-      const char *error = perform();-      if (error != NULL)-        return error;-    }--  CURLMsg *msg = curl_multi_info_read(multi, &msgs_in_queue);-  if (msg == NULL)-    return error_strings[RESULT_MULTI_INFO_READ_FAIL];--  if (msg->msg == CURLMSG_DONE)-    {-      CURL *easy = msg->easy_handle;-      CURLcode result = msg->data.result;-      struct UrlData *url_data;--      int error = set_time_out(easy, errorCode);-      if (error != CURLE_OK ){-        *errorCode = error;-        return curl_easy_strerror(error);-      }--      error = curl_easy_getinfo(easy, CURLINFO_PRIVATE, (char **)&url_data);-      if (error != CURLE_OK){-        *errorCode = error;-        return curl_easy_strerror(error);-      }--      last_url = url_data->url;-      fclose(url_data->file);-      curl_slist_free_all(url_data->headers);-      free(url_data);--      error = curl_multi_remove_handle(multi, easy);-      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-        return curl_multi_strerror(error);-      curl_easy_cleanup(easy);--      if (result != CURLE_OK){-        *errorCode = result;--        if (result == CURLE_HTTP_RETURNED_ERROR)-		  curl_easy_getinfo(easy, CURLINFO_RESPONSE_CODE, httpErrorCode);--        return curl_easy_strerror(result);-      }-    }-  else-    return error_strings[RESULT_UNKNOWN_MESSAGE];--  return error_strings[RESULT_OK];-}--const char *curl_last_url()-{-  return last_url != NULL ? last_url : "";-}--void curl_enable_debug()-{-  debug = 1;-}--int curl_pipelining_enabled()-{-#ifdef ENABLE_PIPELINING-  return 1;-#else-  return 0;-#endif-}--int set_time_out(CURL *handle, int* errorCode)-{-  int error;-  long time_out = DEFAULT_CONNECTION_TIMEOUT;-  const char *stime_out;--  stime_out = getenv("DARCS_CONNECTION_TIMEOUT");-  if (stime_out != NULL){-    long result = atol (stime_out);-    if ( result > 0 )-      time_out = result;-    else-      *errorCode = 90 ;-  }--  error = curl_easy_setopt(handle, CURLOPT_CONNECTTIMEOUT, time_out);--  return error;-}
− src/hscurl.h 
@@ -1,16 +0,0 @@-#define DEFAULT_CONNECTION_TIMEOUT 30--const char *curl_request_url(const char *url,-                             const char *filename,-                             int cache_time,-                             int *errorCode);--const char *curl_wait_next_url(int *errorCode, long* httpErrorCode);--const char *curl_last_url();--void curl_enable_debug();--int curl_pipelining_enabled();--int set_time_out();
src/win32/System/Posix/Files.hs view
@@ -1,15 +1,15 @@ module System.Posix.Files     ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink     , getFdStatus, getFileStatus, getSymbolicLinkStatus-    , modificationTime, setFileMode, fileSize, fileMode, fileOwner+    , modificationTimeHiRes, setFileMode, fileSize, fileMode, fileOwner     , stdFileMode, FileStatus, fileID-    , linkCount, createLink+    , linkCount, createLink, ownerModes     ) where  import System.PosixCompat.Files     ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink     , getFdStatus, getFileStatus, getSymbolicLinkStatus-    , modificationTime, setFileMode, fileSize, fileMode, fileOwner+    , modificationTimeHiRes, setFileMode, fileSize, fileMode, fileOwner     , stdFileMode, FileStatus, fileID-    , linkCount, createLink+    , linkCount, createLink, ownerModes     )
src/win32/System/Posix/IO.hsc view
@@ -11,11 +11,8 @@  import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ ) -import GHC.IO.Handle.FD ( fdToHandle )--import System.Posix.Internals ( c_open, c_close, c_dup2 )+import System.Posix.Internals ( c_open, c_close ) import System.Posix.Types ( Fd(..), FileMode )-import System.IO ( Handle )  import Data.Bits ( (.|.) ) @@ -32,15 +29,16 @@   exclusive :: Bool,   noctty :: Bool,   nonBlock :: Bool,-  trunc :: Bool+  trunc :: Bool,+  creat :: Maybe FileMode  }   -- Adapted from System.Posix.IO in ghc #include <fcntl.h> -openFd :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd-openFd name how maybe_mode off = do+openFd :: FilePath -> OpenMode -> OpenFileFlags -> IO Fd+openFd name how off = do #if mingw32_HOST_OS   withCWString name $ \s -> do #else@@ -49,13 +47,13 @@    fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w)    return (Fd fd)  where-   all_flags = binary .|. creat .|. flags .|. open_mode+   all_flags = binary .|. creat_ .|. flags .|. open_mode    flags =     (if append off    then (#const O_APPEND)   else 0) .|.     (if exclusive off then (#const O_EXCL)     else 0) .|.     (if trunc off     then (#const O_TRUNC)    else 0)    binary = (#const O_BINARY)-   (creat, mode_w) = maybe (0,0) (\x->((#const O_CREAT),x)) maybe_mode+   (creat_, mode_w) = maybe (0,0) (\x->((#const O_CREAT),x)) (creat off)    open_mode = case how of                 ReadOnly  -> (#const O_RDONLY)                 WriteOnly -> (#const O_WRONLY)@@ -64,18 +62,9 @@ closeFd :: Fd -> IO () closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd) --fdToHandle :: Fd -> IO Handle-fdToHandle fd = GHC.IO.Handle.FD.fdToHandle (fromIntegral fd)--dupTo :: Fd -> Fd -> IO Fd-dupTo (Fd fd1) (Fd fd2) = do-  r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2)-  return (Fd r)- data OpenMode = ReadOnly | WriteOnly | ReadWrite  defaultFileFlags :: OpenFileFlags-defaultFileFlags = OpenFileFlags False False False False False+defaultFileFlags = OpenFileFlags False False False False False Nothing
tests/EXAMPLE.sh view
@@ -24,19 +24,26 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.-darcs init      --repo S+# every test script MUST source lib+. lib +# every test script should remove directories before creating them+rm -rf R S+darcs init R+darcs init S+ cd R-mkdir d e                       # Change the working tree.+# change the working tree+mkdir d e echo 'Example content.' > d/f-darcs record -lam 'Add d/f and e.'+darcs record -lam 'Add d/f and e.' --debug 2>../RLOG darcs mv d/f e/ darcs record -am 'Move d/f to e/f.'-darcs push ../S -a	        # Try to push patches between repos.+# push patches from R to S+darcs push ../S -a cd ..  cd S+# push patches back from S to R darcs push ../R -a cd ..
tests/add.sh view
@@ -75,13 +75,13 @@ touch a.d/aa.d/aaa.d/baz touch a.d/aa.d/aaa.d/bar darcs add -v a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log-test ! -s log # no output+not grep -F ".d" log -# Make sure that darcs doesn\'t complains about duplicate adds when adding parent dirs.+# Make sure that darcs doesn't complain about duplicate adds when adding parent dirs. mkdir c.d touch c.d/baz darcs add -v c.d/baz c.d 2> log-test ! -s log # no output+not grep -F ".d" log  # Make sure that add output looks good when adding files in subdir mkdir d.d@@ -99,27 +99,21 @@ darcs init temp1 cd temp1 -empty='test ! -s'-nonempty='test -s'- rm -f foo-darcs add foo >stdout 2>stderr && exit 1 || true-$empty stdout-$nonempty stderr+not darcs add foo >stdout 2>stderr+not grep foo stdout+grep foo stderr # error message about foo not existing ->foo+touch foo darcs add foo >stdout 2>stderr-$nonempty stdout  # confirmation message of added file-$empty stderr+grep foo stdout  # confirmation message of added file+not grep foo stderr -darcs add foo >stdout 2>stderr && exit 1 || true-$empty stdout-$nonempty stderr+not darcs add foo 2>stderr+grep 'not added' stderr # error message about some files not being added  rm foo-darcs add foo >stdout 2>stderr && exit 1 || true-$empty stdout-$nonempty stderr+not darcs add foo 2>stderr+grep 'not added' stderr # error message about some files not being added  cd ..-rm -rf temp1
tests/add_permissions.sh view
@@ -27,6 +27,9 @@ . lib  abort_windows                   # does not work on Windows.++trap "chmod a+r $PWD/temp1/unreadable $PWD/temp1/d" EXIT+ mkdir temp1 cd temp1 darcs initialize@@ -34,9 +37,7 @@ chmod a-r unreadable      # Make the file unreadable. not darcs add unreadable 2> log fgrep -i 'permission denied' log-# Testing by hand with a directory works, but darcs-test gets-# stuck by having an unreadable subdir.-#mkdir d-#chmod a-r d-#not darcs add --debug --verbose d-#fgrep -i 'permission denied' log+mkdir d+chmod a-r d+not darcs add --debug --verbose d+fgrep -i 'permission denied' log
tests/amend.sh view
@@ -48,7 +48,6 @@ # check that normally the date changes when we amend echo "another line" >> foo darcs changes --last=1 | head -n 1 > old_date-sleep 1 echo y | darcs amend -a foo -A new_author | grep -i 'amending changes' darcs changes --last=1 | head -n 1 > new_date not cmp old_date new_date
tests/apply.sh view
@@ -1,6 +1,4 @@ #!/usr/bin/env bash-## Test for issue2017 - apply should gracefully handle tag missing-## from context (complain, not crash) ## ## Copyright (C) 2010 Eric Kow ## Copyright (C) 2012 Owen Stephens
tests/ask_deps.sh view
@@ -8,7 +8,6 @@ darcs init cat > _darcs/prefs/defaults <<. ALL author test-ALL ignore-times ALL ask-deps .
+ tests/bin/sendmail.hs view
@@ -0,0 +1,16 @@+import System.Environment++main = do+  args <- getArgs+  let filename = args !! 5+  input <- getContents+  filecontent <- readFile filename+  writeFile "saved.out" $+    unlines $+    [ "arg["++show i++"] = "++v | (i,v) <- zip [1..] args ]+    +++    [ "input contains:"+    , input+    , filename++" contains:"+    , filecontent+    ]
tests/bin/trackdown-bisect-helper.hs view
@@ -24,9 +24,8 @@  stamp i j = system ("echo " ++ show i ++ " > ./i") >>             system ("echo " ++ show j ++ " > ./j") >>-            -- system ("sleep 1") >>             hFlush stdout >>-            system ("darcs record --ignore-times -am '" ++ show i ++ "'")+            system ("darcs record -am '" ++ show i ++ "'")  generate :: [Int] -> IO () generate = mapM_ (uncurry stamp) . zip [1..]
+ tests/boring-files.sh view
@@ -0,0 +1,35 @@+#!/usr/bin/env bash++#######+## Check that _darcs/ptefs/boring file is ALWAYS used+#+rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch test.txt++echo > _darcs/prefs/boring+darcs wh -l | grep test.txt # Empty boring file - new file is reported.++echo test.txt > _darcs/prefs/boring+darcs wh -l | grep -v test.txt # Pattern in the repository private boring file is used.++touch .boring+darcs setpref boringfile .boring+darcs record -am"setpref boringfile"+darcs wh -l | grep -v test.txt # Pattern in the repository private boring file is used+                               # despite the fact that there is an explicitly defined+                               # boringfile.++echo > _darcs/prefs/boring+echo test.txt > .boring+darcs wh -l | grep -v test.txt # Explicitly defined boringfile is used++echo > _darcs/prefs/boring+echo > .boring+darcs wh -l | grep test.txt # Both explicitly defined boringfile and repository private+                            # boring file are empty and do not mask new file.+++rm -rf temp1
tests/broken_move.sh view
@@ -58,7 +58,7 @@ # test that commutes either work or we can repair echo y | darcs amend -a -p 'move d1 to d2' -m 'edited move d1 to d2' if ! (echo y | darcs amend -a -p 'bad second move' -m 'edited bad second move' 2> LOG); then-  grep -i "Error renaming" LOG+  grep -i "Cannot apply" LOG   # but then we should be able to repair it   not darcs check | grep 'Dropping move patch with non-existing source'   rm -rf ../repaired@@ -67,7 +67,7 @@ fi darcs obliterate -a -p 'move d1 to d2' if ! (darcs obliterate -a -p 'bad second move' 2>LOG); then-  grep -i "Error renaming" LOG+  grep -i "Cannot apply" LOG   # but then we should be able to repair it   not darcs check | grep 'Dropping move patch with non-existing source'   rm -rf ../repaired@@ -77,7 +77,7 @@ # test that unapplying patches either works or we can repair the repo rm -rf ../S if ! (darcs clone . ../S --to-patch 'add d1' 2>LOG); then-  grep -i "Error renaming" LOG+  grep -i "Cannot apply" LOG   # but then we should be able to repair it   not darcs check | grep 'Dropping move patch with non-existing source'   rm -rf ../repaired
+ tests/broken_pending.sh view
@@ -0,0 +1,73 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init++date > date.t+date > date_moved.t++write_buggy_pending () {+cat > _darcs/patches/pending <<EOF+{+addfile ./date.t+addfile ./date.t+addfile ./date_moved.t+move ./date.t ./date_moved.t+}+EOF+}++write_buggy_pending++# darcs log should be unaffected by pending, even with -v+darcs log -v >/dev/null++write_buggy_pending++# darcs check should detect a broken pending+not darcs check 2>&1 | tee out+grep -i 'broken pending' out++write_buggy_pending++# darcs whatsnew should fail+not darcs whatsnew 2>&1 | tee out+grep -i 'cannot apply pending' out+# and issue a recommendation about repair+grep -i 'darcs repair' out++# darcs revert should fail+not darcs revert -a 2>&1 | tee out+grep -i 'cannot apply pending' out+# and issue a recommendation about repair+grep -i 'darcs repair' out++# darcs revert should fail+not darcs record -a -m foo 2>&1 | tee out+grep -i 'cannot apply pending' out+# and issue a recommendation about repair+grep -i 'darcs repair' out++write_buggy_pending++# we should be able to successfully repair pending+darcs repair -v 2>&1 | tee out+grep -i 'repaired pending' out++darcs whatsnew+darcs check++write_buggy_pending++# final repair, quiet+darcs repair -q 2>&1 | not grep .++darcs check+darcs record -a -m foo+darcs check++cd ..
+ tests/clean-command.sh view
@@ -0,0 +1,66 @@+#!/usr/bin/env bash+# Tests for the clean / revert -l command++. lib++rm -rf R+darcs init R+cd R++create_stuff () {+  rm -rf unadded unadded-dir unadded-dir-with-boring boring.o CVS++  # non-boring stuff+  echo content > unadded+  mkdir unadded-dir+  echo content > unadded-dir/unadded+  mkdir unadded-dir-with-boring+  echo content > unadded-dir-with-boring/unadded++  # boring stuff+  echo content > boring.o+  mkdir CVS+  echo content > CVS/also-considered-boring+  echo content > CVS/boring.o+  echo content > unadded-dir-with-boring/boring.o+}++test_nonboring () {+  # test that non-boring stuff is gone+  not ls unadded+  not ls unadded-dir+  not ls unadded-dir-with-boring/unadded+  # non-boring file under boring dir is still considered non-boring+  not ls CVS/unadded++  # test that boring stuff is unchanged+  diff unadded-dir-with-boring/boring.o <(echo content)+  diff boring.o <(echo content)+  diff CVS/boring.o <(echo content)+}++test_boring () {+  not ls unadded+  not ls unadded-dir+  not ls unadded-dir-with-boring+  not ls boring.o+  not ls CVS+}++create_stuff+darcs clean -a+test_nonboring++create_stuff+darcs revert -l -a+test_nonboring++create_stuff+darcs clean --boring -a+test_boring++create_stuff+# error: conflicting options+not darcs revert -l --boring -a++cd ..
tests/clone.sh view
@@ -16,6 +16,24 @@ darcs log --context --repo temp2 > repo2_context diff -u "${abs_to_context}" repo2_context +# trailing slash in the target dir should not change the result+rm -rf temp2+darcs clone temp1 --context="${abs_to_context}" temp2/+darcs log --context --repo temp2 > repo2_context+diff -u "${abs_to_context}" repo2_context++# clone should fail if the target dir already exists+rm -rf temp2+mkdir temp2+not darcs clone temp1 temp2+not ls temp2/* temp2/.[^.]*++# same, with target dir containing a trailing slash+rm -rf temp2+mkdir temp2+not darcs clone temp1 temp2/+not ls temp2/* temp2/.[^.]*+ # issue1865: cover interaction of clone --context with tags  rm -rf temp1 temp2@@ -92,7 +110,6 @@ rm -rf temp1 temp2 darcs init temp1 cd temp1-echo ALL ignore-times >> _darcs/prefs/defaults echo A > foo darcs record -lam AA echo B > foo
tests/conflict-chain-resolution.sh view
@@ -37,9 +37,7 @@ rm -rf R2 darcs clone -q C R2 cd R2-sed -i -e 's/[bc]/&2X/' f-darcs record -am 'p2X'-sed -i -e 's/2X/2/' f+sed -i -e 's/[bc]/&2/' f darcs record -am 'p2' cd .. @@ -68,73 +66,100 @@  cd C darcs pull -a ../R*-cd .. +# For darcs-3 patches we do not merge non-conflicting+# alternatives.++cat <<EOF > f.darcs-3+v v v v v v v+a+b+c+d+e+f+=============+a+b+c+d+e5+f5+*************+a+b+c+d4+e4+f+*************+a+b+c3+d3+e+f+*************+a+b2+c2+d+e+f+*************+a1+b1+c+d+e+f+^ ^ ^ ^ ^ ^ ^+EOF+ # The maximal non-conflicting subsets are: #  {p1, p3, p5}, {p1, p4}, {p2, p4} {p2, p5}-# They are what I would expect conflict resolution-# to display as alternatives to the baseline.+# They are what darcs displays as alternatives to the baseline+# for darcs-1 patches. -baseline='+cat <<EOF > f.darcs-1+v v v v v v v a b c d e f-'--p25='+============= a b2 c2 d e5 f5-'--p24='+************* a b2 c2 d4 e4 f-'--p14='+************* a1 b1 c d4 e4 f-'--p135='+************* a1 b1 c3 d3 e5 f5-'--cd C-# now check that:--# * there is exactly one conflict resolution-test $(grep -cF 'v v v v v v v' f) = 1-test $(grep -cF '=============' f) = 1-test $(grep -cF '^ ^ ^ ^ ^ ^ ^' f) = 1--# * each of the alternatives occur at least once-cat f | tr '\n' 'X' > xf-for p in "$baseline" "$p25" "$p24" "$p14" "$p135"; do-  grep $(echo -n "$p" | tr '\n' 'X') xf-done+^ ^ ^ ^ ^ ^ ^+EOF -# * there are 4 alternatives to the baseline-test $(grep -cF '*************' f) = 3+diff f f.$format >&2  cd ..
+ tests/conflict-depends-resolution.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash++# The simplest example of a conflict with dependencies:+# we merge A;B with C, where B depends on A, and C conflicts with A+# and thus also with B. The conflict resolution should not show A+# explicitly as an alternative, but merely show A;B versus C.++. lib++rm -rf base AB C++darcs init base+cd base+touch f+darcs record -lam base+cd ..++darcs clone base AB+cd AB+echo A > f+darcs record -am A+echo B > f+darcs record -am B+cd ..++darcs clone base C+cd C+echo C > f+darcs record -lam C+darcs pull --mark-conflicts -a ../AB+cd ..++cd AB+darcs pull --mark-conflicts -a ../C+cd ..++cat <<EOF > f.expected+v v v v v v v+=============+B+*************+C+^ ^ ^ ^ ^ ^ ^+EOF+diff C/f f.expected >&2+diff AB/f f.expected >&2
tests/convert-darcs2.sh view
@@ -42,7 +42,7 @@     darcs init --darcs-1     darcs apply --allow-conflicts $TESTDATA/convert/darcs1/$name.dpatch     cd ..-    echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 --$opt+    echo 'yes' | darcs convert darcs-2 repo repo2 --$opt     mkdir empty-darcs2     cd empty-darcs2     darcs init --darcs-2@@ -50,8 +50,7 @@     cd repo2     darcs send --no-minimize -a -o ../$name-darcs2.dpatch ../empty-darcs2     cd ..-    diff -I'1 patch for repository ' -I'patches for repository ' -I'Oct 1' \-      -u $TESTDATA/convert/darcs2/$name.dpatch $name-darcs2.dpatch+    compare_bundles $TESTDATA/convert/darcs2/$name.dpatch $name-darcs2.dpatch      cd ../.. }
+ tests/data/empty-old.tgz view

binary file changed (absent → 3487 bytes)

tests/data/tabular.tgz view

binary file changed (62224 → 65337 bytes)

+ tests/decoalesce-add-remove.sh view
@@ -0,0 +1,31 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R++touch f+touch g+darcs add f+darcs add g+rm g++grep "addfile ./g" _darcs/patches/pending++# record only f+darcs record -a -m 'add f'+# check that we did not record anything about g+darcs log -v | tee log >&2+not grep -F ./g log++# check that we still have a pending "addfile g"+# even if on the fly we coalesced it with the rm+# in the working tree to NilFL++grep "addfile ./g" _darcs/patches/pending+touch g+darcs whatsnew | grep "addfile ./g"++cd ..
tests/decoalesce-move.sh view
@@ -1,4 +1,4 @@-#!/bin/sh -e+#!/usr/bin/env bash ## ## Checking what happens when we need to remove an add from pending ## after doing a move.@@ -48,7 +48,7 @@ +bar EOF -diff want got+diff -u want got >&2  cd .. @@ -74,6 +74,108 @@ +foo EOF -diff want got+diff -u want got >&2++cd ..++# Now test what happens if we do /not/ select the coalesced add+move++rm -rf temp3+mkdir temp3+cd temp3+darcs init++echo 'foo' > a+echo 'bar' > b++darcs add a b++mv b c++darcs whatsnew --look-for-moves > got+cat >want <<EOF+addfile ./a+hunk ./a 1++foo+addfile ./c+hunk ./c 1++bar+EOF++echo yyny | darcs rec --look-for-moves -m"added a (but not c via b)"++# make sure we recorded only changes to ./a+darcs log -v | grep -vF ./b | grep -vF ./c++# check pending still has the addfile ./b+grep -F 'addfile ./b' _darcs/patches/pending+# but not the detected move+grep -v move _darcs/patches/pending++# The tests below are disable because --look-for-moves does not detect+# the move in this case. It is currently (2022-07-21) unclear to me why.++if false; then+darcs whatsnew --look-for-moves > got+cat >want <<EOF+addfile ./c+hunk ./c 1++bar+EOF++diff -u want got >&2++darcs whatsnew > got+cat >want <<EOF+addfile ./c+hunk ./c 1++bar+EOF++diff -u want got >&2+fi++cd ..++# The same thing backwards, that is, we first `darcs move`,+# then remove the target w/o telling darcs+# then record only the (forced) hunk and not the+# coalesced move+rmfile.+# The expectation is that pending still contains+# the move, but not the coalesced "rmfile ./a".++rm -rf temp4+mkdir temp4+cd temp4+darcs init++echo 'foo' > a++darcs add a+darcs record -am 'add a with content'++darcs move a b+rm b++# remember the pending patch+cp _darcs/patches/pending pending.before++darcs whatsnew > dwh+# coalescing means dwh should be:+cat >dwh.expected <<EOF+hunk ./a 1+-foo+rmfile ./a+EOF+# check that+diff -u dwh.expected dwh >&2++# record only the hunk+echo yny | darcs rec -m"only the hunk"++# The actual test:+# Since whatsnew always "looks for removes" we can't use it here;+# instead check that _darcs/patches/pending hasn't changed:+diff -u pending.before _darcs/patches/pending >&2  cd ..
+ tests/decoalesce-replace.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R++touch f+darcs record -lam 'add f'++touch g+darcs add g+darcs replace one two f+rm f++echo nyy | darcs record -m 'add g'++# make sure we recorded the addfile ./g but nothing about f:+darcs log --last=1 -v > log+grep -F 'addfile ./g' log+grep -v -F './f' log++# test that pending still contains the replace that was eliminated+# (in memory) by coalescing it with the detected rm+cat >pending.want <<EOF+replace ./f [A-Za-z_0-9] one two+EOF++diff -u pending.want _darcs/patches/pending >&2++cd ..
+ tests/decoalesce-rmdir.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R++mkdir d+mkdir e+touch d/f+touch e/g+darcs add d/f+darcs add e/g+rm -r e++grep "addfile ./e/g" _darcs/patches/pending++# record only d/f+darcs record -a -m 'add d/f'+# check that we did not record anything about g+darcs log -v | tee log >&2+not grep -F ./g log++# check that we still have a pending "addfile g"+# even if on the fly we coalesced it with the rm+# in the working tree to NilFL++grep "addfile ./e/g" _darcs/patches/pending+mkdir e+touch e/g+darcs whatsnew | grep "addfile ./e/g"++cd ..
+ tests/decoalesce-split.sh view
@@ -0,0 +1,64 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R++echo 'version1' > file+darcs record -lam "version1"++# force replace so we have a hunk in pending that we can split+# but no (additional) changes detected in the working tree+darcs replace -f version2 version1 file++echo eyd | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5" >&2++# test that we correctly removed the recorded hunk which we split off from+# the forced hunk in pending:++cat > expected <<EOF+hunk ./file 1+-version1.5++version2+replace ./file [A-Za-z_0-9] version2 version1+EOF++darcs whatsnew | diff -u expected - >&2++cd ..++# same test as above but now *with* additional changes in working++rm -rf R+darcs init R+cd R++echo 'version1' > file+touch file2+darcs record -lam "version1"++# force replace so we have a hunk in pending that we can split+darcs replace -f version2 version1 file+darcs move file2 file3+echo text > file3++echo neyd | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5" >&2++# test that we correctly removed the recorded hunk which we split off from+# the forced hunk in pending:++cat > expected <<EOF+move ./file2 ./file3+hunk ./file 1+-version1.5++version2+replace ./file [A-Za-z_0-9] version2 version1+hunk ./file3 1++text+EOF++darcs whatsnew | diff -u expected - >&2++cd ..
tests/emailformat.sh view
@@ -43,10 +43,6 @@ main = getContents >>= print . not . any (> Data.Char.chr 127) EOF -ghc --make is_ascii.hs -o is_ascii-./is_ascii < ../temp1/mail_as_file | grep '^True$'+runghc is_ascii < ../temp1/mail_as_file | grep True  cd ..-rm -rf temp1-rm -rf temp2-rm -rf temp3
+ tests/empty_inventory.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash++# This tests that a minor change to the format of inventory files introduced+# in darcs-2.17.2 is compatible with previous releases. The situation is when+# a tag is recorded in an empty repository. This now creates and refers to an+# empty inventory, whereas previously it did not.++. lib++# forward compatibility++rm -rf empty-old empty-new+darcs init empty-new+cd empty-new+darcs tag XX+# we have not (semantically) changed the functions that read+# inventories so this suffices for testing forward compatibility+test $(darcs log --count) = "1"+cd ..++# backward compatibility++unpack_testdata empty-old+cd empty-old+# read+test $(darcs log --count) = "1"+# write+darcs tag YY+echo y | darcs obliterate -a+cd ..
− tests/failing-issue1014_identical_patches.sh 
@@ -1,62 +0,0 @@-#!/usr/bin/env bash-. ./lib--# Set up a base repo. Our experiment will start from this point-mkdir base-cd base-darcs init-printf "Line1\nLine2\nLine3\n" > foo-darcs rec -alm Base-cd ..--# Now we want to record patch A, which will turn "Line2" into "Hello"-darcs get base a-cd a-printf "Line1\nHello\nLine3\n" > foo-darcs rec --ignore-times -am A-cd ..--# Make B the same as A-darcs get base b-cd b-printf "Line1\nHello\nLine3\n" > foo-darcs rec --ignore-times -am B-cd ..--# Now we make a patch C that depends on A-darcs get a ac-cd ac-printf "Line1\nWorld\nLine3\n" > foo-darcs rec --ignore-times -am C-cd ..--# Merge A and B-darcs get a ab-cd ab-darcs pull -a ../b-darcs revert -a-cd ..--# And merge in C too-darcs get ab abc-cd abc-darcs pull -a ../ac-darcs revert -a-cd ..--# Now we can pull just B and C into base-darcs get base bc-cd bc-darcs pull ../abc -ap 'B|C'-cd ..--# Now we have base, B and C in a repository.  At this point we're correct.--# Let's try merging AC with BC now, here we discover a bug.--darcs get ac abc2-cd abc2-darcs pull -a ../bc-darcs changes--test `darcs changes | fgrep -c '* C'` -eq 1
− tests/failing-issue1325_pending_minimisation.sh 
@@ -1,55 +0,0 @@-#!/usr/bin/env bash-## Test for issue1325 - hunk patches interfere with pending patch-## minimisation-##-## Copyright (C) 2009 Marco Túlio Gontijo e Silva, Eric Kow-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.-darcs init   --repo=R-darcs init   --repo=S--# this is expected to pass regardless of issue1325-# and is here to provide contrast-cd R-touch file-darcs add file-darcs record -am ' file'-mkdir b-darcs add b-darcs mv  file b-rm -r b-darcs whatsnew | not grep adddir-cd ..--# this is/was the failing part of issue1325-cd S-echo file > file                # we need a hunk to make this interesting-darcs add file-darcs record -am ' file'-mkdir b-darcs add b-darcs mv  file b-rm -r b-darcs whatsnew | not grep adddir-cd ..
− tests/failing-issue1327.sh 
@@ -1,27 +0,0 @@-#!/usr/bin/env bash-. ./lib--# See issue1327.-# results in the error:-# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452---rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-echo fileA version 1 > fileA-echo fileB version 1 > fileB-darcs add fileA fileB-darcs record --author foo@bar --ignore-times --all -m "Add fileA and fileB"-echo fileA version 2 > fileA-darcs record --author foo@bar --ignore-times --all -m "Modify fileA"-cd ..-darcs get temp1 temp2-cd temp2-darcs obliterate -p "Modify fileA" --all-darcs unrecord -p "Add fileA and fileB" --all-darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA"-cd ../temp1-darcs pull --all ../temp2-echo yy | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"
− tests/failing-issue1579_diff_opts.sh 
@@ -1,46 +0,0 @@-#!/usr/bin/env bash-## Test for issue1579 - the diff-opts parameter with multiple parameters -## separated by space are passed like an one parameter to diff.-##-## Copyright (C) 2013 dixiecko-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                           # Load some portability helpers.-abort_windows                   # No diff command available--darcs init      --repo R        # Create our test repos.--cd R-echo 'Example content line 1.' > f-darcs record -lam 'Add f.'-echo 'Example content line 2.' >> f--# Darcs passes the parameters to diff like [ "-wpurNd -U 999" ]-# instead of [ "-wpurNd","-U","999" ]-darcs diff --diff-opts '-wpurNd -U 999' > result--# Darcs doesn't indicate the error in return error code,-# when diff command didn't work the result is empty.--if [ -z "$(cat result)" ]; then -   exit 2-fi
− tests/failing-issue1819-pull-dont-allow-conflicts.sh 
@@ -1,38 +0,0 @@-#!/usr/bin/env bash-## Test for issue1819 - pull --dont-allow-conflicts doesn't work-##-## Dave Love <fx@gnu.org>, Public domain--. lib-rm -rf R S-for repo in R S; do-    darcs init --repo $repo-    cd $repo-    echo 'Example content.' >x-    darcs add x-    darcs record -lam 'Add x'-    echo $repo >x-    darcs record -lam 'Change x'-    cd ..-done--darcs get S S0-cd S0-# the 'echo |' is for the external merge prompt 'hit return to continue' prompt-echo | darcs pull --all --allow-conflicts --external-merge 'cp %2 %o' ../R-cd ..--darcs get S S0b-cd S0b-echo | not darcs pull --all --dont-allow-conflicts ../R-cd ..--darcs get S S1-cd S1-echo | not darcs pull --all --external-merge 'cp %2 %o' --dont-allow-conflicts ../R-cd ..--darcs get S S2-cd S2-echo | not darcs pull --all --dont-allow-conflicts --external-merge 'cp %2 %o' ../R-cd ..
− tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh 
@@ -1,129 +0,0 @@-#!/usr/bin/env bash-## Test that shows failing commute of conflictors/duplicates.-##-## Copyright (C) 2012 Owen Stephens-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--# We want to create this situation:-#-# Context: [adddir "./dir1", addfile "./file1.txt"]-#-# (ParTree-#     (ParTree (DP "./dir1" RmDir)-#              (Move "./file1.txt" "./dir1/file3.txt")-#     (SeqTree (DP "./dir1" RmDir) (Move "./file1.txt" "./file2.txt")))-#-# And then create the merged tree consisting of merging the second "branch" of-# a par tree into the first, depth-first.-#-# Finally, we show that commute is broken for certain combinations of-# conflictors/duplicates, since we can commute out one way, but not the-# other. We do so, by creating both orderings of the final two patches, and-# show that only in one case can we obliterate the penultimate patch alone (due-# to non-commutation).-#-# See issue2047 on the BTS for more information.--. ./lib--rm -rf R1* R2 R3*--darcs init --repo R1-cd R1--mkdir dir1-touch file1.txt--darcs rec -alm 'Init'--darcs get . ../R2-darcs get . ../R3--rmdir dir1-darcs rec -am 'Remove dir1'--cd ../R2-darcs mv file1.txt dir1/file3.txt-darcs rec -am 'Move 1 -> 3'--# Create the first merged ParTree.-cd ../R1-darcs pull -a ../R2--# Revert conflict-markup-darcs rev -a--# Create a copy of R1, so we can show the effect of commuting out the final two-# patches, when we create a different ordered R3...-darcs get . ../R1_OTHER--cd ../R3--# Copy R3, so we can create the other ordering for its patches.-darcs get . ../R3_OTHER--#### In R3 we do rmdir; move file-rmdir dir1-darcs rec -alm 'Rmdir'--cd ../R1-darcs pull -a ../R3-darcs rev -a--cd ../R3-darcs mv file1.txt file2.txt-darcs rec -alm 'Move 1 -> 2'--cd ../R1-darcs pull -a ../R3-darcs rev -a--#### In R3_OTHER we do move file; rmdir-cd ../R3_OTHER-darcs mv file1.txt file2.txt-darcs rec -alm 'Move 1 -> 2'--cd ../R1_OTHER-darcs pull -a ../R3_OTHER-darcs rev -a--cd ../R3_OTHER-rmdir dir1-darcs rec -alm 'Rmdir'--cd ../R1_OTHER-darcs pull -a ../R3_OTHER-darcs rev -a--# Now, to show the bug, we can ob the penultimate patch from R1, but not-# R1_OTHER-cd ../R1-darcs ob -p 'Rmdir' -a--[[ $(darcs changes --count) -eq 4 ]]--cd ../R1_OTHER-echo y | darcs ob -p 'Move 1 -> 2' -a--# There should be 4 changes remaining, but due to the failure to commute, we'll-# actually obliterate 2 patches, leaving 3.-[[ $(darcs changes --count) -eq 4 ]]
tests/failing-issue2383-hunk-edit-fails.sh view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash ## Test for issue2383 hunk-edit/last-regrets being able to put darcs into a ## state that it can't apply the recorded patch ##
tests/failing-record-scaling.sh view
@@ -26,12 +26,15 @@ . lib                  # Load some portability helpers. which strace || exit 200        # This test requires strace(1). +# This test is bogus. Record does indeed access _darcs/inventories,+# namely to store the tentative version of hashed_inventory. This does+# not mean it accesses any other old inventory (it does not).+ rm -rf R                        # Another script may have left a mess. darcs init      --repo R        # Create our test repo. touch R/a-unique-filename-strace -eopen -oR/trace \-  darcs record  --repo R -lam 'A unique commit message.'+strace -eopenat -oR/trace \+  darcs record  --repo R -l a-unique-filename -am 'A unique commit message.' grep a-unique-filename R/trace grep _darcs/hashed_inventory R/trace not grep _darcs/inventories/ R/trace-rm -rf R                        # Clean up after ourselves.
tests/filepath.sh view
@@ -23,10 +23,8 @@ # local vs remote filepaths # ---------------------------------------------------------------------- -# trick: OS-detection (if needed)-if echo $OS | grep -i windows; then-  echo This test does not work on Windows-else+# Windows does not allow ':' in file names+if ! os_is_windows; then   darcs get temp1 temp2   cd temp2   mkdir -p dir@@ -82,7 +80,7 @@ darcs setpref --repodir=temp1 test echo | grep -i "Changing value of test"  # test --linear accepts --repodir.-darcs test --linear --repodir=temp1 | grep -i "Success!"+darcs test --linear --repodir=temp1 | grep -i "Test does not fail on head"  # ---------------------------------------------------------------------- # converting between absolute and relative paths
tests/hashed_inventory.sh view
@@ -28,13 +28,14 @@ }  +rm -rf temp1 temp2 temp3 temp4 temp5  mkdir temp1 cd temp1 darcs init touch foo darcs add foo-darcs rec -m t1 -a -A tester+darcs rec -m t1 -a echo 1 >> foo darcs what -s | grep -v No\ changes darcs what -l | grep -v No\ changes@@ -64,7 +65,7 @@ diff -rc temp2/pristine temp3/pristine  cd temp1-darcs record -a -A tester -m t2+darcs record -a -m t2 darcs push ../temp2 -a darcs push ../temp3 -a makepristine@@ -83,7 +84,7 @@  cd temp1 date > foo-darcs record -a -A tester -m t3+darcs record -a -m t3 makepristine cd ../temp2 darcs pull -a
tests/ignoretimes.sh view
@@ -11,17 +11,16 @@ darcs rec -Ax -alm p1 echo -e 'foo\nbar\nwibble' > f darcs rec -Ax -alm p2-sleep 1 # ensure the timestamps would differ after this change alone echo -e 'baz\nbar\nwibble' > f -# check that wh (without --ignore-times) sees the change now+# check that wh (without --ignore-times) sees the change darcs wh > whatsnew grep 'foo' whatsnew -# the problematic unpull-darcs unpull --last 1 -a --ignore-times+# the (once) problematic unpull+darcs unpull --last 1 -a -# whatsnew will now think there are no changes without --ignore-times+# whatsnew no longer thinks there are no changes without --ignore-times darcs wh > whatsnew grep 'foo' whatsnew
tests/inherit-default.sh view
@@ -20,18 +20,18 @@  not test -e U/_darcs/prefs/defaultrepo not test -e V/_darcs/prefs/defaultrepo-grep '/U$' R1/_darcs/prefs/defaultrepo-grep '/U$' R2/_darcs/prefs/defaultrepo-grep '/U$' R3/_darcs/prefs/defaultrepo-grep '/V$' S/_darcs/prefs/defaultrepo+test U = $(cat R1/_darcs/prefs/defaultrepo | xargs basename)+test U = $(cat R2/_darcs/prefs/defaultrepo | xargs basename)+test U = $(cat R3/_darcs/prefs/defaultrepo | xargs basename)+test V = $(cat S/_darcs/prefs/defaultrepo | xargs basename)  cd R3 for cmd in pull push send; do   # set-default works by setting the defaultrepo of the remote repo   darcs $cmd ../S --set-default-  grep '/V$' _darcs/prefs/defaultrepo+  test V = $(cat _darcs/prefs/defaultrepo | xargs basename)   # but not if remote repo has no defaultrepo   darcs $cmd ../U --set-default-  grep '/U$' _darcs/prefs/defaultrepo+  test U = $(cat _darcs/prefs/defaultrepo | xargs basename) done cd ..
+ tests/issue1014_identical_patches.sh view
@@ -0,0 +1,67 @@+#!/usr/bin/env bash++. ./lib++# test fails for these obsolete formats:+skip-formats darcs-1 darcs-2++rm -rf a ab abc ac b bc acb base++# Set up a base repo. Our experiment will start from this point+mkdir base+cd base+darcs init+printf "Line1\nLine2\nLine3\n" > foo+darcs rec -alm Base+cd ..++# Now we want to record patch A, which will turn "Line2" into "Hello"+darcs get base a+cd a+printf "Line1\nHello\nLine3\n" > foo+darcs rec -am A+cd ..++# Make B the same as A+darcs get base b+cd b+printf "Line1\nHello\nLine3\n" > foo+darcs rec -am B+cd ..++# Now we make a patch C that depends on A+darcs get a ac+cd ac+printf "Line1\nWorld\nLine3\n" > foo+darcs rec -am C+cd ..++# Merge A and B+darcs get a ab+cd ab+darcs pull -a ../b --allow-conflicts+cd ..++# And merge in C too+darcs get ab abc+cd abc+darcs revert -a+darcs pull -a ../ac --allow-conflicts+cd ..++# Now we can pull just B and C into base+darcs get base bc+cd bc+darcs pull ../abc -ap 'B|C' --allow-conflicts+cd ..++# Now we have base, B and C in a repository.  At this point we're correct.++# Let's try merging AC with BC now, here we discover a bug.++darcs get ac acb+cd acb+darcs pull -a ../bc+darcs changes+test `darcs changes | fgrep -c '* C'` -eq 1+cd ..
+ tests/issue1057-pull-from-current-repo-via-symlink.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash+## Test for issue1057 - when pulling from a symlink to the current+## repository, Darcs should detect that it *is* the current repo.+##+## Copyright (C) 2008  Thorkil Naur+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf repo srepo+darcs init repo+ln -s repo srepo+DIR=`pwd`+cd srepo+not darcs pull -a "$DIR/repo" 2>&1 | tee err >&2+grep 'Can.t pull from current repository' err+not darcs pull -a "$DIR/srepo" 2>&1 | tee err >&2+grep 'Can.t pull from current repository' err+cd ..
− tests/issue1057.sh 
@@ -1,48 +0,0 @@-#!/usr/bin/env bash-## Test for issue1057 - when pulling from a symlink to the current-## repository, Darcs should detect that it *is* the current repo.-##-## Copyright (C) 2008  Thorkil Naur-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib--rm -rf temp-mkdir temp-cd temp--mkdir repo-cd repo-darcs init-cd ..--ln -s repo srepo-cd srepo-DIR=`pwd`-echo $DIR-not darcs pull --debug -a "$DIR" 2> out-cat out-grep 'Can.t pull from current repository' out-cd ..--cd ..-rm -rf temp
tests/issue1078_symlink.sh view
@@ -2,20 +2,26 @@  . lib -if echo $OS | grep -i windows; then-    echo this test does not work on windows because-    echo windows does not have symlinks-    exit 0-fi- rm -rf temp1 temp2 mkdir temp1 ln -s temp1 temp2+DIR1="$(pwd)/temp1"+DIR2="$(pwd)/temp2"+ cd temp2 darcs init-touch a b-DIR=`pwd`-darcs add "${DIR}/../temp1/a" # should work, just to contrast with the case below-darcs add "${DIR}/b"          # this is the case we are testing for+touch a b c d e f g h i j+darcs add "$DIR1/../temp1/a"+darcs add "$DIR1/../temp2/b"+darcs add "$DIR1/c"+darcs add "$DIR2/../temp1/d"+darcs add "$DIR2/../temp2/e"+darcs add "$DIR2/f"+darcs add "../temp1/g"+darcs add "../temp2/h"+# This should definitely work:+darcs add "i"+# ... as should this one:+mkdir dir+darcs add dir/../j cd ..-rm -rf temp1 temp2
tests/issue1101.sh view
@@ -1,9 +1,6 @@ #!/usr/bin/env bash-. ./lib -DARCS_EDITOR=echo-export DARCS_EDITOR-export SENDMAIL=`which true`+. ./lib  rm -rf temp1 temp2 mkdir temp1 temp2@@ -19,10 +16,13 @@ darcs record -a -m add_foo_bar -A x  # Test that --cc is also printed as recipient in case of success-darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com+export SENDMAIL=true+darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 >out+grep 'foo@example.com' out  # Test that --cc is also printed as recipient in case of error-darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com+export SENDMAIL=false+not darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>err+grep 'foo@example.com' err  cd ..-rm -rf temp1 temp2
tests/issue1105.sh view
@@ -1,4 +1,5 @@ #!/usr/bin/env bash+#issue1105: defaults file silently rejects abbreviations  . lib @@ -8,6 +9,7 @@ darcs init darcs changes +# note: extra argument for an option is just a warning echo changes summary > _darcs/prefs/defaults darcs changes echo changes summary arg > _darcs/prefs/defaults@@ -19,17 +21,19 @@ darcs changes 2> LOG grep 'takes no argument' LOG +# note: missing required option argument is an error echo changes last 10 > _darcs/prefs/defaults darcs changes echo changes last > _darcs/prefs/defaults-darcs changes 2> LOG+not darcs changes 2> LOG grep 'requires an argument' LOG echo ALL last 10 > _darcs/prefs/defaults darcs changes echo ALL last > _darcs/prefs/defaults-darcs changes 2> LOG+not darcs changes 2> LOG grep 'requires an argument' LOG +# note: unknown option is just a warning echo changes author me > _darcs/prefs/defaults darcs changes 2> LOG grep 'has no option' LOG
+ tests/issue121-amend-ask-deps.sh view
@@ -0,0 +1,72 @@+#!/usr/bin/env bash+## Test for issue121 - amend-record --ask-deps+##+## Copyright (C) 2009 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                  # Load some portability helpers.+rm -rf R+darcs init      --repo R        # Create our test repos.++cd R+touch a+darcs add a+darcs rec -am 'add a'+(echo '1' ; echo '1' ; echo '1') > a+darcs rec -am 'patch X'+(echo '2' ; echo '1' ; echo '1') > a+darcs rec -am 'patch Y'+(echo '2' ; echo '1' ; echo '2') > a+darcs rec -am 'patch Z'++darcs obliterate --dry-run --patch 'patch Y' | not grep 'patch Z'++# add explicit dependency on 'patch Z'+echo 'yyd' | darcs amend --ask-deps++darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'++# remove the explicit dependency; note that it shouldn't ask+# us about the one we dropped+echo 'yyd' | darcs amend --ask-deps++darcs obliterate --dry-run --patch 'patch Y' | not grep 'patch Z'++# add another independent patch+touch b+darcs rec -lam 'patch B'++# add explicit dependency on 'patch B' and 'patch Y'+echo 'yyyd' | darcs amend --patch 'patch Z' --ask-deps++darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'+darcs obliterate --dry-run --patch 'patch B' | grep 'patch Z'++# remove the one on 'patch B', keep that on 'patch Y';+# note that we aren't offered to re-add 'patch B'++echo 'yyd' | darcs amend --patch 'patch Z' --ask-deps++darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'+darcs obliterate --dry-run --patch 'patch B' | not grep 'patch Z'++cd ..
− tests/issue121.sh 
@@ -1,45 +0,0 @@-#!/usr/bin/env bash-## Test for issue121 - amend-record --ask-deps-##-## Copyright (C) 2009 Ganesh Sittampalam-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R-darcs init      --repo R        # Create our test repos.--cd R-touch a-darcs add a-darcs rec --ignore-times -am 'add a'-(echo '1' ; echo '1' ; echo '1') > a-darcs rec --ignore-times -am 'patch X'-(echo '2' ; echo '1' ; echo '1') > a-darcs rec --ignore-times -am 'patch Y'-(echo '2' ; echo '1' ; echo '2') > a-darcs rec --ignore-times -am 'patch Z'--darcs obliterate --dry-run --patch 'patch Y' | not grep 'patch Z'--echo 'yYyY' | tr '[A-Z]' '[a-z]' | darcs amend --ask-deps--darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'
tests/issue1224_convert-darcs2-repository.sh view
@@ -37,7 +37,7 @@ darcs record --name=add_file.txt --author=me --no-test -a --repodir R  # This should fail with repository already in darcs-2 format.-echo "I understand the consequences of my action" > ack+echo "yes" > ack not darcs convert temp/repo-2 temp/repo-2-converted < ack  rm -rf R
+ tests/issue1325_pending_minimisation.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+## Test for issue1325 - hunk patches interfere with pending patch+## minimisation+##+## Copyright (C) 2009 Marco Túlio Gontijo e Silva, Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init   --repo=R+darcs init   --repo=S++# this is expected to pass regardless of issue1325+# and is here to provide contrast+cd R+touch file+darcs add file+darcs record -am ' file'+mkdir b+darcs add b+darcs mv  file b+rm -r b+darcs whatsnew | not grep adddir+cd ..++# this is/was the failing part of issue1325+cd S+echo file > file                # we need a hunk to make this interesting+darcs add file+darcs record -am ' file'+mkdir b+darcs add b+darcs mv  file b+rm -r b+darcs whatsnew | not grep adddir+cd ..
+ tests/issue1327.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash+. ./lib++# test fails for these obsolete formats:+skip-formats darcs-1 darcs-2++# See issue1327.+# results in the error:+# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452+++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo fileA version 1 > fileA+echo fileB version 1 > fileB+darcs add fileA fileB+darcs record --author foo@bar --all -m "Add fileA and fileB"+echo fileA version 2 > fileA+darcs record --author foo@bar --all -m "Modify fileA"+cd ..+darcs get temp1 temp2+cd temp2+darcs obliterate -p "Modify fileA" --all+darcs unrecord -p "Add fileA and fileB" --all+darcs record --author foo@bar --all fileA -m "Add just fileA"+cd ../temp1+darcs pull --all ../temp2+echo yy | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"
tests/issue1344_abort_early_cant_send.sh view
@@ -44,9 +44,6 @@   exit 200 fi -DARCS_EDITOR=echo-export DARCS_EDITOR- mkdir temp1 temp2  cd temp2
tests/issue154_pull_dir_not_empty.sh view
@@ -44,8 +44,9 @@ grep -i "backing up" log grep -i "finished pulling" log # check that moo is not lost (it will be in a backup of d)-find -name moo+find . -name moo # ideally we would preserve the pending 'addfile ./d/moo', # but we currently do not #darcs whatsnew | grep 'addfile ./d/moo'+darcs whatsnew | grep 'adddir ./d' cd ..
+ tests/issue1579_diff_opts.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Test for issue1579 - the diff-opts parameter with multiple parameters +## separated by space are passed like an one parameter to diff.+##+## Copyright (C) 2013 dixiecko+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.++darcs init      --repo R        # Create our test repos.++cd R+echo 'Example content line 1.' > f+darcs record -lam 'Add f.'+echo 'Example content line 2.' >> f++# Darcs passes the parameters to diff like [ "-wpurNd -U 999" ]+# instead of [ "-wpurNd","-U","999" ]+darcs diff --diff-opts '-wpurNd -U 999' > result++# Darcs doesn't indicate the error in return error code,+# when diff command didn't work the result is empty.++if [ -z "$(cat result)" ]; then +   exit 2+fi
@@ -32,6 +32,7 @@ ## SOFTWARE.  . lib                           # Load some portability helpers.+ rm -rf R S                      # Another script may have left a mess. darcs init      --repo R        # Create our test repos. darcs init      --repo S@@ -45,8 +46,6 @@ touch log add_to_boring '^log$' -unset pwd # Since this test is pretty much linux-specific, hspwd.hs is not needed- # Skip the case-folding tests on systems that don't support it touch cs-test ln -s cs-test cs-Test || exit 200@@ -57,16 +56,16 @@ touch non-recorded-file2 ln -s ./non-recorded-file2 ./Non-Recorded-File2 ln -s "`pwd`"/non-recorded-file2 ./Non-ReCoRdEd-File2-darcs w -l >log 2>&1                                             # should report only "non-recorded-file"-darcs rec -alm "added ./non-recorded-file2" >>log 2>&1            # should add only file, not symlink-darcs changes -s --patches="added ./non-recorded-file2" >>log 2>&1  # should report only file, not symlink+darcs w -l >log                                                  # should report only "non-recorded-file"+darcs rec -alm "added ./non-recorded-file2" >>log                 # should add only file, not symlink+darcs changes -s --patches="added ./non-recorded-file2" >>log       # should report only file, not symlink not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file2)" log rm Non-Recorded-File2 ./Non-ReCoRdEd-File2  # Case 16: case-folding link to recorded file ln -s ./recorded-file ./Recorded-File ln -s "`pwd`"/recorded-file ./ReCorded-File-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm Recorded-File ReCorded-File
tests/issue1645-ignore-symlinks.sh view
@@ -32,12 +32,11 @@ ## SOFTWARE.  . lib                           # Load some portability helpers.+ rm -rf R S                      # Another script may have left a mess. darcs init      --repo R        # Create our test repos. darcs init      --repo S -darcs --version- add_to_boring() {   echo "$1" >> _darcs/prefs/boring }@@ -47,16 +46,13 @@ touch log add_to_boring '^log$' -unset pwd # Since this test is pretty much linux-specific, hspwd.hs is not needed-abort_windows # and skip if we are on win32...- # Case 1: looping symlink to non-recorded non-boring dir mkdir non-recorded-dir ln -s ../non-recorded-dir ./non-recorded-dir/loop               # relative symlink ln -s "`pwd`"/non-recorded-dir ./non-recorded-dir/loop2           # absolute symlink-darcs w -l >log 2>&1                                            # should not loop-darcs rec -alm "added ./non-recorded-dir" >>log 2>&1            # should not loop-darcs changes -s --patches="added ./non-recorded-dir" >>log 2>&1  # should report only dir, not symlink+darcs w -l >log                                                 # should not loop+darcs rec -alm "added ./non-recorded-dir" >>log                 # should not loop+darcs changes -s --patches="added ./non-recorded-dir" >>log       # should report only dir, not symlink not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir)" log  # Case 2: looping symlink to recorded dir@@ -65,50 +61,50 @@ darcs rec -am "added recorded-dir" ln -s ../recorded-dir ./recorded-dir/loop      # relative symlink ln -s "`pwd`"/recorded-dir ./recorded-dir/loop2  # absolute symlink-not darcs w -l >log 2>&1                       # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1  # expecting "No changes!" as well+not darcs w -l >log                            # expecting "No changes!"+not darcs rec -alm "should not happen" >>log       # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log  # Case 3: looping symlink to boring dir mkdir boring-dir-add_to_boring '^boring-dir$'+add_to_boring '^boring-dir/$' ln -s ../boring-dir ./boring-dir/loop ln -s "`pwd`"/boting-dir ./boring-dir/loop2-not darcs w -l >log 2>&1                      # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well+not darcs w -l >log                           # expecting "No changes!"+not darcs rec -alm "should not happen" >>log      # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log  # Case 4: non-looping symlink to non-recorded non-boring dir mkdir non-recorded-dir2 ln -s ./non-recorded-dir2 link ln -s "`pwd`"/non-recorded-dir2 ./link2-darcs w -l >log 2>&1                                             # should report only "non-recorded-dir2"-darcs rec -alm "added ./non-recorded-dir2" >>log 2>&1            # should add only dir, not symlink-darcs changes -s --patches="added ./non-recorded-dir2" >>log 2>&1  # should report only dir, not symlink+darcs w -l >log                                                  # should report only "non-recorded-dir2"+darcs rec -alm "added ./non-recorded-dir2" >>log                 # should add only dir, not symlink+darcs changes -s --patches="added ./non-recorded-dir2" >>log       # should report only dir, not symlink not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir2)" log rm link link2  # Case 5: non-looping symlink to recorded dir ln -s ./recorded-dir ./link ln -s "`pwd`"/recorded-dir ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 6: non-looping symlink to boring dir ln -s ./boring-dir ./link ln -s "`pwd`"/boring-dir ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 7: symlink pointing outside the repo ln -s ../S link (cd ..; ln -s "`pwd`"/S ./R/link2)-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2 @@ -116,9 +112,9 @@ touch non-recorded-file ln -s ./non-recorded-file ./link ln -s "`pwd`"/non-recorded-file ./link2-darcs w -l >log 2>&1                                             # should report only "non-recorded-file"-darcs rec -alm "added ./non-recorded-file" >>log 2>&1            # should add only file, not symlink-darcs changes -s --patches="added ./non-recorded-file" >>log 2>&1  # should report only file, not symlink+darcs w -l >log                                                  # should report only "non-recorded-file"+darcs rec -alm "added ./non-recorded-file" >>log                 # should add only file, not symlink+darcs changes -s --patches="added ./non-recorded-file" >>log       # should report only file, not symlink not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file)" log rm link link2 @@ -128,47 +124,49 @@ darcs rec -am "added recorded-file" recorded-file ln -s ./recorded-file ./link ln -s "`pwd`"/recorded-file ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 10: symlink to boring file ln -s ./log ./link ln -s "`pwd`"/log ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 11: dangling symlink ln -s /completely/bogus/path ./link ln -s ../../../../not/exist ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 12: self-referencing link ln -s l l ln -s "`pwd`"/l2 ./l2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm l l2  # Case 13: link to device file outside the repo ln -s /dev/zero l-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm l  # Case 14: link to fifo-mkfifo f-ln -s f l-ln -s "`pwd`"/f ./l2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well-not grep -vE "(^ *$|^\+|No changes!)" log-rm f l l2+if ! os_is_windows; then+  mkfifo f+  ln -s f l+  ln -s "`pwd`"/f ./l2+  not darcs w -l >log                                              # expecting "No changes!"+  not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well+  not grep -vE "(^ *$|^\+|No changes!)" log+  rm f l l2+fi
tests/issue1726_darcs_always-boring.sh view
@@ -37,7 +37,7 @@ function bad_add {     filename="$1"     touch "$filename"-    not darcs whatsnew -ls --boring+    not darcs whatsnew -s --boring     not darcs whatsnew -ls     not darcs add --boring "$filename" }@@ -62,7 +62,7 @@  # Passing --boring should definitely succeed. touch _darcsfoo-darcs whatsnew -ls --boring+darcs whatsnew -s --boring darcs add --boring _darcsfoo darcs record -am 'add _darcsfoo' _darcsfoo
tests/issue1756_moves_index.sh view
@@ -34,7 +34,7 @@ echo 'c' > e/c darcs record -lam '.' darcs mv d/a e/-darcs check --no-ignore-times+darcs check cd .. rm -rf R @@ -45,6 +45,6 @@ echo 'b' > e/b darcs record -lam '.' darcs mv d/a e/-darcs check --no-ignore-times+darcs check cd .. rm -rf R
+ tests/issue1819-pull-dont-allow-conflicts.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+## Test for issue1819 - pull --dont-allow-conflicts doesn't work+##+## Dave Love <fx@gnu.org>, Public domain++. lib+rm -rf R S+for repo in R S; do+    darcs init --repo $repo+    cd $repo+    echo 'Example content.' >x+    darcs add x+    darcs record -lam 'Add x'+    echo $repo >x+    darcs record -lam 'Change x'+    cd ..+done++rm -rf S0+darcs get S S0+cd S0+darcs pull --no-pause-for-gui --all --external-merge 'cp %2 %o' ../R+cd ..++rm -rf S0b+darcs get S S0b+cd S0b+not darcs pull --no-pause-for-gui --all --dont-allow-conflicts ../R+cd ..++# --external-merge is now in the same set of mutually exclusive options+# as the --{[no-]allow,mark}-conflicts, so passing two of them+# should result in an error.++rm -rf S1+darcs get S S1+cd S1+not darcs pull --no-pause-for-gui --all --external-merge 'cp %2 %o' --dont-allow-conflicts ../R 2>log+grep -i 'conflicting options' log+cd ..++rm -rf S2+darcs get S S2+cd S2+not darcs pull --no-pause-for-gui --all --dont-allow-conflicts --external-merge 'cp %2 %o' ../R 2>log+grep -i 'conflicting options' log+cd ..
tests/issue1857-pristine-conversion.sh view
@@ -30,11 +30,15 @@  cd minimal-darcs-2.4 darcs check-darcs setpref test false+# we used to do+#  darcs setpref test false+# here but that will now do the pristine conversion itself+# (during revertRepositoryChanges), so we have to fake it:+echo 'test false' >> _darcs/prefs/prefs echo 'hi' > README not darcs record -a -m argh --test 2> errlog 1> outlog # check that we are really doing the pristine conversion...-grep 'one-time conversion of pristine' errlog+grep -i 'converting pristine' errlog # ...and not fail for some other reason grep "Test failed" outlog darcs check
tests/issue1879-same-patchinfo-uncommon.sh view
@@ -34,5 +34,12 @@ cd ..  cd R-not darcs pull -a ../S 2>&1 | tee log+# The issue calls for darcs to detect this and fail, which it does,+# though not in a regular way but by calling 'error'. Since the 'not'+# function now regards that as test failure we cannot use it here.+# This is only a temporary work-around: Darcs should never call error+# unless it is really a bug in darcs.+if darcs pull -a ../S 2>&1 | tee log; then+  exit 1+fi cd ..
+ tests/issue189-external-merge-move.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash++. lib++rm -rf jhc lhc++# Set up repository to represent JHC's situation -- all sources in the root+mkdir jhc+cd jhc+darcs init+echo content > Foo+darcs rec -alm Base+cd ..++# Now create another one to represent LHC -- sources in src/ dir+darcs get jhc lhc+cd lhc+mkdir src/+darcs add src/+darcs mv Foo src/Foo+darcs rec -am "Move sources into src/"+# ... and change something+echo content1 > src/Foo+darcs rec -am "content1"+cd ..++# change something different in JHC+cd jhc+echo content2 > Foo+darcs rec -am "content2"+cd ..++# our external merge tool checks that the arguments+# exist and have the expected content+cat > external_merge.hs <<EOF+import Control.Monad+import System.Environment+import System.Exit+main = do+  [ca,c1,c2,co] <- getArgs >>= mapM readFile+  when (ca /= "content\n") exitFailure+  when (c1 /= "content1\n") exitFailure+  when (c2 /= "content2\n") exitFailure+  when (co /= "content\n") exitFailure+EOF+ghc --make external_merge.hs+merge_tool=$(pwd)/external_merge++# try to merge them with our external_merge script+cd lhc+darcs pull -a ../jhc --no-pause-for-gui --external-merge="$merge_tool %a %1 %2 %o"+cd ..
− tests/issue1898-set-default-notification.sh 
@@ -1,60 +0,0 @@-#!/usr/bin/env bash-## Test for issue1898 - set-default mechanism-##-## Copyright (C) 2010 Eric Kow-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R0 R1 R2 S               # Another script may have left a mess.-darcs init      --repo R0       # Create our test repos.--darcs get R0 R1-darcs get R0 R2-darcs get R0 S--cd S-# default to no-set-default-darcs push ../R1 > log-grep '/R0$' _darcs/prefs/defaultrepo-# notification when using no-set-default-grep -- "--set-default" log-# ...but not when --inherit-default is active-darcs push ../R1 --inherit-default > log-not grep -- "--set-default" log-# set-default works-darcs push ../R1 --set-default > log-grep '/R1$' _darcs/prefs/defaultrepo-# no notification when already using --set-default-not grep -- "--set-default" log-# no notification when already pushing to the default repo-darcs push > log-not grep -- "--set-default" log-# no notification when it's just the --remote-repo-darcs push --remote-repo ../R1 > log-not grep -- "--set-default" log-# but... notification still works in presence of remote-repo-darcs push --remote-repo ../R1 ../R2 > log-grep -- "--set-default" log-# ...but not when --inherit-default is active-darcs push --remote-repo ../R1 ../R2 --inherit-default > log-not grep -- "--set-default" log-cd ..
tests/issue1909-unrecord-O-misses-tag.sh view
@@ -7,12 +7,12 @@ mkdir R darcs init --repo R echo a > R/a-darcs rec -lam a --repo R --ignore-times+darcs rec -lam a --repo R darcs tag -m T --repo R echo b > R/a-darcs rec -lam b --repo R --ignore-times+darcs rec -lam b --repo R echo c > R/a-darcs rec -lam c --repo R --ignore-times+darcs rec -lam c --repo R  darcs unpull -p c -a --repo R -O --no-minimize cat c.dpatch
tests/issue1956.sh view
@@ -13,26 +13,23 @@ darcs init --darcs-2 echo A > file darcs add file-darcs rec -a -m A --ignore-times+darcs rec -a -m A cd ..  darcs get a b  cd a echo BB > file-darcs rec -a -m B --ignore-times+darcs rec -a -m B cd .. -sleep 1- cd b touch ts echo R > file touch file --reference=ts darcs rec -a -m R-# sleep 1 echo S > file touch file --reference=ts-# darcs rec -a -m S --ignore-times+# darcs rec -a -m S echo y| darcs pull ../a -ap B cd ..
tests/issue1959-unwritable-darcsdir.sh view
@@ -43,23 +43,23 @@ # commands that don't take a lock should not # access the index at all if passed --ignore-times -darcs check-darcs diff --last=1+darcs check --ignore-times+darcs diff --last=1 --ignore-times #would work if we could tell it to create the file elsewhere: #darcs dist-darcs log-darcs init ../S-darcs send ../S -a -o ../patch-darcs show authors-darcs show contents foo-darcs show files-darcs show tags-darcs whatsnew+darcs log --ignore-times+darcs init ../S --ignore-times+darcs send ../S -a -o ../patch --ignore-times+darcs show authors --ignore-times+darcs show contents foo --ignore-times+darcs show files --ignore-times+darcs show tags --ignore-times+darcs whatsnew --ignore-times  # ...and output a warning message otherwise -#doesn't work yet, it accesses the index directly via readIndex:-#darcs check --no-ignore-times | grep "Warning, cannot access the index"+darcs check --no-ignore-times 2>../log+grep "Warning, cannot access the index" ../log darcs diff --last=1 --no-ignore-times 2>../log grep "Warning, cannot access the index" ../log darcs whatsnew --no-ignore-times 2>../log@@ -75,6 +75,8 @@   grep "Cannot write index" record   not darcs obliterate 2>record   grep "Cannot write index" record+  not darcs unrecord 2>unrecord+  grep "Cannot write index" unrecord   not darcs move foo bar 2>move   grep "Cannot write index" move   echo bla > foo@@ -84,6 +86,8 @@   grep "Cannot write index" remove   not darcs replace x y foo 2>remove   grep "Cannot write index" remove+  not darcs repair 2>repair+  grep "Cannot write index" repair }  # ...if the index iself isn't writable (but _darcs is)@@ -93,14 +97,5 @@  # made it writable again chmod -R +w .--# ...and similarly with _darcs/index_invalid-# the touch+add+remove is so that _darcs/index_invalid exists-touch f-darcs add f-darcs remove f-chmod -R -w _darcs/index_invalid--test_cannot_write_index  cd ..
+ tests/issue1981-missing-pristine.sh view
@@ -0,0 +1,12 @@+. lib++# note: we enforce --no-cache otherwise this is hard to reproduce++rm -rf R S+darcs init R+cd R+echo x > x+darcs record --no-cache x -lam add_x+rm -f _darcs/pristine.hashed/*+cd ..+not darcs clone  --no-cache R S 2>&1 | grep repair
tests/issue1987.sh view
@@ -113,6 +113,7 @@ darcs record -am 'Add f.'  # $INV_DIR_AFTER_RECORD should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 # 0000000192-3863012ed1377e2d80e0f97bccbad0260d9e186bc28080549563f22d8b968e33 INV_DIR_AFTER_RECORD=$(ls -1 $INV_DIR) @@ -121,6 +122,7 @@ darcs record -am 'Add g.'  # $INV_DIR_AFTER_SND_RECORD should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 # 0000000192-3863012ed1377e2d80e0f97bccbad0260d9e186bc28080549563f22d8b968e33 # 0000000384-e5683733407c4aae642604adf29d582a8fbbb6c50a96d6e8bba20058f7892b68 INV_DIR_AFTER_SND_RECORD=$(ls -1 $INV_DIR)@@ -157,12 +159,14 @@ darcs record -am 'Add f.'  # $INV_DIR_AFTER_RECORD should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 # 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018 INV_DIR_AFTER_RECORD=$(ls -1 $INV_DIR)  darcs tag -m 'Add f.'  # $INV_DIR_AFTER_FST_TAG should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 # 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018 # 0000000297-eed3c68ee2d145f499f00d8367ec09a2cebdf79de7341e873e7bc68088236fc6 INV_DIR_AFTER_TAG=$(ls -1 $INV_DIR)@@ -177,6 +181,7 @@ darcs record -am 'Add g.'  # $INV_DIR_AFTER_SND_RECORD should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 # 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018 # 0000000297-eed3c68ee2d145f499f00d8367ec09a2cebdf79de7341e873e7bc68088236fc6 # 0000000489-6892c56cd7ec4381ad7d8bbcf10ed5a3366d3ac40f2a569d9bf7d2e5633fe32a@@ -194,7 +199,12 @@ # 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018 INV_DIR_AFTER_OPTIMIZE=$(ls -1 $INV_DIR) -[ "$INV_DIR_AFTER_OPTIMIZE" == "$INV_DIR_AFTER_RECORD" ]+# comm -3 is the symmetric difference i.e. union \\ intersection,+# the extra echo gets rid of the whitespace+NULL_INV=$(echo $(comm -3 <(echo "$INV_DIR_AFTER_OPTIMIZE") \+					<(echo "$INV_DIR_AFTER_RECORD")))++[ "$NULL_INV" = "0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]  cd ..
tests/issue2012_send_output_no_address.sh view
@@ -26,9 +26,6 @@  . ./lib -DARCS_EDITOR=echo-export DARCS_EDITOR- mkdir temp1 temp2  cd temp2
tests/issue2013_send_to_context.sh view
@@ -25,9 +25,6 @@  . ./lib -DARCS_EDITOR=echo-export DARCS_EDITOR- rm -rf temp2 mkdir temp2
tests/issue2041_dont_add_symlinks.sh view
@@ -29,12 +29,7 @@ rm -rf R                        # Another script may have left a mess. darcs init      --repo R        # Create our test repo. -darcs --version- cd R--unset pwd # Since this test is pretty much linux-specific, hspwd.hs is not needed-abort_windows # and skip if we are on win32...  # test for file touch test-file
+ tests/issue2047_duplicate_conflictor_recommute_fail.sh view
@@ -0,0 +1,132 @@+#!/usr/bin/env bash+## Test that shows failing commute of conflictors/duplicates.+##+## Copyright (C) 2012 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++# We want to create this situation:+#+# Context: [adddir "./dir1", addfile "./file1.txt"]+#+# (ParTree+#     (ParTree (DP "./dir1" RmDir)+#              (Move "./file1.txt" "./dir1/file3.txt")+#     (SeqTree (DP "./dir1" RmDir) (Move "./file1.txt" "./file2.txt")))+#+# And then create the merged tree consisting of merging the second "branch" of+# a par tree into the first, depth-first.+#+# Finally, we show that commute is broken for certain combinations of+# conflictors/duplicates, since we can commute out one way, but not the+# other. We do so, by creating both orderings of the final two patches, and+# show that only in one case can we obliterate the penultimate patch alone (due+# to non-commutation).+#+# See issue2047 on the BTS for more information.++. ./lib++# test fails for these obsolete formats:+skip-formats darcs-1 darcs-2++rm -rf R1* R2 R3*++darcs init --repo R1+cd R1++mkdir dir1+touch file1.txt++darcs rec -alm 'Init'++darcs get . ../R2+darcs get . ../R3++rmdir dir1+darcs rec -am 'Remove dir1'++cd ../R2+darcs mv file1.txt dir1/file3.txt+darcs rec -am 'Move 1 -> 3'++# Create the first merged ParTree.+cd ../R1+darcs pull -a ../R2++# Revert conflict-markup+darcs rev -a++# Create a copy of R1, so we can show the effect of commuting out the final two+# patches, when we create a different ordered R3...+darcs get . ../R1_OTHER++cd ../R3++# Copy R3, so we can create the other ordering for its patches.+darcs get . ../R3_OTHER++#### In R3 we do rmdir; move file+rmdir dir1+darcs rec -alm 'Rmdir'++cd ../R1+darcs pull -a ../R3+darcs rev -a++cd ../R3+darcs mv file1.txt file2.txt+darcs rec -alm 'Move 1 -> 2'++cd ../R1+darcs pull -a ../R3+darcs rev -a++#### In R3_OTHER we do move file; rmdir+cd ../R3_OTHER+darcs mv file1.txt file2.txt+darcs rec -alm 'Move 1 -> 2'++cd ../R1_OTHER+darcs pull -a ../R3_OTHER+darcs rev -a++cd ../R3_OTHER+rmdir dir1+darcs rec -alm 'Rmdir'++cd ../R1_OTHER+darcs pull -a ../R3_OTHER+darcs rev -a++# Now, to show the bug, we can ob the penultimate patch from R1, but not+# R1_OTHER+cd ../R1+darcs ob -p 'Rmdir' -a++[[ $(darcs changes --count) -eq 4 ]]++cd ../R1_OTHER+echo y | darcs ob -p 'Move 1 -> 2' -a++# There should be 4 changes remaining, but due to the failure to commute, we'll+# actually obliterate 2 patches, leaving 3.+[[ $(darcs changes --count) -eq 4 ]]
+ tests/issue2072-coalesce-move.sh view
@@ -0,0 +1,51 @@+. lib++rm -rf R+darcs init R+cd R++touch x1 y1+darcs rec -lam "adds"++darcs mv x1 x2+darcs mv y1 y2++rm x2 y2+darcs whatsnew > out+cat out >&2+not grep move out++# coalescing should result in 2 changes plus 1 last regrets prompt+echo yyy | darcs record -m "rms"+darcs log -v --last=1 > log+not grep move log++cd ..++# same situation but record only one of the coalesced changes++rm -rf R+darcs init R+cd R++touch x1 y1+darcs rec -lam "adds"++darcs mv x1 x2+rm x2++darcs whatsnew > whx++darcs mv y1 y2+rm y2++# record only the 'rmfile ./y1'+echo nyy | darcs record -m "rms"+darcs log -v --last=1 > log+not grep move log+grep -F 'rmfile ./y1' log+grep move _darcs/patches/pending+darcs whatsnew > whx_after+diff -u whx whx_after >&2++cd ..
+ tests/issue2074.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash++. lib++darcs init R+cd R+touch a+darcs rec -l a -am 'a'+echo "line1" > a+darcs rev -a+# the "n" cancels obliterate after the+# "this will make unrevert impossible" question+# which is not a failure+echo "yyn" | darcs ob+cd ..
tests/issue2209-look_for_replaces.sh view
@@ -25,9 +25,12 @@  . lib -darcs init R+rm -rf R+mkdir R cd R+ # simple full complete replace (record)+darcs init echo "foo" > file darcs record -al -m "add file" echo "bar_longer" > file          # replace by token of different length@@ -87,6 +90,16 @@ rm -rf *  # partial replace (only some of the words/chunks replaced) (amend-record)+# note that coalescing simplifies+#     hunk ./file 1+#     +foo foo+#     replace ./file [A-Za-z_0-9] foo bar+#     hunk ./file 1+#     -bar bar+#     +bar foo+# to+#     hunk ./file 1+#     +bar foo darcs init echo "foo foo" > file darcs record -al -m "add file"@@ -97,10 +110,6 @@   * add file     addfile ./file     hunk ./file 1-    +foo foo-    replace ./file [A-Za-z_0-9] foo bar-    hunk ./file 1-    -bar bar     +bar foo EOF diff -u log log.expected@@ -153,19 +162,19 @@ foo bar EOF-darcs record -al -m "add file" --ignore-times+darcs record -al -m "add file" cat > file <<EOF foo bar bar EOF-darcs record -a -m "change file" --ignore-times+darcs record -a -m "change file" cat > file <<EOF bar bar bar EOF-echo yyyy | darcs amend-record --look-for-replaces --ignore-times+echo yyyy | darcs amend-record --look-for-replaces darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^    {\|    }$" > log cat > log.expected <<EOF   * change file@@ -322,9 +331,7 @@  # 2 -cd ..-darcs init S-cd S+darcs init echo 'Example content' > f echo 'This is golden content , super interesting content' >> f @@ -336,12 +343,11 @@ sed -i "s/content/topic/g" g darcs whatsnew --look-for-replace | grep replace # replace same token differently in different files is OK+rm -rf *  # 3 -cd ..-darcs init T-cd T+darcs init echo 'Example content' > f echo 'This is golden content , super interesting content' >> f @@ -363,3 +369,5 @@ grep "^replace ./e" out  # 1 replace in e not grep "^replace ./f" out  # 0 replace in f grep "^replace ./g" out  # 1 replace in g++cd ..
tests/issue2275_follows-symlinks.sh view
@@ -28,7 +28,6 @@ ## SOFTWARE.  . lib-abort_windows                   # Skip test on Windows  rm -rf R darcs init R@@ -43,123 +42,106 @@  # extended test extracted from the bug report -extended_test () {--  rm -rf R log-  mkdir log--  # initialize the repository-  darcs init R--  cd R-  echo ImmutableFile > file-  darcs rec -lam init--  # add a test file and record the patch-  echo TemporaryFile > maybeFile-  darcs rec -lam 'Add maybeFile'--  # remove the just added file and check that darcs recognizes the-  # removal-  rm maybeFile-  darcs wh -s > ../log/before-ln-wh-s-  darcs wh -ls > ../log/before-ln-wh-ls--  diff -u ../log/before-ln-wh-s ../log/before-ln-wh-ls+rm -rf R log+mkdir log -  # create a symbolic link with the same name of the just removed-  # file pointing to an existent file (does not need to be in the-  # repodir)-  ln -s file maybeFile+# initialize the repository+darcs init R -  # now you get different opinions about what changed depending on-  # the use of the '--look-for-adds' option. In both case 'maybeFile'-  # is wrongly reported as changed (the current content of 'maybeFile'-  # is assumed to be the one of the file the link points to), anyway-  # using the '-l' option you also get the right information that-  # 'maybeFile' has been removed.-  darcs wh -s > ../log/after-ln-wh-s-  darcs wh -ls > ../log/after-ln-wh-ls+cd R+echo ImmutableFile > file+darcs rec -lam init -  diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s-  diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls+# add a test file and record the patch+echo TemporaryFile > maybeFile+darcs rec -lam 'Add maybeFile' -  # trying to record the changes without the use of '-l' leads to-  # the wrong patch being recorded-  darcs rec -am 'Maybe remove maybeFile'-  darcs log --last 1 -s | not grep 'M ./maybeFile'+# remove the just added file and check that darcs recognizes the+# removal+rm maybeFile+darcs wh -s > ../log/before-ln-wh-s+darcs wh -ls > ../log/before-ln-wh-ls -  # unrecord the wrong patch-  darcs unrec --last 1 -a+diff -u ../log/before-ln-wh-s ../log/before-ln-wh-ls -  # passing '-l' to the record command leads to the right patch-  # being  recorded.-  darcs rec -lam 'Remove maybeFile'-  darcs log --last 1 -s | grep -F './maybeFile' > ../log/after-record-l+# create a symbolic link with the same name of the just removed+# file pointing to an existent file (does not need to be in the+# repodir)+ln -s file maybeFile -  diff -u -w ../log/after-record-l ../log/after-ln-wh-ls+# now you get different opinions about what changed depending on+# the use of the '--look-for-adds' option. In both case 'maybeFile'+# is wrongly reported as changed (the current content of 'maybeFile'+# is assumed to be the one of the file the link points to), anyway+# using the '-l' option you also get the right information that+# 'maybeFile' has been removed.+darcs wh -s > ../log/after-ln-wh-s+darcs wh -ls > ../log/after-ln-wh-ls -  # now if you unrecord the last patch the `-l' option does not-  # make a difference anymore-  darcs unrec --last 1 -a-  darcs wh -s > ../log/after-unrec-wh-s-  darcs wh -ls > ../log/after-unrec-wh-ls+diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls -  # use -w to ignore different indentation-  diff -u -w ../log/after-record-l ../log/after-unrec-wh-s-  diff -u -w ../log/after-record-l ../log/after-unrec-wh-ls+# trying to record the changes without the use of '-l' leads to+# the wrong patch being recorded+darcs rec -am 'Maybe remove maybeFile'+darcs log --last 1 -s | not grep 'M ./maybeFile' -  # create again the issue, this time giving the file the same-  # content as the file referenced by the link-  echo ImmutableFile > maybeFileThree-  darcs rec -lam 'Add maybeFileThree'-  rm maybeFileThree+# unrecord the wrong patch+darcs unrec --last 1 -a -  darcs wh -s > ../log/before-ln-wh-s-  darcs wh -ls > ../log/before-ln-wh-ls+# passing '-l' to the record command leads to the right patch+# being  recorded.+darcs rec -lam 'Remove maybeFile'+darcs log --last 1 -s | grep -F './maybeFile' > ../log/after-record-l -  ln -s file maybeFileThree+diff -u -w ../log/after-record-l ../log/after-ln-wh-ls -  darcs wh -s > ../log/after-ln-wh-s-  darcs wh -ls > ../log/after-ln-wh-ls+# now if you unrecord the last patch the `-l' option does not+# make a difference anymore+darcs unrec --last 1 -a+darcs wh -s > ../log/after-unrec-wh-s+darcs wh -ls > ../log/after-unrec-wh-ls -  diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s-  diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls+# use -w to ignore different indentation+diff -u -w ../log/after-record-l ../log/after-unrec-wh-s+diff -u -w ../log/after-record-l ../log/after-unrec-wh-ls -  darcs rec -lam 'Remove maybeFileThree'+# create again the issue, this time giving the file the same+# content as the file referenced by the link+echo ImmutableFile > maybeFileThree+darcs rec -lam 'Add maybeFileThree'+rm maybeFileThree -  # create again the problem, pointing the symbolic link to a-  # not-existent file-  echo JustAnotherTemporaryFile > maybeFileFour-  darcs rec -lam 'Add maybeFileFour'-  rm maybeFileFour+darcs wh -s > ../log/before-ln-wh-s+darcs wh -ls > ../log/before-ln-wh-ls -  darcs wh -s > ../log/before-ln-wh-s-  darcs wh -ls > ../log/before-ln-wh-ls+ln -s file maybeFileThree -  ln -s not-existent maybeFileFour+darcs wh -s > ../log/after-ln-wh-s+darcs wh -ls > ../log/after-ln-wh-ls -  darcs wh -s > ../log/after-ln-wh-s-  darcs wh -ls > ../log/after-ln-wh-ls+diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls -  diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s-  diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls+darcs rec -lam 'Remove maybeFileThree' -  darcs rec -lam 'Remove maybeFileFour'+# create again the problem, pointing the symbolic link to a+# not-existent file+echo JustAnotherTemporaryFile > maybeFileFour+darcs rec -lam 'Add maybeFileFour'+rm maybeFileFour -  cd ..-}+darcs wh -s > ../log/before-ln-wh-s+darcs wh -ls > ../log/before-ln-wh-ls -echo ############## --ignore-times #################+ln -s not-existent maybeFileFour -extended_test+darcs wh -s > ../log/after-ln-wh-s+darcs wh -ls > ../log/after-ln-wh-ls -echo ############ --no-ignore-times ################+diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls -restore_defaults () {-  sed -i 's/no-ignore-times/ignore-times/g' $1/.darcs/defaults-}-sed -i 's/ignore-times/no-ignore-times/g' .darcs/defaults+darcs rec -lam 'Remove maybeFileFour' -trap "restore_defaults '$PWD'" EXIT-extended_test+cd ..
tests/issue2293-laziness.sh view
@@ -35,10 +35,16 @@ darcs log --last=1 # amend echo 'baz' > bar+# note: the last 'y' here is for the hijack prompt echo yyyy | darcs amend darcs log --last=1+# amend --ask-deps, deselect the only offered patch (i.e. the tag)+echo yny | darcs amend --ask-deps+# amend --ask-deps, select the tag+# note: the last 'y' here is for the hijack prompt+echo yyyy | darcs amend --ask-deps # unrecord-echo yd | darcs unrecord -o+echo yd | darcs unrecord # log --context darcs log --context > ctx # record@@ -53,5 +59,11 @@ # apply darcs apply xxx.dpatch --debug darcs log --last=1+# clean up xxx+echo yd | darcs obliterate+# record --ask-deps, deselect the only offered patch (i.e. the tag)+echo n | darcs record -m emptynodeps --ask-deps # does not record anything+# record --ask-deps, select the tag+echo yy | darcs record -m emptywithdeps --ask-deps  cd ..
tests/issue2312_posthooks_for_record_and_amend-record_should_receive_DARCS_PATCHES.sh view
@@ -24,25 +24,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -. lib                           # Load some portability helpers.--# passing environment variables to posthooks isn't supported at-# all in Windows-abort_windows--# even though the test doesn't work on Windows at the moment,-# might as well future proof it by using a Haskell program instead-# of a script for the post hook.--cat <<FAKE > echo_darcs_patches.hs # create a posthoook that echos $DARCS_PATCHES-import System.Environment-main = do-    [outFile] <- getArgs-    darcsPatches <- getEnv "DARCS_PATCHES"-    writeFile outFile (darcsPatches ++ "\n")-FAKE-ghc --make -o echo_darcs_patches echo_darcs_patches.hs-ECHO_DARCS_PATCHES=`pwd`/echo_darcs_patches+. lib  rm -rf R mkdir R@@ -53,14 +35,14 @@ darcs add some.file  # posthook for darcs record should receive DARCS_PATCHES with correct change-darcs record -am msg1 --posthook="$ECHO_DARCS_PATCHES out"+darcs record -am msg1 --posthook="printenv DARCS_PATCHES" > out cat out grep msg1 out grep "A ./some.file" out  # posthook for amend-record should receive DARCS_PATCHES with correct change echo contents > some.file-echo y | darcs amend-record -a --posthook="$ECHO_DARCS_PATCHES out"+echo y | darcs amend-record -a --posthook="printenv DARCS_PATCHES" > out cat out grep msg1 out grep "A ./some.file" out@@ -68,13 +50,13 @@ # newly added file should appear after amend echo more contents >> some.file touch new.file-darcs record -am msg2 --posthook="$ECHO_DARCS_PATCHES out"+darcs record -am msg2 --posthook="printenv DARCS_PATCHES" > out cat out grep msg2 out grep "M ./some.file" out not grep "A ./new.file" out darcs add new.file-echo y | darcs amend-record -a --posthook="$ECHO_DARCS_PATCHES out"+echo y | darcs amend-record -a --posthook="printenv DARCS_PATCHES" > out cat out not grep msg1 out grep msg2 out@@ -84,11 +66,10 @@ # no change should appear if it is not recorded echo > out      # clear out file, in case posthook is not called echo contents >> new.file-echo ny | darcs record -m msg3 --posthook="$ECHO_DARCS_PATCHES out"+echo ny | darcs record -m msg3 --posthook="printenv DARCS_PATCHES" > out not grep msg1 out not grep msg2 out not grep msg3 out not grep "M ./new.file" out  cd ..-rm -rf R
tests/issue2343.sh view
@@ -53,7 +53,7 @@ # is important to make a different line from the top # "foo(foobar);" -> "foo(foovar2);" because if not it will only be an deleted # line and the algorithm will skip the check of boring lines.-darcs wh >log 2>&1+darcs wh >log cat > log.expected <<EOF hunk ./file 2 -    foo(foovar);
tests/issue2365-whatsnew-fails-get-no-working-dir.sh view
@@ -34,6 +34,10 @@  darcs get R S --no-working-dir +# rename the source repo to trigger the bug, since we are+# now using caches for pristine+mv R X+ cd S not darcs whatsnew | grep "No changes"
tests/issue2512-multiple-authors-clobbered-in-global-conf.sh view
@@ -2,7 +2,6 @@ ## Test for issue2512 - Multiple authors in global config get overwritten  . lib-abort_windows  # different directory names on Windows  # helper function fail {
tests/issue2526-whatsnew-boring.sh view
@@ -2,7 +2,7 @@  . lib -# test that 'whatsnew -l --boring' actually lists boring files+# test that 'whatsnew --boring' actually lists boring files  rm -rf R darcs init R@@ -12,8 +12,8 @@ darcs setpref boringfile boring darcs record -lam'added boring and set as boringile' touch xxx-darcs whatsnew -l --boring | grep xxx-darcs whatsnew -l --boring | grep -v 'No changes'+darcs whatsnew --boring | grep xxx+darcs whatsnew --boring | grep -v 'No changes'  cd .. rm -rf R
tests/issue2592-pending-look-for.sh view
@@ -1,11 +1,6 @@ #!/usr/bin/env bash . ./lib -cat << EOF > empty_pending-{-}-EOF- # darcs add a file and then rename without telling darcs  rm -rf test1@@ -22,7 +17,7 @@ darcs whatsnew --look-for-moves | grep 'addfile ./g' darcs record -am 'addfile f + move f g = addfile g' --look-for-moves # make sure pending is now empty-diff ../empty_pending _darcs/patches/pending+not darcs whatsnew cd ..  # add and record a file, darcs move it and then rename it back@@ -35,7 +30,7 @@ darcs add f darcs record -lam 'addfile f' f # make sure pending is empty-diff ../empty_pending _darcs/patches/pending+not darcs whatsnew darcs move f g darcs whatsnew | grep 'move ./f ./g' mv g f
+ tests/issue2668-create-directory-permission.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+# issue2668 is actually two separate issues:+# * patch index does not work with repos whose parent dir is read-only+# * failure to create or update patch index should not make other commands fail++. lib++readonly_path=$(/bin/pwd)/readonly+trap "chmod -R +w $readonly_path" EXIT++rm -rf readonly+mkdir readonly++darcs init R++darcs init S+darcs optimize enable-patch-index --repo=S++mv R S readonly+chmod -w readonly++# 1st problem+cd readonly/R+darcs optimize disable-patch-index+darcs optimize enable-patch-index+cd ../..++# 2nd problem+cd readonly/S+# provoke failure when we try to update the patch index+# even if 1st problem is no longer an issue+chmod -w _darcs/patch_index+echo text > file+darcs record -l file -am 'file'+darcs unrecord -a -p 'file'+cd ../..
+ tests/issue2682.sh view
@@ -0,0 +1,72 @@+#!/usr/bin/env bash+# test for issue2682: conflict not marked if tag pulled at the same time++. lib++rm -rf R S+darcs init R+cd R+echo initial>file+darcs add file+darcs record -am initial+darcs clone . ../S++# Record a change in R+echo one > file+darcs record -am one+cd ../S++# Record a conflicting change in S+echo two > file+darcs record -am two+cd ..++tag() {+  name=T$1+  rm -rf $name+  darcs clone $1 $name+  cd $name+  darcs tag $name+  cd ..+}++depend() {+  name=D$1+  rm -rf $name+  darcs clone $1 $name+  cd $name+  echo yd | darcs record --ask-deps -m $name+  cd ..+}++runtest() {+  cd $2+  # Pull from R to S+  # Darcs should say there's a conflict and+  # mark it, but instead the pull silently succeeds.+  darcs pull ../$1 -a 2>&1 | tee LOG+  grep -i conflicts LOG+  darcs whatsnew++  # undo the pull+  darcs revert -a+  echo y | darcs obliterate -a --last=2+  # again, this time with --reorder-patches+  darcs pull ../$1 -a --reorder-patches 2>&1 | tee LOG+  grep -i conflicts LOG+  darcs whatsnew+  cd ..+}++# test all 4 combinations of tag/depend+tag R+depend R++tag S+runtest TR TS+depend S+runtest TR DS+tag S+runtest DR TS+depend S+runtest DR DS
+ tests/issue2697-amend-unrecord.sh view
@@ -0,0 +1,17 @@+#!/usr/bin/env bash++# amend --unrecord should move unrecorded changes to pending++. lib++rm -rf R+darcs init R+cd R++echo bla > bla+darcs record -lam 'bla'+echo yyy | darcs amend --unrecord -a bla+darcs whatsnew > new+grep 'addfile ./bla' new++cd ..
+ tests/issue2699-obliterate-rebase-suspend-pending.sh view
@@ -0,0 +1,30 @@+# test for issue2699++. lib+rm -rf R S+darcs init R+cd R++mkdir d+darcs record -lam add-d+darcs move d e+darcs record -am move-d-e++darcs clone . ../S++touch e/f+darcs add e/f+echo yy | darcs obliterate -p move-d-e+cat >../pending_expected <<EOF+addfile ./d/f+EOF+diff _darcs/patches/pending ../pending_expected >&2++cd ../S++touch e/f+darcs add e/f+echo yy | darcs rebase suspend -p move-d-e+diff _darcs/patches/pending ../pending_expected >&2++cd ..
+ tests/issue2702-invalid-regex.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash++. lib++darcs init R+cd R+# need to have at least one patch as long as we throw the error+# only when we actually try to match+touch f+darcs rec -lam 'dummy'+# test that using an invalid regex is not treated as bug in darcs+not darcs log -p '' >&2+not darcs log -p '[' >&2+not darcs log -p '*x' >&2+cd ..
tests/issue381.sh view
@@ -3,9 +3,6 @@  # for issue381: "darcs send -o message --edit-description doesn't work" -DARCS_EDITOR=echo-export DARCS_EDITOR- rm -rf temp1 temp2 mkdir temp1 temp2 @@ -47,4 +44,3 @@ IFS=' ' darcs send --author=me -a --subject="it works" --to user@place.org --sendmail-command='grep "^Subject: it works$" %<' ../temp2  cd ..-rm -rf temp1 temp2
tests/issue436.sh view
@@ -7,21 +7,21 @@ darcs init echo A > f darcs add f-darcs record --ignore-times -a -m A+darcs record -a -m A cd ..  darcs get temp1 temp2  cd temp1 echo C > f-darcs record --ignore-times -a -m A-C+darcs record -a -m A-C cd ..  cd temp2 echo B > f-darcs record --ignore-times -a -m A-B+darcs record -a -m A-B echo A > f-darcs record --ignore-times -a -m B-A+darcs record -a -m B-A (darcs push -a || :) 2> push-result grep "Refusing to apply" push-result cd ..
tests/issue458.sh view
@@ -3,12 +3,10 @@ ### darcs get --set-scripts-executable ignores umask . ./lib -## Windows doesn't support proper permissions.--if echo $OS | grep -i windows; then-    echo Windows does not support posix permissions-    exit 0-fi+# We can set and clear permission bits with bash on Windows but that+# has not the expected effect on programs. So even though this test+# actually succeeds on Windows, it makes no sense to run it.+abort_windows  rm -rf temp mkdir temp@@ -26,4 +24,3 @@ diff -u desired-mode mode  cd ..-rm -rf temp
tests/issue538.sh view
@@ -1,4 +1,4 @@-#!/bin/env bash+#!/usr/bin/env bash # A test for issue 538 - that an executable test script will run successfully if # it is recorded with --set-scripts-executable. @@ -73,7 +73,7 @@ # test --linear with --set-scripts-executable rm -rf temp1 make_repo_with_test-if darcs test --linear --set-scripts-executable | grep 'Success!' ; then+if darcs test --linear --set-scripts-executable | grep 'Test does not fail on head' ; then     echo "ok 5" else     echo "not ok 5 tracking down with --set-scripts-executable failed (because test failed?)"
tests/issue612_repo_not_writable.sh view
@@ -1,10 +1,12 @@ #!/usr/bin/env bash -# Test that darcs fails appropriately when the target repo inventory file is not writable.-# See issue612+# Test that darcs fails appropriately when the target repo inventory file is+# not writable. See issue612  . lib +# We can set and clear permission bits with bash on Windows but that+# has not the expected effect on programs. abort_windows  rm -rf temp1 temp2@@ -14,22 +16,13 @@ touch t.t darcs add t.t darcs record -am "initial add"-if [ -e _darcs/inventories ]; then-  chmod 0555 _darcs/inventories/*-  chmod 0555 _darcs/inventories-fi-if [ -e _darcs/inventory ]; then-  chmod 0555 _darcs/inventory-fi+trap "chmod -R +w $(pwd)/_darcs/inventories" EXIT+chmod -R a-w _darcs/inventories cd ..  darcs get temp1 temp2 cd temp2-# this block may fail so we'd better make sure we clean up after-# ourselves to avoid a permissions mess for other tests-trap "cd ..; chmod -R 0755 temp1; rm -rf temp1 temp2" EXIT echo new >> t.t darcs record -am "new patch"-not darcs push -a ../temp1 2> log-grep failed log-+not darcs push -a ../temp1+cd ..
tests/issue706.sh view
@@ -3,9 +3,6 @@  # for issue706: "Filenames with spaces issue" -DARCS_EDITOR=echo-export DARCS_EDITOR- rm -rf temp mkdir temp cd temp
tests/latin9-input.sh view
@@ -54,9 +54,6 @@ # Please leave it this way :-) switch_to_latin9_locale -# This test clobbers the global darcs author--f $HOME/.darcs/author && exit 200- rm -rf temp1 mkdir temp1 cd temp1
tests/lazy-optimize-reorder.sh view
@@ -21,20 +21,20 @@ darcs record -am 'add f2' cd .. -darcs get --lazy temp1 temp2+darcs get --lazy temp1 temp2 --no-cache -darcs get --lazy temp2 temp3+darcs get --lazy temp2 temp3 --no-cache  cd temp2  # Run darcs changes so we pull in the inventories (but no the patches)-darcs changes+darcs changes --no-cache  # Remove original repository, so we have no references to changes f1 and f2. rm -rf ../temp1  # Now we should be unable to read some of the history-darcs changes -s > out+darcs changes -s --no-cache > out cat out grep unavailable out @@ -57,6 +57,6 @@ darcs optimize reorder  # Just a double-check: we shouldn't be able to check in this case.-not darcs check+not darcs check --no-cache  cd ..
tests/lib view
@@ -2,24 +2,45 @@  . ./env -## I would use the builtin !, but that has the wrong semantics.-not () { "$@" && exit 1 || :; }+# I would use the builtin !, but that has the wrong semantics+not () {+  set +x+  if "$@" || test $? = "4"; then+    # fail the test if command succeeds or returns 4+    exit 1+  fi+  set -x+}  # trick: OS-detection (if needed)+os_is_windows() {+  echo $OS | grep -i windows+}+ abort_windows () {-if echo $OS | grep -i windows; then+if os_is_windows; then   echo This test does not work on Windows   exit 200 fi } -pwd() {-    ghc --make -o hspwd "$TESTBIN/hspwd.hs" > /dev/null-    "./hspwd"-}+if os_is_windows; then+  # some installations of bash on Windows do not include \r by default+  # which breaks a lot of tests+  IFS=$' \t\n\r'+  # this is for the github CI: we need to make sure that our test data (e.g.+  # patch bundles) is not converted to CRLF style by git when we checkout a+  # snapshot of our repo+  git config --global core.autocrlf input+fi +# tests now work on windows with this or with the bash pwd:+# pwd() {+#     runghc "$TESTBIN/hspwd.hs"+# }+ which() {-    type -P "$@" | cut -d' ' -f 3-+    type -P "$@" }  # switch locale to one supporting the latin-9 (ISO 8859-15) character set if possible, otherwise skip test@@ -30,7 +51,7 @@ }  switch_to_latin9_locale () {-    if echo $OS | grep -i windows; then+    if os_is_windows; then         chcp.com 28605     else         if ! which locale ; then@@ -51,7 +72,7 @@ # switch locale to utf8 if supported if there's a locale command, skip test # otherwise switch_to_utf8_locale () {-    if echo $OS | grep -i windows; then+    if os_is_windows; then         chcp.com 65001     else         if ! which locale ; then@@ -95,8 +116,22 @@    tar -xzf $TESTDATA/$1.tgz } +# comparing patch bundles requires we filter out some (irrelevant) lines+filter_bundle() {+  cat $1 | grep -v '^Date: ' | grep -v 'patch\(es\)\? for repository '+}+compare_bundles() {+  diff <(filter_bundle $1) <(filter_bundle $2) >&2+}+ grep -q darcs-3 .darcs/defaults && format=darcs-3 grep -q darcs-2 .darcs/defaults && format=darcs-2 grep -q darcs-1 .darcs/defaults && format=darcs-1++# To test if darcs works correctly in case hard-linking fails because the+# cache is in a different file system. This assumes that /run/darcs-test is+# writable and on a separate filesystem (e.g. tmpfs).+#+# export XDG_CACHE_HOME=`mktemp -d -p /run/darcs-test`  set -vex -o pipefail
+ tests/list-options.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+# some tests for the --list-options option++. lib++rm -rf R+darcs init R+cd R+echo aboringfile > _darcs/prefs/boring+touch anunaddedfile+touch aboringfile+darcs record --list-options | not grep -w anunaddedfile+darcs record -l --list-options | grep -w anunaddedfile+darcs record -l --list-options | not grep -w aboringfile+darcs record --boring --list-options | grep -w anunaddedfile+darcs record --boring --list-options | grep -w aboringfile+darcs add --list-options | grep -w anunaddedfile+darcs add --list-options | not grep -w aboringfile+darcs add --boring --list-options | grep -w anunaddedfile+darcs add --boring --list-options | grep -w aboringfile+cd ..
tests/look_for_add.sh view
@@ -1,16 +1,5 @@ #!/usr/bin/env bash -cat > empty_pending <<EOF-{-}-EOF-check_empty_pending() {-  echo ================ pending ==================-  cat _darcs/patches/pending-  echo ================ pending ==================-  [ -z _darcs/patches/pending ] || cmp _darcs/patches/pending ../empty_pending-}- . ./lib  rm -rf temp1 temp2@@ -19,13 +8,13 @@ darcs init mkdir dir darcs record -a -m add_dir -A x --look-for-adds-check_empty_pending+not darcs whatsnew echo zig > dir/foo echo zag > foo mkdir dir2 echo hi > dir2/foo2 darcs record -a -m add_foo -A x --look-for-adds-check_empty_pending+not darcs whatsnew cd ../temp2 darcs init darcs pull -a ../temp1
tests/look_for_moves.sh view
@@ -12,11 +12,11 @@ touch foo darcs record -lam add_file mv foo foo2-darcs wh --summary --look-for-moves >log 2>&1+darcs wh --summary --look-for-moves >log cat > log.expected <<EOF  ./foo -> ./foo2 EOF-diff -u log log.expected+diff -u log log.expected >&2 rm log log.expected darcs record -am move_file --look-for-moves darcs wh --look-for-moves --look-for-adds  >log 2>&1@@ -29,7 +29,7 @@ mkdir foo darcs record -lam add_dir mv foo foo2-darcs wh --summary --look-for-moves >log 2>&1+darcs wh --summary --look-for-moves >log cat > log.expected <<EOF  ./foo -> ./foo2 EOF@@ -47,7 +47,7 @@ darcs record -lam add_file mv foo foo2 touch foo-darcs wh --summary --look-for-moves >log 2>&1+darcs wh --summary --look-for-moves >log cat > log.expected <<EOF  ./foo -> ./foo2 EOF@@ -118,7 +118,7 @@ mv foo dir darcs record -lam add_files mv dir dir2-darcs wh --summary --look-for-moves > log 2>&1+darcs wh --summary --look-for-moves > log cat > log.expected <<EOF  ./dir -> ./dir2 EOF@@ -149,7 +149,7 @@ mv dir dir.tmp mv dir2 dir mv dir.tmp dir2-darcs wh --summary --look-for-moves > log 2>&1+darcs wh --summary --look-for-moves > log cat > log.expected <<EOF  ./dir/foo -> ./dir2/foo  ./dir2/foo2 -> ./dir/foo2@@ -164,7 +164,7 @@ darcs record -lam add_files_and_dirs darcs mv foo foo2 mv foo2 foo3-darcs wh --summary --look-for-moves > log 2>&1+darcs wh --summary --look-for-moves > log cat > log.expected <<EOF  ./foo -> ./foo3 EOF@@ -181,7 +181,7 @@ touch foo darcs record -lam add_files_and_dirs mv foo foo~-darcs wh --summary --look-for-moves > log 2>&1+darcs wh --summary --look-for-moves > log cat > log.expected <<EOF R ./foo EOF
tests/look_for_moves_with_args.sh view
@@ -20,7 +20,7 @@ }  num_lines () {-  test "$(cat $2 | wc -l)" = "$1"+  test $(wc -l < $2) = $1 }  move1='move \./old1 \./new1'
tests/mark-conflicts.sh view
@@ -1,10 +1,10 @@ #!/usr/bin/env bash -# Automated tests for "darcs mark-conflicts".+# tests for "darcs mark-conflicts" -# The builtin ! has the wrong semantics for not.-not () { "$@" && exit 1 || :; }+. lib +rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init@@ -25,14 +25,25 @@ cd ..  cd temp1-darcs pull -a ../temp2 2> log+darcs pull -a ../temp2 >log 2>&1 grep conflict log-grep finished log+grep -i finished log grep 'v v' child_of_conflict darcs revert -a not grep 'v v' child_of_conflict darcs mark-conflicts grep 'v v' child_of_conflict-cd .. -rm -rf temp1 temp2+# test that a change depending on both parts counts as resolution,+# so that mark-conflicts doesn't see any conflicts to mark+darcs revert  -a+echo "Conflict, Part 3." > child_of_conflict+# it should count as resolution regardless of whether unrecorded...+darcs mark-conflicts | grep -i 'No conflicts'+not grep 'v v' child_of_conflict+# ...or recorded+darcs record -am 'Conflict resolution'+darcs mark-conflicts | grep -i 'No conflicts'+not grep 'v v' child_of_conflict++cd ..
tests/merge_three_patches.sh view
@@ -8,7 +8,6 @@ echo record author me > _darcs/prefs/defaults echo ALL all >> _darcs/prefs/defaults #echo ALL verbose >> _darcs/prefs/defaults-echo ALL ignore-times >> _darcs/prefs/defaults echo A > foo echo B >> foo echo C >> foo
tests/mergeresolved.sh view
@@ -8,7 +8,6 @@ echo record author me > _darcs/prefs/defaults echo ALL all >> _darcs/prefs/defaults #echo ALL verbose >> _darcs/prefs/defaults-echo ALL ignore-times >> _darcs/prefs/defaults echo Old > foo darcs add foo darcs record -m Old
tests/network/clone-http-packed-detect.sh view
@@ -28,7 +28,9 @@ rm -rf S darcs clone $baseurl/repo S --no-packs --verbose  |not grep "Cloning packed basic repository" -# check that it does not clam getting packs when there are not+# check that it does not claim getting packs when there are not rm -rf S rm -rf repo/_darcs/packs/+# sleep for a second to avoid spurious false positives on MacOS:+sleep 1 darcs clone $baseurl/repo S --verbose |not grep "Cloning packed basic repository"
tests/network/external.sh view
@@ -4,37 +4,28 @@  . lib -rm -rf temp1+rm -rf foo temp1 temp2 rm -f fakessh -# make our ssh command one word only-if os_is_windows; then-  fakessh=fakessh.bat-  echo 'echo hello > touchedby_fakessh' > $fakessh-else-  fakessh=./fakessh-  echo '#!/bin/sh' > $fakessh-  echo 'echo hello > touchedby_fakessh' >> $fakessh-fi-chmod u+x $fakessh+fakessh=$(pwd)/fakessh+cat >$fakessh.hs <<EOF+main = writeFile "touchedby_fakessh" "hello\n"+EOF+ghc --make $fakessh.hs  export DARCS_SSH=$fakessh export DARCS_SCP=$fakessh export DARCS_SFTP=$fakessh  # first test the DARCS_SSH environment variable-rm -rf touchedby_fakessh-not darcs clone example.com:foo+rm -f touchedby_fakessh+darcs clone example.com:foo grep hello touchedby_fakessh  # now make sure that we don't launch ssh for nothing rm -f touchedby_fakessh-mkdir temp1-cd temp1-darcs init-cd ..-darcs clone temp1 > log+darcs init temp1+darcs clone temp1 temp2 > log not grep touchedby_fakessh log not darcs clone http://darcs.net/nonexistent not grep touchedby_fakessh log-cd ..
− tests/network/failing-issue1599-automatically-expire-unused-caches.sh 
@@ -1,57 +0,0 @@-#!/usr/bin/env bash-## Test for issue1599 - 'Automatically expire unused caches'-##-## Copyright (C) 2010  Adolfo Builes-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib-. httplib--rm -rf R S log && mkdir R-cd R-darcs init-echo a > a-darcs rec -lam a-echo b > b-darcs rec -lam b-echo c > c-darcs rec -lam c-cd ..--serve_http # sets baseurl-darcs clone --lazy $baseurl/R S-rm S/_darcs/prefs/sources-if [ -z "$http_proxy" ]; then-  echo "repo:http://10.1.2.3/S" >> S/_darcs/prefs/sources-fi-echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources-echo "repo:~/test1599/S" >> S/_darcs/prefs/sources-echo "repo:$baseurl/R" >> S/_darcs/prefs/sources-export DARCS_CONNECTION_TIMEOUT=1 && darcs log --repo S --debug --verbose --no-cache 2>&1 | tee log-if [ -z "$http_proxy" ]; then-  c=`grep -c "URL.waitUrl http://10.1.2.3/S" log`-  [ $c  -eq 1 ]-fi-c1=`grep -c "URL.waitUrl $baseurl/dummyRepo" log`-[ $c1 -eq 2 ]-c2=`grep -c "~/test1599/S" log`-[ $c2 -eq 1 ]
tests/network/httplib view
@@ -9,13 +9,14 @@     index-file.names           = () EOF     trap "finish_http \"$PWD\"" EXIT+    PATH=${PATH}:/sbin:/usr/sbin     lighttpd -f light.conf || exit 200     ps `cat light.pid` > /dev/null 2>&1 || exit 200     baseurl="http://localhost:$lightpid" }  finish_http() {-    test -e "$1/light.pid" && kill `cat "$1/light.pid"` || true+    (test -e "$1/light.pid" && kill `cat "$1/light.pid"`) || true }  check_remote_http() {
tests/network/issue1503_prefer_local_caches_to_remote_one.sh view
@@ -26,11 +26,11 @@ . lib . httplib -check_remote_http http://darcs.net/testing/repo1+check_remote_http https://darcs.net/testing/repo1  rm -rf S T-darcs clone --lazy http://darcs.net/testing/repo1 S+darcs clone --lazy https://darcs.net/testing/repo1 S darcs tag --repo S -m 2-darcs clone --lazy http://darcs.net/testing/repo1 T+darcs clone --lazy https://darcs.net/testing/repo1 T darcs pull --repo T S -a --debug --verbose 2>&1 | tee log not grep repo1 log
+ tests/network/issue1599-automatically-expire-unused-caches.sh view
@@ -0,0 +1,57 @@+#!/usr/bin/env bash+## Test for issue1599 - 'Automatically expire unused caches'+##+## Copyright (C) 2010  Adolfo Builes+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib+. httplib++rm -rf R S log && mkdir R+cd R+darcs init+echo a > a+darcs rec -lam a+echo b > b+darcs rec -lam b+echo c > c+darcs rec -lam c+darcs tag bla # so that the clone really is lazy+cd ..++serve_http # sets baseurl+darcs clone --lazy $baseurl/R S+rm S/_darcs/prefs/sources+if [ -z "$http_proxy" ]; then+  echo "repo:http://10.1.2.3/S" >> S/_darcs/prefs/sources+fi+echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources+echo "repo:/does/not/exist" >> S/_darcs/prefs/sources+echo "repo:$baseurl/R" >> S/_darcs/prefs/sources+DARCS_CONNECTION_TIMEOUT=1 darcs log --repo S --debug --no-cache 2>&1 | tee log+grep "could not reach the following locations" log+# the count is two, once for the file we want, and once to test+# for reachability using _darcs/hashed_inventory+if test -z "$http_proxy"; then+  test `grep -c "copyRemote: http://10.1.2.3/S" log` = 2+fi+test `grep -c "copyRemote: $baseurl/dummyRepo" log` = 2
tests/network/issue1932-remote.sh view
@@ -32,11 +32,11 @@  # Repo name with ':' is either scp repo or http repo. # Let's check scp repo first.-( darcs clone user@invalid:path || true ) > log 2>&1-[ -n "$(grep 'ssh: Could not resolve hostname invalid' log)" ]+( darcs clone user@ssh.bogus.domain.so.it.will.surely.fail.example.org.:path || true ) >log 2>&1+fgrep 'ssh: Could not resolve host' log  # HTTP repo-( http_proxy= darcs clone http://www.bogus.domain.so.it.will.surely.fail.com || true ) 2>&1 | tee log+( http_proxy= darcs clone http://www.bogus.domain.so.it.will.surely.fail.example.org. || true ) >log 2>&1 egrep 'CouldNotResolveHost|host lookup failure|Name or service not known' log  # local repos are tested by tests/issue1932-colon-breaks-add.sh
tests/network/issue2090-transfer-mode.sh view
@@ -38,6 +38,7 @@ "  # Set up a repo to test+rm -rf R darcs init --repo R cd R touch f g@@ -46,7 +47,8 @@ darcs clone . $REMOTE:$REMOTE_DIR/R cd .. +rm -rf S darcs clone $REMOTE:$REMOTE_DIR/R S --debug > log 2>&1-COUNT=$(grep -c '^Exec.*darcs.*transfer-mode' log)+COUNT=$(grep -c '^Exec: "ssh" .* "darcs" "transfer-mode"' log) # with issue2090, this was 6! test $COUNT -eq 1
tests/network/issue2545_command-execution-via-ssh-uri.sh view
@@ -40,6 +40,6 @@ echo "text" > file              # Modify the working dir darcs record -lam "First Patch" # Record the changes -check="\"${SSH}\" \"--\" \"${REMOTE}\" \"darcs apply --all --debug --repodir '${REMOTE_DIR}/R'\""+check="\"${SSH}\" \"--\" \"${REMOTE}\" \"darcs apply --all --repodir '${REMOTE_DIR}/R' --debug\"" darcs push -a --debug "${REMOTE}":"${REMOTE_DIR}"/R 2>&1 >/dev/null | \     fgrep "$check"
tests/network/lazy-clone.sh view
@@ -3,20 +3,14 @@ . lib . httplib -# this should all work without a cache-if ! grep no-cache $HOME/.darcs/defaults; then-  echo ALL no-cache >> $HOME/.darcs/defaults-fi- rm -rf tabular unpack_testdata tabular serve_http # sets baseurl -rm -rf temp temp2 temp3+rm -rf temp temp2 darcs clone --lazy $baseurl/tabular temp darcs clone --lazy temp temp2 -rm -rf temp cd temp2 test ! -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2 darcs log -p 'Initial version' -v | cat@@ -26,9 +20,18 @@ # test if we can unapply patches after a tag rm -rf temp4 darcs clone --lazy $baseurl/tabular temp4 --tag '^0.1$'+darcs log --repo=temp4 # to get all inventories+darcs log --repo=temp # to get all inventories finish_http $PWD # and that the log -v output is correct-cd temp4-darcs log -v > LOG-grep -c 'this patch is unavailable' LOG | grep -w 32-cd ..+darcs log -v --repo=temp4 > LOG+if grep no-cache $HOME/.darcs/defaults; then+  expected_unavailable=33+else+  # With cache, the patch 'initial version' is available+  # because of the darcs log command in temp2 above.+  expected_unavailable=32+fi+test $(grep -c 'this patch is unavailable' LOG) = $expected_unavailable++darcs log -v --repo=temp
tests/network/log.sh view
@@ -3,21 +3,25 @@ . lib . httplib -check_remote_http http://darcs.net+check_remote_http https://hub.darcs.net/darcs/darcs-screened  # Demonstrates issue385 and others-darcs log --repo=http://darcs.net GNUmakefile --last 300+darcs log --repo=https://hub.darcs.net/darcs/darcs-screened GNUmakefile --last 30  # Test things mentioned in issue2461:  # no _darcs should remain test ! -d _darcs+ # go to a directory where we have no write access-# (I dearly hope nobody tries to run the tests as root!)-cd /+trap "chmod u+w $PWD/ro" EXIT+mkdir ro+chmod a-w ro+cd ro # and try again (with less patches to fetch)-darcs log --repo=http://darcs.net GNUmakefile --last 3+darcs log --repo=https://hub.darcs.net/darcs/darcs-screened GNUmakefile --last 3 # an absolute path should give an error-not darcs log --repo=http://darcs.net /GNUmakefile --last 3+not darcs log --repo=https://hub.darcs.net/darcs/darcs-screened /GNUmakefile --last 3 # also test that it works without any filename arguments-darcs log --repo=http://darcs.net --last 1+darcs log --repo=https://hub.darcs.net/darcs/darcs-screened --last 1+cd ..
tests/network/show_tags-remote.sh view
@@ -26,6 +26,8 @@ . lib                           # Load some portability helpers. . httplib +rm -rf R S+ darcs init      --repo R        # Create our test repos. darcs init      --repo S
tests/network/ssh.sh view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash # echo 'Comment this line out and run the script by hand'; exit 200  # . $(dirname $0)/../lib@@ -10,7 +10,7 @@ REMOTE_DARCS=$(which darcs)  # ================ Setting up remote repositories ===============-${SSH} ${REMOTE} "+${SSH} ${REMOTE} /bin/sh <<EOF rm -rf ${REMOTE_DIR} mkdir ${REMOTE_DIR} cd ${REMOTE_DIR}@@ -35,7 +35,7 @@  darcs clone testrepo testrepo-push darcs clone testrepo testrepo-send-"+EOF  # ================ Settings =============== echo ${DARCS_SSH_FLAGS}@@ -86,10 +86,48 @@  # ================ Checking darcs clone to ssh destination ==================" cd testrepo+ darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-clone # check that the clone was successful ${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/testrepo-clone/_darcs ]" ${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-clone/a ]"+# check that it fails with proper error message of target exists+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-clone 2> errlog+grep "Cannot create remote directory" errlog++# now with nested target directories+darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/x/y/testrepo-clone+# check that the clone was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/x/y/testrepo-clone/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/x/y/testrepo-clone/a ]"+# check that it fails with proper error message if remote dir exists+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/x/y 2> errlog+grep "Cannot create remote directory" errlog+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/x/y/testrepo-clone 2> errlog+grep "Cannot create remote directory" errlog++# now with trailing slash in target+darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/foo/testrepo-clone/+# check that the clone was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/foo/testrepo-clone/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/foo/testrepo-clone/a ]"+# check that it fails with proper error message if remote dir exists+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/foo/ 2> errlog+grep "Cannot create remote directory" errlog+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/foo/testrepo-clone/ 2> errlog+grep "Cannot create remote directory" errlog++# now with ssh:// URI+darcs clone . ${DARCS_SSH_FLAGS} ssh://${REMOTE}/${REMOTE_DIR}/bar/testrepo-clone/+# check that the clone was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/bar/testrepo-clone/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/bar/testrepo-clone/a ]"+# check that it fails with proper error message if remote dir exists+not darcs clone . ${DARCS_SSH_FLAGS} ssh://${REMOTE}/${REMOTE_DIR}/bar/ 2> errlog+grep "Cannot create remote directory" errlog+not darcs clone . ${DARCS_SSH_FLAGS} ssh://${REMOTE}/${REMOTE_DIR}/bar/testrepo-clone/ 2> errlog+grep "Cannot create remote directory" errlog+ cd ..  # ======== Checking push over ssh with a conflict ========="
tests/network/sshlib view
@@ -1,7 +1,11 @@-if [ x${REMOTE_DIR} = x ]; then-  REMOTE_DIR=/tmp/darcs-ssh-test$$-fi+# Note: we are connecting via ssh to the local machine, so the REMOTE_DIR is+# actually a local path. This requires that the user running the tests has ssh+# installed (client and server) and that they have a valid key pair and an ssh+# agent running, so they can do 'ssh localhost' w/o getting prompted for their+# passphrase every time. +REMOTE_DIR="$(pwd)/remote_dir"+ if [ x"${USE_PUTTY}" != x ]; then   DARCS_SSH=plink   export DARCS_SSH@@ -23,7 +27,7 @@ fi  if [ x${REMOTE} = x ]; then-  REMOTE=$(whoami)@localhost+  REMOTE=$(whoami)@localhost. fi  init_remote_repo() {
+ tests/no-prefs-template.sh view
@@ -0,0 +1,87 @@+#!/usr/bin/env bash+#+# Tests for `--[with|no]-prefs-template` options+#++. lib++has_template() {+  grep -v '^#' "$1" | grep -v '^\s*$'+}+++#########+## Tests for `init` command+#++rm -rf temp1+mkdir temp1+cd temp1+darcs init+test -f _darcs/prefs/boring+has_template _darcs/prefs/boring # by default boring file is filled with template+test -f _darcs/prefs/binaries+has_template _darcs/prefs/binaries # by default binaries file is filled with template+cd ..++rm -rf temp1+mkdir temp1+cd temp1+darcs init --with-prefs-template+test -f _darcs/prefs/boring+has_template _darcs/prefs/boring # boring file is filled with template+test -f _darcs/prefs/binaries+has_template _darcs/prefs/binaries # binaries file is filled with template+cd ..++rm -rf temp1+mkdir temp1+cd temp1+darcs init --no-prefs-template+test -f _darcs/prefs/boring+not has_template _darcs/prefs/boring # boring file is not filled with template+test -f _darcs/prefs/binaries+not has_template _darcs/prefs/binaries # binaries file not is filled with template+cd ..+++#########+## Tests for `clone` command+#++rm -rf temp1+mkdir temp1+cd temp1+darcs init+cd ..++rm -rf temp2+darcs clone temp1 temp2+cd temp2+test -f _darcs/prefs/boring+has_template _darcs/prefs/boring # by default boring file is filled with template+test -f _darcs/prefs/binaries+has_template _darcs/prefs/binaries # by default binaries file is filled with template+cd ..++rm -rf temp2+darcs clone --with-prefs-template temp1 temp2+cd temp2+test -f _darcs/prefs/boring+has_template _darcs/prefs/boring # boring file is filled with template+test -f _darcs/prefs/binaries+has_template _darcs/prefs/binaries # binaries file is filled with template+cd ..++rm -rf temp2+darcs clone --no-prefs-template temp1 temp2+cd temp2+test -f _darcs/prefs/boring+not has_template _darcs/prefs/boring # boring file is not filled with template+test -f _darcs/prefs/binaries+not has_template _darcs/prefs/binaries # binaries file not is filled with template+cd ..++++rm -rf temp1 temp2
tests/nodeps.sh view
@@ -13,7 +13,6 @@ cd tmp1 darcs init echo 'record no-ask-deps' >> _darcs/prefs/defaults-echo 'record ignore-times' >> _darcs/prefs/defaults echo 'a' > f darcs add f darcs rec -am 'fa' f
tests/nonewline.sh view
@@ -7,9 +7,7 @@ darcs init echo -n zig > foo darcs add foo-sleep 1 darcs record -a -m add_foo -A x-#sleep 1 echo -n zag >> foo darcs record --ignore-time -a -m mod_foo -A x cd ../temp2
tests/obliterate.sh view
@@ -104,3 +104,32 @@ cmp f g cd .. rm -rf temp1++# Part 4: obliterate with conflicting unrecorded changes++rm -rf R+darcs init R+cd R+echo orig > file+darcs record -lam thepatch+darcs replace -f changed orig file+echo changed > file+darcs whatsnew > ../whatsnew.orig+# make sure we have a change in the pending patch as well+grep replace ../whatsnew.orig++# non-interactive mode: should fail+not darcs obliterate -p thepatch -a 2>ERR+grep "Can't obliterate .* without reverting" ERR+darcs whatsnew > ../whatsnew.failed+diff ../whatsnew.orig ../whatsnew.failed++# interactive mode: user gets prompted+# first y to select patch, second y to confirm selection, n to refuse revert+echo yyn | darcs obliterate -p thepatch+darcs whatsnew > ../whatsnew.refuse+diff ../whatsnew.orig ../whatsnew.refuse+# first y to select patch, second y to confirm selection, third y to accept revert+echo yyy | darcs obliterate -p thepatch+# all unrecorded changes are reverted now+not darcs whatsnew
tests/oldfashioned.sh view
@@ -31,11 +31,14 @@ unpack_testdata many-files--old-fashioned-inventory mv many-files--old-fashioned-inventory old +find old | sort > untouched_old+ cd old not darcs add not darcs amend not darcs annotate not darcs apply+not darcs check not darcs diff not darcs dist not darcs mark@@ -56,10 +59,17 @@ not darcs unrevert cd .. +find old | sort > touched_old+diff untouched_old touched_old+ ## test that darcs can clone, pull and send (from, to) a remote ## old-fashioned repository.  darcs clone old hashed++# check that the "trees" coincide+diff old/foo hashed/foo+ cd hashed  test -e _darcs/hashed_inventory # issue1110: clone hashed@@ -77,11 +87,15 @@ cd ..  # issue2253 - darcs log FILE should not build patch index in an OF repo-cd old-darcs log x+darcs log x --repo=old +# note: with --no-ignore-times darcs add/rec create an index+find old | grep -v '_darcs/index' | sort > touched_old+diff untouched_old touched_old+ # issue1584 - darcs optimize --upgrade +cd old echo x > foo # Unrecorded change darcs optimize upgrade darcs check
tests/optimize.sh view
@@ -5,7 +5,7 @@  ## test that darcs optimize reorder works -rm -rf test1+rm -rf test1 test1a mkdir test1 cd test1 darcs init@@ -19,15 +19,68 @@ # make the tag unclean echo y | darcs amend -p foo_tag -a --author me not grep 'Starting with inventory' _darcs/hashed_inventory+# save repo for next test+darcs clone . ../test1a+# the actual test darcs optimize reorder | grep -i "done" # check it is again clean grep 'Starting with inventory' _darcs/hashed_inventory cd .. +## optimize reorder --deep++cd test1a+# we have an unclean tag foo_tag; add another tag+darcs tag bar_tag+darcs optimize reorder | grep -i "done"+# this makes bar_tag clean:+# neither foo_tag nor add_foo are in the head inventory+not grep add_foo _darcs/hashed_inventory+not grep foo_tag _darcs/hashed_inventory+# but foo_tag remains dirty+# (this greps for a lone inventory hash)+grep -E '^[0-9]+-[0-9a-f]+$' _darcs/hashed_inventory > ihash+zgrep add_foo _darcs/inventories/$(cat ihash)+# now do the deep reorder+darcs optimize reorder --deep+# add_foo is not in the parent inventory+grep -E '^[0-9]+-[0-9a-f]+$' _darcs/hashed_inventory > ihash+not zgrep add_foo _darcs/inventories/$(cat ihash)+# but instead in the grandparent+zgrep -E '^[0-9]+-[0-9a-f]+$' _darcs/inventories/$(cat ihash) > ihash2+zgrep add_foo _darcs/inventories/$(cat ihash2)+cd ..+ ## issue2388 - optimize fails if no patches have been recorded  rm -rf test2 darcs init test2 cd test2 darcs optimize clean+cd ..++## optimize compress/uncompress++find_hashed_files() {+  find _darcs | grep -E '([0-9]{10}-)?[0-9a-f]{64}'+}++rm -rf test3+darcs init test3+cd test3+echo one > file+darcs record -lam one+darcs tag mytag # so we get a hashed inventory file+# check all hashed files are compressed+find_hashed_files | xargs gunzip -t+# uncompress+darcs optimize uncompress+# check all hashed files are uncompressed+find_hashed_files | while read f; do+  not gunzip -t $f+done+# compress+darcs optimize compress+# check all hashed files are compressed+find_hashed_files | xargs gunzip -t cd ..
+ tests/order_of_resolutions.sh view
@@ -0,0 +1,76 @@+#!/usr/bin/env bash++. lib++rm -rf B R S S1 S2 C1 C2++darcs init B+cd B+echo '++n S' > ./a+darcs record -l ./a -am base+cd ..++darcs clone B R+cd R+darcs replace K u ./a+darcs record -am p1+echo 'u+Q L+P n++n S' > ./a+darcs record -am p2+cd ..++darcs clone B S1+cd S1+echo 'i d+n S' > ./a+darcs record -am p3+cd ..++darcs clone B S2+cd S2+echo '+C+h Z' > ./a+darcs record -am p4+cd ..++darcs clone S1 S+cd S+darcs pull --allow -a ../S2+echo '++ll+G z+h Z' >./a+darcs record -am p5+cd ..++darcs clone B C1+cd C1+darcs pull --allow -a -p p2 ../R+darcs pull --allow -a -p p1 ../R+darcs pull --allow -a -p p3 ../S+darcs pull --allow -a -p p4 ../S+darcs pull --allow -a -p p5 ../S+darcs mark+cd ..++darcs clone B C2+cd C2+darcs pull --allow -a -p p1 ../R+darcs pull --allow -a -p p3 ../S+darcs pull --allow -a -p p2 ../R+darcs pull --allow -a -p p4 ../S+darcs pull --allow -a -p p5 ../S+darcs mark+cd ..++darcs whatsnew --repo C1 > markup-C1+darcs whatsnew --repo C2 > markup-C2++diff markup-C1 markup-C2
tests/patch-index-creation.sh view
@@ -59,14 +59,14 @@  rm -rf repo repo2 unpack_testdata simple-v1-echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 +echo 'yes' | darcs convert darcs-2 repo repo2  cd repo2 darcs show patch-index | grep 'Patch Index is not yet created.' # convert cd ..  rm -rf repo repo2 unpack_testdata simple-v1-echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 --with-patch-index+echo 'yes' | darcs convert darcs-2 repo repo2 --with-patch-index cd repo2 darcs show patch-index | grep 'Patch Index is in sync with repo.' # convert --patch-index
− tests/pending_has_conflicts.sh 
@@ -1,55 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init--date > date.t-date > date_moved.t--write_buggy_pending () {-cat > _darcs/patches/pending <<EOF-{-addfile ./date.t-addfile ./date_moved.t-move ./date.t ./date_moved.t-}-EOF-}-write_buggy_pending--echo now watch the fireworks as all sorts of things fail-not darcs whatsnew 2>&1 | tee out-grep 'pending has conflicts' out--echo pending should now be fixed but there are no changes-not darcs whatsnew--write_buggy_pending--darcs revert -a 2>&1 | tee out-grep 'pending has conflicts' out--echo pending should now be emptied-darcs revert -a--write_buggy_pending--not darcs record -a -m foo 2>&1 | tee out-grep 'pending has conflicts' out--darcs changes -v--darcs repair 2>&1 | tee out-grep 'The repository is already consistent' out--write_buggy_pending--darcs repair 2>&1 | tee out-grep 'The repository is already consistent' out--cd ..-rm -rf temp1
tests/perms.sh view
@@ -10,7 +10,6 @@ echo record author me > _darcs/prefs/defaults echo ALL all >> _darcs/prefs/defaults echo ALL verbose >> _darcs/prefs/defaults-echo ALL ignore-times >> _darcs/prefs/defaults touch foo darcs add foo darcs record -m add_foo
tests/posthook.sh view
@@ -23,27 +23,14 @@ cd .. rm -rf temp1 -# POSIX-only section-# -----------------------------------------------------------------------# Things below this section do not appear to work on Windows.-# Pending further investigation at http://bugs.darcs.net/issue1813--if echo $OS | grep -i windows; then-  exit 0-fi- # Check that DARCS_PATCHES_XML works rm -rf R S                      # another script may have left a mess darcs init      --repo R        # Create our test repos. darcs init      --repo S        # Create our test repos.  cd R-echo 'echo $DARCS_PATCHES_XML' > hook-darcs record -lam 'hook'-chmod u+x hook cat > _darcs/prefs/defaults << END-apply run-posthook-apply posthook ./hook+apply posthook printenv DARCS_PATCHES_XML END cd ..
tests/prefs.sh view
@@ -5,7 +5,6 @@ mkdir temp1 cd temp1 darcs initialize-echo ALL ignore-times >> _darcs/prefs/defaults cp _darcs/prefs/boring .boring darcs add .boring darcs setpref boringfile .boring
tests/printer.sh view
@@ -52,8 +52,12 @@ # skip ^@ and ^Z since they make darcs treat the file as binary # don't put any space control chars at end of line # ascii control chars are escaped with ^-test_line $(printf '\x01\x02\x03\x04\x05\x06\x07\x08\x0B\x0C\x0D\x0E')\-          '[_^A_][_^B_][_^C_][_^D_][_^E_][_^F_][_^G_][_^H_][_^K_][_^L_][_^M_][_^N_]'+test_line $(printf '\x01\x02\x03\x04\x05\x06\x07\x08\x0B\x0C\x0E')\+          '[_^A_][_^B_][_^C_][_^D_][_^E_][_^F_][_^G_][_^H_][_^K_][_^L_][_^N_]'+# this doesn't seem to work on windows, no idea why:+if ! os_is_windows; then+  test_line $(printf '\x0D') '[_^M_]'+fi test_line $(printf '\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19')\           '[_^O_][_^P_][_^Q_][_^R_][_^S_][_^T_][_^U_][_^V_][_^W_][_^X_][_^Y_]' test_line $(printf '\x1B') '[_^[_]'
tests/pull.sh view
@@ -31,14 +31,11 @@ darcs record --repodir ./temp2 -a -m foo  # set up client repo for failure-if echo $OS | grep -i windows; then-    echo this test does not work on windows because it-    echo is not possible to chmod -r-elif whoami | grep root; then-    echo root never gets permission denied-else+if ! os_is_windows; then     chmod a-rwx ./temp1/one # remove all permissions-    not darcs pull --repodir ./temp1 -a 2> err+    # this fails only with --ignore-times because otherwise the index+    # will be used+    not darcs pull --repodir ./temp1 -a --ignore-times 2> err     chmod u+rwx temp1/one # restore permission     grep 'permission denied' err     rm -rf temp1/one@@ -84,7 +81,6 @@ rm -rf temp2 darcs get --to-patch B temp1 temp2 cd temp2-sleep 1 # So that rollback won't have same timestamp as get. darcs rollback -p BB -a darcs record -am unB darcs pull -a ../temp1 2> err2
tests/pull_complement.sh view
@@ -52,7 +52,7 @@     set -ev     sed -e "$1" foo > foo.tmp     mv foo.tmp foo-    darcs record -a --ignore-times -m "$2"+    darcs record -a -m "$2" }  cd temp1
tests/push.sh view
@@ -4,16 +4,6 @@  . lib -slash() {-if echo $OS | grep -q -i windows; then-    echo -n \\-else-    echo -n /-fi-}--DIR="`pwd`"- rm -rf temp1 temp2 mkdir temp1 cd temp1@@ -48,7 +38,7 @@ # Before trying to pull from self, defaultrepo does not exist test ! -e _darcs/prefs/defaultrepo # return special message when you try to push to yourself-not darcs push -a "$DIR`slash`temp1" 2> log+not darcs push -a ../temp1 2> log grep -i "cannot push from repository to itself" log # and don't update the default repo to be the current dir test ! -e _darcs/prefs/defaultrepo
tests/rebase-changes.sh view
@@ -37,4 +37,4 @@ # now we should see a conflict with change 2 # which removes the line "first" darcs rebase changes --verbose | grep "first"-darcs rebase changes --verbose | grep "conflicts:"+darcs rebase changes --verbose | grep "conflictor"
tests/rebase-keeps-deps-on-amend.sh view
@@ -33,15 +33,15 @@  echo 'A' > A darcs add A-darcs rec -am"A" --ignore-times+darcs rec -am"A"  echo 'B' > B darcs add B-darcs rec -am"B" --ignore-times+darcs rec -am"B"  echo 'C' > C darcs add C-echo 'yyy' | darcs rec -am"C" --ignore-times --ask-deps+echo 'yyy' | darcs rec -am"C" --ask-deps  echo 'yyd' | darcs rebase suspend
tests/rebase-keeps-deps.sh view
@@ -33,15 +33,15 @@  echo 'A' > A darcs add A-darcs rec -am"A" --ignore-times+darcs rec -am"A"  echo 'B' > B darcs add B-darcs rec -am"B" --ignore-times+darcs rec -am"B"  echo 'C' > C darcs add C-echo 'yyy' | darcs rec -am"C" --ignore-times --ask-deps+echo 'yyy' | darcs rec -am"C" --ask-deps  echo 'yydy' | darcs rebase suspend
tests/rebase-move.sh view
@@ -32,9 +32,9 @@ darcs init echo 'wibble' > wibble darcs add wibble-darcs rec -am"wibble" --ignore-times+darcs rec -am"wibble" echo 'wobble' > wibble-darcs rec -am"wobble" --ignore-times+darcs rec -am"wobble"  echo 'yd' | darcs rebase suspend darcs mv wibble wobble
tests/rebase-new-style.sh view
@@ -58,7 +58,6 @@ optimize compress optimize uncompress optimize relink-optimize pristine mark-conflicts repair convert export
tests/rebase-tag.sh view
@@ -32,7 +32,7 @@ darcs init echo 'wibble' > wibble darcs add wibble-darcs rec -am"wibble" --ignore-times+darcs rec -am"wibble" echo 'yy' | darcs rebase suspend darcs tag 'ugh' darcs check
+ tests/rebase-unsuspend-quit.sh view
@@ -0,0 +1,45 @@+#!/bin/sh -e+##+## Test rebase unsuspend, with quit+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init+touch foo+darcs rec -lam 'add foo'++touch bar+darcs rec -lam 'add bar'++touch baz+darcs rec -lam 'add baz'++echo 'yyyy' | darcs rebase suspend++echo yyq | darcs rebase unsuspend 2> log+grep "3 suspended patches" log
tests/rebase-unsuspend-to-patch.sh view
@@ -41,7 +41,8 @@  echo 'yyyy' | darcs rebase suspend -darcs rebase unsuspend --to-patch 'bar' -a+darcs rebase unsuspend --to-patch 'bar' -a 2>log darcs changes | grep 'add foo' darcs changes | grep 'add bar' darcs changes | not grep 'add baz'+grep "1 suspended patch" log
tests/rebase-warns-lost-deps.sh view
@@ -33,15 +33,15 @@  echo 'A' > A darcs add A-darcs rec -am"patch A" --ignore-times+darcs rec -am"patch A"  echo 'B' > B darcs add B-darcs rec -am"patch B" --ignore-times+darcs rec -am"patch B"  echo 'C' > C darcs add C-echo 'yyy' | darcs rec -am"patch C" --ignore-times --ask-deps+echo 'yyy' | darcs rec -am"patch C" --ask-deps  echo 'ydy' | darcs rebase suspend
+ tests/rebase-with-conflicting-unrecorded.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash+# rebase with conflicting unrecorded changes+# TODO repeat test for rebase pull and rebase apply++. lib++rm -rf R+darcs init R+cd R+echo orig > file+darcs record -lam thepatch+darcs replace -f changed orig file+echo changed > file+darcs whatsnew > ../whatsnew.orig+# make sure we have a change in the pending patch as well+grep replace ../whatsnew.orig++# non-interactive mode: should fail+not darcs rebase suspend -p thepatch -a 2>ERR+grep "Can't suspend .* without reverting" ERR+darcs whatsnew > ../whatsnew.failed+diff ../whatsnew.orig ../whatsnew.failed++# interactive mode: user gets prompted+# first y to select patch, second y to confirm selection, n to refuse revert+echo yyn | darcs rebase suspend -p thepatch+darcs whatsnew > ../whatsnew.refuse+diff ../whatsnew.orig ../whatsnew.refuse+# first y to select patch, second y to confirm selection, third y to accept revert+echo yyy | darcs rebase suspend -p thepatch+# all unrecorded changes are reverted now+not darcs whatsnew
tests/record.sh view
@@ -13,14 +13,10 @@ darcs record -am foo --ask-deps | grep -i "Ok, if you don't want to record anything, that's fine!"  # RT#476 - --ask-deps works when there are no patches-if echo $OS | grep -i windows; then-  echo This test does not work on Windows-else-  touch t.f-  darcs add t.f-  darcs record  -am add-  echo a | darcs record  -am foo --ask-deps | grep -i 'finished recording'-fi+touch t.f+darcs add t.f+darcs record -am add+echo a | darcs record  -am foo --ask-deps | grep -i 'finished recording'  # RT#231 - special message is given for nonexistent directories not darcs record -am foo not_there.txt > log 2>&1@@ -82,9 +78,7 @@ darcs init echo zig > foo darcs add foo-sleep 1 darcs record -a -m add_foo -A x-#sleep 1 echo zag >> foo darcs record --ignore-time -a -m mod_foo -A x cd ../foo2
tests/repair.sh view
@@ -24,8 +24,8 @@ # remove each hashed pristine file one at a time for f in $(ls _darcs/pristine.hashed/*); do   rm $f-  not darcs check-  darcs repair | grep -i "fixing pristine"+  not darcs check --no-cache+  darcs repair --no-cache | grep -i "fixing pristine" done  cd ..@@ -176,6 +176,6 @@ darcs record -am 'Move d/f to e/f.' rm _darcs/pristine.hashed/*     # Make the repository bogus cp -r _darcs archive-not darcs check+not darcs check --no-cache diff -r _darcs archive cd ..
tests/replace.sh view
@@ -9,15 +9,24 @@  echo "X X X" > foo echo $'A A,A\tA,A\vA' >> foo+echo "aä" >> foo+echo $'\02' >> foo darcs rec -alm "Added"  # These should fail until replace handles tokens and # token-chars with leteral spaces in them-darcs replace ' X ' ' XX ' --token-chars '[ X]' foo && exit 1 || true-darcs replace $'A A'  'aaa' --token-chars '[^,]' foo && exit 1 || true-darcs replace $'A\tA' 'aaa' --token-chars '[^,]' foo && exit 1 || true-darcs replace $'A\vA' 'aaa' --token-chars '[^,]' foo && exit 1 || true+not darcs replace ' X ' ' XX ' --token-chars '[ X]' foo+not darcs replace $'A A'  'aaa' --token-chars '[^,]' foo+not darcs replace $'A\tA' 'aaa' --token-chars '[^,]' foo+not darcs replace $'A\vA' 'aaa' --token-chars '[^,]' foo +# These should fail since darcs cannot handle non-ASCII token chars+# nor non-printable ones+not darcs replace 'X' 'ä' --token-chars '[Xä]' foo+not darcs replace 'ä' 'X' --token-chars '[ä]' foo+not darcs replace $'\02' 'X' --token-chars $'[X\02]' foo+not darcs replace 'X' $'\02' --token-chars $'[X\02]' foo+ # Check that replace is not fooled by duplicate file names # (i.e. not trying to performe the replace twice in the same file) darcs replace X Y foo foo@@ -38,7 +47,7 @@ echo "x" > foo darcs rec -am xx echo "y" > foo-darcs replace --ignore-times x y foo+darcs replace x y foo  # this fails echo "hej" > foo@@ -68,9 +77,8 @@  echo a b a b a b > A darcs add A-if darcs replace a c A | grep Skipping; then-    exit 1-fi+darcs replace a c A > LOG+not grep Skipping LOG cd ..  rm -fr temp1@@ -85,9 +93,8 @@ darcs add A darcs record --all --name=p1 darcs mv A B-if darcs replace a c B | grep Skipping; then-    exit 1-fi+darcs replace a c B > LOG+not grep Skipping LOG cd ..  rm -fr temp1
tests/repoformat.sh view
@@ -21,7 +21,7 @@  corrupt_format_file() {   # mimic format file corruption as in issue2650-  sed -i 's/gobbledygook/Unknown format: gobbledygook/' future/_darcs/format+  sed -i 's/gobbledygook/Unknown format: gobbledygook/' $1/_darcs/format }  # check the rules for reading and writing@@ -57,27 +57,30 @@ # add in garbage repo cd garbage touch toto++cp _darcs/format before not darcs add toto 2> log grep -i "read repository.*unknown format" log+diff before _darcs/format # issue2650 cd ..  # rebase suspend in garbage repo cd garbage+cp _darcs/format before not darcs rebase suspend --last=1 2> log grep -i "read repository.*unknown format" log-# issue2650-not grep 'Unknown format' _darcs/format+diff before _darcs/format # issue2650 cd .. }  test_garbage  # corrupt once-corrupt_format_file+corrupt_format_file garbage test_garbage # corrupt multiple times-corrupt_format_file-corrupt_format_file+corrupt_format_file garbage+corrupt_format_file garbage test_garbage  @@ -89,11 +92,16 @@ # --to-match is needed because of bug### rm -rf temp1 darcs get future temp1 --to-match "name titi"+# fresh clone should fix corrupt format cd temp1+not grep 'Unknown format' _darcs/format # issue2650 darcs changes+not grep 'Unknown format' _darcs/format # issue2650 touch toto darcs add toto+not grep 'Unknown format' _darcs/format # issue2650 darcs record -am 'blah'+not grep 'Unknown format' _darcs/format # issue2650 cd ..  # pull from future repo: ok@@ -103,6 +111,7 @@ darcs init darcs pull ../future -a darcs changes | grep titi+not grep 'Unknown format' _darcs/format # issue2650 cd ..  # apply in future repo: !ok@@ -114,9 +123,11 @@ darcs tag -m "just a patch" darcs send -a --context=empty-context -o ../bundle.dpatch . cd ../future+cp _darcs/format before not darcs apply ../bundle.dpatch 2> log cat log grep -i "write repository.*unknown format" log+diff before _darcs/format # issue2650 cd ..  # record in future repo: !ok@@ -128,19 +139,19 @@  # rebase suspend in future repo cd future+cp _darcs/format before not darcs rebase suspend --last=1 2> log grep -i "write repository.*unknown format" log-# issue2650-not grep 'Unknown format' _darcs/format+diff before _darcs/format # issue2650 cd .. }  test_future  # corrupt once-corrupt_format_file+corrupt_format_file future test_future # corrupt multiple times-corrupt_format_file-corrupt_format_file+corrupt_format_file future+corrupt_format_file future test_future
tests/resolve-conflicts-explicitly.sh view
@@ -1,3 +1,4 @@+#!/usr/bin/env bash # Test that we can resolve a conflict by explicitly depending on # the conflicting patches, thereby accepting the "default" resolution # (i.e. not to apply both) as correctly resolving the conflict.
tests/revert.sh view
@@ -29,7 +29,7 @@  echo "nyy" | darcs revert -DARCS_DONT_COLOR=1 darcs wh > whatsnew+darcs wh > whatsnew cat > correct <<EOF hunk ./foo 2 -b@@ -46,9 +46,10 @@ darcs add bar darcs replace hello goodbye bar foo -echo "cnnnyy/y" | tr / \\012 | darcs revert+# revert only the last of 4 changes which is the replace in ./foo+echo "nnnyy" | darcs revert -DARCS_DONT_COLOR=1 darcs wh > whatsnew+darcs wh > whatsnew cat > correct <<EOF addfile ./bar hunk ./bar 1
tests/sametwice.sh view
@@ -8,7 +8,6 @@ echo record author me > _darcs/prefs/defaults echo ALL all >> _darcs/prefs/defaults echo ALL verbose >> _darcs/prefs/defaults-echo ALL ignore-times >> _darcs/prefs/defaults touch foo darcs add foo darcs whatsnew
tests/send-external.sh view
@@ -1,11 +1,6 @@ #!/usr/bin/env bash . ./lib -# The argument quoting in the test script below breaks on Windows paths--DARCS_EDITOR=echo-export DARCS_EDITOR- rm -rf temp1 temp2 mkdir temp1 temp2 @@ -19,39 +14,14 @@ darcs add foobar darcs rec -a -m add-foobar -cat > saveit.sh <<EOF-#!/bin/sh-# send-mail1.sh: Test sendmail command for darcs send 1-# 2008-Oct-06 22.25 / TN-set -ev-echo all: \$0 "\$@" >>saved.out-echo \$6 contains: >>saved.out-ls -ltr >>saved.out-cat "\$6" >>saved.out-echo End of \$6 contents >>saved.out-grep add-foobar \$6-CNT=0-while [ "\$#" != "0" ]; do-  CNT=`expr \$CNT + 1`-  echo \$0: arg[\$CNT] = \"\$1\" >>saved.out-  shift-done-echo \$0: Total \$CNT arguments >>saved.out-echo \$0: Input: >>saved.out-cat >>saved.out-echo \$0: End of input: >>saved.out-EOF--chmod +x saveit.sh+cp $TESTBIN/sendmail.hs . -# foobar-darcs send --mail\+darcs send --mail \     --author=me -a --to=random@random \-    --sendmail-command='bash ./saveit.sh %s %t %c %b %f %a %S %t %C %B %F %A something' ../temp2+    --sendmail-command="runghc sendmail.hs %s %t %c %b %f %a %S %T %C %B %F %A something" ../temp2  cat saved.out grep add-foobar saved.out grep 'addfile ./foobar' saved.out  cd ..-rm -rf temp1 temp2
tests/send-output-v1.sh view
@@ -39,8 +39,7 @@ cd repo darcs send --no-minimize -o repo.dpatch -a ../empty -day=$(grep "Date: " $TESTDATA/simple-v1.dpatch | head -n 1 | cut -f1-3 -d' ')-diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/simple-v1.dpatch repo.dpatch+compare_bundles $TESTDATA/simple-v1.dpatch repo.dpatch cd ..  # context-v1 tests that we are including some context lines in hunk patches@@ -48,6 +47,6 @@ unpack_testdata context-v1 cd repo darcs send --no-minimize -o repo.dpatch -a ../empty-day=$(grep "Date: " $TESTDATA/context-v1.dpatch | head -n 1 | cut -f1-3 -d' ')-diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/context-v1.dpatch repo.dpatch++compare_bundles $TESTDATA/context-v1.dpatch repo.dpatch cd ..
tests/send-output-v2.sh view
@@ -39,16 +39,13 @@ cd repo darcs send --no-minimize -o repo.dpatch -a ../empty -day=$(grep "Date: " $TESTDATA/simple-v2.dpatch | head -n 1 | cut -f1-3 -d' ')-diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/simple-v2.dpatch repo.dpatch+compare_bundles $TESTDATA/simple-v2.dpatch repo.dpatch cd .. -# context-v1 tests that we are including some context lines in hunk patches+# context-v2 tests that we are including some context lines in hunk patches rm -rf repo unpack_testdata context-v2 cd repo darcs send --no-minimize -o repo.dpatch -a ../empty--day=$(grep "Date: " $TESTDATA/context-v2.dpatch | head -n 1 | cut -f1-3 -d' ')-diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/context-v2.dpatch repo.dpatch+compare_bundles $TESTDATA/context-v2.dpatch repo.dpatch cd ..
tests/send.sh view
@@ -1,9 +1,6 @@ #!/usr/bin/env bash . ./lib -DARCS_EDITOR=echo-export DARCS_EDITOR- rm -rf temp1 temp2 mkdir temp1 temp2
− tests/set-default-hint.sh 
@@ -1,54 +0,0 @@-#!/usr/bin/env bash-## Test that set-default hint messages are produced at the right times-##-## Copyright (C) 2011 Ganesh Sittampalam-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R1 R2 R3                 # Another script may have left a mess.--darcs init      --repo R1-darcs get R1 R2-darcs get R1 R3--HINTSTRING="issue the same command with the --set-default flag"--cd R3-for command in pull push send-do-   opt=-   test "$command" = "send" && opt=-O--   # R1 should be the default for R3-   darcs $command $opt ../R1 | not grep "$HINTSTRING"-   darcs $command $opt ../R2 | grep "$HINTSTRING"--   # can disable message on the command-line-   darcs $command $opt --no-set-default ../R2 | not grep "$HINTSTRING"--   # or using defaults-   echo "$command no-set-default" >> ../.darcs/defaults-   darcs $command $opt ../R2 | not grep "$HINTSTRING"--   darcs $command $opt --set-default ../R2 | not grep "$HINTSTRING"-   darcs $command $opt --set-default ../R1 | not grep "$HINTSTRING"-done
tests/show_files.sh view
@@ -49,7 +49,7 @@ darcs add d/3 d/4 check_manifest "" "" "--no-pending" check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending"-darcs record -A test --all --name "patch 1" --skip-long-comment+darcs record --all --name "patch 1" --skip-long-comment check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending" @@ -65,7 +65,7 @@ darcs mv c/2 c/1 check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" check_manifest "a b c/1 e/3 e/4" "c e" "--pending"-darcs record -A test --all --name "patch 2" --skip-long-comment+darcs record --all --name "patch 2" --skip-long-comment check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" check_manifest "a b c/1 e/3 e/4" "c e" "--pending" @@ -75,7 +75,7 @@ darcs remove c check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" check_manifest "a b e/3 e/4" "e" "--pending"-darcs record -A test --all --name "patch 3" --skip-long-comment+darcs record --all --name "patch 3" --skip-long-comment check_manifest "a b e/3 e/4" "e" "--no-pending" check_manifest "a b e/3 e/4" "e" "--pending" @@ -83,13 +83,13 @@ darcs mv b2 b3 check_manifest "a b e/3 e/4" "e" "--no-pending" check_manifest "a b3 e/3 e/4" "e" "--pending"-darcs record -A test --all --name "patch 3" --skip-long-comment+darcs record --all --name "patch 3" --skip-long-comment check_manifest "a b3 e/3 e/4" "e" "--no-pending" check_manifest "a b3 e/3 e/4" "e" "--pending"  cd ..-rm -rf temp +rm -rf R darcs init --repo R cd R @@ -113,4 +113,3 @@ not darcs show files --pending --patch "bar"  cd ..-rm -rf R
tests/show_tags.sh view
@@ -5,7 +5,6 @@ mkdir temp1 cd temp1 darcs initialize-echo ALL ignore-times >> _darcs/prefs/defaults echo A > foo darcs add foo darcs record -a -m AA -A x
tests/switch-encoding.sh view
@@ -3,6 +3,8 @@ switch_to_utf8_locale lc_utf8=$LC_ALL +rm -rf E U+ darcs init E darcs clone E U
+ tests/test-untestable.sh view
@@ -0,0 +1,81 @@+#!/bin/sh -e+##+## Tests with untestable states+##+## Copyright (C) 2015 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++cat > runtest.hs <<END+import Control.Monad+import System.Exit+import System.IO+import System.Directory+main = do+  exists <- doesFileExist "teststatus"+  when exists $ do+    n <- liftM read (readFile "teststatus")+    when (n /= 0) (exitWith (ExitFailure n))+END++ghc --make -o runtest runtest.hs++export RUNTEST=`pwd`/runtest++mkdir R+cd R+darcs init++echo 0 > teststatus+darcs add teststatus+darcs rec -am "teststatus=0"++echo 125 > teststatus+darcs rec -am "teststatus=125"++echo 1 > teststatus+darcs rec -am "teststatus=1"++darcs test --linear "$RUNTEST" > results++grep -A10 "These patches jointly trigger the failure" results > patchlist++grep "teststatus=1" patchlist+grep "teststatus=125" patchlist+not grep "teststatus=0" patchlist++darcs test --backoff "$RUNTEST" > results++grep -A10 "These patches jointly trigger the failure" results > patchlist++grep "teststatus=1" patchlist+grep "teststatus=125" patchlist+not grep "teststatus=0" patchlist++darcs test --bisect "$RUNTEST" > results++grep -A10 "These patches jointly trigger the failure" results > patchlist++grep "teststatus=1" patchlist+grep "teststatus=125" patchlist+not grep "teststatus=0" patchlist
tests/trackdown-bisect.sh view
@@ -1,4 +1,4 @@-#!/bin/env bash+#!/usr/bin/env bash # A test for test --linear, test --bisect and test --backoff. # In general it construct various repositories and try # to find the last recent failing patch and match it with@@ -53,7 +53,6 @@ # Section with test-cases ############################################################################# -# TEST01: Repo with success in the half testTrackdown() { make_repo_with_test $1 if darcs test $test_args "$test_cmd" | is_found_good_patch $2; then@@ -65,6 +64,17 @@ cleanup_repo_after } +testTrackdownNoPasses() {+make_repo_with_test $1+if darcs test $test_args "$test_cmd" | grep "Noone passed the test"; then+    echo "ok 1"+else+    echo "not ok 1. The trackdown should report 'Noone passed the test'."+    exit 1+fi+cleanup_repo_after+}+ # TEST01: Repo with success in the half test01() { testTrackdown '[1,1,0,0,0]' 3@@ -72,7 +82,7 @@  # TEST02: Repo without success condition test02() { -testTrackdown '[0,0,0,0,0]' 1+testTrackdownNoPasses '[0,0,0,0,0]' }  # TEST03: Repo with success condition at before last patch
tests/uniqueoptions.sh view
@@ -1,21 +1,14 @@ #!/usr/bin/env bash-echo-echo Checking that each command expects each option only once-echo+# Check that each command expects each option only once  . ./lib -if echo $OS | grep -i windows; then-    echo Noone knows how to handle newlines under cygwin, so we skip this test-    exit 0-fi- rm -rf temp1 mkdir temp1 cd temp1  for i in `darcs --commands | grep -v -- -- | xargs echo`; do-    echo -n Checking $i... ' '+    echo -n "Checking $i... "     # only output actual command options, i.e. lines that contain a --     darcs $i --help | grep -- "--" | sort > $i     uniq $i > uni$i@@ -29,5 +22,3 @@ done  cd ..-rm -rf temp1-
tests/unrevert.sh view
@@ -121,7 +121,6 @@ darcs init temp1 cd temp1 -echo ALL ignore-times > _darcs/prefs/defaults echo a > foo darcs record -lam aa echo b > foo
tests/utf8-display.sh view
@@ -26,8 +26,6 @@  . lib -abort_windows # TODO make this work- switch_to_utf8_locale  #is now the default, must use DARCS_ESCAPE_8BIT to disable
tests/whatsnew.sh view
@@ -155,7 +155,7 @@ cd temp1 touch foo darcs add foo-darcs rec -m t1 -a -A tester+darcs rec -m t1 -a echo 1 >> foo darcs what -s | grep -v No\ changes darcs what -l | grep -v No\ changes
tests/workingdir.sh view
@@ -30,6 +30,7 @@ # try to move a file that we don't have the right to do darcs get temp1 temp2 --to-patch aa cd temp2+trap "test -d $PWD/a && chmod u+w $PWD/a" EXIT chmod u-w a darcs pull -a test -e b