packages feed

darcs 2.14.5 → 2.16.1

raw patch · 478 files changed

+27814/−17198 lines, 478 filesdep +conduitdep +constraintsdep +cryptonitedep −HTTPdep −cryptohashdep −graphvizdep ~QuickCheckdep ~Win32dep ~basesetup-changedbinary-added

Dependencies added: conduit, constraints, cryptonite, http-conduit, http-types, leancheck, memory, temporary, test-framework-leancheck

Dependencies removed: HTTP, cryptohash, graphviz, random

Dependency ranges changed: QuickCheck, Win32, base, binary, directory, network-uri, shelly, unix-compat, vector

Files

CHANGELOG view
@@ -1,3 +1,231 @@+Darcs 2.16.1, 14 August 2020++  * Building:+    * Drop support for building with ghc-8.0+    * Allow clean (warning-free) builds with all ghc versions from 8.2.2 up+      to ghc-8.10.1+    * Various dependency updates+    * Remove sdist and postConf hooks from Setup.hs+    * move -DHAVE_MAPI from Setup.hs to darcs.cabal+    * Recommended way to build is using cabal-install >= 3.0+    * The source tree now contains a cleaned-up version of shelly-1.7.1+      (locally named shelly-1.7.1.1) which we need to run our test suite.+      Unfortunately, later versions break compatibility on Windows and+      keeping the dependency fixed to 1.7.1 would mean we cannot support+      newer ghc versions.++  * Preliminary UNSTABLE support for a new patch theory named "darcs-3",+    largely based on the pioneering work of Ian Lynagh for 'camp'.++    Please note that this format is not yet officially supported: some+    features (like conversion from older formats) are still missing, and we+    have not yet finalized the on-disk format. You should NOT use it for any+    serious work yet.++    The new theory finally solves all the well-known consistency problems+    that plagued the earlier ones, and thus fixes a number of issues+    (including issue1401 and issue2605) that have been outstanding for many+    years. It also reduces the worst case asymptotic runtime for commutation+    and merging from exponential to merely quadratic in the number of+    patches involved.++    One of the reasons we are confident this new theory and its+    implementation is sound, i.e. respect all required properties, is that+    we have improved our test case generator for sequences of patches. It+    now generates all possible conflict scenarios. Since the new theory no+    longer has worst case exponential runtime, we can and did test all+    required properties and invariants with a large number of generated test+    cases (up to 100000).++  * The internals of how 'darcs rebase' stores and handles suspended patches+    and their "fixups" has been changed in incompatible ways. This means+    that if you have a rebase in progress started with darcs < 2.16, you+    will first need to use the new 'darcs rebase upgrade' command to upgrade+    the suspended patches to the new format. If you start a rebase with+    darcs-2.16, then earlier darcs versions will not work with that repo,+    until you have finished the rebase.++    The new implementation fixes a lot of bugs (including outright crashes+    in some situations). The behavior when conflicted patches are suspended+    is much better now, though there are still a few corner cases where the+    behavior can be quite unintuitive, especially when complicated conflicts+    are suspended.++    A number of limitations regarding repositories with a rebase in progress+    have been lifted; in particular, push, pull, and clone between repos can+    now be done regardless of whether any of the repos have a rebase in+    progress or not.++  * The way conflict markup is generated has been cleaned up and refactored.+    The main user-visible improvement is that darcs now reliably /either/+    marks a conflict /or/ keeps the default resolution (i.e. remove both+    changes) and reports the conflicts that it cannot mark. Previously,+    conflicts that could not be properly marked (roughly all conflicts+    involving changes other than hunks, e.g. replaces and file or dir adds,+    removes, and renames) would be silently "half-resolved" in favour of one+    of the alternatives. This could be pretty confusing, the more so since+    it was hard to predict which of the conflicting alternatives was chosen.++  * Complete re-implementation of the way in which the pending patch is+    updated after record and amend. This fixes a number of problems with+    pending becoming corrupt. The new code also works in cases where hunks+    are edited interactively. The algorithm is documented in detail.++  * Downloading files via http now uses the http-conduit package. This is+    now the default method when building darcs. Building against the curl+    library is still supported but you have to explicitly request it by+    passing -fcurl to cabal.++  * Reworked internal failure handling so we can clearly distinguish between+    normal command failures and internal errors, i.e bugs, in darcs. In case+    of a bug, darcs exits with status 4 and prints a message that asks the+    user to report it and how to do that.++  * During interactive patch selection, the 'x', 'v', and 'p' keys no longer+    print the patch description (if any), only the summary or the patch+    content. A new key 'r' was added to re-display the currently selected+    patch in default mode (normally this is just the description). See+    issue2649 for details.++  * A large number of other internal refactors and code cleanups.++  * A forward compatibility bug (issue2650), roughly fixed in Darcs 2.14.5,+    is now resolved in full. In particular, we modify the format file only+    if we have taken the repo lock, silently fix possibly corrupted entries+    when reading the format file, internally document the forward+    compatibility rules, and finally test them more thoroughly.++  * Issues fixed:+    * 1316: amend-record: files/dirs still in pending even if they are removed+    * 1609: darcs conflict marking gives different results in different orders+    * 2001: repair fails to detect missing pristine files+    * 2275: ignore symlinks as repo paths even when the index is used+    * 2404: darcs convert export ignores --repodir+    * 2441: Use pager for darcs annotate+    * 2445: internal error if suspended patch is pulled into repository again+    * 2454: help markdown/manpage should use a pager+    * 2533: add umask option to all commands that modify the repo+    * 2536: show files --no-files: can't mix match and pending flags+    * 2548: inconsistent pending after addfile f; rm f; mkdir f+    * 2550: apply only properly mangled resolutions, warn about any others+    * 2592: update pending with coalesced look-for changes+    * 2593: network test can collide with shell tests+    * 2594: darcs show index crashes replace with unrecorded force hunk+    * 2599: don't bother to update pending when cloning a repo+    * 2603: warn and mark conflicts when cloning+    * 2604: remove --reply and related options+    * 2608: download _darcs/hashed_inventory separately+    * 2610: add --inherit-default option+    * 2614: (an intermediate regression)+    * 2618: option --ask-deps adds too many dependencies+    * 2625: catch only IO exceptions from applyToWorking+    * 2626: treat applyToWorking more uniformly+    * 2634: use unwind to suspend patches+    * 2635: build/install man page only if we build darcs executable+    * 2639: darcs diff crashes with --last=1 and file name+    * 2645: search for ":" to detect ssh URLs only up to the first "/"+    * 2648: convert import with non-ASCII meta data and filepaths+    * 2649: cleanup display of patches++  * Partial fixes:+    * 1959: read-only commands should not need write access to the index+      This is mostly fixed, see tests/issue1959-unwritable-darcsdir.sh+      for the few remaining problematic cases. We also now check+      writability of the index when we start a transaction.++  * Miscellaneous user-visible changes and bugfixes:+    * always prompt for confirmation when there are conflicts with unrecorded+      changes+    * darcs optimize upgrade: don't throw away pending+    * use cryptonite instead of cryptohash and random; the random junk added+      to patch meta data now uses a cryptographically secure random number+      generator; also replaces our own implementation of SHA1+    * darcs repair: handle broken binary patches+    * fail if pending patch cannot be parsed instead of silently ignoring it+    * darcs remove: don't allow removal of root+    * darcs suspend reify: give reified fixup patches a real author+    * darcs add: fail unconditionally when no files were added+    * darcs optimize compress: don't compress special patches such as+      pending or unrevert+    * darcs send: bugfix on Windows with GHC>=8.6+    * fix prompting when we get a bad patch name from the user+    * darcs apply: fix interpretation of patch bundles as patchsets when the+      context tag is not in our repo+    * darcs apply: fix lazy reading of inventories+    * darcs amend: fix editing of tag names+    * clone to ssh: don't overwrite existing remote target directories+    * darcs rebase: remove error if no suspended patches found+    * fully respect the (badly named) --no-ignore-times option (which+      actually means to ignore the index)+    * replace the code for creating unique temporary directory names+      (that was prone to race conditions); instead we now use the temporary+      package+    * darcs check/repair: detect and repair missing (hashed) pristine files+    * remove option --restrict-paths (is always active now)+    * remove defunct --set-default option for rebase pull+    * remove env var DARCS_DO_COLOR_LINES+    * demote errors in defaults file and commandline to warnings+    * add --not-in-remote option to amend and rebase suspend; the option+      is now supported by all history editing commands.+    * remove our own optimisation settings in darcs.cabal+    * regard explicit dependencies as resolving conflicts+    * suspend reify: give reified fixup patches a real author+    * never overwrite existing files with -O/--output-auto-name+    * make working with temporary directories more robust+    * make sure we cancel pending download actions at exit+    * darcs diff: allow use of interactive external diff commands+    * remove graphviz dependency by re-implementing show dependencies+    * darcs show dependencies: review matching options+    * darcs annotate: more than one file argument is now an error++  * Changes in the output of commands:+    * add a warning when the index code ignores a symlink+    * print remote execution failure message to stderr+    * darcs amend: respect verbosity options+    * commands that can produce large amounts of output now display it using+      a pager, similar to 'darcs log'+    * remove "withSignalsHandled:" from message when we are interrupted (Ctrl-C)+    * add progress reporting to patch index+    * print remote execution failure message to stderr+    * re-formulate the bad sources hint+    * remove hint "Do you have the right URI for the repository?"+    * remove the "darcs failed:" from error messages+    * re-formulate the set-default hint+    * darcs check/repair: no coloring in progress reports+    * add progress reporting when creating packs+    * darcs test: make linear search report results like bisect+    * colorize --dry-run output and warnings+    * darcs whatsnew: print via pager (unless --xml or -s is active)+    * darcs apply: print "reading from stdin" unless --quiet+    * darcs send: include all the information when reporting exceptions+    * print name of patch bundle for obliterate --output++  * Deliberate API changes to support darcsden:+    * export getPrefLines+    * export a simplified version of getLogInfo+    * export runWithHooks instead of recordConfig and RecordConfig++  * Documentation/help changes:+    * extend help text for darcs show and darcs convert+    * re-word some option descriptions+    * improve the (top level) usage text+    * update help for defaults file(s)+    * add subcommand 'darcs help preferences'+    * improve help for _darcs/prefs/sources+    * darcs diff: fix help for --unified option+    * fix manpage formatting of bullet lists+    * fix docs and description for the status command+    * automatically format (most) help texts to 80 chars per line+    * replace initial blurb in the manpage+    * unify warning hints for history editing commands+    * move debugging options to the end of the advanced options+    * shorten the help for alias commands+    * add extended help for rebase super command+    * include help for super commands in the man page+    * group --reorder under the merge options and improve its help text+    * bring help text for 'darcs repair' up to date+    * darcs.cabal: fix license and reword package description+ Darcs 2.14.5, 6 August 2020    * Resolve issue2650
Setup.hs view
@@ -1,174 +1,80 @@ -- copyright (c) 2008 Duncan Coutts -- portions copyright (c) 2008 David Roundy -- portions copyright (c) 2007-2009 Judah Jacobson-{-# OPTIONS_GHC -Wno-deprecations #-}-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-} import Distribution.Simple-         ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.ModuleName( toFilePath )-import Distribution.PackageDescription-         ( PackageDescription(executables, testSuites), Executable(exeName)-         , emptyBuildInfo-         , TestSuite(testBuildInfo)-         , updatePackageDescription-         , cppOptions, ccOptions-         , library, libBuildInfo, otherModules )-import Distribution.Package-         ( packageVersion )+         ( defaultMainWithHooks, UserHooks(..), simpleUserHooks, Args )+import Distribution.PackageDescription ( PackageDescription )+import Distribution.Package ( packageVersion ) import Distribution.Version( Version ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), absoluteInstallDirs ) import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest)) import Distribution.Simple.Setup-    (buildVerbosity, copyDest, copyVerbosity, fromFlag,-     haddockVerbosity, installVerbosity, sDistVerbosity, replVerbosity )-#if MIN_VERSION_Cabal(3,0,0)+    (configVerbosity, copyDest, copyVerbosity, fromFlag, ConfigFlags,+     installVerbosity) import Distribution.Simple.BuildPaths ( autogenPackageModulesDir )-#else-import Distribution.Simple.BuildPaths ( autogenModulesDir )-#endif-import Distribution.System-         ( OS(Windows), buildOS ) import Distribution.Simple.Utils     (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,-#if MIN_VERSION_Cabal(3,0,0)-     rewriteFileEx-#else-     rewriteFile-#endif-    )-import Distribution.Verbosity-         ( Verbosity, silent )-import Distribution.Text-         ( display )-import Control.Monad ( unless, void, when )+     rewriteFileEx)+import Distribution.Verbosity ( Verbosity, silent )+import Distribution.Text ( display ) -import System.Directory-    ( doesDirectoryExist, doesFileExist )-import System.IO-    ( openFile, IOMode(..) )+import Control.Monad ( unless, when, void )+import System.Directory ( doesDirectoryExist, doesFileExist )+import System.IO ( openFile, IOMode(..) ) import System.Process (runProcess)-import Data.List( isInfixOf, lines )-import System.FilePath       ( (</>) )-import Foreign.Marshal.Utils ( with )-import Foreign.Storable      ( peek )-import Foreign.Ptr           ( castPtr )-import Data.Monoid           ( mappend )-import Data.Word             ( Word8, Word32 )+import Data.List( isInfixOf )+import System.FilePath ( (</>) )  import qualified Control.Exception as Exception -#if MIN_VERSION_Cabal(3,0,0)-autogenModulesDir = autogenPackageModulesDir-rewriteFile = rewriteFileEx silent-#endif- catchAny :: IO a -> (Exception.SomeException -> IO a) -> IO a catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException))  main :: IO ()-main = defaultMainWithHooks $ simpleUserHooks {--  buildHook = \ pkg lbi hooks flags ->-              let verb = fromFlag $ buildVerbosity flags-               in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags),--  haddockHook = \ pkg lbi hooks flags ->-                let verb = fromFlag $ haddockVerbosity flags-                 in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) ,-  replHook = \pkg lbi hooks flags args ->-                let verb = fromFlag $ replVerbosity flags-                 in commonBuildHook replHook pkg lbi hooks verb >>= (\f -> f flags args) ,-  postBuild = \ _ _ _ lbi -> buildManpage lbi,-  postCopy = \ _ flags pkg lbi ->-             installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags),-  postInst = \ _ flags pkg lbi ->-             installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest,--#if !MIN_VERSION_Cabal(3,0,0)-  sDistHook = \ pkg lbi hooks flags -> do-    let pkgVer = packageVersion pkg-        verb = fromFlag $ sDistVerbosity flags-    x <- versionPatches verb pkgVer-    y <- context verb-    rewriteFile "release/distributed-version" $ show x-    rewriteFile "release/distributed-context" $ show y-    putStrLn "about to hand over"-    let pkg' = pkg { library = sanity (library pkg) }-        sanity (Just lib) = Just $ lib { libBuildInfo = sanity' $ libBuildInfo lib }-        sanity _ = error "eh"-        sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] }--    sDistHook simpleUserHooks pkg' lbi hooks flags-             ,-#endif-  postConf = \_ _ _ _ -> return () --- Usually this checked for external C-             --- dependencies, but we already have performed such-             --- check in the confHook-}+main =+  defaultMainWithHooks $+  simpleUserHooks+    { postConf = postConfHook+    , postBuild = \_ _ _ lbi -> buildManpage lbi+    , postCopy =+        \_ flags pkg lbi ->+          installManpage pkg lbi+            (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags)+    , postInst =+        \_ flags pkg lbi ->+          installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest+    } --- | For @./Setup build@ and @./Setup haddock@, do some unusual--- things, then invoke the base behaviour ("simple hook").-commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a)-                -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a-commonBuildHook runHook pkg lbi hooks verbosity = do+postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+postConfHook _args flags pkg lbi = do+  let verbosity = fromFlag $ configVerbosity flags   (version, state) <- determineVersion verbosity pkg--  -- Create our own context file.   generateVersionModule verbosity lbi version state -  -- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c)-  -- invocations, doing a dance to make the base hook aware of them.-  littleEndian <- testEndianness-  let args = ("-DPACKAGE_VERSION=" ++ show' version) :-             [arg | (arg, True) <-         -- include fst iff snd.-              [-- We have MAPI iff building on/for Windows.-               ("-DHAVE_MAPI", buildOS == Windows),-               ("-DLITTLEENDIAN", littleEndian),-               ("-DBIGENDIAN", not littleEndian)]]-      bi = emptyBuildInfo { cppOptions = args, ccOptions = args }-      hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg])-      pkg' = updatePackageDescription hbi pkg--      -- updatePackageDescription doesn't handle test suites so we-      -- need to do this manually-      updateTestSuiteBI bi' testSuite-          = testSuite { testBuildInfo = bi' `mappend` testBuildInfo testSuite }-      pkg'' = pkg' { testSuites = map (updateTestSuiteBI bi) (testSuites pkg') }--      lbi' = lbi { localPkgDescr = pkg'' }-  return $ runHook simpleUserHooks pkg'' lbi' hooks--  where-    show' :: String -> String   -- Petr was worried that we might-    show' = show                -- allow non-String arguments.-    testEndianness :: IO Bool-    testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p-                                                   return $ o == (1 :: Word8)- -- --------------------------------------------------------------------- -- man page -- ---------------------------------------------------------------------  buildManpage :: LocalBuildInfo -> IO () buildManpage lbi = do-  let darcs = buildDir lbi </> "darcs/darcs"-      manpage = buildDir lbi </> "darcs/darcs.1"-  darcsExists <- doesFileExist darcs-  when darcsExists $ do+  have_darcs_exe_dir <- doesDirectoryExist (buildDir lbi </> "darcs")+  when have_darcs_exe_dir $ do+    let darcs = buildDir lbi </> "darcs/darcs"+        manpage = buildDir lbi </> "darcs/darcs.1"     manpageHandle <- openFile manpage WriteMode     void $ runProcess darcs ["help","manpage"]-             Nothing Nothing Nothing (Just manpageHandle) Nothing+            Nothing Nothing Nothing (Just manpageHandle) Nothing -installManpage :: PackageDescription -> LocalBuildInfo-                  -> Verbosity -> CopyDest -> IO ()+installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO () installManpage pkg lbi verbosity copy = do-  let manpage = buildDir lbi </> "darcs/darcs.1"-  manpageExists <- doesFileExist manpage-  when manpageExists $ do-    copyFiles verbosity-              (mandir (absoluteInstallDirs pkg lbi copy) </> "man1")-              [(buildDir lbi </> "darcs", "darcs.1")]+  have_manpage <- doesFileExist (buildDir lbi </> "darcs" </> "darcs.1")+  when have_manpage $+    copyFiles+      verbosity+      (mandir (absoluteInstallDirs pkg lbi copy) </> "man1")+      [(buildDir lbi </> "darcs", "darcs.1")]  -- --------------------------------------------------------------------- -- version module@@ -176,7 +82,7 @@  determineVersion :: Verbosity -> PackageDescription -> IO (String, String) determineVersion verbosity pkg = do-  let darcsVersion  =  packageVersion pkg+  let darcsVersion = packageVersion pkg   numPatches <- versionPatches verbosity darcsVersion   return (display darcsVersion, versionStateString numPatches) @@ -196,25 +102,21 @@         ((n,_):_) -> return $ Just ((n :: Int) - 1)         _         -> return Nothing     `catchAny` \_ -> return Nothing--  numPatchesDist <- parseFile versionFile+  numPatchesDist <- parseFile "release/distributed-version"   return $ case (numPatchesDarcs, numPatchesDist) of              (Just x, _) -> Just x              (Nothing, Just x) -> Just x              (Nothing, Nothing) -> Nothing - where-  versionFile = "release/distributed-version"--generateVersionModule :: Verbosity -> LocalBuildInfo-                      -> String -> String -> IO ()+generateVersionModule :: Verbosity -> LocalBuildInfo -> String -> String -> IO () generateVersionModule verbosity lbi version state = do-  let dir = autogenModulesDir lbi+  let dir = autogenPackageModulesDir lbi   createDirectoryIfMissingVerbose verbosity True dir   ctx <- context verbosity   hash <- weakhash verbosity-  rewriteFile (dir </> "Version.hs") $ unlines+  rewriteFileEx silent (dir </> "Version.hs") $ unlines     ["module Version where"+    ,"import Darcs.Prelude"     ,"version, weakhash, context :: String"     ,"version = \"" ++ version ++ " (" ++ state ++ ")\""     ,"weakhash = " ++ case hash of@@ -237,27 +139,21 @@  `catchAny` \_ -> return Nothing  context :: Verbosity -> IO (Maybe String)-context verbosity = do-  contextDarcs <- do+context verbosity =+   do       inrepo <- doesDirectoryExist "_darcs"       unless inrepo $ fail "Not a repository."       out <- rawSystemStdout verbosity "darcs" ["log", "-a", "--context"]       return $ Just out-   `catchAny` \_ -> return Nothing--  contextDist <- parseFile contextFile-  return $ case (contextDarcs, contextDist) of-             (Just x, _) -> Just x-             (Nothing, Just x) -> Just x-             (Nothing, Nothing) -> Nothing- where contextFile = "release/distributed-context"+   `catchAny` \_ -> parseFile "release/distributed-context" -parseFile :: (Read a) => String -> IO (Maybe a)+parseFile :: Read a => FilePath -> IO (Maybe a) parseFile f = do   exist <- doesFileExist f-  if exist then do-             content <- readFile f -- ^ ratify readFile: we don't care here.-             case reads content of-               ((s,_):_) -> return s-               _         -> return Nothing-             else return Nothing+  if exist+    then do+      content <- readFile f+      case reads content of+        ((s, _):_) -> return s+        _ -> return Nothing+    else return Nothing
darcs.cabal view
@@ -1,7 +1,7 @@-cabal-version:  1.24+Cabal-Version:  2.2 Name:           darcs-version:        2.14.5-License:        GPL-2+version:        2.16.1+License:        GPL-2.0-or-later License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net> Maintainer:     <darcs-devel@darcs.net>@@ -12,39 +12,40 @@ Description:    Darcs is a free, open source revision control                 system. It is:                 .-                * Distributed: Every user has access to the full-                  command set, removing boundaries between server and-                  client or committer and non-committers.-                .-                * Interactive: Darcs is easy to learn and efficient to-                  use because it asks you questions in response to-                  simple commands, giving you choices in your work-                  flow. You can choose to record one change in a file,-                  while ignoring another. As you update from upstream,-                  you can review each patch name, even the full "diff"-                  for interesting patches.+                * Distributed: Darcs was one of the first revision control+                  systems in which every user has access to the full command+                  set, removing boundaries between server and client or+                  committer and non-committers.                 .-                * Smart: Originally developed by physicist David-                  Roundy, darcs is based on a unique algebra of-                  patches.+                * Interactive: Darcs is easy to learn and efficient to use+                  because it asks you questions in response to simple+                  commands, giving you choices in your work flow. You can+                  choose to record one change in a file, while ignoring+                  another. As you update from upstream, you can review each+                  patch, picking and choosing which patches are appropriate.                 .-                  This smartness lets you respond to changing demands-                  in ways that would otherwise not be possible. Learn-                  more about spontaneous branches with darcs.+                * Smart: Darcs is different from most revision control+                  systems in that it is based on the notion of change (or+                  patch), rather than version. An underlying algebra of+                  patches determines whether changes can be re-ordered. The+                  laws of this algebra guarantee that the result of merging+                  depends only on the final set of patches applied in a+                  repository and not on their order.                 .-                * Please note that hackage does not correctly display-                  the license. It is meant to be "GPL-2.0-or-later".+                * Simple: As a consequence, Darcs offers a conceptually+                  simpler view of the state of a repository: it is given by+                  the set of patches it contains. Pulling and pushing+                  patches merely transfers them from one set to another. So+                  called "cherry-picking" is the default mode of operation,+                  and it fully preserves the identity of patches.+ Homepage:       http://darcs.net/  Build-Type:     Custom- extra-source-files:   -- C files-  src/*.c   src/*.h-  src/win32/send_email.c   src/win32/send_email.h-  src/win32/sys/mman.h    contrib/cygwin-wrapper.bash   contrib/darcs_completion@@ -61,9 +62,16 @@   release/distributed-version   release/distributed-context +  -- bundled shelly (the bare minimum required)+  shelly/LICENSE+  shelly/shelly.cabal+  shelly/src/Shelly/*.hs+  shelly/src/Shelly.hs+   -- testsuite   tests/data/*.tgz   tests/data/README+  tests/data/cyrillic_import_stream   tests/data/*.dpatch   tests/data/example_binary.png   tests/data/convert/darcs1/*.dpatch@@ -71,6 +79,7 @@   tests/*.sh   tests/README.test_maintainers.txt   tests/bin/*.hs+  tests/network/httplib   tests/network/sshlib   tests/network/*.sh   tests/lib@@ -84,16 +93,18 @@  flag curl   description: Use libcurl for HTTP support.+  default:     False  -- in future this could extend to any other external libraries,--- e.g. libiconv +-- e.g. libiconv flag pkgconfig   description: Use pkgconfig to configure libcurl-  default: False+  default:     False  flag static   description: Build static binary   default:     False+  manual:      True  flag terminfo   description: Use the terminfo package for enhanced console support.@@ -101,6 +112,7 @@ flag threaded   description: Use threading and SMP support.   default:     True+  manual:      True  flag executable   description: Build darcs executable@@ -109,6 +121,7 @@  flag rts   default:     False+  manual:      True  flag warn-as-error   default:     False@@ -120,11 +133,11 @@ -- ----------------------------------------------------------------------  custom-setup-    setup-depends: base      >= 4.9 && < 4.15,-                   Cabal     >= 1.24,+    setup-depends: base      >= 4.10 && < 4.15,+                   Cabal     >= 2.2 && < 3.3,                    process   >= 1.2.3.0 && < 1.7,                    filepath  >= 1.4.1 && < 1.5.0.0,-                   directory >= 1.2.6.2 && < 1.4+                   directory >= 1.2.7 && < 1.4  -- ---------------------------------------------------------------------- -- darcs library@@ -143,25 +156,26 @@                       Darcs.Patch.ApplyMonad                       Darcs.Patch.ApplyPatches                       Darcs.Patch.Bracketed-                      Darcs.Patch.Bracketed.Instances                       Darcs.Patch.Bundle                       Darcs.Patch.Choices                       Darcs.Patch.Commute                       Darcs.Patch.CommuteFn+                      Darcs.Patch.CommuteNoConflicts                       Darcs.Patch.Conflict                       Darcs.Patch.Debug                       Darcs.Patch.Depends-                      Darcs.Patch.Dummy                       Darcs.Patch.Effect                       Darcs.Patch.FileHunk+                      Darcs.Patch.Format+                      Darcs.Patch.FromPrim+                      Darcs.Patch.Ident                       Darcs.Patch.Index.Monad                       Darcs.Patch.Index.Types-                      Darcs.Patch.Format                       Darcs.Patch.Info                       Darcs.Patch.Inspect                       Darcs.Patch.Invert+                      Darcs.Patch.Invertible                       Darcs.Patch.Match-                      Darcs.Patch.Matchable                       Darcs.Patch.Merge                       Darcs.Patch.MonadProgress                       Darcs.Patch.Named@@ -170,32 +184,34 @@                       Darcs.Patch.Permutations                       Darcs.Patch.Prim                       Darcs.Patch.Prim.Class-                      Darcs.Patch.Prim.V1-                      Darcs.Patch.Prim.V1.Apply-                      Darcs.Patch.Prim.V1.Coalesce-                      Darcs.Patch.Prim.V1.Commute-                      Darcs.Patch.Prim.V1.Core-                      Darcs.Patch.Prim.V1.Details-                      Darcs.Patch.Prim.V1.Read-                      Darcs.Patch.Prim.V1.Show                       Darcs.Patch.Prim.FileUUID-                      Darcs.Patch.Prim.FileUUID.ObjectMap                       Darcs.Patch.Prim.FileUUID.Apply                       Darcs.Patch.Prim.FileUUID.Coalesce                       Darcs.Patch.Prim.FileUUID.Commute                       Darcs.Patch.Prim.FileUUID.Core                       Darcs.Patch.Prim.FileUUID.Details+                      Darcs.Patch.Prim.FileUUID.ObjectMap                       Darcs.Patch.Prim.FileUUID.Read                       Darcs.Patch.Prim.FileUUID.Show+                      Darcs.Patch.Prim.Named+                      Darcs.Patch.Prim.V1+                      Darcs.Patch.Prim.V1.Apply+                      Darcs.Patch.Prim.V1.Coalesce+                      Darcs.Patch.Prim.V1.Commute+                      Darcs.Patch.Prim.V1.Core+                      Darcs.Patch.Prim.V1.Details+                      Darcs.Patch.Prim.V1.Mangle+                      Darcs.Patch.Prim.V1.Read+                      Darcs.Patch.Prim.V1.Show+                      Darcs.Patch.Prim.WithName                       Darcs.Patch.Progress                       Darcs.Patch.Read-                      Darcs.Patch.Rebase-                      Darcs.Patch.Rebase.Container+                      Darcs.Patch.Rebase.Change                       Darcs.Patch.Rebase.Fixup-                      Darcs.Patch.Rebase.Item+                      Darcs.Patch.Rebase.Legacy.Item                       Darcs.Patch.Rebase.Name-                      Darcs.Patch.Rebase.Viewing-                      Darcs.Patch.ReadMonads+                      Darcs.Patch.Rebase.PushFixup+                      Darcs.Patch.Rebase.Suspended                       Darcs.Patch.RegChars                       Darcs.Patch.Repair                       Darcs.Patch.RepoPatch@@ -207,8 +223,7 @@                       Darcs.Patch.SummaryData                       Darcs.Patch.TokenReplace                       Darcs.Patch.TouchesFiles-                      Darcs.Patch.Type-                      Darcs.Patch.Viewing+                      Darcs.Patch.Unwind                       Darcs.Patch.V1                       Darcs.Patch.V1.Apply                       Darcs.Patch.V1.Commute@@ -221,7 +236,13 @@                       Darcs.Patch.V2.Non                       Darcs.Patch.V2.Prim                       Darcs.Patch.V2.RepoPatch+                      Darcs.Patch.V3+                      Darcs.Patch.V3.Contexted+                      Darcs.Patch.V3.Core+                      Darcs.Patch.V3.Resolution+                      Darcs.Patch.Viewing                       Darcs.Patch.Witnesses.Eq+                      Darcs.Patch.Witnesses.Maybe                       Darcs.Patch.Witnesses.Ordered                       Darcs.Patch.Witnesses.Sealed                       Darcs.Patch.Witnesses.Show@@ -233,37 +254,44 @@                       Darcs.Repository.Cache                       Darcs.Repository.Clone                       Darcs.Repository.Create-                      Darcs.Repository.PatchIndex                       Darcs.Repository.Diff                       Darcs.Repository.Flags                       Darcs.Repository.Format-                      Darcs.Repository.HashedIO                       Darcs.Repository.Hashed-                      Darcs.Repository.Inventory+                      Darcs.Repository.HashedIO                       Darcs.Repository.Identify-                      Darcs.Repository.Job-                      Darcs.Repository.Merge                       Darcs.Repository.InternalTypes+                      Darcs.Repository.Inventory+                      Darcs.Repository.Job                       Darcs.Repository.Match+                      Darcs.Repository.Merge                       Darcs.Repository.Old                       Darcs.Repository.Packs+                      Darcs.Repository.PatchIndex+                      Darcs.Repository.Paths                       Darcs.Repository.Pending                       Darcs.Repository.Prefs+                      Darcs.Repository.Pristine                       Darcs.Repository.Rebase                       Darcs.Repository.Repair                       Darcs.Repository.Resolution                       Darcs.Repository.State                       Darcs.Repository.Test+                      Darcs.Repository.Traverse                       Darcs.Repository.Working+                      Darcs.Test.TestOnly                       Darcs.UI.ApplyPatches                       Darcs.UI.Commands                       Darcs.UI.Commands.Add                       Darcs.UI.Commands.Amend                       Darcs.UI.Commands.Annotate                       Darcs.UI.Commands.Apply-                      Darcs.UI.CommandsAux                       Darcs.UI.Commands.Clone                       Darcs.UI.Commands.Convert+                      Darcs.UI.Commands.Convert.Darcs2+                      Darcs.UI.Commands.Convert.Export+                      Darcs.UI.Commands.Convert.Import+                      Darcs.UI.Commands.Convert.Util                       Darcs.UI.Commands.Diff                       Darcs.UI.Commands.Dist                       Darcs.UI.Commands.GZCRCs@@ -296,15 +324,15 @@                       Darcs.UI.Commands.Tag                       Darcs.UI.Commands.Test                       Darcs.UI.Commands.TransferMode-                      Darcs.UI.Commands.Util-                      Darcs.UI.Commands.Util.Tree                       Darcs.UI.Commands.Unrecord                       Darcs.UI.Commands.Unrevert+                      Darcs.UI.Commands.Util+                      Darcs.UI.Commands.Util.Tree                       Darcs.UI.Commands.WhatsNew                       Darcs.UI.Completion+                      Darcs.UI.Defaults                       Darcs.UI.Email                       Darcs.UI.External-                      Darcs.UI.Defaults                       Darcs.UI.Flags                       Darcs.UI.Options                       Darcs.UI.Options.All@@ -331,7 +359,6 @@                       Darcs.Util.Diff.Patience                       Darcs.Util.Download                       Darcs.Util.Download.Request-                      Darcs.Util.Download.HTTP                       Darcs.Util.Encoding                       Darcs.Util.English                       Darcs.Util.Exception@@ -339,10 +366,13 @@                       Darcs.Util.External                       Darcs.Util.File                       Darcs.Util.Global+                      Darcs.Util.Graph                       Darcs.Util.Hash+                      Darcs.Util.HTTP                       Darcs.Util.Index                       Darcs.Util.IsoDate                       Darcs.Util.Lock+                      Darcs.Util.Parser                       Darcs.Util.Path                       Darcs.Util.Printer                       Darcs.Util.Printer.Color@@ -352,7 +382,6 @@                       Darcs.Util.Show                       Darcs.Util.SignalHandler                       Darcs.Util.Ssh-                      Darcs.Util.Text                       Darcs.Util.Tree                       Darcs.Util.Tree.Hashed                       Darcs.Util.Tree.Monad@@ -361,8 +390,8 @@                       Darcs.Util.Workaround      autogen-modules:  Version+     other-modules:    Version-                      Darcs.Util.Download.Curl      c-sources:        src/atomic_create.c                       src/maybe_relink.c@@ -383,15 +412,15 @@                       System.Posix                       System.Posix.Files                       System.Posix.IO-      cpp-options:    -DWIN32+      cpp-options:    -DWIN32 -DHAVE_MAPI       c-sources:      src/win32/send_email.c-      build-depends:  Win32 >= 2.3.1 && < 2.4+      build-depends:  Win32 >= 2.4.0 && < 2.7     else       build-depends:  unix >= 2.7.1.0 && < 2.8 -    build-depends:    base              >= 4.9 && < 4.15,+    build-depends:    base              >= 4.10 && < 4.15,                       stm               >= 2.1 && < 2.6,-                      binary            >= 0.5 && < 0.10,+                      binary            >= 0.5 && < 0.11,                       containers        >= 0.5.6.2 && < 0.7,                       regex-compat-tdfa >= 0.95.1 && < 0.96,                       regex-applicative >= 0.2 && < 0.4,@@ -399,11 +428,11 @@                       transformers      >= 0.4.2.0 && < 0.6,                       parsec            >= 3.1.9 && < 3.2,                       fgl               >= 5.5.2.3 && < 5.8,-                      graphviz          >= 2999.18.1 && < 2999.20.1,                       html              >= 1.0.1.2 && < 1.1,                       filepath          >= 1.4.1 && < 1.5.0.0,                       haskeline         >= 0.7.2 && < 0.9,-                      cryptohash        >= 0.11 && < 0.12,+                      memory            >= 0.14 && < 0.16,+                      cryptonite        >= 0.24 && < 0.28,                       base16-bytestring >= 0.1 && < 0.2,                       utf8-string       >= 1 && < 1.1,                       vector            >= 0.11 && < 0.13,@@ -412,22 +441,25 @@                       attoparsec        >= 0.13.0.1 && < 0.14,                       zip-archive       >= 0.3 && < 0.5,                       async             >= 2.0.2 && < 2.3,+                      constraints       >= 0.11 && < 0.13,                       sandi             >= 0.4 && < 0.6,-                      unix-compat       >= 0.4.2 && < 0.6,+                      unix-compat       >= 0.5 && < 0.6,                       bytestring        >= 0.10.6 && < 0.11,                       old-time          >= 1.1.0.3 && < 1.2,                       time              >= 1.5.0.1 && < 1.10,                       text              >= 1.2.1.3 && < 1.3,-                      directory         >= 1.2.6.2 && < 1.4,+                      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,-                      random            >= 1.1 && < 1.2,                       hashable          >= 1.2.3.3 && < 1.4,                       mmap              >= 0.5.9 && < 0.6,                       zlib              >= 0.6.1.2 && < 0.7.0.0,-                      network-uri       == 2.6.*,+                      network-uri       >= 2.6 && < 2.8,                       network           >= 2.6 && < 3.2,-                      HTTP              >= 4000.2.20 && < 4000.4+                      conduit           >= 1.3.0 && < 1.3.3,+                      http-conduit      >= 2.3 && < 2.4,+                      http-types        >= 0.12.1 && < 0.12.4      if flag(warn-as-error)       ghc-options:    -Werror@@ -435,6 +467,7 @@     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@@ -451,18 +484,31 @@      default-extensions:         BangPatterns-        PatternGuards-        GADTSyntax-        ExistentialQuantification-        TypeOperators+        ConstraintKinds+        DataKinds+        DefaultSignatures+        DeriveDataTypeable+        DeriveFunctor+        EmptyDataDecls         FlexibleContexts         FlexibleInstances-        ScopedTypeVariables+        GADTs+        GeneralizedNewtypeDeriving         KindSignatures-        DataKinds-        ConstraintKinds+        LambdaCase+        NoImplicitPrelude+        PatternGuards         RankNTypes+        RecordWildCards+        RoleAnnotations+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications         TypeFamilies+        TypeOperators+        -- this must come last because some of the+        -- other extensions imply MonoLocalBinds         NoMonoLocalBinds  -- ----------------------------------------------------------------------@@ -480,12 +526,13 @@   main-is:          darcs.hs   hs-source-dirs:   darcs +  autogen-modules:  Version++  other-modules:    Version+   if flag(warn-as-error)     ghc-options:    -Werror -  if impl(ghc >= 8.2)-    ghc-options:    -Wno-missing-home-modules-   ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs    if flag(threaded)@@ -502,6 +549,9 @@    build-depends:    darcs, base +  default-extensions:+                    NoImplicitPrelude+ -- ---------------------------------------------------------------------- -- unit test driver -- ----------------------------------------------------------------------@@ -515,7 +565,7 @@    if os(windows)     cpp-options:    -DWIN32-    build-depends:  Win32 >= 2.3.1 && < 2.4+    build-depends:  Win32 >= 2.4.0 && < 2.7    build-depends:    darcs,                     base,@@ -523,6 +573,7 @@                     bytestring,                     cmdargs      >= 0.10.10 && < 0.11,                     containers,+                    constraints,                     filepath,                     mtl,                     transformers,@@ -531,20 +582,20 @@                     text,                     directory,                     FindBin      >= 0.0.5 && < 0.1,-                    QuickCheck   >= 2.8.2 && < 2.14,+                    QuickCheck   >= 2.13 && < 2.14,+                    leancheck    >= 0.9 && < 0.10,                     HUnit        >= 1.3 && < 1.7,                     test-framework             >= 0.8.1.1 && < 0.9,                     test-framework-hunit       >= 0.3.0.2 && < 0.4,                     test-framework-quickcheck2 >= 0.3.0.3 && < 0.4,+                    test-framework-leancheck   >= 0.0.1 && < 0.1,+                    vector,                     zip-archive -  -- note for windows we can't allow 1.9 or above until-  -- https://github.com/gregwebs/Shelly.hs/issues/176-  -- and possibly-  -- https://github.com/gregwebs/Shelly.hs/issues/177-  -- are dealt with-  if os(windows)-    build-depends: shelly < 1.7.2+  -- the tests shell out to a built darcs binary, so we depend on it to make+  -- sure that it's built. It's not actually required for build, just at runtime,+  -- but there isn't a way to express the latter and it seems harmless.+  build-tool-depends: darcs:darcs    -- list all unit test modules not exported by libdarcs; otherwise Cabal won't   -- include them in the tarball@@ -553,6 +604,7 @@                     Darcs.Test.Patch.Check                     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.V1Set1@@ -560,33 +612,45 @@                     Darcs.Test.Patch.Properties.Generic                     Darcs.Test.Patch.Properties.GenericUnwitnessed                     Darcs.Test.Patch.Properties.Check-                    Darcs.Test.Patch.Properties.RepoPatchV2+                    Darcs.Test.Patch.Properties.RepoPatch+                    Darcs.Test.Patch.Properties.RepoPatchV3                     Darcs.Test.Patch.Arbitrary.Generic-                    Darcs.Test.Patch.Arbitrary.PrimV1+                    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+                    Darcs.Test.Patch.Arbitrary.RepoPatch                     Darcs.Test.Patch.Arbitrary.RepoPatchV1                     Darcs.Test.Patch.Arbitrary.RepoPatchV2+                    Darcs.Test.Patch.Arbitrary.RepoPatchV3+                    Darcs.Test.Patch.Arbitrary.Shrink+                    Darcs.Test.Patch.Merge.Checked                     Darcs.Test.Patch.Rebase                     Darcs.Test.Patch.RepoModel                     Darcs.Test.Patch.Selection                     Darcs.Test.Patch.Utils                     Darcs.Test.Patch.V1Model                     Darcs.Test.Patch.FileUUIDModel+                    Darcs.Test.Patch.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.TestOnly.Instance                     Darcs.Test.Util.TestResult                     Darcs.Test.Util.QuickCheck    if flag(warn-as-error)     ghc-options:    -Werror -  if impl(ghc >= 8.2)-    ghc-options:    -Wno-missing-home-modules-   ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-orphans    if flag(threaded)@@ -599,15 +663,30 @@   cc-options:       -D_REENTRANT    default-extensions:-      GADTSyntax-      ExistentialQuantification-      TypeOperators+      AllowAmbiguousTypes+      BangPatterns+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveFunctor+      EmptyCase+      EmptyDataDecls       FlexibleContexts       FlexibleInstances-      ScopedTypeVariables+      GADTs+      GeneralizedNewtypeDeriving       KindSignatures-      DataKinds-      ConstraintKinds+      LambdaCase+      MultiParamTypeClasses+      NoImplicitPrelude       RankNTypes+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TypeApplications       TypeFamilies+      TypeOperators+      -- this must come last because some of the+      -- other extensions imply MonoLocalBinds       NoMonoLocalBinds
darcs/darcs.hs view
@@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-}  -- | -- Module      : Main@@ -27,12 +27,12 @@  module Main ( main ) where -import Prelude () import Darcs.Prelude -import Control.Exception ( AssertionFailed(..), handle )+import Control.Exception ( handle, ErrorCall ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs )+import System.IO ( hPutStrLn, stderr )  import Darcs.UI.RunCommand ( runTheCommand ) import Darcs.UI.Commands.Help ( helpCmd, listAvailableCommands, printVersion,@@ -56,7 +56,7 @@     exitWith $ ExitFailure 3  main :: IO ()-main = withAtexit . withSignalsHandled . handleExecFail . handleAssertFail $ do+main = handleErrors . withAtexit . withSignalsHandled . handleExecFail $ do     atexit reportBadSources     setDarcsEncodings     argv <- getArgs@@ -74,8 +74,14 @@         ["--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)     handleExecFail = handle execExceptionHandler-    handleAssertFail = handle $ \(AssertionFailed e) -> bug e     printExactVersion =  do         putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__ ++ "\n"         putStrLn $ "Weak Hash: " ++ weakhash
harness/Darcs/Test/Email.hs view
@@ -23,6 +23,9 @@ -- to check for CR-LF newlines because that's handled by sendmail.  module Darcs.Test.Email ( testSuite ) where++import Darcs.Prelude+ import Data.Char ( isPrint ) import qualified Data.ByteString as B ( length, unpack, null, head, pack,                                         cons, empty, foldr, ByteString )
harness/Darcs/Test/HashedStorage.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}-module Darcs.Test.HashedStorage( tests ) where+module Darcs.Test.HashedStorage ( tests, unsafeMakeName ) where  import Prelude hiding ( filter, readFile, writeFile, lookup, (<$>) ) import qualified Prelude@@ -13,7 +12,6 @@ import Codec.Archive.Zip( extractFilesFromArchive, toArchive )  import Data.Maybe-import Data.Word import Data.List( sort, intercalate, intersperse )  import Darcs.Util.Path hiding ( setCurrentDirectory )@@ -61,17 +59,20 @@ emptyStub :: TreeItem IO emptyStub = Stub (return emptyTree) NoHash +unsafeMakeName :: String -> Name+unsafeMakeName = either error id . makeName+ testTree :: Tree IO testTree =-    makeTree [ (makeName "foo", emptyStub)-             , (makeName "subtree", SubTree sub)-             , (makeName "substub", Stub getsub NoHash) ]-    where sub = makeTree [ (makeName "stub", emptyStub)-                         , (makeName "substub", Stub getsub2 NoHash)-                         , (makeName "x", SubTree emptyTree) ]+    makeTree [ (unsafeMakeName "foo", emptyStub)+             , (unsafeMakeName "subtree", SubTree sub)+             , (unsafeMakeName "substub", Stub getsub NoHash) ]+    where sub = makeTree [ (unsafeMakeName "stub", emptyStub)+                         , (unsafeMakeName "substub", Stub getsub2 NoHash)+                         , (unsafeMakeName "x", SubTree emptyTree) ]           getsub = return sub-          getsub2 = return $ makeTree [ (makeName "file", File emptyBlob)-                                      , (makeName "file2",+          getsub2 = return $ makeTree [ (unsafeMakeName "file", File emptyBlob)+                                      , (unsafeMakeName "file2",                                          File $ Blob (return $ BLC.pack "foo") NoHash) ]  equals_testdata :: Tree IO -> IO ()@@ -140,8 +141,6 @@ index = [ testCase "index versioning" check_index_versions         , testCase "index listing" check_index         , testCase "index content" check_index_content-        , testProperty "xlate32" prop_xlate32-        , testProperty "xlate64" prop_xlate64         , testProperty "align bounded" prop_align_bounded         , testProperty "align aligned" prop_align_aligned ]     where pristine = readDarcsPristine "." >>= expand@@ -169,8 +168,6 @@                Prelude.writeFile "_darcs/index" "nonsense index... do not crash!"                valid <- indexFormatValid "_darcs/index"                assertBool "index format invalid" $ not valid-          prop_xlate32 x = (xlate32 . xlate32) x == x where _types = x :: Word32-          prop_xlate64 x = (xlate64 . xlate64) x == x where _types = x :: Word64           prop_align_bounded (bound, x) =               bound > 0 && bound < 1024 && x >= 0 ==>                     align bound x >= x && align bound x < x + bound@@ -200,7 +197,7 @@        , testProperty "overlay keeps shape" prop_overlay_shape        , testProperty "overlay is superset of over" prop_overlay_super ]     where blob x = File $ Blob (return (BLC.pack x)) (sha256 $ BLC.pack x)-          name = makeName+          name = unsafeMakeName           check_modify =               let t = makeTree [(name "foo", blob "bar")]                   modify = modifyTree t (floatPath "foo") (Just $ blob "bla")@@ -378,7 +375,7 @@                       return (File $ Blob (return content) NoHash)           subtree n = do branches <- choose (1, n)                          let sub name = do t <- tree' ((n - 1) `div` branches)-                                           return (makeName $ show name, t)+                                           return (unsafeMakeName $ show name, t)                          sublist <- mapM sub [0..branches]                          oneof [ tree' 0                                , return (SubTree $ makeTree sublist)@@ -427,7 +424,7 @@ shapeEq :: Tree m -> Tree m -> Bool shapeEq a b = Just EQ == cmpShape a b -expandedShapeEq :: (Monad m, Functor m) => Tree m -> Tree m -> m Bool+expandedShapeEq :: Monad m => Tree m -> Tree m -> m Bool expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b  cmpcat :: [Maybe Ordering] -> Maybe Ordering@@ -438,7 +435,7 @@ cmpcat [x] = x cmpcat [] = Just EQ -- empty things are equal -cmpTree :: (Monad m, Functor m) => Tree m -> Tree m -> m (Maybe Ordering)+cmpTree :: Monad m => Tree m -> Tree m -> m (Maybe Ordering) cmpTree x y = do x' <- expand x                  y' <- expand y                  con <- contentsEq x' y'@@ -465,7 +462,7 @@                           return $ x `cmpShape` y  nondarcs :: AnchoredPath -> TreeItem m -> Bool-nondarcs (AnchoredPath (x:_)) _ | x == makeName "_darcs" = False+nondarcs (AnchoredPath (x:_)) _ | x == unsafeMakeName "_darcs" = False                                      | otherwise = True nondarcs (AnchoredPath []) _ = True
harness/Darcs/Test/Misc.hs view
@@ -17,6 +17,8 @@  module Darcs.Test.Misc ( testSuite ) where +import Darcs.Prelude+ import Darcs.Util.ByteString     ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex     , propHexConversion@@ -30,8 +32,10 @@  import Darcs.Test.Misc.CommandLine ( commandLineTestSuite ) import qualified Darcs.Test.Misc.Encoding as Encoding+import qualified Darcs.Test.Misc.Graph as Graph+import qualified Darcs.Test.Misc.URL as URL -import qualified Data.ByteString.Char8 as BC ( unpack, pack, last )+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 Data.Array.Base@@ -49,6 +53,8 @@  , lcsTestSuite  , commandLineTestSuite  , Encoding.testSuite+ , Graph.testSuite+ , URL.testSuite  ]  @@ -81,9 +87,12 @@ -- if certain conditions are met prop_betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString -> Property prop_betweenLinesPS start end ps =-  not (B.null start) && not (B.null end) &&-  (B.null ps || BC.last ps == '\n') ==>-  betweenLinesPS start end ps == spec_betweenLinesPS start end ps+  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'  -- ---------------------------------------------------------------------- -- * LCS
harness/Darcs/Test/Misc/CommandLine.hs view
@@ -3,6 +3,8 @@     commandLineTestSuite   ) where +import Darcs.Prelude+ import Test.HUnit ( assertEqual, assertFailure ) import Test.Framework.Providers.HUnit ( testCase ) import Test.Framework ( Test, testGroup )
harness/Darcs/Test/Misc/Encoding.hs view
@@ -1,5 +1,7 @@ module Darcs.Test.Misc.Encoding ( testSuite ) where +import Darcs.Prelude+ import qualified Data.ByteString as B import Control.Monad import Data.Word@@ -25,7 +27,12 @@  deriving Show  instance Arbitrary MyByteString where-  arbitrary = MBS <$> sized (\n -> vectorOf (100*n) arbitrary)+  arbitrary =+    MBS <$> frequency+      -- make sure we test some very long ByteStrings+      [ (1, sized (\n -> vectorOf (100*n) arbitrary))+      , (9, sized (\n -> vectorOf n arbitrary))+      ]   shrink (MBS ws) = MBS <$> shrinkList shrink ws  toBS :: MyByteString -> B.ByteString
+ harness/Darcs/Test/Misc/Graph.hs view
@@ -0,0 +1,57 @@+{- | Calculating the properties of graph algorithms scales very badly+because the specifications aren't optimised (naturally). Exhaustive testing+is a lot more effective than randomized testing in this case because it+avoids computations on large graphs. -}++module Darcs.Test.Misc.Graph ( testSuite ) where++import Darcs.Prelude++import Darcs.Util.Graph+  ( Graph+  , Component+  , genGraphs+  , genComponents+  , prop_ltmis_eq_bkmis+  , prop_ltmis_maximal_independent_sets+  , prop_ltmis_all_maximal_independent_sets+  , prop_components+  )++import Test.Framework+    ( Test+    , plusTestOptions+    , testGroup+    , topt_maximum_generated_tests+    )+import Test.Framework.Providers.LeanCheck ( testProperty )+import Test.LeanCheck++testSuite :: Test+testSuite =+  {- Unfortunately, test-framework is a bit limited in that it doesn't allow+  to scale the number of tests, just to set them to a fixed value. We opt to+  set it to 0x8000 which roughly covers the graphs up to size 6 and+  completes reasonably fast. The estimate is not precise because it doesn't+  account for graphs with more than one component; however, the overall+  error is not big because the majority of graphs have only one component,+  e.g. for graphs of size 6 the average number of components is 1.22. -}+  plusTestOptions (mempty { topt_maximum_generated_tests = Just 0x8000 }) $+  testGroup "Darcs.Util.Graph"+  [ testProperty "ltmis is equivalent to bkmis" prop_ltmis_eq_bkmis+  , testProperty+      "ltmis generates only maximal independent sets"+      prop_ltmis_maximal_independent_sets+  , testProperty+      "ltmis generates all maximal independent sets"+      prop_ltmis_all_maximal_independent_sets+  , testProperty+      "components generates all connected components"+      prop_components+  ]++instance Listable Graph where+  tiers = map genGraphs [0..]++instance Listable Component where+  tiers = map genComponents [0..]
+ harness/Darcs/Test/Misc/URL.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+module Darcs.Test.Misc.URL ( testSuite ) where++import Darcs.Prelude++import Test.HUnit ( assertEqual )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework ( Test, testGroup )++import Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl )++cases :: [(String, Bool, Bool, Bool)]+cases =+  -- input                                local   http    ssh+  [ ("http://host.domain/path/to/repo",   False,  True,   False)+  , ("https://host.domain/path/to/repo",  False,  True,   False)+  , ("http://host.domain/path:to/repo",   False,  True,   False)+  , ("https://host.domain/path:to/repo",  False,  True,   False)+  , ("http://host.domain/",               False,  True,   False)+  , ("https://host.domain/",              False,  True,   False)+#ifdef WIN32+  -- local paths valid only on Windows+  , ("a:/",                               True,   False,  False)+  , ("b:/absolute/path",                  True,   False,  False)+  , ("c:relative/path",                   True,   False,  False)+  , ("d:.",                               True,   False,  False)+  , ("e:..",                              True,   False,  False)+  , ("f:./relative/path",                 True,   False,  False)+  , ("g:../relative/path",                True,   False,  False)+  , ("A:\\",                              True,   False,  False)+  , ("B:\\absolute\\path",                True,   False,  False)+  , ("C:relative\\path",                  True,   False,  False)+  , ("D:.",                               True,   False,  False)+  , ("E:..",                              True,   False,  False)+  , ("F:.\\relative\\path",               True,   False,  False)+  , ("G:..\\relative\\path",              True,   False,  False)+#else+  -- local paths valid only on Posix+  , ("/absolute/path:with/colons",        True,   False,  False)+  , ("relative/path:with/colons",         True,   False,  False)+  , ("./relative/path:with/colons",       True,   False,  False)+  , ("../relative/path:with/colons",      True,   False,  False)+#endif+  , ("/",                                 True,   False,  False)+  , ("/absolute/path",                    True,   False,  False)+  , ("/absolute/path",                    True,   False,  False)+  , ("relative/path",                     True,   False,  False)+  , (".",                                 True,   False,  False)+  , ("..",                                True,   False,  False)+  , ("./relative/path",                   True,   False,  False)+  , ("../relative/path",                  True,   False,  False)+  -- ssh "URL"s+  , ("user@host:/path/to/repo",           False,  False,  True)+  , ("host:/path/to/repo",                False,  False,  True)+  , ("user@host:/path:with/colons/",      False,  False,  True)+  , ("host:/path:with/colons/",           False,  False,  True)+  ]++test :: (String, Bool, Bool, Bool) -> Test+test (input, local, http, ssh) = testCase input $ do+  assertEqual "isValidLocalPath" (isValidLocalPath input) local+  assertEqual "isHttpUrl" (isHttpUrl input) http+  assertEqual "isSshUrl" (isSshUrl input) ssh++testSuite :: Test+testSuite = testGroup "Darcs.Util.URL" $ map test cases
harness/Darcs/Test/Patch.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE AllowAmbiguousTypes  #-} --  Copyright (C) 2002-2005,2007 David Roundy -- --  This program is free software; you can redistribute it and/or modify@@ -16,60 +15,87 @@ --  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 Data.Maybe( isNothing )+import Darcs.Prelude++import Data.Constraint ( Dict(..) ) import Test.Framework ( Test, testGroup )-import Test.Framework.Providers.HUnit ( testCase ) import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.QuickCheck.Arbitrary( Arbitrary )-import Test.QuickCheck( Testable )-import Test.HUnit ( assertBool )+import Test.QuickCheck( Arbitrary(..) ) -import Darcs.Test.Util.TestResult ( TestResult, isOk, fromMaybe )-import Darcs.Test.Patch.Utils ( testConditional )+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, unsafeCompare )+import Darcs.Patch.Witnesses.Eq ( Eq2 ) import Darcs.Patch.Witnesses.Show-import Darcs.Patch.Prim( PrimPatch, coalesce, FromPrim, PrimOf )+import Darcs.Patch.Annotate ( Annotate )+import Darcs.Patch.FromPrim ( PrimOf, FromPrim(..) )+import Darcs.Patch.Prim ( PrimPatch, coalesce ) import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim )-import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.Type ( PatchType(..) )-import Darcs.Patch.V1 as V1 ( RepoPatchV1 ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim )+import Darcs.Patch.Prim.Named ( NamedPrim ) 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.Merge( Merge ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Apply( Apply, ApplyState )+import Darcs.Patch.Merge ( Merge )  import Darcs.Test.Patch.Arbitrary.Generic-import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1+import Darcs.Test.Patch.Arbitrary.Named ()+import Darcs.Test.Patch.Arbitrary.PatchTree import Darcs.Test.Patch.Arbitrary.PrimFileUUID()-import Darcs.Test.Patch.Arbitrary.RepoPatchV1 ()-import Darcs.Test.Patch.Arbitrary.RepoPatchV2+import Darcs.Test.Patch.Arbitrary.NamedPrimV1 ()+import Darcs.Test.Patch.Arbitrary.NamedPrimFileUUID ()+import Darcs.Test.Patch.Arbitrary.RepoPatch+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( WithState, WithStartState )+import Darcs.Test.Patch.WithState+    ( ArbitraryState+    , PropagateShrink+    , ShrinkModel+    , WithState+    , arbitraryTriple+    , makeS2Gen+    , makeWS2Gen+    , wesPatch+    )  import qualified Darcs.Test.Patch.Info import qualified Darcs.Test.Patch.Selection -import qualified Darcs.Test.Patch.Examples.Set1 as Ex import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU  import Darcs.Test.Patch.Properties.Check( Check(..) )-import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1-import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2+import Darcs.Test.Patch.Properties.Generic ( PatchProperty, MergeProperty, SequenceProperty ) import qualified Darcs.Test.Patch.Properties.Generic as PropG-import qualified Darcs.Test.Patch.Properties.RepoPatchV2 as PropR+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.Rebase as Rebase+import qualified Darcs.Test.Patch.Unwind as Unwind  import qualified Darcs.Test.Patch.WSub as WSub @@ -77,55 +103,43 @@ type Prim1 = V1.Prim type Prim2 = V2.Prim -newtype TestGenerator thing gen = TestGenerator (forall t ctx . ((forall wXx wYy . thing wXx wYy -> t) -> (gen ctx -> t)))-newtype TestCondition thing = TestCondition (forall wYy wZz . thing wYy wZz -> Bool)-newtype TestCheck thing t = TestCheck (forall wYy wZz . thing wYy wZz -> t)+-- Generic Arbitrary instances --- arbitraryThing :: (forall wXx wYy . thing wXx wYy -> t) -> (thing wA wB -> t)-arbitraryThing :: x -> TestGenerator thing (thing x)-arbitraryThing _ = TestGenerator (\f p -> f p)+-- We define them here so they don't overlap with those for RepoPatchV1,+-- which use a different generator for V1Model. --- | Run a test function on a set of data, using HUnit. The test function should---   return @Nothing@ upon success and a @Just x@ upon failure.-testCases :: Show a => String               -- ^ The test name-             -> (a -> TestResult)  -- ^ The test function-             -> [a]                -- ^ The test data-             -> Test-testCases name test datas = testCase name (assertBool assertName res)-    where assertName = "Boolean assertion for \"" ++ name ++ "\""-          res        = and $ map (isOk . test) datas+type ArbitraryModel p = (RepoModel (ModelOf p), ArbitraryState p) -unit_V1P1:: [Test]-unit_V1P1 =-  [ testCases "known commutes" Prop1.checkCommute Ex.knownCommutes-  , testCases "known non-commutes" Prop1.checkCantCommute Ex.knownCantCommutes-  , testCases "known merges" Prop1.checkMerge Ex.knownMerges-  , testCases "known merges (equiv)" Prop1.checkMergeEquiv Ex.knownMergeEquivs-  , testCases "known canons" Prop1.checkCanon Ex.knownCanons-  , testCases "merge swaps" Prop1.checkMergeSwap Ex.mergePairs2-  , testCases "the patch validation works" Prop1.tTestCheck Ex.validPatches-  , testCases "commute/recommute" (PropG.recommute commute) Ex.commutePairs-  , testCases "merge properties: merge either way valid" Prop1.tMergeEitherWayValid Ex.mergePairs-  , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs-  , testCases "primitive patch IO functions" (Prop1.tShowRead eqFLUnsafe) Ex.primitiveTestPatches-  , testCases "IO functions (test patches)" (Prop1.tShowRead eqFLUnsafe) Ex.testPatches-  , testCases "IO functions (named test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatchesNamed-  , testCases "primitive commute/recommute" (PropG.recommute commute) Ex.primitiveCommutePairs-  ]+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 "prim patch and inverse commute" (PropU.patchAndInverseCommute 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 prim patch and inverse commute" (PropU.patchAndInverseCommute 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.show_read ExU.primPatches-  , testCases "read and show work on RepoPatchV2" PropU.show_read ExU.repov2Patches-  , testCases "example flattenings work" PropU.consistentTreeFlattenings ExU.repov2PatchLoopExamples+  , 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@@ -136,120 +150,199 @@   , 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-  , testCases "V2 partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.repov2NonduplicateTriples   ]+  where+    fromPrim2 :: PropR.FromPrimT RepoPatchV2 Prim2+    fromPrim2 = fromAnonymousPrim -qc_prim :: forall prim wX wY wA model.-           (PrimPatch prim, ArbitraryPrim prim, Show2 prim-           , model ~ ModelOf prim, RepoModel model-           , RepoState model ~ ApplyState (PrimOf prim)+arbitraryThing :: TestGenerator thing (Sealed2 thing)+arbitraryThing = TestGenerator (\f p -> Just (unseal2 f p))++qc_prim :: forall prim.+           ( TestablePrim prim+           , Show2 prim            , Show1 (ModelOf prim)-           , Check prim, PrimOf prim ~ prim-           , FromPrim prim            , MightBeEmptyHunk prim            , MightHaveDuplicate prim-           , Show1 (prim wA)-           , Arbitrary (Sealed ((prim :> prim) wA))-           , Arbitrary (Sealed ((prim :> prim :> prim) wA))-           , Arbitrary (Sealed (prim wA))-           , Arbitrary (Sealed (FL prim wA))-           , Arbitrary (Sealed ((FL prim :> FL prim) wA))-           , Arbitrary (Sealed (WithState model prim wA))-           , Arbitrary (Sealed (WithState model (FL prim) wA))-           , Arbitrary (Sealed2 (WithState model (prim :> prim)))-           , Arbitrary (Sealed ((WithState model (prim :> prim)) wA))-           , Arbitrary (Sealed ((WithState model (FL prim :> FL prim)) wA))-           ) => prim wX wY -> [Test]-qc_prim p =-  -- The following fails because of setpref patches...+           , 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)-  (if runCoalesceTests p then-    [ testProperty "prim coalesce effect preserving... "-      (unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState model (prim :> prim)) -> TestResult)-    ]-   else [])+  (case runCoalesceTests @prim of+    Just Dict ->+      [ testProperty "prim coalesce effect preserving"+        (unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState (prim :> prim)) -> TestResult)+      ]+    Nothing -> [])     ++ concat-  [ pair_properties            (undefined :: prim wX wY)    "arbitrary"    arbitraryThing'-  , pair_properties            (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing'-  , coalesce_properties        (undefined :: prim wX wY)    "arbitrary"    arbitraryThing'-  , nonrpv2_commute_properties (undefined :: prim wX wY)    "arbitrary"    arbitraryThing'-  , nonrpv2_commute_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing'-  , patch_properties           (undefined :: prim wX wA)    "arbitrary"    arbitraryThing'-  , patch_properties           (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'-  , patch_repo_properties      (undefined :: prim wX wA)    "arbitrary"    arbitraryThing'-  , patch_repo_properties      (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'-  , pair_repo_properties       (undefined :: prim wX wA)    "arbitrary"    arbitraryThing'-  , pair_repo_properties       (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'+  [ 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)+    ]   ]-      where arbitraryThing' = arbitraryThing (undefined :: wA) -- bind the witness for generator -consistentV2 :: RepoPatchV2 Prim2 wX wY -> TestResult-consistentV2 = fromMaybe . isConsistent--commuteRepoPatchV2s :: (RepoPatchV2 Prim2 :> RepoPatchV2 Prim2) wX wY -> Maybe ((RepoPatchV2 Prim2 :> RepoPatchV2 Prim2) wX wY)-commuteRepoPatchV2s = commute--qc_V2P1 :: [Test]-qc_V2P1 =-  [ testProperty "tree flattenings are consistent... "-    (PropR.propConsistentTreeFlattenings :: Sealed (WithStartState (ModelOf Prim2) (Tree Prim2)) -> Bool)-  , testProperty "with quickcheck that RepoPatchV2 patches are consistent... "-    (unseal $ P1.patchFromTree $ consistentV2)-  -- permutivity -----------------------------------------------------------------------------  , testConditional "permutivity"-    (unseal $ P1.commuteTripleFromTree notDuplicatestriple)-    (unseal $ P1.commuteTripleFromTree $ PropG.permutivity commuteRepoPatchV2s)-  , testConditional "partial permutivity"-    (unseal $ P1.commuteTripleFromTree notDuplicatestriple)-    (unseal $ P1.commuteTripleFromTree $ PropG.partialPermutivity commuteRepoPatchV2s)-  , testConditional "nontrivial permutivity"-    (unseal $ P1.commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t))-    (unseal $ P1.commuteTripleFromTree $ (PropG.permutivity commuteRepoPatchV2s))+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, Show1 (ModelOf prim), RepoModel (ModelOf prim),-                                  ArbitraryPrim prim, Show2 prim,-                                  RepoState (ModelOf prim) ~ ApplyState prim)+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 "readPatch and showPatch work on RepoPatchV2... "-    (unseal $ patchFromTree $ (PropG.show_read :: RepoPatchV2 prim wX wY -> TestResult))-  , testProperty "readPatch and showPatch work on FL RepoPatchV2... "-    (unseal2 $ (PropG.show_read :: FL (RepoPatchV2 prim) wX wY -> TestResult))-  , testProperty "we can do merges using QuickCheck"-    (isNothing . (PropG.propIsMergeable ::-                     Sealed (WithStartState (ModelOf prim) (Tree prim))-                     -> Maybe (Tree (RepoPatchV2 prim) wX)))+  [ testProperty "with quickcheck that patches are consistent"+    (withSingle consistent)   ]+  ++ repoPatchProperties @(RepoPatchV2 prim)   ++ concat-  [ merge_properties   (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator mergePairFromTree)-  , merge_properties   (undefined :: RepoPatchV2 prim wX wY) "twfp" (TestGenerator mergePairFromTWFP)-  , pair_properties    (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator commutePairFromTree)-  , pair_properties    (undefined :: RepoPatchV2 prim wX wY) "twfp" (TestGenerator commutePairFromTWFP)-  , patch_properties   (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator patchFromTree)+  [ 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 -properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen)) =>-              TestGenerator thing gen-           -- -> forall xx yy. thing xx yy-           -> String -> String-           -> forall t. Testable t => [(String, TestCondition thing, TestCheck thing t)]-           -> [Test]-properties (TestGenerator gen) prefix genname tests =-  [ cond name condition check | (name, condition, check) <- tests ]-  where cond :: forall testable. Testable testable-             => String -> TestCondition thing -> TestCheck thing testable -> Test-        cond t (TestCondition c) (TestCheck p) =-          testConditional (prefix ++ " (" ++ genname ++ "): " ++ t) (unseal $ gen c) (unseal $ gen p)+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) -type PropList what gen = String -> TestGenerator what gen -> [Test]+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))+  ] -pair_properties :: forall p gen x y-                 . ( Show1 gen, Arbitrary (Sealed gen), MightHaveDuplicate 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                    )-                => p x y -> PropList (p :> p) gen-pair_properties _ genname gen =+                => 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)           )@@ -258,47 +351,88 @@   , ("inverse composition"    , TestCondition (const True)     , TestCheck PropG.inverseComposition            )   ] -coalesce_properties :: forall p gen x y-                     . ( Show1 gen, Arbitrary (Sealed gen), PrimPatch p-                       , ArbitraryPrim p, MightBeEmptyHunk p+coalesce_properties :: forall p gen+                     . ( Show gen, Arbitrary gen, TestablePrim p+                       , MightBeEmptyHunk p                        )-                    => p x y -> PropList (p :> p :> p) gen-coalesce_properties p genname gen =+                    => PropList (p :> p :> p) gen+coalesce_properties genname gen =   properties gen "commute" genname-   (if runCoalesceTests p then [ ("coalesce commutes with commute", TestCondition (const True), TestCheck (PropG.coalesceCommute coalesce)) ] else [])+   (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) .-nonrpv2_commute_properties :: forall p gen x y-                            . (Show1 gen, Arbitrary (Sealed gen), Commute p, Invert p, ShowPatchBasic p, Eq2 p)-                           => p x y -> PropList (p :> p) gen-nonrpv2_commute_properties _ genname gen =+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-  [ ("patch & inverse commute", TestCondition (const True)     , TestCheck (PropG.patchAndInverseCommute commute))-  , ("patch & inverse commute", TestCondition nontrivialCommute, TestCheck (PropG.patchAndInverseCommute commute))+  [ ("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 x y. (Show1 gen, Arbitrary (Sealed gen), Invert p, Apply p, Eq2 p)-                 => p x y -> PropList p gen-patch_properties _ genname gen =+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.invertSymmetry)+  [ ("inverse . inverse is id"  , TestCondition (const True)     , TestCheck PropG.invertInvolution)   ] -patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen),-                                            Invert p, Apply p, ShowPatchBasic p,-                                            RepoModel (ModelOf (PrimOf p)),-                                            RepoState (ModelOf (PrimOf p)) ~ ApplyState p)-                      => p x y -> PropList (WithState (ModelOf (PrimOf p)) p) gen-patch_repo_properties _ genname gen =+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 x y.-     ( Show1 gen-     , Arbitrary (Sealed gen)+  :: forall p gen .+     ( Show gen+     , Arbitrary gen      , Commute p      , Apply p      , ShowPatchBasic p@@ -306,92 +440,58 @@      , RepoModel (ModelOf p)      , RepoState (ModelOf p) ~ ApplyState p      )-  => p x y -> PropList (WithState (ModelOf p) (p :> p)) gen-pair_repo_properties _ genname gen =-  properties-    gen-    "patch/repo"-    genname+  => 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))     ] -merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen)-                                      , Invert p, Eq2 p, Merge p, ShowPatchBasic p-                                      , MightHaveDuplicate p, Show2 p, Check p)-                 => p x y -> PropList (p :\/: p) gen-merge_properties _ genname gen =-  properties gen "merge" genname-  [ ("merge either way"           , TestCondition (const True)   , TestCheck PropG.mergeEitherWay      )-  , ("merge either way valid"     , TestCondition (const True)   , TestCheck Prop1.tMergeEitherWayValid)-  , ("nontrivial merge either way", TestCondition nontrivialMerge, TestCheck PropG.mergeEitherWay      )-  , ("merge commute"              , TestCondition (const True)   , TestCheck PropG.mergeCommute        )-  ]--qc_V1P1 :: [Test]-qc_V1P1 =-  [-    testProperty "show and read work right" (unseal Prop2.propReadShow)-  ]-  ++ Prop2.checkSubcommutes Prop2.subcommutesInverse "patch and inverse both commute"-  ++ Prop2.checkSubcommutes Prop2.subcommutesNontrivialInverse "nontrivial commutes are correct"-  ++ Prop2.checkSubcommutes Prop2.subcommutesFailure "inverses fail"-  ++-  [ testProperty "commuting by patch and its inverse is ok" Prop2.propCommuteInverse-  -- , testProperty "conflict resolution is valid... " Prop.propResolveConflictsValid-  , testProperty "a patch followed by its inverse is identity"-    Prop2.propPatchAndInverseIsIdentity-  , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough-  , testProperty "commutes are equivalent" Prop2.propCommuteEquivalency-  , testProperty "merges are valid" Prop2.propMergeValid-  , testProperty "inverses being valid" Prop2.propInverseValid-  , testProperty "other inverse being valid" Prop2.propOtherInverseValid-  -- The patch generator isn't smart enough to generate correct test cases for-  -- the following: (which will be obsoleted soon, anyhow)-  -- , testProperty "the order dependence of unravel... " Prop.propUnravelOrderIndependent-  -- , testProperty "the unravelling of three merges... " Prop.propUnravelThreeMerge-  -- , testProperty "the unravelling of a merge of a sequence... " Prop.propUnravelSeqMerge-  , testProperty "the order of commutes" Prop2.propCommuteEitherOrder-  , testProperty "commute either way" Prop2.propCommuteEitherWay-  , testProperty "the double commute" Prop2.propCommuteTwice-  , testProperty "merges commute and are well behaved"-    Prop2.propMergeIsCommutableAndCorrect-  , testProperty "merges can be swapped" Prop2.propMergeIsSwapable-  , testProperty "again that merges can be swapped (I'm paranoid) " Prop2.propMergeIsSwapable--  ] -- the following properties are disabled, because they routinely lead to-    -- exponential cases, making the tests run for ever and ever; nevertheless,-    -- we would expect them to hold- {- ++ merge_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "tree" mergePairFromTree-    ++ merge_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "twfp" mergePairFromTWFP-    ++ commute_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "tree" commutePairFromTree-    ++ commute_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "twfp" commutePairFromTWFP -}- -- tests (either QuickCheck or Unit) that should be run on any type of patch-general_patchTests :: (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType rt p -> [Test]-general_patchTests pt =-     [ testGroup "Rebase patches" $ Rebase.testSuite pt+general_patchTests+  :: forall p+   . ( ArbitraryRepoPatch p, CheckedMerge p+     , PrimBased p, Commute (OnlyPrim p), ArbitraryPrim (OnlyPrim p)+     , ShrinkModel (PrimOf p)+     , Show1 (ModelOf (PrimOf p)), Show2 p+     )+  => [Test]+general_patchTests =+     [ testGroup "Rebase patches" $ Rebase.testSuite @p+     , testGroup "Unwind" $ Unwind.testSuite @p      ]  -- | This is the big list of tests that will be run using testrunner. testSuite :: [Test] testSuite =-  [ testGroup "Darcs.Patch.Prim.V1 for V1" $ qc_prim (undefined :: Prim1 wX wY)-    -- testing both Prim1 and Prim2 here is redundant, since they differ-    -- only in their read/show behavior, which is not tested in qc_prim;-    -- we still include them because such tests might be added in the future-  , testGroup "Darcs.Patch.Prim.V1 for V2" $ qc_prim (undefined :: Prim2 wX wY)-  , testGroup "Darcs.Patch.Prim.FileUUID" $ qc_prim (undefined :: FileUUID.Prim wX wY)-  , testGroup "Darcs.Patch.V1 (using Prim.V1)" $-      unit_V1P1 ++ qc_V1P1 ++-      general_patchTests (PatchType :: PatchType rt (V1.RepoPatchV1 Prim1))-  , testGroup "Darcs.Patch.V2 (using Prim.V1)" $-      unit_V2P1 ++ qc_V2 (undefined :: Prim2 wX wY) ++ qc_V2P1 ++-      general_patchTests (PatchType :: PatchType rt (RepoPatchV2 Prim2))-  , testGroup "Darcs.Patch.V2 (using Prim.FileUUID)" $-      qc_V2 (undefined :: FileUUID.Prim wX wY) ++-      general_patchTests (PatchType :: PatchType rt (RepoPatchV2 FileUUID.Prim))-  , Darcs.Test.Patch.Info.testSuite-  , Darcs.Test.Patch.Selection.testSuite-  ]+    [ primTests+    , repoPatchV2Tests+    , repoPatchV3Tests+    , Darcs.Test.Patch.Info.testSuite+    , Darcs.Test.Patch.Selection.testSuite+    ]+  where+    primTests = testGroup "Prim patches"+      [ testGroup "V1.Prim wrapper for Prim.V1" $ qc_prim @Prim1+      , testGroup "V2.Prim wrapper for Prim.V1" $ qc_prim @Prim2+      , testGroup "Prim.FileUUID" $ qc_prim @FileUUID.Prim+      , testGroup "NamedPrim over V2.Prim" $ qc_named_prim @Prim2+      , testGroup "NamedPrim over Prim.FileUUID" $ qc_named_prim @FileUUID.Prim+      ]+    repoPatchV2Tests = testGroup "RepoPatchV2"+      [ testGroup "using V2.Prim wrapper for Prim.V1" $+          unit_V2P1 ++ qc_V2 (undefined :: Prim2 wX wY) +++          general_patchTests @(RepoPatchV2 Prim2)+      , testGroup "using Prim.FileUUID" $+          qc_V2 (undefined :: FileUUID.Prim wX wY) +++          general_patchTests @(RepoPatchV2 FileUUID.Prim)+      ]+    repoPatchV3Tests = testGroup "RepoPatchV3"+      [ testGroup "using V2.Prim wrapper for Prim.V1" $+          qc_V3 (undefined :: Prim2 wX wY) +++          general_patchTests @(RepoPatchV3 Prim2)+      , testGroup "using Prim.FileUUID" $+          qc_V3 (undefined :: FileUUID.Prim wX wY) +++          general_patchTests @(RepoPatchV3 FileUUID.Prim)+      ]
harness/Darcs/Test/Patch/Arbitrary/Generic.hs view
@@ -1,107 +1,51 @@-{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,-             FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-} module Darcs.Test.Patch.Arbitrary.Generic-       ( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim(..), NullPatch(..), RepoModel(..)-       , MightBeEmptyHunk(..), MightHaveDuplicate(..)-       , flattenOne, flattenTree, mapTree, sizeTree-       , commutePairFromTree, mergePairFromTree-       , commuteTripleFromTree, mergePairFromCommutePair-       , commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples-       , patchFromTree-       , canonizeTree-       , quickCheck-       ) where+  ( ArbitraryPrim(..)+  , ShrinkPrim+  , TestablePrim+  , PrimBased(..)+  , NullPatch(..)+  , RepoModel(..)+  , MightBeEmptyHunk(..)+  , MightHaveDuplicate(..)+  , nontrivialCommute+  , nontrivialTriple+  , nontrivialMerge+  , notDuplicatestriple+  , MergeableSequence(..)+  , arbitraryMergeableSequence+  , mergeableSequenceToRL+  ) where -import Control.Monad ( liftM )+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.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.Merge ( Merge(..) )+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.Invert ( Invert(..) ) import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Prim ( PrimOf, PrimPatch, PrimPatchBase, FromPrim(..), PrimConstruct( anIdentity ) )-import Darcs.Patch.V2 ( RepoPatchV2 ) -- XXX this is more or less a hack---import Darcs.ColorPrinter ( errorDoc )---import Darcs.ColorPrinter ( traceDoc )+import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )+import Darcs.Patch.Prim ( sortCoalesceFL, PrimCanonize, PrimConstruct )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Witnesses.Show---import Darcs.Util.Printer ( greenText, ($$) ) --- | Generate a patch to a certain state.-class ArbitraryStateIn s p where-  arbitraryStateIn :: s wX -> Gen (p wX)--data Tree p wX where-   NilTree :: Tree p wX-   SeqTree :: p wX wY -> Tree p wY -> Tree p wX-   ParTree :: Tree p wX -> Tree p wX -> Tree p wX--mapTree :: (forall wY wZ . p wY wZ -> q wY wZ) -> Tree p wX -> Tree q wX-mapTree _ NilTree = NilTree-mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)-mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)--instance Show2 p => Show (Tree p wX) where-   showsPrec _ NilTree = showString "NilTree"-   showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .-                               showsPrec2 (appPrec + 1) a . showString " " .-                               showsPrec (appPrec + 1) t-   showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .-                                 showsPrec (appPrec + 1) t1 . showString " " .-                                 showsPrec (appPrec + 1) t2--instance Show2 p => Show1 (Tree p) where-    showDict1 = ShowDictClass--instance Show2 p => Show1 (TreeWithFlattenPos p) where-    showDict1 = ShowDictClass--sizeTree :: Tree p wX -> Int-sizeTree NilTree = 0-sizeTree (SeqTree _ t) = 1 + sizeTree t-sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2---- newtype G1 l p wX = G1 { _unG1 :: l (p wX) }-newtype G2 l p wX wY = G2 { unG2 :: l (p wX wY) }--flattenTree :: (Merge p) => Tree p wZ -> Sealed (G2 [] (FL p) wZ)-flattenTree NilTree = seal $ G2 $ return NilFL-flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t-flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2))-                            = seal $ G2 $-                              do ps1 <- unG2 gpss1-                                 ps2 <- unG2 gpss2-                                 ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)-                                 -- We can't prove that the existential type in the result-                                 -- of merge will be the same for each pair of-                                 -- ps1 and ps2.-                                 map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']--instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where-  -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).-  -- Note if we don't put a non-zero lower bound the first generated trees will always have depth 0.-  arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth---- | Generate a tree of patches, bounded by the depth @maxDepth@.-arbitraryTree :: ArbitraryState s p => s wX -> Int -> Gen (Tree p wX)-arbitraryTree rm depth-    | depth == 0 = return NilTree-                      -- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.-                      -- For the purpose of this module empty trees are useless, but even when-                      -- NilTree case is omitted there is still a small percentage of empty trees-                      -- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.-    | otherwise  = frequency [(1, do Sealed (WithEndState p rm') <- arbitraryState rm-                                     t <- arbitraryTree rm' (depth - 1)-                                     return (SeqTree p t))-                             ,(3, do t1 <- arbitraryTree rm (depth - 1)-                                     t2 <- arbitraryTree rm (depth - 1)-                                     return (ParTree t1 t2))]-- class NullPatch p where   nullPatch :: p wX wY -> EqCheck wX wY @@ -126,139 +70,328 @@   hasDuplicate NilFL = False   hasDuplicate (p :>: ps) = hasDuplicate p || hasDuplicate ps +nontrivialCommute :: (Commute p, Eq2 p) => (p :> p) wX wY -> Bool+nontrivialCommute (x :> y) =+  case commute (x :> y) of+    Just (y' :> x') -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x)+    Nothing -> False -class ( ArbitraryState (ModelOf prim) prim+nontrivialMerge :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool+nontrivialMerge (x :\/: y) =+  case merge (x :\/: y) of+    y' :/\: x' -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x)++nontrivialTriple :: (Eq2 p, Commute p) => (p :> p :> p) wX wY -> Bool+nontrivialTriple (a :> b :> c) =+  case commute (a :> b) of+    Nothing -> False+    Just (b' :> a') ->+      case commute (a' :> c) of+        Nothing -> False+        Just (c'' :> a'') ->+          case commute (b :> c) of+            Nothing -> False+            Just (c' :> b'') ->+              (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&+              (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&+              (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))++notDuplicatestriple :: MightHaveDuplicate p => (p :> p :> p) wX wY -> Bool+notDuplicatestriple (a :> b :> c) =+  not (hasDuplicate a || hasDuplicate b || hasDuplicate c)++class ( ArbitraryState prim       , NullPatch prim-      , PrimPatch prim       , RepoModel (ModelOf prim)+      , Shrinkable prim       )       => ArbitraryPrim prim     where         -- hooks to disable certain kinds of tests for certain kinds of patches-        runCoalesceTests :: prim wX wY -> Bool-        runCoalesceTests _ = True -        hasPrimConstruct :: prim wX wY -> Bool-        hasPrimConstruct _ = True+        -- These tests depend on the PrimCanonize 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 = Just Dict +        -- TODO in practice both hasPrimConstruct and usesV1Model will only work for V1 prims+        -- and their newtypes. Consider merging into one method. --- canonize a tree, removing any dead branches-canonizeTree :: NullPatch p => Tree p wX -> Tree p wX-canonizeTree NilTree = NilTree-canonizeTree (ParTree t1 t2)-    | NilTree <- canonizeTree t1 = canonizeTree t2-    | NilTree <- canonizeTree t2 = canonizeTree t1-    | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)-canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t-                           | otherwise = SeqTree p (canonizeTree t)+        hasPrimConstruct :: Maybe (Dict (PrimConstruct prim))+        default hasPrimConstruct :: PrimConstruct prim => Maybe (Dict (PrimConstruct prim))+        hasPrimConstruct = Just Dict +        usesV1Model :: Maybe (Dict (ModelOf prim ~ V1Model))+        default usesV1Model :: ModelOf prim ~ V1Model => Maybe (Dict (ModelOf prim ~ V1Model))+        usesV1Model = Just Dict -instance (RepoModel model, ArbitraryPrim prim, model ~ ModelOf prim,-          ArbitraryState model prim) => Arbitrary (Sealed (WithStartState model (Tree prim))) where-  arbitrary = do repo <- aSmallRepo-                 Sealed (WithStartState rm tree) <--                     liftM (seal . WithStartState repo) (arbitraryStateIn repo)-                 return $ Sealed $ WithStartState rm (canonizeTree tree)+type ShrinkPrim prim =+  ( ShrinkModel prim+  , PropagateShrink prim prim+  ) -flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) wX -> Sealed (FL p wX)-flattenOne NilTree = seal NilFL-flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromPrim p :>: ps)-flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =-    --traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$-    --          greenText "ps2" $$ showPatch ps2) $-    case merge (ps1 :\/: ps2) of-      ps2' :/\: _ -> seal (ps1 +>+ ps2')+type TestablePrim prim =+  ( Apply prim, Commute prim, Invert prim, Eq2 prim+  , PatchListFormat prim, ShowPatchBasic prim, ReadPatch prim+  , RepoModel (ModelOf prim), ApplyState prim ~ RepoState (ModelOf prim)+  , ArbitraryPrim prim+  ) -data TreeWithFlattenPos p wX = TWFP Int (Tree p wX)+-- | 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 -commutePairFromTWFP :: (FromPrim p, Merge p, PrimPatchBase p)-                    => (forall wY wZ . (p :> p) wY wZ -> t)-                    -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) wX -> t)-commutePairFromTWFP handlePair (WithStartState _ (TWFP n t))-    = unseal2 handlePair $-      let xs = unseal getPairs (flattenOne t)-      in if length xs > n && n >= 0 then xs!!n else seal2 (fromPrim anIdentity :> fromPrim anIdentity)+-- | 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') -commutePairFromTree :: (FromPrim p, Merge p, PrimPatchBase p)-                    => (forall wY wZ . (p :> p) wY wZ -> t)-                    -> (WithStartState model (Tree (PrimOf p)) wX -> t)-commutePairFromTree handlePair (WithStartState _ t)-   = unseal2 handlePair $-     case flattenOne t of-       Sealed ps ->-         let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $-                 getPairs ps-         in if null xs then seal2 (fromPrim anIdentity :> fromPrim anIdentity) else last xs+-- |Given a patch type that contains mergeable patches, such as+-- @RepoPatchV1 prim@ or @Named (RepoPatchV1 prim)@, construct the+-- equivalent conflict-free types, e.g. @prim@ / @Named prim@ respectively.+class ( Effect p, Show2 (OnlyPrim p), ArbitraryState (OnlyPrim p)+      , Shrinkable (OnlyPrim p), PropagateShrink (PrimOf p) (OnlyPrim p)+      , ModelOf p ~ ModelOf (OnlyPrim p)+      )+    => PrimBased p where+  type OnlyPrim p :: * -> * -> *+  primEffect :: OnlyPrim p wX wY -> FL (PrimOf p) wX wY+  liftFromPrim :: OnlyPrim p wX wY -> p wX wY -commuteTripleFromTree :: (FromPrim p, Merge p, PrimPatchBase p)-                      => (forall wY wZ . (p :> p :> p) wY wZ -> t)-                      -> (WithStartState model (Tree (PrimOf p)) wX -> t)-commuteTripleFromTree handle (WithStartState _ t)-   = unseal2 handle $-     case flattenOne t of-       Sealed ps ->-         let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $-                  getTriples ps-         in if null xs-            then seal2 (fromPrim anIdentity :> fromPrim anIdentity :> fromPrim anIdentity)-            else last xs+instance (Commute (OnlyPrim p), PrimBased p) => PrimBased (FL p) where+  type OnlyPrim (FL p) = FL (OnlyPrim p)+  primEffect = concatFL . mapFL_FL (primEffect @p)+  liftFromPrim = mapFL_FL liftFromPrim -mergePairFromCommutePair :: (Commute p, Invert p)-                         => (forall wY wZ . (p :\/: p) wY wZ -> t)-                         -> (forall wY wZ . (p :>   p) wY wZ -> t)-mergePairFromCommutePair handlePair (a :> b)- = case commute (a :> b) of-     Just (b' :> _) -> handlePair (a :\/: b')-     Nothing -> handlePair (b :\/: b)+-- | 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) --- impredicativity problems mean we can't use (.) in the definitions below+instance PrimPatchBase p => PrimPatchBase (MergeableSequence p) where+  type PrimOf (MergeableSequence p) = PrimOf p -mergePairFromTWFP :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)-                  => (forall wY wZ . (p :\/: p) wY wZ -> t)-                  -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) wX -> t)-mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)+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' -mergePairFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)-                  => (forall wY wZ . (p :\/: p) wY wZ -> t)-                  -> (WithStartState model (Tree (PrimOf p)) wX -> t)-mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x) -patchFromCommutePair :: (Commute p, Invert p)-                     => (forall wY wZ . p wY wZ -> t)-                     -> (forall wY wZ . (p :> p) wY wZ -> t)-patchFromCommutePair handle (_ :> b) = handle b+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') -patchFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)-              => (forall wY wZ . p wY wZ -> t)-              -> (WithStartState model (Tree (PrimOf p)) wX -> t)-patchFromTree x = commutePairFromTree (patchFromCommutePair x)+instance (Show2 p, 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) -instance Show2 p => Show (TreeWithFlattenPos p wX) where-   showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .-                            showsPrec (appPrec + 1) n . showString " " .-                            showsPrec1 (appPrec + 1) t+type instance ModelOf (MergeableSequence p) = ModelOf p -getPairs :: FL p wX wY -> [Sealed2 (p :> p)]-getPairs NilFL = []-getPairs (_:>:NilFL) = []-getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)+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 -getTriples :: FL p wX wY -> [Sealed2 (p :> p :> p)]-getTriples NilFL = []-getTriples (_:>:NilFL) = []-getTriples (_:>:_:>:NilFL) = []-getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)+instance 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 -instance (ArbitraryPrim prim, RepoModel (ModelOf prim), model ~ ModelOf prim,-          ArbitraryState model prim)-         => Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where-   arbitrary = do Sealed (WithStartState rm t) <- arbitrary-                  let num = unseal (length . getPairs) (flattenOneRP t)-                  if num == 0 then return $ Sealed $ WithStartState rm $ TWFP 0 NilTree-                    else do n <- choose (0, num - 1)-                            return $ Sealed $ WithStartState rm $ TWFP n t-                    where -- just used to get the length. In principle this should be independent of the patch type.-                          flattenOneRP :: Tree prim wX -> Sealed (FL (RepoPatchV2 prim) wX)-                          flattenOneRP = flattenOne+  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
@@ -0,0 +1,51 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Arbitrary.Named+  (+  ) where++import Darcs.Prelude++import Darcs.Test.Patch.Info ()+import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Shrink+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.WithState++import Darcs.Patch.Commute+import Darcs.Patch.Named+import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed++import Control.Applicative ( (<|>) )+import Test.QuickCheck++type instance ModelOf (Named prim) = ModelOf prim++instance ArbitraryState prim => ArbitraryState (Named prim) where+  arbitraryState rm = do+    info <- arbitrary+    Sealed (WithEndState prims rm') <- arbitraryState rm+    return $ Sealed $ WithEndState (NamedP info [] prims) rm'++instance (Commute p, Shrinkable p) => Shrinkable (Named p) where+  shrinkInternally (NamedP pi deps ps) =+    -- TODO this isn't quite right because other patches might+    -- explicitly depend on this one+    (\pi' -> NamedP pi' deps ps) <$> shrink pi+    <|>+    NamedP pi deps <$> shrinkInternally ps++  shrinkAtStart (NamedP pi deps ps) = mapFlipped (NamedP pi deps) <$> shrinkAtStart ps+  shrinkAtEnd (NamedP pi deps ps) = mapSeal (NamedP pi deps) <$> shrinkAtEnd ps++instance PropagateShrink prim p => PropagateShrink prim (Named p) where+  propagateShrink (prim :> NamedP pi deps ps) = do+    mps' :> mprim' <- propagateShrink (prim :> ps)+    return (mapMB_MB (NamedP pi deps) mps' :> mprim')++instance (Commute (OnlyPrim p), PrimBased p) => PrimBased (Named p) where+  type OnlyPrim (Named p) = Named (OnlyPrim p)++  primEffect (NamedP _ _ ps) = primEffect @(FL p) ps+  liftFromPrim (NamedP pi deps ps) = NamedP pi deps (liftFromPrim ps)
+ harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings, UndecidableInstances #-}+module Darcs.Test.Patch.Arbitrary.NamedPrim ( aPatchId ) where++import Prelude ()+import Darcs.Prelude+import Test.QuickCheck+import Test.QuickCheck.Gen ( chooseAny )++import Darcs.Patch.Prim.Named ( NamedPrim, namedPrim, PrimPatchId, unsafePrimPatchId )+import Darcs.Patch.Prim.WithName ( PrimWithName(..), wnPatch )+import Darcs.Util.Hash ( SHA1(..) )++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Shrink++import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.TestOnly.Instance ()++import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed++type instance ModelOf (NamedPrim p) = ModelOf p+instance+    ( RepoModel (ModelOf p)+    , ArbitraryState (NamedPrim p)+    , ArbitraryPrim p+    )+  => ArbitraryPrim (NamedPrim p) where+    runCoalesceTests = Nothing+    hasPrimConstruct = Nothing+    usesV1Model = Nothing++instance Shrinkable prim => Shrinkable (PrimWithName n prim) where+  shrinkInternally (PrimWithName n p) = PrimWithName n <$> shrinkInternally p+  shrinkAtEnd (PrimWithName n p) = mapSeal (PrimWithName n) <$> shrinkAtEnd p+  shrinkAtStart (PrimWithName n p) = mapFlipped (PrimWithName n) <$> shrinkAtStart p++instance MightBeEmptyHunk p => MightBeEmptyHunk (NamedPrim p) where+  isEmptyHunk = isEmptyHunk . wnPatch++instance MightHaveDuplicate (NamedPrim p)++instance NullPatch p => NullPatch (NamedPrim p) where+  nullPatch p = nullPatch (wnPatch p)++instance ArbitraryState prim => ArbitraryState (NamedPrim prim) where+  arbitraryState repo = do+    Sealed (WithEndState p repo') <- arbitraryState repo+    pid <- aPatchId+    return $ Sealed $ WithEndState (namedPrim pid p) repo'+++instance PropagateShrink prim1 prim2 => PropagateShrink prim1 (PrimWithName n2 prim2) where+  propagateShrink (p1 :> PrimWithName n2 p2) = do+    mp2' :> mp1' <- propagateShrink (p1 :> p2)+    return (mapMB_MB (PrimWithName n2) mp2' :> mp1')++aPatchId :: Gen PrimPatchId+aPatchId = unsafePrimPatchId <$> (arbitrarySizedNatural `suchThat` (> 0)) <*> aHash++aHash :: Gen SHA1+aHash =+  -- it's important to avoid hash collisions, so we use chooseAny rather+  -- than arbitrary so that the values generated are uniformly distributed+  SHA1 <$> chooseAny <*> chooseAny <*> chooseAny <*> chooseAny <*> chooseAny
+ harness/Darcs/Test/Patch/Arbitrary/NamedPrimFileUUID.hs view
@@ -0,0 +1,50 @@+{-# 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 view
@@ -0,0 +1,50 @@+{-# 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/PatchTree.hs view
@@ -0,0 +1,264 @@+-- UndecidableInstances was added because GHC 8.6 needed it+-- even though GHC 8.2 didn't+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+module Darcs.Test.Patch.Arbitrary.PatchTree+  ( Tree(..)+  , TreeWithFlattenPos(..)+  , G2(..)+  , flattenOne+  , flattenTree+  , mapTree+  , commutePairFromTree+  , mergePairFromTree+  , commuteTripleFromTree+  , mergePairFromCommutePair+  , commutePairFromTWFP+  , mergePairFromTWFP+  , getPairs+  , getTriples+  , patchFromTree+  , canonizeTree+  ) where++import Darcs.Prelude++import Test.QuickCheck++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Util.QuickCheck ( bSized )++import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.FromPrim ( FromPrim(..), PrimOf )+import Darcs.Patch.Witnesses.Show++-- | A 'Tree' of patches 'p' starting at state 'wX' simulating+-- several branches of a repo. The end states of the branches+-- may of course differ.+data Tree p wX where+   NilTree :: Tree p wX+   SeqTree :: p wX wY -> Tree p wY -> Tree p wX+   ParTree :: Tree p wX -> Tree p wX -> Tree p wX++mapTree :: (forall wY wZ . p wY wZ -> q wY wZ) -> Tree p wX -> Tree q wX+mapTree _ NilTree = NilTree+mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)+mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)++instance Show2 p => Show (Tree p wX) where+   showsPrec _ NilTree = showString "NilTree"+   showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .+                               showsPrec2 (appPrec + 1) a . showString " " .+                               showsPrec (appPrec + 1) t+   showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .+                                 showsPrec (appPrec + 1) t1 . showString " " .+                                 showsPrec (appPrec + 1) t2++instance Show2 p => Show1 (Tree p)++instance Show2 p => Show1 (TreeWithFlattenPos p)++-- | The number of patches in a 'Tree'. This is the (common) length of all+-- elements of 'flattenTree'.+sizeTree :: Tree p wX -> Int+sizeTree NilTree = 0+sizeTree (SeqTree _ t) = 1 + sizeTree t+sizeTree (ParTree t1 t2) = sizeTree t1 + sizeTree t2++-- | The number of successive pairs in a flattened 'Tree'.+numPairs :: Tree p wX -> Int+numPairs t =+  case sizeTree t of+    0 -> 0+    s -> s - 1++-- | The number of successive triples in a flattened 'Tree'.+numTriples :: Tree p wX -> Int+numTriples t =+  case sizeTree t of+    0 -> 0+    1 -> 0+    s -> s - 2++newtype G2 l p wX wY = G2 { unG2 :: l (p wX wY) }++-- | All possible ways that the several branches of a 'Tree' can be+-- merged into a linear sequence.+flattenTree :: (Merge p) => Tree p wZ -> Sealed (G2 [] (FL p) wZ)+flattenTree NilTree = seal $ G2 $ return NilFL+flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t+flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2)) =+  seal $+  G2 $ do+    ps1 <- unG2 gpss1+    ps2 <- unG2 gpss2+    ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)+    -- We can't prove that the existential type in the result+    -- of merge will be the same for each pair of ps1 and ps2.+    map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']++-- | Generate a tree of patches, bounded by depth.+arbitraryTree :: ArbitraryState p => ModelOf p wX -> Int -> Gen (Tree p wX)+arbitraryTree rm depth+  | depth == 0 = return NilTree+    -- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.+    -- For the purpose of this module empty trees are useless, but even when+    -- NilTree case is omitted there is still a small percentage of empty trees+    -- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.+  | otherwise =+    frequency+      [ ( 1+        , do Sealed (WithEndState p rm') <- arbitraryState rm+             t <- arbitraryTree rm' (depth - 1)+             return (SeqTree p t))+      , ( 3+        , do t1 <- arbitraryTree rm (depth - 1)+             t2 <- arbitraryTree rm (depth - 1)+             return (ParTree t1 t2))+      ]++-- | Canonize a 'Tree', removing any dead branches.+canonizeTree :: NullPatch p => Tree p wX -> Tree p wX+canonizeTree NilTree = NilTree+canonizeTree (ParTree t1 t2)+    | NilTree <- canonizeTree t1 = canonizeTree t2+    | NilTree <- canonizeTree t2 = canonizeTree t1+    | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)+canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t+                           | otherwise = SeqTree p (canonizeTree t)+++-- | Generate a patch to a certain state.+class ArbitraryStateIn s p where+  arbitraryStateIn :: s wX -> Gen (p wX)++instance (ArbitraryState p, s ~ ModelOf p) => ArbitraryStateIn s (Tree p) where+  -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).+  -- Note if we don't put a non-zero lower bound the first generated trees will+  -- always have depth 0.+  -- The minimum size of 3 means that we have a reasonable probability that the+  -- Tree has at least one triple.+  arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth++instance ( RepoModel model+         , ArbitraryPrim prim+         , model ~ ModelOf prim+         , ArbitraryState prim+         ) =>+         Arbitrary (Sealed (WithStartState model (Tree prim))) where+  arbitrary = do+    repo <- aSmallRepo+    Sealed . WithStartState repo <$>+      (canonizeTree <$> arbitraryStateIn repo) `suchThat` (\t -> numTriples t >= 1)++flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) wX -> Sealed (FL p wX)+flattenOne NilTree = seal NilFL+flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromAnonymousPrim p :>: ps)+flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =+    case merge (ps1 :\/: ps2) of+      ps2' :/\: _ -> seal (ps1 +>+ ps2')++-- | A 'Tree' together with some number that is no greater than+-- the number of pairs in the 'Tree'.+data TreeWithFlattenPos p wX = TWFP Int (Tree p wX)++commutePairFromTWFP :: (FromPrim p, Merge p)+                    => (forall wY wZ . (p :> p) wY wZ -> t)+                    -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))+                    -> Maybe t+commutePairFromTWFP handlePair (Sealed (WithStartState _ (TWFP n t)))+    = unseal2 handlePair <$>+      let xs = unseal getPairs (flattenOne t)+      in if length xs > n && n >= 0 then Just (xs!!n) else Nothing++commutePairFromTree :: (FromPrim p, Merge p)+                    => (forall wY wZ . (p :> p) wY wZ -> t)+                    -> Sealed (WithStartState model (Tree (PrimOf p)))+                    -> Maybe t+commutePairFromTree handlePair (Sealed (WithStartState _ t))+   = unseal2 handlePair <$>+     let xs = unseal getPairs (flattenOne t)+     in if null xs then Nothing else Just (last xs)++commuteTripleFromTree :: (FromPrim p, Merge p)+                      => (forall wY wZ . (p :> p :> p) wY wZ -> t)+                      -> Sealed (WithStartState model (Tree (PrimOf p)))+                      -> Maybe t+commuteTripleFromTree handle (Sealed (WithStartState _ t))+   = unseal2 handle <$>+     case flattenOne t of+       Sealed ps ->+         let xs = getTriples ps+         in if null xs+            then Nothing+            else Just (last xs)++mergePairFromCommutePair :: Commute p+                         => (forall wY wZ . (p :\/: p) wY wZ -> t)+                         -> (forall wY wZ . (p :>   p) wY wZ -> t)+mergePairFromCommutePair handlePair (a :> b)+ = case commute (a :> b) of+     Just (b' :> _) -> handlePair (a :\/: b')+     Nothing -> handlePair (b :\/: b)++-- impredicativity problems mean we can't use (.) in the definitions below++mergePairFromTWFP :: (FromPrim p, Commute p, Merge p)+                  => (forall wY wZ . (p :\/: p) wY wZ -> t)+                  -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))+                  -> Maybe t+mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)++mergePairFromTree :: (FromPrim p, Commute p, Merge p)+                  => (forall wY wZ . (p :\/: p) wY wZ -> t)+                  -> Sealed (WithStartState model (Tree (PrimOf p)))+                  -> Maybe t+mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)++patchFromCommutePair :: (forall wY wZ . p wY wZ -> t)+                     -> (forall wY wZ . (p :> p) wY wZ -> t)+patchFromCommutePair handle (_ :> b) = handle b++patchFromTree :: (FromPrim p, Merge p)+              => (forall wY wZ . p wY wZ -> t)+              -> Sealed (WithStartState model (Tree (PrimOf p)))+              -> Maybe t+patchFromTree x = commutePairFromTree (patchFromCommutePair x)+++instance Show2 p => Show (TreeWithFlattenPos p wX) where+   showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .+                            showsPrec (appPrec + 1) n . showString " " .+                            showsPrec1 (appPrec + 1) t++getPairs :: FL p wX wY -> [Sealed2 (p :> p)]+getPairs NilFL = []+getPairs (_:>:NilFL) = []+getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)++getTriples :: FL p wX wY -> [Sealed2 (p :> p :> p)]+getTriples NilFL = []+getTriples (_:>:NilFL) = []+getTriples (_:>:_:>:NilFL) = []+getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)++instance ( ArbitraryPrim prim+         , RepoModel (ModelOf prim)+         , model ~ ModelOf prim+         , ArbitraryState prim+         ) =>+         Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where+  arbitrary = do+    Sealed (WithStartState rm t) <- arbitrary+    case numPairs t of+      0 -> return $ Sealed $ WithStartState rm $ TWFP 0 NilTree+      num -> do+        n <- choose (0, num - 1)+        return $ Sealed $ WithStartState rm $ TWFP n t
harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs view
@@ -1,17 +1,13 @@-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} module Darcs.Test.Patch.Arbitrary.PrimFileUUID where  import Prelude () import Darcs.Prelude -import qualified Darcs.Test.Patch.Arbitrary.Generic as T-     ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP-     , mergePairFromTree, mergePairFromTWFP-     , patchFromTree ) import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Shrink import Darcs.Test.Patch.RepoModel -import Control.Monad ( liftM ) import Test.QuickCheck import Darcs.Test.Patch.WithState import Darcs.Patch.Witnesses.Sealed@@ -20,41 +16,28 @@ import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Prim.FileUUID () import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Location(..), Hunk(..), UUID(..) )-import Darcs.Patch.RepoPatch ( RepoPatch )  import Darcs.Test.Patch.FileUUIDModel import Darcs.Test.Util.QuickCheck ( notIn, maybeOf ) -import Darcs.Patch.Prim- import qualified Data.ByteString as B import Data.Maybe ( fromJust, isJust ) import qualified Data.Map as M import Darcs.Util.Hash( Hash(..) ) -patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t-patchFromTree = T.patchFromTree--mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t-mergePairFromTree = T.mergePairFromTree--mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState FileUUIDModel (TreeWithFlattenPos Prim) wX -> t-mergePairFromTWFP = T.mergePairFromTWFP--commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (TreeWithFlattenPos Prim) wX -> t-commutePairFromTWFP = T.commutePairFromTWFP--commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t-commutePairFromTree = T.commutePairFromTree--commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t-commuteTripleFromTree = T.commuteTripleFromTree- type instance ModelOf Prim = FileUUIDModel instance ArbitraryPrim Prim where-    runCoalesceTests _ = False-    hasPrimConstruct _ = False+    runCoalesceTests = Nothing+    hasPrimConstruct = Nothing+    usesV1Model = Nothing +-- TODO add some useful shrinking, at least to+-- shrinkAtEnd/shrinkAtStart+instance Shrinkable Prim where+  shrinkInternally _ = []+  shrinkAtEnd _ = []+  shrinkAtStart _ = []+ instance MightBeEmptyHunk Prim instance MightHaveDuplicate Prim @@ -64,12 +47,12 @@     | old == new = unsafeCoerceP IsEq   nullPatch _ = NotEq --- instance Show1 (TreeWithFlattenPos Prim) where---   showDict1 = ShowDictClass+instance PropagateShrink Prim Prim where+  propagateShrink = propagatePrim --- WithState and propFail are handy for debugging arbitrary code-propFail :: Int -> Tree Prim wX -> Bool-propFail n xs = sizeTree xs < n+instance ShrinkModel Prim where+  -- no shrinking for now+  shrinkModelPatch _ = []  ---------------------------------------------------------------------- -- * QuickCheck generators@@ -86,13 +69,13 @@ aTextHunk (uuid, (Blob text _)) =   do h <- aHunk (unFail text)      return $ Hunk uuid h-aTextHunk _ = impossible+aTextHunk _ = error "impossible case"  aManifest :: UUID -> (UUID, Object Fail) -> Gen (Prim wX wY) aManifest uuid (dirId, Directory dir) =   do filename <- aFilename `notIn` (M.keys dir)      return $ Manifest uuid (L dirId filename)-aManifest _ _ = impossible+aManifest _ _ = error "impossible case"  aDemanifest :: UUID -> Location -> Gen (Prim wX wY) aDemanifest uuid loc = return $ Demanifest uuid loc@@ -103,8 +86,8 @@   = do mbFile <- maybeOf repoFiles -- some file, not necessarily manifested        dir <- elements repoDirs -- some directory, not necessarily manifested        -- note, the root directory always exists and is never manifested nor demanifested-       mbDemanifested <- maybeOf notManifested -- something manifested-       mbManifested <- maybeOf manifested -- something not manifested+       mbDemanifested <- maybeOf notManifested -- something not manifested+       mbManifested <- maybeOf manifested -- something manifested        fresh <- anUUID `notIn` repoIds repo -- a fresh uuid        let whenjust m x = if isJust m then x else 0            whenfile = whenjust mbFile@@ -147,7 +130,7 @@      selectChunk (H off old new) content = elements [prefix, suffix]        where prefix = (0, B.take off content)              suffix = (off + B.length new, B.drop (off + B.length old) content)-hunkPair _ = impossible+hunkPair _ = error "impossible case"  aPrimPair :: FileUUIDModel wX           -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY)@@ -171,77 +154,25 @@ ---------------------------------------------------------------------- -- Arbitrary instances -ourSmallRepo :: Gen (FileUUIDModel wX)-ourSmallRepo = aSmallRepo--instance ArbitraryState FileUUIDModel Prim where+instance ArbitraryState Prim where   arbitraryState s = seal <$> aPrim s  -instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) where-  arbitrary = do repo <- ourSmallRepo-                 liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo-+-- 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 ourSmallRepo--instance Arbitrary (Sealed (Prim x)) where-  arbitrary = makeSGen ourSmallRepo+  arbitrary = makeS2Gen aSmallRepo  instance Arbitrary (Sealed2 (Prim :> Prim)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp _ <- aPrimPair repo-                 return $ seal2 pp--instance Arbitrary (Sealed ((Prim :> Prim) wA)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp _ <- aPrimPair repo-                 return $ seal pp--instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim) wA)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState FileUUIDModel Prim)) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState FileUUIDModel Prim wA)) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim) wA)) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState FileUUIDModel (Prim :> Prim))) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed (WithState FileUUIDModel (Prim :> Prim) a)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal $ WithState repo pp repo'---instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim))) where-  arbitrary = makeWS2Gen ourSmallRepo+  arbitrary = mapSeal2 wsPatch <$> arbitraryPair -instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim :> FL Prim))) where-  arbitrary = makeWS2Gen ourSmallRepo+instance Arbitrary (Sealed2 (WithState Prim)) where+  arbitrary = makeWS2Gen aSmallRepo -instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim :> FL Prim) a)) where-  arbitrary = makeWSGen ourSmallRepo+instance Arbitrary (Sealed2 (WithState (Prim :> Prim))) where+  arbitrary = arbitraryPair
harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs view
@@ -1,18 +1,22 @@-{-# LANGUAGE MultiParamTypeClasses #-}-module Darcs.Test.Patch.Arbitrary.PrimV1 where--import qualified Darcs.Test.Patch.Arbitrary.Generic as T-     ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP-     , mergePairFromTree, mergePairFromTWFP-     , patchFromTree )+module Darcs.Test.Patch.Arbitrary.PrimV1+    ( aPrim+    , aPrimPair+    ) where  import Prelude () import Darcs.Prelude +import qualified Darcs.Test.Patch.Arbitrary.Generic as T import Darcs.Test.Patch.Arbitrary.Generic+    ( NullPatch(..)+    , MightBeEmptyHunk+    , MightHaveDuplicate+    , ArbitraryPrim+    ) import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Arbitrary.Shrink -import Control.Monad ( liftM )+import Control.Applicative ( (<|>) ) import Test.QuickCheck import Darcs.Test.Patch.WithState import Darcs.Patch.Witnesses.Sealed@@ -23,100 +27,58 @@ import qualified Darcs.Patch.Prim.V1.Core as Prim ( Prim( FP ) ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )-import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.FileHunk( IsHunk( isHunk ), FileHunk(..) )  import Darcs.Test.Patch.V1Model import Darcs.Util.Path-import qualified Darcs.Util.Tree as UT ( Tree )+import Darcs.Util.Tree ( Tree ) import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )  import Darcs.UI.Commands.Replace ( defaultToks )-import Darcs.Patch.Prim+import Darcs.Patch.Prim ( PrimPatch, PrimConstruct(..) ) import Darcs.Patch.Apply ( ApplyState ) +import Control.Monad ( guard ) import qualified Data.ByteString.Char8 as BC import Data.Maybe ( fromJust, isJust )  type Prim1 = V1.Prim type Prim2 = V2.Prim -patchFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t-patchFromTree = T.patchFromTree--mergePairFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t-mergePairFromTree = T.mergePairFromTree--mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos prim) wX -> t-mergePairFromTWFP = T.mergePairFromTWFP--commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos prim) wX -> t-commutePairFromTWFP = T.commutePairFromTWFP--commutePairFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t-commutePairFromTree = T.commutePairFromTree--commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t-commuteTripleFromTree = T.commuteTripleFromTree--nonEmptyHunk :: (IsHunk p) => p wX wY -> Bool-nonEmptyHunk p-  | Just (FileHunk _ _ [] []) <- isHunk p = False-  | otherwise                             = True--nonEmptyHunksPair :: (IsHunk p) => (p :> p) wX wY -> Bool-nonEmptyHunksPair (p1 :> p2) = nonEmptyHunk p1 && nonEmptyHunk p2--nonEmptyHunksTriple :: (IsHunk p) => (p :> p :> p) wX wY -> Bool-nonEmptyHunksTriple (p1 :> p2 :> p3) = nonEmptyHunk p1 && nonEmptyHunk p2 && nonEmptyHunk p3--nonEmptyHunksFLPair :: (IsHunk p) => (FL p :> FL p) wX wY -> Bool-nonEmptyHunksFLPair (ps :> qs) = allFL nonEmptyHunk ps && allFL nonEmptyHunk qs- type instance ModelOf Prim1 = V1Model type instance ModelOf Prim2 = V1Model+ instance ArbitraryPrim Prim1 instance ArbitraryPrim Prim2 -instance NullPatch Prim2 where-  nullPatch (V2.Prim (Prim.FP _ fp)) = nullPatch fp-  nullPatch p | IsEq <- isIdentity (V2.unPrim p) = IsEq-  nullPatch _ = NotEq--instance NullPatch Prim1 where-  nullPatch (V1.Prim (Prim.FP _ fp)) = nullPatch fp-  nullPatch p | IsEq <- isIdentity (V1.unPrim p) = IsEq+instance NullPatch Prim.Prim where+  nullPatch (Prim.FP _ fp) = nullPatch fp+  nullPatch p | IsEq <- isIdentity p = IsEq   nullPatch _ = NotEq+deriving instance NullPatch Prim1+deriving instance NullPatch Prim2  instance NullPatch FilePatchType where   nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe?   nullPatch _ = NotEq -instance MightBeEmptyHunk Prim1 where-  isEmptyHunk (V1.Prim (Prim.FP _ (Hunk _ [] []))) = True-  isEmptyHunk _ = False--instance MightBeEmptyHunk Prim2 where-  isEmptyHunk (V2.Prim (Prim.FP _ (Hunk _ [] []))) = True+instance MightBeEmptyHunk Prim.Prim where+  isEmptyHunk (Prim.FP _ (Hunk _ [] [])) = True   isEmptyHunk _ = False+deriving instance MightBeEmptyHunk Prim1+deriving instance MightBeEmptyHunk Prim2  instance MightHaveDuplicate Prim1 instance MightHaveDuplicate Prim2 -instance Arbitrary (Sealed2 (FL (WithState V1Model Prim1))) where-  arbitrary = do repo <- ourSmallRepo-                 liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo--instance Arbitrary (Sealed2 (FL (WithState V1Model Prim2))) where-  arbitrary = do repo <- ourSmallRepo-                 liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo---- instance Show1 (TreeWithFlattenPos Prim) where---   showDict1 = ShowDictClass+-- TODO add some useful shrinking, at least to+-- shrinkAtEnd/shrinkAtStart+instance Shrinkable Prim.Prim where+  shrinkInternally _ = []+  shrinkAtEnd _ = []+  shrinkAtStart _ = [] --- WithState and propFail are handy for debugging arbitrary code-propFail :: Int -> Tree prim wX -> Bool-propFail n xs = sizeTree xs < n+deriving instance Shrinkable V1.Prim+deriving instance Shrinkable V2.Prim  ---------------------------------------------------------------------- -- * QuickCheck generators@@ -126,7 +88,7 @@  aHunk :: Content -> Gen (Int, [BC.ByteString], [BC.ByteString]) aHunk content- = sized $ \n ->+ = (sized $ \n ->      do pos <- choose (1, contentLen+1)         let prefixLen = pos-1             restLen   = contentLen-prefixLen@@ -153,9 +115,10 @@                       ]         new <- vectorOf newLen aLine         let old = take oldLen $ drop prefixLen $ content-        return (pos, old, new)+        return (pos, old, new)) `suchThat` notEmptyHunk   where       contentLen = length content+      notEmptyHunk (_,old,new) = not (null old && null new)  aTokReplace :: Content -> Gen (String, String, String) aTokReplace []@@ -173,52 +136,102 @@ ---------------------------------------------------------------------- -- ** Prim generators -aHunkP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY)+aHunkP :: PrimPatch prim => (AnchoredPath, File) -> Gen (prim wX wY) aHunkP (path,file)   = do (pos, old, new) <- aHunk content-       return $ hunk (ap2fp path) pos old new+       return $ hunk path pos old new   where       content = fileContent file -aTokReplaceP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY)+aTokReplaceP :: PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY) aTokReplaceP (path,file)   = do (tokchars, old, new) <- aTokReplace content-       return $ tokreplace (ap2fp path) tokchars old new+       return $ tokreplace path tokchars old new   where       content = fileContent file -anAddFileP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)+anAddFileP :: PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY) anAddFileP (path,dir)   = do newFilename <- aFilename `notIn` existing        let newPath = path `appendPath` newFilename-       return $ addfile (ap2fp newPath)+       return $ addfile newPath   where       existing = map fst $ filterFiles $ dirContent dir -aRmFileP :: forall prim wX wY . PrimPatch prim => AnchoredPath   -- ^ Path of an empty file-                          -> prim wX wY-aRmFileP path = rmfile (ap2fp path)+aRmFileP :: PrimPatch prim+         => AnchoredPath   -- ^ Path of an empty file+         -> prim wX wY+aRmFileP path = rmfile path -anAddDirP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)+anAddDirP :: PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY) anAddDirP (path,dir)   = do newDirname <- aDirname `notIn` existing        let newPath = path `appendPath` newDirname-       return $ adddir (ap2fp newPath)+       return $ adddir newPath   where       existing = map fst $ filterDirs $ dirContent dir -aRmDirP :: forall prim wX wY . PrimPatch prim => AnchoredPath    -- ^ Path of an empty directory-                        -> prim wX wY-aRmDirP path = rmdir (ap2fp path)+aRmDirP :: PrimPatch prim+        => AnchoredPath    -- ^ Path of an empty directory+        -> prim wX wY+aRmDirP path = rmdir path -aMoveP :: forall prim wX wY . PrimPatch prim => Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (prim wX wY)+aMoveP :: PrimPatch prim+       => Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (prim wX wY) aMoveP nameGen oldPath (dirPath,dir)   = do newName <- nameGen `notIn` existing        let newPath = dirPath `appendPath` newName-       return $ move (ap2fp oldPath) (ap2fp newPath)+       return $ move oldPath newPath   where       existing = map fst $ dirContent dir +aModelShrink :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelShrink repo =+  aModelShrinkName repo <|>+  aModelDeleteFile repo <|>+  aModelDeleteDir repo <|>+  aModelShrinkFileContent repo++shrinkPath :: AnchoredPath -> [AnchoredPath]+shrinkPath (AnchoredPath ps) = do+  ps' <- shrinkList shrinkName ps+  guard (not $ null ps')+  return $ AnchoredPath ps'++shrinkName :: Name -> [Name]+shrinkName n = do+  n' <- shrink (BC.unpack . encodeWhiteName $ n)+  guard (n' /= ".")+  guard (not $ null n')+  return $ decodeWhiteName $ BC.pack n'++aModelShrinkName :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelShrinkName repo = do+  (oldPath, _) <- list repo+  newPath <- shrinkPath oldPath+  return $ Sealed $ move oldPath newPath++aModelDeleteFile :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelDeleteFile repo = do+  (path, _) <- filterFiles (list repo)+  return $ Sealed $ rmfile path++aModelDeleteDir :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelDeleteDir repo = do+  (path, _) <- filterDirs (list repo)+  return $ Sealed $ rmdir path++aModelShrinkFileContent :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelShrinkFileContent repo = do+  (path, file) <- filterFiles (list repo)+  (pos, lineToRemove) <- zip [0..] $ fileContent file+  (return (Sealed $ hunk path pos [lineToRemove] [])+   <|>+   do+    smaller <- BC.pack <$> shrink (BC.unpack lineToRemove)+    return $ Sealed $ hunk path pos [lineToRemove] [smaller])++ -- | Generates any type of 'prim' patch, except binary and setpref patches. aPrim :: forall prim wX wY . (PrimPatch prim, ApplyState prim ~ RepoState V1Model)       => V1Model wX -> Gen (WithEndState V1Model (prim wX) wY)@@ -287,25 +300,30 @@ -- *** Pairs of primitive patches  -- Try to generate commutable pairs of hunks-hunkPairP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen ((prim :> prim) wX wY)+hunkPairP :: PrimPatch prim => (AnchoredPath, File) -> Gen ((prim :> prim) wX wY) hunkPairP (path,file)   = do (l1, old1, new1) <- aHunk content        (delta, content') <- selectChunk (Hunk l1 old1 new1) content        (l2', old2, new2) <- aHunk content'        let l2 = l2'+delta-       return (hunk fpPath l1 old1 new1 :> hunk fpPath l2 old2 new2)+       return (hunk path l1 old1 new1 :> hunk path l2 old2 new2)   where       content = fileContent file-      fpPath = ap2fp path       selectChunk (Hunk l old new) content_         = elements [prefix, suffix]         where             start = l - 1             prefix = (0, take start content_)             suffix = (start + length new, drop (start + length old) content_)-      selectChunk _ _ = impossible+      selectChunk _ _ = error "impossible case" -aPrimPair :: forall prim wX wY . (PrimPatch prim, ArbitraryState V1Model prim, ApplyState prim ~ RepoState V1Model) => V1Model wX -> Gen (WithEndState V1Model ((prim :> prim) wX) wY)+aPrimPair :: ( PrimPatch prim+             , ArbitraryState prim+             , ApplyState prim ~ RepoState V1Model+             , ModelOf prim ~ V1Model+             )+          => V1Model wX+          -> Gen (WithEndState V1Model ((prim :> prim) wX) wY) aPrimPair repo   = do mbFile <- maybeOf repoFiles        frequency@@ -355,146 +373,67 @@ ---------------------------------------------------------------------- -- Arbitrary instances -ourSmallRepo :: Gen (V1Model wX)-ourSmallRepo = aSmallRepo+type instance ModelOf Prim.Prim = V1Model -instance ArbitraryState V1Model Prim1 where-  arbitraryState s = seal <$> aPrim s+instance ShrinkModel Prim.Prim where+  shrinkModelPatch s = aModelShrink s -instance ArbitraryState V1Model Prim2 where-  arbitraryState s = seal <$> aPrim 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 Arbitrary (Sealed (Prim1 wA)) where-  arbitrary = makeSGen ourSmallRepo+instance ArbitraryState Prim1 where+  arbitraryState s = seal <$> aPrim s -instance Arbitrary (Sealed (Prim2 wA)) where-  arbitrary = makeSGen ourSmallRepo+instance ShrinkModel Prim1 where+  shrinkModelPatch s = map (mapSeal V1.Prim) $ shrinkModelPatch s -instance Arbitrary (Sealed2 Prim1) where-  arbitrary = makeS2Gen ourSmallRepo+instance PropagateShrink Prim1 Prim1 where+  propagateShrink = propagatePrim -instance Arbitrary (Sealed2 Prim2) where-  arbitrary = makeS2Gen ourSmallRepo -arbitrarySeal2 :: (PrimPatch prim, ApplyState prim ~ UT.Tree,-                   ArbitraryState V1Model prim)-               => Gen (Sealed2 (prim :> prim))-arbitrarySeal2 = do-  repo <- ourSmallRepo-  WithEndState pp _ <- aPrimPair repo-  return $ seal2 pp--arbitrarySeal :: (PrimPatch prim, ApplyState prim ~ UT.Tree,-                  ArbitraryState V1Model prim)-              => Gen (Sealed ((:>) prim prim wX))-arbitrarySeal = do-  repo <- ourSmallRepo-  WithEndState pp _ <- aPrimPair repo-  return $ seal pp+instance Arbitrary (Sealed2 Prim1) where+  arbitrary = makeS2Gen aSmallRepo  instance Arbitrary (Sealed2 (Prim1 :> Prim1)) where-  arbitrary = arbitrarySeal2--instance Arbitrary (Sealed2 (Prim2 :> Prim2)) where-  arbitrary = arbitrarySeal2--instance Arbitrary (Sealed ((Prim1 :> Prim1) wA)) where-  arbitrary = arbitrarySeal--instance Arbitrary (Sealed ((Prim2 :> Prim2) wA)) where-  arbitrary = arbitrarySeal--instance Arbitrary (Sealed2 (Prim1 :> Prim1 :> Prim1)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((Prim1 :> Prim1 :> Prim1) a)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim1)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim1) wA)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim1 :> FL Prim1)) where-  arbitrary = makeS2Gen ourSmallRepo+  arbitrary = mapSeal2 wsPatch <$> arbitraryPair -instance Arbitrary (Sealed ((FL Prim1 :> FL Prim1) wA)) where-  arbitrary = makeSGen ourSmallRepo+instance Arbitrary (Sealed2 (WithState Prim1)) where+  arbitrary = makeWS2Gen aSmallRepo -instance Arbitrary (Sealed2 (WithState V1Model Prim1)) where-  arbitrary = makeWS2Gen ourSmallRepo+instance Arbitrary (Sealed2 (WithState (Prim1 :> Prim1))) where+  arbitrary = arbitraryPair -instance Arbitrary (Sealed (WithState V1Model Prim1 wA)) where-  arbitrary = makeWSGen ourSmallRepo+-- Prim2 -instance Arbitrary (Sealed (WithState V1Model (FL Prim1) wA)) where-  arbitrary = makeWSGen ourSmallRepo+instance ArbitraryState Prim2 where+  arbitraryState s = seal <$> aPrim s -instance Arbitrary (Sealed2 (WithState V1Model (Prim1 :> Prim1))) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal2 $ WithState repo pp repo'+instance ShrinkModel Prim2 where+  shrinkModelPatch s = map (mapSeal V2.Prim) $ shrinkModelPatch s -instance Arbitrary (Sealed (WithState V1Model (Prim1 :> Prim1) a)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal $ WithState repo pp repo'+instance PropagateShrink Prim2 Prim2 where+  propagateShrink = propagatePrim  -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1))) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1 :> FL Prim1))) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model (FL Prim1 :> FL Prim1) a)) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed2 (Prim2 :> Prim2 :> Prim2)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((Prim2 :> Prim2 :> Prim2) a)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim2)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim2) wA)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim2 :> FL Prim2)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim2 :> FL Prim2) wA)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model Prim2)) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model Prim2 wA)) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model (FL Prim2) wA)) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model (Prim2 :> Prim2))) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed (WithState V1Model (Prim2 :> Prim2) a)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal $ WithState repo pp repo'-+instance Arbitrary (Sealed2 Prim2) where+  arbitrary = makeS2Gen aSmallRepo -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2))) where-  arbitrary = makeWS2Gen ourSmallRepo+instance Arbitrary (Sealed2 (Prim2 :> Prim2)) where+  arbitrary = mapSeal2 wsPatch <$> arbitraryPair -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2 :> FL Prim2))) where-  arbitrary = makeWS2Gen ourSmallRepo+instance Arbitrary (Sealed2 (WithState Prim2)) where+  arbitrary = makeWS2Gen aSmallRepo -instance Arbitrary (Sealed (WithState V1Model (FL Prim2 :> FL Prim2) a)) where-  arbitrary = makeWSGen ourSmallRepo+instance Arbitrary (Sealed2 (WithState (Prim2 :> Prim2))) where+  arbitrary = arbitraryPair
+ harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE UndecidableInstances, ViewPatterns #-}+-- | Test case generator for patch with a Merge instance+module Darcs.Test.Patch.Arbitrary.RepoPatch+  ( withSingle+  , withPair+  , withTriple+  , withFork+  , withSequence+  , withAllSequenceItems+  , NotRepoPatchV1(..)+  , ArbitraryRepoPatch(..)+  ) where++import Darcs.Prelude++import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Arbitrary.Generic+  ( mergeableSequenceToRL, MergeableSequence(..),  ArbitraryPrim(..), PrimBased )+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Ordered hiding ( Fork )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.V1 ( RepoPatchV1 )++import Data.Constraint+import Data.Void++data NotRepoPatchV1 p = NotRepoPatchV1 (forall prim . Dict (p ~ RepoPatchV1 prim) -> Void)++-- | Class to simplify type signatures and superclass constraints.+class+  ( RepoPatch p+  , ArbitraryPrim (PrimOf p)+  , ModelOf p ~ ModelOf (PrimOf p)+  , ApplyState p ~ RepoState (ModelOf p)+  ) => ArbitraryRepoPatch p where++  notRepoPatchV1 :: Maybe (NotRepoPatchV1 p)+++withSingle+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. p wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r+withSingle prop (Sealed2 (WithStartState2 _ ms))+  = case mergeableSequenceToRL ms of+      _ :<: pp -> Just (prop pp)+      _ -> Nothing++withPair+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. (p :> 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))+      _ -> Nothing++withTriple+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. (p :> p :> p) wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r+withTriple prop (Sealed2 (WithStartState2 _ ms))+  = case mergeableSequenceToRL ms of+      _ :<: pp1 :<: pp2 :<: pp3 -> Just (prop (pp1 :> pp2 :> pp3))+      _ -> Nothing++withFork+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. (FL p :\/: FL p) wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r+-- We can't use (MergeableSequence p:\/: MergeableSequence p) as the input because+-- the witnesses would be wrong, so just use MergeableSequence p and choose the+-- ParMS cases.+withFork prop (Sealed2 (WithStartState2 _ (ParMS ms1 ms2)))+  = Just (prop (reverseRL (mergeableSequenceToRL ms1) :\/: reverseRL (mergeableSequenceToRL ms2)))+withFork _ _ = Nothing++withSequence+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. RL p wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> r+withSequence prop (Sealed2 (WithStartState2 _ ms))+  = prop (mergeableSequenceToRL ms)++withAllSequenceItems+  :: (CheckedMerge p, PrimBased p, Monoid r)+  => (forall wX wY. p wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> r+withAllSequenceItems prop (Sealed2 (WithStartState2 _ ms))+  = mconcat . mapRL prop . mergeableSequenceToRL $ ms+
harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs view
@@ -15,22 +15,22 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}--module Darcs.Test.Patch.Arbitrary.RepoPatchV1 () where+{-# 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 ( addfile, adddir, move,-                     hunk, tokreplace, binary,-                     changepref, invert, merge )+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(..) )@@ -39,11 +39,17 @@ import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) ) import Darcs.Patch.Witnesses.Unsafe +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 )+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(..) )  type Patch = RepoPatchV1 V1.Prim @@ -53,6 +59,19 @@ class ArbitraryP p where     arbitraryP :: Gen (Sealed (p wX)) +instance+  (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))+  => ArbitraryRepoPatch (RepoPatchV1 prim)+  where++    notRepoPatchV1 = Nothing++instance PrimPatch prim => CheckedMerge (RepoPatchV1 prim) where+  validateMerge v =+    case unsafePerformIO (try (evaluate v)) of+      Left (_ :: SomeException) -> Nothing+      Right x -> Just x+ {- TODO: there is a lot of overlap in testing between between this module and Darcs.Test.Patch.QuickCheck@@ -74,11 +93,14 @@ 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 (Prim :> Prim)) where+    arbitrary = unseal Sealed2 <$> arbitraryP  instance Arbitrary (Sealed2 (FL Patch)) where     arbitrary = unseal Sealed2 <$> arbitraryP@@ -111,6 +133,13 @@  instance MightHaveDuplicate (RepoPatchV1 prim) +type instance ModelOf (RepoPatchV1 prim) = ModelOf prim++instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV1 prim) where+  type OnlyPrim (RepoPatchV1 prim) = prim+  primEffect prim = prim :>: NilFL+  liftFromPrim = PP+ hunkgen :: Gen (Sealed (Prim wX)) hunkgen = do   i <- frequency [(1,choose (0,5)),(1,choose (0,35)),@@ -132,7 +161,7 @@      then return $ Sealed $ tokreplace f "A-Za-z" "old" "new"      else return $ Sealed $ tokreplace f "A-Za-z_" o n -twofilegen :: (forall wY . FilePath -> FilePath -> Prim wX wY) -> Gen (Sealed (Prim wX))+twofilegen :: (forall wY . AnchoredPath -> AnchoredPath -> Prim wX wY) -> Gen (Sealed (Prim wX)) twofilegen p = do   n1 <- filepathgen   n2 <- filepathgen@@ -194,7 +223,7 @@           _ :/\: p2' ->               if checkAPatch (p1+>+p2')               then return $ Sealed $ p1+>+p2'-              else impossible+              else error "impossible case"      else mergegen n   where len = if n < 15 then n`div`3 else 3 @@ -234,18 +263,6 @@               frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen),                          (1,return ""), (1,return "{"), (1,return "}") ] -filepathgen :: Gen String-filepathgen = liftM fixpath badfpgen--fixpath :: String -> String-fixpath "" = "test"-fixpath p = fpth p--fpth :: String -> String-fpth ('/':'/':cs) = fpth ('/':cs)-fpth (c:cs) = c : fpth cs-fpth [] = []- newtype SafeChar = SS Char instance Arbitrary SafeChar where     arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0")@@ -253,10 +270,15 @@ fromSafeChar :: SafeChar -> Char fromSafeChar (SS s) = s -badfpgen :: Gen String-badfpgen =  frequency [(1,return "test"), (1,return "hello"), (1,return "world"),-                       (1,map fromSafeChar `fmap` arbitrary),-                       (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ]+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
harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs view
@@ -1,68 +1,41 @@ {-# LANGUAGE UndecidableInstances #-}-module Darcs.Test.Patch.Arbitrary.RepoPatchV2 where-import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.Arbitrary.PrimV1 ()-import Darcs.Test.Patch.RepoModel--import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Prim ( PrimPatch, anIdentity )-import Darcs.Patch.V2 ( RepoPatchV2 )-import Darcs.Patch.V2.RepoPatch ( isDuplicate )--import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Eq-import Darcs.Patch.Prim ( FromPrim(..) )---nontrivialRepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool-nontrivialRepoPatchV2s = nontrivialCommute+module Darcs.Test.Patch.Arbitrary.RepoPatchV2 () where -nontrivialCommute :: (Commute p, Eq2 p) => (p :> p) wX wY -> Bool-nontrivialCommute (x :> y) = case commute (x :> y) of-                              Just (y' :> x') -> not (y' `unsafeCompare` y) ||-                                                 not (x' `unsafeCompare` x)-                              Nothing -> False+import Darcs.Prelude -nontrivialMergerepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :\/: RepoPatchV2 prim) wX wY -> Bool-nontrivialMergerepoPatchV2s = nontrivialMerge+import Control.Exception+import System.IO.Unsafe -nontrivialMerge :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool-nontrivialMerge (x :\/: y) = case merge (x :\/: y) of-                              y' :/\: x' -> not (y' `unsafeCompare` y) ||-                                            not (x' `unsafeCompare` x)+import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate(..), PrimBased(..), ArbitraryPrim )+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  instance MightHaveDuplicate (RepoPatchV2 prim) where   hasDuplicate = isDuplicate -instance (RepoModel (ModelOf prim), ArbitraryPrim prim)-         => Arbitrary (Sealed2 (FL (RepoPatchV2 prim))) where-    arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))-                   return $ unseal seal2 (flattenOne tree)+type instance ModelOf (RepoPatchV2 prim) = ModelOf prim -instance (RepoModel (ModelOf prim), ArbitraryPrim prim)-         => Arbitrary (Sealed2 (RepoPatchV2 prim)) where-    arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))-                   case mapFL seal2 `unseal` flattenOne tree of-                     [] -> return $ seal2 $ fromPrim anIdentity-                     ps -> elements ps+instance+  (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))+  => ArbitraryRepoPatch (RepoPatchV2 prim)+  where -notDuplicatestriple :: (RepoPatchV2 prim :> RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool-notDuplicatestriple (a :> b :> c) = not (isDuplicate a || isDuplicate b || isDuplicate c)+    notRepoPatchV1 = Just (NotRepoPatchV1 (\case {})) -nontrivialTriple :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool-nontrivialTriple (a :> b :> c) =-    case commute (a :> b) of-    Nothing -> False-    Just (b' :> a') ->-      case commute (a' :> c) of-      Nothing -> False-      Just (c'' :> a'') ->-        case commute (b :> c) of-        Nothing -> False-        Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&-                            (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&-                            (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))+instance PrimPatch prim => CheckedMerge (RepoPatchV2 prim) where+  validateMerge v =+    case unsafePerformIO (try (evaluate v)) of+      Left (_ :: SomeException) -> Nothing+      Right x -> Just x++instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV2 prim) where+  type OnlyPrim (RepoPatchV2 prim) = prim+  primEffect = (:>: NilFL)+  liftFromPrim = Normal
+ harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE UndecidableInstances, PatternSynonyms #-}+module Darcs.Test.Patch.Arbitrary.RepoPatchV3 () where++import Darcs.Prelude++import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate(..), PrimBased(..), ArbitraryPrim )+import Darcs.Test.Patch.Arbitrary.NamedPrim ()+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf )+import Darcs.Test.Patch.WithState ( PropagateShrink )++import Darcs.Patch+import Darcs.Patch.Annotate+import Darcs.Patch.Prim.Named+import Darcs.Patch.Prim.WithName+import Darcs.Patch.V3 ( RepoPatchV3 )+import qualified Darcs.Patch.V3.Core as V3 ( RepoPatchV3(Prim) )++import Darcs.Patch.Witnesses.Ordered++instance MightHaveDuplicate (RepoPatchV3 prim) where+  hasDuplicate _ = False++type instance ModelOf (RepoPatchV3 prim) = ModelOf prim++instance+  (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))+  => ArbitraryRepoPatch (RepoPatchV3 prim)+  where++    notRepoPatchV1 = Just (NotRepoPatchV1 (\case {}))++instance PrimPatch prim => CheckedMerge (RepoPatchV3 prim)++instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV3 prim) where+  type OnlyPrim (RepoPatchV3 prim) = NamedPrim prim+  primEffect p = wnPatch p :>: NilFL+  liftFromPrim = V3.Prim
+ harness/Darcs/Test/Patch/Arbitrary/Shrink.hs view
@@ -0,0 +1,53 @@+module Darcs.Test.Patch.Arbitrary.Shrink+  ( Shrinkable(..)+  ) where++import Darcs.Prelude++import Darcs.Patch.Commute+import Darcs.Patch.Permutations++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed++-- |This class encapsulates the general concept of shrinking a patch+-- without using any information about the repository state the+-- patch is applied to.+class Shrinkable p where+  -- |Shrink a patch while preserving the start and end contexts.+  shrinkInternally :: p wX wY -> [p wX wY]+  -- |Shrink a patch, preserving the start context, but maybe not the end context.+  shrinkAtEnd :: p wX wY -> [Sealed (p wX)]+  -- |Shrink a patch, preserving the end context, but maybe not the start context.+  shrinkAtStart :: p wX wY -> [FlippedSeal p wY]++instance (Shrinkable p, Shrinkable q) => Shrinkable (p :> q) where+  shrinkInternally (p :> q) =+    ((:> q) <$> shrinkInternally p) +++    ((p :>) <$> shrinkInternally q)+  shrinkAtEnd (p :> q) = do+    Sealed q' <- shrinkAtEnd q+    return (Sealed (p :> q'))+  shrinkAtStart (p :> q) = do+    FlippedSeal p' <- shrinkAtStart p+    return (FlippedSeal (p' :> q))++instance (Commute p, Shrinkable p) => Shrinkable (FL p) where+  shrinkInternally NilFL = []+  shrinkInternally (p :>: ps) =+    ((:>: ps) <$> shrinkInternally p) ++ ((p :>: ) <$> shrinkInternally ps)++  shrinkAtStart ps = do+    q :> qs <- headPermutationsFL ps+    FlippedSeal qs:map (mapFlipped (:>: qs)) (shrinkAtStart q)++  shrinkAtEnd = map (mapSeal reverseRL) . shrinkAtEnd . reverseFL++instance (Commute p, Shrinkable p) => Shrinkable (RL p) where+  shrinkInternally = map reverseFL . shrinkInternally . reverseRL++  shrinkAtStart = map (mapFlipped reverseFL) . shrinkAtStart . reverseRL++  shrinkAtEnd ps = do+    qs :<: q <- headPermutationsRL ps+    Sealed qs:map (mapSeal (qs :<:)) (shrinkAtEnd q)
harness/Darcs/Test/Patch/Check.hs view
@@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Darcs.Test.Patch.Check ( PatchCheck, doCheck, fileExists, dirExists,                                 removeFile, removeDir, createFile, createDir,                                 insertLine, deleteLine, isValid,@@ -28,13 +28,19 @@ import Darcs.Prelude  import qualified Data.ByteString as B (ByteString)-import Data.List ( isPrefixOf, inits ) import Control.Monad.State ( State, evalState ) import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.State.Class ( get, put, modify, MonadState ) import qualified Data.IntMap as M ( IntMap, mapKeys, delete, insert, empty, lookup, null )-import System.FilePath ( joinPath, splitDirectories ) +import Darcs.Util.Path+    ( AnchoredPath+    , anchorPath+    , isPrefix+    , movedirfilename+    , parents+    )+ -- | File contents are represented by a map from line numbers to line contents. --   If for a certain line number, the line contents are Nothing, that means --   that we are sure that that line exists, but we don't know its contents.@@ -44,15 +50,19 @@ data FileContents = FC { fcLines   :: M.IntMap B.ByteString                        , fcMaxline :: Int                        } deriving (Eq, Show)-data Prop = FileEx String | DirEx String | NotEx String-          | FileLines String FileContents-            deriving (Eq) +data Prop+    = FileEx AnchoredPath+    | DirEx AnchoredPath+    | NotEx AnchoredPath+    | FileLines AnchoredPath FileContents+    deriving (Eq)+ instance  Show Prop  where-    show (FileEx f) = "FileEx "++f-    show (DirEx d)  = "DirEx "++d-    show (NotEx f) = "NotEx"++f-    show (FileLines f l)  = "FileLines "++f++": "++show l+    show (FileEx f) = "FileEx " ++ anchorPath "" f+    show (DirEx d)  = "DirEx " ++ anchorPath "" d+    show (NotEx f) = "NotEx" ++ anchorPath "" f+    show (FileLines f l)  = "FileLines " ++ anchorPath "" f ++ ": " ++ show l  -- | A simulated repository state. The repository is assumed to be -- consistent, and it has two lists of properties: one list with properties@@ -61,7 +71,8 @@ -- repository would be inconsistent. data ValidState = P [Prop] [Prop] deriving Show --- | PatchCheck is a state monad with a simulated repository state+-- | PatchCheck is a 'State' monad with a simulated repository state, wrapped in+-- a 'MaybeT' to indicate failure ('Nothing') or success ('Just'). newtype PatchCheck a = PatchCheck { runPatchCheck :: MaybeT (State ValidState) a }   deriving (Functor, Applicative, Monad, MonadState ValidState) @@ -101,10 +112,9 @@ isValid = return ()  has :: Prop -> [Prop] -> Bool-has _ [] = False-has k (k':ks) = k == k' || has k ks+has = elem -modifyFile :: String+modifyFile :: AnchoredPath            -> (Maybe FileContents -> Maybe FileContents)            -> PatchCheck () modifyFile f change = do@@ -114,7 +124,7 @@       Nothing -> assertNot $ FileEx f -- shorthand for "FAIL"       Just c' -> setContents f c' -insertLine :: String -> Int -> B.ByteString -> PatchCheck ()+insertLine :: AnchoredPath -> Int -> B.ByteString -> PatchCheck () insertLine f n l = do     c <- fileContents f     case c of@@ -127,7 +137,7 @@  -- deletes a line from a hunk patch (third argument) in the given file (first -- argument) at the given line number (second argument)-deleteLine :: String -> Int -> B.ByteString -> PatchCheck ()+deleteLine :: AnchoredPath -> Int -> B.ByteString -> PatchCheck () deleteLine f n l = do     c <- fileContents f     case c of@@ -146,7 +156,7 @@                        then do_delete                        else assertNot $ FileEx f -setContents :: String -> FileContents -> PatchCheck ()+setContents :: AnchoredPath -> FileContents -> PatchCheck () setContents f c = do     P ks nots <- get     let ks' = FileLines f c : filter (not . is_file_lines_for f) ks@@ -157,7 +167,7 @@  -- | Get (as much as we know about) the contents of a file in the current state. --   Returns Nothing if the state is inconsistent.-fileContents :: String -> PatchCheck (Maybe FileContents)+fileContents :: AnchoredPath -> PatchCheck (Maybe FileContents) fileContents f = do       P ks _ <- get       return (fic ks)@@ -166,7 +176,8 @@           fic [] = Just emptyFilecontents  -- | Checks if a file is empty-fileEmpty :: String -> PatchCheck ()+fileEmpty :: AnchoredPath          -- ^ Name of the file to check+          -> PatchCheck () fileEmpty f = do   c <- fileContents f   let empty = case c of@@ -177,27 +188,19 @@      -- Crude way to make it inconsistent and return false:      else assertNot $ FileEx f -movedirfilename :: String -> String -> String -> String-movedirfilename d d' f-  | (d ++ "/") `isPrefixOf` f = d' ++ drop (length d) f-  | f == d = d'-  | otherwise = f- -- | Replaces a filename by another in all paths. Returns True if the repository --   is consistent, False if it is not.-doSwap :: String -> String -> PatchCheck ()+doSwap :: AnchoredPath -> AnchoredPath -> PatchCheck () doSwap f f' = modify map_sw-  where sw (FileEx a) | f  `is_soe` a = FileEx $ movedirfilename f f' a-                      | f' `is_soe` a = FileEx $ movedirfilename f' f a-        sw (DirEx a) | f  `is_soe` a = DirEx $ movedirfilename f f' a-                     | f' `is_soe` a = DirEx $ movedirfilename f' f a-        sw (FileLines a c) | f  `is_soe` a = FileLines (movedirfilename f f' a) c-                           | f' `is_soe` a = FileLines (movedirfilename f' f a) c-        sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a-                     | f' `is_soe` a = NotEx $ movedirfilename f' f a+  where sw (FileEx a) | f  `isPrefix` a = FileEx $ movedirfilename f f' a+                      | f' `isPrefix` a = FileEx $ movedirfilename f' f a+        sw (DirEx a) | f  `isPrefix` a = DirEx $ movedirfilename f f' a+                     | f' `isPrefix` a = DirEx $ movedirfilename f' f a+        sw (FileLines a c) | f  `isPrefix` a = FileLines (movedirfilename f f' a) c+                           | f' `isPrefix` a = FileLines (movedirfilename f' f a) c+        sw (NotEx a) | f `isPrefix` a = NotEx $ movedirfilename f f' a+                     | f' `isPrefix` a = NotEx $ movedirfilename f' f a         sw p = p-        is_soe d1 d2 = -- is_superdir_or_equal-            d1 == d2 || (d1 ++ "/") `isPrefixOf` d2         map_sw (P ks nots) = P (map sw ks) (map sw nots)  -- | Assert a property about the repository. If the property is already present@@ -240,30 +243,32 @@     modify filter_ks     where filter_ks (P ks nots) = P (filter (p /=) ks) (p:nots) -assertFileExists :: String -> PatchCheck ()+assertFileExists :: AnchoredPath -> PatchCheck () assertFileExists f =   do assertNot $ NotEx f                           assertNot $ DirEx f                           assert $ FileEx f-assertDirExists :: String -> PatchCheck ()++assertDirExists :: AnchoredPath -> PatchCheck () assertDirExists d =   do assertNot $ NotEx d                          assertNot $ FileEx d                          assert $ DirEx d-assertExists :: String -> PatchCheck ()++assertExists :: AnchoredPath -> PatchCheck () assertExists f = assertNot $ NotEx f -assertNoSuch :: String -> PatchCheck ()+assertNoSuch :: AnchoredPath -> PatchCheck () assertNoSuch f =   do assertNot $ FileEx f                       assertNot $ DirEx f                       assert $ NotEx f -createFile :: String -> PatchCheck ()+createFile :: AnchoredPath -> PatchCheck () createFile fn = do   superdirsExist fn   assertNoSuch fn   changeToTrue (FileEx fn)   changeToFalse (NotEx fn) -createDir :: String -> PatchCheck ()+createDir :: AnchoredPath -> PatchCheck () createDir fn = do   substuffDontExist fn   superdirsExist fn@@ -271,7 +276,7 @@   changeToTrue (DirEx fn)   changeToFalse (NotEx fn) -removeFile :: String -> PatchCheck ()+removeFile :: AnchoredPath -> PatchCheck () removeFile fn = do   superdirsExist fn   assertFileExists fn@@ -279,7 +284,7 @@   changeToFalse (FileEx fn)   changeToTrue (NotEx fn) -removeDir :: String -> PatchCheck ()+removeDir :: AnchoredPath -> PatchCheck () removeDir fn = do   substuffDontExist fn   superdirsExist fn@@ -287,7 +292,7 @@   changeToFalse (DirEx fn)   changeToTrue (NotEx fn) -checkMove :: String -> String -> PatchCheck ()+checkMove :: AnchoredPath -> AnchoredPath -> PatchCheck () checkMove f f' = do   superdirsExist f   superdirsExist f'@@ -295,7 +300,7 @@   assertNoSuch f'   doSwap f f' -substuffDontExist :: String -> PatchCheck ()+substuffDontExist :: AnchoredPath -> PatchCheck () substuffDontExist d = do     P ks _ <- get     if all noss ks@@ -304,22 +309,17 @@   where noss (FileEx f) = not (is_within_dir f)         noss (DirEx f) = not (is_within_dir f)         noss _ = True-        is_within_dir f = (d ++ "/") `isPrefixOf` f+        is_within_dir f = d `isPrefix` f && d /= f --- the init and tail calls dump the final init (which is just the path itself--- again), the first init (which is empty), and the initial "." from--- splitDirectories-superdirsExist :: String -> PatchCheck ()-superdirsExist fn = mapM_ assertDirExists superdirs-  where superdirs =  map (("./"++) . joinPath)-                         (init (tail (inits (tail (splitDirectories fn)))))+superdirsExist :: AnchoredPath -> PatchCheck ()+superdirsExist fn = mapM_ assertDirExists (parents fn) -fileExists :: String -> PatchCheck ()+fileExists :: AnchoredPath -> PatchCheck () fileExists fn = do   superdirsExist fn   assertFileExists fn -dirExists :: String -> PatchCheck ()+dirExists :: AnchoredPath -> PatchCheck () dirExists fn = do   superdirsExist fn   assertDirExists fn
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. +{-# LANGUAGE OverloadedStrings #-} module Darcs.Test.Patch.Examples.Set1        ( knownCommutes, knownCantCommutes, knownMerges        , knownMergeEquivs, knownCanons, mergePairs2@@ -24,25 +25,34 @@  import Prelude () import Darcs.Prelude-import Data.Maybe ( fromJust ) import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString.Char8 as BC ( pack ) import qualified Data.ByteString as B ( empty )+import Data.String ( IsString(..) )+ import Darcs.Patch      ( commute, invert, merge-     , Named, namepatch-     , readPatch, fromPrim+     , Named, infopatch+     , readPatch      , adddir, addfile, hunk, binary, rmdir, rmfile, tokreplace )-import Darcs.Patch.Prim ( PrimOf, FromPrim )+import Darcs.Patch.Info ( patchinfo )+import Darcs.Patch.FromPrim ( PrimOf, FromPrim(..) ) import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import Darcs.Test.Patch.Properties.Check( checkAPatch ) import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed ( unsafeUnseal )+import Darcs.Patch.Witnesses.Sealed ( unseal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )+import Darcs.Util.Path ( AnchoredPath, floatPath ) +instance IsString AnchoredPath where+  fromString = floatPath+ type Patch = V1.RepoPatchV1 V1.Prim +flFromPrim :: FromPrim p => PrimOf p wX wY -> FL p wX wY+flFromPrim p = fromAnonymousPrim p :>: NilFL+ -- The unit tester function is really just a glorified map for functions that -- return lists, in which the lists get concatenated (where map would end up -- with a list of lists).@@ -85,9 +95,12 @@      (quickhunk 1 "abcde" "acde" :>: NilFL, quickhunk 2 "b" "" :>: NilFL)]  quickhunk :: (FromPrim p, PrimOf p ~ V1.Prim) => Int -> String -> String -> p wX wY-quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o)+quickhunk l o n = fromAnonymousPrim $ hunk "test" l (map (\c -> BC.pack [c]) o)                                              (map (\c -> BC.pack [c]) n) +quickhunkFL :: (FromPrim p, PrimOf p ~ V1.Prim) => Int -> String -> String -> FL p wX wY+quickhunkFL l o n = quickhunk l o n :>: NilFL+ -- ---------------------------------------------------------------------- -- * Merge/unmgerge tests -- ----------------------------------------------------------------------@@ -139,8 +152,8 @@                   (testhunk 2                    ["hello world all that is old is good old_"]                    ["I don't like old things"]:>-                   fromPrim (tokreplace "test" "A-Za-z_" "old" "new"),-                   fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):>+                   flFromPrim (tokreplace "test" "A-Za-z_" "old" "new"),+                   flFromPrim (tokreplace "test" "A-Za-z_" "old" "new"):>                    testhunk 2                    ["hello world all that is new is good old_"]                    ["I don't like new things"]),@@ -148,10 +161,10 @@                    testhunk 1 ["A"] ["B"],                    testhunk 1 ["A"] ["B"]:>                    testhunk 2 ["C"] ["D"]),-                  ((quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):>-                   fromPrim (rmfile "NwNSO"),-                   fromPrim (rmfile "NwNSO"):>-                   (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello")))),+                  ((quickmerge (flFromPrim (addfile "hello"):\/:flFromPrim (addfile "hello"))):>+                   flFromPrim (rmfile "NwNSO"),+                   flFromPrim (rmfile "NwNSO"):>+                   (quickmerge (flFromPrim (addfile "hello"):\/:flFromPrim (addfile "hello")))),                    (testhunk 1 [] ["a"]:>                    quickmerge (testhunk 3 ["o"] ["n"]:\/:@@ -179,7 +192,7 @@                    testhunk 1 ["A"] ["B","C"],                    testhunk 1 ["A"] ["B","C"]:>                    testhunk 3 ["B"] ["C","D"])]-  where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)+  where testhunk l o n = flFromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)  knownCantCommutes :: [(FL Patch :> FL Patch) wX wY] knownCantCommutes = [@@ -190,9 +203,9 @@                       (testhunk 1 [] ["a"]:>                        quickmerge (testhunk 2 ["o"] ["n"]:\/:                                    testhunk 2 ["o"] ["v"])),-                      (fromPrim (addfile "test"):>-                       fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])))]-  where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)+                      (flFromPrim (addfile "test"):>+                       flFromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])))]+  where testhunk l o n = flFromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)  -- ---------------------------------------------------------------------- -- * Merge tests@@ -210,9 +223,9 @@                 (testhunk 3 [BC.pack "A"] []:\/:                  testhunk 1 [BC.pack "B"] [],                  testhunk 2 [BC.pack "A"] []),-                (fromPrim (rmdir "./test/world"):\/:-                 fromPrim (hunk "./world" 3 [BC.pack "A"] []),-                 fromPrim (rmdir "./test/world")),+                (flFromPrim (rmdir "./test/world"):\/:+                 flFromPrim (hunk "./world" 3 [BC.pack "A"] []),+                 flFromPrim (rmdir "./test/world")),                  ((quickhunk 1 "a" "bc" :>:                   quickhunk 6 "d" "ef" :>: NilFL):\/:@@ -228,7 +241,7 @@                 (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/:                  testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"],                  testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"])]-  where testhunk l o n = fromPrim $ hunk "test" l o n+  where testhunk l o n = flFromPrim $ hunk "test" l o n  knownMergeEquivs :: [((FL Patch :\/: FL Patch) wX wY, FL Patch wY wZ)] knownMergeEquivs = [@@ -252,20 +265,20 @@                      -- move "old" "test",                      -- joinPatches (move "a" "test" :>:                      --              move "old" "test-conflict" :>: NilFL)),-                     (fromPrim (hunk "test" 1 [] [BC.pack "A"]) :\/:-                       fromPrim (hunk "test" 1 [] [BC.pack "B"]),-                       fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])),-                     (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/:-                      fromPrim (hunk "test" 1 [BC.pack "b"] []),+                     (flFromPrim (hunk "test" 1 [] [BC.pack "A"]) :\/:+                       flFromPrim (hunk "test" 1 [] [BC.pack "B"]),+                       flFromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])),+                     (flFromPrim (hunk "test" 1 [] [BC.pack "a"]):\/:+                      flFromPrim (hunk "test" 1 [BC.pack "b"] []),                       unsafeCoerceP NilFL),                       --hunk "test" 1 [] [BC.pack "v v v v v v v",                       --                  BC.pack "*************",                       --                  BC.pack "a",                       --                  BC.pack "b",                       --                  BC.pack "^ ^ ^ ^ ^ ^ ^"]),-                     (quickhunk 4 "a"  "" :\/:-                      quickhunk 3 "a"  "",-                      quickhunk 3 "aa" ""),+                     (quickhunkFL 4 "a"  "" :\/:+                      quickhunkFL 3 "a"  "",+                      quickhunkFL 3 "aa" ""),                      ((quickhunk 1 "a" "bc" :>:                        quickhunk 6 "d" "ef" :>: NilFL) :\/:                        (quickhunk 3 "a" "bc" :>:@@ -274,9 +287,9 @@                       quickhunk 8 "d" "ef" :>:                       quickhunk 1 "a" "bc" :>:                       quickhunk 7 "d" "ef" :>: NilFL),-                     (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a") :\/:-                              quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"),-                              quickhunk 2 "" "abdc")+                     (quickmerge (quickhunkFL 2 "" "bd":\/:quickhunkFL 2 "" "a") :\/:+                              quickmerge (quickhunkFL 2 "" "c":\/:quickhunkFL 2 "" "a"),+                              quickhunkFL 2 "" "abdc")                      ]  @@ -311,19 +324,24 @@ testPatchesMerged :: [FL Patch wX wY] validPatches :: [FL Patch wX wY] -testPatchesNamed = [unsafePerformIO $-                      namepatch "date is" "patch name" "David Roundy" []-                                (fromPrim $ addfile "test"),-                      unsafePerformIO $-                      namepatch "Sat Oct 19 08:31:13 EDT 2002"-                                "This is another patch" "David Roundy"-                                ["This log file has","two lines in it"]-                                (fromPrim $ rmfile "test")]-testPatchesAddfile = map fromPrim+testPatchesNamed =+  [ unsafePerformIO $ do+      info <- patchinfo "date is" "patch name" "David Roundy" []+      return $ infopatch info $ addfile "test" :>: NilFL+  , unsafePerformIO $ do+      info <-+        patchinfo+          "Sat Oct 19 08:31:13 EDT 2002"+          "This is another patch"+          "David Roundy"+          ["This log file has", "two lines in it"]+      return $ infopatch info $ rmfile "test" :>: NilFL+  ]+testPatchesAddfile = map flFromPrim                        [addfile "test",adddir "test",addfile "test/test"] testPatchesRmfile = map invert testPatchesAddfile testPatchesHunk  =-    [fromPrim (hunk file line old new) |+    [flFromPrim (hunk file line old new) |      file <- ["test"],      line <- [1,2],      old <- map (map BC.pack) partials,@@ -332,17 +350,21 @@     ]     where partials  = [["A"],["B"],[],["B","B2"]] +fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "impossible"+ primitiveTestPatches = testPatchesAddfile ++                          testPatchesRmfile ++                          testPatchesHunk ++-                         [unsafeUnseal.fromJust.readPatch $+                         [unseal unsafeCoercePEnd.fromRight.readPatch $                           BC.pack "move ./test/test ./hello",-                          unsafeUnseal.fromJust.readPatch $+                          unseal unsafeCoercePEnd.fromRight.readPatch $                           BC.pack "move ./test ./hello"] ++                          testPatchesBinary  testPatchesBinary =-    [fromPrim $ binary "./hello"+    [flFromPrim $ binary "./hello"      (BC.pack $ "agadshhdhdsa75745457574asdgg" ++       "a326424677373735753246463gadshhdhdsaasdgg" ++       "a326424677373735753246463gadshhdhdsaasdgg" ++@@ -351,7 +373,7 @@       "a326424677373735753246463gadshhdhdsaasdgg" ++       "a326424677373735753246463gadshhdhdsaasdgg" ++       "a326424677373735753246463gadshhdhdsaagg"),-     fromPrim $ binary "./hello"+     flFromPrim $ binary "./hello"      B.empty      (BC.pack "adafjttkykrere")]
harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs view
@@ -15,6 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE OverloadedStrings #-} module Darcs.Test.Patch.Examples.Set2Unwitnessed        ( primPermutables, primPatches        , commutables, commutablesFL@@ -22,16 +23,25 @@        , repov2NonduplicateTriples, repov2Patches, repov2PatchLoopExamples        ) where +import Darcs.Prelude+ import Data.Maybe ( catMaybes ) import qualified Data.ByteString.Char8 as BC ( pack )+import Data.String ( IsString(..) )+ import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Prim ( PrimPatch, fromPrim )+import Darcs.Patch ( invert, hunk )+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.FromPrim ( fromAnonymousPrim )+import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.V2 ( RepoPatchV2 ) -- import Darcs.Test.Patch.Test () -- for instance Eq Patch -- import Darcs.Test.Patch.Examples.Set2Unwitnessed import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )-import qualified Darcs.Test.Patch.Arbitrary.RepoPatchV2 as W ( notDuplicatestriple )+import qualified Darcs.Test.Patch.Arbitrary.Generic as W ( notDuplicatestriple )+import Darcs.Test.Patch.Arbitrary.RepoPatchV2 ()+import Darcs.Test.Patch.Arbitrary.PrimV1 () --import Darcs.Util.Printer ( greenText ) --import Darcs.Util.Printer.Color ( traceDoc ) --import Darcs.Util.Printer.Color ( errorDoc )@@ -44,10 +54,10 @@ import Darcs.Test.Patch.V1Model ( V1Model, Content                                 , makeRepo, makeFile) import Darcs.Test.Patch.WithState ( WithStartState(..) )-import Darcs.Util.Path ( makeName )-import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim, PrimConstruct(..) )+import Darcs.Util.Path ( AnchoredPath, floatPath, makeName )+import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim ) import Darcs.Patch.Merge ( Merge )-import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.PatchTree     ( Tree(..)     , TreeWithFlattenPos(..)     , commutePairFromTree, commuteTripleFromTree@@ -55,24 +65,32 @@     , canonizeTree     ) +instance IsString AnchoredPath where+  fromString = floatPath++ -- import Debug.Trace  type Patch = RepoPatchV2 Prim2  makeSimpleRepo :: String -> Content -> V1Model wX-makeSimpleRepo filename content = makeRepo [(makeName filename, makeFile content)]+makeSimpleRepo filename content =+    makeRepo [(either error id $ makeName filename, makeFile content)] +withStartState :: s wX -> p wX -> Sealed (WithStartState s p)+withStartState s p = seal (WithStartState s p) -w_tripleExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [Sealed2 (p W.:> p W.:> p)]-w_tripleExamples = [commuteTripleFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [])+w_tripleExamples :: (FromPrim p, Merge p, PrimPatchBase p)+                 => [Sealed2 (p W.:> p W.:> p)]+w_tripleExamples = catMaybes [commuteTripleFromTree seal2 $+                   withStartState (makeSimpleRepo "file" [])                    (ParTree                     (SeqTree (hunk "file" 1 [] [BC.pack "g"])                      (SeqTree (hunk "file" 2 [] [BC.pack "j"])                       (SeqTree (hunk "file" 1 [] [BC.pack "s"]) NilTree)))                     (SeqTree (hunk "file" 1 [] [BC.pack "e"]) NilTree))                   ,commuteTripleFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [BC.pack "j"])+                   withStartState (makeSimpleRepo "file" [BC.pack "j"])                    (ParTree                     (SeqTree (hunk "file" 1 [] [BC.pack "s"])                      (ParTree@@ -82,13 +100,14 @@                   ]  -w_mergeExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [Sealed2 (p W.:\/: p)]+w_mergeExamples :: (FromPrim p, Commute p, Merge p, PrimPatchBase p)+                => [Sealed2 (p W.:\/: p)] w_mergeExamples = map (unseal2 (mergePairFromCommutePair seal2)) w_commuteExamples -w_commuteExamples :: (FromPrim p, Merge p, PrimPatchBase p, PrimConstruct (PrimOf p)) => [Sealed2 (p W.:> p)]-w_commuteExamples = [+w_commuteExamples :: (FromPrim p, Merge p, PrimPatchBase p) => [Sealed2 (p W.:> p)]+w_commuteExamples = catMaybes [                    commutePairFromTWFP seal2 $-                   WithStartState (makeSimpleRepo "file" [])+                   withStartState (makeSimpleRepo "file" [])                    (TWFP 3                     (ParTree                      (SeqTree (hunk "file" 1 [] [BC.pack "h"]) NilTree)@@ -97,7 +116,7 @@                          (SeqTree (hunk "file" 1 [] [BC.pack "v"])                            (SeqTree (hunk "file" 2 [BC.pack "f"] []) NilTree)))))),                    commutePairFromTWFP seal2 $-                   WithStartState+                   withStartState                    (makeSimpleRepo "file" [BC.pack "f",BC.pack "s",BC.pack "d"])                    (TWFP 3                     (ParTree@@ -108,7 +127,7 @@                         (SeqTree (hunk "file" 1 [BC.pack "s",BC.pack "d"] [])                           (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)))))), {-                   commutePairFromTWFP seal2 $-                   WithStartState+                   withStartState                    (makeSimpleRepo "file" [BC.pack "f",BC.pack "u",                                             BC.pack "s",BC.pack "d"])                    (TWFP 5@@ -122,7 +141,7 @@                         (SeqTree (hunk "file" 1 [] [BC.pack "a"])                          (SeqTree (hunk "file" 1 [BC.pack "a"] []) NilTree))))))),-}                    commutePairFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])+                   withStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])                    (ParTree                     (SeqTree (hunk "file" 1 [BC.pack "n",BC.pack "t",BC.pack "h"] [])                      NilTree)@@ -130,13 +149,13 @@                      (SeqTree (hunk "file" 1 [BC.pack "n"] [])                       (SeqTree (hunk "file" 1 [BC.pack "t"] []) NilTree)))),                   commutePairFromTree seal2 $-                  WithStartState (makeSimpleRepo "file" [])+                  withStartState (makeSimpleRepo "file" [])                   (ParTree                    (SeqTree (hunk "file" 1 [] [BC.pack "n"]) NilTree)                    (SeqTree (hunk "file" 1 [] [BC.pack "i"])                                 (SeqTree (hunk "file" 1 [] [BC.pack "i"]) NilTree))),                   commutePairFromTree seal2 $-                  WithStartState (makeSimpleRepo "file" [])+                  withStartState (makeSimpleRepo "file" [])                   (ParTree                    (SeqTree (hunk "file" 1 [] [BC.pack "c"])                      (ParTree@@ -145,7 +164,7 @@                         (SeqTree (hunk "file" 1 [] [BC.pack "d"]) NilTree))))                    (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree)),                   commutePairFromTWFP seal2 $-                  WithStartState (makeSimpleRepo "file" [])+                  withStartState (makeSimpleRepo "file" [])                   (TWFP 1                   (ParTree                    (ParTree@@ -153,7 +172,7 @@                     (SeqTree (hunk "file" 1 [] [BC.pack "t"]) NilTree))                    (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree))),                    commutePairFromTWFP seal2 $-                   WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",+                   withStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",                                                             BC.pack "c",BC.pack "v"])                    (TWFP 4                     (ParTree@@ -165,7 +184,7 @@                           (SeqTree (hunk "file" 1 [] [BC.pack "y"]) NilTree))))                      (SeqTree (hunk "file" 4 [BC.pack "v"] []) NilTree))),                    commutePairFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [])+                   withStartState (makeSimpleRepo "file" [])                    (ParTree                     (SeqTree (hunk "file" 1 [] [BC.pack "z"]) NilTree)                     (ParTree@@ -174,7 +193,7 @@                       (SeqTree (hunk "file" 1 [] [BC.pack "r"]) NilTree)                       (SeqTree (hunk "file" 1 [] [BC.pack "d"]) NilTree))))                  , commutePairFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])+                   withStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])                    (ParTree                     (ParTree                      (SeqTree (hunk "file" 1 [BC.pack "t",BC.pack "r",BC.pack "h"] [])@@ -183,7 +202,7 @@                     (SeqTree (hunk "file" 1 [BC.pack "t"] [])                      (SeqTree (hunk "file" 2 [BC.pack "h"] []) NilTree)))                  , commutePairFromTWFP seal2 $-                   WithStartState (makeSimpleRepo "file" []) $+                   withStartState (makeSimpleRepo "file" []) $                    TWFP 2                    (ParTree                     (SeqTree (hunk "file" 1 [] [BC.pack "h"]) NilTree)@@ -191,26 +210,26 @@                      (SeqTree (hunk "file" 2 [] [BC.pack "m"])                       (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree))))                  , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [])+                 withStartState (makeSimpleRepo "file" [])                  (ParTree                   (SeqTree (hunk "file" 1 [] [BC.pack "p"])                    (SeqTree (hunk "file" 1 [BC.pack "p"] [])                     (SeqTree (hunk "file" 1 [] [BC.pack "c"]) NilTree)))                   (SeqTree (hunk "file" 1 [] [BC.pack "z"]) NilTree))                  , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [])+                 withStartState (makeSimpleRepo "file" [])                  (ParTree                   (SeqTree (hunk "file" 1 [] [BC.pack "j" ])                    (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree))                   (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree))                  , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [])+                 withStartState (makeSimpleRepo "file" [])                  (ParTree                   (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)                   (SeqTree (hunk "file" 1 [] [BC.pack "j" ])                    (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree)))                  , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])+                 withStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])                  (ParTree                   (SeqTree (hunk "file" 1 [] [BC.pack "h"])                    (ParTree@@ -219,7 +238,7 @@                      (SeqTree (hunk "file" 1 [] [BC.pack "j"]) NilTree))))                   (SeqTree (hunk "file" 1 [] [BC.pack "l"]) NilTree))                  , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [])+                 withStartState (makeSimpleRepo "file" [])                  (ParTree                   (SeqTree (hunk "file" 1 [] (packStringLetters "s")) NilTree)                   (SeqTree (hunk "file" 1 [] (packStringLetters "k"))@@ -291,7 +310,7 @@              NilTree              NilTree)))))))))]   where-      fx :: String+      fx :: IsString a => a       fx = "F"  mergeExamples :: [Sealed2 (Patch :\/: Patch)]@@ -352,12 +371,12 @@ repov2Triples :: [(Patch :> Patch :> Patch) wX wY] repov2Triples = [ob' :> oa2 :> a2'',                  oa' :> oa2 :> a2'']-               ++ map unsafeUnseal2 tripleExamples-               ++ map unsafeUnseal2 (concatMap getTriples repov2FLs)-    where oa = fromPrim $ quickhunk 1 "o" "aa"+               ++ map (unseal2 unsafeCoerceP) tripleExamples+               ++ map (unseal2 unsafeCoerceP) (concatMap getTriples repov2FLs)+    where oa = fromAnonymousPrim $ quickhunk 1 "o" "aa"           oa2 = oa-          a2 = fromPrim $ quickhunk 2 "a34" "2xx"-          ob = fromPrim $ quickhunk 1 "o" "bb"+          a2 = fromAnonymousPrim $ quickhunk 2 "a34" "2xx"+          ob = fromAnonymousPrim $ quickhunk 1 "o" "bb"           ob' :/\: oa' = merge (oa :\/: ob)           a2' :/\: _ = merge (ob' :\/: a2)           a2'' :/\: _ = merge (oa2 :\/: a2')@@ -367,22 +386,22 @@  repov2FLs :: [FL (Patch) wX wY] repov2FLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]-    where oa = fromPrim $ quickhunk 1 "o" "a"+    where oa = fromAnonymousPrim $ quickhunk 1 "o" "a"           ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL)  repov2Commutables :: [(Patch :> Patch) wX wY]-repov2Commutables = map unsafeUnseal2 commuteExamples+++repov2Commutables = map (unseal2 unsafeCoerceP) commuteExamples++                      map mergeable2commutable repov2Mergeables++-                     [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs repov2FLs)-    where oa = fromPrim $ quickhunk 1 "o" "a"-          ob = fromPrim $ quickhunk 1 "o" "b"+                     [invert oa :> ob'] ++ map (unseal2 unsafeCoerceP) (concatMap getPairs repov2FLs)+    where oa = fromAnonymousPrim $ quickhunk 1 "o" "a"+          ob = fromAnonymousPrim $ quickhunk 1 "o" "b"           _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL)  repov2Mergeables :: [(Patch :\/: Patch) wX wY]-repov2Mergeables = map (\ (x :\/: y) -> fromPrim x :\/: fromPrim y) mergeables+repov2Mergeables = map (\ (x :\/: y) -> fromAnonymousPrim x :\/: fromAnonymousPrim y) mergeables                         ++ repov2IglooMergeables                         ++ repov2QuickcheckMergeables-                        ++ map unsafeUnseal2 mergeExamples+                        ++ map (unseal2 unsafeCoerceP) mergeExamples                         ++ catMaybes (map pair2m (concatMap getPairs repov2FLs))                         ++ [(oa :\/: od),                             (oa :\/: a2'),@@ -400,16 +419,16 @@                             (ob'' :\/: og''),                             (ob'' :\/: oc''),                             (oc' :\/: od'')]-    where oa = fromPrim $ quickhunk 1 "o" "aa"-          a2 = fromPrim $ quickhunk 2 "a34" "2xx"-          og = fromPrim $ quickhunk 3 "4" "g"-          ob = fromPrim $ quickhunk 1 "o" "bb"-          b2 = fromPrim $ quickhunk 2 "b" "2"-          oc = fromPrim $ quickhunk 1 "o" "cc"-          od = fromPrim $ quickhunk 7 "x" "d"-          oe = fromPrim $ quickhunk 7 "x" "e"-          pf = fromPrim $ quickhunk 7 "x" "f"-          od'' = fromPrim $ quickhunk 8 "x" "d"+    where oa = fromAnonymousPrim $ quickhunk 1 "o" "aa"+          a2 = fromAnonymousPrim $ quickhunk 2 "a34" "2xx"+          og = fromAnonymousPrim $ quickhunk 3 "4" "g"+          ob = fromAnonymousPrim $ quickhunk 1 "o" "bb"+          b2 = fromAnonymousPrim $ quickhunk 2 "b" "2"+          oc = fromAnonymousPrim $ quickhunk 1 "o" "cc"+          od = fromAnonymousPrim $ quickhunk 7 "x" "d"+          oe = fromAnonymousPrim $ quickhunk 7 "x" "e"+          pf = fromAnonymousPrim $ quickhunk 7 "x" "f"+          od'' = fromAnonymousPrim $ quickhunk 8 "x" "d"           ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)           a2' :/\: _ = merge (ob' :\/: a2)           ob'' :/\: _ = merge (a2 :\/: ob')@@ -437,12 +456,12 @@                     (z' :\/: y'),                     (x' :\/: z'),                     (a :\/: a)]-    where a = fromPrim $ quickhunk 1 "1" "A"-          b = fromPrim $ quickhunk 2 "2" "B"-          c = fromPrim $ quickhunk 3 "3" "C"-          x = fromPrim $ quickhunk 1 "1BC" "xbc"-          y = fromPrim $ quickhunk 1 "A2C" "ayc"-          z = fromPrim $ quickhunk 1 "AB3" "abz"+    where a = fromAnonymousPrim $ quickhunk 1 "1" "A"+          b = fromAnonymousPrim $ quickhunk 2 "2" "B"+          c = fromAnonymousPrim $ quickhunk 3 "3" "C"+          x = fromAnonymousPrim $ quickhunk 1 "1BC" "xbc"+          y = fromAnonymousPrim $ quickhunk 1 "A2C" "ayc"+          z = fromAnonymousPrim $ quickhunk 1 "AB3" "abz"           x' :/\: _ = merge (a :\/: x)           y' :/\: _ = merge (b :\/: y)           z' :/\: _ = merge (c :\/: z)@@ -457,11 +476,11 @@                              , k' :\/: k'                              , k3 :\/: k3                              ] ++ catMaybes (map pair2m pairs)-    where hb = fromPrim $ quickhunk 0 "" "hb"-          k = fromPrim $ quickhunk 0 "" "k"-          n = fromPrim $ quickhunk 0 "" "n"-          b = fromPrim $ quickhunk 1 "b" ""-          d = fromPrim $ quickhunk 2 "" "d"+    where hb = fromAnonymousPrim $ quickhunk 0 "" "hb"+          k = fromAnonymousPrim $ quickhunk 0 "" "k"+          n = fromAnonymousPrim $ quickhunk 0 "" "n"+          b = fromAnonymousPrim $ quickhunk 1 "b" ""+          d = fromAnonymousPrim $ quickhunk 2 "" "d"           d':/\:_ = merge (b :\/: d)           --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL)           --k2 :>: n2 :>: NilFL :/\: _ =@@ -473,9 +492,9 @@           pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)                                           return $ unsafeCoerceP (xx :\/: y') -          i = fromPrim $ quickhunk 0 "" "i"-          x = fromPrim $ quickhunk 0 "" "x"-          xi = fromPrim $ quickhunk 0 "xi" ""+          i = fromAnonymousPrim $ quickhunk 0 "" "i"+          x = fromAnonymousPrim $ quickhunk 0 "" "x"+          xi = fromAnonymousPrim $ quickhunk 0 "xi" ""           d3 :/\: _ = merge (xi :\/: d)           _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL)
+ harness/Darcs/Test/Patch/Examples/Unwind.hs view
@@ -0,0 +1,264 @@+-- BSD3+--+-- This file contains examples found during the development of Darcs.Patch.Unwind++{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Darcs.Test.Patch.Examples.Unwind where++import Darcs.Prelude++import Darcs.Patch.FromPrim+import Darcs.Patch.Info+import Darcs.Patch.Merge+import Darcs.Patch.Named+import Darcs.Patch.V1 ()+import Darcs.Patch.V1.Core+import Darcs.Patch.Prim.Class+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed++import Darcs.Util.Path+import Darcs.Util.Tree++import Darcs.Test.HashedStorage ( unsafeMakeName )+import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Named ()+import Darcs.Test.Patch.Arbitrary.PrimV1 ()+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.V1Model+import Darcs.Test.Patch.WithState+import Darcs.Test.TestOnly.Instance ()++#if MIN_VERSION_base(4,12,0) && !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif+import Data.ByteString.Char8 ( pack )+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.Constraint+import Data.String++examples+  :: forall p+   . (ArbitraryRepoPatch p, ArbitraryPrim (OnlyPrim p))+   => [Sealed2 (WithStartState2 (MergeableSequence (Named p)))]+examples =+  case (hasPrimConstruct @(OnlyPrim p), usesV1Model @(PrimOf p), notRepoPatchV1 @p) of+    (Just Dict, Just Dict, Just _) -> [example1, example2, example3, example4]+    (Just Dict, Just Dict, Nothing) -> [example1, example2, example3]+    _ -> []++mkNamed :: String -> FL p wX wY -> Named p wX wY+mkNamed hash = NamedP (rawPatchInfo "" "" "" ["Ignore-this: "++hash] False) []++path :: String -> AnchoredPath+path s = AnchoredPath [unsafeMakeName s]++repo :: [(String, [BLC.ByteString])] -> V1Model wX+repo entries =+  makeRepo [ (unsafeMakeName s, RepoItem (File (makeBlob (BLC.unlines thelines))))+           | (s, thelines) <- entries+           ]++example1+  :: forall p+   . (FromPrim p, PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))+example1 =+  Sealed2+    (WithStartState2+      (repo [("a", [])])+      (ParMS+        (SeqMS+          NilMS+          (mkNamed "d4c5605cd6b83371fec990c1835c6416a187ba0"+            (hunk (path "a") 1 [] [pack "x"] :>: NilFL)))+        (SeqMS+          NilMS+          (mkNamed "bb201b95265f199e7fd98a7e2216a0add4fece68"+            (hunk (path "a") 1 [] [pack "y"] :>:+             hunk (path "a") 1 [pack "y"] [pack "z"] :>:+             NilFL)))))++example2+  :: forall p+   . (FromPrim p, PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))+example2 =+  let s3,s4 :: forall s . IsString s => [s]+      s3 = ["f"]+      s4 = ["g"]+  in+  Sealed2+    (WithStartState2+      (repo [("a", s3++s4)])+      (ParMS+        (ParMS+          (SeqMS+            NilMS+              (mkNamed "e8204d03b3f785675ce4bd676adbfe89c4979399"+                (hunk (path "a") 1 (map pack s3) [] :>: NilFL)))+          (SeqMS+            NilMS+              (mkNamed "ac22106fec2b81ae4f75039210f0601dbc9f677d"+                (hunk (path "a") 1 (map pack (s3++s4)) [] :>: NilFL))))+        (SeqMS+          NilMS+          (mkNamed "4f5a9665900931228596a8241ff03dea1a54805f"+            (+             hunk (path "a") (1 + length s3 + length s4) [] [pack "d"] :>:+             hunk (path "a") 1 (map pack s3) [] :>:+            NilFL)))))+++example3+  :: forall p+   . (FromPrim p, PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))+example3 =+  let+    s4 :: IsString s => [s]+    s4 = ["w"]+  in+  Sealed2+    (WithStartState2+      (repo [("a", s4)])+      (ParMS+        (SeqMS+          (ParMS+            (SeqMS NilMS+               (mkNamed "e631e70c43b4e609830053068eef382a4b2fec7"+                 (+                  hunk (path "a") (1+length s4) [] [pack "t"] :>:+                  NilFL+                 )))+            (SeqMS NilMS+               (mkNamed "cc39750d852a02487e2854be4c2b28f6cadf0957"+                 (+                  hunk (path "a") 1 (map pack (s4)) [] :>:+                  NilFL+                 ))))+          (mkNamed "3e2975afd211888617b20a58455926411f1ebaab"+            (+              hunk (path "a") (1+length s4) (map pack ([])) [pack "d"] :>:+              NilFL+            )))+        (SeqMS NilMS+          (mkNamed "441f412b978df5bd8febfe1f4baa5cb8d35f6e4c"+            (+             hunk (path "a") 1 (map pack []) [pack "U"] :>: +             hunk (path "a") 2 (map pack s4) [] :>:+             NilFL+          )+        )+      )+    ))++example4guts :: forall p prim . (PrimConstruct prim, ModelOf p ~ V1Model, OnlyPrim p ~ prim) => Sealed2 (WithStartState2 (MergeableSequence p))+example4guts =+  let+    s3,s5,s7,s9,s10,s11,s12 :: IsString a => [a]+    s3 = ["A","F","l"]+    s5 = ["w"]+    s7 = ["y"]+    s9 = ["u"]+    s10 = ["x"]+    s11 = ["S"]+    s12 = ["e"]+    off :: [[a]] -> Int+    off xs = 1 + sum (map length xs)+  in+   Sealed2+     (WithStartState2+       (repo [("a", s3++s5++s7)])+       (+         (NilMS+           `SeqMS` hunk (path "a") (off [s3,s5]) [] (map pack s10)+           `SeqMS` hunk (path "a") (off [s3,s5,s10,s7]) [] (map pack s11)+         )+         `ParMS`+         (NilMS+            `SeqMS` hunk (path "a") (off []) (map pack s3) (map pack s9)+            `SeqMS` hunk (path "a") (off []) (map pack (s9++s5++s7)) []+         )+         `ParMS`+         (NilMS+           `SeqMS` hunk (path "a") (off []) (map pack (s3)) []+           `SeqMS` hunk (path "a") (off []) [] (map pack s12)+         )+       )+     )+         ++example4+  :: forall p+   . (FromPrim p, PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))+example4 =+  case example4guts @p of+   Sealed2 (WithStartState2 model (((NilMS `SeqMS` a1 `SeqMS` a2) `ParMS` (NilMS `SeqMS` a3 `SeqMS` a4)) `ParMS` (NilMS `SeqMS` a5 `SeqMS` a6))) ->+     Sealed2+       (WithStartState2 model+         ((NilMS+            `SeqMS`+            mkNamed "91b78b39ea6649b6e43ea74a57070480c87d7053"+                   (a1 :>: NilFL)+            `SeqMS`+            mkNamed "80da177d495a63bc9d80b8c9bc56045b23b629f7"+                   (a2 :>: NilFL)+          )+          `ParMS`+          (NilMS+            `SeqMS`+            mkNamed "cdd591a73493d39bd763bd71acac4c1e3078a4a"+                   (a3 :>: a4 :>: NilFL)+          )+          `ParMS`+          (NilMS+            `SeqMS`+            mkNamed "9b7b08b417d62868eb92d2cac7512b899c32f722"+               (a5 :>: a6 :>: NilFL)+          )+         ))++-- like Identity but with a MonadFail instance, just to make it easier+-- to write 'brokenV1Merge' below+newtype ErrorFail a = ErrorFail { runErrorFail :: a }++instance Functor ErrorFail where+  fmap f = ErrorFail . f . runErrorFail+instance Applicative ErrorFail where+  pure = ErrorFail+  liftA2 f (ErrorFail v1) (ErrorFail v2) = ErrorFail (f v1 v2)+instance Monad ErrorFail where+  ErrorFail v >>= f = f v+#if MIN_VERSION_base(4,12,0)+instance MonadFail ErrorFail where+#endif+  fail = error++-- For now this code isn't used, it just demonstrates how example4 is broken in V1+-- x4;x5' =\/= x5;x4' but not (effect (x4;x5') =\/= effect (x5;x4'))+brokenV1Merge :: forall prim . (OnlyPrim (RepoPatchV1 prim) ~ prim, ModelOf (RepoPatchV1 prim) ~ V1Model, PrimPatch prim) => ()+brokenV1Merge =+  let+    x4, x4', x4'', x5, x5', x6, x6' :: Sealed2 (RepoPatchV1 prim)+    (x4, x4', x4'', x5, x5', x6, x6') =+      case example4guts @(RepoPatchV1 prim) of+        Sealed2+          (WithStartState2 _+            ((NilMS `SeqMS` a1 `SeqMS` a2) `ParMS` (NilMS `SeqMS` a3 `SeqMS` a4) `ParMS` (NilMS `SeqMS` a5 `SeqMS` a6))+          )+         -> runErrorFail $ do+          (a3' :>: a4' :>: NilFL) :/\: _ <- return $ merge ((PP a1 :>: PP a2 :>: NilFL) :\/: (PP a3 :>: PP a4 :>: NilFL))+          (a5' :>: a6' :>: NilFL) :/\: _ <- return $ merge ((PP a1 :>: PP a2 :>: a3' :>: NilFL) :\/: (PP a5 :>: PP a6 :>: NilFL))+          a5'' :/\: a4'' <- return $ merge (a4' :\/: a5')+          a6'' :/\: a4''' <- return $ merge (a4'' :\/: a6')+          return (Sealed2 a4', Sealed2 a4'', Sealed2 a4''', Sealed2 a5', Sealed2 a5'', Sealed2 a6', Sealed2 a6'')+  in x4 `seq` x4' `seq` x4'' `seq` x5 `seq` x5' `seq` x6 `seq` x6' `seq` ()
harness/Darcs/Test/Patch/FileUUIDModel.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}  -- | Repository model module Darcs.Test.Patch.FileUUIDModel@@ -30,7 +30,7 @@ import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) import Darcs.Patch.Witnesses.Show -import Darcs.Util.Path ( Name, unsafeMakeName )+import Darcs.Util.Path ( Name, makeName ) import Darcs.Util.Hash( Hash(..) )  import qualified Data.ByteString as B@@ -59,8 +59,7 @@ instance Show (FileUUIDModel wX) where   show repo = "FileUUIDModel " ++ show (repoObjects repo) -instance Show1 FileUUIDModel where-  showDict1 = ShowDictClass+instance Show1 FileUUIDModel  ---------------------------------------------------------------------- -- * Constructors@@ -132,13 +131,13 @@ aFilename = do   len <- choose (1,3)   name <- vectorOf len alpha-  return $ unsafeMakeName . BC.pack $ name ++ ".txt"+  return $ either error id . makeName $ name ++ ".txt"  aDirname :: Gen Name aDirname = do   len <- choose (1,3)   name <- vectorOf len alpha-  return $ unsafeMakeName . BC.pack $ name+  return $ either error id . makeName $ name  aWord :: Gen B.ByteString aWord = do c <- alpha
harness/Darcs/Test/Patch/Info.hs view
@@ -20,15 +20,20 @@ module Darcs.Test.Patch.Info ( testSuite ) where  import Prelude hiding ( pi )++import Control.Applicative ( (<|>) ) import qualified Data.ByteString as B ( ByteString, pack )-import qualified Data.ByteString.Char8 as BC ( unpack )-import Data.List ( sort , isPrefixOf )+import qualified Data.ByteString.Char8 as BC ( pack, unpack )+import Data.List ( sort , isPrefixOf, partition ) import Data.Maybe ( isNothing ) import Data.Text as T ( find, any ) import Data.Text.Encoding ( decodeUtf8With ) import Data.Text.Encoding.Error ( lenientDecode )+import Data.Word ( Word32 )+import Numeric ( showHex ) import Test.QuickCheck ( Arbitrary(arbitrary), oneof, listOf, choose, shrink                        , Gen, suchThat, scale )+import Test.QuickCheck.Gen ( chooseAny ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework (Test, testGroup) -- import Text.Show.Pretty ( ppShow )@@ -36,9 +41,10 @@ import Darcs.Patch.Info     ( PatchInfo(..), rawPatchInfo, showPatchInfo, readPatchInfo     , piLog, piAuthor, piName, validDate, validLog, validAuthor-    , validDatePS, validLogPS, validAuthorPS+    , validDatePS, validLogPS, validAuthorPS, piDateString     )-import Darcs.Patch.ReadMonads ( parseStrictly )+import Darcs.Test.TestOnly.Instance ()+import Darcs.Util.Parser ( parse ) import Darcs.Patch.Show ( ShowPatchFor(..) ) import Darcs.Util.ByteString     ( decodeLocale, packStringToUTF8, unpackPSFromUTF8, linesPS )@@ -86,17 +92,20 @@  instance Arbitrary UTF8PatchInfo where     arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8PatchInfo-    shrink upi = flip withUTF8PatchInfo upi $ \pi -> do-        sn <- shrink (piName pi)-        sa <- shrink (piAuthor pi)-        sl <- shrink (filter (not . isPrefixOf "Ignore-this:") (piLog pi))-        i <- shrink (isInverted pi)-        return (UTF8PatchInfo (rawPatchInfo sn (BC.unpack (_piDate pi)) sa sl i))+    shrink (UTF8PatchInfo pi) = map UTF8PatchInfo (shrinkPatchInfo pi)  instance Arbitrary UTF8OrNotPatchInfo where     arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8PatchInfo,                                                   arbitraryUnencodedPatchInfo])+    shrink (UTF8OrNotPatchInfo pi) = map UTF8OrNotPatchInfo (shrinkPatchInfo pi) +-- Generate a random "Ignore-this:" line that makes sure that separately+-- generated PatchInfos are not equal+generateJunk :: Gen String+generateJunk =+  fmap (("Ignore-this: " ++) . concatMap (flip showHex "")) $+  sequence $ replicate 5 (chooseAny :: Gen Word32) + -- | Generate arbitrary patch metadata. -- Note : We must NOT use 'patchinfo' from Darcs.Patch.Info -- with unsafePerformIO here because this breaks  the parse/unparse test@@ -107,19 +116,22 @@     n <- (asString `fmap` arbitrary) `suchThat` validLog     a <- (asString `fmap` arbitrary) `suchThat` validAuthor     l <- lines `fmap` scale (* 2) arbitrary-    i <- return False-    return $ rawPatchInfo d n a l i+    junk <- generateJunk+    i <- arbitrary+    return $ rawPatchInfo d n a (l ++ [junk]) i  -- | Generate arbitrary patch metadata that has totally arbitrary byte strings---   as its name, date, author and log.+--   as its name, date, author and log, as well as an arbitrary "legacy+--   inverted" setting. arbitraryUnencodedPatchInfo :: Gen PatchInfo arbitraryUnencodedPatchInfo = do     d <- arbitraryByteString `suchThat` validDatePS     n <- arbitraryByteString `suchThat` validLogPS     a <- arbitraryByteString `suchThat` validAuthorPS     l <- linesPS `fmap` scale (* 2) arbitraryByteString-    i <- return False-    return (PatchInfo d n a l i)+    junk <- generateJunk+    i <- arbitrary+    return (PatchInfo d n a (l ++ [BC.pack junk]) i)  arbitraryByteString :: Gen B.ByteString arbitraryByteString = B.pack <$> listOf arbitrary@@ -158,7 +170,7 @@ packUnpackTest = testProperty "Testing UTF-8 packing and unpacking" $     \uString -> asString uString == (unpackPSFromUTF8 . packStringToUTF8) (asString uString) -superset :: (Eq a, Ord a) => [a] -> [a] -> Bool+superset :: Ord a => [a] -> [a] -> Bool superset a b = sorted_superset (sort a) (sort b)   where sorted_superset (x:xs) (y:ys) | x == y = sorted_superset xs ys                                       | x <  y = sorted_superset xs (y:ys)@@ -176,14 +188,35 @@ parseUnparseTest :: Test parseUnparseTest = testProperty "parse . show == id" propParseUnparse -parsePatchInfo :: B.ByteString -> Maybe PatchInfo-parsePatchInfo = fmap fst . parseStrictly readPatchInfo+parsePatchInfo :: B.ByteString -> Either String PatchInfo+parsePatchInfo = fmap fst . parse readPatchInfo  unparsePatchInfo :: PatchInfo -> B.ByteString unparsePatchInfo = renderPS . showPatchInfo ForStorage +-- Once generated, we assume that shrinking will preserve UTF8ness etc,+-- so we reuse this function for all the various Arbitrary instances+shrinkPatchInfo :: PatchInfo -> [PatchInfo]+shrinkPatchInfo pi =+  go shrink return return return <|>+  go return shrink return return <|>+  go return return shrink return <|>+  go return return return shrink+  where+    go f1 f2 f3 f4 = do+      sn <- f1 (piName pi)+      sa <- f2 (piAuthor pi)+      sl <- f3 logLines+      i <- f4 (_piLegacyIsInverted pi)+      return $ rawPatchInfo (piDateString pi) sn sa (sl ++ junkLines) i+    -- We need to be careful to preserve the junk lines to prevent creating+    -- two identical PatchInfos from different ones, which would break darcs' invariants+    -- and cause a genuine failure to be shrunk into a spurious one.+    (junkLines, logLines) = partition (isPrefixOf "Ignore-this:") . map BC.unpack . _piLog $ pi+ instance Arbitrary PatchInfo where     arbitrary = arbitraryUnencodedPatchInfo+    shrink = shrinkPatchInfo  propParseUnparse :: PatchInfo -> Bool-propParseUnparse pi = Just pi == parsePatchInfo (unparsePatchInfo pi)+propParseUnparse pi = Right pi == parsePatchInfo (unparsePatchInfo pi)
+ harness/Darcs/Test/Patch/Merge/Checked.hs view
@@ -0,0 +1,89 @@+module Darcs.Test.Patch.Merge.Checked+  ( CheckedMerge(..), checkedMerger+  ) where++import Darcs.Prelude++import Darcs.Patch.Commute+import Darcs.Patch.CommuteFn+import Darcs.Patch.Effect+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Invert+import Darcs.Patch.Merge+import Darcs.Patch.Named++import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), (:>)(..)+    )++import GHC.Stack++class+  (Merge p, Effect p, Eq2 p, Eq2 (PrimOf p), Commute p, Commute (PrimOf p), Invert (PrimOf p))+  => CheckedMerge p+  where++  -- |V1 and V2 merges can produce invalid patches. We use 'checkedMerger' to+  -- validate all merges and fail if there is a problem. When generating tests+  -- we might want to continue after a failure instead of reporting it, so we+  -- can test some other property on all *valid* V1/V2 patches.+  --+  -- This hook allows V1/V2 patches to catch such errors using unsafePerformIO.+  -- Type type is generic to allow arbitrary structures containing mergers to+  -- be checked - e.g. a tuple of two merge results.+  --+  -- There are three reasonable ways of implementing validateMerge. The default+  -- is 'Just' which means no validation.+  --+  -- For repo patch types that might have errors, use unsafePerformIO with try and+  -- evaluate to catch errors and convert them into Nothing.+  --+  -- Finally for compound patch types like Named, FL etc, just delegate to+  -- validateMerge of the underlying patch type.+  --+  -- We could do all this in the Maybe monad right through, but that would+  -- pollute all the generic code with a monad that is only needed because of bugs+  -- in "older" patch implementations+  validateMerge :: a -> Maybe a+  validateMerge = Just++instance CheckedMerge p => CheckedMerge (Named p) where+  validateMerge = validateMerge @p++instance CheckedMerge p => CheckedMerge (FL p) where+  validateMerge = validateMerge @p++checkedMerger :: (HasCallStack, CheckedMerge p) => MergeFn p p -> MergeFn p p+checkedMerger fn pair = let res = fn pair in checkMerge pair res `seq` res++checkMerge+  :: (HasCallStack, CheckedMerge p)+  => (p :\/: p) wX wY+  -> (p :/\: p) wX wY+  -> ()+checkMerge (p :\/: q) (q' :/\: p')+  -- TODO this check doesn't work at the moment - try to enable it and see if it makes+  -- sense to keep or not.+  | False, NotEq <- (p :>: q' :>: NilFL) =\/= (q :>: p' :>: NilFL) =+      error "internal error: merge didn't produce equivalent sequences"+  | NotEq <- squashes (effect p +>+ effect q' +>+ invert (effect q +>+ effect p')) =+      error "internal error: merge didn't produce equivalent effects"+  | otherwise = ()++squashCons :: (Commute p, Eq2 p, Invert p) => p wX wY -> FL p wY wZ -> FL p wX wZ+squashCons p NilFL = p :>: NilFL+squashCons p (q :>: qs)+  | IsEq <- invert p =\/= q = qs+  | Just (q' :> p') <- commute (p :> q) = q' :>: squashCons p' qs+  | otherwise = p :>: q :>: qs++squash :: (Commute p, Eq2 p, Invert p) => FL p wX wY -> FL p wX wY+squash NilFL = NilFL+squash (p :>: ps) = squashCons p (squash ps)++squashes :: (Commute p, Eq2 p, Invert p) => FL p wX wY -> EqCheck wX wY+squashes ps =+  case squash ps of+    NilFL -> IsEq+    _ -> NotEq
harness/Darcs/Test/Patch/Properties/Check.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where  import Prelude ()@@ -15,7 +15,6 @@ import Darcs.Util.ByteString ( linesPS ) import qualified Data.ByteString as B ( ByteString, null, concat ) import qualified Data.ByteString.Char8 as BC ( break, pack )-import Darcs.Util.Path ( fn2fp ) import qualified Data.IntMap as M ( mapMaybe )  import Darcs.Patch ( invert, effect, PrimPatch )@@ -23,10 +22,11 @@ import Darcs.Patch.V1 ( ) import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) import Darcs.Patch.V2.RepoPatch ( RepoPatchV2, isConsistent )+import Darcs.Patch.V3.Core ( RepoPatchV3 ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )-import Darcs.Patch.V1.Core ( isMerger ) import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim )+import Darcs.Patch.Prim.WithName ( PrimWithName(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Witnesses.Ordered @@ -50,42 +50,48 @@ instance PrimPatch prim => Check (RepoPatchV2 prim) where   checkPatch p = maybe isValid (const inconsistent) $ isConsistent p -instance Check (RepoPatchV1 Prim1) where-   checkPatch p | isMerger p = checkPatch $ effect p-   checkPatch (Merger _ _ _ _) = impossible-   checkPatch (Regrem _ _ _ _) = impossible-   checkPatch (PP p) = checkPatch p+instance (PrimPatch prim, Check prim) => Check (RepoPatchV1 prim) where+  checkPatch = checkPatch . effect +instance Check prim => Check (RepoPatchV3 name prim) where+  checkPatch = checkPatch . effect+ deriving instance Check Prim1 deriving instance Check Prim2 +instance Check prim => Check (PrimWithName name prim) where+  checkPatch = checkPatch . wnPatch+ instance Check FileUUID.Prim where   checkPatch _ = isValid -- XXX  instance Check Prim where -   checkPatch (FP f RmFile) = removeFile $ fn2fp f-   checkPatch (FP f AddFile) =  createFile $ fn2fp f+   checkPatch (FP f RmFile) = removeFile f+   checkPatch (FP f AddFile) =  createFile f+   -- This is stupid but was designed that way ages ago:+   -- empty hunks commute with everything, so the file need+   -- not even exist, nor the line in the file.+   -- Perhaps we should avoid generating empty hunks.+   checkPatch (FP _ (Hunk _ [] [])) = isValid    checkPatch (FP f (Hunk line old new)) = do-       fileExists $ fn2fp f-       mapM_ (deleteLine (fn2fp f) line) old-       mapM_ (insertLine (fn2fp f) line) (reverse new)-       isValid+       fileExists f+       mapM_ (deleteLine f line) old+       mapM_ (insertLine f line) (reverse new)    checkPatch (FP f (TokReplace t old new)) =-       modifyFile (fn2fp f) (tryTokPossibly t old new)+       modifyFile f (tryTokPossibly t old new)    -- note that the above isn't really a sure check, as it leaves PSomethings    -- and PNothings which may have contained new...    checkPatch (FP f (Binary o n)) = do-       fileExists $ fn2fp f-       mapM_ (deleteLine (fn2fp f) 1) (linesPS o)-       fileEmpty $ fn2fp f-       mapM_ (insertLine (fn2fp f) 1) (reverse $ linesPS n)-       isValid+       fileExists f+       mapM_ (deleteLine f 1) (linesPS o)+       fileEmpty f+       mapM_ (insertLine f 1) (reverse $ linesPS n) -   checkPatch (DP d AddDir) = createDir $ fn2fp d-   checkPatch (DP d RmDir) = removeDir $ fn2fp d+   checkPatch (DP d AddDir) = createDir d+   checkPatch (DP d RmDir) = removeDir d -   checkPatch (Move f f') = checkMove (fn2fp f) (fn2fp f')+   checkPatch (Move f f') = checkMove f f'    checkPatch (ChangePref _ _ _) = isValid  tryTokPossibly :: String -> String -> String
harness/Darcs/Test/Patch/Properties/Generic.hs view
@@ -16,78 +16,145 @@ --  Boston, MA 02110-1301, USA.  module Darcs.Test.Patch.Properties.Generic-    ( invertSymmetry, inverseComposition, invertRollback,-      recommute, commuteInverses, effectPreserving,-      permutivity, partialPermutivity,-      patchAndInverseCommute, mergeEitherWay,-      show_read,-      mergeCommute, mergeConsistent, mergeArgumentsConsistent,-      coalesceEffectPreserving, coalesceCommute, propIsMergeable+    ( invertInvolution+    , inverseComposition+    , invertRollback+    , recommute+    , commuteInverses+    , effectPreserving+    , inverseDoesntCommute+    , permutivity+    , squareCommuteLaw+    , mergeEitherWay+    , showRead+    , mergeEitherWayValid+    , mergeCommute+    , mergeConsistent+    , mergeArgumentsConsistent+    , coalesceEffectPreserving+    , coalesceCommute+    , PatchProperty+    , MergeProperty+    , SequenceProperty     ) where -import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed, rejected,-                                    (<&&>), fromMaybe )-import Darcs.Test.Patch.RepoModel ( RepoModel, RepoState, repoApply, eqModel, showModel-                                  , maybeFail )-import Darcs.Test.Patch.WithState ( WithState(..), WithStartState(..) )-import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenOne, MightBeEmptyHunk(..), MightHaveDuplicate(..) )+import Darcs.Prelude +import Darcs.Test.Patch.RepoModel+    ( ModelOf+    , RepoModel+    , RepoState+    , eqModel+    , maybeFail+    , repoApply+    , showModel+    )+import Darcs.Test.Util.TestResult+    ( TestResult+    , failed+    , maybeFailed+    , rejected+    , succeeded+    )+import Darcs.Test.Patch.WithState ( WithState(..) )+import Darcs.Test.Patch.Arbitrary.Generic+    ( MightBeEmptyHunk(..)+    , MightHaveDuplicate(..)+    , TestablePrim+    )+import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check )+ import Control.Monad ( msum )  import Darcs.Patch.Witnesses.Show ( Show2(..), show2 ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Show     ( ShowPatchBasic, displayPatch, showPatch, ShowPatchFor(ForStorage) )-import Darcs.Patch.Prim.Class ( PrimPatch, PrimOf, FromPrim ) import Darcs.Patch () import Darcs.Patch.Apply ( Apply, ApplyState )-import Darcs.Patch.Commute ( commute, commuteFL )+import Darcs.Patch.Commute ( Commute, commute, commuteFL )+import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Merge ( Merge(merge) ) import Darcs.Patch.Read ( readPatch )-import Darcs.Patch.Invert ( Invert, invert, invertFL )+import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:/\:)(..), lengthFL, eqFL, reverseRL )-import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal2, Sealed2 )-import Darcs.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text )+import Darcs.Patch.Witnesses.Ordered+    ( (:/\:)(..)+    , (:>)(..)+    , (:\/:)(..)+    , FL(..)+    , RL(..)+    , eqFL+    , mapFL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text, vcat ) --import Darcs.ColorPrinter ( traceDoc ) -propIsMergeable :: forall model p wX . (FromPrim p, Merge p, RepoModel model)-                  => Sealed (WithStartState model (Tree (PrimOf p)))-                  -> Maybe (Tree p wX)-propIsMergeable (Sealed (WithStartState _ t))-   = case flattenOne t of-        Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p)-                     in case lengthFL ps of-                       _ -> Nothing+type PatchProperty p = forall wA wB. p wA wB -> TestResult+-- type PairProperty p = forall wA wB. (p :> p) wA wB -> TestResult+type MergeProperty p = forall wA wB. (FL p :\/: FL p) wA wB -> TestResult+type SequenceProperty p = forall wA wB. RL p wA wB -> TestResult --- | invert symmetry   inv(inv(p)) = p-invertSymmetry :: (Invert p, Eq2 p) => p wA wB -> TestResult-invertSymmetry p = case invert (invert p) =\/= p of-                        IsEq  -> succeeded-                        NotEq -> failed $ redText "p /= inv(inv(p))"+-- | @A^^=A@+invertInvolution :: (Invert p, Eq2 p, ShowPatchBasic p) => p wA wB -> TestResult+invertInvolution p =+  let p' = invert (invert p)+  in case p =\/= p' of+    IsEq  -> succeeded+    NotEq ->+      failed $ redText "p /= p^^, where"+      $$ text "##p=" $$ displayPatch p+      $$ text "##p^^=" $$ displayPatch p' -inverseComposition :: (Invert p, Eq2 p) => (p :> p) wX wY -> TestResult+displayPatchFL :: ShowPatchBasic p => FL p wX wY -> Doc+displayPatchFL = vcat . mapFL displayPatch++-- | @(AB)^ = B^A^@+inverseComposition :: (Invert p, Eq2 p, ShowPatchBasic p)+                   => (p :> p) wX wY -> TestResult inverseComposition (a :> b) =-    case eqFL (reverseRL (invertFL (a:>:b:>:NilFL))) (invert b:>:invert a:>:NilFL) of-      IsEq -> succeeded-      NotEq -> failed $ redText "inv(a :>: b :>: NilFL) /= inv(b) :>: inv(a) :>: NilFL"+  let ab = a:>:b:>:NilFL+      iab = invert ab+      ibia = invert b:>:invert a:>:NilFL+  in case eqFL iab ibia of+    IsEq -> succeeded+    NotEq ->+      failed $ redText "ab^ /= b^a^, where"+      $$ text "##ab=" $$ displayPatchFL ab+      $$ text "##(ab)^=" $$ displayPatchFL iab+      $$ text "##b^a^=" $$ displayPatchFL ibia --- | invert rollback   if b = A(a) then a = A'(b)-invertRollback :: (Invert p, Apply p, ApplyState p ~ RepoState model, ShowPatchBasic p, RepoModel model)-                => WithState model p wA wB -> TestResult-invertRollback (WithState a x b)-  = case maybeFail $ repoApply b (invert x) of-         Nothing -> failed $ redText "x' not applicable to b."-         Just a1 -> if a1 `eqModel` a-                       then succeeded-                       else failed $ redText "a1: " $$ text (showModel a1)-                                  $$ redText " ---- is not equals to a:" $$ text (showModel a)-                                  $$ redText "where a was" $$ text (showModel b)-                                  $$ redText "with (invert x) on top:" $$ displayPatch (invert x)+-- | @ apply A x = y ==> apply A^ y = x@+invertRollback+  :: ( ApplyState p ~ RepoState model+     , Invert p+     , Apply p+     , ShowPatchBasic p+     , RepoModel model+     , model ~ ModelOf p+     )+  => WithState p wA wB+  -> TestResult+invertRollback (WithState a x b) =+  case maybeFail $ repoApply b (invert x) of+    Nothing -> failed $ redText "x^ not applicable to b."+    Just a' ->+      if a' `eqModel` a+        then+          succeeded+        else+          failed $+            redText "##original repo a:" $$ text (showModel a) $$+            redText "##with patch x:" $$ displayPatch x $$+            redText "##results in b:" $$ text (showModel b) $$+            redText "##but (invert x):" $$ displayPatch (invert x) $$+            redText "##applied to b is a':" $$ text (showModel a') $$+            redText "##which is not equal to a."  -- | recommute   AB ↔ B′A′ if and only if B′A′ ↔ AB recommute :: (ShowPatchBasic p, Eq2 p, MightHaveDuplicate p)-          => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY)))+          => CommuteFn p p           -> (p :> p) wA wB -> TestResult recommute c (x :> y) =     case c (x :> y) of@@ -124,16 +191,25 @@  -- | commuteInverses   AB ↔ B′A′ if and only if B⁻¹A⁻¹ ↔ A′⁻¹B′⁻¹ commuteInverses :: (Invert p, ShowPatchBasic p, Eq2 p)-                => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+                => CommuteFn p p                 -> (p :> p) wA wB -> TestResult commuteInverses c (x :> y) =     case c (x :> y) of-    Nothing -> rejected+    Nothing ->+      -- check that inverse commute neither+      case c (invert y :> invert x) of+        Just _ -> failed $+          redText "second commute did not fail"+          $$ redText "x" $$ displayPatch x+          $$ redText "y" $$ displayPatch y+          $$ redText "invert y" $$ displayPatch (invert y)+          $$ redText "invert x" $$ displayPatch (invert x)+        Nothing -> succeeded     Just (y' :> x') ->         case c (invert y :> invert x) of         Nothing -> failed $ redText "second commute failed" $$                             redText "x" $$ displayPatch x $$ redText "y" $$ displayPatch y $$-                            redText "y'" $$ displayPatch y' $$ redText "x'" $$ displayPatch x'+                            redText "invert y" $$ displayPatch (invert y) $$ redText "invert x" $$ displayPatch (invert x)         Just (ix' :> iy') ->             case invert ix' =/\= x' of             NotEq -> failed $ redText "invert ix' /= x'" $$@@ -154,11 +230,12 @@   :: ( Apply p      , MightBeEmptyHunk p      , RepoModel model+     , model ~ ModelOf p      , ApplyState p ~ RepoState model      , ShowPatchBasic p      )-  => (forall wX wY. (p :> p) wX wY -> Maybe ((p :> p) wX wY))-  -> WithState model (p :> p) wA wB+  => CommuteFn p p+  -> WithState (p :> p) wA wB   -> TestResult effectPreserving _ (WithState _ (x :> _) _)   | isEmptyHunk x = rejected@@ -201,13 +278,13 @@   where     displayModel = text . showModel --- | patchAndInverseCommute   If AB ↔ B′A′ then A⁻¹B′ ↔ BA′⁻¹-patchAndInverseCommute+-- | squareCommuteLaw   If AB ↔ B′A′ then A⁻¹B′ ↔ BA′⁻¹+squareCommuteLaw   :: (Invert p, ShowPatchBasic p, Eq2 p)-  => (forall wX wY. (p :> p) wX wY -> Maybe ((p :> p) wX wY))+  => CommuteFn p p   -> (p :> p) wA wB   -> TestResult-patchAndInverseCommute c (x :> y) =+squareCommuteLaw c (x :> y) =   case c (x :> y) of     Nothing -> rejected     Just (y' :> x') ->@@ -243,85 +320,101 @@                   redText "invert ix'" $$ displayPatch (invert ix')                 IsEq -> succeeded -permutivity :: (ShowPatchBasic p, Eq2 p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+permutivity :: (ShowPatchBasic p, Eq2 p)+            => CommuteFn p p             -> (p :> p :> p) wA wB -> TestResult-permutivity c (x:>y:>z) =+permutivity c (x :> y :> z) =   case c (x :> y) of-  Nothing -> rejected-  Just (y1 :> x1) ->+   Nothing -> rejected+   Just (y1 :> x1) ->     case c (y :> z) of     Nothing -> rejected     Just (z2 :> y2) ->       case c (x :> z2) of-      Nothing -> rejected+      Nothing ->+        case c (x1 :> z) of+          Just _ -> failed $ redText "##partial permutivity:" $$+            redText "##x" $$ displayPatch x $$+            redText "##y" $$ displayPatch y $$+            redText "##z" $$ displayPatch z $$+            redText "##y1" $$ displayPatch y1 $$+            redText "##x1" $$ displayPatch x1 $$+            redText "##z2" $$ displayPatch z2 $$+            redText "##y2" $$ displayPatch y2 $$+            redText "##x :> z2 does not commute, whereas x1 :> z does"+          Nothing -> succeeded       Just (z3 :> x3) ->         case c (x1 :> z) of-          Nothing -> failed $ redText "permutivity1"+          Nothing ->+            failed $ redText "##permutivity1:" $$+              redText "##x" $$ displayPatch x $$+              redText "##y" $$ displayPatch y $$+              redText "##z" $$ displayPatch z $$+              redText "##y1" $$ displayPatch y1 $$+              redText "##y2" $$ displayPatch y2 $$+              redText "##failed commute with z of" $$+              redText "##x1" $$ displayPatch x1 $$+              redText "##whereas x commutes with" $$+              redText "##z2" $$ displayPatch z2           Just (z4 :> x4) ->             --traceDoc (greenText "third commuted" $$             --          greenText "about to commute" $$             --          greenText "y1" $$ displayPatch y1 $$             --          greenText "z4" $$ displayPatch z4) $             case c (y1 :> z4) of-            Nothing -> failed $ redText "permutivity2"+            Nothing ->+              failed $ redText "##permutivity2:" $$+                redText "##failed to commute y1 with z4, where" $$+                redText "##x" $$ displayPatch x $$+                redText "##y" $$ displayPatch y $$+                redText "##z" $$ displayPatch z $$+                redText "##y1" $$ displayPatch y1 $$+                redText "##x1" $$ displayPatch x1 $$+                redText "##z2" $$ displayPatch z2 $$+                redText "##y2" $$ displayPatch y2 $$+                redText "##z3" $$ displayPatch z3 $$+                redText "##x3" $$ displayPatch x3 $$+                redText "##z4" $$ displayPatch z4 $$+                redText "##x4" $$ displayPatch x4             Just (z3_ :> y4)                 | IsEq <- z3_ =\/= z3 ->                      --traceDoc (greenText "passed z3") $ error "foobar test" $                      case c (y4 :> x4) of-                     Nothing -> failed $ redText "permutivity5: input was" $$-                                         redText "x" $$ displayPatch x $$-                                         redText "y" $$ displayPatch y $$-                                         redText "z" $$ displayPatch z $$-                                         redText "z3" $$ displayPatch z3 $$-                                         redText "failed commute of" $$-                                         redText "y4" $$ displayPatch y4 $$-                                         redText "x4" $$ displayPatch x4 $$-                                         redText "whereas commute of x and y give" $$-                                         redText "y1" $$ displayPatch y1 $$-                                         redText "x1" $$ displayPatch x1+                     Nothing -> failed $+                        redText "##permutivity5: input was" $$+                        redText "##x" $$ displayPatch x $$+                        redText "##y" $$ displayPatch y $$+                        redText "##z" $$ displayPatch z $$+                        redText "##z3" $$ displayPatch z3 $$+                        redText "##z4" $$ displayPatch z4 $$+                        redText "##failed commute of" $$+                        redText "##y4" $$ displayPatch y4 $$+                        redText "##x4" $$ displayPatch x4 $$+                        redText "##whereas commute of x and y give" $$+                        redText "##y1" $$ displayPatch y1 $$+                        redText "##x1" $$ displayPatch x1                      Just (x3_ :> y2_)-                          | NotEq <- x3_ =\/= x3 -> failed $ redText "permutivity6"-                          | NotEq <- y2_ =/\= y2 -> failed $ redText "permutivity7"+                          | NotEq <- x3_ =\/= x3 ->+                              failed $+                                redText "##permutivity6: x3_ /= x3" $$+                                redText "##x3_" $$ displayPatch x3_ $$+                                redText "##x3" $$ displayPatch x3+                          | NotEq <- y2_ =/\= y2 ->+                              failed $+                                redText "##permutivity7: y2_ /= y2" $$+                                redText "##y2_" $$ displayPatch y2_ $$+                                redText "##y2" $$ displayPatch y2                           | otherwise -> succeeded                 | otherwise ->-                    failed $ redText "permutivity failed" $$-                             redText "z3" $$ displayPatch z3 $$-                             redText "z3_" $$ displayPatch z3_--partialPermutivity-  :: (Invert p, ShowPatchBasic p)-  => (forall wX wY. (p :> p) wX wY -> Maybe ((p :> p) wX wY))-  -> (p :> p :> p) wA wB-  -> TestResult-partialPermutivity c (xx :> yy :> zz) =-  pp (xx :> yy :> zz) <&&> pp (invert zz :> invert yy :> invert xx)-  where-    pp (x :> y :> z) =-      case c (y :> z) of-        Nothing -> rejected-        Just (z1 :> y1) ->-          case c (x :> z1) of-            Nothing -> rejected-            Just (_ :> x1) ->-              case c (x :> y) of-                Just _ -> rejected -- this is covered by full permutivity test above-                Nothing ->-                  case c (x1 :> y1) of-                    Nothing -> succeeded-                    Just _ ->-                      failed $-                      greenText "partialPermutivity error" $$ greenText "x" $$-                      displayPatch x $$-                      greenText "y" $$-                      displayPatch y $$-                      greenText "z" $$-                      displayPatch z+                    failed $ redText "##permutivity failed" $$+                             redText "##z3" $$ displayPatch z3 $$+                             redText "##z3_" $$ displayPatch z3_  mergeArgumentsConsistent :: (ShowPatchBasic p) =>                               (forall wX wY . p wX wY -> Maybe Doc)                            -> (p :\/: p) wA wB -> TestResult mergeArgumentsConsistent isConsistent (x :\/: y) =-  fromMaybe $+  maybeFailed $     msum [(\z -> redText "mergeArgumentsConsistent x" $$ displayPatch x $$ z) `fmap` isConsistent x,           (\z -> redText "mergeArgumentsConsistent y" $$ displayPatch y $$ z) `fmap` isConsistent y] @@ -331,7 +424,7 @@ mergeConsistent isConsistent (x :\/: y) =     case merge (x :\/: y) of     y' :/\: x' ->-      fromMaybe $+      maybeFailed $         msum [(\z -> redText "mergeConsistent x" $$ displayPatch x $$ z) `fmap` isConsistent x,               (\z -> redText "mergeConsistent y" $$ displayPatch y $$ z) `fmap` isConsistent y,               (\z -> redText "mergeConsistent x'" $$ displayPatch x' $$ z $$@@ -339,15 +432,33 @@                      redText "and y" $$ displayPatch y) `fmap` isConsistent x',               (\z -> redText "mergeConsistent y'" $$ displayPatch y' $$ z) `fmap` isConsistent y'] -mergeEitherWay :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> TestResult+-- merge (A\/B) = B'/\A' <==> merge (B\/A) = A'/\B'+--  or, equivalently,+-- merge . swap_par = swap_antipar . merge+--  where swap_par  (A\/B) = B\/A and swap_antipar (A/\B) = B/\A+-- It should not be needed to test this, since it follows from+-- mergeCommute and recommute.+mergeEitherWay :: (Eq2 p, ShowPatchBasic p, Merge p)+               => (p :\/: p) wX wY -> TestResult mergeEitherWay (x :\/: y) =-    case merge (x :\/: y) of-    y' :/\: x' -> case merge (y :\/: x) of-                  x'' :/\: y'' | IsEq <- x'' =\/= x',-                                 IsEq <- y'' =\/= y' -> succeeded-                               | otherwise -> failed $ redText "mergeEitherWay bug"+  case merge (x :\/: y) of+    y' :/\: x' ->+      case merge (y :\/: x) of+        x'' :/\: y''+          | IsEq <- x'' =\/= x'+          , IsEq <- y'' =\/= y' -> succeeded+          | otherwise ->+            failed $+              redText "##x" $$ displayPatch x $$+              redText "##y" $$ displayPatch y $$+              redText "##y'" $$ displayPatch y' $$+              redText "##x'" $$ displayPatch x' $$+              redText "##x''" $$ displayPatch x'' $$+              redText "##y''" $$ displayPatch y'' $$+              redText "##x'' /= x' or y'' /= y'" -mergeCommute :: (Eq2 p, ShowPatchBasic p, Merge p, MightHaveDuplicate p)+-- merge (A\/B) = B'/\A' ==> AB' <--> BA'+mergeCommute :: (Eq2 p, ShowPatchBasic p, Commute p, Merge p, MightHaveDuplicate p)              => (p :\/: p) wX wY -> TestResult mergeCommute (x :\/: y) =     case merge (x :\/: y) of@@ -394,9 +505,9 @@  -- | coalesce effect preserving coalesceEffectPreserving-            :: (PrimPatch prim, RepoModel model, ApplyState prim ~ RepoState model )+            :: TestablePrim prim             => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY))-            -> WithState model (prim :> prim) wA wB -> TestResult+            -> WithState (prim :> prim) wA wB -> TestResult coalesceEffectPreserving j (WithState r (a :> b) r') =   case j (a :> b) of        Nothing -> rejected@@ -422,7 +533,7 @@                                         $$ text (showModel r_x)  coalesceCommute-          :: (PrimPatch prim, MightBeEmptyHunk prim)+          :: (TestablePrim prim, MightBeEmptyHunk prim)           => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY))           -> (prim :> prim :> prim) wA wB -> TestResult coalesceCommute _ (a :> _ :> _) | isEmptyHunk a = rejected@@ -474,18 +585,62 @@  -- note: we would normally use displayPatch in the failure message -- but that would be very misleading here-show_read :: (Show2 p, Eq2 p, ReadPatch p, ShowPatchBasic p) => p wA wB -> TestResult-show_read p = let ps = renderPS (showPatch ForStorage p)-              in case readPatch ps of-                 Nothing -> failed (redText "unable to read " $$ showPatch ForStorage p)-                 Just (Sealed p'  ) | IsEq <- p' =\/= p -> succeeded-                                    | otherwise -> failed $ redText "trouble reading patch p" $$-                                                            showPatch ForStorage p $$-                                                            redText "reads as p'" $$-                                                            showPatch ForStorage p' $$-                                                            redText "aka" $$-                                                            greenText (show2 p) $$-                                                            redText "and" $$-                                                            greenText (show2 p')+showRead :: (Show2 p, Eq2 p, ReadPatch p, ShowPatchBasic p) => p wA wB -> TestResult+showRead p =+  let ps = renderPS (showPatch ForStorage p)+   in case readPatch ps of+        Left e -> failed (redText "unable to read " $$ showPatch ForStorage p $$ text e)+        Right (Sealed p')+          | IsEq <- p' =\/= p -> succeeded+          | otherwise ->+            failed $+            redText "##trouble reading patch p" $$ showPatch ForStorage p $$+            redText "##reads as p'" $$+            showPatch ForStorage p' $$+            redText "##aka" $$+            greenText (show2 p) $$+            redText "##and" $$+            greenText (show2 p')  -- vim: fileencoding=utf-8 :++mergeEitherWayValid+  :: (Check p, Merge p, Invert p, ShowPatchBasic p)+  => (p :\/: p) wX wY+  -> TestResult+mergeEitherWayValid (p1 :\/: p2) =+  case merge (p1 :\/: p2) of+    _ :/\: p1' ->+      case p2 :>: p1' :>: NilFL of+        combo2 ->+          case merge (p2 :\/: p1) of+            _ :/\: p2' ->+              case p1 :>: p2' :>: NilFL of+                combo1+                  | not $ checkAPatch combo1 ->+                      failed $ text "combo1 invalid: p1="+                      $$ displayPatch p1+                      $$ text "p2="+                      $$ displayPatch p2+                      $$ text "combo1="+                      $$ vcat (mapFL displayPatch combo1)+                  | checkAPatch (invert combo1 :>: combo2 :>: NilFL) ->+                      succeeded+                  | otherwise ->+                      failed $ text "merge both ways invalid: p1="+                      $$ displayPatch p1+                      $$ text "p2="+                      $$ displayPatch p2+                      $$ text "combo1="+                      $$ vcat (mapFL displayPatch combo1)+                      $$ text "combo2="+                      $$ vcat (mapFL displayPatch combo2)++inverseDoesntCommute :: (ShowPatchBasic p, Invert p, Commute p)+                     => p wY1 wY2 -> TestResult+inverseDoesntCommute x =+  case commute (x :> invert x) of+    Nothing -> succeeded+    Just (ix' :> x') -> failed $ redText "x:" $$ displayPatch x+      $$ redText "commutes with x^ to ix':" $$ displayPatch ix'+      $$ redText "x':" $$ displayPatch x'
harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs view
@@ -1,28 +1,27 @@ module Darcs.Test.Patch.Properties.GenericUnwitnessed where +import Darcs.Prelude+ import qualified Darcs.Test.Patch.Properties.Generic as W-     ( permutivity, partialPermutivity+     ( permutivity      , mergeConsistent, mergeArgumentsConsistent, mergeEitherWay-     , mergeCommute, patchAndInverseCommute, coalesceCommute, commuteInverses+     , mergeCommute, squareCommuteLaw, coalesceCommute, commuteInverses      , recommute-     , show_read )-import Darcs.Test.Patch.Arbitrary.Generic ( Tree, MightBeEmptyHunk, MightHaveDuplicate )-import Darcs.Test.Patch.RepoModel( RepoModel, RepoState )-import Darcs.Test.Patch.WithState( WithStartState )+     , showRead )+import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate )+import Darcs.Test.Patch.Arbitrary.PrimV1 () -import qualified Darcs.Test.Patch.Properties.RepoPatchV2 as W ( propConsistentTreeFlattenings ) import Darcs.Test.Patch.WSub import Darcs.Test.Util.TestResult +import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Show ( ShowPatchBasic, displayPatch ) import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Eq-import Darcs.Patch.Witnesses.Sealed( Sealed ) import Darcs.Patch.Merge ( Merge ) import Darcs.Util.Printer ( Doc, redText, ($$) )-import qualified Darcs.Util.Tree as T ( Tree )   permutivity :: (ShowPatchBasic wp, Eq2 wp, WSub wp p)@@ -30,11 +29,6 @@             -> (p :> p :> p) wA wB -> TestResult permutivity f = W.permutivity (fmap toW . f . fromW) . toW -partialPermutivity :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p)-                    => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))-                    -> (p :> p :> p) wA wB -> TestResult-partialPermutivity f = W.partialPermutivity (fmap toW . f . fromW) . toW- mergeEitherWay :: (ShowPatchBasic wp, Eq2 wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult mergeEitherWay = W.mergeEitherWay . toW @@ -48,8 +42,15 @@           -> (p :> p) wA wB -> TestResult recommute f = W.recommute (fmap toW . f . fromW) . toW -mergeCommute :: (MightHaveDuplicate wp, ShowPatchBasic wp, Eq2 wp, Merge wp, WSub wp p)-             => (p :\/: p) wX wY -> TestResult+mergeCommute :: ( MightHaveDuplicate wp+                , ShowPatchBasic wp+                , Eq2 wp+                , Commute wp+                , Merge wp+                , WSub wp p+                )+             => (p :\/: p) wX wY+             -> TestResult mergeCommute = W.mergeCommute . toW  mergeConsistent :: (Merge wp, ShowPatchBasic wp, WSub wp p) =>@@ -62,27 +63,20 @@                            -> (p :\/: p) wA wB -> TestResult mergeArgumentsConsistent f = W.mergeArgumentsConsistent (f . fromW) . toW -show_read :: (ShowPatchBasic p, ReadPatch p, Eq2 p, Show2 p) => p wX wY -> TestResult-show_read = W.show_read+showRead :: (ShowPatchBasic p, ReadPatch p, Eq2 p, Show2 p) => p wX wY -> TestResult+showRead = W.showRead -patchAndInverseCommute :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p) =>+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-patchAndInverseCommute f = W.patchAndInverseCommute (fmap toW . f . fromW) . toW+squareCommuteLaw f = W.squareCommuteLaw (fmap toW . f . fromW) . toW  -coalesceCommute :: MightBeEmptyHunk Prim2-                => (forall wX wY . (Prim2 :> Prim2) wX wY -> Maybe (FL Prim2 wX wY))+coalesceCommute :: (forall wX wY . (Prim2 :> Prim2) wX wY -> Maybe (FL Prim2 wX wY))                 -> (Prim2 :> Prim2 :> Prim2) wA wB -> TestResult coalesceCommute f = W.coalesceCommute (fmap toW . f . fromW) . toW -consistentTreeFlattenings :: (RepoState model ~ T.Tree, RepoModel model)-                          => Sealed (WithStartState model (Tree Prim2)) -> TestResult-consistentTreeFlattenings = (\x -> if W.propConsistentTreeFlattenings x-                                      then succeeded-                                      else failed $ redText "oops")--commuteFails :: (Eq2 p, ShowPatchBasic p)+commuteFails :: ShowPatchBasic p              => ((p :> p) wX wY -> Maybe ((p :> p) wX wY))              -> (p :> p) wX wY              -> TestResult
+ harness/Darcs/Test/Patch/Properties/RepoPatch.hs view
@@ -0,0 +1,131 @@+module Darcs.Test.Patch.Properties.RepoPatch+    ( propConsistentTreeFlattenings+    , propConsistentReorderings+    , propResolutionsDontConflict+    , propResolutionsOrderIndependent+    , FromPrimT+    ) where++import Prelude ()+import Darcs.Prelude++import Data.Maybe ( catMaybes )++import Darcs.Test.Patch.Arbitrary.Generic+  ( MergeableSequence, mergeableSequenceToRL, PrimBased )+import Darcs.Test.Patch.Arbitrary.PatchTree+  ( Tree, flattenTree, G2(..), mapTree )+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+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 )++import Darcs.Util.Printer ( text, redText, ($$), vsep )++import Darcs.Patch.Conflict ( Conflict(..), ConflictDetails(..) )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Merge ( Merge, mergeList )+import Darcs.Patch.Permutations ( permutationsRL )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Show ( displayPatch )++import Darcs.Patch.Witnesses.Ordered ( RL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, Sealed2(..) )+import Darcs.Patch.Witnesses.Show ( Show2 )++assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool+assertEqualFst (x,bx) (y,by)+    | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True+    | Nothing <- maybeFail x, Nothing <- maybeFail y = True+    | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy+                         ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)+      where showx | Just x' <- maybeFail x = showModel x'+                  | otherwise = "Nothing"+            showy | Just y' <- maybeFail y = showModel y'+                  | otherwise = "Nothing"++type FromPrimT rp p = forall wX wY. p wX wY -> rp p wX wY++-- | This property states that any flattening of a 'Tree' of prim patches,+-- when applied to the start state, produces the same end state.+propConsistentTreeFlattenings :: forall rp prim model.+                                 ( RepoModel model+                                 , RepoState model ~ ApplyState prim+                                 , ApplyState (rp prim) ~ ApplyState prim+                                 , Merge (rp prim)+                                 , Apply (rp prim)+                                 , Show2 (rp prim) )+                              => FromPrimT rp prim+                              -> Sealed (WithStartState model (Tree prim))+                              -> TestResult+propConsistentTreeFlattenings fromPrim (Sealed (WithStartState start t)) =+  case flattenTree (mapTree fromPrim t) of+    Sealed (G2 flat') ->+      -- Limit the number of tree flattenings to something sane, as+      -- the length of the original list can grow exponentially.+      let flat = take 20 flat' in+      case map (start `repoApply`) flat of+        rms ->+          if and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat)+            then succeeded+            else failed $ redText "oops"++-- | This property states that all reorderings of a sequence of patches,+-- when applied to the same state, give the same result state.+propConsistentReorderings :: ( RepoPatch p+                             , RepoModel (ModelOf p)+                             , RepoState (ModelOf p) ~ ApplyState p+                             , CheckedMerge p+                             , PrimBased p+                             )+                          => Sealed2 (WithStartState2 (MergeableSequence p))+                          -> TestResult+propConsistentReorderings (Sealed2 (WithStartState2 start ms)) =+  case mapM (repoApply start) $ permutationsRL ps of+    Failed msg -> failed $ redText "could not apply all reorderings:" $$ text msg+    OK results -> eql results+  where+    eql [] = succeeded+    eql [_] = succeeded+    eql (r1:r2:rs)+      | r1 `eqModel` r2 =+          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+  where+    eql [] = succeeded+    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)++-- | This property states that the standard conflict resolutions for a+-- sequence of patches do not themselves conflict with each other.+propResolutionsDontConflict :: RepoPatch p => RL p wX wY -> TestResult+propResolutionsDontConflict patches =+  case mergeList $ catMaybes $ map conflictMangled $ resolveConflicts NilRL patches of+    Right _ -> succeeded+    Left (Sealed ps, Sealed qs) ->+      failed+        $ redText "resolutions conflict:"+        $$ displayPatch ps+        $$ redText "conflicts with"+        $$ displayPatch qs+        $$ redText "for sequence"+        $$ displayPatch patches
− harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs 
@@ -1,43 +0,0 @@-module Darcs.Test.Patch.Properties.RepoPatchV2-       ( propConsistentTreeFlattenings ) where--import Prelude ()-import Darcs.Prelude-import Data.Maybe ( fromJust )--import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree )-import Darcs.Test.Patch.WithState-import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState-                                  , Fail, maybeFail )-import qualified Darcs.Util.Tree as T ( Tree )--import Darcs.Patch.Prim ( fromPrim )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )-import qualified Darcs.Patch.V2.Prim as V2 ( Prim )-import Darcs.Patch.V2 ( RepoPatchV2 )--type Prim2 = V2.Prim--fromPrim2 :: Prim2 wX wY -> RepoPatchV2 Prim2 wX wY-fromPrim2 = fromPrim--assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool-assertEqualFst (x,bx) (y,by)-    | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True-    | Nothing <- maybeFail x, Nothing <- maybeFail y = True-    | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy-                         ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)-      where showx | Just x' <- maybeFail x = showModel x'-                  | otherwise = "Nothing"-            showy | Just y' <- maybeFail y = showModel y'-                  | otherwise = "Nothing"--propConsistentTreeFlattenings :: (RepoState model ~ T.Tree, RepoModel model)-                              => Sealed (WithStartState model (Tree Prim2))-                              -> Bool-propConsistentTreeFlattenings (Sealed (WithStartState start t))-  = fromJust $-    do Sealed (G2 flat) <- return $ flattenTree $ mapTree fromPrim2 t-       rms <- return $ map (start `repoApply`) flat-       return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat)-
+ harness/Darcs/Test/Patch/Properties/RepoPatchV3.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE PatternSynonyms #-}+module Darcs.Test.Patch.Properties.RepoPatchV3+    ( prop_repoInvariants+    ) where++import Prelude ()+import Darcs.Prelude+import qualified Data.Set as S++import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed )+import Darcs.Test.TestOnly.Instance ()++import Darcs.Patch.Commute+import Darcs.Patch.Ident+import Darcs.Patch.Invert+import Darcs.Patch.Permutations ( headPermutationsRL )+import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Patch.Show ( displayPatch, ShowPatchFor(..) )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.V3 ( RepoPatchV3 )+import Darcs.Patch.V3.Contexted+import Darcs.Patch.V3.Core ( pattern PrimP, pattern ConflictorP )++import Darcs.Util.Printer++-- * Repo Invariants++-- What we mean with "repo" here is a flattened version i.e. with named patches+-- replaced by their content, disregarding explicit dependencies. This is why+-- we represent them with a plain 'RL' of 'RepoPatchV3'.++prop_repoInvariants :: PrimPatch p => RL (RepoPatchV3 p) wX wY -> TestResult+prop_repoInvariants NilRL = succeeded+prop_repoInvariants (ps :<: p) =+    prop_repoInvariants ps <>+    prop_positiveId p <>+    prop_uniqueId ps p <>+    prop_consistentConflictor p <>+    prop_onlyFirstConflictorReverts ps p <>+    prop_conflictsCommutePastConflictor ps p <>+    prop_containedCtxEq (ps :<: p)+  where+    -- each patch in a repo has a positive identity+    prop_positiveId x+      | positiveId (ident x) = succeeded+      | otherwise = failed $ text "prop_positiveId"+    -- each patch in a repo has a unique identity+    prop_uniqueId xs x+      | ident x `notElem` mapRL ident xs = succeeded+      | otherwise = failed $ text "prop_uniqueId"++prop_consistentConflictor :: (Invert prim, Commute prim)+                          => RepoPatchV3 prim wX1 wX2 -> TestResult+prop_consistentConflictor (ConflictorP _ x p)+  | all prop_ctxInvariants (p : S.toList x)+  , prop_ctxPositive p+  , all prop_ctxPositive x = succeeded+  | otherwise = failed $ text "prop_consistentConflictor"+prop_consistentConflictor _ = succeeded++-- | This property states that a 'Conflictor' reverts only prims that have not+-- already been reverted by any earlier 'Conflictor'. In other words, the set+-- of 'PatchId's of reverted prims does not intersect with the set of those of+-- preceding 'Conflictor'.+prop_onlyFirstConflictorReverts :: PrimPatch p+                                => RL (RepoPatchV3 p) wX wY+                                -> RepoPatchV3 p wY wZ+                                -> TestResult+prop_onlyFirstConflictorReverts ps p+  | S.null doubly_reverted = succeeded+  | otherwise = failed+      $ text "undone patches are already undone:"+      $$ vcat (map (showId ForStorage) (S.toList doubly_reverted))+      $$ text "in the sequence:"+      $$ vcat (mapRL displayPatch (ps :<: p))+  where+    doubly_reverted = S.intersection this_rids preceding_rids+    this_rids = revertedIds p+    preceding_rids = S.unions (mapRL revertedIds ps)+    revertedIds (ConflictorP r _ _) = S.map invertId (idsFL r)+    revertedIds _ = S.empty++-- | This property states that the patches that a conflictor at the+-- end of a repo conflicts with are in the patches preceding it,+-- that these patches together commute past the conflictor, thereby+-- turning the conflictor into a 'Prim' patch.+-- Note that this does not mean that each of them separately commutes+-- past the conflictor, since there may be dependencies among them.+prop_conflictsCommutePastConflictor :: PrimPatch p+                                    => RL (RepoPatchV3 p) wX wY+                                    -> RepoPatchV3 p wY wZ+                                    -> TestResult+prop_conflictsCommutePastConflictor ps p+  | not (xids `S.isSubsetOf` rids)+  = failed+      $ text "conflicting patches not found in repo:"+      $$ vcat (mapRL displayPatch (ps :<: p))+  | not (revertedIds p `S.isSubsetOf` rids)+  = failed+      $ text "undone patches not found in repo:"+      $$ vcat (mapRL displayPatch (ps :<: p))+  | otherwise =+      case commuteWhatWeCanToPostfix xids ps of+        _ :> xs ->+          case commuteRL (xs :> p) of+            Just (PrimP _ :> _) -> succeeded+            Just _ ->+              failed+                $ text "commuting conflicts past conflictor does not result in a Prim:"+                $$ displayPatch (ps :<: p)+            Nothing ->+              failed+                $ text "cannot commute conflicts past conflictor:"+                $$ displayPatch (ps :<: p)+  where+    xids = conflictIds p+    rids = idsRL ps+    conflictIds (ConflictorP _ x _) = S.map ctxId x+    conflictIds _ = S.empty+    revertedIds (ConflictorP r _ _) = S.map invertId (idsFL r)+    revertedIds _ = S.empty++-- | This is 'prop_ctxEq' checked for any pair of 'Contexted' patches+-- from an 'RL' of 'RepoPatchV3' that we can bring into a common context.+prop_containedCtxEq :: PrimPatch p => RL (RepoPatchV3 p) wX wY -> TestResult+prop_containedCtxEq =+    allSucceeded . map propCtxEq . pairs . concatMap contextedIn . headPermutationsRL+  where+    pairs :: [a] -> [(a,a)]+    pairs xs = [(x,y) | x <- xs, y <- xs]+    contextedIn (_ :<: ConflictorP _ x p) = p : S.toList x+    contextedIn _ = []+    propCtxEq (cp, cq)+      | prop_ctxEq cp cq = succeeded+      | otherwise =+          failed+          $ text "prop_ctxEq: cp="+          $$ showCtx ForStorage cp+          $$ text "cq="+          $$ showCtx ForStorage cq+    allSucceeded = foldr (<>) succeeded++idsFL :: Ident p => FL p wX wY -> S.Set (PatchId p)+idsFL = S.fromList . mapFL ident++idsRL :: Ident p => RL p wX wY -> S.Set (PatchId p)+idsRL = S.fromList . mapRL ident
harness/Darcs/Test/Patch/Properties/V1Set1.hs view
@@ -2,19 +2,21 @@        ( checkMerge, checkMergeEquiv, checkMergeSwap, checkCanon        , checkCommute, checkCantCommute        , tShowRead-       , tMergeEitherWayValid, tTestCheck ) where+       , tTestCheck ) where +import Darcs.Prelude+ import Darcs.Patch      ( commute, invert, merge, effect      , readPatch, showPatch-     , fromPrim, canonize, sortCoalesceFL )-import Darcs.Patch.Invert ( Invert )+     , canonize, sortCoalesceFL )+import Darcs.Patch.FromPrim ( fromAnonymousPrim ) import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor(..) ) import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )-import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check )+import Darcs.Test.Patch.Properties.Check ( checkAPatch ) import Darcs.Util.Printer ( renderPS ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered@@ -91,13 +93,13 @@     then if isIsEq $ eqFL p1_p p2          then succeeded          else failed $ text $ "Canonization with Patience Diff failed:\n"++show p1++"canonized is\n"-               ++show (p1_p :: FL Patch wX wY)+               ++ show p1_p                ++"which is not\n"++show p2     else failed $ text $ "Canonization with Myers Diff failed:\n"++show p1++"canonized is\n"-          ++show (p1_ :: FL Patch wX wY)+          ++ show p1_           ++"which is not\n"++show p2-    where p1_ = mapFL_FL fromPrim $ concatFL $ mapFL_FL (canonize D.MyersDiff) $ sortCoalesceFL $ effect p1-          p1_p = mapFL_FL fromPrim $ concatFL $ mapFL_FL (canonize D.PatienceDiff) $ sortCoalesceFL $ effect p1+    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  checkCommute :: ((FL Patch :> FL Patch) wX wY, (FL Patch :> FL Patch) wX wY) -> TestResult checkCommute (p2 :> p1,p1' :> p2') =@@ -109,7 +111,7 @@              ++"should be\n"++show p2'++"\n"++show p1'              ++"but is\n"++show p2a++"\n"++show p1a    Nothing -> failed $ text $ "Commute failed!\n"++show p1++"\n"++show p2-   <&&>+   <>    case commute (p1' :> p2') of    Just (p2a :> p1a) ->        if (p2a :> p1a) == (p2 :> p1)@@ -133,24 +135,9 @@           => (forall wX wY wW wZ . p wX wY -> p wW wZ -> Bool) -> forall wX wY . p wX wY -> TestResult tShowRead eq p =     case readPatch $ renderPS $ showPatch ForStorage p of-    Just (Sealed p') -> if p' `eq` p then succeeded+    Right (Sealed p') -> if p' `eq` p then succeeded                         else failed $ text $ "Failed to read shown:  "++(show2 p)++"\n"-    Nothing -> failed $ text $ "Failed to read at all:  "++(show2 p)++"\n"--tMergeEitherWayValid :: forall wX wY p . (Check p, Show2 p, Merge p, Invert p) => (p :\/: p) wX wY -> TestResult-tMergeEitherWayValid (p1 :\/: p2) =-  case p2 :>: quickmerge (p1:\/: p2) :>: NilFL of-  combo2 ->-    case p1 :>: quickmerge (p2:\/: p1) :>: NilFL of-    combo1 ->-      if not $ checkAPatch combo1-      then failed $ text $ "oh my combo1 invalid:\n"++show2 p1++"and...\n"++show2 p2++show combo1-      else-        if checkAPatch (invert combo1 :>: combo2 :>: NilFL)-        then succeeded-        else failed $ text $ "merge both ways invalid:\n"++show2 p1++"and...\n"++show2 p2++-              show combo1++-              show combo2+    Left e -> failed $ text $ unlines ["Failed to read at all:  "++show2 p, e]  tTestCheck :: forall wX wY . FL Patch wX wY -> TestResult tTestCheck p = if checkAPatch p
harness/Darcs/Test/Patch/Properties/V1Set2.hs view
@@ -30,7 +30,7 @@     -- TODO: these are exported temporarily to mark them as used     -- Figure out whether to enable or remove the tests.     , propUnravelThreeMerge, propUnravelSeqMerge-    , propUnravelOrderIndependent, propResolveConflictsValid+    , propUnravelOrderIndependent     ) where  import Prelude ()@@ -44,12 +44,10 @@ import Darcs.Test.Patch.Properties.Check ( Check, checkAPatch )  import Darcs.Patch ( invert, commute, merge,-                     readPatch, resolveConflicts,-                     fromPrim, showPatch, ShowPatchFor(..) )+                     readPatch,+                     showPatch, ShowPatchFor(..) ) import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Invert ( Invert )-import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 )-import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import Darcs.Patch.V1.Commute ( unravel, merger ) import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.Prim.V1.Commute@@ -63,11 +61,13 @@ import Darcs.Util.Printer ( renderPS ) import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal, unseal, mapSeal, Sealed2(..) )+import Darcs.Patch.Witnesses.Sealed+    ( Sealed(Sealed), unseal+    , Sealed2(..)+    ) import Darcs.Patch.Witnesses.Unsafe -type Prim1 = V1.Prim-type Patch = V1.RepoPatchV1 Prim1+import Darcs.Test.Patch.Arbitrary.RepoPatchV1 (Patch)   -- | Groups a set of tests by giving them the same prefix in their description.@@ -96,7 +96,7 @@     (doesCommute p1 p2) ==>     case commute (p1:>p2) of     Just (p2':>p1') -> checkAPatch (p1:>:p2:>:invert p1':>:invert p2':>:NilFL)-    _ -> impossible+    _ -> error "impossible case"  propCommuteEitherWay :: Sealed2 (FL Patch :> FL Patch) -> Property propCommuteEitherWay (Sealed2 (p1:>p2)) =@@ -130,7 +130,7 @@     Just (p2':>_) -> case commute (invert p1:>p2') of                     Nothing -> True -- This is a subtle distinction.                     Just (p2'':>_) -> isIsEq (p2'' =\/= p2)-    Nothing -> impossible+    Nothing -> error "impossible case"  propMergeIsCommutableAndCorrect :: Sealed2 (FL Patch :\/: FL Patch) -> Property propMergeIsCommutableAndCorrect (Sealed2 (p1:\/:p2)) =@@ -189,42 +189,33 @@ propUnravelThreeMerge :: Patch wX wY -> Patch wX wZ -> Patch wX wW -> Property propUnravelThreeMerge p1 p2 p3 =     checkAPatch (invert p1:>:p2:>:invert p2:>:p3:>:NilFL) ==>-    (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p2 p3)) (unsafeUnseal (merger "0.0" p2 p1))) ==-    (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p1 p3)) (unsafeUnseal (merger "0.0" p1 p2)))+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0"+         (unseal unsafeCoercePEnd (merger "0.0" p2 p3))+         (unseal unsafeCoercePEnd (merger "0.0" p2 p1))) ==+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0"+         (unseal unsafeCoercePEnd (merger "0.0" p1 p3))+         (unseal unsafeCoercePEnd (merger "0.0" p1 p2)))  propUnravelSeqMerge :: Patch wX wY -> Patch wX wZ -> Patch wZ wW -> Property propUnravelSeqMerge p1 p2 p3 =     checkAPatch (invert p1:>:p2:>:p3:>:NilFL) ==>-    (unravel $ unsafeUnseal $ merger "0.0" p3 $ unsafeUnseal $ merger "0.0" p2 p1) ==-    (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal $ merger "0.0" p2 p1) p3)+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0"+                   p3+                   (unseal unsafeCoercePEnd $ merger "0.0" p2 p1)) ==+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0"+                      (unseal unsafeCoercePEnd $ merger "0.0" p2 p1)+                      p3)  propUnravelOrderIndependent :: Patch wX wY -> Patch wX wZ -> Property propUnravelOrderIndependent p1 p2 =     checkAPatch (invert p1:>:p2:>:NilFL) ==>-    (unravel $ unsafeCoercePStart $ unsafeUnseal $ merger "0.0" p2 p1) == (unravel $ unsafeUnseal $ merger "0.0" p1 p2)--propResolveConflictsValid :: Patch wX wY -> Patch wX wZ -> Property-propResolveConflictsValid p1 p2 =- case merge (p1:\/:p2) of- _ :/\: p1' ->-   let p = p2:>:p1':>:NilFL in-    checkAPatch (invert p1:>:p2:>:NilFL) ==>-    and $ map (\l -> (\ml -> checkAPatch (p+>+ml)) `unseal` mergeList l)-            $ resolveConflicts p--mergeList :: [Sealed (FL Prim1 wX)] -> Sealed (FL Patch wX)-mergeList patches = mapFL_FL fromPrim `mapSeal` doml NilFL patches-    where doml :: FL Prim1 wX wY -> [Sealed (FL Prim1 wX)] -> Sealed (FL Prim1 wX)-          doml mp (Sealed p:ps) =-              case commute (invert p :> mp) of-              Just (mp' :> _) -> doml (p +>+ mp') ps-              Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.-          doml mp [] = Sealed mp+    (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-                   Just (Sealed p') -> isIsEq (p' =\/= p)-                   Nothing -> False+                   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@@ -232,16 +223,16 @@ propCommuteInverse :: Sealed2 (FL Patch :> FL Patch) -> Property propCommuteInverse (Sealed2 (p1 :> p2)) =     doesCommute p1 p2 ==> case commute (p1 :> p2) of-                           Nothing -> impossible+                           Nothing -> error "impossible case"                            Just (_ :> p1') ->                                case commute (p1' :> invert p2) of                                Nothing -> False                                Just (_ :> p1'') -> isIsEq (p1'' =/\= p1) -type CommuteProperty = Sealed2 (Prim1 :> Prim1) -> Property+type CommuteProperty = Sealed2 (Prim :> Prim) -> Property  type CommuteFunction =-    forall wX wY . (Prim1 :> Prim1) wX wY -> Perhaps ((Prim1 :> Prim1) wX wY)+    forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY)  newtype WrappedCommuteFunction = WrappedCommuteFunction     { runWrappedCommuteFunction :: CommuteFunction }@@ -249,8 +240,8 @@ wrapCommuteFunction :: (forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY)) -> WrappedCommuteFunction wrapCommuteFunction f = WrappedCommuteFunction $   \(p :> q) -> do-    q' :> p' <- f (V1.unPrim p :> V1.unPrim q)-    return (V1.Prim q' :> V1.Prim p')+    q' :> p' <- f (p :> q)+    return (q' :> p')  subcommutes :: [(String, WrappedCommuteFunction)] subcommutes =@@ -322,19 +313,19 @@                  Failed -> True                  _ -> False -doesFail :: WrappedCommuteFunction -> Prim1 wX wY -> Prim1 wY wZ -> Bool+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 -> Prim1 wX wY -> Prim1 wY wZ -> Bool+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 -> Prim1 wX wY -> Prim1 wY wZ -> Bool+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)
harness/Darcs/Test/Patch/Rebase.hs view
@@ -1,27 +1,33 @@ {-# LANGUAGE EmptyDataDecls #-} module Darcs.Test.Patch.Rebase ( testSuite ) where +import Darcs.Prelude+ import Control.Monad ( unless )+import Data.Maybe  import Test.Framework ( Test ) import Test.Framework.Providers.HUnit ( testCase ) import Test.HUnit ( assertFailure )  import Darcs.Patch-import Darcs.Patch.Conflict+import Darcs.Patch.Info+import Darcs.Patch.Named+import Darcs.Patch.Summary import Darcs.Patch.Rebase.Fixup-import Darcs.Patch.Rebase.Viewing-import Darcs.Patch.Type+import Darcs.Patch.Rebase.Change import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Show  import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.TestOnly.Instance () -testSuite :: forall rt p . (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType rt p -> [Test]-testSuite pt =-    if hasPrimConstruct (undefined :: PrimOf p WX WX)+import Darcs.Util.Path ( floatPath )++testSuite :: forall p . (RepoPatch p, ArbitraryPrim (PrimOf p)) => [Test]+testSuite =+    if isJust (hasPrimConstruct @(PrimOf p))         then-           [ duplicateConflictedEffect pt+           [ duplicateConflictedEffect @p            ]         else            [@@ -29,14 +35,17 @@  data WX -duplicateConflictedEffect :: forall rt p . (RepoPatch p, Show2 (PrimOf p)) => PatchType rt p -> Test-duplicateConflictedEffect _ =+duplicateConflictedEffect :: forall p . RepoPatch p => Test+duplicateConflictedEffect =     testCase "duplicate in rebase fixup has a conflicted effect" $         unless (all (/= Okay) cStatuses) $             assertFailure ("unexpected conflicted effect: " ++ show cEffect)     where-        corePrim = addfile "./file"-        rebase :: RebaseChange p WX WX-        rebase = RCFwd (PrimFixup (invert corePrim) :>: NilFL) (fromPrim corePrim :>: NilFL)+        corePrim = addfile (floatPath "file")+        rebase :: RebaseChange (PrimOf p) WX WX+        rebase =+          RC (PrimFixup (invert corePrim) :>: NilFL)+             (NamedP dummyPatchInfo [] (corePrim :>: NilFL))+        dummyPatchInfo = rawPatchInfo "1999" "dummy" "harness" [] False         cEffect = conflictedEffect rebase         cStatuses = map (\(IsC status _) -> status) cEffect
harness/Darcs/Test/Patch/RepoModel.hs view
@@ -1,6 +1,9 @@ module Darcs.Test.Patch.RepoModel where++import Darcs.Prelude+ import Darcs.Patch.Apply ( Apply, ApplyState )-import Darcs.Patch.Witnesses.Ordered ( FL )+import Darcs.Patch.Witnesses.Ordered ( FL, RL )  import Test.QuickCheck ( Gen ) @@ -37,6 +40,7 @@   aSmallRepo :: Gen (model x)   repoApply :: (Apply p, ApplyState p ~ RepoState model) => model x -> p x y -> Fail (model y) -type family ModelOf (patch :: * -> * -> *) :: * -> *+type family ModelOf (p :: * -> * -> *) :: * -> * -type instance ModelOf (FL prim) = ModelOf prim+type instance ModelOf (FL p) = ModelOf p+type instance ModelOf (RL p) = ModelOf p
+ harness/Darcs/Test/Patch/RepoPatchV1.hs view
@@ -0,0 +1,106 @@+--  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
@@ -2,6 +2,8 @@  module Darcs.Test.Patch.Selection ( testSuite ) where +import Darcs.Prelude+ import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit ( testCase ) @@ -14,16 +16,18 @@  import Darcs.UI.SelectChanges     ( PatchSelectionOptions(..)-    , selectionContext+    , selectionConfig     , runSelection     , WhichChanges(..)     )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd(..) )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch ) import Darcs.Patch.Info ( rawPatchInfo ) import Darcs.UI.Options.All-    ( Verbosity(..), Summary(..)+    ( Verbosity(..), WithSummary(..)     , WithContext(..), SelectDeps(..), MatchFlag(..) ) +import Darcs.Test.TestOnly.Instance ()+ -- A test module for interactive patch selection.  type Patch = RepoPatchV2 V2.Prim@@ -42,16 +46,16 @@        lnmPatches [] = NilFL        lnmPatches (n:names) = buildPatch n  :>: lnmPatches names        buildPatch :: String -> PatchInfoAnd ('RepoType 'NoRebase) Patch wX wY-       buildPatch name = PIAP (rawPatchInfo "1999" name "harness" [] False) (error "Patch content read!")+       buildPatch name = patchInfoAndPatch (rawPatchInfo "1999" name "harness" [] False) (error "Patch content read!")        pso = PatchSelectionOptions            { verbosity = Quiet            , matchFlags = [OnePatch "."]  -- match on every patch            , interactive = False            , selectDeps = AutoDeps-           , summary = NoSummary+           , withSummary = NoSummary            , withContext = NoContext            }-       context = selectionContext whch "select" pso Nothing Nothing+       context = selectionConfig whch "select" pso Nothing Nothing    (unselected :> selected) <- runSelection launchNuclearMissilesPatches context    -- Forcing selection to happen (at least to the point of knowing whether unselected    -- and unselected are NilFL or not) should not evaluate the `undefined` inside of our
+ harness/Darcs/Test/Patch/Unwind.hs view
@@ -0,0 +1,58 @@+module Darcs.Test.Patch.Unwind+  ( testSuite+  ) where++import Darcs.Prelude++import Darcs.Patch+import Darcs.Patch.Commute+import Darcs.Patch.Unwind+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Show++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Examples.Unwind+import Darcs.Test.Patch.Merge.Checked+import Darcs.Test.Patch.Properties.Generic+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.WithState+import Darcs.Test.Util.TestResult ( TestResult, succeeded, assertNotFailed )++import Test.Framework ( Test )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )++-- This property could be generalised over all instances of Unwind (not+-- just Named), but in practice it is only interesting for Named, for which+-- the fullUnwind implementation is non-trivial.+propUnwindNamedSucceeds+  :: (Unwind p, PrimPatchBase p)+  => Named p wX wY+  -> TestResult+propUnwindNamedSucceeds p =+  case fullUnwind p of+    Unwound before ps after ->+      lengthFL before `seq` ps `seq` lengthRL after `seq` succeeded++numberedTestCases :: forall a . String -> (a -> TestResult) -> [a] -> [Test]+numberedTestCases text runTest = zipWith numbered [1..]+  where+    numbered :: Int -> a -> Test+    numbered n testItem = testCase (text ++ " " ++ show n) (assertNotFailed $ runTest testItem)++testSuite+  :: forall p+   . ( ArbitraryRepoPatch p, PrimBased p, ArbitraryPrim (OnlyPrim p)+     , ShrinkModel (PrimOf p)+     , Show1 (ModelOf (PrimOf p)), Show2 p+     , CheckedMerge p, Commute (OnlyPrim p)+     )+  => [Test]+testSuite =+    -- TODO these need to take the patch type, currently hard-coded to V1+    numberedTestCases "full unwind example" (withAllSequenceItems propUnwindNamedSucceeds) (examples @p)+      +++  [ testProperty "unwind named succeeds"+     (withAllSequenceItems (propUnwindNamedSucceeds :: PatchProperty (Named p)))+  ]
harness/Darcs/Test/Patch/Utils.hs view
@@ -1,13 +1,28 @@ module Darcs.Test.Patch.Utils-    ( testConditional, testStringList )-    where+    ( testConditional+    , testConditionalMaybe+    , testStringList+    , TestGenerator(..)+    , TestCondition(..)+    , TestCheck(..)+    , PropList+    , properties+    , testCases+    , fromNothing+    ) where +import Darcs.Prelude++import Data.Maybe ( fromMaybe )+ import Test.Framework ( Test, TestName ) import Test.Framework.Providers.HUnit ( testCase ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.HUnit ( assertFailure ) import Test.QuickCheck ( Arbitrary, Testable, (==>) ) +import Darcs.Test.Util.TestResult+ -- | Turns a condition and a test function into a conditional quickcheck --   property that can be run by test-framework. testConditional@@ -18,7 +33,72 @@ testConditional name cond t = testProperty name t'     where t' x = cond x ==> t x +testConditionalMaybe+  :: (Arbitrary a, Show a, Testable prop)+  => TestName -- ^ Test name+  -> (a -> Maybe Bool) -- ^ Condition+  -> (a -> prop) -- ^ Test function+  -> Test+testConditionalMaybe name cond t = testProperty name t'+  where+    cond' x =+      case cond x of+        Nothing -> False+        Just b -> b+    t' x = cond' x ==> t x+ -- | Utility function to run old tests that return a list of error messages, --   with the empty list meaning success. testStringList :: String -> [String] -> Test testStringList name test = testCase name $ mapM_ assertFailure test++-- | Run a test function on a set of data, using HUnit. The test function should+--   return @Nothing@ upon success and a @Just x@ upon failure.+testCases :: String             -- ^ The test name+          -> (a -> TestResult)  -- ^ The test function+          -> [a]                -- ^ The test data+          -> Test+testCases name test datas = testCase name (mapM_ (assertNotFailed . test) datas)++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))++newtype TestCondition thing =+  TestCondition (forall wX wY. thing wX wY -> Bool)++newtype TestCheck thing t =+  TestCheck (forall wX wY. thing wX wY -> t)++type PropList what gen = String -> TestGenerator what gen -> [Test]++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)]+           -> [Test]+properties (TestGenerator gen) prefix genname tests =+  [cond name condition check | (name, condition, check) <- tests]+  where+    cond ::+         forall testable. (Testable testable, HasDefault testable)+      => String+      -> TestCondition thing+      -> TestCheck thing testable+      -> Test+    cond t (TestCondition c) (TestCheck p) =+      testConditional+        (prefix ++ " (" ++ genname ++ "): " ++ t)+        (fromMaybe def . gen c)+        (gen p)
harness/Darcs/Test/Patch/V1Model.hs view
@@ -1,7 +1,7 @@ -- | Repository model module Darcs.Test.Patch.V1Model-  ( V1Model, repoTree-  , RepoItem, File, Dir, Content+  ( V1Model(..)+  , RepoItem(..), File, Dir, Content   , makeRepo, emptyRepo   , makeFile, emptyFile   , emptyDir@@ -13,7 +13,6 @@   , filterFiles, filterDirs   , find   , list-  , ap2fp   , aFilename, aDirname   , aLine, aContent   , aFile, aDir@@ -79,13 +78,12 @@   flattenEntry (fn, T.SubTree _) = Dir (BC.unpack (flatten fn))   flattenEntry (fn, T.File blob) = File (BC.unpack (flatten fn))     (map BLC.unpack $ BLC.lines $ unFail $ T.readBlob blob)-  flattenEntry (_, _) = impossible+  flattenEntry (_, _) = error "impossible case"  instance Show (V1Model wX) where   show repo = "V1Model " ++ show (flattenTree (repoTree repo)) -instance Show1 V1Model where-  showDict1 = ShowDictClass+instance Show1 V1Model  ---------------------------------------- -- Utils@@ -103,12 +101,6 @@ lbs2content = map lbs2bs . BLC.lines  ------------------------------------------------------------------------- ** Path conversion--ap2fp :: AnchoredPath -> FilePath-ap2fp = anchorPath ""------------------------------------------------------------------------ -- * Constructors  makeRepo :: [(Name, RepoItem)] -> V1Model wX@@ -212,14 +204,14 @@ aFilename :: Gen Name aFilename = do len <- choose (1,maxLength)                name <- vectorOf len alpha-               return $ makeName (name ++ ".txt")+               return $ either error id $ makeName (name ++ ".txt")   where       maxLength = 3  aDirname :: Gen Name aDirname = do len <- choose (1,maxLength)               name <- vectorOf len alpha-              return $ makeName name+              return $ either error id $ makeName name   where       maxLength = 3
harness/Darcs/Test/Patch/WSub.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-} module Darcs.Test.Patch.WSub where  {-@@ -16,7 +16,9 @@ We call the normal darcs constructors the 'W' variants. -} -import qualified Darcs.Test.Patch.Arbitrary.Generic as W+import Darcs.Prelude++import qualified Darcs.Test.Patch.Arbitrary.PatchTree as W      ( getPairs, getTriples )  import qualified Darcs.Patch as W ( commute )@@ -84,7 +86,7 @@    toW NilFL = unsafeCoerceP W.NilFL    toW (x :>: xs) = unsafeCoercePEnd (toW x) W.:>: unsafeCoercePStart (toW xs) -instance WSub prim prim => WSub (RepoPatchV2 prim) (RepoPatchV2 prim) where+instance WSub (RepoPatchV2 prim) (RepoPatchV2 prim) where    fromW = id    toW = id @@ -95,25 +97,22 @@ instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :> q) wX wY) where    show = show . toW -instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :> q) where-   showDict2 = ShowDictClass+instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :> q)  instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :\/: q) wX wY) where    show = show . toW -instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :\/: q) where-   showDict2 = ShowDictClass+instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :\/: q)  instance (WSub wp p, Show2 wp) => Show (FL p wX wY) where    show = show . toW -instance (WSub wp p, Show2 wp) => Show2 (FL p) where-   showDict2 = ShowDictClass+instance (WSub wp p, Show2 wp) => Show2 (FL p)  instance (WSub wp p, Commute wp, Eq2 wp) => Eq2 (FL p) where    unsafeCompare x y = unsafeCompare (toW x) (toW y) -instance (WSub wp p, Commute wp, Invert wp) => Invert (FL p) where+instance (WSub wp p, Invert wp) => Invert (FL p) where    invert = fromW . invert . toW  instance (WSub wp p, Commute wp) => Commute (FL p) where
harness/Darcs/Test/Patch/WithState.hs view
@@ -1,28 +1,38 @@-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}---module Darcs.Test.Patch.WithState-  where+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.WithState where +import Darcs.Prelude +import Darcs.Patch.Apply+import Darcs.Patch.Commute+import Darcs.Patch.Effect+import Darcs.Patch.FromPrim+import Darcs.Patch.Invert+import Darcs.Patch.Prim.Class+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Maybe import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Show-import Test.QuickCheck ( Gen, sized, choose )+import Test.QuickCheck ( Gen, Arbitrary(..), sized, choose ) +import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Arbitrary.Shrink +import Data.Maybe  ---------------------------------------------------------------------- -- * WithState -data WithState s p wX wY = WithState {-                              wsStartState :: s wX+data WithState p wX wY = WithState {+                              wsStartState :: (ModelOf p) wX                             , wsPatch      :: p wX wY-                            , wsEndState   :: s wY+                            , wsEndState   :: (ModelOf p) wY                             }-    deriving Eq -instance (Show1 s, Show2 p) => Show (WithState s p wX wY) where+type instance ModelOf (WithState p) = ModelOf p++instance (Show1 (ModelOf p), Show2 p) => Show (WithState p wX wY) where   showsPrec d (WithState s p s')     = showParen (d > appPrec) $ showString "WithState "                               . showsPrec1 (appPrec+1) s@@ -31,9 +41,13 @@                               . showString " "                               . showsPrec1 (appPrec+1) s' -instance (Show1 s, Show2 p) => Show2 (WithState s p) where-  showDict2 = ShowDictClass+instance (Show1 (ModelOf p), Show2 p) => Show1 (WithState p wA) +instance (Show1 (ModelOf p), Show2 p) => Show2 (WithState p)++-- | This is only used for the legacy 'Tree' based test generator, where the+-- @p@ parameter gets instantiated to @'Tree' p@ (which has no definite end+-- state). data WithStartState s p wX = WithStartState {                                  wssStartState :: s wX                                , wssPatch      :: p wX@@ -45,9 +59,24 @@                                       showsPrec1 (appPrec + 1) s . showString " " .                                       showsPrec1 (appPrec + 1) p -instance (Show1 s, Show1 p) => Show1 (WithStartState s p) where-   showDict1 = ShowDictClass+instance (Show1 s, Show1 p) => Show1 (WithStartState s p) +-- |'WithStartState2' is like 'WithStartState' but for patches that have both witnesses.+data WithStartState2 p wX wY =+  WithStartState2+  { wss2StartState :: ModelOf p wX+  , wss2Patch      :: p wX wY+  }++instance (Show1 (ModelOf p), Show2 p) => Show (WithStartState2 p wX wY) where+  showsPrec d (WithStartState2 s p) =+    showParen (d > appPrec) $ showString "WithStartState2 " .+    showsPrec1 (appPrec + 1) s . showString " " .+    showsPrec2 (appPrec + 1) p++instance (Show1 (ModelOf p), Show2 p) => Show1 (WithStartState2 p wX)+instance (Show1 (ModelOf p), Show2 p) => Show2 (WithStartState2 p)+ -- | A combination of a patch and its final state. The state, in this module, is --   typically represented by a 'RepoModel' value. The @px@ type is typically a --   patch type applied to its pre-state, e.g. @Prim x@.@@ -63,8 +92,7 @@                                     showsPrec1 (appPrec + 1) s  -instance (Show1 s, Show1 p) => Show1 (WithEndState s p) where-   showDict1 = ShowDictClass+instance (Show1 s, Show1 p) => Show1 (WithEndState s p)   ----------------------------------------------------------------------@@ -74,58 +102,216 @@ --   arbitrary calls. So this can be used to generate a patch that comes after --   another patch. The post-state of the generated patch is hidden by the --   'Sealed'.-class ArbitraryState s p where-  arbitraryState :: s wX -> Gen (Sealed (WithEndState s (p wX)))-  -- does a coarbitrary make sense?-+class ArbitraryState p where+  arbitraryState :: ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (p wX))) -instance ArbitraryState s p => ArbitraryState s (WithState s p) where+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 s p => ArbitraryState s (p :> p) where+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''  -instance ArbitraryState s p => ArbitraryState s (p :> p :> p) where-  arbitraryState s0 = do Sealed (WithEndState p1 s1) <- arbitraryState s0-                         Sealed (WithEndState p2 s2) <- arbitraryState s1-                         Sealed (WithEndState p3 s3) <- arbitraryState s2-                         return $ seal $ WithEndState (p1 :> p2 :> p3) s3+{- the type instance overlaps!+type instance ModelOf (p :> p :> p) = ModelOf p -arbitraryFL :: ArbitraryState s p => forall wX . Int -> s wX -> Gen (Sealed (WithEndState s (FL p wX)))+instance ArbitraryState p => ArbitraryState (p :> p :> p) where+-}++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'''++arbitraryFL ::+     ArbitraryState p+  => forall wX. Int -> ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (FL p wX))) arbitraryFL 0 s = return $ seal $ WithEndState NilFL s arbitraryFL n s = do Sealed (WithEndState x s') <- arbitraryState s                      Sealed (WithEndState xs s'') <- arbitraryFL (n-1) s'                      return $ seal $ WithEndState (x :>: xs) s'' -instance ArbitraryState s p => ArbitraryState s (FL p) where+instance ArbitraryState p => ArbitraryState (FL p) where   arbitraryState s = sized $ \n -> do k <- choose (0, min 2 (n `div` 5))                                       arbitraryFL k s  -makeS2Gen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed2 p)+makeS2Gen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed2 p) makeS2Gen stGen = do s <- stGen                      Sealed (WithEndState p _) <- arbitraryState s                      return $ seal2 p -makeSGen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed (p wX))+makeSGen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed (p wX)) makeSGen stGen = do s <- stGen                     Sealed (WithEndState p _) <- arbitraryState s                     return $ seal p -makeWS2Gen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed2 (WithState s p))+makeWS2Gen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed2 (WithState p)) makeWS2Gen stGen = do s <- stGen                       Sealed (WithEndState wsP _) <- arbitraryState s                       return $ seal2 wsP -makeWSGen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed (WithState s p wX))+makeWSGen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed (WithState p wX)) makeWSGen stGen = do s <- stGen                      Sealed (WithEndState wsP _) <- arbitraryState s                      return $ seal wsP -instance (Show2 p, Show1 s) => Show1 ((WithState s p) wA) where-  showDict1 = ShowDictClass+-- | A class to help with shrinking complex test cases by simplifying+-- the starting state of the test case. See also 'PropagateShrink'.+class ShrinkModel prim where+  -- |Given a repository state, produce a patch that simplifies the+  -- repository state. The inverse of the patch can be passed as the+  -- "shrinking fixup" to 'propagateShrink'.+  --+  -- Imagine that we start with+  --+  --    s wX1 --p1 wX1 wY1--> s wY1+  --+  -- If we shrink the state to @s wX2@:+  --+  --    s wX2 <--prim wX1 wX2-- s wX1+  --+  -- then we hope that 'propagateShrink' will produce a simpler version of @p1@,+  -- @p2@, that starts from the simpler state @s wX2@:+  --+  --                        p2 wX2 wY2+  --               s wX2 ----------------> s wY2+  --                |                        |+  --                |                        |+  --    invert prim |                        | (discard)+  --                |                        |+  --                V                        V+  --               s wX1 ----------------> s wY1+  --                        p1 wX1 wY1+  shrinkModelPatch :: ModelOf prim wX -> [Sealed (prim wX)] +checkOK :: Fail a -> [a]+checkOK (OK a) = [a]+checkOK (Failed _) = []++shrinkModel+  :: forall s prim wX+   . (Apply prim, ApplyState prim ~ RepoState s, ModelOf prim ~ s, RepoModel s, ShrinkModel prim)+  => s wX -> [Sealed (WithEndState s (prim wX))]+shrinkModel s = do+  Sealed prim <- shrinkModelPatch s+  endState <- checkOK $ repoApply s prim+  return $ Sealed $ WithEndState prim endState++-- | A class to help with shrinking complex test cases. The idea is that the+-- "starting state" of the test case is shrunk and this results in a "fixup"+-- primitive that goes from the shrunk starting state to the original starting+-- state. This so-called "shrinking fixup" is then propagated through the test+-- case to generate a new test case that starts at the shrunk starting state.+-- The shrinking fixup is typically generated via the 'ShrinkModel' class.+class PropagateShrink prim p where+  -- Given a test patch (of type @p@) and a shrinking fixup (of type @prim@),+  -- try to propagate the shrinking fixup past the test patch.+  -- The @Maybe2 p@ return type allows the fixup to eliminate the shrinking+  -- patch entirely, and vice versa the @Maybe2 prim@ allows the shrinking fixup+  -- to disappear (for example it might be cancelled out by something in the test+  -- patch).+  -- We don't use @FL p@, because that would only really be useful for a "stuck"+  -- fixup - one that doesn't eliminate or commute - and that implies that+  -- the state shrink isn't actually shrinking the real test case.+  propagateShrink :: (prim :> p) wX wY -> Maybe ((Maybe2 p :> Maybe2 prim) wX wY)++propagateShrinkKeep+  :: PropagateShrink prim p+  => (prim :> p) wX wY+  -> Maybe ((p :> Maybe2 prim) wX wY)+propagateShrinkKeep inp = do+  Just2 p' :> mprim' <- propagateShrink inp+  return (p' :> mprim')++propagateShrinkMaybe+  :: PropagateShrink prim p+  => (Maybe2 prim :> p) wX wY+  -> Maybe ((Maybe2 p :> Maybe2 prim) wX wY)+propagateShrinkMaybe (Nothing2 :> p) = Just (Just2 p :> Nothing2)+propagateShrinkMaybe (Just2 prim :> p) = propagateShrink (prim :> p)++-- |Shrink a test case wrapped with 'WithStartState2' by shrinking the start state+-- of the test case with 'ShrinkModel' and then propagating the shrink through the+-- patch type of the test case.+shrinkState+  :: forall s prim p+   . ( Invert prim, Apply prim, RepoModel s+     , ShrinkModel prim, PropagateShrink prim p+     , ApplyState prim ~ RepoState s+     , ModelOf p ~ s+     , ModelOf prim ~ s+     )+  => Sealed2 (WithStartState2 p)+  -> [Sealed2 (WithStartState2 p)]+shrinkState (Sealed2 (WithStartState2 s p)) = do+  Sealed (WithEndState fixup shrunkState) <- shrinkModel @s @prim s+  p' :> _ <- maybeToList $ propagateShrinkKeep (invert fixup :> p)+  return $ Sealed2 $ WithStartState2 shrunkState p'++shrinkAtStartState+  :: ( Shrinkable p, RepoModel (ModelOf p), Effect p+     , prim ~ PrimOf p, Invert prim, Apply prim+     , ApplyState prim ~ RepoState (ModelOf p)+     )+  => WithStartState2 p wX wY+  -> [FlippedSeal (WithStartState2 p) wY]+shrinkAtStartState (WithStartState2 s p) = do+  FlippedSeal p' <- shrinkAtStart p+  endState <- checkOK $ repoApply s (effect p)+  newState <- checkOK $ repoApply endState (invert (effect p'))+  return $ FlippedSeal (WithStartState2 newState p')++instance+  ( ArbitraryState p, Shrinkable p, RepoModel s+  , s ~ ModelOf p+  , s ~ ModelOf prim+  , Effect p+  , Apply prim, ApplyState prim ~ RepoState s+  , prim ~ PrimOf p, Invert prim, ShrinkModel prim, PropagateShrink prim p+  )+  => Arbitrary (Sealed2 (WithStartState2 p)) where+  arbitrary = do+    repo <- aSmallRepo @s+    Sealed (WithEndState p _) <- arbitraryState repo+    return (Sealed2 (WithStartState2 repo p))+  shrink 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)+  => (prim :> prim) wX wY -> Maybe ((Maybe2 prim :> Maybe2 prim) wX wY)+propagatePrim (p1 :> p2)+  | IsEq <- invert p1 =\/= p2 = Just (Nothing2 :> Nothing2)+  | Just (p2' :> p1') <- commute (p1 :> p2) = Just (Just2 p2' :> Just2 p1')+  | Just p' <- primCoalesce p1 p2 = Just (Just2 p' :> Nothing2)+  | otherwise = Nothing++instance (PropagateShrink prim p, PropagateShrink prim q)+  => PropagateShrink prim (p :> q) where++  propagateShrink (prim :> (p :> q)) = do+    Just2 mp' :> mprim' <- propagateShrink (prim :> p)+    Just2 mq' :> mprim'' <- propagateShrinkMaybe (mprim' :> q)+    return (Just2 (mp' :> mq') :> mprim'')++instance PropagateShrink prim p => PropagateShrink prim (FL p) where+  propagateShrink (prim :> NilFL) = Just (Just2 NilFL :> Just2 prim)+  propagateShrink (prim :> (p :>: ps)) = do+    mp' :> mprim' <- propagateShrink (prim :> p)+    Just2 ps' :> mprim'' <- propagateShrinkMaybe (mprim' :> ps)+    let result = case mp' of+          Nothing2 -> ps'+          Just2 p' -> p' :>: ps'+    return (Just2 result :> mprim'')
harness/Darcs/Test/Repository/Inventory.hs view
@@ -1,5 +1,7 @@ module Darcs.Test.Repository.Inventory where +import Darcs.Prelude+ import Darcs.Repository.Inventory     ( Inventory(..)     , HeadInventory@@ -7,7 +9,6 @@     , InventoryHash     , PatchHash     , PristineHash-    , getValidHash     , mkValidHash     , parseInventory     , showInventory@@ -59,11 +60,10 @@   vectorOf n $ elements $ '-' : (['0'..'9'] ++ ['a'..'f'])  testInventory :: B.ByteString -> HeadInventory -> Assertion-testInventory raw (vhash,inv) = do-  let hash = getValidHash vhash+testInventory raw (hash,inv) = do   hash @=? peekPristineHash raw   let rest = skipPristineHash raw-  Just inv @=? parseInventory rest+  Right inv @=? parseInventory rest   rest @=? renderPS (showInventory inv)   raw @=? renderPS (pokePristineHash hash rest)
+ harness/Darcs/Test/TestOnly/Instance.hs view
@@ -0,0 +1,5 @@+module Darcs.Test.TestOnly.Instance where++import Darcs.Test.TestOnly++instance TestOnly
harness/Darcs/Test/Util/TestResult.hs view
@@ -3,21 +3,35 @@   , succeeded   , failed   , rejected-  , (<&&>)-  , fromMaybe-  , isOk+  , maybeFailed+  , assertNotFailed   , isFailed   ) where -import Darcs.Util.Printer (Doc, renderString)+import Darcs.Prelude +import Darcs.Util.Printer (Doc)+import Darcs.Util.Printer.Color (unsafeRenderStringColored)+ import qualified Test.QuickCheck.Property as Q+import qualified Test.HUnit as H +-- |Indicate the result of a test, which could be success,+-- failure (with a reason), or that the test couldn't run (rejected),+-- perhaps because the input data didn't meet some pre-condition.+-- The Monoid instance combines results by failing if either result+-- failed, rejecting if both results are rejected, and otherwise+-- succeeding. data TestResult   = TestSucceeded   | TestFailed Doc   | TestRejected +instance Show TestResult where+  show TestSucceeded = "TestSucceeded"+  show (TestFailed reason) = "TestFailed: " ++ unsafeRenderStringColored reason+  show TestRejected = "TestRejected"+ succeeded :: TestResult succeeded = TestSucceeded @@ -27,31 +41,37 @@ rejected :: TestResult rejected = TestRejected --- | Succeed even if one of the arguments is rejected.-(<&&>) :: TestResult -> TestResult -> TestResult-t@(TestFailed _) <&&> _s = t-_t <&&> s@(TestFailed _) = s-TestRejected <&&> s = s-t <&&> TestRejected = t-TestSucceeded <&&> TestSucceeded = TestSucceeded+instance Semigroup TestResult where+  -- Succeed even if one of the arguments is rejected.+  t@(TestFailed _) <> _s = t+  _t <> s@(TestFailed _) = s+  TestRejected <> s = s+  t <> TestRejected = t+  TestSucceeded <> TestSucceeded = TestSucceeded +instance Monoid TestResult where+  mempty = TestRejected+  mappend = (<>)+ -- | 'Nothing' is considered success whilst 'Just' is considered failure.-fromMaybe :: Maybe Doc -> TestResult-fromMaybe Nothing = succeeded-fromMaybe (Just errMsg) = failed errMsg+maybeFailed :: Maybe Doc -> TestResult+maybeFailed Nothing = succeeded+maybeFailed (Just errMsg) = failed errMsg  isFailed :: TestResult -> Bool isFailed (TestFailed _) = True isFailed _other = False --- | A test is considered Ok if it does not fail.-isOk :: TestResult -> Bool-isOk = not . isFailed+-- | Convert 'TestResult' to HUnit testable assertion+assertNotFailed :: TestResult -> H.Assertion+assertNotFailed TestSucceeded = return ()+assertNotFailed TestRejected = return ()+assertNotFailed (TestFailed msg) = H.assertString (unsafeRenderStringColored msg)  -- | 'Testable' instance is defined by converting 'TestResult' to -- 'QuickCheck.Property.Result' instance Q.Testable TestResult where   property TestSucceeded = Q.property Q.succeeded   property (TestFailed errorMsg) =-    Q.property (Q.failed {Q.reason = renderString errorMsg})+    Q.property (Q.failed {Q.reason = unsafeRenderStringColored errorMsg})   property TestRejected = Q.property Q.rejected
harness/test.hs view
@@ -1,23 +1,31 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable, ViewPatterns, OverloadedStrings, ExtendedDefaultRules #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}-module Main ( main ) where+module Main ( main, run, defaultConfig, Config(..) ) where +import Darcs.Prelude+ 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.Util.Exception ( die )  import Control.Monad ( filterM ) import Control.Exception ( SomeException ) import Data.Text ( Text, pack, unpack )+import qualified Data.Text as T 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.Environment.FindBin ( getProgPath )-import System.FilePath( takeDirectory, takeBaseName, isAbsolute )+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 )@@ -38,13 +46,13 @@   [ Darcs.Test.Email.testSuite   , Darcs.Test.Misc.testSuite   , Darcs.Test.Repository.Inventory.testSuite-  ] ++ Darcs.Test.Patch.testSuite+  ] ++ (Darcs.Test.Patch.RepoPatchV1.testSuite : Darcs.Test.Patch.testSuite)  -- ---------------------------------------------------------------------- -- shell tests -- ---------------------------------------------------------------------- -data Format = Darcs1 | Darcs2 deriving (Show, Eq, Typeable, Data)+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@@ -67,24 +75,46 @@                            }                  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 <- toTextIgnore <$> pwd-     setenv "HOME" wd-     setenv "TESTDATA" (toTextIgnore (srcdir </> "tests" </> "data"))-     setenv "TESTBIN" (toTextIgnore (srcdir </> "tests" </> "bin"))-     setenv "DARCS_TESTING_PREFS_DIR" $ toTextIgnore $ wd </> ".darcs"-     setenv "EMAIL" "tester"-     setenv "GIT_AUTHOR_NAME" "tester"-     setenv "GIT_AUTHOR_EMAIL" "tester"-     setenv "GIT_COMMITTER_NAME" "tester"-     setenv "GIT_COMMITTER_EMAIL" "tester"-     setenv "DARCS_DONT_COLOR" "1"-     setenv "DARCS_DONT_ESCAPE_ANYTHING" "1"-     p <- get_env_text "PATH"-     setenv "PATH" (pack (takeDirectory dp ++ pathVarSeparator ++ unpack p))-     setenv "DARCS" $ pack dp-     setenv "GHC_VERSION" $ pack $ show (__GLASGOW_HASKELL__ :: Int)+  do wd <- pwd+     p <- unpack <$> get_env_text "PATH"+     let pathToUse = map (fromText . pack) $ takeDirectory dp:Native.splitSearchPath p+     let env =+          [ ("HOME", EnvFilePath wd)+          , ("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)) $@@ -102,23 +132,56 @@           , "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-        pathVarSeparator = ";"+        -- 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-        pathVarSeparator = ":"+        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)@@ -126,7 +189,7 @@   withTmp =    case testdir t of      Just dir -> \job -> do-       let d = (dir </> show (format t) </> show (diffalgorithm t) </> takeBaseName (testfile t))+       let d = (dir </> show (format t) </> show (diffalgorithm t) </> takeTestName (testfile t))        mkdir_p d        job d      Nothing  -> withTmpDir@@ -138,7 +201,7 @@  shellTest :: FilePath -> Format -> Maybe FilePath -> String -> DiffAlgorithm -> Test shellTest dp fmt tdir file da =-  Test (takeBaseName file ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $+  Test (toString (takeTestName file) ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $   ShellTest fmt file tdir dp da  toString :: Shelly.FilePath -> String@@ -167,6 +230,7 @@                      , patience :: Bool                      , darcs1 :: Bool                      , darcs2 :: Bool+                     , darcs3 :: Bool                      , full :: Bool                      , darcs :: String                      , tests :: [String]@@ -175,24 +239,24 @@                      , hideSuccesses :: Bool                      , threads :: Int                      , qcCount :: Int+                     , replay :: Maybe Integer                      }-            deriving (Data, Typeable, Eq)+            deriving (Data, Typeable, Eq, Show)  -defaultConfig :: Annotate Ann-defaultConfig+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]"--- RELEASE BRANCH ONLY: disable network tests (too fragile)---     , network       := True     += help "Run the network shell tests [yes]"-     , network       := False    += help "Run the network shell tests [no]"+     , 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        := False    += help "Use darcs-1 repo format [no]" += name "1"+     , 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"      , darcs         := ""       += help "Darcs binary path" += typ "PATH"      , tests         := []       += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t"@@ -201,10 +265,14 @@      , hideSuccesses := False    += help "Hide successes [no]"      , threads       := 1        += help "Number of threads [1]" += name "j"      , qcCount       := 100      += help "Number of QuickCheck iterations per test [100]" += name "q"+     , replay        := Nothing  += help "Replay QC tests with given seed" += typ "SEED"      ]    += summary "Darcs test harness"    += program "darcs-test" +defaultConfig :: Config+Right defaultConfig = fmap cmdArgsValue $ process (cmdArgsMode_ defaultConfigAnn) []+ run :: Config -> IO () run conf = do     let args = [ "-j", show $ threads conf ]@@ -215,10 +283,11 @@                 -- 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 $ fail ("Directory " ++ d ++ " already exists. Cowardly exiting")+                     when e $ die ("Directory " ++ d ++ " already exists. Cowardly exiting")     darcsBin <-         case darcs conf of             "" -> do@@ -231,17 +300,25 @@                       -- 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" ]+                      [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-                     [] -> fail ("No darcs specified or found nearby. Perhaps --darcs `pwd`/dist/build/darcs/darcs" ++ exeSuffix ++ "?")+                     [] -> die ("No darcs specified or found nearby. Tried:\n" ++ unlines (map toString candidates))             v -> return v     when (shell conf || network conf || failing conf) $ do       unless (isAbsolute $ darcsBin) $-        fail ("Argument to --darcs should be an absolute path")+        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)" @@ -249,6 +326,7 @@      let repoFormat    = (if darcs1 conf then (Darcs1:) else id)                       . (if darcs2 conf then (Darcs2:) else id)+                      . (if darcs3 conf then (Darcs3:) else id)                       $ []     let diffAlgorithm = (if myers conf then (MyersDiff:) else id)                       . (if patience conf then (PatienceDiff:) else id)@@ -275,7 +353,7 @@           hSetBuffering stdout NoBuffering           hSetBinaryMode stderr True           hSetBinaryMode stdin True-          clp  <- cmdArgs_ defaultConfig+          clp  <- cmdArgs_ defaultConfigAnn           run $             if full clp then clp               { hashed   = True
release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n\n[TAG 2.14.5\nBen Franksen <ben.franksen@online.de>**20200806192304\n Ignore-this: 2c4a08e40916e6c0e2dfde4eb66752af766640f92a4dbb847812e06fc0142c6da8592d68199f6985\n] \n"+Just "\nContext:\n\n\n[TAG 2.16.1\nBen Franksen <ben.franksen@online.de>**20200814093257\n Ignore-this: b5957de98ad629b97483fd6bee8941e2871a58aac4c559d37921feda3e88f06c5a939f40820abf9f\n] \n"
+ shelly/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Petr Rockai <me@mornfall.net>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Petr Rockai nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ shelly/shelly.cabal view
@@ -0,0 +1,198 @@+Name:       shelly++Version:     1.7.1.1+Synopsis:    shell-like (systems) programming in Haskell++Description: Shelly provides convenient systems programming in Haskell,+             similar in spirit to POSIX shells. Shelly:+             .+               * is aimed at convenience and getting things done rather than+                 being a demonstration of elegance.+             .+               * has detailed and useful error messages+             .+               * maintains its own environment, making it thread-safe.+             .+               * is modern, using Text and system-filepath/system-fileio+             .+             Shelly is originally forked from the Shellish package.+             .+             See the shelly-extra package for additional functionality.+             .+             An overview is available in the README: <https://github.com/yesodweb/Shelly.hs/blob/master/README.md>+++Homepage:            https://github.com/yesodweb/Shelly.hs+License:             BSD3+License-file:        LICENSE+Author:              Greg Weber, Petr Rockai+Maintainer:          Greg Weber <greg@gregweber.info>+Category:            Development+Build-type:          Simple+Cabal-version:       >=1.8++-- for the sdist of the test suite+extra-source-files: test/src/*.hs+                    test/examples/*.sh+                    test/examples/*.hs+                    test/data/zshrc+                    test/data/nonascii.txt+                    test/data/symlinked_dir/hoge_file+                    test/testall+                    README.md+                    ChangeLog.md++Library+  Exposed-modules: Shelly, Shelly.Lifted, Shelly.Pipe, Shelly.Unix+  other-modules:   Shelly.Base, Shelly.Find+  hs-source-dirs: src+  other-extensions: InstanceSigs++  Build-depends:+    containers                >= 0.4.2.0,+    time                      >= 1.3 && < 2,+    directory                 >= 1.1.0.0 && < 1.4.0.0,+    mtl                       >= 2,+    process                   >= 1.0,+    unix-compat               < 0.6,+    system-filepath           >= 0.4.7 && < 0.5,+    system-fileio             < 0.4,+    monad-control             >= 0.3.2 && < 1.1,+    lifted-base,+    lifted-async,+    exceptions                >= 0.6,+    enclosed-exceptions,+    text, bytestring, async, transformers, transformers-base++  if impl(ghc >= 7.6.1)+    build-depends:+        base >= 4.6 && < 5+  else+    build-depends:+      base >= 4 && < 5++  ghc-options: -Wall++  if impl(ghc >= 7.6.1)+      CPP-Options: -DNO_PRELUDE_CATCH++  extensions:+    CPP++source-repository head+  type:     git+  location: https://github.com/yesodweb/Shelly.hs++Flag lifted+   Description: run the tests against Shelly.Lifted+   Default: False++Test-Suite shelly-testsuite+  type: exitcode-stdio-1.0+  hs-source-dirs: src test/src+  main-is: TestMain.hs+  other-modules:+    CopySpec+    EnvSpec+    FailureSpec+    FindSpec+    Help+    LiftedSpec+    MoveSpec+    ReadFileSpec+    RmSpec+    RunSpec+    SshSpec+    Shelly+    Shelly.Base+    Shelly.Find+    Shelly.Lifted+    TestInit+    WhichSpec+    WriteSpec++  ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded+               -fno-warn-unused-do-bind -fno-warn-type-defaults+++  extensions: OverloadedStrings, ExtendedDefaultRules++  if flag(lifted)+     cpp-options: -DLIFTED++  build-depends:+    base                      >= 4.6,+    text                      >= 0.11,+    async,+    bytestring                >= 0.10,+    containers                >= 0.5.0.0,+    directory                 >= 1.1.0.0 && < 1.4.0.0,+    process                   >= 1.1.0,+    unix-compat               < 0.6,+    system-filepath           >= 0.4.7 && < 0.5,+    system-fileio             < 0.4,+    time                      >= 1.3 && < 2,+    mtl                       >= 2,+    HUnit                     >= 1.2,+    hspec                     >= 1.5,+    transformers,+    transformers-base,+    filepath,+    monad-control,+    lifted-base,+    lifted-async,+    enclosed-exceptions,+    exceptions++  extensions:+    CPP++Flag build-examples+   Description: build some example programs+   Default: False+   Manual: True++-- demonstarated that command output in Shellish was not shown until after the command finished+-- not necessary anymore+Executable drain+  hs-source-dirs: test/examples+  main-is: drain.hs+  if flag(build-examples)+    buildable: True++    build-depends: base                      >= 4.6+                 , shelly+                 , text++    extensions:+      CPP+  else+    buildable: False++Executable run-handles+  hs-source-dirs: test/examples+  main-is: run-handles.hs+  if flag(build-examples)+    buildable: True++    build-depends: base                      >= 4.6+                 , shelly+                 , text++    extensions:+      CPP+  else+    buildable: False++Executable Color+  hs-source-dirs: test/examples+  main-is: color.hs+  if flag(build-examples)+    buildable: True++    build-depends: base                      >= 4.6+                 , process+                 , shelly+                 , text+  else+    buildable: False
+ shelly/src/Shelly.hs view
@@ -0,0 +1,1473 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings,+             FlexibleInstances, IncoherentInstances,+             TypeFamilies, ExistentialQuantification #-}++-- | A module for shell-like programming in Haskell.+-- Shelly's focus is entirely on ease of use for those coming from shell scripting.+-- However, it also tries to use modern libraries and techniques to keep things efficient.+--+-- The functionality provided by+-- this module is (unlike standard Haskell filesystem functionality)+-- thread-safe: each Sh maintains its own environment and its own working+-- directory.+--+-- Recommended usage includes putting the following at the top of your program,+-- otherwise you will likely need either type annotations or type conversions+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE ExtendedDefaultRules #-}+-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- > import Shelly+-- > import qualified Data.Text as T+-- > default (T.Text)+module Shelly+       (+         -- * Entering Sh.+         Sh, ShIO, shelly, shellyNoDir, shellyFailDir, asyncSh, sub+         , silently, verbosely, escaping, print_stdout, print_stderr, print_commands+         , onCommandHandles+         , tracing, errExit+         , log_stdout_with, log_stderr_with++         -- * Running external commands.+         , run, run_, runFoldLines, cmd, FoldCallback+         , bash, bash_, bashPipeFail+         , (-|-), lastStderr, setStdin, lastExitCode+         , command, command_, command1, command1_+         , sshPairs,sshPairsPar, sshPairs_,sshPairsPar_, sshPairsWithOptions+         , sshCommandText, SshMode(..)+         , ShellCmd(..), CmdArg (..)++         -- * Running commands Using handles+         , runHandle, runHandles, transferLinesAndCombine, transferFoldHandleLines+         , StdHandle(..), StdStream(..)++         -- * Handle manipulation+         , HandleInitializer, StdInit(..), initOutputHandles, initAllHandles++         -- * Modifying and querying environment.+         , setenv, get_env, get_env_text, getenv, get_env_def, get_env_all, get_environment, appendToPath, prependToPath++         -- * Environment directory+         , cd, chdir, chdir_p, pwd++         -- * Printing+         , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err+         , tag, trace, show_command++         -- * Querying filesystem.+         , ls, lsT, test_e, test_f, test_d, test_s, test_px, which++         -- * Filename helpers+         , absPath, (</>), (<.>), canonic, canonicalize, relPath, relativeTo, path+         , hasExt++         -- * Manipulating filesystem.+         , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree++         -- * reading/writing Files+         , readfile, readBinary, writefile, writeBinary, appendfile, touchfile, withTmpDir++         -- * exiting the program+         , exit, errorExit, quietExit, terror++         -- * Exceptions+         , bracket_sh, catchany, catch_sh, handle_sh, handleany_sh, finally_sh, ShellyHandler(..), catches_sh, catchany_sh+         , ReThrownException(..)+         , RunFailed(..)++         -- * convert between Text and FilePath+         , toTextIgnore, toTextWarn, FP.fromText++         -- * Utility Functions+         , whenM, unlessM, time, sleep++         -- * Re-exported for your convenience+         , liftIO, when, unless, FilePath, (<$>)++         -- * internal functions for writing extensions+         , get, put++         -- * find functions+         , find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter+         , followSymlink+         ) where++import Shelly.Base+import Shelly.Find+import Control.Monad ( when, unless, void, forM, filterM, liftM2 )+import Control.Monad.Trans ( MonadIO )+import Control.Monad.Reader (ask)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706+import Prelude hiding ( readFile, FilePath, catch)+#else+import Prelude hiding ( readFile, FilePath)+#endif+import Data.Char ( isAlphaNum, isSpace )+import Data.Typeable+import Data.IORef+import Data.Sequence (Seq, (|>))+import Data.Foldable (toList)+import Data.Maybe+import System.IO ( hClose, stderr, stdout, openTempFile)+import System.IO.Error (isPermissionError, catchIOError, isEOFError, isIllegalOperation)+import System.Exit+import System.Environment+import Control.Applicative+import Control.Exception+import Control.Concurrent+import Control.Concurrent.Async (async, wait, Async)+import Data.Time.Clock( getCurrentTime, diffUTCTime  )++import qualified Data.Text.IO as TIO+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TE+import System.Process( CmdSpec(..), StdStream(CreatePipe, UseHandle), CreateProcess(..), createProcess, waitForProcess, terminateProcess, ProcessHandle, StdStream(..) )++import qualified Data.Text as T+import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++#if !MIN_VERSION_base(4,13,0)+import Data.Monoid (mempty, mappend, (<>))+#endif++import Filesystem.Path.CurrentOS hiding (concat, fromText, (</>), (<.>))+import Filesystem hiding (canonicalizePath)+import qualified Filesystem.Path.CurrentOS as FP++import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory )+import Data.Char (isDigit)++import Data.Tree(Tree(..))+import qualified Data.Set as S+import qualified Data.List as L++searchPathSeparator :: Char+#if defined(mingw32_HOST_OS)+searchPathSeparator = ';'+#else+searchPathSeparator = ':'+#endif++{- GHC won't default to Text with this, even with extensions!+ - see: http://hackage.haskell.org/trac/ghc/ticket/6030+class CmdArgs a where+  toTextArgs :: a -> [Text]++instance CmdArgs Text       where toTextArgs t = [t]+instance CmdArgs FilePath   where toTextArgs t = [toTextIgnore t]+instance CmdArgs [Text]     where toTextArgs = id+instance CmdArgs [FilePath] where toTextArgs = map toTextIgnore++instance CmdArgs (Text, Text) where+  toTextArgs (t1,t2) = [t1, t2]+instance CmdArgs (FilePath, FilePath) where+  toTextArgs (fp1,fp2) = [toTextIgnore fp1, toTextIgnore fp2]+instance CmdArgs (Text, FilePath) where+  toTextArgs (t1, fp1) = [t1, toTextIgnore fp1]+instance CmdArgs (FilePath, Text) where+  toTextArgs (fp1,t1) = [toTextIgnore fp1, t1]++cmd :: (CmdArgs args) => FilePath -> args -> Sh Text+cmd fp args = run fp $ toTextArgs args+-}++-- | Argument converter for the variadic argument version of 'run' called 'cmd'.+-- Useful for a type signature of a function that uses 'cmd'+class CmdArg a where toTextArg :: a -> Text+instance CmdArg Text     where toTextArg = id+instance CmdArg FilePath where toTextArg = toTextIgnore+instance CmdArg String   where toTextArg = T.pack++-- | For the variadic function 'cmd'+--+-- partially applied variadic functions require type signatures+class ShellCmd t where+    cmdAll :: FilePath -> [Text] -> t++instance ShellCmd (Sh Text) where+    cmdAll = run++instance (s ~ Text, Show s) => ShellCmd (Sh s) where+    cmdAll = run++-- note that Sh () actually doesn't work for its case (_<- cmd) when there is no type signature+instance ShellCmd (Sh ()) where+    cmdAll = run_++instance (CmdArg arg, ShellCmd result) => ShellCmd (arg -> result) where+    cmdAll fp acc x = cmdAll fp (acc ++ [toTextArg x])++instance (CmdArg arg, ShellCmd result) => ShellCmd ([arg] -> result) where+    cmdAll fp acc x = cmdAll fp (acc ++ map toTextArg x)++++-- | variadic argument version of 'run'.+-- Please see the documenation for 'run'.+--+-- The syntax is more convenient, but more importantly it also allows the use of a FilePath as a command argument.+-- So an argument can be a Text or a FilePath without manual conversions.+-- a FilePath is automatically converted to Text with 'toTextIgnore'.+--+-- Convenient usage of 'cmd' requires the following:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE ExtendedDefaultRules #-}+-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- > import Shelly+-- > import qualified Data.Text as T+-- > default (T.Text)+--+cmd :: (ShellCmd result) => FilePath -> result+cmd fp = cmdAll fp []++-- | Helper to convert a Text to a FilePath. Used by '(</>)' and '(<.>)'+class ToFilePath a where+  toFilePath :: a -> FilePath++instance ToFilePath FilePath where toFilePath = id+instance ToFilePath Text     where toFilePath = FP.fromText+instance ToFilePath String   where toFilePath = FP.fromText . T.pack+++-- | uses System.FilePath.CurrentOS, but can automatically convert a Text+(</>) :: (ToFilePath filepath1, ToFilePath filepath2) => filepath1 -> filepath2 -> FilePath+x </> y = toFilePath x FP.</> toFilePath y++-- | uses System.FilePath.CurrentOS, but can automatically convert a Text+(<.>) :: (ToFilePath filepath) => filepath -> Text -> FilePath+x <.> y = toFilePath x FP.<.> y+++toTextWarn :: FilePath -> Sh Text+toTextWarn efile = case toText efile of+    Left f -> encodeError f >> return f+    Right f -> return f+  where+    encodeError f = echo ("non-unicode file name: " <> f)++-- | Transfer from one handle to another+-- For example, send contents of a process output to stdout.+-- does not close the write handle.+--+-- Also, return the complete contents being streamed line by line.+transferLinesAndCombine :: Handle -> (Text -> IO ()) -> IO Text+transferLinesAndCombine readHandle putWrite =+  transferFoldHandleLines mempty (|>) readHandle putWrite >>=+    return . lineSeqToText++lineSeqToText :: Seq Text -> Text+-- extra append puts a newline at the end+lineSeqToText = T.intercalate "\n" . toList . flip (|>) ""++type FoldCallback a = (a -> Text -> a)++-- | Transfer from one handle to another+-- For example, send contents of a process output to stdout.+-- does not close the write handle.+--+-- Also, fold over the contents being streamed line by line+transferFoldHandleLines :: a -> FoldCallback a -> Handle -> (Text -> IO ()) -> IO a+transferFoldHandleLines start foldLine readHandle putWrite = go start+  where+    go acc = do+        mLine <- filterIOErrors $ TIO.hGetLine readHandle+        case mLine of+            Nothing -> return acc+            Just line -> putWrite line >> go (foldLine acc line)++filterIOErrors :: IO a -> IO (Maybe a)+filterIOErrors action = catchIOError+               (fmap Just action)+               (\e -> if isEOFError e || isIllegalOperation e -- handle was closed+                       then return Nothing+                       else ioError e)++foldHandleLines :: a -> FoldCallback a -> Handle -> IO a+foldHandleLines start foldLine readHandle = go start+  where+    go acc = do+      mLine <- filterIOErrors $ TIO.hGetLine readHandle+      case mLine of+        Nothing -> return acc+        Just line -> go $ foldLine acc line++-- | same as 'trace', but use it combinator style+tag :: Sh a -> Text -> Sh a+tag action msg = do+  trace msg+  action++put :: State -> Sh ()+put newState = do+  stateVar <- ask+  liftIO (writeIORef stateVar newState)++runCommandNoEscape :: [StdHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle)+runCommandNoEscape handles st exe args = liftIO $ shellyProcess handles st $+    ShellCommand $ T.unpack $ T.intercalate " " (toTextIgnore exe : args)++runCommand :: [StdHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle)+runCommand handles st exe args = findExe exe >>= \fullExe ->+  liftIO $ shellyProcess handles st $+    RawCommand (encodeString fullExe) (map T.unpack args)+  where+    findExe :: FilePath -> Sh FilePath+    findExe+#if defined(mingw32_HOST_OS) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 708)+      fp+#else+      _fp+#endif+      = do+        mExe <- whichEith exe+        case mExe of+          Right execFp -> return execFp+          -- windows looks in extra places besides the PATH, so just give+          -- up even if the behavior is not properly specified anymore+          --+          -- non-Windows < 7.8 has a bug for read-only file systems+          -- https://github.com/yesodweb/Shelly.hs/issues/56+          -- it would be better to specifically detect that bug+#if defined(mingw32_HOST_OS) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 708)+          Left _ -> return fp+#else+          Left err -> liftIO $ throwIO $ userError err+#endif+++++shellyProcess :: [StdHandle] -> State -> CmdSpec -> IO (Handle, Handle, Handle, ProcessHandle)+shellyProcess reusedHandles st cmdSpec =  do+    (createdInH, createdOutH, createdErrorH, pHandle) <- createProcess CreateProcess {+          cmdspec = cmdSpec+        , cwd = Just $ encodeString $ sDirectory st+        , env = Just $ sEnvironment st+        , std_in  = createUnless mInH+        , std_out = createUnless mOutH+        , std_err = createUnless mErrorH+        , close_fds = False+#if MIN_VERSION_process(1,1,0)+        , create_group = False+#endif+#if MIN_VERSION_process(1,2,0)+        , delegate_ctlc = False+#endif+#if MIN_VERSION_process(1,3,0)+        , detach_console = False+        , create_new_console = False+        , new_session = False+#endif+#if MIN_VERSION_process(1,4,0)+        , child_group = Nothing+        , child_user = Nothing+#endif+#if MIN_VERSION_process(1,5,0)+        , use_process_jobs = False+#endif+        }+    return ( just $ createdInH <|> toHandle mInH+           , just $ createdOutH <|> toHandle mOutH+           , just $ createdErrorH <|> toHandle mErrorH+           , pHandle+           )+  where+    just :: Maybe a -> a+    just Nothing  = error "error in shelly creating process"+    just (Just j) = j++    toHandle (Just (UseHandle h)) = Just h+    toHandle _ = error "shellyProcess/toHandle: internal error"++    createUnless Nothing = CreatePipe+    createUnless (Just stream) = stream++    mInH    = getStream mIn reusedHandles+    mOutH   = getStream mOut reusedHandles+    mErrorH = getStream mError reusedHandles++    getStream :: (StdHandle -> Maybe StdStream) -> [StdHandle] -> Maybe StdStream+    getStream _ [] = Nothing+    getStream mHandle (h:hs) = mHandle h <|> getStream mHandle hs++    mIn, mOut, mError :: (StdHandle -> Maybe StdStream)+    mIn (InHandle h) = Just h+    mIn _ = Nothing+    mOut (OutHandle h) = Just h+    mOut _ = Nothing+    mError (ErrorHandle h) = Just h+    mError _ = Nothing++{-+-- | use for commands requiring usage of sudo. see 'run_sudo'.+--  Use this pattern for priveledge separation+newtype Sudo a = Sudo { sudo :: Sh a }++-- | require that the caller explicitly state 'sudo'+run_sudo :: Text -> [Text] -> Sudo Text+run_sudo cmd args = Sudo $ run "/usr/bin/sudo" (cmd:args)+-}++-- | Same as a normal 'catch' but specialized for the Sh monad.+catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a+catch_sh action handler = do+    ref <- ask+    liftIO $ catch (runSh action ref) (\e -> runSh (handler e) ref)++-- | Same as a normal 'handle' but specialized for the Sh monad.+handle_sh :: (Exception e) => (e -> Sh a) -> Sh a -> Sh a+handle_sh handler action = do+    ref <- ask+    liftIO $ handle (\e -> runSh (handler e) ref) (runSh action ref)+++-- | Same as a normal 'finally' but specialized for the 'Sh' monad.+finally_sh :: Sh a -> Sh b -> Sh a+finally_sh action handler = do+    ref <- ask+    liftIO $ finally (runSh action ref) (runSh handler ref)++bracket_sh :: Sh a -> (a -> Sh b) -> (a -> Sh c) -> Sh c+bracket_sh acquire release main = do+  ref <- ask+  liftIO $ bracket (runSh acquire ref)+                   (\resource -> runSh (release resource) ref)+                   (\resource -> runSh (main resource) ref)++++-- | You need to wrap exception handlers with this when using 'catches_sh'.+data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> Sh a)++-- | Same as a normal 'catches', but specialized for the 'Sh' monad.+catches_sh :: Sh a -> [ShellyHandler a] -> Sh a+catches_sh action handlers = do+    ref <- ask+    let runner a = runSh a ref+    liftIO $ catches (runner action) $ map (toHandler runner) handlers+  where+    toHandler :: (Sh a -> IO a) -> ShellyHandler a -> Handler a+    toHandler runner (ShellyHandler handler) = Handler (\e -> runner (handler e))++-- | Catch any exception in the Sh monad.+catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a+catchany_sh = catch_sh++-- | Handle any exception in the Sh monad.+handleany_sh :: (SomeException -> Sh a) -> Sh a -> Sh a+handleany_sh = handle_sh++-- | Change current working directory of Sh. This does *not* change the+-- working directory of the process we are running it. Instead, Sh keeps+-- track of its own working directory and builds absolute paths internally+-- instead of passing down relative paths.+cd :: FilePath -> Sh ()+cd = traceCanonicPath ("cd " <>) >=> cd'+  where+    cd' dir = do+        unlessM (test_d dir) $ errorExit $ "not a directory: " <> tdir+        modify $ \st -> st { sDirectory = dir, sPathExecutables = Nothing }+      where+        tdir = toTextIgnore dir++-- | 'cd', execute a Sh action in the new directory and then pop back to the original directory+chdir :: FilePath -> Sh a -> Sh a+chdir dir action = do+  d <- gets sDirectory+  cd dir+  action `finally_sh` cd d++-- | 'chdir', but first create the directory if it does not exit+chdir_p :: FilePath -> Sh a -> Sh a+chdir_p d action = mkdir_p d >> chdir d action+++-- | apply a String IO operations to a Text FilePath+{-+liftStringIO :: (String -> IO String) -> FilePath -> Sh FilePath+liftStringIO f = liftIO . f . unpack >=> return . pack++-- | @asString f = pack . f . unpack@+asString :: (String -> String) -> FilePath -> FilePath+asString f = pack . f . unpack+-}++pack :: String -> FilePath+pack = decodeString++-- | Move a file. The second path could be a directory, in which case the+-- original file is moved into that directory.+-- wraps system-fileio 'FileSystem.rename', which may not work across FS boundaries+mv :: FilePath -> FilePath -> Sh ()+mv from' to' = do+  trace $ "mv " <> toTextIgnore from' <> " " <> toTextIgnore to'+  from <- absPath from'+  to <- absPath to'+  to_dir <- test_d to+  let to_loc = if not to_dir then to else to FP.</> filename from+  liftIO $ rename from to_loc+    `catchany` (\e -> throwIO $+      ReThrownException e (extraMsg to_loc from)+    )+  where+    extraMsg t f = "during copy from: " ++ encodeString f ++ " to: " ++ encodeString t++-- | Get back [Text] instead of [FilePath]+lsT :: FilePath -> Sh [Text]+lsT = ls >=> mapM toTextWarn++-- | Obtain the current (Sh) working directory.+pwd :: Sh FilePath+pwd = gets sDirectory `tag` "pwd"++-- | exit 0 means no errors, all other codes are error conditions+exit :: Int -> Sh a+exit 0 = liftIO exitSuccess `tag` "exit 0"+exit n = liftIO (exitWith (ExitFailure n)) `tag` ("exit " <> T.pack (show n))++-- | echo a message and exit with status 1+errorExit :: Text -> Sh a+errorExit msg = echo msg >> exit 1++-- | for exiting with status > 0 without printing debug information+quietExit :: Int -> Sh a+quietExit 0 = exit 0+quietExit n = throw $ QuietExit n++-- | fail that takes a Text+terror :: Text -> Sh a+terror = fail . T.unpack++-- | Create a new directory (fails if the directory exists).+mkdir :: FilePath -> Sh ()+mkdir = traceAbsPath ("mkdir " <>) >=>+        liftIO . createDirectory False++-- | Create a new directory, including parents (succeeds if the directory+-- already exists).+mkdir_p :: FilePath -> Sh ()+mkdir_p = traceAbsPath ("mkdir -p " <>) >=>+          liftIO . createTree++-- | Create a new directory tree. You can describe a bunch of directories as+-- a tree and this function will create all subdirectories. An example:+--+-- > exec = mkTree $+-- >           "package" # [+-- >                "src" # [+-- >                    "Data" # leaves ["Tree", "List", "Set", "Map"]+-- >                ],+-- >                "test" # leaves ["QuickCheck", "HUnit"],+-- >                "dist/doc/html" # []+-- >            ]+-- >         where (#) = Node+-- >               leaves = map (# [])+--+mkdirTree :: Tree FilePath -> Sh ()+mkdirTree = mk . unrollPath+    where mk :: Tree FilePath -> Sh ()+          mk (Node a ts) = do+            b <- test_d a+            unless b $ mkdir a+            chdir a $ mapM_ mkdirTree ts++          unrollPath :: Tree FilePath -> Tree FilePath+          unrollPath (Node v ts) = unrollRoot v $ map unrollPath ts+              where unrollRoot x = foldr1 phi $ map Node $ splitDirectories x+                    phi a b = a . return . b+++isExecutable :: FilePath -> IO Bool+isExecutable f = (executable `fmap` getPermissions (encodeString f)) `catch` (\(_ :: IOError) -> return False)++-- | Get a full path to an executable by looking at the @PATH@ environement+-- variable. Windows normally looks in additional places besides the+-- @PATH@: this does not duplicate that behavior.+which :: FilePath -> Sh (Maybe FilePath)+which fp = either (const Nothing) Just <$> whichEith fp++-- | Get a full path to an executable by looking at the @PATH@ environement+-- variable. Windows normally looks in additional places besides the+-- @PATH@: this does not duplicate that behavior.+whichEith :: FilePath -> Sh (Either String FilePath)+whichEith originalFp = whichFull+#if defined(mingw32_HOST_OS)+    $ case extension originalFp of+        Nothing -> originalFp <.> "exe"+        Just _ -> originalFp+#else+    originalFp+#endif+  where+    whichFull fp = do+      (trace . mappend "which " . toTextIgnore) fp >> whichUntraced+      where+        whichUntraced | absolute fp            = checkFile+                      | dotSlash splitOnDirs   = checkFile+                      | length splitOnDirs > 0 = lookupPath  >>= leftPathError+                      | otherwise              = lookupCache >>= leftPathError++        splitOnDirs = splitDirectories fp+        dotSlash ("./":_) = True+        dotSlash _ = False++        checkFile :: Sh (Either String FilePath)+        checkFile = do+            exists <- liftIO $ isFile fp+            return $ if exists then Right fp else+              Left $ "did not find file: " <> encodeString fp++        leftPathError :: Maybe FilePath -> Sh (Either String FilePath)+        leftPathError Nothing  = Left <$> pathLookupError+        leftPathError (Just x) = return $ Right x++        pathLookupError :: Sh String+        pathLookupError = do+          pATH <- get_env_text "PATH"+          return $+            "shelly did not find " `mappend` encodeString fp `mappend`+            " in the PATH: " `mappend` T.unpack pATH++        lookupPath :: Sh (Maybe FilePath)+        lookupPath = (pathDirs >>=) $ findMapM $ \dir -> do+            let fullFp = dir </> fp+            res <- liftIO $ isExecutable fullFp+            return $ if res then Just fullFp else Nothing++        lookupCache :: Sh (Maybe FilePath)+        lookupCache = do+            pathExecutables <- cachedPathExecutables+            return $ fmap (flip (</>) fp . fst) $+                L.find (S.member fp . snd) pathExecutables+++        pathDirs = mapM absPath =<< ((map FP.fromText . filter (not . T.null) . T.split (== searchPathSeparator)) `fmap` get_env_text "PATH")++        cachedPathExecutables :: Sh [(FilePath, S.Set FilePath)]+        cachedPathExecutables = do+          mPathExecutables <- gets sPathExecutables+          case mPathExecutables of+              Just pExecutables -> return pExecutables+              Nothing -> do+                dirs <- pathDirs+                executables <- forM dirs (\dir -> do+                    files <- (liftIO . listDirectory) dir `catch_sh` (\(_ :: IOError) -> return [])+                    exes <- fmap (map snd) $ liftIO $ filterM (isExecutable . fst) $+                      map (\f -> (f, filename f)) files+                    return $ S.fromList exes+                  )+                let cachedExecutables = zip dirs executables+                modify $ \x -> x { sPathExecutables = Just cachedExecutables }+                return $ cachedExecutables+++-- | A monadic findMap, taken from MissingM package+findMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+findMapM _ [] = return Nothing+findMapM f (x:xs) = do+    mb <- f x+    if (isJust mb)+      then return mb+      else findMapM f xs++-- | A monadic-conditional version of the 'unless' guard.+unlessM :: Monad m => m Bool -> m () -> m ()+unlessM c a = c >>= \res -> unless res a++-- | Does a path point to an existing filesystem object?+test_e :: FilePath -> Sh Bool+test_e = absPath >=> \f ->+  liftIO $ do+    file <- isFile f+    if file then return True else isDirectory f++-- | Does a path point to an existing file?+test_f :: FilePath -> Sh Bool+test_f = absPath >=> liftIO . isFile++-- | Test that a file is in the PATH and also executable+test_px :: FilePath -> Sh Bool+test_px exe = do+  mFull <- which exe+  case mFull of+    Nothing -> return False+    Just full -> liftIO $ isExecutable full++-- | A swiss army cannon for removing things. Actually this goes farther than a+-- normal rm -rf, as it will circumvent permission problems for the files we+-- own. Use carefully.+-- Uses 'removeTree'+rm_rf :: FilePath -> Sh ()+rm_rf infp = do+  f <- traceAbsPath ("rm -rf " <>) infp+  isDir <- (test_d f)+  if not isDir then whenM (test_f f) $ rm_f f+    else+      (liftIO_ $ removeTree f) `catch_sh` (\(e :: IOError) ->+        when (isPermissionError e) $ do+          find f >>= mapM_ (\file -> liftIO_ $ fixPermissions (encodeString file) `catchany` \_ -> return ())+          liftIO $ removeTree f+        )+  where fixPermissions file =+          do permissions <- liftIO $ getPermissions file+             let deletable = permissions { readable = True, writable = True, executable = True }+             liftIO $ setPermissions file deletable++-- | Remove a file. Does not fail if the file does not exist.+-- Does fail if the file is not a file.+rm_f :: FilePath -> Sh ()+rm_f = traceAbsPath ("rm -f " <>) >=> \f ->+  whenM (test_e f) $ liftIO $ removeFile f++-- | Remove a file.+-- Does fail if the file does not exist (use 'rm_f' instead) or is not a file.+rm :: FilePath -> Sh ()+rm = traceAbsPath ("rm " <>) >=>+  -- TODO: better error message for removeFile (give filename)+  liftIO . removeFile++-- | Set an environment variable. The environment is maintained in Sh+-- internally, and is passed to any external commands to be executed.+setenv :: Text -> Text -> Sh ()+setenv k v = if k == path_env then setPath v else setenvRaw k v++setenvRaw :: Text -> Text -> Sh ()+setenvRaw k v = modify $ \x -> x { sEnvironment = wibble $ sEnvironment x }+  where+    (kStr, vStr) = (T.unpack k, T.unpack v)+    wibble environment = (kStr, vStr) : filter ((/=kStr) . fst) environment++setPath :: Text -> Sh ()+setPath newPath = do+  modify $ \x -> x{ sPathExecutables = Nothing }+  setenvRaw path_env newPath++path_env :: Text+path_env = "PATH"++-- | add the filepath onto the PATH env variable+appendToPath :: FilePath -> Sh ()+appendToPath = traceAbsPath ("appendToPath: " <>) >=> \filepath -> do+  tp <- toTextWarn filepath+  pe <- get_env_text path_env+  setPath $ pe <> T.singleton searchPathSeparator <> tp++-- | prepend the filepath to the PATH env variable+-- similar to `appendToPath` but gives high priority to the filepath instead of low priority.+prependToPath :: FilePath -> Sh ()+prependToPath = traceAbsPath ("prependToPath: " <>) >=> \filepath -> do+  tp <- toTextWarn filepath+  pe <- get_env_text path_env+  setPath $ tp <> T.singleton searchPathSeparator <> pe++get_environment :: Sh [(String, String)]+get_environment = gets sEnvironment+{-# DEPRECATED get_environment "use get_env_all" #-}++-- | get the full environment+get_env_all :: Sh [(String, String)]+get_env_all = gets sEnvironment++-- | Fetch the current value of an environment variable.+-- if non-existant or empty text, will be Nothing+get_env :: Text -> Sh (Maybe Text)+get_env k = do+  mval <- return . fmap T.pack . lookup (T.unpack k) =<< gets sEnvironment+  return $ case mval of+    Nothing  -> Nothing+    Just val -> if (not $ T.null val) then Just val else Nothing++-- | deprecated+getenv :: Text -> Sh Text+getenv k = get_env_def k ""+{-# DEPRECATED getenv "use get_env or get_env_text" #-}++-- | Fetch the current value of an environment variable. Both empty and+-- non-existent variables give empty string as a result.+get_env_text :: Text -> Sh Text+get_env_text = get_env_def ""++-- | Fetch the current value of an environment variable. Both empty and+-- non-existent variables give the default Text value as a result+get_env_def :: Text -> Text -> Sh Text+get_env_def d = get_env >=> return . fromMaybe d+{-# DEPRECATED get_env_def "use fromMaybe DEFAULT get_env" #-}++-- | Apply a single initializer to the two output process handles (stdout and stderr)+initOutputHandles :: HandleInitializer -> StdInit+initOutputHandles f = StdInit (const $ return ()) f f++-- | Apply a single initializer to all three standard process handles (stdin, stdout and stderr)+initAllHandles :: HandleInitializer -> StdInit+initAllHandles f = StdInit f f f++-- | When running an external command, apply the given initializers to+-- the specified handles for that command.+-- This can for example be used to change the encoding of the+-- handles or set them into binary mode.+onCommandHandles :: StdInit -> Sh a -> Sh a+onCommandHandles initHandles a =+    sub $ modify (\x -> x { sInitCommandHandles = initHandles }) >> a++-- | Create a sub-Sh in which external command outputs are not echoed and+-- commands are not printed.+-- See 'sub'.+silently :: Sh a -> Sh a+silently a = sub $ modify (\x -> x+                                { sPrintStdout = False+                                , sPrintStderr = False+                                , sPrintCommands = False+                                }) >> a++-- | Create a sub-Sh in which external command outputs are echoed and+-- Executed commands are printed+-- See 'sub'.+verbosely :: Sh a -> Sh a+verbosely a = sub $ modify (\x -> x+                                 { sPrintStdout = True+                                 , sPrintStderr = True+                                 , sPrintCommands = True+                                 }) >> a++-- | Create a sub-Sh in which stdout is sent to the user-defined+-- logger.  When running with 'silently' the given log will not be+-- called for any output. Likewise the log will also not be called for+-- output from 'run_' and 'bash_' commands.+log_stdout_with :: (Text -> IO ()) -> Sh a -> Sh a+log_stdout_with logger a = sub $ modify (\s -> s { sPutStdout = logger })+                                 >> a++-- | Create a sub-Sh in which stderr is sent to the user-defined+-- logger.  When running with 'silently' the given log will not be+-- called for any output. However, unlike 'log_stdout_with' the log+-- will be called for output from 'run_' and 'bash_' commands.+log_stderr_with :: (Text -> IO ()) -> Sh a -> Sh a+log_stderr_with logger a = sub $ modify (\s -> s { sPutStderr = logger })+                                 >> a++-- | Create a sub-Sh with stdout printing on or off+-- Defaults to True.+print_stdout :: Bool -> Sh a -> Sh a+print_stdout shouldPrint a =+  sub $ modify (\x -> x { sPrintStdout = shouldPrint }) >> a++-- | Create a sub-Sh with stderr printing on or off+-- Defaults to True.+print_stderr :: Bool -> Sh a -> Sh a+print_stderr shouldPrint a =+  sub $ modify (\x -> x { sPrintStderr = shouldPrint }) >> a+++-- | Create a sub-Sh with command echoing on or off+-- Defaults to False, set to True by 'verbosely'+print_commands :: Bool -> Sh a -> Sh a+print_commands shouldPrint a = sub $ modify (\st -> st { sPrintCommands = shouldPrint }) >> a++-- | Enter a sub-Sh that inherits the environment+-- The original state will be restored when the sub-Sh completes.+-- Exceptions are propagated normally.+sub :: Sh a -> Sh a+sub a = do+  oldState <- get+  modify $ \st -> st { sTrace = T.empty }+  a `finally_sh` restoreState oldState+  where+    restoreState oldState = do+      newState <- get+      put oldState {+         -- avoid losing the log+         sTrace  = sTrace oldState <> sTrace newState+         -- latest command execution: not make sense to restore these to old settings+       , sCode   = sCode newState+       , sStderr = sStderr newState+         -- it is questionable what the behavior of stdin should be+       , sStdin  = sStdin newState+       }++-- | Create a sub-Sh where commands are not traced+-- Defaults to True.+-- You should only set to False temporarily for very specific reasons+tracing :: Bool -> Sh a -> Sh a+tracing shouldTrace action = sub $ do+  modify $ \st -> st { sTracing = shouldTrace }+  action++-- | Create a sub-Sh with shell character escaping on or off.+-- Defaults to @True@.+--+-- Setting to @False@ allows for shell wildcard such as * to be expanded by the shell along with any other special shell characters.+-- As a side-effect, setting to @False@ causes changes to @PATH@ to be ignored:+-- see the 'run' documentation.+escaping :: Bool -> Sh a -> Sh a+escaping shouldEscape action = sub $ do+  modify $ \st -> st { sCommandEscaping = shouldEscape }+  action++-- | named after bash -e errexit. Defaults to @True@.+-- When @True@, throw an exception on a non-zero exit code.+-- When @False@, ignore a non-zero exit code.+-- Not recommended to set to @False@ unless you are specifically checking the error code with 'lastExitCode'.+errExit :: Bool -> Sh a -> Sh a+errExit shouldExit action = sub $ do+  modify $ \st -> st { sErrExit = shouldExit }+  action++-- | 'find'-command follows symbolic links. Defaults to @False@.+-- When @True@, follow symbolic links.+-- When @False@, never follow symbolic links.+followSymlink :: Bool -> Sh a -> Sh a+followSymlink enableFollowSymlink action = sub $ do+  modify $ \st -> st { sFollowSymlink = enableFollowSymlink }+  action+++defReadOnlyState :: ReadOnlyState+defReadOnlyState = ReadOnlyState { rosFailToDir = False }++-- | Deprecated now, just use 'shelly', whose default has been changed.+-- Using this entry point does not create a @.shelly@ directory in the case+-- of failure. Instead it logs directly into the standard error stream (@stderr@).+shellyNoDir :: MonadIO m => Sh a -> m a+shellyNoDir = shelly' ReadOnlyState { rosFailToDir = False }+{-# DEPRECATED shellyNoDir "Just use shelly. The default settings have changed" #-}++-- | Using this entry point creates a @.shelly@ directory in the case+-- of failure where errors are recorded.+shellyFailDir :: MonadIO m => Sh a -> m a+shellyFailDir = shelly' ReadOnlyState { rosFailToDir = True }++-- | Enter a Sh from (Monad)IO. The environment and working directories are+-- inherited from the current process-wide values. Any subsequent changes in+-- processwide working directory or environment are not reflected in the+-- running Sh.+shelly :: MonadIO m => Sh a -> m a+shelly = shelly' defReadOnlyState++shelly' :: MonadIO m => ReadOnlyState -> Sh a -> m a+shelly' ros action = do+  environment <- liftIO getEnvironment+  dir <- liftIO getWorkingDirectory+  let def  = State { sCode = 0+                   , sStdin = Nothing+                   , sStderr = T.empty+                   , sPutStdout = TIO.hPutStrLn stdout+                   , sPutStderr = TIO.hPutStrLn stderr+                   , sPrintStdout = True+                   , sPrintStderr = True+                   , sPrintCommands = False+                   , sInitCommandHandles = initAllHandles (const $ return ())+                   , sCommandEscaping = True+                   , sEnvironment = environment+                   , sTracing = True+                   , sTrace = T.empty+                   , sDirectory = dir+                   , sPathExecutables = Nothing+                   , sErrExit = True+                   , sReadOnly = ros+                   , sFollowSymlink = False+                   }+  stref <- liftIO $ newIORef def+  let caught =+        action `catches_sh` [+              ShellyHandler (\ex ->+                case ex of+                  ExitSuccess   -> liftIO $ throwIO ex+                  ExitFailure _ -> throwExplainedException ex+              )+            , ShellyHandler (\ex -> case ex of+                                     QuietExit n -> liftIO $ throwIO $ ExitFailure n)+            , ShellyHandler (\(ex::SomeException) -> throwExplainedException ex)+          ]+  liftIO $ runSh caught stref+  where+    throwExplainedException :: Exception exception => exception -> Sh a+    throwExplainedException ex = get >>= errorMsg >>= liftIO . throwIO . ReThrownException ex++    errorMsg st =+      if not (rosFailToDir $ sReadOnly st) then ranCommands else do+          d <- pwd+          sf <- shellyFile+          let logFile = d</>shelly_dir</>sf+          (writefile logFile trc >> return ("log of commands saved to: " <> encodeString logFile))+            `catchany_sh` (\_ -> ranCommands)++      where+        trc = sTrace st+        ranCommands = return . mappend "Ran commands: \n" . T.unpack $ trc++    shelly_dir = ".shelly"+    shellyFile = chdir_p shelly_dir $ do+      fs <- ls "."+      return $ pack $ show (nextNum fs) <> ".txt"++    nextNum :: [FilePath] -> Int+    nextNum [] = 1+    nextNum fs = (+ 1) . maximum . map (readDef 1 . filter isDigit . encodeString . filename) $ fs++-- from safe package+readDef :: Read a => a -> String -> a+readDef def = fromMaybe def . readMay+  where+    readMay :: Read a => String -> Maybe a+    readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of+                  [x] -> Just x+                  _ -> Nothing++data RunFailed = RunFailed FilePath [Text] Int Text deriving (Typeable)++instance Show RunFailed where+  show (RunFailed exe args code errs) =+    let codeMsg = case code of+          127 -> ". exit code 127 usually means the command does not exist (in the PATH)"+          _ -> ""+    in "error running: " ++ T.unpack (show_command exe args) +++         "\nexit status: " ++ show code ++ codeMsg ++ "\nstderr: " ++ T.unpack errs++instance Exception RunFailed++show_command :: FilePath -> [Text] -> Text+show_command exe args =+    T.intercalate " " $ map quote (toTextIgnore exe : args)+  where+    quote t | T.any (== '\'') t = t+    quote t | T.any isSpace t = surround '\'' t+    quote t | otherwise = t++-- quote one argument+quoteOne :: Text -> Text+quoteOne t =+    surround '\'' $ T.replace "'" "'\\''" t+++-- returns a string that can be executed by a shell.+-- NOTE: all parts are treated literally, which means that+-- things like variable expansion will not be available.+quoteCommand :: FilePath -> [Text] -> Text+quoteCommand exe args =+    T.intercalate " " $ map quoteOne (toTextIgnore exe : args)++surround :: Char -> Text -> Text+surround c t = T.cons c $ T.snoc t c++data SshMode = ParSsh | SeqSsh++-- | same as 'sshPairs', but returns ()+sshPairs_ :: Text -> [(FilePath, [Text])] -> Sh ()+sshPairs_ _ [] = return ()+sshPairs_ server cmds = sshPairs' run_ server cmds++-- | same as 'sshPairsP', but returns ()++sshPairsPar_ :: Text -> [(FilePath, [Text])] -> Sh ()+sshPairsPar_ _ [] = return ()+sshPairsPar_ server cmds = sshPairsPar' run_ server cmds++-- | run commands over SSH.+-- An ssh executable is expected in your path.+-- Commands are in the same form as 'run', but given as pairs+--+-- > sshPairs "server-name" [("cd", "dir"), ("rm",["-r","dir2"])]+--+-- This interface is crude, but it works for now.+--+-- Please note this sets 'escaping' to False, and the remote commands are+-- quoted with single quotes, in a way such that the remote commands will see+-- the literal values you passed, this means that no variable expansion and+-- alike will done on either the local shell or the remote shell, and that+-- if there are a single or double quotes in your arguments, they need not+-- to be quoted manually.+--+-- Internally the list of commands are combined with the string @&&@ before given to ssh.+sshPairs :: Text -> [(FilePath, [Text])] -> Sh Text+sshPairs _ [] = return ""+sshPairs server cmds = sshPairsWithOptions' run server [] cmds SeqSsh++-- | Same as sshPairs, but combines commands with the string @&@, so they will be started in parallell.+sshPairsPar :: Text -> [(FilePath, [Text])] -> Sh Text+sshPairsPar _ [] = return ""+sshPairsPar server cmds = sshPairsWithOptions' run server [] cmds ParSsh++sshPairsPar' :: (FilePath -> [Text] -> Sh a) -> Text -> [(FilePath, [Text])] -> Sh a+sshPairsPar' run' server actions = sshPairsWithOptions' run' server [] actions ParSsh++sshPairs' :: (FilePath -> [Text] -> Sh a) -> Text -> [(FilePath, [Text])] -> Sh a+sshPairs' run' server actions = sshPairsWithOptions' run' server [] actions SeqSsh++-- | Like 'sshPairs', but allows for arguments to the call to ssh.+sshPairsWithOptions :: Text                  -- ^ Server name.+                    -> [Text]                -- ^ Arguments to ssh (e.g. ["-p","22"]).+                    -> [(FilePath, [Text])]  -- ^ Pairs of commands to run on the remote.+                    -> Sh Text               -- ^ Returns the standard output.+sshPairsWithOptions _ _ [] = return ""+sshPairsWithOptions server sshargs cmds = sshPairsWithOptions' run server sshargs cmds SeqSsh++sshPairsWithOptions' :: (FilePath -> [Text] -> Sh a) -> Text -> [Text] -> [(FilePath, [Text])] -> SshMode  -> Sh a+sshPairsWithOptions' run' server sshargs actions mode = escaping False $ do+    run' "ssh" ([server] ++ sshargs ++ [sshCommandText actions mode])++sshCommandText :: [(FilePath, [Text])] -> SshMode -> Text+sshCommandText actions mode =+    quoteOne (foldl1 joiner (map (uncurry quoteCommand) actions))+  where+    joiner memo next = case mode of+        SeqSsh -> memo <> " && " <> next+        ParSsh -> memo <> " & " <> next++data QuietExit = QuietExit Int deriving (Show, Typeable)+instance Exception QuietExit++-- | Shelly's wrapper around exceptions thrown in its monad+data ReThrownException e = ReThrownException e String deriving (Typeable)+instance Exception e => Exception (ReThrownException e)+instance Exception e => Show (ReThrownException e) where+  show (ReThrownException ex msg) = "\n" +++    msg ++ "\n" ++ "Exception: " ++ show ex++-- | Execute an external command.+-- Takes the command name and arguments.+--+-- You may prefer using 'cmd' instead, which is a variadic argument version+-- of this function.+--+-- 'stdout' and 'stderr' are collected. The 'stdout' is returned as+-- a result of 'run', and complete stderr output is available after the fact using+-- 'lastStderr'+--+-- All of the stdout output will be loaded into memory.+-- You can avoid this if you don't need stdout by using 'run_',+-- If you want to avoid the memory and need to process the output then use 'runFoldLines' or 'runHandle' or 'runHandles'.+--+-- By default shell characters are escaped and+-- the command name is a name of a program that can be found via @PATH@.+-- Shelly will look through the @PATH@ itself to find the command.+--+-- When 'escaping' is set to @False@, shell characters are allowed.+-- Since there is no longer a guarantee that a single program name is+-- given, Shelly cannot look in the @PATH@ for it.+-- a @PATH@ modified by setenv is not taken into account when finding the exe name.+-- Instead the original Haskell program @PATH@ is used.+-- On a Posix system the @env@ command can be used to make the 'setenv' PATH used when 'escaping' is set to False. @env echo hello@ instead of @echo hello@+--+run :: FilePath -> [Text] -> Sh Text+run fp args = return . lineSeqToText =<< runFoldLines mempty (|>) fp args++-- | Like `run`, but it invokes the user-requested program with _bash_.+bash :: FilePath -> [Text] -> Sh Text+bash fp args = escaping False $ run "bash" $ bashArgs fp args++bash_ :: FilePath -> [Text] -> Sh ()+bash_ fp args = escaping False $ run_ "bash" $ bashArgs fp args++bashArgs :: FilePath -> [Text] -> [Text]+bashArgs fp args = ["-c", "'" <> sanitise (toTextIgnore fp : args) <> "'"]+  where+    sanitise = T.replace "'" "\'" . T.intercalate " "++-- | Use this with `bash` to set _pipefail_+--+-- > bashPipeFail $ bash "echo foo | echo"+bashPipeFail :: (FilePath -> [Text] -> Sh a) -> FilePath -> [Text] -> Sh a+bashPipeFail runner fp args = runner "set -o pipefail;" (toTextIgnore fp : args)++-- | bind some arguments to run for re-use. Example:+--+-- > monit = command "monit" ["-c", "monitrc"]+-- > monit ["stop", "program"]+command :: FilePath -> [Text] -> [Text] -> Sh Text+command com args more_args = run com (args ++ more_args)++-- | bind some arguments to 'run_' for re-use. Example:+--+-- > monit_ = command_ "monit" ["-c", "monitrc"]+-- > monit_ ["stop", "program"]+command_ :: FilePath -> [Text] -> [Text] -> Sh ()+command_ com args more_args = run_ com (args ++ more_args)++-- | bind some arguments to run for re-use, and require 1 argument. Example:+--+-- > git = command1 "git" []; git "pull" ["origin", "master"]+command1 :: FilePath -> [Text] -> Text -> [Text] -> Sh Text+command1 com args one_arg more_args = run com (args ++ [one_arg] ++ more_args)++-- | bind some arguments to run for re-use, and require 1 argument. Example:+--+-- > git_ = command1_ "git" []; git "pull" ["origin", "master"]+command1_ :: FilePath -> [Text] -> Text -> [Text] -> Sh ()+command1_ com args one_arg more_args = run_ com (args ++ [one_arg] ++ more_args)++-- | the same as 'run', but return @()@ instead of the stdout content+-- stdout will be read and discarded line-by-line+run_ :: FilePath -> [Text] -> Sh ()+run_ exe args = do+    state <- get+    if sPrintStdout state+      then runWithColor_+      else runFoldLines () (\_ _ -> ()) exe args+  where+    -- same a runFoldLines except Inherit Stdout+    -- That allows color to show up+    runWithColor_ =+        runHandles exe args [OutHandle Inherit] $ \inH _ errH -> do+          state <- get+          errs <- liftIO $ do+            hClose inH -- setStdin was taken care of before the process even ran+            errVar <- (putHandleIntoMVar mempty (|>) errH (sPutStderr state) (sPrintStderr state))+            lineSeqToText `fmap` wait errVar+          modify $ \state' -> state' { sStderr = errs }+          return ()++liftIO_ :: IO a -> Sh ()+liftIO_ = void . liftIO++-- | Similar to 'run' but gives the raw stdout handle in a callback.+-- If you want even more control, use 'runHandles'.+runHandle :: FilePath -- ^ command+          -> [Text] -- ^ arguments+          -> (Handle -> Sh a) -- ^ stdout handle+          -> Sh a+runHandle exe args withHandle = runHandles exe args [] $ \_ outH errH -> do+    state <- get+    errVar <- liftIO $+      (putHandleIntoMVar mempty (|>) errH (sPutStderr state) (sPrintStderr state))+    res <- withHandle outH+    errs <- liftIO $ lineSeqToText `fmap` wait errVar+    modify $ \state' -> state' { sStderr = errs }+    return res++-- | Similar to 'run' but gives direct access to all input and output handles.+--+-- Be careful when using the optional input handles.+-- If you specify Inherit for a handle then attempting to access the handle in your+-- callback is an error+runHandles :: FilePath -- ^ command+           -> [Text] -- ^ arguments+           -> [StdHandle] -- ^ optionally connect process i/o handles to existing handles+           -> (Handle -> Handle -> Handle -> Sh a) -- ^ stdin, stdout and stderr+           -> Sh a+runHandles exe args reusedHandles withHandles = do+    -- clear stdin before beginning command execution+    origstate <- get+    let mStdin = sStdin origstate+    put $ origstate { sStdin = Nothing, sCode = 0, sStderr = T.empty }+    state <- get++    let cmdString = show_command exe args+    when (sPrintCommands state) $ echo cmdString+    trace cmdString++    let doRun = if sCommandEscaping state then runCommand else runCommandNoEscape++    bracket_sh+      (doRun reusedHandles state exe args)+      (\(_,_,_,procH) -> (liftIO $ terminateProcess procH))+      (\(inH,outH,errH,procH) -> do++        liftIO $ do+          inInit (sInitCommandHandles state) inH+          outInit (sInitCommandHandles state) outH+          errInit (sInitCommandHandles state) errH++        liftIO $ case mStdin of+          Just input -> TIO.hPutStr inH input+          Nothing -> return ()++        result <- withHandles inH outH errH++        (ex, code) <- liftIO $ do+          ex' <- waitForProcess procH++          -- TODO: specifically catch our own error for Inherit pipes+          hClose outH `catchany` (const $ return ())+          hClose errH `catchany` (const $ return ())+          hClose inH `catchany` (const $ return ())++          return $ case ex' of+            ExitSuccess -> (ex', 0)+            ExitFailure n -> (ex', n)++        modify $ \state' -> state' { sCode = code }++        case (sErrExit state, ex) of+          (True,  ExitFailure n) -> do+              newState <- get+              liftIO $ throwIO $ RunFailed exe args n (sStderr newState)+          _                      -> return result+      )+++-- | used by 'run'. fold over stdout line-by-line as it is read to avoid keeping it in memory+-- stderr is still being placed in memory under the assumption it is always relatively small+runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a+runFoldLines start cb exe args =+  runHandles exe args [] $ \inH outH errH -> do+    state <- get+    (errVar, outVar) <- liftIO $ do+      hClose inH -- setStdin was taken care of before the process even ran+      liftM2 (,)+          (putHandleIntoMVar mempty (|>) errH (sPutStderr state) (sPrintStderr state))+          (putHandleIntoMVar start cb outH (sPutStdout state) (sPrintStdout state))+    errs <- liftIO $ lineSeqToText `fmap` wait errVar+    modify $ \state' -> state' { sStderr = errs }+    liftIO $ wait outVar+++putHandleIntoMVar :: a -> FoldCallback a+                  -> Handle -- ^ out handle+                  -> (Text -> IO ()) -- ^ in handle+                  -> Bool  -- ^ should it be printed while transfered?+                  -> IO (Async a)+putHandleIntoMVar start cb outH putWrite shouldPrint = liftIO $ async $ do+  if shouldPrint+    then transferFoldHandleLines start cb outH putWrite+    else foldHandleLines start cb outH+++-- | The output of last external command. See 'run'.+lastStderr :: Sh Text+lastStderr = gets sStderr++-- | The exit code from the last command.+-- Unless you set 'errExit' to False you won't get a chance to use this: a non-zero exit code will throw an exception.+lastExitCode :: Sh Int+lastExitCode = gets sCode++-- | set the stdin to be used and cleared by the next 'run'.+setStdin :: Text -> Sh ()+setStdin input = modify $ \st -> st { sStdin = Just input }++-- | Pipe operator. set the stdout the first command as the stdin of the second.+-- This does not create a shell-level pipe, but hopefully it will in the future.+-- To create a shell level pipe you can set @escaping False@ and use a pipe @|@ character in a command.+(-|-) :: Sh Text -> Sh b -> Sh b+one -|- two = do+  res <- print_stdout False one+  setStdin res+  two++-- | Copy a file, or a directory recursively.+-- uses 'cp'+cp_r :: FilePath -> FilePath -> Sh ()+cp_r from' to' = do+    from <- absPath from'+    fromIsDir <- (test_d from)+    if not fromIsDir then cp from' to' else do+       trace $ "cp -r " <> toTextIgnore from <> " " <> toTextIgnore to'+       to <- absPath to'+       toIsDir <- test_d to++       when (from == to) $ liftIO $ throwIO $ userError $ show $ "cp_r: " <>+         toTextIgnore from <> " and " <> toTextIgnore to <> " are identical"++       finalTo <- if not toIsDir then mkdir to >> return to else do+                   let d = to </> dirname (addTrailingSlash from)+                   mkdir_p d >> return d++       ls from >>= mapM_ (\item -> cp_r (from FP.</> filename item) (finalTo FP.</> filename item))++-- | Copy a file. The second path could be a directory, in which case the+-- original file name is used, in that directory.+cp :: FilePath -> FilePath -> Sh ()+cp from' to' = do+  from <- absPath from'+  to <- absPath to'+  trace $ "cp " <> toTextIgnore from <> " " <> toTextIgnore to+  to_dir <- test_d to+  let to_loc = if to_dir then to FP.</> filename from else to+  liftIO $ copyFile from to_loc `catchany` (\e -> throwIO $+      ReThrownException e (extraMsg to_loc from)+    )+  where+    extraMsg t f = "during copy from: " ++ encodeString f ++ " to: " ++ encodeString t++++-- | Create a temporary directory and pass it as a parameter to a Sh+-- computation. The directory is nuked afterwards.+withTmpDir :: (FilePath -> Sh a) -> Sh a+withTmpDir act = do+  trace "withTmpDir"+  dir <- liftIO getTemporaryDirectory+  tid <- liftIO myThreadId+  (pS, fhandle) <- liftIO $ openTempFile dir ("tmp" ++ filter isAlphaNum (show tid))+  let p = pack pS+  liftIO $ hClose fhandle -- required on windows+  rm_f p+  mkdir p+  act p `finally_sh` rm_rf p++-- | Write a Text to a file.+writefile :: FilePath -> Text -> Sh ()+writefile f' bits = do+  f <- traceAbsPath ("writefile " <>) f'+  liftIO (TIO.writeFile (encodeString f) bits)++writeBinary :: FilePath -> ByteString -> Sh ()+writeBinary f' bytes = do+  f <- traceAbsPath ("writeBinary " <>) f'+  liftIO (BS.writeFile (encodeString f) bytes)++-- | Update a file, creating (a blank file) if it does not exist.+touchfile :: FilePath -> Sh ()+touchfile = traceAbsPath ("touch " <>) >=> flip appendfile ""++-- | Append a Text to a file.+appendfile :: FilePath -> Text -> Sh ()+appendfile f' bits = do+  f <- traceAbsPath ("appendfile " <>) f'+  liftIO (TIO.appendFile (encodeString f) bits)++readfile :: FilePath -> Sh Text+readfile = traceAbsPath ("readfile " <>) >=> \fp ->+  readBinary fp >>=+    return . TE.decodeUtf8With TE.lenientDecode++-- | wraps ByteSting readFile+readBinary :: FilePath -> Sh ByteString+readBinary = traceAbsPath ("readBinary " <>)+         >=> liftIO . BS.readFile . encodeString++-- | flipped hasExtension for Text+hasExt :: Text -> FilePath -> Bool+hasExt = flip hasExtension++-- | Run a Sh computation and collect timing information.+--   The value returned is the amount of _real_ time spent running the computation+--   in seconds, as measured by the system clock.+--   The precision is determined by the resolution of `getCurrentTime`.+time :: Sh a -> Sh (Double, a)+time what = sub $ do+  trace "time"+  t <- liftIO getCurrentTime+  res <- what+  t' <- liftIO getCurrentTime+  return (realToFrac $ diffUTCTime t' t, res)++-- | threadDelay wrapper that uses seconds+sleep :: Int -> Sh ()+sleep = liftIO . threadDelay . (1000 * 1000 *)++-- | spawn an asynchronous action with a copy of the current state+asyncSh :: Sh a -> Sh (Async a)+asyncSh proc = do+  state <- get+  liftIO $ async $ shelly (put state >> proc)++-- helper because absPath can throw exceptions+-- This helps give clear tracing messages+tracePath :: (FilePath -> Sh FilePath) -- ^ filepath conversion+          -> (Text -> Text) -- ^ tracing statement+          -> FilePath+          -> Sh FilePath -- ^ converted filepath+tracePath convert tracer infp =+  (convert infp >>= \fp -> traceIt fp >> return fp)+  `catchany_sh` (\e -> traceIt infp >> liftIO (throwIO e))+    where traceIt = trace . tracer . toTextIgnore++traceAbsPath :: (Text -> Text) -> FilePath -> Sh FilePath+traceAbsPath = tracePath absPath++traceCanonicPath :: (Text -> Text) -> FilePath -> Sh FilePath+traceCanonicPath = tracePath canonic
+ shelly/src/Shelly/Base.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE InstanceSigs#-}+-- | I started exposing multiple module (starting with one for finding)+-- Base prevented circular dependencies+-- However, Shelly went back to exposing a single module+module Shelly.Base+  (+    Sh(..), ShIO, runSh, State(..), ReadOnlyState(..), StdHandle(..),+    HandleInitializer, StdInit(..),+    FilePath, Text,+    relPath, path, absPath, canonic, canonicalize,+    test_d, test_s,+    unpack, gets, get, modify, trace,+    ls, lsRelAbs,+    toTextIgnore,+    echo, echo_n, echo_err, echo_n_err, inspect, inspect_err,+    catchany,+    liftIO, (>=>),+    eitherRelativeTo, relativeTo, maybeRelativeTo,+    whenM+    -- * utilities not yet exported+    , addTrailingSlash+  ) where++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706+import Prelude hiding (FilePath, catch)+#else+import Prelude hiding (FilePath)+#endif++import Data.Text (Text)+import System.Process( StdStream(..) )+import System.IO ( Handle, hFlush, stderr, stdout )++import Control.Monad (when, (>=>))+import Control.Monad.Base+import Control.Monad.Trans.Control+#if !MIN_VERSION_base(4,13,0)+import Control.Applicative (Applicative, (<$>))+#endif+import Filesystem (isDirectory, listDirectory)+import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )+import Filesystem.Path.CurrentOS (FilePath, encodeString, relative)+import qualified Filesystem.Path.CurrentOS as FP+import qualified Filesystem as FS+import Data.IORef (readIORef, modifyIORef, IORef)+#if !MIN_VERSION_base(4,13,0)+import Data.Monoid (mappend)+#endif+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Control.Exception (SomeException, catch, throwIO, Exception)+import Data.Maybe (fromMaybe)+import qualified Control.Monad.Catch as Catch+import Control.Monad.Trans ( MonadIO, liftIO )+import Control.Monad.Reader.Class (MonadReader, ask)+import Control.Monad.Trans.Reader (runReaderT, ReaderT(..))+import qualified Data.Set as S+import Data.Typeable (Typeable)++-- | ShIO is Deprecated in favor of 'Sh', which is easier to type.+type ShIO a = Sh a+{-# DEPRECATED ShIO "Use Sh instead of ShIO" #-}++newtype Sh a = Sh {+      unSh :: ReaderT (IORef State) IO a+  } deriving (Applicative, Monad, MonadIO, MonadReader (IORef State), Functor, Catch.MonadMask)++#if MIN_VERSION_base(4,13,0)+instance MonadFail Sh where+  fail = liftIO . fail+#endif++instance MonadBase IO Sh where+    liftBase = Sh . ReaderT . const++instance MonadBaseControl IO Sh where+#if MIN_VERSION_monad_control(1,0,0)+    type StM Sh a = StM (ReaderT (IORef State) IO) a+    liftBaseWith f =+        Sh $ liftBaseWith $ \runInBase -> f $ \k ->+            runInBase $ unSh k+    restoreM = Sh . restoreM+#else+    newtype StM Sh a = StMSh (StM (ReaderT (IORef State) IO) a)+    liftBaseWith f =+        Sh $ liftBaseWith $ \runInBase -> f $ \k ->+            liftM StMSh $ runInBase $ unSh k+    restoreM (StMSh m) = Sh . restoreM $ m+#endif++instance Catch.MonadThrow Sh where+  throwM = liftIO . Catch.throwM++instance Catch.MonadCatch Sh where+  catch (Sh (ReaderT m)) c =+      Sh $ ReaderT $ \r -> m r `Catch.catch` \e -> runSh (c e) r++runSh :: Sh a -> IORef State -> IO a+runSh = runReaderT . unSh++data ReadOnlyState = ReadOnlyState { rosFailToDir :: Bool }+data State = State+   { sCode :: Int -- ^ exit code for command that ran+   , sStdin :: Maybe Text -- ^ stdin for the command to be run+   , sStderr :: Text -- ^ stderr for command that ran+   , sDirectory :: FilePath -- ^ working directory+   , sPutStdout :: Text -> IO ()   -- ^ by default, hPutStrLn stdout+   , sPrintStdout :: Bool   -- ^ print stdout of command that is executed+   , sPutStderr :: Text -> IO ()   -- ^ by default, hPutStrLn stderr+   , sPrintStderr :: Bool   -- ^ print stderr of command that is executed+   , sPrintCommands :: Bool -- ^ print command that is executed+   , sInitCommandHandles :: StdInit -- ^ initializers for the standard process handles+                                    -- when running a command+   , sCommandEscaping :: Bool -- ^ when running a command, escape shell characters such as '*' rather+                              -- than passing to the shell for expansion+   , sEnvironment :: [(String, String)]+   , sPathExecutables :: Maybe [(FilePath, S.Set FilePath)] -- ^ cache of executables in the PATH+   , sTracing :: Bool -- ^ should we trace command execution+   , sTrace :: Text -- ^ the trace of command execution+   , sErrExit :: Bool -- ^ should we exit immediately on any error+   , sReadOnly :: ReadOnlyState+   , sFollowSymlink :: Bool -- ^ 'find'-command follows symlinks.+   }++data StdHandle = InHandle StdStream+               | OutHandle StdStream+               | ErrorHandle StdStream++-- | Initialize a handle before using it+type HandleInitializer = Handle -> IO ()++-- | A collection of initializers for the three standard process handles+data StdInit =+    StdInit {+      inInit :: HandleInitializer,+      outInit :: HandleInitializer,+      errInit :: HandleInitializer+    }++-- | A monadic-conditional version of the "when" guard.+whenM :: Monad m => m Bool -> m () -> m ()+whenM c a = c >>= \res -> when res a++-- | Makes a relative path relative to the current Sh working directory.+-- An absolute path is returned as is.+-- To create an absolute path, use 'absPath'+relPath :: FilePath -> Sh FilePath+relPath fp = do+  wd  <- gets sDirectory+  rel <- eitherRelativeTo wd fp+  return $ case rel of+    Right p -> p+    Left  p -> p++eitherRelativeTo :: FilePath -- ^ anchor path, the prefix+                 -> FilePath -- ^ make this relative to anchor path+                 -> Sh (Either FilePath FilePath) -- ^ Left is canonic of second path+eitherRelativeTo relativeFP fp = do+  let fullFp = relativeFP FP.</> fp+  let relDir = addTrailingSlash relativeFP+  stripIt relativeFP fp $+    stripIt relativeFP fullFp $+      stripIt relDir fp $+        stripIt relDir fullFp $ do+          relCan <- canonic relDir+          fpCan  <- canonic fullFp+          stripIt relCan fpCan $ return $ Left fpCan+  where+    stripIt rel toStrip nada =+      case FP.stripPrefix rel toStrip of+        Just stripped ->+          if stripped == toStrip then nada+            else return $ Right stripped+        Nothing -> nada++-- | make the second path relative to the first+-- Uses 'Filesystem.stripPrefix', but will canonicalize the paths if necessary+relativeTo :: FilePath -- ^ anchor path, the prefix+           -> FilePath -- ^ make this relative to anchor path+           -> Sh FilePath+relativeTo relativeFP fp =+  fmap (fromMaybe fp) $ maybeRelativeTo relativeFP fp++maybeRelativeTo :: FilePath -- ^ anchor path, the prefix+                 -> FilePath -- ^ make this relative to anchor path+                 -> Sh (Maybe FilePath)+maybeRelativeTo relativeFP fp = do+  epath <- eitherRelativeTo relativeFP fp+  return $ case epath of+             Right p -> Just p+             Left _ -> Nothing+++-- | add a trailing slash to ensure the path indicates a directory+addTrailingSlash :: FilePath -> FilePath+addTrailingSlash p =+  if FP.null (FP.filename p) then p else+    p FP.</> FP.empty++-- | makes an absolute path.+-- Like 'canonicalize', but on an exception returns 'absPath'+canonic :: FilePath -> Sh FilePath+canonic fp = do+  p <- absPath fp+  liftIO $ canonicalizePath p `catchany` \_ -> return p++-- | Obtain a (reasonably) canonic file path to a filesystem object. Based on+-- "canonicalizePath" in system-fileio.+canonicalize :: FilePath -> Sh FilePath+canonicalize = absPath >=> liftIO . canonicalizePath++-- | bugfix older version of canonicalizePath (system-fileio <= 0.3.7) loses trailing slash+canonicalizePath :: FilePath -> IO FilePath+canonicalizePath p = let was_dir = FP.null (FP.filename p) in+   if not was_dir then FS.canonicalizePath p+     else addTrailingSlash `fmap` FS.canonicalizePath p++data EmptyFilePathError = EmptyFilePathError deriving Typeable+instance Show EmptyFilePathError where+    show _ = "Empty filepath"+instance Exception EmptyFilePathError++-- | Make a relative path absolute by combining with the working directory.+-- An absolute path is returned as is.+-- To create a relative path, use 'relPath'.+absPath :: FilePath -> Sh FilePath+absPath p | FP.null p = liftIO $ throwIO EmptyFilePathError+          | relative p = (FP.</> p) <$> gets sDirectory+          | otherwise = return p++-- | deprecated+path :: FilePath -> Sh FilePath+path = absPath+{-# DEPRECATED path "use absPath, canonic, or relPath instead" #-}++-- | Does a path point to an existing directory?+test_d :: FilePath -> Sh Bool+test_d = absPath >=> liftIO . isDirectory++-- | Does a path point to a symlink?+test_s :: FilePath -> Sh Bool+test_s = absPath >=> liftIO . \f -> do+  stat <- getSymbolicLinkStatus (encodeString f)+  return $ isSymbolicLink stat++unpack :: FilePath -> String+unpack = encodeString++gets :: (State -> a) -> Sh a+gets f = f <$> get++get :: Sh State+get = do+  stateVar <- ask+  liftIO (readIORef stateVar)++modify :: (State -> State) -> Sh ()+modify f = do+  state <- ask+  liftIO (modifyIORef state f)++-- | internally log what occurred.+-- Log will be re-played on failure.+trace :: Text -> Sh ()+trace msg =+  whenM (gets sTracing) $ modify $+    \st -> st { sTrace = sTrace st `mappend` msg `mappend` "\n" }++-- | List directory contents. Does *not* include \".\" and \"..\", but it does+-- include (other) hidden files.+ls :: FilePath -> Sh [FilePath]+-- it is important to use path and not absPath so that the listing can remain relative+ls fp = do+  trace $ "ls " `mappend` toTextIgnore fp+  fmap fst $ lsRelAbs fp++lsRelAbs :: FilePath -> Sh ([FilePath], [FilePath])+lsRelAbs f = absPath f >>= \fp -> do+  filt <- if not (relative f) then return return+             else do+               wd <- gets sDirectory+               return (relativeTo wd)+  absolute <- liftIO $ listDirectory fp+  relativized <- mapM filt absolute+  return (relativized, absolute)++-- | silently uses the Right or Left value of "Filesystem.Path.CurrentOS.toText"+toTextIgnore :: FilePath -> Text+toTextIgnore fp = case FP.toText fp of+                    Left  f -> f+                    Right f -> f++-- | a print lifted into 'Sh'+inspect :: (Show s) => s -> Sh ()+inspect x = do+  (trace . T.pack . show) x+  liftIO $ print x++-- | a print lifted into 'Sh' using stderr+inspect_err :: (Show s) => s -> Sh ()+inspect_err x = do+  let shown = T.pack $ show x+  trace shown+  echo_err shown++-- | Echo text to standard (error, when using _err variants) output. The _n+-- variants do not print a final newline.+echo, echo_n, echo_err, echo_n_err :: Text -> Sh ()+echo       msg = traceEcho msg >> liftIO (TIO.putStrLn msg >> hFlush stdout)+echo_n     msg = traceEcho msg >> liftIO (TIO.putStr msg >> hFlush stdout)+echo_err   msg = traceEcho msg >> liftIO (TIO.hPutStrLn stderr msg >> hFlush stdout)+echo_n_err msg = traceEcho msg >> liftIO (TIO.hPutStr stderr msg >> hFlush stderr)++traceEcho :: Text -> Sh ()+traceEcho msg = trace ("echo " `mappend` "'" `mappend` msg `mappend` "'")++-- | A helper to catch any exception (same as+-- @... `catch` \(e :: SomeException) -> ...@).+catchany :: IO a -> (SomeException -> IO a) -> IO a+catchany = catch+
+ shelly/src/Shelly/Find.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+-- | File finding utiliites for Shelly+-- The basic 'find' takes a dir and gives back a list of files.+-- If you don't just want a list, use the folding variants like 'findFold'.+-- If you want to avoid traversing certain directories, use the directory filtering variants like 'findDirFilter'+module Shelly.Find+ (+   find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter+ ) where++import Prelude hiding (FilePath)+import Shelly.Base+import Control.Monad (foldM)+#if !MIN_VERSION_base(4,13,0)+import Data.Monoid (mappend)+#endif+import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )+import Filesystem (isDirectory)+import Filesystem.Path.CurrentOS (encodeString)++-- | List directory recursively (like the POSIX utility "find").+-- listing is relative if the path given is relative.+-- If you want to filter out some results or fold over them you can do that with the returned files.+-- A more efficient approach is to use one of the other find functions.+find :: FilePath -> Sh [FilePath]+find = findFold (\paths fp -> return $ paths ++ [fp]) []++-- | 'find' that filters the found files as it finds.+-- Files must satisfy the given filter to be returned in the result.+findWhen :: (FilePath -> Sh Bool) -> FilePath -> Sh [FilePath]+findWhen = findDirFilterWhen (const $ return True)++-- | Fold an arbitrary folding function over files froma a 'find'.+-- Like 'findWhen' but use a more general fold rather than a filter.+findFold :: (a -> FilePath -> Sh a) -> a -> FilePath -> Sh a+findFold folder startValue = findFoldDirFilter folder startValue (const $ return True)++-- | 'find' that filters out directories as it finds+-- Filtering out directories can make a find much more efficient by avoiding entire trees of files.+findDirFilter :: (FilePath -> Sh Bool) -> FilePath -> Sh [FilePath]+findDirFilter filt = findDirFilterWhen filt (const $ return True)++-- | similar 'findWhen', but also filter out directories+-- Alternatively, similar to 'findDirFilter', but also filter out files+-- Filtering out directories makes the find much more efficient+findDirFilterWhen :: (FilePath -> Sh Bool) -- ^ directory filter+                  -> (FilePath -> Sh Bool) -- ^ file filter+                  -> FilePath -- ^ directory+                  -> Sh [FilePath]+findDirFilterWhen dirFilt fileFilter = findFoldDirFilter filterIt [] dirFilt+  where+    filterIt paths fp = do+      yes <- fileFilter fp+      return $ if yes then paths ++ [fp] else paths++-- | like 'findDirFilterWhen' but use a folding function rather than a filter+-- The most general finder: you likely want a more specific one+findFoldDirFilter :: (a -> FilePath -> Sh a) -> a -> (FilePath -> Sh Bool) -> FilePath -> Sh a+findFoldDirFilter folder startValue dirFilter dir = do+  absDir <- absPath dir+  trace ("find " `mappend` toTextIgnore absDir)+  filt <- dirFilter absDir+  if not filt then return startValue+    -- use possible relative path, not absolute so that listing will remain relative+    else do+      (rPaths, aPaths) <- lsRelAbs dir +      foldM traverse' startValue (zip rPaths aPaths)+  where+    traverse' acc (relativePath, absolutePath) = do+      -- optimization: don't use Shelly API since our path is already good+      isDir <- liftIO $ isDirectory absolutePath+      sym   <- liftIO $ fmap isSymbolicLink $ getSymbolicLinkStatus (encodeString absolutePath)+      newAcc <- folder acc relativePath+      follow <- fmap sFollowSymlink get+      if isDir && (follow || not sym)+        then findFoldDirFilter folder newAcc +                dirFilter relativePath+        else return newAcc
+ shelly/src/Shelly/Lifted.hs view
@@ -0,0 +1,584 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings,+             FlexibleInstances, FlexibleContexts, IncoherentInstances,+             TypeFamilies, ExistentialQuantification, RankNTypes,+             ImpredicativeTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | A module for shell-like programming in Haskell.+-- Shelly's focus is entirely on ease of use for those coming from shell scripting.+-- However, it also tries to use modern libraries and techniques to keep things efficient.+--+-- The functionality provided by+-- this module is (unlike standard Haskell filesystem functionality)+-- thread-safe: each Sh maintains its own environment and its own working+-- directory.+--+-- Recommended usage includes putting the following at the top of your program,+-- otherwise you will likely need either type annotations or type conversions+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE ExtendedDefaultRules #-}+-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- > import Shelly+-- > import qualified Data.Text as T+-- > default (T.Text)+module Shelly.Lifted+       (+         MonadSh(..),+         MonadShControl(..),++         -- This is copied from Shelly.hs, so that we are sure to export the+         -- exact same set of symbols.  Whenever that export list is updated,+         -- please make the same updates here and implements the corresponding+         -- lifted functions.++         -- * Entering Sh.+         Sh, ShIO, S.shelly, S.shellyNoDir, S.shellyFailDir, sub+         , silently, verbosely, escaping, print_stdout, print_stderr, print_commands+         , tracing, errExit+         , log_stdout_with, log_stderr_with++         -- * Running external commands.+         , run, run_, runFoldLines, S.cmd, S.FoldCallback+         , (-|-), lastStderr, setStdin, lastExitCode+         , command, command_, command1, command1_+         , sshPairs, sshPairs_+         , S.ShellCmd(..), S.CmdArg (..)++         -- * Running commands Using handles+         , runHandle, runHandles, transferLinesAndCombine, S.transferFoldHandleLines+         , S.StdHandle(..), S.StdStream(..)+++         -- * Modifying and querying environment.+         , setenv, get_env, get_env_text, get_env_all, appendToPath, prependToPath++         -- * Environment directory+         , cd, chdir, chdir_p, pwd++         -- * Printing+         , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err+         , tag, trace, S.show_command++         -- * Querying filesystem.+         , ls, lsT, test_e, test_f, test_d, test_s, test_px, which++         -- * Filename helpers+         , absPath, (S.</>), (S.<.>), canonic, canonicalize, relPath, relativeTo+         , S.hasExt++         -- * Manipulating filesystem.+         , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree++         -- * reading/writing Files+         , readfile, readBinary, writefile, appendfile, touchfile, withTmpDir++         -- * exiting the program+         , exit, errorExit, quietExit, terror++         -- * Exceptions+         , bracket_sh, catchany, catch_sh, handle_sh, handleany_sh, finally_sh, catches_sh, catchany_sh++         -- * convert between Text and FilePath+         , S.toTextIgnore, toTextWarn, FP.fromText++         -- * Utility Functions+         , S.whenM, S.unlessM, time, sleep++         -- * Re-exported for your convenience+         , liftIO, S.when, S.unless, FilePath, (S.<$>)++         -- * internal functions for writing extensions+         , Shelly.Lifted.get, Shelly.Lifted.put++         -- * find functions+         , S.find, S.findWhen, S.findFold, S.findDirFilter, S.findDirFilterWhen, S.findFoldDirFilter+         , followSymlink+         ) where++import qualified Shelly as S+import Shelly.Base (Sh(..), ShIO, Text, (>=>), FilePath)+import qualified Shelly.Base as S+import Control.Monad ( liftM )+import Prelude hiding ( FilePath )+import Data.ByteString ( ByteString )+import System.IO ( Handle )+import Data.Tree ( Tree )+import qualified Filesystem.Path.CurrentOS as FP++import Control.Exception.Lifted+import Control.Exception.Enclosed+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import qualified Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.Writer+import qualified Control.Monad.Trans.Writer.Strict as Strict+import qualified Control.Monad.Trans.RWS as RWS+import qualified Control.Monad.Trans.RWS.Strict as Strict++class Monad m => MonadSh m where+    liftSh :: Sh a -> m a++instance MonadSh Sh where+    liftSh = id++instance MonadSh m => MonadSh (IdentityT m) where+    liftSh = IdentityT . liftSh+instance MonadSh m => MonadSh (MaybeT m) where+    liftSh = MaybeT . liftM Just . liftSh+instance MonadSh m => MonadSh (ContT r m) where+    liftSh m = ContT (liftSh m >>=)+instance MonadSh m => MonadSh (ExceptT e m) where+    liftSh m = ExceptT $ do+        a <- liftSh m+        return (Right a)+instance MonadSh m => MonadSh (ReaderT r m) where+    liftSh = ReaderT . const . liftSh+instance MonadSh m => MonadSh (StateT s m) where+    liftSh m = StateT $ \s -> do+        a <- liftSh m+        return (a, s)+instance MonadSh m => MonadSh (Strict.StateT s m) where+    liftSh m = Strict.StateT $ \s -> do+        a <- liftSh m+        return (a, s)+instance (Monoid w, MonadSh m) => MonadSh (WriterT w m) where+    liftSh m = WriterT $ do+        a <- liftSh m+        return (a, mempty :: w)+instance (Monoid w, MonadSh m) => MonadSh (Strict.WriterT w m) where+    liftSh m = Strict.WriterT $ do+        a <- liftSh m+        return (a, mempty :: w)+instance (Monoid w, MonadSh m) => MonadSh (RWS.RWST r w s m) where+    liftSh m = RWS.RWST $ \_ s -> do+        a <- liftSh m+        return (a, s, mempty :: w)+instance (Monoid w, MonadSh m) => MonadSh (Strict.RWST r w s m) where+    liftSh m = Strict.RWST $ \_ s -> do+        a <- liftSh m+        return (a, s, mempty :: w)++instance MonadSh m => S.ShellCmd (m Text) where+    cmdAll = (liftSh .) . S.run++instance (MonadSh m, s ~ Text, Show s) => S.ShellCmd (m s) where+    cmdAll = (liftSh .) . S.run++instance MonadSh m => S.ShellCmd (m ()) where+    cmdAll = (liftSh .) . S.run_++class Monad m => MonadShControl m where+    data ShM m a :: *+    liftShWith :: ((forall x. m x -> Sh (ShM m x)) -> Sh a) -> m a+    restoreSh :: ShM m a -> m a++instance MonadShControl Sh where+     newtype ShM Sh a = ShSh a+     liftShWith f = f $ liftM ShSh+     restoreSh (ShSh x) = return x+     {-# INLINE liftShWith #-}+     {-# INLINE restoreSh #-}++instance MonadShControl m => MonadShControl (MaybeT m) where+    newtype ShM (MaybeT m) a = MaybeTShM (ShM m (Maybe a))+    liftShWith f =+        MaybeT $ liftM return $ liftShWith $ \runInSh -> f $ \k ->+            liftM MaybeTShM $ runInSh $ runMaybeT k+    restoreSh (MaybeTShM m) = MaybeT . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance MonadShControl m+         => MonadShControl (IdentityT m) where+    newtype ShM (IdentityT m) a = IdentityTShM (ShM m a)+    liftShWith f =+        IdentityT $ liftM id $ liftShWith $ \runInSh -> f $ \k ->+            liftM IdentityTShM $ runInSh $ runIdentityT k+    restoreSh (IdentityTShM m) = IdentityT . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance (MonadShControl m, Monoid w)+         => MonadShControl (WriterT w m) where+    newtype ShM (WriterT w m) a = WriterTShM (ShM m (a, w))+    liftShWith f =+        WriterT $ liftM  (\x -> (x, mempty :: w)) $ liftShWith $ \runInSh -> f $ \k ->+            liftM WriterTShM $ runInSh $ runWriterT k+    restoreSh (WriterTShM m) = WriterT . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance (MonadShControl m, Monoid w)+         => MonadShControl (Strict.WriterT w m) where+    newtype ShM (Strict.WriterT w m) a = StWriterTShM (ShM m (a, w))+    liftShWith f =+        Strict.WriterT $ liftM (\x -> (x, mempty :: w)) $ liftShWith $ \runInSh -> f $ \k ->+            liftM StWriterTShM $ runInSh $ Strict.runWriterT k+    restoreSh (StWriterTShM m) = Strict.WriterT . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance MonadShControl m+         => MonadShControl (ExceptT e m) where+    newtype ShM (ExceptT e m) a = ErrorTShM (ShM m (Either e a))+    liftShWith f =+        ExceptT $ liftM return $ liftShWith $ \runInSh -> f $ \k ->+            liftM ErrorTShM $ runInSh $ runExceptT k+    restoreSh (ErrorTShM m) = ExceptT . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance MonadShControl m => MonadShControl (StateT s m) where+    newtype ShM (StateT s m) a = StateTShM (ShM m (a, s))+    liftShWith f = StateT $ \s ->+        liftM (\x -> (x,s)) $ liftShWith $ \runInSh -> f $ \k ->+            liftM StateTShM $ runInSh $ runStateT k s+    restoreSh (StateTShM m) = StateT . const . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance MonadShControl m => MonadShControl (Strict.StateT s m) where+    newtype ShM (Strict.StateT s m) a = StStateTShM (ShM m (a, s))+    liftShWith f = Strict.StateT $ \s ->+        liftM (\x -> (x,s)) $ liftShWith $ \runInSh -> f $ \k ->+            liftM StStateTShM $ runInSh $ Strict.runStateT k s+    restoreSh (StStateTShM m) = Strict.StateT . const . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance MonadShControl m => MonadShControl (ReaderT r m) where+    newtype ShM (ReaderT r m) a = ReaderTShM (ShM m a)+    liftShWith f = ReaderT $ \r ->+        liftM id $ liftShWith $ \runInSh -> f $ \k ->+            liftM ReaderTShM $ runInSh $ runReaderT k r+    restoreSh (ReaderTShM m) = ReaderT . const . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance (MonadShControl m, Monoid w)+         => MonadShControl (RWS.RWST r w s m) where+    newtype ShM (RWS.RWST r w s m) a = RWSTShM (ShM m (a, s ,w))+    liftShWith f = RWS.RWST $ \r s ->+        liftM (\x -> (x,s,mempty :: w)) $ liftShWith $ \runInSh -> f $ \k ->+            liftM RWSTShM $ runInSh $ RWS.runRWST k r s+    restoreSh (RWSTShM m) = RWS.RWST . const . const . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++instance (MonadShControl m, Monoid w)+         => MonadShControl (Strict.RWST r w s m) where+    newtype ShM (Strict.RWST r w s m) a = StRWSTShM (ShM m (a, s, w))+    liftShWith f = Strict.RWST $ \r s ->+        liftM (\x -> (x,s,mempty :: w)) $ liftShWith $ \runInSh -> f $ \k ->+            liftM StRWSTShM $ runInSh $ Strict.runRWST k r s+    restoreSh (StRWSTShM m) = Strict.RWST . const . const . restoreSh $ m+    {-# INLINE liftShWith #-}+    {-# INLINE restoreSh #-}++controlSh :: MonadShControl m => ((forall x. m x -> Sh (ShM m x)) -> Sh (ShM m a)) -> m a+controlSh = liftShWith >=> restoreSh+{-# INLINE controlSh #-}++tag :: (MonadShControl m, MonadSh m) => m a -> Text -> m a+tag action msg = controlSh $ \runInSh -> S.tag (runInSh action) msg++chdir :: MonadShControl m => FilePath -> m a -> m a+chdir dir action = controlSh $ \runInSh -> S.chdir dir (runInSh action)++chdir_p :: MonadShControl m => FilePath -> m a -> m a+chdir_p dir action = controlSh $ \runInSh -> S.chdir_p dir (runInSh action)++silently :: MonadShControl m => m a -> m a+silently a = controlSh $ \runInSh -> S.silently (runInSh a)++verbosely :: MonadShControl m => m a -> m a+verbosely a = controlSh $ \runInSh -> S.verbosely (runInSh a)++log_stdout_with :: MonadShControl m => (Text -> IO ()) -> m a -> m a+log_stdout_with logger a = controlSh $ \runInSh -> S.log_stdout_with logger (runInSh a)++log_stderr_with :: MonadShControl m => (Text -> IO ()) -> m a -> m a+log_stderr_with logger a = controlSh $ \runInSh -> S.log_stderr_with logger (runInSh a)++print_stdout :: MonadShControl m => Bool -> m a -> m a+print_stdout shouldPrint a = controlSh $ \runInSh -> S.print_stdout shouldPrint (runInSh a)++print_stderr :: MonadShControl m => Bool -> m a -> m a+print_stderr shouldPrint a = controlSh $ \runInSh -> S.print_stderr shouldPrint (runInSh a)++print_commands :: MonadShControl m => Bool -> m a -> m a+print_commands shouldPrint a = controlSh $ \runInSh -> S.print_commands shouldPrint (runInSh a)++sub :: MonadShControl m => m a -> m a+sub a = controlSh $ \runInSh -> S.sub (runInSh a)++trace :: MonadSh m => Text -> m ()+trace = liftSh . S.trace++tracing :: MonadShControl m => Bool -> m a -> m a+tracing shouldTrace action = controlSh $ \runInSh -> S.tracing shouldTrace (runInSh action)++escaping :: MonadShControl m => Bool -> m a -> m a+escaping shouldEscape action = controlSh $ \runInSh -> S.escaping shouldEscape (runInSh action)++errExit :: MonadShControl m => Bool -> m a -> m a+errExit shouldExit action = controlSh $ \runInSh -> S.errExit shouldExit (runInSh action)++followSymlink :: MonadShControl m => Bool -> m a -> m a+followSymlink enableFollowSymlink action = controlSh $ \runInSh -> S.followSymlink enableFollowSymlink (runInSh action)++(-|-) :: (MonadShControl m, MonadSh m) => m Text -> m b -> m b+one -|- two = controlSh $ \runInSh -> do+    x <- runInSh one+    runInSh $ restoreSh x >>= \x' ->+        controlSh $ \runInSh' -> return x' S.-|- runInSh' two++withTmpDir :: MonadShControl m => (FilePath -> m a) -> m a+withTmpDir action = controlSh $ \runInSh -> S.withTmpDir (fmap runInSh action)++time :: MonadShControl m => m a -> m (Double, a)+time what = controlSh $ \runInSh -> do+    (d, a) <- S.time (runInSh what)+    runInSh $ restoreSh a >>= \x -> return (d, x)++toTextWarn :: MonadSh m => FilePath -> m Text+toTextWarn = liftSh . toTextWarn++transferLinesAndCombine :: MonadIO m => Handle -> (Text -> IO ()) -> m Text+transferLinesAndCombine = (liftIO .) . S.transferLinesAndCombine++get :: MonadSh m => m S.State+get = liftSh S.get++put :: MonadSh m => S.State -> m ()+put = liftSh . S.put++catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a+catch_sh = Control.Exception.Lifted.catch+{-# DEPRECATED catch_sh "use Control.Exception.Lifted.catch instead" #-}++handle_sh :: (Exception e) => (e -> Sh a) -> Sh a -> Sh a+handle_sh = handle+{-# DEPRECATED handle_sh "use Control.Exception.Lifted.handle instead" #-}++finally_sh :: Sh a -> Sh b -> Sh a+finally_sh = finally+{-# DEPRECATED finally_sh "use Control.Exception.Lifted.finally instead" #-}++bracket_sh :: Sh a -> (a -> Sh b) -> (a -> Sh c) -> Sh c+bracket_sh = bracket+{-# DEPRECATED bracket_sh "use Control.Exception.Lifted.bracket instead" #-}++catches_sh :: Sh a -> [Handler Sh a] -> Sh a+catches_sh = catches+{-# DEPRECATED catches_sh "use Control.Exception.Lifted.catches instead" #-}++catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a+catchany_sh = catchAny+{-# DEPRECATED catchany_sh "use Control.Exception.Enclosed.catchAny instead" #-}++handleany_sh :: (SomeException -> Sh a) -> Sh a -> Sh a+handleany_sh = handleAny+{-# DEPRECATED handleany_sh "use Control.Exception.Enclosed.handleAny instead" #-}++cd :: MonadSh m => FilePath -> m ()+cd = liftSh . S.cd++mv :: MonadSh m => FilePath -> FilePath -> m ()+mv = (liftSh .) . S.mv++lsT :: MonadSh m => FilePath -> m [Text]+lsT = liftSh . S.lsT++pwd :: MonadSh m => m FilePath+pwd = liftSh S.pwd++exit :: MonadSh m => Int -> m a+exit = liftSh . S.exit++errorExit :: MonadSh m => Text -> m a+errorExit = liftSh . S.errorExit++quietExit :: MonadSh m => Int -> m a+quietExit = liftSh . S.quietExit++terror :: MonadSh m => Text -> m a+terror = liftSh . S.terror++mkdir :: MonadSh m => FilePath -> m ()+mkdir = liftSh . S.mkdir++mkdir_p :: MonadSh m => FilePath -> m ()+mkdir_p = liftSh . S.mkdir_p++mkdirTree :: MonadSh m => Tree FilePath -> m ()+mkdirTree = liftSh . S.mkdirTree++which :: MonadSh m => FilePath -> m (Maybe FilePath)+which = liftSh . S.which++test_e :: MonadSh m => FilePath -> m Bool+test_e = liftSh . S.test_e++test_f :: MonadSh m => FilePath -> m Bool+test_f = liftSh . S.test_f++test_px :: MonadSh m => FilePath -> m Bool+test_px = liftSh . S.test_px++rm_rf :: MonadSh m => FilePath -> m ()+rm_rf = liftSh . S.rm_rf++rm_f :: MonadSh m => FilePath -> m ()+rm_f = liftSh . S.rm_f++rm :: MonadSh m => FilePath -> m ()+rm = liftSh . S.rm++setenv :: MonadSh m => Text -> Text -> m ()+setenv = (liftSh .) . S.setenv++appendToPath :: MonadSh m => FilePath -> m ()+appendToPath = liftSh . S.appendToPath++prependToPath :: MonadSh m => FilePath -> m ()+prependToPath = liftSh . S.prependToPath++get_env_all :: MonadSh m => m [(String, String)]+get_env_all = liftSh S.get_env_all++get_env :: MonadSh m => Text -> m (Maybe Text)+get_env = liftSh . S.get_env++get_env_text :: MonadSh m => Text -> m Text+get_env_text = liftSh . S.get_env_text++sshPairs_ :: MonadSh m => Text -> [(FilePath, [Text])] -> m ()+sshPairs_ = (liftSh .) . S.sshPairs_++sshPairs :: MonadSh m => Text -> [(FilePath, [Text])] -> m Text+sshPairs = (liftSh .) . S.sshPairs++run :: MonadSh m => FilePath -> [Text] -> m Text+run = (liftSh .) . S.run++command :: MonadSh m => FilePath -> [Text] -> [Text] -> m Text+command com args more_args =+    liftSh $ S.command com args more_args++command_ :: MonadSh m => FilePath -> [Text] -> [Text] -> m ()+command_ com args more_args =+    liftSh $ S.command_ com args more_args++command1 :: MonadSh m => FilePath -> [Text] -> Text -> [Text] -> m Text+command1 com args one_arg more_args =+    liftSh $ S.command1 com args one_arg more_args++command1_ :: MonadSh m => FilePath -> [Text] -> Text -> [Text] -> m ()+command1_ com args one_arg more_args =+    liftSh $ S.command1_ com args one_arg more_args++run_ :: MonadSh m => FilePath -> [Text] -> m ()+run_ = (liftSh .) . S.run_++runHandle :: MonadShControl m => FilePath -- ^ command+          -> [Text] -- ^ arguments+          -> (Handle -> m a) -- ^ stdout handle+          -> m a+runHandle exe args withHandle =+    controlSh $ \runInSh -> S.runHandle exe args (fmap runInSh withHandle)++runHandles :: MonadShControl m => FilePath -- ^ command+           -> [Text] -- ^ arguments+           -> [S.StdHandle] -- ^ optionally connect process i/o handles to existing handles+           -> (Handle -> Handle -> Handle -> m a) -- ^ stdin, stdout and stderr+           -> m a+runHandles exe args reusedHandles withHandles =+    controlSh $ \runInSh ->+        S.runHandles exe args reusedHandles (fmap (fmap (fmap runInSh)) withHandles)++runFoldLines :: MonadSh m => a -> S.FoldCallback a -> FilePath -> [Text] -> m a+runFoldLines start cb exe args = liftSh $ S.runFoldLines start cb exe args++lastStderr :: MonadSh m => m Text+lastStderr = liftSh S.lastStderr++lastExitCode :: MonadSh m => m Int+lastExitCode = liftSh S.lastExitCode++setStdin :: MonadSh m => Text -> m ()+setStdin = liftSh . S.setStdin++cp_r :: MonadSh m => FilePath -> FilePath -> m ()+cp_r = (liftSh .) . S.cp_r++cp :: MonadSh m => FilePath -> FilePath -> m ()+cp = (liftSh .) . S.cp++writefile :: MonadSh m => FilePath -> Text -> m ()+writefile = (liftSh .) . S.writefile++touchfile :: MonadSh m => FilePath -> m ()+touchfile = liftSh . S.touchfile++appendfile :: MonadSh m => FilePath -> Text -> m ()+appendfile = (liftSh .) . S.appendfile++readfile :: MonadSh m => FilePath -> m Text+readfile = liftSh . S.readfile++readBinary :: MonadSh m => FilePath -> m ByteString+readBinary = liftSh . S.readBinary++sleep :: MonadSh m => Int -> m ()+sleep = liftSh . S.sleep++echo, echo_n, echo_err, echo_n_err :: MonadSh m => Text -> m ()+echo       = liftSh . S.echo+echo_n     = liftSh . S.echo_n+echo_err   = liftSh . S.echo_err+echo_n_err = liftSh . S.echo_n_err++relPath :: MonadSh m => FilePath -> m FilePath+relPath = liftSh . S.relPath++relativeTo :: MonadSh m => FilePath -- ^ anchor path, the prefix+           -> FilePath -- ^ make this relative to anchor path+           -> m FilePath+relativeTo = (liftSh .) . S.relativeTo++canonic :: MonadSh m => FilePath -> m FilePath+canonic = liftSh . canonic++-- | Obtain a (reasonably) canonic file path to a filesystem object. Based on+-- "canonicalizePath" in system-fileio.+canonicalize :: MonadSh m => FilePath -> m FilePath+canonicalize = liftSh . S.canonicalize++absPath :: MonadSh m => FilePath -> m FilePath+absPath = liftSh . S.absPath++test_d :: MonadSh m => FilePath -> m Bool+test_d = liftSh . S.test_d++test_s :: MonadSh m => FilePath -> m Bool+test_s = liftSh . S.test_s++ls :: MonadSh m => FilePath -> m [FilePath]+ls = liftSh . S.ls++inspect :: (Show s, MonadSh m) => s -> m ()+inspect = liftSh . S.inspect++inspect_err :: (Show s, MonadSh m) => s -> m ()+inspect_err = liftSh . S.inspect_err++catchany :: MonadBaseControl IO m => m a -> (SomeException -> m a) -> m a+catchany = Control.Exception.Lifted.catch
+ shelly/src/Shelly/Pipe.hs view
@@ -0,0 +1,643 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, +             TypeFamilies, ExistentialQuantification #-}+-- | This module is a wrapper for the module "Shelly". +-- The only difference is a main type 'Sh'. In this module +-- 'Sh' contains a list of results. Actual definition of the type 'Sh' is:+--+-- > import qualified Shelly as S+-- >+-- > newtype Sh a = Sh { unSh :: S.Sh [a] }+--+-- This definition can simplify some filesystem commands. +-- A monad bind operator becomes a pipe operator and we can write+--+-- > findExt ext = findWhen (pure . hasExt ext)+-- >+-- > main :: IO ()+-- > main = shs $ do+-- >     mkdir "new"+-- >     findExt "hs"  "." >>= flip cp "new"+-- >     findExt "cpp" "." >>= rm_f +-- >     liftIO $ putStrLn "done"+--+-- Monad methods "return" and ">>=" behave like methods for+-- @ListT Shelly.Sh@, but ">>" forgets the number of +-- the empty effects. So the last line prints @\"done\"@ only once. +--+-- Documentation in this module mostly just reference documentation from+-- the main "Shelly" module.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE ExtendedDefaultRules #-}+-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- > import Shelly+-- > import Data.Text as T+-- > default (T.Text)+module Shelly.Pipe+       (+         -- * Entering Sh.+         Sh, shs, shelly, shellyFailDir, shsFailDir, sub, silently, verbosely, escaping, print_stdout, print_commands, tracing, errExit, log_stdout_with, log_stderr_with+         -- * List functions+         , roll, unroll, liftSh+         -- * Running external commands.+         , FoldCallback+         , run, run_, runFoldLines, cmd+         , (-|-), lastStderr, setStdin, lastExitCode+         , command, command_, command1, command1_+         , sshPairs, sshPairs_++         -- * Modifying and querying environment.+         , setenv, get_env, get_env_text, get_env_def, appendToPath, prependToPath++         -- * Environment directory+         , cd, chdir, pwd++         -- * Printing+         , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err+         , tag, trace, show_command++         -- * Querying filesystem.+         , ls, lsT, test_e, test_f, test_d, test_s, which++         -- * Filename helpers+         , absPath, (</>), (<.>), canonic, canonicalize, relPath, relativeTo+         , hasExt++         -- * Manipulating filesystem.+         , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree++         -- * reading/writing Files+         , readfile, readBinary, writefile, appendfile, touchfile, withTmpDir++         -- * exiting the program+         , exit, errorExit, quietExit, terror++         -- * Exceptions+         , catchany, catch_sh, finally_sh +         , ShellyHandler(..), catches_sh+         , catchany_sh++         -- * convert between Text and FilePath+         , toTextIgnore, toTextWarn, fromText++         -- * Utilities.+         , (<$>), whenM, unlessM, time++         -- * Re-exported for your convenience+         , liftIO, when, unless, FilePath++         -- * internal functions for writing extensions+         , get, put++         -- * find functions +         , find, findWhen, findFold+         , findDirFilter, findDirFilterWhen, findFoldDirFilter+         , followSymlink+         ) where++import Prelude hiding (FilePath)++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Exception hiding (handle)++import Filesystem.Path(FilePath)++import qualified Shelly as S++import Shelly(+      (</>), (<.>), hasExt+    , whenM, unlessM, toTextIgnore+    , fromText, catchany+    , FoldCallback)++import Data.Maybe(fromMaybe)+import Shelly.Base(State)+import Data.ByteString (ByteString)++import Data.Tree(Tree)++import Data.Text as T hiding (concat, all, find, cons)+++-- | This type is a simple wrapper for a type @Shelly.Sh@.+-- 'Sh' contains a list of results. +newtype Sh a = Sh { unSh :: S.Sh [a] }++instance Functor Sh where+    fmap f = Sh . fmap (fmap f) . unSh    ++instance Monad Sh where+    return  = Sh . return . return +    a >>= f = Sh $ fmap concat $ mapM (unSh . f) =<< unSh a+    a >> b  = Sh $ unSh a >> unSh b++instance Applicative Sh where+    pure = return+    (<*>) = ap++instance Alternative Sh where+    empty = mzero+    (<|>) = mplus++instance MonadPlus Sh where+    mzero = Sh $ return []+    mplus a b = Sh $ liftA2 (++) (unSh a) (unSh b)++instance MonadIO Sh where+    liftIO = sh1 liftIO++-------------------------------------------------------+-- converters++sh0 :: S.Sh a -> Sh a+sh0 = Sh . fmap return++sh1 :: (a -> S.Sh b) -> (a -> Sh b) +sh1 f = \a -> sh0 (f a)++sh2 :: (a1 -> a2 -> S.Sh b) -> (a1 -> a2 -> Sh b) +sh2 f = \a b -> sh0 (f a b)++sh3 :: (a1 -> a2 -> a3 -> S.Sh b) -> (a1 -> a2 -> a3 -> Sh b) +sh3 f = \a b c -> sh0 (f a b c)++sh4 :: (a1 -> a2 -> a3 -> a4 -> S.Sh b) -> (a1 -> a2 -> a3 -> a4 -> Sh b) +sh4 f = \a b c d -> sh0 (f a b c d)++sh0s :: S.Sh [a] -> Sh a+sh0s = Sh++sh1s :: (a -> S.Sh [b]) -> (a -> Sh b) +sh1s f = \a -> sh0s (f a)++{-  Just in case ...+sh2s :: (a1 -> a2 -> S.Sh [b]) -> (a1 -> a2 -> Sh b) +sh2s f = \a b -> sh0s (f a b)++sh3s :: (a1 -> a2 -> a3 -> S.Sh [b]) -> (a1 -> a2 -> a3 -> Sh b) +sh3s f = \a b c -> sh0s (f a b c)+-}++lift1 :: (S.Sh a -> S.Sh b) -> (Sh a -> Sh b)+lift1 f = Sh . (mapM (f . return) =<< ) . unSh++lift2 :: (S.Sh a -> S.Sh b -> S.Sh c) -> (Sh a -> Sh b -> Sh c)+lift2 f a b = Sh $ join $ liftA2 (mapM2 f') (unSh a) (unSh b)+    where f' = \x y -> f (return x) (return y)++mapM2 :: Monad m => (a -> b -> m c)-> [a] -> [b] -> m [c]+mapM2 f as bs = sequence $ liftA2 f as bs ++-----------------------------------------------------------++-- | Unpack list of results.+unroll :: Sh a -> Sh [a]+unroll = Sh . fmap return . unSh ++-- | Pack list of results. It performs @concat@ inside 'Sh'.+roll :: Sh [a] -> Sh a+roll = Sh . fmap concat . unSh++-- | Transform result as list. It can be useful for filtering. +liftSh :: ([a] -> [b]) -> Sh a -> Sh b+liftSh f = Sh . fmap f . unSh++------------------------------------------------------------------+-- Entering Sh++-- | see 'S.shelly'+shelly :: MonadIO m => Sh a -> m [a]+shelly = S.shelly . unSh++-- | Performs 'shelly' and then an empty action @return ()@. +shs :: MonadIO m => Sh () -> m ()+shs x = shelly x >> return ()++-- | see 'S.shellyFailDir'+shellyFailDir :: MonadIO m => Sh a -> m [a]+shellyFailDir = S.shellyFailDir . unSh++-- | Performs 'shellyFailDir' and then an empty action @return ()@.+shsFailDir :: MonadIO m => Sh () -> m ()+shsFailDir x = shellyFailDir x >> return ()++-- | see 'S.sub'+sub :: Sh a -> Sh a+sub = lift1 S.sub++-- See 'S.siliently'+silently :: Sh a -> Sh a+silently = lift1 S.silently++-- See 'S.verbosely+verbosely :: Sh a -> Sh a+verbosely = lift1 S.verbosely++-- | see 'S.escaping'+escaping :: Bool -> Sh a -> Sh a+escaping b = lift1 (S.escaping b)++-- | see 'S.log_stdout_with'+log_stdout_with :: (Text -> IO ()) -> Sh a -> Sh a+log_stdout_with logger = lift1 (S.log_stdout_with logger)++-- | see 'S.log_stderr_with'+log_stderr_with :: (Text -> IO ()) -> Sh a -> Sh a+log_stderr_with logger = lift1 (S.log_stdout_with logger)++-- | see 'S.print_stdout'+print_stdout :: Bool -> Sh a -> Sh a+print_stdout b = lift1 (S.print_stdout b)++-- | see 'S.print_commands+print_commands :: Bool -> Sh a -> Sh a+print_commands b = lift1 (S.print_commands b)++-- | see 'S.tracing'+tracing :: Bool -> Sh a -> Sh a+tracing b = lift1 (S.tracing b)++-- | see 'S.errExit'+errExit :: Bool -> Sh a -> Sh a+errExit b = lift1 (S.errExit b)++-- | see 'S.followSymlink'+followSymlink :: Bool -> Sh a -> Sh a+followSymlink b = lift1 (S.followSymlink b)++-- | see 'S.run'+run :: FilePath -> [Text] -> Sh Text+run a b = sh0 $ S.run a b++-- | see 'S.run_'+run_ :: FilePath -> [Text] -> Sh ()+run_ a b = sh0 $ S.run_ a b++-- | see 'S.runFoldLines'+runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a+runFoldLines a cb fp ts = sh0 $ S.runFoldLines a cb fp ts++-- | see 'S.-|-'+(-|-) :: Sh Text -> Sh b -> Sh b+(-|-) = lift2 (S.-|-)++-- | see 'S.lastStderr'+lastStderr :: Sh Text+lastStderr = sh0 S.lastStderr++-- | see 'S.setStdin'+setStdin :: Text -> Sh ()+setStdin = sh1 S.setStdin ++-- | see 'S.lastExitCode'+lastExitCode :: Sh Int+lastExitCode = sh0 S.lastExitCode++-- | see 'S.command'+command :: FilePath -> [Text] -> [Text] -> Sh Text+command = sh3 S.command++-- | see 'S.command_'+command_ :: FilePath -> [Text] -> [Text] -> Sh ()+command_ = sh3 S.command_+++-- | see 'S.command1'+command1 :: FilePath -> [Text] -> Text -> [Text] -> Sh Text+command1 = sh4 S.command1++-- | see 'S.command1_'+command1_ :: FilePath -> [Text] -> Text -> [Text] -> Sh ()+command1_ = sh4 S.command1_++-- | see 'S.sshPairs'+sshPairs :: Text -> [(FilePath, [Text])] -> Sh Text+sshPairs = sh2 S.sshPairs++-- | see 'S.sshPairs_'+sshPairs_ :: Text -> [(FilePath, [Text])] -> Sh ()+sshPairs_ = sh2 S.sshPairs_++-- | see 'S.setenv'+setenv :: Text -> Text -> Sh ()+setenv = sh2 S.setenv++-- | see 'S.get_env'+get_env :: Text -> Sh (Maybe Text)+get_env = sh1 S.get_env++-- | see 'S.get_env_text'+get_env_text :: Text -> Sh Text+get_env_text = sh1 S.get_env_text++-- | see 'S.get_env_def'+get_env_def :: Text -> Text -> Sh Text+get_env_def a d = sh0 $ fmap (fromMaybe d) $ S.get_env a+{-# DEPRECATED get_env_def "use fromMaybe DEFAULT get_env" #-}++-- | see 'S.appendToPath'+appendToPath :: FilePath -> Sh ()+appendToPath = sh1 S.appendToPath++-- | see 'S.prependToPath'+prependToPath :: FilePath -> Sh ()+prependToPath = sh1 S.prependToPath++-- | see 'S.cd'+cd :: FilePath -> Sh ()+cd = sh1 S.cd++-- | see 'S.chdir'+chdir :: FilePath -> Sh a -> Sh a+chdir p = lift1 (S.chdir p)++-- | see 'S.pwd'+pwd :: Sh FilePath+pwd = sh0 S.pwd++-----------------------------------------------------------------+-- Printing ++-- | Echo text to standard (error, when using _err variants) output. The _n+-- variants do not print a final newline.+echo, echo_n_err, echo_err, echo_n :: Text -> Sh ()++echo        = sh1 S.echo+echo_n_err  = sh1 S.echo_n_err+echo_err    = sh1 S.echo_err+echo_n      = sh1 S.echo_n++-- | see 'S.inspect'+inspect :: Show s => s -> Sh ()+inspect = sh1 S.inspect++-- | see 'S.inspect_err'+inspect_err :: Show s => s -> Sh ()+inspect_err = sh1 S.inspect_err++-- | see 'S.tag'+tag :: Sh a -> Text -> Sh a+tag a t = lift1 (flip S.tag t) a++-- | see 'S.trace'+trace :: Text -> Sh ()+trace = sh1 S.trace++-- | see 'S.show_command'+show_command :: FilePath -> [Text] -> Text+show_command = S.show_command++------------------------------------------------------------------+-- Querying filesystem++-- | see 'S.ls'+ls :: FilePath -> Sh FilePath+ls = sh1s S.ls++-- | see 'S.lsT'+lsT :: FilePath -> Sh Text+lsT = sh1s S.lsT++-- | see 'S.test_e'+test_e :: FilePath -> Sh Bool+test_e = sh1 S.test_e++-- | see 'S.test_f'+test_f :: FilePath -> Sh Bool+test_f = sh1 S.test_f++-- | see 'S.test_d'+test_d :: FilePath -> Sh Bool+test_d = sh1 S.test_d++-- | see 'S.test_s'+test_s :: FilePath -> Sh Bool+test_s = sh1 S.test_s++-- | see 'S.which+which :: FilePath -> Sh (Maybe FilePath)+which = sh1 S.which++---------------------------------------------------------------------+-- Filename helpers++-- | see 'S.absPath'+absPath :: FilePath -> Sh FilePath+absPath = sh1 S.absPath++-- | see 'S.canonic'+canonic :: FilePath -> Sh FilePath+canonic = sh1 S.canonic++-- | see 'S.canonicalize'+canonicalize :: FilePath -> Sh FilePath+canonicalize = sh1 S.canonicalize++-- | see 'S.relPath'+relPath :: FilePath -> Sh FilePath+relPath = sh1 S.relPath++-- | see 'S.relativeTo'+relativeTo :: FilePath -- ^ anchor path, the prefix+           -> FilePath -- ^ make this relative to anchor path+           -> Sh FilePath+relativeTo = sh2 S.relativeTo++-------------------------------------------------------------+-- Manipulating filesystem++-- | see 'S.mv'+mv :: FilePath -> FilePath -> Sh ()+mv = sh2 S.mv++-- | see 'S.rm'+rm :: FilePath -> Sh ()+rm = sh1 S.rm++-- | see 'S.rm_f'+rm_f :: FilePath -> Sh ()+rm_f = sh1 S.rm_f++-- | see 'S.rm_rf'+rm_rf :: FilePath -> Sh ()+rm_rf = sh1 S.rm_rf++-- | see 'S.cp'+cp :: FilePath -> FilePath -> Sh ()+cp = sh2 S.cp++-- | see 'S.cp_r'+cp_r :: FilePath -> FilePath -> Sh ()+cp_r = sh2 S.cp_r++-- | see 'S.mkdir'+mkdir :: FilePath -> Sh ()+mkdir = sh1 S.mkdir++-- | see 'S.mkdir_p'+mkdir_p :: FilePath -> Sh ()+mkdir_p = sh1 S.mkdir_p++-- | see 'S.mkdirTree'+mkdirTree :: Tree FilePath -> Sh ()+mkdirTree = sh1 S.mkdirTree++-- | see 'S.readFile'+readfile :: FilePath -> Sh Text+readfile = sh1 S.readfile++-- | see 'S.readBinary'+readBinary :: FilePath -> Sh ByteString+readBinary = sh1 S.readBinary++-- | see 'S.writeFile'+writefile :: FilePath -> Text -> Sh ()+writefile = sh2 S.writefile++-- | see 'S.touchFile'+touchfile :: FilePath -> Sh ()+touchfile = sh1 S.touchfile++-- | see 'S.appendFile'+appendfile :: FilePath -> Text -> Sh ()+appendfile = sh2 S.appendfile++-- | see 'S.withTmpDir'+withTmpDir :: (FilePath -> Sh a) -> Sh a+withTmpDir f = Sh $ S.withTmpDir (unSh . f)++-----------------------------------------------------------------+-- find++-- | see 'S.find'+find :: FilePath -> Sh FilePath+find = sh1s S.find++-- | see 'S.findWhen'+findWhen :: (FilePath -> Sh Bool) -> FilePath -> Sh FilePath+findWhen p a = Sh $ S.findWhen (fmap and . unSh . p) a++-- | see 'S.findFold'+findFold :: (a -> FilePath -> Sh a) -> a -> FilePath -> Sh a+findFold cons nil a = Sh $ S.findFold cons' nil' a+    where nil'  = return nil+          cons' as dir = unSh $ roll $ mapM (flip cons dir) as++-- | see 'S.findDirFilter'+findDirFilter :: (FilePath -> Sh Bool) -> FilePath -> Sh FilePath+findDirFilter p a = Sh $ S.findDirFilter (fmap and . unSh . p) a+    +-- | see 'S.findDirFilterWhen'+findDirFilterWhen :: (FilePath -> Sh Bool) -- ^ directory filter+                  -> (FilePath -> Sh Bool) -- ^ file filter+                  -> FilePath -- ^ directory+                  -> Sh FilePath+findDirFilterWhen dirPred filePred a = +    Sh $ S.findDirFilterWhen  +            (fmap and . unSh . dirPred) +            (fmap and . unSh . filePred)+            a+++-- | see 'S.findFoldDirFilterWhen'+findFoldDirFilter :: (a -> FilePath -> Sh a) -> a -> (FilePath -> Sh Bool) -> FilePath -> Sh a+findFoldDirFilter cons nil p a = Sh $ S.findFoldDirFilter cons' nil' p' a+    where p'    = fmap and . unSh . p+          nil'  = return nil+          cons' as dir = unSh $ roll $ mapM (flip cons dir) as+           +-----------------------------------------------------------+-- exiting the program ++-- | see 'S.exit'+exit :: Int -> Sh ()+exit = sh1 S.exit++-- | see 'S.errorExit'+errorExit :: Text -> Sh ()+errorExit = sh1 S.errorExit++-- | see 'S.quietExit'+quietExit :: Int -> Sh ()+quietExit = sh1 S.quietExit++-- | see 'S.terror'+terror :: Text -> Sh a+terror = sh1 S.terror++------------------------------------------------------------+-- Utilities++-- | see 'S.catch_sh'+catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a+catch_sh a f = Sh $ S.catch_sh (unSh a) (unSh . f)++-- | see 'S.catchany_sh'+catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a+catchany_sh = catch_sh+++-- | see 'S.finally_sh'+finally_sh :: Sh a -> Sh b -> Sh a+finally_sh = lift2 S.finally_sh++-- | see 'S.time'+time :: Sh a -> Sh (Double, a)+time = lift1 S.time++-- | see 'S.ShellyHandler'+data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> Sh a)++-- | see 'S.catches_sh'+catches_sh :: Sh a -> [ShellyHandler a] -> Sh a+catches_sh a hs = Sh $ S.catches_sh (unSh a) (fmap convert hs)+    where convert :: ShellyHandler a -> S.ShellyHandler [a]+          convert (ShellyHandler f) = S.ShellyHandler (unSh . f)++------------------------------------------------------------+-- convert between Text and FilePath ++-- | see 'S.toTextWarn'+toTextWarn :: FilePath -> Sh Text+toTextWarn = sh1 S.toTextWarn++-------------------------------------------------------------+-- internal functions for writing extension ++get :: Sh State+get = sh0 S.get++put :: State -> Sh ()+put = sh1 S.put++--------------------------------------------------------+-- polyvariadic vodoo++-- | Converter for the variadic argument version of 'run' called 'cmd'.+class ShellArg a where toTextArg :: a -> Text+instance ShellArg Text     where toTextArg = id+instance ShellArg FilePath where toTextArg = toTextIgnore+++-- Voodoo to create the variadic function 'cmd'+class ShellCommand t where+    cmdAll :: FilePath -> [Text] -> t++instance ShellCommand (Sh Text) where+    cmdAll fp args = run fp args++instance (s ~ Text, Show s) => ShellCommand (Sh s) where+    cmdAll fp args = run fp args++-- note that Sh () actually doesn't work for its case (_<- cmd) when there is no type signature+instance ShellCommand (Sh ()) where+    cmdAll fp args = run_ fp args++instance (ShellArg arg, ShellCommand result) => ShellCommand (arg -> result) where+    cmdAll fp acc = \x -> cmdAll fp (acc ++ [toTextArg x])++-- | see 'S.cmd'+cmd :: (ShellCommand result) => FilePath -> result+cmd fp = cmdAll fp []
+ shelly/src/Shelly/Unix.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}++-- | commands that only work on Unix+module Shelly.Unix+  ( kill+  ) where++import Shelly+import qualified Data.Text as T++kill :: Int -> Sh ()+kill pid = run_ "kill" ["-15", T.pack $ show pid]
src/Darcs/Patch.hs view
@@ -20,11 +20,9 @@ module Darcs.Patch     ( RepoType     , IsRepoType-    , PrimOf+    , PrimPatchBase(..)     , Named-    , WrappedNamed-    , fromPrim-    , fromPrims+    , ApplyState     , rmfile     , addfile     , rmdir@@ -32,7 +30,6 @@     , move     , hunk     , tokreplace-    , namepatch     , anonymous     , binary     , description@@ -40,7 +37,7 @@     , ShowPatchFor(..)     , showPatch     , displayPatch-    , showNicely+    , content     , infopatch     , changepref     , thing@@ -63,8 +60,8 @@     , invert     , invertFL     , invertRL+    , dropInverses     , commuteFL-    , commuteFLorComplain     , commuteRL     , readPatch     , readPatchPartial@@ -73,11 +70,10 @@     , tryToShrink     , patchname     , patchcontents-    , applyToFilePaths     , apply     , applyToTree     , maybeApplyToTree-    , effectOnFilePaths+    , effectOnPaths     , patch2patchinfo     , summary     , summaryFL@@ -92,35 +88,39 @@     ) where  -import Darcs.Patch.Apply ( apply,applyToFilePaths, effectOnFilePaths, applyToTree,-                           maybeApplyToTree )-import Darcs.Patch.Commute ( commute, commuteFL, commuteFLorComplain, commuteRL )-import Darcs.Patch.Conflict ( listConflictedFiles, resolveConflicts )+import Darcs.Patch.Apply ( apply, effectOnPaths, applyToTree,+                           maybeApplyToTree, ApplyState )+import Darcs.Patch.Commute ( commute, commuteFL, commuteRL )+import Darcs.Patch.Conflict ( resolveConflicts ) import Darcs.Patch.Effect ( Effect(effect) )-import Darcs.Patch.Invert ( invert, invertRL, invertFL )+import Darcs.Patch.Invert ( invert, invertRL, invertFL, dropInverses ) import Darcs.Patch.Inspect ( listTouchedFiles, hunkMatches ) import Darcs.Patch.Merge ( merge ) import Darcs.Patch.Named ( Named,-                           adddeps, namepatch,+                           adddeps,                            anonymous,                            getdeps,                            infopatch,                            patch2patchinfo, patchname, patchcontents )-import Darcs.Patch.Named.Wrapped ( WrappedNamed )-import Darcs.Patch.Prim ( fromPrims, fromPrim,-                          canonize,+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Prim ( canonize,                           sortCoalesceFL,                           rmdir, rmfile, tokreplace, adddir, addfile,                           binary, changepref, hunk, move,                           primIsAdddir, primIsAddfile,                           primIsHunk, primIsBinary, primIsSetpref,                           tryToShrink,-                          PrimPatch, PrimPatchBase(..) )+                          PrimPatch ) import Darcs.Patch.Read ( readPatch, readPatchPartial ) import Darcs.Patch.Repair ( isInconsistent ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.RepoType ( RepoType, IsRepoType )-import Darcs.Patch.Show ( description, showPatch, showNicely, displayPatch+import Darcs.Patch.Show ( description, showPatch, content, displayPatch                         , summary, summaryFL, thing, things, ShowPatchFor(..), ShowContextPatch(..) )-import Darcs.Patch.Summary ( xmlSummary, plainSummary, plainSummaryPrims )+import Darcs.Patch.Summary+    ( listConflictedFiles+    , xmlSummary+    , plainSummary+    , plainSummaryPrims+    ) import Darcs.Patch.TokenReplace ( forceTokReplace )
src/Darcs/Patch/Annotate.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}  -- Copyright (C) 2010 Petr Rockai --@@ -38,9 +38,9 @@     , machineFormat     , AnnotateResult     , Annotate(..)+    , AnnotateRP     ) where -import Prelude () import Darcs.Prelude  import Control.Monad.State ( modify, modify', when, gets, State, execState )@@ -56,15 +56,17 @@  import qualified Darcs.Patch.Prim.FileUUID as FileUUID +import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FromPrim ( PrimOf(..) ) import Darcs.Patch.Info ( PatchInfo(..), displayPatchInfo, piAuthor, makePatchname )-import Darcs.Patch.Named ( Named(..) )-import Darcs.Patch.Named.Wrapped ( WrappedNamed(..) )+import Darcs.Patch.Invert ( Invert, invert )+import Darcs.Patch.Named ( patchcontents ) import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd, hopefully ) import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.TokenReplace ( annotateReplace ) import Darcs.Patch.Witnesses.Ordered -import Darcs.Util.Path ( FileName, movedirfilename, fn2ps, ps2fn )+import Darcs.Util.Path ( AnchoredPath, movedirfilename, flatten ) import Darcs.Util.Printer( renderString ) import Darcs.Util.ByteString ( linesPS, decodeLocale ) @@ -74,88 +76,103 @@  type AnnotateResult = V.Vector (Maybe PatchInfo, B.ByteString) -data Annotated = Annotated+data Content2 f g+  = FileContent (f (g B.ByteString))+  | DirContent (f (g AnchoredPath))++data Annotated2 f g = Annotated2     { annotated     :: !AnnotateResult-    , current       :: ![(Int, B.ByteString)]-    , path          :: (Maybe FileName)-    , what          :: FileOrDirectory+    , current       :: !(Content2 f g)+    , currentPath   :: (Maybe AnchoredPath)     , currentInfo   :: PatchInfo-    } deriving Show+    } +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)+type AnnotateRP p = (Annotate (PrimOf p), Invert (PrimOf p), Effect p)+ instance Annotate Prim where   annotate (FP fn fp) = case fp of     RmFile -> do-      whenPathIs fn $ modify' (\s -> s { path = Nothing })-      whenWhatIs Directory $ updateDirectory fn+      whenPathIs fn $ modify' (\s -> s { currentPath = Nothing })+      withDirectory $ updateDirectory fn     AddFile -> return ()-    Hunk off o n -> whenPathIs fn $ whenWhatIs File $ do+    Hunk off o n -> whenPathIs fn $ withFile $ \c -> do       let remove = length o       let add = length n       i <- gets currentInfo-      c <- gets current       a <- gets annotated       -- NOTE patches are inverted and in inverse order       modify' $ \s ->         -- NOTE subtract one from offset because darcs counts from one,         -- whereas vectors and lists count from zero.         let (to,from) = splitAt (off-1) c-        in  s { current = map eval $ to ++ replicate add (-1, B.empty) ++ drop remove from+        in  s { current = FileContent $ map eval $ to ++ replicate add (-1, B.empty) ++ drop remove from               , annotated = merge i a $ map eval $ take remove $ from               }-    TokReplace t o n -> whenPathIs fn $ whenWhatIs File $ do+    TokReplace t o n -> whenPathIs fn $ withFile $ \c -> do       let test = annotateReplace t (BC.pack o) (BC.pack n)       i <- gets currentInfo-      c <- gets current       a <- gets annotated       modify' $ \s -> s-        { current = map (\(ix,b)->if test b then (-1,B.empty) else (ix,b)) c+        { current = FileContent $ map (\(ix,b)->if test b then (-1,B.empty) else (ix,b)) c         , annotated = merge i a $ map eval $ filter (test . snd) $ c         }     -- TODO what if the status of a file changed from text to binary?-    Binary _ _ -> whenPathIs fn $ bug "annotate: can't handle binary changes"+    Binary _ _ -> whenPathIs fn $ error "annotate: can't handle binary changes"   annotate (DP _ AddDir) = return ()-  annotate (DP fn RmDir) = whenWhatIs Directory $ do-    whenPathIs fn $ modify' (\s -> s { path = Nothing })-    updateDirectory fn+  annotate (DP fn RmDir) = withDirectory $ \c -> do+    whenPathIs fn $ modify' (\s -> s { currentPath = Nothing })+    updateDirectory fn c   annotate (Move fn fn') = do-    modify' (\s -> s { path = fmap (movedirfilename fn fn') (path s) })-    whenWhatIs Directory $ do-      let fix (i, x) = (i, fn2ps $ movedirfilename fn fn' (ps2fn x))-      modify $ \s -> s { current = map fix $ current s }+    modify' (\s -> s { currentPath = fmap (movedirfilename fn fn') (currentPath s) })+    withDirectory $ \c -> do+      let fix (i, x) = (i, movedirfilename fn fn' x)+      modify $ \s -> s { current = DirContent $ map fix c }   annotate (ChangePref _ _ _) = return ()  instance Annotate FileUUID.Prim where-  annotate _ = bug "annotate not implemented for FileUUID patches"--instance Annotate p => Annotate (FL p) where-  annotate = sequence_ . mapFL annotate--instance Annotate p => Annotate (Named p) where-  annotate (NamedP _ _ p) = annotate p+  annotate _ = error "annotate not implemented for FileUUID patches" -instance Annotate p => Annotate (WrappedNamed rt p) where-  annotate (NormalP n) = annotate n-  annotate (RebaseP _ _) = bug "annotate not implemented for Rebase patches"+annotatePIAP :: AnnotateRP p => PatchInfoAnd rt p wX wY -> AnnotatedM ()+annotatePIAP =+  sequence_ . mapFL annotate . invert . effect . patchcontents . hopefully -instance Annotate p => Annotate (PatchInfoAnd rt p) where-  annotate = annotate . hopefully+withDirectory :: ([(Int, AnchoredPath)] -> AnnotatedM ()) -> AnnotatedM ()+withDirectory actions = do+  what <- gets current+  case what of+    DirContent c -> actions c+    FileContent _ -> return () -whenWhatIs :: FileOrDirectory -> AnnotatedM () -> AnnotatedM ()-whenWhatIs w actions = do-  w' <- gets what-  when (w == w') actions+withFile :: ([(Int, B.ByteString)] -> AnnotatedM ()) -> AnnotatedM ()+withFile actions = do+  what <- gets current+  case what of+    FileContent c -> actions c+    DirContent _ -> return () -whenPathIs :: FileName -> AnnotatedM () -> AnnotatedM ()+whenPathIs :: AnchoredPath -> AnnotatedM () -> AnnotatedM () whenPathIs fn actions = do-  p <- gets path+  p <- gets currentPath   when (p == Just fn) actions -eval :: (Int, B.ByteString) -> (Int, B.ByteString)+eval :: (Int, a) -> (Int, a) eval (i,b) = seq i $ seq b $ (i,b)  merge :: a@@ -165,57 +182,54 @@ merge i a l = a V.// [ (line, (Just i, B.empty))                      | (line, _) <- l, line >= 0 && line < V.length a] -updateDirectory :: FileName -> AnnotatedM ()-updateDirectory p = whenWhatIs Directory $ do-    let line = fn2ps p-    files <- gets current-    case filter ((==line) . snd) files of-      [match@(ident, _)] -> reannotate ident match line+updateDirectory :: AnchoredPath -> [(Int,AnchoredPath)] -> AnnotatedM ()+updateDirectory path files = do+    case filter ((==path) . snd) files of+      [match@(ident, _)] -> reannotate ident match       _ -> return ()   where-    reannotate ident match line =-      modify $ \x -> x { annotated = annotated x V.// [ (ident, update line $ currentInfo x) ]-                       , current = filter (/= match) $ current x }-    update line inf = (Just inf, BC.concat [ " -- created as: ", line ])+    reannotate :: Int -> (Int, AnchoredPath) -> AnnotatedM ()+    reannotate ident match =+      modify $ \x -> x { annotated = annotated x V.// [ (ident, update $ currentInfo x) ]+                       , current = DirContent $ filter (/= match) files }+    update inf = (Just inf, flatten path)  complete :: Annotated -> Bool complete x = V.all (isJust . fst) $ annotated x -annotate' :: Annotate p-          => FL (PatchInfoAnd rt p) wX wY+annotate' :: AnnotateRP p+          => RL (PatchInfoAnd rt p) wX wY           -> Annotated           -> Annotated-annotate' NilFL ann = ann-annotate' (p :>: ps) ann+annotate' NilRL ann = ann+annotate' (ps :<: p) ann     | complete ann = ann-    | otherwise = annotate' ps $ execState (annotate p) (ann { currentInfo = info p })+    | otherwise = annotate' ps $ execState (annotatePIAP p) (ann { currentInfo = info p }) -annotateFile :: Annotate p-             => FL (PatchInfoAnd rt p) wX wY-             -> FileName+annotateFile :: AnnotateRP p+             => RL (PatchInfoAnd rt p) wX wY+             -> AnchoredPath              -> B.ByteString              -> AnnotateResult annotateFile patches inipath inicontent = annotated $ annotate' patches initial   where-    initial = Annotated { path = Just inipath-                        , currentInfo = bug "There is no currentInfo."-                        , current = zip [0..] (linesPS inicontent)-                        , what = File+    initial = Annotated2 { currentPath = Just inipath+                        , currentInfo = error "There is no currentInfo."+                        , current = FileContent $ zip [0..] (linesPS inicontent)                         , annotated = V.replicate (length $ breakLines inicontent)                                                       (Nothing, B.empty)                         } -annotateDirectory :: Annotate p-                  => FL (PatchInfoAnd rt p) wX wY-                  -> FileName-                  -> [FileName]+annotateDirectory :: AnnotateRP p+                  => RL (PatchInfoAnd rt p) wX wY+                  -> AnchoredPath+                  -> [AnchoredPath]                   -> AnnotateResult annotateDirectory patches inipath inicontent = annotated $ annotate' patches initial   where-    initial = Annotated { path = Just inipath-                        , currentInfo = bug "There is no currentInfo."-                        , current = zip [0..] (map fn2ps inicontent)-                        , what = Directory+    initial = Annotated2 { currentPath = Just inipath+                        , currentInfo = error "There is no currentInfo."+                        , current = DirContent $ zip [0..] inicontent                         , annotated = V.replicate (length inicontent) (Nothing, B.empty)                         }
src/Darcs/Patch/Apply.hs view
@@ -15,10 +15,6 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. --{-# LANGUAGE MultiParamTypeClasses #-}-- -- | -- Module      : Darcs.Patch.Apply -- Copyright   : 2002-2005 David Roundy@@ -30,59 +26,59 @@ module Darcs.Patch.Apply     (       Apply(..)-    , applyToFilePaths+    , applyToPaths     , applyToTree     , applyToState     , maybeApplyToTree-    , effectOnFilePaths+    , effectOnPaths     ) where -import Prelude () import Darcs.Prelude  import Control.Exception ( catch, IOException )-import Control.Arrow ( (***) ) -import Darcs.Util.Tree( Tree )+import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Tree ( Tree )  import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) )-import Darcs.Util.Path( fn2fp, fp2fn )+import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )  class Apply p where     type ApplyState p :: (* -> *) -> *     apply :: ApplyMonad (ApplyState p) m => p wX wY -> m ()+    unapply :: ApplyMonad (ApplyState p) m => p wX wY -> m ()+    default unapply :: (ApplyMonad (ApplyState p) m, Invert p) => p wX wY -> m ()+    unapply = apply . invert  instance Apply p => Apply (FL p) where     type ApplyState (FL p) = ApplyState p     apply NilFL = return ()     apply (p:>:ps) = apply p >> apply ps+    unapply NilFL = return ()+    unapply (p:>:ps) = unapply ps >> unapply p  instance Apply p => Apply (RL p) where     type ApplyState (RL p) = ApplyState p     apply NilRL = return ()-    apply (p:<:ps) = apply ps >> apply p---effectOnFilePaths :: (Apply p, ApplyState p ~ Tree)-                  => p wX wY-                  -> [FilePath]-                  -> [FilePath]-effectOnFilePaths p fps = fps' where-    (_, fps', _) = applyToFilePaths p Nothing fps+    apply (ps:<:p) = apply ps >> apply p+    unapply NilRL = return ()+    unapply (ps:<:p) = unapply p >> unapply ps  -applyToFilePaths :: (Apply p, ApplyState p ~ Tree)-                 => p wX wY-                 -> Maybe [(FilePath, FilePath)]-                 -> [FilePath]-                 -> ([FilePath], [FilePath], [(FilePath, FilePath)])-applyToFilePaths pa ofpos fs = toFPs $ withFileNames ofnos fns (apply pa) where-        fns = map fp2fn fs-        ofnos = map (fp2fn *** fp2fn) <$> ofpos-        toFPs (affected, new, renames) =-            (map fn2fp affected, map fn2fp new, map (fn2fp *** fn2fp) renames)+effectOnPaths :: (Apply p, ApplyState p ~ Tree)+              => p wX wY+              -> [AnchoredPath]+              -> [AnchoredPath]+effectOnPaths p fps = fps' where+    (_, fps', _) = applyToPaths p Nothing fps +applyToPaths :: (Apply p, ApplyState p ~ Tree)+             => p wX wY+             -> Maybe [(AnchoredPath, AnchoredPath)]+             -> [AnchoredPath]+             -> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])+applyToPaths pa ofpos fs = withFileNames ofpos fs (apply pa)  -- | Apply a patch to a 'Tree', yielding a new 'Tree'. applyToTree :: (Apply p, Monad m, ApplyState p ~ Tree)@@ -97,8 +93,7 @@              -> m ((ApplyState p) m) applyToState patch t = snd <$> runApplyMonad (apply patch) t --- | Attempts to apply a given replace patch to a Tree. If the apply fails (if--- the file the patch applies to already contains the target token), we return+-- | 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))
src/Darcs/Patch/ApplyMonad.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses-           , ConstraintKinds, UndecidableInstances-           , UndecidableSuperClasses #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses #-} -- Copyright (C) 2010, 2011 Petr Rockai -- -- Permission is hereby granted, free of charge, to any person@@ -29,7 +28,6 @@   , ApplyMonadTree(..)   ) where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString      as B@@ -38,54 +36,50 @@ import qualified Darcs.Util.Tree.Monad as TM import Darcs.Util.Tree ( Tree ) import Data.Maybe ( fromMaybe )-import Darcs.Util.Path-    ( FileName, movedirfilename, fn2fp, isParentOrEqOf, floatPath, AnchoredPath )+import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix ) import Control.Monad.State.Strict import Control.Monad.Identity( Identity ) import Darcs.Patch.MonadProgress  import GHC.Exts ( Constraint ) -fn2ap :: FileName -> AnchoredPath-fn2ap = floatPath . fn2fp- class ToTree s where   toTree :: s m -> Tree m  instance ToTree Tree where   toTree = id -class (Functor m, Monad m, ApplyMonad state (ApplyMonadOver state m))+class (Monad m, ApplyMonad state (ApplyMonadOver state m))       => ApplyMonadTrans (state :: (* -> *) -> *) m where   type ApplyMonadOver state m :: * -> *   runApplyMonad :: (ApplyMonadOver state m) x -> state m -> m (x, state m) -instance (Functor m, Monad m) => ApplyMonadTrans Tree m where+instance Monad m => ApplyMonadTrans Tree m where   type ApplyMonadOver Tree m = TM.TreeMonad m   runApplyMonad = TM.virtualTreeMonad  class ApplyMonadState (state :: (* -> *) -> *) where   type ApplyMonadStateOperations state :: (* -> *) -> Constraint -class (Functor m, Monad m) => ApplyMonadTree m where+class Monad m => ApplyMonadTree m where     -- a semantic, Tree-based interface for patch application-    mDoesDirectoryExist ::  FileName -> m Bool-    mDoesFileExist ::  FileName -> m Bool-    mReadFilePS ::  FileName -> m B.ByteString-    mCreateDirectory ::  FileName -> m ()-    mRemoveDirectory ::  FileName -> m ()-    mCreateFile ::  FileName -> m ()+    mDoesDirectoryExist ::  AnchoredPath -> m Bool+    mDoesFileExist ::  AnchoredPath -> m Bool+    mReadFilePS ::  AnchoredPath -> m B.ByteString+    mCreateDirectory ::  AnchoredPath -> m ()+    mRemoveDirectory ::  AnchoredPath -> m ()+    mCreateFile ::  AnchoredPath -> m ()     mCreateFile f = mModifyFilePS f $ \_ -> return B.empty-    mRemoveFile ::  FileName -> m ()-    mRename ::  FileName -> FileName -> m ()-    mModifyFilePS ::  FileName -> (B.ByteString -> m B.ByteString) -> m ()+    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 -class ( Functor m, Monad m, Functor (ApplyMonadBase m), Monad (ApplyMonadBase m)+class ( Monad m, Monad (ApplyMonadBase m)       , ApplyMonadStateOperations state m, ToTree state       )        -- ApplyMonadOver (ApplyMonadBase m) ~ m is *not* required in general,@@ -99,48 +93,48 @@      getApplyState :: m (state (ApplyMonadBase m)) -instance (Functor m, Monad m) => ApplyMonad Tree (TM.TreeMonad m) 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 -instance (Functor m, Monad m) => ApplyMonadTree (TM.TreeMonad m) where+instance Monad m => ApplyMonadTree (TM.TreeMonad m) where -    mDoesDirectoryExist d = TM.directoryExists (fn2ap d)-    mDoesFileExist d = TM.fileExists (fn2ap d)-    mReadFilePS p = B.concat `fmap` BL.toChunks `fmap` TM.readFile (fn2ap p)-    mModifyFilePS p j = do have <- TM.fileExists (fn2ap p)-                           x <- if have then B.concat `fmap` BL.toChunks `fmap` TM.readFile (fn2ap p)+    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 (fn2ap p) . BL.fromChunks . (:[]) =<< j x-    mCreateDirectory p = TM.createDirectory (fn2ap p)-    mRename from to = TM.rename (fn2ap from) (fn2ap to)-    mRemoveDirectory = TM.unlink . fn2ap-    mRemoveFile = TM.unlink . fn2ap+                           TM.writeFile p . BL.fromChunks . (:[]) =<< j x+    mCreateDirectory p = TM.createDirectory p+    mRename from to = TM.rename from to+    mRemoveDirectory = TM.unlink+    mRemoveFile = TM.unlink  -- Latest name, current original name.-type OrigFileNameOf = (FileName, FileName)+type OrigFileNameOf = (AnchoredPath, AnchoredPath) -- Touched files, new file list (after removes etc.) and rename details-type FilePathMonadState = ([FileName], [FileName], [OrigFileNameOf])+type FilePathMonadState = ([AnchoredPath], [AnchoredPath], [OrigFileNameOf]) type FilePathMonad = State FilePathMonadState  -- |trackOrigRename takes an old and new name and attempts to apply the mapping -- to the OrigFileNameOf pair. If the old name is the most up-to-date name of -- the file in question, the first element of the OFNO will match, otherwise if -- the up-to-date name was originally old, the second element will match.-trackOrigRename :: FileName -> FileName -> OrigFileNameOf -> OrigFileNameOf+trackOrigRename :: AnchoredPath -> AnchoredPath -> OrigFileNameOf -> OrigFileNameOf trackOrigRename old new pair@(latest, from)-    | old `isParentOrEqOf` latest = (latest, movedirfilename old new latest)-    | old `isParentOrEqOf` from = (latest, movedirfilename old new from)+    | old `isPrefix` latest = (latest, movedirfilename old new latest)+    | old `isPrefix` from = (latest, movedirfilename old new from)     | otherwise = pair  -- |withFileNames takes a maybe list of existing rename-pairs, a list of -- filenames and an action, and returns the resulting triple of affected files, -- updated filename list and new rename details. If the rename-pairs are not -- present, a new list is generated from the filesnames.-withFileNames :: Maybe [OrigFileNameOf] -> [FileName] -> FilePathMonad a+withFileNames :: Maybe [OrigFileNameOf] -> [AnchoredPath] -> FilePathMonad a     -> FilePathMonadState withFileNames mbofnos fps x = execState x ([], fps, ofnos) where     ofnos = fromMaybe (map (\y -> (y, y)) fps) mbofnos@@ -151,7 +145,7 @@  instance ApplyMonadTree FilePathMonad where     -- We can't check it actually is a directory here-    mDoesDirectoryExist d = gets $ \(_, fs, _) -> d `elem` fs+    mDoesDirectoryExist p = gets $ \(_, fs, _) -> p `elem` fs      mCreateDirectory = mCreateFile     mCreateFile f = modify $ \(ms, fs, rns) -> (f : ms, fs, rns)@@ -166,7 +160,7 @@ instance MonadProgress FilePathMonad where   runProgressActions = silentlyRunProgressActions -type RestrictedApply = State (M.Map FileName B.ByteString)+type RestrictedApply = State (M.Map AnchoredPath B.ByteString)  instance ApplyMonad Tree RestrictedApply where   type ApplyMonadBase RestrictedApply = Identity@@ -187,5 +181,5 @@ instance MonadProgress RestrictedApply where   runProgressActions = silentlyRunProgressActions -withFiles :: [(FileName, B.ByteString)] -> RestrictedApply a -> [(FileName, B.ByteString)]+withFiles :: [(AnchoredPath, B.ByteString)] -> RestrictedApply a -> [(AnchoredPath, B.ByteString)] withFiles p x = M.toList $ execState x $ M.fromList p
src/Darcs/Patch/Bracketed.hs view
@@ -3,12 +3,14 @@     , BracketedFL, mapBracketedFLFL, unBracketedFL     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, concatFL )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL, mapFL_FL, concatFL )+import Darcs.Util.Printer ( vcat, blueText, ($$) ) + -- |This type exists for legacy support of on-disk format patch formats. -- It is a wrapper type that explicitly tracks the nesting of braces and parens -- in the on-disk representation of such patches. It is used as an intermediate@@ -39,3 +41,13 @@ mapBracketedFLFL f = mapFL_FL (mapBracketed f)  instance PatchListFormat (Bracketed p)++instance ShowPatchBasic p => ShowPatchBasic (Bracketed p) where+    showPatch f (Singleton p) = showPatch f p+    showPatch _ (Braced NilFL) = blueText "{" $$ blueText "}"+    showPatch f (Braced ps) = blueText "{" $$ vcat (mapFL (showPatch f) ps) $$ blueText "}"+    showPatch f (Parens ps) = blueText "(" $$ vcat (mapFL (showPatch f) ps) $$ blueText ")"++-- the ReadPatch instance is defined in Darcs.Patch.Read as it is+-- used as an intermediate form during reading of lists of patches+-- that are specified as ListFormatV1 or ListFormatV2.
− src/Darcs/Patch/Bracketed/Instances.hs 
@@ -1,42 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Bracketed.Instances () where--import Darcs.Patch.Bracketed ( Bracketed(..) )-import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.Prim ( FromPrim(..), PrimPatchBase(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..) )--import Darcs.Patch.Witnesses.Ordered ( FL(NilFL), mapFL )--import Darcs.Util.Printer ( vcat, blueText, ($$) )---- The PrimPatchBase, Effect and FromPrim instances are only--- needed (by Darcs.Patch.Bundle) because the ReadPatch instance for--- WrappedNamed unconditionally has them as requirements even though--- they are only needed for the 'IsRebase case which isn't itself used--- by Darcs.Patch.Bundle.--- TODO see if this can be simplified-instance PrimPatchBase p => PrimPatchBase (Bracketed p) where-    type PrimOf (Bracketed p) = PrimOf p--instance Effect p => Effect (Bracketed p) where-    effect (Singleton p) = effect p-    effect (Braced ps) = effect ps-    effect (Parens ps) = effect ps--    effectRL (Singleton p) = effectRL p-    effectRL (Braced ps) = effectRL ps-    effectRL (Parens ps) = effectRL ps--instance FromPrim p => FromPrim (Bracketed p) where-    fromPrim p = Singleton (fromPrim p)--instance ShowPatchBasic p => ShowPatchBasic (Bracketed p) where-    showPatch f (Singleton p) = showPatch f p-    showPatch _ (Braced NilFL) = blueText "{" $$ blueText "}"-    showPatch f (Braced ps) = blueText "{" $$ vcat (mapFL (showPatch f) ps) $$ blueText "}"-    showPatch f (Parens ps) = blueText "(" $$ vcat (mapFL (showPatch f) ps) $$ blueText ")"---- the ReadPatch instance is defined in Darcs.Patch.Read as it is--- used as an intermediate form during reading of lists of patches--- that are specified as ListFormatV1 or ListFormatV2.
src/Darcs/Patch/Bundle.hs view
@@ -14,288 +14,290 @@ -- along with this program; see the file COPYING.  If not, write to -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA.- module Darcs.Patch.Bundle-    ( makeBundleN-    , scanBundle-    , contextPatches-    , scanContextFile-    , patchFilename+    ( Bundle(..)+    , makeBundle+    , parseBundle+    , interpretBundle+    , readContextFile     , minContext     ) where -import Prelude () import Darcs.Prelude -import Data.Char ( isAlpha, toLower, isDigit, isSpace )-import qualified Data.ByteString as B ( ByteString, length, null, drop,-                                        isPrefixOf )-import qualified Data.ByteString.Char8 as BC ( unpack, break, pack )+import Control.Applicative ( many, (<|>) )+import Control.Monad ( (<=<) ) -import Darcs.Util.Tree( Tree )-import Darcs.Util.Tree.Monad( virtualTreeIO )+import qualified Data.ByteString as B+    ( ByteString+    , breakSubstring+    , concat+    , drop+    , isPrefixOf+    , null+    , splitAt+    )+import qualified Data.ByteString.Char8 as BC+    ( break+    , dropWhile+    , pack+    ) -import Darcs.Patch ( RepoPatch, showPatch, showContextPatch,-                     readPatchPartial )-import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch+    ( RepoPatch+    , ApplyState+    , showPatch+    , showContextPatch+    ) import Darcs.Patch.Bracketed ( Bracketed, unBracketedFL )-import Darcs.Patch.Bracketed.Instances ()-import Darcs.Patch.Commute( commute )-import Darcs.Patch.Depends ( slightlyOptimizePatchset )+import Darcs.Patch.Commute ( Commute, commuteFL )+import Darcs.Patch.Depends ( contextPatches, splitOnTag ) import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo,-                          displayPatchInfo, isTag )-import Darcs.Patch.Named.Wrapped ( WrappedNamed )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, fmapFLPIAP, info,-                                  patchInfoAndPatch, unavailable, hopefully,-                                  generaliseRepoTypePIAP-                                )-import Darcs.Patch.ReadMonads ( parseStrictly )-import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin )+import Darcs.Patch.Info+    ( PatchInfo+    , displayPatchInfo+    , piTag+    , readPatchInfo+    , showPatchInfo+    )+import Darcs.Patch.Named ( Named, fmapFL_Named )+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , info+    , n2pia+    , patchInfoAndPatch+    , unavailable+    )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )+import Darcs.Patch.Read ( readPatch' )+import Darcs.Patch.Set+    ( PatchSet(..)+    , SealedPatchSet+    , Origin+    , appendPSFL+    ) import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor(ForStorage) ) import Darcs.Patch.Witnesses.Ordered-    ( RL(..), FL(..), (:>)(..), reverseFL, (+<+),-    mapFL, mapFL_FL, mapRL )+    ( (:>)(..)+    , FL(..)+    , RL(..)+    , mapFL+    , mapFL_FL+    , mapRL+    , reverseFL+    ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd, unsafeCoercePStart )  import Darcs.Util.ByteString-    ( mmapFilePS, linesPS, unlinesPS, dropSpace, substrPS, decodeLocale )-import Darcs.Util.Hash ( sha1PS )-import Darcs.Util.Printer ( Doc, renderPS, newline, text, ($$),-                 vcat, vsep, renderString )+    ( dropSpace+    , mmapFilePS+    , betweenLinesPS+    )+import Darcs.Util.Hash ( sha1PS, sha1Show )+import Darcs.Util.Parser+    ( Parser+    , lexString+    , lexWord+    , optional+    , parse+    )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , newline+    , packedString+    , renderPS+    , renderString+    , text+    , vcat+    , vsep+    )+import Darcs.Util.Tree( Tree )+import Darcs.Util.Tree.Monad( virtualTreeIO ) --- |hashBundle creates a SHA1 string of a given a FL of named patches. This--- allows us to ensure that the patches in a received patchBundle have not been--- modified in transit.-hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (WrappedNamed rt p) wX wY-           -> String-hashBundle to_be_sent =-    show $ sha1PS $ renderPS $ vcat (mapFL (showPatch ForStorage) to_be_sent) <> newline -makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)-            -> PatchSet rt p wStart wX -> FL (WrappedNamed rt p) wX wY -> IO Doc-makeBundleN the_s (PatchSet (_ :<: Tagged t _ _) ps) to_be_sent =-    makeBundle2 the_s ((NilRL :<: t) +<+ ps) to_be_sent to_be_sent-makeBundleN the_s (PatchSet NilRL ps) to_be_sent =-    makeBundle2 the_s ps to_be_sent to_be_sent+-- | 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 --- | In makeBundle2, it is presumed that the two patch sequences are--- identical, but that they may be lazily generated.  If two different--- patch sequences are passed, a bundle with a mismatched hash will be--- generated, which is not the end of the world, but isn't very useful--- either.-makeBundle2 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)-            -> RL (PatchInfoAnd rt p) wStart wX -> FL (WrappedNamed rt p) wX wY-            -> FL (WrappedNamed rt p) wX wY -> IO Doc-makeBundle2 the_s common' to_be_sent to_be_sent2 = do-    patches <- case the_s of-                   Just tree -> fst `fmap` virtualTreeIO (showContextPatch ForStorage to_be_sent) tree-                   Nothing -> return (vsep $ mapFL (showPatch ForStorage) to_be_sent)-    return $ format patches-  where-    format the_new = text ""-                     $$ text "New patches:"-                     $$ text ""-                     $$ the_new-                     $$ text ""-                     $$ text "Context:"-                     $$ text ""-                     $$ vcat (map (showPatchInfo ForStorage) common)-                     $$ text "Patch bundle hash:"-                     $$ text (hashBundle to_be_sent2)-                     $$ text ""-    common = mapRL info common'+-- | 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)+interpretBundle ref (Bundle (context :> patches)) =+  flip appendPSFL patches <$> interpretContext ref context -parseBundle :: forall rt p. RepoPatch p => B.ByteString-            -> Either String-                      (Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin))-parseBundle input | B.null input = Left "Bad patch bundle!"-parseBundle input = case sillyLex input of-    ("New patches:", rest) -> case getPatches rest of-        (Sealed bracketedPatches, rest') -> case sillyLex rest' of-            ("Context:", rest'') -> case getContext rest'' of-                (cont, maybe_hash) ->-                    let sealedCtxAndPs = sealCtxAndPs cont bracketedPatches in-                    case substrPS (BC.pack "Patch bundle hash:") maybe_hash of-                        Just n ->-                            let hPs = mapFL_FL hopefully bracketedPatches-                                realHash = hashBundle hPs-                                getHash = fst . sillyLex . snd . sillyLex-                                bundleHash = getHash $ B.drop n maybe_hash in-                            if realHash == bundleHash-                                then sealedCtxAndPs-                                else Left hashFailureMessage-                        Nothing -> sealedCtxAndPs-            (a, r) -> Left $ "Malformed patch bundle: '" ++ a-                             ++ "' is not 'Context:'\n" ++ BC.unpack r-    ("Context:", rest) -> case getContext rest of-        (cont, rest') -> case sillyLex rest' of-            ("New patches:", rest'') -> case getPatches rest'' of-                (Sealed bracketedPatches, _) ->-                    Right $ sealContextWithPatches cont bracketedPatches-            (a, _) -> Left $ "Malformed patch bundle: '" ++ a-                             ++ "' is not 'New patches:'"-    ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->-        parseBundle $ filterGpgDashes rest-    (_, rest) -> parseBundle rest-  where-    hashFailureMessage = "Patch bundle failed hash!\n"-                         ++ "This probably means that the patch has been "-                         ++ "corrupted by a mailer.\n"-                         ++ "The most likely culprit is CRLF newlines."+-- | Create a b16 encoded SHA1 of a given a FL of named patches. This allows us+-- to ensure that the patches in a received bundle have not been modified in+-- transit.+hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) wX wY+           -> B.ByteString+hashBundle to_be_sent =+    sha1Show $ sha1PS $ renderPS $+        vcat (mapFL (showPatch ForStorage) to_be_sent) <> newline -    sealCtxAndPs ctx ps = Right $ sealContextWithPatches ctx ps+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+  | _ :> context <- contextPatches repo =+    format context <$>+      case state of+        Just tree ->+          fst <$> virtualTreeIO (showContextPatch ForStorage to_be_sent) tree+        Nothing -> return (vsep $ mapFL (showPatch ForStorage) to_be_sent)+  where+    format context patches =+      text ""+      $$ text "New patches:"+      $$ text ""+      $$ patches+      $$ text ""+      $$ text "Context:"+      $$ text ""+      $$ vcat (mapRL (showPatchInfo ForStorage . info) context)+      $$ text "Patch bundle hash:"+      $$ packedString (hashBundle to_be_sent)+      $$ text "" -    sealContextWithPatches :: [PatchInfo]-                           -> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY-                           -> Sealed-                                  ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin)-    sealContextWithPatches context bracketedPatches =-        let -- witness to fmapFLPIAP that the bundle won't contain stash/rebase patches-            -- TODO use EmptyCase with GHC 7.8+-            notRebasing _-              = error "internal error: unreachable case (Darcs.Patch.Bundle.parseBundle.notRebasing)"-            patches = mapFL_FL (generaliseRepoTypePIAP . fmapFLPIAP unBracketedFL notRebasing)-                               bracketedPatches-        in-        case reverse context of-            (x : ry) | isTag x ->-                  let ps = unavailablePatches (reverse ry)-                      t = Tagged (piUnavailable x) Nothing NilRL in-                  Sealed $ PatchSet (NilRL :<: t) ps :> patches-            _ -> let ps = PatchSet NilRL (unavailablePatches context) in-                 Sealed $ ps :> patches-                 -- The above NilRLs aren't quite right, because ther *are*-                 -- earlier patches, but we can't set this to undefined-                 -- because there are situations where we look at the rest.-                 -- :{+hashFailureMessage :: String+hashFailureMessage =+  "Patch bundle failed hash!\n\+  \This probably means that the patch has been corrupted by a mailer.\n\+  \The most likely culprit is CRLF newlines." -scanBundle :: forall rt p . RepoPatch p => B.ByteString-           -> Either String (SealedPatchSet rt p Origin)-scanBundle bundle = do-  Sealed (PatchSet tagged recent :> ps) <- parseBundle bundle-  return . Sealed $ PatchSet tagged (recent +<+ reverseFL ps)+parseBundle :: RepoPatch p+            => B.ByteString -> Either String (Sealed (Bundle rt p wX))+parseBundle =+    fmap fst . parse pUnsignedBundle . dropInitialTrash . decodeGpgClearsigned+  where+    dropInitialTrash s =+      case BC.break (== '\n') (dropSpace s) of+        (line,rest)+          | contextName `B.isPrefixOf` line || patchesName `B.isPrefixOf` line -> s+          | B.null rest -> rest+          | otherwise -> dropInitialTrash rest --- |filterGpgDashes unescapes a clearsigned patch, which will have had any--- lines starting with dashes escaped with a leading "- ".-filterGpgDashes :: B.ByteString -> B.ByteString-filterGpgDashes ps =-    unlinesPS $ map drop_dashes $-    takeWhile (/= BC.pack "-----END PGP SIGNED MESSAGE-----") $-    dropWhile not_context_or_newpatches $ linesPS ps+pUnsignedBundle :: forall rt p wX. RepoPatch p => Parser (Sealed (Bundle rt p wX))+pUnsignedBundle = pContextThenPatches <|> pPatchesThenContext   where-    drop_dashes x-        | B.length x < 2 = x-        | BC.pack "- " `B.isPrefixOf` x = B.drop 2 x-        | otherwise = x+    packBundle context patches =+      Sealed $ Bundle $ (unavailablePatchesFL (reverse context)) :>+        (mapFL_FL (n2pia . fmapFL_Named unBracketedFL) patches)+    -- Is this a legacy format?+    pContextThenPatches = do+      context <- pContext+      Sealed patches <- pPatches+      return $ packBundle context patches+    pPatchesThenContext = do+      Sealed patches <- pPatches+      context <- pContext+      mBundleHash <- optional pBundleHash+      case mBundleHash of+        Just bundleHash -> do+          let realHash = hashBundle patches+          if realHash == bundleHash+            then return $ packBundle context patches+            else fail hashFailureMessage+        Nothing -> return $ packBundle context patches -    not_context_or_newpatches s = (s /= BC.pack "Context:") &&-                                  (s /= BC.pack "New patches:")+pBundleHash :: Parser B.ByteString+pBundleHash = lexString bundleHashName >> lexWord --- |unavailablePatches converts a list of PatchInfos into a RL of PatchInfoAnd--- Unavailable patches. This is used to represent the Context of a patchBundle.-unavailablePatches :: [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY-unavailablePatches = foldr (flip (:<:) . piUnavailable) (unsafeCoerceP NilRL)+bundleHashName :: B.ByteString+bundleHashName = BC.pack "Patch bundle hash:" --- |piUnavailable returns an Unavailable within a PatchInfoAnd given a--- PatchInfo.-piUnavailable :: PatchInfo -> PatchInfoAnd rt p wX wY-piUnavailable i = patchInfoAndPatch i . unavailable $-    "Patch not stored in patch bundle:\n" ++ renderString (displayPatchInfo i)+unavailablePatchesFL :: [PatchInfo] -> FL (PatchInfoAnd rt p) wX wY+unavailablePatchesFL = foldr ((:>:) . piUnavailable) (unsafeCoercePEnd NilFL)+  where+    piUnavailable i = patchInfoAndPatch i . unavailable $+      "Patch not stored in patch bundle:\n" ++ renderString (displayPatchInfo i) --- |getContext parses a context list, returning a tuple containing the list,--- and remaining ByteString input.-getContext :: B.ByteString -> ([PatchInfo],B.ByteString)-getContext ps = case parseStrictly readPatchInfo ps of-    Just (pinfo, r') -> case getContext r' of-        (pis, r'') -> (pinfo : pis, r'')-    Nothing -> ([], ps)+pContext :: Parser [PatchInfo]+pContext = lexString contextName >> many readPatchInfo --- |(-:-) is used to build up a Sealed FL of patches and tuple it, along with--- any unconsumed input.-(-:-) :: a wX wY -> (Sealed (FL a wY), b) -> (Sealed (FL a wX), b)-p -:- (Sealed ps, r) = (Sealed (p :>: ps), r)+contextName :: B.ByteString+contextName = BC.pack "Context:" --- |getPatches attempts to parse a sequence of patches from a ByteString,--- returning the FL of as many patches-with-info as were successfully parsed,--- along with any unconsumed input.-getPatches :: RepoPatch p => B.ByteString-           -> (Sealed (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX), B.ByteString)-getPatches ps = case parseStrictly readPatchInfo ps of-    Nothing -> (Sealed NilFL, ps)-    Just (pinfo, _) -> case readPatchPartial ps of-        Nothing -> (Sealed NilFL, ps)-        Just (Sealed p, r) -> (pinfo `piap` p) -:- getPatches r+pPatches :: RepoPatch p => Parser (Sealed (FL (Named (Bracketed p)) wX))+pPatches = lexString patchesName >> readPatch' --- |sillyLex takes a ByteString and breaks it upon the first newline, having--- removed any leading spaces. The before-newline part is unpacked to a String,--- and tupled up with the remaining ByteString.-sillyLex :: B.ByteString -> (String, B.ByteString)-sillyLex ps = (decodeLocale a, b)+patchesName :: B.ByteString+patchesName = BC.pack "New patches:"++readContextFile :: Commute p+                => PatchSet rt p Origin wX+                -> FilePath+                -> IO (SealedPatchSet rt p Origin)+readContextFile ref = fmap Sealed . (parseAndInterpret <=< mmapFilePS)   where-    (a, b) = BC.break (== '\n') (dropSpace ps)+    parseAndInterpret =+      either fail return . (interpretContext ref <=< parseContextFile) -contextPatches :: PatchSet rt p Origin wX-               -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) Origin wX-contextPatches set = case slightlyOptimizePatchset set of-    PatchSet (ts :<: Tagged t _ ps') ps ->-        PatchSet ts ps' :> ((NilRL :<: t) +<+ ps)-    PatchSet NilRL ps -> PatchSet NilRL NilRL :> ps+-- | 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)+interpretContext ref context =+  case context of+    tag :>: rest+      | Just tagname <- piTag (info tag) ->+        case splitOnTag (info tag) ref of+          Nothing ->+            Left $ "Cannot find tag " ++ tagname ++ " from context in our repo"+          Just (PatchSet ts _) ->+            Right $ PatchSet ts (unsafeCoercePStart (reverseFL rest))+    _ -> Right $ PatchSet NilRL (unsafeCoercePStart (reverseFL context)) --- |'scanContextFile' scans the context in the file of the given name.-scanContextFile :: FilePath -> IO (PatchSet rt p Origin wX)-scanContextFile filename = scanContext `fmap` mmapFilePS filename+parseContextFile :: B.ByteString+                 -> Either String (FL (PatchInfoAnd rt p) wX wY)+parseContextFile =+    fmap fst . parse pUnsignedContext . decodeGpgClearsigned   where-    -- are the type witnesses sensible?-    scanContext :: B.ByteString -> PatchSet rt p Origin wX-    scanContext input-        | B.null input = error "Bad context!"-        | otherwise = case sillyLex input of-            ("Context:",rest) -> case getContext rest of-                (cont@(_ : _), _) | isTag (last cont) ->-                    let ps = unavailablePatches $ init cont-                        t = Tagged (piUnavailable $ last cont) Nothing NilRL in-                    PatchSet (NilRL :<: t) ps-                (cont, _) -> PatchSet NilRL (unavailablePatches cont)-            ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->-                scanContext $ filterGpgDashes rest-            (_, rest) -> scanContext rest+    pUnsignedContext = unavailablePatchesFL . reverse <$> pContext --- | Minimize the context of a bundle to be sent, taking into account---   the patches selected to be sent +-- | Minimize the context of an 'FL' of patches to be packed into a bundle. minContext :: (RepoPatch p)-          => PatchSet rt p wStart wB-          -> FL (PatchInfoAnd rt p) wB wC-          -> Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) wStart)+           => PatchSet rt p wStart wB -- context to be minimized+           -> FL (PatchInfoAnd rt p) wB wC+           -> Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) wStart) minContext (PatchSet behindTag topCommon) to_be_sent =-  case go topCommon NilFL to_be_sent of-    Sealed (c :> to_be_sent') -> seal (PatchSet behindTag c :> to_be_sent') -  where-    go :: (RepoPatch p)-       => RL (PatchInfoAnd rt p) wA wB -- context we attempt to minimize-       -> FL (PatchInfoAnd rt p) wB wC -- patches we cannot remove from context-       -> FL (PatchInfoAnd rt p) wC wD -- patches to be included in the bundle-       -> Sealed (( RL (PatchInfoAnd rt p) :> FL (PatchInfoAnd rt p) ) wA )-    go NilRL necessary to_be_sent' = seal (reverseFL necessary :> to_be_sent')-    go (rest :<: candidate) necessary to_be_sent' =-      let fl1 = (candidate :>: NilFL) in-      case commute (fl1 :> necessary) of-        Nothing                   -> go rest (candidate :>: necessary) to_be_sent'-        Just (necessary' :> fl1') ->-            case commute (fl1' :> to_be_sent') of-                Nothing                  -> go rest (candidate :>: necessary) to_be_sent'-                Just (to_be_sent'' :> _) -> -- commutation work, we can drop the patch-                  go rest necessary' to_be_sent''+  case genCommuteWhatWeCanRL commuteFL (topCommon :> to_be_sent) of+    (c :> to_be_sent' :> _) -> seal (PatchSet behindTag c :> to_be_sent')  --- |patchFilename maps a patch description string to a safe (lowercased, spaces--- removed and ascii-only characters) patch filename.-patchFilename :: String -> String-patchFilename the_summary = name ++ ".dpatch"+-- TODO shouldn't we verify the signature? That is, pipe the input through+-- "gpg --verify -o-"? This would also let gpg handle their own mangling.++-- | Decode gpg clearsigned file content.+decodeGpgClearsigned :: B.ByteString -> B.ByteString+decodeGpgClearsigned input =+  case betweenLinesPS startSignedName endSignedName input of+    Nothing -> input+    Just signed -> removeGpgDashes (dropHashType signed)   where-    name = map safeFileChar the_summary-    safeFileChar c | isAlpha c = toLower c-                   | isDigit c = c-                   | isSpace c = '-'-    safeFileChar _ = '_'+    -- Note that B.concat is optimized to avoid unnecessary work, in particular+    -- concatenating slices that were originally adjacent involves no extra+    -- copying, and allocation of the result buffer is done only once.+    removeGpgDashes = B.concat . splitGpgDashes+    splitGpgDashes s =+      case B.breakSubstring newline_dashes s of+        (before, rest)+          | B.null rest -> [s]+          | (keep, after) <- B.splitAt 2 rest ->+              before : keep : splitGpgDashes (B.drop 2 after)+    newline_dashes = BC.pack "\n- -"+    dropHashType s =+      case B.breakSubstring hashTypeName s of+        (_, rest)+          | B.null rest -> s+          | otherwise -> dropSpace $ BC.dropWhile (/= '\n') rest+    hashTypeName = BC.pack "Hash:"+    startSignedName = BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"+    endSignedName = BC.pack "-----BEGIN PGP SIGNATURE-----"
src/Darcs/Patch/Choices.hs view
@@ -72,18 +72,16 @@     , getLabelInt     ) where -import Prelude () import Darcs.Prelude -import Darcs.Patch.Merge ( Merge, merge ) import Darcs.Patch.Invert ( Invert, invert ) import Darcs.Patch.Commute ( Commute, commute, commuteRL ) import Darcs.Patch.Inspect ( PatchInspect, listTouchedFiles, hunkMatches ) import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL )-import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered     ( FL(..), RL(..)-    , (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..)+    , (:>)(..), (:||:)(..)     , zipWithFL, mapFL_FL, concatFL     , (+>+), reverseRL, anyFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )@@ -150,9 +148,6 @@ compareLabels :: LabelledPatch p wA wB -> LabelledPatch p wC wD -> EqCheck (wA, wB) (wC, wD) compareLabels (LP l1 _) (LP l2 _) = if l1 == l2 then unsafeCoerceP IsEq else NotEq -instance Eq2 p => Eq2 (LabelledPatch p) where-  unsafeCompare (LP l1 p1) (LP l2 p2) = l1 == l2 && unsafeCompare p1 p2- instance Invert p => Invert (LabelledPatch p) where   invert (LP t p) = LP t (invert p) @@ -165,11 +160,6 @@   listTouchedFiles = listTouchedFiles . unLabel   hunkMatches f = hunkMatches f . unLabel -instance Merge p => Merge (LabelledPatch p) where-  merge (LP l1 p1 :\/: LP l2 p2) =-    case merge (p1 :\/: p2) of-      p2' :/\: p1' -> LP l2 p2' :/\: LP l1 p1'- instance Commute p => Commute (PatchChoice p) where   commute (PC p1 c1 :> PC p2 c2) = do     p2' :> p1' <- commute (p1 :> p2)@@ -179,10 +169,6 @@   listTouchedFiles = listTouchedFiles . pcPatch   hunkMatches f = hunkMatches f . pcPatch -instance Merge p => Merge (PatchChoice p) where-  merge (PC lp1 c1 :\/: PC lp2 c2) = case merge (lp1 :\/: lp2) of-    lp2' :/\: lp1' -> PC lp2' c2 :/\: PC lp1' c1- -- | Create a 'PatchChoices' from a sequence of patches, so that -- all patches are initially 'InMiddle'. patchChoices :: FL p wX wY -> PatchChoices p wX wY@@ -197,10 +183,7 @@ mkPatchChoices :: FL (LabelledPatch p) wX wY -> PatchChoices p wX wY mkPatchChoices = PCs NilFL . mapFL_FL (pcSetLast False) -instance Eq2 p => Eq2 (PatchChoice p) where-  unsafeCompare (PC lp1 _) (PC lp2 _) = unsafeCompare lp1 lp2 - -- | Like 'getChoices' but lumps together 'InMiddle' and 'InLast' patches. -- This is more efficient than using 'getChoices' and then catenating 'InMiddle' -- and 'InLast' sections because we have to commute less.@@ -309,7 +292,7 @@       case commuteRL (bubble :> lp) of         Just (lp' :> bubble') -> psLast firsts (middles :<: lp') bubble' ls         Nothing -> psLast firsts middles (bubble :<: lp) ls-    psLast _ _ _ NilFL = impossible+    psLast _ _ _ NilFL = error "impossible case"     settleM middles = mapFL_FL (\lp -> PC lp False) $ reverseRL middles     settleB bubble = mapFL_FL (\lp -> PC lp True) $ reverseRL bubble
src/Darcs/Patch/Commute.hs view
@@ -1,27 +1,47 @@ module Darcs.Patch.Commute     ( Commute(..)     , commuteFL-    , commuteFLorComplain     , commuteRL     , commuteRLFL     , selfCommuter     ) where -import Prelude () import Darcs.Prelude -import Darcs.Patch.CommuteFn ( CommuteFn )-+import Darcs.Patch.CommuteFn+    ( CommuteFn+    , commuterIdFL+    , commuterRLId+    , commuterRLFL+    ) import Darcs.Patch.Witnesses.Ordered     ( FL(..), RL(..), reverseFL, reverseRL,     (:>)(..) )-import Darcs.Patch.Witnesses.Sealed ( Sealed2, seal2 )  -- | 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 Commute p where     commute :: (p :> p) wX wY -> Maybe ((p :> p) wX wY)  instance Commute p => Commute (FL p) where+    {-# INLINE commute #-}     commute (NilFL :> x) = Just (x :> NilFL)     commute (x :> NilFL) = Just (NilFL :> x)     commute (xs :> ys) = do@@ -29,45 +49,26 @@         return $ ys' :> reverseRL rxs'  -- |'commuteRLFL' commutes an 'RL' past an 'FL'.+{-# INLINE commuteRLFL #-} commuteRLFL :: Commute p => (RL p :> FL p) wX wY             -> Maybe ((FL p :> RL p) wX wY)-commuteRLFL (NilRL :> ys) = Just (ys :> NilRL)-commuteRLFL (xs :> NilFL) = Just (NilFL :> xs)-commuteRLFL (xs :> y :>: ys) = do-    y' :> xs' <- commuteRL (xs :> y)-    ys' :> xs'' <- commuteRLFL (xs' :> ys)-    return (y' :>: ys' :> xs'')+commuteRLFL = commuterRLFL commute  instance Commute p => Commute (RL p) where+    {-# INLINE commute #-}     commute (xs :> ys) = do         fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)         return (reverseFL fys' :> xs')  -- |'commuteRL' commutes a RL past a single element.+{-# INLINE commuteRL #-} commuteRL :: Commute p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY)-commuteRL (zs :<: z :> w) = do-    w' :> z' <- commute (z :> w)-    w'' :> zs' <- commuteRL (zs :> w')-    return (w'' :> zs' :<: z')-commuteRL (NilRL :> w) = Just (w :> NilRL)+commuteRL = commuterRLId commute  -- |'commuteFL' commutes a single element past a FL.+{-# INLINE commuteFL #-} commuteFL :: Commute p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY)-commuteFL = either (const Nothing) Just . commuteFLorComplain---- |'commuteFLorComplain' attempts to commute a single element past a FL. If--- any individual commute fails, then we return the patch that first patch that--- cannot be commuted past.-commuteFLorComplain :: Commute p => (p :> FL p) wX wY-                    -> Either (Sealed2 p) ((FL p :> p) wX wY)-commuteFLorComplain (p :> NilFL) = Right (NilFL :> p)-commuteFLorComplain (q :> p :>: ps) =-    case commute (q :> p) of-        Just (p' :> q') ->-            case commuteFLorComplain (q' :> ps) of-                Right (ps' :> q'') -> Right (p' :>: ps' :> q'')-                Left l -> Left l-        Nothing -> Left $ seal2 p+commuteFL = commuterIdFL commute  -- |Build a commuter between a patch and itself using the operation from the type class. selfCommuter :: Commute p => CommuteFn p p
src/Darcs/Patch/CommuteFn.hs view
@@ -2,15 +2,18 @@     ( CommuteFn,       commuterIdFL, commuterFLId,       commuterIdRL, commuterRLId,+      commuterRLFL,       MergeFn,+      PartialMergeFn,       mergerIdFL,       TotalCommuteFn,-      totalCommuterIdFL, totalCommuterFLId, totalCommuterFLFL+      totalCommuterIdFL, totalCommuterFLId, totalCommuterFLFL,+      invertCommuter     ) where -import Prelude () import Darcs.Prelude +import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Witnesses.Ordered     ( (:>)(..)     , (:\/:)(..)@@ -27,12 +30,19 @@ -- multiple constructors on top of each other. The type class resolution machinery -- really can't cope with selecting some route, because it doesn't know that all -- possible routes should be equivalent.+--+-- Note that a CommuteFn cannot be lazy i.e. commute patches only when the+-- resulting sequences are demanded. This is because of the possibility of+-- failure ('Nothing'): all the commutes must be performed before we can know+-- whether the overall commute succeeds. type CommuteFn p1 p2 = forall wX wY . (p1 :> p2) wX wY -> Maybe ((p2 :> p1) wX wY)  type TotalCommuteFn p1 p2 = forall wX wY . (p1 :> p2) wX wY -> (p2 :> p1) wX wY  type MergeFn p1 p2 = forall wX wY . (p1 :\/: p2) wX wY -> (p2 :/\: p1) wX wY +type PartialMergeFn p1 p2 = forall wX wY . (p1 :\/: p2) wX wY -> Maybe ((p2 :/\: p1) wX wY)+ commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2) commuterIdRL _ (x :> NilRL) = return (NilRL :> x) commuterIdRL commuter (x :> (ys :<: y))@@ -47,6 +57,7 @@        ys' :> x'' <- commuterIdFL commuter (x' :> ys)        return ((y' :>: ys') :> x'') +-- | TODO document laziness or lack thereof mergerIdFL :: MergeFn p1 p2 -> MergeFn p1 (FL p2) mergerIdFL _ (x :\/: NilFL) = NilFL :/\: x mergerIdFL merger (x :\/: (y :>: ys))@@ -54,6 +65,7 @@       y' :/\: x' -> case mergerIdFL merger (x' :\/: ys) of           ys' :/\: x'' -> (y' :>: ys') :/\: x'' +-- | TODO document laziness or lack thereof totalCommuterIdFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn p1 (FL p2) totalCommuterIdFL _ (x :> NilFL) = NilFL :> x totalCommuterIdFL commuter (x :> (y :>: ys)) =@@ -75,6 +87,23 @@        y'' :> xs' <- commuterRLId commuter (xs :> y')        return (y'' :> (xs' :<: x')) +commuterRLFL :: forall p1 p2. CommuteFn p1 p2 -> CommuteFn (RL p1) (FL p2)+commuterRLFL commuter (xs :> ys) = right xs ys+  where+    right :: RL p1 wX wY -> FL p2 wY wZ -> Maybe ((FL p2 :> RL p1) wX wZ)+    right as NilFL = Just (NilFL :> as)+    right as (b :>: bs) = do+      b' :> as' <- commuterRLId commuter (as :> b)+      bs' :> as'' <- left as' bs+      return (b' :>: bs' :> as'')+    left :: RL p1 wX wY -> FL p2 wY wZ -> Maybe ((FL p2 :> RL p1) wX wZ)+    left NilRL bs = Just (bs :> NilRL)+    left (as :<: a) bs = do+      bs' :> a' <- commuterIdFL commuter (a :> bs)+      bs'' :> as' <- right as bs'+      return (bs'' :> as' :<: a')++-- | TODO document laziness or lack thereof totalCommuterFLId :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) p2 totalCommuterFLId _ (NilFL :> y) = y :> NilFL totalCommuterFLId commuter ((x :>: xs) :> y) =@@ -82,5 +111,14 @@      y' :> xs' -> case commuter (x :> y') of                     y'' :> x' -> y'' :> (x' :>: xs') +-- | TODO document laziness or lack thereof totalCommuterFLFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) (FL p2) totalCommuterFLFL commuter = totalCommuterFLId (totalCommuterIdFL commuter)++-- | Make use of the inverse-commute law to reduce the number of cases+-- when defining commute for complicated patch types.+{-# INLINE invertCommuter #-}+invertCommuter :: (Invert p, Invert q) => CommuteFn p q -> CommuteFn q p+invertCommuter commuter (x :> y) = do+    ix' :> iy' <- commuter (invert y :> invert x)+    return (invert iy' :> invert ix')
+ src/Darcs/Patch/CommuteNoConflicts.hs view
@@ -0,0 +1,77 @@+module Darcs.Patch.CommuteNoConflicts+    ( CommuteNoConflicts(..)+    , mergeNoConflicts+    ) where++import Darcs.Prelude++import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Witnesses.Ordered ( (:/\:)(..), (:>)(..), (:\/:)(..) )++-- | It is natural to think of conflicting patches @p@ and @q@ as+-- a parallel pair @p:\/:q@ because this is how conflicting patches arise.+-- But then Darcs comes along and merges them anyway by converting one of+-- them to a conflictor. Thus, inside a sequence of patches we may see+-- them as a sequential pair @(p:>q')@. In that case, 'commute' will always+-- succeed, as expressed by the 'prop_mergeCommute' law. 'commuteNoConflicts'+-- is a restricted version of 'commute' that should fail in this case but+-- otherwise give the same result as 'commute'.+--+-- Primitive patch types have no conflictors, so for them we have+-- @commute == commuteNoConflicts@.+--+-- Instances should obey the following laws:+--+-- * Symmetry+--+--   prop> commuteNoConflicts (p:>q) == Just (q':>p') <=> commuteNoConflicts (q':>p') == Just (p':>q)+--+-- * Square-Commute (if an instance @'Invert' p@ exists)+--+--   prop> commuteNoConflicts (p:>q) == Just (q':>p') => commuteNoConflicts (invert p:>q') == Just (q:>invert p')+--+-- * 'commuteNoConflicts' is a restriction of 'commute'+--+--   prop> commuteNoConflicts (p:>q) == Just r => commute (p:>q) == Just r+--+class Commute p => CommuteNoConflicts p where+    commuteNoConflicts :: (p :> p) wX wY -> Maybe ((p :> p) wX wY)+    -- ^ An alternative to 'commute' to be used if correctness of your code+    -- depends on the validity of the square-commute law, or to determine+    -- whether patches are in conflict. A parallel pair of patches @p:\/:q@+    -- is conflicting if and only if @commuteNoConflicts(p^:>q)@ fails. Its+    -- main use is so that we can define 'mergeNoConflicts' cleanly.++{- |+The non-conflicting merge of @p:\/:q@ tries to commute the inverse @p^@+of @p@ with @q@. If it succeeds then the part of the result that corresponds+to @p^@ is re-inverted. This is also known as a "clean merge".++Note that to maintain consistency in the presence of conflictors we must use+use 'commuteNoConflicts' here and not 'commute'. Otherwise we run into+contradictions as explained below.++Concretely, suppose we use 'commute' here and that @q@ is a conflictor that+represents the primitive patch @r@ and conflicts (only) with (primitive+patch) @p^@. That is, @q@ results from the conflicted+@merge(r:\/:p^)=(s:/\:q)@, where @s@ is another conflictor. Now, according+to '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.)++As a side note, the fact that we now get an inverse conflictor @s^@ as part+of the result leads to further problems. For instance, whether our repo is+conflicted now depends on the order of patches: @(p:>r)@ is not conflicted,+but its commute @(q:>s^)@ obviously is. In fact, @(q:>s^)@ is nothing else+but the (identity-preserving) "force-commute" of @(p:>r)@, see the thread at+https://lists.osuosl.org/pipermail/darcs-devel/2017-November/018403.html+-}+mergeNoConflicts :: (Invert p, CommuteNoConflicts p)+                 => (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)+mergeNoConflicts (p :\/: q) = do+  q' :> ip' <- commuteNoConflicts (invert p :> q)+  return (q' :/\: invert ip')
src/Darcs/Patch/Conflict.hs view
@@ -1,200 +1,75 @@ --  Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam-{-# LANGUAGE ViewPatterns #-} module Darcs.Patch.Conflict-    ( Conflict(..), CommuteNoConflicts(..), listConflictedFiles-    , IsConflictedPrim(..), ConflictState(..)-    , mangleUnravelled+    ( Conflict(..)+    , ConflictDetails(..)+    , Mangled+    , Unravelled+    , mangleOrFail+    , combineConflicts     ) where -import Prelude () import Darcs.Prelude -import qualified Data.ByteString.Char8 as BC (pack, last)-import qualified Data.ByteString       as B (null, ByteString)-import Data.Maybe ( isJust )-import Data.List ( sort, intercalate )-import Data.List.Ordered ( nubSort )--import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk, isHunk )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.CommuteFn ( commuterIdFL )+import Darcs.Patch.CommuteNoConflicts ( CommuteNoConflicts(..) ) import Darcs.Patch.Permutations ()-import Darcs.Patch.Prim ( PrimPatch, is_filepatch, primIsHunk, primFromHunk )-import Darcs.Patch.Prim.Class ( PrimOf )-import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), (:>)(..)-    , mapFL, reverseFL, mapRL, reverseRL-    )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, mapSeal )-import Darcs.Patch.Witnesses.Show ( Show2, showsPrec2 )-import Darcs.Util.Path ( FileName, fn2fp, fp2fn )-import Darcs.Util.Show ( appPrec )--listConflictedFiles :: Conflict p => p wX wY -> [FilePath]-listConflictedFiles p =-    nubSort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p--class (Effect p, PatchInspect (PrimOf p)) => Conflict p where-    resolveConflicts :: p wX wY -> [[Sealed (FL (PrimOf p) wY)]]--    conflictedEffect :: p wX wY -> [IsConflictedPrim (PrimOf p)]+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Prim ( PrimMangleUnravelled(..), Mangled, Unravelled )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) ) -class CommuteNoConflicts p where-    -- | If 'commuteNoConflicts' @x :> y@ succeeds, we know that that @x@ commutes-    --   past @y@ without any conflicts.   This function is useful for patch types-    --   for which 'commute' is defined to always succeed; so we need some way to-    --   pick out the specific cases where commutation succeeds without any conflicts.-    commuteNoConflicts :: (p :> p) wX wY -> Maybe ((p :> p) wX wY)+data ConflictDetails prim wX =+  ConflictDetails {+    conflictMangled :: Maybe (Mangled prim wX),+    conflictParts :: Unravelled prim wX+  } -instance (CommuteNoConflicts p, Conflict p) => Conflict (FL p) where-    resolveConflicts NilFL = []-    resolveConflicts x = resolveConflicts $ reverseFL x-    conflictedEffect = concat . mapFL conflictedEffect+mangleOrFail :: PrimMangleUnravelled prim+             => Unravelled prim wX -> ConflictDetails prim wX+mangleOrFail parts =+  ConflictDetails {+    conflictMangled = mangleUnravelled parts,+    conflictParts = parts+  } -instance CommuteNoConflicts p => CommuteNoConflicts (FL p) where-    commuteNoConflicts (NilFL :> x) = Just (x :> NilFL)-    commuteNoConflicts (x :> NilFL) = Just (NilFL :> x)-    commuteNoConflicts (xs :> ys) =   do ys' :> rxs' <- commuteNoConflictsRLFL (reverseFL xs :> ys)-                                         return $ ys' :> reverseRL rxs'+class Conflict p where+    -- | The first parameter is a context containing all patches+    -- preceding the ones for which we want to calculate the conflict+    -- resolution, which is the second parameter.+    -- Each element of the result list represents the resolution+    -- of one maximal set of transitively conflicting alternatives,+    -- in other words, a connected subset of the conflict graph.+    -- But the elements themselves must not conflict with each other,+    -- guaranteeing that they can be cleanly merged into a single 'FL' of prims.+    resolveConflicts :: RL p wO wX -> RL p wX wY -> [ConflictDetails (PrimOf p) wY] -instance (CommuteNoConflicts p, Conflict p) => Conflict (RL p) where-    -- By definition, a conflicting (primitive) patch is resolved if-    -- another (primitive) patch depends on the conflict.-    -- -    -- So, when looking for conflicts in a list of patches, we go-    -- through the whole list looking for individual patches that are-    -- in conflict. But then we try to commute them past all the-    -- patches we've already seen. If we fail, i.e. there's something-    -- that depends on the conflict, then we forget about the conflict;-    -- this is the Nothing case of the 'commuteNoConflictsFL' call.-    ---    -- Note that 'primitive' does not mean Prim (this is a case of bad-    -- naming) but rather a RepoPatchV1 or RepoPatchV2. Prim patches-    -- are merely a 'base class' containing everything common to V1 and-    -- V2 primitive patches.-    resolveConflicts x = rcs x NilFL+-- | By definition, a conflicting patch is resolved if another patch+-- (that is not itself conflicted) depends on the conflict. If the+-- representation of conflicts is self-contained as it is for V1 and V2,+-- then we can calculate the maximal set of conflicting alternatives for+-- a conflict separately for each conflictor at the end of a repo.+-- This function can then be used to lift this to an 'RL' of patches.+--+-- So, when looking for conflicts in a list of patches, we go+-- through the whole list looking for individual patches that represent+-- a conflict. But then we try to commute them past all the+-- patches we've already seen. If we fail, i.e. there's something+-- that depends on the conflict, then we forget about the conflict;+-- this is the Nothing case of the 'commuteNoConflictsFL' call.+-- Otherwise the patch is now in the correct position to extract the+-- conflicting alternatives.+combineConflicts+    :: forall p wX wY. CommuteNoConflicts p+    => (forall wA wB. p wA wB -> [Unravelled (PrimOf p) wB])+    -> RL p wX wY -> [Unravelled (PrimOf p) wY]+combineConflicts resolveOne x = rcs x NilFL+  where+    rcs :: RL p wX wM -> FL p wM wY -> [Unravelled (PrimOf p) wY]+    rcs NilRL _ = []+    rcs (ps :<: p) passedby+      | null (resolveOne p) = seq passedby rest -- TODO why seq here?+      | otherwise =+        case commuterIdFL commuteNoConflicts (p :> passedby) of+          Just (_ :> p') -> resolveOne p' ++ rest+          Nothing -> rest       where-        rcs :: RL p wX wY -> FL p wY wW -> [[Sealed (FL (PrimOf p) wW)]]-        rcs NilRL _ = []-        rcs (ps :<: p) passedby-          | null (resolveConflicts p) = seq passedby rest -- TODO why seq here?-          | otherwise =-            case commuteNoConflictsFL (p :> passedby) of-              Just (_ :> p') -> resolveConflicts p' ++ rest-              Nothing -> rest-          where-            rest = rcs ps (p :>: passedby)-    conflictedEffect = concat . reverse . mapRL conflictedEffect--instance CommuteNoConflicts p => CommuteNoConflicts (RL p) where-    commuteNoConflicts (NilRL :> x) = Just (x :> NilRL)-    commuteNoConflicts (x :> NilRL) = Just (NilRL :> x)-    commuteNoConflicts (xs :> ys) =   do ys' :> rxs' <- commuteNoConflictsRLFL (xs :> reverseRL ys)-                                         return $ reverseFL ys' :> rxs'--data IsConflictedPrim prim where-    IsC :: !ConflictState -> !(prim wX wY) -> IsConflictedPrim prim-data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read)--instance Show2 prim => Show (IsConflictedPrim prim) where-    showsPrec d (IsC cs prim) =-        showParen (d > appPrec) $-            showString "IsC " . showsPrec (appPrec + 1) cs .-            showString " " . showsPrec2 (appPrec + 1) prim--commuteNoConflictsFL :: CommuteNoConflicts p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY)-commuteNoConflictsFL (p :> NilFL) = Just (NilFL :> p)-commuteNoConflictsFL (q :> p :>: ps) =   do p' :> q' <- commuteNoConflicts (q :> p)-                                            ps' :> q'' <- commuteNoConflictsFL (q' :> ps)-                                            return (p' :>: ps' :> q'')--commuteNoConflictsRL :: CommuteNoConflicts p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY)-commuteNoConflictsRL (NilRL :> p) = Just (p :> NilRL)-commuteNoConflictsRL (ps :<: p :> q) =   do q' :> p' <- commuteNoConflicts (p :> q)-                                            q'' :> ps' <- commuteNoConflictsRL (ps :> q')-                                            return (q'' :> ps' :<: p')--commuteNoConflictsRLFL :: CommuteNoConflicts p => (RL p :> FL p) wX wY -> Maybe ((FL p :> RL p) wX wY)-commuteNoConflictsRLFL (NilRL :> ys) = Just (ys :> NilRL)-commuteNoConflictsRLFL (xs :> NilFL) = Just (NilFL :> xs)-commuteNoConflictsRLFL (xs :> y :>: ys) =   do y' :> xs' <- commuteNoConflictsRL (xs :> y)-                                               ys' :> xs'' <- commuteNoConflictsRLFL (xs' :> ys)-                                               return (y' :>: ys' :> xs'')---applyHunks :: IsHunk prim => [Maybe B.ByteString] -> FL prim wX wY -> [Maybe B.ByteString]-applyHunks ms ((isHunk -> Just (FileHunk _ l o n)):>:ps) = applyHunks (rls l ms) ps-    where rls k _ | k <=0 = bug $ "bad hunk: start position <=0 (" ++ show k ++ ")"-          rls 1 mls = map Just n ++ drop (length o) mls-          rls i (ml:mls) = ml : rls (i-1) mls-          rls _ [] = bug "rls in applyHunks"-applyHunks ms NilFL = ms-applyHunks _ (_:>:_) = impossible--getAFilename :: PrimPatch prim => [Sealed (FL prim wX)] -> FileName-getAFilename (Sealed ((is_filepatch -> Just f):>:_):_) = f-getAFilename _ = fp2fn ""--getOld :: PrimPatch prim => [Maybe B.ByteString] -> [Sealed (FL prim wX)] -> [Maybe B.ByteString]-getOld = foldl getHunksOld--getHunksOld :: PrimPatch prim => [Maybe B.ByteString] -> Sealed (FL prim wX)-              -> [Maybe B.ByteString]-getHunksOld mls (Sealed ps) =-    applyHunks (applyHunks mls ps) (invert ps)--getHunksNew :: IsHunk prim => [Maybe B.ByteString] -> Sealed (FL prim wX)-              -> [Maybe B.ByteString]-getHunksNew mls (Sealed ps) = applyHunks mls ps--getHunkline :: [[Maybe B.ByteString]] -> Int-getHunkline = ghl 1-    where ghl :: Int -> [[Maybe B.ByteString]] -> Int-          ghl n pps =-            if any (isJust . head) pps-            then n-            else ghl (n+1) $ map tail pps--makeChunk :: Int -> [Maybe B.ByteString] -> [B.ByteString]-makeChunk n mls = pull_chunk $ drop (n-1) mls-    where pull_chunk (Just l:mls') = l : pull_chunk mls'-          pull_chunk (Nothing:_) = []-          pull_chunk [] = bug "should this be [] in pull_chunk?"---mangleUnravelled :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX)-mangleUnravelled pss = if onlyHunks pss-                        then (:>: NilFL) `mapSeal` mangleUnravelledHunks pss-                        else head pss--onlyHunks :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Bool-onlyHunks [] = False-onlyHunks pss = fn2fp f /= "" && all oh pss-    where f = getAFilename pss-          oh :: Sealed (FL prim wY) -> Bool-          oh (Sealed (p:>:ps)) = primIsHunk p &&-                                 [fn2fp f] == listTouchedFiles p &&-                                 oh (Sealed ps)-          oh (Sealed NilFL) = True--mangleUnravelledHunks :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (prim wX)---mangleUnravelledHunks [[h1],[h2]] = Deal with simple cases handily?-mangleUnravelledHunks pss =-        if null nchs then bug "mangleUnravelledHunks"-                     else Sealed (primFromHunk (FileHunk filename l old new))-    where oldf = getOld (repeat Nothing) pss-          newfs = map (getHunksNew oldf) pss-          l = getHunkline $ oldf : newfs-          nchs = sort $ map (makeChunk l) newfs-          filename = getAFilename pss-          old = makeChunk l oldf-          new = [top] ++ old ++ [initial] ++ intercalate [middle] nchs ++ [bottom]-          top    = BC.pack $ "v v v v v v v" ++ eol_c-          initial= BC.pack $ "=============" ++ eol_c-          middle = BC.pack $ "*************" ++ eol_c-          bottom = BC.pack $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c-          eol_c  = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old-                   then "\r"-                   else ""-+        rest = rcs ps (p :>: passedby)
src/Darcs/Patch/Depends.hs view
@@ -15,8 +15,27 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE ScopedTypeVariables #-}+{- | Definitions used in this module: +[Explicit dependencies]: The set of patches that a (named) patch depends on+  "by name", i.e. irrespective of (non-)commutation (non commuting patches are+  implicit dependencies). The most important example are tags, but non-tag+  patches can also have explicit dependencies by recording them with+  --ask-deps.++[Covered]: A patch @p@ is covered by a tag @t@ if @t@ explicitly depends on+  @p@ or a tag covered by @t@ explicitly depends on @p@. In other words, the+  transitive closure of the relation "is depended on", restricted to+  situations where the right hand side is a tag. Note that it does /not/ take+  explicit dependencies of non-tag patches into account at all.++[Clean]: A tag @t@ in a repository is clean if all patches prior to the tag are+  covered by @t@. Tags normally start out as clean tags (the exception is+  if --ask-deps is used). It typically becomes unclean when it is merged into+  another repo (here the exceptions are if --reorder-patches is used, or if+  the target repo is actually a subset of the source repo).+-}+ module Darcs.Patch.Depends     ( getUncovered     , areUnrelatedRepos@@ -26,153 +45,101 @@     , countUsThem     , removeFromPatchSet     , slightlyOptimizePatchset-    , getPatchesBeyondTag     , splitOnTag     , patchSetUnion     , patchSetIntersection     , findUncommon-    , merge2FL-    , getDeps-    , SPatchAndDeps+    , cleanLatestTag+    , contextPatches     ) where -import Prelude () import Darcs.Prelude -import Prelude hiding ( pi ) import Data.List ( delete, intersect, (\\) ) import Data.Maybe ( fromMaybe )-import Control.Arrow ( (&&&) ) -import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Named ( Named (..), patch2patchinfo )-import Darcs.Patch.Named.Wrapped ( getdeps )-import Darcs.Patch.Choices ( Label, patchChoices, forceFirst-                           , PatchChoices, unLabel, getChoices-                           , LabelledPatch, label )-import Darcs.Patch.Commute ( Commute, commute, commuteFL, commuteRL )-import Darcs.Patch.Info ( PatchInfo, isTag, displayPatchInfo, piName )-import Darcs.Patch.Merge ( Merge, mergeFL )+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.Set ( PatchSet(..), Tagged(..), SealedPatchSet, patchSet2RL,-                         appendPSFL )+import Darcs.Patch.Set+    ( PatchSet(..)+    , Tagged(..)+    , SealedPatchSet+    , patchSet2RL+    , appendPSFL+    , patchSetSplit+    , Origin+    ) import Darcs.Patch.Progress ( progressRL )-import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=\/=), (=/\=) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart )+import Darcs.Patch.Witnesses.Eq ( Eq2 ) import Darcs.Patch.Witnesses.Ordered     ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..),-    (+>>+), (+<<+), mapFL, RL(..), FL(..), isShorterThanRL,-    (+<+), reverseFL, reverseRL, mapRL, lengthFL, splitAtFL )+    (+<<+), mapFL, RL(..), FL(..), isShorterThanRL, breakRL,+    (+<+), reverseFL, reverseRL, mapRL ) import Darcs.Patch.Witnesses.Sealed-    ( Sealed(..), FlippedSeal(..), flipSeal, seal, Sealed2(..), seal2 )+    ( Sealed(..), seal )  import Darcs.Util.Printer ( renderString, vcat ) -{-- - This module uses the following definitions:- -- - Explicit dependencies: the set of patches that a patch depends on "by name",- - i.e. irrespective of (non-)commutation (non commuting patches are implicit- - dependencies, or conflicts). In other words, the set of patch names in a tag- - or patch recorded with --ask-deps.- -- - Covered: a patch p covers another, q, if p's explicit dependencies include- - q. E.g. in a repo [a,b,t] where t is a tag and a,b have no explicit- - dependencies, then t will cover a and b.- -- - "Clean" tag: a tag in a repository is clean if all patches prior to the tag- - are (transitively-)covered by the tag. An obvious example of obtaining an- - unclean tag is by pulling from one repo into another - the tag could have- - been commuted past other patches. When patches are created, they are clean,- - since they explicitly depend on all uncovered patches.- -}---- | S(ealed) Patch and his dependencies.-type SPatchAndDeps p = ( Sealed2 (LabelledPatch (Named p))-                       , Sealed2 (FL (LabelledPatch (Named p)))-                       )---- | Searchs dependencies in @repoFL@ of the patches in @getDepsFL@.-getDeps :: (RepoPatch p) =>-            FL (Named p) wA wR -> FL (PatchInfoAnd rt p) wX wY -> [SPatchAndDeps p]-getDeps repoFL getDepsFL =-        let repoChoices   = patchChoices repoFL-            getDepsFL'    = mapFL (piName . info) getDepsFL-            labelledDeps  = getLabelledDeps getDepsFL' repoChoices-        in-            map (deps repoChoices) labelledDeps-    where-        -- Search dependencies for the patch with label @l@ in @repoChoices@.-        deps :: (Commute p) => PatchChoices (Named p) wX wY ->-                (String,Label) -> SPatchAndDeps p-        deps repoChoices (_,l) =-            case getChoices $ forceFirst l repoChoices of-                (ds :> _) -> let i = lengthFL ds-                             in case splitAtFL (i-1) ds of-                                    -- Separate last patch in list-                                    ds' :> (r :>: NilFL) -> (seal2 r, seal2 ds')-                                    _ -> impossible -- Because deps at least-                                                    -- has r, which is the patch-                                                    -- that we are looking at-                                                    -- dependencies.-        getLabelledDeps :: (Commute p) => [String] ->-                           PatchChoices (Named p) x y -> [(String, Label)]-        getLabelledDeps patchnames repoChoices =-            case getChoices repoChoices of-                 a :> (b :> c) -> filterDepsFL patchnames a ++-                                  filterDepsFL patchnames b ++-                                  filterDepsFL patchnames c-        filterDepsFL :: [String] -> FL (LabelledPatch (Named p)) wX wY ->-                        [(String, Label)]-        filterDepsFL _ NilFL = []-        filterDepsFL patchnames (lp :>: lps) =-                                if fst dep `elem` patchnames-                                    then dep : filterDepsFL patchnames lps-                                    else filterDepsFL patchnames lps-            where-                lpTostring :: LabelledPatch (Named p) wA wB -> String-                lpTostring = piName . patch2patchinfo . unLabel-                dep :: (String, Label)-                dep = lpTostring &&& label $ lp- {-|-taggedIntersection takes two 'PatchSet's and splits them into a /common/-intersection portion and two sets of patches.  The intersection, however,-is only lazily determined, so there is no guarantee that all intersecting-patches will be included in the intersection 'PatchSet'.  This is a pretty-efficient function, because it makes use of the already-broken-up nature of-'PatchSet's.+Find clean tags that are common to both argument 'PatchSet's and return a+'Fork' with the common clean tags and whatever remains of the 'PatchSet's.+The two "uncommon" sequences may still have patches in common, even clean+tags, since we look only at the "known clean" tags of the second argument,+i.e. those that are the head of a 'Tagged' section. -Note that the first argument to taggedIntersection should be-the repository that is more cheaply accessed (i.e. local), as-taggedIntersection does its best to reduce the number of-inventories that are accessed from its rightmost argument.+This is a pretty efficient function, because it makes use of the+already-broken-up nature of 'PatchSet's.++Note that the first argument should be the repository that is more cheaply+accessed (i.e. local), as 'taggedIntersection' does its best to reduce the+number of inventories that are accessed from its second argument. -}-taggedIntersection :: forall rt p wStart wX wY . Commute p-                   => PatchSet rt p wStart wX -> PatchSet rt p wStart wY ->+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)) wStart wX wY+                           (RL (PatchInfoAnd rt 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 t _ _) ps2)-    | Just (PatchSet ts1 ps1) <- maybeSplitSetOnTag (info t) s1 =-    Fork ts1 ps1 (unsafeCoercePStart ps2)-taggedIntersection s1 s2@(PatchSet (ts2 :<: Tagged t _ p) ps2) =-    case hopefullyM t of-        Just _ -> taggedIntersection s1 (PatchSet ts2 (p :<: t +<+ ps2))-        Nothing -> case splitOnTag (info t) s1 of-                       Just (PatchSet com NilRL :> us) ->-                           Fork com us (unsafeCoercePStart ps2)-                       Just _ -> impossible-                       Nothing -> Fork NilRL (patchSet2RL s1) (patchSet2RL s2)+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)  -- |'maybeSplitSetOnTag' takes a tag's 'PatchInfo', @t0@, and a 'PatchSet' and -- attempts to find @t0@ in one of the 'Tagged's in the PatchSet. If the tag is--- found, the PatchSet is split up, on that tag, such that all later patches+-- found, the 'PatchSet' is split up, on that tag, such that all later patches -- are in the "since last tag" patch list. If the tag is not found, 'Nothing' -- is returned.+-- This is a simpler version of 'splitOnTag' that only looks at the heads+-- of 'Tagged' sections and does not commute any patches. maybeSplitSetOnTag :: PatchInfo -> PatchSet rt p wStart wX                    -> Maybe (PatchSet rt p wStart wX) maybeSplitSetOnTag t0 origSet@(PatchSet (ts :<: Tagged t _ pst) ps)@@ -182,44 +149,25 @@         Just $ PatchSet ts' (ps' +<+ ps) maybeSplitSetOnTag _ _ = Nothing -getPatchesBeyondTag :: Commute p => PatchInfo -> PatchSet rt p wStart wX-                    -> FlippedSeal (RL (PatchInfoAnd rt p)) wX-getPatchesBeyondTag t (PatchSet (_ :<: Tagged hp _ _) ps) | info hp == t =-    flipSeal ps-getPatchesBeyondTag t patchset@(PatchSet ts (ps :<: hp)) =-    if info hp == t-        then if getUncovered patchset == [info hp]-                 -- special case to avoid looking at redundant patches-                 then flipSeal NilRL-                 else case splitOnTag t patchset of-                     Just (_ :> e) -> flipSeal e-                     _ -> impossible-        else case getPatchesBeyondTag t (PatchSet ts ps) of-                 FlippedSeal xxs -> FlippedSeal (xxs :<: hp)-getPatchesBeyondTag t (PatchSet NilRL NilRL) =-    bug $ "tag\n" ++ renderString (displayPatchInfo t)-          ++ "\nis not in the patchset in getPatchesBeyondTag."-getPatchesBeyondTag t0 (PatchSet (ts :<: Tagged t _ ps) NilRL) =-    getPatchesBeyondTag t0 (PatchSet ts (ps :<: t))---- |splitOnTag takes a tag's 'PatchInfo', and a 'PatchSet', and attempts to--- find the tag in the PatchSet, returning a pair: the clean PatchSet "up to"--- the tag, and a RL of patches after the tag; If the tag is not in the--- PatchSet, we return Nothing.+-- | Take a tag's 'PatchInfo', and a 'PatchSet', and attempt to find the tag in+-- the 'PatchSet'. If found, return a new 'PatchSet', in which the tag is now+-- clean (and the last of the 'Tagged' list), while all patches that are not+-- covered by the tag are in the trailing list of patches.+-- If the tag is not in the 'PatchSet', we return 'Nothing'. splitOnTag :: Commute p => PatchInfo -> PatchSet rt p wStart wX-           -> Maybe ((PatchSet rt p :> RL (PatchInfoAnd 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 (PatchSet ts@(_ :<: Tagged hp _ _) ps) | info hp == t =-    Just $ PatchSet ts NilRL :> ps+splitOnTag t s@(PatchSet (_ :<: Tagged hp _ _) _) | info hp == t = Just s -- If the tag is the most recent patch in the set, we check if the patch is the -- only non-depended-on patch in the set (i.e. it is a clean tag); creating a -- new Tagged out of the patches and tag, and adding it to the patchset, if -- this is the case. Otherwise, we try to make the tag clean. splitOnTag t patchset@(PatchSet ts hps@(ps :<: hp)) | info hp == t =     if getUncovered patchset == [t]-        then Just $ PatchSet (ts :<: Tagged hp Nothing ps) NilRL :> NilRL-        else case partitionRL ((`notElem` (t : ds)) . info) hps of+        -- 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.             tagAndDeps@(ds' :<: hp') :> nonDeps ->                 -- If @ds@ doesn't contain the tag of the first Tagged, that@@ -228,24 +176,34 @@                 -- being partitioned out in the recursive call to splitOnTag.                 if getUncovered (PatchSet ts tagAndDeps) == [t]                     then let tagged = Tagged hp' Nothing ds' in-                         return $ PatchSet (ts :<: tagged) NilRL :> nonDeps+                         return $ PatchSet (ts :<: tagged) nonDeps                     else do                         unfolded <- unwrapOneTagged $ PatchSet ts tagAndDeps-                        xx :> yy <- splitOnTag t unfolded-                        return $ xx :> (yy +<+ nonDeps)-            _ -> impossible-  where-    ds = getdeps (hopefully hp)+                        PatchSet xx yy <- splitOnTag t unfolded+                        return $ PatchSet xx (yy +<+ nonDeps)+            _ -> error "impossible case" -- We drop the leading patch, to try and find a non-Tagged tag. splitOnTag t (PatchSet ts (ps :<: p)) = do-    ns :> x <- splitOnTag t (PatchSet ts ps)-    return $ ns :> (x :<: p)+    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) =     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+cleanLatestTag inp@(PatchSet ts ps) =+  case breakRL (isTag . info) ps of+    NilRL :> _ -> inp -- no tag among the ps -> we are done+    (left@(_ :<: t) :> right) ->+      case splitOnTag (info t) (PatchSet ts left) of+        Just (PatchSet ts' ps') -> PatchSet ts' (ps' +<+ right)+        _ -> error "impossible case" -- because t is in left+ -- |'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)@@ -253,14 +211,11 @@     Just $ PatchSet ts (tps :<: t +<+ ps) unwrapOneTagged _ = Nothing --- | @getUncovered ps@ returns the 'PatchInfo' for all the patches in---   @ps@ that are not depended on by anything else *through explicit---   dependencies*. Tags are a likely candidate, although we may also---   find some non-tag patches in this list.+-- | Return the 'PatchInfo' for all the patches in a 'PatchSet'+-- that are not depended on by any tag (in the given 'PatchSet'). -----   Keep in mind that in a typical repository with a lot of tags, only a small---   fraction of tags would be returned as they would be at least indirectly---   depended on by the topmost ones.+-- 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)@@ -294,30 +249,22 @@         | isTag (info p) = (info p, getdeps `fmap` hopefullyM p)         | otherwise = (info p, Nothing) --- | @slightlyOptimizePatchset@ only works on the surface inventory---   (see 'optimizePatchset') and only optimises at most one tag in---   there, going for the most recent tag which has no non-depended---   patch after it. Older tags won't be 'clean', which means the---   PatchSet will not be in 'clean :> unclean' state.+-- | 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 ps0 ts0) =-    sops $ PatchSet (prog ps0) ts0+slightlyOptimizePatchset (PatchSet ts0 ps0) =+    go $ PatchSet ts0 (progressRL "Optimizing inventory" ps0)   where-    prog = progressRL "Optimizing inventory"-    sops :: PatchSet rt p wStart wY -> PatchSet rt p wStart wY-    sops patchset@(PatchSet _ NilRL) = patchset-    sops patchset@(PatchSet ts (ps :<: hp))-        | isTag (info hp) =-            if getUncovered patchset == [info hp]-                -- exactly one tag and it depends on everything not already-                -- archived-                then PatchSet (ts :<: Tagged hp Nothing ps) NilRL-                -- other tags or other top-level patches too (so move past hp)-                else let ps' = sops $ PatchSet ts (prog ps) in-                     appendPSFL ps' (hp :>: NilFL)-        | otherwise = appendPSFL (sops $ PatchSet ts ps) (hp :>: NilFL)+    go :: PatchSet rt p wStart wY -> PatchSet rt 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+        | otherwise = appendPSFL (go (PatchSet ts ps)) (hp :>: NilFL) -removeFromPatchSet :: Commute p => FL (PatchInfoAnd rt p) wX wY+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     ps' <- fastRemoveSubsequenceRL (reverseFL bad) ps@@ -326,29 +273,22 @@ removeFromPatchSet bad (PatchSet (ts :<: Tagged t _ tps) ps) =     removeFromPatchSet bad (PatchSet ts (tps :<: t +<+ ps)) -fastRemoveSubsequenceRL :: Commute p-                        => RL (PatchInfoAnd rt p) wY wZ-                        -> RL (PatchInfoAnd rt p) wX wZ-                        -> Maybe (RL (PatchInfoAnd rt p) wX wY)-fastRemoveSubsequenceRL NilRL ys = Just ys-fastRemoveSubsequenceRL (xs:<:x) ys = fastRemoveRL x ys >>= fastRemoveSubsequenceRL xs--findCommonAndUncommon :: forall rt p wStart wX wY . Commute p-                      => PatchSet rt p wStart wX -> PatchSet rt p wStart wY+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)) wStart wX wY+                              (FL (PatchInfoAnd rt p)) Origin wX wY findCommonAndUncommon us them = case taggedIntersection us them of     Fork common us' them' ->         case partitionFL (infoIn them') $ reverseRL us' of             _ :> bad@(_ :>: _) :> _ ->-                bug $ "Failed to commute common patches:\n"+                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@(_ :>: _) :> _ ->-                        bug $ "Failed to commute common patches:\n"+                        error $ "Failed to commute common patches:\n"                             ++ renderString (vcat $                                 mapRL (displayPatchInfo . info) $ reverseFL bad)                     _ :> NilFL :> only_theirs ->@@ -358,21 +298,21 @@     infoIn inWhat = (`elem` mapRL info inWhat) . info  findCommonWithThem :: Commute p-                   => PatchSet rt p wStart wX-                   -> PatchSet rt p wStart wY-                   -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) wStart wX+                   => 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     Fork common us' them' ->         case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of             _ :> bad@(_ :>: _) :> _ ->-                bug $ "Failed to commute common patches:\n"+                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  findUncommon :: Commute p-             => PatchSet rt p wStart wX -> PatchSet rt p wStart wY+             => PatchSet rt p Origin wX -> PatchSet rt p Origin wY              -> (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY findUncommon us them =     case findCommonWithThem us them of@@ -380,8 +320,8 @@             _ :> them' -> unsafeCoercePStart us' :\/: them'  countUsThem :: Commute p-            => PatchSet rt p wStart wX-            -> PatchSet rt p wStart wY+            => PatchSet rt p Origin wX+            -> PatchSet rt p Origin wY             -> (Int, Int) countUsThem us them =     case taggedIntersection us them of@@ -389,8 +329,8 @@                                 tt = mapRL info them' in                             (length $ uu \\ tt, length $ tt \\ uu) -mergeThem :: (Merge p)-          => PatchSet rt p wStart wX -> PatchSet rt p wStart wY+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@@ -399,8 +339,8 @@                them'' :/\: _ -> Sealed them''  patchSetIntersection :: Commute p-                   => [SealedPatchSet rt p wStart]-                   -> SealedPatchSet rt p wStart+                   => [SealedPatchSet rt p Origin]+                   -> SealedPatchSet rt p Origin patchSetIntersection [] = seal $ PatchSet NilRL NilRL patchSetIntersection [x] = x patchSetIntersection (Sealed y : ys) =@@ -411,46 +351,19 @@                     case partitionRL (\e -> info e `notElem` morecommon) a of                         commonps :> _ -> seal $ PatchSet common commonps -patchSetUnion :: (Merge p)-            => [SealedPatchSet rt p wStart]-            -> SealedPatchSet rt p wStart+patchSetUnion :: (Commute p, Merge p, Eq2 p)+            => [SealedPatchSet rt p Origin]+            -> SealedPatchSet rt p Origin patchSetUnion [] = seal $ PatchSet NilRL NilRL patchSetUnion [x] = x patchSetUnion (Sealed y@(PatchSet tsy psy) : Sealed y2 : ys) =     case mergeThem y y2 of         Sealed p2 ->-            patchSetUnion $ seal (PatchSet tsy (psy +<+ reverseFL p2)) : ys---- | Merge two FLs (say L and R), starting in a common context. The result is a--- FL starting in the original end context of L, going to a new context that is--- the result of applying all patches from R on top of patches from L.------ While this function is similar to 'mergeFL', there are some important--- differences to keep in mind:------ * 'mergeFL' does not correctly deal with duplicate patches whereas this one---   does---   (Question from Eric Kow: in what sense? Why not fix 'mergeFL'?)---   (bf: I guess what was meant here is that 'merge2FL' works in the---    the way it does because it considers patch meta data whereas---    'mergeFL' cannot since it must work for primitive patches, too.-merge2FL :: (Merge p)-         => FL (PatchInfoAnd rt p) wX wY-         -> FL (PatchInfoAnd rt p) wX wZ-         -> (FL (PatchInfoAnd rt p) :/\: FL (PatchInfoAnd rt 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')+            patchSetUnion $ seal (PatchSet tsy (psy +<<+ p2)) : ys  areUnrelatedRepos :: Commute p-                  => PatchSet rt p wStart wX-                  -> PatchSet rt p wStart wY -> Bool+                  => PatchSet rt p Origin wX+                  -> PatchSet rt p Origin wY -> Bool areUnrelatedRepos us them =     case taggedIntersection us them of         Fork c u t -> checkit c u t@@ -460,62 +373,8 @@                   | u `isShorterThanRL` 5 = False                   | otherwise = null $ intersect (mapRL info u) (mapRL info t) --- | Remove a patch from FL, using PatchInfo equality. The result is Just--- whenever the patch has been found and removed. If the patch is not present--- in the sequence at all or any commutation fails, we get Nothing. First two--- cases are optimisations for the common cases where the head of the list is--- the patch to remove, or the patch is not there at all.------ A note on the witness types: the patch to be removed is typed as if it had--- to be the first in the list, since it has the same pre-context as the list.--- The types fit together (internally, in this module) because we commute the--- patch to the front before removing it and commutation inside a sequence does--- not change the sequence's contexts.-fastRemoveFL :: Commute p-             => PatchInfoAnd rt p wX wY -- this type assumes element is at the front-             -> FL (PatchInfoAnd rt p) wX wZ-             -> Maybe (FL (PatchInfoAnd rt p) wY wZ)-fastRemoveFL _ NilFL = Nothing-fastRemoveFL a (b :>: bs) | IsEq <- a =\/= b = Just bs-                          | info a `notElem` mapFL info bs = Nothing-fastRemoveFL a (b :>: bs) = do-    a' :> bs' <- pullout NilRL bs-    a'' :> b' <- commute (b :> a')-    IsEq <- return (a'' =\/= a)-    Just (b' :>: bs')-  where-    i = info a-    pullout :: Commute p-            => RL (PatchInfoAnd rt p) wA wB-            -> FL (PatchInfoAnd rt p) wB wC-            -> Maybe ((PatchInfoAnd rt p :> FL (PatchInfoAnd rt p)) wA wC)-    pullout _ NilFL = Nothing-    pullout acc (x :>: xs)-        | info x == i = do x' :> acc' <- commuteRL (acc :> x)-                           Just (x' :> acc' +>>+ xs)-        | otherwise = pullout (acc :<: x) xs---- | Same as 'fastRemoveFL' only for 'RL'.-fastRemoveRL :: Commute p-             => PatchInfoAnd rt p wY wZ -- this type assumes element is at the back-             -> RL (PatchInfoAnd rt p) wX wZ-             -> Maybe (RL (PatchInfoAnd rt p) wX wY)-fastRemoveRL _ NilRL = Nothing-fastRemoveRL a (bs :<: b) | IsEq <- b =/\= a = Just bs-                          | info a `notElem` mapRL info bs = Nothing-fastRemoveRL a (bs :<: b) = do-    bs' :> a' <- pullout bs NilFL-    b' :> a'' <- commute (a' :> b)-    IsEq <- return (a'' =/\= a)-    Just (bs' :<: b')-  where-    i = info a-    pullout :: Commute p-            => RL (PatchInfoAnd rt p) wA wB-            -> FL (PatchInfoAnd rt p) wB wC-            -> Maybe ((RL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wA wC)-    pullout NilRL _ = Nothing-    pullout (xs :<: x) acc-        | info x == i = do acc' :> x' <- commuteFL (x :> acc)-                           Just (xs +<<+ acc' :> x')-        | otherwise = pullout xs (x :>: acc)+-- | 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 = patchSetSplit . slightlyOptimizePatchset
− src/Darcs/Patch/Dummy.hs 
@@ -1,89 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-methods #-}-{-# LANGUAGE EmptyDataDecls #-}-module Darcs.Patch.Dummy ( DummyPatch ) where--import Darcs.Patch.Annotate ( Annotate )-import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )-import Darcs.Patch.Debug ( PatchDebug(..) )-import Darcs.Patch.Effect ( Effect )-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Matchable ( Matchable )-import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute )-import Darcs.Patch.Invert ( Invert )-import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Patch.Read ( ReadPatch )-import Darcs.Patch.Show ( ShowPatch )-import Darcs.Patch.Prim ( FromPrim, PrimPatchCommon, PrimPatch, PrimPatchBase(..) )-import Darcs.Patch.Prim.Class-        ( PrimConstruct, PrimCanonize, PrimClassify-        , PrimDetails, PrimShow, PrimRead, PrimApply )-import Darcs.Patch.Merge ( Merge)-import Darcs.Patch.Repair ( Check, RepairToFL )-import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.Show ( ShowPatchBasic, ShowContextPatch )-import Darcs.Patch.Witnesses.Eq ( Eq2 )-import Darcs.Patch.Witnesses.Show ( Show2 )-import Darcs.Util.Tree( Tree )---data DummyPrim wX wY-data DummyPatch wX wY--instance IsHunk DummyPrim-instance PatchListFormat DummyPrim-instance Eq2 DummyPrim-instance Invert DummyPrim-instance PatchInspect DummyPrim-instance ReadPatch DummyPrim-instance ShowPatchBasic DummyPrim-instance ShowPatch DummyPrim-instance ShowContextPatch DummyPrim-instance Commute DummyPrim-instance Apply DummyPrim where-  type ApplyState DummyPrim = Tree--instance RepairToFL DummyPrim-instance PrimConstruct DummyPrim-instance PrimCanonize DummyPrim-instance PrimClassify DummyPrim-instance PrimDetails DummyPrim-instance PrimShow DummyPrim-instance PrimRead DummyPrim-instance PrimApply DummyPrim-instance PrimPatch DummyPrim-instance Show2 DummyPrim--instance PatchDebug DummyPrim--instance PrimPatchCommon DummyPrim--instance IsHunk DummyPatch-instance PatchListFormat DummyPatch-instance Eq2 DummyPatch-instance Invert DummyPatch-instance PatchInspect DummyPatch-instance ReadPatch DummyPatch-instance ShowPatchBasic DummyPatch-instance ShowPatch DummyPatch-instance ShowContextPatch DummyPatch-instance Show2 DummyPatch-instance Commute DummyPatch-instance Apply DummyPatch where-  type ApplyState DummyPatch = Tree-instance Matchable DummyPatch-instance Annotate DummyPatch--instance Effect DummyPatch-instance Merge DummyPatch-instance Conflict DummyPatch-instance FromPrim DummyPatch-instance CommuteNoConflicts DummyPatch-instance Check DummyPatch-instance RepairToFL DummyPatch-instance PrimPatchBase DummyPatch where-   type PrimOf DummyPatch = DummyPrim-instance RepoPatch DummyPatch--instance PatchDebug DummyPatch
src/Darcs/Patch/Effect.hs view
@@ -1,33 +1,25 @@ {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} module Darcs.Patch.Effect ( Effect(..) ) where -import Prelude () import Darcs.Prelude -import Darcs.Patch.Prim.Class ( PrimOf )+import Darcs.Patch.FromPrim ( PrimOf )  import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), reverseFL, reverseRL-    , concatFL, concatRL, mapFL_FL, mapRL_RL+    ( FL(..), RL(..), reverseRL+    , concatFL, mapFL_FL     )  --- | Patches whose concrete effect which can be expressed as a list of+-- | Patches whose concrete effect can be expressed as a list of --   primitive patches. -- --   A minimal definition would be either of @effect@ or @effectRL@. class Effect p where     effect :: p wX wY -> FL (PrimOf p) wX wY-    effect = reverseRL . effectRL-    effectRL :: p wX wY -> RL (PrimOf p) wX wY-    effectRL = reverseFL . effect-    {-# MINIMAL effect | effectRL #-}  instance Effect p => Effect (FL p) where-    effect p = concatFL $ mapFL_FL effect p-    effectRL p = concatRL $ mapRL_RL effectRL $ reverseFL p+    effect = concatFL . mapFL_FL effect  instance Effect p => Effect (RL p) where-    effect p = concatFL $ mapFL_FL effect $ reverseRL p-    effectRL p = concatRL $ mapRL_RL effectRL p-+    effect = effect . reverseRL
src/Darcs/Patch/FileHunk.hs view
@@ -3,11 +3,11 @@     )     where -import Prelude () import Darcs.Prelude -import Darcs.Util.Path ( FileName )+import Darcs.Util.Path ( AnchoredPath ) import Darcs.Patch.Format ( FileNameFormat )+import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Show ( formatFileName )  import Darcs.Util.Printer@@ -17,8 +17,10 @@ import qualified Data.ByteString as B ( ByteString )  -data FileHunk wX wY = FileHunk !FileName !Int [B.ByteString] [B.ByteString]+data FileHunk wX wY = FileHunk !AnchoredPath !Int [B.ByteString] [B.ByteString] +type role FileHunk nominal nominal+ class IsHunk p where     isHunk :: p wX wY -> Maybe (FileHunk wX wY) @@ -27,3 +29,6 @@            blueText "hunk" <+> formatFileName x f <+> text (show line)         $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old))         $$ lineColor Cyan    (prefix "+" (vcat $ map userchunkPS new))++instance Invert FileHunk where+    invert (FileHunk path line old new) = FileHunk path line new old
src/Darcs/Patch/Format.hs view
@@ -4,6 +4,8 @@     , FileNameFormat(..)     ) where +import Darcs.Prelude+ -- | Showing and reading lists of patches. This class allows us to control how -- lists of patches are formatted on disk. For legacy reasons V1 patches have -- their own special treatment (see 'ListFormat'). Other patch types use the@@ -27,9 +29,11 @@                         -- and flatten them out.     | ListFormatV2      -- ^ Show lists without braces. Read with arbitrary                         -- nested parens and flatten them out.+    | ListFormatV3      -- ^ Temporary hack to disable use of showContextSeries+                        -- for darcs-3 patches, until I find out how to fix this.  data FileNameFormat-    = OldFormat  -- ^ on-disk format for V1 patches-    | NewFormat  -- ^ on-disk format for V2 patches-    | UserFormat -- ^ display format+    = FileNameFormatV1      -- ^ on-disk format for V1 patches+    | FileNameFormatV2      -- ^ on-disk format for V2 patches+    | FileNameFormatDisplay -- ^ display format     deriving (Eq, Show)
+ src/Darcs/Patch/FromPrim.hs view
@@ -0,0 +1,38 @@+module Darcs.Patch.FromPrim+    ( PrimPatchBase(..)+    , FromPrim(..)+    , ToPrim(..)+    , ToFromPrim+    ) where++import Darcs.Prelude++import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Patch.Witnesses.Ordered ( FL, RL, mapFL_FL )+import Darcs.Patch.Ident ( PatchId )+import Darcs.Patch.Info ( PatchInfo )++class PrimPatch (PrimOf p) => PrimPatchBase p where+    type PrimOf (p :: (* -> * -> *)) :: (* -> * -> *)++instance PrimPatchBase p => PrimPatchBase (FL p) where+    type PrimOf (FL p) = PrimOf p++instance PrimPatchBase p => PrimPatchBase (RL p) where+    type PrimOf (RL p) = PrimOf p++class FromPrim p where+    fromAnonymousPrim :: PrimOf p wX wY -> p wX wY+    fromPrim :: PatchId p -> PrimOf p wX wY -> p wX wY+    fromPrims :: PatchInfo -> FL (PrimOf p) wX wY -> FL p wX wY++    default fromPrim :: (PatchId p ~ ()) => PatchId p -> PrimOf p wX wY -> p wX wY+    fromPrim () = fromAnonymousPrim++    default fromPrims :: (PatchId p ~ ()) => PatchInfo -> FL (PrimOf p) wX wY -> FL p wX wY+    fromPrims _ = mapFL_FL (fromPrim ())++class ToPrim p where+    toPrim :: p wX wY -> Maybe (PrimOf p wX wY)++type ToFromPrim p = (FromPrim p, ToPrim p)
+ src/Darcs/Patch/Ident.hs view
@@ -0,0 +1,325 @@+module Darcs.Patch.Ident+    ( Ident(..)+    , SignedIdent+    , PatchId+    , SignedId(..)+    , StorableId(..)+    , IdEq2(..)+    , merge2FL+    , fastRemoveFL+    , fastRemoveRL+    , fastRemoveSubsequenceRL+    , findCommonFL+    , commuteToPrefix+    , commuteToPostfix+    , commuteWhatWeCanToPostfix+    -- * Properties+    , prop_identInvariantUnderCommute+    , prop_sameIdentityImpliesCommutable+    , prop_equalImpliesSameIdentity+    ) where++import qualified Data.Set as S++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.Show ( ShowPatchFor )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..), isIsEq )+import Darcs.Patch.Witnesses.Ordered+    ( (:/\:)(..)+    , (:>)(..)+    , (:\/:)(..)+    , FL(..)+    , RL(..)+    , Fork(..)+    , (+<<+)+    , (+>>+)+    , mapFL+    , mapRL+    , reverseRL+    )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd, unsafeCoercePStart )++import Darcs.Util.Parser ( Parser )+import Darcs.Util.Printer ( Doc )++type family PatchId (p :: * -> * -> *)++{- | Class of patches that have an identity.++It generalizes named prim patches a la camp (see Darcs.Patch.Prim.Named) and+Named patches i.e. those with a PatchInfo.++Patch identity should be invariant under commutation: if there is also an+@instance 'Commute' p@, then++prop> commute (p :> q) == Just (q' :> p') => ident p == ident p' && ident q == ident q'++The converse should also be true: patches with the same identity can be+commuted (back) to the same context and then compare equal. Assuming++@+  p :: p wX wY, (ps :> q) :: (RL p :> p) wX wZ+@++then++prop> ident p == ident q => commuteRL (ps :> q) == Just (p :> _)++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++prop> ident p == ident q => p =\/= q == IsEq++In general, comparing patches via their identity is coarser than+(structural) equality, so we only have++prop> unsafeCompare p q => (ident p == ident q)+-}+class Ord (PatchId p) => Ident p where+  ident :: p wX wY -> PatchId p++{- | Signed identities.++Like for class 'Invert', we require that 'invertId' is self-inverse:++prop> invertId . invertId = id++We also require that inverting changes the sign:++prop> positiveId . invertId = not . positiveId++Side remark: in mathematical terms, these properties can be expressed by+stating that 'invertId' is an involution and that 'positiveId' is a+"homomorphism of sets with an involution" (there is no official term for+this) from @a@ to the simplest non-trivial set with involution, namely+'Bool' with the involution 'not'.+-}+class Ord a => SignedId a where+  positiveId :: a -> Bool+  invertId :: a -> a++{- | Constraint for patches that have an identity that is signed,+     i.e. can be positive (uninverted) or negative (inverted).++Provided that an instance 'Invert' exists, inverting a patch+inverts its identity:++prop> ident (invert p) = invertId (ident p)++-}+type SignedIdent p = (Ident p, SignedId (PatchId p))+++{- | Storable identities.++The methods here can be used to help implement ReadPatch and ShowPatch+for a patch type containing the identity.++As with all Read/Show pairs, We expect that the output of+@showId ForStorage a@ can be parsed by 'readId' to produce @a@.+-}+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'+-- otherwise. If the patch is not found at the head of the sequence we must+-- first commute it to the head before we can remove it.+-- +-- We assume that this commute always succeeds. This is justified because+-- patches are created with a (universally) unique identity, implying that if+-- two patches have the same identity, then they have originally been the same+-- patch; thus being at a different position must be due to commutation,+-- meaning we can commute it back.+fastRemoveFL :: forall p wX wY wZ. (Commute p, Ident p)+             => p wX wY+             -> FL p wX wZ+             -> Maybe (FL p wY wZ)+fastRemoveFL a bs+  | i `notElem` mapFL ident bs = Nothing+  | otherwise = do+      _ :> bs' <- pullout NilRL bs+      Just (unsafeCoercePStart bs')+  where+    i = ident a+    pullout :: RL p wA wB -> FL p wB wC -> Maybe ((p :> FL p) wA wC)+    pullout _ NilFL = Nothing+    pullout acc (x :>: xs)+      | ident x == i = do+          x' :> acc' <- commuteRL (acc :> x)+          Just (x' :> acc' +>>+ xs)+      | otherwise = pullout (acc :<: x) xs++-- | Same as 'fastRemoveFL' only for 'RL'.+fastRemoveRL :: forall p wX wY wZ. (Commute p, Ident p)+             => p wY wZ+             -> RL p wX wZ+             -> Maybe (RL p wX wY)+fastRemoveRL a bs+  | i `notElem` mapRL ident bs = Nothing+  | otherwise = do+      bs' :> _ <- pullout bs NilFL+      Just (unsafeCoercePEnd bs')+  where+    i = ident a+    pullout :: RL p wA wB -> FL p wB wC -> Maybe ((RL p :> p) wA wC)+    pullout NilRL _ = Nothing+    pullout (xs :<: x) acc+      | ident x == i = do+          acc' :> x' <- commuteFL (x :> acc)+          Just (xs +<<+ acc' :> x')+      | otherwise = pullout xs (x :>: acc)++fastRemoveSubsequenceRL :: (Commute p, Ident p)+                        => RL p wY wZ+                        -> RL p wX wZ+                        -> Maybe (RL p wX wY)+fastRemoveSubsequenceRL NilRL ys = Just ys+fastRemoveSubsequenceRL (xs :<: x) ys =+  fastRemoveRL x ys >>= fastRemoveSubsequenceRL xs++-- | Find the common and uncommon parts of two lists that start in a common+-- context, using patch identity for comparison. Of the common patches, only+-- one is retained, the other is discarded, similar to 'merge2FL'.+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 cxs =\^/= cys of+            NotEq -> error "common patches aren't equal"+            IsEq -> Fork cxs (reverseRL xs') (reverseRL ys')+  where+    commonIds =+      S.fromList (mapFL ident xs) `S.intersection` 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.+commuteToPrefix :: (Commute p, Ident p)+                => S.Set (PatchId p) -> FL p wX wY -> Maybe ((FL p :> RL p) wX wY)+commuteToPrefix is ps+  | prefix :> NilRL :> rest <-+      partitionFL' ((`S.member` is) . ident) NilRL NilRL ps = Just (prefix :> rest)+  | otherwise = Nothing++-- | 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) =+  case commute (p :> q) of+    Just (q' :> p') -> Just $ ident p == ident p' && ident q == ident q'+    Nothing -> Nothing++prop_sameIdentityImpliesCommutable :: (Commute p, Eq2 p, Ident p)+                                   => (p :\/: (RL p :> p)) wX wY -> Maybe Bool+prop_sameIdentityImpliesCommutable (p :\/: (ps :> q))+  | ident p == ident q =+      case commuteRL (ps :> q) of+        Just (p' :> _) -> Just $ isIsEq (p =\/= p')+        Nothing -> Just False+  | otherwise = Nothing++prop_equalImpliesSameIdentity :: (Eq2 p, Ident p)+                              => (p :\/: p) wX wY -> Maybe Bool+prop_equalImpliesSameIdentity (p :\/: q)+  | IsEq <- p =\/= q = Just $ ident p == ident q+  | otherwise = Nothing
src/Darcs/Patch/Index/Monad.hs view
@@ -16,8 +16,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. --{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Darcs.Patch.Index.Monad@@ -26,7 +24,6 @@     , makePatchID     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Index.Types ( PatchMod(..), PatchId(..) )@@ -35,25 +32,30 @@ import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) ) import Control.Monad.State import Control.Arrow-import Darcs.Util.Path ( FileName, fn2fp, movedirfilename )+import Darcs.Util.Path ( AnchoredPath, anchorPath, movedirfilename, isPrefix ) import qualified Data.Set as S import Data.Set ( Set )-import Data.List ( isPrefixOf ) import Darcs.Util.Tree (Tree) -newtype FileModMonad a = FMM (State (Set FileName, [PatchMod FileName]) a)-  deriving (Functor, Applicative, Monad, MonadState (Set FileName, [PatchMod FileName]))+newtype FileModMonad a = FMM (State (Set AnchoredPath, [PatchMod AnchoredPath]) a)+  deriving ( Functor+           , Applicative+           , Monad+           , MonadState (Set AnchoredPath, [PatchMod AnchoredPath])+           ) -withPatchMods :: FileModMonad a -> Set FileName -> (Set FileName, [PatchMod FileName])+withPatchMods :: FileModMonad a+              -> Set AnchoredPath+              -> (Set AnchoredPath, [PatchMod AnchoredPath]) withPatchMods (FMM m) fps = second reverse $ execState m (fps,[])  -- These instances are defined to be used only with -- apply. instance ApplyMonad Tree FileModMonad where     type ApplyMonadBase FileModMonad = FileModMonad-    nestedApply _ _ = bug "nestedApply FileModMonad"-    liftApply _ _ = bug "liftApply FileModMonad"-    getApplyState = bug "getApplyState FileModMonad"+    nestedApply _ _ = error "nestedApply FileModMonad"+    liftApply _ _ = error "liftApply FileModMonad"+    getApplyState = error "getApplyState FileModMonad"  instance ApplyMonadTree FileModMonad where     mDoesDirectoryExist d = do@@ -62,7 +64,7 @@     mDoesFileExist f = do       fps <- gets fst       return $ S.member f fps-    mReadFilePS _ = bug "mReadFilePS FileModMonad"+    mReadFilePS _ = error "mReadFilePS FileModMonad"     mCreateFile = createFile     mCreateDirectory = createDir     mRemoveFile = remove@@ -77,7 +79,7 @@            modifyFps (S.delete a)            addFile b            forM_ (S.toList fns) $ \fn ->-             when (fn2fp a `isPrefixOf` fn2fp fn) $ do+             when (a `isPrefix` fn && a /= fn) $ do                modifyFps (S.delete fn)                let newfn = movedirfilename a b fn                addFile newfn@@ -88,44 +90,48 @@ -- --------------------------------------------------------------------- -- State Handling Functions -addMod :: PatchMod FileName -> FileModMonad ()+addMod :: PatchMod AnchoredPath -> FileModMonad () addMod pm = modify $ second (pm :) -addFile :: FileName -> FileModMonad ()+addFile :: AnchoredPath -> FileModMonad () addFile f = modifyFps (S.insert f) -createFile :: FileName -> FileModMonad ()+createFile :: AnchoredPath -> FileModMonad () createFile fn = do   errorIfPresent fn True   addMod (PCreateFile fn)   addFile fn -createDir :: FileName -> FileModMonad ()+createDir :: AnchoredPath -> FileModMonad () createDir fn = do   errorIfPresent fn False   addMod (PCreateDir fn)   addFile fn -errorIfPresent :: FileName -> Bool -> FileModMonad ()+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"-                        , fn2fp fn+                        , anchorPath "" fn                         , "created >1 times. Run `darcs repair` and try again."                         ] -remove :: FileName -> FileModMonad ()+remove :: AnchoredPath -> FileModMonad () remove f = addMod (PRemove f) >> modifyFps (S.delete f) -modifyFps :: (Set FileName -> Set FileName) -> FileModMonad ()+modifyFps :: (Set AnchoredPath -> Set AnchoredPath) -> FileModMonad () modifyFps f = modify $ first f  makePatchID :: PatchInfo -> PatchId makePatchID = PID . makePatchname  ----------------------------------------------------------------------------------- | Apply a patch to set of 'FileName's, yielding the new set of 'FileName's and 'PatchMod's-applyToFileMods :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Set FileName -> (Set FileName, [PatchMod FileName])+-- | Apply a patch to set of 'AnchoredPath's, yielding the new set of+-- 'AnchoredPath's and 'PatchMod's+applyToFileMods :: (Apply p, ApplyState p ~ Tree)+                => p wX wY+                -> Set AnchoredPath+                -> (Set AnchoredPath, [PatchMod AnchoredPath]) applyToFileMods patch = withPatchMods (apply patch)
src/Darcs/Patch/Index/Types.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveFunctor #-} -- Copyright (C) 2009-2010 Benedikt Schmidt -- -- This program is free software; you can redistribute it and/or modify@@ -18,11 +17,10 @@  module Darcs.Patch.Index.Types where -import Prelude () import Darcs.Prelude  import Darcs.Util.Hash( SHA1, sha1short, sha1zero )-import Darcs.Util.Path ( fn2fp, FileName )+import Darcs.Util.Path ( anchorPath, AnchoredPath ) import Data.Binary ( Binary(..) ) import Data.Word ( Word32 ) @@ -30,43 +28,43 @@ --   and an index. The index denotes how many files --   with the same name have been added before (and subsequently --   deleted or moved)-data FileId = FileId {cname::FileName,count::Int}+data FileId = FileId {cname::AnchoredPath,count::Int}   deriving (Eq,Show,Ord)  instance Binary FileId where-  put (FileId  rfp i) = put (rfp,i)+  put (FileId rfp i) = put (rfp,i)   get = do    (rfp,cnt) <- get    return $ FileId rfp cnt  -- | Convert FileId to string showFileId :: FileId -> String-showFileId (FileId fn i) = show i++"#"++fn2fp fn+showFileId (FileId fn i) = show i++"#"++anchorPath "." fn  -- | The PatchId identifies a patch and can be created from a PatchInfo with makePatchname newtype PatchId = PID {patchId :: SHA1}-  deriving (Show,Ord,Eq)--instance Binary PatchId where-  put (PID p) = put p-  get = PID `fmap` get+  deriving (Binary,Show,Ord,Eq)  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-                | PInvalid a         -- ^ This is an invalid patch-                                     --   e.g. there is a patch 'Move Autoconf.lhs Autoconf.lhs.in'-                                     --   where there is no Autoconf.lhs in the darcs repo-                | PDuplicateTouch a  -- ^ this is used for duplicate patches that don't-                                     --   have any effect, but we still want to keep-                                     --   track of them- deriving (Show, Eq, Functor)+data PatchMod a+  = PTouch a+  | PCreateFile a+  | PCreateDir a+  | PRename a+            a+  | PRemove a+  | PInvalid a+    -- ^ This is an invalid patch+    --   e.g. there is a patch 'Move Autoconf.lhs Autoconf.lhs.in'+    --   where there is no Autoconf.lhs in the darcs repo+  | PDuplicateTouch a+    -- ^ this is used for duplicate patches that don't+    --   have any effect, but we still want to keep+    --   track of them+  deriving (Show, Eq, Functor)  short :: PatchId -> Word32 short (PID sha1) = sha1short sha1
src/Darcs/Patch/Info.hs view
@@ -19,8 +19,8 @@     ( PatchInfo(..) -- constructor and fields exported *only for tests*     , rawPatchInfo  -- exported *only for tests*     , patchinfo-    , invertName     , addJunk+    , replaceJunk     , makePatchname     , readPatchInfo     , justName@@ -30,7 +30,6 @@     , toXml     , toXmlShort     , piDate-    , setPiDate     , piDateString     , piName     , piRename@@ -48,11 +47,10 @@     , validAuthorPS     ) where -import Prelude ( (^) ) import Darcs.Prelude  import Data.Char ( isAscii )-import System.Random ( randomRIO )+import Crypto.Random ( seedNew, seedToInteger ) import Numeric ( showHex ) import Control.Monad ( when, unless, void ) @@ -62,9 +60,9 @@     , unlinesPS     , unpackPSFromUTF8     )-import qualified Darcs.Patch.ReadMonads as RM ( take )-import Darcs.Patch.ReadMonads as RM ( skipSpace, char,-                                      takeTill, anyChar, ParserM,+import qualified Darcs.Util.Parser as RM ( take )+import Darcs.Util.Parser as RM ( skipSpace, char,+                                      takeTill, anyChar, Parser,                                       option,                                       takeTillChar,                                       linesStartingWithEndingWith)@@ -87,21 +85,67 @@ import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Show ( appPrec ) --- | A PatchInfo value contains the metadata of a patch. The date, name, author--- and log fields are UTF-8 encoded text in darcs 2.4 and later, and just--- sequences of bytes (decoded with whatever is the locale when displayed) in--- earlier darcs.------ The members with names that start with '_' are not supposed to be used--- directly in code that does not care how the patch info is stored.-data PatchInfo = PatchInfo { _piDate    :: !B.ByteString-                           , _piName    :: !B.ByteString-                           , _piAuthor  :: !B.ByteString-                           , _piLog     :: ![B.ByteString]-                           , isInverted :: !Bool-                           }-                 deriving (Eq,Ord)+import Darcs.Test.TestOnly ( TestOnly ) +{- |+A PatchInfo value contains the metadata of a patch. The date, name, author+and log fields are UTF-8 encoded text in darcs 2.4 and later, and just+sequences of bytes (decoded with whatever is the locale when displayed) in+earlier darcs.++The members with names that start with '_' are not supposed to be used+directly in code that does not care how the patch info is stored.++@_piLegacyIsInverted@:++Historically, the @isInverted@ flag was used to indicate that a Named patch+was inverted.++We no longer support direct inversion of 'Darcs.Patch.Named.Named' patches,+except sometimes via the 'Darcs.Patch.Invertible.Invertible' wrapper which+tracks inversion in the wrapper.++However, going even further back in time, inverted patches could be written+out by @darcs rollback@. This was changed in 2008 so any patches on disk+with this flag set would have been written by a darcs from prior to then.+As they still exist, including in the darcs repository itself, we need+to support them.++As far as current darcs is concerned, the flag should be treated like any+other field in 'PatchInfo' apart from never being set freshly:++ - There is no semantic relationship between a 'PatchInfo' with+   @piLegacyIsInverted = False@ and the same 'PatchInfo' with+   @piLegacyIsInverted = True@. For example they are not inverses of each+   other.++- New or amended patches should never be written out with+  @_piLegacyIsInverted = True@.++ - We do need to maintain backwards compatibility so we take care to+   preserve things like the hash, on-disk format etc.++- A patch with @_piLegacyIsInverted = True@ should work with all the+  normal darcs operations.++The flag is completely separate and orthogonal to the tracking of+explicit inversion in the 'Darcs.Patch.Invertible.Invertible' wrapper.+The 'Darcs.Patch.Invertible.Invertible' wrapper+is only used in memory and never stored to disk so there should be no+confusion when reading a patch from disk. Within the codebase they+serve completely different purposes and should not interact at all.+-}+data PatchInfo =+  PatchInfo { _piDate    :: !B.ByteString+            , _piName    :: !B.ByteString+            , _piAuthor  :: !B.ByteString+            , _piLog     :: ![B.ByteString]+              -- | See the long description of this field in the+              -- docs above.+            , _piLegacyIsInverted :: !Bool+            }+  deriving (Eq,Ord)+ instance Show PatchInfo where     showsPrec d (PatchInfo date name author log inverted) =         showParen (d > appPrec) $@@ -138,13 +182,19 @@ validAuthorPS :: B.ByteString -> Bool validAuthorPS = BC.notElem '*' -rawPatchInfo :: String -> String -> String -> [String] -> Bool -> PatchInfo-rawPatchInfo date name author log inverted =+rawPatchInfo+  :: TestOnly+  => String -> String -> String -> [String] -> Bool -> PatchInfo+rawPatchInfo = rawPatchInfoInternal++rawPatchInfoInternal :: String -> String -> String -> [String] -> Bool -> PatchInfo+rawPatchInfoInternal date name author log inverted =     PatchInfo { _piDate     = BC.pack $ validateDate date               , _piName     = packStringToUTF8 $ validateName name               , _piAuthor   = packStringToUTF8 $ validateAuthor author               , _piLog      = map (packStringToUTF8 . validateLog) log-              , isInverted  = inverted }+              , _piLegacyIsInverted  = inverted+              }   where     validateAuthor = validate validAuthor "author"     validateName = validate validLog "patch name"@@ -159,13 +209,14 @@ -- the date string's sanity. patchinfo :: String -> String -> String -> [String] -> IO PatchInfo patchinfo date name author log =-    addJunk $ rawPatchInfo date name author log False+    addJunk $ rawPatchInfoInternal date name author log False  -- | addJunk adds a line that contains a random number to make the patch --   unique. addJunk :: PatchInfo -> IO PatchInfo addJunk pinf =-    do x <- randomRIO (0,2^(128 ::Integer) :: Integer)+    do x <- seedToInteger <$> seedNew+       -- Note: this is now 40 bytes long compare to the 32 we had before        when (_piLog pinf /= ignoreJunk (_piLog pinf)) $             do putStrLn $ "Lines beginning with 'Ignore-this: ' " ++                           "will not be shown when displaying a patch."@@ -174,6 +225,9 @@        return $ pinf { _piLog = BC.pack (head ignored++showHex x ""):                                  _piLog pinf } +replaceJunk :: PatchInfo -> IO PatchInfo+replaceJunk pi@(PatchInfo {_piLog=log}) = addJunk $ pi{_piLog = ignoreJunk log}+ ignored :: [String] -- this is a [String] so we can change the junk header. ignored = ["Ignore-this: "] @@ -184,13 +238,14 @@   -- * Patch info formatting-invertName :: PatchInfo -> PatchInfo-invertName pi = pi { isInverted = not (isInverted pi) } --- | Get the name, including an "UNDO: " prefix if the patch is inverted.+-- | Get the name, including an "UNDO: " prefix if the patch is+-- a legacy inverted patch. justName :: PatchInfo -> String-justName pinf = if isInverted pinf then "UNDO: " ++ nameString-                                     else nameString+justName pinf =+  if _piLegacyIsInverted pinf+    then "UNDO: " ++ nameString+    else nameString   where nameString = metadataToString (_piName pinf)  -- | Returns the author of a patch.@@ -210,10 +265,10 @@   where hfn x = case piTag pi of                 Nothing -> inverted <+> text x                 Just t -> text "  tagged" <+> text t-        inverted = if isInverted pi then text "  UNDO:" else text "  *"+        inverted = if _piLegacyIsInverted pi then text "  UNDO:" else text "  *"  -- | Returns the name of the patch. Unlike 'justName', it does not preprend---   "UNDO: " to the name if the patch is inverted.+--   "UNDO: " to the name if the patch has the legacy inverted flag set. piName :: PatchInfo -> String piName = metadataToString . _piName @@ -240,9 +295,6 @@ piDateString :: PatchInfo -> String piDateString = BC.unpack . _piDate -setPiDate :: String -> PatchInfo -> PatchInfo-setPiDate date pi = pi { _piDate = BC.pack date }- -- | Get the log message of a patch. piLog :: PatchInfo -> [String] piLog = map metadataToString . ignoreJunk . _piLog@@ -282,7 +334,7 @@     <+> text "author='" <> escapeXMLByteString (_piAuthor pi) <> text "'"     <+> text "date='" <> escapeXMLByteString (_piDate pi) <> text "'"     <+> text "local_date='" <> escapeXML (friendlyD $ _piDate pi) <> text "'"-    <+> text "inverted='" <> text (show $ isInverted pi) <> text "'"+    <+> text "inverted='" <> text (show $ _piLegacyIsInverted pi) <> text "'"     <+> text "hash='" <> text (show $ makePatchname pi) <> text "'>"     $$  indent abstract     $$  text "</patch>"@@ -329,8 +381,9 @@                                      else B.cons (B.head bs)                                                  (bstrReplace c s (B.tail bs)) --- | Hash on patch metadata (patch name, author, date, log, and \"inverted\"--- flag. Robust against context changes but does not garantee patch contents.+-- | Hash on patch metadata (patch name, author, date, log, and the legacy+-- \"inverted\" flag.+-- Robust against context changes but does not guarantee patch contents. -- Usually used as matcher or patch identifier (see Darcs.Patch.Match). makePatchname :: PatchInfo -> SHA1 makePatchname pi = sha1PS sha1_me@@ -340,7 +393,7 @@                                   _piAuthor pi,                                   _piDate pi,                                   B.concat $ _piLog pi,-                                  b2ps $ isInverted pi]+                                  b2ps $ _piLegacyIsInverted pi]   showPatchInfo :: ShowPatchFor -> PatchInfo -> Doc@@ -365,7 +418,7 @@     blueText "[" <> packedString (_piName pi)  $$ packedString (_piAuthor pi) <> text inverted <> packedString (_piDate pi)                                  <> myunlines (_piLog pi) <> blueText "] "-    where inverted = if isInverted pi then "*-" else "**"+    where inverted = if _piLegacyIsInverted pi then "*-" else "**"           myunlines [] = empty           myunlines xs =               foldr (\s -> ((text "\n " <> packedString s) <>)) (text "\n") xs@@ -380,7 +433,7 @@ -- > ] -- -- See 'showPatchInfo' for the inverse operation.-readPatchInfo :: ParserM m => m PatchInfo+readPatchInfo :: Parser PatchInfo readPatchInfo = do   skipSpace   char '['@@ -395,5 +448,5 @@                    , _piName = name                    , _piAuthor = author                    , _piLog = log-                   , isInverted = BC.index s2 1 /= '*'+                   , _piLegacyIsInverted = BC.index s2 1 /= '*'                    }
src/Darcs/Patch/Inspect.hs view
@@ -3,17 +3,24 @@        )        where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Witnesses.Ordered ( FL, RL, reverseRL, mapFL )+import Darcs.Util.Path ( AnchoredPath )  import qualified Data.ByteString.Char8 as BC import Data.List ( nub ) +-- TODO Whether a patch touches a given file is not an invariant property of a+-- patch: it depends on the context i.e. it changes when we re-order patches.+-- Can we define an interface where this becomes an invariant property? +-- TODO This interface only makes sense if @ApplyState p ~ Tree@. To support+-- other ApplyStates we need to devise an abstraction for "objects" of the+-- ApplyState.+ class PatchInspect p where-    listTouchedFiles :: p wX wY -> [FilePath]+    listTouchedFiles :: p wX wY -> [AnchoredPath]     hunkMatches :: (BC.ByteString -> Bool) -> p wX wY -> Bool  instance PatchInspect p => PatchInspect (FL p) where
src/Darcs/Patch/Invert.hs view
@@ -1,15 +1,17 @@ module Darcs.Patch.Invert-       ( Invert(..), invertFL, invertRL+       ( Invert(..), invertFL, invertRL, dropInverses        )        where -import Prelude () import Darcs.Prelude  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:+--+-- prop> invert . invert = id class Invert p where     invert :: p wX wY -> p wY wX @@ -29,3 +31,13 @@  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
@@ -0,0 +1,112 @@+{- | Formal inverses for patches that aren't really invertible. Note that+most the mixed {'Fwd','Rev'} cases for 'Commute' and 'Eq2' are just errors.+-}+module Darcs.Patch.Invertible+    ( Invertible+    , mkInvertible+    , fromPositiveInvertible+    , withInvertible+    ) where++import Darcs.Prelude++import Darcs.Patch.CommuteFn ( invertCommuter )+import Darcs.Patch.Ident+  ( Ident(..), PatchId, SignedId(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.RepoPatch+    ( Apply(..)+    , Commute(..)+    , Eq2(..)+    , PrimPatchBase(..)+    , PatchInspect(..)+    , ShowContextPatch(..)+    , ShowPatch(..)+    , ShowPatchBasic(..)+    )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Patch.Witnesses.Ordered ((:>)(..))++-- | Wrapper type to allow formal inversion of patches which aren't really+-- invertible.+data Invertible p wX wY where+   Fwd :: p wX wY -> Invertible p wX wY+   Rev :: p wX wY -> Invertible p wY wX++-- | Wrap a patch to make it (formally) 'Invertible'. The result is initially+-- positive i.e. 'Fwd'.+mkInvertible :: p wX wY -> Invertible p wX wY+mkInvertible = Fwd++-- | Get the underlying patch from an 'Invertible', assuming (as a precondition)+-- that it is positive i.e. 'Fwd'.+fromPositiveInvertible :: Invertible p wX wY -> p wX wY+fromPositiveInvertible (Fwd p) = p+fromPositiveInvertible (Rev _) = error "precondition of fromPositiveInvertible"++-- | Run a function on the patch inside an 'Invertible'. The function has to be+-- parametric in the witnesses, so we can run it with both a 'Fwd' and a 'Rev'+-- patch.+withInvertible :: (forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r+withInvertible f (Fwd p) = f p+withInvertible f (Rev p) = f p++instance Invert (Invertible p) where+  invert (Fwd p) = Rev p+  invert (Rev p) = Fwd p++instance Commute p => Commute (Invertible p) where+  commute (Fwd p :> Fwd q) = do+    q' :> p' <- commute (p :> q)+    return (Fwd q' :> Fwd p')+  commute pair@(Rev _ :> Rev _) = invertCommuter commute pair+  commute _ = error "cannote commute mixed Fwd/Rev"++instance Eq2 p => Eq2 (Invertible p) where+  Fwd p =\/= Fwd q = p =\/= q+  Rev p =\/= Rev q = p =/\= q+  _ =\/= _ = error "cannot compare mixed Fwd/Rev"++instance Apply p => Apply (Invertible p) where+  type ApplyState (Invertible p) = ApplyState p+  apply (Fwd p) = apply p+  apply (Rev p) = unapply p+  unapply (Fwd p) = unapply p+  unapply (Rev p) = apply p++data InvertibleId ident = InvertibleId Bool ident+  deriving (Eq, Ord)++instance Ord ident => SignedId (InvertibleId ident) where+  positiveId (InvertibleId inverted _) = inverted+  invertId (InvertibleId inverted theid) =+     InvertibleId (not inverted) theid++type instance PatchId (Invertible p) = InvertibleId (PatchId p)++instance Ident p => Ident (Invertible p) where+  ident (Fwd p) = InvertibleId False (ident p)+  ident (Rev p) = InvertibleId True  (ident p)++instance PatchInspect p => PatchInspect (Invertible p) where+  listTouchedFiles (Fwd p) = listTouchedFiles p+  listTouchedFiles (Rev p) = listTouchedFiles p+  hunkMatches f (Fwd p) = hunkMatches f p+  hunkMatches f (Rev p) = hunkMatches f p++instance PrimPatchBase p => PrimPatchBase (Invertible p) where+  type PrimOf (Invertible p) = PrimOf p++instance ShowPatchBasic p => ShowPatchBasic (Invertible p) where+  showPatch ForStorage = error "Invertible patches must not be stored"+  showPatch ForDisplay = withInvertible (showPatch ForDisplay)++instance ShowPatch p => ShowPatch (Invertible p) where+  -- note these are only used for display+  description = withInvertible description+  summary = withInvertible summary+  content = withInvertible content++instance ShowContextPatch p => ShowContextPatch (Invertible p) where+  showContextPatch ForStorage = error "Invertible patches must not be stored"+  showContextPatch ForDisplay = withInvertible (showContextPatch ForDisplay)
src/Darcs/Patch/Match.hs view
@@ -15,8 +15,6 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}- -- | /First matcher, Second matcher and Nonrange matcher/ -- -- When we match for patches, we have a PatchSet, of which we want a@@ -35,43 +33,40 @@ -- options. The patches we want would then be the ones that all -- present matchers have in common. --+-- Alternatively, match flags can also be understood as a 'patchSetMatch'.+-- This (ab-)uses match flags that normally denote a 'nonrangeMatcher',+-- (additionally including the 'OneIndex' flag --index=n), to denote+-- selection of a full 'PatchSet' up to the latest matching patch. This+-- works similar to 'secondMatcher' except for tag matches, which in this+-- case mean to select only the tag and all its dependencies. In other+-- words, the tag will be clean in the resulting 'PatchSet'.+-- -- (Implementation note: keep in mind that the PatchSet is written -- backwards with respect to the timeline, ie., from right to left) module Darcs.Patch.Match-    (-      matchParser-    , helpOnMatchers-    , addInternalMatcher+    ( helpOnMatchers     , matchFirstPatchset     , matchSecondPatchset     , splitSecondFL-    , matchPatch     , matchAPatch-    , getNonrangeMatchS+    , rollbackToPatchSetMatch     , firstMatch     , secondMatch     , haveNonrangeMatch-    , haveNonrangeExplicitMatch-    , havePatchsetMatch+    , PatchSetMatch(..)+    , patchSetMatch     , checkMatchSyntax-    , applyInvToMatcher-    , nonrangeMatcher-    , InclusiveOrExclusive(..)-    , matchExists-    , applyNInv     , hasIndexRange     , getMatchingTag     , matchAPatchset-    , getFirstMatchS-    , nonrangeMatcherIsTag     , MatchFlag(..)+    , matchingHead+    , Matchable+    , MatchableRP     ) where -import Prelude () import Darcs.Prelude -import Control.Exception ( throw )- import Text.ParserCombinators.Parsec     ( parse     , CharParser@@ -96,119 +91,120 @@     , buildExpressionParser     ) import Text.Regex ( mkRegex, matchRegex )++import Control.Exception ( Exception, throw ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafePerformIO )-import Control.Monad ( when ) import Data.List ( isPrefixOf, intercalate ) import Data.Char ( toLower )+import Data.Typeable ( Typeable )  import Darcs.Util.Path ( AbsolutePath ) import Darcs.Patch     ( IsRepoType     , hunkMatches     , listTouchedFiles-    , invert-    , invertRL-    , apply     ) import Darcs.Patch.Info ( justName, justAuthor, justLog, makePatchname,-                          piDate )-import Darcs.Patch.Named.Wrapped-    ( WrappedNamed-    , patch2patchinfo-    )+                          piDate, piTag )  import qualified Data.ByteString.Char8 as BC -import Darcs.Patch.Dummy ( DummyPatch )--import Darcs.Patch.Matchable ( Matchable )-import Darcs.Patch.MonadProgress ( MonadProgress )-import Darcs.Patch.Named.Wrapped ( runInternalChecker, namedIsInternal, namedInternalChecker )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, conscientiously, hopefully )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, patchSet2RL, Origin )-import Darcs.Patch.Type ( PatchType(..) )-import Darcs.Patch.Apply( Apply, ApplyState )-import Darcs.Patch.ApplyPatches( applyPatches )-import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag )-import Darcs.Patch.Invert( Invert )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, conscientiously )+import Darcs.Patch.Set+    ( Origin+    , PatchSet(..)+    , SealedPatchSet+    , Tagged(..)+    , patchSetDrop+    )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Depends ( splitOnTag, contextPatches )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Inspect ( PatchInspect ) -import Darcs.Patch.Witnesses.Eq ( isIsEq )-import Darcs.Patch.Witnesses.Ordered ( RL(..), snocRLSealed, FL(..), (:>)(..) )+import Darcs.Patch.Witnesses.Ordered+    ( RL(..), FL(..), (:>)(..), reverseRL, mapRL, (+<+) ) import Darcs.Patch.Witnesses.Sealed-    ( FlippedSeal(..), Sealed2(..),-    seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )+    ( Sealed2(..), seal, seal2, unseal2, unseal ) import Darcs.Util.Printer ( text, ($$) ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )  import Darcs.Util.DateMatcher ( parseDateMatcher )-+import Darcs.Util.Path ( anchorPath ) import Darcs.Util.Tree ( Tree ) +-- | Patches that can be matched.+type Matchable p =+  ( Apply p+  , PatchInspect p+  , Ident p+  , PatchId p ~ PatchInfo+  )++-- | Constraint for a patch type @p@ that ensures @'PatchInfoAnd' rt p@+-- is 'Matchable'.+type MatchableRP p =+  ( Apply p+  , Commute p+  , PatchInspect p+  )+ -- | A type for predicates over patches which do not care about -- contexts-type MatchFun rt p = Sealed2 (PatchInfoAnd rt p) -> Bool+data MatchFun = MatchFun (forall p. Matchable p => Sealed2 p -> Bool)  -- | A @Matcher@ is made of a 'MatchFun' which we will use to match -- patches and a @String@ representing it.-data Matcher rt p = MATCH String (MatchFun rt p)+data Matcher = MATCH String MatchFun -instance Show (Matcher rt p) where+instance Show Matcher where     show (MATCH s _) = '"':s ++ "\"" --data MatchFlag =-                 OnePattern      String-               | SeveralPattern  String-               | AfterPattern    String-               | UpToPattern     String-               | OnePatch        String-               | OneHash         String-               | AfterHash       String-               | UpToHash        String-               | SeveralPatch    String-               | AfterPatch      String-               | UpToPatch       String-               | OneTag          String-               | AfterTag        String-               | UpToTag         String-               | LastN           Int-               | PatchIndexRange Int Int-               | Context AbsolutePath-                 deriving ( Show )-+data MatchFlag+    = OnePattern String+    | SeveralPattern String+    | AfterPattern String+    | UpToPattern String+    | OnePatch String+    | SeveralPatch String+    | AfterPatch String+    | UpToPatch String+    | OneHash String+    | AfterHash String+    | UpToHash String+    | OneTag String+    | AfterTag String+    | UpToTag String+    | LastN Int+    | OneIndex Int+    | IndexRange Int Int+    | Context AbsolutePath+    deriving (Show) -makeMatcher :: String -> MatchFun rt p -> Matcher rt p+makeMatcher :: String -> MatchFun -> Matcher makeMatcher = MATCH  -- | @applyMatcher@ applies a matcher to a patch.-applyMatcher :: Matcher rt p -> PatchInfoAnd rt p wX wY -> Bool-applyMatcher (MATCH _ m) = m . seal2+applyMatcher :: Matchable p => Matcher -> p wX wY -> Bool+applyMatcher (MATCH _ (MatchFun m)) = m . seal2 -parseMatch :: Matchable p => String -> Either String (MatchFun rt p)+parseMatch :: String -> Either String Matcher parseMatch pattern =     case parse matchParser "match" pattern of     Left err -> Left $ "Invalid --match pattern '"++ pattern ++                 "'.\n"++ unlines (map ("    "++) $ lines $ show err) -- indent-    Right m -> Right m+    Right m -> Right (makeMatcher pattern m) -matchPattern :: Matchable p => String -> Matcher rt p+matchPattern :: String -> Matcher matchPattern pattern =     case parseMatch pattern of     Left err -> error err-    Right m -> makeMatcher pattern m--addInternalMatcher :: (IsRepoType rt) => Maybe (Matcher rt p) -> Maybe (Matcher rt p)-addInternalMatcher om =-  case namedInternalChecker of-    Nothing -> om-    Just f ->-         let matchFun = unseal2 (not . isIsEq . runInternalChecker f . hopefully)-         in case om of-            Nothing -> Just (MATCH "internal patch" matchFun)-            Just (MATCH s oldFun) -> Just (MATCH s (\p -> matchFun p && oldFun p))+    Right m -> m -matchParser :: Matchable p => CharParser st (MatchFun rt p)+matchParser :: CharParser st MatchFun matchParser = submatcher <?> helpfulErrorMsg   where     submatcher = do@@ -222,19 +218,16 @@                       ++ intercalate ", " (map (\(name, _, _, _, _) -> name) ps)                       ++ "\nfor more help, see `darcs help patterns`." -    -- This type signature is just to bind an ambiguous type var.-    ps :: [(String, String, String, [String], String -> MatchFun rt DummyPatch)]     ps = primitiveMatchers      -- matchAnyPatch is returned if submatch fails without consuming any     -- input, i.e. if we pass --match '', we want to match anything.-    matchAnyPatch :: MatchFun rt p-    matchAnyPatch = const True+    matchAnyPatch = MatchFun (const True) -submatch :: Matchable p => CharParser st (MatchFun rt p)+submatch :: CharParser st MatchFun submatch = buildExpressionParser table match -table :: OperatorTable Char st (MatchFun rt p)+table :: OperatorTable Char st MatchFun table   = [ [prefix "not" negate_match,              prefix "!" negate_match ]           , [binary "||" or_match,@@ -247,20 +240,20 @@           tryNameAndUseFun name fun = do _ <- trystring name                                          spaces                                          return fun-          negate_match a p = not (a p)-          or_match m1 m2 p = m1 p || m2 p-          and_match m1 m2 p = m1 p && m2 p+          negate_match (MatchFun m) = MatchFun $ \p -> not (m p)+          or_match (MatchFun m1) (MatchFun m2) = MatchFun $ \p -> m1 p || m2 p+          and_match (MatchFun m1) (MatchFun m2) = MatchFun $ \p -> m1 p && m2 p  trystring :: String -> CharParser st String trystring s = try $ string s -match :: Matchable p => CharParser st (MatchFun rt p)+match :: CharParser st MatchFun match = between spaces spaces (parens submatch <|> choice matchers_)   where     matchers_ = map createMatchHelper primitiveMatchers -createMatchHelper :: (String, String, String, [String], String -> MatchFun rt p)-                  -> CharParser st (MatchFun rt p)+createMatchHelper :: (String, String, String, [String], String -> MatchFun)+                  -> CharParser st MatchFun createMatchHelper (key,_,_,_,matcher) =   do _ <- trystring key      spaces@@ -279,29 +272,28 @@    "complement (not), conjunction (and) and disjunction (or) operators.",    "The C notation for logic operators (!, && and ||) can also be used.",    "",-   "- --patches=regex is a synonym for --matches='name regex'",-   "- --hash=HASH is a synonym for --matches='hash HASH'",-   "- --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...",-   "- --from-patch and --to-match can be unproblematically combined:",-   "  `darcs log --from-patch='html.*documentation' --to-match='date 20040212'`",+   "    --patches=regex is a synonym for --matches='name regex'",+   "    --hash=HASH is a synonym for --matches='hash HASH'",+   "    --from-patch and --to-patch are synonyms for",+   "      --from-match='name... and --to-match='name...",+   "    --from-patch and --to-match can be unproblematically combined:",+   "      `darcs log --from-patch='html.*docu' --to-match='date 20040212'`",    "",    "The following primitive Boolean expressions are supported:"    ,""]   ++ keywords   ++ ["", "Here are some examples:", ""]   ++ examples-  where -- This type signature exists to appease GHC.-        ps :: [(String, String, String, [String], String -> MatchFun rt DummyPatch)]-        ps = primitiveMatchers+  where ps = primitiveMatchers         keywords = [showKeyword (unwords [k,a]) d | (k,a,d,_,_) <- ps]         examples = [showExample k e | (k,_,_,es,_) <- ps, e <- es]         showKeyword keyword description =-            "  " ++ keyword ++ " - " ++ description ++ "."+            "    " ++ keyword ++ " - " ++ description ++ "."         showExample keyword example =-            "  darcs log --match "+            "    darcs log --match "             ++ "'" ++ keyword ++ " " ++ example ++ "'" -primitiveMatchers :: Matchable p => [(String, String, String, [String], String -> MatchFun rt p)]+primitiveMatchers :: [(String, String, String, [String], String -> MatchFun)]                      -- ^ keyword (operator), argument name, help description, list                      -- of examples, matcher function primitiveMatchers =@@ -330,8 +322,8 @@           , ["src/foo.c", "src/", "\"src/*.(c|h)\""]           , touchmatch ) ] -parens :: CharParser st (MatchFun rt p)-       -> CharParser st (MatchFun rt p)+parens :: CharParser st MatchFun+       -> CharParser st MatchFun parens = between (string "(") (string ")")  quoted :: CharParser st String@@ -343,145 +335,113 @@          <|> between spaces spaces (many $ noneOf " ()")          <?> "string" -datematch, hashmatch, authormatch, exactmatch, namematch, logmatch-  :: String -> MatchFun rt p--hunkmatch, touchmatch-  :: Matchable p => String -> MatchFun rt p--namematch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp)--exactmatch r (Sealed2 hp) = r == justName (info hp)+datematch, hashmatch, authormatch, exactmatch, namematch, logmatch,+  hunkmatch, touchmatch :: String -> MatchFun -authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ justAuthor (info hp)+namematch r =+  MatchFun $ \(Sealed2 hp) ->+    isJust $ matchRegex (mkRegex r) $ justName (ident hp) -logmatch l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp)+exactmatch r = MatchFun $ \(Sealed2 hp) -> r == justName (ident hp) -hunkmatch r (Sealed2 hp) = let regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack-                           in hunkMatches regexMatcher hp+authormatch a =+  MatchFun $ \(Sealed2 hp) ->+    isJust $ matchRegex (mkRegex a) $ justAuthor (ident hp) -hashmatch h (Sealed2 hp) = let rh = show $ makePatchname (info hp)-                               lh = map toLower h-                           in (lh `isPrefixOf` rh) || (lh == rh ++ ".gz")+logmatch l =+  MatchFun $ \(Sealed2 hp) ->+    isJust $ matchRegex (mkRegex l) $ justLog (ident hp) -datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d-                                  in dm $ piDate (info hp)+hunkmatch r =+  MatchFun $ \(Sealed2 hp) ->+    let regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack+     in hunkMatches regexMatcher hp -touchmatch r (Sealed2 hp) = let files = listTouchedFiles hp-                            in any (isJust . matchRegex (mkRegex r)) files+hashmatch h =+  MatchFun $ \(Sealed2 hp) ->+    let rh = show $ makePatchname (ident hp)+        lh = map toLower h+     in (lh `isPrefixOf` rh) || (lh == rh ++ ".gz") -data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq+datematch d =+  MatchFun $ \(Sealed2 hp) ->+    let dm = unsafePerformIO $ parseDateMatcher d+     in dm $ piDate (ident hp) -data IncludeInternalPatches = IncludeInternalPatches | ExcludeInternalPatches-                              deriving Eq+touchmatch r =+  MatchFun $ \(Sealed2 hp) ->+    let files = listTouchedFiles hp+     in any (isJust . matchRegex (mkRegex r)) (map (anchorPath ".") files)  -- | @haveNonrangeMatch flags@ tells whether there is a flag in -- @flags@ which corresponds to a match that is "non-range". Thus,--- @--match@, @--patch@, @--hash@ and @--index@ make @haveNonrangeMatch@+-- @--match@, @--patch@, and @--hash@ make @haveNonrangeMatch@ -- true, but not @--from-patch@ or @--to-patch@.-haveNonrangeMatch :: forall rt p . (IsRepoType rt, Matchable p)-                  => PatchType rt p -> [MatchFlag] -> Bool-haveNonrangeMatch pt fs = haveNonrangeMatch' IncludeInternalPatches pt fs---- | @haveNonrangeExplicitMatch flags@ is just like @haveNonrangeMatch flags@,--- but ignores "internal matchers" used to mask "internal patches"-haveNonrangeExplicitMatch :: forall rt p . (IsRepoType rt, Matchable p)-                          => PatchType rt p -> [MatchFlag] -> Bool-haveNonrangeExplicitMatch pt fs = haveNonrangeMatch' ExcludeInternalPatches pt fs--haveNonrangeMatch' :: forall rt p . (IsRepoType rt, Matchable p)-                   => IncludeInternalPatches -> PatchType rt p -> [MatchFlag] -> Bool-haveNonrangeMatch' i _ fs =-     case hasIndexRange fs of Just (m,n) | m == n -> True; _ -> False-  || isJust (nonrangeMatch::Maybe (Matcher rt p))-    where-     nonrangeMatch | i == IncludeInternalPatches = nonrangeMatcher fs-                   | otherwise = nonrangeMatcherArgs fs+haveNonrangeMatch :: [MatchFlag] -> Bool+haveNonrangeMatch fs = isJust (nonrangeMatcher fs) --- | @havePatchsetMatch flags@ tells whether there is a "patchset--- match" in the flag list. A patchset match is @--match@ or--- @--patch@, or @--context@, but not @--from-patch@ nor (!)--- @--index@.--- Question: Is it supposed not to be a subset of @haveNonrangeMatch@?-havePatchsetMatch-  :: forall rt p-   . (IsRepoType rt, Matchable p)-  => PatchType rt p -> [MatchFlag] -> Bool-havePatchsetMatch _ fs = isJust (nonrangeMatcher fs::Maybe (Matcher rt p)) || hasC fs-    where hasC [] = False-          hasC (Context _:_) = True-          hasC (_:xs) = hasC xs+data PatchSetMatch+  = IndexMatch Int+  | PatchMatch Matcher+  | TagMatch Matcher+  | ContextMatch AbsolutePath -getNonrangeMatchS :: ( ApplyMonad (ApplyState p) m, MonadProgress m-                     , IsRepoType rt, Matchable p, ApplyState p ~ Tree-                     )-                  => [MatchFlag]-                  -> PatchSet rt p Origin wX-                  -> m ()-getNonrangeMatchS fs repo =-    case nonrangeMatcher fs of-        Just m -> if nonrangeMatcherIsTag fs-                        then getTagS m repo-                        else getMatcherS Exclusive m repo-        Nothing -> throw $ userError "Pattern not specified in getNonrangeMatch."+patchSetMatch :: [MatchFlag] -> Maybe PatchSetMatch+patchSetMatch [] = Nothing+patchSetMatch (OneTag t:_) = strictJust $ TagMatch $ tagmatch t+patchSetMatch (OnePattern m:_) = strictJust $ PatchMatch $ matchPattern m+patchSetMatch (OnePatch p:_) = strictJust $ PatchMatch $ patchmatch p+patchSetMatch (OneHash h:_) = strictJust $ PatchMatch $ hashmatch' h+patchSetMatch (OneIndex n:_) = strictJust $ IndexMatch n+patchSetMatch (Context p:_) = strictJust $ ContextMatch p+patchSetMatch (_:fs) = patchSetMatch fs  -- | @firstMatch fs@ tells whether @fs@ implies a "first match", that -- is if we match against patches from a point in the past on, rather -- than against all patches since the creation of the repository. firstMatch :: [MatchFlag] -> Bool firstMatch fs = isJust (hasLastn fs)-                 || isJust (firstMatcher fs::Maybe (Matcher rt DummyPatch))+                 || isJust (firstMatcher fs)                  || isJust (hasIndexRange fs) -getFirstMatchS :: (ApplyMonad (ApplyState p) m, MonadProgress m, Matchable p, IsRepoType rt)-               => [MatchFlag] -> PatchSet rt p Origin wX -> m ()-getFirstMatchS fs repo =-    case hasLastn fs of-    Just n -> unpullLastN repo n-    Nothing ->-     case hasIndexRange fs of-     Just (_,b) -> unpullLastN repo b -- b is chronologically earlier than a-     Nothing    ->-      case firstMatcher fs of-               Nothing -> throw $ userError "Pattern not specified in getFirstMatchS."-               Just m -> if firstMatcherIsTag fs-                         then getTagS m repo-                         else getMatcherS Inclusive m repo- -- | @secondMatch fs@ tells whether @fs@ implies a "second match", that -- is if we match against patches up to a point in the past on, rather -- than against all patches until now. secondMatch :: [MatchFlag] -> Bool-secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher rt DummyPatch)) || isJust (hasIndexRange fs)--unpullLastN :: (Apply p, Invert p, ApplyMonad (ApplyState p) m, MonadProgress m, IsRepoType rt)-            => PatchSet rt p wX wY-            -> Int-            -> m ()-unpullLastN repo n = applyInvRL `unsealFlipped` safetake n (patchSet2RL repo)+secondMatch fs =+  isJust (secondMatcher fs) ||+  isJust (hasIndexRange fs)  checkMatchSyntax :: [MatchFlag] -> IO () checkMatchSyntax opts =- case getMatchPattern opts of-  Nothing -> return ()-  Just p  -> either (throw . userError) (const $ return ()) (parseMatch p::Either String (MatchFun rt DummyPatch))+  case getMatchPattern opts of+    Nothing -> return ()+    Just p ->+      either+        fail+        (const $ return ())+        (parseMatch p)  getMatchPattern :: [MatchFlag] -> Maybe String getMatchPattern [] = Nothing getMatchPattern (OnePattern m:_) = Just m getMatchPattern (SeveralPattern m:_) = Just m+getMatchPattern (AfterPattern m:_) = Just m+getMatchPattern (UpToPattern m:_) = Just m getMatchPattern (_:fs) = getMatchPattern fs -tagmatch :: String -> Matcher rt p-tagmatch r = makeMatcher ("tag-name "++r) tm-    where tm (Sealed2 p) =-              let n = justName (info p) in-              "TAG " `isPrefixOf` n && isJust (matchRegex (mkRegex r) $ drop 4 n)+tagmatch :: String -> Matcher+tagmatch r = makeMatcher ("tag-name "++r) (MatchFun tm)+  where+    tm (Sealed2 p) =+      case piTag (ident p) of+        Just t -> isJust (matchRegex (mkRegex r) t)+        Nothing -> False -patchmatch :: String -> Matcher rt p+patchmatch :: String -> Matcher patchmatch r = makeMatcher ("patch-name "++r) (namematch r) -hashmatch' :: String -> Matcher rt p+hashmatch' :: String -> Matcher hashmatch' r = makeMatcher ("hash "++r) (hashmatch r)  @@ -494,32 +454,21 @@ -- | @nonrangeMatcher@ is the criterion that is used to match against -- patches in the interval. It is 'Just m' when the @--patch@, @--match@, -- @--tag@ options are passed (or their plural variants).-nonrangeMatcher :: (IsRepoType rt, Matchable p) => [MatchFlag] -> Maybe (Matcher rt p)-nonrangeMatcherArgs :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p)--nonrangeMatcher fs = addInternalMatcher $ nonrangeMatcherArgs fs--nonrangeMatcherArgs [] = Nothing-nonrangeMatcherArgs (OnePattern m:_) = strictJust $ matchPattern m-nonrangeMatcherArgs (OneTag t:_) = strictJust $ tagmatch t-nonrangeMatcherArgs (OnePatch p:_) = strictJust $ patchmatch p-nonrangeMatcherArgs (OneHash h:_) = strictJust $ hashmatch' h-nonrangeMatcherArgs (SeveralPattern m:_) = strictJust $ matchPattern m-nonrangeMatcherArgs (SeveralPatch p:_) = strictJust $ patchmatch p-nonrangeMatcherArgs (_:fs) = nonrangeMatcherArgs fs---- | @nonrangeMatcherIsTag@ returns true if the matching option was--- '--tag'-nonrangeMatcherIsTag :: [MatchFlag] -> Bool-nonrangeMatcherIsTag [] = False-nonrangeMatcherIsTag (OneTag _:_) = True-nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs+nonrangeMatcher :: [MatchFlag] -> Maybe Matcher+nonrangeMatcher [] = Nothing+nonrangeMatcher (OnePattern m:_) = strictJust $ matchPattern m+nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t+nonrangeMatcher (OnePatch p:_) = strictJust $ patchmatch p+nonrangeMatcher (OneHash h:_) = strictJust $ hashmatch' h+nonrangeMatcher (SeveralPattern m:_) = strictJust $ matchPattern m+nonrangeMatcher (SeveralPatch p:_) = strictJust $ patchmatch p+nonrangeMatcher (_:fs) = nonrangeMatcher fs  -- | @firstMatcher@ returns the left bound of the matched interval. -- This left bound is also specified when we use the singular versions -- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@ -- returns @Nothing@.-firstMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p)+firstMatcher :: [MatchFlag] -> Maybe Matcher firstMatcher [] = Nothing firstMatcher (OnePattern m:_) = strictJust $ matchPattern m firstMatcher (AfterPattern m:_) = strictJust $ matchPattern m@@ -535,7 +484,7 @@ firstMatcherIsTag (AfterTag _:_) = True firstMatcherIsTag (_:fs) = firstMatcherIsTag fs -secondMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p)+secondMatcher :: [MatchFlag] -> Maybe Matcher secondMatcher [] = Nothing secondMatcher (OnePattern m:_) = strictJust $ matchPattern m secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m@@ -551,30 +500,16 @@ secondMatcherIsTag (UpToTag _:_) = True secondMatcherIsTag (_:fs) = secondMatcherIsTag fs --- | @matchAPatch fs p@ tells whether @p@ matches the matchers in--- the flags @fs@-matchAPatch :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchInfoAnd rt p wX wY -> Bool+-- | Whether a patch matches the given 'MatchFlag's. This should be+-- invariant under inversion:+--+-- prop> matchAPatch (invert p) = matchAPatch p+matchAPatch :: Matchable p => [MatchFlag] -> p wX wY -> Bool matchAPatch fs p =   case nonrangeMatcher fs of     Nothing -> True     Just m -> applyMatcher m p -matchPatch :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX -> Sealed2 (WrappedNamed rt p)-matchPatch fs ps =-    case hasIndexRange fs of-    Just (a,a') | a == a' -> case unseal myhead $ dropn (a-1) ps of-                             Just (Sealed2 p) -> seal2 $ hopefully p-                             Nothing -> error "Patch out of range!"-                | otherwise -> bug ("Invalid index range match given to matchPatch: "++-                                    show (PatchIndexRange a a'))-                where myhead :: PatchSet rt p wStart wX -> Maybe (Sealed2 (PatchInfoAnd rt p))-                      myhead (PatchSet (_ :<: Tagged t _ _) NilRL) = Just $ seal2 t-                      myhead (PatchSet _ (_:<:x)) = Just $ seal2 x-                      myhead _ = Nothing-    Nothing -> case nonrangeMatcher fs of-                    Nothing -> bug "Couldn't matchPatch"-                    Just m -> findAPatch m ps- -- | @hasLastn fs@ return the @--last@ argument in @fs@, if any. hasLastn :: [MatchFlag] -> Maybe Int hasLastn [] = Nothing@@ -584,156 +519,184 @@  hasIndexRange :: [MatchFlag] -> Maybe (Int,Int) hasIndexRange [] = Nothing-hasIndexRange (PatchIndexRange x y:_) = Just (x,y)+hasIndexRange (IndexRange x y:_) = Just (x,y) hasIndexRange (_:fs) = hasIndexRange fs  -- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its -- first matcher, ie the one that comes first dependencywise. Hence, -- patches in @matchFirstPatchset fs ps@ are the context for the ones -- we don't want.-matchFirstPatchset :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX-                   -> SealedPatchSet rt p wStart-matchFirstPatchset fs patchset =-    case hasLastn fs of-    Just n -> dropn n patchset-    Nothing ->-        case hasIndexRange fs of-        Just (_,b) -> dropn b patchset-        Nothing ->-               case firstMatcher fs of-               Nothing -> bug "Couldn't matchFirstPatchset"-               Just m -> unseal (dropn 1) $ if firstMatcherIsTag fs-                                            then getMatchingTag m patchset-                                            else matchAPatchset m patchset---- | @dropn n ps@ drops the @n@ last patches from @ps@.-dropn :: IsRepoType rt => Int -> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart-dropn n ps | n <= 0 = seal ps-dropn n (PatchSet (ts :<: Tagged t _ ps) NilRL) = dropn n $ PatchSet ts (ps:<:t)-dropn _ (PatchSet NilRL NilRL) = seal $ PatchSet NilRL NilRL-dropn n (PatchSet ts (ps:<:p))-    | isIsEq (namedIsInternal (hopefully p))-   = dropn n $ PatchSet ts ps-dropn n (PatchSet ts (ps:<:_)) = dropn (n-1) $ PatchSet ts ps+matchFirstPatchset :: MatchableRP p+                   => [MatchFlag] -> PatchSet rt p wStart wX+                   -> Maybe (SealedPatchSet rt p wStart)+matchFirstPatchset fs patchset+  | Just n <- hasLastn fs = Just $ patchSetDrop n patchset+  | Just (_, b) <- hasIndexRange fs = Just $ patchSetDrop b patchset+  | Just m <- firstMatcher fs =+    Just $ unseal (patchSetDrop 1) $+    if firstMatcherIsTag fs+      then getMatchingTag m patchset+      else matchAPatchset m patchset+  | otherwise = Nothing  -- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its -- second matcher, ie the one that comes last dependencywise.-matchSecondPatchset :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX-                    -> SealedPatchSet rt p wStart-matchSecondPatchset fs ps =-  case hasIndexRange fs of-  Just (a,_) -> dropn (a-1) ps-  Nothing ->-    case secondMatcher fs of-    Nothing -> bug "Couldn't matchSecondPatchset"-    Just m -> if secondMatcherIsTag fs-              then getMatchingTag m ps-              else matchAPatchset m ps+matchSecondPatchset :: MatchableRP p+                    => [MatchFlag] -> PatchSet rt p wStart wX+                    -> Maybe (SealedPatchSet rt p wStart)+matchSecondPatchset fs ps+  | Just (a, _) <- hasIndexRange fs = Just $ patchSetDrop (a - 1) ps+  | Just m <- secondMatcher fs =+    Just $+    if secondMatcherIsTag fs+      then getMatchingTag m ps+      else matchAPatchset m ps+  | otherwise = Nothing --- | Split on the second matcher. Note that this picks up the first match starting from--- the earliest patch in a sequence, as opposed to 'matchSecondPatchset' which picks up the--- first match starting from the latest patch+-- | Split on the second matcher. Note that this picks up the first match+-- starting from the earliest patch in a sequence, as opposed to+-- 'matchSecondPatchset' which picks up the first match starting from the+-- latest patch splitSecondFL :: Matchable p-              => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd rt p))+              => (forall wA wB . q wA wB -> Sealed2 p)               -> [MatchFlag]               -> FL q wX wY-              -> (FL q :> FL q) wX wY -- ^The first element is the patches before and including the first patch matching the second matcher,-                                      --  the second element is the patches after it+              -> (FL q :> FL q) wX wY -- ^The first element is the patches before+                                      --  and including the first patch matching the+                                      --  second matcher, the second element is the+                                      --  patches after it splitSecondFL extract fs ps =    case hasIndexRange fs of-   Just _ -> -- selecting the last n doesn't really make sense if we're starting from the earliest patches-             bug "index matches not supported by splitSecondPatchesFL"+   Just _ -> -- selecting the last n doesn't really make sense if we're starting+             -- from the earliest patches+             error "index matches not supported by splitSecondPatchesFL"    Nothing ->      case secondMatcher fs of-     Nothing -> bug "Couldn't splitSecondPatches"+     Nothing -> error "Couldn't splitSecondPatches"      Just m -> splitMatchFL extract m ps --- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and--- calls 'error' if there is none.-findAPatch :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX -> Sealed2 (WrappedNamed rt p)-findAPatch m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m-findAPatch m (PatchSet (ts :<: Tagged t _ ps) NilRL) = findAPatch m (PatchSet ts (ps:<:t))-findAPatch m (PatchSet ts (ps:<:p)) | applyMatcher m p = seal2 $ hopefully p-                                    | otherwise = findAPatch m (PatchSet ts ps)+splitMatchFL+  :: Matchable p+  => (forall wA wB. q wA wB -> Sealed2 p)+  -> Matcher+  -> FL q wX wY+  -> (FL q :> FL q) wX wY+splitMatchFL _extract m NilFL = error $ "Couldn't find a patch matching " ++ show m+splitMatchFL extract m (p :>: ps)+   | unseal2 (applyMatcher m) . extract $ p = (p :>: NilFL) :> ps+   | otherwise = case splitMatchFL extract m ps of+                    before :> after -> (p :>: before) :> after +-- | Using a special exception type here means that is is treated as+-- regular failure, and not as a bug in Darcs.+data MatchFailure = MatchFailure String+  deriving Typeable++instance Exception MatchFailure++instance Show MatchFailure where+  show (MatchFailure m) =+    "Couldn't find a patch matching " ++ m+ -- | @matchAPatchset m ps@ returns a prefix of @ps@ -- ending in a patch matching @m@, and calls 'error' if there is none.-matchAPatchset :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX-               -> SealedPatchSet rt p wStart-matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m-matchAPatchset m (PatchSet (ts :<: Tagged t _ ps) NilRL) = matchAPatchset m (PatchSet ts (ps:<:t))-matchAPatchset m (PatchSet ts (ps:<:p)) | applyMatcher m p = seal (PatchSet ts (ps:<:p))-                                        | otherwise = matchAPatchset m (PatchSet ts ps)+matchAPatchset+  :: MatchableRP p+  => Matcher+  -> PatchSet rt p wStart wX+  -> SealedPatchSet rt p wStart+matchAPatchset m (PatchSet NilRL NilRL) =+  throw $ MatchFailure $ show m+matchAPatchset m (PatchSet (ts :<: Tagged t _ ps) NilRL) =+  matchAPatchset m (PatchSet ts (ps :<: t))+matchAPatchset m (PatchSet ts (ps :<: p))+  | applyMatcher m p = seal (PatchSet ts (ps :<: p))+  | otherwise = matchAPatchset m (PatchSet ts ps) +splitOnMatchingTag :: MatchableRP p+                   => Matcher+                   -> PatchSet rt p wStart wX+                   -> PatchSet rt p wStart wX+splitOnMatchingTag _ s@(PatchSet NilRL NilRL) = s+splitOnMatchingTag m s@(PatchSet (ts :<: Tagged t _ ps) NilRL)+    | applyMatcher m t = s+    | otherwise = splitOnMatchingTag m (PatchSet ts (ps:<:t))+splitOnMatchingTag m (PatchSet ts (ps:<:p))+    -- found a non-clean tag, need to commute out the things that it doesn't depend on+    | applyMatcher m p =+        case splitOnTag (info p) (PatchSet ts (ps:<:p)) of+          Just x -> x+          Nothing -> error "splitOnTag failed"+    | otherwise =+        case splitOnMatchingTag m (PatchSet ts ps) of+          PatchSet ts' ps' -> PatchSet ts' (ps' :<: p)+ -- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags -- returns a 'SealedPatchSet' containing all patches in the last tag which -- matches @m@. Last tag means the most recent tag in repository order, -- i.e. the last one you'd see if you ran darcs log -t @m@. Calls -- 'error' if there is no matching tag.-getMatchingTag :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart-getMatchingTag m (PatchSet NilRL NilRL) = error $ "Couldn't find a tag matching " ++ show m-getMatchingTag m (PatchSet (ts :<: Tagged t _ ps) NilRL) = getMatchingTag m (PatchSet ts (ps:<:t))-getMatchingTag m (PatchSet ts (ps:<:p))-    | applyMatcher m p =-        -- found a non-clean tag, need to commute out the things that it doesn't depend on-        case splitOnTag (info p) (PatchSet ts (ps:<:p)) of-            Nothing -> bug "splitOnTag couldn't find tag we explicitly provided!"-            Just (patchSet :> _) -> seal patchSet-    | otherwise = getMatchingTag m (PatchSet ts ps)--splitMatchFL :: Matchable p => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd rt p)) -> Matcher rt p -> FL q wX wY -> (FL q :> FL q) wX wY-splitMatchFL _extract m NilFL = error $ "Couldn't find patch matching " ++ show m-splitMatchFL extract m (p :>: ps)-   | unseal2 (applyMatcher m) . extract $ p = (p :>: NilFL) :> ps-   | otherwise = case splitMatchFL extract m ps of-                    before :> after -> (p :>: before) :> after+getMatchingTag :: MatchableRP p+               => Matcher+               -> PatchSet rt p wStart wX+               -> SealedPatchSet rt p wStart+getMatchingTag m ps =+  case splitOnMatchingTag m ps of+    PatchSet NilRL _ -> throw $ userError $ "Couldn't find a tag matching " ++ show m+    PatchSet ps' _ -> seal $ PatchSet ps' NilRL --- | @matchExists m ps@ tells whether there is a patch matching--- @m@ in @ps@-matchExists :: Matcher rt p -> PatchSet rt p wStart wX -> Bool-matchExists _ (PatchSet NilRL NilRL) = False-matchExists m (PatchSet (ts :<: Tagged t _ ps) NilRL) = matchExists m (PatchSet ts (ps:<:t))-matchExists m (PatchSet ts (ps:<:p)) | applyMatcher m p = True-                                     | otherwise = matchExists m (PatchSet ts ps)+-- | Rollback (i.e. apply the inverse) of what remains of a 'PatchSet' after we+-- extract a 'PatchSetMatch'. This is the counterpart of 'getOnePatchset' and+-- is used to create a matching state. In particular, if the match is --index=n+-- then rollback the last (n-1) patches; if the match is --tag, then rollback+-- patches that are not depended on by the tag; otherwise rollback patches that+-- follow the latest matching patch.+rollbackToPatchSetMatch :: ( ApplyMonad (ApplyState p) m+                           , IsRepoType rt, MatchableRP p, ApplyState p ~ Tree+                           )+                        => PatchSetMatch+                        -> PatchSet rt p Origin wX+                        -> m ()+rollbackToPatchSetMatch psm repo =+  case psm of+    IndexMatch n -> applyNInv (n-1) repo+    TagMatch m ->+      case splitOnMatchingTag m repo of+        PatchSet NilRL _ -> throw $ MatchFailure $ show m+        PatchSet _ extras -> unapply extras+    PatchMatch m -> applyInvToMatcher m repo+    ContextMatch _ -> error "rollbackToPatchSetMatch: unexpected context match" -applyInvToMatcher :: (Matchable p, ApplyMonad (ApplyState p) m)-                  => InclusiveOrExclusive -> Matcher rt p -> PatchSet rt p Origin wX -> m ()-applyInvToMatcher _ _ (PatchSet NilRL NilRL) = impossible-applyInvToMatcher ioe m (PatchSet (ts :<: Tagged t _ ps) NilRL) = applyInvToMatcher ioe m-                                                                  (PatchSet ts (ps:<:t))-applyInvToMatcher ioe m (PatchSet xs (ps:<:p))-    | applyMatcher m p = when (ioe == Inclusive) (applyInvp p)-    | otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet xs ps)+-- | @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)+                  => Matcher+                  -> PatchSet rt 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 (ps :<: t))+applyInvToMatcher m (PatchSet xs (ps :<: p))+  | applyMatcher m p = return ()+  | otherwise = applyInvp p >> applyInvToMatcher m (PatchSet xs ps)  -- | @applyNInv@ n ps applies the inverse of the last @n@ patches of @ps@.-applyNInv :: (Matchable p, ApplyMonad (ApplyState p) m) => Int -> PatchSet rt p Origin wX -> m ()+applyNInv :: (IsRepoType rt, MatchableRP p, ApplyMonad (ApplyState p) m)+          => Int -> PatchSet rt p Origin wX -> m () applyNInv n _ | n <= 0 = return ()-applyNInv _ (PatchSet NilRL NilRL) = error "Index out of range."+applyNInv _ (PatchSet NilRL NilRL) = throw $ userError "Index out of range" applyNInv n (PatchSet (ts :<: Tagged t _ ps) NilRL) =   applyNInv n (PatchSet ts (ps :<: t)) applyNInv n (PatchSet xs (ps :<: p)) =   applyInvp p >> applyNInv (n - 1) (PatchSet xs ps) --getMatcherS :: (ApplyMonad (ApplyState p) m, Matchable p) =>-                 InclusiveOrExclusive -> Matcher rt p -> PatchSet rt p Origin wX -> m ()-getMatcherS ioe m repo =-    if matchExists m repo-    then applyInvToMatcher ioe m repo-    else throw $ userError $ "Couldn't match pattern "++ show m--getTagS :: (ApplyMonad (ApplyState p) m, MonadProgress m, Matchable p) =>-             Matcher rt p -> PatchSet rt p Origin wX -> m ()-getTagS matcher repo = do-    let pinfo = patch2patchinfo `unseal2` findAPatch matcher repo-    case getPatchesBeyondTag pinfo repo of-        FlippedSeal extras -> applyInvRL extras- -- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd -- patch', and to apply its inverse. If we fail to fetch the patch -- then we share our sorrow with the user.-applyInvp :: (Apply p, Invert p, ApplyMonad (ApplyState p) m) => PatchInfoAnd rt p wX wY -> m ()-applyInvp hp = apply (invert $ fromHopefully hp)+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@@ -741,12 +704,20 @@                      $$ text "If you think what you're trying to do is ok then"                      $$ text "report this as a bug on the darcs-user list." --- | a version of 'take' for 'RL' lists that cater for contexts.-safetake :: IsRepoType rt => Int -> RL (PatchInfoAnd rt p) wX wY -> FlippedSeal (RL (PatchInfoAnd rt p)) wY-safetake 0 _ = flipSeal NilRL-safetake _ NilRL = error "There aren't that many patches..."-safetake i (as:<:a) | isIsEq (namedIsInternal (hopefully a)) = safetake i as `snocRLSealed` a-safetake i (as:<:a) = safetake (i-1) as `snocRLSealed` a--applyInvRL :: (Apply p, Invert p, ApplyMonad (ApplyState p) m, MonadProgress m) => RL (PatchInfoAnd rt p) wX wR -> m ()-applyInvRL = applyPatches . invertRL -- this gives nicer feedback+-- | 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 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 s@(PatchSet _ x)+        | or (mapRL (matchAPatch matchFlags) x) = contextPatches s+    mh (PatchSet (ts :<: Tagged t _ ps) x) =+        case mh (PatchSet ts (ps :<: t)) of+            (start :> patches) -> start :> patches +<+ x+    mh ps = ps :> NilRL
− src/Darcs/Patch/Matchable.hs 
@@ -1,13 +0,0 @@---  Copyright (C) 2013 Ganesh Sittampalam------  BSD3--module Darcs.Patch.Matchable ( Matchable ) where--import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Invert ( Invert(..) )--class (Apply p, Commute p, Invert p, PatchInspect p)-    => Matchable p
src/Darcs/Patch/Merge.hs view
@@ -5,79 +5,202 @@ -- Portability : portable  module Darcs.Patch.Merge-    ( -- * Definitions-      Merge(..)+    ( -- * Classes+      CleanMerge(..)+    , Merge(..)+      -- * Functions     , selfMerger+    , swapMerger+    , mergerIdFL+    , mergerFLId+    , mergerFLFL+    , cleanMergeFL     , mergeFL-    , naturalMerge+    , swapMerge+    , swapCleanMerge+    , mergeList       -- * Properties     , prop_mergeSymmetric     , prop_mergeCommute     ) where +import Control.Monad ( foldM )++import Darcs.Prelude+ import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.CommuteFn ( MergeFn )+import Darcs.Patch.CommuteFn ( MergeFn, PartialMergeFn ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), isIsEq ) import Darcs.Patch.Witnesses.Ordered     ( (:\/:)(..)     , (:/\:)(..)     , FL(..)-    , RL     , (:>)(..)-    , reverseFL-    , reverseRL+    , (+>+)     )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) --- | Things that can always be merged.------ Instances should obey the following laws:------ * Symmetry------   prop> merge (p :\/: q) == q' :/\: p' <=> merge (q :\/: p) == p' :/\: q'------ * MergesCommute------   prop> merge (p :\/: q) == q' :/\: p' ==> commute (p :> q') == Just (q :> p')------   that is, the two branches of a merge commute to each other-class Commute p => Merge p where-    merge :: (p :\/: p) wX wY-          -> (p :/\: p) wX wY+{- | Class of patches that can, possibly, be merged cleanly, that is,+without conflict. +Every patch type can be made an instance of 'CleanMerge' in a trivial way by+defining @'cleanMerge' _ = 'Nothing'@, which vacuously conforms to all+required laws.++Instances should obey the following laws:++[/symmetry/]++    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') <=> cleanMerge (q :\/: p) == Just (p' :/\: q')++If an instance @'Commute' p@ exists, then we also require++[/merge-commute/]++    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') ==> commute (p :> q') == Just (q :> p')++    that is, the two branches of a clean merge commute to each other.++If an instance @'Invert' p@ exists, then we also require++[/square-merge/]++    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') => cleanMerge (invert p :\/: q') == Just (q :/\: invert p')++    Here is a picture that explains why we call this /square-merge/:++    >     A---p--->X          A<--p^---X+    >     |        |          |        |+    >     |        |          |        |+    >     q        q'   =>    q        q'+    >     |        |          |        |+    >     v        v          v        v+    >     Y---p'-->B          Y<--p'^--B++-}+class CleanMerge p where+  cleanMerge :: (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)++instance CleanMerge p => CleanMerge (FL p) where+  cleanMerge (NilFL :\/: x) = return $ x :/\: NilFL+  cleanMerge (x :\/: NilFL) = return $ NilFL :/\: x+  cleanMerge ((x :>: xs) :\/: ys) = do+    ys' :/\: x' <- cleanMergeFL (x :\/: ys)+    xs' :/\: ys'' <- cleanMerge (ys' :\/: xs)+    return $ ys'' :/\: (x' :>: xs')++-- | Cleanly merge a single patch with an 'FL' of patches.+cleanMergeFL :: CleanMerge p => PartialMergeFn p (FL p)+cleanMergeFL (p :\/: NilFL) = return $ NilFL :/\: p+cleanMergeFL (p :\/: (x :>: xs)) = do+  x' :/\: p'  <- cleanMerge (p :\/: x)+  xs' :/\: p'' <- cleanMergeFL (p' :\/: xs)+  return $ (x' :>: xs') :/\: p''++{- | Patches that can always be merged, even if they conflict.++Instances should obey the following laws:++[/symmetry/]++    prop> merge (p :\/: q) == q' :/\: p' <=> merge (q :\/: p) == p' :/\: q'++[/merge-commute/]++    prop> merge (p :\/: q) == q' :/\: p' ==> commute (p :> q') == Just (q :> p')++    that is, the two branches of a merge commute to each other.++[/extension/]++    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') => merge (p :\/: q) == q' :/\: p'++    that is, 'merge' is an extension of 'cleanMerge'.++-}+class CleanMerge p => Merge p where+    merge :: (p :\/: p) wX wY -> (p :/\: p) wX wY++-- | Synonym for 'merge'. selfMerger :: Merge p => MergeFn p p selfMerger = merge  instance Merge p => Merge (FL p) where-    merge (NilFL :\/: x) = x :/\: NilFL-    merge (x :\/: NilFL) = NilFL :/\: x-    merge ((x:>:xs) :\/: ys) = case mergeFL (x :\/: ys) of-      ys' :/\: x' -> case merge (ys' :\/: xs) of-        xs' :/\: ys'' -> ys'' :/\: (x' :>: xs')--instance Merge p => Merge (RL p) where-    merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of-        (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx'+    merge = mergerFLFL merge  mergeFL :: Merge p         => (p :\/: FL p) wX wY         -> (FL p :/\: p) wX wY-mergeFL (p :\/: NilFL) = NilFL :/\: p-mergeFL (p :\/: (x :>: xs)) = case merge (p :\/: x) of-    x' :/\: p' -> case mergeFL (p' :\/: xs) of+mergeFL = mergerIdFL merge++-- | Lift a merge function over @p :\/: q@+-- to a merge function over @p :\/: FL q@+mergerIdFL :: MergeFn p q -> MergeFn p (FL q)+mergerIdFL _mergeFn (p :\/: NilFL) = NilFL :/\: p+mergerIdFL  mergeFn (p :\/: (x :>: xs)) =+  case mergeFn (p :\/: x) of+    x' :/\: p' -> case mergerIdFL mergeFn (p' :\/: xs) of       xs' :/\: p'' -> (x' :>: xs') :/\: p'' --- | The natural, non-conflicting merge.-naturalMerge :: (Invert p, Commute p)-             => (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)-naturalMerge (p :\/: q) = do-  q' :> ip' <- commute (invert p :> q)-  -- TODO: find a small convincing example that demonstrates why-  -- it is necessary to do this extra check here-  _ <- commute (p :> q')-  return (q' :/\: invert ip')+-- | Lift a merge function over @p :\/: q@+-- to a merge function over @FL p :\/: q@+mergerFLId :: MergeFn p q -> MergeFn (FL p) q+mergerFLId mergeFn = swapMerger (mergerIdFL (swapMerger mergeFn)) +-- | Lift a merge function over @p :\/: q@+-- to a merge function over @FL p :\/: FL q@+mergerFLFL :: MergeFn p q -> MergeFn (FL p) (FL q)+mergerFLFL mergeFn = mergerIdFL (mergerFLId mergeFn)++-- | Swap the two patches, 'merge', then swap again. Used to exploit+-- 'prop_mergeSymmetric' when defining 'merge'.+swapMerge :: Merge p => (p :\/: p) wX wY -> (p :/\: p) wX wY+swapMerge = swapMerger merge++-- | Swap the two patches, apply an arbitrary merge function, then swap again.+swapMerger :: MergeFn p q -> MergeFn q p+swapMerger mergeFn (x :\/: y) = case mergeFn (y :\/: x) of x' :/\: y' -> y' :/\: x'++-- | Swap the two patches, 'cleanMerge', then swap again. Used to exploit+-- 'prop_cleanMergeSymmetric' when defining 'cleanMerge'.+swapCleanMerge :: CleanMerge p => (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)+swapCleanMerge (x :\/: y) = do+  x' :/\: y' <- cleanMerge (y :\/: x)+  return $ y' :/\: x'++-- | Combine a list of patch sequences, all starting at the same state, into a+-- single sequence that also starts at the same state, using cleanMerge.+-- If the merge fails, we return the two sequences that+-- could not be merged so we can issue more detailed error messages.+mergeList :: CleanMerge p+          => [Sealed (FL p wX)]+          -> Either (Sealed (FL p wX), Sealed (FL p wX)) (Sealed (FL p wX))+mergeList = foldM mergeTwo (Sealed NilFL)+  where+    mergeTwo (Sealed ps) (Sealed qs) =+      case cleanMerge (ps :\/: qs) of+        Just (qs' :/\: _) -> Right $ Sealed $ ps +>+ qs'+        Nothing -> Left (Sealed ps, Sealed qs)++-- | This function serves no purpose except to demonstrate how merge together+-- with the square commute law allows us to commute any pair of adjacent+-- patches.+-- Note that using this function introduces inverse conflictors if the regular+-- commute would fail. This is problematic because it invalidates another+-- global invariant we rely on, namely that we can always drop (obliterate or+-- amend) patches from the end of a repo. This is because inverse conflictors+-- contain references to patches that come after it, so dropping them would+-- make the inverse conflictor inconsistent.+_forceCommute :: (Commute p, Merge p, Invert p) => (p :> p) wX wY -> (p :> p) wX wY+_forceCommute (p :> q) =+  case commute (p :> q) of+    Just (q' :> p') -> q' :> p'+    Nothing ->+      case merge (invert p :\/: q) of+        q' :/\: ip' -> q' :> invert ip'++-- | Whether the given pair of patches satisfies the /symmetry/ law. prop_mergeSymmetric :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool prop_mergeSymmetric (p :\/: q) =   case merge (p :\/: q) of@@ -86,7 +209,8 @@         p'' :/\: q'' ->           isIsEq (q' =\/= q'') && isIsEq (p' =\/= p'') -prop_mergeCommute :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool+-- | Whether the given pair of patches satisfies the /merge-commute/ law.+prop_mergeCommute :: (Commute p, Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool prop_mergeCommute (p :\/: q) =   case merge (p :\/: q) of     q' :/\: p' ->
src/Darcs/Patch/MonadProgress.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TypeSynonymInstances #-} --  Copyright (C) 2011 Ganesh Sittampalam -- -- Permission is hereby granted, free of charge, to any person@@ -27,7 +26,6 @@     , silentlyRunProgressActions     ) where -import Prelude () import Darcs.Prelude  import Darcs.Util.Printer ( Doc )
src/Darcs/Patch/Named.hs view
@@ -16,53 +16,72 @@ --  Boston, MA 02110-1301, USA.  module Darcs.Patch.Named-       ( Named(..),-         infopatch,-         adddeps, namepatch, anonymous,-         getdeps,-         patch2patchinfo, patchname, patchcontents,-         fmapNamed, fmapFL_Named,-         commuterIdNamed, commuterNamedId,-         mergerIdNamed-       )-       where+    ( Named(..)+    , infopatch+    , adddeps+    , anonymous+    , HasDeps(..)+    , patch2patchinfo+    , patchname+    , patchcontents+    , fmapNamed+    , fmapFL_Named+    , mergerIdNamed+    , ShowDepsFormat(..)+    , showDependencies+    ) where -import Prelude () import Darcs.Prelude -import Prelude hiding ( pi )-import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterFLId-                             , MergeFn, mergerIdFL )-import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts )+import Data.List.Ordered ( nubSort )+import qualified Data.Set as S++import Darcs.Patch.CommuteFn ( MergeFn, commuterIdFL, mergerIdFL )+import Darcs.Patch.Conflict ( Conflict(..) ) import Darcs.Patch.Debug ( PatchDebug(..) )-import Darcs.Patch.Effect ( Effect(effect, effectRL) )+import Darcs.Patch.Effect ( Effect(effect) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, patchinfo,-                          piName, displayPatchInfo, makePatchname, invertName )-import Darcs.Patch.Merge ( Merge(..) )+                          piName, displayPatchInfo, makePatchname )+import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId, IdEq2(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL ) import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Prim ( PrimPatchBase(..) )-import Darcs.Patch.ReadMonads ( ParserM, option, lexChar,+import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim(..) )+import Darcs.Util.Parser ( Parser, option, lexChar,                                 choice, skipWhile, anyChar ) import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL, Check(..) ) import Darcs.Patch.Show-    ( ShowPatchBasic(..), ShowPatch(..), ShowContextPatch(..), ShowPatchFor(..) )-import Darcs.Patch.Summary ( plainSummary )+    ( ShowContextPatch(..)+    , ShowPatch(..)+    , ShowPatchBasic(..)+    , ShowPatchFor(..)+    , displayPatch+    )+import Darcs.Patch.Summary+    ( Summary(..)+    , plainSummaryFL+    )+import Darcs.Patch.Unwind ( Unwind(..), squashUnwound ) import Darcs.Patch.Viewing () -- for ShowPatch FL instances  import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered-    ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL, mapFL_FL )+    ( (:>)(..), (:\/:)(..), (:/\:)(..)+    , FL(..), RL(..), mapFL, mapFL_FL, mapRL_RL+    , (+>+), concatRLFL, reverseFL+    , (+<<+), (+>>+), concatFL+    ) import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal )-import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) +import Darcs.Util.IsoDate ( showIsoDateTime, theBeginning ) import Darcs.Util.Printer-    ( Doc, ($$), (<+>), prefix, text, vcat, cyanText, blueText )+    ( Doc, ($$), (<+>), text, vcat, cyanText, blueText )  -- | The @Named@ type adds a patch info about a patch, that is a name. data Named p wX wY where@@ -81,8 +100,14 @@  instance Effect p => Effect (Named p) where     effect (NamedP _ _ p) = effect p-    effectRL (NamedP _ _ p) = effectRL p +type instance PatchId (Named p) = PatchInfo++instance Ident (Named p) where+    ident = patch2patchinfo++instance IdEq2 (Named p)+ instance IsHunk (Named p) where     isHunk _ = Nothing @@ -91,19 +116,18 @@ instance (ReadPatch p, PatchListFormat p) => ReadPatch (Named p) where  readPatch' = readNamed -readNamed :: (ReadPatch p, PatchListFormat p, ParserM m) => m (Sealed (Named p wX))-readNamed-          = do n <- readPatchInfo+readNamed :: (ReadPatch p, PatchListFormat p) => Parser (Sealed (Named p wX))+readNamed = do n <- readPatchInfo                d <- readDepends                p <- readPatch'                return $ (NamedP n d) `mapSeal` p -readDepends :: ParserM m => m [PatchInfo]+readDepends :: Parser [PatchInfo] readDepends =   option [] $ do lexChar '<'                  readPis -readPis :: ParserM m => m [PatchInfo]+readPis :: Parser [PatchInfo] readPis = choice [ do pi <- readPatchInfo                       pis <- readPis                       return (pi:pis)@@ -114,28 +138,30 @@ instance Apply p => Apply (Named p) where     type ApplyState (Named p) = ApplyState p     apply (NamedP _ _ p) = apply p+    unapply (NamedP _ _ p) = unapply p  instance RepairToFL p => Repair (Named p) where     applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p -namepatch :: String -> String -> String -> [String] -> FL p wX wY -> IO (Named p wX wY)-namepatch date name author desc p-    | '\n' `elem` name = error "Patch names cannot contain newlines."-    | otherwise = do pinf <- patchinfo date name author desc-                     return $ NamedP pinf [] p--anonymous :: FL p wX wY -> IO (Named p wX wY)-anonymous p = namepatch "today" "anonymous" "unknown" ["anonymous"] p+anonymous :: FromPrim p => FL (PrimOf p) wX wY -> IO (Named p wX wY)+anonymous ps = do+  info <- patchinfo (showIsoDateTime theBeginning) "anonymous" "unknown" ["anonymous"]+  return $ infopatch info ps -infopatch :: PatchInfo -> FL p wX wY -> Named p wX wY-infopatch pi p = NamedP pi [] p+infopatch :: forall p wX wY. FromPrim p => PatchInfo -> FL (PrimOf p) wX wY -> Named p wX wY+infopatch pi ps = NamedP pi [] (fromPrims pi ps) where  adddeps :: Named p wX wY -> [PatchInfo] -> Named p wX wY adddeps (NamedP pi _ p) ds = NamedP pi ds p -getdeps :: Named p wX wY -> [PatchInfo]-getdeps (NamedP _ ds _) = ds+-- | This slightly ad-hoc class is here so we can call 'getdeps' with patch+-- types that wrap a 'Named', such as 'RebaseChange'.+class HasDeps p where+  getdeps :: p wX wY -> [PatchInfo] +instance HasDeps (Named p) where+  getdeps (NamedP _ ds _) = ds+ patch2patchinfo :: Named p wX wY -> PatchInfo patch2patchinfo (NamedP i _ _) = i @@ -145,19 +171,17 @@ patchcontents :: Named p wX wY -> FL p wX wY patchcontents (NamedP _ _ p) = p +patchcontentsRL :: RL (Named p) wX wY -> RL p wX wY+patchcontentsRL = concatRLFL . mapRL_RL patchcontents+ fmapNamed :: (forall wA wB . p wA wB -> q wA wB) -> Named p wX wY -> Named q wX wY fmapNamed f (NamedP i deps p) = NamedP i deps (mapFL_FL f p)  fmapFL_Named :: (FL p wA wB -> FL q wC wD) -> Named p wA wB -> Named q wC wD fmapFL_Named f (NamedP i deps p) = NamedP i deps (f p) -instance (Commute p, Eq2 p) => Eq2 (Named p) where-    unsafeCompare (NamedP n1 d1 p1) (NamedP n2 d2 p2) =-        n1 == n2 && d1 == d2 && unsafeCompare p1 p2--instance Invert p => Invert (Named p) where-    invert (NamedP n d p)  = NamedP (invertName n) (map invertName d) (invert p)-+instance Eq2 (Named p) where+    unsafeCompare (NamedP n1 _ _) (NamedP n2 _ _) = n1 == n2  instance Commute p => Commute (Named p) where     commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) =@@ -166,33 +190,87 @@         else do (p2' :> p1') <- commute (p1 :> p2)                 return (NamedP n2 d2 p2' :> NamedP n1 d1 p1') -commuterIdNamed :: CommuteFn p1 p2 -> CommuteFn p1 (Named p2)-commuterIdNamed commuter (p1 :> NamedP n2 d2 p2) =-   do p2' :> p1' <- commuterIdFL commuter (p1 :> p2)-      return (NamedP n2 d2 p2' :> p1')--commuterNamedId :: CommuteFn p1 p2 -> CommuteFn (Named p1) p2-commuterNamedId commuter (NamedP n1 d1 p1 :> p2) =-   do p2' :> p1' <- commuterFLId commuter (p1 :> p2)-      return (p2' :> NamedP n1 d1 p1')+instance CleanMerge p => CleanMerge (Named p) where+    cleanMerge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2)+      | n1 == n2 = error "cannot cleanMerge identical Named patches"+      | otherwise = do+          p2' :/\: p1' <- cleanMerge (p1 :\/: p2)+          return $ NamedP n2 d2 p2' :/\: NamedP n1 d1 p1'  instance Merge p => Merge (Named p) where     merge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2)-        = case merge (p1 :\/: p2) of-          (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1'+      | n1 == n2 = error "cannot merge identical Named patches"+      | otherwise =+          case merge (p1 :\/: p2) of+            (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1' +-- Merge an unnamed patch with a named patch.+-- This operation is safe even if the first patch is named, as names can+-- never conflict with each other.+-- This is in contrast with commuterIdNamed which is not safe and hence+-- is defined closer to the code that uses it. mergerIdNamed :: MergeFn p1 p2 -> MergeFn p1 (Named p2) mergerIdNamed merger (p1 :\/: NamedP n2 d2 p2) =    case mergerIdFL merger (p1 :\/: p2) of      p2' :/\: p1' -> NamedP n2 d2 p2' :/\: p1' +{- | This instance takes care of handling the interaction between conflict+resolution and explicit dependencies. 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.++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.+-}++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++        -- used to accumulate explicit dependencies+        some +| more = foldr S.insert some more++instance (PrimPatchBase p, Unwind p) => Unwind (Named p) where+  fullUnwind (NamedP _ _ ps) = squashUnwound (mapFL_FL fullUnwind ps)+ instance PatchInspect p => PatchInspect (Named p) where     listTouchedFiles (NamedP _ _ p) = listTouchedFiles p     hunkMatches f (NamedP _ _ p) = hunkMatches f p -instance (CommuteNoConflicts p, Conflict p) => Conflict (Named p) where-    resolveConflicts (NamedP _ _ p) = resolveConflicts p-    conflictedEffect (NamedP _ _ p) = conflictedEffect p+instance Summary p => Summary (Named p) where+    conflictedEffect = conflictedEffect . patchcontents  instance Check p => Check (Named p) where     isInconsistent (NamedP _ _ p) = isInconsistent p@@ -216,21 +294,6 @@     $$ showDependencies ShowDepsVerbose d     $$ p -data ShowDepsFormat = ShowDepsVerbose | ShowDepsSummary-                        deriving (Eq)--showDependencies :: ShowDepsFormat -> [PatchInfo] -> Doc-showDependencies format deps = vcat (map showDependency deps)-                    where-                      showDependency d = mark-                                         <+> cyanText "patch"-                                         <+> cyanText (show (makePatchname d))-                                         $$ asterisk <+> text (piName d)-                      mark | format == ShowDepsVerbose = blueText "depend"-                           | otherwise = text "D"-                      asterisk | format == ShowDepsVerbose = text "*"-                               | otherwise = text "  *"- instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Named p) where     showPatch f (NamedP n d p) = showNamedPrefix f n d $ showPatch f p @@ -239,37 +302,36 @@     showContextPatch f (NamedP n d p) =         showNamedPrefix f n d <$> showContextPatch f p -instance (CommuteNoConflicts p, Conflict p, PatchListFormat p,+data ShowDepsFormat = ShowDepsVerbose | ShowDepsSummary+                        deriving (Eq)++showDependencies :: ShowDepsFormat -> [PatchInfo] -> Doc+showDependencies 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 "  *"++instance (Summary p, PatchListFormat p,           PrimPatchBase p, ShowPatch p) => ShowPatch (Named p) where     description (NamedP n _ _) = displayPatchInfo n-    summary p@(NamedP _ ds _) =-        let-            indent = prefix "    "-            deps | ds == []  = text ""-                 | otherwise = text ""-                               $$ indent (showDependencies ShowDepsSummary ds)-        in-            description p $$ deps $$ indent (plainSummary p)-                                        -- this isn't summary because summary-                                        -- does the wrong thing with-                                        -- (Named (FL p)) so that it can get-                                        -- the summary of a sequence of named-                                        -- patches right.-    summaryFL = vcat . mapFL summary-    showNicely p@(NamedP _ ds pt) =-        let-            indent = prefix "    "-            deps | ds == []  = text ""-                 | otherwise = text ""-                               $$ indent (showDependencies ShowDepsVerbose ds)-        in-            description p <> deps $$ indent (showNicely pt)+    summary (NamedP _ ds ps) =+        showDependencies ShowDepsSummary ds $$ plainSummaryFL ps+    summaryFL nps =+        showDependencies 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 -instance Show2 p => Show1 (Named p wX) where-    showDict1 = ShowDictClass+instance Show2 p => Show1 (Named p wX) -instance Show2 p => Show2 (Named p) where-    showDict2 = ShowDictClass+instance Show2 p => Show2 (Named p)  instance PatchDebug p => PatchDebug (Named p)
src/Darcs/Patch/Named/Wrapped.hs view
@@ -1,212 +1,85 @@-{-# LANGUAGE StandaloneDeriving, TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Named.Wrapped   ( WrappedNamed(..)-  , patch2patchinfo, activecontents-  , infopatch, namepatch, anonymous-  , getdeps, adddeps-  , mkRebase, toRebasing, fromRebasing-  , runInternalChecker, namedInternalChecker, namedIsInternal, removeInternalFL-  , fmapFL_WrappedNamed, (:~:)(..), (:~~:)(..)-  , generaliseRepoTypeWrapped+  , fromRebasing   ) where -import Prelude () import Darcs.Prelude++import Control.Applicative ( (<|>) ) import Data.Coerce ( coerce )  import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat )-import Darcs.Patch.Info-  ( PatchInfo, showPatchInfo, displayPatchInfo, patchinfo-  )-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Named ( Named(..), fmapFL_Named )-import qualified Darcs.Patch.Named as Base-  ( patch2patchinfo, patchcontents-  , infopatch, namepatch, anonymous-  , getdeps, adddeps-  )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Prim ( FromPrim )-import Darcs.Patch.Prim.Class ( PrimPatchBase(..) )+import Darcs.Patch.Info ( PatchInfo, showPatchInfo )+import Darcs.Patch.FromPrim ( FromPrim, PrimPatchBase(..) )+import Darcs.Patch.Named ( Named(..), patch2patchinfo ) import Darcs.Patch.Read ( ReadPatch(..) )-import qualified Darcs.Patch.Rebase.Container as Rebase+import Darcs.Patch.Rebase.Suspended   ( Suspended(..)-  , addFixupsToSuspended, removeFixupsFromSuspended+  , addFixupsToSuspended+  , removeFixupsFromSuspended   )-import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL(..), Check(..) )+import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.RepoType   ( RepoType(..), IsRepoType(..), SRepoType(..)-  , RebaseType(..), RebaseTypeOf, SRebaseType(..)+  , RebaseType(..), SRebaseType(..)   )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), ShowContextPatch(..), ShowPatchFor(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..) ) -import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Sealed ( mapSeal )-import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) import Darcs.Patch.Witnesses.Ordered-  ( FL(..), mapFL_FL, mapFL, (:>)(..)-  , (:\/:)(..), (:/\:)(..)+  ( FL(..), mapFL_FL, (:>)(..)   ) -import Darcs.Util.IsoDate ( getIsoDateTime )-import Darcs.Util.Text ( formatParas )-import Darcs.Util.Printer ( ($$), vcat, prefix )--import Control.Applicative ( (<|>) )---- |A layer inbetween the 'Named p' type and 'PatchInfoAnd p'--- design for holding "internal" patches such as the rebase--- container. Ideally these patches would be stored at the--- repository level but this would require some significant--- refactoring/cleaning up of that code.+-- |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 -- TODO: this should always be the "internal implementation detail" rebase-                  -- patch description, so could be replaced by just the Ignore-this and Date fields-    -> !(Rebase.Suspended p wX wX)+    => !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) where-  showDict1 = ShowDictClass--instance Show2 p => Show2 (WrappedNamed rt p) where-  showDict2 = ShowDictClass---- TODO use Data.Type.Equality and PolyKinds from GHC 7.8/base 4.7-data (a :: * -> * -> *) :~: b where-    ReflPatch :: a :~: a--data (a :: RebaseType) :~~: b where-    ReflRebaseType :: a :~~: a---- |lift a function over an 'FL' of patches to one over--- a 'WrappedNamed rt'.--- The function is only applied to "normal" patches,--- and any rebase container patch is left alone.-fmapFL_WrappedNamed-  :: (FL p wA wB -> FL q wA wB)-  -> (RebaseTypeOf rt :~~: 'IsRebase -> p :~: q)-     -- ^If the patch might be a rebase container patch,-     -- then 'p' and 'q' must be the same type, as no-     -- transformation is applied. This function provides-     -- a witness to this requirement: if 'RebaseTypeOf rt'-     -- might be 'IsRebase', then it must be able to return-     -- a proof that 'p' and 'q' are equal. If 'RebaseTypeOf rt'-     -- must be 'NoRebase', then this function can never be called-     -- with a valid value.-  -> WrappedNamed rt p wA wB-  -> WrappedNamed rt q wA wB-fmapFL_WrappedNamed f _ (NormalP n) = NormalP (fmapFL_Named f n)-fmapFL_WrappedNamed _ whenRebase (RebaseP n s) =-  case whenRebase ReflRebaseType of-    ReflPatch -> RebaseP n s--patch2patchinfo :: WrappedNamed rt p wX wY -> PatchInfo-patch2patchinfo (NormalP p) = Base.patch2patchinfo p-patch2patchinfo (RebaseP name _) = name--namepatch :: String -> String -> String -> [String] -> FL p wX wY -> IO (WrappedNamed rt p wX wY)-namepatch date name author desc p = fmap NormalP (Base.namepatch date name author desc p)--anonymous :: FL p wX wY -> IO (WrappedNamed rt p wX wY)-anonymous p = fmap NormalP (Base.anonymous p)--infopatch :: PatchInfo -> FL p wX wY -> WrappedNamed rt p wX wY-infopatch i ps = NormalP (Base.infopatch i ps)---- |Return a list of the underlying patches that are actually--- 'active' in the repository, i.e. not suspended as part of a rebase-activecontents :: WrappedNamed rt p wX wY -> FL p wX wY-activecontents (NormalP p) = Base.patchcontents p-activecontents (RebaseP {}) = NilFL--adddeps :: WrappedNamed rt p wX wY -> [PatchInfo] -> WrappedNamed rt p wX wY-adddeps (NormalP n) pis = NormalP (Base.adddeps n pis)-adddeps (RebaseP {}) _ = error "Internal error: can't add dependencies to a rebase internal patch"--getdeps :: WrappedNamed rt p wX wY -> [PatchInfo]-getdeps (NormalP n) = Base.getdeps n-getdeps (RebaseP {}) = []--mkRebase :: (PrimPatchBase p, FromPrim p, Effect p)-         => Rebase.Suspended p wX wX-         -> IO (WrappedNamed ('RepoType 'IsRebase) p wX wX)-mkRebase s = do-     let name = "DO NOT TOUCH: Rebase patch"-     let desc = formatParas 72-                ["This patch is an internal implementation detail of rebase, used to store suspended patches, " ++-                 "and should not be visible in the user interface. Please report a bug if a darcs " ++-                 "command is showing you this patch."]-     date <- getIsoDateTime-     let author = "Invalid <invalid@invalid>"-     info <- patchinfo date name author desc-     return $ RebaseP info s+instance Show2 p => Show1 (WrappedNamed rt p wX) -toRebasing :: Named p wX wY -> WrappedNamed ('RepoType 'IsRebase) p wX wY-toRebasing n = NormalP n+instance Show2 p => Show2 (WrappedNamed rt p) -fromRebasing :: WrappedNamed ('RepoType 'IsRebase) p wX wY -> Named p wX wY+fromRebasing :: WrappedNamed rt p wX wY -> Named p wX wY fromRebasing (NormalP n) = n fromRebasing (RebaseP {}) = error "internal error: found rebasing internal patch" -generaliseRepoTypeWrapped-  :: WrappedNamed ('RepoType 'NoRebase) p wA wB-  -> WrappedNamed rt p wA wB-generaliseRepoTypeWrapped (NormalP p) = NormalP p---- Note: the EqCheck result could be replaced by a Bool if clients were changed to commute the patch--- out if necessary.-newtype InternalChecker p =-  InternalChecker { runInternalChecker :: forall wX wY . p wX wY -> EqCheck wX wY }---- |Is the given 'WrappedNamed' patch an internal implementation detail--- that shouldn't be visible in the UI or included in tags/matchers etc?--- Two-level checker for efficiency: if the value of this is 'Nothing' for a given--- patch type then there's no need to inspect patches of this type at all,--- as none of them can be internal.-namedInternalChecker :: forall rt p . IsRepoType rt => Maybe (InternalChecker (WrappedNamed rt p))-namedInternalChecker =-  case singletonRepoType :: SRepoType rt of-    SRepoType SNoRebase -> Nothing-    SRepoType SIsRebase ->-      let-        isInternal :: WrappedNamed rt p wX wY -> EqCheck wX wY-        isInternal (NormalP {}) = NotEq-        isInternal (RebaseP {}) = IsEq-      in Just (InternalChecker isInternal)---- |Is the given 'WrappedNamed' patch an internal implementation detail--- that shouldn't be visible in the UI or included in tags/matchers etc?-namedIsInternal :: IsRepoType rt => WrappedNamed rt p wX wY -> EqCheck wX wY-namedIsInternal = maybe (const NotEq) runInternalChecker namedInternalChecker--removeInternalFL :: IsRepoType rt => FL (WrappedNamed rt p) wX wY -> FL (Named p) wX wY-removeInternalFL NilFL = NilFL-removeInternalFL (NormalP n :>: ps) = n :>: removeInternalFL ps-removeInternalFL (RebaseP {} :>: ps) = removeInternalFL ps- instance PrimPatchBase p => PrimPatchBase (WrappedNamed rt p) where   type PrimOf (WrappedNamed rt p) = PrimOf p -instance Invert p => Invert (WrappedNamed rt p) where-  invert (NormalP n) = NormalP (invert n)-  invert (RebaseP i s) = RebaseP i s -- TODO is this sensible?+type instance PatchId (WrappedNamed rt p) = PatchInfo -instance PatchListFormat (WrappedNamed rt p)+instance Ident (WrappedNamed rt p) where+  ident (NormalP p) = patch2patchinfo p+  ident (RebaseP name _) = name -instance IsHunk (WrappedNamed rt p) where-  isHunk _ = Nothing+instance PatchListFormat (WrappedNamed rt p)  instance (ShowPatchBasic p, PatchListFormat p)   => ShowPatchBasic (WrappedNamed rt p) where@@ -214,45 +87,6 @@   showPatch f (NormalP n) = showPatch f n   showPatch f (RebaseP i s) = showPatchInfo f i <> showPatch f s -instance ( ShowContextPatch p, PatchListFormat p, Apply p-         , PrimPatchBase p, IsHunk p-         )-  => ShowContextPatch (WrappedNamed rt p) where--  showContextPatch f (NormalP n) = showContextPatch f n-  showContextPatch f@ForDisplay (RebaseP i s) =-    fmap (showPatchInfo f i $$) $ return (showPatch f s)-  showContextPatch f@ForStorage (RebaseP i s) =-    fmap (showPatchInfo f i <>) $ return (showPatch f s)--instance ( ShowPatch p, PatchListFormat p, Apply p-         , PrimPatchBase p, IsHunk p, Conflict p, CommuteNoConflicts p-         )-  => ShowPatch (WrappedNamed rt p) where--  description (NormalP n) = description n-  description (RebaseP i _) = displayPatchInfo i--  summary (NormalP n) = summary n-  summary (RebaseP i _) = displayPatchInfo i--  summaryFL = vcat . mapFL summary--  showNicely (NormalP n) = showNicely n-  showNicely (RebaseP i s) = displayPatchInfo i $$-                             prefix "    " (showNicely s)--instance PatchInspect p => PatchInspect (WrappedNamed rt p) where-  listTouchedFiles (NormalP n) = listTouchedFiles n-  listTouchedFiles (RebaseP _ s) = listTouchedFiles s--  hunkMatches f (NormalP n) = hunkMatches f n-  hunkMatches f (RebaseP _ s) = hunkMatches f s--instance RepairToFL p => Repair (WrappedNamed rt p) where-  applyAndTryToFix (NormalP n) = fmap (mapMaybeSnd NormalP) $ applyAndTryToFix n-  applyAndTryToFix (RebaseP i s) = fmap (mapMaybeSnd (RebaseP i)) $ applyAndTryToFix 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*@@ -265,10 +99,10 @@ -- saves/reads 'RebaseP'. data ReadRebasing p wX wY where   ReadNormal    :: p wX wY -> ReadRebasing p wX wY-  ReadSuspended :: Rebase.Suspended p wX wX -> ReadRebasing p wX wX+  ReadSuspended :: Suspended p wX wX -> ReadRebasing p wX wX  instance ( ReadPatch p, PrimPatchBase p, FromPrim p, Effect p, PatchListFormat p-         , IsRepoType rt+         , RepoPatch p, IsRepoType rt          ) => ReadPatch (WrappedNamed rt p) where   readPatch' =     case singletonRepoType :: SRepoType rt of@@ -288,36 +122,22 @@ instance PatchListFormat p => PatchListFormat (ReadRebasing p) where   patchListFormat = coerce (patchListFormat :: ListFormat p) -instance (ReadPatch p, PatchListFormat p, PrimPatchBase p) => ReadPatch (ReadRebasing p) where+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 :: Rebase.Suspended p wX wY -> ReadRebasing p wX wY-            toSuspended (Rebase.Items ps) = ReadSuspended (Rebase.Items ps)--instance (CommuteNoConflicts p, Conflict p) => Conflict (WrappedNamed rt p) where-  resolveConflicts (NormalP n) = resolveConflicts n-  resolveConflicts (RebaseP _ s) = resolveConflicts s--  conflictedEffect (NormalP n) = conflictedEffect n-  conflictedEffect (RebaseP _ s) = conflictedEffect s--instance Check p => Check (WrappedNamed rt p) where-  isInconsistent (NormalP n) = isInconsistent n-  isInconsistent (RebaseP _ s) = isInconsistent s+            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-  apply (RebaseP _ s) = apply s--instance Effect p => Effect (WrappedNamed rt p) where-  effect (NormalP n) = effect n-  effect (RebaseP _ s) = effect s--  effectRL (NormalP n) = effectRL n-  effectRL (RebaseP _ s) = effectRL s+  -- 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@@ -332,22 +152,7 @@     return (RebaseP i2 s2 :> RebaseP i1 s1)    commute (NormalP n1 :> RebaseP i2 s2) =-    return (RebaseP i2 (Rebase.addFixupsToSuspended n1 s2) :> NormalP n1)+    return (RebaseP i2 (addFixupsToSuspended n1 s2) :> NormalP n1)    commute (RebaseP i1 s1 :> NormalP n2) =-    return (NormalP n2 :> RebaseP i1 (Rebase.removeFixupsFromSuspended n2 s1))--instance Merge p => Merge (WrappedNamed rt p) where-  merge (NormalP n1 :\/: NormalP n2) =-    case merge (n1 :\/: n2) of-      n2' :/\: n1' -> NormalP n2' :/\: NormalP n1'--  -- shouldn't happen as each repo only has a single Suspended patch-  merge (RebaseP i1 items1 :\/: RebaseP i2 items2) =-    RebaseP i2 items2 :/\: RebaseP i1 items1--  merge (NormalP n1 :\/: RebaseP i2 s2) =-    RebaseP i2 (Rebase.removeFixupsFromSuspended n1 s2) :/\: NormalP n1--  merge (RebaseP i1 s1 :\/: NormalP n2) =-    NormalP n2 :/\: RebaseP i1 (Rebase.removeFixupsFromSuspended n2 s1)+    return (NormalP n2 :> RebaseP i1 (removeFixupsFromSuspended n2 s1))
src/Darcs/Patch/PatchInfoAnd.hs view
@@ -15,52 +15,70 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}-module Darcs.Patch.PatchInfoAnd ( Hopefully(..), SimpleHopefully(..), PatchInfoAnd(..),-                         WPatchInfo, unWPatchInfo, compareWPatchInfo,-                         piap, n2pia, patchInfoAndPatch,-                         fmapFLPIAP, generaliseRepoTypePIAP,-                         conscientiously, hopefully, info, winfo,-                         hopefullyM, createHashed, extractHash,-                         actually, unavailable, patchDesc ) where+module Darcs.Patch.PatchInfoAnd+    ( Hopefully+    , PatchInfoAnd+    , PatchInfoAndG+    , WPatchInfo+    , unWPatchInfo+    , compareWPatchInfo+    , piap+    , n2pia+    , patchInfoAndPatch+    , fmapPIAP+    , fmapFLPIAP+    , conscientiously+    , hopefully+    , info+    , winfo+    , hopefullyM+    , createHashed+    , extractHash+    , actually+    , unavailable+    , patchDesc+    ) where -import Prelude () import Darcs.Prelude +import Control.Exception ( Exception, throw ) import System.IO.Unsafe ( unsafeInterleaveIO )+import Data.Typeable ( Typeable )  import Darcs.Util.SignalHandler ( catchNonSignal )-import Darcs.Util.Printer-    ( Doc, renderString, errorDoc, text, ($$), vcat-     )+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.Conflict ( Conflict, CommuteNoConflicts )+import Darcs.Patch.Conflict ( Conflict(..) ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Named.Wrapped-    ( WrappedNamed, patch2patchinfo, fmapFL_WrappedNamed, (:~:), (:~~:)-    , generaliseRepoTypeWrapped-    )-import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim )+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.Invert ( Invert(..) ) 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(..), IsRepoType, RebaseTypeOf, RebaseType(..) )+import Darcs.Patch.RepoType ( RepoType(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowContextPatch(..) )+import Darcs.Patch.Summary ( Summary ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL )+import Darcs.Patch.Witnesses.Ordered+  ( (:/\:)(..)+  , (:>)(..)+  , (:\/:)(..)+  , FL+  , mapFL+  , mapRL_RL+  ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal )-import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) import Darcs.Util.Exception ( prettyException )-import Darcs.Util.Tree( Tree )  -- | @'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@@ -80,20 +98,15 @@ data SimpleHopefully a wX wY = Actually (a wX wY) | Unavailable String     deriving Show +type PatchInfoAnd rt p = PatchInfoAndG rt (Named p)+ -- | @'PatchInfoAnd' p wA wB@ represents a hope we have to get a -- patch through its info. We're not sure we have the patch, but we -- know its info.-data PatchInfoAnd rt p wA wB = PIAP !PatchInfo (Hopefully (WrappedNamed rt p) wA wB)-    deriving Show--instance Show2 p => Show1 (PatchInfoAnd rt p wX) where-    showDict1 = ShowDictClass--instance Show2 p => Show2 (PatchInfoAnd rt p) where-    showDict2 = ShowDictClass--instance PrimPatchBase p => PrimPatchBase (PatchInfoAnd rt p) where-   type PrimOf (PatchInfoAnd rt p) = PrimOf p+data PatchInfoAndG (rt :: RepoType) 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.@@ -116,7 +129,7 @@     where ff (Actually a) = Actually (f a)           ff (Unavailable e) = Unavailable e -info :: PatchInfoAnd rt p wA wB -> PatchInfo+info :: PatchInfoAndG rt p wA wB -> PatchInfo info (PIAP i _) = i  patchDesc :: forall rt p wX wY . PatchInfoAnd rt p wX wY -> String@@ -126,59 +139,59 @@ winfo (PIAP i _) = WPatchInfo i  -- | @'piap' i p@ creates a PatchInfoAnd containing p with info i.-piap :: PatchInfo -> WrappedNamed rt p wA wB -> PatchInfoAnd rt p wA wB+piap :: PatchInfo -> p wA wB -> PatchInfoAndG rt p wA wB piap i p = PIAP i (Hopefully $ Actually p)  -- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch.-n2pia :: WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY-n2pia x = patch2patchinfo x `piap` x+n2pia :: (Ident p, PatchId p ~ PatchInfo) => p wX wY -> PatchInfoAndG rt p wX wY+n2pia x = ident x `piap` x -patchInfoAndPatch :: PatchInfo -> Hopefully (WrappedNamed rt p) wA wB -> PatchInfoAnd rt p wA wB+patchInfoAndPatch :: PatchInfo -> Hopefully p wA wB -> PatchInfoAndG rt p wA wB patchInfoAndPatch =  PIAP -fmapFLPIAP-  :: (FL p wX wY -> FL q wX wY)-  -> (RebaseTypeOf rt :~~: 'IsRebase -> p :~: q)-  -> PatchInfoAnd rt p wX wY-  -> PatchInfoAnd rt q wX wY-fmapFLPIAP f whenRebase (PIAP i hp)-  = PIAP i (fmapH (fmapFL_WrappedNamed f whenRebase) hp)+fmapFLPIAP :: (FL p wX wY -> FL q wX wY)+           -> PatchInfoAnd rt p wX wY -> PatchInfoAnd rt q wX wY+fmapFLPIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp) -generaliseRepoTypePIAP-    :: PatchInfoAnd ('RepoType 'NoRebase) p wA wB-    -> PatchInfoAnd rt p wA wB-generaliseRepoTypePIAP (PIAP i hp) = PIAP i (fmapH generaliseRepoTypeWrapped hp)+fmapPIAP :: (p wX wY -> q wX wY)+           -> PatchInfoAndG rt p wX wY -> PatchInfoAndG rt q wX wY+fmapPIAP f (PIAP i hp) = PIAP i (fmapH f hp)  -- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd' -- value. If it fails, it outputs an error \"failed to read patch: -- \<description of the patch>\". We get the description of the patch -- from the info part of 'hp'-hopefully :: PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB+hopefully :: PatchInfoAndG rt p wA wB -> p wA wB hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e +-- | Using a special exception type here means that is is treated as+-- regular failure, and not as a bug in Darcs.+data PatchNotAvailable = PatchNotAvailable Doc+  deriving Typeable++instance Exception PatchNotAvailable++instance Show PatchNotAvailable where+  show (PatchNotAvailable e) = renderString e+ -- | @'conscientiously' er hp@ tries to extract a patch from a 'PatchInfoAnd'. -- If it fails, it applies the error handling function @er@ to a description -- of the patch info component of @hp@.+-- Note: this function must be lazy in its second argument, which is why we+-- use a lazy pattern match. conscientiously :: (Doc -> Doc)-                -> PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB-conscientiously er (PIAP pinf hp) =+                -> PatchInfoAndG rt p wA wB -> p wA wB+conscientiously er ~(PIAP pinf hp) =     case hopefully2either hp of       Right p -> p-      Left e -> errorDoc $ er (displayPatchInfo pinf $$ text e)+      Left e -> throw $ PatchNotAvailable $ er (displayPatchInfo pinf $$ text e)  -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a -- monad instead of erroring.-hopefullyM ::-#if MIN_VERSION_base(4,13,0)-  MonadFail m-#else-  Monad m-#endif-  => PatchInfoAnd rt p wA wB -> m (WrappedNamed rt p wA wB)-hopefullyM (PIAP pinf hp) = case hopefully2either hp of+hopefullyM :: PatchInfoAndG rt p wA wB -> Maybe (p wA wB)+hopefullyM (PIAP _ hp) = case hopefully2either hp of                               Right p -> return p-                              Left e -> fail $ renderString-                                                     (displayPatchInfo pinf $$ text e)+                              Left _ -> Nothing  -- Any recommendations for a nice adverb to name the below? hopefully2either :: Hopefully a wX wY -> Either String (a wX wY)@@ -197,80 +210,112 @@           return (Sealed (Actually x))   handler e = return $ seal $ Unavailable $ prettyException e -extractHash :: PatchInfoAnd rt p wA wB -> Either (WrappedNamed rt p wA wB) String+extractHash :: PatchInfoAndG rt p wA wB -> Either (p wA wB) String extractHash (PIAP _ (Hashed s _)) = Right s extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp  unavailable :: String -> Hopefully a wX wY unavailable = Hopefully . Unavailable --- Equality on PatchInfoAnd is solely determined by the PatchInfo+-- * Instances defined only for PatchInfoAnd++instance Show2 p => Show1 (PatchInfoAnd rt p wX)++instance Show2 p => Show2 (PatchInfoAnd rt p)++instance RepairToFL p => Repair (PatchInfoAnd rt p) where+    applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p+                            case mp' of+                              Nothing -> return Nothing+                              Just (e,p') -> return $ Just (e, n2pia p')++-- * Instances defined for PatchInfoAndG++instance PrimPatchBase p => PrimPatchBase (PatchInfoAndG rt p) where+   type PrimOf (PatchInfoAndG rt 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 (PatchInfoAnd rt p) where+instance Eq2 (PatchInfoAndG rt p) where     unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2 -instance Invert p => Invert (PatchInfoAnd rt p) where-    invert (PIAP i p) = PIAP i (invert `fmapH` p)+type instance PatchId (PatchInfoAndG rt p) = PatchInfo -instance PatchListFormat (PatchInfoAnd rt p)+instance Ident (PatchInfoAndG rt p) where+    ident (PIAP i _) = i -instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (PatchInfoAnd rt p) where+instance IdEq2 (PatchInfoAndG rt p)++instance PatchListFormat (PatchInfoAndG rt p)++instance ShowPatchBasic p => ShowPatchBasic (PatchInfoAndG rt p) where     showPatch f (PIAP n p) =       case hopefully2either p of         Right x -> showPatch f x         Left _ -> showPatchInfo f n -instance (Apply p, IsHunk p, PatchListFormat p, PrimPatchBase p,-          ShowContextPatch p) => ShowContextPatch (PatchInfoAnd rt p) where-    showContextPatch f (PIAP n p) = case hopefully2either p of-                                      Right x -> showContextPatch f x-                                      Left _ -> return $ showPatchInfo f n+instance ShowContextPatch p => ShowContextPatch (PatchInfoAndG rt p) where+  showContextPatch f (PIAP n p) =+    case hopefully2either p of+      Right x -> showContextPatch f x+      Left _ -> return $ showPatchInfo f n -instance (Apply p, Conflict p, CommuteNoConflicts p, IsHunk p, PatchListFormat p, PrimPatchBase p,-          ShowPatch p, ApplyState p ~ Tree) => ShowPatch (PatchInfoAnd rt p) where+instance (Summary p, PatchListFormat p,+          ShowPatch p) => ShowPatch (PatchInfoAndG rt p) where     description (PIAP n _) = displayPatchInfo n-    summary (PIAP n p) = case hopefully2either p of-                         Right x -> summary x-                         Left _ -> displayPatchInfo n+    summary (PIAP _ p) =+      case hopefully2either p of+        Right x -> summary x+        Left _ -> text $ "[patch summary is unavailable]"     summaryFL = vcat . mapFL summary-    showNicely (PIAP n p) = case hopefully2either p of-                            Right x -> showNicely x-                            Left _ -> displayPatchInfo n+    content (PIAP _ p) =+      case hopefully2either p of+        Right x -> content x+        Left _ -> text $ "[patch content is unavailable]" -instance Commute p => Commute (PatchInfoAnd rt p) where+instance (PatchId p ~ PatchInfo, Commute p) => Commute (PatchInfoAndG rt p) where     commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y)-                          return $ (info y `piap` y') :> (info x `piap` x')+                          return $ (ident y `piap` y') :> (ident x `piap` x') -instance Merge p => Merge (PatchInfoAnd rt p) where-    merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of-                       y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x')+instance (PatchId p ~ PatchInfo, CleanMerge p) =>+         CleanMerge (PatchInfoAndG rt p) where+    cleanMerge (x :\/: y)+      | ident x == ident y = error "cannot cleanMerge identical PatchInfoAndG"+      | otherwise = do+          y' :/\: x' <- cleanMerge (hopefully x :\/: hopefully y)+          return $ (ident y `piap` y') :/\: (ident x `piap` x') -instance PatchInspect p => PatchInspect (PatchInfoAnd rt p) where+instance (PatchId p ~ PatchInfo, Merge p) => Merge (PatchInfoAndG rt 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     listTouchedFiles = listTouchedFiles . hopefully     hunkMatches f = hunkMatches f . hopefully -instance Apply p => Apply (PatchInfoAnd rt p) where-    type ApplyState (PatchInfoAnd rt p) = ApplyState p-    apply p = apply $ hopefully p--instance RepairToFL p => Repair (PatchInfoAnd rt p) where-    applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p-                            case mp' of-                              Nothing -> return Nothing-                              Just (e,p') -> return $ Just (e, n2pia p')--instance ( ReadPatch p, PatchListFormat p, PrimPatchBase p, Effect p, FromPrim p-         , IsRepoType rt-         ) => ReadPatch (PatchInfoAnd rt p) where+instance Apply p => Apply (PatchInfoAndG rt p) where+    type ApplyState (PatchInfoAndG rt p) = ApplyState p+    apply = apply . hopefully+    unapply = unapply .hopefully +instance ( ReadPatch p, Ident p, PatchId p ~ PatchInfo+         ) => ReadPatch (PatchInfoAndG rt p) where     readPatch' = mapSeal n2pia <$> readPatch' -instance Effect p => Effect (PatchInfoAnd rt p) where+instance Effect p => Effect (PatchInfoAndG rt p) where     effect = effect . hopefully-    effectRL = effectRL . hopefully -instance IsHunk (PatchInfoAnd rt p) where+instance IsHunk (PatchInfoAndG rt p) where     isHunk _ = Nothing -instance PatchDebug p => PatchDebug (PatchInfoAnd rt p)+instance PatchDebug p => PatchDebug (PatchInfoAndG rt p)++instance (Commute p, Conflict p) => Conflict (PatchInfoAnd rt p) where+    -- Note: this relies on the laziness of 'hopefully' for efficiency+    -- and correctness in the face of lazy repositories+    resolveConflicts context patches =+      resolveConflicts (mapRL_RL hopefully context) (mapRL_RL hopefully patches)
src/Darcs/Patch/Permutations.hs view
@@ -21,84 +21,81 @@ module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon,                                   commuteWhatWeCanFL, commuteWhatWeCanRL,                                   genCommuteWhatWeCanRL, genCommuteWhatWeCanFL,-                                  partitionFL, partitionRL,+                                  partitionFL, partitionRL, partitionFL',                                   simpleHeadPermutationsFL, headPermutationsRL,-                                  headPermutationsFL,+                                  headPermutationsFL, permutationsRL,                                   removeSubsequenceFL, removeSubsequenceRL,-                                  partitionConflictingFL,-                                  inverseCommuter+                                  partitionConflictingFL                                 ) where -import Prelude () import Darcs.Prelude  import Data.Maybe ( mapMaybe )-import Darcs.Patch.Commute ( Commute, commute, commuteFLorComplain, commuteRL )-import Darcs.Patch.CommuteFn ( CommuteFn )-import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Commute ( Commute, commute, commuteFL, commuteRL )+import Darcs.Patch.Merge ( CleanMerge(..), cleanMergeFL ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), (:>)(..), (+<+)-    , reverseFL, (+>+), (:\/:)(..), lengthFL-    , lengthRL, reverseRL )+    ( FL(..), RL(..), (:>)(..), (:\/:)(..), (:/\:)(..)+    , (+<+), (+>+)+    , lengthFL, lengthRL+    , reverseFL, reverseRL+    ) --- |split an 'FL' into "left" and "right" lists according to a predicate @p@, using commutation as necessary.--- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy--- the predicate, it goes in the "middle" list; to sum up, we have: @all p left@ and @all (not.p) right@, while--- midddle is mixed.--- Note that @p@ should be invariant under commutation (i.e. if 'x1' can commute to 'x2' then 'p x1 <=> p x2').+-- | Split an 'FL' according to a predicate, using commutation as necessary,+-- into those that satisfy the predicate and can be commuted to the left, and+-- those that do not satisfy it and can be commuted to the right. Whatever+-- remains stays in the middle.+--+-- Note that the predicate @p@ should be invariant under commutation:+-- if @commute(x:>y)==Just(y':>x')@ then @p x == p x' && p y == p y'@. partitionFL :: Commute p             => (forall wU wV . p wU wV -> Bool)  -- ^predicate; if true we would like the patch in the "left" list             -> FL p wX wY                        -- ^input 'FL'             -> (FL p :> FL p :> FL p) wX wY      -- ^"left", "middle" and "right"+partitionFL keepleft ps =+    case partitionFL' keepleft NilRL NilRL ps of+        left :> middle :> right -> left :> reverseRL middle :> reverseRL right --- optimise by using an accumulating parameter to track all the "right" patches that we've found so far+-- optimise by using an accumulating parameter to track all the "left"+-- patches that we've found so far; also do not reverse the result lists partitionFL' :: Commute p              => (forall wU wV . p wU wV -> Bool)              -> RL p wA wB  -- the "middle" patches found so far              -> RL p wB wC  -- the "right" patches found so far              -> FL p wC wD-             -> (FL p :> FL p :> FL p) wA wD--partitionFL keepleft = partitionFL' keepleft NilRL NilRL--partitionFL' _ middle right NilFL = NilFL :> reverseRL middle :> reverseRL right+             -> (FL p :> RL p :> RL p) wA wD+partitionFL' _ middle right NilFL = NilFL :> middle :> right partitionFL' keepleft middle right (p :>: ps)-   | keepleft p = case commuteRL (right :> p) of-     Just (p' :> right') -> case commuteRL (middle :> p') of-       Just (p'' :> middle') -> case partitionFL' keepleft middle' right' ps of-         (a :> b :> c) -> p'' :>: a :> b :> c-       Nothing -> partitionFL' keepleft (middle :<: p') right' ps-     Nothing -> case commuteWhatWeCanRL (right :> p) of-       (tomiddle :> p' :> right') -> partitionFL' keepleft (middle +<+ tomiddle :<: p') right' ps-   | otherwise = partitionFL' keepleft middle (right :<: p) ps-+    | keepleft p = case commuteWhatWeCanRL (right :> p) of+        (NilRL :> p' :> right') -> case commuteRL (middle :> p') of+            Just (p'' :> middle') -> case partitionFL' keepleft middle' right' ps of+                (a :> b :> c) -> p'' :>: a :> b :> c+            Nothing -> partitionFL' keepleft (middle :<: p') right' ps+        (tomiddle :> p' :> right') ->+            partitionFL' keepleft (middle +<+ tomiddle :<: p') right' ps+    | otherwise = partitionFL' keepleft middle (right :<: p) ps --- |split an 'RL' into "left" and "right" lists according to a predicate, using commutation as necessary.--- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy--- the predicate, it goes in the "left" list.-partitionRL :: Commute p-            => (forall wU wV . p wU wV -> Bool)    -- ^predicate; if true we would like the patch in the "right" list+-- | Split an 'RL' according to a predicate, using commutation as necessary,+-- into those that satisfy the predicate and can be commuted to the right, and+-- those that don't, i.e. either do not satisfy the predicate or cannot be+-- commuted to the right.+--+-- Note that the predicate @p@ should be invariant under commutation:+-- if @commute(x:>y)==Just(y':>x')@ then @p x == p x' && p y == p y'@.+partitionRL :: forall p wX wY. Commute p+            => (forall wU wV . p wU wV -> Bool) -- ^predicate; if true we would like the patch in the "right" list             -> RL p wX wY                       -- ^input 'RL'             -> (RL p :> RL p) wX wY             -- ^"left" and "right" results---- optimise by using an accumulating parameter to track all the "left" patches that we've found so far-partitionRL' :: Commute p-             => (forall wU wV . p wU wV -> Bool)-             -> RL p wX wZ-             -> FL p wZ wY   -- the "left" patches found so far-             -> (RL p :> RL p) wX wY--partitionRL keepright ps = partitionRL' keepright ps NilFL--partitionRL' _ NilRL qs = reverseFL qs :> NilRL--partitionRL' keepright (ps :<: p) qs-   | keepright p,-     Right (qs' :> p') <- commuteFLorComplain (p :> qs)-       = case partitionRL' keepright ps qs' of-         a :> b -> a :> b :<: p'-   | otherwise = partitionRL' keepright ps (p :>: qs)+partitionRL keepright = go . (:> NilFL)+  where+    go :: (RL p :> FL p) wA wB -> (RL p :> RL p) wA wB+    go (NilRL :> qs) = (reverseFL qs :> NilRL)+    go (ps :<: p :> qs)+      | keepright p+      , Just (qs' :> p') <- commuteFL (p :> qs) =+          case go (ps :> qs') of+            a :> b -> a :> b :<: p'+      | otherwise = go (ps :> p :>: qs)  commuteWhatWeCanFL :: Commute p => (p :> FL p) wX wY -> (FL p :> p :> FL p) wX wY commuteWhatWeCanFL = genCommuteWhatWeCanFL commute@@ -139,7 +136,7 @@           rc nms ((n:>ns):_) | Just ms <- removeFL n nms = removeCommon (ms :\/: ns)           rc ms [n:>ns] = ms :\/: n:>:ns           rc ms (_:nss) = rc ms nss-          rc _ [] = impossible -- because we already checked for NilFL case+          rc _ [] = error "impossible case" -- because we already checked for NilFL case  -- | 'removeFL' @x xs@ removes @x@ from @xs@ if @x@ can be commuted to its head. --   Otherwise it returns 'Nothing'@@ -219,6 +216,11 @@                                               Just $ xs:<:p1':<:p2'               swapfirstRL _ = Nothing +-- | 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]+ instance (Eq2 p, Commute p) => Eq2 (FL p) where     a =\/= b | lengthFL a /= lengthFL b = NotEq              | otherwise = cmpSameLength a b@@ -229,7 +231,7 @@     xs =/\= ys = reverseFL xs =/\= reverseFL ys  instance (Eq2 p, Commute p) => Eq2 (RL p) where-    unsafeCompare = bug "Buggy use of unsafeCompare on RL"+    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@@ -238,21 +240,19 @@                    cmpSameLength _ _ = NotEq     xs =\/= ys = reverseRL xs =\/= reverseRL ys --- |Partition a list into the patches that merge with the given patch and those that don't (including dependencies)-partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 wX wY -> p2 wX wZ -> (FL p1 :> FL p1) wX wY-partitionConflictingFL _ NilFL _ = NilFL :> NilFL-partitionConflictingFL commuter (x :>: xs) y =-   case commuter (invert x :> y) of-     Nothing -> case commuteWhatWeCanFL (x :> xs) of-                 xs_ok :> x' :> xs_deps ->-                   case partitionConflictingFL commuter xs_ok y of-                     xs_clean :> xs_conflicts -> xs_clean :> (xs_conflicts +>+ (x' :>: xs_deps))-     Just (y' :> _) ->-       case partitionConflictingFL commuter xs y' of-          xs_clean :> xs_conflicts -> (x :>: xs_clean) :> xs_conflicts--inverseCommuter :: (Invert p, Invert q) => CommuteFn p q -> CommuteFn q p-inverseCommuter commuter (p :> q) =-   do invp' :> invq' <- commuter (invert q :> invert p)-      return (invert invq' :> invert invp')-+-- | 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
src/Darcs/Patch/Prim.hs view
@@ -1,24 +1,30 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim-    ( primIsAddfile, primIsHunk, primIsBinary, primIsSetpref-    , primIsAdddir, is_filepatch-    , summarizePrim-    , applyPrimFL+    ( PrimApply(..)+    , PrimCanonize(..)+    , PrimClassify(..)+    , PrimConstruct(..)+    , PrimDetails(..)+    , PrimMangleUnravelled(..)+    , PrimPatch     , PrimRead(..)     , PrimShow(..)-    , FromPrim(..), FromPrims(..), ToFromPrim(..)-    , PrimPatch, PrimPatchBase(..)-    , PrimConstruct(..)-    , PrimCanonize(..)-    , PrimPatchCommon+    , PrimSift(..)+    , Mangled+    , Unravelled     ) where  import Darcs.Patch.Prim.Class-    ( PrimConstruct(..), PrimCanonize(..)-    , PrimClassify(..), PrimDetails(..)-    , PrimShow(..), PrimRead(..)-    , PrimApply(..)-    , FromPrim(..), FromPrims(..), ToFromPrim(..)-    , PrimPatchBase(..), PrimPatch-    , PrimPatchCommon+    ( PrimApply(..)+    , PrimCanonize(..)+    , PrimClassify(..)+    , PrimConstruct(..)+    , PrimDetails(..)+    , PrimMangleUnravelled(..)+    , PrimPatch+    , PrimRead(..)+    , PrimShow(..)+    , PrimSift(..)+    , Mangled+    , Unravelled     )
src/Darcs/Patch/Prim/Class.hs view
@@ -1,94 +1,67 @@ module Darcs.Patch.Prim.Class     ( PrimConstruct(..), PrimCanonize(..)     , PrimClassify(..), PrimDetails(..)+    , PrimSift(..)     , PrimShow(..), PrimRead(..)     , PrimApply(..)-    , PrimPatch, PrimPatchBase(..)-    , FromPrim(..), FromPrims(..), ToFromPrim(..)-    , PrimPatchCommon+    , PrimPatch+    , PrimMangleUnravelled(..)+    , Mangled+    , Unravelled+    , primCleanMerge     )     where -import Prelude () import Darcs.Prelude  import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.FileHunk ( FileHunk, IsHunk )-import Darcs.Util.Path ( FileName ) import Darcs.Patch.Format ( FileNameFormat, PatchListFormat ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.CommuteFn ( PartialMergeFn ) import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Merge ( CleanMerge(..) ) import Darcs.Patch.Read ( ReadPatch )-import Darcs.Patch.ReadMonads ( ParserM ) 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(..), RL, (:>), mapFL_FL, reverseFL )+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 )  --- | This class describes the abstract interface to primitive patches--- that is indepenent of the on-disk format.-class ( Apply prim-      , Commute prim-      , Invert prim-      , Eq2 prim-      , IsHunk prim-      , PatchInspect prim-      , RepairToFL prim-      , Show2 prim-      , PrimConstruct prim-      , PrimCanonize prim-      , PrimClassify prim-      , PrimDetails prim-      , PrimApply prim-      )-    => PrimPatchCommon prim--class ( PrimPatchCommon prim-      , ReadPatch prim-      , ShowPatch prim-      , ShowContextPatch prim-      , PatchListFormat prim-      )-    => PrimPatch prim--class PrimPatch (PrimOf p) => PrimPatchBase p where-    type PrimOf (p :: (* -> * -> *)) :: (* -> * -> *)--instance PrimPatchBase p => PrimPatchBase (FL p) where-    type PrimOf (FL p) = PrimOf p--instance PrimPatchBase p => PrimPatchBase (RL p) where-    type PrimOf (RL p) = PrimOf p--class FromPrim p where-    fromPrim :: PrimOf p wX wY -> p wX wY--class FromPrim p => ToFromPrim p where-    toPrim :: p wX wY -> Maybe (PrimOf p wX wY)--class FromPrims p where-    fromPrims :: FL (PrimOf p) wX wY -> p wX wY--instance FromPrim p => FromPrim (FL p) where-    fromPrim p = fromPrim p :>: NilFL--instance FromPrim p => FromPrims (FL p) where-    fromPrims = mapFL_FL fromPrim--instance FromPrim p => FromPrims (RL p) where-    fromPrims = reverseFL . mapFL_FL fromPrim+type PrimPatch prim =+    ( Apply prim+    , CleanMerge prim+    , Commute prim+    , Invert prim+    , Eq2 prim+    , IsHunk prim+    , PatchInspect prim+    , RepairToFL prim+    , Show2 prim+    , PrimConstruct prim+    , PrimCanonize prim+    , PrimClassify prim+    , PrimDetails prim+    , PrimApply prim+    , PrimSift prim+    , PrimMangleUnravelled prim+    , ReadPatch prim+    , ShowPatch prim+    , ShowContextPatch prim+    , PatchListFormat prim+    )  class PrimClassify prim where    primIsAddfile :: prim wX wY -> Bool@@ -100,20 +73,19 @@    primIsTokReplace :: prim wX wY -> Bool    primIsBinary :: prim wX wY -> Bool    primIsSetpref :: prim wX wY -> Bool-   is_filepatch :: prim wX wY -> Maybe FileName+   is_filepatch :: prim wX wY -> Maybe AnchoredPath  class PrimConstruct prim where-   addfile :: FilePath -> prim wX wY-   rmfile :: FilePath -> prim wX wY-   adddir :: FilePath -> prim wX wY-   rmdir :: FilePath -> prim wX wY-   move :: FilePath -> FilePath -> prim wX wY+   addfile :: AnchoredPath -> prim wX wY+   rmfile :: AnchoredPath -> prim wX wY+   adddir :: AnchoredPath -> prim wX wY+   rmdir :: AnchoredPath -> prim wX wY+   move :: AnchoredPath -> AnchoredPath -> prim wX wY    changepref :: String -> String -> String -> prim wX wY-   hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> prim wX wY-   tokreplace :: FilePath -> String -> String -> String -> prim wX wY-   binary :: FilePath -> B.ByteString -> B.ByteString -> prim wX wY+   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-   anIdentity :: prim wX wX  class PrimCanonize prim where    -- | @tryToShrink ps@ simplifies @ps@ by getting rid of self-cancellations@@ -124,11 +96,6 @@    --   it finds (as far as I can tell).  Is that OK? Can we try harder?    tryToShrink :: FL prim wX wY -> FL prim wX wY -   -- | @tryShrinkingInverse ps@ deletes the first subsequence of-   --   primitive patches that is followed by the inverse subsequence,-   --   if one exists.  If not, it returns @Nothing@-   tryShrinkingInverse :: FL prim wX wY -> Maybe (FL prim wX wY)-    -- | 'sortCoalesceFL' @ps@ coalesces as many patches in @ps@ as    --   possible, sorting the results in some standard order.    sortCoalesceFL :: FL prim wX wY -> FL prim wX wY@@ -153,9 +120,38 @@    -- or the like).    canonizeFL :: D.DiffAlgorithm -> FL prim wX wY -> FL prim wX wY +   -- | Either 'primCoalesce' or cancel inverses.+   --+   -- 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) +   -- | 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.+   --+   -- prop> Just r == primCoalesce p q => primDecoalesce r p == Just q+   primDecoalesce :: prim wX wZ -> prim wX wY -> Maybe (prim wY wZ)++-- TODO This has been cut'n'pasted from Darcs.Repository.Pending.+--      It is not a good interface and should be re-designed.+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)+ class PrimDetails prim where    summarizePrim :: prim wX wY -> [SummDetail] @@ -164,7 +160,23 @@    showPrimCtx :: ApplyMonad  (ApplyState prim) m => FileNameFormat -> prim wA wB -> m Doc  class PrimRead prim where-   readPrim :: ParserM m => FileNameFormat -> m (Sealed (prim wX))+   readPrim :: FileNameFormat -> Parser (Sealed (prim wX))  class PrimApply prim where    applyPrimFL :: ApplyMonad (ApplyState prim) m => FL prim wX wY -> m ()++-- | A list of conflicting alternatives. They form a connected+-- component of the conflict graph i.e. one transitive conflict.+type Unravelled prim wX = [Sealed (FL prim wX)]++-- | Result of mangling a single Unravelled.+type Mangled prim wX = Sealed (FL prim wX)++class PrimMangleUnravelled prim where+  -- | Mangle conflicting alternatives if possible.+  mangleUnravelled :: Unravelled prim wX -> Maybe (Mangled prim wX)++primCleanMerge :: (Commute prim, Invert prim) => PartialMergeFn prim prim+primCleanMerge (p :\/: q) = do+  q' :> ip' <- commute (invert p :> q)+  return $ q' :/\: invert ip'
src/Darcs/Patch/Prim/FileUUID.hs view
@@ -1,6 +1,8 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Darcs.Patch.Prim.FileUUID ( Prim ) where +import Darcs.Prelude+ import Darcs.Patch.Prim.FileUUID.Apply () import Darcs.Patch.Prim.FileUUID.Coalesce () import Darcs.Patch.Prim.FileUUID.Commute ()@@ -9,13 +11,10 @@ import Darcs.Patch.Prim.FileUUID.Read () import Darcs.Patch.Prim.FileUUID.Show () -import Darcs.Patch.Prim.Class ( PrimPatchCommon, PrimPatch, PrimPatchBase(..), FromPrim(..) )--instance PrimPatchCommon Prim-instance PrimPatch Prim--instance PrimPatchBase Prim where-  type PrimOf Prim = Prim+import Darcs.Patch.Prim.Class+  ( PrimMangleUnravelled(..)+  ) -instance FromPrim Prim where-  fromPrim = id+-- dummy implementation+instance PrimMangleUnravelled Prim where+  mangleUnravelled _ = Nothing
src/Darcs/Patch/Prim/FileUUID/Apply.hs view
@@ -2,7 +2,6 @@ {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} module Darcs.Patch.Prim.FileUUID.Apply ( hunkEdit, ObjectMap(..) ) where -import Prelude () import Darcs.Prelude  import Control.Monad.State( StateT, runStateT, gets, lift, put )
src/Darcs/Patch/Prim/FileUUID/Coalesce.hs view
@@ -1,18 +1,14 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-missing-methods #-} module Darcs.Patch.Prim.FileUUID.Coalesce () where -import Prelude () import Darcs.Prelude -import Darcs.Patch.Prim.Class ( PrimCanonize(..) )-import Darcs.Patch.Witnesses.Ordered( FL(..) )+import Darcs.Patch.Prim.Class ( PrimCanonize(..), PrimSift(..) ) import Darcs.Patch.Prim.FileUUID.Core( Prim ) --- TODO+-- none of the methods are implemented instance PrimCanonize Prim where-   tryToShrink = error "tryToShrink"-   tryShrinkingInverse _ = error "tryShrinkingInverse"-   sortCoalesceFL = id-   canonize _ = (:>: NilFL)-   canonizeFL _ = id-   coalesce = const Nothing+  sortCoalesceFL = id -- just so that we can use it in the tests++-- none of the methods are implemented+instance PrimSift Prim
src/Darcs/Patch/Prim/FileUUID/Commute.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.FileUUID.Commute () where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString as B (length)@@ -10,8 +9,9 @@ import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..) ) import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Merge ( CleanMerge(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL-+import Darcs.Patch.Prim.Class ( primCleanMerge )  -- For FileUUID it is easier to list the cases that do /not/ commute depends :: (Prim :> Prim) wX wY -> Bool@@ -60,3 +60,6 @@     len_new2 = B.length new2     yes (off2', off1') = Just (H off2' old2 new2 :> H off1' old1 new1)     no = Nothing++instance CleanMerge Prim where+  cleanMerge = primCleanMerge
src/Darcs/Patch/Prim/FileUUID/Core.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-}- -- Copyright (C) 2011 Petr Rockai -- -- Permission is hereby granted, free of charge, to any person@@ -35,11 +33,10 @@     , FileContent     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Witnesses.Eq ( Eq2(..) )-import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.FileHunk( IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) )@@ -53,12 +50,12 @@ data Hunk wX wY = H !Int !FileContent !FileContent   deriving (Eq, Show) -instance Show1 (Hunk wX) where-  showDict1 = ShowDictClass+type role Hunk nominal nominal -instance Show2 Hunk where-  showDict2 = ShowDictClass+instance Show1 (Hunk wX) +instance Show2 Hunk+ invertHunk :: Hunk wX wY -> Hunk wY wX invertHunk (H off old new) = H off new old @@ -71,6 +68,8 @@ data HunkMove wX wY = HM !UUID !Int !UUID !Int !FileContent   deriving (Eq, Show) +type role HunkMove nominal nominal+ invertHunkMove :: HunkMove wX wY -> HunkMove wY wX invertHunkMove (HM sid soff tid toff content) = HM tid toff sid soff content @@ -91,11 +90,9 @@ deriving instance Eq (Prim wX wY) deriving instance Show (Prim wX wY) -instance Show1 (Prim wX) where-  showDict1 = ShowDictClass+instance Show1 (Prim wX) -instance Show2 Prim where-  showDict2 = ShowDictClass+instance Show2 Prim  -- TODO: PrimClassify doesn't make sense for FileUUID prims instance PrimClassify Prim where@@ -122,7 +119,6 @@   tokreplace _ _ _ _ = error "PrimConstruct tokreplace"   binary _ _ _ = error "PrimConstruct binary"   primFromHunk _ = error "PrimConstruct primFromHunk"-  anIdentity = Identity  instance IsHunk Prim where   isHunk _ = Nothing
src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs view
@@ -27,7 +27,6 @@     , Name -- re-export     ) where -import Prelude () import Darcs.Prelude  import Darcs.Util.Hash ( Hash )
src/Darcs/Patch/Prim/FileUUID/Read.hs view
@@ -1,22 +1,19 @@-{-# LANGUAGE CPP, ViewPatterns, OverloadedStrings #-}+{-# LANGUAGE ViewPatterns, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.FileUUID.Read () where -import Prelude ()-import Darcs.Prelude+import Darcs.Prelude hiding ( take ) +import Control.Monad ( liftM, liftM2 )+ import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.ReadMonads import Darcs.Patch.Prim.Class( PrimRead(..) ) import Darcs.Patch.Prim.FileUUID.Core( Prim(..), Hunk(..) ) import Darcs.Patch.Prim.FileUUID.ObjectMap import Darcs.Patch.Witnesses.Sealed( seal )-import Darcs.Util.Path ( unsafeMakeName ) -import Control.Monad ( liftM, liftM2 )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Data.Char ( chr )+import Darcs.Util.Path ( decodeWhiteName )+import Darcs.Util.Parser  instance PrimRead Prim where   readPrim _ = do@@ -31,13 +28,13 @@       manifest kind ctor = liftM2 ctor (patch kind) location       identity = lexString "identity" >> return Identity       patch x = string x >> uuid-      uuid = UUID <$> myLex'-      filename = unsafeMakeName . decodeWhite <$> myLex'+      uuid = UUID <$> lexWord+      filename = decodeWhiteName <$> lexWord       content = do         lexString "content"         len <- int         _ <- char '\n'-        Darcs.Patch.ReadMonads.take len+        take len       location = liftM2 L uuid filename       hunk kind ctor = do         uid <- patch kind@@ -47,17 +44,4 @@         return $ ctor uid (H offset old new)  instance ReadPatch Prim where- readPatch' = readPrim undefined---- XXX a bytestring version of decodeWhite from Darcs.FileName-decodeWhite :: B.ByteString -> B.ByteString-decodeWhite (BC.uncons -> Just ('\\', cs)) =-    case BC.break (=='\\') cs of-    (theord, BC.uncons -> Just ('\\', rest)) ->-        chr (read $ BC.unpack theord) `BC.cons` decodeWhite rest-    _ -> error "malformed filename"-decodeWhite (BC.uncons -> Just (c, cs)) = c `BC.cons` decodeWhite cs-decodeWhite (BC.uncons -> Nothing) = BC.empty-#if !MIN_VERSION_base(4,14,0)-decodeWhite _ = impossible-#endif+  readPatch' = readPrim undefined
src/Darcs/Patch/Prim/FileUUID/Show.hs view
@@ -4,7 +4,6 @@     ( displayHunk )     where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString as B@@ -29,8 +28,8 @@ instance PatchListFormat Prim  fileNameFormat :: ShowPatchFor -> FileNameFormat-fileNameFormat ForDisplay = UserFormat-fileNameFormat ForStorage = NewFormat+fileNameFormat ForDisplay = FileNameFormatDisplay+fileNameFormat ForStorage = FileNameFormatV2  instance ShowPatchBasic Prim where   showPatch fmt = showPrim (fileNameFormat fmt)@@ -46,14 +45,14 @@   thing _ = "change"  instance PrimShow Prim where-  showPrim UserFormat (Hunk u h) = displayHunk (Just u) h+  showPrim FileNameFormatDisplay (Hunk u h) = displayHunk (Just u) h   showPrim _ (Hunk u h) = storeHunk u h-  showPrim UserFormat (HunkMove hm) = displayHunkMove hm+  showPrim FileNameFormatDisplay (HunkMove hm) = displayHunkMove hm   showPrim _ (HunkMove hm) = storeHunkMove hm   showPrim _ (Manifest f (L d p)) = showManifest "manifest" d f p   showPrim _ (Demanifest f (L d p)) = showManifest "demanifest" d f p   showPrim _ Identity = blueText "identity"-  showPrimCtx _ _ = bug "show with context not implemented"+  showPrimCtx _ _ = error "show with context not implemented"  showManifest :: String -> UUID -> UUID -> Name -> Doc showManifest txt dir file name =
+ src/Darcs/Patch/Prim/Named.hs view
@@ -0,0 +1,110 @@+-- -fno-cse is here because of anonymousNamedPrim - see the comments on that+{-# OPTIONS_GHC -fno-cse #-}+-- | Wrapper for prim patches to give them an identity derived from the identity+-- of the containined Named patch.+module Darcs.Patch.Prim.Named+    ( NamedPrim+    -- accessors+    , PrimPatchId+    , namedPrim+    , positivePrimPatchIds+    , anonymousNamedPrim+    -- for testing+    , unsafePrimPatchId+    , prop_primPatchIdNonZero+    ) where++import Control.Monad ( mzero )++import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL++import qualified Data.Binary as Binary+import Crypto.Random ( getRandomBytes )+import System.IO.Unsafe ( unsafePerformIO )++import Darcs.Prelude hiding ( take )++import Darcs.Patch.Ident ( PatchId, SignedId(..), StorableId(..) )+import Darcs.Patch.Info ( PatchInfo, makePatchname )+import Darcs.Patch.Prim.WithName ( PrimWithName(..) )+import Darcs.Patch.Show ( ShowPatchFor(..) )++import Darcs.Test.TestOnly+import Darcs.Util.Hash ( SHA1, sha1Show, sha1Read )+import Darcs.Util.Parser+import Darcs.Util.Printer++-- TODO [V3INTEGRATION]:+-- Review whether we can use a PatchInfo directly here instead of a SHA1+-- Unless we can use observable sharing, this might be significantly+-- slower/less space efficient.+-- | Signed patch identity.+-- The 'SHA1' hash of the non-inverted meta data ('PatchInfo') plus an 'Int'+-- for the sequence number within the named patch, starting with 1. The 'Int'+-- gets inverted together with the patch and must never be 0 else we could not+-- distinguish between the patch and its inverse.+data PrimPatchId = PrimPatchId !Int !SHA1+  deriving (Eq, Ord, Show)++-- | This should only be used for testing, as it exposes the internal structure+-- of a 'PrimPatchId'.+unsafePrimPatchId :: TestOnly => Int -> SHA1 -> PrimPatchId+unsafePrimPatchId = PrimPatchId++prop_primPatchIdNonZero :: PrimPatchId -> Bool+prop_primPatchIdNonZero (PrimPatchId i _) = i /= 0++instance SignedId PrimPatchId where+  positiveId (PrimPatchId i _) = i > 0+  invertId (PrimPatchId i h) = PrimPatchId (- i) h++-- | Create an infinite list of positive 'PrimPatchId's.+positivePrimPatchIds :: PatchInfo -> [PrimPatchId]+positivePrimPatchIds info = map (flip PrimPatchId (makePatchname info)) [1..]++type NamedPrim = PrimWithName PrimPatchId++namedPrim :: PrimPatchId -> p wX wY -> NamedPrim p wX wY+namedPrim = PrimWithName++type instance PatchId (NamedPrim p) = PrimPatchId++-- TODO [V3INTEGRATION]:+-- It might be nice to elide the patch identifiers from the+-- on-disk format when they are the same as that of the containing patch+-- (which is the common case when there are no conflicts).+-- It's not that easy to implement as it requires refactoring to pass+-- the patch identifier downwards.+-- The sequence numbers could also be inferred from position.+instance StorableId PrimPatchId where+  readId = do+    lexString (BC.pack "hash")+    i <- int+    skipSpace+    x <- take 40+    liftMaybe $ PrimPatchId i <$> sha1Read x+   where+     liftMaybe = maybe mzero return++  showId ForStorage (PrimPatchId i h) =+    text "hash" <+> text (show i) <+> packedString (sha1Show h)+  showId ForDisplay _ = mempty++-- Because we are using unsafePerformIO, we need -fno-cse for+-- this module. We don't need -fno-full-laziness because the+-- body of the unsafePerformIO mentions 'p' so can't float outside+-- the scope of 'p'.+-- http://hackage.haskell.org/package/base-4.12.0.0/docs/System-IO-Unsafe.html+{-# NOINLINE anonymousNamedPrim #-}+anonymousNamedPrim :: p wX wY -> NamedPrim p wX wY+anonymousNamedPrim p =+  unsafePerformIO $ do+    b20 <- getRandomBytes 20+    b8 <- getRandomBytes 8+    return $+      PrimWithName+        (PrimPatchId+           (abs (Binary.decode $ BL.fromStrict b8))+           (Binary.decode $ BL.fromStrict b20))+        p
src/Darcs/Patch/Prim/V1.hs view
@@ -1,14 +1,91 @@ {-# 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 () import Darcs.Patch.Prim.V1.Core ( Prim ) import Darcs.Patch.Prim.V1.Details ()+import Darcs.Patch.Prim.V1.Mangle () import Darcs.Patch.Prim.V1.Read () import Darcs.Patch.Prim.V1.Show () -import Darcs.Patch.Prim.Class ( PrimPatchCommon )+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 PrimPatchCommon Prim+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
@@ -1,9 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1.Apply () where -import Prelude () import Darcs.Prelude +import Control.Exception ( throw )+ import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Repair ( RepairToFL(..) ) @@ -13,8 +14,8 @@       DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Prim.V1.Show ( showHunk ) -import Darcs.Util.Path ( FileName, fn2fp )-import Darcs.Patch.Format ( FileNameFormat(UserFormat) )+import Darcs.Util.Path ( AnchoredPath, anchorPath )+import Darcs.Patch.Format ( FileNameFormat(FileNameFormatDisplay) ) import Darcs.Patch.TokenReplace ( tryTokReplace )  import Darcs.Patch.ApplyMonad ( ApplyMonadTree(..) )@@ -26,14 +27,23 @@ import Darcs.Util.ByteString ( unlinesPS ) import Darcs.Util.Printer( renderString ) -import Control.Exception ( throw )--import qualified Data.ByteString            as B-import qualified Data.ByteString.Internal   as BI-import qualified Data.ByteString.Char8 as BC (pack, unpack, unlines)+import qualified Data.ByteString as B+    ( ByteString+    , drop+    , empty+    , null+    , concat+    , isPrefixOf+    , length+    , splitAt+    )+import qualified Data.ByteString.Char8 as BC (pack, unpack, unlines, elemIndices)  type FileContents = B.ByteString +ap2fp :: AnchoredPath -> FilePath+ap2fp = anchorPath ""+ instance Apply Prim where     type ApplyState Prim = Tree     apply (FP f RmFile) = mRemoveFile f@@ -42,13 +52,14 @@     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 " ++ fn2fp f+                  Nothing -> throw $ 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 $ "binary patch to " ++ fn2fp f+                             else throw $ userError+                                  $ "binary patch to " ++ ap2fp f                                   ++ " couldn't apply."     apply (DP d AddDir) = mCreateDirectory d     apply (DP d RmDir) = mRemoveDirectory d@@ -61,7 +72,7 @@            mRemoveFile f            return $ if B.null x                         then Nothing-                        else Just ("WARNING: Fixing removal of non-empty file "++fn2fp f,+                        else Just ("WARNING: Fixing removal of non-empty file "++ap2fp f,                                    -- No need to coerce because the content                                    -- removal patch has freely decided contexts                                    FP f (Binary x B.empty) :>: FP f RmFile :>: NilFL )@@ -69,7 +80,7 @@         do exists <- mDoesFileExist f            if exists              then return $-                     Just ("WARNING: Dropping add of existing file "++fn2fp f,+                     Just ("WARNING: Dropping add of existing file "++ap2fp f,                            -- the old context was wrong, so we have to coerce                            unsafeCoercePStart NilFL                           )@@ -79,12 +90,21 @@         do exists <- mDoesDirectoryExist f            if exists              then return $-                     Just ("WARNING: Dropping add of existing directory "++fn2fp f,+                     Just ("WARNING: Dropping add of existing directory "++ap2fp f,                            -- the old context was wrong, so we have to coerce                            unsafeCoercePStart NilFL                           )              else do mCreateDirectory f                      return Nothing+    applyAndTryToFixFL (FP f (Binary old new)) =+        do x <- mReadFilePS f+           mModifyFilePS f (\_ -> return new)+           if x /= old+             then return $+                     Just ("WARNING: Fixing binary patch to "++ap2fp f,+                           FP f (Binary x new) :>: NilFL+                          )+             else return Nothing     applyAndTryToFixFL p = do apply p; return Nothing  instance PrimApply Prim where@@ -104,11 +124,11 @@               hunkmod NilFL content = return content               hunkmod (Hunk line old new:>:hs) content =                   applyHunk f (line, old, new) content >>= hunkmod hs-              hunkmod _ _ = impossible+              hunkmod _ _ = error "impossible case"     applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps  applyHunk :: Monad m-          => FileName+          => AnchoredPath           -> (Int, [B.ByteString], [B.ByteString])           -> FileContents           -> m FileContents@@ -118,10 +138,10 @@     Left msg ->       throw $ userError $       "### Error applying:\n" ++ renderHunk h ++-      "\n### to file " ++ fn2fp f ++ ":\n" ++ BC.unpack fc +++      "\n### to file " ++ ap2fp f ++ ":\n" ++ BC.unpack fc ++       "### Reason: " ++ msg   where-    renderHunk (l, o, n) = renderString (showHunk UserFormat f l o n)+    renderHunk (l, o, n) = renderString (showHunk FileNameFormatDisplay f l o n)  {- The way darcs handles newlines is not easy to understand. @@ -207,7 +227,7 @@ breakAfterNthNewline :: Int -> B.ByteString -> Maybe (B.ByteString, B.ByteString) breakAfterNthNewline 0 the_ps = Just (B.empty, the_ps) breakAfterNthNewline n _ | n < 0 = error "precondition of breakAfterNthNewline"-breakAfterNthNewline n the_ps = go n (B.elemIndices (BI.c2w '\n') the_ps)+breakAfterNthNewline n the_ps = go n (BC.elemIndices '\n' the_ps)   where     go _ [] = Nothing -- we have fewer than n newlines     go 1 (i:_) = Just $ B.splitAt (i + 1) the_ps@@ -215,7 +235,7 @@  breakBeforeNthNewline :: Int -> B.ByteString -> Either String (B.ByteString, B.ByteString) breakBeforeNthNewline n _ | n < 0 = error "precondition of breakBeforeNthNewline"-breakBeforeNthNewline n the_ps = go n (B.elemIndices (BI.c2w '\n') the_ps)+breakBeforeNthNewline n the_ps = go n (BC.elemIndices '\n' the_ps)   where     go 0 [] = Right (the_ps, B.empty)     go 0 (i:_) = Right $ B.splitAt i the_ps
src/Darcs/Patch/Prim/V1/Coalesce.hs view
@@ -3,10 +3,8 @@     ()     where -import Prelude () import Darcs.Prelude -import Prelude hiding ( pi ) import Control.Arrow ( second ) import Data.Maybe ( fromMaybe ) import Data.Map ( elems, fromListWith, mapWithKey )@@ -28,35 +26,17 @@     , reverseRL, mapFL, mapFL_FL     , concatFL, lengthFL, (+>+) ) import Darcs.Patch.Witnesses.Sealed-    ( unseal, Sealed2(..), unsafeUnseal2+    ( unseal, Sealed2(..), unseal2     , Gap(..), unFreeLeft     ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )-import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Invert ( Invert(..), dropInverses ) import Darcs.Patch.Commute ( Commute(..) )  import Darcs.Util.Diff ( getChanges ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Path ( FileName, fp2fn )---- | 'coalesceFwd' @p1 :> p2@ tries to combine @p1@ and @p2@ into a single---   patch without intermediary changes.  For example, two hunk patches---   modifying adjacent lines can be coalesced into a bigger hunk patch.---   Or a patch which moves file A to file B can be coalesced with a---   patch that moves file B into file C, yielding a patch that moves---   file A to file C.-coalesceFwd :: (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY)-coalesceFwd (FP f1 _ :> FP f2 _) | f1 /= f2 = Nothing-coalesceFwd (p1 :> p2) | IsEq <- invert p1 =\/= p2 = Just NilFL-coalesceFwd (FP f1 p1 :> FP _ p2) = fmap (:>: NilFL) $ coalesceFilePrim f1 (p1 :> p2) -- f1 = f2-coalesceFwd (Move a b :> Move b' a') | b == b' = Just $ Move a a' :>: NilFL-coalesceFwd (FP f AddFile :> Move a b) | f == a = Just $ FP b AddFile :>: NilFL-coalesceFwd (DP f AddDir :> Move a b) | f == a = Just $ DP b AddDir :>: NilFL-coalesceFwd (Move a b :> FP f RmFile) | b == f = Just $ FP a RmFile :>: NilFL-coalesceFwd (Move a b :> DP f RmDir) | b == f = Just $ DP a RmDir :>: NilFL-coalesceFwd (ChangePref p1 f1 t1 :> ChangePref p2 f2 t2) | p1 == p2 && t1 == f2 = Just $ ChangePref p1 f1 t2 :>: NilFL-coalesceFwd _ = Nothing+import Darcs.Util.Path ( AnchoredPath, floatPath )  mapPrimFL :: (forall wX wY . FL Prim wX wY -> FL Prim wX wY)              -> FL Prim wW wZ -> FL Prim wW wZ@@ -71,36 +51,34 @@      Nothing -> f x   where         unsealList :: [Sealed2 p] -> FL p wA wB-        unsealList = foldr ((:>:) . unsafeUnseal2) (unsafeCoerceP NilFL)+        unsealList = foldr ((:>:) . unseal2 unsafeCoerceP) (unsafeCoerceP NilFL) -        toSimpleSealed :: Sealed2 Prim -> Maybe (FileName, Sealed2 Simple)+        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 (FileName, Simple wX wY)+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 (fp2fn $ darcsdir </> "prefs" </> "prefs", SCP a b c)+toSimple (ChangePref a b c) = Just (floatPath (darcsdir </> "prefs" </> "prefs"), SCP a b c) -fromSimple :: FileName -> Simple wX wY -> Prim wX wY+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 :: FileName -> FL Simple wX wY -> FL Prim wX wY+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 (tryShrinkingInverse x)+tryHarderToShrink x = tryToShrink2 $ fromMaybe x (dropInverses x)  tryToShrink2 :: FL Prim wX wY -> FL Prim wX wY tryToShrink2 psold =@@ -125,7 +103,7 @@         -> Maybe (FL Prim wW wZ) tryOne _ _ NilFL = Nothing tryOne sofar p (p1:>:ps) =-    case coalesceFwd (p :> p1) of+    case coalesceOrCancel p p1 of     Just p' -> Just (reverseRL sofar +>+ p' +>+ ps)     Nothing -> case commute (p :> p1) of                Nothing -> Nothing@@ -159,10 +137,10 @@                     -> Either (FL Prim wX wZ) (FL Prim wX wZ) pushCoalescePatch new NilFL = Left (new:>:NilFL) pushCoalescePatch new ps@(p:>:ps')-    = case coalesceFwd (new :> p) of+    = case coalesceOrCancel new p of       Just (new' :>: NilFL) -> Right $ either id id $ pushCoalescePatch new' ps'       Just NilFL -> Right ps'-      Just _ -> impossible -- coalesce either returns a singleton or empty+      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') ->@@ -172,21 +150,71 @@                                      Left r -> Left (p' :>: r)                                  Nothing -> Left (new:>:ps) -coalesceFilePrim :: FileName -> (FilePatchType :> FilePatchType) wX wY-                  -> Maybe (Prim wX wY)-coalesceFilePrim f (Hunk line1 old1 new1 :> Hunk line2 old2 new2)+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++-- | @'coalescePair' p1 p2@ tries to combine @p1@ and @p2@ into a single+--   patch. For example, two hunk patches+--   modifying adjacent lines can be coalesced into a bigger hunk patch.+--   Or a patch which moves file A to file B can be coalesced with a+--   patch that moves file B into file C, yielding a patch that moves+--   file A to file C.+coalescePair :: Prim wX wY -> Prim wY wZ -> Maybe (Prim wX wZ)+coalescePair (FP f1 p1) (FP f2 p2)+  | f1 /= f2 = Nothing+  | otherwise = coalesceFilePrim f1 p1 p2+coalescePair (Move a b) (Move b' c) | b == b' = Just $ Move a c+coalescePair (FP a AddFile) (Move a' b) | a == a' = Just $ FP b AddFile+coalescePair (DP a AddDir) (Move a' b) | a == a' = Just $ DP b AddDir+coalescePair (Move a b) (FP b' RmFile) | b == b' = Just $ FP a RmFile+coalescePair (Move a b) (DP b' RmDir) | b == b' = Just $ DP a RmDir+{- 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 (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 line2 old2 new2 line1 old1 new1 -- Token replace patches operating right after (or before) AddFile (RmFile) -- is an identity patch, as far as coalescing is concerned.-coalesceFilePrim f (AddFile :> TokReplace{}) = Just $ FP f AddFile-coalesceFilePrim f (TokReplace{} :> RmFile) = Just $ FP f RmFile-coalesceFilePrim f (TokReplace t1 o1 n1 :> TokReplace t2 o2 n2)-    | t1 == t2 && n1 == o2 = Just $ FP f $ TokReplace t1 o1 n2-coalesceFilePrim f (Binary o m' :> Binary m n)+-- 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)+    | t1 == t2 && b == b' = Just $ FP f $ TokReplace t1 a c+coalesceFilePrim f (Binary o m') (Binary m n)     | m == m' = Just $ FP f $ Binary o n-coalesceFilePrim _ _ = Nothing+coalesceFilePrim _ _ _ = Nothing -coalesceHunk :: FileName+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]              -> Maybe (Prim wX wY)@@ -214,7 +242,7 @@           lengthnew2 = length new2  canonizeHunk :: Gap w-             => D.DiffAlgorithm -> FileName -> Int -> [B.ByteString] -> [B.ByteString]+             => 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]@@ -222,7 +250,7 @@ canonizeHunk da f line old new = makeHoley f line $ getChanges da old new  makeHoley :: Gap w-          => FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])]+          => 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)@@ -230,19 +258,15 @@ instance PrimCanonize Prim where    tryToShrink = mapPrimFL tryHarderToShrink -   tryShrinkingInverse (x:>:y:>:z)-       | IsEq <- invert x =\/= y = Just z-       | otherwise = case tryShrinkingInverse (y:>:z) of-                     Nothing -> Nothing-                     Just yz' -> Just $ fromMaybe (x :>: yz') $ tryShrinkingInverse (x:>:yz')-   tryShrinkingInverse _ = Nothing-    sortCoalesceFL = mapPrimFL sortCoalesceFL2    canonize _ p | IsEq <- isIdentity p = NilFL    canonize da (FP f (Hunk line old new)) = unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk da f line old new    canonize _ p = p :>: NilFL-   -- Running canonize twice is apparently necessary to fix issue525;-   -- would be nice to understand why.-   canonizeFL da = concatFL . mapFL_FL (canonize da) . sortCoalesceFL .-                   concatFL . mapFL_FL (canonize da)-   coalesce = coalesceFwd+   -- 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
src/Darcs/Patch/Prim/V1/Commute.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1.Commute     ( Perhaps(..)@@ -10,27 +9,43 @@     , commuteFilepatches     ) where -import Prelude () import Darcs.Prelude -import Prelude hiding ( pi, Applicative(..) ) import Control.Monad ( MonadPlus, msum, mzero, mplus ) import Control.Applicative ( Alternative(..) )  import qualified Data.ByteString as B ( ByteString ) import qualified Data.ByteString.Char8 as BC ( pack ) -import Darcs.Util.Path ( FileName, fn2fp, movedirfilename )+import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..) ) import Darcs.Patch.Prim.V1.Core      ( Prim(..), FilePatchType(..) ) import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Merge ( CleanMerge(..) ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL+import Darcs.Patch.Prim.Class ( primCleanMerge ) import Darcs.Patch.TokenReplace ( tryTokReplace ) -isInDirectory :: FileName -> FileName -> Bool+isSuperdir :: AnchoredPath -> AnchoredPath -> Bool+isSuperdir d1 d2 = isPrefix d1 d2 && d1 /= d2++{-+This is the original definition.+Note that it explicitly excludes equality:++isSuperdir d1 d2 = isd (fn2fp d1) (fn2fp d2)+  where+    isd s1 s2 =+      length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/"+-}++isInDirectory :: AnchoredPath -> AnchoredPath -> Bool+isInDirectory = isPrefix+{-+Again, here is the orginial definition: isInDirectory d f = iid (fn2fp d) (fn2fp f)     where iid (cd:cds) (cf:cfs)               | cd /= cf = False@@ -38,6 +53,7 @@           iid [] ('/':_) = True           iid [] [] = True -- Count directory itself as being in directory...           iid _ _ = False+-}  data Perhaps a = Unknown | Failed | Succeeded a @@ -59,10 +75,6 @@     Failed   >>= _      =  Failed     Unknown  >>= _      =  Unknown     return              =  Succeeded-#if MIN_VERSION_base(4,13,0)-instance MonadFail Perhaps where-#endif-    fail _              =  Unknown  instance Alternative Perhaps where     empty = Unknown@@ -127,11 +139,6 @@                                 everythingElseCommute x                                ] -isSuperdir :: FileName -> FileName -> Bool-isSuperdir d1 d2 = isd (fn2fp d1) (fn2fp d2)-    where isd s1 s2 =-              length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/"- commuteFiledir :: CommuteFunction commuteFiledir (FP f1 p1 :> FP f2 p2) =   if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerceP p2) :> FP f1 (unsafeCoerceP p1) )@@ -145,6 +152,8 @@     then Succeeded (DP d (unsafeCoerceP dp) :> FP f (unsafeCoerceP fp))     else Failed +-- FIXME using isSuperdir here makes no sense, should use just isPrefix+ commuteFiledir (FP f1 p1 :> Move d d')     | f1 == d' = Failed     | (p1 == AddFile || p1 == RmFile) && d == f1 = Failed@@ -172,7 +181,7 @@ commuteFilepatches (FP f1 p1 :> FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :> p2) commuteFilepatches _ = Unknown -commuteFP :: FileName -> (FilePatchType :> FilePatchType) wX wY+commuteFP :: AnchoredPath -> (FilePatchType :> FilePatchType) wX wY           -> Perhaps ((Prim :> Prim) wX wY) commuteFP f (p1 :> Hunk line1 [] []) =     Succeeded (FP f (Hunk line1 [] []) :> FP f (unsafeCoerceP p1))@@ -222,3 +231,6 @@ tryTokReplaces :: String -> B.ByteString -> B.ByteString                -> [B.ByteString] -> Maybe [B.ByteString] tryTokReplaces t o n = mapM (tryTokReplace t o n)++instance CleanMerge Prim where+  cleanMerge = primCleanMerge
src/Darcs/Patch/Prim/V1/Core.hs view
@@ -23,12 +23,11 @@        )        where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString as B (ByteString) -import Darcs.Util.Path ( FileName, fn2fp, fp2fn, normPath )+import Darcs.Util.Path ( AnchoredPath ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Debug ( PatchDebug(..) )@@ -39,9 +38,9 @@ import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) )  data Prim wX wY where-    Move :: !FileName -> !FileName -> Prim wX wY-    DP :: !FileName -> !(DirPatchType wX wY) -> Prim wX wY-    FP :: !FileName -> !(FilePatchType wX wY) -> Prim wX wY+    Move :: !AnchoredPath -> !AnchoredPath -> Prim wX wY+    DP :: !AnchoredPath -> !(DirPatchType wX wY) -> Prim wX wY+    FP :: !AnchoredPath -> !(FilePatchType wX wY) -> Prim wX wY     ChangePref :: !String -> !String -> !String -> Prim wX wY  data FilePatchType wX wY@@ -52,15 +51,30 @@     | Binary B.ByteString B.ByteString     deriving (Eq,Ord) +type role FilePatchType nominal nominal+ data DirPatchType wX wY = RmDir | AddDir                            deriving (Eq,Ord) +type role DirPatchType nominal nominal+ instance Eq2 FilePatchType where     unsafeCompare a b = a == unsafeCoerceP b +instance Invert FilePatchType where+    invert RmFile = AddFile+    invert AddFile = RmFile+    invert (Hunk line old new) = Hunk line new old+    invert (TokReplace t o n) = TokReplace t n o+    invert (Binary o n) = Binary n o+ instance Eq2 DirPatchType where     unsafeCompare a b = a == unsafeCoerceP b +instance Invert DirPatchType where+    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@@ -103,42 +117,33 @@ evalargs f x y = (f $! x) $! y  instance PrimConstruct Prim where-   addfile f = FP (fp2fn $ nFn f) AddFile-   rmfile f = FP (fp2fn $ nFn f) RmFile-   adddir d = DP (fp2fn $ nFn d) AddDir-   rmdir d = DP (fp2fn $ nFn d) RmDir-   move f f' = Move (fp2fn $ nFn f) (fp2fn $ nFn f')+   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 (fp2fn $ nFn f) (Hunk line old new)+   hunk f line old new = evalargs FP f (Hunk line old new)    tokreplace f tokchars old new =-       evalargs FP (fp2fn $ nFn f) (TokReplace tokchars old new)-   binary f old new = FP (fp2fn $! nFn f) $ Binary old new-   primFromHunk (FileHunk fn line before after) = FP fn (Hunk line before after)-   anIdentity = let fp = "./dummy" in move fp fp--nFn :: FilePath -> FilePath-nFn f = "./"++(fn2fp $ normPath $ fp2fn f)+       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 IsHunk Prim where-   isHunk (FP fn (Hunk line before after)) = Just (FileHunk fn line before after)+   isHunk (FP f (Hunk line before after)) = Just (FileHunk f line before after)    isHunk _ = Nothing  instance Invert Prim where-    invert (FP f RmFile)  = FP f AddFile-    invert (FP f AddFile)  = FP f RmFile-    invert (FP f (Hunk line old new))  = FP f $ Hunk line new old-    invert (FP f (TokReplace t o n)) = FP f $ TokReplace t n o-    invert (FP f (Binary o n)) = FP f $ Binary n o-    invert (DP d RmDir) = DP d AddDir-    invert (DP d AddDir) = DP d RmDir+    invert (FP f p)  = FP f (invert p)+    invert (DP d p) = DP d (invert p)     invert (Move f f') = Move f' f     invert (ChangePref p f t) = ChangePref p t f  instance PatchInspect Prim where     -- Recurse on everything, these are potentially spoofed patches-    listTouchedFiles (Move f1 f2) = map fn2fp [f1, f2]-    listTouchedFiles (FP f _) = [fn2fp f]-    listTouchedFiles (DP d _) = [fn2fp d]+    listTouchedFiles (Move f1 f2) = [f1, f2]+    listTouchedFiles (FP f _) = [f]+    listTouchedFiles (DP d _) = [d]     listTouchedFiles (ChangePref _ _ _) = []      hunkMatches f (FP _ (Hunk _ remove add)) = anyMatches remove || anyMatches add
src/Darcs/Patch/Prim/V1/Details.hs view
@@ -3,7 +3,6 @@     ()     where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Prim.Class ( PrimDetails(..) )
+ src/Darcs/Patch/Prim/V1/Mangle.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.Prim.V1.Mangle () where++import Darcs.Prelude++import qualified Data.ByteString.Char8 as BC (pack, last)+import qualified Data.ByteString as B (null, ByteString)+import Data.Maybe ( isJust, listToMaybe )+import Data.List ( sort, intercalate, nub )++import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )+import Darcs.Patch.Inspect ( PatchInspect(listTouchedFiles) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Prim.Class+    ( PrimConstruct(primFromHunk)+    , PrimMangleUnravelled(..)+    )+import Darcs.Patch.Prim.V1.Core ( Prim )+import Darcs.Patch.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] }++-- | An infinite list of undefined lines.+unknownFileState :: FileState wX+unknownFileState = FileState (repeat Nothing)++-- | Note that @applyHunk p . applyHunk (invert p) /= id@: it converts+-- undefined lines ('Nothing') to defined ones ('Just' the old content of @p@).+applyHunk :: FileHunk wX wY -> FileState wX -> FileState wY+applyHunk (FileHunk _ line old new) = FileState . go . content+  where+    go mls =+      case splitAt (line - 1) mls of+        (before, rest) ->+          concat [before, map Just new, drop (length old) rest]++-- | Iterate 'applyHunk'.+applyHunks :: FL FileHunk wX wY -> FileState wX -> FileState wY+applyHunks NilFL = id+applyHunks (p:>:ps) = applyHunks ps . applyHunk p+++instance PrimMangleUnravelled Prim where+  mangleUnravelled pss = do+      hunks <- onlyHunks pss+      filename <- listToMaybe (filenames pss)+      return $ mapSeal ((:>: NilFL) . primFromHunk) $ mangleHunks filename hunks+    where+      -- | The names of all touched files.+      filenames = nub . concatMap (unseal listTouchedFiles)++      -- | Convert every prim in the input to a 'FileHunk', or fail.+      onlyHunks :: forall prim wX. IsHunk prim+                => [Sealed (FL prim wX)]+                -> Maybe [Sealed (FL FileHunk wX)]+      onlyHunks = mapM toHunk where+        toHunk :: Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk 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 _ [] = error "mangleHunks called with empty list of alternatives"+      mangleHunks path ps = Sealed (FileHunk path l old new)+        where+          oldf    = foldl oldFileState unknownFileState ps+          newfs   = map (newFileState oldf) ps+          l       = getHunkline (Sealed oldf : newfs)+          nchs    = sort (map (makeChunk l) newfs)+          old     = makeChunk l (Sealed oldf)+          new     = [top] ++ old ++ [initial] ++ intercalate [middle] nchs ++ [bottom]+          top     = BC.pack ("v v v v v v v" ++ eol_c)+          initial = BC.pack ("=============" ++ eol_c)+          middle  = BC.pack ("*************" ++ eol_c)+          bottom  = BC.pack ("^ ^ ^ ^ ^ ^ ^" ++ eol_c)+          -- simple heuristic to infer the line ending convention from patch contents+          eol_c   =+            if any (\line -> not (B.null line) && BC.last line == '\r') old+              then "\r"+              else ""++      -- | Apply the patches and their inverse. This turns all lines touched+      -- by the 'FL' of patches into defined lines with their "old" values.+      oldFileState :: FileState wX -> Sealed (FL FileHunk 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 mls (Sealed ps) = Sealed (applyHunks ps mls)++      -- Index of the first line touched by any of the FileStates (1-based).+      getHunkline :: [Sealed FileState] -> Int+      getHunkline = go 1 . map (unseal content)+        where+          -- head and tail are safe here because all inner lists are infinite+          go n pps =+            if any (isJust . head) pps+              then n+              else go (n + 1) $ map tail pps++      -- | The chunk of defined lines starting at the given position (1-based).+      makeChunk :: Int -> Sealed FileState -> [B.ByteString]+      makeChunk n = takeWhileJust . drop (n - 1) . unseal content+        where+          -- stolen from utility-ht, thanks Henning!+          takeWhileJust = foldr (\x acc -> maybe [] (:acc) x) []
src/Darcs/Patch/Prim/V1/Read.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1.Read () where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Prim.Class ( PrimRead(..), hunk, binary )@@ -11,12 +10,12 @@     , FilePatchType(..)     ) -import Darcs.Util.Path ( fn2fp )+import Darcs.Util.Path (  ) import Darcs.Patch.Format ( FileNameFormat ) import Darcs.Patch.Read ( readFileName )-import Darcs.Patch.ReadMonads-    ( ParserM, takeTillChar, string, int-    , option, choice, anyChar, char, myLex'+import Darcs.Util.Parser+    ( Parser, takeTillChar, string, int+    , option, choice, anyChar, char, lexWord     , skipSpace, skipWhile, linesStartingWith     ) @@ -72,10 +71,10 @@ changepref :: B.ByteString changepref = BC.pack "changepref" -readHunk :: ParserM m => FileNameFormat -> m (Prim wX wY)+readHunk :: FileNameFormat -> Parser (Prim wX wY) readHunk fmt = do   string hunk'-  fi <- myLex'+  fi <- readFileName fmt   l <- int   have_nl <- skipNewline   if have_nl@@ -84,21 +83,21 @@       old <- linesStartingWith '-'       new <- linesStartingWith '+'       _ <- linesStartingWith ' ' -- skipping context-      return $ hunk (fn2fp $ readFileName fmt fi) l old new-    else return $ hunk (fn2fp $ readFileName fmt fi) l [] []+      return $ hunk fi l old new+    else return $ hunk fi l [] [] -skipNewline :: ParserM m => m Bool+skipNewline :: Parser Bool skipNewline = option False (char '\n' >> return True) -readTok :: ParserM m => FileNameFormat -> m (Prim wX wY)+readTok :: FileNameFormat -> Parser (Prim wX wY) readTok fmt = do   string replace-  f <- myLex'-  regstr <- myLex'-  o <- myLex'-  n <- myLex'-  return $ FP (readFileName fmt f) $ TokReplace (BC.unpack (drop_brackets regstr))-                          (BC.unpack o) (BC.unpack n)+  f <- readFileName fmt+  regstr <- lexWord+  o <- lexWord+  n <- lexWord+  return $ FP f $ TokReplace (BC.unpack (drop_brackets regstr))+                             (BC.unpack o) (BC.unpack n)     where drop_brackets = B.init . B.tail  @@ -113,43 +112,41 @@ -- > newhex -- > *HEXHEXHEX -- > ...-readBinary :: ParserM m => FileNameFormat -> m (Prim wX wY)+readBinary :: FileNameFormat -> Parser (Prim wX wY) readBinary fmt = do   string binary'-  fi <- myLex'-  _ <- myLex'+  fi <- readFileName fmt+  _ <- lexWord   skipSpace   old <- linesStartingWith '*'-  _ <- myLex'+  _ <- lexWord   skipSpace   new <- linesStartingWith '*'-  return $ binary (fn2fp $ readFileName fmt fi)-                  (fromHex2PS $ B.concat old)-                  (fromHex2PS $ B.concat new)+  return $ binary fi (fromHex2PS $ B.concat old) (fromHex2PS $ B.concat new) -readAddFile :: ParserM m => FileNameFormat -> m (Prim wX wY)+readAddFile :: FileNameFormat -> Parser (Prim wX wY) readAddFile fmt = do   string addfile-  f <- myLex'-  return $ FP (readFileName fmt f) AddFile+  f <- readFileName fmt+  return $ FP f AddFile -readRmFile :: ParserM m => FileNameFormat -> m (Prim wX wY)+readRmFile :: FileNameFormat -> Parser (Prim wX wY) readRmFile fmt = do   string rmfile-  f <- myLex'-  return $ FP (readFileName fmt f) RmFile+  f <- readFileName fmt+  return $ FP f RmFile -readMove :: ParserM m => FileNameFormat -> m (Prim wX wY)+readMove :: FileNameFormat -> Parser (Prim wX wY) readMove fmt = do   string move-  d <- myLex'-  d' <- myLex'-  return $ Move (readFileName fmt d) (readFileName fmt d')+  d <- readFileName fmt+  d' <- readFileName fmt+  return $ Move d d' -readChangePref :: ParserM m => m (Prim wX wY)+readChangePref :: Parser (Prim wX wY) readChangePref = do   string changepref-  p <- myLex'+  p <- lexWord   skipWhile (== ' ')   _ <- anyChar -- skip newline   f <- takeTillChar '\n'@@ -157,14 +154,14 @@   t <- takeTillChar '\n'   return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t) -readAddDir :: ParserM m => FileNameFormat -> m (Prim wX wY)+readAddDir :: FileNameFormat -> Parser (Prim wX wY) readAddDir fmt = do   string adddir-  f <- myLex'-  return $ DP (readFileName fmt f) AddDir+  f <- readFileName fmt+  return $ DP f AddDir -readRmDir :: ParserM m => FileNameFormat -> m (Prim wX wY)+readRmDir :: FileNameFormat -> Parser (Prim wX wY) readRmDir fmt = do   string rmdir-  f <- myLex'-  return $ DP (readFileName fmt f) RmDir+  f <- readFileName fmt+  return $ DP f RmDir
src/Darcs/Patch/Prim/V1/Show.hs view
@@ -4,7 +4,6 @@     ( showHunk )     where -import Prelude () import Darcs.Prelude  import Darcs.Util.ByteString ( fromPS2Hex )@@ -21,9 +20,9 @@      ( Prim(..), FilePatchType(..), DirPatchType(..) ) import Darcs.Patch.Prim.V1.Details () import Darcs.Patch.Viewing ( showContextHunk )-import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) -import Darcs.Util.Path ( FileName )+import Darcs.Util.Path ( AnchoredPath ) import Darcs.Util.Printer ( Doc, vcat,                  text, userchunk, invisibleText, invisiblePS, blueText,                  ($$), (<+>)@@ -32,26 +31,11 @@ import Darcs.Util.Tree ( Tree )  -instance Show (Prim wX wY) where-    showsPrec d (Move fn1 fn2) = showParen (d > appPrec) $ showString "Move " .-                                 showsPrec (appPrec + 1) fn1 . showString " " .-                                 showsPrec (appPrec + 1) fn2-    showsPrec d (DP fn dp) = showParen (d > appPrec) $ showString "DP " .-                             showsPrec (appPrec + 1) fn . showString " " .-                             showsPrec (appPrec + 1) dp-    showsPrec d (FP fn fp) = showParen (d > appPrec) $ showString "FP " .-                             showsPrec (appPrec + 1) fn . showString " " .-                             showsPrec (appPrec + 1) fp-    showsPrec d (ChangePref p f t) = showParen (d > appPrec) $ showString "ChangePref " .-                                     showsPrec (appPrec + 1) p . showString " " .-                                     showsPrec (appPrec + 1) f . showString " " .-                                     showsPrec (appPrec + 1) t+deriving instance Show (Prim wX wY) -instance Show2 Prim where-   showDict2 = ShowDictClass+instance Show2 Prim -instance Show1 (Prim wX) where-   showDict1 = ShowDictClass+instance Show1 (Prim wX)  instance Show (FilePatchType wX wY) where     showsPrec _ RmFile = showString "RmFile"@@ -76,9 +60,7 @@                                    showsPrec (appPrec + 1) (BSWrapper old) . showString " " .                                    showsPrec (appPrec + 1) (BSWrapper new) -instance Show (DirPatchType wX wY) where-    showsPrec _ RmDir = showString "RmDir"-    showsPrec _ AddDir = showString "AddDir"+deriving instance Show (DirPatchType wX wY)  instance ApplyState Prim ~ Tree => PrimShow Prim where   showPrim fmt (FP f AddFile) = showAddFile fmt f@@ -93,13 +75,13 @@   showPrimCtx fmt (FP f (Hunk line old new)) = showContextHunk fmt (FileHunk f line old new)   showPrimCtx fmt p = return $ showPrim fmt p -showAddFile :: FileNameFormat -> FileName -> Doc+showAddFile :: FileNameFormat -> AnchoredPath -> Doc showAddFile fmt f = blueText "addfile" <+> formatFileName fmt f -showRmFile :: FileNameFormat -> FileName -> Doc+showRmFile :: FileNameFormat -> AnchoredPath -> Doc showRmFile fmt f = blueText "rmfile" <+> formatFileName fmt f -showMove :: FileNameFormat -> FileName -> FileName -> Doc+showMove :: FileNameFormat -> AnchoredPath -> AnchoredPath -> Doc showMove fmt d d' = blueText "move" <+> formatFileName fmt d <+> formatFileName fmt d'  showChangePref :: String -> String -> String -> Doc@@ -107,22 +89,22 @@                     $$ userchunk f                     $$ userchunk t -showAddDir :: FileNameFormat -> FileName -> Doc+showAddDir :: FileNameFormat -> AnchoredPath -> Doc showAddDir fmt d = blueText "adddir" <+> formatFileName fmt d -showRmDir :: FileNameFormat -> FileName -> Doc+showRmDir :: FileNameFormat -> AnchoredPath -> Doc showRmDir fmt d = blueText "rmdir" <+> formatFileName fmt d -showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc+showHunk :: FileNameFormat -> AnchoredPath -> Int -> [B.ByteString] -> [B.ByteString] -> Doc showHunk fmt f line old new = showFileHunk fmt (FileHunk f line old new) -showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc+showTok :: FileNameFormat -> AnchoredPath -> String -> String -> String -> Doc showTok fmt f t o n = blueText "replace" <+> formatFileName fmt f                                      <+> text "[" <> userchunk t <> text "]"                                      <+> userchunk o                                      <+> userchunk n -showBinary :: FileNameFormat -> FileName -> B.ByteString -> B.ByteString -> Doc+showBinary :: FileNameFormat -> AnchoredPath -> B.ByteString -> B.ByteString -> Doc showBinary fmt f o n =     blueText "binary" <+> formatFileName fmt f  $$ invisibleText "oldhex"
+ src/Darcs/Patch/Prim/WithName.hs view
@@ -0,0 +1,151 @@+-- | Generic wrapper for prim patches to give them an identity.+module Darcs.Patch.Prim.WithName+  ( PrimWithName(..)+  ) where++import Darcs.Prelude++import Darcs.Patch.Annotate ( Annotate(..) )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Ident+    ( Ident(..)+    , PatchId+    , SignedId(..)+    , StorableId(..)+    , IdEq2(..)+    )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Prim.Class ( PrimApply(..), PrimClassify(..), PrimDetails(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Merge ( CleanMerge(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Repair ( RepairToFL(..) )+import Darcs.Patch.Show+    ( ShowPatchBasic(..)+    , ShowPatch(..)+    , ShowContextPatch(..)+    )+import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered ( mapFL_FL, (:>)(..), (:\/:)(..), (:/\:)(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 )++import Darcs.Util.Printer++-- |A 'PrimWithName' is a general way of associating an identity+-- with an underlying (presumably unnamed) primitive type. This is+-- required, for example, for V3 patches.+-- Normally the members of the 'name' type will be generated in+-- some way when a patch is initially created, to guarantee global+-- unqiueness across all repositories.+data PrimWithName name p wX wY =+  PrimWithName { wnName :: !name, wnPatch :: !(p wX wY) }++type instance PatchId (PrimWithName name p) = name++instance SignedId name => Ident (PrimWithName name p) where+  ident = wnName++instance (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+    | otherwise = NotEq++instance (Invert p, SignedId name) => Invert (PrimWithName name p) where+  invert (PrimWithName i p) = PrimWithName (invertId i) (invert p)++instance PatchInspect p => PatchInspect (PrimWithName name p) where+  listTouchedFiles = listTouchedFiles . wnPatch+  hunkMatches m = hunkMatches m . wnPatch++instance (Show2 p, Show name) => Show (PrimWithName name p wX wY) where+  showsPrec d (PrimWithName i p) =+    showParen (d > appPrec)+      $ showString "PrimWithName "+      . showsPrec (appPrec + 1) i+      . showString " "+      . showsPrec2 (appPrec + 1) p++instance (Show2 p, Show name) => Show1 (PrimWithName name p wX)++instance (Show2 p, Show name) => Show2 (PrimWithName name p)++instance Apply p => Apply (PrimWithName name p) where+  type ApplyState (PrimWithName name p) = ApplyState p+  apply = apply . wnPatch+  unapply = unapply . wnPatch++instance PatchListFormat (PrimWithName name p)++instance Apply p => RepairToFL (PrimWithName name p) where+  applyAndTryToFixFL p = apply p >> return Nothing++instance Annotate p => Annotate (PrimWithName name p) where+  annotate = annotate . wnPatch++instance IsHunk p => IsHunk (PrimWithName name p) where+  isHunk = isHunk . wnPatch++instance PrimApply p => PrimApply (PrimWithName name p) where+  applyPrimFL = applyPrimFL . mapFL_FL wnPatch++instance 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++-- this is the most important definition:+-- it ensures that a patch conflicts with itself+instance (SignedId name, Commute p) => Commute (PrimWithName name p) where+  commute (PrimWithName i1 p1 :> PrimWithName i2 p2)+    -- We should never get into a situation where we try+    -- to commute identical patches+    | i1 == i2 = error "internal error: trying to commute identical patches"+    -- whereas this case is the equivalent of merging a patch+    -- with itself, so it is correct to just report that they don't commute+    | i1 == invertId i2 = Nothing+    | otherwise = do+        p2' :> p1' <- commute (p1 :> p2)+        return (PrimWithName i2 p2' :> PrimWithName i1 p1')++instance (SignedId name, CleanMerge p) => CleanMerge (PrimWithName name p) where+  cleanMerge (PrimWithName i1 p1 :\/: PrimWithName i2 p2)+    | i1 == i2 = error "cannot cleanMerge identical patches"+    | otherwise = do+        p2' :/\: p1' <- cleanMerge (p1 :\/: p2)+        return $ PrimWithName i2 p2' :/\: PrimWithName i1 p1'++instance (StorableId name, ReadPatch p) => ReadPatch (PrimWithName name p) where+  readPatch' = do+      name <- readId+      Sealed p <- readPatch'+      return (Sealed (PrimWithName name p))++instance (StorableId name, ShowPatchBasic p) => ShowPatchBasic (PrimWithName name p) where+  showPatch use (PrimWithName name p) = showId use name $$ showPatch use p++instance (StorableId name, PrimDetails p, ShowPatchBasic p) => ShowPatch (PrimWithName name p) where+  summary = plainSummaryPrim . wnPatch+  summaryFL = plainSummaryPrims False+  thing _ = "change"++instance (StorableId name, ShowContextPatch p) => ShowContextPatch (PrimWithName name p) where+  showContextPatch use (PrimWithName name p) = do+    r <- showContextPatch use p+    return $ showId use name $$ r
src/Darcs/Patch/Progress.hs view
@@ -4,7 +4,6 @@     , progressRLShowTags     ) where -import Prelude () import Darcs.Prelude  import System.IO.Unsafe ( unsafePerformIO )
src/Darcs/Patch/Read.hs view
@@ -15,49 +15,57 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Patch.Read ( ReadPatch(..),-                          readPatch, readPatchPartial,-                          bracketedFL, peekfor,-                          readFileName )-             where+module Darcs.Patch.Read+    ( ReadPatch(..)+    , readPatch+    , readPatchPartial+    , bracketedFL+    , peekfor+    , readFileName+    ) where -import Prelude () import Darcs.Prelude -import Darcs.Util.ByteString ( dropSpace, unpackPSFromUTF8, decodeLocale )-import qualified Data.ByteString       as B  (ByteString, null)+import Control.Applicative ( (<|>) )+import Control.Monad ( mzero )+import qualified Data.ByteString as B ( ByteString, null )+import qualified Data.ByteString.Char8 as BC ( ByteString, pack, stripPrefix )  import Darcs.Patch.Bracketed ( Bracketed(..), unBracketedFL )-import Darcs.Util.Path ( FileName, fp2fn, decodeWhite )-import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) )-import Darcs.Patch.ReadMonads (ParserM,-                               parseStrictly,-                               choice, lexChar, lexString,-                               checkConsumes )-+import Darcs.Patch.Format+    ( FileNameFormat(..)+    , ListFormat(..)+    , PatchListFormat(..)+    )+import Darcs.Util.Parser+    ( Parser+    , checkConsumes+    , choice+    , lexChar+    , lexString+    , lexWord+    , parse+    ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) -import Control.Applicative ( (<|>) )-import Control.Monad ( mzero )-import qualified Data.ByteString.Char8 as BC ( ByteString, pack )+import Darcs.Util.ByteString ( decodeLocale, dropSpace, unpackPSFromUTF8 )+import Darcs.Util.Path ( AnchoredPath, decodeWhite, floatPath )  -- | This class is used to decode patches from their binary representation. class ReadPatch p where-    readPatch'-        :: ParserM m => m (Sealed (p wX))+    readPatch' :: Parser (Sealed (p wX)) -readPatchPartial :: ReadPatch p => B.ByteString -> Maybe (Sealed (p wX), B.ByteString)-readPatchPartial ps-    = case parseStrictly readPatch' ps of-         Just (p, ps') -> Just (p, ps')-         _ -> Nothing+readPatchPartial :: ReadPatch p => B.ByteString -> Either String (Sealed (p wX), B.ByteString)+readPatchPartial = parse readPatch' -readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p wX))-readPatch ps-    = case readPatchPartial ps of-         Just (p, ps') | B.null (dropSpace ps') -> Just p-         _ -> Nothing+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]  instance ReadPatch p => ReadPatch (Bracketed p) where     readPatch' = mapSeal Braced <$> bracketedFL readPatch' '{' '}'@@ -76,7 +84,7 @@             = mapSeal unBracketedFL <$> readPatch'         | otherwise             = read_patches-     where read_patches :: ParserM m => m (Sealed (FL p wX))+     where read_patches :: Parser (Sealed (FL p wX))            read_patches = do --tracePeek "starting FL read"                              -- checkConsumes is needed to make sure that something is read,                              -- to avoid stack overflow when parsing FL (FL p)@@ -93,29 +101,37 @@     readPatch' = mapSeal reverseFL <$> readPatch'  {-# INLINE bracketedFL #-}-bracketedFL :: forall p m wX . (ParserM m) =>-               (forall wY . m (Sealed (p wY))) -> Char -> Char -> m (Sealed (FL p wX))+bracketedFL :: forall p wX .+               (forall wY . Parser (Sealed (p wY))) -> Char -> Char -> Parser (Sealed (FL p wX)) bracketedFL parser pre post =     peekforc pre bfl mzero-        where bfl :: forall wZ . m (Sealed (FL p wZ))+        where bfl :: forall wZ . Parser (Sealed (FL p wZ))               bfl = peekforc post (return $ Sealed NilFL)                                   (do Sealed p <- parser                                       Sealed ps <- bfl                                       return $ Sealed (p:>:ps))  {-# INLINE peekforc #-}-peekforc :: ParserM m => Char -> m a -> m a -> m a+peekforc :: Char -> Parser a -> Parser a -> Parser a peekforc c ifstr ifnot = choice [ lexChar c >> ifstr                                 , ifnot ] -peekfor :: ParserM m => BC.ByteString -> m a -> m a -> m a+peekfor :: BC.ByteString -> Parser a -> Parser a -> Parser a peekfor ps ifstr ifnot = choice [ do lexString ps                                      ifstr                                 , ifnot ] {-# INLINE peekfor #-}  -- See also Darcs.Patch.Show.formatFileName.-readFileName :: FileNameFormat -> B.ByteString -> FileName-readFileName OldFormat = fp2fn . decodeWhite . decodeLocale . BC.pack . unpackPSFromUTF8-readFileName NewFormat = fp2fn . decodeWhite . decodeLocale-readFileName UserFormat = error "readFileName called with UserFormat"+readFileName :: 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'+  where+    convert FileNameFormatV1 =+      floatPath . decodeWhite . decodeLocale . BC.pack . unpackPSFromUTF8+    convert FileNameFormatV2 =+      floatPath . decodeWhite . decodeLocale+    convert FileNameFormatDisplay = error "readFileName called with FileNameFormatDisplay"
− src/Darcs/Patch/ReadMonads.hs 
@@ -1,275 +0,0 @@--- | This module defines our parsing monad.  In the past there have been lazy--- and strict parsers in this module.  Currently we have only the strict--- variant and it is used for parsing patch files.--module Darcs.Patch.ReadMonads (ParserM, Darcs.Patch.ReadMonads.take,-                        parse, parseStrictly, char, int,-                        option, choice, skipSpace, skipWhile, string,-                        lexChar, lexString, lexEof, takeTillChar,-                        myLex', anyChar, endOfInput, takeTill,-                        checkConsumes,-                        linesStartingWith, linesStartingWithEndingWith) where--import Prelude ()-import Darcs.Prelude--import Darcs.Util.ByteString ( dropSpace, breakSpace, breakFirstPS,-                         readIntPS, breakLastPS )-import qualified Data.ByteString as B (null, drop, length, tail, empty,-                                       ByteString)-import qualified Data.ByteString.Char8 as BC ( uncons, dropWhile, break-                                             , splitAt, length, head )-import Control.Applicative ( Alternative(..) )-import Data.Foldable ( asum )-import Control.Monad ( MonadPlus(..) )---- | 'lexChar' checks if the next space delimited token from--- the input stream matches a specific 'Char'.--- Uses 'Maybe' inside 'ParserM' to handle failed matches, so--- that it always returns () on success.-lexChar :: ParserM m => Char -> m ()-lexChar c = do-  skipSpace-  char c-  return ()---- | 'lexString' fetches the next whitespace delimited token from--- from the input and checks if it matches the 'ByteString' input.--- Uses 'Maybe' inside 'ParserM' to handle failed matches, so--- that it always returns () on success.-lexString :: ParserM m => B.ByteString -> m ()-lexString str = work-           $ \s -> case myLex s of-                       Just (xs :*: ys) | xs == str -> Just (() :*: ys)-                       _ -> Nothing---- | Only succeeds if the characters in the input exactly match @str@.-string :: ParserM m => B.ByteString -> m ()-string str = work-        $ \s -> case BC.splitAt (BC.length str) s of-                  (h, t) | h == str -> Just (() :*: t)-                  _ -> Nothing---- | 'lexEof' looks for optional spaces followed by the end of input.--- Uses 'Maybe' inside 'ParserM' to handle failed matches, so--- that it always returns () on success.-lexEof :: ParserM m => m ()-lexEof = work-        $ \s -> if B.null (dropSpace s)-                then Just (() :*: B.empty)-                else Nothing---- | 'myLex' drops leading spaces and then breaks the string at the--- next space.  Returns 'Nothing' when the string is empty after--- dropping leading spaces, otherwise it returns the first sequence--- of non-spaces and the remainder of the input.-myLex :: B.ByteString -> Maybe (ParserState B.ByteString)-myLex s = let s' = dropSpace s-           in if B.null s'-              then Nothing-              else Just $ stuple $ breakSpace s'---- | Like 'myLex' except that it is in ParserM-myLex' :: ParserM m => m B.ByteString-myLex' = work myLex---- | Accepts the next character and returns it.  Only fails at end of--- input.-anyChar :: ParserM m => m Char-anyChar = work $ \s -> stuple <$> BC.uncons s---- | Only succeeds at end of input, consumes no characters.-endOfInput :: ParserM m => m ()-endOfInput = work $ \s -> if B.null s-                            then Just (() :*: s)-                            else Nothing---- | Accepts only the specified character.  Consumes a character, if--- available.-char :: ParserM m => Char -> m ()-char c = work $ \s ->-  case BC.uncons s of-  Just (c', s') | c == c' -> Just (() :*: s')-  _ -> Nothing---- | Parse an integer and return it.  Skips leading whitespaces and--- | uses the efficient ByteString readInt.-int :: ParserM m => m Int-int = work $ \s -> stuple <$> readIntPS s---- | Discards spaces until a non-space character is encountered.--- Always succeeds.-skipSpace :: ParserM m => m ()-skipSpace = alterInput dropSpace---- | Discards any characters as long as @p@ returns True.  Always--- | succeeds.-skipWhile :: ParserM m => (Char -> Bool) -> m ()-skipWhile p = alterInput (BC.dropWhile p)---- | Takes characters while @p@ returns True.  Always succeeds.-takeTill :: ParserM m => (Char -> Bool) -> m B.ByteString-takeTill p = work $ \s -> Just $ stuple (BC.break p s)---- | Equivalent to @takeTill (==c)@, except that it is optimized for--- | the equality case.-takeTillChar :: ParserM m => Char -> m B.ByteString-takeTillChar c = work $ \s -> Just $ stuple (BC.break (==c) s)---- | Takes exactly @n@ bytes, or fails.-take :: ParserM m => Int -> m B.ByteString-take n = work $ \s -> if B.length s >= n-                        then Just $ stuple $ BC.splitAt n s-                        else Nothing---- | This is a highly optimized way to read lines that start with a--- particular character.  To implement this efficiently we need access--- to the parser's internal state.  If this is implemented in terms of--- the other primitives for the parser it requires us to consume one--- character at a time.  That leads to @(>>=)@ wasting significant--- time.-linesStartingWith :: ParserM m => Char -> m [B.ByteString]-linesStartingWith c = work $ linesStartingWith' c---- | Helper function for 'linesStartingWith'.-linesStartingWith' :: Char -> B.ByteString -> Maybe (ParserState [B.ByteString])-linesStartingWith' c thes =-    Just (lsw [] thes)-    where lsw acc s | B.null s || BC.head s /= c = reverse acc :*: s-          lsw acc s = let s' = B.tail s-                  in case breakFirstPS '\n' s' of-                     Just (l, r) -> lsw (l:acc) r-                     Nothing -> reverse (s':acc) :*: B.empty---- | This is a highly optimized way to read lines that start with a--- particular character, and stops when it reaches a particular |--- character.  See 'linesStartingWith' for details on why this |--- defined here as a primitive.-linesStartingWithEndingWith :: ParserM m => Char -> Char -> m [B.ByteString]-linesStartingWithEndingWith st en = work $ linesStartingWithEndingWith' st en---- | Helper function for 'linesStartingWithEndingWith'.-linesStartingWithEndingWith' :: Char -> Char -> B.ByteString-                             -> Maybe (ParserState [B.ByteString])-linesStartingWithEndingWith' st en = lswew-    where-  lswew x-    | B.null x = Nothing-    | BC.head x == en = Just $ [] :*: B.tail x-    | BC.head x /= st = Nothing-    | otherwise = case BC.break ('\n' ==) $ B.tail x of-              (l,r) -> case lswew $ B.tail r of-                       Just (ls :*: r') -> Just ((l:ls) :*: r')-                       Nothing ->-                           case breakLastPS en l of-                           Just (l2,_) ->-                               Just ([l2] :*: B.drop (B.length l2+2) x)-                           Nothing -> Nothing----- | Applies a function to the input stream and discards the--- result of the function.-alterInput :: ParserM m-            => (B.ByteString -> B.ByteString) -> m ()-alterInput f = work (\s -> Just (() :*: f s))---- | If @p@ fails it returns @x@, otherwise it returns the result of @p@.-option :: Alternative f => a -> f a -> f a-option x p = p <|> pure x---- | Attempts each option until one succeeds.-choice :: Alternative f => [f a] -> f a-choice = asum---- |Ensure that a parser consumes input when producing a result--- Causes the initial state of the input stream to be held on to while the--- parser runs, so use with caution.-checkConsumes :: ParserM m => m a -> m a-checkConsumes parser = do-   x <- B.length <$> peekInput-   res <- parser-   x' <- B.length <$> peekInput-   if x' < x then return res else mzero--class (Functor m, Applicative m, Alternative m, Monad m, MonadPlus m) => ParserM m where-    -- | Applies a parsing function inside the 'ParserM' monad.-    work :: (B.ByteString -> Maybe (ParserState a)) -> m a-    -- | Allows for the inspection of the input that is yet to be parsed.-    peekInput :: m B.ByteString-    -- | Run the parser-    parse :: m a -> B.ByteString -> Maybe (a, B.ByteString)------- Strict Monad -------- | 'parseStrictly' applies the parser functions to a string--- and checks that each parser produced a result as it goes.--- The strictness is in the 'ParserM' instance for 'SM'.-parseStrictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString)-parseStrictly (SM f) s = case f s of-  Just (a :*: r) -> Just (a, r)-  _ -> Nothing---- | ParserState represents the internal state of the parser.  We make it--- strict and specialize it on ByteString.  This is purely to help GHC--- optimize.  If performance were not a concern, it could be replaced--- with @(a, ByteString)@.-data ParserState a = !a :*: !B.ByteString---- | Convert from a lazy tuple to a strict tuple.-stuple :: (a, B.ByteString) -> ParserState a-stuple (a, b) = a :*: b---- | 'SM' is the Strict Monad for parsing.-newtype SM a = SM (B.ByteString -> Maybe (ParserState a))--bindSM :: SM a -> (a -> SM b) -> SM b-bindSM (SM m) k = SM $ \s -> case m s of-                             Nothing -> Nothing-                             Just (x :*: s') ->-                               case k x of-                               SM y -> y s'-{-# INLINE bindSM #-}-returnSM :: a -> SM a-returnSM x = SM (\s -> Just (x :*: s))-{-# INLINE returnSM #-}-failSM :: String -> SM a-failSM _ = SM (\_ -> Nothing)-{-# INLINE failSM #-}--instance Monad SM where-    (>>=)  = bindSM-    return = returnSM--instance ParserM SM where-    work = SM-    peekInput = SM $ \s -> Just (s :*: s)-    parse = parseStrictly---- The following instances allow us to use more conventional--- interfaces provided by other parser libraries. The instances are--- defined using bindSM, returnSM, and failSM to avoid any infinite,--- or even unneccessary, recursion of instances between between--- ParserM and Monad.  Other recursive uses will be fine, such as--- (<|>) = mplus.-instance MonadPlus SM where-  mzero = failSM ""-  -- | Over using mplus can lead to space leaks.  It's best to push-  -- the use of mplus as far down as possible, because until the the-  -- first parameter completes, we must hold on to the input.-  mplus (SM a) (SM b) = SM $ \s ->-    case a s of-      Nothing -> b s-      r -> r--instance Functor SM where-  fmap f m = m `bindSM` (returnSM . f)--instance Applicative SM where-  pure = returnSM-  a <*> b =-    a `bindSM` \c ->-    b `bindSM` \d ->-    returnSM (c d)--instance Alternative SM where-  empty = failSM ""-  (<|>) = mplus
− src/Darcs/Patch/Rebase.hs 
@@ -1,159 +0,0 @@---  Copyright (C) 2009 Ganesh Sittampalam------  BSD3-module Darcs.Patch.Rebase-    ( takeHeadRebase-    , takeHeadRebaseFL-    , takeAnyRebase-    , takeAnyRebaseAndTrailingPatches-    , dropAnyRebase-    ) where--import Prelude ()-import Darcs.Prelude--import Darcs.Patch.Named.Wrapped ( WrappedNamed(RebaseP) )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )-import Darcs.Patch.Rebase.Container ( Suspended(..) )-import Darcs.Patch.RepoType-    ( RepoType(..)-    , RebaseType(..)-    , IsRepoType(..)-    , SRepoType(..)-    , SRebaseType(..)-    )-import Darcs.Patch.Set ( PatchSet(..) )-import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed--{- Notes--Note [Rebase representation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The entire rebase state is stored in a single Suspended patch-(see Darcs.Patch.Rebase.Container).--This is both unnatural and inefficient:-- - Unnatural because the rebase state is not really a patch and-   treating it as one requires various hacks:--   - It has to be given a fake name: see mkRebase--   - Since 'Named p' actually contains 'FL p', we have to-     assume/assert that the FL either contains a sequence of Normals-     or a single Suspended--   - When 'Named ps' commutes past 'Named (Suspended items :> NilFL)',-     we need to inject the name from 'Named ps' into 'items', which-     is a layering violation: see Darcs.Patch.Rebase.NameHack--   - We need to hide the patch in the UI: see Darcs.Patch.MaybeInternal--   - We need a conditional hook so that amend-record can change the-     Suspended patch itself: see Darcs.Patch.Rebase.Recontext-     (something like this might be necessary no matter what the-     representation)-- - Inefficient because we need to write the entire rebase state out-   each time, even though most operations will only affect a small-   portion near the beginning.--   - This also means that we need to commute the rebase patch back-     to the head of the repo lazily: we only do so when a rebase-     operation requires it. Otherwise, pulling in 100 patches-     would entail writing out the entire rebase patch to disk 100-     times.--The obvious alternative is to store the rebase state at the repository-level, using inventories in some appropriate way.--The main reason this wasn't done is that the repository handling code-is quite fragile and hard to modify safely.--Also, rebase relies heavily on witnesses to check correctness, and-the witnesses on the Repository type are not as reliable as those-on patch types, partly because of the cruft in the repository code,-and partly because it's inherently harder to track witnesses when-the objects being manipulated are stored on disk and being changed-imperatively.--If and when the repository code becomes easier to work with, rebase-should be changed accordingly.---}---- | Given the repository contents, get the rebase container patch, and its--- contents. The rebase patch can be anywhere in the repository and is returned--- without being commuted to the end.-takeAnyRebase ::  PatchSet ('RepoType 'IsRebase) p wA wB-              -> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),-                  Sealed2 (Suspended p))-takeAnyRebase (PatchSet _ NilRL) =-   -- it should never be behind a tag so we can stop now-   bug "internal error: no suspended patch found"-takeAnyRebase (PatchSet pss (ps :<: p))-    | RebaseP _ rs <- hopefully p = (Sealed2 p, Sealed2 rs)-    | otherwise = takeAnyRebase (PatchSet pss ps)---- | Given the repository contents, get the rebase container patch, its--- contents, and the rest of the repository contents. The rebase patch can be--- anywhere in the repository and is returned without being commuted to the end.-takeAnyRebaseAndTrailingPatches-               :: PatchSet ('RepoType 'IsRebase) p wA wB-               -> FlippedSeal (PatchInfoAnd ('RepoType 'IsRebase) p :>-                               RL (PatchInfoAnd ('RepoType 'IsRebase) p)) wB-takeAnyRebaseAndTrailingPatches (PatchSet _ NilRL) =-   -- it should never be behind a tag so we can stop now-   bug "internal error: no suspended patch found"-takeAnyRebaseAndTrailingPatches (PatchSet pss (ps :<: p))-    | RebaseP _ _ <- hopefully p = FlippedSeal (p :> NilRL)-    | otherwise = case takeAnyRebaseAndTrailingPatches (PatchSet pss ps) of-                     FlippedSeal (r :> ps') -> FlippedSeal (r :> (ps' :<: p))---- | Remove the rebase patch from a 'PatchSet'.-dropAnyRebase :: forall rt p wA wB. IsRepoType rt-              => PatchSet rt p wA wB -> PatchSet rt p wA wB-dropAnyRebase ps@(PatchSet tags patches) =-  case singletonRepoType::SRepoType rt of-    SRepoType SNoRebase -> ps-    SRepoType SIsRebase -> PatchSet tags (dropRebaseRL patches)---- | Remove the rebase patch from an 'RL' of patches.-dropRebaseRL :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB-             -> RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB-dropRebaseRL NilRL = bug "internal error: no suspended patch found"-dropRebaseRL (ps :<: p)-  | RebaseP _ _ <- hopefully p = ps-  | otherwise = dropRebaseRL ps :<: p---- | Given the repository contents, get the rebase container patch, its--- contents, and the rest of the repository contents. The rebase patch must be--- at the head of the repository.-takeHeadRebase :: PatchSet ('RepoType 'IsRebase) p wA wB-               -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB,-                   Suspended p wB wB,-                   PatchSet ('RepoType 'IsRebase) p wA wB)-takeHeadRebase (PatchSet pss (ps :<: p))-    | RebaseP _ rs <- hopefully p = (p, rs, PatchSet pss ps)-takeHeadRebase _ =-    bug "internal error: must have a rebase container patch at end of repository"---- | Same as 'takeHeadRebase' but for an 'RL' of patches.-takeHeadRebaseRL :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB-                 -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB,-                     Suspended p wB wB,-                     RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB)-takeHeadRebaseRL (ps :<: p)-    | RebaseP _ rs <- hopefully p = (p, rs, ps)-takeHeadRebaseRL _ =-    bug "internal error: must have a suspended patch at end of repository"---- | Same as 'takeHeadRebase' but for an 'FL' of patches.-takeHeadRebaseFL :: FL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB-                 -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB,-                     Suspended p wB wB,-                     FL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB)-takeHeadRebaseFL ps =-  let (a, b, c) = takeHeadRebaseRL (reverseFL ps) in (a, b, reverseRL c)
+ src/Darcs/Patch/Rebase/Change.hs view
@@ -0,0 +1,497 @@+--  Copyright (C) 2009 Ganesh Sittampalam+--+--  BSD3+module Darcs.Patch.Rebase.Change+    ( RebaseChange(..)+    , toRebaseChanges+    , extractRebaseChange+    , reifyRebaseChange+    , partitionUnconflicted+    , rcToPia+    , WithDroppedDeps(..)+    , WDDNamed+    , commuterIdWDD+    , simplifyPush, simplifyPushes+    , addNamedToRebase+    ) where++import Darcs.Prelude++import Darcs.Patch.Commute ( commuteFL, commuteRL )+import Darcs.Patch.CommuteFn+    ( CommuteFn+    , MergeFn+    , commuterFLId, commuterIdFL+    )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Info ( PatchInfo, patchinfo, displayPatchInfo )+import Darcs.Patch.Invert ( Invert, invert, invertFL )+import Darcs.Patch.Merge ( selfMerger )+import Darcs.Patch.Named+    ( Named(..)+    , HasDeps(..)+    , infopatch+    , mergerIdNamed+    , patchcontents+    , ShowDepsFormat(..)+    , showDependencies+    )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, PatchInfoAndG, 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.Summary+    ( ConflictState(..)+    , IsConflictedPrim(..)+    , Summary(..)+    , plainSummary+    , plainSummaryFL+    )+import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim(..) )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanFL )+import Darcs.Patch.Prim.Class ( PrimPatch )+import Darcs.Patch.Rebase.Fixup+    ( RebaseFixup(..)+    , commuteFixupNamed, commuteNamedFixup+    , flToNamesPrims+    , pushFixupFixup+    )+import Darcs.Patch.Rebase.Name ( RebaseName(..) )+import Darcs.Patch.Rebase.PushFixup+  ( PushFixupFn, dropFixups+  , pushFixupFLMB_FLFLMB+  , pushFixupIdMB_FLFLMB+  , pushFixupIdMB_FLIdFLFL+  )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(..), ShowContextPatch(..) )+import Darcs.Patch.Unwind ( Unwound(..), fullUnwind )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm )+import Darcs.Util.IsoDate ( getIsoDateTime )+import Darcs.Util.Parser ( lexString )+import Darcs.Util.Printer ( Doc, ($$), ($+$), (<+>), blueText, redText, empty, vcat )++import qualified Data.ByteString.Char8 as BC ( pack )+import Data.List ( (\\) )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( fromMaybe )++data RebaseChange prim wX wY where+    RC :: FL (RebaseFixup prim) wX wY -> Named prim wY wZ -> RebaseChange prim wX wZ++instance Show2 prim => Show1 (RebaseChange prim wX)++instance Show2 prim => Show2 (RebaseChange prim)++deriving instance Show2 prim => Show (RebaseChange prim wX wY)++-- |Get hold of the 'Named' patch inside a 'RebaseChange' and wrap it in a+-- 'PatchInfoAnd'.+rcToPia :: RebaseChange prim wX wY -> Sealed2 (PatchInfoAnd ('RepoType 'NoRebase) prim)+rcToPia (RC _ toEdit) = Sealed2 (n2pia toEdit)++instance PrimPatch prim => PrimPatchBase (RebaseChange prim) where+  type PrimOf (RebaseChange prim) = prim++instance PatchDebug prim => PatchDebug (RebaseChange prim)++instance HasDeps (RebaseChange prim) where+  getdeps (RC _ toedit) = getdeps toedit++type instance PatchId (RebaseChange prim) = PatchInfo++instance Ident (RebaseChange prim) where+  ident (RC _ toedit) = ident toedit++instance Apply prim => Apply (RebaseChange prim) where+   type ApplyState (RebaseChange prim) = ApplyState prim+   apply (RC fixups toedit) = apply fixups >> apply toedit+   unapply (RC fixups toedit) = unapply toedit >> unapply fixups++instance Commute prim => Summary (RebaseChange prim) where+  conflictedEffect (RC fixups toedit) =+    case flToNamesPrims fixups of+      _names :> prims ->+        -- Report on the conflicts we would get if we unsuspended just this patch.+        -- An alternative implementation strategy would be to "force commute"+        -- prims :> toedit and report on the resulting conflicts in toedit.+        -- However this ties us to a specific RepoPatch type which isn't really+        -- needed for a simple calculation like this.+        --+        -- The rebase invariants should mean that 'fixups' (if non-empty) won't+        -- commute with 'changes' as a whole, but here we need to report each individual+        -- prim as conflicted or not, so we try to push the fixups as far through+        -- the individual prims as we can.+        --+        -- Taking the effect also means that any conflicts already present in the+        -- suspended patch won't be reported, but in general such conflicts+        -- are not supported anyway.+        case genCommuteWhatWeCanFL (commuterFLId commute) (prims :> patchcontents toedit) of+          unconflicted :> _ :> conflicted ->+            mapFL (IsC Okay) unconflicted ++ mapFL (IsC Conflicted) conflicted++instance (ShowPatchBasic prim, Invert prim, PatchListFormat 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++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++instance PrimPatch prim => ShowPatch (RebaseChange prim) where+    -- This should really just call 'description' on the ToEdit patch,+    -- but that introduces a spurious dependency on Summary (PrimOf p),+    -- because of other methods in the Named instance, so we just inline+    -- the implementation from Named here.+    description (RC _ (NamedP n _ _)) = displayPatchInfo n+    -- TODO report conflict indicating name fixups (i.e. dropped deps)+    summary p@(RC _ (NamedP _ ds _)) =+      showDependencies ShowDepsSummary ds $$ plainSummary p+    summaryFL ps =+      showDependencies ShowDepsSummary (getdepsFL ps) $$ plainSummaryFL ps+      where+        getdepsFL = nubSort . concat . mapFL getdeps+    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 (ReadPatch prim, PatchListFormat prim) => ReadPatch (RebaseChange prim) where+  readPatch' = do+    lexString (BC.pack "rebase-change")+    lexString (BC.pack "(")+    Sealed fixups <- readPatch'+    lexString (BC.pack ")")+    Sealed contents <- readPatch'+    return $ Sealed $ RC fixups contents++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+    fixups2' :> edit1' <- commuterIdFL commuteNamedFixup (edit1 :> fixups2)+    edit2' :> edit1'' <- commute (edit1' :> edit2)+    fixupsS :> (fixups2'' :> edit2'') :> fixups1' <-+      return $ pushThrough (fixups1 :> (fixups2' :> edit2'))+    return (RC (fixupsS +>+ fixups2'') edit2'' :> RC fixups1' edit1'')++instance PatchInspect prim => PatchInspect (RebaseChange prim) where+   listTouchedFiles (RC fixup toedit) = nubSort (listTouchedFiles fixup ++ listTouchedFiles toedit)+   hunkMatches f (RC fixup toedit) = hunkMatches f fixup || hunkMatches f toedit++-- |Split a list of rebase patches into those that will+-- have conflicts if unsuspended and those that won't.+partitionUnconflicted+    :: Commute prim+    => FL (RebaseChange prim) wX wY+    -> (FL (RebaseChange prim) :> RL (RebaseChange prim)) wX wY+partitionUnconflicted = partitionUnconflictedAcc NilRL++partitionUnconflictedAcc+  :: Commute prim+  => RL (RebaseChange prim) wX wY -> FL (RebaseChange prim) wY wZ+  -> (FL (RebaseChange prim) :> RL (RebaseChange prim)) wX wZ+partitionUnconflictedAcc right NilFL = NilFL :> right+partitionUnconflictedAcc right (p :>: ps) =+   case commuteRL (right :> p) of+     Just (p'@(RC NilFL _) :> right')+       -> case partitionUnconflictedAcc right' ps of+            left' :> right'' -> (p' :>: left') :> right''+     _ -> partitionUnconflictedAcc (right :<: p) ps++-- | A patch, together with a list of patch names that it used to depend on,+-- but were lost during the rebasing process. The UI can use this information+-- to report them to the user.+data WithDroppedDeps p wX wY =+    WithDroppedDeps {+        wddPatch :: p wX wY,+        wddDependedOn :: [PatchInfo]+    }++noDroppedDeps :: p wX wY -> WithDroppedDeps p wX wY+noDroppedDeps p = WithDroppedDeps p []++instance PrimPatchBase p => PrimPatchBase (WithDroppedDeps p) where+   type PrimOf (WithDroppedDeps p) = PrimOf p++instance Effect p => Effect (WithDroppedDeps p) where+   effect = effect . wddPatch++-- |Given a list of rebase items, try to push a new fixup as far as possible into+-- the list as possible, using both commutation and coalescing. If the fixup+-- commutes past all the 'ToEdit' patches then it is dropped entirely.+simplifyPush+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> RebaseFixup prim wX wY+  -> FL (RebaseChange prim) wY wZ+  -> Sealed (FL (RebaseChange prim) wX)+simplifyPush da fixup items = dropFixups $ pushFixupChanges da (fixup :> items)++-- |Like 'simplifyPush' but for a list of fixups.+simplifyPushes+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> FL (RebaseFixup prim) wX wY+  -> FL (RebaseChange prim) wY wZ+  -> Sealed (FL (RebaseChange prim) wX)+simplifyPushes _ NilFL ps = Sealed ps+simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps)++pushFixupChange+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> PushFixupFn+       (RebaseFixup prim) (RebaseChange prim)+       (RebaseChange prim) (Maybe2 (RebaseFixup prim))+pushFixupChange da (f1 :> RC fs2 e)+  = case pushFixupFLMB_FLFLMB (pushFixupFixup da) (f1 :> fs2) of+      fs2' :> Nothing2 -> RC fs2' e :> Nothing2+      fs2' :> Just2 f1' ->+        case commuteFixupNamed (f1' :> e) of+          -- The fixup is "stuck" so just attach it here+          Nothing -> RC (fs2' +>+ f1' :>: NilFL) e :> Nothing2+          Just (e' :> f1'') -> RC fs2' e' :> Just2 f1''++pushFixupChanges+  :: PrimPatch prim+  =>  D.DiffAlgorithm+  -> PushFixupFn+       (RebaseFixup prim) (FL (RebaseChange prim))+       (FL (RebaseChange prim)) (Maybe2 (RebaseFixup prim))+pushFixupChanges da = pushFixupIdMB_FLFLMB (pushFixupChange da)++pushFixupsChange+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> PushFixupFn+       (FL (RebaseFixup prim)) (RebaseChange prim)+       (RebaseChange prim) (FL (RebaseFixup prim))+pushFixupsChange da = pushFixupIdMB_FLIdFLFL (pushFixupChange da)+++-- Note, this could probably be rewritten using a generalised commuteWhatWeCanFL from+-- Darcs.Patch.Permutations.+-- |@pushThrough (ps :> (qs :> te))@ tries to commute as much of @ps@ as possible through+-- both @qs@ and @te@, giving @psStuck :> (qs' :> te') :> psCommuted@.+-- Anything that can be commuted ends up in @psCommuted@ and anything that can't goes in+-- @psStuck@.+pushThrough+  :: Commute prim+  => (FL (RebaseFixup prim) :> (FL (RebaseFixup prim) :> Named prim)) wX wY+  -> (FL (RebaseFixup prim) :> (FL (RebaseFixup prim) :> Named prim) :> FL (RebaseFixup prim)) wX wY+pushThrough (NilFL :> v) = NilFL :> v :> NilFL+pushThrough ((p :>: ps) :> v) =+  case pushThrough (ps :> v) of+   psS :> v'@(qs:>te) :> ps' ->+     fromMaybe ((p :>: psS) :> v' :> ps') $ do+       psS' :> p' <- commuteFL (p :> psS)+       qs' :> p'' <- commuteFL (p' :> qs)+       te' :> p''' <- commuteFixupNamed (p'' :> te)+       return (psS' :> (qs' :> te') :> (p''' :>: ps'))++type WDDNamed p = WithDroppedDeps (Named p)++mergerIdWDD :: MergeFn p1 p2 -> MergeFn p1 (WithDroppedDeps p2)+mergerIdWDD merger (p1 :\/: WithDroppedDeps p2 deps) =+   case merger (p1 :\/: p2) of+     p2' :/\: p1' -> WithDroppedDeps p2' deps :/\: p1'++commuterIdWDD :: CommuteFn p q -> CommuteFn p (WithDroppedDeps q)+commuterIdWDD commuter (p :> WithDroppedDeps q deps)+  = do -- no need to worry about names, because by definition a dropped dep+       -- is a name we no longer have+       -- TODO consistency checking?+       -- TODO consider inverse commutes, e.g. what happens if we wanted to+       -- commute (WithDroppedDeps ... [n] :> AddName n)?+       q' :> p' <- commuter (p :> q)+       return (WithDroppedDeps q' deps :> p')++-- |Forcibly commute a 'RebaseName' with a patch, dropping any dependencies+-- if necessary and recording them in the patch+forceCommuteName :: (RebaseName :> WDDNamed p) wX wY -> (WDDNamed p :> RebaseName) wX wY+forceCommuteName (AddName an :> WithDroppedDeps (NamedP pn deps body) ddeps)+  | an == pn = error "impossible case"+  | otherwise =+      WithDroppedDeps+        (NamedP pn (deps \\ [an]) (unsafeCoerceP body))+        (if an `elem` deps then an : ddeps else ddeps)+      :>+      AddName an+forceCommuteName (DelName dn :> p@(WithDroppedDeps (NamedP pn deps _body) _ddeps))+  | dn == pn = error "impossible case"+  | dn `elem` deps = error "impossible case"+  | otherwise = unsafeCoerceP p :> DelName dn+forceCommuteName (Rename old new :> WithDroppedDeps (NamedP pn deps body) ddeps)+  | old == pn = error "impossible case"+  | new == pn = error "impossible case"+  | old `elem` deps = error "impossible case"+  | otherwise =+      let newdeps = map (\dep -> if new == dep then old else dep) deps+      in WithDroppedDeps (NamedP pn newdeps (unsafeCoerceP body)) ddeps :> Rename old new++forceCommutePrim :: RepoPatch p+                 => (PrimOf p :> WDDNamed p) wX wY+                 -> (WDDNamed p :> FL (PrimOf p)) wX wY+forceCommutePrim (p :> wq) =+    -- rp and irp are not inverses for RepoPatchV3, only their effects are inverse+    let rp = fromAnonymousPrim p+        irp = fromAnonymousPrim (invert p)+    in case mergerIdWDD (mergerIdNamed selfMerger) (irp :\/: wq) of+        wq' :/\: irp' -> prefixWith (rp :>: irp :>: NilFL) wq' :> invert (effect irp')+    where+      -- TODO [V3INTEGRATION]:+      -- This is a hack to adapt forceCommutePrim to the stricter assumptions+      -- made by RepoPatchV3, for which resolveConflicts expects that we can+      -- find each patch we conflict with somewhere in the context.+      -- Force-commuting the fixups with the patch to be edited violates that+      -- assumption. It works for RepoPatchV1/2 because their conflictors are+      -- self-contained i.e. they contain the transitive set of conflicts in+      -- their representation, which is no longer true for RepoPatchV3.+      -- To restore the assumption for RepoPatchV3 we prefix the patches+      -- contained in the 'Named' patch with (rp;irp). The conflictor wq' can+      -- now refer to irp, and the effect of rp will cancel with that of irp+      -- on unsuspend.+      prefixWith xs (WithDroppedDeps (NamedP i ds ps) dds) =+          WithDroppedDeps (NamedP i ds (xs +>+ ps)) dds++forceCommutes :: RepoPatch p+              => (FL (RebaseFixup (PrimOf p)) :> WDDNamed p) wX wY+              -> (WDDNamed p :> FL (RebaseFixup (PrimOf p))) wX wY+forceCommutes (NilFL :> q) = q :> NilFL+forceCommutes ((NameFixup n :>: ps) :> q) =+    case forceCommutes (ps :> q) of+        q' :> ps' ->+            case forceCommuteName (n :> q') of+                q'' :> n' -> q'' :> (NameFixup n' :>: ps')+forceCommutes ((PrimFixup p :>: ps) :> q) =+    case forceCommutes (ps :> q) of+        q' :> ps' ->+            case forceCommutePrim (p :> q') of+                qs'' :> p' -> qs'' :> (mapFL_FL PrimFixup p' +>+ ps')++fromPrimNamed :: FromPrim p => Named (PrimOf p) wX wY -> Named p wX wY+fromPrimNamed (NamedP n deps ps) = NamedP n deps (fromPrims n ps)++-- |Turn a selected rebase patch back into a patch we can apply to+-- the main repository, together with residual fixups that need+-- to go back into the rebase state (unless the rebase is now finished).+-- Any fixups associated with the patch will turn into conflicts.+extractRebaseChange+  :: forall p wX wY+   . RepoPatch p+  => D.DiffAlgorithm+  -> FL (RebaseChange (PrimOf p)) wX wY+  -> (FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wX wY+extractRebaseChange da rcs = go (NilFL :> rcs)+  where+    go+      :: forall wA wB+       . (FL (RebaseFixup (PrimOf p)) :> FL (RebaseChange (PrimOf p))) wA wB+      -> (FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wA wB+    go (fixupsIn :> NilFL) = NilFL :> fixupsIn+    go (fixupsIn :> rc :>: rest) =+      -- First simplify any fixups coming from previous extract operations.+      -- Note that it's important to start at the front of the list so that+      -- we can do this, as it minimises the conflicts we end up with.+      case pushFixupsChange da (fixupsIn :> rc) of+        -- Now use 'fromPrimNamed' to change the toedit patch from+        -- Named (PrimOf p) that we store in the rebase to Named p+        -- that we store in the repository. Then, wrap it in WithDroppedDeps+        -- so we can track any explicit dependencies that were lost, and+        -- finally force-commute the fixups with this and any other patches we are+        -- unsuspending.+        RC fixups toedit :> fixupsOut2 ->+          case forceCommutes (fixups :> WithDroppedDeps (fromPrimNamed toedit) []) of+            toedit' :> fixupsOut1 ->+              case go (fixupsOut1 +>+ fixupsOut2 :> rest) of+                toedits' :> fixupsOut -> toedit' :>: toedits' :> fixupsOut++-- signature to be compatible with extractRebaseChange+-- | Like 'extractRebaseChange', but any fixups are "reified" into a separate patch.+reifyRebaseChange+  :: FromPrim p+  => String+  -> FL (RebaseChange (PrimOf p)) wX wY+  -> IO ((FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wX wY)+reifyRebaseChange author rs = do+    res <- concatFL <$> mapFL_FL_M reifyOne rs+    return (res :> NilFL)+  where+    reifyOne :: FromPrim p => RebaseChange (PrimOf p) wA wB -> IO (FL (WDDNamed p) wA wB)+    reifyOne (RC fixups toedit) =+      case flToNamesPrims fixups of+        names :> NilFL ->+          return $+            mapFL_FL (noDroppedDeps . mkDummy) names +>++            noDroppedDeps (fromPrimNamed toedit) :>:+            NilFL+        names :> prims -> do+          n <- mkReified author prims+          return $+            mapFL_FL (noDroppedDeps . mkDummy) names +>+ noDroppedDeps n :>:+            noDroppedDeps (fromPrimNamed toedit) :>:+            NilFL++mkReified :: FromPrim p => String -> FL (PrimOf p) wX wY -> IO (Named p wX wY)+mkReified author ps = do+     let name = "Reified fixup patch"+     let desc = []+     date <- getIsoDateTime+     info <- patchinfo date name author desc+     return $ infopatch info ps++mkDummy :: FromPrim p => RebaseName wX wY -> Named p wX wY+mkDummy (AddName pi) = infopatch pi (unsafeCoerceP NilFL)+mkDummy (DelName _) = error "internal error: can't make a dummy patch from a delete"+mkDummy (Rename _ _) = error "internal error: can't make a dummy patch from a rename"++instance IsHunk (RebaseChange prim) where+    -- RebaseChange is a compound patch, so it doesn't really make sense to+    -- ask whether it's a hunk. TODO: get rid of the need for this.+    isHunk _ = Nothing++instance PatchListFormat (RebaseChange prim)++addNamedToRebase+  :: RepoPatch p+  => D.DiffAlgorithm+  -> Named p wX wY+  -> FL (RebaseChange (PrimOf p)) wY wZ+  -> Sealed (FL (RebaseChange (PrimOf p)) wX)+addNamedToRebase da named@(NamedP n deps _) =+  case fullUnwind named of+    Unwound before underlying after ->+      unseal (simplifyPushes da (mapFL_FL PrimFixup before)) .+      mapSeal ((RC NilFL (NamedP n deps underlying) :>:)) .+      simplifyPushes da (mapFL_FL PrimFixup (reverseRL after))
− src/Darcs/Patch/Rebase/Container.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE UndecidableInstances, StandaloneDeriving #-}-module Darcs.Patch.Rebase.Container-    ( Suspended(..)-    , countToEdit, simplifyPush, simplifyPushes-    , addFixupsToSuspended, removeFixupsFromSuspended-    ) where--import Prelude ()-import Darcs.Prelude--import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )-import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Format ( PatchListFormat(..) )-import Darcs.Patch.Invert ( invert )-import Darcs.Patch.Named ( Named )-import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Show ( ShowPatch(..) )-import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim(..), FromPrim(..) )-import Darcs.Patch.Read ( bracketedFL )-import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), namedToFixups )-import Darcs.Patch.Rebase.Item ( RebaseItem(..) )-import qualified Darcs.Patch.Rebase.Item as Item ( countToEdit, simplifyPush, simplifyPushes )-import Darcs.Patch.Repair ( Check(..), Repair(..), RepairToFL(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Patch.ReadMonads ( lexString, myLex' )-import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..)-    , ShowDict(ShowDictClass)-    )-import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) )-import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )--import Control.Applicative ( (<|>) )-import Control.Arrow ( (***), second )-import Control.Monad ( when )-import Data.Maybe ( catMaybes )-import qualified Data.ByteString.Char8 as BC ( pack )----- TODO: move some of the docs of types to individual constructors--- once http://trac.haskell.org/haddock/ticket/43 is fixed.---- |A patch that lives in a repository where a rebase is in--- progress. Such a repository will consist of @Normal@ patches--- along with exactly one @Suspended@ patch.------ Most rebase operations will require the @Suspended@ patch--- to be at the end of the repository.------ @Normal@ represents a normal patch within a respository where a--- rebase is in progress. @Normal p@ is given the same on-disk--- representation as @p@, so a repository can be switched into--- and out of rebasing mode simply by adding or removing a--- @Suspended@ patch and setting the appropriate format flag.------ The single @Suspended@ patch contains the entire rebase--- state, in the form of 'RebaseItem's.------ Note that the witnesses are such that the @Suspended@--- patch has no effect on the context of the rest of the--- repository; in a sense the patches within it are--- dangling off to one side from the main repository.------ See Note [Rebase representation] in the 'Darcs.Patch.Rebase' for--- a discussion of the design choice to embed the rebase state in a--- single patch.-data Suspended p wX wY where-    Items :: FL (RebaseItem 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) where-    showDict1 = ShowDictClass--instance (Show2 p, Show2 (PrimOf p)) => Show2 (Suspended p) where-    showDict2 = ShowDictClass--instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Suspended p) where-  listTouchedFiles (Items ps) = listTouchedFiles ps-  hunkMatches f (Items ps) = hunkMatches f ps--instance Effect (Suspended p) where-  effect (Items _) = NilFL--instance Conflict p => Conflict (Suspended p) where-   resolveConflicts _ = []-   conflictedEffect _ = []--instance Apply (Suspended p) where-   type ApplyState (Suspended p) = ApplyState p-   apply _ = return ()--instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where-   showPatch f (Items ps)-       = blueText "rebase" <+> text "0.0" <+> blueText "{"-         $$ vcat (mapFL (showPatch f) ps)-         $$ blueText "}"--instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (Suspended p) where-   summary (Items ps) = summaryFL ps-   summaryFL ps = vcat (mapFL summary ps)--instance PrimPatchBase p => PrimPatchBase (Suspended p) where-   type PrimOf (Suspended p) = PrimOf p--instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Suspended p) where-   readPatch' =-    do lexString (BC.pack "rebase")-       version <- myLex'-       when (version /= BC.pack "0.0") $ error $ "can't handle rebase version " ++ show version-       (lexString (BC.pack "{}") >> return (seal (Items NilFL)))-         <|>-         (unseal (Sealed . Items) <$> bracketedFL readPatch' '{' '}')--instance Check p => Check (Suspended p) where-   isInconsistent (Items ps) =-       case catMaybes (mapFL isInconsistent ps) of-         [] -> Nothing-         xs -> Just (vcat xs)--instance Repair (Suspended p) where-   applyAndTryToFix (Items ps) =-   -- TODO: ideally we would apply ps in a sandbox to check the individual patches-   -- are consistent with each other.-       return . fmap (unlines *** Items) $ repairInternal ps--instance RepairToFL (Suspended p) where-   applyAndTryToFixFL s = fmap (second $ (:>: NilFL)) <$> applyAndTryToFix s---- Just repair the internals of the patch, without applying it to anything--- or checking against an external context.--- Included for the internal implementation of applyAndTryToFixFL for Rebasing,--- consider either generalising it for use everywhere, or removing once--- the implementation works in a sandbox and thus can use the "full" Repair on the--- contained patches.-class RepairInternalFL p where-   repairInternalFL :: p wX wY -> Maybe ([String], FL p wX wY)--class RepairInternal p where-   repairInternal :: p wX wY -> Maybe ([String], p wX wY)--instance RepairInternalFL p => RepairInternal (FL p) where-   repairInternal NilFL = Nothing-   repairInternal (x :>: ys) =-     case (repairInternalFL x, repairInternal ys) of-       (Nothing      , Nothing)        -> Nothing-       (Just (e, rxs), Nothing)        -> Just (e      , rxs +>+ ys )-       (Nothing      , Just (e', rys)) -> Just (e'     , x   :>: rys)-       (Just (e, rxs), Just (e', rys)) -> Just (e ++ e', rxs +>+ rys)--instance RepairInternalFL (RebaseItem p) where-   repairInternalFL (ToEdit _) = Nothing-   repairInternalFL (Fixup p) = fmap (second $ mapFL_FL Fixup) $ repairInternalFL p--instance RepairInternalFL (RebaseFixup p) where-   repairInternalFL (PrimFixup _) = Nothing-   repairInternalFL (NameFixup _) = Nothing--countToEdit :: Suspended p wX wY -> Int-countToEdit (Items ps) = Item.countToEdit ps--onSuspended-  :: (forall wZ . FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem 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)-  => Named p wX wY-  -> Suspended p wY wY-  -> Suspended p wX wX-addFixupsToSuspended p = simplifyPushes D.MyersDiff (namedToFixups p)---- |remove fixups (actually, add their inverse) for the name and effect of a patch to a 'Suspended'-removeFixupsFromSuspended-  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)-  => Named p wX wY-  -> Suspended p wX wX-  -> Suspended p wY wY-removeFixupsFromSuspended p = simplifyPushes D.MyersDiff (invert (namedToFixups p))--simplifyPush-  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)-  => D.DiffAlgorithm-  -> RebaseFixup p wX wY-  -> Suspended p wY wY-  -> Suspended p wX wX-simplifyPush da fixups = onSuspended (Item.simplifyPush da fixups)--simplifyPushes-  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)-  => D.DiffAlgorithm-  -> FL (RebaseFixup p) wX wY-  -> Suspended p wY wY-  -> Suspended p wX wX-simplifyPushes da fixups = onSuspended (Item.simplifyPushes da fixups)
src/Darcs/Patch/Rebase/Fixup.hs view
@@ -5,89 +5,111 @@ {-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Rebase.Fixup     ( RebaseFixup(..)-    , commuteNamedFixup, commuteFixupNamed, commuteNamedFixups+    , commuteNamedFixup, commuteFixupNamed+    , pushFixupFixup     , flToNamesPrims, namedToFixups     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..), selfCommuter ) import Darcs.Patch.CommuteFn ( totalCommuterIdFL ) import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.Prim ( FromPrim(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Named ( Named(..), commuterNamedId, commuterIdNamed )-import Darcs.Patch.Prim ( PrimPatchBase(..), PrimPatch )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Prim ( PrimPatch, canonizeFL )+import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.Rebase.Name     ( RebaseName(..)     , commuteNamedName, commuteNameNamed+    , commuterNamedId, commuterIdNamed     , commutePrimName, commuteNamePrim+    , pushFixupName     )-import Darcs.Patch.Witnesses.Eq ( Eq2(..) )+import Darcs.Patch.Rebase.PushFixup ( PushFixupFn )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..), mapMB_MB ) import Darcs.Patch.Witnesses.Ordered-    ( FL(..), mapFL_FL, (:>)(..), (+>+) )-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..), showsPrec2-    , ShowDict(ShowDictClass), appPrec-    )+    ( FL(..), mapFL_FL, (:>)(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, showsPrec2, appPrec ) +import qualified Darcs.Util.Diff as D ( DiffAlgorithm )+import Darcs.Util.Parser ( Parser, lexString )+import Darcs.Util.Printer ( ($$), (<+>), blueText )++import Control.Applicative ( (<|>) )+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( pack )+ -- |A single rebase fixup, needed to ensure that the actual patches -- being stored in the rebase state have the correct context.-data RebaseFixup p wX wY where-  PrimFixup :: PrimPatch (PrimOf p) => PrimOf p wX wY -> RebaseFixup p wX wY-  NameFixup :: RebaseName p wX wY -> RebaseFixup p wX wY+data RebaseFixup prim wX wY where+  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 p) wX wY+namedToFixups :: (PrimPatch (PrimOf p), 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 (PrimOf p) => Show (RebaseFixup p wX wY) where+instance Show2 prim => Show (RebaseFixup prim wX wY) where     showsPrec d (PrimFixup p) =         showParen (d > appPrec) $ showString "PrimFixup " . showsPrec2 (appPrec + 1) p     showsPrec d (NameFixup p) =         showParen (d > appPrec) $ showString "NameFixup " . showsPrec2 (appPrec + 1) p -instance Show2 (PrimOf p) => Show1 (RebaseFixup p wX) where-    showDict1 = ShowDictClass+instance Show2 prim => Show1 (RebaseFixup prim wX) -instance Show2 (PrimOf p) => Show2 (RebaseFixup p) where-    showDict2 = ShowDictClass+instance Show2 prim => Show2 (RebaseFixup prim) -instance PrimPatchBase p => PrimPatchBase (RebaseFixup p) where-    type PrimOf (RebaseFixup p) = PrimOf p+instance PrimPatch prim => PrimPatchBase (RebaseFixup prim) where+    type PrimOf (RebaseFixup prim) = prim -instance (PrimPatchBase p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseFixup p) where-    type ApplyState (RebaseFixup p) = ApplyState p+instance Apply prim => Apply (RebaseFixup prim) where+    type ApplyState (RebaseFixup prim) = ApplyState prim     apply (PrimFixup p) = apply p-    apply (NameFixup p) = apply p--instance Effect (RebaseFixup p) where-    effect (PrimFixup p) = p :>: NilFL-    effect (NameFixup p) = effect p--instance Eq2 (PrimOf p) => Eq2 (RebaseFixup p) where-    PrimFixup p1 `unsafeCompare` PrimFixup p2 = p1 `unsafeCompare` p2-    PrimFixup _ `unsafeCompare` _ = False-    _ `unsafeCompare` PrimFixup _ = False--    NameFixup n1 `unsafeCompare` NameFixup n2 = n1 `unsafeCompare` n2-    -- NameFixup _ `unsafeCompare` _ = False-    -- _ `unsafeCompare` NameFixup _ = False+    apply (NameFixup _) = return ()+    unapply (PrimFixup p) = unapply p+    unapply (NameFixup _) = return () -instance Invert (PrimOf p) => Invert (RebaseFixup p) where+instance Invert prim => Invert (RebaseFixup prim) where     invert (PrimFixup p) = PrimFixup (invert p)     invert (NameFixup n) = NameFixup (invert n) -instance PatchInspect (PrimOf p) => PatchInspect (RebaseFixup p) where+instance PatchInspect prim => PatchInspect (RebaseFixup prim) where     listTouchedFiles (PrimFixup p) = listTouchedFiles p     listTouchedFiles (NameFixup n) = listTouchedFiles n      hunkMatches f (PrimFixup p) = hunkMatches f p     hunkMatches f (NameFixup n) = hunkMatches f n -instance PrimPatchBase p => Commute (RebaseFixup p) where+instance PatchListFormat (RebaseFixup prim)++instance ShowPatchBasic prim => ShowPatchBasic (RebaseFixup prim) where+  showPatch f (PrimFixup p) =+    blueText "rebase-fixup" <+> blueText "(" $$ showPatch f p $$ blueText ")"+  showPatch f (NameFixup p) =+    blueText "rebase-name" <+> blueText "(" $$ showPatch f p $$ blueText ")"++instance ReadPatch prim => ReadPatch (RebaseFixup prim) where+ readPatch' =+   mapSeal PrimFixup <$> readWith (BC.pack "rebase-fixup" ) <|>+   mapSeal NameFixup <$> readWith (BC.pack "rebase-name"  )+   where+     readWith :: forall q wX . ReadPatch q => B.ByteString -> Parser (Sealed (q wX))+     readWith str = do+       lexString str+       lexString (BC.pack "(")+       res <- readPatch'+       lexString (BC.pack ")")+       return res+++instance Commute prim => Commute (RebaseFixup prim) where     commute (PrimFixup p :> PrimFixup q) = do         q' :> p' <- commute (p :> q)         return (PrimFixup q' :> PrimFixup p')@@ -104,10 +126,45 @@         q' :> p' <- return $ commuteNamePrim (p :> q)         return (PrimFixup q' :> NameFixup p') +pushFixupPrim+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> PushFixupFn prim prim (FL prim) (Maybe2 prim)+pushFixupPrim da (f1 :> f2)+ | IsEq <- isInverse = NilFL :> Nothing2+ | otherwise+   = case commute (f1 :> f2) of+       Nothing -> canonizeFL da (f1 :>: f2 :>: NilFL) :> Nothing2+       Just (f2' :> f1') -> (f2' :>: NilFL) :> Just2 f1'+  where isInverse = invert f1 =\/= f2++pushFixupFixup+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> PushFixupFn+       (RebaseFixup prim) (RebaseFixup prim)+       (FL (RebaseFixup prim)) (Maybe2 (RebaseFixup prim))++pushFixupFixup da (PrimFixup f1 :> PrimFixup f2)+  = case pushFixupPrim da (f1 :> f2) of+      fs2' :> f1' -> mapFL_FL PrimFixup fs2' :> mapMB_MB PrimFixup f1'++pushFixupFixup _da (PrimFixup f :> NameFixup n)+  = case commutePrimName (f :> n) of+      n' :> f' -> (NameFixup n' :>: NilFL) :> Just2 (PrimFixup f')++pushFixupFixup _da (NameFixup n1 :> NameFixup n2)+  = case pushFixupName (n1 :> n2) of+      ns2' :> n1' -> mapFL_FL NameFixup ns2' :> mapMB_MB NameFixup n1'++pushFixupFixup _da (NameFixup n :> PrimFixup f)+  = case commuteNamePrim (n :> f) of+      f' :> n' -> (PrimFixup f' :>: NilFL) :> Just2 (NameFixup n')++ -- |Split a sequence of fixups into names and prims-flToNamesPrims :: PrimPatchBase p-               => FL (RebaseFixup p) wX wY-               -> (FL (RebaseName p) :> FL (PrimOf p)) wX wY+flToNamesPrims :: FL (RebaseFixup prim) wX wY+               -> (FL RebaseName :> FL prim) wX wY flToNamesPrims NilFL = NilFL :> NilFL flToNamesPrims (NameFixup n :>: fs) =     case flToNamesPrims fs of@@ -118,50 +175,24 @@             case totalCommuterIdFL commutePrimName (p :> names) of                 names' :> p' -> names' :> (p' :>: prims) --- Note that this produces a list result because of the need to use effect to--- extract the result.--- Some general infrastructure for commuting p with PrimOf p would be helpful here,-commuteNamedPrim :: (FromPrim p, Effect p, Commute p)-                 => (Named p :> PrimOf p) wX wY-                 -> Maybe ((FL (PrimOf p) :> Named p) wX wY)-commuteNamedPrim (p :> q) = do-    q' :> p' <- commuterNamedId selfCommuter (p :> fromPrim q)-    return (effect q' :> p')--commutePrimNamed :: (FromPrim p, Effect p, Commute p)-                 => (PrimOf p :> Named p) wX wY-                 -> Maybe ((Named p :> FL (PrimOf p)) wX wY)-commutePrimNamed (p :> q) = do-    q' :> p' <- commuterIdNamed selfCommuter (fromPrim p :> q)-    return (q' :> effect p')--commuteNamedFixup :: (FromPrim p, Effect p, Commute p, Invert p)-                  => (Named p :> RebaseFixup p) wX wY-                  -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY)+commuteNamedFixup+  :: Commute prim+  => (Named prim :> RebaseFixup prim) wX wY+  -> Maybe ((RebaseFixup prim :> Named prim) wX wY) commuteNamedFixup (p :> PrimFixup q) = do-    qs' :> p' <- commuteNamedPrim (p :> q)-    return (mapFL_FL PrimFixup qs' :> p')+    q' :> p' <- commuterNamedId selfCommuter (p :> q)+    return (PrimFixup q' :> p') commuteNamedFixup (p :> NameFixup n) = do     n' :> p' <- commuteNamedName (p :> n)-    return ((NameFixup n' :>: NilFL) :> p')---commuteNamedFixups :: (FromPrim p, Effect p, Commute p, Invert p)-                   => (Named p :> FL (RebaseFixup p)) wX wY-                   -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY)-commuteNamedFixups (p :> NilFL) = return (NilFL :> p)-commuteNamedFixups (p :> (q :>: rs)) = do-    qs' :> p' <- commuteNamedFixup (p :> q)-    rs' :> p'' <- commuteNamedFixups (p' :> rs)-    return ((qs' +>+ rs') :> p'')-+    return (NameFixup n' :> p') -commuteFixupNamed :: (FromPrim p, Effect p, Commute p, Invert p)-                  => (RebaseFixup p :> Named p) wX wY-                  -> Maybe ((Named p :> FL (RebaseFixup p)) wX wY)+commuteFixupNamed+  :: Commute prim+  => (RebaseFixup prim :> Named prim) wX wY+  -> Maybe ((Named prim :> RebaseFixup prim) wX wY) commuteFixupNamed (PrimFixup p :> q) = do-    q' :> ps' <- commutePrimNamed (p :> q)-    return (q' :> mapFL_FL PrimFixup ps')+    q' :> p' <- commuterIdNamed selfCommuter (p :> q)+    return (q' :> PrimFixup p') commuteFixupNamed (NameFixup n :> q) = do     q' :> n' <- commuteNameNamed (n :> q)-    return (q' :> (NameFixup n' :>: NilFL))+    return (q' :> NameFixup n')
− src/Darcs/Patch/Rebase/Item.hs 
@@ -1,184 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Darcs.Patch.Rebase.Item-    ( RebaseItem(..)-    , simplifyPush, simplifyPushes-    , countToEdit-    ) where--import Prelude ()-import Darcs.Prelude--import Darcs.Patch.Commute ( selfCommuter )-import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )-import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Format ( PatchListFormat(..) )-import Darcs.Patch.Named ( Named(..), commuterIdNamed )-import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Show ( ShowPatch(..) )-import Darcs.Patch.Prim-    ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL )-import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )-import Darcs.Patch.Rebase.Name-    ( RebaseName(..)-    , commutePrimName, commuteNamePrim-    , canonizeNamePair-    )-import Darcs.Patch.Repair ( Check(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Patch.Summary ( plainSummaryPrim )-import Darcs.Patch.ReadMonads ( ParserM, lexString )-import Darcs.Patch.Witnesses.Eq-import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..), showsPrec2-    , ShowDict(ShowDictClass), appPrec-    )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )-import qualified Darcs.Util.Diff as D ( DiffAlgorithm )-import Darcs.Util.Printer ( vcat, blueText, ($$), (<+>) )--import Control.Applicative ( (<|>) )-import qualified Data.ByteString as B ( ByteString )-import qualified Data.ByteString.Char8 as BC ( pack )---- |A single item in the rebase state consists of either--- a patch that is being edited, or a fixup that adjusts--- the context so that a subsequent patch that is being edited--- \"makes sense\".------ @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of--- the patch will typically be the name the patch had before--- it was added to the rebase state; if it is moved back--- into the repository it must be given a fresh name to account--- for the fact that it will not necessarily have the same--- dependencies as the original patch. This is typically--- done by changing the @Ignore-This@ junk.------ @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch--- is correct. Where possible, @Fixup@ changes are commuted--- as far as possible into the rebase state, so any remaining--- ones will typically cause a conflict when the @ToEdit@ patch--- is moved back into the repository.-data RebaseItem p wX wY where-    ToEdit :: Named p wX wY -> RebaseItem p wX wY-    Fixup :: RebaseFixup p wX wY -> RebaseItem p wX wY--instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY) where-    showsPrec d (ToEdit p) =-        showParen (d > appPrec) $ showString "ToEdit " . showsPrec2 (appPrec + 1) p-    showsPrec d (Fixup p) =-        showParen (d > appPrec) $ showString "Fixup " . showsPrec2 (appPrec + 1) p--instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX) where-    showDict1 = ShowDictClass--instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p) where-    showDict2 = ShowDictClass--countToEdit :: FL (RebaseItem p) wX wY -> Int-countToEdit NilFL = 0-countToEdit (ToEdit _ :>: ps) = 1 + countToEdit ps-countToEdit (_ :>: ps) = countToEdit ps---- |Given a list of rebase items, try to push a new fixup as far as possible into--- the list as possible, using both commutation and coalescing. If the fixup--- commutes past all the 'ToEdit' patches then it is dropped entirely.-simplifyPush :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)-             => D.DiffAlgorithm -> RebaseFixup p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)--simplifyPush _ _f NilFL = Sealed NilFL--simplifyPush da (PrimFixup f1) (Fixup (PrimFixup f2) :>: ps)- | IsEq <- isInverse = Sealed ps- | otherwise-   = case commute (f1 :> f2) of-       Nothing -> Sealed (mapFL_FL (Fixup . PrimFixup) (canonizeFL da (f1 :>: f2 :>: NilFL)) +>+ ps)-       Just (f2' :> f1') -> mapSeal (Fixup (PrimFixup f2') :>:) (simplifyPush da (PrimFixup f1') ps)-  where isInverse = invert f1 =\/= f2--simplifyPush da (PrimFixup f) (Fixup (NameFixup n) :>: ps)-    = case commutePrimName (f :> n) of-        n' :> f' -> mapSeal (Fixup (NameFixup n') :>:) (simplifyPush da (PrimFixup f') ps)--simplifyPush da (PrimFixup f) (ToEdit e :>: ps)-   = case commuterIdNamed selfCommuter (fromPrim f :> e) of-       Nothing -> Sealed (Fixup (PrimFixup f) :>: ToEdit e :>: ps)-       Just (e' :> f') -> mapSeal (ToEdit e' :>:) (simplifyPushes da (mapFL_FL PrimFixup (effect f')) ps)--simplifyPush da (NameFixup n1) (Fixup (NameFixup n2) :>: ps)- | IsEq <- isInverse = Sealed ps- | otherwise-   = case commute (n1 :> n2) of-       Nothing -> Sealed (mapFL_FL (Fixup . NameFixup) (canonizeNamePair (n1 :> n2)) +>+ ps)-       Just (n2' :> n1') -> mapSeal (Fixup (NameFixup n2') :>:) (simplifyPush da (NameFixup n1') ps)-  where isInverse = invert n1 =\/= n2--simplifyPush da (NameFixup n) (Fixup (PrimFixup f) :>: ps) =-    case commuteNamePrim (n :> f) of-      f' :> n' -> mapSeal (Fixup (PrimFixup f') :>:) (simplifyPush da (NameFixup n') ps)--simplifyPush da (NameFixup (AddName an)) (p@(ToEdit (NamedP pn deps _)) :>: ps)-  | an == pn = impossible-  | an `elem` deps = Sealed (Fixup (NameFixup (AddName an)) :>: p :>: ps)-  | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (AddName an)) ps)-simplifyPush da (NameFixup (DelName dn)) (p@(ToEdit (NamedP pn deps _)) :>: ps)-  -- this case can arise if a patch is suspended then a fresh copy is pulled from another repo-  | dn == pn = Sealed (Fixup (NameFixup (DelName dn)) :>: p :>: ps)-  | dn `elem` deps = impossible-  | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (DelName dn)) ps)-simplifyPush da (NameFixup (Rename old new)) (p@(ToEdit (NamedP pn deps body)) :>: ps)-  | old == pn = impossible-  | new == pn = impossible-  | old `elem` deps = impossible-  | new `elem` deps =-      let newdeps = map (\dep -> if new == dep then old else dep) deps-      in mapSeal (ToEdit (NamedP pn newdeps (unsafeCoerceP body)) :>:) (simplifyPush da (NameFixup (Rename old new)) ps)-  | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (Rename old new)) ps)---- |Like 'simplifyPush' but for a list of fixups.-simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)-               => D.DiffAlgorithm -> FL (RebaseFixup p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)-simplifyPushes _ NilFL ps = Sealed ps-simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps)--instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where-   showPatch f (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch f p $$ blueText ")"-   showPatch f (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch f p $$ blueText ")" where-   showPatch f (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch f p $$ blueText ")"--instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p)-    => ShowPatch (RebaseItem p) where--   summary (ToEdit p) = summary p-   summary (Fixup (PrimFixup p)) = plainSummaryPrim p-   summary (Fixup (NameFixup n)) = summary n-   summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts---instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where-   readPatch' = mapSeal ToEdit              <$> readWith (BC.pack "rebase-toedit") <|>-                mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|>-                mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name"  )-     where readWith :: forall m q wX . (ParserM m, ReadPatch q) => B.ByteString -> m (Sealed (q wX))-           readWith str = do lexString str-                             lexString (BC.pack "(")-                             res <- readPatch'-                             lexString (BC.pack ")")-                             return res--instance Check p => Check (RebaseItem p) where-   isInconsistent (Fixup _) = Nothing-   isInconsistent (ToEdit p) = isInconsistent p--instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseItem p) where-   listTouchedFiles (ToEdit p) = listTouchedFiles p-   listTouchedFiles (Fixup p) = listTouchedFiles p--   hunkMatches f (ToEdit p) = hunkMatches f p-   hunkMatches f (Fixup p) = hunkMatches f p
+ src/Darcs/Patch/Rebase/Legacy/Item.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.Rebase.Legacy.Item+    ( RebaseItem(..)+    , toRebaseChanges+    ) where++import Darcs.Prelude++import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )+import Darcs.Patch.Rebase.Change ( RebaseChange(..), addNamedToRebase )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Util.Parser ( Parser, lexString )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import qualified Darcs.Util.Diff as D++import Control.Applicative ( (<|>) )+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( pack )++-- |A single item in the rebase state consists of either+-- a patch that is being edited, or a fixup that adjusts+-- the context so that a subsequent patch that is being edited+-- \"makes sense\".+--+-- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of+-- the patch will typically be the name the patch had before+-- it was added to the rebase state; if it is moved back+-- into the repository it must be given a fresh name to account+-- for the fact that it will not necessarily have the same+-- dependencies or content as the original patch. This is typically+-- done by changing the @Ignore-This@ junk.+--+-- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch+-- is correct. Where possible, @Fixup@ changes are commuted+-- as far as possible into the rebase state, so any remaining+-- ones will typically cause a conflict when the @ToEdit@ patch+-- is moved back into the repository.+data RebaseItem p wX wY where+    ToEdit :: Named p wX wY -> RebaseItem p wX wY+    Fixup :: RebaseFixup (PrimOf p) wX wY -> RebaseItem p wX wY++deriving instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY)++instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX)++instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p)++toRebaseChanges+  :: forall p wX wY+   . 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)++-- This Read instance partly duplicates the instances for RebaseFixup,+-- but are left this way given this code is now here only for backwards compatibility of the on-disk+-- format and we might want to make future changes to RebaseFixup.+instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where+   readPatch' = mapSeal ToEdit              <$> readWith (BC.pack "rebase-toedit") <|>+                mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|>+                mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name"  )+     where readWith :: forall q wX . ReadPatch q => B.ByteString -> Parser (Sealed (q wX))+           readWith str = do lexString str+                             lexString (BC.pack "(")+                             res <- readPatch'+                             lexString (BC.pack ")")+                             return res
src/Darcs/Patch/Rebase/Name.hs view
@@ -5,36 +5,31 @@ module Darcs.Patch.Rebase.Name     ( RebaseName(..)     , commuteNamePrim, commutePrimName+    , commuterIdNamed, commuterNamedId     , commuteNameNamed, commuteNamedName-    , canonizeNamePair+    , pushFixupName     ) where -import Prelude () import Darcs.Prelude -import Darcs.Patch.CommuteFn ( CommuteFn )-import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.Info ( PatchInfo, isInverted, showPatchInfo, readPatchInfo )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Named ( Named(..) )-import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterFLId )+import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo )+import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Named ( Named(..) ) import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Show ( ShowPatch(..) )-import Darcs.Patch.Permutations ( inverseCommuter )-import Darcs.Patch.Prim ( PrimPatchBase(..) )-import Darcs.Patch.ReadMonads ( lexString )-import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Patch.Witnesses.Eq ( Eq2(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..)-    , ShowDict(ShowDictClass)-    )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) +import Darcs.Patch.Rebase.PushFixup ( PushFixupFn )++import Darcs.Util.Parser ( lexString ) import Darcs.Util.Printer ( empty, blueText, ($$) )  import Control.Applicative ( (<|>) )@@ -43,33 +38,32 @@ -- Note: in principle this is a general concept not limited to -- rebase, and we might be able to generalise this type and -- refactor named patches to use it too.+ -- | A 'RebaseName' encapsulates the concept of the name of a patch, -- without any contents. This allows us to track explicit dependencies -- in the rebase state, changing them to follow uses of amend-record -- or unsuspend on a depended-on patch, and warning the user if any -- are lost entirely.-data RebaseName (p :: * -> * -> *) wX wY where-  AddName :: PatchInfo -> RebaseName p wX wY-  DelName :: PatchInfo -> RebaseName p wX wY-  Rename :: PatchInfo -> PatchInfo -> RebaseName p wX wY-    deriving Show+data RebaseName wX wY where+  AddName :: PatchInfo -> RebaseName wX wY+  DelName :: PatchInfo -> RebaseName wX wY+  Rename :: PatchInfo -> PatchInfo -> RebaseName wX wY+    deriving (Eq, Show) -instance Show1 (RebaseName p wX) where-    showDict1 = ShowDictClass+instance Show1 (RebaseName wX) -instance Show2 (RebaseName p) where-    showDict2 = ShowDictClass+instance Show2 RebaseName -instance ShowPatchBasic (RebaseName p) where+instance ShowPatchBasic RebaseName where    showPatch f (AddName n) = blueText "addname" $$ showPatchInfo f n    showPatch f (DelName n) = blueText "delname" $$ showPatchInfo f n    showPatch f (Rename old new) = blueText "rename" $$ showPatchInfo f old $$ showPatchInfo f new -instance ShowPatch (RebaseName p) where+instance ShowPatch RebaseName where    summary _ = empty -- TODO improve this?    summaryFL _ = empty -instance ReadPatch (RebaseName p) where+instance ReadPatch RebaseName where    readPatch' = readAddName <|> readDelName <|> readRename      where        readAddName = do lexString (BC.pack "addname")@@ -83,12 +77,12 @@                         new <- readPatchInfo                         return (Sealed (Rename old new)) -instance Commute (RebaseName p) where+instance Commute RebaseName where    commute (AddName n1 :> AddName n2)-      | n1 == n2 = impossible+      | n1 == n2 = error "impossible case"       | otherwise = Just (AddName n2 :> AddName n1)    commute (DelName n1 :> DelName n2)-      | n1 == n2 = impossible+      | n1 == n2 = error "impossible case"       | otherwise = Just (DelName n2 :> DelName n1)    commute (AddName n1 :> DelName n2)       | n1 /= n2 = Just (DelName n2 :> AddName n1)@@ -98,99 +92,101 @@       | otherwise = Nothing    commute (Rename old new :> AddName n)       | n == old = Nothing-      | n == new = impossible -- precondition of Add is that n doesn't exist+      | n == new = error "impossible case" -- precondition of Add is that n doesn't exist       | otherwise = Just (AddName n :> Rename old new)    commute (AddName n :> Rename old new)       | n == old = Nothing-      | n == new = impossible -- precondition of Rename is that new doesn't exist+      | n == new = error "impossible case" -- precondition of Rename is that new doesn't exist       | otherwise = Just (Rename old new :> AddName n)    commute (Rename old new :> DelName n)-      | n == old = impossible -- precondition of Del is that n does exist+      | n == old = error "impossible case" -- precondition of Del is that n does exist       | n == new = Nothing       | otherwise = Just (DelName n :> Rename old new)    commute (DelName n :> Rename old new)-      | n == old = impossible -- precondition of Rename is that old does exist+      | n == old = error "impossible case" -- precondition of Rename is that old does exist       | n == new = Nothing       | otherwise = Just (Rename old new :> DelName n)    commute (Rename old1 new1 :> Rename old2 new2)-      | old1 == old2 = impossible-      | new1 == new2 = impossible+      | old1 == old2 = error "impossible case"+      | new1 == new2 = error "impossible case"       | old1 == new2 = Nothing       | new1 == old2 = Nothing       | otherwise = Just (Rename old2 new2 :> Rename old1 new1) -instance Invert (RebaseName p) where+instance Invert RebaseName where    invert (AddName n) = DelName n    invert (DelName n) = AddName n    invert (Rename old new) = Rename new old -instance PatchInspect (RebaseName p) where+instance PatchInspect RebaseName where     listTouchedFiles _ = []     hunkMatches _ _ = False -instance Apply (RebaseName p) where-   type ApplyState (RebaseName p) = ApplyState p-   apply _ = return ()--instance PrimPatchBase p => PrimPatchBase (RebaseName p) where-   type PrimOf (RebaseName p) = PrimOf p--instance Effect (RebaseName p) where-   effect _ = unsafeCoerceP NilFL--instance Eq2 (RebaseName p) where-   AddName n1 `unsafeCompare` AddName n2 = n1 == n2-   AddName _ `unsafeCompare` _ = False-   _ `unsafeCompare` AddName _ = False--   DelName n1 `unsafeCompare` DelName n2 = n1 == n2-   DelName _ `unsafeCompare` _ = False-   _ `unsafeCompare` DelName _ = False--   Rename old1 new1 `unsafeCompare` Rename old2 new2 = old1 == old2 && new1 == new2-   -- Rename _ _  `unsafeCompare` _ = False-   -- _ `unsafeCompare` Rename _ _  = False-+instance Eq2 RebaseName where+   p1 =\/= p2+      | p1 == unsafeCoercePEnd p2 = unsafeCoercePEnd IsEq+      | otherwise = NotEq --- |Commute a name patch and a primitive patch. They trivially+-- |Commute a 'RebaseName' and a primitive patch. They trivially -- commute so this just involves changing the witnesses.-commuteNamePrim :: (RebaseName p :> PrimOf p) wX wY -> (PrimOf p :> RebaseName p) wX wY+-- This is unsafe if the patch being commuted actually has a+-- name (e.g. Named or PatchInfo - PrimWithName is ok),+commuteNamePrim :: (RebaseName :> prim) wX wY -> (prim :> RebaseName) wX wY commuteNamePrim (n :> f) = unsafeCoerceP f :> unsafeCoerceP n --- |Commute a primitive patch and a name patch. They trivially+-- |Commute a primitive patch and a 'RebaseName'. They trivially -- commute so this just involves changing the witnesses.-commutePrimName :: (PrimOf p :> RebaseName p) wX wY -> (RebaseName p :> PrimOf p) wX wY+-- This is unsafe if the patch being commuted actually has a+-- name (e.g. Named or PatchInfo - PrimWithName is ok),+commutePrimName :: (prim :> RebaseName) wX wY -> (RebaseName :> prim) wX wY commutePrimName (f :> n) = unsafeCoerceP n :> unsafeCoerceP f +-- commuterIdNamed and commuterNamedId are defined here rather than in+-- Named given that they are unsafe, to reduce the chances of them+-- being used inappropriately.++-- |Commute an unnamed patch with a named patch. This is unsafe if the+-- second patch actually does have a name (e.g. Named, PatchInfoAnd, etc),+-- as it won't check the explicit dependencies.+commuterIdNamed :: CommuteFn p1 p2 -> CommuteFn p1 (Named p2)+commuterIdNamed commuter (p1 :> NamedP n2 d2 p2) =+   do p2' :> p1' <- commuterIdFL commuter (p1 :> p2)+      return (NamedP n2 d2 p2' :> p1')++-- |Commute an unnamed patch with a named patch. This is unsafe if the+-- first patch actually does have a name (e.g. Named, PatchInfoAnd, etc),+-- as it won't check the explicit dependencies.+commuterNamedId :: CommuteFn p1 p2 -> CommuteFn (Named p1) p2+commuterNamedId commuter (NamedP n1 d1 p1 :> p2) =+   do p2' :> p1' <- commuterFLId commuter (p1 :> p2)+      return (p2' :> NamedP n1 d1 p1')+ -- |Commute a name patch and a named patch. In most cases this is -- trivial but we do need to check explicit dependencies.-commuteNameNamed :: Invert p => CommuteFn (RebaseName p) (Named p)-commuteNameNamed pair@(_ :> NamedP pn _ _)-  | isInverted pn = inverseCommuter commuteNamedName pair+commuteNameNamed :: CommuteFn RebaseName (Named p) commuteNameNamed (AddName an :> p@(NamedP pn deps _))-  | an == pn = impossible+  | an == pn = error "impossible case"   | an `elem` deps = Nothing   | otherwise = Just (unsafeCoerceP p :> AddName an) commuteNameNamed (DelName dn :> p@(NamedP pn deps _))-  | dn == pn = impossible-  | dn `elem` deps = impossible+  -- this case can arise if a patch is suspended then a fresh copy is pulled from another repo+  | dn == pn = Nothing+  | dn `elem` deps = error "impossible case"   | otherwise = Just (unsafeCoerceP p :> DelName dn) commuteNameNamed (Rename old new :> NamedP pn deps body)-  | old == pn = impossible-  | new == pn = impossible-  | old `elem` deps = impossible+  | old == pn = error "impossible case"+  | new == pn = error "impossible case"+  | old `elem` deps = error "impossible case"   | otherwise =       let newdeps = map (\dep -> if new == dep then old else dep) deps       in Just (NamedP pn newdeps (unsafeCoerceP body) :> Rename old new)  -- |Commute a named patch and a name patch. In most cases this is -- trivial but we do need to check explicit dependencies.-commuteNamedName :: Invert p => CommuteFn (Named p) (RebaseName p)-commuteNamedName pair@(NamedP pn _ _ :> _)-  | isInverted pn = inverseCommuter commuteNameNamed pair+commuteNamedName :: CommuteFn (Named p) RebaseName commuteNamedName (p@(NamedP pn deps _) :> AddName an)-  | an == pn = impossible  -- the NamedP introduces pn, then AddName introduces it again-  | an `elem` deps = impossible -- the NamedP depends on an before it is introduced+  | an == pn = error "impossible case"  -- the NamedP introduces pn, then AddName introduces it again+  | an `elem` deps = error "impossible case" -- the NamedP depends on an before it is introduced   | otherwise = Just (AddName an :> unsafeCoerceP p) commuteNamedName (p@(NamedP pn deps _) :> DelName dn)   | dn == pn = Nothing@@ -198,15 +194,23 @@   | otherwise = Just (DelName dn :> unsafeCoerceP p) commuteNamedName (NamedP pn deps body :> Rename old new)   | old == pn = Nothing-  | new == pn = impossible-  | new `elem` deps = impossible+  | new == pn = error "impossible case"+  | new `elem` deps = error "impossible case"   | otherwise =       let newdeps = map (\dep -> if old == dep then new else dep) deps       in Just (Rename old new :> NamedP pn newdeps (unsafeCoerceP body)) -canonizeNamePair :: (RebaseName p :> RebaseName p) wX wY -> FL (RebaseName p) wX wY+canonizeNamePair :: (RebaseName :> RebaseName) wX wY -> FL RebaseName wX wY canonizeNamePair (AddName n :> Rename old new) | n == old = AddName new :>: NilFL canonizeNamePair (Rename old new :> DelName n) | n == new = DelName old :>: NilFL canonizeNamePair (Rename old1 new1 :> Rename old2 new2) | new1 == old2 = Rename old1 new2 :>: NilFL canonizeNamePair (n1 :> n2) = n1 :>: n2 :>: NilFL +pushFixupName :: PushFixupFn RebaseName RebaseName (FL RebaseName) (Maybe2 RebaseName)+pushFixupName (n1 :> n2)+ | IsEq <- isInverse = NilFL :> Nothing2+ | otherwise+   = case commute (n1 :> n2) of+       Nothing -> (canonizeNamePair (n1 :> n2)) :> Nothing2+       Just (n2' :> n1') -> (n2' :>: NilFL) :> Just2 n1'+  where isInverse = invert n1 =\/= n2
+ src/Darcs/Patch/Rebase/PushFixup.hs view
@@ -0,0 +1,108 @@+module Darcs.Patch.Rebase.PushFixup+  ( PushFixupFn, dropFixups+  , pushFixupFLFL_FLFLFL+  , pushFixupFLFL_FLFLFLFL+  , pushFixupFLMB_FLFLMB+  , pushFixupIdFL_FLFLFL+  , pushFixupIdMB_FLFLMB+  , pushFixupIdMB_FLIdFLFL+  ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered+  ( (:>)(..), FL(..), (+>+)+  )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )++-- | During a rebase, we use "fixup" patches to maintain the correct+-- context for the real "items" that are being stored in the rebase+-- that the user wants to keep. As the context of the rebase changes,+-- new fixups get added to the beginning that then need to be pushed+-- past as many items as possible.+--+-- There are multiple fixup types and multiple ways of representing+-- the items being stored in the rebase, so this is polymorphic in+-- both types. Also, the structure of the results varies - in some+-- cases it will be a single value, sometimes an FL, or sometimes+-- zero or one values (Maybe2), so the output types are separate+-- variables. A typical instantiation would be something like+-- PushFixupFn Fixup Item (FL Item) (FL Fixup).+type PushFixupFn fixupIn itemIn itemOut fixupOut+  =  forall wX wY+  .  (fixupIn :> itemIn  ) wX wY+  -> (itemOut :> fixupOut) wX wY++dropFixups :: (item :> fixup) wX wY -> Sealed (item wX)+dropFixups (item :> _) = Sealed item++{-+The collection below of pushFixup combinators is quite annoying, but+there's no obvious generalisation, and inlining them at each use site+would be even worse.+-}++pushFixupFLFL_FLFLFL+  :: PushFixupFn fixup     item  (FL item) (FL fixup)+  -> PushFixupFn fixup (FL item) (FL item) (FL fixup)+pushFixupFLFL_FLFLFL _pushOne (fixup :> NilFL)+  = NilFL :> (fixup :>: NilFL)+pushFixupFLFL_FLFLFL pushOne (fixup :> (item1 :>: items2))+  = case pushOne (fixup :> item1) of+      items1' :> fixups' ->+        case pushFixupFLFL_FLFLFLFL pushOne (fixups' :> items2) of+          items2' :> fixups'' -> (items1' +>+ items2') :> fixups''++pushFixupFLFL_FLFLFLFL+  :: PushFixupFn     fixup      item  (FL item) (FL fixup)+  -> PushFixupFn (FL fixup) (FL item) (FL item) (FL fixup)+pushFixupFLFL_FLFLFLFL _pushOne (NilFL :> items)+  = items :> NilFL+pushFixupFLFL_FLFLFLFL pushOne ((fixup1 :>: fixups2) :> items)+  = case pushFixupFLFL_FLFLFLFL pushOne (fixups2 :> items) of+      items' :> fixups2' ->+        case pushFixupFLFL_FLFLFL pushOne (fixup1 :> items') of+          items'' :> fixups1' -> items'' :> (fixups1' +>+ fixups2')++pushFixupFLMB_FLFLMB+  :: PushFixupFn fixup     item  (FL item) (Maybe2 fixup)+  -> PushFixupFn fixup (FL item) (FL item) (Maybe2 fixup)+pushFixupFLMB_FLFLMB _pushOne (fixup :> NilFL)+  = NilFL :> Just2 fixup+pushFixupFLMB_FLFLMB pushOne (fixup :> (item1 :>: items2))+  = case pushOne (fixup :> item1) of+      items1' :> Nothing2 -> items1' +>+ items2 :> Nothing2+      items1' :> Just2 fixup' ->+        case pushFixupFLMB_FLFLMB pushOne (fixup' :> items2) of+          items2' :> fixup'' -> items1' +>+ items2' :> fixup''++pushFixupIdFL_FLFLFL+  :: PushFixupFn fixup     item      item  (FL fixup)+  -> PushFixupFn fixup (FL item) (FL item) (FL fixup)+pushFixupIdFL_FLFLFL pushOne+  = pushFixupFLFL_FLFLFL (mkList . pushOne)+  where+    mkList :: (item :> FL fixup) wX wY -> (FL item :> FL fixup) wX wY+    mkList (item :> fixups) = (item :>: NilFL) :> fixups++pushFixupIdMB_FLFLMB+  :: PushFixupFn fixup     item      item  (Maybe2 fixup)+  -> PushFixupFn fixup (FL item) (FL item) (Maybe2 fixup)+pushFixupIdMB_FLFLMB pushOne+  = pushFixupFLMB_FLFLMB (mkList . pushOne)+  where+    mkList :: (item :> Maybe2 fixup) wX wY -> (FL item :> Maybe2 fixup) wX wY+    mkList (item :> fixups) = (item :>: NilFL) :> fixups++pushFixupIdMB_FLIdFLFL+  :: PushFixupFn     fixup  item     item (Maybe2 fixup)+  -> PushFixupFn (FL fixup) item     item (FL     fixup)+pushFixupIdMB_FLIdFLFL _pushOne (NilFL :> item)+  = item :> NilFL+pushFixupIdMB_FLIdFLFL pushOne ((fixup :>: fixups) :> item)+  = case pushFixupIdMB_FLIdFLFL pushOne (fixups :> item) of+      item' :> fixups2' ->+        case pushOne (fixup :> item') of+          item'' :> Nothing2      -> item'' :>             fixups2'+          item'' :> Just2 fixup1' -> item'' :> fixup1' :>: fixups2'
+ src/Darcs/Patch/Rebase/Suspended.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.Rebase.Suspended+    ( Suspended(..)+    , countToEdit, simplifyPush, simplifyPushes+    , addFixupsToSuspended, removeFixupsFromSuspended+    , addToEditsToSuspended+    ) 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.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.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Util.Printer ( 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)++instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Suspended p) where+  listTouchedFiles (Items ps) = listTouchedFiles ps+  hunkMatches f (Items ps) = hunkMatches f ps++instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where+   showPatch 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' =+    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' '{' '}')+           -- 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' '{' '}'+           | otherwise -> error $ "can't handle rebase version " ++ show version++countToEdit :: Suspended p wX wY -> 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)+  => Named p wX wY+  -> Suspended p wY wY+  -> Suspended p wX wX+addFixupsToSuspended p = simplifyPushes D.MyersDiff (namedToFixups p)++-- |remove fixups (actually, add their inverse) for the name and effect of a patch to a 'Suspended'+removeFixupsFromSuspended+  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)+  => Named p wX wY+  -> Suspended p wX wX+  -> Suspended p wY wY+removeFixupsFromSuspended p = simplifyPushes D.MyersDiff (invert (namedToFixups p))++-- | Add 'Named' patches for editing to a 'Suspended'. The patches to be+-- suspended are renamed by replacing the junk in their 'Patchinfo'.+--+-- The reason we rename patches immediately when suspending them is that+-- the user may pull an identical copy from a clone, Which means we have+-- the same patch name twice, once in the normal repo and once suspended.+-- Furthermore, they can again suspend that copy, leaving us with multiple+-- copies of the same patch in the rebase state. This is bad because it+-- invalidates most of the invariants for RebaseName fixups. See issue2445+-- and tests/rebase-repull.sh for examples which lead to crashes when we+-- don't do the renaming here.+addToEditsToSuspended+  :: RepoPatch p+  => D.DiffAlgorithm+  -> FL (Named p) wX wY+  -> Suspended p wY wY+  -> IO (Suspended p wX wX)+addToEditsToSuspended _ NilFL items = return items+addToEditsToSuspended da (NamedP old ds ps :>: qs) items = do+  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'''++simplifyPush+  :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)+  => D.DiffAlgorithm+  -> RebaseFixup (PrimOf p) wX wY+  -> Suspended p wY wY+  -> Suspended p wX wX+simplifyPush da fixups = onSuspended (Change.simplifyPush da fixups)++simplifyPushes+  :: (PrimPatchBase p, Commute p, FromPrim p, Effect 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)
− src/Darcs/Patch/Rebase/Viewing.hs 
@@ -1,570 +0,0 @@---  Copyright (C) 2009 Ganesh Sittampalam------  BSD3-{-# LANGUAGE UndecidableInstances #-}-module Darcs.Patch.Rebase.Viewing-    ( RebaseSelect(..)-    , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect-    , partitionUnconflicted-    , rsToPia-    , WithDroppedDeps(..), WDDNamed, commuterIdWDD-    , RebaseChange(..), toRebaseChanges-    ) where--import Prelude ()-import Darcs.Prelude--import Darcs.Patch.Commute ( selfCommuter )-import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterRLId, MergeFn-                             , totalCommuterIdFL-                             )-import Darcs.Patch.Conflict-    ( Conflict(..), CommuteNoConflicts(..)-    , IsConflictedPrim-    )-import Darcs.Patch.Debug ( PatchDebug(..) )-import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Format ( PatchListFormat(..) )-import Darcs.Patch.Info ( PatchInfo )-import Darcs.Patch.Invert ( invertFL, invertRL )-import Darcs.Patch.Matchable ( Matchable )-import Darcs.Patch.Merge ( Merge(..), selfMerger )-import Darcs.Patch.Named-    ( Named(..), namepatch, infopatch-    , mergerIdNamed-    , getdeps-    , patch2patchinfo, patchcontents-    )-import Darcs.Patch.Named.Wrapped-    ( WrappedNamed(..)-    )-import qualified Darcs.Patch.Named.Wrapped as Wrapped-    ( infopatch, adddeps-    )--import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )-import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Show ( ShowPatch(..) )-import Darcs.Patch.Prim-    ( PrimPatch, PrimPatchBase(..), FromPrim(..), FromPrims(..)-    )-import Darcs.Patch.Rebase.Container ( Suspended(..) )-import Darcs.Patch.Rebase.Fixup-    ( RebaseFixup(..)-    , commuteFixupNamed, commuteNamedFixups-    , flToNamesPrims-    )-import Darcs.Patch.Rebase.Item ( RebaseItem(..) )-import Darcs.Patch.Rebase.Name ( RebaseName(..) )-import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(..), ShowContextPatch(..) )-import Darcs.Patch.Summary ( plainSummary )-import Darcs.Patch.Witnesses.Eq-import Darcs.Patch.Witnesses.Ordered-import Darcs.Patch.Witnesses.Sealed-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..), ShowDict(ShowDictClass)-    , showsPrec2-    )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )-import Darcs.Util.IsoDate ( getIsoDateTime )-import Darcs.Util.Printer ( ($$), redText, empty, vcat )-import Darcs.Util.Show ( appPrec )--import Data.List ( nub, (\\) )-import Data.Maybe ( fromMaybe )---- |Encapsulate a single patch in the rebase state together with its fixups.--- Used during interactive selection to make sure that each item presented--- to the user corresponds to a patch.-data RebaseSelect p wX wY where-   -- The normal case for a RebaseSelect - a patch that points forwards.-   RSFwd :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseSelect p wX wZ-   -- We need an 'Invert' instance. We just represent inverses-   -- with a different constructor instead of trying to come up with some logical-   -- inversion of the individual components. Typically they get uninverted-   -- before anything significant is done with them, so a lot of code that-   -- processes 'RebaseSelect' patches just uses 'impossible' for 'RSRev'.-   RSRev :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseSelect p wZ wX---instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseSelect p wX wY) where-    showsPrec d (RSFwd fixups toedit) =-        showParen (d > appPrec) $-            showString "RSFwd " . showsPrec2 (appPrec + 1) fixups .-            showString " " . showsPrec2 (appPrec + 1) toedit-    showsPrec d (RSRev fixups toedit) =-        showParen (d > appPrec) $-            showString "RSRev " . showsPrec2 (appPrec + 1) fixups .-            showString " " . showsPrec2 (appPrec + 1) toedit--instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseSelect p wX) where-    showDict1 = ShowDictClass--instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseSelect p) where-    showDict2 = ShowDictClass---- TODO: merge with RebaseSelect.--- |Used for displaying during 'rebase changes'.--- 'Named (RebaseChange p)' is very similar to 'RebaseSelect p' but slight--- mismatches ('Named' embeds an 'FL') makes it not completely trivial to merge--- them.-data RebaseChange p wX wY where-    RCFwd :: FL (RebaseFixup p) wX wY -> FL p wY wZ -> RebaseChange p wX wZ-    RCRev :: FL (RebaseFixup p) wX wY -> FL p wY wZ -> RebaseChange p wZ wX--instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseChange p wX) where-    showDict1 = ShowDictClass--instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseChange p) where-    showDict2 = ShowDictClass--instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseChange p wX wY) where-    showsPrec d (RCFwd fixups changes) =-        showParen (d > appPrec) $-            showString "RCFwd " . showsPrec2 (appPrec + 1) fixups .-            showString " " . showsPrec2 (appPrec + 1) changes-    showsPrec d (RCRev fixups changes) =-        showParen (d > appPrec) $-            showString "RCRev " . showsPrec2 (appPrec + 1) fixups .-            showString " " . showsPrec2 (appPrec + 1) changes---- |Get hold of the 'PatchInfoAnd' patch inside a 'RebaseSelect'.-rsToPia :: RebaseSelect p wX wY -> Sealed2 (PatchInfoAnd ('RepoType 'NoRebase) p)-rsToPia (RSFwd _ toEdit) = Sealed2 (n2pia (NormalP toEdit))-rsToPia (RSRev _ toEdit) = Sealed2 (n2pia (NormalP toEdit))--instance PrimPatchBase p => PrimPatchBase (RebaseSelect p) where-   type PrimOf (RebaseSelect p) = PrimOf p--instance PatchDebug p => PatchDebug (RebaseSelect p)--instance PatchDebug p => PatchDebug (RebaseChange p)--instance (PrimPatchBase p, Invert p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseSelect p) where-   type ApplyState (RebaseSelect p) = ApplyState p-   apply (RSFwd fixups toedit) = apply fixups >> apply toedit-   apply (RSRev fixups toedit) = apply (invert toedit) >> apply (invertFL fixups)--instance ( PrimPatchBase p, Invert p, Apply p-         , ApplyState p ~ ApplyState (PrimOf p)-         )-        => Apply (RebaseChange p) where--    type ApplyState (RebaseChange p) = ApplyState p-    apply (RCFwd fixups contents) = apply fixups >> apply contents-    apply (RCRev fixups contents) = apply (invert contents) >> apply (invertFL fixups)--instance (PrimPatchBase p, Conflict p, CommuteNoConflicts p, Invert p) => Conflict (RebaseSelect p) where-   resolveConflicts (RSFwd _ toedit) = resolveConflicts toedit-   resolveConflicts (RSRev{}) = impossible--   conflictedEffect (RSFwd _ toedit) = conflictedEffect toedit-   conflictedEffect (RSRev{}) = impossible---- newtypes to help the type-checker with the 'changeAsMerge' abstraction-newtype ResolveConflictsResult p wY =-    ResolveConflictsResult {-        getResolveConflictsResult :: [[Sealed (FL (PrimOf p) wY)]]-    }--newtype ConflictedEffectResult p wY =-    ConflictedEffectResult {-        getConflictedEffectResult :: [IsConflictedPrim (PrimOf p)]-    }--changeAsMerge-    :: (PrimPatchBase p, Invert p, FromPrim p, Merge p)-    => (forall wX' . FL p wX' wY -> result p wY)-    -> RebaseChange p wX wY-    -> result p wY-changeAsMerge f (RCFwd fixups changes) =-    case flToNamesPrims fixups of-        _names :> prims ->-            case merge (invert (fromPrims prims) :\/: changes) of-                changes' :/\: _ifixups' ->-                    -- it might make sense to pass-                    -- (changes' +>+ invert _ifixups') to resolveConflicts,-                    -- but this isn't actually treated as a conflict by-                    -- either V1 or V2 patches (not quite sure why)-                    f (unsafeCoercePEnd changes')-changeAsMerge _ (RCRev _ _) = impossible--instance-    ( PrimPatchBase p, Invert p, Effect p-    , FromPrim p, Merge p, Conflict p, CommuteNoConflicts p-    )-   => Conflict (RebaseChange p) where-    resolveConflicts =-        getResolveConflictsResult . changeAsMerge (ResolveConflictsResult . resolveConflicts)---    conflictedEffect =-        getConflictedEffectResult . changeAsMerge (ConflictedEffectResult . conflictedEffect)--instance (PrimPatchBase p, Invert p, Effect p) => Effect (RebaseSelect p) where-   effect (RSFwd fixups toedit) =-        concatFL (mapFL_FL effect fixups) +>+ effect toedit-   effect (RSRev fixups toedit) = invertRL . reverseFL . effect $ RSFwd fixups toedit--instance (PrimPatchBase p, Invert p, Effect p) => Effect (RebaseChange p) where-    effect (RCFwd fixups changes) =-        concatFL (mapFL_FL effect fixups) +>+ effect changes-    effect (RCRev fixups changes) =-        invertRL . reverseFL . effect $ RCFwd fixups changes--instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseSelect p) where-   showPatch f (RSFwd fixups toedit) =-         showPatch f (Items (mapFL_FL Fixup fixups +>+ ToEdit toedit :>: NilFL))-   showPatch _ (RSRev {}) = impossible---- TODO this is a dummy instance that does not actually show context-instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowContextPatch (RebaseSelect p) where-   showContextPatch f p = return $ showPatch f p--instance (PrimPatchBase p, ShowPatchBasic p)-      => ShowPatchBasic (RebaseChange p) where-    showPatch ForStorage _ = impossible-    showPatch ForDisplay (RCFwd fixups contents) =-        vcat (mapFL (showPatch ForDisplay) contents) $$-        (if nullFL fixups-            then empty-            else-                redText "" $$-                redText "conflicts:" $$-                redText "" $$-                vcat (mapRL showFixup (invertFL fixups))-        )-        where-            showFixup (PrimFixup p) = showPatch ForDisplay p-            showFixup (NameFixup n) = showPatch ForDisplay n-    showPatch _ (RCRev {}) = impossible--instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p)-    => ShowPatch (RebaseSelect p) where--   description (RSFwd _ toedit) = description toedit-   description (RSRev _  _toedit) = impossible--   summary = summaryFL . fromRebaseSelect . (:>: NilFL)-   summaryFL = summaryFL . fromRebaseSelect--instance-    ( PrimPatchBase p, PatchListFormat p, ShowPatchBasic p-    , Invert p, Effect p, Merge p, FromPrim p-    , Conflict p, CommuteNoConflicts p-    )-   => ShowPatch (RebaseChange p) where--    summary = plainSummary-    summaryFL = plainSummary---- TODO this is a dummy instance that does not actually show context-instance-    ( PrimPatchBase p, ShowPatchBasic p)-   => ShowContextPatch (RebaseChange p) where--    showContextPatch f p = return $ showPatch f p--instance ReadPatch (RebaseSelect p) where-   readPatch' = error "can't read RebaseSelect patches"--instance ReadPatch (RebaseChange p) where-   readPatch' = error "can't read RebaseChange patches"---- |Turn a list of rebase items being rebased into a list suitable for use--- by interactive selection. Each actual patch being rebased is grouped--- together with any fixups needed.-toRebaseSelect :: PrimPatchBase p => FL (RebaseItem p) wX wY -> FL (RebaseSelect p) wX wY---- |Turn a list of items back from the format used for interactive selection--- into a normal list-fromRebaseSelect :: FL (RebaseSelect p) wX wY -> FL (RebaseItem p) wX wY--fromRebaseSelect NilFL = NilFL-fromRebaseSelect (RSFwd fixups toedit :>: ps)-    = mapFL_FL Fixup fixups +>+ ToEdit toedit :>: fromRebaseSelect ps-fromRebaseSelect (RSRev {} :>: _) = impossible--toRebaseSelect NilFL = NilFL-toRebaseSelect (Fixup f :>: ps) =-    case toRebaseSelect ps of-      RSFwd fixups toedit :>: rest -> RSFwd (f :>: fixups) toedit :>: rest-      NilFL -> bug "rebase chain with Fixup at end"-      _ -> impossible-toRebaseSelect (ToEdit te :>: ps) = RSFwd NilFL te :>: toRebaseSelect ps--toRebaseChanges-    :: PrimPatchBase p-    => FL (RebaseItem p) wX wY-    -> FL (PatchInfoAnd ('RepoType 'IsRebase) (RebaseChange p)) wX wY-toRebaseChanges = mapFL_FL toChange . toRebaseSelect--toChange :: RebaseSelect p wX wY -> PatchInfoAnd rt (RebaseChange p) wX wY-toChange (RSFwd fixups named) =-    n2pia $-    flip Wrapped.adddeps (getdeps named) $-    Wrapped.infopatch (patch2patchinfo named) $-    (:>: NilFL) $-    RCFwd fixups (patchcontents named)-toChange (RSRev fixups named) =-    n2pia $-    flip Wrapped.adddeps (getdeps named) $-    Wrapped.infopatch (patch2patchinfo named) $-    (:>: NilFL) $-    RCRev fixups (patchcontents named)--instance PrimPatch (PrimOf p) => PrimPatchBase (RebaseChange p) where-    type PrimOf (RebaseChange p) = PrimOf p---instance Invert (RebaseSelect p) where-   invert (RSFwd fixups edit) = RSRev fixups edit-   invert (RSRev fixups edit) = RSFwd fixups edit--instance Invert (RebaseChange p) where-   invert (RCFwd fixups contents) = RCRev fixups contents-   invert (RCRev fixups contents) = RCFwd fixups contents--instance (PrimPatchBase p, Commute p, Eq2 p) => Eq2 (RebaseSelect p) where-   RSFwd fixups1 edit1 =\/= RSFwd fixups2 edit2-      | IsEq <- fixups1 =\/= fixups2, IsEq <- edit1 =\/= edit2 = IsEq-   RSRev fixups1 edit1 =\/= RSRev fixups2 edit2-      | IsEq <- edit1 =/\= edit2, IsEq <- fixups1 =/\= fixups2 = IsEq--   _ =\/= _ = impossible--instance (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p) => Commute (RebaseSelect p) where-   commute (RSFwd {} :> RSRev {}) = impossible-   commute (RSRev {} :> RSFwd {}) = impossible-   commute (RSRev fixups1 edit1 :> RSRev fixups2 edit2) =-      do RSFwd fixups1' edit1' :> RSFwd fixups2' edit2'-                   <- commute (RSFwd fixups2 edit2 :> RSFwd fixups1 edit1)-         return (RSRev fixups2' edit2' :> RSRev fixups1' edit1')--   commute (RSFwd fixups1 edit1 :> RSFwd fixups2 edit2)-    = do-         fixups2' :> edit1' <- commuteNamedFixups (edit1 :> fixups2)-         edit2' :> edit1'' <- commute (edit1' :> edit2)-         fixupsS :> (fixups2'' :> edit2'') :> fixups1' <- return $ pushThrough (fixups1 :> (fixups2' :> edit2'))-         return (RSFwd (fixupsS +>+ fixups2'') edit2'' :> RSFwd fixups1' edit1'')--instance Commute (RebaseChange p) where-    commute _ = impossible--instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseSelect p) where-   listTouchedFiles (RSFwd fixup toedit) = nub (listTouchedFiles fixup ++ listTouchedFiles toedit)-   listTouchedFiles (RSRev fixup toedit) = nub (listTouchedFiles fixup ++ listTouchedFiles toedit)--   hunkMatches f (RSFwd fixup toedit) = hunkMatches f fixup || hunkMatches f toedit-   hunkMatches f (RSRev fixup toedit) = hunkMatches f fixup || hunkMatches f toedit--instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseChange p) where-   listTouchedFiles (RCFwd fixup contents) = nub (listTouchedFiles fixup ++ listTouchedFiles contents)-   listTouchedFiles (RCRev fixup contents) = nub (listTouchedFiles fixup ++ listTouchedFiles contents)--   hunkMatches f (RCFwd fixup contents) = hunkMatches f fixup || hunkMatches f contents-   hunkMatches f (RCRev fixup contents) = hunkMatches f fixup || hunkMatches f contents---- |Split a list of rebase patches into those that will--- have conflicts if unsuspended and those that won't.-partitionUnconflicted-    :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p)-    => FL (RebaseSelect p) wX wY-    -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wY-partitionUnconflicted = partitionUnconflictedAcc NilRL--partitionUnconflictedAcc :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p)-                         => RL (RebaseSelect p) wX wY -> FL (RebaseSelect p) wY wZ-                         -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wZ-partitionUnconflictedAcc right NilFL = NilFL :> right-partitionUnconflictedAcc right (p :>: ps) =-   case commuterRLId selfCommuter (right :> p) of-     Just (p'@(RSFwd NilFL _) :> right')-       -> case partitionUnconflictedAcc right' ps of-            left' :> right'' -> (p' :>: left') :> right''-     _ -> partitionUnconflictedAcc (right :<: p) ps---- | A patch, together with a list of patch names that it used to depend on,--- but were lost during the rebasing process. The UI can use this information--- to report them to the user.-data WithDroppedDeps p wX wY =-    WithDroppedDeps {-        wddPatch :: p wX wY,-        wddDependedOn :: [PatchInfo]-    }--noDroppedDeps :: p wX wY -> WithDroppedDeps p wX wY-noDroppedDeps p = WithDroppedDeps p []--instance PrimPatchBase p => PrimPatchBase (WithDroppedDeps p) where-   type PrimOf (WithDroppedDeps p) = PrimOf p--instance Effect p => Effect (WithDroppedDeps p) where-   effect = effect . wddPatch---- Note, this could probably be rewritten using a generalised commuteWhatWeCanFL from--- Darcs.Patch.Permutations.--- |@pushThrough (ps :> (qs :> te))@ tries to commute as much of @ps@ as possible through--- both @qs@ and @te@, giving @psStuck :> (qs' :> te') :> psCommuted@.--- Anything that can be commuted ends up in @psCommuted@ and anything that can't goes in--- @psStuck@.-pushThrough :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p)-            => (FL (RebaseFixup p) :> (FL (RebaseFixup p) :> Named p)) wX wY-            -> (FL (RebaseFixup p) :> (FL (RebaseFixup p) :> Named p) :> FL (RebaseFixup p)) wX wY-pushThrough (NilFL :> v) = NilFL :> v :> NilFL-pushThrough ((p :>: ps) :> v) =-  case pushThrough (ps :> v) of-   psS :> v'@(qs:>te) :> ps' ->-     fromMaybe ((p :>: psS) :> v' :> ps') $ do-       psS' :> p' <- commuterIdFL selfCommuter (p :> psS)-       qs' :> p'' <- commuterIdFL selfCommuter (p' :> qs)-       te' :> p''' <- commuteFixupNamed (p'' :> te)-       return (psS' :> (qs' :> te') :> (p''' +>+ ps'))--type WDDNamed p = WithDroppedDeps (Named p)--mergerIdWDD :: MergeFn p1 p2 -> MergeFn p1 (WithDroppedDeps p2)-mergerIdWDD merger (p1 :\/: WithDroppedDeps p2 deps) =-   case merger (p1 :\/: p2) of-     p2' :/\: p1' -> WithDroppedDeps p2' deps :/\: p1'---commuterIdWDD :: CommuteFn p q -> CommuteFn p (WithDroppedDeps q)-commuterIdWDD commuter (p :> WithDroppedDeps q deps)-  = do -- no need to worry about names, because by definition a dropped dep-       -- is a name we no longer have-       -- TODO consistency checking?-       -- TODO consider inverse commutes, e.g. what happens if we wanted to-       -- commute (WithDroppedDeps ... [n] :> AddName n)?-       q' :> p' <- commuter (p :> q)-       return (WithDroppedDeps q' deps :> p')---- |Forcibly commute a 'RebaseName' with a patch, dropping any dependencies--- if necessary and recording them in the patch-forceCommuteName :: (RebaseName p :> WDDNamed p) wX wY -> (WDDNamed p :> RebaseName p) wX wY-forceCommuteName (AddName an :> WithDroppedDeps (NamedP pn deps body) ddeps)-  | an == pn = impossible-  | otherwise = WithDroppedDeps (NamedP pn (deps \\ [an]) (unsafeCoerceP body)) (if an `elem` deps then an:ddeps else ddeps) :> AddName an-forceCommuteName (DelName dn :> p@(WithDroppedDeps (NamedP pn deps _body) _ddeps))-  | dn == pn = impossible-  | dn `elem` deps = impossible-  | otherwise = unsafeCoerceP p :> DelName dn-forceCommuteName (Rename old new :> WithDroppedDeps (NamedP pn deps body) ddeps)-  | old == pn = impossible-  | new == pn = impossible-  | old `elem` deps = impossible-  | otherwise =-      let newdeps = map (\dep -> if new == dep then old else dep) deps-      in WithDroppedDeps (NamedP pn newdeps (unsafeCoerceP body)) ddeps :> Rename old new--forceCommutePrim :: (Merge p, Invert p, Effect p, FromPrim p)-                 => (PrimOf p :> WDDNamed p) wX wY-                 -> (WDDNamed p :> FL (PrimOf p)) wX wY-forceCommutePrim (p :> q) =-    case mergerIdWDD (mergerIdNamed selfMerger) (invert (fromPrim p) :\/: q) of-        q' :/\: invp' -> q' :> effect (invert invp')---forceCommutesPrim :: (Merge p, Invert p, Effect p, FromPrim p)-                  => (PrimOf p :> FL (WDDNamed p)) wX wY-                  -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY-forceCommutesPrim (p :> NilFL) = NilFL :> (p :>: NilFL)-forceCommutesPrim (p :> (q :>: qs)) =-    case forceCommutePrim (p :> q) of-        q' :> p' -> case forceCommutessPrim ( p' :> qs) of-            qs' :> p'' -> (q' :>: qs') :> p''--forceCommutessPrim :: (Merge p, Invert p, Effect p, FromPrim p)-                   => (FL (PrimOf p) :> FL (WDDNamed p)) wX wY-                   -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY-forceCommutessPrim (NilFL :> qs) = qs :> NilFL-forceCommutessPrim ((p :>: ps) :> qs) =-    case forceCommutessPrim (ps :> qs) of-        qs' :> ps' ->-            case forceCommutesPrim (p :> qs') of-                qs'' :> p' -> qs'' :> (p' +>+ ps')--forceCommutess :: (Merge p, Invert p, Effect p, FromPrim p)-               => (FL (RebaseFixup p) :> FL (WDDNamed p)) wX wY-               -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY-forceCommutess (NilFL :> qs) = qs :> NilFL-forceCommutess ((NameFixup n :>: ps) :> qs) =-    case forceCommutess (ps :> qs) of-        qs' :> ps' ->-            case totalCommuterIdFL forceCommuteName (n :> qs') of-                qs'' :> n' -> qs'' :> (NameFixup n' :>: ps')-forceCommutess ((PrimFixup p :>: ps) :> qs) =-    case forceCommutess (ps :> qs) of-        qs' :> ps' ->-            case forceCommutesPrim (p :> qs') of-                qs'' :> p' -> qs'' :> (mapFL_FL PrimFixup p' +>+ ps')---- |Turn a selected rebase patch back into a patch we can apply to--- the main repository, together with residual fixups that need--- to go back into the rebase state (unless the rebase is now finished).--- Any fixups associated with the patch will turn into conflicts.-extractRebaseSelect :: (Merge p, Invert p, Effect p, FromPrim p, PrimPatchBase p)-                    => FL (RebaseSelect p) wX wY-                    -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY-extractRebaseSelect NilFL = NilFL :> NilFL-extractRebaseSelect (RSFwd fixups toedit :>: rest)-  = case extractRebaseSelect rest of-     toedits2 :> fixups2 ->-        case forceCommutess (fixups :> (WithDroppedDeps toedit [] :>: toedits2)) of-          toedits' :> fixups' ->-            toedits' :> (fixups' +>+ fixups2)--extractRebaseSelect (RSRev{} :>: _) = impossible---- signature to be compatible with extractRebaseSelect--- | Like 'extractRebaseSelect', but any fixups are "reified" into a separate patch.-reifyRebaseSelect :: forall p wX wY-                   . (PrimPatchBase p, FromPrim p)-                  => FL (RebaseSelect p) wX wY-                  -> IO ((FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY)-reifyRebaseSelect rs = do res <- concatFL <$> mapFL_FL_M reifyOne rs-                          return (res :> NilFL)-  where reifyOne :: RebaseSelect p wA wB -> IO (FL (WDDNamed p) wA wB)-        reifyOne (RSFwd fixups toedit) =-            case flToNamesPrims fixups of-                names :> NilFL ->-                    return (mapFL_FL (noDroppedDeps . mkDummy) names +>+ noDroppedDeps toedit :>: NilFL)-                names :> prims -> do-                    n <- mkReified prims-                    return (mapFL_FL (noDroppedDeps . mkDummy) names +>+ noDroppedDeps n :>: noDroppedDeps toedit :>: NilFL)-        reifyOne (RSRev{}) = impossible--mkReified :: FromPrim p => FL (PrimOf p) wX wY -> IO (Named p wX wY)-mkReified ps = do-     let name = "Reified fixup patch"-     let desc = []-     date <- getIsoDateTime-     let author = "Invalid <invalid@invalid>"-     namepatch date name author desc (mapFL_FL fromPrim ps)--mkDummy :: RebaseName p wX wY -> Named p wX wY-mkDummy (AddName pi) = infopatch pi (unsafeCoerceP NilFL)-mkDummy (DelName _) = error "internal error: can't make a dummy patch from a delete"-mkDummy (Rename _ _) = error "internal error: can't make a dummy patch from a rename"--instance CommuteNoConflicts (RebaseChange p) where-    commuteNoConflicts _ = impossible--instance IsHunk (RebaseChange p) where-    -- RebaseChange is a compound patch, so it doesn't really make sense to-    -- ask whether it's a hunk. TODO: get rid of the need for this.-    isHunk _ = Nothing--instance PatchListFormat (RebaseChange p)--instance ( PrimPatchBase p, Apply p, Invert p-         , PatchInspect p-         , ApplyState p ~ ApplyState (PrimOf p)-         )-        => Matchable (RebaseChange p)
src/Darcs/Patch/RegChars.hs view
@@ -19,7 +19,6 @@ module Darcs.Patch.RegChars ( regChars,                 ) where -import Prelude () import Darcs.Prelude  (&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
src/Darcs/Patch/Repair.hs view
@@ -2,7 +2,6 @@     ( Repair(..), RepairToFL(..), mapMaybeSnd, Check(..) )     where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Apply ( Apply(..) )@@ -28,7 +27,8 @@ -- 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)
src/Darcs/Patch/RepoPatch.hs view
@@ -1,27 +1,66 @@-module Darcs.Patch.RepoPatch ( RepoPatch )-    where+module Darcs.Patch.RepoPatch+    ( RepoPatch+    , AnnotateRP+    , Apply(..)+    , Check(..)+    , Commute(..)+    , Conflict(..)+    , Effect(..)+    , Eq2(..)+    , FromPrim(..)+    , IsHunk(..)+    , Merge(..)+    , PatchInspect(..)+    , PatchListFormat(..)+    , PrimPatchBase(..)+    , ReadPatch(..)+    , RepairToFL(..)+    , ShowContextPatch(..)+    , ShowPatch(..)+    , ShowPatchBasic(..)+    , Summary(..)+    , ToPrim(..)+    , Unwind(..)+    ) where -import Darcs.Patch.Annotate ( Annotate )-import Darcs.Patch.Apply ( Apply, ApplyState )-import Darcs.Patch.Commute ( Commute )-import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )-import Darcs.Patch.Effect ( Effect )-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Patch.Invert ( Invert )-import Darcs.Patch.Matchable ( Matchable )-import Darcs.Patch.Merge ( Merge )-import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim )-import Darcs.Patch.Read ( ReadPatch )-import Darcs.Patch.Repair ( RepairToFL, Check )-import Darcs.Patch.Show ( ShowPatch, ShowContextPatch )+import Darcs.Patch.Annotate ( AnnotateRP )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Conflict ( Conflict(..) )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase(..), PrimOf(..), FromPrim(..), ToPrim(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Repair ( RepairToFL(..), Check(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), ShowContextPatch(..) )+import Darcs.Patch.Summary ( Summary(..) )+import Darcs.Patch.Unwind ( Unwind(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) -class (Apply p, Commute p, Invert p, Merge p, Effect p, IsHunk p,-       PatchInspect p, ReadPatch p, ShowPatch p, ShowContextPatch p,-       FromPrim p, Conflict p, CommuteNoConflicts p,-       Check p, RepairToFL p, PatchListFormat p,-       PrimPatchBase p, IsHunk (PrimOf p),-       Matchable p, Annotate p, ApplyState p ~ ApplyState (PrimOf p)-      )-    => RepoPatch p+type RepoPatch p =+    ( AnnotateRP p+    , Apply p+    , ApplyState p ~ ApplyState (PrimOf p)+    , Check p+    , Commute p+    , Conflict p+    , Effect p+    , Eq2 p+    , FromPrim p+    , IsHunk p+    , IsHunk (PrimOf p)+    , Merge p+    , PatchInspect p+    , PatchListFormat p+    , PrimPatchBase p+    , ReadPatch p+    , RepairToFL p+    , ShowContextPatch p+    , ShowPatch p+    , Summary p+    , ToPrim p+    , Unwind p+    )
src/Darcs/Patch/Set.hs view
@@ -15,32 +15,33 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE EmptyDataDecls, StandaloneDeriving #-}- module Darcs.Patch.Set     ( PatchSet(..)     , Tagged(..)     , SealedPatchSet     , Origin     , progressPatchSet-    , tags+    , patchSetTags     , emptyPatchSet     , appendPSFL     , patchSet2RL     , patchSet2FL-    , patchSetfMap+    , inOrderTags+    , patchSetSnoc+    , patchSetSplit+    , patchSetDrop     ) where -import Prelude () import Darcs.Prelude+import Data.Maybe ( catMaybes ) -import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Info ( PatchInfo, piTag ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )-import Darcs.Patch.Witnesses.Sealed ( Sealed )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Ordered-    ( FL, RL(..), (+<+), reverseFL, reverseRL,+    ( FL, RL(..), (+<+), (+<<+), (:>)(..), reverseRL,     mapRL_RL, concatRL, mapRL )-import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )  import Darcs.Util.Progress ( progress ) @@ -56,20 +57,26 @@ -- -- A 'PatchSet' represents a repo's history as the list of patches since the -- last clean tag, and then a list of patch lists each delimited by clean tags.+--+-- Because the invariants about clean tags can only be maintained if a+-- 'PatchSet' contains the whole history, the first witness is always forced+-- to be 'Origin'. The type still has two witnesses so it can easily be used+-- with combinators like ':>' and 'Fork'.+--+-- The history is lazily loaded from disk so does not normally need to be all+-- kept in memory. data PatchSet rt p wStart wY where-    PatchSet :: RL (Tagged rt p) wStart wX -> RL (PatchInfoAnd rt p) wX wY-             -> PatchSet rt p wStart wY+    PatchSet :: RL (Tagged rt p) Origin wX -> RL (PatchInfoAnd rt p) wX wY+             -> PatchSet rt p Origin wY  deriving instance Show2 p => Show (PatchSet rt p wStart wY) -instance Show2 p => Show1 (PatchSet rt p wStart) where-    showDict1 = ShowDictClass+instance Show2 p => Show1 (PatchSet rt p wStart) -instance Show2 p => Show2 (PatchSet rt p) where-    showDict2 = ShowDictClass+instance Show2 p => Show2 (PatchSet rt p)  -emptyPatchSet :: PatchSet rt p wX wX+emptyPatchSet :: PatchSet rt p Origin Origin emptyPatchSet = PatchSet NilRL NilRL  -- |A 'Tagged' is a single chunk of a 'PatchSet'.@@ -82,11 +89,9 @@  deriving instance Show2 p => Show (Tagged rt p wX wZ) -instance Show2 p => Show1 (Tagged rt p wX) where-    showDict1 = ShowDictClass+instance Show2 p => Show1 (Tagged rt p wX) -instance Show2 p => Show2 (Tagged rt p) where-    showDict2 = ShowDictClass+instance Show2 p => Show2 (Tagged rt p)   -- |'patchSet2RL' takes a 'PatchSet' and returns an equivalent, linear 'RL' of@@ -106,7 +111,7 @@ -- 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 ts ps) newps = PatchSet ts (ps +<+ reverseFL newps)+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.@@ -119,13 +124,34 @@     progressTagged :: Tagged rt p wY wZ -> Tagged rt p wY wZ     progressTagged (Tagged t h tps) = Tagged (prog t) h (mapRL_RL prog tps) --- |'tags' returns the PatchInfos corresponding to the tags of a given--- 'PatchSet'.-tags :: PatchSet rt p wStart wX -> [PatchInfo]-tags (PatchSet ts _) = mapRL taggedTagInfo ts-  where-    taggedTagInfo :: Tagged rt p wY wZ -> PatchInfo-    taggedTagInfo (Tagged t _ _) = info t+-- | The tag names of /all/ tags of a given 'PatchSet'.+patchSetTags :: PatchSet rt p wX wY -> [String]+patchSetTags = catMaybes . mapRL (piTag . info) . patchSet2RL -patchSetfMap:: (forall wW wZ . PatchInfoAnd rt p wW wZ -> IO a) -> PatchSet rt p wW' wZ' -> IO [a]-patchSetfMap f = sequence . mapRL f . patchSet2RL+inOrderTags :: PatchSet rt 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'+        go NilRL = []++patchSetSnoc :: PatchSet rt p wX wY -> PatchInfoAnd rt p wY wZ -> PatchSet rt 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) =+  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+patchSetDrop n ps | n <= 0 = Sealed ps+patchSetDrop n (PatchSet (ts :<: Tagged t _ ps) 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
@@ -24,7 +24,6 @@      , formatFileName      ) where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString.Char8 as BC ( unpack )@@ -36,7 +35,7 @@  import Darcs.Util.ByteString ( packStringToUTF8, encodeLocale ) import Darcs.Util.English ( plural, Noun(Noun) )-import Darcs.Util.Path ( FileName, encodeWhite, fn2fp )+import Darcs.Util.Path ( AnchoredPath, encodeWhite, anchorPath ) import Darcs.Util.Printer ( Doc, vcat, text, packedString )  data ShowPatchFor = ForDisplay | ForStorage@@ -56,13 +55,18 @@     showContextPatch :: (ApplyMonad (ApplyState p) m)                      => ShowPatchFor -> p wX wY -> m Doc --- This class is used only for user interaction, not for storage+-- | This class is used only for user interaction, not for storage. The default+-- implementations for 'description' and 'content' are suitable only for+-- 'PrimPatch' and 'RepoPatch' types. Logically, 'description' should default+-- to 'mempty' while 'content' should default to 'displayPatch'. We define them+-- the other way around so that 'Darcs.UI.PrintPatch.showFriendly' gives+-- reasonable results for all patch types. class ShowPatchBasic p => ShowPatch p where-    showNicely :: p wX wY -> Doc-    showNicely = showPatch ForDisplay+    content :: p wX wY -> Doc+    content = mempty      description :: p wX wY -> Doc-    description = showPatch ForDisplay+    description = displayPatch      summary :: p wX wY -> Doc @@ -75,19 +79,22 @@     things :: p wX wY -> String     things x = plural (Noun $ thing x) "" --- | Format a 'FileName' to a 'Doc' according to the given 'FileNameFormat'.+-- | 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 'NewFormat' we just pack it into a 'Doc'. For--- 'OldFormat' we must emulate the non-standard darcs-1 encoding of file paths: it+-- 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 -> FileName -> Doc-formatFileName OldFormat = packedString . packStringToUTF8 . BC.unpack .-                            encodeLocale . encodeWhite . fn2fp-formatFileName NewFormat = text . encodeWhite . fn2fp-formatFileName UserFormat = text . fn2fp+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
@@ -30,7 +30,6 @@     , reversePrimSplitter     ) where -import Prelude () import Darcs.Prelude  import Data.List ( intersperse )@@ -43,7 +42,7 @@ import Darcs.Patch.Show ( showPatch, ShowPatch(..) ) import Darcs.Patch.Invert( Invert(..), invertFL ) import Darcs.Patch.Prim ( PrimPatch, canonize, canonizeFL, primFromHunk )-import Darcs.Patch.ReadMonads ( parseStrictly )+import Darcs.Util.Parser ( parse ) import Darcs.Patch.Read () import Darcs.Patch.Show ( ShowPatchFor(ForDisplay) ) import Darcs.Patch.Viewing ()@@ -105,9 +104,9 @@ rawSplitter = Splitter     { applySplitter = \p ->         Just (renderPS . showPatch ForDisplay $ p-             ,\str -> case parseStrictly readPatch' str of-                        Just (Sealed res, _) -> Just (withEditedHead p res)-                        _                    -> Nothing)+             ,\str -> case parse readPatch' str of+                        Right (Sealed res, _) -> Just (withEditedHead p res)+                        Left _                -> Nothing)     , canonizeSplit = id     }
src/Darcs/Patch/Summary.hs view
@@ -1,25 +1,67 @@ module Darcs.Patch.Summary-    ( plainSummary, plainSummaryPrim, plainSummaryPrims,-      xmlSummary )-    where+    ( plainSummary+    , plainSummaryFL+    , plainSummaryPrim+    , plainSummaryPrims+    , xmlSummary+    , Summary(..)+    , ConflictState(..)+    , IsConflictedPrim(..)+    , listConflictedFiles+    ) where -import Prelude () import Darcs.Prelude -import Darcs.Util.Path ( fn2fp )-import Darcs.Patch.Conflict ( Conflict(..), IsConflictedPrim(IsC), ConflictState(..) )-import Darcs.Patch.Format ( FileNameFormat(UserFormat) )-import Darcs.Patch.Prim.Class ( PrimDetails(..), PrimPatchBase )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( catMaybes )++import Darcs.Patch.Format ( FileNameFormat(FileNameFormatDisplay) )+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Prim ( PrimDetails(..) ) import Darcs.Patch.Show ( formatFileName ) import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )+import Darcs.Patch.Witnesses.Show -import Darcs.Util.Printer ( Doc, empty, vcat,-                 text,-                 minus, plus, ($$), (<+>)-               )+import Darcs.Util.Path ( AnchoredPath, anchorPath )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , (<+>)+    , empty+    , minus+    , plus+    , text+    , vcat+    ) +-- | This type tags a patch with a 'ConflictState' and also hides the context+-- witnesses (as in 'Sealed2'), so we can put them in a list.+data IsConflictedPrim prim where+    IsC :: !ConflictState -> !(prim wX wY) -> IsConflictedPrim prim+data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read) +class Summary p where+    conflictedEffect :: p wX wY -> [IsConflictedPrim (PrimOf p)]++instance Summary p => Summary (FL p) where+    conflictedEffect = concat . mapFL conflictedEffect++instance Show2 prim => Show (IsConflictedPrim prim) where+    showsPrec d (IsC cs prim) =+        showParen (d > appPrec) $+            showString "IsC " . showsPrec (appPrec + 1) cs .+            showString " " . showsPrec2 (appPrec + 1) prim++listConflictedFiles+  :: (Summary p, PatchInspect (PrimOf p)) => p wX wY -> [AnchoredPath]+listConflictedFiles =+    nubSort . concat . catMaybes . map conflictedFiles . conflictedEffect+  where+    conflictedFiles (IsC Conflicted p) = Just (listTouchedFiles p)+    conflictedFiles _ = Nothing+ plainSummaryPrim :: PrimDetails prim => prim wX wY -> Doc plainSummaryPrim = vcat . map (summChunkToLine False) . genSummary . (:[]) . IsC Okay @@ -27,10 +69,13 @@ plainSummaryPrims machineReadable =  vcat . map (summChunkToLine machineReadable) . genSummary . mapFL (IsC Okay) -plainSummary :: (Conflict e, PrimPatchBase e) => e wX wY -> Doc+plainSummary :: (Summary e, PrimDetails (PrimOf e)) => e wX wY -> Doc plainSummary = vcat . map (summChunkToLine False) . genSummary . conflictedEffect -xmlSummary :: (Conflict p, PrimPatchBase p) => p wX wY -> Doc+plainSummaryFL :: (Summary e, PrimDetails (PrimOf e)) => FL e wX wY -> Doc+plainSummaryFL = vcat . map (summChunkToLine False) . genSummary . concat . mapFL conflictedEffect++xmlSummary :: (Summary p, PrimDetails (PrimOf p)) => p wX wY -> Doc xmlSummary p = text "<summary>"              $$ (vcat . map summChunkToXML . genSummary . conflictedEffect $ p)              $$ text "</summary>"@@ -98,7 +143,7 @@    xconf Okay t x       = text ('<':t++">") $$ x $$ text ("</"++t++">")    xconf Conflicted t x = text ('<':t++" conflict='true'>") $$ x $$ text ("</"++t++">")    xconf Duplicated t x = text ('<':t++" duplicate='true'>") $$ x $$ text ("</"++t++">")-   xfn = escapeXML . dropDotSlash . fn2fp+   xfn = escapeXML . anchorPath ""    --    xad 0 = empty    xad a = text "<added_lines num='" <> text (show a) <> text "'/>"@@ -110,18 +155,18 @@ summChunkToLine :: Bool -> SummChunk -> Doc summChunkToLine machineReadable (SummChunk detail c) =   case detail of-   SummRmDir f   -> lconf c "R" $ formatFileName UserFormat f <> text "/"-   SummAddDir f  -> lconf c "A" $ formatFileName UserFormat f <> text "/"-   SummFile SummRm  f _ _ _ -> lconf c "R" $ formatFileName UserFormat f-   SummFile SummAdd f _ _ _ -> lconf c "A" $ formatFileName UserFormat f+   SummRmDir f   -> lconf c "R" $ formatFileName FileNameFormatDisplay f <> text "/"+   SummAddDir f  -> lconf c "A" $ formatFileName FileNameFormatDisplay f <> text "/"+   SummFile SummRm  f _ _ _ -> lconf c "R" $ formatFileName FileNameFormatDisplay f+   SummFile SummAdd f _ _ _ -> lconf c "A" $ formatFileName FileNameFormatDisplay f    SummFile SummMod f r a x-     | machineReadable -> lconf c "M" $ formatFileName UserFormat f-     | otherwise       -> lconf c "M" $ formatFileName UserFormat f <+> rm r <+> ad a <+> rp x+     | machineReadable -> lconf c "M" $ formatFileName FileNameFormatDisplay f+     | otherwise       -> lconf c "M" $ formatFileName FileNameFormatDisplay f <+> rm r <+> ad a <+> rp x    SummMv f1 f2-     | machineReadable -> text "F " <> formatFileName UserFormat f1-                       $$ text "T " <> formatFileName UserFormat f2-     | otherwise       -> text " "    <> formatFileName UserFormat f1-                       <> text " -> " <> formatFileName UserFormat f2+     | machineReadable -> text "F " <> formatFileName FileNameFormatDisplay f1+                       $$ text "T " <> formatFileName FileNameFormatDisplay f2+     | otherwise       -> text " "    <> formatFileName FileNameFormatDisplay f1+                       <> text " -> " <> formatFileName FileNameFormatDisplay f2    SummNone -> case c of                Okay -> empty                _    -> lconf c ""  empty@@ -138,8 +183,3 @@    rm a = minus <> text (show a)    rp 0 = empty    rp a = text "r" <> text (show a)--dropDotSlash :: FilePath -> FilePath-dropDotSlash ('.':'/':str) = dropDotSlash str-dropDotSlash str = str-
src/Darcs/Patch/SummaryData.hs view
@@ -1,14 +1,13 @@ module Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) where -import Prelude () import Darcs.Prelude -import Darcs.Util.Path ( FileName )+import Darcs.Util.Path ( AnchoredPath ) -data SummDetail = SummAddDir FileName-                | SummRmDir  FileName-                | SummFile SummOp FileName Int Int Int-                | SummMv   FileName FileName+data SummDetail = SummAddDir AnchoredPath+                | SummRmDir  AnchoredPath+                | SummFile SummOp AnchoredPath Int Int Int+                | SummMv   AnchoredPath AnchoredPath                 | SummNone   deriving (Ord, Eq)
src/Darcs/Patch/TokenReplace.hs view
@@ -6,7 +6,6 @@     , defaultToks     ) where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString as B@@ -38,9 +37,9 @@ tryTokReplace :: String -> B.ByteString -> B.ByteString               -> B.ByteString -> Maybe B.ByteString tryTokReplace tokChars old new-  | B.null old = bug "tryTokInternal called with empty old token"-  | BC.any (not . isTokChar) old = bug "tryTokInternal called with old non-token"-  | BC.any (not . isTokChar) new = bug "tryTokInternal called with new non-token"+  | 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"   | otherwise = fmap B.concat . loop 0     where       isTokChar = regChars tokChars@@ -61,9 +60,9 @@ forceTokReplace :: String -> B.ByteString -> B.ByteString                 -> B.ByteString -> B.ByteString forceTokReplace tokChars old new-  | B.null old = bug "tryTokInternal called with empty old token"-  | BC.any (not . isTokChar) old = bug "tryTokInternal called with old non-token"-  | BC.any (not . isTokChar) new = bug "tryTokInternal called with new non-token"+  | 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"   | otherwise = B.concat . loop 0     where       isTokChar = regChars tokChars
src/Darcs/Patch/TouchesFiles.hs view
@@ -18,33 +18,31 @@ module Darcs.Patch.TouchesFiles     ( lookTouch     , chooseTouching-    , choosePreTouching-    , selectTouching     , deselectNotTouching     , selectNotTouching     ) where  import Darcs.Prelude-import Prelude () -import Data.List (isSuffixOf, nub)+import Data.List ( nub )  import Darcs.Patch.Apply-       (Apply, ApplyState, applyToFilePaths, effectOnFilePaths)+       (Apply, ApplyState, applyToPaths) import Darcs.Patch.Choices        (PatchChoices, Label, LabelledPatch, patchChoices, label,         getChoices, forceFirsts, forceLasts, unLabel) import Darcs.Patch.Commute (Commute) import Darcs.Patch.Inspect (PatchInspect)-import Darcs.Patch.Invert (invert, Invert) import Darcs.Patch.Witnesses.Ordered        (FL(..), (:>)(..), mapFL_FL, (+>+)) import Darcs.Patch.Witnesses.Sealed (Sealed, seal)++import Darcs.Util.Path (AnchoredPath, isPrefix) import Darcs.Util.Tree (Tree)  labelTouching   :: (Apply p, PatchInspect p, ApplyState p ~ Tree)-  => Bool -> [FilePath] -> FL (LabelledPatch p) wX wY -> [Label]+  => Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label] labelTouching _ _ NilFL = [] labelTouching wantTouching fs (lp :>: lps) =   case lookTouchOnlyEffect fs (unLabel lp) of@@ -57,80 +55,61 @@  labelNotTouchingFM   :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)-  => [FilePath] -> PatchChoices p wX wY -> [Label]-labelNotTouchingFM files pc =+  => [AnchoredPath] -> PatchChoices p wX wY -> [Label]+labelNotTouchingFM paths pc =   case getChoices pc of-    fc :> mc :> _ -> labelTouching False (map fix files) (fc +>+ mc)+    fc :> mc :> _ -> labelTouching False paths (fc +>+ mc)  selectTouching   :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)-  => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY+  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectTouching Nothing pc = pc-selectTouching (Just files) pc = forceFirsts xs pc+selectTouching (Just paths) pc = forceFirsts xs pc   where     xs =       case getChoices pc of-        _ :> mc :> lc -> labelTouching True (map fix files) (mc +>+ lc)+        _ :> mc :> lc -> labelTouching True paths (mc +>+ lc)  deselectNotTouching   :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)-  => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY+  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY deselectNotTouching Nothing pc = pc-deselectNotTouching (Just files) pc =-  forceLasts (labelNotTouchingFM files pc) pc+deselectNotTouching (Just paths) pc =+  forceLasts (labelNotTouchingFM paths pc) pc  selectNotTouching   :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)-  => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY+  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectNotTouching Nothing pc = pc-selectNotTouching (Just files) pc = forceFirsts (labelNotTouchingFM files pc) pc--fix :: FilePath -> FilePath-fix f-  | "/" `isSuffixOf` f = fix $ init f-fix "" = "."-fix "." = "."-fix f = "./" ++ f+selectNotTouching (Just paths) pc = forceFirsts (labelNotTouchingFM paths pc) pc  chooseTouching   :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)-  => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX)+  => Maybe [AnchoredPath] -> FL p wX wY -> Sealed (FL p wX) chooseTouching Nothing p = seal p-chooseTouching files p =-  case getChoices $ selectTouching files $ patchChoices p of+chooseTouching paths p =+  case getChoices $ selectTouching paths $ patchChoices p of     fc :> _ :> _ -> seal $ mapFL_FL unLabel fc -choosePreTouching-  :: (Apply p, Commute p, Invert p, PatchInspect p, ApplyState p ~ Tree)-  => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX)-choosePreTouching files patch = chooseTouching filesBeforePatch patch-  where-    filesBeforePatch = effectOnFilePaths (invert patch) <$> files- lookTouchOnlyEffect   :: (Apply p, ApplyState p ~ Tree)-  => [FilePath] -> p wX wY -> (Bool, [FilePath])+  => [AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath]) lookTouchOnlyEffect fs p = (wasTouched, fs')   where     (wasTouched, _, fs', _) = lookTouch Nothing fs p  lookTouch   :: (Apply p, ApplyState p ~ Tree)-  => Maybe [(FilePath, FilePath)]-  -> [FilePath]+  => Maybe [(AnchoredPath, AnchoredPath)]+  -> [AnchoredPath]   -> p wX wY-  -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)])+  -> (Bool, [AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)]) lookTouch renames fs p = (anyTouched, touchedFs, fs', renames')   where     touchedFs = nub . concatMap fsAffectedBy $ affected     fsAffectedBy af = filter (affectedBy af) fs     anyTouched = length touchedFs > 0-    affectedBy :: FilePath -> FilePath -> Bool+    affectedBy :: AnchoredPath -> AnchoredPath -> Bool     touched `affectedBy` f =-      touched == f || touched `isSubPathOf` f || f `isSubPathOf` touched-    isSubPathOf :: FilePath -> FilePath -> Bool-    path `isSubPathOf` parent =-      case splitAt (length parent) path of-        (path', '/':_) -> path' == parent-        _ -> False-    (affected, fs', renames') = applyToFilePaths p renames fs+      touched `isPrefix` f || f `isPrefix` touched+    (affected, fs', renames') = applyToPaths p renames fs
− src/Darcs/Patch/Type.hs 
@@ -1,9 +0,0 @@-module Darcs.Patch.Type ( PatchType(..), patchType ) where--import Darcs.Patch.RepoType ( RepoType )---- |Used for indicating a patch type without having a concrete patch-data PatchType (rt :: RepoType) (p :: * -> * -> *) = PatchType--patchType :: p wX wY -> PatchType rt p-patchType _ = PatchType
+ src/Darcs/Patch/Unwind.hs view
@@ -0,0 +1,241 @@+-- BSD3+module Darcs.Patch.Unwind+  ( Unwind(..)+  , Unwound(..)+  , mkUnwound+  , squashUnwound+  ) where++import Darcs.Prelude++import Darcs.Patch.Commute+  ( Commute, commute, selfCommuter+  )+import Darcs.Patch.CommuteFn+  ( commuterIdFL, commuterFLId+  )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Invert+  ( Invert(..), invertFL, invertRL+  )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Viewing ()+import Darcs.Patch.Witnesses.Eq ( EqCheck(..), Eq2(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered+  ( FL(..), (:>)(..), (+>+), reverseFL+  , RL(..), (+<+), reverseRL+  )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, show2 )++import Darcs.Util.Printer ( blueText, vcat )++-- | An 'Unwound' represents a primitive patch, together with any+-- other primitives that are required to place the primitive in a+-- different context. Typically, the presence of context patches+-- indicates that the underlying primitive would be in conflict in+-- the given context.+--+-- We have the following invariants:+--  - if a context contains a patch, that context does not also+--    contain the inverse of that patch (when commuted next to each other)+--  - if either context contains a patch that commutes with the underlying+--    patch, then neither context contains the inverse of that patch+--    (when commuted next to each other)+-- Another way of putting it is that all possible pairs of patch+inverse+-- that can be reached by commutation are removed.+data Unwound prim wX wY where+  Unwound+    :: FL prim wA wB        -- ^context before+    -> FL prim wB wC        -- ^underlying primitives+    -> RL prim wC wD        -- ^context after+    -> Unwound prim wA wD++deriving instance Show2 prim => Show (Unwound prim wX wY)+instance Show2 prim => Show1 (Unwound prim wX)+instance Show2 prim => Show2 (Unwound prim)++instance (PatchListFormat prim, ShowPatchBasic prim)+  => ShowPatchBasic (Unwound prim) where+  showPatch f (Unwound before prims after) =+    vcat [+      blueText "before:",+      showPatch f before,+      blueText "prims:",+      showPatch f prims,+      blueText "after:",+      showPatch f after+    ]++instance Invert prim => Invert (Unwound prim) where+  invert (Unwound before prim after)+    = Unwound (invertRL after) (invert prim) (invertFL before)++class Unwind p where+  -- | Get hold of the underlying primitives for a given patch, placed in+  -- the context of the patch. If there are conflicts then context patches+  -- will be needed.+  fullUnwind :: p wX wY -> Unwound (PrimOf p) wX wY++mkUnwound+  :: (Commute prim, Invert prim, Eq2 prim)+  => FL prim wA wB+  -> FL prim wB wC+  -> FL prim wC wD+  -> Unwound prim wA wD+mkUnwound before ps after =+  consBefores before .+  flip consAfters after $+  Unwound NilFL ps NilRL++consBefores+  :: (Commute prim, Invert prim, Eq2 prim)+  => FL prim wA wB+  -> Unwound prim wB wC+  -> Unwound prim wA wC+consBefores NilFL u = u+consBefores (b :>: bs) u = consBefore b (consBefores bs u)++consAfters+  :: (Commute prim, Invert prim, Eq2 prim)+  => Unwound prim wA wB+  -> FL prim wB wC+  -> Unwound prim wA wC+consAfters u NilFL = u+consAfters u (a :>: as) = consAfters (consAfter u a) as++consBefore+  :: (Commute prim, Invert prim, Eq2 prim)+  => prim wA wB+  -> Unwound prim wB wC+  -> Unwound prim wA wC+consBefore b (Unwound NilFL ps after) =+  case commuterIdFL selfCommuter (b :> ps) of+    Nothing -> Unwound (b :>: NilFL) ps after+    -- It is possible for a context patch to commute with the+    -- underlying primitive. If that happens we want to see if we can eliminate it+    -- by propagating it through the other context ("after" in this case).+    -- "full unwind example 3" fails if this case is omitted, as (typically) do the standard+    -- 100 iteration QuickCheck tests+    Just (ps' :> b') -> Unwound NilFL ps' (propagateAfter (NilRL :> b' :> reverseRL after))+consBefore b1 (Unwound (b2 :>: bs) ps after)+  | IsEq <- invert b1 =\/= b2 = Unwound bs ps after+  | Just (b2' :> b1') <- commute (b1 :> b2)+     = case consBefore b1' (Unwound bs ps after) of+         Unwound bs' ps' after' -> Unwound (b2' :>: bs') ps' after'+consBefore b (Unwound bs ps after) = Unwound (b :>: bs) ps after++consAfter+  :: (Commute prim, Invert prim, Eq2 prim)+  => Unwound prim wA wB+  -> prim wB wC+  -> Unwound prim wA wC+consAfter (Unwound before ps NilRL) a =+  case commuterFLId selfCommuter (ps :> a) of+    Nothing -> Unwound before ps (NilRL :<: a)+    -- as with consBefore, we need to see if we can eliminate a context patch+    -- that commutes with the underlying primitive, by propagating it through the+    -- "before" context+    -- "full unwind example 3" fails if this case is omitted, as (typically) do the standard+    -- 100 iteration QuickCheck tests+    Just (a' :> ps') -> Unwound (propagateBefore (reverseFL before :> a' :> NilFL)) ps' NilRL+consAfter (Unwound before ps (as :<: a1)) a2+  | IsEq <- invert a1 =\/= a2 = Unwound before ps as+  | Just (a2' :> a1') <- commute (a1 :> a2)+      = case consAfter (Unwound before ps as) a2' of+          Unwound before' ps' as' -> Unwound before' ps' (as' :<: a1')+consAfter (Unwound before ps as) a = Unwound before ps (as :<: a)++propagateBefore+  :: (Commute prim, Invert prim, Eq2 prim)+  => (RL prim :> prim :> FL prim) wA wB+  -> FL prim wA wB+propagateBefore (NilRL :> p :> acc) = p :>: acc+propagateBefore (qs :<: q :> p :> acc)+  | IsEq <- invert q =\/= p = reverseRL qs +>+ acc+  | Just (p' :> q') <- commute (q :> p)+      = propagateBefore (qs :> p' :> q' :>: acc)+  | otherwise = reverseRL qs +>+ q :>: p :>: acc++propagateAfter+  :: (Commute prim, Invert prim, Eq2 prim)+  => (RL prim :> prim :> FL prim) wA wB+  -> RL prim wA wB+propagateAfter (acc :> p :> NilFL) = acc :<: p+propagateAfter (acc :> p :> q :>: qs)+  | IsEq <- invert p =\/= q = acc +<+ reverseFL qs+  | Just (q' :> p') <- commute (p :> q)+      = propagateAfter (acc :<: q' :> p' :> qs)+  | otherwise = acc :<: p :<: q +<+ reverseFL qs+++-- | Given a list of unwound patches, use commutation and cancellation of+-- inverses to remove intermediate contexts. This is not guaranteed to be+-- possible in general, but should be possible if the patches that were+-- unwound were all originally recorded (unconflicted) in the same context,+-- e.g. as part of the same 'Darcs.Patch.Named.Named'.+squashUnwound+  :: (Show2 prim, Commute prim, Eq2 prim, Invert prim)+  => FL (Unwound prim) wX wY+  -> Unwound prim wX wY+squashUnwound NilFL = Unwound NilFL NilFL NilRL+squashUnwound (u :>: us) =+  -- As described in consBefore/consAfter, it's possible for some of the elements+  -- in a context to commute with the underlying prim that context is attached to,+  -- so consBefore/consAfter try to cancel them by propagating through the other+  -- context.+  -- Sometimes they also won't cancel or commute with patches in the other context+  -- so when squashing we need to move them out of the way of the patches that really+  -- need to be squashed first.+  -- The unit test "full unwind example 3" fails if we remove the moveCommuting calls,+  -- as do QuickCheck tests with a lot of iterations (e.g. 100K)+  squashPair (moveCommutingToBefore u :> moveCommutingToAfter (squashUnwound us))++moveCommutingToBefore+  :: (Commute prim, Invert prim, Eq2 prim)+  => Unwound prim wA wB+  -> Unwound prim wA wB+moveCommutingToBefore (Unwound before ps after) =+  flip consAfters (reverseRL after) $+  Unwound before ps NilRL++moveCommutingToAfter+  :: (Commute prim, Invert prim, Eq2 prim)+  => Unwound prim wA wB+  -> Unwound prim wA wB+moveCommutingToAfter (Unwound before ps after) =+  consBefores before $+  Unwound NilFL ps after++squashPair+  :: (Show2 prim, Commute prim, Eq2 prim, Invert prim)+  => (Unwound prim :> Unwound prim) wX wY+  -> Unwound prim wX wY+squashPair (Unwound before ps1 NilRL :> Unwound NilFL ps2 after) =+  Unwound before (ps1 +>+ ps2) after+squashPair (Unwound before1 ps1 (after1 :<: a) :> Unwound before2 ps2 after2) =+  case pushPastForward (a :> before2) of+    before2' :> Nothing2 ->+      squashPair (Unwound before1 ps1 after1 :> Unwound before2' ps2 after2)+    before2' :> Just2 a' ->+      case commuterIdFL selfCommuter (a' :> ps2) of+        Nothing -> error $ "stuck patch: squashPair 1:\n" ++ show2 a' ++ "\n" ++ show2 ps2+        Just (ps2' :> a'') ->+          squashPair (Unwound before1 ps1 after1 :> Unwound before2' ps2' (NilRL :<: a'' +<+ after2))+squashPair (Unwound before1 ps1 NilRL :> Unwound (b :>: before2) ps2 after2) =+  case commuterFLId selfCommuter (ps1 :> b) of+    Nothing -> error "stuck patch: squashPair 2"+    Just (b' :> ps1') -> squashPair (Unwound (before1 +>+ b' :>: NilFL) ps1' NilRL :> Unwound before2 ps2 after2)++pushPastForward+  :: (Show2 prim, Commute prim, Eq2 prim, Invert prim)+  => (prim :> FL prim) wX wY+  -> (FL prim :> Maybe2 prim) wX wY+pushPastForward (p :> NilFL) = NilFL :> Just2 p+pushPastForward (p :> (q :>: qs))+  | IsEq <- invert p =\/= q = qs :> Nothing2+  | Just (q' :> p') <- commute (p :> q)+      = case pushPastForward (p' :> qs) of+          qs' :> p'' -> (q' :>: qs') :> p''+  | otherwise = error $ "stuck patch: pushPastForward:\n" ++ show2 p ++ "\n" ++ show2 q
src/Darcs/Patch/V1.hs view
@@ -1,10 +1,6 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1 ( RepoPatchV1 ) where -import Darcs.Patch.Annotate ( Annotate )-import Darcs.Patch.Matchable ( Matchable )-import Darcs.Patch.Prim ( PrimPatch )-import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Annotate ()  import Darcs.Patch.V1.Apply () import Darcs.Patch.V1.Commute ()@@ -12,6 +8,3 @@ import Darcs.Patch.V1.Read () import Darcs.Patch.V1.Show () import Darcs.Patch.V1.Viewing ()--instance PrimPatch prim => Matchable (RepoPatchV1 prim)-instance (PrimPatch prim, Annotate prim) => RepoPatch (RepoPatchV1 prim)
src/Darcs/Patch/V1/Apply.hs view
@@ -1,10 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Apply () where -import Prelude () import Darcs.Prelude -import Darcs.Patch.Annotate ( Annotate(..) ) import Darcs.Patch.Apply ( ApplyState, Apply, apply ) import Darcs.Patch.Prim ( PrimPatch, applyPrimFL ) import Darcs.Patch.Repair ( RepairToFL, applyAndTryToFixFL,@@ -23,6 +21,3 @@ instance PrimPatch prim => RepairToFL (RepoPatchV1 prim) where     applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x     applyAndTryToFixFL x = do apply x; return Nothing--instance (PrimPatch prim, Annotate prim) => Annotate (RepoPatchV1 prim) where-    annotate = annotate . effect
src/Darcs/Patch/V1/Commute.hs view
@@ -15,7 +15,6 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Darcs.Patch.V1.Commute@@ -26,49 +25,59 @@     )        where -import Prelude () import Darcs.Prelude  import Control.Monad ( MonadPlus, mplus, msum, mzero, guard ) import Control.Applicative ( Alternative(..) )+import Data.Maybe ( fromMaybe )  import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdFL, commuterFLId )-import Darcs.Util.Path ( FileName )-import Darcs.Util.Printer ( errorDoc )+import Darcs.Util.Path ( AnchoredPath ) import Darcs.Patch.Invert ( invertRL )-import Darcs.Patch.Merge ( Merge(..), naturalMerge )+import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.V1.Core ( RepoPatchV1(..),                              isMerger,                              mergerUndo )-import Darcs.Patch.Conflict-    ( Conflict(..), listConflictedFiles-    , IsConflictedPrim(..), ConflictState(..), CommuteNoConflicts(..)-    , mangleUnravelled+import Darcs.Patch.CommuteNoConflicts+    ( CommuteNoConflicts(..)+    , mergeNoConflicts     )+import Darcs.Patch.Conflict+  ( Conflict(..), combineConflicts, mangleOrFail+  )+import Darcs.Patch.Unwind ( Unwind(..), Unwound(..), mkUnwound ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Prim ( FromPrim(..), PrimPatch,-                          is_filepatch, sortCoalesceFL,-                        )-import Darcs.Patch.Permutations ( headPermutationsRL, simpleHeadPermutationsFL )-import Darcs.Util.Printer ( text, vcat, ($$) )+import Darcs.Patch.Prim ( PrimPatch, is_filepatch )+import Darcs.Patch.Permutations+    ( headPermutationsRL+    , simpleHeadPermutationsFL+    , removeFL+    )+import Darcs.Util.Printer ( renderString, text, vcat, ($$) ) import Darcs.Patch.V1.Show ( showPatch_ )-import Data.List ( nub, nubBy )+import Data.List ( nub ) import Data.List.Ordered ( nubSort )+import Darcs.Patch.Summary+    ( Summary(..)+    , ConflictState(..)+    , IsConflictedPrim(..)+    ) import Darcs.Patch.Witnesses.Sealed-    ( Sealed(..) , mapSeal, unseal, FlippedSeal(..), mapFlipped-    , unsafeUnseal, unsafeUnsealFlipped )+    ( Sealed(..) , mapSeal, unseal+    , FlippedSeal(..), mapFlipped, unsealFlipped+    ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..), Eq2(..) ) import Darcs.Patch.Witnesses.Unsafe     ( unsafeCoerceP, unsafeCoercePStart     , unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Ordered     ( mapFL_FL, mapFL,-    FL(..), RL(..),+    FL(..), RL(..), (+>+),     (:/\:)(..), (:\/:)(..), (:>)(..),     lengthFL, mapRL,     reverseFL, reverseRL, concatFL@@ -94,10 +103,6 @@     Failed   >>= _      =  Failed     Unknown  >>= _      =  Unknown     return              =  Succeeded-#if MIN_VERSION_base(4,13,0)-instance MonadFail Perhaps where-#endif-    fail _              =  Unknown  instance Alternative Perhaps where     empty = Unknown@@ -164,7 +169,7 @@ -}  unsafeMerger :: PrimPatch prim => String -> RepoPatchV1 prim wX wY -> RepoPatchV1 prim wX wZ -> RepoPatchV1 prim wA wB-unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2+unsafeMerger x p1 p2 = unseal unsafeCoerceP $ merger x p1 p2  -- | Attempt to commute two patches, the first of which is a Merger patch. mergerCommute :: PrimPatch prim@@ -179,18 +184,18 @@                   ) mergerCommute _ = Unknown +instance PrimPatch prim => CleanMerge (RepoPatchV1 prim) where+    cleanMerge = mergeNoConflicts+ instance PrimPatch prim => Merge (RepoPatchV1 prim) where-    merge (y :\/: z) =-        case actualMerge (y:\/:z) of-        -- actualMerge returns one "arm" of a merge result (@y'@, which applies-        -- "after" @z@), but we need to return both arms. We therefore commute-        -- @z@ and @y'@, to obtain a @z'@, which applies "after" @y'' == y@.-        Sealed y' -> case commute (z :> y') of-                         Nothing -> errorDoc $ text "merge_patches bug"-                                    $$ showPatch_ y-                                   $$ showPatch_ z-                                   $$ showPatch_ y'-                         Just (_ :> z') -> unsafeCoercePStart z' :/\: y'+    merge (p1 :\/: p2) =+        case mergeNoConflicts (p1 :\/: p2) of+            Just r -> r+            Nothing ->+                case merger "0.0" p1 p2 of+                    Sealed p2' ->+                        case merger "0.0" p2 p1 of+                            Sealed p1' -> unsafeCoercePEnd p2' :/\: unsafeCoercePEnd p1'  instance PrimPatch prim => Commute (RepoPatchV1 prim) where     commute x = toMaybe $ msum@@ -210,13 +215,7 @@     hunkMatches f c@(Regrem{}) = hunkMatches f $ invert c     hunkMatches f (PP p) = hunkMatches f p -commuteNoMerger :: PrimPatch prim => MaybeCommute prim-commuteNoMerger x =-    toMaybe $ msum [ speedyCommute x-                   , everythingElseCommute x-                   ]--isFilepatchMerger :: PrimPatch prim => RepoPatchV1 prim wX wY -> Maybe FileName+isFilepatchMerger :: PrimPatch prim => RepoPatchV1 prim wX wY -> Maybe AnchoredPath isFilepatchMerger (PP p) = is_filepatch p isFilepatchMerger (Merger _ _ p1 p2) = do      f1 <- isFilepatchMerger p1@@ -267,15 +266,7 @@ otherCommuteRecursiveMerger _ = Unknown  type CommuteFunction prim = forall wX wY . (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY)-type MaybeCommute prim = forall wX wY . (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Maybe ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY) -commuteFLId :: MaybeCommute prim -> (RepoPatchV1 prim :> FL (RepoPatchV1 prim)) wX wY -> Maybe ((FL (RepoPatchV1 prim) :> RepoPatchV1 prim) wX wY)-commuteFLId _        (p :> NilFL) = return (NilFL :> p)-commuteFLId commuter (p :> (q :>: qs)) = do-   q' :> p' <- commuter (p :> q)-   qs' :> p'' <- commuteFLId commuter (p' :> qs)-   return ((q' :>: qs') :> p'')- {- A note about mergers and type witnesses ---------------------------------------@@ -299,17 +290,6 @@ -}  --- |actualMerge attempts to perform a merge; if successful, it returns the--- "right" branch of the merge------ TODO: why does this code throw away the other branch, only for merge to--- rebuild it?-actualMerge :: PrimPatch prim-    => (RepoPatchV1 prim :\/: RepoPatchV1 prim) wX wY -> Sealed (RepoPatchV1 prim wY)-actualMerge (p1 :\/: p2) = case naturalMerge (p1:\/:p2) of-                             Just (_ :/\: p1') -> Sealed p1'-                             Nothing -> merger "0.0" p2 p1- -- Recreates a patch history in reverse. unwind :: RepoPatchV1 prim wX wY -> Sealed (RL (RepoPatchV1 prim) wX) unwind (Merger _ unwindings _ _) = Sealed unwindings@@ -318,13 +298,14 @@ -- Recreates a patch history in reverse. The patch being unwound is always at -- the start of the list of patches. trueUnwind :: PrimPatch prim-    => RepoPatchV1 prim wX wY -> Sealed (RL (RepoPatchV1 prim) wX)-trueUnwind p@(Merger _ _ p1 p2) =-    case (unwind p1, unwind p2) of+    => RepoPatchV1 prim wC wX -> RepoPatchV1 prim wC wD -> Sealed ((RL (RepoPatchV1 prim) :> RepoPatchV1 prim) wX)+trueUnwind p1 p2 =+  let fake_p = Merger NilFL NilRL p1 p2+  in+  case (unwind p1, unwind p2) of     (Sealed (p1s:<:_),Sealed (p2s:<:_)) ->-         Sealed (unsafeUnsealFlipped (reconcileUnwindings p p1s (unsafeCoercePEnd p2s)) :<: unsafeCoerceP p1 :<: p)-    _ -> impossible-trueUnwind _ = impossible+         Sealed (unsealFlipped unsafeCoerceP (reconcileUnwindings fake_p p1s (unsafeCoercePEnd p2s)) :<: unsafeCoerceP p1 :> fake_p)+    _ -> error "impossible case"  reconcileUnwindings :: PrimPatch prim     => RepoPatchV1 prim wA wB -> RL (RepoPatchV1 prim) wX wZ -> RL (RepoPatchV1 prim) wY wZ -> FlippedSeal (RL (RepoPatchV1 prim)) wZ@@ -345,10 +326,11 @@               Just p1s' -> mapFlipped (:<:p2) $                            reconcileUnwindings p p1s' tp2s               Nothing ->-                errorDoc $ text "in function reconcileUnwindings"-                        $$ text "Original patch:"-                        $$ showPatch_ p-    _ -> bug "in reconcileUnwindings"+                error $ renderString+                  $ text "in function reconcileUnwindings"+                  $$ text "Original patch:"+                  $$ showPatch_ p+    _ -> error "in reconcileUnwindings"  -- This code seems wrong, shouldn't the commute be invert p1 :> p2 ? And why isn't p1' re-inverted? -- it seems to have been this way forever:@@ -363,40 +345,51 @@ putBefore _ NilFL = Just (unsafeCoerceP NilFL)  instance PrimPatch prim => CommuteNoConflicts (RepoPatchV1 prim) where-  commuteNoConflicts (x :> y) = do y' :> x' <- commuteNoMerger (x :> y)-                                   return (y' :> x')+  commuteNoConflicts x =+    toMaybe $ msum [ speedyCommute x+                   , everythingElseCommute x+                   ]  instance PrimPatch prim => Conflict (RepoPatchV1 prim) where-  resolveConflicts patch = rcs NilFL (NilRL :<: patch)-    where rcs :: FL (RepoPatchV1 prim) wY wW -> RL (RepoPatchV1 prim) wX wY -> [[Sealed (FL prim wW)]]-          rcs _ NilRL = []-          rcs passedby (ps:<:p@(Merger{})) =-              case commuteFLId commuteNoMerger (p :> passedby) of-              Just (_ :> p'@(Merger _ _ p1 p2)) ->-                  map Sealed (nubBy unsafeCompare $-                        effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) :-                          map (unsafeCoercePStart . unsafeUnseal) (unravel p'))-                  : rcs (p :>: passedby) ps-              Nothing -> rcs (p :>: passedby) ps-              _ -> impossible-          rcs passedby (ps:<:p) = seq passedby $-                                  rcs (p :>: passedby) ps+  resolveConflicts _ = map mangleOrFail . combineConflicts resolveOne+    where+      resolveOne p | isMerger p = [publicUnravel p]+      resolveOne _ = [] -  conflictedEffect x =-    case listConflictedFiles x of-      [] -> mapFL (IsC Okay) $ effect x-      _ -> mapFL (IsC Conflicted) $ effect x+instance PrimPatch prim => Unwind (RepoPatchV1 prim) where+  fullUnwind (PP prim) = mkUnwound NilFL (prim :>: NilFL) NilFL+  fullUnwind (Merger a _ c d) =+    case fullUnwind d of+      Unwound before prim _after ->+        mkUnwound+          (invert (effect c) +>+ before)+          prim+          (invert prim +>+ invert before +>+ effect c +>+ effect a)+  fullUnwind (Regrem a b c d) = invert (fullUnwind (Merger a b c d)) +instance PrimPatch prim => Summary (RepoPatchV1 prim) where+  conflictedEffect x+    | isMerger x = mapFL (IsC Conflicted) $ effect x+    | otherwise = mapFL (IsC Okay) $ effect x  -- This type seems wrong - the most natural type for the result would seem to be -- [Sealed (FL prim wX)], given the type of unwind. -- However downstream code in darcs convert assumes the wY type, and I was unable -- to figure out whether this could/should reasonably be changed -- Ganesh 13/4/10+--+-- bf says: the type here is correct, those of unwind and unravel are wrong,+-- because conflict resolution applies to the end of the repo. publicUnravel :: PrimPatch prim => RepoPatchV1 prim wX wY -> [Sealed (FL prim wY)] publicUnravel = map (mapSeal unsafeCoercePStart) . unravel +dropAllInverses :: (Commute p, Invert p, Eq2 p) => FL p wX wY -> FL p wX wY+dropAllInverses NilFL = NilFL+dropAllInverses (p :>: ps) =+  let ps' = dropAllInverses ps in+  fromMaybe (p :>: ps') $ removeFL (invert p) ps'+ unravel :: PrimPatch prim => RepoPatchV1 prim wX wY -> [Sealed (FL prim wX)]-unravel p = nub $ map (mapSeal (sortCoalesceFL . concatFL . mapFL_FL effect)) $+unravel p = nub $ map (mapSeal (dropAllInverses . concatFL . mapFL_FL effect)) $             getSupers $ map (mapSeal reverseRL) $ unseal (newUr p) $ unwind p  getSupers :: PrimPatch prim@@ -424,27 +417,26 @@ -- the resulting Merger is therefore a representation of @p2@. merger :: PrimPatch prim     => String -> RepoPatchV1 prim wX wY -> RepoPatchV1 prim wX wZ -> Sealed (RepoPatchV1 prim wY)-merger "0.0" p1 p2 = Sealed $ Merger undoit unwindings p1 p2-    where fake_p = Merger NilFL NilRL p1 p2-          unwindings = unsafeUnseal (trueUnwind fake_p)-          p = Merger NilFL unwindings p1 p2-          undoit =+merger "0.0" p1 p2 = final_p+    where+          sealed_unwindings = trueUnwind p1 p2+          final_p =+            case (sealed_undoit, sealed_unwindings) of+              (Sealed undoit, Sealed unwindings)+                -> Sealed $ Merger undoit ((\(a :> b) -> (a :<: b)) unwindings) p1 p2+          sealed_undoit =               case (isMerger p1, isMerger p2) of-              (True ,True ) -> case unwind p of-                                 Sealed (t:<:_) -> unsafeCoerceP $ invertRL t-                                 _ -> impossible-              (False,False) -> unsafeCoerceP $ invert p1 :>: NilFL-              (True ,False) -> unsafeCoerceP NilFL-              (False,True ) -> unsafeCoerceP $ invert p1 :>: mergerUndo p2+              (True ,True ) -> case sealed_unwindings of+                                 Sealed (t :> _) -> Sealed $ unsafeCoercePStart $ invertRL t+              (False,False) -> Sealed $ invert p1 :>: NilFL+              (True ,False) -> Sealed NilFL+              (False,True ) -> Sealed $ invert p1 :>: mergerUndo p2 merger g _ _ =     error $ "Cannot handle mergers other than version 0.0\n"++g     ++ "\nPlease use darcs optimize --modernize with an older darcs." -glump09 :: PrimPatch prim => RepoPatchV1 prim wX wY -> RepoPatchV1 prim wX wZ -> Sealed (FL (RepoPatchV1 prim) wY)-glump09 p1 p2 = mapSeal (mapFL_FL fromPrim) $ mangleUnravelled $ unseal unravel $ merger "0.0" p1 p2- instance PrimPatch prim => Effect (RepoPatchV1 prim) where-    effect p@(Merger{}) = sortCoalesceFL $ effect $ mergerUndo p+    effect p@(Merger{}) = dropAllInverses $ effect $ mergerUndo p     effect p@(Regrem{}) = invert $ effect $ invert p     effect (PP p) = p :>: NilFL @@ -457,7 +449,7 @@ newUr p (ps :<: Merger _ _ p1 p2) =    case filter (\(_:<:pp) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of    ((ps':<:_):_) -> newUr p (ps':<:unsafeCoercePStart p1) ++ newUr p (ps':<:unsafeCoercePStart p2)-   _ -> errorDoc $ text "in function newUr"+   _ -> error $ renderString $ text "in function newUr"                  $$ text "Original patch:"                  $$ showPatch_ p                  $$ text "Unwound:"
src/Darcs/Patch/V1/Core.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} module Darcs.Patch.V1.Core     ( RepoPatchV1(..),       isMerger, mergerUndo     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Format@@ -12,17 +10,17 @@     , ListFormat(ListFormatV1)     ) import Darcs.Patch.Debug ( PatchDebug(..) )-import Darcs.Patch.Prim-    ( FromPrim(..), PrimPatchBase(..), PrimPatch+import Darcs.Patch.FromPrim+    ( FromPrim(..)+    , PrimPatchBase(..)+    , ToPrim(..)     )+import Darcs.Patch.Ident ( PatchId )+import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Repair ( Check )  import Darcs.Patch.Witnesses.Ordered ( FL(..), RL )-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..)-    , ShowDict(ShowDictClass)-    , appPrec, showsPrec2-    )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 )  -- This haddock could be put on the individual bits of Merger instead -- once haddock supports doc comments on GADT constructors@@ -41,13 +39,13 @@     PP :: prim wX wY -> RepoPatchV1 prim wX wY     Merger :: FL (RepoPatchV1 prim) wX wY            -> RL (RepoPatchV1 prim) wX wB-           -> RepoPatchV1 prim wC wB+           -> RepoPatchV1 prim wC wX            -> RepoPatchV1 prim wC wD            -> RepoPatchV1 prim wX wY     Regrem :: FL (RepoPatchV1 prim) wX wY            -> RL (RepoPatchV1 prim) wX wB-           -> RepoPatchV1 prim wC wB-           -> RepoPatchV1 prim wC wA+           -> RepoPatchV1 prim wC wX+           -> RepoPatchV1 prim wC wD            -> RepoPatchV1 prim wY wX  instance Show2 prim => Show (RepoPatchV1 prim wX wY)  where@@ -66,18 +64,22 @@             showString " " . showsPrec2 (appPrec + 1) conflicting .             showString " " . showsPrec2 (appPrec + 1) original -instance Show2 prim => Show1 (RepoPatchV1 prim wX) where-    showDict1 = ShowDictClass+instance Show2 prim => Show1 (RepoPatchV1 prim wX) -instance Show2 prim => Show2 (RepoPatchV1 prim) where-    showDict2 = ShowDictClass+instance Show2 prim => Show2 (RepoPatchV1 prim)  instance PrimPatch prim => PrimPatchBase (RepoPatchV1 prim) where     type PrimOf (RepoPatchV1 prim) = prim +type instance PatchId (RepoPatchV1 prim) = ()+ instance FromPrim (RepoPatchV1 prim) where-    fromPrim = PP+    fromAnonymousPrim = PP +instance ToPrim (RepoPatchV1 prim) where+    toPrim (PP p) = Just p+    toPrim _ = Nothing+ isMerger :: RepoPatchV1 prim wA wB -> Bool isMerger (Merger{}) = True isMerger (Regrem{}) = True@@ -85,7 +87,7 @@  mergerUndo :: RepoPatchV1 prim wX wY -> FL (RepoPatchV1 prim) wX wY mergerUndo (Merger undo _ _ _) = undo-mergerUndo _ = impossible+mergerUndo _ = error "impossible case"  instance PatchListFormat (RepoPatchV1 prim) where    -- In principle we could use ListFormatDefault when prim /= V1 Prim patches,
src/Darcs/Patch/V1/Prim.hs view
@@ -1,25 +1,23 @@ -- it is stupid that we need UndecidableInstances just to call another -- type function (see instance Apply below which requires this) {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Darcs.Patch.V1.Prim ( Prim(..) ) where -import Prelude () import Darcs.Prelude  import Data.Coerce ( coerce )  import Darcs.Patch.Annotate ( Annotate(..) ) import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format     ( PatchListFormat(..)     , ListFormat(ListFormatV1)-    , FileNameFormat(OldFormat,UserFormat) )+    , FileNameFormat(FileNameFormatV1,FileNameFormatDisplay) ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Merge ( CleanMerge ) import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.Repair ( RepairToFL(..) ) import Darcs.Patch.Show@@ -31,26 +29,23 @@ import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )  import Darcs.Patch.Witnesses.Eq ( Eq2 )-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..)-    , ShowDict(ShowDictClass)-    , appPrec, showsPrec2-    )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Patch.Witnesses.Sealed ( mapSeal )  import Darcs.Patch.Prim.Class     ( PrimConstruct(..), PrimCanonize(..)     , PrimClassify(..), PrimDetails(..)     , PrimShow(..), PrimRead(..)     , PrimApply(..)-    , PrimPatch, PrimPatchBase(..)-    , FromPrim(..), ToFromPrim(..)-    , PrimPatchCommon+    , PrimSift(..)+    , PrimMangleUnravelled(..)     ) import qualified Darcs.Patch.Prim.V1 as Base ( Prim )  newtype Prim x y = Prim { unPrim :: Base.Prim x y } deriving     ( Annotate+    , Apply+    , CleanMerge     , Commute     , Invert     , IsHunk@@ -61,44 +56,27 @@     , PrimClassify     , PrimConstruct     , PrimDetails-    , PrimPatchCommon+    , PrimMangleUnravelled+    , PrimSift+    , Show     ) -instance PrimPatch Prim--instance Show (Prim wX wY)  where-  showsPrec d (Prim p) =-    showParen (d > appPrec) $ showString "Prim " . showsPrec2 (appPrec + 1) p--instance Show1 (Prim wX) where-  showDict1 = ShowDictClass--instance Show2 Prim where-  showDict2 = ShowDictClass--instance PrimPatchBase Prim where-  type PrimOf Prim = Prim--instance FromPrim Prim where-  fromPrim = id+instance Show1 (Prim wX) -instance ToFromPrim Prim where-  toPrim = Just+instance Show2 Prim  instance ReadPatch Prim where-  readPatch' = do-    Sealed p <- readPrim OldFormat-    return (Sealed (Prim p))+  readPatch' = fmap (mapSeal Prim) (readPrim FileNameFormatV1)  fileNameFormat :: ShowPatchFor -> FileNameFormat-fileNameFormat ForDisplay = UserFormat-fileNameFormat ForStorage = OldFormat+fileNameFormat ForDisplay = FileNameFormatDisplay+fileNameFormat ForStorage = FileNameFormatV1  instance ShowPatchBasic Prim where   showPatch fmt = showPrim (fileNameFormat fmt) . unPrim  instance ShowContextPatch Prim where-  showContextPatch f = showPrimCtx (fileNameFormat f) . unPrim+  showContextPatch fmt = showPrimCtx (fileNameFormat fmt) . unPrim  instance ShowPatch Prim where   summary = plainSummaryPrim . unPrim@@ -107,10 +85,6 @@  instance PatchListFormat Prim where   patchListFormat = ListFormatV1--instance Apply Prim where-  type ApplyState Prim = ApplyState Base.Prim-  apply = apply . unPrim  instance RepairToFL Prim where   applyAndTryToFixFL = fmap coerce . applyAndTryToFixFL . unPrim
src/Darcs/Patch/V1/Read.hs view
@@ -1,14 +1,13 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Read () where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Invert ( invert ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.ReadMonads ( ParserM, choice, string,-                                lexChar, myLex', skipSpace )+import Darcs.Util.Parser ( Parser, choice, string,+                                lexChar, lexWord, skipSpace )  import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) import Darcs.Patch.V1.Commute ( merger )@@ -27,9 +26,9 @@             , liftM seal $ skipSpace >> readMerger False             , liftM (mapSeal PP) readPatch'             ]-readMerger :: (ParserM m, PrimPatch prim) => Bool -> m (RepoPatchV1 prim wX wY)+readMerger :: (PrimPatch prim) => Bool -> Parser (RepoPatchV1 prim wX wY) readMerger b = do string s-                  g <- myLex'+                  g <- lexWord                   lexChar '('                   Sealed p1 <- readPatch'                   Sealed p2 <- readPatch'
src/Darcs/Patch/V1/Show.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Show ( showPatch_ ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(..) )
src/Darcs/Patch/V1/Viewing.hs view
@@ -1,9 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Viewing () where +import Darcs.Prelude+ import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Show ( ShowPatch(..), ShowContextPatch(..), showPatch )-import Darcs.Patch.Summary ( plainSummary )+import Darcs.Patch.Summary ( plainSummary, plainSummaryFL )  import Darcs.Patch.V1.Apply () import Darcs.Patch.V1.Core ( RepoPatchV1(..) )@@ -15,5 +17,5 @@  instance PrimPatch prim => ShowPatch (RepoPatchV1 prim) where     summary = plainSummary-    summaryFL = plainSummary+    summaryFL = plainSummaryFL     thing _ = "change"
src/Darcs/Patch/V2.hs view
@@ -1,11 +1,4 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V2 ( RepoPatchV2 ) where -import Darcs.Patch.Annotate ( Annotate )-import Darcs.Patch.Matchable ( Matchable )-import Darcs.Patch.Prim ( PrimPatch )-import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Annotate () import Darcs.Patch.V2.RepoPatch ( RepoPatchV2 )--instance PrimPatch prim => Matchable (RepoPatchV2 prim)-instance (PrimPatch prim, Annotate prim) => RepoPatch (RepoPatchV2 prim)
src/Darcs/Patch/V2/Non.hs view
@@ -16,7 +16,7 @@ -- Boston, MA 02110-1301, USA.  {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}-{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-}   module Darcs.Patch.V2.Non@@ -39,7 +39,6 @@     , (>>*)     ) where -import Prelude () import Darcs.Prelude hiding ( (*>) )  import Data.List ( delete )@@ -49,23 +48,21 @@ import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Invert ( Invert, invertFL, invertRL )-import Darcs.Patch.Prim-    ( FromPrim(..), ToFromPrim(..)-    , PrimOf, PrimPatchBase-    , sortCoalesceFL+import Darcs.Patch.FromPrim+    ( FromPrim(..), ToFromPrim+    , PrimOf, PrimPatchBase, toPrim     )+import Darcs.Patch.Prim ( sortCoalesceFL ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Invert ( Invert(invert) ) import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.Show ( showPatch )-import Darcs.Patch.ReadMonads ( ParserM, lexChar )+import Darcs.Util.Parser ( Parser, lexChar ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered     ( FL(..), RL(..), (+>+), mapRL_RL     , (:>)(..), reverseFL, reverseRL )-import Darcs.Patch.Witnesses.Show-    ( ShowDict(..), Show1(..), Show2(..), appPrec-    , showsPrec2 )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Read ( peekfor ) import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor )@@ -82,15 +79,14 @@ -- |unNon converts a Non into a FL of its context followed by the primitive -- patch. unNon :: FromPrim p => Non p wX -> Sealed (FL p wX)-unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL)+unNon (Non c x) = Sealed (c +>+ fromAnonymousPrim x :>: NilFL)  instance (Show2 p, Show2 (PrimOf p)) => Show (Non p wX) where     showsPrec d (Non cs p) = showParen (d > appPrec) $ showString "Non " .                              showsPrec2 (appPrec + 1) cs . showString " " .                              showsPrec2 (appPrec + 1) p -instance (Show2 p, Show2 (PrimOf p)) => Show1 (Non p) where-    showDict1 = ShowDictClass+instance (Show2 p, Show2 (PrimOf p)) => Show1 (Non p)  -- |showNons creates a Doc representing a list of Nons. showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p)@@ -108,8 +104,8 @@                       $$ showPatch f p  -- |readNons is a parser that attempts to read a list of Nons.-readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m)-         => m [Non p wX]+readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p)+         => Parser [Non p wX] readNons = peekfor (BC.pack "{{") rns (return [])   where rns = peekfor (BC.pack "}}") (return []) $               do Sealed ps <- readPatch'@@ -118,8 +114,8 @@                  (Non ps p :) `liftM` rns  -- |readNon is a parser that attempts to read a single Non.-readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m)-        => m (Non p wX)+readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p)+        => Parser (Non p wX) readNon = do Sealed ps <- readPatch'              let doReadPrim = do Sealed p <- readPatch'                                  return $ Non ps p@@ -183,7 +179,7 @@ -- past a Non. commutePrimsOrAddToCtx :: (WL l, Apply p, Commute p, Invert p, ToFromPrim p) => l (PrimOf p) wX wY          -> Non p wY -> Non p wX-commutePrimsOrAddToCtx q = commuteOrAddToCtxRL (mapRL_RL fromPrim $ toRL q)+commutePrimsOrAddToCtx q = commuteOrAddToCtxRL (mapRL_RL fromAnonymousPrim $ toRL q)  -- TODO: Figure out what remNons is for; it's is only used in one place - when -- commuting two Conflictors:@@ -252,7 +248,7 @@      -> Maybe (Non p wX) y >* (Non c x) = do     c' :> y' <- commuteFL (y :> c)-    px' :> _ <- commute (y' :> fromPrim x)+    px' :> _ <- commute (y' :> fromAnonymousPrim x)     x' <- toPrim px'     return (Non c' x') @@ -269,4 +265,4 @@     commuteRLPastNon :: (Apply p, Commute p, Invert p, ToFromPrim p) => RL (PrimOf p) wX wY                      -> Non p wY -> Maybe (Non p wX)     commuteRLPastNon NilRL n = Just n-    commuteRLPastNon (xs:<:x) n = fromPrim x >* n >>= commuteRLPastNon xs+    commuteRLPastNon (xs:<:x) n = fromAnonymousPrim x >* n >>= commuteRLPastNon xs
src/Darcs/Patch/V2/Prim.hs view
@@ -1,25 +1,23 @@ -- it is stupid that we need UndecidableInstances just to call another -- type function (see instance Apply below which requires this) {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Darcs.Patch.V2.Prim ( Prim(..) ) where -import Prelude () import Darcs.Prelude  import Data.Coerce (coerce )  import Darcs.Patch.Annotate ( Annotate ) import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Format     ( PatchListFormat(..)     , ListFormat(ListFormatV2)-    , FileNameFormat(NewFormat,UserFormat) )+    , FileNameFormat(FileNameFormatV2,FileNameFormatDisplay) ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Merge ( CleanMerge ) import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.Repair ( RepairToFL(..) ) import Darcs.Patch.Show@@ -31,11 +29,7 @@ import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )  import Darcs.Patch.Witnesses.Eq ( Eq2 )-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..)-    , ShowDict(ShowDictClass)-    , appPrec, showsPrec2-    )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) import Darcs.Patch.Witnesses.Sealed ( mapSeal )  import Darcs.Patch.Prim.Class@@ -43,14 +37,15 @@     , PrimClassify(..), PrimDetails(..)     , PrimShow(..), PrimRead(..)     , PrimApply(..)-    , PrimPatch, PrimPatchBase(..)-    , FromPrim(..), ToFromPrim(..)-    , PrimPatchCommon+    , PrimSift(..)+    , PrimMangleUnravelled(..)     ) import qualified Darcs.Patch.Prim.V1 as Base ( Prim )  newtype Prim x y = Prim { unPrim :: Base.Prim x y } deriving     ( Annotate+    , Apply+    , CleanMerge     , Commute     , Invert     , IsHunk@@ -61,42 +56,27 @@     , PrimClassify     , PrimConstruct     , PrimDetails-    , PrimPatchCommon+    , PrimMangleUnravelled+    , PrimSift+    , Show     ) -instance PrimPatch Prim--instance Show (Prim wX wY)  where-  showsPrec d (Prim p) =-    showParen (d > appPrec) $ showString "Prim " . showsPrec2 (appPrec + 1) p--instance Show1 (Prim wX) where-  showDict1 = ShowDictClass--instance Show2 Prim where-  showDict2 = ShowDictClass--instance PrimPatchBase Prim where-  type PrimOf Prim = Prim--instance FromPrim Prim where-  fromPrim = id+instance Show1 (Prim wX) -instance ToFromPrim Prim where-  toPrim = Just+instance Show2 Prim  instance ReadPatch Prim where-  readPatch' = fmap (mapSeal Prim) (readPrim NewFormat)+  readPatch' = fmap (mapSeal Prim) (readPrim FileNameFormatV2)  fileNameFormat :: ShowPatchFor -> FileNameFormat-fileNameFormat ForDisplay = UserFormat-fileNameFormat ForStorage = NewFormat+fileNameFormat ForDisplay = FileNameFormatDisplay+fileNameFormat ForStorage = FileNameFormatV2  instance ShowPatchBasic Prim where-  showPatch f = showPrim (fileNameFormat f) . unPrim+  showPatch fmt = showPrim (fileNameFormat fmt) . unPrim  instance ShowContextPatch Prim where-  showContextPatch f = showPrimCtx (fileNameFormat f) . unPrim+  showContextPatch fmt = showPrimCtx (fileNameFormat fmt) . unPrim  instance ShowPatch Prim where   summary = plainSummaryPrim . unPrim@@ -111,10 +91,6 @@   -- format. In practice we don't expect RepoPatchV2 to be used with any other   -- argument anyway, so it doesn't matter.   patchListFormat = ListFormatV2--instance Apply Prim where-  type ApplyState Prim = ApplyState Base.Prim-  apply = apply . unPrim  instance RepairToFL Prim where   applyAndTryToFixFL = fmap coerce . applyAndTryToFixFL . unPrim
src/Darcs/Patch/V2/RepoPatch.hs view
@@ -25,7 +25,6 @@     , mergeUnravelled     ) where -import Prelude () import Darcs.Prelude hiding ( (*>) )  import Control.Monad ( mplus, liftM )@@ -34,22 +33,26 @@ import Data.List ( partition, nub ) import Data.List.Ordered ( nubSort ) -import Darcs.Patch.Annotate ( Annotate(..) )-import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL+import Darcs.Patch.Commute ( commuteFL, commuteRL                            , commuteRLFL, Commute(..) )-import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..)-                            , IsConflictedPrim(..), ConflictState(..)-                            , mangleUnravelled )+import Darcs.Patch.CommuteFn ( CommuteFn, invertCommuter )+import Darcs.Patch.CommuteNoConflicts ( CommuteNoConflicts(..), mergeNoConflicts )+import Darcs.Patch.Conflict ( Conflict(..), combineConflicts, mangleOrFail ) import Darcs.Patch.Debug import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(ListFormatV2) )+import Darcs.Patch.Ident ( PatchId ) import Darcs.Patch.Invert ( invertFL, invertRL, Invert(..) )-import Darcs.Patch.Merge ( Merge(..), naturalMerge )-import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..)-                        , PrimPatchBase(..), PrimPatch )+import Darcs.Patch.Merge ( CleanMerge(..), Merge(..), swapMerge )+import Darcs.Patch.FromPrim+    ( FromPrim(..)+    , ToPrim(..)+    , PrimPatchBase(..)+    )+import Darcs.Patch.Prim ( PrimPatch, applyPrimFL ) import Darcs.Patch.Read ( bracketedFL, ReadPatch(..) )-import Darcs.Patch.ReadMonads ( skipSpace, string, choice )+import Darcs.Util.Parser ( skipSpace, string, choice ) import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) ) import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) )@@ -59,7 +62,13 @@ import Darcs.Patch.Show     ( ShowPatch(..), ShowPatchBasic(..), ShowContextPatch(..), ShowPatchFor(..)     , displayPatch )-import Darcs.Patch.Summary ( plainSummary )+import Darcs.Patch.Summary+    ( Summary(..)+    , ConflictState(..)+    , IsConflictedPrim(..)+    , plainSummary+    )+import Darcs.Patch.Unwind ( Unwind(..), mkUnwound ) import Darcs.Patch.V2.Non ( Non(..), Nonable(..), unNon, showNons, showNon                           , readNons, readNon, commutePrimsOrAddToCtx                           , commuteOrAddToCtx, commuteOrAddToCtxRL@@ -68,19 +77,16 @@ import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), (:>)(..), (+>+), (+<+)+    ( FL(..), RL(..), Fork(..), (:>)(..), (+>+), (+<+)     , mapFL, mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..)     , reverseRL, lengthFL, lengthRL, nullFL, initsFL ) import Darcs.Patch.Witnesses.Sealed     ( FlippedSeal(..), Sealed(Sealed), mapSeal     , unseal )-import Darcs.Patch.Witnesses.Show-    ( Show1(..), Show2(..), ShowDict(..)-    , showsPrec2, appPrec-    )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, showsPrec2, appPrec ) -import Darcs.Util.Printer.Color ( errorDoc, assertDoc )-import Darcs.Util.Printer ( Doc, blueText, redText, (<+>), ($$), vcat )+import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Printer ( Doc, renderString, blueText, redText, (<+>), ($$), vcat )  -- |'RepoPatchV2' is used to represents prim patches that are duplicates of, or -- conflict with, another prim patch in the repository.@@ -149,7 +155,7 @@ mergeUnravelled ws =     case mergeUnravelled_private ws of         Nothing -> Nothing-        Just NilRL -> bug "found no patches in mergeUnravelled"+        Just NilRL -> error "found no patches in mergeUnravelled"         Just (_ :<: z) -> Just $ FlippedSeal z   where     notNullS :: Sealed ((FL prim) wX) -> Bool@@ -167,8 +173,8 @@     sealed2non :: Sealed ((FL prim) wX) -> Non (RepoPatchV2 prim) wX     sealed2non (Sealed xs) =         case reverseFL xs of-            ys :<: y -> Non (mapFL_FL fromPrim $ reverseRL ys) y-            NilRL -> bug "NilFL encountered in sealed2non"+            ys :<: y -> Non (mapFL_FL Normal $ reverseRL ys) y+            NilRL -> error "NilFL encountered in sealed2non"  mergeConflictingNons :: PrimPatch prim => [Non (RepoPatchV2 prim) wX]                      -> Maybe (FL (RepoPatchV2 prim) wX wX)@@ -183,7 +189,7 @@                                _ -> Nothing           mcn (Sealed p1:Sealed p2:zs) =             case pullCommon p1 p2 of-                Common c ps qs ->+                Fork c ps qs ->                     case merge (ps :\/: qs) of                         qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs) @@ -199,7 +205,7 @@  assertConsistent :: PrimPatch prim => RepoPatchV2 prim wX wY                  -> RepoPatchV2 prim wX wY-assertConsistent x = flip assertDoc x $ do+assertConsistent x = maybe x (error . renderString) $ do     e <- isConsistent x     Just (redText "Inconsistent patch:" $$ displayPatch x $$ e) @@ -230,8 +236,8 @@                               NilFL -> Just (NilFL, mapFL_FL Normal xs)                               _ -> Nothing     mac (ps :<: p) xs goneby =-        case commuteFLorComplain (p :> mapFL_FL Normal xs) of-            Left _ ->+        case commuteFL (p :> mapFL_FL Normal xs) of+            Nothing ->                 case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of                     a :> p' :> b ->                         do (b', xs') <- mac b xs goneby@@ -242,7 +248,7 @@                         do NilFL <- return goneby                            NilFL <- return $ joinEffects (ps :<: p)                            return (reverseRL (ps :<: p), mapFL_FL Normal xs)-            Right (l :> p'') ->+            Just (l :> p'') ->                 case allNormal l of                     Just xs'' -> mac ps xs'' (p'' :>: goneby)                     Nothing ->@@ -262,7 +268,7 @@                      , Normal x :>: xs') geteff ix xx =     case mergeConflictingNons ix of-        Nothing -> errorDoc $+        Nothing -> error $ renderString $             redText "mergeConflictingNons failed in geteff: ix" $$             displayNons ix $$ redText "xx" $$ displayPatch xx         Just rix ->@@ -271,7 +277,7 @@                     ( map (commuteOrAddToCtxRL (reverseFL a)) $ toNons x                     , a +>+ x)                 Nothing ->-                    errorDoc $+                    error $ renderString $                         redText "mergeAfterConflicting failed in geteff" $$                         redText "where ix" $$ displayNons ix $$                         redText "and xx" $$ displayPatch xx $$@@ -348,18 +354,23 @@                                     ([], _) -> q : qs                                     (_, nc) -> unconflicting_of nc -instance PrimPatch prim => Conflict (RepoPatchV2 prim) where+instance Summary (RepoPatchV2 prim) where     conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x]-    conflictedEffect (Etacilpud _) = impossible+    conflictedEffect (Etacilpud _) = error "impossible case"     conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]-    conflictedEffect (InvConflictor{}) = impossible+    conflictedEffect (InvConflictor{}) = error "impossible case"     conflictedEffect (Normal x) = [IsC Okay x]-    resolveConflicts (Conflictor ix xx x) = [mangledUnravelled : unravelled]++instance PrimPatch prim => Conflict (RepoPatchV2 prim) where+    resolveConflicts _ = map mangleOrFail . combineConflicts resolveOne       where-        mangledUnravelled = mangleUnravelled unravelled-        unravelled = nub $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX-        xIxNonXX = x : ix ++ nonxx-        nonxx = nonxx_ (reverseFL $ xx2patches ix xx)+        resolveOne :: RepoPatchV2 prim wX wY -> [[Sealed (FL prim wY)]]+        resolveOne (Conflictor ix xx x) = [unravelled]+          where+            unravelled = nub $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX+            xIxNonXX = x : ix ++ nonxx+            nonxx = nonxx_ (reverseFL $ xx2patches ix xx)+        resolveOne _ = []         -- |nonxx_ takes an RL of patches, and returns a singleton list         -- containing a Non, in the case where we have a Normal patch at the         -- end of the list (using the rest of the RL as context), and an empty@@ -368,8 +379,19 @@         nonxx_ (qs :<: Normal q) = [Non (reverseRL qs) q]         nonxx_ _ = []         isCons = unseal (not . nullFL)-    resolveConflicts _ = [] +instance PrimPatch prim => Unwind (RepoPatchV2 prim) where+  fullUnwind (Normal p) =+    mkUnwound NilFL (p :>: NilFL) NilFL+  fullUnwind (Duplicate (Non ps p)) =+    mkUnwound (effect ps) (p :>: NilFL) (invert p :>: effect (invert ps))+  fullUnwind (Conflictor _ es (Non ps p)) =+    mkUnwound (invert es +>+ effect ps) (p :>: NilFL) (invert p :>: effect (invert ps))+  fullUnwind (Etacilpud non) =+    invert (fullUnwind (Duplicate non))+  fullUnwind (InvConflictor ix xx x) =+    invert (fullUnwind (Conflictor ix xx x))+ instance PrimPatch prim => CommuteNoConflicts (RepoPatchV2 prim) where     commuteNoConflicts (d1@(Duplicate _) :> d2@(Duplicate _)) = Just (d2 :> d1)     commuteNoConflicts (e@(Etacilpud _) :> d@(Duplicate _)) = Just (d :> e)@@ -462,10 +484,12 @@ instance PrimPatch prim => Check (RepoPatchV2 prim) where     isInconsistent = isConsistent +type instance PatchId (RepoPatchV2 prim) = ()+ instance FromPrim (RepoPatchV2 prim) where-    fromPrim = Normal+    fromAnonymousPrim = Normal -instance ToFromPrim (RepoPatchV2 prim) where+instance ToPrim (RepoPatchV2 prim) where     toPrim (Normal p) = Just p     toPrim _ = Nothing @@ -505,8 +529,8 @@   where     nix = Normal $ invert x -nonTouches :: PatchInspect prim => Non (RepoPatchV2 prim) wX -> [FilePath]-nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL)+nonTouches :: PatchInspect prim => Non (RepoPatchV2 prim) wX -> [AnchoredPath]+nonTouches (Non c x) = listTouchedFiles (c +>+ Normal x :>: NilFL)  nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool)                -> Non (RepoPatchV2 prim) wX -> Bool@@ -523,12 +547,13 @@                        case non p of                            Non NilFL pp -> Non (reverseRL deps) pp                            Non ds pp ->-                               errorDoc $ redText "Weird case in toNons" $$-                                          redText "please report this bug!" $$-                                          (case xxx of-                                           z :> zs -> displayPatch (z :>: zs)) $$-                                          redText "ds are" $$ displayPatch ds $$-                                          redText "pp is" $$ displayPatch pp+                               error $ renderString $+                                  redText "Weird case in toNons" $$+                                  redText "please report this bug!" $$+                                  (case xxx of+                                   z :> zs -> displayPatch (z :>: zs)) $$+                                  redText "ds are" $$ displayPatch ds $$+                                  redText "pp is" $$ displayPatch pp            reverseFoo :: (p :> FL p) wX wZ -> (RL p :> p) wX wZ           reverseFoo (p :> ps) = rf NilRL p ps@@ -545,7 +570,7 @@                   -> FL prim wX wY -> (FL prim :> FL prim) wX wY filterConflictsFL _ NilFL = NilFL :> NilFL filterConflictsFL n (p :>: ps)-    | Just n' <- commuteOrRemFromCtx (fromPrim p) n =+    | Just n' <- commuteOrRemFromCtx (Normal p) n =         case filterConflictsFL n' ps of             p1 :> p2 -> p :>: p1 :> p2     | otherwise = case commuteWhatWeCanFL (p :> ps) of@@ -560,74 +585,69 @@     invert (Conflictor x c p) = InvConflictor x c p     invert (InvConflictor x c p) = Conflictor x c p -instance PrimPatch prim => Commute (RepoPatchV2 prim) where-    commute (x :> y) | Just (y' :> x') <--        commuteNoConflicts (assertConsistent x :> assertConsistent y) =-        Just (y' :> x')--    -- These patches conflicted, since we failed to commuteNoConflicts in the-    -- case above.-    commute (Normal x :> Conflictor a1'nop2 n1'x p1')-        | Just rn1' <- removeRL x (reverseFL n1'x) = do-            let p2 : n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (rn1' :<: x)-                a2 = p1' : a1'nop2 ++ n1nons-            case (a1'nop2, reverseRL rn1', p1') of-                ([], NilFL, Non c y) | NilFL <- joinEffects c ->-                    Just (Normal y :> Conflictor a1'nop2 (y :>: NilFL) p2)-                (a1, n1, _) ->-                    Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)--    -- Handle using the inverting commuter, and the previous case.  N.b. this-    -- is innefficient, since we'll have to also try commuteNoConflicts again-    -- (which we know will fail, since we got here).-    commute c@(InvConflictor{} :> Normal _) = invertCommute c--    commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)-        | Just a2_minus_p1 <- remove1 p1' a2-        , not (p2 `dependsUpon` p1') = do-            let n1nons = map (commutePrimsOrAddToCtx n2) $ xx2nons a1 n1-                n2nons = xx2nons a2 n2-                Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons-                n2n1 = n2 +>+ n1-                a1' = map (commutePrimsOrAddToCtx n2) a1-                p2ooo = remNons a1' p2-            n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1-            let n1'n2'nons = xx2nons a2_minus_p1n1 (n1' +>+ n2')-                n1'nons = take (lengthFL n1') n1'n2'nons-                n2'nons = drop (lengthFL n1') n1'n2'nons-                Just a1'nop2 = (a2 ++ n2nons) `minus` (p1' : n1'nons)-                Just a2'o =-                    fst (allConflictsWith p2 $ a2_minus_p1 ++ n2nons)-                    `minus` n2'nons-                Just a2' =-                    mapM (commuteOrRemFromCtxFL (xx2patches a1'nop2 n1')) a2'o-                Just p2' = commuteOrRemFromCtxFL (xx2patches a1'nop2 n1') p2-            case (a2', n2', p2') of-                ([], NilFL, Non c x) ->-                    case joinEffects c of-                        NilFL -> let n1'x = n1' +>+ x :>: NilFL in-                                 Just (Normal x :> Conflictor a1'nop2 n1'x p1')-                        _ -> impossible-                _ -> Just (c1 :> c2)-                  where-                    c1 = Conflictor a2' n2' p2'-                    c2 = Conflictor (p2 : a1'nop2) n1' p1'--        where (_, rpn2) = geteff a2 n2-              p1' = commuteOrAddToCtxRL (reverseFL rpn2) p1+-- | Commute conflicting patches, i.e. one of them is the result of a+-- conflicted 'merge' with the other.+commuteConflicting :: PrimPatch prim+                   => CommuteFn (RepoPatchV2 prim) (RepoPatchV2 prim)+commuteConflicting (Normal x :> Conflictor a1'nop2 n1'x p1')+    | Just rn1' <- removeRL x (reverseFL n1'x) = do+        let p2 : n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (rn1' :<: x)+            a2 = p1' : a1'nop2 ++ n1nons+        case (a1'nop2, reverseRL rn1', p1') of+            ([], NilFL, Non c y) | NilFL <- joinEffects c ->+                Just (Normal y :> Conflictor a1'nop2 (y :>: NilFL) p2)+            (a1, n1, _) ->+                Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)+commuteConflicting c@(InvConflictor{} :> Normal _) = invertCommuteC c+commuteConflicting (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)+    | Just a2_minus_p1 <- remove1 p1' a2+    , not (p2 `dependsUpon` p1') = do+        let n1nons = map (commutePrimsOrAddToCtx n2) $ xx2nons a1 n1+            n2nons = xx2nons a2 n2+            Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons+            n2n1 = n2 +>+ n1+            a1' = map (commutePrimsOrAddToCtx n2) a1+            p2ooo = remNons a1' p2+        n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1+        let n1'n2'nons = xx2nons a2_minus_p1n1 (n1' +>+ n2')+            n1'nons = take (lengthFL n1') n1'n2'nons+            n2'nons = drop (lengthFL n1') n1'n2'nons+            Just a1'nop2 = (a2 ++ n2nons) `minus` (p1' : n1'nons)+            Just a2'o =+                fst (allConflictsWith p2 $ a2_minus_p1 ++ n2nons)+                `minus` n2'nons+            Just a2' =+                mapM (commuteOrRemFromCtxFL (xx2patches a1'nop2 n1')) a2'o+            Just p2' = commuteOrRemFromCtxFL (xx2patches a1'nop2 n1') p2+        case (a2', n2', p2') of+            ([], NilFL, Non c x) ->+                case joinEffects c of+                    NilFL -> let n1'x = n1' +>+ x :>: NilFL in+                             Just (Normal x :> Conflictor a1'nop2 n1'x p1')+                    _ -> error "impossible case"+            _ -> Just (c1 :> c2)+              where+                c1 = Conflictor a2' n2' p2'+                c2 = Conflictor (p2 : a1'nop2) n1' p1'+    where (_, rpn2) = geteff a2 n2+          p1' = commuteOrAddToCtxRL (reverseFL rpn2) p1+commuteConflicting c@(InvConflictor{} :> InvConflictor{}) = invertCommuteC c+commuteConflicting _ = Nothing -    -- Handle using the inverting commuter, and the previous case. This is also-    -- innefficient, since we'll have to also try commuteNoConflicts again-    -- (which we know will fail, since we got here).-    commute c@(InvConflictor{} :> InvConflictor{}) = invertCommute c+instance PrimPatch prim => Commute (RepoPatchV2 prim) where+    commute pair@(x :> y) =+      commuteNoConflicts (assertConsistent x :> assertConsistent y)+      `mplus`+      commuteConflicting pair -    commute _ = Nothing+instance PrimPatch prim => CleanMerge (RepoPatchV2 prim) where+    cleanMerge = mergeNoConflicts  instance PrimPatch prim => Merge (RepoPatchV2 prim) where-    merge (InvConflictor{} :\/: _) = impossible-    merge (_ :\/: InvConflictor{}) = impossible-    merge (Etacilpud _ :\/: _) = impossible-    merge (_ :\/: Etacilpud _) = impossible+    merge (InvConflictor{} :\/: _) = error "impossible case"+    merge (_ :\/: InvConflictor{}) = error "impossible case"+    merge (Etacilpud _ :\/: _) = error "impossible case"+    merge (_ :\/: Etacilpud _) = error "impossible case"       merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a@@ -639,9 +659,9 @@     merge m@(_ :\/: Duplicate _) = swapMerge m      merge (x :\/: y)-        -- First try the natural (non-conflicting) merge.+        -- First try the non-conflicting merge.         | Just (y' :/\: x') <--            naturalMerge ((assertConsistent x) :\/: (assertConsistent y))+            mergeNoConflicts ((assertConsistent x) :\/: (assertConsistent y))               = assertConsistent y' :/\: assertConsistent x'         -- If we detect equal patches, we have a duplicate.         | IsEq <- x =\/= y@@ -695,7 +715,7 @@                             c1 = Conflictor (x' : ixy' ++ nxx') yy' y'                             c2 = Conflictor (y' : ixy' ++ nyy') xx' x' in                             c1 :/\: c2-                    Nothing -> impossible+                    Nothing -> error "impossible case"  instance PatchInspect prim => PatchInspect (RepoPatchV2 prim) where     listTouchedFiles (Duplicate p) = nonTouches p@@ -714,6 +734,8 @@     hunkMatches f (InvConflictor x c p) =         any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p +-- | Split the rhs into those that /transitively/ conflict with the+-- lhs and those that don't. allConflictsWith :: PrimPatch prim => Non (RepoPatchV2 prim) wX                  -> [Non (RepoPatchV2 prim) wX]                  -> ([Non (RepoPatchV2 prim) wX], [Non (RepoPatchV2 prim) wX])@@ -730,16 +752,16 @@ conflictsWith x (Non cy y) =     case commuteOrRemFromCtxFL cy x of         Just (Non cx' x') ->-            let iy = fromPrim $ invert y in-            case commuteFLorComplain (iy :> cx' +>+ fromPrim x' :>: NilFL) of-                Right _ -> False-                Left _ -> True+            let iy = Normal $ invert y in+            case commuteFL (iy :> cx' +>+ Normal x' :>: NilFL) of+                Just _ -> False+                Nothing -> True         Nothing -> True  dependsUpon :: PrimPatch prim => Non (RepoPatchV2 prim) wX             -> Non (RepoPatchV2 prim) wX -> Bool dependsUpon (Non xs _) (Non ys y) =-    case removeSubsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of+    case removeSubsequenceFL (ys +>+ Normal y :>: NilFL) xs of         Just _ -> True         Nothing -> False @@ -749,38 +771,28 @@ (x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys)                | otherwise = x : (xs +++ xys) -swapMerge :: Merge p => (p :\/: p) wX wY-          -> (p :/\: p) wX wY-swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x'--invertCommute :: (Invert p, Commute p) => (p :> p) wX wY-              -> Maybe ((p :> p) wX wY)-invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x)-                            return (invert iy' :> invert ix')+invertCommuteC :: PrimPatch prim => CommuteFn (RepoPatchV2 prim) (RepoPatchV2 prim)+invertCommuteC = invertCommuter commuteConflicting -invertCommuteNC :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY-                -> Maybe ((RepoPatchV2 prim :> RepoPatchV2 prim) wX wY)-invertCommuteNC (x :> y) = do-    ix' :> iy' <- commuteNoConflicts (invert y :> invert x)-    return (invert iy' :> invert ix')+invertCommuteNC :: PrimPatch prim => CommuteFn (RepoPatchV2 prim) (RepoPatchV2 prim)+invertCommuteNC = invertCommuter commuteNoConflicts  -- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted out -- of both @xs@ and @ys@ along with the remnants of both lists pullCommon :: (Commute p, Eq2 p) => FL p wO wX -> FL p wO wY -> Common p wO wX wY-pullCommon NilFL ys = Common NilFL NilFL ys-pullCommon xs NilFL = Common NilFL xs NilFL+pullCommon NilFL ys = Fork NilFL NilFL ys+pullCommon xs NilFL = Fork NilFL xs NilFL pullCommon (x :>: xs) xys | Just ys <- removeFL x xys =     case pullCommon xs ys of-        Common c xs' ys' -> Common (x :>: c) xs' ys'+        Fork c xs' ys' -> Fork (x :>: c) xs' ys' pullCommon (x :>: xs) ys =     case commuteWhatWeCanFL (x :> xs) of         xs1 :> x' :> xs2 -> case pullCommon xs1 ys of-            Common c xs1' ys' -> Common c (xs1' +>+ x' :>: xs2) ys'+            Fork c xs1' ys' -> Fork c (xs1' +>+ x' :>: xs2) ys'  -- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in -- common, in other words @cs +>+ xs@ and @cs +>+ ys@-data Common p wO wX wY where-    Common :: FL p wO wI -> FL p wI wX -> FL p wI wY -> Common p wO wX wY+type Common p wO wX wY = Fork (FL p) (FL p) (FL p) wO wX wY  -- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted --   out of both @xs@ and @ys@ along with the remnants of both lists@@ -803,16 +815,13 @@  instance PrimPatch prim => Apply (RepoPatchV2 prim) where     type ApplyState (RepoPatchV2 prim) = ApplyState prim-    apply p = apply (effect p)+    apply p = applyPrimFL (effect p)  instance PrimPatch prim => RepairToFL (RepoPatchV2 prim) where     applyAndTryToFixFL (Normal p) =         mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p     applyAndTryToFixFL x = do apply x; return Nothing -instance (PrimPatch prim, Annotate prim) => Annotate (RepoPatchV2 prim) where-    annotate = annotate . effect- instance PatchListFormat (RepoPatchV2 prim) where    -- In principle we could use ListFormatDefault when prim /= V1 Prim patches,    -- as those are the only case where we need to support a legacy on-disk@@ -901,11 +910,9 @@             showString " " . showsPrec (appPrec + 1) xx .             showString " " . showsPrec (appPrec + 1) x -instance Show2 prim => Show1 (RepoPatchV2 prim wX) where-    showDict1 = ShowDictClass+instance Show2 prim => Show1 (RepoPatchV2 prim wX) -instance Show2 prim => Show2 (RepoPatchV2 prim) where-    showDict2 = ShowDictClass+instance Show2 prim => Show2 (RepoPatchV2 prim)  instance PrimPatch prim => Nonable (RepoPatchV2 prim) where     non (Duplicate d) = d@@ -920,11 +927,6 @@     effect (Normal p) = p :>: NilFL     effect (Conflictor _ e _) = invert e     effect (InvConflictor _ e _) = e-    effectRL (Duplicate _) = NilRL-    effectRL (Etacilpud _) = NilRL-    effectRL (Normal p) = NilRL :<: p-    effectRL (Conflictor _ e _) = invertFL e-    effectRL (InvConflictor _ e _) = reverseFL e  instance IsHunk prim => IsHunk (RepoPatchV2 prim) where     isHunk rp = do Normal p <- return rp
+ src/Darcs/Patch/V3.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.V3 ( RepoPatchV3 ) where++import Darcs.Prelude++import Darcs.Patch.Annotate ()+import Darcs.Patch.FromPrim ( FromPrim(..) )+import Darcs.Patch.Prim.Named+  ( PrimPatchId+  , anonymousNamedPrim, namedPrim, positivePrimPatchIds+  )+import Darcs.Patch.Witnesses.Ordered ( FL(..) )+import qualified Darcs.Patch.V3.Core as Core ( RepoPatchV3(..) )+import Darcs.Patch.V3.Resolution ()++type RepoPatchV3 = Core.RepoPatchV3 PrimPatchId++-- This instance is specialised to PrimPatchId because it is dependent+-- on the relationship between PatchInfo and PrimPatchId+instance FromPrim (RepoPatchV3 prim) where+  fromAnonymousPrim = Core.Prim . anonymousNamedPrim+  fromPrim pid p = Core.Prim (namedPrim pid p)+  fromPrims = go . positivePrimPatchIds+    where+      go :: [PrimPatchId] -> FL prim wX wY -> FL (RepoPatchV3 prim) wX wY+      go _ NilFL = NilFL+      go (pid:pids) (p:>:ps) = fromPrim pid p :>: go pids ps+      go [] _ = error "positivePrimPatchIds should return an infinite list"
+ src/Darcs/Patch/V3/Contexted.hs view
@@ -0,0 +1,252 @@+-- | 'Contexted' patches.++{-# LANGUAGE ViewPatterns #-}+module Darcs.Patch.V3.Contexted+    ( -- * Contexted patches+      Contexted+      -- * Query+    , ctxId+    , ctxView+    , ctxNoConflict+    , ctxToFL+      -- * Construct+    , ctx+    , ctxAdd+    , ctxAddRL+    , ctxAddInvFL+    , ctxAddFL+    , commutePast+    , commutePastRL+      -- * 'PatchInspect' helpers+    , ctxTouches+    , ctxHunkMatches+      -- * 'ReadPatch' and 'ShowPatch' helpers+    , showCtx+    , readCtx+      -- * Properties+    , prop_ctxInvariants+    , prop_ctxEq+    , prop_ctxPositive+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC ( pack )+import Data.Maybe ( isNothing, isJust )++import Darcs.Prelude++import Darcs.Patch.Commute+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Ident+import Darcs.Patch.Invert+import Darcs.Patch.Inspect+import Darcs.Patch.Merge ( CleanMerge(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Util.Parser ( Parser, lexString )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor )+import Darcs.Patch.Viewing ()+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show++import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Printer++{-+| (Definition 10.1) A 'Contexted' patch is a patch transferred to, or viewed+from, a different context.++More precisely we make the following definitions:++* A /context/ for a patch @p@ is a sequence of patches that @p@ depends on,+  and such that it never contains a patch and its inverse.++* A 'Contexted' patch is a patch @p@ together with a context for @p@, such+  that the end state of the patch and its context is hidden (existentially+  quantified).++The definition of context above is chosen so that this sequence is minimal.+-}+data Contexted p wX where+  Contexted :: FL p wX wY -> p wY wZ -> Contexted p wX++-- | Equality between 'Contexted' patches reduces to equality of the+-- identifiers of the patches referred to /if/ we look at them from the same+-- context. (This assumes witnesses aren't coerced in an unsafe manner.)+instance Ident p => Eq (Contexted p wX) where+  c1 == c2 = ctxId c1 == ctxId c2+{-+-- 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++instance Show2 p => Show (Contexted p wX) where+  showsPrec d (Contexted ps p) =+    showParen (d > appPrec) $ showString "Contexted " .+    showsPrec2 (appPrec + 1) ps . showString " " .+    showsPrec2 (appPrec + 1) p++instance Show2 p => Show1 (Contexted p)++-- | This property states that no prefix of the context commutes with the rest+-- of the 'Contexted' patch and that the context never contains a patch+-- and its inverse.+prop_ctxInvariants :: (Commute p, Invert p, SignedIdent p) => Contexted p wX -> Bool+prop_ctxInvariants (Contexted NilFL _) = True+prop_ctxInvariants c@(Contexted (_ :>: ps) q) =+  prop_ctxInvariants (Contexted ps q) && prop_ctxNotCom c && prop_ctxNotInv c++-- | This property states that the first patch in the context must not+-- commute with the rest of the 'Contexted' patch.+prop_ctxNotCom :: Commute p => Contexted p wX -> Bool+prop_ctxNotCom (Contexted NilFL _) = True+prop_ctxNotCom (Contexted (p :>: ps) q) =+  isNothing $ commuteFL (p :> ps +>+ q :>: NilFL)++-- | This property states that patches in the context of a 'Contexted' patch as+-- well as the patch itself are positive. It does /not/ necessarily hold for all+-- 'Contexted' patches.+prop_ctxPositive :: SignedIdent p => Contexted p wX -> Bool+prop_ctxPositive (Contexted ps p) =+  allFL (positiveId . ident) ps && positiveId (ident p)++-- | This property states that the inverse of the first patch in the context+-- is not contained in the rest of the context.+prop_ctxNotInv :: SignedIdent p => Contexted p wX -> Bool+prop_ctxNotInv (Contexted NilFL _) = True+prop_ctxNotInv (Contexted (p :>: ps) _) =+  invertId (ident p) `notElem` mapFL ident ps++-- This property states that equal 'Contexted' patches have equal content.+prop_ctxEq :: (Commute p, Eq2 p, Ident p) => Contexted p wX -> Contexted p wX -> Bool+prop_ctxEq cp@(Contexted ps p) cq@(Contexted qs q)+  | cp == cq =+      case ps =\/= qs of+        IsEq -> isIsEq (p =\/= q)+        NotEq -> False+prop_ctxEq _ _ = True++-- * Query++-- | Identity of a contexted patch.+{-# INLINE ctxId #-}+ctxId :: Ident p => Contexted p wX -> PatchId p+ctxId (Contexted _ p) = ident p++-- | 'Contexted' patches conflict with each other if the identity of one is in+-- the context of the other or they cannot be merged cleanly.+ctxNoConflict :: (CleanMerge p, Commute p, Ident p)+              => Contexted p wX -> Contexted p wX -> Bool+ctxNoConflict cp cq | cp == cq = True+ctxNoConflict (Contexted ps p) (Contexted qs q)+  | ident p `elem` mapFL ident qs || ident q `elem` mapFL ident ps = False+  | otherwise =+      case findCommonFL ps qs of+        Fork _ ps' qs' ->+          isJust $ cleanMerge (ps' +>+ p :>: NilFL :\/: qs' +>+ q :>: NilFL)++{-+-- This is (Definition 10.4) of the paper.+-- It misses a case for equal contexted patches and is also quite slow.+ctxNoConflict (Contexted cs p) cq =+  isJust $ commutePast (invert p) (ctxAddInvFL cs cq)+-}++-- | We sometimes want to pattern match on a 'Contexted' patch but still guard+-- against violation of teh invariants. So we export a view that is isomorphic+-- to the 'Contexted' type but doesn't allow to manipulate the internals.+ctxView :: Contexted p wX -> Sealed ((FL p :> p) wX)+ctxView (Contexted cs p) = Sealed (cs :> p)++-- | Convert a 'Contexted' patch into a plain 'FL' with the patch at the end.+ctxToFL :: Contexted p wX -> Sealed (FL p wX)+ctxToFL (ctxView -> Sealed (ps :> p)) = Sealed (ps +>+ p :>: NilFL)++-- * Construct++-- | A 'Contexted' patch with empty context.+ctx :: p wX wY -> Contexted p wX+ctx p = Contexted NilFL p++-- | Add a patch to the context of a 'Contexted' patch. This is+-- the place where we take care of the invariants.+ctxAdd :: (Commute p, Invert p, Ident p)+       => p wX wY -> Contexted p wY -> Contexted p wX+ctxAdd p (Contexted ps q)+  | Just ps' <- fastRemoveFL (invert p) ps = Contexted ps' q+ctxAdd p c@(Contexted ps q) =+  case commutePast p c of+    Just c' -> c'+    Nothing -> Contexted (p :>: ps) q++-- | Add an 'RL' of patches to the context.+ctxAddRL :: (Commute p, Invert p, Ident p)+         => RL p wX wY -> Contexted p wY -> Contexted p wX+ctxAddRL NilRL cp = cp+ctxAddRL (ps :<: p) cp = ctxAddRL ps (ctxAdd p cp)++-- | Add an 'FL' of patches to the context but invert it first.+ctxAddInvFL :: (Commute p, Invert p, Ident p)+            => FL p wX wY -> Contexted p wX -> Contexted p wY+ctxAddInvFL = ctxAddRL . invertFL++-- | Add an 'FL' of patches to the context.+ctxAddFL :: (Commute p, Invert p, Ident p)+         => FL p wX wY -> Contexted p wY -> Contexted p wX+ctxAddFL NilFL t = t+ctxAddFL (p :>: ps) t = ctxAdd p (ctxAddFL ps t)++-- | (Definition 10.2) Commute a patch past a 'Contexted' patch. This+-- commutes it past the context and then past the patch itself. If it+-- succeeds, the patch that we commuted past gets dropped.+-- Note that this does /not/ succeed if the inverted patch is in the+-- 'Contexted' patch.+commutePast :: Commute p+            => p wX wY -> Contexted p wY -> Maybe (Contexted p wX)+commutePast q (Contexted ps p) = do+  ps' :> q' <- commuteFL (q :> ps)+  p' :> _ <- commute (q' :> p)+  return (Contexted ps' p')++-- | Not defined in the paper but used in the commute algorithm.+commutePastRL :: Commute p+              => RL p wX wY -> Contexted p wY -> Maybe (Contexted p wX)+commutePastRL = foldRL_M commutePast++-- * 'PatchInspect' helpers++ctxTouches :: PatchInspect p => Contexted p wX -> [AnchoredPath]+ctxTouches (Contexted ps p) =+  concat $ listTouchedFiles p : mapFL listTouchedFiles ps++ctxHunkMatches :: PatchInspect p => (B.ByteString -> Bool)+               -> Contexted p wX -> Bool+ctxHunkMatches f (Contexted ps p) = hunkMatches f ps || hunkMatches f p++-- * 'ReadPatch' and 'ShowPatch' helpers++-- For storage it would be enough to read/write the patch identifiers in the+-- context. But this means that we need access to the patches preceding us.+-- So these functions would no longer be independent of context.++showCtx :: (ShowPatchBasic p, PatchListFormat p)+        => ShowPatchFor -> Contexted p wX -> Doc+showCtx f (Contexted c p) =+  hiddenPrefix "|" (showPatch f c) $$ hiddenPrefix "|" (blueText ":") $$ showPatch f p++readCtx :: (ReadPatch p, PatchListFormat p)+        => Parser (Contexted p wX)+readCtx = do+  Sealed ps <- readPatch'+  lexString (BC.pack ":")+  Sealed p <- readPatch'+  return $ Contexted ps p
+ src/Darcs/Patch/V3/Core.hs view
@@ -0,0 +1,519 @@+{- | 'Conflictor's a la camp.++Similar to the camp paper, but with a few differences:++* no reverse conflictors and no Invert instance++* instead we directly implement cleanMerge++* minor details of merge and commute due to bug fixes++-}++{-# LANGUAGE ViewPatterns, PatternSynonyms #-}+module Darcs.Patch.V3.Core+    ( RepoPatchV3(..)+    , pattern PrimP+    , pattern ConflictorP+    , (+|)+    , (-|)+    ) where++import Control.Applicative ( Alternative(..) )+import Control.Monad ( guard )+import qualified Data.ByteString.Char8 as BC+import Data.List.Ordered ( nubSort )+import qualified Data.Set as S++import Darcs.Prelude++import Darcs.Patch.Commute ( commuteFL, commuteRL, commuteRLFL )+import Darcs.Patch.CommuteFn ( CommuteFn )+import Darcs.Patch.CommuteNoConflicts ( CommuteNoConflicts(..) )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( ListFormat(ListFormatV3) )+import Darcs.Patch.FromPrim ( ToPrim(..) )+import Darcs.Patch.Ident+    ( Ident(..)+    , IdEq2(..)+    , PatchId+    , SignedId(..)+    , StorableId(..)+    , commuteToPrefix+    , fastRemoveFL+    , findCommonFL+    )+import Darcs.Patch.Invert ( Invert, invert, invertFL )+import Darcs.Patch.Merge+    ( CleanMerge(..)+    , Merge(..)+    , cleanMergeFL+    , swapCleanMerge+    , swapMerge+    )+import Darcs.Patch.Prim ( PrimPatch, applyPrimFL )+import Darcs.Patch.Prim.WithName ( PrimWithName, wnPatch )+import Darcs.Patch.Read ( bracketedFL )+import Darcs.Patch.Repair (RepairToFL(..), Check(..) )+import Darcs.Patch.RepoPatch+    ( Apply(..)+    , Commute(..)+    , Effect(..)+    , Eq2(..)+    , PatchInspect(..)+    , PatchListFormat(..)+    , PrimPatchBase(..)+    , ReadPatch(..)+    , Summary(..)+    )+import Darcs.Patch.Show hiding ( displayPatch )+import Darcs.Patch.Summary+    ( ConflictState(..)+    , IsConflictedPrim(..)+    , plainSummary+    , plainSummaryFL+    )+import Darcs.Patch.Unwind ( Unwind(..), mkUnwound )+import Darcs.Patch.V3.Contexted+    ( Contexted+    , ctxId+    , ctxView+    , ctxNoConflict+    , ctx+    , ctxAddRL+    , ctxAddInvFL+    , ctxAddFL+    , commutePast+    , commutePastRL+    , ctxTouches+    , ctxHunkMatches+    , showCtx+    , readCtx+    )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( (:/\:)(..)+    , (:>)(..)+    , (:\/:)(..)+    , FL(..)+    , Fork(..)+    , (+>+)+    , mapFL+    , mapFL_FL+    , reverseFL+    , reverseRL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP1 )++import Darcs.Test.TestOnly++import Darcs.Util.Parser ( string, lexString, choice, skipSpace )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , (<+>)+    , blueText+    , redText+    , renderString+    , vcat+    )++data RepoPatchV3 name prim wX wY where+  Prim :: PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY+  Conflictor :: FL (PrimWithName name prim) wX wY             -- ^ effect+             -> S.Set (Contexted (PrimWithName name prim) wY) -- ^ conflicts+             -> Contexted (PrimWithName name prim) wY         -- ^ identity+             -> RepoPatchV3 name prim wX wY++{- Naming convention: If we don't examine the contents of a RepoPatchV3, we+use @p@ (on the lhs) and @q@ (on the rhs), otherwise these names refer to+the (uncontexted) prims they represent (regardless of whether they are+conflicted or not). The components of Conflictors are named as follows: On+the lhs we use @Conflictor r x cp@, on the rhs @Conflictor s y cq@, execpt+when we have two conflictors that may have common prims in their effects. In+that case we use @com_r@ and @com_s@ for the effects and use @r@ and @s@ for+the uncommon parts (and @com@ for the common part). Primed versions always+refer to things with the same ident/name i.e. they are commuted versions of+the un-primed ones. -}++-- TODO now that we export the constructors of RepoPatchV3 these+-- pattern synonyms could probably be removed+pattern PrimP :: TestOnly => PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY+pattern PrimP prim <- Prim prim++pattern ConflictorP+  :: TestOnly+  => FL (PrimWithName name prim) wX wY+  -> S.Set (Contexted (PrimWithName name prim) wY)+  -> Contexted (PrimWithName name prim) wY+  -> RepoPatchV3 name prim wX wY+pattern ConflictorP r x cp <- Conflictor r x cp++-- * Effect++instance Effect (RepoPatchV3 name prim) where+  effect (Prim p) = wnPatch p :>: NilFL+  effect (Conflictor r _ _) = mapFL_FL wnPatch r++-- * Ident++type instance PatchId (RepoPatchV3 name prim) = name++instance SignedId name => Ident (RepoPatchV3 name prim) where+  ident (Prim p) = ident p+  ident (Conflictor _ _ cp) = ctxId cp++-- * Merge++-- We only use displayPatch for error messages here, so it makes sense+-- to use the storage format that contains the patch names.+displayPatch :: ShowPatchBasic p => p wX wY -> Doc+displayPatch p = showPatch ForStorage p++instance (SignedId name, StorableId name, PrimPatch prim) =>+         CleanMerge (RepoPatchV3 name prim) where+  cleanMerge (p :\/: q)+    | ident p == ident q = error "merging identical patches is undefined"+  cleanMerge (Prim p :\/: Prim q) = do+    q' :/\: p' <- cleanMerge (p :\/: q)+    return $ Prim q' :/\: Prim p'+  cleanMerge (Prim p :\/: Conflictor s y cq) = do+    -- note: p cannot occur in y, because every element of y already+    -- exists in the history /before/ the rhs, and PatchIds must be+    -- unique in a repo+    s' :/\: p' <- cleanMergeFL (p :\/: s)+    let ip' = invert p'+    cq' <- commutePast ip' cq+    y' <- S.fromList <$> mapM (commutePast ip') (S.toList y)+    return $ Conflictor s' y' cq' :/\: Prim p'+  cleanMerge pair@(Conflictor {} :\/: Prim {}) = swapCleanMerge pair+  cleanMerge (Conflictor com_r x cp :\/: Conflictor com_s y cq) =+    case findCommonFL com_r com_s of+      Fork _ rev_r rev_s -> do+        s' :/\: r' <- cleanMerge (rev_r :\/: rev_s)+        -- the paper uses commutePast to calculate cp' and cq', but this must+        -- succeed (and then give the same result as adding to the context)+        -- because of the ctxNoConflict guards below+        let cp' = ctxAddInvFL s' cp+        let cq' = ctxAddInvFL r' cq+        let x' = S.map (ctxAddInvFL s') x+        let y' = S.map (ctxAddInvFL r') y+        guard (ctxNoConflict cq' cp')+        guard $ all (ctxNoConflict cq') (S.difference x' y')+        guard $ all (ctxNoConflict cp') (S.difference y' x')+        return $ Conflictor s' y' cq' :/\: Conflictor r' x' cp'++instance (SignedId name, StorableId name, PrimPatch prim) =>+         Merge (RepoPatchV3 name prim) where+  -- * no conflict+  merge pq | Just r <- cleanMerge pq = r+  -- * conflicting prim patches:+  -- If we have p and pull conflicting q, we make a conflictor+  -- that inverts p, conflicts with p, and represents q.+  merge (Prim p :\/: Prim q) =+    Conflictor (invert p :>: NilFL) (S.singleton (ctx p)) (ctx q)+    :/\:+    Conflictor (invert q :>: NilFL) (S.singleton (ctx q)) (ctx p)+  -- * prim patch p conflicting with conflictor on the rhs:+  -- The rhs is the first to conflict with p, so must we add invert p+  -- to its effect, and to its conflicts (adding invert r as context for p).+  -- For the other branch, we add a new conflictor representing p. It+  -- conflicts with q and has no effect, since q is already conflicted.+  merge (Prim p :\/: Conflictor r x cq) =+    Conflictor (invert p :>: r) (ctxAddInvFL r (ctx p) +| x) cq+    :/\:+    Conflictor NilFL (S.singleton cq) (ctxAddInvFL r (ctx p))+  -- same as previous case with both sides swapped+  merge pair@(Conflictor {} :\/: Prim {}) = swapMerge pair+  -- * conflictor c1 conflicts with conflictor c2:+  -- If we pull c2 onto c1, we remove everything common to both effects+  -- from the effect of c2 (but still remember that we conflict with them).+  -- We also record that we now conflict with c1, too, and as before keep+  -- our identity unchanged. The rest consists of adapting contexts.+  --+  -- 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 ->+        case cleanMerge (r :\/: s) of+          Just (s' :/\: r') ->+            let cp' = ctxAddInvFL s' cp+                cq' = ctxAddInvFL r' cq+                x' = cq' +| S.map (ctxAddInvFL s') x+                y' = cp' +| S.map (ctxAddInvFL r') y+            in Conflictor s' y' cq' :/\: Conflictor r' x' cp'+          Nothing ->+            error $ renderString $ redText "uncommon effects can't be merged cleanly:"+              $$ redText "lhs:" $$ displayPatch lhs+              $$ redText "rhs:" $$ displayPatch rhs+              $$ redText "r:" $$ displayPatch r+              $$ redText "s:" $$ displayPatch s++-- * CommuteNoConflicts++instance (SignedId name, StorableId name, PrimPatch prim)+  => CommuteNoConflicts (RepoPatchV3 name prim) where++  -- 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+  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 :> 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++-- * Commute++-- commuting a conflicted merge; these cases follow directly from merge+commuteConflicting+  :: (SignedId name, StorableId name, PrimPatch prim)+  => CommuteFn (RepoPatchV3 name prim) (RepoPatchV3 name prim)+-- if we have a prim and a conflictor that only conflicts with that prim,+-- they trade places+-- [p] :> [p^, {:p}, :q] <-> [q] :> [q^, {:q}, :p]+commuteConflicting (Prim p :> Conflictor (ip:>:NilFL) ys cq@(ctxView -> Sealed (NilFL :> q)))+  | [ctxView -> Sealed (NilFL :> p')] <- S.toList ys+  , IsEq <- invert p =\/= ip+  , IsEq <- p =\/= p' =+      Just (Prim q :> Conflictor (invert q :>: NilFL) (S.singleton cq) (ctx p))+-- similar to above case: a prim and a conflictor that conflicts with the prim+-- but also conflicts with other patches+-- [p] :> [p^ s, {s^:p} U Y, cq] <-> [s, Y, cq] :> [, {cq}, s^:p]+commuteConflicting (Prim p :> Conflictor s y cq)+  | ident p `S.member` S.map ctxId y =+      case fastRemoveFL (invert p) s of+        Nothing ->+          error $ renderString $ redText "commuteConflicting: cannot remove (invert lhs):"+            $$ displayPatch (invert p)+            $$ redText "from effect of rhs:"+            $$ displayPatch s+        Just r ->+          let cp = ctxAddInvFL r (ctx p)+          in Just (Conflictor r (cp -| y) cq :> Conflictor NilFL (S.singleton cq) cp)+-- if we have two conflictors where the rhs conflicts /only/ with the lhs,+-- the latter becomes a prim patch+-- [r, X, cp] [, {cp}, r^:q] <-> [q] [q^r, {r^:q} U X, cp]+commuteConflicting (lhs@(Conflictor r x cp) :> rhs@(Conflictor NilFL y cq))+  | y == S.singleton cp =+      case ctxView (ctxAddFL r cq) of+        Sealed (NilFL :> cq') ->+          Just $+            Prim cq'+            :>+            Conflictor (invert cq' :>: r) (cq +| x) cp+        Sealed (c' :> _) ->+          error $ renderString $ redText "remaining context in commute:"+            $$ displayPatch c'+            $$ redText "lhs:" $$ displayPatch lhs+            $$ redText "rhs:" $$ displayPatch rhs+-- conflicting conflictors where the rhs conflicts with lhs but+-- also conflicts with other patches+-- [com r, X, cp] [s, y=({s^cp} U Y'), cq] <-> [com s', r'Y', r'cq] [r', {cq} U s^X, s^cp]+commuteConflicting (Conflictor com_r x cp :> Conflictor s y cq)+  | let is_cp = ctxAddInvFL s cp+  , is_cp `S.member` y+  , let y' = is_cp -| y =+      case commuteToPrefix (S.map (invertId . ctxId) y') com_r of+        Nothing -> error "commuteConflicting: cannot commute common effects"+        Just (com :> rr) ->+          case commuteRLFL (rr :> s) of+            Nothing -> error "commuteConflicting: cannot commute uncommon effects"+            Just (s' :> rr') ->+              Just $+                Conflictor (com +>+ s')+                  (S.map (ctxAddRL rr') y')+                  (ctxAddRL rr' cq)+                :>+                Conflictor (reverseRL rr')+                  (cq +| S.map (ctxAddInvFL s) x)+                  is_cp+commuteConflicting _ = Nothing++instance (SignedId name, StorableId name, PrimPatch prim) =>+         Commute (RepoPatchV3 name prim) where+  commute pair = commuteConflicting pair <|> commuteNoConflicts pair++-- * PatchInspect++-- Note: in contrast to RepoPatchV2 we do not look at the list of conflicts+-- here. I see no reason why we should: the conflicts are only needed for the+-- instance Commute. We do however look at the patches that we undo.+instance PatchInspect prim => PatchInspect (RepoPatchV3 name prim) where+  listTouchedFiles (Prim p) = listTouchedFiles p+  listTouchedFiles (Conflictor r _ cp) =+    nubSort $ concat (mapFL listTouchedFiles r) ++ ctxTouches cp+  hunkMatches f (Prim p) = hunkMatches f p+  hunkMatches f (Conflictor r _ cp) = hunkMatches f r || ctxHunkMatches f cp++-- * Boilerplate instances++instance (SignedId name, Eq2 prim, Commute prim) => Eq2 (RepoPatchV3 name prim) where+    (Prim p) =\/= (Prim q) = p =\/= q+    (Conflictor r x cp) =\/= (Conflictor s y cq)+        | IsEq <- r =\^/= s -- more efficient than IsEq <- r =\/= s+        , x == y+        , cp == cq = IsEq+    _ =\/= _ = NotEq++instance (Show name, Show2 prim) => Show (RepoPatchV3 name prim wX wY) where+  showsPrec d rp = showParen (d > appPrec) $+    case rp of+      Prim prim ->+        showString "Prim " . showsPrec2 (appPrec + 1) prim+      Conflictor r x cp -> showString "Conflictor " . showContent r x cp+    where+      showContent r x cp =+        showsPrec (appPrec + 1) r .+          showString " " . showsPrec (appPrec + 1) x .+          showString " " . showsPrec (appPrec + 1) cp++instance (Show name, Show2 prim) => Show1 (RepoPatchV3 name prim wX)++instance (Show name, Show2 prim) => Show2 (RepoPatchV3 name prim)++instance PrimPatch prim => PrimPatchBase (RepoPatchV3 name prim) where+  type PrimOf (RepoPatchV3 name prim) = prim++instance ToPrim (RepoPatchV3 name prim) where+  toPrim (Conflictor {}) = Nothing+  toPrim (Prim p) = Just (wnPatch p)++instance PatchDebug prim => PatchDebug (RepoPatchV3 name prim)++instance PrimPatch prim => Apply (RepoPatchV3 name prim) where+  type ApplyState (RepoPatchV3 name prim) = ApplyState prim+  apply = applyPrimFL . effect+  unapply = applyPrimFL . invert . effect++instance PatchListFormat (RepoPatchV3 name prim) where+  patchListFormat = ListFormatV3++instance IsHunk prim => IsHunk (RepoPatchV3 name prim) where+  isHunk rp = do+    Prim p <- return rp+    isHunk p++instance Summary (RepoPatchV3 name prim) where+  conflictedEffect (Conflictor _ _ (ctxView -> Sealed (_ :> p))) = [IsC Conflicted (wnPatch p)]+  conflictedEffect (Prim p) = [IsC Okay (wnPatch p)]++instance (Invert prim, Commute prim, Eq2 prim) => Unwind (RepoPatchV3 name prim) where+  fullUnwind (Prim p)+    = mkUnwound NilFL (wnPatch p :>: NilFL) NilFL+  fullUnwind+    (Conflictor+      (mapFL_FL wnPatch -> es)+      _+      (ctxView -> Sealed ((mapFL_FL wnPatch -> cs) :> (wnPatch -> i)))+    ) =+    mkUnwound+      (es +>+ cs)+      (i :>: NilFL)+      (invert i :>: invert cs +>+ NilFL)++-- * More boilerplate instances++instance PrimPatch prim => Check (RepoPatchV3 name prim)+  -- use the default implementation for method isInconsistent++instance PrimPatch prim => RepairToFL (RepoPatchV3 name prim)+  -- use the default implementation for method applyAndTryToFixFL++instance (SignedId name, StorableId name, PrimPatch prim)+  => ShowPatch (RepoPatchV3 name prim) where++  summary = plainSummary+  summaryFL = plainSummaryFL+  thing _ = "change"++instance (StorableId name, PrimPatch prim)+  => ShowContextPatch (RepoPatchV3 name prim) where++  showContextPatch f (Prim p) = showContextPatch f p+  showContextPatch f p = return $ showPatch f p++-- * Read and Write++instance (SignedId name, StorableId name, PrimPatch prim)+  => ReadPatch (RepoPatchV3 name prim) where++  readPatch' = do+    skipSpace+    choice+      [ do string (BC.pack "conflictor")+           (Sealed r, x, p) <- readContent+           return (Sealed (Conflictor r (S.map unsafeCoerceP1 x) (unsafeCoerceP1 p)))+      , do mapSeal Prim <$> readPatch'+      ]+    where+      readContent = do+        r <- bracketedFL readPatch' '[' ']'+        x <- readCtxSet+        p <- readCtx+        return (r, x, p)+      readCtxSet = (lexString (BC.pack "{{") >> go) <|> pure S.empty+        where+          go = (lexString (BC.pack "}}") >> pure S.empty) <|> S.insert <$> readCtx <*> go++instance (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+    where+      showContent r x cp = showEffect r <+> showCtxSet x $$ showCtx fmt cp+      showEffect NilFL = blueText "[]"+      showEffect ps = blueText "[" $$ vcat (mapFL (showPatch fmt) ps) $$ blueText "]"+      showCtxSet xs =+        case S.minView xs of+          Nothing -> mempty+          Just _ ->+            blueText "{{"+              $$ vcat (map (showCtx fmt) (S.toAscList xs))+              $$ blueText "}}"++-- * Local helper functions++infixr +|, -|++-- | A handy synonym for 'S.insert'.+(+|) :: Ord a => a -> S.Set a -> S.Set a+c +| cs = S.insert c cs++-- | A handy synonym for 'S.delete'.+(-|) :: Ord a => a -> S.Set a -> S.Set a+c -| cs = S.delete c cs
+ src/Darcs/Patch/V3/Resolution.hs view
@@ -0,0 +1,268 @@+{- | Conflict resolution for 'RepoPatchV3' -}+{-# 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 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.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.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++{- This gives an overview of the algorithm for marking conflicts.++The goal is to calculate the markup for a trailing RL of patches, usually+the ones we are going to add to our repo. But since in V3 we store only the+direct conflicts, not the transitive set, we also require the full context+of all previous patches. 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.++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.++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.++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.++Next we partition the graph into connected components, since these are what+makes up one transitive conflict.++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.++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. -}++instance (SignedId name, StorableId name, PrimPatch prim) =>+         Conflict (RepoPatchV3 name prim) where+  resolveConflicts context =+      resolveComponents . findEdges . findVertices 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++-- | 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)+  }++deriving instance (Show name, Show2 prim) => Show (Node 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.++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.++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.++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.)++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.++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.+-}++findVertices+  :: 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+  go :: S.Set name+     -> [Contexted (PrimWithName name prim) wY]+     -> 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)+    | 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)+    | otherwise =+        go (ident p -| check) done cs NilRL (p :>: passedby)+  go _ _ NilRL NilRL _ = error "autsch, hit the bottom"++  isConflicted Conflictor{} = True+  isConflicted Prim{} = False++  conflicts (Conflictor _ x _) = S.map ctxId 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++-- | 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.!)++-- 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++-- 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
src/Darcs/Patch/Viewing.hs view
@@ -21,12 +21,10 @@     ( showContextHunk     ) where -import Prelude ()-import Darcs.Prelude+import Darcs.Prelude hiding ( readFile )  import Control.Applicative( (<$>) ) import qualified Data.ByteString as B ( null )-import Prelude hiding ( pi, readFile ) import Darcs.Util.Tree ( Tree ) import Darcs.Util.Tree.Monad ( virtualTreeMonad ) @@ -80,8 +78,8 @@                 -> Maybe (FileHunk wC wD) -> m Doc coolContextHunk fmt prev fh@(FileHunk f l o n) next = do     have <- mDoesFileExist f-    content <- if have then Just `fmap` mReadFilePS f else return Nothing-    case linesPS `fmap` content of+    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 ->@@ -123,10 +121,11 @@                                             $$ blueText "}"         showPatchInternal ListFormatV2 ps = vcat (mapFL (showPatch ForStorage) ps)         showPatchInternal ListFormatDefault ps = vcat (mapFL (showPatch ForStorage) ps)+        showPatchInternal ListFormatV3 ps = vcat (mapFL (showPatch ForStorage) ps)  instance (Apply p, IsHunk p, PatchListFormat p, ShowContextPatch p)         => ShowContextPatch (FL p) where-    showContextPatch ForDisplay = showContextSeries ForDisplay UserFormat+    showContextPatch ForDisplay = showContextSeries ForDisplay FileNameFormatDisplay     showContextPatch ForStorage = showContextPatchInternal patchListFormat       where         showContextPatchInternal :: (ApplyMonad (ApplyState (FL p)) m)@@ -136,12 +135,15 @@         showContextPatchInternal ListFormatV1 NilFL =             return $ blueText "{" $$ blueText "}"         showContextPatchInternal ListFormatV1 ps = do-            x <- showContextSeries ForStorage OldFormat ps+            x <- showContextSeries ForStorage FileNameFormatV1 ps             return $ blueText "{" $$ x $$ blueText "}"-        showContextPatchInternal ListFormatV2 ps = showContextSeries ForStorage NewFormat ps-        showContextPatchInternal ListFormatDefault ps = showContextSeries ForStorage NewFormat ps+        showContextPatchInternal ListFormatV2 ps = showContextSeries ForStorage FileNameFormatV2 ps+        showContextPatchInternal ListFormatDefault ps = showContextSeries ForStorage FileNameFormatV2 ps+        showContextPatchInternal ListFormatV3 ps = return $ showPatch ForStorage ps  instance (PatchListFormat p, ShowPatch p) => ShowPatch (FL p) where+    content = vcat . mapFL content+     description = vcat . mapFL description      summary = summaryFL@@ -163,6 +165,8 @@     showContextPatch use = showContextPatch use . reverseRL  instance (PatchListFormat p, ShowPatch p) => ShowPatch (RL p) where+    content = content . reverseRL+     description = description . reverseRL      summary = summary . reverseRL
src/Darcs/Patch/Witnesses/Eq.hs view
@@ -4,7 +4,6 @@     , isIsEq     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
+ src/Darcs/Patch/Witnesses/Maybe.hs view
@@ -0,0 +1,23 @@+module Darcs.Patch.Witnesses.Maybe+  ( Maybe2(..)+  , maybeToFL, maybeToRL+  , mapMB_MB+  ) where++import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )++data Maybe2 p wX wY where+  Nothing2 :: Maybe2 p wX wX+  Just2 :: p wX wY -> Maybe2 p wX wY++maybeToFL :: Maybe2 p wX wY -> FL p wX wY+maybeToFL Nothing2 = NilFL+maybeToFL (Just2 v) = v :>: NilFL++maybeToRL :: Maybe2 p wX wY -> RL p wX wY+maybeToRL Nothing2 = NilRL+maybeToRL (Just2 v) = NilRL :<: v++mapMB_MB :: (p wX wY -> q wX wY) -> Maybe2 p wX wY -> Maybe2 q wX wY+mapMB_MB _ Nothing2 = Nothing2+mapMB_MB f (Just2 v) = Just2 (f v)
src/Darcs/Patch/Witnesses/Ordered.hs view
@@ -37,14 +37,18 @@     , mapRL     , mapFL_FL     , mapRL_RL-    , foldlFL+    , foldrFL     , foldlRL+    , foldrwFL+    , foldlwRL     , allFL     , allRL     , anyFL     , anyRL     , filterFL     , filterRL+    , foldFL_M+    , foldRL_M     , splitAtFL     , splitAtRL     , filterOutFLFL@@ -61,7 +65,6 @@     , dropWhileRL     -- * 'FL' only     , bunchFL-    , foldFL_M     , spanFL     , spanFL_M     , zipWithFL@@ -69,15 +72,17 @@     , mapFL_FL_M     , sequenceFL_     , eqFL-    , eqFLRev     , eqFLUnsafe     , initsFL     -- * 'RL' only     , isShorterThanRL     , snocRLSealed+    , spanRL+    , breakRL+    , takeWhileRL+    , concatRLFL     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Witnesses.Show@@ -128,11 +133,8 @@                             showString " :>: " . showsPrec (prec + 1) xs        where prec = 5 -instance Show2 a => Show1 (FL a wX) where-   showDict1 = ShowDictClass--instance Show2 a => Show2 (FL a) where-   showDict2 = ShowDictClass+instance Show2 a => Show1 (FL a wX)+instance Show2 a => Show2 (FL a)  instance Show2 a => Show (RL a wX wZ) where    showsPrec _ NilRL = showString "NilRL"@@ -140,14 +142,11 @@                             showString " :<: " . showsPrec2 (prec + 1) x        where prec = 5 -instance Show2 a => Show1 (RL a wX) where-   showDict1 = ShowDictClass+instance Show2 a => Show1 (RL a wX) -instance Show2 a => Show2 (RL a) where-   showDict2 = ShowDictClass+instance Show2 a => Show2 (RL a) -instance (Show2 a, Show2 b) => Show1 ((a :> b) wX) where-   showDict1 = ShowDictClass+instance (Show2 a, Show2 b) => Show1 ((a :> b) wX)  -- * Merge Types @@ -234,20 +233,17 @@ instance (Eq2 a, Eq2 b) => Eq ((a :> b) wX wY) where     (==) = unsafeCompare -instance (Show2 a, Show2 b) => Show2 (a :> b) where-    showDict2 = ShowDictClass+instance (Show2 a, Show2 b) => Show2 (a :> b)  instance (Show2 a, Show2 b) => Show ( (a :\/: b) wX wY ) where     showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y -instance (Show2 a, Show2 b) => Show2 (a :\/: b) where-    showDict2 = ShowDictClass+instance (Show2 a, Show2 b) => Show2 (a :\/: b)  instance (Show2 a, Show2 b) => Show ( (a :/\: b) wX wY ) where     showsPrec d (x :/\: y) = showOp2 1 ":/\\:" d x y -instance (Show2 a, Show2 b) => Show2 ( (a :/\: b) ) where-    showDict2 = ShowDictClass+instance (Show2 a, Show2 b) => Show2 ( (a :/\: b) )  -- * Functions @@ -350,8 +346,8 @@           bFL bs = case splitAtFL n bs of                    a :> b -> a :>: bFL b --- | Monadic fold over an 'FL'--- associating to the left, i.e. from left to right.+-- | Monadic fold over an 'FL' associating to the left, sequencing+-- effects from left to right. -- The order of arguments follows the standard 'foldM' from base. foldFL_M :: Monad m          => (forall wA wB. r wA -> p wA wB -> m (r wB))@@ -359,6 +355,16 @@ foldFL_M _ r NilFL = return r foldFL_M f r (x :>: xs) = f r x >>= \r' -> foldFL_M f r' xs +-- | Monadic fold over an 'FL' associating to the right, sequencing+-- effects from right to left.+-- Mostly useful for prepend-like operations with an effect where the+-- order of effects is not relevant.+foldRL_M :: Monad m+         => (forall wA wB. p wA wB -> r wB -> m (r wA))+         -> RL p wX wY -> r wY -> m (r wX)+foldRL_M _ NilRL r = return r+foldRL_M f (xs :<: x) r = f x r >>= foldRL_M f xs+ allFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool allFL f xs = and $ mapFL f xs @@ -371,14 +377,32 @@ anyRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> Bool anyRL f xs = or $ mapRL f xs -foldlFL :: (forall wW wY . a -> b wW wY -> a) -> a -> FL b wX wZ -> a-foldlFL _ x NilFL = x-foldlFL f x (y:>:ys) = foldlFL f (f x y) ys+-- | The "natural" fold over an 'FL' i.e. associating to the right.+-- Like 'Prelude.foldr' only with the more useful order of arguments.+foldrFL :: (forall wA wB . p wA wB -> r -> r) -> FL p wX wY -> r -> r+foldrFL _ NilFL r = r+foldrFL f (p:>:ps) r = f p (foldrFL f ps r) -foldlRL :: (forall wW wY . a -> b wW wY -> a) -> a -> RL b wX wZ -> a-foldlRL _ x NilRL = x-foldlRL f x (ys:<:y) = foldlRL f (f x y) ys+-- | The "natural" fold over an RL i.e. associating to the left.+foldlRL :: (forall wA wB . r -> p wA wB -> r) -> r -> RL p wX wY -> r+foldlRL _ r NilRL = r+foldlRL f r (ps:<:p) = f (foldlRL f r ps) p +-- | Right associative fold for 'FL's that transforms a witnessed state+-- in the direction opposite to the 'FL'.+-- This is the "natural" fold for 'FL's i.e. the one which replaces the+-- ':>:' with the passed operator.+foldrwFL :: (forall wA wB . p wA wB -> r wB -> r wA) -> FL p wX wY -> r wY -> r wX+foldrwFL _ NilFL r = r+foldrwFL f (p:>:ps) r = f p (foldrwFL f ps r)++-- | The analog of 'foldrwFL' for 'RL's.+-- This is the "natural" fold for 'RL's i.e. the one which replaces the+-- ':<:' with the 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+ 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@@ -396,12 +420,13 @@           -> [a] -> FL p wW wZ -> FL q wW wZ zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys zipWithFL _ _ NilFL = NilFL-zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list"+zipWithFL _ [] (_:>:_) = error "zipWithFL called with too short a list"  mapRL_RL :: (forall wW wY . a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ mapRL_RL _ NilRL = NilRL mapRL_RL f (as:<:a) = mapRL_RL f as :<: f a +{-# INLINABLE mapFL #-} mapFL :: (forall wW wZ . a wW wZ -> b) -> FL a wX wY -> [b] mapFL _ NilFL = [] mapFL f (a :>: b) = f a : mapFL f b@@ -452,6 +477,24 @@           | p x       = dropWhileRL p xs'           | otherwise = seal xs +-- | Like 'takeWhile' only for 'RL's. This function is supposed to be lazy:+-- elements before the split point should not be touched.+takeWhileRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> FlippedSeal (RL a) wY+takeWhileRL f xs = case spanRL f xs of _ :> r -> flipSeal r ++-- | Like 'span' only for 'RL's. This function is supposed to be lazy:+-- elements before the split point should not be touched.+spanRL :: (forall wA wB . p wA wB -> Bool) -> RL p wX wY -> (RL p :> RL p) wX wY+spanRL _ NilRL = NilRL :> NilRL+spanRL f left@(ps :<: p)+    | f p = case spanRL f ps of left' :> right -> left' :> right :<: p+    | otherwise = left :> NilRL++-- | Like 'break' only for 'RL's. This function is supposed to be lazy:+-- elements before the split point should not be touched.+breakRL :: (forall wA wB . p wA wB -> Bool) -> RL p wX wY -> (RL p :> RL p) wX wY+breakRL f = spanRL (not . f)+ -- |Check that two 'FL's are equal element by element. -- This differs from the 'Eq2' instance for 'FL' which -- uses commutation.@@ -460,11 +503,6 @@ eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq eqFL _ _ = NotEq -eqFLRev :: Eq2 a => FL a wX wZ -> FL a wY wZ -> EqCheck wX wY-eqFLRev NilFL NilFL = IsEq-eqFLRev (x:>:xs) (y:>:ys) | IsEq <- eqFLRev xs ys, IsEq <- x =/\= y = IsEq-eqFLRev _ _ = NotEq- eqFLUnsafe :: 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@@ -488,3 +526,7 @@ initsFL (x :>: xs) =     Sealed (x :> NilFL) :     map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs)++concatRLFL :: RL (FL p) wX wY -> RL p wX wY+concatRLFL NilRL = NilRL+concatRLFL (ps :<: p) = concatRLFL ps +<<+ p
src/Darcs/Patch/Witnesses/Sealed.hs view
@@ -15,7 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_HADDOCK ignore-exports #-}  module Darcs.Patch.Witnesses.Sealed@@ -23,9 +22,6 @@     , seal     , unseal     , mapSeal-    , unsafeUnseal-    , unsafeUnsealFlipped-    , unsafeUnseal2     , Sealed2(..)     , seal2     , unseal2@@ -34,8 +30,6 @@     , flipSeal     , unsealFlipped     , mapFlipped-    , unsealM-    , liftSM     , Gap(..)     , FreeLeft     , unFreeLeft@@ -43,9 +37,10 @@     , unFreeRight     ) where -import Prelude () import Darcs.Prelude +import Data.Functor.Compose ( Compose(..) )+ import Darcs.Patch.Witnesses.Eq ( Eq2, EqCheck(..) ) import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Eq ( (=\/=) )@@ -80,9 +75,6 @@ unsafeUnseal :: Sealed a -> a wX unsafeUnseal (Sealed a) = unsafeCoerceP1 a -unsafeUnsealFlipped :: FlippedSeal a wY -> a wX wY-unsafeUnsealFlipped (FlippedSeal a) = unsafeCoerceP a- unsafeUnseal2 :: Sealed2 a -> a wX wY unsafeUnseal2 (Sealed2 a) = unsafeCoerceP a @@ -91,14 +83,26 @@  -- laziness property: -- unseal (const True) undefined == True--unsealM :: Monad m => m (Sealed a) -> (forall wX . a wX -> m b) -> m b-unsealM m1 m2 = do sx <- m1-                   unseal m2 sx--liftSM :: Monad m => (forall wX . a wX -> b) -> m (Sealed a) -> m b-liftSM f m = do sx <- m-                return (unseal f sx)+--+-- Pattern-matching on Sealed is currently strict in GHC because it's an existential:+-- https://gitlab.haskell.org/ghc/ghc/issues/17130+-- Implementing unseal via unsafeUnseal (with the unsafeCoerceP1 underneath) works+-- around that, and we rely on that occasionally for performance, e.g. when reading+-- the history of a repository.+--+-- TODO: this is quite obscure and makes it hard to know whether we really need+-- laziness in a certain place or are just getting it incidentally because someone+-- chose to use unseal rather than pattern-matching. We should introduce an explicit+-- "Make this Sealed lazy" combinator (also using unsafeCoerceP1 in the implementation)+-- and then make the seal implementation itself be strict.+--+-- The combinator would work by making a value with a fresh Sealed constructor, so even+-- though the subsequent pattern-match/unseal on that would itself be strict, it would+-- only force as far as the newly introduced Sealed.+--+-- All this applies to Sealed2 too, and FlippedSeal if we ever need a lazy one (but+-- the implementation of unsealFlipped has been strict for a long time without causing+-- trouble).  mapSeal :: (forall wX . a wX -> b wX) -> Sealed a -> Sealed b mapSeal f = unseal (seal . f)@@ -124,11 +128,6 @@ -- universally quantified instead of being existentially quantified. newtype Poly a = Poly { unPoly :: forall wX . a wX } --- |'Stepped' is a type level composition operator.--- For example, @ 'Stepped' ('Sealed' p) @ is equivalent to --- @ \\x -> 'Sealed' (p x) @-newtype Stepped (f :: (* -> *) -> *) a wX = Stepped { unStepped :: f (a wX) }- -- |'FreeLeft' p is @ \forall x . \exists y . p x y @ -- In other words the caller is free to specify the left witness, -- and then the right witness is an existential.@@ -137,7 +136,7 @@ -- This is why 'Stepped' is needed, rather than writing the more obvious -- 'Sealed' ('Poly' p) which would notionally have the same quantification -- of the type witnesses.-newtype FreeLeft p = FLInternal (Poly (Stepped Sealed p))+newtype FreeLeft p = FLInternal (Poly (Compose Sealed p))  -- |'FreeRight' p is @ \forall y . \exists x . p x y @ -- In other words the caller is free to specify the right witness,@@ -148,7 +147,7 @@  -- |Unwrap a 'FreeLeft' value unFreeLeft :: FreeLeft p -> Sealed (p wX)-unFreeLeft (FLInternal x) = unStepped (unPoly x)+unFreeLeft (FLInternal x) = getCompose (unPoly x)  -- |Unwrap a 'FreeRight' value unFreeRight :: FreeRight p -> FlippedSeal p wX@@ -166,10 +165,10 @@   joinGap :: (forall wX wY wZ . p wX wY -> q wY wZ -> r wX wZ) -> w p -> w q -> w r  instance Gap FreeLeft where-  emptyGap e = FLInternal (Poly (Stepped (Sealed e)))-  freeGap e =  FLInternal (Poly (Stepped (Sealed e)))+  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 Stepped (Sealed p') -> case unPoly q of Stepped (Sealed q') -> Stepped (Sealed (p' `op` 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))
src/Darcs/Patch/Witnesses/Show.hs view
@@ -1,9 +1,5 @@ module Darcs.Patch.Witnesses.Show-    ( ShowDict(..)-    , showD-    , showListD-    , showsPrecD-    , Show1(..)+    ( Show1(..)     , Show2(..)     , show1     , showsPrec1@@ -13,29 +9,24 @@     , appPrec     ) where -import Prelude () import Darcs.Prelude  import Darcs.Util.Show ( appPrec ) -data ShowDict a where-    ShowDictClass :: Show a => ShowDict a-    ShowDictRecord :: (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowDict a+import Data.Constraint ( Dict(..) ) +type ShowDict a = Dict (Show a)+ showsPrecD :: ShowDict a -> Int -> a -> ShowS-showsPrecD ShowDictClass       = showsPrec-showsPrecD (ShowDictRecord showsPrecR _ _) = showsPrecR+showsPrecD Dict       = showsPrec  showD :: ShowDict a -> a -> String-showD ShowDictClass       = show-showD (ShowDictRecord _ showR _) = showR--showListD :: ShowDict a -> [a] -> ShowS-showListD ShowDictClass       = showList-showListD (ShowDictRecord _ _ showListR) = showListR+showD Dict       = show  class Show1 a where-    showDict1 :: ShowDict (a wX)+  showDict1 :: Dict (Show (a wX))+  default showDict1 :: Show (a wX) => ShowDict (a wX)+  showDict1 = Dict  showsPrec1 :: Show1 a => Int -> a wX -> ShowS showsPrec1 = showsPrecD showDict1@@ -44,7 +35,9 @@ show1 = showD showDict1  class Show2 a where-    showDict2 :: ShowDict (a wX wY)+  showDict2 :: ShowDict (a wX wY)+  default showDict2 :: Show (a wX wY) => ShowDict (a wX wY)+  showDict2 = Dict  showsPrec2 :: Show2 a => Int -> a wX wY -> ShowS showsPrec2 = showsPrecD showDict2
src/Darcs/Patch/Witnesses/Unsafe.hs view
@@ -2,7 +2,6 @@     ( unsafeCoerceP     , unsafeCoercePStart     , unsafeCoercePEnd-    , unsafeCoerceP2     , unsafeCoerceP1     ) where @@ -16,9 +15,6 @@  unsafeCoercePEnd :: a wX wY1 -> a wX wY2 unsafeCoercePEnd = unsafeCoerce--unsafeCoerceP2 :: t wW wX wY wZ -> t wA wB wC wD-unsafeCoerceP2 = unsafeCoerce  unsafeCoerceP1 :: a wX -> a wY unsafeCoerceP1 = unsafeCoerce
src/Darcs/Patch/Witnesses/WZipper.hs view
@@ -32,7 +32,6 @@     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch.Witnesses.Ordered
src/Darcs/Prelude.hs view
@@ -7,9 +7,11 @@ Prelude but clash with common names in the Darcs code.  Broadly it exports everything that the latest Prelude supports, minus the-things we explicitly exclude-By default it should be imported with-    import Prelude ()+things we explicitly exclude. Since we now use the NoImplicitPrelude extension,+every module must import it explicitly.++By convention everything from Darcs.Prelude is imported:+     import Darcs.Prelude  If necessary more things can be hidden in the 'Darcs.Prelude' import if they@@ -27,7 +29,6 @@     , module Data.Monoid     , Semigroup(..)     , module Data.Traversable-    , impossible, bug     ) where  import Prelude hiding@@ -41,12 +42,12 @@     ,       -- because it's in the new Prelude but only in Data.Monoid in older GHCs       Monoid(..)-    , #if MIN_VERSION_base(4,11,0)+    ,       -- because it's in the new Prelude but only in Data.Semigroup in older GHCs       Semigroup(..)-    , #endif+    ,       -- because it's in the new Prelude but only in Data.Traversable in older GHCs       traverse     ,@@ -64,10 +65,3 @@ import Data.Monoid ( Monoid(..) ) import Data.Semigroup ( Semigroup(..) ) import Data.Traversable ( traverse )--impossible :: a-impossible = error "Impossible case"--bug :: String -> a-bug str = error ("This is a bug! Please report it at http://darcs.net\n" ++ str)-
src/Darcs/Repository.hs view
@@ -24,19 +24,23 @@     , repoCache     , PristineType(..)     , HashedDir(..)-    , Cache(..)+    , Cache     , CacheLoc(..)+    , CacheType(..)     , WritableOrNot(..)+    , cacheEntries+    , mkCache+    , reportBadSources     , RepoJob(..)     , maybeIdentifyRepository     , identifyRepositoryFor+    , ReadingOrWriting(..)     , withRecorded     , withRepoLock     , withRepoLockCanFail     , withRepository     , withRepositoryLocation     , withUMaskFlag-    , writePatchSet     , findRepository     , amInRepository     , amNotInRepository@@ -44,14 +48,12 @@     , replacePristine     , readRepo     , prefsUrl-    , repoPatchType     , addToPending     , addPendingDiffToPending     , tentativelyAddPatch     , tentativelyRemovePatches     , tentativelyAddToPending     , readTentativeRepo-    , RebaseJobFlags(..)     , withManualRebaseUpdate     , tentativelyMergePatches     , considerMergeToWorking@@ -62,7 +64,6 @@     , createRepositoryV2     , EmptyRepository(..)     , cloneRepository-    , unrevertUrl     , applyToWorking     , createPristineDirectoryTree     , createPartialsPristineDirectoryTree@@ -75,13 +76,12 @@     , setScriptsExecutablePatches     , testTentative     , modifyCache-    , reportBadSources     -- * Recorded and unrecorded and pending.     , readRecorded     , readUnrecorded     , unrecordedChanges+    , readPendingAndWorking     , filterOutConflicts-    , readPending     , readRecordedAndPending     -- * Index.     , readIndex@@ -92,7 +92,7 @@     ( readRecorded     , readUnrecorded     , unrecordedChanges-    , readPending+    , readPendingAndWorking     , readIndex     , invalidateIndex     , readRecordedAndPending@@ -106,6 +106,7 @@ import Darcs.Repository.Identify     ( maybeIdentifyRepository     , identifyRepositoryFor+    , ReadingOrWriting(..)     , findRepository     , amInRepository     , amNotInRepository@@ -114,17 +115,18 @@ import Darcs.Repository.Hashed     ( readRepo     , readTentativeRepo-    , withRecorded     , tentativelyAddPatch     , tentativelyRemovePatches     , revertRepositoryChanges     , finalizeRepositoryChanges-    , unrevertUrl+    , reorderInventory+    )+import Darcs.Repository.Pristine+    ( withRecorded     , createPristineDirectoryTree     , createPartialsPristineDirectoryTree-    , reorderInventory-    , cleanRepository     )+import Darcs.Repository.Traverse ( cleanRepository ) import Darcs.Repository.Pending     ( tentativelyAddToPending     )@@ -141,22 +143,25 @@     , withRepositoryLocation     , withUMaskFlag     )-import Darcs.Repository.Rebase ( RebaseJobFlags(..), withManualRebaseUpdate )+import Darcs.Repository.Rebase ( withManualRebaseUpdate ) import Darcs.Repository.Test ( testTentative ) import Darcs.Repository.Merge( tentativelyMergePatches                              , considerMergeToWorking                              )-import Darcs.Repository.Cache ( HashedDir(..)-                              , Cache(..)-                              , CacheLoc(..)-                              , WritableOrNot(..)-                              , reportBadSources-                              )+import Darcs.Repository.Cache+    ( Cache+    , CacheLoc(..)+    , CacheType(..)+    , HashedDir(..)+    , WritableOrNot(..)+    , cacheEntries+    , mkCache+    , reportBadSources+    ) import Darcs.Repository.InternalTypes     ( Repository     , PristineType(..)     , modifyCache-    , repoPatchType     , repoLocation     , repoFormat     , repoPristineType@@ -165,7 +170,6 @@ import Darcs.Repository.Clone     ( cloneRepository     , replacePristine-    , writePatchSet     ) import Darcs.Repository.Create     ( createRepository@@ -174,5 +178,5 @@     , EmptyRepository(..)     ) -import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
src/Darcs/Repository/ApplyPatches.hs view
@@ -16,7 +16,7 @@ -- Boston, MA 02110-1301, USA.  {-# OPTIONS_GHC -fno-warn-missing-methods #-}-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}  module Darcs.Repository.ApplyPatches     ( applyPatches@@ -25,20 +25,20 @@     , DefaultIO, runDefault     ) where -import Prelude hiding ( Applicative ) import Control.Exception ( catch, SomeException, IOException ) import Data.Char ( toLower ) import Data.List ( isSuffixOf ) import System.IO ( stderr ) import System.IO.Error ( isDoesNotExistError, isPermissionError ) import Control.Monad ( unless, mplus )-import Control.Applicative (Applicative) import System.Directory ( createDirectory,                           removeDirectory, removeFile,                           renameFile, renameDirectory,                           doesDirectoryExist, doesFileExist                         ) +import Darcs.Prelude+ import Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTree(..) ) import Darcs.Patch.ApplyPatches ( applyPatches ) import Darcs.Patch.MonadProgress ( MonadProgress(..), ProgressAction(..) )@@ -47,14 +47,17 @@  import Darcs.Util.Exception ( prettyException ) import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )-import Darcs.Util.Printer ( hPutDocLn )-import Darcs.Util.Printer.Color ( showDoc )+import Darcs.Util.Printer ( hPutDocLn, renderString ) import Darcs.Util.External ( backupByCopying, backupByRenaming )-import Darcs.Util.Path ( FileName, fn2fp )+import Darcs.Util.Path ( AnchoredPath, anchorPath ) import qualified Data.ByteString as B (empty, null, readFile)  import Darcs.Util.Tree( Tree ) ++ap2fp :: AnchoredPath -> FilePath+ap2fp = anchorPath ""+ newtype DefaultIO a = DefaultIO { runDefaultIO :: IO a }     deriving (Functor, Applicative, Monad) @@ -66,7 +69,7 @@        mapM_ go items        endTedious what     where go item =-            do finishedOneIO what (showDoc $ paMessage item)+            do finishedOneIO what (renderString $ paMessage item)                runDefaultIO (paAction item) `catch` \e ->                  do hPutDocLn stderr $ paOnError item                     ioError e@@ -75,23 +78,23 @@     type ApplyMonadBase DefaultIO = IO  instance ApplyMonadTree DefaultIO where-    mDoesDirectoryExist = DefaultIO . doesDirectoryExist . fn2fp+    mDoesDirectoryExist = DefaultIO . doesDirectoryExist . ap2fp     mChangePref a b c = DefaultIO $ changePrefval a b c-    mModifyFilePS f j = DefaultIO $ B.readFile (fn2fp f) >>= runDefaultIO . j >>= writeAtomicFilePS (fn2fp f)-    mCreateDirectory = DefaultIO . createDirectory . fn2fp+    mModifyFilePS f j = DefaultIO $ B.readFile (ap2fp f) >>= runDefaultIO . j >>= writeAtomicFilePS (ap2fp f)+    mCreateDirectory = DefaultIO . createDirectory . ap2fp     mCreateFile f = DefaultIO $-                    do exf <- doesFileExist (fn2fp f)-                       if exf then fail $ "File '"++fn2fp f++"' already exists!"-                              else do exd <- doesDirectoryExist $ fn2fp f-                                      if exd then fail $ "File '"++fn2fp f++"' already exists!"-                                             else writeAtomicFilePS (fn2fp f) B.empty+                    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     mRemoveFile f = DefaultIO $-                    do let fp = fn2fp f+                    do let fp = ap2fp f                        x <- B.readFile fp                        unless (B.null x) $                             fail $ "Cannot remove non-empty file "++fp                        removeFile fp-    mRemoveDirectory = DefaultIO . removeDirectory . fn2fp+    mRemoveDirectory = DefaultIO . removeDirectory . ap2fp     mRename a b = DefaultIO $                   catch                   (renameDirectory x y `mplus` renameFile x y)@@ -99,8 +102,8 @@                   -- versions of darcs allowed users to rename nonexistent                   -- files.  :(                   (\e -> unless (isDoesNotExistError e) $ ioError e)-      where x = fn2fp a-            y = fn2fp b+      where x = ap2fp a+            y = ap2fp b  class (Functor m, Monad m) => TolerantMonad m where     warning :: IO () -> m ()@@ -155,13 +158,13 @@                                  (\(e :: IOException) ->                                    if "(Directory not empty)" `isSuffixOf` show e                                    then ioError $ userError $-                                            "Not deleting " ++ fn2fp d ++ " because it is not empty."+                                            "Not deleting " ++ ap2fp d ++ " because it is not empty."                                    else ioError $ userError $-                                            "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)+                                            "Not deleting " ++ ap2fp d ++ " because:\n" ++ show e)     mRename a b = warning $ catch                           (let do_backup = if map toLower x == map toLower y-                                           then backupByCopying (fn2fp b) -- avoid making the original vanish-                                           else backupByRenaming (fn2fp b)+                                           then backupByCopying (ap2fp b) -- avoid making the original vanish+                                           else backupByRenaming (ap2fp b)                            in do_backup >> runDefaultIO (mRename a b))                           (\e -> case () of                                  _ | isPermissionError e -> ioError $ userError $@@ -171,9 +174,9 @@                                    | otherwise -> ioError e                           )        where-        x = fn2fp a-        y = fn2fp b+        x = ap2fp a+        y = ap2fp b         couldNotRename = "Could not rename " ++ x ++ " to " ++ y -backup :: FileName -> IO ()-backup f = backupByRenaming (fn2fp f)+backup :: AnchoredPath -> IO ()+backup f = backupByRenaming (ap2fp f)
src/Darcs/Repository/Cache.hs view
@@ -1,7 +1,9 @@ module Darcs.Repository.Cache     ( cacheHash     , okayHash-    , Cache(..)+    , Cache+    , mkCache+    , cacheEntries     , CacheType(..)     , CacheLoc(..)     , WritableOrNot(..)@@ -22,25 +24,29 @@     , isThisRepo     , hashedFilePath     , allHashedDirs-    , compareByLocality     , 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 )-import Data.Maybe ( catMaybes, fromMaybe )+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, addBadSource, isBadSource, addReachableSource,-                      isReachableSource, getBadSourcesList, defaultRemoteDarcsCmd )+import Darcs.Util.Global ( darcsdir, defaultRemoteDarcsCmd ) import Darcs.Util.External ( gzFetchFilePS, fetchFilePS                            , speculateFileOrUrl, copyFileOrUrl                            , Cachable( Cachable ) )@@ -53,8 +59,8 @@ import Darcs.Util.Hash ( sha256sum ) import Darcs.Util.English ( englishNum, Noun(..), Pronoun(..) ) import Darcs.Util.Exception ( catchall )-import Darcs.Util.Progress ( progressList, debugMessage, debugFail )-import qualified Darcs.Util.Download as Download ( ConnectionError(..) )+import Darcs.Util.Progress ( progressList, debugMessage )+import qualified Darcs.Util.Download as Download ( ConnectionError )  data HashedDir = HashedPristineDir                | HashedPatchesDir@@ -88,6 +94,12 @@ -- | 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 @@ -111,7 +123,7 @@ --     network entries can lead to darcs hang when it tries to get to --     unaccessible host. -----   * If remote repositoty is local, copy all network cache entries. For local+--   * 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.@@ -195,6 +207,21 @@ 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@@ -219,9 +246,9 @@ -- 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+    d </> hashedDir s </> f hashedFilePathReadOnly (Cache Repo _ r) s f =-    r ++ "/" ++ darcsdir ++ "/" ++ hashedDir 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@@ -273,7 +300,7 @@ copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO () copyFileUsingCache oos (Ca cache) subdir f = do     debugMessage $-        "I'm doing copyFileUsingCache on " ++ hashedDir subdir ++ "/" ++ f+        "I'm doing copyFileUsingCache on " ++ hashedDir subdir </> f     Just stickItHere <- cacheLoc cache     createDirectoryIfMissing True         (reverse $ dropWhile (/= '/') $ reverse stickItHere)@@ -374,7 +401,7 @@     `catchNonSignal` const (return False)  -- | Get contents of some hashed file taking advantage of the cache system.--- We hace a list of locations (@cache@) ordered from "closest/fastest"+-- 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.@@ -386,7 +413,7 @@     when (fromWhere == Anywhere) $         copyFileUsingCache ActuallyCopy (Ca cache) subdir f     filterBadSources cache >>= ffuc-    `catchall` debugFail ("Couldn't fetch `" ++ f ++ "'\nin subdir "+    `catchall` fail ("Couldn't fetch " ++ f ++ "\nin subdir "                           ++ hashedDir subdir ++ " from sources:\n\n"                           ++ show (Ca cache))   where@@ -446,11 +473,11 @@                     return (fname, x)         | otherwise = ffuc cs -    ffuc [] = debugFail $ "No sources from which to fetch file `" ++ f-                          ++ "'\n"++ show (Ca cache)+    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)+        createDirectoryIfMissing False (d </> hashedDir subdir)         createLink ff (hashedFilePath c subdir f)         `catchall`         return ()@@ -458,7 +485,7 @@  createCache :: CacheLoc -> HashedDir -> IO () createCache (Cache Directory _ d) subdir =-    createDirectoryIfMissing True (d ++ "/" ++ hashedDir subdir)+    createDirectoryIfMissing True (d </> hashedDir subdir) createCache _ _ = return ()  -- | @write compression filename content@ writes @content@ to the file@@ -480,7 +507,7 @@     `catchall`     wfuc cache     `catchall`-    debugFail ("Couldn't write `" ++ hash ++ "'\nin subdir "+    fail ("Couldn't write " ++ hash ++ "\nin subdir "                ++ hashedDir subdir ++ " to sources:\n\n"++ show (Ca cache))   where     hash = cacheHash ps@@ -491,8 +518,7 @@             -- FIXME: create links in caches             write compr (hashedFilePath c subdir hash) ps             return hash-    wfuc [] = debugFail $ "No location to write file `" ++ hashedDir subdir-                          ++ "/" ++ hash ++ "'"+    wfuc [] = fail $ "No location to write file " ++ (hashedDir subdir </> hash)  cleanCaches :: Cache -> HashedDir -> IO () cleanCaches c d = cleanCachesWithHint' c d Nothing@@ -504,10 +530,10 @@ cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs   where     cleanCache (Cache Directory Writable d) =-        withCurrentDirectory (d ++ "/" ++ hashedDir subdir) (do+        withCurrentDirectory (d </> hashedDir subdir) (do             fs' <- getDirectoryContents "."             let fs = filter okayHash $ fromMaybe fs' hint-                cleanMsg = "Cleaning cache " ++ d ++ "/" ++ hashedDir subdir+                cleanMsg = "Cleaning cache " ++ d </> hashedDir subdir             mapM_ clean $ progressList cleanMsg fs)         `catchall`         return ()@@ -524,12 +550,47 @@     sources <- getBadSourcesList     let size = length sources     unless (null sources) $ hPutStrLn stderr $-        concat [ "\nHINT: I could not reach the following "-               , englishNum size (Noun "repository") ":"+        concat [ "\nBy the way, I could not reach the following "+               , englishNum size (Noun "location") ":"                , "\n"-               , intercalate "\n" (map ("        " ++) sources)-               , "\n      If you're not using "-               , englishNum size It ", you should probably delete"-               , "\n      the corresponding "+               , 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,21 +1,19 @@ module Darcs.Repository.Clone     ( cloneRepository     , replacePristine-    , writePatchSet     ) where -import Prelude () import Darcs.Prelude  import Control.Exception ( catch, SomeException )-import Control.Monad ( when )+import Control.Monad ( unless, void, when ) import qualified Data.ByteString.Char8 as BC import Data.List( intercalate ) import Data.Maybe( catMaybes ) import System.FilePath( (</>) ) import System.Directory     ( removeFile-    , getDirectoryContents+    , listDirectory     ) import System.IO ( stderr ) @@ -25,17 +23,21 @@     , writePristine     ) import Darcs.Repository.State ( invalidateIndex )-import Darcs.Repository.Pending ( tentativelyAddToPending )-import Darcs.Repository.Identify-    ( IdentifyRepo(..)-    , identifyRepositoryFor-    , maybeIdentifyRepository )+import Darcs.Repository.Identify ( identifyRepositoryFor, ReadingOrWriting(..) )+import Darcs.Repository.Pristine+    ( ApplyDir(..)+    , applyToTentativePristineCwd+    , createPristineDirectoryTree+    ) import Darcs.Repository.Hashed-    ( readRepo-    , tentativelyRemovePatches+    ( copyHashedInventory     , finalizeRepositoryChanges-    , createPristineDirectoryTree+    , finalizeTentativeChanges+    , readRepo     , revertRepositoryChanges+    , revertTentativeChanges+    , tentativelyRemovePatches+    , writeTentativeInventory     ) import Darcs.Repository.Working     ( setScriptsExecutable@@ -46,7 +48,7 @@     , repoFormat     , repoCache     , modifyCache-    , repoPatchType )+    ) import Darcs.Repository.Job ( withUMaskFlag ) import Darcs.Repository.Cache     ( unionRemoteCaches@@ -54,20 +56,17 @@     , fetchFileUsingCache     , speculateFileUsingCache     , HashedDir(..)-    , Cache(..)-    , CacheLoc(..)     , repo2cache+    , dropNonRepos     )-import qualified Darcs.Repository.Cache as DarcsCache -import qualified Darcs.Repository.Hashed as HashedRepo import Darcs.Repository.ApplyPatches ( runDefault )-import Darcs.Repository.Hashed-    ( applyToTentativePristineCwd-    , peekPristineHash+import Darcs.Repository.Inventory+    ( peekPristineHash+    , getValidHash     ) import Darcs.Repository.Format-    ( RepoProperty ( HashedInventory, Darcs2 )+    ( RepoProperty ( HashedInventory, Darcs2, Darcs3 )     , RepoFormat     , formatHas     , readProblem@@ -88,9 +87,15 @@     , fetchAndUnpackPatches     , packsDir     )+import Darcs.Repository.Resolution+    ( StandardResolution(..)+    , patchsetConflictResolutions+    , announceConflicts+    )+import Darcs.Repository.Working ( applyToWorking ) import Darcs.Util.Lock ( appendTextFile, withNewDirectory ) import Darcs.Repository.Flags-    ( UpdateWorking(..)+    ( UpdatePending(..)     , UseCache(..)     , RemoteDarcs (..)     , remoteDarcs@@ -102,35 +107,37 @@     , SetScriptsExecutable (..)     , RemoteRepos (..)     , SetDefault (..)+    , InheritDefault (..)     , WithWorkingDir (..)     , ForgetParent (..)     , WithPatchIndex (..)     , PatchFormat (..)+    , AllowConflicts(..)+    , ExternalMerge(..)     ) -import Darcs.Patch ( RepoPatch, IsRepoType, apply, invert, effect )-import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )-import Darcs.Patch.Set ( Origin-                       , PatchSet-                       , patchSet2RL+import Darcs.Patch ( RepoPatch, IsRepoType, description )+import Darcs.Patch.Depends ( findUncommon )+import Darcs.Patch.Set ( patchSet2RL                        , patchSet2FL                        , progressPatchSet                        )-import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch )+import Darcs.Patch.Match ( MatchFlag(..), patchSetMatch ) import Darcs.Patch.Progress ( progressRLShowTags, progressFL )-import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Ordered-    ( (:>)(..)-    , lengthFL-    , mapFL_FL+    ( FL(..)     , RL(..)+    , (:\/:)(..)+    , lengthFL     , bunchFL     , mapFL     , mapRL     , lengthRL+    , nullFL     )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash )  import Darcs.Util.Tree( Tree, emptyTree ) @@ -139,8 +146,9 @@ import Darcs.Util.English ( englishNum, Noun(..) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.URL ( isValidLocalPath )-import Darcs.Util.SignalHandler ( catchInterrupt )-import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc )+import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked )+import Darcs.Util.Printer ( Doc, ($$), hPutDocLn, hsep, putDocLn, text )+import Darcs.Util.Printer.Color ( unsafeRenderStringColored ) import Darcs.Util.Progress     ( debugMessage     , tediousSize@@ -158,7 +166,9 @@     -> CloneKind     -> UMask -> RemoteDarcs     -> SetScriptsExecutable-    -> RemoteRepos -> SetDefault+    -> RemoteRepos+    -> SetDefault+    -> InheritDefault     -> [MatchFlag]     -> RepoFormat     -> WithWorkingDir@@ -166,19 +176,22 @@     -> Bool   -- use packs     -> ForgetParent     -> IO ()-cloneRepository repodir mysimplename v useCache cloneKind um rdarcs sse remoteRepos-                setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks-                forget =+cloneRepository repourl mysimplename v useCache cloneKind um rdarcs sse remoteRepos+                setDefault inheritDefault matchFlags rfsource withWorkingDir+                usePatchIndex usePacks forget =   withUMaskFlag um $ withNewDirectory mysimplename $ do-      let patchfmt = if formatHas Darcs2 rfsource then PatchFormat2 else PatchFormat1-      EmptyRepository toRepo' <-+      let patchfmt+            | formatHas Darcs3 rfsource = PatchFormat3+            | formatHas Darcs2 rfsource = PatchFormat2+            | otherwise                 = PatchFormat1+      EmptyRepository _toRepo <-         createRepository patchfmt withWorkingDir           (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex) useCache       debugMessage "Finished initializing new repository."-      addRepoSource repodir NoDryRun remoteRepos setDefault+      addRepoSource repourl NoDryRun remoteRepos setDefault inheritDefault False        debugMessage "Identifying and copying repository..."-      fromRepo <- identifyRepositoryFor toRepo' useCache repodir+      fromRepo <- identifyRepositoryFor Reading _toRepo useCache repourl       let fromLoc = repoLocation fromRepo       let rffrom = repoFormat fromRepo       case readProblem rffrom of@@ -189,58 +202,69 @@         (joinUrl [fromLoc, darcsdir, "prefs", "prefs"])         (darcsdir </> "prefs/prefs") (MaxAge 600) `catchall` return ()       debugMessage "Copying sources..."-      cache <- unionRemoteCaches (repoCache toRepo') (repoCache fromRepo) fromLoc+      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-      let toRepo = modifyCache toRepo' (const $ cache `unionCaches` repo2cache fromLoc)+      _toRepo <- return $+        modifyCache (const $ cache `unionCaches` repo2cache fromLoc) _toRepo       if formatHas HashedInventory rffrom then do-       -- copying basic repository (hashed_inventory and pristine)+       debugMessage "Copying basic repository (hashed_inventory and pristine)"        if usePacks && (not . isValidLocalPath) fromLoc-         then copyBasicRepoPacked    fromRepo toRepo v rdarcs withWorkingDir-         else copyBasicRepoNotPacked fromRepo toRepo v rdarcs withWorkingDir+         then copyBasicRepoPacked    fromRepo _toRepo v rdarcs withWorkingDir+         else copyBasicRepoNotPacked fromRepo _toRepo v rdarcs withWorkingDir        when (cloneKind /= LazyClone) $ do          when (cloneKind /= CompleteClone) $            putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..."-       -- copying complete repository (inventories and patches)+         debugMessage "Copying complete repository (inventories and patches)"          if usePacks && (not . isValidLocalPath) fromLoc-           then copyCompleteRepoPacked    fromRepo toRepo v cloneKind-           else copyCompleteRepoNotPacked fromRepo toRepo v cloneKind+           then copyCompleteRepoPacked    fromRepo _toRepo v cloneKind+           else copyCompleteRepoNotPacked fromRepo _toRepo v cloneKind       else        -- old-fashioned repositories are cloned diferently since        -- we need to copy all patches first and then build pristine-       copyRepoOldFashioned fromRepo toRepo v withWorkingDir+       copyRepoOldFashioned fromRepo _toRepo v withWorkingDir       when (sse == YesSetScriptsExecutable) setScriptsExecutable-      when (havePatchsetMatch (repoPatchType toRepo) matchFlags) $ do+      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 repo's patches-        revertRepositoryChanges toRepo YesUpdateWorking-        patches <- readRepo toRepo-        Sealed context <- getOnePatchset toRepo matchFlags-        when (snd (countUsThem patches context) > 0) $-             errorDoc $ text "Missing patches from context!" -- FIXME : - (-        _ :> us' <- return $ findCommonWithThem patches context-        let ps = mapFL_FL hopefully us'-        putInfo v $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " ++-                    englishNum (lengthFL ps) (Noun "patch") ""-        invalidateIndex toRepo-        _ <- tentativelyRemovePatches toRepo GzipCompression YesUpdateWorking us'-        tentativelyAddToPending toRepo YesUpdateWorking $ invert $ effect us'-        finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression-        runDefault (apply (invert $ effect ps)) `catch` \(e :: SomeException) ->-            fail ("Couldn't undo patch in working dir.\n" ++ show e)-        when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps)+        -- the following is necessary to be able to read _toRepo's patches+        _toRepo <- revertRepositoryChanges _toRepo NoUpdatePending+        patches <- readRepo _toRepo+        Sealed context <- getOnePatchset _toRepo psm+        to_remove :\/: only_in_context <- return $ findUncommon patches context+        case only_in_context of+          NilFL -> do+            let num_to_remove = lengthFL to_remove+            putInfo v $ hsep $ map text+              [ "Unapplying"+              , show num_to_remove+              , englishNum num_to_remove (Noun "patch") ""+              ]+            invalidateIndex _toRepo+            _toRepo <-+              tentativelyRemovePatches _toRepo GzipCompression NoUpdatePending to_remove+            _toRepo <-+              finalizeRepositoryChanges _toRepo NoUpdatePending GzipCompression+            runDefault (unapply to_remove) `catch` \(e :: SomeException) ->+                fail ("Couldn't undo patch in working tree.\n" ++ show e)+            when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches to_remove+          _ ->+            -- This can only happen if the user supplied a context file that+            -- doesn't specify a subset of the remote repo.+            fail $ unsafeRenderStringColored+              $ text "Missing patches from context:"+              $$ description only_in_context       when (forget == YesForgetParent) deleteSources---- | This keeps only NonWritable Repo entries.-dropNonRepos :: Cache -> Cache-dropNonRepos (Ca cache) = Ca $ filter notRepo cache where-  notRepo xs = case xs of-    Cache DarcsCache.Directory _ _ -> False-    -- we don't want to write thisrepo: entries to the disk-    Cache DarcsCache.Repo DarcsCache.Writable _ -> False-    _ -> True+      -- check for unresolved conflicts+      patches <- readRepo _toRepo+      let conflicts = patchsetConflictResolutions patches+      _ <- announceConflicts "clone" YesAllowConflictsAndMark NoExternalMerge 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 ()@@ -259,8 +283,8 @@                         -> IO () copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir = do   putVerbose verb $ text "Copying hashed inventory from remote repo..."-  HashedRepo.copyHashedInventory toRepo rdarcs (repoLocation fromRepo)-  putVerbose verb $ text "Writing pristine and working directory contents..."+  copyHashedInventory toRepo rdarcs (repoLocation fromRepo)+  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)@@ -291,15 +315,19 @@      mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing)      let hiURL = joinUrl [fromLoc, darcsdir, "hashed_inventory"]      i <- gzFetchFilePS hiURL Uncachable-     let currentHash = BC.pack $ peekPristineHash i+     let currentHash = BC.pack $ getValidHash $ peekPristineHash i      let copyNormally = copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir      case mPackHash of       Just packHash | packHash == currentHash-              -> ( copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir-                    `catch` \(e :: SomeException) ->+              -> ( do copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir+                      -- need to obtain a fresh copy of hashed_inventory as reference+                      putVerbose verb $ text "Copying hashed inventory from remote repo..."+                      copyHashedInventory toRepo rdarcs (repoLocation fromRepo)+                   `catch` \(e :: SomeException) ->                                do putStrLn ("Exception while getting basic pack:\n" ++ show e)                                   copyNormally)-      _       -> do putVerbose verb $ text "Remote repo has no basic pack or outdated basic pack, copying normally."+      _       -> do putVerbose verb $+                      text "Remote repo has no basic pack or outdated basic pack, copying normally."                     copyNormally  copyBasicRepoPacked2 ::@@ -352,8 +380,7 @@     when pi $ createPIWithInterrupt toRepo us -- TODO or do another readRepo?  cleanDir :: FilePath -> IO ()-cleanDir d = mapM_ (\x -> removeFile $ d </> x) .-  filter (\x -> head x /= '.') =<< getDirectoryContents d+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@@ -361,28 +388,28 @@                         -> Verbosity                         -> WithWorkingDir                         -> IO ()-copyRepoOldFashioned fromrepository toRepo verb withWorkingDir = do-  HashedRepo.revertTentativeChanges+copyRepoOldFashioned fromrepository _toRepo verb withWorkingDir = do+  revertTentativeChanges   patches <- readRepo fromrepository   let k = "Copying patch"   beginTedious k   tediousSize k (lengthRL $ patchSet2RL patches)   let patches' = progressPatchSet k patches-  HashedRepo.writeTentativeInventory (repoCache toRepo) GzipCompression patches'+  writeTentativeInventory (repoCache _toRepo) GzipCompression patches'   endTedious k-  HashedRepo.finalizeTentativeChanges toRepo GzipCompression+  finalizeTentativeChanges _toRepo GzipCompression   -- apply all patches into current hashed repository-  HashedRepo.revertTentativeChanges-  local_patches <- readRepo toRepo-  replacePristine toRepo emptyTree+  _toRepo <- revertRepositoryChanges _toRepo NoUpdatePending+  local_patches <- readRepo _toRepo+  replacePristine _toRepo emptyTree   let patchesToApply = progressFL "Applying patch" $ patchSet2FL local_patches-  sequence_ $ mapFL applyToTentativePristineCwd $ bunchFL 100 patchesToApply-  finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression-  putVerbose verb $ text "Writing pristine and working directory contents..."-  createPristineDirectoryTree toRepo "." withWorkingDir+  sequence_ $ mapFL (applyToTentativePristineCwd ApplyNormal) $ bunchFL 100 patchesToApply+  _toRepo <- finalizeRepositoryChanges _toRepo NoUpdatePending GzipCompression+  putVerbose verb $ text "Writing pristine and working tree contents..."+  createPristineDirectoryTree _toRepo "." withWorkingDir  -- | This function fetches all patches that the given repository has---   with fetchFileUsingCache, unless --lazy is passed.+--   with fetchFileUsingCache. fetchPatchesIfNecessary :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p)                         => Repository rt p wR wU wT                         -> IO ()@@ -402,49 +429,6 @@           _ <- fetchFileUsingCache c HashedPatchesDir f           mapM_ (speculateFileUsingCache c HashedPatchesDir) ss         c = repoCache toRepo--{---- | patchSetToRepository takes a patch set, and writes a new repository---   in the current directory that contains all the patches in the patch---   set.  This function is used when 'darcs get'ing a repository with---   the --to-match flag.--- bf: no it is not used anywhere-patchSetToRepository :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                     => Repository rt p wR1 wU1 wR1-                     -> PatchSet rt p Origin wX-                     -> UseCache -> RemoteDarcs-                     -> IO ()-patchSetToRepository fromRepo patchset useCache rDarcs = do-    when (formatHas HashedInventory (repoFormat fromRepo)) $-       -- set up sources and all that-       do writeFile (darcsdir </> "tentative_pristine") "" -- this is hokey-          repox <- writePatchSet patchset useCache-          let fromLoc = repoLocation fromRepo-          HashedRepo.copyHashedInventory repox rDarcs fromLoc-          void $ copySources repox fromLoc-    repo <- writePatchSet patchset useCache-    readRepo repo >>= (runDefault . applyPatches . patchSet2FL)-    debugMessage "Writing the pristine"-    withRepoLocation repo $ readWorking >>= replacePristine repo--}---- | writePatchSet is like patchSetToRepository, except that it doesn't--- touch the working directory or pristine cache.-writePatchSet :: (IsRepoType rt, RepoPatch p)-              => PatchSet rt p Origin wX-              -> UseCache-              -> IO (Repository rt p wR wU wT)-writePatchSet patchset useCache = do-    maybeRepo <- maybeIdentifyRepository useCache "."-    let repo =-          case maybeRepo of-            GoodRepository r -> r-            BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e)-            NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e)-    debugMessage "Writing inventory"-    HashedRepo.writeTentativeInventory (repoCache repo) GzipCompression patchset-    HashedRepo.finalizeTentativeChanges repo GzipCompression-    return repo  -- | Replace the existing pristine with a new one (loaded up in a Tree object). replacePristine :: Repository rt p wR wU wT -> Tree IO -> IO ()
src/Darcs/Repository/Create.hs view
@@ -6,7 +6,6 @@     , writePristine     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when )@@ -18,7 +17,6 @@     , getCurrentDirectory     , setCurrentDirectory     )-import System.FilePath ( (</>) ) import System.IO.Error     ( catchIOError     , isAlreadyExistsError@@ -30,6 +28,7 @@ import Darcs.Patch.Set ( Origin, emptyPatchSet ) import Darcs.Patch.V1 ( RepoPatchV1 ) import Darcs.Patch.V2 ( RepoPatchV2 )+import Darcs.Patch.V3 ( RepoPatchV3 ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) @@ -45,12 +44,16 @@     , WithPatchIndex (..)     , PatchFormat (..)     )-import Darcs.Repository.Hashed+import Darcs.Repository.Inventory     ( pokePristineHash-    , pristineDirPath+    , mkValidHash+    )+import Darcs.Repository.Paths+    ( pristineDirPath     , patchesDirPath     , inventoriesDirPath     , hashedInventoryPath+    , formatPath     ) import Darcs.Repository.Identify ( seekRepo ) import Darcs.Repository.InternalTypes@@ -93,7 +96,7 @@   createDirectory prefsDirPath   writeDefaultPrefs   let repo_format = createRepoFormat patchfmt withWorkingDir-  writeRepoFormat repo_format (darcsdir </> "format")+  writeRepoFormat repo_format formatPath   -- note: all repos we create nowadays are hashed   writeBinFile hashedInventoryPath B.empty   writePristine here emptyTree@@ -112,6 +115,7 @@   repo@(EmptyRepository r) <- case patchfmt of     PatchFormat1 -> return $ EmptyRepository $ mkRepoV1 rfmt cache     PatchFormat2 -> return $ EmptyRepository $ mkRepoV2 rfmt cache+    PatchFormat3 -> return $ EmptyRepository $ mkRepoV3 rfmt cache   maybeCreatePatchIndex withPatchIndex r   return repo @@ -119,14 +123,20 @@   :: RepoFormat   -> Cache   -> Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin-mkRepoV1 repofmt cache = mkRepo "." repofmt HashedPristine cache+mkRepoV1 repofmt cache = mkRepo here repofmt HashedPristine cache  mkRepoV2   :: RepoFormat   -> Cache   -> Repository ('RepoType 'NoRebase) (RepoPatchV2 V2.Prim) Origin Origin Origin-mkRepoV2 repofmt cache = mkRepo "." repofmt HashedPristine cache+mkRepoV2 repofmt cache = mkRepo here repofmt HashedPristine cache +mkRepoV3+  :: RepoFormat+  -> Cache+  -> Repository ('RepoType 'NoRebase) (RepoPatchV3 V2.Prim) Origin Origin Origin+mkRepoV3 repofmt cache = mkRepo here repofmt HashedPristine cache+ createRepositoryV1   :: WithWorkingDir -> WithPatchIndex -> UseCache   -> IO (Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin)@@ -159,7 +169,8 @@     inv <- gzReadFilePS hashedInventoryPath     tree' <- darcsAddMissingHashes tree     root <- writeDarcsHashed tree' pristineDirPath-    writeDocBinFile hashedInventoryPath $ pokePristineHash (BC.unpack $ encodeBase16 root) inv+    writeDocBinFile hashedInventoryPath $+      pokePristineHash (mkValidHash $ BC.unpack $ encodeBase16 root) inv  here :: String here = "."
src/Darcs/Repository/Diff.hs view
@@ -33,7 +33,6 @@       treeDiff     ) where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString.Lazy.Char8 as BLC@@ -80,7 +79,7 @@ getDiff p Nothing (Just t) = (p, Added t) getDiff p (Just from) (Just to) = (p, Changed from to) getDiff p (Just t) Nothing = (p, Removed t)-getDiff _ Nothing Nothing = impossible -- zipTrees should never return this+getDiff _ Nothing Nothing = error "impossible case" -- zipTrees should never return this   treeDiff :: forall m w prim . (Monad m, Gap w, PrimPatch prim)@@ -111,34 +110,35 @@     diff :: AnchoredPath -> Diff m -> m (w (FL prim))     diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL)     diff p (Removed (SubTree _)) =-        return $ freeGap (rmdir (anchorPath "" p) :>: NilFL)+        -- Note: With files we first make the file empty before removing it.+        -- But for subtrees this has already been done in previous recursive calls.+        return $ freeGap (rmdir p :>: NilFL)     diff p (Added (SubTree _)) =-        return $ freeGap (adddir (anchorPath "" p) :>: NilFL)+        return $ freeGap (adddir p :>: NilFL)     diff p (Added b'@(File _)) =         do diff' <- diff p (Changed (File emptyBlob) b')-           return $ joinGap (:>:) (freeGap (addfile (anchorPath "" p))) diff'+           return $ joinGap (:>:) (freeGap (addfile p)) diff'     diff p (Removed a'@(File _)) =         do diff' <- diff p (Changed a' (File emptyBlob))-           return $ joinGap (+>+) diff' (freeGap (rmfile (anchorPath "" p) :>: NilFL))+           return $ joinGap (+>+) diff' (freeGap (rmfile p :>: NilFL))     diff p (Changed (File a') (File b')) =         do a <- readBlob a'            b <- readBlob b'-           let path = anchorPath "" p-           case ft path of+           case ft (anchorPath "" p) of              TextFile | no_bin a && no_bin b ->-                          return $ text_diff path a b+                          return $ text_diff p a b              _ -> return $ if a /= b-                              then freeGap (binary path (strict a) (strict b) :>: NilFL)+                              then freeGap (binary p (strict a) (strict b) :>: NilFL)                               else emptyGap NilFL     diff p (Changed a'@(File _) subtree@(SubTree _)) =-        do rmFileP <- diff p (Changed a' (File emptyBlob))+        do rmFileP <- diff p (Removed a')            addDirP <- diff p (Added subtree)            return $ joinGap (+>+) rmFileP addDirP     diff p (Changed subtree@(SubTree _) b'@(File _)) =         do rmDirP <- diff p (Removed subtree)-           addFileP <- diff p (Changed (File emptyBlob) b')+           addFileP <- diff p (Added b')            return $ joinGap (+>+) rmDirP addFileP-    diff p _ = error $ "Missing case at path " ++ show p+    diff p _ = error $ "Missing case at path " ++ show (anchorPath "" p)      text_diff p a b         | BL.null a && BL.null b = emptyGap NilFL
src/Darcs/Repository/Flags.hs view
@@ -5,7 +5,7 @@     , remoteDarcs     , Reorder (..)     , Verbosity (..)-    , UpdateWorking (..)+    , UpdatePending (..)     , UseCache (..)     , DryRun (..)     , UMask (..)@@ -18,6 +18,7 @@     , LeaveTestDir (..)     , RemoteRepos (..)     , SetDefault (..)+    , InheritDefault (..)     , UseIndex (..)     , ScanKnown (..)     , CloneKind (..)@@ -34,6 +35,8 @@     , HookConfig (..)     ) where +import Darcs.Prelude+ import Darcs.Util.Diff ( DiffAlgorithm(..) ) import Darcs.Util.Global ( defaultRemoteDarcsCmd ) @@ -59,7 +62,7 @@ data Reorder = NoReorder | Reorder     deriving ( Eq ) -data UpdateWorking = YesUpdateWorking | NoUpdateWorking+data UpdatePending = YesUpdatePending | NoUpdatePending     deriving ( Eq, Show )  data UseCache = YesUseCache | NoUseCache@@ -98,6 +101,9 @@ data SetDefault = YesSetDefault Bool | NoSetDefault Bool     deriving ( Eq, Show ) +data InheritDefault = YesInheritDefault | NoInheritDefault+    deriving ( Eq, Show )+ data UseIndex = UseIndex | IgnoreIndex deriving ( Eq, Show )  data ScanKnown = ScanKnown -- ^Just files already known to darcs@@ -129,7 +135,7 @@ data ForgetParent = YesForgetParent | NoForgetParent     deriving ( Eq, Show ) -data PatchFormat = PatchFormat1 | PatchFormat2+data PatchFormat = PatchFormat1 | PatchFormat2 | PatchFormat3     deriving ( Eq, Show )  data HooksConfig = HooksConfig
src/Darcs/Repository/Format.hs view
@@ -2,6 +2,64 @@ -- -- This file is licensed under the GPL, version two or later. +{- | The format file.++The purpose of the format file is to check compatibility between+repositories in different formats and to allow the addition of new features+without risking corruption by old darcs versions that do not yet know about+these features.++This allows a limited form of forward compatibility between darcs versions.+Old versions of darcs that are unaware of features added in later versions+will fail with a decent error message instead of crashing or misbehaving or+even corrupting new repos.++The format file lives at _darcs/format and must only contain printable ASCII+characters and must not contain the characters @<@ and @>@.++(We currently do not strip whitespace from the lines, but may want to do so+in the future.)++The file consists of format properties. A format property can contain any+allowed ASCII character except the vertical bar (@|@) and newlines. Empty+lines are ignored and multiple properties on the same line are separated+with a @|@.++If multiple properties appear on the same line (separated by vertical bars),+then this indicates alternative format properties. These have a generic+meaning:++ * If we know *any* of these properties, then we can read the repo.++ * If we know *all* of them, we can also write the repo.++The above rules are necessary conditions, not sufficient ones. It is allowed+to further restrict read and/or write access for specific commands, but care+should be taken to not unnecessarily break forward compatibility. It is not+recommended, but sometimes necessary, to impose ad-hoc restrictions on the+format, see 'transferProblem' and 'readProblem' for examples.++The no-working-dir property is an example for how to use alternative+properties. An old darcs version that does not know this format can perform+most read-only operations correctly even if there is no working tree;+however, whatsnew will report that the whole tree was removed, so the+solution is not perfect.++When you add a new property as an alternative to an existing one, you should+make sure that the old format remains to be updated in parallel to the new+one, so that reading the repo with old darcs versions behaves correctly. If+this cannot be guaranteed, it is better to add the new format on a separate+line.++It is not advisable for commands to modify an existing format file. However,+sometimes compatibility requirements may leave us no other choice. In this+case make sure to write the format file only after having checked that the+existing repo format allows modification of the repo, and that you have+taken the repo lock.++-}++{-# LANGUAGE OverloadedStrings #-} module Darcs.Repository.Format     ( RepoFormat(..)     , RepoProperty(..)@@ -17,22 +75,24 @@     , removeFromFormat     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( mplus, (<=<) )-import qualified Data.ByteString.Char8 as BC ( split, pack, unpack, elemIndex )-import qualified Data.ByteString  as B ( null, empty )+import qualified Data.ByteString.Char8 as BC ( split, pack, unpack, elem )+import qualified Data.ByteString  as B ( ByteString, null, empty, stripPrefix ) import Data.List ( partition, intercalate, (\\) )-import Data.Maybe ( isJust, mapMaybe )+import Data.Maybe ( mapMaybe )+import Data.String ( IsString )+import System.FilePath.Posix( (</>) )  import Darcs.Util.External     ( fetchFilePS     , Cachable( Cachable )     )-import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Lock ( writeBinFile )-import qualified Darcs.Repository.Flags as F ( WithWorkingDir (..), PatchFormat (..)  )+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 ) @@ -41,42 +101,54 @@  data RepoProperty = Darcs1                   | Darcs2+                  | Darcs3                   | HashedInventory                   | NoWorkingDir                   | RebaseInProgress-                  | UnknownFormat String+                  | RebaseInProgress_2_16+                  | UnknownFormat B.ByteString                   deriving ( Eq )  -- | Define string constants in one place, for reuse in show/parse functions.-darcs1Format, darcs2Format, hashedInventoryFormat :: String-noWorkingDirFormat, rebaseInProgressFormat :: String+darcs1Format, darcs2Format, darcs3Format,+  hashedInventoryFormat, noWorkingDirFormat,+  rebaseInProgressFormat, rebaseInProgress_2_16,+  newStyleRebaseInProgress :: IsString s => s  darcs1Format = "darcs-1.0" darcs2Format = "darcs-2"+darcs3Format = "darcs-3" hashedInventoryFormat = "hashed" noWorkingDirFormat = "no-working-dir" rebaseInProgressFormat = "rebase-in-progress"+rebaseInProgress_2_16 = "rebase-in-progress-2-16"+-- compatibility alias, may want to remove this at some point in the future+newStyleRebaseInProgress = "new-style-rebase-in-progress"  instance Show RepoProperty where     show Darcs1 = darcs1Format     show Darcs2 = darcs2Format+    show Darcs3 = darcs3Format     show HashedInventory = hashedInventoryFormat     show NoWorkingDir = noWorkingDirFormat     show RebaseInProgress = rebaseInProgressFormat-    show (UnknownFormat f) = f+    show RebaseInProgress_2_16 = rebaseInProgress_2_16+    show (UnknownFormat f) = BC.unpack f -readRepoProperty :: String -> RepoProperty+readRepoProperty :: B.ByteString -> RepoProperty readRepoProperty input     | input == darcs1Format = Darcs1     | input == darcs2Format = Darcs2+    | input == darcs3Format = Darcs3     | input == hashedInventoryFormat = HashedInventory     | input == noWorkingDirFormat = NoWorkingDir     | input == rebaseInProgressFormat = RebaseInProgress+    | input == newStyleRebaseInProgress = RebaseInProgress_2_16+    | input == rebaseInProgress_2_16 = RebaseInProgress_2_16     | otherwise = UnknownFormat input  -- | Representation of the format of a repository. Each -- sublist corresponds to a line in the format file.--- Currently all lines are expected to be singleton words. newtype RepoFormat = RF [[RepoProperty]]  -- | Is a given property contained within a given format?@@ -111,14 +183,14 @@     let k = "Identifying repository " ++ repo     beginTedious k     finishedOneIO k "format"-    formatInfo <- (fetchFilePS (repoPath "format") Cachable)+    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 || isJust (BC.elemIndex '<' formatInfo)) then do+      if B.null formatInfo || BC.elem '<' formatInfo then do         finishedOneIO k "inventory"-        missingInvErr <- checkFile (repoPath "inventory")+        missingInvErr <- checkFile (repo </> oldInventoryPath)         case missingInvErr of           Nothing -> return . Right $ RF [[Darcs1]]           Just e -> return . Left $ makeErrorMsg e@@ -126,9 +198,14 @@     endTedious k     return format   where-    repoPath fileName = repo ++ "/" ++ darcsdir ++ "/" ++ fileName+    readFormat =+      RF . map (map (readRepoProperty . fixupUnknownFormat)) . splitFormat -    readFormat = RF . map (map (readRepoProperty . BC.unpack)) . splitFormat+    -- silently fixup unknown format entries broken by previous darcs versions+    fixupUnknownFormat s =+      case B.stripPrefix "Unknown format: " s of+        Nothing -> s+        Just s' -> fixupUnknownFormat s' -- repeat until not found anymore      -- split into lines, then split each non-empty line on '|'     splitFormat = map (BC.split '|') . filter (not . B.null) . linesPS@@ -137,24 +214,21 @@                      `catchNonSignal`                      (return . Just . prettyException) -    makeErrorMsg e = unlines-        [ "Not a repository: " ++ repo ++ " (" ++ e ++ ")"-        , ""-        , "HINT: Do you have the right URI for the repository?"-        ]+    makeErrorMsg e =  "Not a repository: " ++ repo ++ " (" ++ e ++ ")"  -- | Write the repo format to the given file. writeRepoFormat :: RepoFormat -> FilePath -> IO () writeRepoFormat rf loc = writeBinFile loc $ BC.pack $ show rf -- note: this assumes show returns ascii --- | Create a repo format. The first argument is whether to use the old (darcs-1)+-- | Create a repo format. The first argument specifies the patch -- format; the second says whether the repo has a working tree. createRepoFormat :: F.PatchFormat -> F.WithWorkingDir -> RepoFormat createRepoFormat fmt wwd = RF $ (HashedInventory : flags2wd wwd) : flags2format fmt   where     flags2format F.PatchFormat1 = []     flags2format F.PatchFormat2 = [[Darcs2]]+    flags2format F.PatchFormat3 = [[Darcs3]]     flags2wd F.NoWorkingDir   = [NoWorkingDir]     flags2wd F.WithWorkingDir = [] @@ -163,7 +237,7 @@ writeProblem :: RepoFormat -> Maybe String writeProblem target = readProblem target `mplus` findProblems target wp   where-    wp [] = impossible+    wp [] = error "impossible case"     wp x = case partition isKnown x of                (_, []) -> Nothing                (_, unknowns) -> Just . unwords $@@ -174,12 +248,13 @@ -- @target@, or 'Nothing' if there are no such problem. transferProblem :: RepoFormat -> RepoFormat -> Maybe String transferProblem source target+    | formatHas Darcs3 source /= formatHas Darcs3 target =+        Just "Cannot mix darcs-3 repositories with older formats"     | formatHas Darcs2 source /= formatHas Darcs2 target =         Just "Cannot mix darcs-2 repositories with older formats"     | formatHas RebaseInProgress source =-        -- we could support this, by applying an appropriate filter to the patches-        -- as we pull them.-        Just "Cannot transfer patches from a repository where a rebase is in progress" +        Just "Cannot transfer patches from a repository \+          \where an old-style rebase is in progress"     | otherwise = readProblem source `mplus` writeProblem target  -- | @'readProblem' source@ returns 'Just' an error message if we cannot read@@ -187,11 +262,14 @@ readProblem :: RepoFormat -> Maybe String readProblem source     | formatHas Darcs1 source && formatHas Darcs2 source =-        Just "Invalid repositoryformat: format 2 is incompatible with format 1"+        Just "Invalid repository format: format 2 is incompatible with format 1"+    | formatHas RebaseInProgress source && formatHas RebaseInProgress_2_16 source =+        Just "Invalid repository format: \+          \cannot have both old-style and new-style rebase in progress" readProblem source = findProblems source rp   where     rp x | any isKnown x = Nothing-    rp [] = impossible+    rp [] = error "impossible case"     rp x = Just . unwords $ "Can't read repository: unknown formats:" : map show x  -- |'findProblems' applies a function that maps format-entries to an optional@@ -208,7 +286,9 @@     knownProperties :: [RepoProperty]     knownProperties = [ Darcs1                       , Darcs2+                      , Darcs3                       , HashedInventory                       , NoWorkingDir                       , RebaseInProgress+                      , RebaseInProgress_2_16                       ]
src/Darcs/Repository/Hashed.hs view
@@ -13,1089 +13,800 @@ -- 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.Hashed-    ( inventoriesDir-    , inventoriesDirPath-    , pristineDir-    , pristineDirPath-    , patchesDir-    , patchesDirPath-    , hashedInventory-    , hashedInventoryPath--    , revertTentativeChanges-    , revertRepositoryChanges-    , finalizeTentativeChanges-    , cleanPristine-    , filterDirContents-    , cleanInventories-    , cleanPatches-    , copyPristine-    , copyPartialsPristine-    , applyToTentativePristine-    , applyToTentativePristineCwd-    , addToTentativeInventory-    , readRepo-    , readRepoHashed-    , readTentativeRepo-    , writeAndReadPatch-    , writeTentativeInventory-    , copyHashedInventory-    , readHashedPristineRoot-    , pokePristineHash-    , peekPristineHash-    , listInventories-    , listInventoriesLocal-    , listInventoriesRepoDir-    , listPatchesLocalBucketed-    , writePatchIfNecessary-    , diffHashLists-    , withRecorded-    , withTentative-    , tentativelyAddPatch-    , tentativelyRemovePatches-    , tentativelyRemovePatches_-    , tentativelyAddPatch_-    , tentativelyAddPatches_-    , tentativelyReplacePatches-    , finalizeRepositoryChanges-    , unrevertUrl-    , createPristineDirectoryTree-    , createPartialsPristineDirectoryTree-    , reorderInventory-    , cleanRepository-    , UpdatePristine(..)-    , repoXor-    ) where--import Prelude ()-import Darcs.Prelude--import Control.Arrow ( (&&&) )-import Control.Exception ( catch, IOException )-import Darcs.Util.Exception ( catchall )-import Control.Monad ( when, unless, void )-import Data.Maybe-import Data.List( foldl' )--import qualified Data.ByteString as B ( empty, readFile, append )-import qualified Data.ByteString.Char8 as BC ( unpack, pack )-import qualified Data.Set as Set--import Darcs.Util.Hash( encodeBase16, Hash(..), SHA1, sha1Xor, sha1zero )-import Darcs.Util.Prompt ( promptYorn )-import Darcs.Util.Tree( treeHash, Tree )-import Darcs.Util.Tree.Hashed( hashedTreeIO, readDarcsHashedNosize,-                             readDarcsHashed, writeDarcsHashed,-                             decodeDarcsHash, decodeDarcsSize )-import Darcs.Util.SignalHandler ( withSignalsBlocked )--import System.Directory ( createDirectoryIfMissing, getDirectoryContents-                        , doesFileExist, doesDirectoryExist )-import System.FilePath.Posix( (</>) )-import System.IO.Unsafe ( unsafeInterleaveIO )-import System.IO ( stderr, hPutStrLn )--import Darcs.Util.External-    ( copyFileOrUrl-    , cloneFile-    , fetchFilePS-    , gzFetchFilePS-    , Cachable( Uncachable )-    )-import Darcs.Repository.Flags ( Compression, RemoteDarcs, remoteDarcs-    , Verbosity(..), UpdateWorking (..), WithWorkingDir (WithWorkingDir) )--import Darcs.Repository.Format ( RepoProperty( HashedInventory ), formatHas )-import Darcs.Repository.Pending-    ( readPending-    , pendingName-    , tentativelyRemoveFromPending-    , finalizePending-    , setTentativePending-    , prepend-    )-import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist )-import Darcs.Repository.State ( readRecorded, updateIndex )--import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Lock-    ( writeBinFile-    , writeDocBinFile-    , writeAtomicFilePS-    , appendDocBinFile-    , removeFileMayNotExist-    )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..)-                       , SealedPatchSet, Origin-                       , patchSet2RL-                       )--import Darcs.Patch.Show ( ShowPatch, ShowPatchFor(..) )-import Darcs.Patch.PatchInfoAnd-    ( PatchInfoAnd, Hopefully, patchInfoAndPatch, info-    , extractHash, createHashed, hopefully )-import Darcs.Patch ( IsRepoType, RepoPatch, showPatch, apply-                   , description-                   , commuteRL-                   , readPatch-                   , effect-                   , invert-                   )--import Darcs.Patch.Apply ( Apply, ApplyState )--import Darcs.Patch.Bundle ( scanBundle-                          , makeBundleN-                          )-import Darcs.Patch.Named.Wrapped ( namedIsInternal )-import Darcs.Patch.Read ( ReadPatch )-import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset-                           , mergeThem, splitOnTag )-import Darcs.Patch.Info-    ( PatchInfo, displayPatchInfo, isTag, makePatchname )-import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath-                       , AbsolutePath, toFilePath )-import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache,-                                speculateFilesUsingCache, writeFileUsingCache,-                                HashedDir(..), hashedDir, peekInCache, bucketFolder )-import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,-                                   cleanHashdir )-import Darcs.Repository.Inventory-import Darcs.Repository.InternalTypes-    ( Repository-    , repoCache-    , repoFormat-    , repoLocation-    , withRepoLocation-    , coerceT )-import qualified Darcs.Repository.Old as Old ( readOldRepo, oldRepoFailMsg )-import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Patch.Witnesses.Ordered-    ( (+<+), FL(..), RL(..), mapRL, foldFL_M-    , (:>)(..), lengthFL, filterOutFLFL-    , reverseFL, reverseRL )-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 ( showDoc )-import Darcs.Util.Printer-    ( Doc, hcat, ($$), renderString, renderPS, text, putDocLn, (<+>) )-import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )-import Darcs.Patch.Progress (progressFL)-import Darcs.Util.Workaround ( renameFile )-import Darcs.Repository.Prefs ( globalCacheDir )---makeDarcsdirPath :: String -> String-makeDarcsdirPath name = darcsdir </> name---- TODO rename xyzPath to xyzLocal to make it clear that it is--- relative to the local darcsdir---- Location of the (one and only) head inventory.-hashedInventory, hashedInventoryPath :: String-hashedInventory = "hashed_inventory"-hashedInventoryPath = makeDarcsdirPath hashedInventory---- Location of the (one and only) tentative head inventory.-tentativeHashedInventory, tentativeHashedInventoryPath :: String-tentativeHashedInventory = "tentative_hashed_inventory"-tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory---- Location of parent inventories.-inventoriesDir, inventoriesDirPath :: String-inventoriesDir = "inventories"-inventoriesDirPath = makeDarcsdirPath inventoriesDir---- Location of pristine trees.-pristineDir, tentativePristinePath, pristineDirPath :: String-tentativePristinePath = makeDarcsdirPath "tentative_pristine"-pristineDir = "pristine.hashed"-pristineDirPath = makeDarcsdirPath pristineDir---- Location of patches.-patchesDir, patchesDirPath :: String-patchesDir = "patches"-patchesDirPath = makeDarcsdirPath patchesDir---- | The way patchfiles, inventories, and pristine trees are stored.--- 'PlainLayout' means all files are in the same directory. 'BucketedLayout'--- means we create a second level of subdirectories, such that all files whose--- hash starts with the same two letters are in the same directory.-data DirLayout = PlainLayout | BucketedLayout---- | '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) => String -> p wX wY-                      -> IO String-applyToHashedPristine h p = applyOrConvertOldPristineAndApply-  where-    applyOrConvertOldPristineAndApply =-        tryApply hash `catch` \(_ :: IOException) -> handleOldPristineAndApply--    hash = decodeDarcsHash $ BC.pack h--    failOnMalformedRoot (SHA256 _) = return ()-    failOnMalformedRoot root = fail $ "Cannot handle hash: " ++ show root--    hash2root = BC.unpack . encodeBase16--    tryApply :: Hash -> IO String-    tryApply root = do-        failOnMalformedRoot root-        -- Read a non-size-prefixed pristine, failing if we encounter one.-        tree <- readDarcsHashedNosize pristineDirPath root-        (_, updatedTree) <- hashedTreeIO (apply p) tree pristineDirPath-        return . hash2root $ treeHash updatedTree--    warn = "WARNING: Doing a one-time conversion of pristine format.\n"-           ++ "This may take a while. The new format is backwards-compatible."--    handleOldPristineAndApply = do-        hPutStrLn stderr warn-        inv <- gzReadFilePS hashedInventoryPath-        let oldroot = BC.pack $ 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 (Ca []) HashedPristineDir [newroot]-        hPutStrLn stderr "Pristine conversion done..."-        -- Retry applying the patch, which should now succeed.-        tryApply root---- |revertTentativeChanges swaps the tentative and "real" hashed inventory--- files, and then updates the tentative pristine with the "real" inventory--- hash.-revertTentativeChanges :: IO ()-revertTentativeChanges = do-    cloneFile hashedInventoryPath tentativeHashedInventoryPath-    i <- gzReadFilePS hashedInventoryPath-    writeBinFile tentativePristinePath $ B.append pristineName (BC.pack (peekPristineHash i))---- |finalizeTentativeChanges trys to atomically swap the tentative--- inventory/pristine pointers with the "real" pointers; it first re-reads the--- inventory to optimize it, presumably to take account of any new tags, and--- then writes out the new tentative inventory, and finally does the atomic--- swap. In general, we can't clean the pristine cache at the same time, since--- a simultaneous get might be in progress.-finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p)-                         => Repository rt p wR wU wT -> Compression -> IO ()-finalizeTentativeChanges r compr = do-    debugMessage "Optimizing the inventory..."-    -- Read the tentative patches-    ps <- readTentativeRepo r "."-    writeTentativeInventory (repoCache r) compr ps-    i <- gzReadFilePS tentativeHashedInventoryPath-    p <- gzReadFilePS tentativePristinePath-    -- Write out the "optimised" tentative inventory.-    writeDocBinFile tentativeHashedInventoryPath $ pokePristineHash (peekPristineHash p) i-    -- Atomically swap.-    renameFile tentativeHashedInventoryPath hashedInventoryPath---- |readHashedPristineRoot attempts to read the pristine hash from the current--- inventory, returning Nothing if it cannot do so.-readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe String)-readHashedPristineRoot r = withRepoLocation r $ do-    i <- (Just <$> gzReadFilePS hashedInventoryPath)-         `catch` (\(_ :: IOException) -> return Nothing)-    return $ peekPristineHash <$> i---- |cleanPristine removes any obsolete (unreferenced) entries in the pristine--- cache.-cleanPristine :: Repository rt p wR wU wT -> IO ()-cleanPristine r = withRepoLocation r $ do-    debugMessage "Cleaning out the pristine cache..."-    i <- gzReadFilePS hashedInventoryPath-    cleanHashdir (repoCache r) HashedPristineDir [peekPristineHash i]---- |filterDirContents returns the contents of the directory @d@--- except files whose names begin with '.' (directories . and ..,--- hidden files) and files whose names are filtered by the function @f@, if--- @dir@ is empty, no paths are returned.-filterDirContents :: FilePath -> (FilePath -> Bool) -> IO [FilePath]-filterDirContents d f = do-    let realPath = makeDarcsdirPath d-    exists <- doesDirectoryExist realPath-    if exists-        then filter (\x -> head x /= '.' && f x) <$>-            getDirectoryContents realPath-        else return []---- | Set difference between two lists of hashes.-diffHashLists :: [String] -> [String] -> [String]-diffHashLists xs ys = from_set $ (to_set xs) `Set.difference` (to_set ys)-  where-    to_set = Set.fromList . map BC.pack-    from_set = map BC.unpack . Set.toList---- |cleanInventories removes any obsolete (unreferenced) files in the--- inventories directory.-cleanInventories :: Repository rt p wR wU wT -> IO ()-cleanInventories _ = do-    debugMessage "Cleaning out inventories..."-    hs <- listInventoriesLocal-    fs <- filterDirContents inventoriesDir (const True)-    mapM_ (removeFileMayNotExist . (inventoriesDirPath </>))-        (diffHashLists fs hs)---- FIXME this is ugly, these files should be directly under _darcs--- since they are not hashed. And 'unrevert' isn't even a real patch but--- a patch bundle.--- |specialPatches list of special patch files that may exist in the directory--- _darcs/patches/.-specialPatches :: [FilePath]-specialPatches = ["unrevert", "pending", "pending.tentative"]---- |cleanPatches removes any obsolete (unreferenced) files in the--- patches directory.-cleanPatches :: Repository rt p wR wU wT -> IO ()-cleanPatches _ = do-    debugMessage "Cleaning out patches..."-    hs <- listPatchesLocal PlainLayout darcsdir darcsdir-    fs <- filterDirContents patchesDir (`notElem` specialPatches)-    mapM_ (removeFileMayNotExist . (patchesDirPath </>))-        (diffHashLists fs hs)----- |addToSpecificInventory adds a patch to a specific inventory file, and--- returns the FilePath whichs corresponds to the written-out patch.-addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression-                       -> PatchInfoAnd rt p wX wY -> IO FilePath-addToSpecificInventory invPath c compr p = do-    let invFile = makeDarcsdirPath invPath-    hash <- snd <$> writePatchIfNecessary c compr p-    appendDocBinFile invFile $-      showInventoryEntry (info p, hash)-    return $ patchesDirPath </> getValidHash hash---- | Warning: this allows to add any arbitrary patch! Used by convert import.-addToTentativeInventory :: RepoPatch p => Cache -> Compression-                        -> PatchInfoAnd rt p wX wY -> IO FilePath-addToTentativeInventory = addToSpecificInventory tentativeHashedInventory---- | Attempt to remove an FL of patches from the tentative inventory.--- This is used for commands that wish to modify already-recorded patches.------ Precondition: it must be possible to remove the patches, i.e.------ * the patches are in the repository------ * any necessary commutations will succeed-removeFromTentativeInventory :: (IsRepoType rt, RepoPatch p)-                             => Repository rt p wR wU wT -> Compression-                             -> FL (PatchInfoAnd rt p) wX wT -> IO ()-removeFromTentativeInventory repo compr to_remove = do-    debugMessage $ "Start removeFromTentativeInventory"-    allpatches <- readTentativeRepo repo "."-    remaining <- case removeFromPatchSet to_remove allpatches of-        Nothing -> bug "Hashed.removeFromTentativeInventory: precondition violated"-        Just r -> return r-    writeTentativeInventory (repoCache repo) compr remaining-    debugMessage $ "Done removeFromTentativeInventory"---- |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, RepoPatch 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, RepoPatch 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, RepoPatch 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, RepoPatch p)-  => Cache-  -> Inventory-  -> IO (SealedPatchSet rt p Origin)-readRepoFromInventoryList cache = parseInv-  where-    parseInv :: (IsRepoType rt, RepoPatch p)-             => Inventory-             -> IO (SealedPatchSet rt p Origin)-    parseInv (Inventory Nothing ris) =-        mapSeal (PatchSet NilRL) <$> read_patches (reverse ris)-    parseInv (Inventory (Just h) []) =-        -- TODO could be more tolerant and create a larger PatchSet-        bug $ "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 (read_patches $ reverse ris)-        return $ seal $ PatchSet ts ps--    read_patches :: (IsRepoType rt, RepoPatch p) => [InventoryEntry]-                 -> IO (Sealed (RL (PatchInfoAnd rt p) wX))-    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 :: (IsRepoType rt, RepoPatch p) => [InventoryEntry]-           -> IO (Sealed (RL (PatchInfoAnd rt p) wX))-        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 (parse 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 >> parse i h--    speculate :: PatchHash -> [InventoryEntry] -> IO ()-    speculate h is = do-        already_got_one <- peekInCache cache HashedPatchesDir (getValidHash h)-        unless already_got_one $-            speculateFilesUsingCache cache HashedPatchesDir (map (getValidHash . snd) is)--    parse :: ReadPatch p => PatchInfo -> PatchHash -> IO (Sealed (p wX))-    parse i h = do-        debugMessage ("Reading patch file: "++ showDoc (displayPatchInfo i))-        (fn, ps) <- fetchFileUsingCache cache HashedPatchesDir (getValidHash h)-        case readPatch ps of-            Just p -> return p-            Nothing -> fail $ unlines [ "Couldn't parse file " ++ fn-                                      , "which is patch"-                                      , renderString $ displayPatchInfo i ]--    read_ts :: (IsRepoType rt, RepoPatch p) => InventoryEntry-            -> InventoryHash -> IO (Sealed (RL (Tagged rt p) Origin))-    read_ts tag0 h0 = do-        contents <- unsafeInterleaveIO $ readTaggedInventoryFromHash (getValidHash h0)-        let is = reverse $ case contents of-                               (Inventory (Just _) (_ : ris0)) -> ris0-                               (Inventory Nothing ris0) -> ris0-                               (Inventory (Just _) []) -> bug "inventory without tag!"-        Sealed ts <- unseal seal <$>-                         unsafeInterleaveIO-                            (case contents of-                                 (Inventory (Just h') (t' : _)) -> read_ts t' h'-                                 (Inventory (Just _) []) -> bug "inventory without tag!"-                                 (Inventory Nothing _) -> return $ seal NilRL)-        Sealed ps <- unseal seal <$> unsafeInterleaveIO (read_patches is)-        Sealed tag00 <- read_tag tag0-        return $ seal $ ts :<: Tagged tag00 (Just (getValidHash h0)) ps--    read_tag :: (IsRepoType rt, RepoPatch p) => InventoryEntry-             -> IO (Sealed (PatchInfoAnd rt p wX))-    read_tag (i, h) =-        mapSeal (patchInfoAndPatch i) <$> createValidHashed h (parse i)--    readTaggedInventoryFromHash :: String-                                -> IO Inventory-    readTaggedInventoryFromHash invHash = do-        (fileName, pristineAndInventory) <--            fetchFileUsingCache cache HashedInventoriesDir invHash-        case parseInventory pristineAndInventory of-          Just r -> return r-          Nothing -> fail $ unwords ["parse error in file", fileName]---- | 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-      Just r -> return r-      Nothing -> fail $ unwords ["parse error in file", path]---- |copyRepo copies the hashed inventory of @repo@ to the repository located at--- @remote@.-copyHashedInventory :: Repository rt p wR wU wT -> RemoteDarcs -> String -> IO ()-copyHashedInventory outrepo rdarcs inloc | remote <- remoteDarcs rdarcs = do-    let outloc = repoLocation outrepo-    createDirectoryIfMissing False (outloc ++ "/" ++ inventoriesDirPath)-    copyFileOrUrl remote (inloc </> hashedInventoryPath)-                         (outloc </> hashedInventoryPath)-                  Uncachable -- no need to copy anything but hashed_inventory!-    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 :: (IsRepoType rt, 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-    unsafeInterleaveIO $ readp h i-  where-    parse i h = do-        debugMessage ("Rereading patch file: "++ showDoc (displayPatchInfo i))-        (fn, ps) <- fetchFileUsingCache c HashedPatchesDir (getValidHash h)-        case readPatch ps of-            Just x -> return x-            Nothing -> fail $ unlines [ "Couldn't parse patch file " ++ fn-                                      , "which is"-                                      , renderString $ displayPatchInfo i]--    readp h i = do Sealed x <- createValidHashed 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-    debugMessage "in writeTentativeInventory..."-    createDirectoryIfMissing False inventoriesDirPath-    beginTedious tediousName-    hsh <- writeInventoryPrivate $ 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---- |listInventoriesWith returns a list of the inventories hashes.--- The first argument is to choose directory format.--- The first argument can be readInventoryPrivate or readInventoryLocalPrivate.--- The second argument specifies whether the files are expected--- to be stored in plain or in bucketed format.--- The third argument is the directory of the parent inventory files.--- The fourth argument is the directory of the head inventory file.-listInventoriesWith-  :: (FilePath -> IO Inventory)-  -> DirLayout-  -> String -> String -> IO [String]-listInventoriesWith readInv dirformat baseDir startDir = do-    mbStartingWithInv <- getStartingWithHash startDir hashedInventory-    followStartingWiths mbStartingWithInv-  where-    getStartingWithHash dir file = inventoryParent <$> readInv (dir </> file)--    invDir = baseDir </> inventoriesDir-    nextDir dir = case dirformat of-        BucketedLayout -> invDir </> bucketFolder dir-        PlainLayout -> invDir--    followStartingWiths Nothing = return []-    followStartingWiths (Just hash) = do-        let startingWith = getValidHash hash-        mbNextInv <- getStartingWithHash (nextDir startingWith) startingWith-        (startingWith :) <$> followStartingWiths mbNextInv---- |listInventories returns a list of the inventories hashes.--- This function attempts to retrieve missing inventory files.-listInventories :: IO [String]-listInventories =-    listInventoriesWith readInventoryPrivate PlainLayout darcsdir darcsdir---- | Read the given inventory file if it exist, otherwise return an empty--- inventory. Used when we expect that some inventory files may be missing.-readInventoryLocalPrivate :: FilePath -> IO Inventory-readInventoryLocalPrivate path = do-    b <- doesFileExist path-    if b then readInventoryPrivate path-        else return emptyInventory---- | Return inventories hashes by following the head inventory.--- This function does not attempt to retrieve missing inventory files.-listInventoriesLocal :: IO [String]-listInventoriesLocal =-    listInventoriesWith readInventoryLocalPrivate PlainLayout darcsdir darcsdir---- |listInventoriesRepoDir returns a list of the inventories hashes.--- The argument @repoDir@ is the directory of the repository from which--- we are going to read the head inventory file.--- The rest of hashed files are read from the global cache.-listInventoriesRepoDir :: String -> IO [String]-listInventoriesRepoDir repoDir = do-    gCacheDir' <- globalCacheDir-    let gCacheInvDir = fromJust gCacheDir'-    listInventoriesWith-      readInventoryLocalPrivate BucketedLayout gCacheInvDir (repoDir </> darcsdir)---- | Return a list of the patch filenames, extracted from inventory--- files, by starting with the head inventory and then following the--- chain of parent inventories.------ This function does not attempt to download missing inventory files.------ * The first argument specifies whether the files are expected---   to be stored in plain or in bucketed format.--- * The second argument is the directory of the parent inventory.--- * The third argument is the directory of the head inventory.-listPatchesLocal :: DirLayout -> String -> String -> IO [String]-listPatchesLocal dirformat baseDir startDir = do-    inventory <- readInventoryPrivate (startDir </> hashedInventory)-    followStartingWiths (inventoryParent inventory) (inventoryPatchNames inventory)-    where-        invDir = baseDir </> inventoriesDir-        nextDir dir = case dirformat of-            BucketedLayout -> invDir </> bucketFolder dir-            PlainLayout -> invDir--        followStartingWiths Nothing patches = return patches-        followStartingWiths (Just hash) patches = do-            let startingWith = getValidHash hash-            inv <- readInventoryLocalPrivate-                (nextDir startingWith </> startingWith)-            (patches++) <$> followStartingWiths (inventoryParent inv) (inventoryPatchNames inv)---- |listPatchesLocalBucketed is similar to listPatchesLocal, but--- it read the inventory directory under @darcsDir@ in bucketed format.-listPatchesLocalBucketed :: String -> String -> IO [String]-listPatchesLocalBucketed = listPatchesLocal BucketedLayout---- | copyPristine copies a pristine tree into the current pristine dir,---   and possibly copies a clean working copy.---   The target is read from the passed-in dir/inventory name combination.-copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO ()-copyPristine cache dir iname wwd = do-    i <- fetchFilePS (dir ++ "/" ++ iname) Uncachable-    debugMessage $ "Copying hashed pristine tree: " ++ peekPristineHash i-    let tediousName = "Copying pristine"-    beginTedious tediousName-    copyHashed tediousName cache wwd $ peekPristineHash i-    endTedious tediousName---- |copyPartialsPristine copies the pristine entries for a given list of--- filepaths.-copyPartialsPristine :: FilePathLike fp => Cache -> String-                     -> String -> [fp] -> IO ()-copyPartialsPristine c d iname fps = do-    i <- fetchFilePS (d ++ "/" ++ iname) Uncachable-    copyPartialsHashed c (peekPristineHash i) fps--unrevertUrl :: Repository rt p wR wU wT -> String-unrevertUrl r = repoLocation r ++ "/"++darcsdir++"/patches/unrevert"--tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)-                    => Repository rt p wR wU wT-                    -> Compression-                    -> Verbosity-                    -> UpdateWorking-                    -> PatchInfoAnd rt p wT wY-                    -> IO (Repository rt p wR wU wY)-tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine--data UpdatePristine = UpdatePristine -                    | DontUpdatePristine-                    | DontUpdatePristineNorRevert deriving Eq--tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree)-                       => UpdatePristine-                       -> Repository rt p wR wU wT-                       -> Compression-                       -> Verbosity-                       -> UpdateWorking-                       -> FL (PatchInfoAnd rt p) wT wY-                       -> IO (Repository rt p wR wU wY)-tentativelyAddPatches_ up r c v uw ps =-    foldFL_M (\r' p -> tentativelyAddPatch_ up r' c v uw p) r ps---- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun--- :: Bool, with dryRun = unsafePerformIO $ readIORef ...-tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)-                     => UpdatePristine-                     -> Repository rt p wR wU wT-                     -> Compression-                     -> Verbosity-                     -> UpdateWorking-                     -> PatchInfoAnd rt p wT wY-                     -> IO (Repository rt p wR wU wY)--tentativelyAddPatch_ up r compr verb uw p =-    withRepoLocation r $ do-       void $ addToTentativeInventory (repoCache r) compr p-       when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."-                                        applyToTentativePristine r verb p-                                        debugMessage "Updating pending..."-                                        tentativelyRemoveFromPending r uw p-       return (coerceT r)----- |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-                         -> Verbosity-                         -> q wT wY-                         -> IO ()-applyToTentativePristine r verb p =-    withRepoLocation r $-    do when (verb == Verbose) $ putDocLn $ text "Applying to pristine..." <+> description p-       applyToTentativePristineCwd p--applyToTentativePristineCwd :: (ApplyState p ~ Tree, Apply p) => p wX wY-                            -> IO ()-applyToTentativePristineCwd p = do-    tentativePristine <- gzReadFilePS tentativePristinePath-    -- Extract the pristine hash from the tentativePristine file, using-    -- peekPristineHash (this is valid since we normally just extract the hash from the-    -- first line of an inventory file; we can pass in a one-line file that-    -- just contains said hash).-    let tentativePristineHash = peekPristineHash tentativePristine-    newPristineHash <- applyToHashedPristine tentativePristineHash p-    writeDocBinFile tentativePristinePath $-        pokePristineHash newPristineHash tentativePristine--tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                         => Repository rt p wR wU wT-                         -> Compression-                         -> UpdateWorking-                         -> FL (PatchInfoAnd rt p) wX wT-                         -> IO (Repository rt p wR wU wX)-tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine--tentativelyRemovePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                          => UpdatePristine-                          -> Repository rt p wR wU wT-                          -> Compression-                          -> UpdateWorking-                          -> FL (PatchInfoAnd rt p) wX wT-                          -> IO (Repository rt p wR wU wX)-tentativelyRemovePatches_ up r compr uw ps =-    withRepoLocation r $ do-      when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."-                                       prepend r uw $ effect ps-      unless (up == DontUpdatePristineNorRevert) $ removeFromUnrevertContext r ps-      debugMessage "Removing changes from tentative inventory..."-      if formatHas HashedInventory (repoFormat r)-        then do removeFromTentativeInventory r compr ps-                when (up == UpdatePristine) $-                     applyToTentativePristineCwd $-                     progressFL "Applying inverse to pristine" $ invert ps-        else fail Old.oldRepoFailMsg-      return (coerceT r)---- FIXME this is a rather weird API. If called with a patch that isn't already--- in the repo, it fails with an obscure error from 'commuteToEnd'. It also--- ends up redoing the work that the caller has already done - if it has--- already commuted these patches to the end, it must also know the commuted--- versions of the other patches in the repo.--- |Given a sequence of patches anchored at the end of the current repository,--- actually pull them to the end of the repository by removing any patches--- with the same name and then adding the passed in sequence.--- Typically callers will have obtained the passed in sequence using--- 'findCommon' and friends.-tentativelyReplacePatches :: forall rt p wR wU wT wX-                           . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                          => Repository rt p wR wU wT-                          -> Compression-                          -> UpdateWorking-                          -> Verbosity-                          -> FL (PatchInfoAnd rt p) wX wT-                          -> IO ()-tentativelyReplacePatches repository compr uw verb ps =-    do let ps' = filterOutFLFL (namedIsInternal . hopefully) ps-       repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps'-       mapAdd repository' ps'-  where mapAdd :: Repository rt p wM wL wI-               -> FL (PatchInfoAnd rt p) wI wJ-               -> IO ()-        mapAdd _ NilFL = return ()-        mapAdd r (a:>:as) =-               do r' <- tentativelyAddPatch_ DontUpdatePristine r compr verb uw a-                  mapAdd r' as---- The type here should rather be---  ... -> Repo rt p wR wU wT -> IO (Repo rt p wT wU wT)--- In other words: we set the recorded state to the tentative state.-finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                          => Repository rt p wR wU wT-                          -> UpdateWorking-                          -> Compression-                          -> IO ()-finalizeRepositoryChanges r updateWorking compr-    | formatHas HashedInventory (repoFormat r) =-        withRepoLocation r $ do-            debugMessage "Finalizing changes..."-            withSignalsBlocked $ do-                 finalizeTentativeChanges r compr-                 recordedState <- readRecorded r-                 finalizePending r updateWorking recordedState-            debugMessage "Done finalizing changes..."-            ps <- readRepo r-            doesPatchIndexExist (repoLocation r) >>= (`when` createOrUpdatePatchIndexDisk r ps)-            updateIndex 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.--- So the type should rather be------ > ... -> Repo rt p wR wU wT -> IO (Repo rt p wR wU wR)-revertRepositoryChanges :: RepoPatch p-                        => Repository rt p wR wU wT-                        -> UpdateWorking-                        -> IO ()-revertRepositoryChanges r uw- | formatHas HashedInventory (repoFormat r) =-    withRepoLocation r $-    do removeFileMayNotExist (pendingName ++ ".tentative")-       Sealed x <- readPending r-       setTentativePending r uw x-       when (uw == NoUpdateWorking) $ removeFileMayNotExist pendingName-       revertTentativeChanges- | otherwise = fail Old.oldRepoFailMsg--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 r ps = do-  Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (PatchSet NilRL NilRL))-  remove_from_unrevert_context_ bundle-  where unrevert_impossible =-            do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?"-               if confirmed then removeFileMayNotExist (unrevertUrl r)-                            else fail "Cancelled."-        unrevert_patch_bundle :: IO (SealedPatchSet rt p Origin)-        unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl r)-                                   case scanBundle pf of-                                     Right foo -> return foo-                                     Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err-        remove_from_unrevert_context_ :: PatchSet rt p Origin wZ -> IO ()-        remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return ()-        remove_from_unrevert_context_ bundle =-         do debugMessage "Adjusting the context of the unrevert changes..."-            debugMessage $ "Removing "++ show (lengthFL ps) ++-                                  " patches in removeFromUnrevertContext!"-            ref <- readTentativeRepo 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 ()-            withSinglet (mergeThem ref bundle) $ \h_us ->-                  case commuteRL (reverseFL ps :> h_us) of-                    Nothing -> unrevert_impossible-                    Just (us' :> _) ->-                      case removeFromPatchSet ps ref of-                      Nothing -> unrevert_impossible-                      Just common ->-                          do debugMessage "Have now found the new context..."-                             bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL)-                             writeDocBinFile (unrevertUrl r) bundle'-            debugMessage "Done adjusting the context of the unrevert changes!"--cleanRepository :: Repository rt p wR wU wT -> IO ()-cleanRepository r = cleanPristine r >> cleanInventories r >> cleanPatches r---- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree,---   possibly writing a clean working copy in the process.-createPristineDirectoryTree :: 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 Old.oldRepoFailMsg---- fp below really should be FileName--- | Used by the commands dist and diff-createPartialsPristineDirectoryTree :: (FilePathLike fp)-                                    => Repository rt p wR wU wT-                                    -> [fp]-                                    -> FilePath-                                    -> IO ()-createPartialsPristineDirectoryTree r prefs dir-    | formatHas HashedInventory (repoFormat r) =-        do createDirectoryIfMissing True dir-           withCurrentDirectory dir $-            copyPartialsPristine (repoCache r) (repoLocation r)-              hashedInventoryPath prefs-    | otherwise = fail Old.oldRepoFailMsg--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--withTentative :: forall rt p a wR wU wT.-                 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 Old.oldRepoFailMsg---- | Writes out a fresh copy of the inventory that minimizes the--- amount of inventory that need be downloaded when people pull from--- the repository.------ Specifically, it breaks up the inventory on the most recent tag.--- This speeds up most commands when run remotely, both because a--- smaller file needs to be transfered (only the most recent--- inventory).  It also gives a guarantee that all the patches prior--- to a given tag are included in that tag, so less commutation and--- history traversal is needed.  This latter issue can become very--- important in large repositories.-reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                 => Repository rt p wR wU wR-                 -> Compression-                 -> UpdateWorking-                 -> Verbosity-                 -> IO ()-reorderInventory repository compr uw verb = do-        debugMessage "Reordering the inventory."-        PatchSet _ ps <- misplacedPatches `fmap` readRepo repository-        tentativelyReplacePatches repository compr uw verb $ reverseRL ps-        finalizeTentativeChanges repository compr-        debugMessage "Done reordering the inventory."---- | Returns the patches that make the most recent tag dirty.-misplacedPatches :: forall rt p wS wX . RepoPatch p-                 => PatchSet rt p wS wX-                 -> PatchSet rt p wS wX-misplacedPatches ps = -        -- Filter the repository keeping only with the tags, ordered from the-        -- most recent.-        case filter isTag $ mapRL info $ patchSet2RL ps of-                [] -> ps-                (lt:_) -> -                    -- Take the most recent tag, and split the repository in,-                    -- the clean PatchSet "up to" the tag (ts), and a RL of-                    -- patches after the tag (r).-                    case splitOnTag lt ps of-                        Just (PatchSet ts xs :> r) -> PatchSet ts (xs+<+r)-                        _ -> impossible -- Because the tag is in ps.---- @todo: we should not have to open the result of HashedRepo and--- seal it.  Instead, update this function to work with type witnesses--- by fixing DarcsRepo to match HashedRepo in the handling of--- Repository state.-readRepo :: (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)-    | otherwise = do Sealed ps <- Old.readOldRepo (repoLocation r)-                     return $ unsafeCoerceP ps---- | XOR of all hashes of the patches' metadata.--- It enables to quickly see whether two repositories--- have the same patches, independently of their order.--- It relies on the assumption that the same patch cannot--- be present twice in a repository.--- This checksum is not cryptographically secure,--- see http://robotics.stanford.edu/~xb/crypto06b/ .-repoXor :: (IsRepoType rt, RepoPatch p)-        => Repository rt p wR wU wR -> IO SHA1-repoXor repo = do-  hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readRepo repo-  return $ foldl' sha1Xor sha1zero hashes---+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Repository.Hashed+    ( revertTentativeChanges+    , revertRepositoryChanges+    , finalizeTentativeChanges+    , addToTentativeInventory+    , readRepo+    , readRepoHashed+    , readTentativeRepo+    , writeAndReadPatch+    , writeTentativeInventory+    , copyHashedInventory+    , writePatchIfNecessary+    , tentativelyAddPatch+    , tentativelyRemovePatches+    , tentativelyRemovePatches_+    , tentativelyAddPatch_+    , 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 System.Directory+    ( copyFile+    , createDirectoryIfMissing+    , doesFileExist+    , removeFile+    , renameFile+    )+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.Repository.Flags+    ( Compression+    , RemoteDarcs+    , UpdatePending(..)+    , Verbosity(..)+    , remoteDarcs+    )++import Darcs.Repository.Format+    ( RepoProperty( HashedInventory, RebaseInProgress, RebaseInProgress_2_16 )+    , formatHas+    , writeRepoFormat+    , addToFormat+    , removeFromFormat+    )+import Darcs.Repository.Pending+    ( tentativelyRemoveFromPending+    , revertPending+    , finalizePending+    , readTentativePending+    , writeTentativePending+    )+import Darcs.Repository.PatchIndex+    ( createOrUpdatePatchIndexDisk+    , doesPatchIndexExist+    )+import Darcs.Repository.Pristine+    ( ApplyDir(..)+    , applyToTentativePristine+    , applyToTentativePristineCwd+    )+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.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.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )+import Darcs.Patch.Progress (progressFL)+++-- |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++-- |finalizeTentativeChanges trys to atomically swap the tentative+-- inventory/pristine pointers with the "real" pointers; it first re-reads the+-- inventory to optimize it, presumably to take account of any new tags, and+-- then writes out the new tentative inventory, and finally does the atomic+-- swap. In general, we can't clean the pristine cache at the same time, since+-- a simultaneous get might be in progress.+finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p)+                         => Repository rt p wR wU wT -> Compression -> IO ()+finalizeTentativeChanges r compr = do+    debugMessage "Optimizing the inventory..."+    -- Read the tentative patches+    ps <- readTentativeRepo r "."+    writeTentativeInventory (repoCache r) compr ps+    i <- gzReadFilePS tentativeHashedInventoryPath+    p <- gzReadFilePS tentativePristinePath+    -- Write out the "optimised" tentative inventory.+    writeDocBinFile tentativeHashedInventoryPath $ pokePristineHash (peekPristineHash p) i+    -- Atomically swap.+    renameFile tentativeHashedInventoryPath hashedInventoryPath++-- | Add (append) a patch to 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)++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 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]++-- |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 outrepo rdarcs inloc | remote <- remoteDarcs rdarcs = do+    let outloc = repoLocation outrepo+    createDirectoryIfMissing False (outloc ++ "/" ++ inventoriesDirPath)+    copyFileOrUrl remote (inloc </> hashedInventoryPath)+                         (outloc </> hashedInventoryPath)+                  Uncachable -- no need to copy anything but hashed_inventory!+    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+    unsafeInterleaveIO $ readp h i+  where+    parse i h = do+        debugDoc $ text "Rereading patch file:" <+> displayPatchInfo i+        (fn, ps) <- fetchFileUsingCache c HashedPatchesDir (getValidHash h)+        case readPatch ps of+            Right x -> return x+            Left e -> fail $ unlines+                [ "Couldn't parse patch file " ++ fn+                , "which is"+                , renderString $ displayPatchInfo i+                , e+                ]++    readp h i = do Sealed x <- createValidHashed 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+    debugMessage "in writeTentativeInventory..."+    createDirectoryIfMissing False inventoriesDirPath+    beginTedious tediousName+    hsh <- writeInventoryPrivate $ 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++tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)+                    => Repository rt p wR wU wT+                    -> Compression+                    -> Verbosity+                    -> UpdatePending+                    -> PatchInfoAnd rt p wT wY+                    -> IO (Repository rt p wR wU wY)+tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine++data UpdatePristine = UpdatePristine +                    | DontUpdatePristine+                    | DontUpdatePristineNorRevert deriving Eq++tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree)+                       => UpdatePristine+                       -> Repository rt p wR wU wT+                       -> Compression+                       -> Verbosity+                       -> 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+       when (upr == UpdatePristine) $ do+          debugMessage "Applying to pristine cache..."+          applyToTentativePristine r ApplyNormal verb p+       when (upe == YesUpdatePending) $ do+          debugMessage "Updating pending..."+          tentativelyRemoveFromPending r' (effect p)+       return r'++tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+                         => Repository rt p wR wU wT+                         -> Compression+                         -> UpdatePending+                         -> FL (PatchInfoAnd rt p) wX wT+                         -> IO (Repository rt p wR 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)+                          => UpdatePristine+                          -> Repository rt p wR wU wT+                          -> Compression+                          -> UpdatePending+                          -> FL (PatchInfoAnd rt p) wX wT+                          -> IO (Repository rt p wR wU wX)+tentativelyRemovePatches_ upr r compr upe ps+  | formatHas HashedInventory (repoFormat r) = do+      withRepoLocation r $ do+        unless (upr == DontUpdatePristineNorRevert) $ removeFromUnrevertContext r ps+        Sealed pend <- readTentativePending r+        debugMessage "Removing changes from tentative inventory..."+        r' <- removeFromTentativeInventory r compr ps+        withTentativeRebase r r'+          (foldrwFL' (addFixupsToSuspended . hopefully) ps)+        when (upr == UpdatePristine) $+          applyToTentativePristineCwd ApplyInverted $+            progressFL "Applying inverse to pristine" ps+        when (upe == YesUpdatePending) $ do+          debugMessage "Adding changes to pending..."+          writeTentativePending r' $ effect ps +>+ pend+        return r'+  | otherwise = fail Old.oldRepoFailMsg++-- | Attempt to remove an FL of patches from the tentative inventory.+--+-- Precondition: it must be possible to remove the patches, i.e.+--+-- * the patches are in the repository+--+-- * any necessary commutations will succeed+removeFromTentativeInventory :: forall 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+    debugMessage $ "Start removeFromTentativeInventory"+    allpatches :: PatchSet rt p Origin wT <- readTentativeRepo repo "."+    remaining :: PatchSet rt p Origin wX <-+      case removeFromPatchSet to_remove allpatches of+        Nothing -> error "Hashed.removeFromTentativeInventory: precondition violated"+        Just r -> return r+    writeTentativeInventory (repoCache repo) compr 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'+            doesPatchIndexExist (repoLocation r') >>= (`when` createOrUpdatePatchIndexDisk r' ps)+            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++-- | Writes out a fresh copy of the inventory that minimizes the+-- amount of inventory that need be downloaded when people pull from+-- the repository.+--+-- Specifically, it breaks up the inventory on the most recent tag.+-- This speeds up most commands when run remotely, both because a+-- smaller file needs to be transfered (only the most recent+-- inventory).  It also gives a guarantee that all the patches prior+-- to a given tag are included in that tag, so less commutation and+-- history traversal is needed.  This latter issue can become very+-- important in large repositories.+reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+                 => Repository rt p wR wU wR+                 -> Compression+                 -> IO ()+reorderInventory r compr+  | formatHas HashedInventory (repoFormat r) = do+      cleanLatestTag `fmap` readRepo r >>=+        writeTentativeInventory (repoCache r) compr+      withSignalsBlocked $ finalizeTentativeChanges r compr+  | otherwise = fail Old.oldRepoFailMsg++-- | Read inventories and patches from a repository and return them as a+-- 'PatchSet'. Note that patches and inventories are read lazily.+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)+    | otherwise = do Sealed ps <- Old.readOldRepo (repoLocation r)+                     return $ unsafeCoerceP ps++-- | XOR of all hashes of the patches' metadata.+-- It enables to quickly see whether two repositories+-- have the same patches, independently of their order.+-- It relies on the assumption that the same patch cannot+-- be present twice in a repository.+-- This checksum is not cryptographically secure,+-- see http://robotics.stanford.edu/~xb/crypto06b/ .+repoXor :: (IsRepoType rt, RepoPatch p)+        => Repository rt p wR wU wR -> IO SHA1+repoXor repo = do+  hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readRepo 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 view
@@ -23,37 +23,35 @@                                    pathsAndContents                                  ) where -import Prelude () 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 )+import Control.Monad ( when, void, unless, guard ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafeInterleaveIO ) -import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, writeFileUsingCache,+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-    ( FileName-    , normPath-    , fp2fn-    , fn2fp-    , fn2ps-    , ps2fn+    ( AnchoredPath+    , anchorPath+    , anchoredRoot+    , parent     , breakOnDir-    , ownName-    , superName-    , FilePathLike-    , toFilePath+    , Name+    , name2fp+    , decodeWhiteName+    , encodeWhiteName     , isMaliciousSubPath     ) @@ -65,214 +63,245 @@                              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.-readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString)+-- 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 "++hash++" from "++hashedDir subdir++"/"-       r <- fetchFileUsingCache 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,-                         rootHash :: !String }+                         cwdHash :: !PristineHash } type HashedIO = StateT HashDir IO -mWithCurrentDirectory :: FileName -> HashedIO a -> HashedIO a-mWithCurrentDirectory fn j-    | fn' == fp2fn "" = j-    | otherwise =-        case breakOnDir fn' of-        Nothing -> do c <- readroot-                      case geta D fn' c of-                        Nothing -> fail "dir doesn't exist in mWithCurrentDirectory..."-                        Just h -> do (h',x) <- withh h j-                                     writeroot $ seta D fn' h' c-                                     return x-        Just (d,fn'') -> do c <- readroot-                            case geta D d c of-                              Nothing -> fail "dir doesn't exist..."-                              Just h -> do (h',x) <- withh h $ mWithCurrentDirectory fn'' j-                                           writeroot $ seta D d h' c-                                           return x-    where fn' = normPath fn+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 -mInCurrentDirectory :: FileName -> HashedIO a -> HashedIO a-mInCurrentDirectory fn j | fn' == fp2fn "" = j-                         | otherwise =-                             case breakOnDir fn' of-                             Nothing -> do c <- readroot-                                           case geta D fn' c of-                                             Nothing -> fail "dir doesn't exist mInCurrentDirectory..."-                                             Just h -> inh h j-                             Just (d,fn'') -> do c <- readroot-                                                 case geta D d c of-                                                   Nothing -> fail "dir doesn't exist..."-                                                   Just h -> inh h $ mInCurrentDirectory fn'' j-    where fn' = normPath fn+-- | 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 fn = do thing <- identifyThing fn-                                case thing of Just (D,_) -> return True-                                              _ -> return False-    mReadFilePS fn = mInCurrentDirectory (superName fn) $ do-                                          c <- readroot-                                          case geta F (ownName fn) c of-                                            Nothing -> fail $ " file don't exist... "++ fn2fp fn-                                            Just h -> readhash h-    mCreateDirectory fn = do h <- writeHashFile B.empty-                             exists <- isJust `fmap` identifyThing fn-                             when exists $ fail "can't mCreateDirectory over an existing object."-                             makeThing fn (D,h)-    mRename o n = do nexists <- isJust `fmap` identifyThing n-                     when nexists $ fail "mRename failed..."-                     mx <- identifyThing o+    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-                                             makeThing n x+      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 "++fn2fp f-                       rmThing f -identifyThing :: FileName -> HashedIO (Maybe (ObjType,String))-identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash-                                        return $ Just (D, h)-                 | otherwise = case breakOnDir fn' of-                               Nothing -> getany fn' `fmap` readroot-                               Just (d,fn'') -> do c <- readroot-                                                   case geta D d c of-                                                     Nothing -> return Nothing-                                                     Just h -> inh h $ identifyThing fn''-        where fn' = normPath fn+    mRemoveFile f = do+      x <- mReadFilePS f+      when (B.length x /= 0) $ fail $ "Cannot remove non-empty file " ++ ap2fp f+      rmThing f -makeThing :: FileName -> (ObjType,String) -> HashedIO ()-makeThing fn (o,h) = mWithCurrentDirectory (superName $ normPath fn) $-                     seta o (ownName $ normPath fn) h `fmap` readroot >>= writeroot+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' -rmThing :: FileName -> HashedIO ()-rmThing fn = mWithCurrentDirectory (superName $ normPath fn) $-             do c <- readroot-                let c' = filter (\(_,x,_)->x/= ownName (normPath fn)) c-                if length c' == length c - 1-                  then writeroot c'-                  else fail "obj doesn't exist in rmThing"+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' -readhash :: String -> HashedIO B.ByteString+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 :: String -> HashedIO a -> HashedIO (String,a)+withh :: PristineHash -> HashedIO a -> HashedIO (PristineHash,a) withh h j = do hd <- get-               put $ hd { rootHash = h }+               put $ hd { cwdHash = h }                x <- j-               h' <- gets rootHash+               h' <- gets cwdHash                put hd                return (h',x) -inh :: String -> HashedIO a -> HashedIO a+inh :: PristineHash -> HashedIO a -> HashedIO a inh h j = snd `fmap` withh h j -readroot :: HashedIO [(ObjType, FileName, String)]-readroot = do haveitalready <- peekroot-              cc <- gets rootHash >>= readdir-              unless haveitalready $ speculate cc-              return cc-    where speculate :: [(a,b,String)] -> HashedIO ()+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 z) c+                           mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir (getValidHash z)) c           peekroot :: HashedIO Bool           peekroot = do HashDir c h <- get-                        lift $ peekInCache c HashedPristineDir h+                        lift $ peekInCache c HashedPristineDir (getValidHash h) -writeroot :: [(ObjType, FileName, String)] -> HashedIO ()-writeroot c = do+writecwd :: [DirEntry] -> HashedIO ()+writecwd c = do   h <- writedir c-  modify $ \hd -> hd { rootHash = h }+  modify $ \hd -> hd { cwdHash = h }  data ObjType = F | D deriving Eq --- | @geta objtype name stuff@ tries to get an object of type @objtype@ named @name@--- in @stuff@.-geta :: ObjType -> FileName -> [(ObjType, FileName, String)] -> Maybe String-geta o f c = do (o',h) <- getany f c-                if o == o' then Just h else Nothing+-- | @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 :: FileName -> [(ObjType, FileName, String)] -> Maybe (ObjType,String)+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 -> FileName -> String -> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]+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 :: String -> HashedIO [(ObjType, FileName, String)]+readdir :: PristineHash -> HashedIO [DirEntry] readdir hash = do-  x <- readhash hash-  lift $ debugMessage  $ show x-  let r = (parsed . linesPS) x-  lift $ debugMessage  $ unlines $ map (\(_,fn,_) -> "DEBUG readdir " ++ hash ++ " entry: " ++ show fn) r-  return r+    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-    parsed (t:n:h:rest) | t == dir = (D, ps2fn n, BC.unpack h) : parsed rest-                        | t == file = (F, ps2fn n, BC.unpack h) : parsed rest-    parsed _ = []+    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 _ = [] -dir :: B.ByteString-dir = BC.pack "directory:"-file :: B.ByteString-file = BC.pack "file:"+dirType :: B.ByteString+dirType = BC.pack "directory:" +fileType :: B.ByteString+fileType = BC.pack "file:" -writedir :: [(ObjType, FileName, String)] -> HashedIO String+writedir :: [DirEntry] -> HashedIO PristineHash writedir c = do-  lift $ debugMessage  $ unlines $ map (\(_,fn,_) -> "DEBUG writedir entry: " ++ show fn) c+  --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,fn2ps d,BC.pack h]-    showO D = dir-    showO F = file+    wr (o,d,h) = [showO o, encodeWhiteName d, BC.pack (getValidHash h)]+    showO D = dirType+    showO F = fileType -writeHashFile :: B.ByteString -> HashedIO String-writeHashFile ps = do c <- gets cache-                      -- pristine files are always compressed-                      lift $ writeFileUsingCache c GzipCompression HashedPristineDir ps+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 copy.-copyHashed :: String -> Cache -> WithWorkingDir -> String -> IO ()-copyHashed k c wwd z = void . runStateT cph $ HashDir { cache = c, rootHash = z }-    where cph = do cc <- readroot-                   lift $ tediousSize k (length cc)-                   mapM_ cp cc+--   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 (fn2fp n)-              lift $ debugMessage $ "DEBUG copyHashed " ++ show n+              lift $ finishedOneIO k $ name2fp n+              --lift $ debugMessage $ "DEBUG copyHashed " ++ show n               case wwd of-                WithWorkingDir -> lift $ writeAtomicFilePS (fn2fp n) ps+                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 (fn2fp n)-                 then fail ("Caught malicious path: " ++ fn2fp n)+              if isMaliciousSubPath (name2fp n)+                 then fail ("Caught malicious path: " ++ name2fp n)                  else do-                 lift $ finishedOneIO k (fn2fp n)+                 lift $ finishedOneIO k (name2fp n)                  case wwd of                    WithWorkingDir -> do-                     lift $ createDirectoryIfMissing False (fn2fp n)-                     lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c WithWorkingDir h+                     lift $ createDirectoryIfMissing False (name2fp n)+                     lift $ withCurrentDirectory (name2fp n) $ copyHashed k c WithWorkingDir h                    NoWorkingDir ->                      lift $ copyHashed k c NoWorkingDir h @@ -281,61 +310,66 @@ --   @path@ should be either "." or end with "/" --   Separator "/" is used since this function is used to generate --   zip archives from pristine trees.-pathsAndContents :: FilePath -> Cache ->  String -> IO [(FilePath,B.ByteString)]-pathsAndContents path c root = evalStateT cph HashDir { cache = c, rootHash = root }-    where cph = do cc <- readroot-                   pacs <- concat <$> mapM cp cc+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 ++ "/") ++ fn2fp n+              let p = (if path == "." then "" else path ++ "/") ++ name2fp n               return [(p,ps)]           cp (D,n,h) = do-              let p = (if path == "." then "" else path) ++ fn2fp n ++ "/"+              let p = (if path == "." then "" else path) ++ name2fp n ++ "/"               lift $ pathsAndContents p c h -copyPartialsHashed :: FilePathLike fp =>-                      Cache -> String -> [fp] -> IO ()+copyPartialsHashed :: Cache -> PristineHash -> [AnchoredPath] -> IO () copyPartialsHashed c root = mapM_ (copyPartialHashed c root) -copyPartialHashed :: FilePathLike fp => Cache -> String -> fp -> IO ()-copyPartialHashed c root ff =-    do createDirectoryIfMissing True (basename $ toFilePath ff)-       void $ runStateT (cp $ fp2fn $ toFilePath ff)-                 HashDir { cache = c,-                           rootHash = root }- where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse-       cp f = do mt <- identifyThing f-                 case mt of-                   Just (D,h) -> do lift $ createDirectoryIfMissing True (fn2fp f)-                                    lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c WithWorkingDir h-                   Just (F,h) -> do ps <- readhash h-                                    lift $ writeAtomicFilePS (fn2fp f) ps-                   Nothing -> return ()+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 -> [String] -> IO ()-cleanHashdir c dir_ hashroots =+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 hashroots+      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)+      cleanCachesWithHint c dir (unset $ fs `Set.difference` hs)    where set = Set.fromList . map BC.pack          unset = map BC.unpack . Set.toList  -- | getHashedFiles returns all hash files targeted by files in hashroots in -- the hashdir directory.-getHashedFiles :: String -> [String] -> IO [String]+getHashedFiles :: 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+  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
@@ -10,6 +10,7 @@     , identifyRepository     , identifyRepositoryFor     , IdentifyRepo(..)+    , ReadingOrWriting(..)     , findRepository     , amInRepository     , amNotInRepository@@ -18,7 +19,6 @@     , findAllReposInDir     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( forM )@@ -30,7 +30,7 @@                         , setCurrentDirectory                         , createDirectoryIfMissing                         , doesFileExist-                        , getDirectoryContents+                        , listDirectory                         ) import System.FilePath.Posix ( (</>) ) import System.IO.Error ( catchIOError )@@ -48,6 +48,11 @@ import Darcs.Util.Workaround     ( getCurrentDirectory     )+import Darcs.Repository.Paths+    ( hashedInventoryPath+    , oldCurrentDirPath+    , oldPristineDirPath+    ) import Darcs.Repository.Prefs ( getCaches ) import Darcs.Repository.InternalTypes( Repository                                      , PristineType(..)@@ -94,9 +99,9 @@  identifyPristine :: IO PristineType identifyPristine =-    do pristine <- doesDirectoryExist $ darcsdir++"/pristine"-       current  <- doesDirectoryExist $ darcsdir++"/current"-       hashinv  <- doesFileExist      $ darcsdir++"/hashed_inventory"+    do pristine <- doesDirectoryExist oldPristineDirPath+       current  <- doesDirectoryExist oldCurrentDirPath+       hashinv  <- doesFileExist      hashedInventoryPath        case (pristine || current, hashinv) of            (False, False) -> return NoPristine            (True,  False) -> return PlainPristine@@ -105,8 +110,7 @@  -- | identifyRepository identifies the repo at 'url'. Warning: -- you have to know what kind of patches are found in that repo.-identifyRepository :: forall rt p wR wU wT. UseCache -> String-                           -> IO (Repository rt p wR wU wT)+identifyRepository :: UseCache -> String -> IO (Repository rt p wR wU wT) identifyRepository useCache url =     do er <- maybeIdentifyRepository useCache url        case er of@@ -114,18 +118,24 @@          NonRepository s -> fail s          GoodRepository r -> return r +data ReadingOrWriting = Reading | Writing+ -- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url', -- but fails if it is not compatible for reading from and writing to.-identifyRepositoryFor :: forall rt p wR wU wT vR vU vT.-                         Repository rt p wR wU wT+identifyRepositoryFor :: ReadingOrWriting+                      -> Repository rt p wR wU wT                       -> UseCache                       -> String                       -> IO (Repository rt p vR vU vT)-identifyRepositoryFor source useCache url =-    do target <- identifyRepository useCache url-       case transferProblem (repoFormat target) (repoFormat source) of-         Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e-         Nothing -> return target+identifyRepositoryFor what us useCache them_loc = do+  them <- identifyRepository useCache them_loc+  case+    case what of+      Reading -> transferProblem (repoFormat them) (repoFormat us)+      Writing -> transferProblem (repoFormat us) (repoFormat them) +    of+      Just e -> fail $ "Incompatibility with repository " ++ them_loc ++ ":\n" ++ e+      Nothing -> return them  amInRepository :: WorkRepo -> IO (Either String ()) amInRepository (WorkRepoDir d) =@@ -221,9 +231,8 @@     else return []   where     getRecursiveDarcsRepos' d = do-      names <- getDirectoryContents d-      let properNames = filter (\x -> head x /= '.') names-      paths <- forM properNames $ \name -> 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,30 +13,27 @@ -- 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-                                      , repoPatchType                                       , repoFormat                                       , repoLocation                                       , withRepoLocation                                       , repoPristineType-                                      , coerceR-                                      , coerceU-                                      , coerceT+                                      , unsafeCoerceRepoType+                                      , unsafeCoercePatchType+                                      , unsafeCoerceR+                                      , unsafeCoerceU+                                      , unsafeCoerceT                                       , mkRepo                                       ) where -import Prelude () import Darcs.Prelude -import Data.Coerce ( coerce )-import Data.List ( nub, sortBy )-import Darcs.Repository.Cache ( Cache (..) , compareByLocality )+import Darcs.Repository.Cache ( Cache ) import Darcs.Repository.Format ( RepoFormat ) import Darcs.Patch ( RepoType )-import Darcs.Patch.Type ( PatchType(..) ) import Darcs.Util.File ( withCurrentDirectory )+import Unsafe.Coerce ( unsafeCoerce )  data PristineType   = NoPristine@@ -47,12 +44,14 @@ -- |A @Repository@ is a token representing the state of a repository on disk. -- It is parameterized by the patch type in the repository, and witnesses for -- the recorded state of the repository (i.e. what darcs get would retrieve),--- the unrecorded state (what's in the working directory now),+-- 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 ) +type role Repository nominal nominal nominal nominal nominal+ repoLocation :: Repository rt p wR wU wT -> String repoLocation (Repo loc _ _ _) = loc @@ -68,24 +67,23 @@ repoCache :: Repository rt p wR wU wT -> Cache repoCache (Repo _ _ _ c) = c --- | 'modifyCache' @repository function@ modifies the cache of---   @repository@ with @function@, remove duplicates and sort the results with 'compareByLocality'.-modifyCache :: forall rt p wR wU wT . Repository rt p wR wU wT -> (Cache -> Cache) -> Repository rt p wR wU wT-modifyCache (Repo dir rf pristine cache) f-   = Repo dir rf pristine $ cmap ( sortBy compareByLocality . nub ) $ f cache-  where cmap g (Ca c) = Ca (g c)+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) -repoPatchType :: Repository rt p wR wU wT -> PatchType rt p-repoPatchType _ = PatchType+unsafeCoerceRepoType :: Repository rt p wR wU wT -> Repository rt' p wR wU wT+unsafeCoerceRepoType = unsafeCoerce -coerceR :: Repository rt p wR wU wT -> Repository rt p wR' wU wT-coerceR = coerce+unsafeCoercePatchType :: Repository rt p wR wU wT -> Repository rt p' wR wU wT+unsafeCoercePatchType = unsafeCoerce -coerceU :: Repository rt p wR wU wT -> Repository rt p wR wU' wT-coerceU = coerce+unsafeCoerceR :: Repository rt p wR wU wT -> Repository rt p wR' wU wT+unsafeCoerceR = unsafeCoerce -coerceT :: Repository rt p wR wU wT -> Repository rt p wR wU wT'-coerceT = coerce+unsafeCoerceU :: Repository rt p wR wU wT -> Repository rt p wR wU' wT+unsafeCoerceU = unsafeCoerce++unsafeCoerceT :: Repository rt p wR wU wT -> Repository rt p wR wU wT'+unsafeCoerceT = unsafeCoerce  mkRepo :: String -> RepoFormat -> PristineType -> Cache -> Repository rt p wR wU wT mkRepo = Repo
src/Darcs/Repository/Inventory.hs view
@@ -8,6 +8,7 @@     , PristineHash     , inventoryPatchNames     , parseInventory+    , parseHeadInventory -- not used     , showInventory     , showInventoryPatches     , showInventoryEntry@@ -22,7 +23,6 @@     , prop_skipPokePristineHash     ) where -import Prelude () import Darcs.Prelude hiding ( take )  import Control.Applicative ( optional, many )@@ -32,8 +32,8 @@ import qualified Data.ByteString.Char8 as BC  import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo )-import Darcs.Patch.ReadMonads-    ( ParserM, parseStrictly, string, skipSpace, take, takeTillChar )+import Darcs.Util.Parser+    ( Parser, parse, string, skipSpace, take, takeTillChar ) import Darcs.Patch.Show ( ShowPatchFor(..) ) import Darcs.Repository.Cache ( okayHash ) import Darcs.Util.Hash ( sha256sum )@@ -80,12 +80,11 @@  -- * Inventories --- Note: this type and the commented out parser combinators for it--- aren't actually used (except for testing). They are left 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 with forcing a complete parse of the head inventory. Thus we--- retain the lower-level peek/poke/skip API for the pristine hash.+-- 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@@ -104,47 +103,43 @@  -- * Parsing -{--parseHeadInventory :: B.ByteString -> Maybe HeadInventory+parseHeadInventory :: B.ByteString -> Either String HeadInventory parseHeadInventory = fmap fst . parse pHeadInv--} -parseInventory :: B.ByteString -> Maybe Inventory-parseInventory = fmap fst . parseStrictly pInv+parseInventory :: B.ByteString -> Either String Inventory+parseInventory = fmap fst . parse pInv -{--pHeadInv :: ParserM m => m HeadInventory-pHeadInv = (,) <$> pInvPristine <*> pInv+pHeadInv :: Parser HeadInventory+pHeadInv = (,) <$> pPristineHash <*> pInv -pInvPristine :: ParserM m => m ValidHash-pInvPristine = do+pPristineHash :: Parser PristineHash+pPristineHash = do   string pristineName   skipSpace   pHash--} -pInv :: ParserM m => m Inventory+pInv :: Parser Inventory pInv = Inventory <$> pInvParent <*> pInvPatches -pInvParent :: ParserM m => m (Maybe InventoryHash)+pInvParent :: Parser (Maybe InventoryHash) pInvParent = optional $ do   string parentName   skipSpace   pHash -pHash :: (ParserM m, ValidHash h) => m h+pHash :: ValidHash h => Parser h pHash = do   hash <- BC.unpack <$> pLine   guard (okayHash hash)   return (mkValidHash hash) -pLine :: ParserM m => m B.ByteString+pLine :: Parser B.ByteString pLine = takeTillChar '\n' <* take 1 -pInvPatches :: ParserM m => m [InventoryEntry]+pInvPatches :: Parser [InventoryEntry] pInvPatches = many pInvEntry -pInvEntry :: ParserM m => m InventoryEntry+pInvEntry :: Parser InventoryEntry pInvEntry = do   info <- readPatchInfo   skipSpace@@ -177,8 +172,8 @@  -- | Replace the pristine hash at the start of a raw, unparsed 'HeadInventory' -- or add it if none is present.-pokePristineHash :: String -> B.ByteString -> Doc-pokePristineHash h inv =+pokePristineHash :: PristineHash -> B.ByteString -> Doc+pokePristineHash (PristineHash h) inv =   invisiblePS pristineName <> text h $$ invisiblePS (skipPristineHash inv)  takeHash :: B.ByteString -> Maybe (String, B.ByteString)@@ -188,14 +183,14 @@   guard $ okayHash hash   return (hash, rest) -peekPristineHash :: B.ByteString -> String+peekPristineHash :: B.ByteString -> PristineHash peekPristineHash inv =   case tryDropPristineName inv of     Just rest ->       case takeHash rest of-        Just (h, _) -> h+        Just (h, _) -> mkValidHash h         Nothing -> error $ "Bad hash in inventory!"-    Nothing -> sha256sum B.empty+    Nothing -> mkValidHash $ sha256sum B.empty  -- |skipPristineHash drops the 'pristine: HASH' prefix line, if present. skipPristineHash :: B.ByteString -> B.ByteString@@ -228,12 +223,12 @@  prop_inventoryParseShow :: Inventory -> Bool prop_inventoryParseShow inv =-  Just inv == parseInventory (renderPS (showInventory inv))+  Right inv == parseInventory (renderPS (showInventory inv))  prop_peekPokePristineHash :: (PristineHash, B.ByteString) -> Bool-prop_peekPokePristineHash (PristineHash hash, raw) =+prop_peekPokePristineHash (hash, raw) =   hash == peekPristineHash (renderPS (pokePristineHash hash raw))  prop_skipPokePristineHash :: (PristineHash, B.ByteString) -> Bool-prop_skipPokePristineHash (PristineHash hash, raw) =+prop_skipPokePristineHash (hash, raw) =   raw == skipPristineHash (renderPS (pokePristineHash hash raw))
src/Darcs/Repository/Job.hs view
@@ -30,17 +30,15 @@     , withUMaskFlag     ) where -import Prelude () import Darcs.Prelude -import Darcs.Util.Global ( darcsdir )- import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.V1 ( RepoPatchV1 ) import Darcs.Patch.V2 ( RepoPatchV2 )+import Darcs.Patch.V3 ( RepoPatchV3 ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )-import Darcs.Patch.Prim ( PrimOf )+import Darcs.Patch ( PrimOf ) import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.RepoType@@ -50,11 +48,13 @@   )  import Darcs.Repository.Flags-    ( UseCache(..), UpdateWorking(..), DryRun(..), UMask (..)+    ( UseCache(..), UpdatePending(..), DryRun(..), UMask (..)     ) import Darcs.Repository.Format     ( RepoProperty( Darcs2+                  , Darcs3                   , RebaseInProgress+                  , RebaseInProgress_2_16                   , HashedInventory                   )     , formatHas@@ -66,20 +66,22 @@     ( Repository     , repoFormat     , repoLocation+    , unsafeCoerceRepoType+    , unsafeCoercePatchType     )+import Darcs.Repository.Paths ( lockPath ) import Darcs.Repository.Rebase-    ( RebaseJobFlags-    , startRebaseJob+    ( startRebaseJob     , rebaseJob+    , maybeDisplaySuspendedStatus+    , checkOldStyleRebaseStatus     )-import qualified Darcs.Repository.Rebase as Rebase ( maybeDisplaySuspendedStatus ) import Darcs.Util.Lock ( withLock, withLockCanFail )  import Darcs.Util.Progress ( debugMessage )  import Control.Monad ( when ) import Control.Exception ( bracket_, finally )-import Data.Coerce ( coerce ) import Data.List ( intercalate )  import Foreign.C.String ( CString, withCString )@@ -88,12 +90,9 @@  import Darcs.Util.Tree ( Tree ) -getUMask :: UMask -> Maybe String-getUMask (YesUMask s) = Just s-getUMask NoUMask = Nothing- withUMaskFlag :: UMask -> IO a -> IO a-withUMaskFlag = maybe id withUMask . getUMask+withUMaskFlag NoUMask = id+withUMaskFlag (YesUMask umask) = withUMask umask  foreign import ccall unsafe "umask.h set_umask" set_umask     :: CString -> IO CInt@@ -136,9 +135,10 @@     | 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 RebaseJobFlags (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO a)-    | RebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)-    | StartRebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)+    | 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)  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)@@ -147,9 +147,10 @@ onRepoJob (V1Job job) f = V1Job (f job) onRepoJob (V2Job job) f = V2Job (f job) onRepoJob (PrimV1Job job) f = PrimV1Job (f job)-onRepoJob (RebaseAwareJob flags job) f = RebaseAwareJob flags (f job)-onRepoJob (RebaseJob flags job) f      = RebaseJob flags (f job)-onRepoJob (StartRebaseJob flags job) f = StartRebaseJob flags (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@@ -160,6 +161,7 @@ data RepoPatchType p where   RepoV1 :: RepoPatchType (RepoPatchV1 V1.Prim)   RepoV2 :: RepoPatchType (RepoPatchV2 V2.Prim)+  RepoV3 :: RepoPatchType (RepoPatchV3 V2.Prim)  -- | This type allows us to check multiple patch types against the -- constraints required by most repository jobs@@ -169,6 +171,7 @@ checkTree :: RepoPatchType p -> IsTree p checkTree RepoV1 = IsTree checkTree RepoV2 = IsTree+checkTree RepoV3 = IsTree  class ApplyState p ~ Tree => IsPrimV1 p where   toPrimV1 :: p wX wY -> Prim wX wY@@ -185,6 +188,7 @@ 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@@ -204,15 +208,19 @@           :: IsRebaseType rebaseType           => SRebaseType rebaseType -> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a         runJob1 isRebase =-          if formatHas Darcs2 rf-          then runJob RepoV2 (SRepoType isRebase)-          else runJob RepoV1 (SRepoType 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-          then runJob1 SIsRebase-          else runJob1 SNoRebase+          if startRebase ||+             formatHas RebaseInProgress rf || formatHas RebaseInProgress_2_16 rf+            then runJob1 SIsRebase+            else runJob1 SNoRebase      runJob2 repo repojob @@ -230,11 +238,12 @@   -- 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 = coerce repo :: Repository rt p wR wU wR+    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" @@ -256,70 +265,92 @@   case repojob of     RepoJob job ->       case checkTree patchType of-        IsTree ->+        IsTree -> do+          checkOldStyleRebaseStatus isRebase therepo           job therepo             `finally`-              Rebase.maybeDisplaySuspendedStatus isRebase therepo+              maybeDisplaySuspendedStatus isRebase therepo      PrimV1Job job ->       case checkPrimV1 patchType of         UsesPrimV1 -> do+          checkOldStyleRebaseStatus isRebase therepo           job therepo             `finally`-              Rebase.maybeDisplaySuspendedStatus isRebase therepo+              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."-        (RepoV2, SIsRebase) ->-          fail "This command is not supported while a rebase is in progress."+        (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."-        (RepoV1, SIsRebase) ->-          fail "This command is not supported while a rebase is in progress."+        (RepoV3, _        ) ->+          fail $    "This repository contains darcs v3 patches,"+                 ++ " but the command requires darcs v1 patches." -    RebaseAwareJob flags job ->+    RebaseAwareJob job ->       case (checkTree patchType, isRebase) of         (IsTree, SNoRebase) -> job therepo-        (IsTree, SIsRebase) -> rebaseJob job therepo flags+        (IsTree, SIsRebase) -> do+          checkOldStyleRebaseStatus isRebase therepo+          rebaseJob job therepo -    RebaseJob flags job ->+    RebaseJob job ->       case (checkTree patchType, isRebase) of         (_     , SNoRebase) -> fail "No rebase in progress. Try 'darcs rebase suspend' first."-        (IsTree, SIsRebase) -> rebaseJob job therepo flags+        (IsTree, SIsRebase) -> do+          checkOldStyleRebaseStatus isRebase therepo+          rebaseJob job therepo -    StartRebaseJob flags job ->-       case (checkTree patchType, isRebase) of-         (_     , SNoRebase) -> impossible-         (IsTree, SIsRebase) -> startRebaseJob job therepo flags+    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 the current working directory,---   taking a lock-withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a-withRepoLock dry useCache uw um repojob =-    withRepository useCache $ onRepoJob repojob $ \job repository ->-    do maybe (return ()) fail $ writeProblem (repoFormat repository)-       let name = "./"++darcsdir++"/lock"-       withUMaskFlag um $-         if dry == YesDryRun-           then job repository-           else withLock name (revertRepositoryChanges repository uw >> job repository)+    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.+-- 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 =+  withLock lockPath $+    withRepository useCache $ onRepoJob repojob $ \job repository -> do+      maybe (return ()) fail $ writeProblem (repoFormat repository)+      withUMaskFlag um $ revertRepositoryChanges repository upe >>= job+ -- | run a lock-taking job in an old-fashion repository. --   only used by `darcs optimize upgrade`. withOldRepoLock :: RepoJob a -> IO a withOldRepoLock repojob =     withRepository NoUseCache $ onRepoJob repojob $ \job repository ->-    do let name = "./"++darcsdir++"/lock"-       withLock name $ job repository+    withLock lockPath $ job 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@@ -327,17 +358,20 @@ -- because there is no call to revertRepositoryChanges. This entry point is -- currently only used for attemptCreatePatchIndex. withRepoLockCanFail :: UseCache -> RepoJob () -> IO ()-withRepoLockCanFail useCache repojob =-    withRepository useCache $ onRepoJob repojob $ \job repository ->-    let rf = repoFormat repository in-    if formatHas HashedInventory rf then do-       maybe (return ()) fail $ writeProblem rf-       let name = "./"++darcsdir++"/lock"-       eitherDone <- withLockCanFail name (job repository)-       case eitherDone of-         Left  _ -> debugMessage "Lock could not be obtained, not doing the job."-         Right _ -> return ()-      else debugMessage "Not doing the job because this is an old-fashioned repository."+withRepoLockCanFail useCache repojob = do+  eitherDone <-+    withLockCanFail lockPath $+      withRepository useCache $ onRepoJob repojob $ \job repository -> do+        let rf = repoFormat repository+        if formatHas HashedInventory rf then do+          maybe (return ()) fail $ writeProblem rf+          job repository+        else+          debugMessage+            "Not doing the job because this is an old-fashioned repository."+  case eitherDone of+    Left  _ -> debugMessage "Lock could not be obtained, not doing the job."+    Right _ -> return ()  -- | If the 'RepoType' of the given repo indicates that we have 'NoRebase', -- then 'Just' the repo with the refined type, else 'Nothing'.
src/Darcs/Repository/Match.hs view
@@ -17,68 +17,57 @@  module Darcs.Repository.Match     (-      getNonrangeMatch+      getRecordedUpToMatch     , getOnePatchset     ) where -import Prelude () import Darcs.Prelude -import Control.Exception ( throw )- import Darcs.Patch.Match-    ( getNonrangeMatchS-    , nonrangeMatcherIsTag+    ( rollbackToPatchSetMatch+    , PatchSetMatch(..)     , getMatchingTag     , matchAPatchset-    , nonrangeMatcher-    , applyNInv-    , hasIndexRange-    , MatchFlag(..)     ) -import Darcs.Patch.Bundle ( scanContextFile )+import Darcs.Patch.Bundle ( readContextFile ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch ( RepoPatch, IsRepoType )-import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, Origin )-import Darcs.Patch.Witnesses.Sealed ( seal )+import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet, patchSetDrop )  import Darcs.Repository.Flags     ( WithWorkingDir (WithWorkingDir) ) import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault ) import Darcs.Repository.InternalTypes ( Repository )-import Darcs.Repository.Hashed-    ( readRepo, createPristineDirectoryTree )+import Darcs.Repository.Hashed ( readRepo )+import Darcs.Repository.Pristine ( createPristineDirectoryTree )  import Darcs.Util.Tree ( Tree )  import Darcs.Util.Path ( toFilePath ) -getNonrangeMatch :: (ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                 => Repository rt p wR wU wT-                 -> [MatchFlag]-                 -> IO ()-getNonrangeMatch r = withRecordedMatch r . getMatch where-  getMatch fs = case hasIndexRange fs of-    Just (n, m) | n == m -> applyNInv (n-1)-                | otherwise -> throw $ userError "Index range is not allowed for this command."-    _ -> getNonrangeMatchS fs+-- | 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+                     -> PatchSetMatch+                     -> IO ()+getRecordedUpToMatch r = withRecordedMatch r . rollbackToPatchSetMatch  getOnePatchset :: (IsRepoType rt, RepoPatch p)-               => Repository rt p wR wU wT-               -> [MatchFlag]+               => Repository rt p wR wU wR+               -> PatchSetMatch                -> IO (SealedPatchSet rt p Origin)-getOnePatchset repository fs =-    case nonrangeMatcher fs of-        Just m -> do ps <- readRepo repository-                     if nonrangeMatcherIsTag fs-                        then return $ getMatchingTag m ps-                        else return $ matchAPatchset m ps-        Nothing -> seal `fmap` (scanContextFile . toFilePath . context_f $ fs)-    where context_f [] = bug "Couldn't match_nonrange_patchset"-          context_f (Context f:_) = f-          context_f (_:xs) = context_f xs+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+    ContextMatch path -> do+      ref <- readRepo repository+      readContextFile ref (toFilePath path)  withRecordedMatch :: (IsRepoType rt, RepoPatch p)                   => Repository rt p wR wU wT
src/Darcs/Repository/Merge.hs view
@@ -21,32 +21,34 @@ module Darcs.Repository.Merge     ( tentativelyMergePatches     , considerMergeToWorking-    , announceMergeConflicts     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when, unless )-import Data.List.Ordered ( nubSort ) import System.Exit ( exitSuccess )+import System.IO.Error+    ( catchIOError+    , ioeGetErrorType+    , isIllegalOperationErrorType+    )  import Darcs.Util.Tree( Tree ) import Darcs.Util.External ( backupByCopying )  import Darcs.Patch-    ( RepoPatch, IsRepoType, PrimOf, merge, listTouchedFiles-    , fromPrims, effect, WrappedNamed+    ( RepoPatch, IsRepoType, PrimOf, merge+    , effect     , listConflictedFiles )-import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Depends( merge2FL )-import Darcs.Patch.Named.Wrapped ( activecontents, anonymous, namedIsInternal )+import Darcs.Patch.Ident ( merge2FL )+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.Witnesses.Ordered-    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+),-    mapFL_FL, concatFL, filterOutFLFL )+    ( FL(..), RL(..), Fork(..), (:\/:)(..), (:/\:)(..), (+>+), (+<<+)+    , mapFL_FL, concatFL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )  import Darcs.Repository.Flags@@ -54,177 +56,292 @@     , ScanKnown     , AllowConflicts (..)     , Reorder (..)-    , UpdateWorking (..)+    , UpdatePending (..)     , ExternalMerge (..)     , Verbosity (..)     , Compression (..)     , WantGuiPause (..)     , DiffAlgorithm (..)-    , UseCache(..)     , LookForMoves(..)     , LookForReplaces(..)     ) import Darcs.Repository.Hashed     ( tentativelyAddPatches_-    , applyToTentativePristine     , tentativelyRemovePatches_-    , UpdatePristine(..) )-import Darcs.Repository.Identify ( identifyRepository )-import Darcs.Repository.InternalTypes ( Repository )-import Darcs.Repository.Pending ( setTentativePending, readPending )-import Darcs.Repository.Resolution ( standardResolution, externalResolution )+    , UpdatePristine(..)+    )+import Darcs.Repository.Pristine+    ( applyToTentativePristine+    , ApplyDir(..)+    )+import Darcs.Repository.InternalTypes ( Repository, repoLocation )+import Darcs.Repository.Pending ( setTentativePending )+import Darcs.Repository.Resolution+    ( externalResolution+    , standardResolution+    , StandardResolution(..)+    , announceConflicts+    ) import Darcs.Repository.State ( unrecordedChanges, readUnrecorded )  import Darcs.Util.Prompt ( promptYorn )-import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Path ( anchorPath, displayPath ) import Darcs.Util.Progress( debugMessage )-import Darcs.Util.Printer.Color (fancyPrinters)-import Darcs.Util.Printer ( text, ($$), redText, putDocLnWith, ($$) )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.Printer ( redText, vcat )  data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) -tentativelyMergePatches_ :: forall rt p wR wU wT wY wX-                          . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+{- 'tentativelyMergePatches' is not easy to understand by just staring at+the code. So here is an in-depth explanation.++We start out at the state X at which our repo and the their repo deviate,+assuming any patches common to both repos have first been commuted to the+common part before X. So X is the intermediate state that is existentially+hiddden inside the Fork we get passed as argument. R is our recorded state+and Y is the recorded state of their repo.++ Y       R+  \     /+ them  us+    \ /+     X+     |+   common+     |+     O++We will elide the common part from now on. It doesn't change and we only+pass it unmodified to standardResolution, see below.++The easy part is to merge the local patches (us) with the remote ones+(them), giving us them' and us'.++     T+    / \+  us'  them'+  /     \+ Y       R+  \     /+ them  us+    \ /+     X+++We can ignore us' and just add them' on top of us (which are already in our+repo), unless --reorder-patches is in effect, in which case we remove us and+then first add them and afterwards us'. The new state on top is T which+stands for the new /tentative/ state i.e. what will become the recorded+state after we finalize our changes.++But we're not done yet: we must also adapt the pending patch and the working+tree. Note that changing the working tree is not done in this procedure, we+merely return a list of prims to apply to working. Let us add the difference+between pristine and working, which we call pw, to the picture.++     T       U+    / \     /+ us' them' pw+  /     \ /+ Y       R+  \     /+ them  us+    \ /+     X++It is easy to see now that we must merge pw with them', as both start at the+(old) recorded state. This gives us pw' and them''.++         U'+        / \+      pw' them''+      /     \+     T       U+    / \     /+ us' them' pw+  /     \ /+ Y       R+  \     /+ them  us+    \ /+     X++Since U is our unrecorded state, them'' leads us from our old unrecorded+state to the new one, so this is what we will return (if there are no+conflicts; if there are, see below).++What about the pending patch? It starts at R and goes half-way toward U+since it is a prefix of pw. The new pending should start at T and go+half-way toward the new working state U'. Instead of adapting the old+pending patch, we set the new pending patch to pw', ignoring the old one.+This relies on sifting to commute out and drop the parts that need not be in+the pending patch, which is done when we finalize the tentative changes.++Up to now we did not consider conflicts. Any new conflicts arising from the+merges we made so far must be "resolved", that is, marked for manual+resolution, if possible, or at least reported o the user. We made two+merges, one with us and one with pw. It is important now to realize that our+existing repo, and in particular the sequence us, could already be+conflicted. Our job is to resolve only /new/ conflicts and not any+unresolved conflicts that were already in our repo. So, from the rightmost+branch of our double merge us+>+pw+>+them'', we should /not/ resolve us. And+since the original pw cannot be conflicted (it consists of prim patches+only) we can disregard it. This leaves only them'' which is what we pass to+standardResolution to generate the markup, along with its full context,+consisting of (common +>+ us +>+ pw).++The resulting "resolution" goes on top, leading to our final unrecorded+state U'':++         U''+         |+        res+         |+         U'+        / \+    pw'  them''+      /     \+     T       U+    / \     /+ us' them' pw+  /     \ /+ Y       R+  \     /+ them  us+    \ /+     X++In case the patches we pull are in conflict with local /unrecorded/ changes+(i.e. pw), we want to warn the user about that and allow them to cancel the+operation. The reason is that it is hard to reconstruct the original+unrecorded changes when they are messed up with conflict resolution markup.+To see if this is the case we check whether pw' has conflicts. As an extra+precaution we backup any conflicted files, so the user can refer to them to+restore things or compare in a diff viewer.++The patches we return are what we need to update U to U'' i.e. them''+>+res.+The new pending patch starts out at the new tentative state, so as explained+above, we set it to pw'+>+res, and again rely on sifting to commute out and+drop anything we don't need.++TODO: We should return a properly coerced @Repository rt p wR wU wT@.+-}++tentativelyMergePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)                          => MakeChanges-                         -> Repository rt p wR wU wT -> String-                         -> AllowConflicts -> UpdateWorking+                         -> Repository rt p wR wU wR -> String+                         -> AllowConflicts                          -> ExternalMerge -> WantGuiPause                          -> Compression -> Verbosity -> Reorder                          -> ( UseIndex, ScanKnown, DiffAlgorithm )-                         -> FL (PatchInfoAnd rt p) wX wT-                         -> FL (PatchInfoAnd rt p) wX wY+                         -> Fork (PatchSet rt p)+                                 (FL (PatchInfoAnd rt p))+                                 (FL (PatchInfoAnd rt p)) Origin wR wY                          -> IO (Sealed (FL (PrimOf p) wU))-tentativelyMergePatches_ mc r cmd allowConflicts updateWorking externalMerge-  wantGuiPause compression verbosity reorder diffingOpts@(_, _, dflag) us them = do-    (them_merged :/\: us_merged)+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)-    pend <- unrecordedChanges diffingOpts NoLookForMoves NoLookForReplaces r Nothing-    anonpend <- n2pia `fmap` anonymous (fromPrims pend)-    pend' :/\: pw <- return $ merge (them_merged :\/: anonpend :>: NilFL)-    let pwprim = concatFL $ progressFL "Examining patches for conflicts" $-                                mapFL_FL (activecontents . hopefully) pw-    Sealed standard_resolved_pw <- return $ standardResolution pwprim+    pw <- unrecordedChanges diffingOpts NoLookForMoves NoLookForReplaces _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+     debugMessage "Checking for conflicts..."     when (allowConflicts == YesAllowConflictsAndMark) $-        mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw+        mapM_ backupByCopying $+        map (anchorPath (repoLocation _repo)) $+        conflictedPaths conflicts+     debugMessage "Announcing conflicts..."     have_conflicts <--        announceMergeConflicts cmd allowConflicts externalMerge standard_resolved_pw+        announceConflicts cmd allowConflicts externalMerge conflicts+     debugMessage "Checking for unrecorded conflicts..."-    have_unrecorded_conflicts <- checkUnrecordedConflicts updateWorking $-                                     mapFL_FL hopefully them_merged-    debugMessage "Reading working directory..."-    working <- readUnrecorded r Nothing-    debugMessage "Working out conflicts in actual working directory..."-    let haveConflicts = have_conflicts || have_unrecorded_conflicts-    Sealed pw_resolution <--        case (externalMerge , haveConflicts) of+    let pw'content = concatFL $ progressFL "Examining patches for conflicts" $+                                mapFL_FL (patchcontents . hopefully) pw'+    case listConflictedFiles pw'content of+        [] -> return ()+        fs -> do+          ePutDocLn $ vcat $ map redText $+            "You have conflicting unrecorded changes to:" : map displayPath fs+          -- we catch "hIsTerminalDevice: illegal operation (handle is closed)"+          -- which can be thrown when we apply patches remotely (i.e. during push)+          confirmed <- promptYorn "Proceed?" `catchIOError` (\e ->+            if isIllegalOperationErrorType (ioeGetErrorType e)+              then return True+              else ioError e)+          unless confirmed $ do+            putStrLn "Cancelled."+            exitSuccess++    debugMessage "Reading working tree..."+    working <- readUnrecorded _repo useidx Nothing++    debugMessage "Working out conflict markup..."+    Sealed resolution <-+        case (externalMerge , have_conflicts) of             (NoExternalMerge, _)       -> return $ if allowConflicts == YesAllowConflicts                                                      then seal NilFL-                                                     else seal standard_resolved_pw-            (_, False)                 -> return $ seal standard_resolved_pw+                                                     else standard_resolution+            (_, False)                 -> return $ standard_resolution             (YesExternalMerge c, True) -> externalResolution dflag working c wantGuiPause-                                             (effect us +>+ pend) (effect them) pwprim-    debugMessage "Applying patches to the local directories..."+                                             (effect us +>+ pw) (effect them) them''content++    debugMessage "Adding patches to the inventory and writing new pending..."     when (mc == MakeChanges) $ do+        applyToTentativePristine _repo ApplyNormal verbosity 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-        r' <- case reorder of+        _repo <- case reorder of             NoReorder -> do-                tentativelyAddPatches_ DontUpdatePristine r-                    compression verbosity updateWorking them_merged+                tentativelyAddPatches_ DontUpdatePristine _repo+                    compression verbosity 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 r-                          compression NoUpdateWorking-                          (filterOutFLFL (namedIsInternal . hopefully) us)+                r1 <- tentativelyRemovePatches_ DontUpdatePristineNorRevert _repo+                          compression NoUpdatePending us                 r2 <- tentativelyAddPatches_ DontUpdatePristine r1-                          compression verbosity NoUpdateWorking them+                          compression verbosity NoUpdatePending them                 tentativelyAddPatches_ DontUpdatePristine r2-                    compression verbosity NoUpdateWorking-                    (filterOutFLFL (namedIsInternal . hopefully) us_merged)-        -- must use the original r, not the updated one here:-        applyToTentativePristine r verbosity them_merged-        setTentativePending r' updateWorking (effect pend' +>+ pw_resolution)-    return $ seal (effect pwprim +>+ pw_resolution)+                    compression verbosity 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 wT -> String-                        -> AllowConflicts -> UpdateWorking+                        => Repository rt p wR wU wR -> String+                        -> AllowConflicts                         -> ExternalMerge -> WantGuiPause                         -> Compression -> Verbosity -> Reorder                         -> ( UseIndex, ScanKnown, DiffAlgorithm )-                        -> FL (PatchInfoAnd rt p) wX wT-                        -> FL (PatchInfoAnd rt p) wX wY+                        -> Fork (PatchSet rt p)+                                (FL (PatchInfoAnd rt p))+                                (FL (PatchInfoAnd rt 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 wT -> String-                       -> AllowConflicts -> UpdateWorking+                       => Repository rt p wR wU wR -> String+                       -> AllowConflicts                        -> ExternalMerge -> WantGuiPause                        -> Compression -> Verbosity -> Reorder                        -> ( UseIndex, ScanKnown, DiffAlgorithm )-                       -> FL (PatchInfoAnd rt p) wX wT-                       -> FL (PatchInfoAnd rt p) wX wY+                       -> Fork (PatchSet rt p)+                               (FL (PatchInfoAnd rt p))+                               (FL (PatchInfoAnd rt p)) Origin wR wY                        -> IO (Sealed (FL (PrimOf p) wU)) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges---announceMergeConflicts :: (PrimPatch p)-                       => String-                       -> AllowConflicts-                       -> ExternalMerge-                       -> FL p wX wY-                       -> IO Bool-announceMergeConflicts cmd allowConflicts externalMerge resolved_pw =-  case nubSort $ listTouchedFiles resolved_pw of-    [] -> return False-    cfs -> if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark]-              || externalMerge /= NoExternalMerge-           then do putDocLnWith fancyPrinters $-                     redText "We have conflicts in the following files:" $$ text (unlines cfs)-                   return True-           else do putDocLnWith fancyPrinters $-                     redText "There are conflicts in the following files:" $$ text (unlines cfs)-                   fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++-                          "If you would rather apply the patch and mark the conflicts,\n"++-                          "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++-                          "These can set as defaults by adding\n"++-                          " "++cmd++" mark-conflicts\n"++-                          "to "++darcsdir++"/prefs/defaults in the target repo. "--checkUnrecordedConflicts :: forall rt p wT wY. RepoPatch p-                         => UpdateWorking-                         -> FL (WrappedNamed rt p) wT wY-                         -> IO Bool-checkUnrecordedConflicts NoUpdateWorking _- = return False -- because we are called by `darcs convert` hence we don't care-checkUnrecordedConflicts _ pc =-    do repository <- identifyRepository NoUseCache "."-       cuc repository-    where cuc :: Repository rt p wR wU wT -> IO Bool-          cuc r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- readPending r :: IO (Sealed (FL (PrimOf p) wT))-                     case mpend of-                       NilFL -> return False-                       pend ->-                           case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of-                           _ :/\: pend' ->-                               case listConflictedFiles pend' of-                               [] -> return False-                               fs -> do putStrLn ("You have conflicting local changes to:\n"-                                                 ++ unwords fs)-                                        confirmed <- promptYorn "Proceed?"-                                        unless confirmed $-                                             do putStrLn "Cancelled."-                                                exitSuccess-                                        return True-          fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB-          fromPrims_ = fromPrims--
src/Darcs/Repository/Old.hs view
@@ -18,9 +18,9 @@ module Darcs.Repository.Old ( readOldRepo,                               oldRepoFailMsg ) where -import Prelude () import Darcs.Prelude +import Control.Applicative ( many ) import Darcs.Util.Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr )@@ -30,12 +30,11 @@                          patchInfoAndPatch,                          actually, unavailable ) -import qualified Data.ByteString as B ( ByteString, null )+import qualified Data.ByteString as B ( ByteString ) import qualified Data.ByteString.Char8 as BC ( break, pack, unpack ) -import Darcs.Patch ( RepoPatch, IsRepoType, WrappedNamed,-                     readPatch )-import Darcs.Patch.ReadMonads as RM ( parseStrictly )+import Darcs.Patch ( RepoPatch, Named, readPatch )+import qualified Darcs.Util.Parser as P ( parse ) import Darcs.Patch.Witnesses.Ordered ( RL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal ) import Darcs.Patch.Info ( PatchInfo(..), makePatchname, readPatchInfo, displayPatchInfo )@@ -51,7 +50,7 @@  import Control.Exception ( catch, IOException ) -readOldRepo :: (IsRepoType rt, RepoPatch p) => String -> IO (SealedPatchSet rt p Origin)+readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet rt p Origin) readOldRepo repo_dir = do   realdir <- toPath `fmap` ioAbsoluteOrRemote repo_dir   let task = "Reading inventory of repository "++repo_dir@@ -60,18 +59,13 @@                         (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)                                   ioError e) -readRepoPrivate :: (IsRepoType rt, RepoPatch p)+readRepoPrivate :: RepoPatch p                 => String -> FilePath -> FilePath -> IO (SealedPatchSet rt p Origin) readRepoPrivate task repo_dir inventory_name = do     inventory <- gzFetchFilePS (repo_dir </> darcsdir </> inventory_name) Uncachable     finishedOneIO task inventory_name     let parse inf = parse2 inf $ repo_dir </> darcsdir </> "patches" </> makeFilename inf-        (mt, is) = case BC.break ('\n' ==) inventory of-                   (swt,pistr) | swt == BC.pack "Starting with tag:" ->-                                     case readPatchInfos pistr of-                                     (t:ids) -> (Just t,reverse ids)-                                     [] -> bug "bad inventory in readRepoPrivate"-                   _ -> (Nothing, reverse $ readPatchInfos inventory)+    (mt, is) <- readInventory inventory     Sealed ts <- unseal seal `fmap` unsafeInterleaveIO (read_ts parse mt)     Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is)     return $ seal (PatchSet ts ps)@@ -86,12 +80,7 @@                       do x <- gzFetchFilePS (repo_dir </> darcsdir </> "inventories" </> makeFilename tag0) Uncachable                          finishedOneIO task (renderString (displayPatchInfo tag0))                          return x-                 let (mt, is) = case BC.break ('\n' ==) i of-                                (swt,pistr) | swt == BC.pack "Starting with tag:" ->-                                                case readPatchInfos pistr of-                                                (t:ids) -> (Just t,reverse ids)-                                                [] -> bug "bad inventory in readRepoPrivate"-                                _ -> (Nothing, reverse $ readPatchInfos i)+                 (mt, is) <- readInventory i                  Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $ read_ts parse mt                  Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is)                  Sealed tag00 <-  parse tag0 `catch`@@ -99,16 +88,17 @@                                         return $ seal $                                         patchInfoAndPatch tag0 $ unavailable $ show e                  return $ seal $ ts :<: Tagged tag00 Nothing ps-          parse2 :: (IsRepoType rt, RepoPatch p)+          parse2 :: RepoPatch p                  => PatchInfo -> FilePath                  -> IO (Sealed (PatchInfoAnd rt p wX))           parse2 i fn = do ps <- unsafeInterleaveIO $ gzFetchFilePS fn Cachable                            return $ patchInfoAndPatch i                              `mapSeal` hopefullyNoParseError (toPath fn) (readPatch ps)-          hopefullyNoParseError :: String -> Maybe (Sealed (WrappedNamed rt a1dr wX))-                                -> Sealed (Hopefully (WrappedNamed rt a1dr) wX)-          hopefullyNoParseError _ (Just (Sealed x)) = seal $ actually x-          hopefullyNoParseError s Nothing = seal $ unavailable $ "Couldn't parse file "++s+          hopefullyNoParseError :: String -> Either String (Sealed (Named a1dr wX))+                                -> Sealed (Hopefully (Named a1dr) wX)+          hopefullyNoParseError _ (Right (Sealed x)) = seal $ actually x+          hopefullyNoParseError s (Left e) =+              seal $ unavailable $ unlines ["Couldn't parse file " ++ s, e]           read_patches :: RepoPatch p =>                           (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd rt p wB)))                        -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd rt p) wX))@@ -146,8 +136,20 @@     where d = readUTCDateOldFashioned $ BC.unpack $ _piDate pi           sha1_a = take 5 $ show $ sha1PS $ _piAuthor pi -readPatchInfos :: B.ByteString -> [PatchInfo]-readPatchInfos inv | B.null inv = []-readPatchInfos inv = case parseStrictly readPatchInfo inv of-                     Just (pinfo,r) -> pinfo : readPatchInfos r-                     _ -> []+readPatchInfos :: B.ByteString -> IO [PatchInfo]+readPatchInfos inv =+    case P.parse (many readPatchInfo) inv of+        Right (r, _) -> return r+        Left e -> fail $ unlines ["cannot parse inventory:", e]++readInventory :: B.ByteString -> IO (Maybe PatchInfo, [PatchInfo])+readInventory inv =+    case BC.break ('\n' ==) inv of+        (swt,pistr) | swt == BC.pack "Starting with tag:" -> do+            infos <- readPatchInfos pistr+            case infos of+                (t:ids) -> return (Just t, reverse ids)+                [] -> fail $ unlines ["empty parent inventory:", BC.unpack pistr]+        _ -> do+            infos <- readPatchInfos inv+            return (Nothing, reverse infos)
src/Darcs/Repository/Packs.hs view
@@ -35,13 +35,13 @@  import qualified Data.ByteString.Lazy.Char8 as BLC import Data.List ( isPrefixOf, sort )-import Data.Maybe( catMaybes, listToMaybe )  import System.Directory ( createDirectoryIfMissing                         , renameFile                         , removeFile                         , doesFileExist                         , getModificationTime+                        , listDirectory                         ) import System.FilePath ( (</>)                        , (<.>)@@ -52,32 +52,35 @@                        ) import System.Posix.Files ( createLink ) +import Darcs.Prelude+ import Darcs.Util.ByteString ( gzReadFilePS ) import Darcs.Util.Lock ( withTemp ) import Darcs.Util.External ( Cachable(..), fetchFileLazyPS ) import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Progress ( debugMessage, progressList )  import Darcs.Patch ( IsRepoType, 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 qualified Darcs.Repository.Hashed as HashedRepo-import Darcs.Repository.Hashed ( filterDirContents, readRepo, readHashedPristineRoot )+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(..)-                              , CacheLoc(..)-                              , WritableOrNot(..)+                              , Cache+                              , closestWritableDirectory                               , hashedDir                               , bucketFolder-                              , CacheType(Directory)                               ) import Darcs.Repository.Old ( oldRepoFailMsg )+import Darcs.Repository.Pristine ( readHashedPristineRoot )  packsDir, basicPack, patchesPack :: String packsDir     = "packs"@@ -119,7 +122,7 @@           else do             if p == darcsdir </> "hashed_inventory"               then writeFile' Nothing p bs-              else writeFile' (cacheDir c) p $ GZ.compress bs+              else writeFile' (closestWritableDirectory c) p $ GZ.compress bs             debugMessage $ "TAR thread: GET " ++ p             unpackTar c dir es   _ -> fail "Unexpected non-file tar entry"@@ -149,11 +152,6 @@      then debugMessage $ "FILE thread: exists " ++ path      else void $ fetchFileUsingCache cache dir path -cacheDir :: Cache -> Maybe String-cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of-  Cache Directory Writable x' -> Just x'-  _ -> Nothing- -- | Create packs from the current recorded version of the repository. createPacks :: (IsRepoType rt, RepoPatch p)             => Repository rt p wR wU wT -> IO ()@@ -169,27 +167,26 @@   createDirectoryIfMissing False (darcsdir </> packsDir)   -- pristine hash   Just hash <- readHashedPristineRoot repo-  writeFile ( darcsdir </> packsDir </> "pristine" ) hash+  writeFile ( darcsdir </> packsDir </> "pristine" ) $ getValidHash hash   -- pack patchesTar-  ps <- mapFL hashedPatchFileName . patchSet2FL <$> readRepo repo-  is <- map ((darcsdir </> "inventories") </>) <$> HashedRepo.listInventories+  ps <- mapFL hashedPatchFileName . progressFL "Packing patches" . patchSet2FL <$> readRepo repo+  is <- map ((darcsdir </> "inventories") </>) <$> listInventories   writeFile (darcsdir </> "meta-filelist-inventories") . unlines $     map takeFileName is   -- Note: tinkering with zlib's compression parameters does not make   -- any noticeable difference in generated archive size;   -- switching to bzip2 would provide ~25% gain OTOH.   BLC.writeFile (patchesTar <.> "part") . GZ.compress . Tar.write =<<-    mapM fileEntry' ((darcsdir </> "meta-filelist-inventories") : ps ++-    reverse is)+    mapM fileEntry' ((darcsdir </> "meta-filelist-inventories") : ps ++ reverse is)   renameFile (patchesTar <.> "part") patchesTar   -- pack basicTar-  pr <- sortByMTime =<< dirContents "pristine.hashed"+  pr <- sortByMTime =<< dirContents (darcsdir </> "pristine.hashed")   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"-    ] ++ reverse pr)+    ] ++ progressList "Packing pristine" (reverse pr))   renameFile (basicTar <.> "part") basicTar  where   basicTar = darcsdir </> packsDir </> basicPack@@ -198,8 +195,7 @@     content <- BLC.fromChunks . return <$> gzReadFilePS x     tp <- either fail return $ toTarPath False x     return $ fileEntry tp content-  dirContents d = map ((darcsdir </> d) </>) <$>-    filterDirContents d (const True)+  dirContents dir = map (dir </>) <$> listDirectory dir   hashedPatchFileName x = case extractHash x of     Left _ -> fail "unexpected unhashed patch"     Right h -> darcsdir </> "patches" </> h
src/Darcs/Repository/PatchIndex.hs view
@@ -18,80 +18,101 @@  See <http://darcs.net/Internals/PatchIndex> for more information. -}-module Darcs.Repository.PatchIndex (-  doesPatchIndexExist,-  isPatchIndexDisabled,-  isPatchIndexInSync,-  canUsePatchIndex,-  createPIWithInterrupt,-  createOrUpdatePatchIndexDisk,-  deletePatchIndex,-  attemptCreatePatchIndex,-  PatchFilter,-  maybeFilterPatches,-  getRelevantSubsequence,-  dumpPatchIndex,-  piTest-) where+module Darcs.Repository.PatchIndex+    ( doesPatchIndexExist+    , isPatchIndexDisabled+    , isPatchIndexInSync+    , canUsePatchIndex+    , createPIWithInterrupt+    , createOrUpdatePatchIndexDisk+    , deletePatchIndex+    , attemptCreatePatchIndex+    , PatchFilter+    , maybeFilterPatches+    , getRelevantSubsequence+    , dumpPatchIndex+    , piTest+    ) where -import Prelude () import Darcs.Prelude +import Control.Exception ( catch )+import Control.Monad ( forM_, unless, when )+import Control.Monad.State.Strict ( evalState, execState, State, gets, modify )+ import Data.Binary ( Binary, encodeFile, decodeFileOrFail )-import Data.Word ( Word32 )+import qualified Data.ByteString as B import Data.Int ( Int8 )-import Data.List ( group, mapAccumL, sort, isPrefixOf, nub, (\\) )+import Data.List ( group, mapAccumL, sort, nub, (\\) ) import Data.Maybe ( fromJust, fromMaybe, isJust )-import Data.Set (Set)-import Data.Map (Map) import qualified Data.Map as M import qualified Data.Set as S-import Control.Exception ( catch )-import Control.Monad ( forM_, unless, when )-import Control.Monad.State.Strict ( evalState, execState, State, gets, modify )-import System.Directory ( createDirectory, renameDirectory, doesFileExist, doesDirectoryExist )-import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) )-import Darcs.Repository.InternalTypes ( Repository, repoLocation, repoFormat )-import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL )-import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal, seal2, unsafeUnseal )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd(..), info )-import Darcs.Util.Lock ( withPermDir, rmRecursive )+import Data.Word ( Word32 )++import System.Directory+    ( createDirectory+    , doesDirectoryExist+    , doesFileExist+    , removeDirectoryRecursive+    , removeFile+    , renameDirectory+    )+import System.FilePath( (</>) )+import System.IO ( openFile, IOMode(WriteMode), hClose )+ import Darcs.Patch ( RepoPatch, listTouchedFiles )-import Darcs.Util.Path ( FileName, fp2fn, fn2fp, toFilePath ) import Darcs.Patch.Apply ( ApplyState(..) )-import Darcs.Patch.Set ( PatchSet(..), patchSet2FL, Origin, patchSet2FL )-import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Progress ( debugMessage ) import Darcs.Patch.Index.Types import Darcs.Patch.Index.Monad ( applyToFileMods, makePatchID )-import System.FilePath( (</>) )-import System.IO (openFile, IOMode(WriteMode), hClose)-import qualified Data.ByteString as B+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch.Progress (progressFL )+import Darcs.Patch.Set ( PatchSet, patchSet2FL, Origin, patchSet2FL )+import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL )+import Darcs.Patch.Witnesses.Sealed+    ( Sealed2(..)+    , Sealed(..)+    , seal+    , seal2+    , unseal+    , unseal2+    )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )++import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) )+import Darcs.Repository.InternalTypes ( Repository, repoLocation, repoFormat )++import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Hash ( sha256sum, showAsHex )-import Darcs.Util.Tree ( Tree(..) )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Util.Lock ( withPermDir )+import Darcs.Util.Path ( AnchoredPath, displayPath, toFilePath, isPrefix )+import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.SignalHandler ( catchInterrupt )+import Darcs.Util.Tree ( Tree(..) ) +type Map = M.Map+type Set = S.Set+ data FileIdSpan = FidSpan-                    !FileId           -- the fileid has some fixed name in the-                    !PatchId          -- span starting here-                    !(Maybe PatchId)  -- and (maybe) ending here-  deriving (Show,Eq,Ord)+  !FileId                   -- ^ the fileid has some fixed name in the+  !PatchId                  -- ^ span starting here+  !(Maybe PatchId)          -- ^ and (maybe) ending here+  deriving (Show, Eq, Ord)  data FilePathSpan = FpSpan-                      !FileName         -- the file path has some fixed fileid in the-                      !PatchId          -- span starting here-                      !(Maybe PatchId)  -- and (maybe) ending here-  deriving (Show,Eq,Ord)+  !AnchoredPath             -- ^ the file path has some fixed fileid in the+  !PatchId                  -- ^ span starting here+  !(Maybe PatchId)          -- ^ and (maybe) ending here+  deriving (Show, Eq, Ord)  -- | info about a given fileid, e.g.. is a file or a directory-data FileInfo = FileInfo { isFile::Bool,-                           touching::Set Word32} -- first word of patch hash-  deriving (Show,Eq,Ord)+data FileInfo = FileInfo+  { isFile :: Bool+  , touching :: Set Word32  -- ^ first word of patch hash+  } deriving (Show, Eq, Ord)  -- | timespans where a certain filename corresponds to a file with a given id-type FileIdSpans = Map FileName [FileIdSpan]+type FileIdSpans = Map AnchoredPath [FileIdSpan]  -- | timespans where a file with a certain id corresponds to given filenames type FilePathSpans = Map FileId [FilePathSpan]@@ -100,39 +121,40 @@ type InfoMap = Map FileId FileInfo  -- | the patch-index-data PatchIndex =-    PatchIndex {-        -- |all the PatchIds tracked by this patch index, with the most-        -- recent patch at the head of the list (note, stored in the-        -- reverse order to this on disk for backwards compatibility-        -- with an older format).-        pids::[PatchId],-        fidspans::FileIdSpans,-        fpspans::FilePathSpans,-        infom::InfoMap-    }+data PatchIndex = PatchIndex+  { pids :: [PatchId]+    -- ^ all the 'PatchId's tracked by this patch index, with the most+    -- recent patch at the head of the list (note, stored in the+    -- reverse order to this on disk for backwards compatibility+    -- with an older format).+  , fidspans :: FileIdSpans+  , fpspans :: FilePathSpans+  , infom :: InfoMap+  }  -- | On-disk version of patch index --   version 1 is the one introduced in darcs 2.10 --           2 changes the pids order to newer-to-older+--           3 changes FileName to AnchoredPath everywhere, which has+--             different Binary (and Ord) instances version :: Int8-version = 2+version = 3  type PIM a = State PatchIndex a  -- | 'applyPatchMods pmods pindex' applies a list of PatchMods to the given --   patch index pindex-applyPatchMods :: [(PatchId, [PatchMod FileName])] -> PatchIndex -> PatchIndex+applyPatchMods :: [(PatchId, [PatchMod AnchoredPath])] -> PatchIndex -> PatchIndex applyPatchMods pmods pindex =   flip execState pindex $ mapM_ goList pmods- where goList :: (PatchId, [PatchMod FileName]) -> PIM ()+ where goList :: (PatchId, [PatchMod 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 FileName) -> PIM ()+       go :: (PatchId, PatchMod AnchoredPath) -> PIM ()        go (pid, PCreateFile fn) = do          fid <- createFidStartSpan fn pid          startFpSpan fid fn pid@@ -168,7 +190,7 @@                               ++" in FileIdSpans in duplicate, empty list"  -- | create new filespan for created file-createFidStartSpan :: FileName -> PatchId -> PIM FileId+createFidStartSpan :: AnchoredPath -> PatchId -> PIM FileId createFidStartSpan fn pstart = do   fidspans <- gets fidspans   case M.lookup fn fidspans of@@ -182,7 +204,7 @@       return fid  -- | start new span for name fn for file fid starting with patch pid-startFpSpan :: FileId -> FileName -> PatchId -> PIM ()+startFpSpan :: FileId -> AnchoredPath -> PatchId -> PIM () startFpSpan fid fn pstart = modify (\pind -> pind {fpspans=M.alter alt fid (fpspans pind)})   where alt Nothing = Just [FpSpan fn pstart Nothing]         alt (Just spans) = Just (FpSpan fn pstart Nothing:spans)@@ -197,13 +219,13 @@         alt _ = error $ "impossible: span already ended for " ++ show fid  -- | start new span for name fn for file fid starting with patch pid-startFidSpan :: FileName -> PatchId -> FileId -> PIM ()+startFidSpan :: AnchoredPath -> PatchId -> FileId -> PIM () startFidSpan fn pstart fid = modify (\pind -> pind {fidspans=M.alter alt fn (fidspans pind)})   where alt Nothing = Just [FidSpan fid pstart Nothing]         alt (Just spans) = Just (FidSpan fid pstart Nothing:spans)  -- | stop current span for file name fn-stopFidSpan :: FileName -> PatchId -> PIM ()+stopFidSpan :: AnchoredPath -> PatchId -> PIM () stopFidSpan fn pend = modify (\pind -> pind {fidspans=M.alter alt fn (fidspans pind)})   where alt Nothing = error $ "impossible: no span for " ++ show fn         alt (Just []) = error $ "impossible: no span for " ++ show fn++", empty list"@@ -220,19 +242,19 @@ -- | insert touching patchid for given file id insertTouch :: FileId -> PatchId -> PIM () insertTouch fid pid = modify (\pind -> pind {infom=M.alter alt fid (infom pind)})-  where alt Nothing =  impossible "Fileid does not exist"+  where alt Nothing =  error "impossible: Fileid does not exist"         alt (Just (FileInfo isF pids)) = Just (FileInfo isF (S.insert (short pid) pids))  -- | lookup current fid of filepath-lookupFid :: FileName -> PIM FileId+lookupFid :: AnchoredPath -> PIM FileId lookupFid fn = do     maybeFid <- lookupFid' fn     case maybeFid of-        Nothing -> bug $ "couldn't find " ++ fn2fp fn ++ " in patch index"+        Nothing -> error $ "couldn't find " ++ displayPath fn ++ " in patch index"         Just fid -> return fid  -- | lookup current fid of filepatch, returning a Maybe to allow failure-lookupFid' :: FileName -> PIM (Maybe FileId)+lookupFid' :: AnchoredPath -> PIM (Maybe FileId) lookupFid' fn = do    fidm <- gets fidspans    case M.lookup fn fidm of@@ -241,7 +263,7 @@   -- | lookup all the file ids of a given path-lookupFidf' :: FileName -> PIM [FileId]+lookupFidf' :: AnchoredPath -> PIM [FileId] lookupFidf' fn = do    fidm <- gets fidspans    case M.lookup fn fidm of@@ -251,16 +273,17 @@  -- |  return all fids of matching subpaths --    of the given filepath-lookupFids :: FileName -> PIM [FileId]+lookupFids :: AnchoredPath -> PIM [FileId] lookupFids fn = do    fid_spans <- gets fidspans-   file_idss <- mapM (lookupFidf' . fp2fn) $ filter (isPrefixOf (fn2fp fn)) (fpSpans2filePaths' fid_spans)+   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' :: FileName -> PIM [FileId]+lookupFids' :: AnchoredPath -> PIM [FileId] lookupFids' fn = do   info_map <- gets infom   fps_spans <- gets fpspans@@ -282,12 +305,12 @@   -> PatchSet rt p Origin wR   -> IO () createPatchIndexDisk repository ps = do-  let patches = mapFL Sealed2 $ patchSet2FL ps+  let patches = mapFL Sealed2 $ progressFL "Create patch index" $ patchSet2FL ps   createPatchIndexFrom repository $ patches2patchMods patches S.empty  -- | convert patches to patchmods patches2patchMods :: (Apply p, PatchInspect p, ApplyState p ~ Tree)-                  => [Sealed2 (PatchInfoAnd rt p)] -> Set FileName -> [(PatchId, [PatchMod FileName])]+                  => [Sealed2 (PatchInfoAnd rt p)] -> Set AnchoredPath -> [(PatchId, [PatchMod AnchoredPath])] patches2patchMods patches fns = snd $ mapAccumL go fns patches   where     go filenames (Sealed2 p) = (filenames', (pid, pmods_effect ++ pmods_dup))@@ -298,7 +321,7 @@             touched pm = case pm of {PTouch f -> [f]; PRename a b -> [a,b];                                      PCreateDir f -> [f]; PCreateFile f -> [f];                                      PRemove f -> [f]; _ -> []}-            touched_all = map fp2fn $ listTouchedFiles p+            touched_all = listTouchedFiles p             touched_effect = concatMap touched pmods_effect             touched_invalid = [ f | (PInvalid f) <- pmods_effect]             -- listTouchedFiles returns all files that touched by these@@ -310,7 +333,7 @@                                             S.fromList touched_effect)  -- | return set of current filenames in patch index-fpSpans2fileNames :: FilePathSpans -> Set FileName+fpSpans2fileNames :: FilePathSpans -> Set AnchoredPath fpSpans2fileNames fpSpans =   S.fromList [fn | (FpSpan fn _ Nothing:_)<- M.elems fpSpans] @@ -325,7 +348,7 @@                (M.mapMaybe removefp fpspans)                infom -- leave hashes in infom, false positives are harmless   where-    findIdx pid = fromMaybe (impossible "removePidSuffix") (M.lookup pid pid2idx)+    findIdx pid = fromMaybe (error "impossible case") (M.lookup pid pid2idx)     oldidx = findIdx oldpid     from `after` idx = findIdx from > idx     mto `afterM` idx | Just to <- mto, findIdx to > idx = True@@ -355,7 +378,7 @@     let repodir = repoLocation repo     (_,_,pid2idx,pindex) <- loadPatchIndex repodir     -- check that patch index is up to date-    let flpatches = patchSet2FL patches+    let flpatches = progressFL "Update patch index" $ patchSet2FL patches     let pidsrepo = mapFL (makePatchID . info) flpatches         (oldpids,_,len_common) = uncommon (reverse $ pids pindex) pidsrepo         pindex' = removePidSuffix pid2idx oldpids pindex@@ -377,7 +400,7 @@ -- | 'createPatchIndexFrom repo pmods' creates a patch index from the given --   patchmods. createPatchIndexFrom :: Repository rt p wR wU wT-                     -> [(PatchId, [PatchMod FileName])] -> IO ()+                     -> [(PatchId, [PatchMod AnchoredPath])] -> IO () createPatchIndexFrom repo pmods = do     inv_hash <- getInventoryHash repodir     storePatchIndex repodir cdir inv_hash (applyPatchMods pmods emptyPatchIndex)@@ -446,7 +469,7 @@                              => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO () createOrUpdatePatchIndexDisk repo ps = do    let repodir = repoLocation repo-   rmRecursive (repodir </> darcsdir </> noPatchIndex) `catch` \(_ :: IOError) -> return ()+   removeFile (repodir </> darcsdir </> noPatchIndex) `catch` \(_ :: IOError) -> return ()    dpie <- doesPatchIndexExist repodir    if dpie       then updatePatchIndexDisk repo ps@@ -467,7 +490,7 @@      case (piExists, piDisabled) of         (True, False) -> return True         (False, True) -> return False-        (True, True) -> error "patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify."+        (True, True) -> fail "patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify."         (False, False) -> return False  -- | Creates patch-index (ignoring whether it is explicitely disabled).@@ -498,7 +521,7 @@ storePatchIndex :: FilePath -> FilePath -> String -> PatchIndex -> IO () storePatchIndex repodir cdir inv_hash (PatchIndex pids fidspans fpspans infom) = do   createDirectory cdir `catch` \(_ :: IOError) -> return ()-  tmpdir <- withPermDir (repodir </> "filecache-tmp") $ \dir -> do+  tmpdir <- withPermDir repodir $ \dir -> do               debugMessage "About to create patch index..."               let tmpdir = toFilePath dir               storeRepoState (tmpdir </> repoStateFile) inv_hash@@ -508,7 +531,7 @@               storeFpMap (tmpdir </> fpMapFile) fpspans               debugMessage "Patch index created"               return tmpdir-  rmRecursive cdir `catch` \(_ :: IOError) -> return ()+  removeDirectoryRecursive cdir `catch` \(_ :: IOError) -> return ()   renameDirectory tmpdir cdir  decodeFile :: Binary a => FilePath -> IO a@@ -577,22 +600,22 @@ deletePatchIndex repodir = do     exists <- doesDirectoryExist indexDir     when exists $-         rmRecursive indexDir-            `catch` \(e :: IOError) -> error $ "Error: Could not delete patch index\n" ++ show e+         removeDirectoryRecursive indexDir+            `catch` \(e :: IOError) -> fail $ "Error: Could not delete patch index\n" ++ show e     (openFile (repodir </> darcsdir </> noPatchIndex) WriteMode >>= hClose)-            `catch` \(e :: IOError) -> error $ "Error: Could not disable patch index\n" ++ show e+            `catch` \(e :: IOError) -> fail $ "Error: Could not disable patch index\n" ++ show e  dumpRepoState :: [PatchId] -> String dumpRepoState = unlines . map pid2string  dumpFileIdSpans :: FileIdSpans -> String dumpFileIdSpans fidspans =-  unlines [fn2fp fn++" -> "++showFileId fid++" from "++pid2string from++" to "++maybe "-" pid2string mto+  unlines [displayPath fn++" -> "++showFileId fid++" from "++pid2string from++" to "++maybe "-" pid2string mto            | (fn, fids) <- M.toList fidspans, FidSpan fid from mto <- fids]  dumpFilePathSpans :: FilePathSpans -> String dumpFilePathSpans fpspans =-  unlines [showFileId fid++" -> "++ fn2fp fn++" from "++pid2string from++" to "++maybe "-" pid2string mto+  unlines [showFileId fid++" -> "++ displayPath fn++" from "++pid2string from++" to "++maybe "-" pid2string mto            | (fid, fns) <- M.toList fpspans, FpSpan fn from mto <- fns]  dumpTouchingMap :: InfoMap -> String@@ -602,12 +625,12 @@ -- | return set of current filepaths in patch index fpSpans2filePaths :: FilePathSpans -> InfoMap -> [FilePath] fpSpans2filePaths fpSpans infom =-  sort [fn2fp fn ++ (if isF then "" else "/") | (fid,FpSpan fn _ Nothing:_) <- M.toList fpSpans,+  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 -> [FilePath]-fpSpans2filePaths' fidSpans = [fn2fp fp | (fp, _)  <- M.toList fidSpans]+fpSpans2filePaths' :: FileIdSpans -> [AnchoredPath]+fpSpans2filePaths' fidSpans = [fp | (fp, _)  <- M.toList fidSpans]  -- | Checks if patch index can be created and build it with interrupt. attemptCreatePatchIndex@@ -630,31 +653,38 @@     repodir = repoLocation repo     doesntHaveHashedInventory = return . not . formatHas HashedInventory --- | Returns an RL in which the order of patches matters. Useful for the @annotate@ command.---   If patch-index does not exist and is not explicitely disabled, silently create it.---   (Also, if it is out-of-sync, which should not happen, silently update it).-getRelevantSubsequence :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p)-                       => Sealed ((RL a) wK)          -- ^ Sequence of patches you want to filter-                       -> Repository rt p wR wU wR    -- ^ The repository (to attempt loading patch-index from its path)-                       -> PatchSet rt p Origin wR     -- ^ PatchSet of repository (in case we need to create patch-index)-                       -> [FileName]                  -- ^ File(s) about which you want patches from given sequence-                       -> IO (Sealed ((RL a) Origin)) -- ^ Filtered sequence of patches.+-- | Returns an RL in which the order of patches matters. Useful for the+-- @annotate@ command. If patch-index does not exist and is not explicitely+-- disabled, silently create it. (Also, if it is out-of-sync, which should not+-- happen, silently update it).+getRelevantSubsequence+    :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p)+    => Sealed ((RL a) wK)+    -- ^ Sequence of patches you want to filter+    -> Repository rt p wR wU wR+    -- ^ The repository (to attempt loading patch-index from its path)+    -> PatchSet rt p Origin wR+    -- ^ PatchSet of repository (in case we need to create patch-index)+    -> [AnchoredPath]+    -- ^ File(s) about which you want patches from given sequence+    -> IO (Sealed ((RL a) Origin))+    -- ^ Filtered sequence of patches getRelevantSubsequence pxes repository ps fns = do-   pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repository ps-   let fids = map (\fn -> evalState (lookupFid fn) pi) fns-       pidss = map ((\(FileInfo _ a) -> a).fromJust.(`M.lookup` infom)) fids-       pids = S.unions pidss-   let flpxes = reverseRL $ unsafeUnseal 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 NilFL acc _ = unsafeCoerceP acc-        keepElems (x:>:xs) acc pids-          | short (makePatchID $ info x) `S.member` pids = keepElems xs (acc:<:x) pids-          | otherwise                                    = keepElems (unsafeCoerceP xs) acc pids+    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+    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 NilFL acc _ = unsafeCoerceP acc+    keepElems (x :>: xs) acc pids+      | short (makePatchID $ info x) `S.member` pids = keepElems xs (acc :<: x) pids+      | otherwise = keepElems (unsafeCoerceP xs) acc pids -type PatchFilter rt p = [FilePath] -> [Sealed2 (PatchInfoAnd rt p)] -> IO [Sealed2 (PatchInfoAnd rt p)]+type PatchFilter rt p = [AnchoredPath] -> [Sealed2 (PatchInfoAnd rt p)] -> IO [Sealed2 (PatchInfoAnd rt 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.@@ -671,9 +701,10 @@     if usePI       then do         pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repo ps-        let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi). fp2fn) fps+        let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi)) fps             npids = S.unions $ map (touching.fromJust.(`M.lookup` infom)) fids-        return $ filter (flip S.member npids . (\(Sealed2 (PIAP pin _)) -> short $ makePatchID pin)) ops+        return $ filter+          (flip S.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.@@ -713,8 +744,8 @@           g (FidSpan _ x (Just y)) = [y,x]           g (FidSpan _ x _) = [x]           ascTs = reverse . nub . concat $ map g spans-      unless (isInOrder ascTs pids) (error $ "In order test failed! filename: " ++ show fn)-      forM_ spans $ \(FidSpan fid _ _) -> unless (M.member fid fpspans) (error $ "Valid file id test failed! fid: " ++ show fid)+      unless (isInOrder ascTs pids) (fail $ "In order test failed! filename: " ++ show fn)+      forM_ spans $ \(FidSpan fid _ _) -> unless (M.member fid fpspans) (fail $ "Valid file id test failed! fid: " ++ show fid)    putStrLn "fidspans tests passed"     -- test fpspans@@ -725,12 +756,12 @@           g (FpSpan _ x (Just y)) = [y,x]           g (FpSpan _ x _) = [x]           ascTs = reverse . nub . concat $ map g spans-      unless (isInOrder ascTs pids) (error $ "In order test failed! fileid: " ++ show fid)-      forM_ spans $ \(FpSpan fn _ _) -> unless (M.member fn fidspans) (error $ "Valid file name test failed! file name: " ++ show fn)+      unless (isInOrder ascTs pids) (fail $ "In order test failed! fileid: " ++ show fid)+      forM_ spans $ \(FpSpan fn _ _) -> unless (M.member fn fidspans) (fail $ "Valid file name test failed! file name: " ++ show fn)       let f :: FilePathSpan -> FilePathSpan -> Bool           f (FpSpan _ x _) (FpSpan _ _ (Just y)) = x == y           f _ _ = error "adj test of fpspans fail"-      unless (and $ zipWith f spans (tail spans)) (error $ "Adjcency test failed! fid: " ++ show fid)+      unless (and $ zipWith f spans (tail spans)) (fail $ "Adjcency test failed! fid: " ++ show fid)    putStrLn "fpspans tests passed"     -- test infomap
+ src/Darcs/Repository/Paths.hs view
@@ -0,0 +1,60 @@+-- everything here has type String/FilePath+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module Darcs.Repository.Paths where++import Darcs.Prelude+import Darcs.Util.Global ( darcsdir )+import System.FilePath.Posix( (</>) )++makeDarcsdirPath :: String -> String+makeDarcsdirPath name = darcsdir </> name++-- | Location of the lock file.+lockPath = makeDarcsdirPath "lock"++-- | Location of the (one and only) head inventory.+hashedInventory = "hashed_inventory"+hashedInventoryPath = makeDarcsdirPath hashedInventory++-- | Location of the (one and only) tentative head inventory.+tentativeHashedInventory = "tentative_hashed_inventory"+tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory++-- | Location of parent inventories.+inventoriesDir = "inventories"+inventoriesDirPath = makeDarcsdirPath inventoriesDir++-- | Location of pristine trees.+tentativePristinePath = makeDarcsdirPath "tentative_pristine"+pristineDir = "pristine.hashed"+pristineDirPath = makeDarcsdirPath pristineDir++-- | Location of patches.+patchesDir = "patches"+patchesDirPath = makeDarcsdirPath patchesDir++-- | Location of index files.+indexPath = darcsdir </> "index"+indexInvalidPath = darcsdir </> "index_invalid"++-- | Location of the rebase patch+rebasePath = makeDarcsdirPath "rebase"+tentativeRebasePath = makeDarcsdirPath "rebase.tentative"++-- | Location of format file+formatPath = makeDarcsdirPath "format"++-- | Location of pending files+pendingPath = patchesDirPath </> "pending"+tentativePendingPath = patchesDirPath </> "pending.tentative"+newPendingPath = patchesDirPath </> "pending.new"++-- | Location of unrevert bundle.+unrevertPath = patchesDirPath </> "unrevert"++-- | Location of old style (unhashed) files and directories.+oldPristineDirPath = makeDarcsdirPath "pristine"+oldCurrentDirPath = makeDarcsdirPath "current"+oldCheckpointDirPath = makeDarcsdirPath "checkpoints"+oldInventoryPath = makeDarcsdirPath "inventory"+oldTentativeInventoryPath = makeDarcsdirPath "tentative_inventory"
src/Darcs/Repository/Pending.hs view
@@ -18,85 +18,73 @@  module Darcs.Repository.Pending     ( readPending+    , readTentativePending+    , writeTentativePending     , siftForPending     , tentativelyRemoveFromPending+    , tentativelyRemoveFromPW+    , revertPending     , finalizePending     , makeNewPending     , tentativelyAddToPending     , setTentativePending-    , prepend-    -- deprecated interface:-    , pendingName     ) where -import Prelude () import Darcs.Prelude  import Control.Applicative-import qualified Data.ByteString as B ( empty )- import Control.Exception ( catch, IOException )-import Data.Maybe ( fromJust, fromMaybe )+import System.Directory ( renameFile ) -import Darcs.Util.Printer ( errorDoc )-import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Lock-    ( writeDocBinFile-    , removeFileMayNotExist-    )-import Darcs.Repository.InternalTypes ( Repository, withRepoLocation )-import Darcs.Repository.Flags-    ( UpdateWorking (..)) import Darcs.Patch-    ( readPatch, RepoPatch, PrimOf, tryToShrink-    , primIsHunk, primIsBinary, commute, invert-    , primIsAddfile, primIsAdddir, commuteFLorComplain-    , effect, primIsSetpref, applyToTree )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )+    ( PrimOf+    , RepoPatch+    , PrimPatch+    , applyToTree+    , readPatch+    )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Permutations+    ( removeFL+    , commuteWhatWeCanFL+    , commuteWhatWeCanRL+    )+import Darcs.Patch.Prim+    ( PrimSift(siftForPending)+    , PrimCanonize(primDecoalesce)+    ) import Darcs.Patch.Progress (progressFL)-import Darcs.Patch.Permutations ( commuteWhatWeCanFL-                                , removeFL-                                )--import Darcs.Patch.Prim ( tryShrinkingInverse-                        , PrimPatch-                        )+import Darcs.Util.Parser ( Parser ) import Darcs.Patch.Read ( ReadPatch(..), bracketedFL )-import Darcs.Patch.ReadMonads ( ParserM ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(ForStorage) )-import Darcs.Patch.Apply ( ApplyState )--import Darcs.Util.Tree ( Tree )-import Darcs.Util.Exception ( catchall )-import Darcs.Util.Workaround ( renameFile )-import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )-import Darcs.Patch.Witnesses.Sealed-    ( Sealed(Sealed), mapSeal, seal-    , FlippedSeal(FlippedSeal)-    , flipSeal-    )-import Darcs.Patch.Witnesses.Unsafe-    ( unsafeCoerceP, unsafeCoercePStart )+import Darcs.Patch.Show ( displayPatch )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), (:>)(..), (+>+)-    , lengthFL, allFL, filterOutFLFL-    , reverseFL, mapFL )+    ( RL(..), FL(..), (+>+), (+>>+), (:>)(..), mapFL, reverseFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart )++import Darcs.Repository.Flags ( UpdatePending (..))+import Darcs.Repository.InternalTypes ( Repository, withRepoLocation, unsafeCoerceT )+import Darcs.Repository.Paths ( pendingPath )+ import Darcs.Util.ByteString ( gzReadFilePS )-import Darcs.Util.Printer ( Doc, ($$), text, vcat, (<+>) )+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 ) -pendingName :: String-pendingName = darcsdir ++ "/patches/pending"  newSuffix, tentativeSuffix :: String newSuffix = ".new" tentativeSuffix = ".tentative"  -- | Read the contents of pending.--- The return type is currently incorrect as it refers to the tentative--- state rather than the recorded state. readPending :: RepoPatch p => Repository rt p wR wU wT-            -> IO (Sealed (FL (PrimOf p) wT))+            -> IO (Sealed (FL (PrimOf p) wR)) readPending = readPendingFile ""  -- |Read the contents of tentative pending.@@ -113,9 +101,14 @@ -- directory. readPendingFile :: ReadPatch prim => String -> Repository rt p wR wU wT                 -> IO (Sealed (FL prim wX))-readPendingFile suffix _ = do-    pend <- gzReadFilePS (pendingName ++ suffix) `catchall` return B.empty-    return . maybe (Sealed NilFL) (mapSeal unFLM) . readPatch $ pend+readPendingFile suffix _ =+  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@@ -131,9 +124,8 @@ instance ShowPatchBasic p => ShowPatchBasic (FLM p) where     showPatch f = showMaybeBracketedFL (showPatch f) '{' '}' . unFLM -readMaybeBracketedFL :: forall m p wX . ParserM m-                     => (forall wY . m (Sealed (p wY))) -> Char -> Char-                     -> m (Sealed (FL p wX))+readMaybeBracketedFL :: (forall wY . Parser (Sealed (p wY))) -> Char -> Char+                     -> Parser (Sealed (FL p wX)) readMaybeBracketedFL parser pre post =     bracketedFL parser pre post <|> (mapSeal (:>:NilFL) <$> parser) @@ -152,7 +144,7 @@  -- |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 wY -> IO ()+                               -> FL (PrimOf p) wT wP -> IO () writeNewPending = writePendingFile newSuffix  -- Write a pending file, with the given suffix. CWD should be the repository@@ -161,231 +153,217 @@                  -> FL prim wX wY -> IO () writePendingFile suffix _ = writePatch name . FLM   where-    name = pendingName ++ suffix+    name = pendingPath ++ suffix  writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO () writePatch f p = writeDocBinFile f $ showPatch ForStorage p <> text "\n" --- | @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+-- | 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. -----   The visual image of sifting can be quite helpful here.  We are---   repeatedly tapping (shrinking) the patch sequence and---   shaking it (sift). Whatever falls out is the pending we want---   to keep. We do this until the sequence looks about as clean as---   we can get it-siftForPending :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> Sealed (FL prim wX)-siftForPending simple_ps =-    if allFL (\p -> primIsAddfile p || primIsAdddir p) oldps-       then seal oldps-       else fromJust $ do-           Sealed x <- return $ sift NilFL $ reverseFL oldps-           return $ case tryToShrink x of-               ps | lengthFL ps < lengthFL oldps -> siftForPending ps-                  | otherwise -> seal ps-  where-    oldps = fromMaybe simple_ps $ tryShrinkingInverse $ crudeSift simple_ps-    -- get rid of any hunk/binary patches that we can commute out the-    -- back (ie. we work our way backwards, pushing the patches down-    -- to the very end and popping them off; so in (addfile f :> hunk)-    -- we can nuke the hunk, but not so in (hunk :> replace)-    sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)-    sift sofar NilRL = seal sofar-    sift sofar (ps:<:p) | primIsHunk p || primIsBinary p =-        case commuteFLorComplain (p :> sofar) of-            Right (sofar' :> _) -> sift sofar'      ps-            Left _              -> sift (p:>:sofar) ps-    sift sofar (ps:<:p) = sift (p:>:sofar) ps+-- 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 --- | 'crudeSift' can be seen as a first pass approximation of 'siftForPending'---    that works without having to do any commutation.  It either returns a---    sifted pending (if the input is simple enough for this crude approach)---    or has no effect.-crudeSift :: forall prim wX wY . PrimPatch 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+-- | 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+                        -> IO ()+tentativelyRemoveFromPW r changes pending working = do+    Sealed pending' <- return $+        updatePending (progressFL "Removing from pending:" changes) pending working+    writeTentativePending r pending' --- | @tentativelyRemoveFromPending p@ is used by Darcs whenever it---   adds a patch to the repository (eg. with apply or record).---   Think of it as one part of transferring patches from pending to---   somewhere else.------   Question (Eric Kow): how do we detect patch equivalence?-tentativelyRemoveFromPending :: forall rt p wR wU wT wX wY. (RepoPatch p)-                 => Repository rt p wR wU wT-                 -> UpdateWorking-                 -> PatchInfoAnd rt p wX wY-                 -> IO ()-tentativelyRemoveFromPending _    NoUpdateWorking  _ = return ()-tentativelyRemoveFromPending repo YesUpdateWorking p = do-    Sealed pend <- readTentativePending repo-    -- Question (Eric Kow): why does pending being all simple matter for-    -- changepref patches in p? isSimple includes changepref, so what do-    -- adddir/etc have to do with it?  Why don't we we systematically-    -- crudeSift/not?-    let effectp = if isSimple pend-                     then crudeSift $ effect p-                     else effect p-    Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp)-                               (unsafeCoercePStart pend)-    writeTentativePending repo (unsafeCoercePStart newpend)-  where-    -- @rmpend effect pending@ removes as much of @effect@ from @pending@-    -- as possible-    ---    -- Note that @effect@ and @pending@ must start from the same context-    -- This is not a bad thing to assume because @effect@ is a patch we want to-    -- add to the repository anyway so it'd kind of have to start from wR anyway-    ---    -- Question (Eric Kow), ok then why not-    -- @PatchInfoAnd p wR wY@ in the type signature above?-    rmpend :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)-    rmpend NilFL x = Sealed x-    rmpend _ NilFL = Sealed NilFL-    rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys-    rmpend (x:>:xs) ys =-        case commuteWhatWeCanFL (x:>xs) of-            a:>x':>b -> case rmpend a ys of-                Sealed ys' -> case commute (invert (x':>:b) :> ys') of-                    Just (ys'' :> _) -> seal ys''-                    Nothing          -> seal $ invert (x':>:b)+>+ys'-                    -- DJR: I don't think this last case should be-                    -- reached, but it also shouldn't lead to corruption.+{- |+@'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). --- | A sequence of primitive patches (candidates for the pending patch)---   is considered simple if we can reason about their continued status as---   pending patches solely on the basis of them being hunk/binary patches.------   Simple here seems to mean that all patches are either hunk/binary---   patches, or patches that cannot (indirectly) depend on hunk/binary---   patches.  For now, the only other kinds of patches in this category---   are changepref patches.------   It might be tempting to add, say, adddir patches but it's probably not a---   good idea because Darcs also inverts patches a lot in its reasoning so an---   innocent addir may be inverted to a rmdir which in turn may depend on---   a rmfile, which in turn depends on a hunk/binary. Likewise, we would---   not want to add move patches to this category for similar reasons of---   a potential dependency chain forming.-isSimple :: PrimPatch prim => FL prim wX wY -> Bool-isSimple =-    allFL isSimp+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-    isSimp x = primIsHunk x || primIsBinary x || primIsSetpref x+    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) --- | @makeNewPending repo YesUpdateWorking pendPs@ verifies that the+-- | 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++-- | 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++-- | 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++-- | 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')++-- | @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-                 -> UpdateWorking-                 -> FL (PrimOf p) wT wY+                 -> UpdatePending+                 -> FL (PrimOf p) wT wP                  -> Tree IO  -- ^recorded state of the repository, to check if pending can be applied                  -> IO ()-makeNewPending _                  NoUpdateWorking _ _ = return ()-makeNewPending repo YesUpdateWorking origp recordedState =+makeNewPending _                  NoUpdatePending _ _ = return ()+makeNewPending repo YesUpdatePending origp recordedState =     withRepoLocation repo $-    do let newname = pendingName ++ ".new"+    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 = pendingName ++ "_buggy"+         let buggyname = pendingPath ++ "_buggy"          renameFile newname buggyname-         errorDoc $ text ("There was an attempt to write an invalid pending! " ++ show err)-                    $$ text "If possible, please send the contents of"-                    <+> text buggyname-                    $$ text "along with a bug report."-       renameFile newname pendingName+         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  -- | Replace the pending patch with the tentative pending.---   If @NoUpdateWorking@, this merely deletes 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 @YesUpdateWorking@?  I'm just puzzled by the seeming---   inconsistency of the @NoUpdateWorking@ doing deletion, but---   @YesUpdateWorking@ not bothering.+--   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-                -> UpdateWorking+                -> UpdatePending                 -> Tree IO                 -> IO ()-finalizePending repo NoUpdateWorking _ =-  withRepoLocation repo $ removeFileMayNotExist pendingName-finalizePending repo updateWorking@YesUpdateWorking recordedState =+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 updateWorking new_pending recordedState+      makeNewPending repo upe new_pending recordedState --- | @tentativelyAddToPending repo NoDryRun YesUpdateWorking pend ps@---   appends @ps@ to the pending patch.------   It has no effect with @NoUpdateWorking@.+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++-- | @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-                        -> UpdateWorking                         -> FL (PrimOf p) wX wY                         -> IO ()-tentativelyAddToPending _                   NoUpdateWorking  _     = return ()-tentativelyAddToPending repo YesUpdateWorking patch =+tentativelyAddToPending repo patch =     withRepoLocation repo $ do         Sealed pend <- readTentativePending repo-        FlippedSeal newpend_ <- return $-            newpend (unsafeCoerceP pend :: FL (PrimOf p) wA wX) patch-        writeTentativePending repo (unsafeCoercePStart newpend_)-  where-    newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC-    newpend NilFL patch_ = flipSeal patch_-    newpend p     patch_ = flipSeal $ p +>+ patch_+        writeTentativePending repo (pend +>+ unsafeCoercePStart patch) --- | setTentativePending is basically unsafe.  It overwrites the pending---   state with a new one, not related to the repository state.-setTentativePending :: forall rt p wR wU wT wX wY. RepoPatch p+-- | 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-                    -> UpdateWorking-                    -> FL (PrimOf p) wX wY+                    -> FL (PrimOf p) wT wP                     -> IO ()-setTentativePending _                   NoUpdateWorking  _ = return ()-setTentativePending repo YesUpdateWorking patch = do+setTentativePending repo patch = do     Sealed prims <- return $ siftForPending patch-    withRepoLocation repo $ writeTentativePending repo (unsafeCoercePStart prims)---- | @prepend repo YesUpdateWorking ps@ prepends @ps@ to the pending patch---   It's used right before removing @ps@ from the repo.  This ensures that---   the pending patch can still be applied on top of the recorded state.------   This function is basically unsafe.  It overwrites the pending state---   with a new one, not related to the repository state.-prepend :: forall rt p wR wU wT wX wY. RepoPatch p-        => Repository rt p wR wU wT-        -> UpdateWorking-        -> FL (PrimOf p) wX wY-        -> IO ()-prepend _    NoUpdateWorking  _     = return ()-prepend repo YesUpdateWorking patch = do-    Sealed pend <- readTentativePending repo-    Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch-    writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_)-  where-    newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA)-    newpend NilFL patch_ = seal patch_-    newpend p     patch_ = seal $ patch_ +>+ p--+    withRepoLocation repo $ writeTentativePending repo prims
src/Darcs/Repository/Prefs.hs view
@@ -23,7 +23,7 @@     , getGlobal     , environmentHelpHome     , defaultrepo-    , getDefaultRepoPath+    , getDefaultRepo     , addRepoSource     , getPrefval     , setPrefval@@ -31,8 +31,7 @@     , defPrefval     , writeDefaultPrefs     , boringRegexps-    , boringFileFilter-    , darcsdirFilter+    , isBoring     , FileType(..)     , filetypeFunction     , getCaches@@ -43,17 +42,18 @@     , showMotd     , prefsUrl     , prefsDirPath+    , prefsFilePath+    , getPrefLines -- exported for darcsden, don't remove     -- * documentation of prefs files     , prefsFilesHelp     ) where -import Prelude () import Darcs.Prelude  import Control.Exception ( catch ) import Control.Monad ( unless, when, liftM ) import Data.Char ( toUpper )-import Data.List ( nub, isPrefixOf, union, sortBy, lookup )+import Data.List ( nub, isPrefixOf, union, lookup ) import Data.Maybe ( isJust, fromMaybe, mapMaybe, catMaybes, maybeToList ) import qualified Control.Exception as C import qualified Data.ByteString       as B  ( empty, null, hPut, ByteString )@@ -62,19 +62,25 @@                           createDirectory, doesFileExist ) import System.Environment ( getEnvironment ) import System.FilePath.Posix ( normalise, dropTrailingPathSeparator, (</>) )-import System.IO.Error ( isDoesNotExistError )+import System.IO.Error ( isDoesNotExistError, catchIOError ) import System.IO ( stdout, stderr ) import System.Info ( os )+import System.Posix.Files ( getFileStatus, fileOwner ) import Text.Regex ( Regex, mkRegex, matchRegex ) -import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..),-                                WritableOrNot(..), compareByLocality )+import Darcs.Repository.Cache ( Cache, mkCache, CacheType(..), CacheLoc(..),+                                WritableOrNot(..) ) import Darcs.Util.External ( gzFetchFilePS , fetchFilePS, Cachable(..))-import Darcs.Repository.Flags( UseCache (..), DryRun (..), SetDefault (..),-                               RemoteRepos (..) )+import Darcs.Repository.Flags+    ( UseCache (..)+    , DryRun (..)+    , SetDefault (..)+    , InheritDefault (..)+    , RemoteRepos (..)+    ) import Darcs.Util.Lock( readTextFile, writeTextFile ) import Darcs.Util.Exception ( catchall )-import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Global ( darcsdir, debugMessage ) import Darcs.Util.Path ( AbsolutePath, ioAbsolute, toFilePath,                          getCurrentDirectory ) import Darcs.Util.Printer( hPutDocLn, text )@@ -186,6 +192,8 @@     , "(^|/)\\.DS_Store$"     , "# emacs saved sessions (desktops)"     , "(^|.*/)\\.emacs\\.desktop(\\.lock)?$"+    , " # stack"+    , "(^|/)\\.stack-work($|/)"     ]  boringFileInternalHelp :: [String]@@ -201,17 +209,6 @@     , "See regex(7) for a description of extended regular expressions."     ] -darcsdirFilter :: [FilePath] -> [FilePath]-darcsdirFilter = filter (not . isDarcsdir)--isDarcsdir :: FilePath -> Bool-isDarcsdir ('.' : '/' : f) = isDarcsdir f-isDarcsdir "." = True-isDarcsdir "" = True-isDarcsdir ".." = True-isDarcsdir "../" = True-isDarcsdir fp = (darcsdir ++ "/") `isPrefixOf` fp || fp == darcsdir- -- | The path of the global preference directory; @~/.darcs@ on Unix, -- and @%APPDATA%/darcs@ on Windows. globalPrefsDir :: IO (Maybe FilePath)@@ -272,12 +269,10 @@     globalBores <- getGlobal "boring"     liftM catMaybes $ mapM tryMakeBoringRegexp $ localBores ++ globalBores -boringFileFilter :: IO ([FilePath] -> [FilePath])-boringFileFilter = filterBoringAndDarcsdir `fmap` boringRegexps-  where-    filterBoringAndDarcsdir regexps = filter (notBoring regexps . doNormalise)-    notBoring regexps file = not $-        isDarcsdir file || any (\r -> isJust $ matchRegex r file) regexps+isBoring :: IO (FilePath -> Bool)+isBoring = do+  regexps <- boringRegexps+  return $ \file -> any (\r -> isJust $ matchRegex r file) regexps  noncomments :: [String] -> [String] noncomments = filter nonComment@@ -439,12 +434,12 @@ defaultrepo :: RemoteRepos -> AbsolutePath -> [String] -> IO [String] defaultrepo (RemoteRepos rrepos) _ [] =   do case rrepos of-       [] -> maybeToList `fmap` getDefaultRepoPath+       [] -> maybeToList `fmap` getDefaultRepo        rs -> mapM fixRepoPath rs defaultrepo _ _ r = return r -getDefaultRepoPath :: IO (Maybe String)-getDefaultRepoPath = do+getDefaultRepo :: IO (Maybe String)+getDefaultRepo = do     defaults <- getPreflist defaultRepoPref     case defaults of          [] -> return Nothing@@ -456,19 +451,26 @@ -- | addRepoSource adds a new entry to _darcs/prefs/repos and sets it as default --   in _darcs/prefs/defaultrepo, unless --no-set-default or --dry-run is passed, --   or it is the same repository as the current one.-addRepoSource :: String -> DryRun -> RemoteRepos -> SetDefault -> IO ()-addRepoSource r isDryRun (RemoteRepos rrepos) setDefault = (do+addRepoSource :: String+              -> DryRun+              -> RemoteRepos+              -> SetDefault+              -> InheritDefault+              -> Bool+              -> IO ()+addRepoSource r isDryRun (RemoteRepos rrepos) setDefault inheritDefault isInteractive = (do     olddef <- getPreflist defaultRepoPref+    newdef <- newDefaultRepo     let shouldDoIt = null noSetDefault && greenLight-        greenLight = shouldAct && not rIsTmp && (olddef /= [r] || olddef == [])+        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 [r]-       else when (True `notElem` noSetDefault && greenLight) $+       then setPreflist defaultRepoPref [newdef]+       else when (True `notElem` noSetDefault && greenLight && inheritDefault == NoInheritDefault) $                 putStr . unlines $ setDefaultMsg-    addToPreflist "repos" r) `catchall` return ()+    addToPreflist "repos" newdef) `catchall` return ()   where     shouldAct = isDryRun == NoDryRun     rIsTmp = r `elem` rrepos@@ -476,11 +478,39 @@                        NoSetDefault x -> [x]                        _ -> []     setDefaultMsg =-        [ "HINT: if you want to change the default remote repository to"+        [ "By the way, to change the default remote repository to"         , "      " ++ r ++ ","-        , "      quit now and issue the same command with the --set-default "-          ++ "flag."+        , "you can " +++          (if isInteractive then "quit now and " else "") +++          "issue the same command with the --set-default flag."         ]+    newDefaultRepo :: IO String+    newDefaultRepo = case inheritDefault of+      YesInheritDefault -> getRemoteDefaultRepo+      NoInheritDefault -> return r+    -- TODO It would be nice if --inherit-default could be made to work with+    -- arbitrary remote repos; for security reasons we currently allow only+    -- repos on the same host which must also be owned by ourselves. This is+    -- because the defaultrepo file is read and written as a text file, and+    -- therefore encoded in the user's locale encoding. See+    -- http://bugs.darcs.net/issue2627 for a more detailed discussion.+    getRemoteDefaultRepo+      | isValidLocalPath r = do+          sameOwner r "." >>= \case+            True -> do+              defs <-+                getPreffile (r </> darcsdir </> "prefs/defaultrepo")+                `catchIOError`+                const (return [r])+              case defs of+                defrepo:_ -> do+                  debugMessage "using defaultrepo of remote"+                  return defrepo+                [] -> return r+            False -> return r+      | otherwise = return r+    sameOwner p q =+      (==) <$> (fileOwner <$> getFileStatus p) <*> (fileOwner <$> getFileStatus q)  -- | delete references to other repositories. --   Used when cloning to a ssh destination.@@ -509,7 +539,7 @@         thatrepo = [Cache Repo NotWritable repodir]         tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++ here                           ++ thatrepo ++ filterExternalSources there-    return $ Ca $ sortBy compareByLocality tempCache+    return $ mkCache tempCache   where     sourcesFile = darcsdir ++ "/prefs/sources" @@ -553,6 +583,9 @@ prefsDirPath :: FilePath prefsDirPath = darcsdir </> prefsDir +prefsFilePath :: FilePath+prefsFilePath = prefsDirPath </> "prefs"+ prefsFilesHelp :: [(String,String)] prefsFilesHelp  =     [ ("motd", unlines@@ -573,7 +606,7 @@       , "e.g. `David Roundy <droundy@abridgegame.org>`. This file overrides the"       , "contents of the environment variables `$DARCS_EMAIL` and `$EMAIL`."])     , ("defaults", unlines-      [ "Default values for darcs commands. Each line of this file has the"+      [ "Default options for darcs commands. Each line of this file has the"       , "following form:"       , ""       , "    COMMAND FLAG VALUE"@@ -581,12 +614,15 @@       , "where `COMMAND` is either the name of the command to which the default"       , "applies, or `ALL` to indicate that the default applies to all commands"       , "accepting that flag. The `FLAG` term is the name of the long argument"-      , "option without the `--`, i.e. `verbose` rather than `--verbose`."+      , "option with or without the `--`, i.e. `verbose` or `--verbose`."       , "Finally, the `VALUE` option can be omitted if the flag does not involve"       , "a value. If the value has spaces in it, use single quotes, not double"       , "quotes, to surround it. Each line only takes one flag. To set multiple"       , "defaults for the same command (or for `ALL` commands), use multiple lines."       , ""+      , "Options listed in the defaults file are just that: defaults. You can"+      , "override any default on the command line."+      , ""       , "Note that the use of `ALL` easily can have unpredicted consequences,"       , "especially if commands in newer versions of darcs accepts flags that"       , "they did not in previous versions. Only use safe flags with `ALL`."@@ -604,38 +640,10 @@       , ""       , "    amend disable"       , ""-      , "Also, a global preferences file can be created with the name"-      , "`.darcs/defaults` in your home directory. Options present there will be"-      , "added to the repository-specific preferences if they do not conflict."])-    , ("sources", unlines-      [ "The `_darcs/prefs/sources` file is used to indicate alternative locations"-      , "from which to download patches. This file contains lines such as:"-      , ""-      , "    cache:/home/droundy/.cache/darcs"-      , "    readonly:/home/otheruser/.cache/darcs"-      , "    repo:http://darcs.net"-      , ""-      , "This would indicate that darcs should first look in"-      , "`/home/droundy/.cache/darcs` for patches that might be missing, and if"-      , "the patch is not there, it should save a copy there for future use."-      , "In that case, darcs will look in `/home/otheruser/.cache/darcs` to see if"-      , "that user might have downloaded a copy, but will not try to save a copy"-      , "there, of course. Finally, it will look in `http://darcs.net`. Note that"-      , "the `sources` file can also exist in `~/.darcs/`. Also note that the"-      , "sources mentioned in your `sources` file will be tried *before* the"-      , "repository you are pulling from. This can be useful in avoiding"-      , "downloading patches multiple times when you pull from a remote"-      , "repository to more than one local repository."-      , ""-      , "A global cache is enabled by default in your home directory. The cache"-      , "allows darcs to avoid re-downloading patches (for example, when doing a"-      , "second darcs clone of the same repository), and also allows darcs to use"-      , "hard links to reduce disk usage."-      , ""-      , "Note that the cache directory should reside on the same filesystem as"-      , "your repositories, so you may need to vary this. You can also use"-      , "multiple cache directories on different filesystems, if you have several"-      , "filesystems on which you use darcs."])+      , "A global defaults file can be created with the name"+      , "`.darcs/defaults` in your home directory. In case of conflicts,"+      , "the defaults for a specific repository take precedence."+      ])     , ("boring", unlines       [ "The `_darcs/prefs/boring` file may contain a list of regular expressions"       , "describing files, such as object files, that you do not expect to add to"@@ -675,6 +683,46 @@       [ "Contains the URL of the default remote repository used by commands `pull`,"       , "`push`, `send` and `optimize relink`. Darcs edits this file automatically"       , "or when the flag `--set-default` is used."])+    , ("sources", unlines+      [ "Besides the defaultrepo, darcs also keeps track of any other locations"+      , "used in commands for exchanging patches (e.g. push, pull, send)."+      , "These are subsequently used as alternatives from which to download"+      , "patches. The file contains lines such as:"+      , ""+      , "    cache:/home/droundy/.cache/darcs"+      , "    readonly:/home/otheruser/.cache/darcs"+      , "    repo:http://darcs.net"+      , ""+      , "The prefix `cache:` indicates that darcs can use this as a read-write"+      , "cache for patches, `read-only:` indicates a cache that is only"+      , "readable, and `repo:` denotes a (possibly remote) repository. The order"+      , "of the entries is immaterial: darcs will always try local paths before"+      , "remote ones, and only local ones will be used as potentially writable."+      , ""+      , "A global cache is enabled by default in your home directory under"+      , "`.cache/darcs` (older versions of darcs used `.darcs/cache` for this),"+      , "or `$XDG_CACHE_HOME/darcs` if the environment variable is set, see"+      , "https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html."+      , "The cache allows darcs to avoid re-downloading patches (for example, when"+      , "doing a second darcs clone of the same repository), and also allows darcs"+      , "to use hard links to reduce disk usage."+      , ""+      , "Note that the cache directory should reside on the same filesystem as"+      , "your repositories, so you may need to vary this. You can also use"+      , "multiple cache directories on different filesystems, if you have several"+      , "filesystems on which you use darcs."+      , ""+      , "While darcs automatically adds entries to `_darcs/prefs/sources`, it does"+      , "not currently remove them. If one or more of the entries aren't accessible"+      , "(e.g. because they resided on a removable media), then darcs will bugger"+      , "you with a hint, suggesting you remove those entries. This is done because"+      , "certain systems have extremely long timeouts associated with some remotely"+      , "accessible media (e.g. NFS over automounter on Linux), which can slow down"+      , "darcs operations considerably. On the other hand, when you clone a repo"+      , "with --lazy from a no longer accessible location, then the hint may give"+      , "you an idea where the patches could be found, so you can try to restore"+      , "access to them."+      ])     , ("tmpdir", unlines       [ "By default temporary directories are created in `/tmp`, or if that doesn't"       , "exist, in `_darcs` (within the current repo).  This can be overridden by"
+ src/Darcs/Repository/Pristine.hs view
@@ -0,0 +1,218 @@+module Darcs.Repository.Pristine+    ( ApplyDir(..)+    , applyToHashedPristine+    , applyToTentativePristine+    , applyToTentativePristineCwd+    , readHashedPristineRoot+    , pokePristineHash+    , peekPristineHash+    , createPristineDirectoryTree+    , createPartialsPristineDirectoryTree+    , withRecorded+    , withTentative+    ) 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 System.Directory ( createDirectoryIfMissing )+import System.FilePath.Posix( (</>) )+import System.IO ( hPutStrLn, stderr )++import Darcs.Patch ( description )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Show ( ShowPatch )++import Darcs.Repository.Cache ( Cache, HashedDir(..), mkCache )+import Darcs.Repository.Flags ( Verbosity(..), WithWorkingDir(..) )+import Darcs.Repository.Format ( RepoProperty(HashedInventory), formatHas )+import Darcs.Repository.HashedIO ( cleanHashdir, copyHashed, copyPartialsHashed )+import Darcs.Repository.Inventory+import Darcs.Repository.InternalTypes+    ( Repository+    , repoCache+    , repoFormat+    , repoLocation+    , withRepoLocation+    )+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.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.Tree.Hashed+    ( decodeDarcsHash+    , decodeDarcsSize+    , hashedTreeIO+    , readDarcsHashed+    , readDarcsHashedNosize+    , writeDarcsHashed+    )+++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+  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+        -- 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."++    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++-- | 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++-- |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+                         -> 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+    tentativePristine <- gzReadFilePS tentativePristinePath+    -- Extract the pristine hash from the tentativePristine file, using+    -- peekPristineHash (this is valid since we normally just extract the hash from the+    -- first line of an inventory file; we can pass in a one-line file that+    -- just contains said hash).+    let tentativePristineHash = peekPristineHash tentativePristine+    newPristineHash <- applyToHashedPristine dir 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+  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++-- | 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++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++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
src/Darcs/Repository/Rebase.hs view
@@ -1,220 +1,247 @@ --  Copyright (C) 2009-2012 Ganesh Sittampalam -- --  BSD3+{-# LANGUAGE OverloadedStrings #-} module Darcs.Repository.Rebase-    ( RebaseJobFlags(..)-    , withManualRebaseUpdate+    ( withManualRebaseUpdate     , rebaseJob     , startRebaseJob     , maybeDisplaySuspendedStatus+    -- create/read/write rebase patch+    , readTentativeRebase+    , writeTentativeRebase+    , withTentativeRebase+    , createTentativeRebase+    , readRebase+    , commuteOutOldStyleRebase+    , checkOldStyleRebaseStatus     ) where -import Prelude () import Darcs.Prelude -import Darcs.Util.Global ( darcsdir )+import Control.Exception (throwIO )+import Control.Monad ( unless )+import System.Exit ( exitFailure )+import System.IO.Error ( catchIOError, isDoesNotExistError )  import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.CommuteFn ( commuterIdRL )-import Darcs.Patch.Commute ( selfCommuter )-import Darcs.Patch.Named.Wrapped ( WrappedNamed(..), mkRebase )-import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully )-import Darcs.Patch.Rebase-  ( takeHeadRebase-  , takeAnyRebase-  , takeAnyRebaseAndTrailingPatches-  )-import Darcs.Patch.Rebase.Container ( Suspended(..), countToEdit, simplifyPushes )+import Darcs.Patch.Commute ( Commute(..) )+import qualified Darcs.Patch.Named.Wrapped as W+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAndG+    , hopefully+    )+import Darcs.Patch.Read ( readPatch )+import Darcs.Patch.Rebase.Suspended+    ( Suspended(Items)+    , countToEdit+    , simplifyPushes+    ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )-import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.RepoPatch ( RepoPatch, PrimOf ) import Darcs.Patch.RepoType   ( RepoType(..), IsRepoType(..), SRepoType(..)   , RebaseType(..), SRebaseType(..)   )-import Darcs.Patch.Set ( PatchSet(..) )-import Darcs.Patch.Witnesses.Ordered-    ( FL(..), (:>)(..), RL(..), reverseRL-    )-import Darcs.Patch.Witnesses.Sealed-    ( Sealed2(..), FlippedSeal(..) )-+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.Repository.Flags-    ( Compression-    , UpdateWorking(..)-    , Verbosity-    ) import Darcs.Repository.Format-    ( RepoProperty ( RebaseInProgress )+    ( RepoProperty ( RebaseInProgress_2_16, RebaseInProgress )     , formatHas     , addToFormat     , removeFromFormat     , writeRepoFormat     )-import Darcs.Repository.Hashed-    ( tentativelyAddPatch-    , tentativelyAddPatch_-    , tentativelyAddPatches_-    , tentativelyRemovePatches-    , tentativelyRemovePatches_-    , finalizeRepositoryChanges-    , revertRepositoryChanges-    , readTentativeRepo-    , readRepo-    , UpdatePristine(..)+import Darcs.Repository.InternalTypes+    ( Repository+    , repoFormat+    , withRepoLocation     )-import Darcs.Repository.InternalTypes ( Repository, repoFormat, repoLocation )+import Darcs.Repository.Paths+    ( rebasePath+    , tentativeRebasePath+    , formatPath+    ) -import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )-import Darcs.Util.Printer ( ePutDocLn, text )-import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) )+import Darcs.Util.English ( englishNum, Noun(..) )+import Darcs.Util.Lock ( writeDocBinFile, readBinFile )+import Darcs.Util.Printer ( renderString, text, hsep, vcat, ($$) )+import Darcs.Util.Printer.Color ( ePutDocLn ) import Darcs.Util.Tree ( Tree )  import Control.Exception ( finally ) -import System.FilePath.Posix ( (</>) )---- | Some common flags that are needed to run rebase jobs.--- Normally flags are captured directly by the implementation of the specific--- job's function, but the rebase infrastructure needs to do work on the repository--- directly that sometimes needs these options, so they have to be passed--- as part of the job definition.-data RebaseJobFlags =-  RebaseJobFlags-  { rjoCompression   :: Compression-  , rjoVerbosity     :: Verbosity-  , rjoUpdateWorking :: UpdateWorking-  }- withManualRebaseUpdate    :: forall rt p x wR wU wT1 wT2     . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-   => RebaseJobFlags-   -> Repository rt p wR wU wT1-   -> (Repository rt p wR wU wT1 -> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x))+   => 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 (RebaseJobFlags compr verb uw) r subFunc- | SRepoType SIsRebase <- singletonRepoType :: SRepoType rt- = do patches <- readTentativeRepo r (repoLocation r)-      let go :: PatchSet rt p wS wT1 -> IO (Repository rt p wR wU wT2, x)-          go (PatchSet _ NilRL) = bug "trying to recontext rebase without rebase patch at head (tag)"-          go (PatchSet _ (_ :<: q)) =-              case hopefully q of-                  NormalP {} ->-                      bug "trying to recontext rebase without a rebase patch at head (not match)"-                  RebaseP _ s -> do-                      r' <- tentativelyRemovePatches r compr uw (q :>: NilFL)-                      (r'', fixups, x) <- subFunc r'-                      q' <- n2pia <$> mkRebase (simplifyPushes D.MyersDiff fixups s)-                      r''' <- tentativelyAddPatch r'' compr verb uw q'-                      return (r''', x)-      go patches-withManualRebaseUpdate _flags r subFunc- = do (r', _, x) <- subFunc r+withManualRebaseUpdate r subFunc+  | SRepoType SIsRebase <- singletonRepoType :: SRepoType rt = do+      susp <- readTentativeRebase r+      (r', fixups, x) <- subFunc r+      -- 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) --- got a rebase operation to run where it is required that a rebase is already in progress+catchDoesNotExist :: IO a -> IO a -> IO a+catchDoesNotExist a b =+  a `catchIOError` (\e -> if isDoesNotExistError e then b else throwIO e)++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+      ePutDocLn upgradeMsg+      exitFailure+  where+    upgradeMsg = vcat+      [ "An old-style rebase is in progress in this repository. You can upgrade it"+      , "to the new format using the 'darcs rebase upgrade' command. The repository"+      , "format is unaffected by this, but you won't be able to use a darcs version"+      , "older than 2.16 on this repository until the current rebase is finished."+      ]++-- | 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-          -> RebaseJobFlags           -> IO a-rebaseJob job repo flags = do-    repo' <- moveRebaseToEnd repo flags-    job repo'-      -- the use of finally here is because various things in job+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).-      -- It's a bit questionable/non-standard as it's doing quite a bit-      -- of cleanup and if there was an unexpected error then this-      -- may may things worse.+      --       -- The better fix would be to standardise expected early exits       -- e.g. using a layer on top of IO or a common Exception type       -- and then just catch those.-      `finally` checkSuspendedStatus repo' flags+      `finally` checkSuspendedStatus repo --- got a rebase operation to run where we may need to initialise the rebase state first+-- | 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-               -> RebaseJobFlags                -> IO a-startRebaseJob job repo flags = do-    repo' <- startRebaseIfNecessary repo flags-    rebaseJob job repo' flags+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-                     -> RebaseJobFlags                      -> IO ()-checkSuspendedStatus repo flags@(RebaseJobFlags compr _verb uw) = do-    (_, Sealed2 ps) <- takeAnyRebase <$> readRepo repo+checkSuspendedStatus _repo = do+    ps <- readTentativeRebase _repo `catchIOError` \_ -> readRebase _repo     case countToEdit ps of          0 -> do-               debugMessage "Removing the rebase patch file..."-               -- this shouldn't actually be necessary since the count should-               -- only go to zero after an actual rebase operation which would-               -- leave the patch at the end anyway, but be defensive.-               repo' <- moveRebaseToEnd repo flags-               revertRepositoryChanges repo' uw-               -- in theory moveRebaseToEnd could just return the commuted one,-               -- but since the repository has been committed and re-opened-               -- best to just do things carefully-               (rebase, _, _) <- takeHeadRebase <$> readRepo repo'-               repo'' <- tentativelyRemovePatches repo' compr uw (rebase :>: NilFL)-               finalizeRepositoryChanges repo'' uw compr                writeRepoFormat-                  (removeFromFormat RebaseInProgress (repoFormat repo))-                  (darcsdir </> "format")+                  (removeFromFormat RebaseInProgress_2_16 $+                    repoFormat _repo)+                  formatPath                putStrLn "Rebase finished!"-         n -> ePutDocLn $ text $ "Rebase in progress: " ++ show n ++ " suspended patches"+         n -> displaySuspendedStatus n -moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree)-                => Repository ('RepoType 'IsRebase) p wR wU wR-                -> RebaseJobFlags-                -> IO (Repository ('RepoType 'IsRebase) p wR wU wR)-moveRebaseToEnd repo (RebaseJobFlags compr verb uw) = do-    allpatches <- readRepo repo-    case takeAnyRebaseAndTrailingPatches allpatches of-        FlippedSeal (_ :> NilRL) -> return repo -- already at head-        FlippedSeal (r :> ps) -> do-            Just (ps' :> r') <- return $ commuterIdRL selfCommuter (r :> ps)-            debugMessage "Moving rebase patch to head..."-            revertRepositoryChanges repo uw-            repo' <- tentativelyRemovePatches_ DontUpdatePristine repo compr uw (reverseRL ps)-            repo'' <- tentativelyRemovePatches_ DontUpdatePristine repo' compr uw (r :>: NilFL)-            repo''' <- tentativelyAddPatches_ DontUpdatePristine repo'' compr verb uw (reverseRL ps')-            repo'''' <- tentativelyAddPatch_ DontUpdatePristine repo''' compr verb uw r'-            finalizeRepositoryChanges repo'''' uw compr-            return repo''''+displaySuspendedStatus :: Int -> IO ()+displaySuspendedStatus count =+  ePutDocLn $ hsep+    [ "Rebase in progress:"+    , text (show count)+    , "suspended"+    , text (englishNum count (Noun "patch") "")+    ] -displaySuspendedStatus :: RepoPatch p => Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()-displaySuspendedStatus repo = do-    (_, Sealed2 ps) <- takeAnyRebase <$> readRepo repo-    ePutDocLn $ text $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches"+-- | 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 () -maybeDisplaySuspendedStatus+withTentativeRebase   :: RepoPatch p-  => SRebaseType rebaseType -> Repository ('RepoType rebaseType) p wR wU wR -> IO ()-maybeDisplaySuspendedStatus SIsRebase repo = displaySuspendedStatus repo-maybeDisplaySuspendedStatus SNoRebase _    = return ()+  => Repository rt p wR wU wT+  -> Repository rt p wR wU wY+  -> (Suspended p wT wT -> Suspended p wY wY)+  -> IO ()+withTentativeRebase r r' f =+  readTentativeRebase r >>= writeTentativeRebase r' . f -startRebaseIfNecessary :: (RepoPatch p, ApplyState p ~ Tree)-                       => Repository ('RepoType 'IsRebase) p wR wU wT-                       -> RebaseJobFlags-                       -> IO (Repository ('RepoType 'IsRebase) p wR wU wT)-startRebaseIfNecessary repo (RebaseJobFlags compr verb uw) =-  let rf = repoFormat repo-  in-    if formatHas RebaseInProgress rf-    then return repo-    else do -- TODO this isn't under the repo lock, and it should be-           writeRepoFormat (addToFormat RebaseInProgress rf) (darcsdir </> "format")-           debugMessage "Writing the rebase patch file..."-           revertRepositoryChanges repo uw-           mypatch <- mkRebase (Items NilFL)-           repo' <- tentativelyAddPatch_ UpdatePristine repo compr verb uw $ n2pia mypatch-           finalizeRepositoryChanges repo' uw compr-           return repo'+readTentativeRebase :: RepoPatch p+                    => Repository rt p wR wU wT -> IO (Suspended p wT wT)+readTentativeRebase = readRebaseFile tentativeRebasePath +writeTentativeRebase :: RepoPatch p+                     => Repository rt p wR wU wT -> Suspended p wT wT -> IO ()+writeTentativeRebase = writeRebaseFile tentativeRebasePath++readRebase :: RepoPatch p => Repository rt p wR wU wR -> IO (Suspended p wR 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)++-- 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)++-- unsafe witnesses, not exported+writeRebaseFile :: RepoPatch p+                => FilePath -> Repository rt p wR wU wT+                -> Suspended p wX wX -> IO ()+writeRebaseFile path r sp =+  withRepoLocation r $+    writeDocBinFile path (showPatch ForStorage sp)++type PiaW rt p = PatchInfoAndG rt (W.WrappedNamed rt 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
src/Darcs/Repository/Repair.hs view
@@ -3,7 +3,6 @@                                  RepositoryConsistency(..) )        where -import Prelude () import Darcs.Prelude  import Control.Monad ( when, unless )@@ -11,11 +10,23 @@ import Control.Exception ( catch, finally, IOException ) import Data.Maybe ( catMaybes ) import Data.List ( sort, (\\) )-import System.Directory ( createDirectoryIfMissing, getCurrentDirectory,-                          setCurrentDirectory )+import System.Directory+    ( createDirectoryIfMissing+    , getCurrentDirectory+    , removeDirectoryRecursive+    , setCurrentDirectory+    ) import System.FilePath ( (</>) ) import Darcs.Util.Path( anchorPath, AbsolutePath, ioAbsolute, toFilePath )-import Darcs.Patch.PatchInfoAnd ( hopefully, PatchInfoAnd, info, winfo, WPatchInfo, unWPatchInfo, compareWPatchInfo )+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , WPatchInfo+    , compareWPatchInfo+    , hopefully+    , info+    , unWPatchInfo+    , winfo+    )  import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered@@ -28,30 +39,37 @@ import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2FL, patchSet2RL ) import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, isInconsistent ) -import Darcs.Repository.Flags-    ( Verbosity(..), Compression, DiffAlgorithm )-import Darcs.Repository.Format ( identifyRepoFormat,-                                 RepoProperty ( HashedInventory ), formatHas ) 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 ( readHashedPristineRoot, writeAndReadPatch )+import Darcs.Repository.Hashed ( readRepo, writeAndReadPatch ) import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation ) import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.Repository.Hashed ( readRepo )+import Darcs.Repository.Pristine ( readHashedPristineRoot ) import Darcs.Repository.State     ( readRecorded     , readIndex     , readRecordedAndPending     )-import Darcs.Repository.Diff( treeDiff ) -import Darcs.Util.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )+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( rmRecursive, withTempDir )-import Darcs.Util.Printer ( Doc, putDocLn, text )-import Darcs.Util.Printer.Color ( showDoc )+import Darcs.Util.Lock( withDelayedDir )+import Darcs.Util.Printer ( Doc, putDocLn, text, renderString )  import Darcs.Util.Hash( Hash(NoHash), encodeBase16 ) import Darcs.Util.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees )@@ -66,14 +84,17 @@             -> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]             -> FL (PatchInfoAnd rt a) wX wY replaceInFL orig [] = orig-replaceInFL NilFL _ = impossible+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+  :: 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@@ -83,7 +104,8 @@        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 :: FL (PatchInfoAnd rt p) wW wZ+              -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)           aaf NilFL = return ([], True)           aaf (p:>:ps) = do             mp' <- applyAndTryToFix p@@ -91,7 +113,8 @@               Just err -> liftIO $ putDocLn err               Nothing -> return ()             let !winfp = winfo p -- assure that 'p' can be garbage collected.-            liftIO $ finishedOneIO k $ showDoc $ displayPatchInfo $ unWPatchInfo winfp+            liftIO $ finishedOneIO k $ renderString $+              displayPatchInfo $ unWPatchInfo winfp             (ps', restok) <- aaf ps             case mp' of               Nothing -> return (ps', restok)@@ -123,9 +146,15 @@           hd [] = Nothing           hd (x1:x2:xs) | x1 == x2 = Just x1                         | otherwise = hd (x2:xs)-replayRepository' ::-    forall rt p wR wU wT . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-               => DiffAlgorithm -> AbsolutePath -> Repository rt p wR wU wT -> Compression -> Verbosity -> IO (RepositoryConsistency rt p wR)++replayRepository'+  :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+  => DiffAlgorithm+  -> AbsolutePath+  -> Repository rt p wR wU wT+  -> Compression+  -> Verbosity+  -> IO (RepositoryConsistency rt p wR) replayRepository' dflag whereToReplay' repo compr verbosity = do   let whereToReplay = toFilePath whereToReplay'       putVerbose s = when (verbosity == Verbose) $ putDocLn s@@ -133,7 +162,10 @@   checkUniqueness putVerbose putInfo repo   createDirectoryIfMissing False whereToReplay   putVerbose $ text "Reading recorded state..."-  pris <- readRecorded repo `catch` \(_ :: IOException) -> return emptyTree+  pris <-+    (readRecorded repo >>= expand >>= darcsUpdateHashes)+    `catch`+    \(_ :: IOException) -> return emptyTree   putVerbose $ text "Applying patches..."   patches <- readRepo repo   debugMessage "Fixing any broken patches..."@@ -146,7 +178,8 @@    debugMessage "Checking pristine against slurpy"   ftf <- filetypeFunction-  is_same <- do Sealed diff <- unFreeLeft `fmap` treeDiff dflag ftf pris newpris :: IO (Sealed (FL (PrimOf p) wR))+  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@@ -162,23 +195,40 @@   let c = repoCache r   rf <- identifyRepoFormat "."   unless (formatHas HashedInventory rf) $-         rmRecursive $ darcsdir ++ "/pristine.hashed"+         removeDirectoryRecursive $ darcsdir ++ "/pristine.hashed"   when (formatHas HashedInventory rf) $ do        current <- readHashedPristineRoot r        cleanHashdir c HashedPristineDir $ catMaybes [current] -replayRepositoryInTemp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                       => DiffAlgorithm -> Repository rt p wR wU wT -> Compression -> Verbosity-                          -> IO (RepositoryConsistency rt p wR)+replayRepositoryInTemp+  :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+  => DiffAlgorithm+  -> Repository rt p wR wU wT+  -> Compression+  -> Verbosity+  -> IO (RepositoryConsistency rt p wR) replayRepositoryInTemp dflag r compr verb = do   repodir <- getCurrentDirectory-  withTempDir "darcs-check" $ \tmpDir -> do+  {- The reason we use withDelayedDir here, instead of withTempDir, is that+  replayRepository' may return a new pristine that is read from the +  temporary location and reading a Tree is done using lazy ByteStrings (for+  file contents). Then we check if there is a difference to our stored+  pristine, but when there are differences the check may terminate early+  and not all of the new pristine was read/evaluated. This may then cause+  does-not-exist-failures later on when the tree is evaluated further.+  -}+  withDelayedDir "darcs-check" $ \tmpDir -> do     setCurrentDirectory repodir     replayRepository' dflag tmpDir r compr verb -replayRepository :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-                 => DiffAlgorithm -> Repository rt p wR wU wT -> Compression -> Verbosity-                 -> (RepositoryConsistency rt p wR -> IO a) -> IO a+replayRepository+  :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+  => DiffAlgorithm+  -> Repository rt p wR wU wT+  -> Compression+  -> Verbosity+  -> (RepositoryConsistency rt p wR -> IO a)+  -> IO a replayRepository dflag r compr verb f =   run `finally` cleanupRepositoryReplay r     where run = do@@ -187,7 +237,11 @@             st <- replayRepository' dflag hashedPristine r compr verb             f st -checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> Bool -> IO Bool+checkIndex+  :: (RepoPatch p, ApplyState p ~ Tree)+  => Repository rt p wR wU wR+  -> Bool+  -> IO Bool checkIndex repo quiet = do   index <- updateIndex =<< readIndex repo   pristine <- expand =<< readRecordedAndPending repo@@ -201,7 +255,8 @@       gethashes p (Just i1) Nothing   = (p, itemHash i1, NoHash)       gethashes p   Nothing (Just i2) = (p,      NoHash, itemHash i2)       gethashes p   Nothing Nothing   = error $ "Bad case at " ++ show p-      mismatches = [ miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2 ]+      mismatches =+        [miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2]        format paths = unlines $ map (("  " ++) . anchorPath "") paths       mismatches_disp = unlines [ anchorPath "" p ++
src/Darcs/Repository/Resolution.hs view
@@ -14,88 +14,165 @@ --  along with this program; see the file COPYING.  If not, write to --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA.- module Darcs.Repository.Resolution     ( standardResolution     , externalResolution     , patchsetConflictResolutions+    , StandardResolution(..)+    , announceConflicts+    , warnUnmangled+    , showUnmangled+    , showUnravelled     ) where -import Prelude () import Darcs.Prelude  import System.FilePath.Posix ( (</>) ) import System.Exit ( ExitCode( ExitSuccess ) ) import System.Directory ( setCurrentDirectory, getCurrentDirectory )-import Data.List ( zip4 )+import Data.List ( intersperse, zip4 )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( catMaybes, isNothing ) import Control.Monad ( when )  import Darcs.Repository.Diff( treeDiff )-import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, resolveConflicts,-                     effectOnFilePaths,-                     invert, listConflictedFiles, commute, applyToTree, fromPrim )+import Darcs.Patch+    ( PrimOf+    , PrimPatchBase+    , RepoPatch+    , applyToTree+    , effect+    , effectOnPaths+    , invert+    , listConflictedFiles+    , resolveConflicts+    ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )-import Darcs.Patch.Named.Wrapped ( activecontents )-import Darcs.Patch.Prim ( PrimPatchBase )-import Darcs.Util.Path ( toFilePath, filterFilePaths )-import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), (:>)(..), (+>+),-    mapFL_FL, concatFL, reverseRL )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Conflict ( Conflict, ConflictDetails(..), Mangled, Unravelled )+import Darcs.Patch.Inspect ( listTouchedFiles )+import Darcs.Patch.Merge ( mergeList )+import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Util.Path+    ( AnchoredPath+    , anchorPath+    , displayPath+    , filterPaths+    , toFilePath+    )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, unFreeLeft )  import Darcs.Util.CommandLine ( parseCmd )-import Darcs.Patch.PatchInfoAnd ( hopefully )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) import Darcs.Util.Prompt ( askEnter )-import Darcs.Patch.Set ( PatchSet(..), Origin )+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.Repository.Flags ( WantGuiPause(..), DiffAlgorithm(..) )+import Darcs.Repository.Flags+    ( AllowConflicts (..)+    , ExternalMerge (..)+    , WantGuiPause (..)+    , DiffAlgorithm (..)+    )  import qualified Darcs.Util.Tree as Tree import Darcs.Util.Tree.Plain ( writePlainTree, readPlainTree ) ---import Darcs.Util.Printer.Color ( traceDoc )---import Darcs.Util.Printer ( greenText, ($$), Doc )---import Darcs.Patch ( showPatch )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Printer ( Doc, renderString, ($$), text, redText, vcat )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Patch ( displayPatch ) -standardResolution :: (PrimPatchBase p, Conflict p, CommuteNoConflicts p)-                   => FL p wX wY -> Sealed (FL (PrimOf p) wY)-standardResolution = mergeList . map head . resolveConflicts+data StandardResolution prim wX =+  StandardResolution {+    mangled :: Mangled prim wX,+    unmangled :: [Unravelled prim wX],+    conflictedPaths :: [AnchoredPath]+  } -mergeList :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX)-mergeList = doml NilFL-    where doml :: FL prim wX wY -> [Sealed (FL prim wX)] -> Sealed (FL prim wX)-          doml mp (Sealed p:ps) =-              case commute (invert p :> mp) of-              Just (mp' :> _) -> doml (p +>+ mp') ps-              Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.-          doml mp [] = Sealed mp+standardResolution :: (Commute p, PrimPatchBase p, Conflict p)+                   => RL (PatchInfoAnd rt p) wO wX+                   -> RL (PatchInfoAnd rt p) wX wY+                   -> StandardResolution (PrimOf p) wY+standardResolution context interesting =+  case mergeList $ catMaybes $ map conflictMangled conflicts of+    Right mangled -> StandardResolution {..}+    Left (Sealed ps, Sealed qs) ->+      error $ renderString+        $ redText "resolutions conflict:"+        $$ displayPatch ps+        $$ redText "conflicts with"+        $$ displayPatch qs+  where+    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 {..}+  | null unmangled = return ()+  | otherwise = ePutDocLn $ showUnmangled unmangled++showUnmangled :: PrimPatch prim => [Unravelled prim wX] -> Doc+showUnmangled = vcat . map showUnmangledConflict+  where+    showUnmangledConflict unravelled =+      redText "Cannot mark these conflicting patches:" $$+      showUnravelled (redText "versus") unravelled++showUnravelled :: PrimPatch prim => Doc -> Unravelled prim wX -> Doc+showUnravelled sep =+  vcat . intersperse sep . map (unseal displayPatch)++announceConflicts :: PrimPatch prim+                  => String+                  -> AllowConflicts+                  -> ExternalMerge+                  -> StandardResolution prim wX+                  -> IO Bool+announceConflicts cmd allowConflicts externalMerge 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 $+          "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. "+ externalResolution :: forall p wX wY wZ wA. (RepoPatch p, ApplyState p ~ Tree.Tree)                    => DiffAlgorithm-                   -> Tree.Tree IO-                   -> String  -- ^ external merge tool command-                   -> WantGuiPause -- ^ tell whether we want GUI pause-                   -> FL (PrimOf p) wX wY-                   -> FL (PrimOf p) wX wZ-                   -> FL p wY wA+                   -> Tree.Tree IO        -- ^ working tree+                   -> String              -- ^ external merge tool command+                   -> WantGuiPause        -- ^ tell whether we want GUI pause+                   -> FL (PrimOf p) wX wY -- ^ our effect+                   -> FL (PrimOf p) wX wZ -- ^ their effect+                   -> FL p wY wA          -- ^ them merged (standard_resolution)                    -> IO (Sealed (FL (PrimOf p) wA))-externalResolution diffa s1 c wantGuiPause p1_prim p2_prim pmerged = do- -- TODO: remove the following two once we can rely on GHC 7.2 / superclass equality- let p1 :: FL p wX wY = mapFL_FL fromPrim p1_prim-     p2 :: FL p wX wZ = mapFL_FL fromPrim p2_prim+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 = effectOnFilePaths (invert pmerged) nms-     n1s = effectOnFilePaths p1 nas-     n2s = effectOnFilePaths p2 nas-     ns = zip4 nas n1s n2s nms-     write_files tree fs = writePlainTree (Tree.filter (filterFilePaths fs) tree) "."+     nas = effectOnPaths (invert (effect pmerged)) nms+     n1s = effectOnPaths p1 nas+     n2s = effectOnPaths p2 nas+     ns = zip4 (tofp nas) (tofp n1s) (tofp n2s) (tofp nms)+     tofp = map (anchorPath "")+     write_files tree fs = writePlainTree (Tree.filter (filterPaths fs) tree) "."   in do    former_dir <- getCurrentDirectory    withTempDir "version1" $ \absd1 -> do@@ -149,18 +226,10 @@                                  exec command args (Null,Null,Null)           rr [] = return ExitSuccess -patchsetConflictResolutions :: RepoPatch p => PatchSet rt p Origin wX -> Sealed (FL (PrimOf p) wX)-patchsetConflictResolutions (PatchSet _ NilRL) = Sealed NilFL-patchsetConflictResolutions (PatchSet _ xs)-    = --traceDoc (greenText "looking at resolutions" $$-      --         (sh $ resolveConflicts $ joinPatches $-      --              mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $-      standardResolution $ concatFL $-      mapFL_FL (activecontents . hopefully) $ reverseRL xs-    --where sh :: [[Sealed (FL Prim)]] -> Doc-    --      sh [] = greenText "no more conflicts"-    --      sh (x:ps) = greenText "one conflict" $$ sh1 x $$ sh ps-    --      sh1 :: [Sealed (FL Prim)] -> Doc-    --      sh1 [] = greenText "end of unravellings"-    --      sh1 (Sealed x:ps) = greenText "one unravelling:" $$ showPatch x $$-    --                          sh1 ps+patchsetConflictResolutions :: RepoPatch p+                            => PatchSet rt p Origin wX+                            -> StandardResolution (PrimOf p) wX+patchsetConflictResolutions (PatchSet ts xs) =+  -- optimization: all patches before the latest known clean tag+  -- are known to be resolved+  standardResolution (patchSet2RL (PatchSet ts NilRL)) xs
src/Darcs/Repository/State.hs view
@@ -24,9 +24,8 @@  module Darcs.Repository.State     ( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir-    , maybeRestrictSubpaths     -- * Diffs-    , unrecordedChanges, readPending+    , unrecordedChanges     -- * Trees     , readRecorded, readUnrecorded, readRecordedAndPending, readWorking     , readPendingAndWorking, readUnrecordedFiltered@@ -38,13 +37,12 @@     , addPendingDiffToPending, addToPending     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when, foldM, forM ) import Control.Monad.State ( StateT, runStateT, get, put, liftIO ) import Control.Exception ( catch, IOException )-import Data.Maybe ( fromJust, isJust )+import Data.Maybe ( isJust ) import Data.Ord ( comparing ) import Data.List ( sortBy, union, delete ) import Text.Regex( matchRegex )@@ -56,99 +54,115 @@     , (<.>) #endif     )+import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( catchIOError )+ import qualified Data.ByteString as B-    ( ByteString, readFile, drop, writeFile, empty, concat )+    ( ByteString, readFile, writeFile, empty, concat ) import qualified Data.ByteString.Char8 as BC-    ( pack, unpack, split )+    ( pack, unpack ) import qualified Data.ByteString.Lazy as BL ( toChunks ) -import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrims+import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL                    , PrimPatch, maybeApplyToTree                    , tokreplace, forceTokReplace, move )-import Darcs.Patch.Named.Wrapped ( anonymous )-import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths )-import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (+>+)+import Darcs.Patch.Named ( anonymous )+import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnPaths )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+)                                      , (:>)(..), reverseRL, reverseFL                                      , mapFL, concatFL, toFL, nullFL ) import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal                                     , freeGap, emptyGap, joinGap, FreeLeft, Gap(..) )-import Darcs.Patch.Commute ( selfCommuter, commuteFL )-import Darcs.Patch.CommuteFn ( commuterIdRL )+import Darcs.Patch.Commute ( commuteFL ) import Darcs.Patch.Permutations ( partitionConflictingFL, genCommuteWhatWeCanRL ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.TokenReplace ( breakToTokens, defaultToks )  import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..)-                              , UpdateWorking(..), LookForMoves(..), LookForReplaces(..) )-import Darcs.Util.Global ( darcsdir )+                              , UpdatePending(..), LookForMoves(..), LookForReplaces(..) ) -import Darcs.Repository.InternalTypes ( Repository, repoFormat )+import Darcs.Repository.InternalTypes ( Repository, repoFormat, repoLocation ) import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir)) import qualified Darcs.Repository.Pending as Pending import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps ) import Darcs.Repository.Diff ( treeDiff )+import Darcs.Repository.Inventory ( peekPristineHash, getValidHash )+import Darcs.Repository.Paths+    ( pristineDirPath+    , hashedInventoryPath+    , oldPristineDirPath+    , oldCurrentDirPath+    , patchesDirPath+    , indexPath+    , indexInvalidPath+    )  import Darcs.Util.Path-    ( AnchoredPath(..), anchorPath, floatPath, fn2fp-    , SubPath, sp2fn, filterPaths, FileName-    , parents, replacePrefixPath, anchoredRoot-    , toFilePath, simpleSubPath, normPath, floatSubPath, makeName+    ( AnchoredPath+    , anchorPath+    , filterPaths+    , inDarcsdir+    , 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 Darcs.Util.Tree.Plain( readPlainTree )-import Darcs.Util.Tree.Hashed( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )+import qualified Darcs.Util.Tree.Plain as PlainTree ( readPlainTree )+import Darcs.Util.Tree.Hashed+    ( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize ) import qualified Darcs.Util.Index as I import qualified Darcs.Util.Tree as Tree import Darcs.Util.Index ( listFileIDs, getFileID ) +#define TEST_INDEX 0++#if TEST_INDEX+import Control.Monad ( unless )+import Darcs.Util.Path ( displayPath )+import Darcs.Util.Tree ( list )+#endif+ newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m } --- | From a repository and a list of SubPath's, construct a filter that can be+-- | From a repository and a list of AnchoredPath's, construct a filter that can be -- used on a Tree (recorded or unrecorded state) of this repository. This -- constructed filter will take pending into account, so the subpaths will be -- translated correctly relative to pending move patches. restrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree)-                 => Repository rt p wR wU wT -> [SubPath]+                 => Repository rt p wR wU wT -> [AnchoredPath]                  -> IO (TreeFilter m)-restrictSubpaths repo subpaths = do+restrictSubpaths repo paths = do   Sealed pending <- Pending.readPending repo-  restrictSubpathsAfter pending repo subpaths+  restrictSubpathsAfter pending repo paths  -- | Like 'restrictSubpaths' but with the pending patch passed as a parameter. -- The 'Repository' parameter is not used, we need it only to avoid -- abiguous typing of @p@. restrictSubpathsAfter :: (RepoPatch p, ApplyState p ~ Tree)-                      => FL (PrimOf p) wT wP+                      => FL (PrimOf p) wR wP                       -> Repository rt p wR wU wT-                      -> [SubPath]+                      -> [AnchoredPath]                       -> IO (TreeFilter m)-restrictSubpathsAfter pending _repo subpaths = do-  let paths = map (fn2fp . sp2fn) subpaths-      paths' = paths `union` effectOnFilePaths pending paths-      anchored = map floatPath paths'+restrictSubpathsAfter pending _repo paths = do+  let paths' = paths `union` effectOnPaths pending paths       restrictPaths :: FilterTree tree m => tree m -> tree m-      restrictPaths = Tree.filter (filterPaths anchored)+      restrictPaths = Tree.filter (filterPaths paths')   return (TreeFilter restrictPaths) +-- note we assume pending starts at the recorded state maybeRestrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree)-                      => FL (PrimOf p) wT wP+                      => FL (PrimOf p) wR wP                       -> Repository rt p wR wU wT-                      -> Maybe [SubPath]+                      -> Maybe [AnchoredPath]                       -> IO (TreeFilter m) maybeRestrictSubpaths pending repo =   maybe (return $ TreeFilter id) (restrictSubpathsAfter pending repo) --- |Is the given path in (or equal to) the _darcs metadata directory?-inDarcsDir :: AnchoredPath -> Bool-inDarcsDir (AnchoredPath (x:_)) | x == makeName darcsdir = True-inDarcsDir _ = False- -- | Construct a 'TreeFilter' that removes any boring files that are not also -- contained in the argument 'Tree'. --@@ -158,7 +172,7 @@ restrictBoring :: Tree m -> IO (TreeFilter m) restrictBoring guide = do   boring <- boringRegexps-  let boring' p | inDarcsDir p = False+  let boring' p | inDarcsdir p = False       boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring           where p' = anchorPath "" p       restrictTree :: FilterTree t m => t m -> t m@@ -170,13 +184,13 @@ -- | Construct a Tree filter that removes any darcs metadata files the -- Tree might have contained. restrictDarcsdir :: TreeFilter m-restrictDarcsdir = TreeFilter $ Tree.filter $ \p _ -> not (inDarcsDir p)+restrictDarcsdir = TreeFilter $ Tree.filter $ \p _ -> not (inDarcsdir p)  {- | For a repository and an optional list of paths (when 'Nothing', take everything) compute a (forward) list of prims (i.e. a patch) going from the recorded state of the repository (pristine) to the unrecorded state of the-repository (the working copy + pending). When a list of paths is given, at+repository (the working tree + pending). When a list of paths is given, at least the files that live under any of these paths in either recorded or unrecorded will be included in the resulting patch. NB. More patches may be included in this list, eg. the full contents of the pending patch. This is@@ -211,8 +225,8 @@                   => (UseIndex, ScanKnown, DiffAlgorithm)                   -> LookForMoves                   -> LookForReplaces-                  -> Repository rt p wR wU wT-                  -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU)+                  -> Repository rt p wR 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)@@ -220,18 +234,18 @@ -- 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 :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+readPendingAndWorking :: (RepoPatch p, ApplyState p ~ Tree)                       => (UseIndex, ScanKnown, DiffAlgorithm)                       -> LookForMoves                       -> LookForReplaces-                      -> Repository rt p wR wU wT-                      -> Maybe [SubPath]-                      -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)+                      -> Repository rt p wR wU wR+                      -> Maybe [AnchoredPath]+                      -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wR wU) readPendingAndWorking _ _ _ r _ | formatHas NoWorkingDir (repoFormat r) = do   IsEq <- return $ workDirLessRepoWitness r   return (NilFL :> NilFL) readPendingAndWorking (useidx, scan, diffalg) lfm lfr repo mbpaths = do-  (pending_tree, working_tree, pending) <-+  (pending_tree, working_tree, (pending :> moves)) <-     readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths   (pending_tree_with_replaces, Sealed replaces) <-     getReplaces lfr diffalg repo pending_tree working_tree@@ -239,18 +253,18 @@   wrapped_diff <- treeDiff diffalg ft pending_tree_with_replaces working_tree   case unFreeLeft wrapped_diff of     Sealed diff -> do-      return (pending +>+ unsafeCoercePEnd replaces :> unsafeCoercePEnd diff)+      return $ unsafeCoercePEnd $ pending :> (moves +>+ replaces +>+ diff)  readPendingAndMovesAndUnrecorded   :: (RepoPatch p, ApplyState p ~ Tree)-  => Repository rt p wR wU wT+  => Repository rt p wR wU wR   -> UseIndex   -> ScanKnown   -> LookForMoves-  -> Maybe [SubPath]+  -> Maybe [AnchoredPath]   -> IO ( Tree IO             -- pristine with (pending + moves)         , Tree IO             -- working-        , FL (PrimOf p) wT wU -- pending + moves+        , (FL (PrimOf p) :> FL (PrimOf p)) wR wU -- pending :> moves         ) readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths = do   (pending_tree, Sealed pending) <- readPending repo@@ -261,44 +275,47 @@     applyTreeFilter relevant <$> applyToTree moves pending_tree   let useidx' = if nullFL moves then useidx else IgnoreIndex   index <--    applyToTree moves =<< I.updateIndex =<<-    applyTreeFilter relevant <$> readIndex repo-  working_tree <- filteredWorking useidx' scan relevant index pending_tree'-  return (pending_tree', working_tree, unsafeCoercePEnd pending')+    applyToTree moves =<< readIndexOrPlainTree repo useidx relevant pending_tree+  working_tree <- filteredWorking repo useidx' scan relevant index pending_tree'+  return (pending_tree', working_tree, unsafeCoercePEnd (pending :> moves))  -- | @filteredWorking useidx scan relevant 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 == 'ScanKnown'@ to act as+-- used (only) if @useidx == 'IgnoreIndex'@ and @scan /= 'ScanBoring'@ to act as -- a guide for filtering the working tree.--- Note that even if @useidx '==' 'IgnoreIndex'@, the index is still used--- to avoid filtering boring files that darcs knows about (see 'restrictBoring').-filteredWorking :: UseIndex+filteredWorking :: Repository rt p wR wU wR+                -> UseIndex                 -> ScanKnown                 -> TreeFilter IO                 -> Tree IO                 -> Tree IO                 -> IO (Tree IO)-filteredWorking useidx scan relevant index pending_tree = do-  applyTreeFilter restrictDarcsdir <$> case scan of-    ScanKnown -> case useidx of-      UseIndex -> return index-      IgnoreIndex -> do-        guide <- expand pending_tree-        applyTreeFilter relevant . restrict guide <$> readPlainTree "."-    ScanAll -> do-      nonboring <- restrictBoring index-      plain <- applyTreeFilter relevant . applyTreeFilter nonboring <$> readPlainTree "."-      return $ case useidx of-        UseIndex -> plain `overlay` index-        IgnoreIndex -> plain-    ScanBoring -> do-      plain <- applyTreeFilter relevant <$> readPlainTree "."-      return $ case useidx of-        UseIndex -> plain `overlay` index-        IgnoreIndex -> plain+filteredWorking repo useidx scan relevant index pending_tree =+  applyTreeFilter restrictDarcsdir <$> applyTreeFilter relevant <$> do+    case useidx of+      UseIndex ->+        case scan of+          ScanKnown -> return index+          ScanAll -> do+            nonboring <- restrictBoring index+            plain <- applyTreeFilter nonboring <$> readPlainTree repo+            return $ plain `overlay` index+          ScanBoring -> do+            plain <- readPlainTree repo+            return $ plain `overlay` index+      IgnoreIndex ->+        case scan of+          ScanKnown -> do+            guide <- expand pending_tree+            restrict guide <$> readPlainTree repo+          ScanAll -> do+            guide <- expand pending_tree+            nonboring <- restrictBoring guide+            applyTreeFilter nonboring <$> readPlainTree repo+          ScanBoring -> readPlainTree repo --- | Witnesses the fact that in the absence of a working directory, we+-- | 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 workDirLessRepoWitness r@@ -310,24 +327,20 @@ -- applying all the repository's patches to an empty directory. readRecorded :: Repository rt p wR wU wT -> IO (Tree IO) readRecorded _repo = do-  let h_inventory = darcsdir </> "hashed_inventory"-  hashed <- doesFileExist h_inventory+  hashed <- doesFileExist hashedInventoryPath   if hashed-     then do inv <- B.readFile h_inventory-             let linesInv = BC.split '\n' inv-             case linesInv of-               [] -> return emptyTree-               (pris_line:_) -> do-                          let hash = decodeDarcsHash $ B.drop 9 pris_line-                              size = decodeDarcsSize $ B.drop 9 pris_line-                          when (hash == NoHash) $-                              fail $ "Bad pristine root: " ++ show pris_line-                          readDarcsHashed (darcsdir </> "pristine.hashed") (size, hash)-     else do have_pristine <- doesDirectoryExist $ darcsdir </> "pristine"-             have_current <- doesDirectoryExist $ darcsdir </> "current"+     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, _) -> readPlainTree $ darcsdir </> "pristine"-               (False, True) -> readPlainTree $ darcsdir </> "current"+               (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:@@ -338,48 +351,98 @@ -- 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 wT -> Maybe [SubPath] -> IO (Tree IO)-readUnrecorded repo mbpaths = do-  Sealed pending <- Pending.readPending repo+               => Repository rt p wR wU wR+               -> UseIndex+               -> Maybe [AnchoredPath]+               -> IO (Tree IO)+readUnrecorded repo useidx mbpaths = do+#if TEST_INDEX+  t1 <- expand =<< readUnrecordedFiltered repo useidx ScanKnown NoLookForMoves mbpaths+  (pending_tree, Sealed pending) <- readPending repo   relevant <- maybeRestrictSubpaths pending repo mbpaths-  readIndex repo >>= I.updateIndex . applyTreeFilter relevant+  t2 <- readIndexOrPlainTree repo useidx relevant pending_tree+  assertEqualTrees "indirect" t1 "direct" t2+  return t1+#else+  expand =<< readUnrecordedFiltered repo useidx ScanKnown NoLookForMoves mbpaths+#endif +#if TEST_INDEX+assertEqualTrees :: String -> Tree m -> String -> Tree m -> IO ()+assertEqualTrees n1 t1 n2 t2 =+  unless (t1 `eqTree` t2) $+    fail $ "Trees are not equal!\n" ++ showTree n1 t1 ++ showTree n2 t2++eqTree :: Tree m -> Tree m -> Bool+eqTree t1 t2 = map fst (list t1) == map fst (list t2)++showTree :: String -> Tree m -> String+showTree name tree = unlines (name : map (("  "++) . displayPath . fst) (list tree))+#endif++readIndexOrPlainTree :: (ApplyState p ~ Tree, RepoPatch p)+                     => Repository rt p wR wU wR+                     -> UseIndex+                     -> TreeFilter IO+                     -> Tree IO+                     -> IO (Tree IO)+#if TEST_INDEX+readIndexOrPlainTree repo useidx treeFilter pending_tree = do+  indexTree <-+    I.updateIndex =<< applyTreeFilter treeFilter <$> readIndex repo+  plainTree <- do+    guide <- expand pending_tree+    expand =<< applyTreeFilter treeFilter . restrict guide <$> readPlainTree repo+  assertEqualTrees "index tree" indexTree "plain tree" plainTree+  return $+    case useidx of+      UseIndex -> indexTree+      IgnoreIndex -> plainTree+#else+readIndexOrPlainTree repo UseIndex treeFilter pending_tree =+  (I.updateIndex =<< applyTreeFilter treeFilter <$> readIndex repo)+    `catchIOError` \e -> do+      hPutStrLn stderr ("Warning, cannot access the index:\n" ++ show e)+      readIndexOrPlainTree repo IgnoreIndex treeFilter pending_tree+readIndexOrPlainTree repo IgnoreIndex treeFilter pending_tree = do+  guide <- expand pending_tree+  expand =<< applyTreeFilter treeFilter . restrict guide <$> readPlainTree repo+#endif+ -- | A variant of 'readUnrecorded' that takes the UseIndex and ScanKnown -- 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 wT+                       => Repository rt p wR wU wR                        -> UseIndex                        -> ScanKnown                        -> LookForMoves-                       -> Maybe [SubPath] -> IO (Tree IO)+                       -> Maybe [AnchoredPath] -> IO (Tree IO) readUnrecordedFiltered repo useidx scan lfm mbpaths = do   (_, working_tree, _) <-     readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths   return working_tree --- | Obtains a Tree corresponding to the complete working copy of the--- repository (modified and non-modified files).-readWorking :: IO (Tree IO)-readWorking = expand =<< (applyTreeFilter restrictDarcsdir <$> readPlainTree ".")+-- | Obtains the relevant (according to the given filter) part of the working tree.+readWorking :: TreeFilter IO -> IO (Tree IO)+readWorking relevant =+  expand =<<+  (applyTreeFilter relevant . applyTreeFilter restrictDarcsdir <$>+   PlainTree.readPlainTree ".")  -- | Obtains the recorded 'Tree' with the pending patch applied. readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree)-                       => Repository rt p wR wU wT -> IO (Tree IO)+                       => Repository rt p wR wU wR -> IO (Tree IO) readRecordedAndPending 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), but we've set to---   say it starts at the tentative state.------   Question (Eric Kow) Is this a bug? Darcs.Repository.Pending.readPending---   says it is+--   renaming pending and starting afresh if it doesn't). readPending :: (RepoPatch p, ApplyState p ~ Tree)-            => Repository rt p wR wU wT-            -> IO (Tree IO, Sealed (FL (PrimOf p) wT))+            => Repository rt p wR wU wR+            -> IO (Tree IO, Sealed (FL (PrimOf p) wR)) readPending repo = do   pristine <- readRecorded repo   Sealed pending <- Pending.readPending repo@@ -387,55 +450,51 @@     \(err :: IOException) -> do        putStrLn $ "Yikes, pending has conflicts! " ++ show err        putStrLn "Stashing the buggy pending as _darcs/patches/pending_buggy"-       renameFile (darcsdir </> "patches" </> "pending")-                  (darcsdir </> "patches" </> "pending_buggy")+       renameFile (patchesDirPath </> "pending")+                  (patchesDirPath </> "pending_buggy")        return (pristine, seal NilFL) -index_file, index_invalid :: FilePath-index_file = darcsdir </> "index"-index_invalid = darcsdir </> "index_invalid"- -- | Mark the existing index as invalid. This has to be called whenever the -- listing of pristine changes and will cause darcs to update the index next -- time it tries to read it. (NB. This is about files added and removed from -- pristine: changes to file content in either pristine or working are handled -- transparently by the index reading code.) invalidateIndex :: t -> IO ()-invalidateIndex _ = B.writeFile index_invalid B.empty+invalidateIndex _ = B.writeFile indexInvalidPath B.empty  readIndex :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository rt p wR wU wT -> IO I.Index+          => Repository rt p wR wU wR -> IO I.Index readIndex repo = do   (invalid, exists, formatValid) <- checkIndex   if not exists || invalid || not formatValid      then do pris <- readRecordedAndPending repo-             idx <- I.updateIndexFrom index_file darcsTreeHash pris-             when invalid $ removeFile index_invalid+             idx <- I.updateIndexFrom indexPath darcsTreeHash pris+             when invalid $ removeFile indexInvalidPath              return idx-     else I.readIndex index_file darcsTreeHash+     else I.readIndex indexPath darcsTreeHash  updateIndex :: (RepoPatch p, ApplyState p ~ Tree)-            => Repository rt p wR wU wT -> IO ()+            => Repository rt p wR wU wR -> IO () updateIndex repo = do   (invalid, _, _) <- checkIndex   pris <- readRecordedAndPending repo-  _ <- I.updateIndexFrom index_file darcsTreeHash pris-  when invalid $ removeFile index_invalid+  _ <- I.updateIndexFrom indexPath darcsTreeHash pris+  when invalid $ removeFile indexInvalidPath  checkIndex :: IO (Bool, Bool, Bool) checkIndex = do-  invalid <- doesFileExist $ index_invalid-  exists <- doesFileExist index_file+  invalid <- doesFileExist $ indexInvalidPath+  exists <- doesFileExist indexPath   formatValid <- if exists-                     then I.indexFormatValid index_file+                     then I.indexFormatValid indexPath                      else return True   when (exists && not formatValid) $ do -- TODO this conditional logic (rename or delete) is mirrored in -- Darcs.Util.Index.updateIndexFrom and should be refactored #if mingw32_HOST_OS-    renameFile index_file (index_file <.> "old")+    renameFile indexPath (indexPath <.> "old") #else-    removeFile index_file+    removeFile indexPath #endif   return (invalid, exists, formatValid) @@ -443,20 +502,21 @@ -- conflict with the recorded or unrecorded changes in a repo filterOutConflicts   :: (RepoPatch p, ApplyState p ~ Tree)-  => RL (PatchInfoAnd rt p) wX wT -- ^Recorded patches from repository, starting from-                                  --  same context as the patches to filter-  -> Repository rt p wR wU wT     -- ^Repository itself, used for grabbing+  => Repository rt p wR wU wR     -- ^Repository itself, used for grabbing                                   --  unrecorded changes+  -> FL (PatchInfoAnd rt 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))                                   -- ^True iff any patches were removed,                                   --  possibly filtered patches-filterOutConflicts us repository them-     = do let commuter = commuterIdRL selfCommuter-          unrec <- fmap n2pia . anonymous . fromPrims+filterOutConflicts repository 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-          them' :> rest <- return $ partitionConflictingFL commuter them (us :<: unrec)+          them' :> rest <-+            return $ partitionConflictingFL them (us +>+ unrec :>: NilFL)           return (check rest, Sealed them')   where check :: FL p wA wB -> Bool         check NilFL = False@@ -464,21 +524,21 @@  -- | Automatically detect file moves using the index. -- TODO: This function lies about the witnesses.-getMoves :: forall rt p wR wU wT wB prim.+getMoves :: forall rt p wR wU wB prim.             (RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p)          => LookForMoves-         -> Repository rt p wR wU wT-         -> Maybe [SubPath]+         -> Repository rt p wR wU wR+         -> Maybe [AnchoredPath]          -> IO (FL prim wB wB) getMoves NoLookForMoves _ _ = return NilFL getMoves YesLookForMoves repository files =     mkMovesFL <$> getMovedFiles repository files   where     mkMovesFL [] = NilFL-    mkMovesFL ((a,b,_):xs) = move (anchorPath "" a) (anchorPath "" b) :>: mkMovesFL xs+    mkMovesFL ((a,b,_):xs) = move a b :>: mkMovesFL xs -    getMovedFiles :: Repository rt p wR wU wT-                  -> Maybe [SubPath]+    getMovedFiles :: Repository rt p wR wU wR+                  -> Maybe [AnchoredPath]                   -> IO [(AnchoredPath, AnchoredPath, ItemType)]     getMovedFiles repo fs = do         old <- sortBy (comparing snd) <$> (listFileIDs =<< readIndex repo)@@ -489,7 +549,7 @@                                                Just fid -> ((p, it), fid):xs) []         new <- sortBy (comparing snd) <$>                  (addIDs . map (\(a,b) -> (a, itemType b)) . Tree.list  =<<-                   expand =<< applyTreeFilter nonboring <$> readPlainTree ".")+                   expand =<< applyTreeFilter nonboring <$> readPlainTree repository)         let match (x:xs) (y:ys)               | snd x > snd y = match (x:xs) ys               | snd x < snd y = match xs (y:ys)@@ -500,9 +560,9 @@             fmovedfiles =               case fs of                 Nothing -> movedfiles-                Just subpath ->+                Just paths ->                   filter (\(f1, f2, _) -> any (`elem` selfiles) [f1, f2]) movedfiles-                  where selfiles = map (floatPath . toFilePath) subpath+                  where selfiles = paths         return (resolve fmovedfiles)      resolve :: [(AnchoredPath, AnchoredPath, ItemType)]@@ -538,14 +598,15 @@                follow _ [] currentSmallest = currentSmallest          -- rewrite [d/ -> e/, .., d/f -> e/h] to [d/ -> e/, .., e/f -> e/h]+        -- and throw out moves that don't move anything (can they be in there?)         fixPaths [] = []         fixPaths (y@(f1,f2,t):ys)-                        | f1 == f2         = fixPaths ys+                        | f1 == f2         = fixPaths ys -- no effect, throw out                         | TreeType <- t    = y:fixPaths (map replacepp ys)                         | otherwise        = y:fixPaths ys-         where replacepp i@(if1,if2,it) | nfst == anchoredRoot = i-                                        | otherwise = (nfst, if2, it)-                where nfst = replacePrefixPath f1 f2 if1+         -- TODO why adapt only if1 here and not if2?+         --      is this a bug?+         where replacepp (if1,if2,it) = (movedirfilename f1 f2 if1, if2, it)  -- | Search for possible replaces between the recordedAndPending state -- and the unrecorded (or working) state. Return a Sealed FL list of@@ -567,13 +628,11 @@         replaces = rmInvalidReplaces allModifiedTokens     (patches, new_pending) <-       flip runStateT pending $-        forM replaces $ \(f,a,b) ->-          doReplace defaultToks-            (fromJust $ simpleSubPath $ fn2fp $ normPath f)-            (BC.unpack a) (BC.unpack b)+        forM replaces $ \(path, a, b) ->+          doReplace defaultToks path (BC.unpack a) (BC.unpack b)     return (new_pending, mapSeal concatFL $ toFL patches)   where-    modifiedTokens :: PrimOf p wX wY -> [(FileName, B.ByteString, B.ByteString)]+    modifiedTokens :: PrimOf p wX wY -> [(AnchoredPath, B.ByteString, B.ByteString)]     modifiedTokens p = case isHunk p of       Just (FileHunk f _ old new) ->         map (\(a,b) -> (f, a, b)) (concatMap checkModified $@@ -591,22 +650,21 @@           rmInvalidReplaces $ filter (\(f'',a',_) -> f'' /= f || a' /= old) rs     rmInvalidReplaces (r:rs) = r:rmInvalidReplaces (filter (/=r) rs) -    doReplace toks f old new = do+    doReplace toks path old new = do         pend <- get         mpend' <- liftIO $ maybeApplyToTree replacePatch pend         case mpend' of-          Nothing -> getForceReplace f toks old new+          Nothing -> getForceReplace path toks old new           Just pend' -> do             put pend'             return $ joinGap (:>:) (freeGap replacePatch) (emptyGap NilFL)       where-        replacePatch = tokreplace (toFilePath f) toks old new+        replacePatch = tokreplace path toks old new      getForceReplace :: (PrimPatch prim, ApplyState prim ~ Tree)-                    => SubPath -> String -> String -> String+                    => AnchoredPath -> String -> String -> String                     -> StateT (Tree IO) IO (FreeLeft (FL prim))-    getForceReplace f toks old new = do-        let path = floatSubPath f+    getForceReplace path toks old new = do         -- the tree here is the "current" pending state         tree <- get         -- It would be nice if we could fuse the two traversals here, that is,@@ -615,7 +673,7 @@         expandedTree <- liftIO $ expandPath tree path         content <- case findFile expandedTree path of           Just blob -> liftIO $ readBlob blob-          Nothing -> bug $ "getForceReplace: not in tree: " ++ show path+          Nothing -> error $ "getForceReplace: not in tree: " ++ show path         let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old)                             (B.concat $ BL.toChunks content)             tree' = modifyTree expandedTree path . Just . File $ makeBlobBS newcontent@@ -623,11 +681,11 @@         normaliseNewTokPatch <- liftIO $ treeDiff diffalg ftf expandedTree tree'         -- make sure we can apply them to the pending state         patches <- return $ joinGap (+>+) normaliseNewTokPatch $ freeGap $-            tokreplace (toFilePath f) toks old new :>: NilFL+            tokreplace path toks old new :>: NilFL         mtree'' <- case unFreeLeft patches of             Sealed ps -> liftIO $ maybeApplyToTree ps tree         case mtree'' of-            Nothing -> bug "getForceReplace: unable to apply detected force replaces"+            Nothing -> error "getForceReplace: unable to apply detected force replaces"             Just tree'' -> do                 put tree''                 return patches@@ -637,17 +695,15 @@ -- 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 wT -> UpdateWorking-                          -> FreeLeft (FL (PrimOf p)) -> IO ()-addPendingDiffToPending _ NoUpdateWorking  _ = return ()-addPendingDiffToPending repo uw@YesUpdateWorking newP = do-    (toPend :> _) <--        readPendingAndWorking (UseIndex, ScanKnown, MyersDiff)-          NoLookForMoves NoLookForReplaces repo Nothing+                        => Repository rt p wR wU wR+                        -> FreeLeft (FL (PrimOf p)) -> IO ()+addPendingDiffToPending repo newP = do+    (_, Sealed toPend) <- readPending repo     invalidateIndex repo     case unFreeLeft newP of-        (Sealed p) -> do recordedState <- readRecorded repo-                         Pending.makeNewPending repo uw (toPend +>+ p) recordedState+        (Sealed p) -> do+            recordedState <- readRecorded repo+            Pending.makeNewPending repo YesUpdatePending (toPend +>+ p) recordedState  -- | Add an 'FL' of patches starting from the working state to the pending patch, -- including as much extra context as is necessary (context meaning@@ -655,15 +711,17 @@ -- 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 wT -> UpdateWorking-             -> FL (PrimOf p) wU wY -> IO ()-addToPending _ NoUpdateWorking  _ = return ()-addToPending repo uw@YesUpdateWorking p = do-   (toPend :> toUnrec) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff)+             => 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    case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of        (toP' :> p'  :> _excessUnrec) -> do            recordedState <- readRecorded repo-           Pending.makeNewPending repo uw+           Pending.makeNewPending repo YesUpdatePending             (toPend +>+ reverseRL toP' +>+ p') recordedState++readPlainTree :: Repository rt p wR wU wT -> IO (Tree IO)+readPlainTree repo  = PlainTree.readPlainTree (repoLocation repo)
src/Darcs/Repository/Test.hs view
@@ -23,7 +23,6 @@     ) where -import Prelude () import Darcs.Prelude  import System.Exit ( ExitCode(..) )@@ -31,13 +30,6 @@ import System.IO ( hPutStrLn, stderr ) import Control.Monad ( when ) -import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Util.Path ( AbsolutePath )-import Darcs.Util.Prompt ( askUser )-import Darcs.Repository.Prefs ( getPrefval )--import Darcs.Repository.Hashed ( withTentative )-import Darcs.Repository.Working ( setScriptsExecutable ) import Darcs.Repository.Flags     ( LeaveTestDir(..)     , Verbosity(..)@@ -45,13 +37,16 @@     , RunTest (..)     , HookConfig (..)     )-import Darcs.Repository.InternalTypes-    ( Repository, repoLocation )+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.Lock-    ( withTempDir-    , withPermDir-    )+import Darcs.Util.Prompt ( askUser )  getTest :: Verbosity -> IO (IO ExitCode) getTest verb =
+ src/Darcs/Repository/Traverse.hs view
@@ -0,0 +1,207 @@+module Darcs.Repository.Traverse+    ( cleanInventories+    , cleanPatches+    , cleanPristine+    , cleanRepository+    , diffHashLists+    , listInventories+    , listInventoriesLocal+    , listInventoriesRepoDir+    , listPatchesLocalBucketed+    , specialPatches+    ) where++import Darcs.Prelude++import Data.Maybe ( fromJust )+import qualified Data.ByteString.Char8 as BC ( unpack, pack )+import qualified Data.Set as Set++import System.Directory ( listDirectory )+import System.FilePath.Posix( (</>) )++import Darcs.Repository.Cache ( HashedDir(..), bucketFolder )+import Darcs.Repository.HashedIO ( cleanHashdir )+import Darcs.Repository.Inventory+    ( Inventory(..)+    , emptyInventory+    , getValidHash+    , inventoryPatchNames+    , parseInventory+    , peekPristineHash+    , skipPristineHash+    )+import Darcs.Repository.InternalTypes+    ( Repository+    , repoCache+    , withRepoLocation+    )+import Darcs.Repository.Paths+    ( hashedInventory+    , hashedInventoryPath+    , inventoriesDir+    , inventoriesDirPath+    , patchesDirPath+    )+import Darcs.Repository.Prefs ( globalCacheDir )++import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Exception ( ifDoesNotExistError )+import Darcs.Util.Global ( darcsdir, debugMessage )+import Darcs.Util.Lock ( removeFileMayNotExist )+++cleanRepository :: Repository rt p wR wU wT -> IO ()+cleanRepository r = cleanPristine r >> cleanInventories r >> cleanPatches r++-- | The way patchfiles, inventories, and pristine trees are stored.+-- 'PlainLayout' means all files are in the same directory. 'BucketedLayout'+-- means we create a second level of subdirectories, such that all files whose+-- hash starts with the same two letters are in the same directory.+-- Currently, only the global cache uses 'BucketedLayout' while repositories+-- use the 'PlainLayout'.+data DirLayout = PlainLayout | BucketedLayout++-- | Remove unreferenced entries in the pristine cache.+cleanPristine :: Repository rt p wR wU wT -> IO ()+cleanPristine r = withRepoLocation r $ do+    debugMessage "Cleaning out the pristine cache..."+    i <- gzReadFilePS hashedInventoryPath+    cleanHashdir (repoCache r) HashedPristineDir [peekPristineHash i]++-- | Set difference between two lists of hashes.+diffHashLists :: [String] -> [String] -> [String]+diffHashLists xs ys = from_set $ (to_set xs) `Set.difference` (to_set ys)+  where+    to_set = Set.fromList . map BC.pack+    from_set = map BC.unpack . Set.toList++-- | Remove unreferenced files in the inventories directory.+cleanInventories :: Repository rt p wR wU wT -> IO ()+cleanInventories _ = do+    debugMessage "Cleaning out inventories..."+    hs <- listInventoriesLocal+    fs <- ifDoesNotExistError [] $ listDirectory inventoriesDirPath+    mapM_ (removeFileMayNotExist . (inventoriesDirPath </>))+        (diffHashLists fs hs)++-- FIXME this is ugly, these files should be directly under _darcs+-- since they are not hashed. And 'unrevert' isn't even a real patch but+-- a patch bundle.++-- | List of special patch files that may exist in the directory+-- _darcs/patches/. We must not clean those.+specialPatches :: [FilePath]+specialPatches = ["unrevert", "pending", "pending.tentative"]++-- | Remove unreferenced files in the patches directory.+cleanPatches :: Repository rt p wR wU wT -> IO ()+cleanPatches _ = do+    debugMessage "Cleaning out patches..."+    hs <- (specialPatches ++) <$> listPatchesLocal PlainLayout darcsdir darcsdir+    fs <- ifDoesNotExistError [] (listDirectory patchesDirPath)+    mapM_ (removeFileMayNotExist . (patchesDirPath </>)) (diffHashLists fs hs)++-- | Return a list of the inventories hashes.+-- The first argument can be readInventory or readInventoryLocal.+-- The second argument specifies whether the files are expected+-- to be stored in plain or in bucketed format.+-- The third argument is the directory of the parent inventory files.+-- The fourth argument is the directory of the head inventory file.+listInventoriesWith+  :: (FilePath -> IO Inventory)+  -> DirLayout+  -> String -> String -> IO [String]+listInventoriesWith readInv dirformat baseDir startDir = do+    mbStartingWithInv <- getStartingWithHash startDir hashedInventory+    followStartingWiths mbStartingWithInv+  where+    getStartingWithHash dir file = inventoryParent <$> readInv (dir </> file)++    invDir = baseDir </> inventoriesDir+    nextDir dir = case dirformat of+        BucketedLayout -> invDir </> bucketFolder dir+        PlainLayout -> invDir++    followStartingWiths Nothing = return []+    followStartingWiths (Just hash) = do+        let startingWith = getValidHash hash+        mbNextInv <- getStartingWithHash (nextDir startingWith) startingWith+        (startingWith :) <$> followStartingWiths mbNextInv++-- | Return a list of the inventories hashes.+-- This function attempts to retrieve missing inventory files from the cache.+listInventories :: IO [String]+listInventories =+    listInventoriesWith readInventory PlainLayout darcsdir darcsdir++-- | Return inventories hashes by following the head inventory.+-- This function does not attempt to retrieve missing inventory files.+listInventoriesLocal :: IO [String]+listInventoriesLocal =+    listInventoriesWith readInventoryLocal PlainLayout darcsdir darcsdir++-- | Return a list of the inventories hashes.+-- The argument @repoDir@ is the directory of the repository from which+-- we are going to read the head inventory file.+-- The rest of hashed files are read from the global cache.+listInventoriesRepoDir :: String -> IO [String]+listInventoriesRepoDir repoDir = do+    gCacheDir' <- globalCacheDir+    let gCacheInvDir = fromJust gCacheDir'+    listInventoriesWith+        readInventoryLocal+        BucketedLayout+        gCacheInvDir+        (repoDir </> darcsdir)++-- | Return a list of the patch filenames, extracted from inventory+-- files, by starting with the head inventory and then following the+-- chain of parent inventories.+--+-- This function does not attempt to download missing inventory files.+--+-- * The first argument specifies whether the files are expected+--   to be stored in plain or in bucketed format.+-- * The second argument is the directory of the parent inventory.+-- * The third argument is the directory of the head inventory.+listPatchesLocal :: DirLayout -> String -> String -> IO [String]+listPatchesLocal dirformat baseDir startDir = do+  inventory <- readInventory (startDir </> hashedInventory)+  followStartingWiths+    (inventoryParent inventory)+    (inventoryPatchNames inventory)+  where+    invDir = baseDir </> inventoriesDir+    nextDir dir =+      case dirformat of+        BucketedLayout -> invDir </> bucketFolder dir+        PlainLayout -> invDir+    followStartingWiths Nothing patches = return patches+    followStartingWiths (Just hash) patches = do+      let startingWith = getValidHash hash+      inv <- readInventoryLocal (nextDir startingWith </> startingWith)+      (patches ++) <$>+        followStartingWiths (inventoryParent inv) (inventoryPatchNames inv)++-- |listPatchesLocalBucketed is similar to listPatchesLocal, but+-- it read the inventory directory under @darcsDir@ in bucketed format.+listPatchesLocalBucketed :: String -> String -> IO [String]+listPatchesLocalBucketed = listPatchesLocal BucketedLayout++-- | Read the given inventory file if it exist, otherwise return an empty+-- inventory. Used when we expect that some inventory files may be missing.+-- Still fails with an error message if file cannot be parsed.+readInventoryLocal :: FilePath -> IO Inventory+readInventoryLocal path =+  ifDoesNotExistError emptyInventory $ readInventory path++-- | Read an inventory from a file. Fails with an error message if+-- file is not there or cannot be parsed.+readInventory :: FilePath -> IO Inventory+readInventory path = do+  -- FIXME we should check the hash (if this is a hashed file)+  inv <- skipPristineHash <$> gzReadFilePS path+  case parseInventory inv of+    Right r -> return r+    Left e -> fail $ unlines [unwords ["parse error in file", path], e]
src/Darcs/Repository/Working.hs view
@@ -6,12 +6,15 @@  import Control.Monad ( when, unless, filterM ) import System.Directory ( doesFileExist )+import System.IO.Error ( catchIOError )  import qualified Data.ByteString as B ( readFile                                       , isPrefixOf                                       ) import qualified Data.ByteString.Char8 as BC (pack) +import Darcs.Prelude+ import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Workaround ( setExecutable )@@ -19,12 +22,10 @@ import Darcs.Util.Path ( anchorPath ) import qualified Darcs.Util.Tree as Tree -import Darcs.Patch ( RepoPatch, apply, listTouchedFiles )+import Darcs.Patch ( RepoPatch, PrimOf, apply, listTouchedFiles ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Prim ( PrimOf ) import Darcs.Patch.Witnesses.Ordered     ( FL(..) )-import Darcs.Patch.Dummy ( DummyPatch ) import Darcs.Patch.Inspect ( PatchInspect )  import Darcs.Repository.Format ( RepoProperty( NoWorkingDir ), formatHas )@@ -33,12 +34,14 @@     ( Repository     , repoFormat     , repoLocation-    , coerceU )+    , unsafeCoerceU ) import Darcs.Repository.ApplyPatches ( runTolerantly, runSilently )-import Darcs.Repository.State ( readWorking )+import Darcs.Repository.State ( readWorking, TreeFilter(..)  )  applyToWorking :: (ApplyState p ~ Tree, RepoPatch p)-               => Repository rt p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY+               => Repository rt p wR wU wT+               -> Verbosity+               -> FL (PrimOf p) wU wY                -> IO (Repository rt p wR wY wT) applyToWorking repo verb patch =   do@@ -47,29 +50,30 @@         if verb == Quiet           then runSilently $ apply patch           else runTolerantly $ apply patch-    return $ coerceU repo+    return $ unsafeCoerceU repo+  `catchIOError` (\e -> fail $ "Error applying changes to working tree:\n" ++ show e) --- | Sets scripts in or below the current directory executable.+-- | Set the given paths executable if they are scripts. --   A script is any file that starts with the bytes '#!'. --   This is used for --set-scripts-executable.-setScriptsExecutable_ :: PatchInspect p => Maybe (p wX wY) -> IO ()-setScriptsExecutable_ pw = do+setScriptsExecutable_ :: [FilePath] -> IO ()+setScriptsExecutable_ paths = do     debugMessage "Making scripts executable"-    tree <- readWorking-    paths <- case pw of-          Just ps -> filterM doesFileExist $ listTouchedFiles ps-          Nothing -> return [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]-    let setExecutableIfScript f =-              do contents <- B.readFile f-                 when (BC.pack "#!" `B.isPrefixOf` contents) $ do-                   debugMessage ("Making executable: " ++ f)-                   setExecutable f True     mapM_ setExecutableIfScript paths  setScriptsExecutable :: IO ()-setScriptsExecutable = setScriptsExecutable_ (Nothing :: Maybe (FL DummyPatch wX wY))+setScriptsExecutable = do+    tree <- readWorking (TreeFilter id)+    setScriptsExecutable_ [anchorPath "." p | (p, Tree.File _) <- Tree.list tree]  setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO ()-setScriptsExecutablePatches = setScriptsExecutable_ . Just-+setScriptsExecutablePatches pw = do+    paths <- filterM doesFileExist $ map (anchorPath ".") $ listTouchedFiles pw+    setScriptsExecutable_ paths +setExecutableIfScript :: FilePath -> IO ()+setExecutableIfScript f = do+    contents <- B.readFile f+    when (BC.pack "#!" `B.isPrefixOf` contents) $ do+        debugMessage ("Making executable: " ++ f)+        setExecutable f True
+ src/Darcs/Test/TestOnly.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Darcs.Test.TestOnly ( TestOnly ) where++-- |This nullary type class flags code that should only be used for+-- the tests. No instance of it should be defined in either the+-- darcs library or the main darcs executable.+class TestOnly
src/Darcs/UI/ApplyPatches.hs view
@@ -1,36 +1,32 @@ module Darcs.UI.ApplyPatches-    ( PatchApplier(..), PatchProxy(..)+    ( PatchApplier(..)+    , PatchProxy(..)     , StandardPatchApplier(..)+    , applyPatchesStart+    , applyPatchesFinish     ) where -import Prelude () import Darcs.Prelude -import System.Exit ( ExitCode ( ExitSuccess ), exitSuccess )-import System.IO ( hClose, stdout, stderr )-import Control.Exception-                 ( catch, fromException, SomeException, throwIO )-import Control.Monad ( when, unless )-import qualified Data.ByteString.Char8 as BC+import Control.Monad ( when, void )  import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.UI.Commands     ( putVerbose-    , putInfo+    , putFinished     , setEnvDarcsPatches     ) import Darcs.UI.Commands.Util ( printDryRunMessageAndExit )-import Darcs.UI.CommandsAux ( checkPaths ) import Darcs.UI.Flags     ( DarcsFlag, verbosity, compress, reorder, allowConflicts, externalMerge     , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive, testChanges-    , xmlOutput, reply, getCc, getSendmailCmd, dryRun+    , xmlOutput, dryRun     ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Options ( (?) ) import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit )-import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.Repository     ( Repository     , tentativelyMergePatches@@ -42,12 +38,13 @@ import Darcs.Repository.Job ( RepoJob(RepoJob) ) import Darcs.Patch ( RepoPatch, RepoType, IsRepoType, description ) import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Set ( PatchSet, Origin ) import Darcs.Patch.Witnesses.Ordered-    ( FL, mapFL, nullFL )+    ( FL, Fork(..), mapFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) -import Darcs.UI.External ( sendEmail )-import Darcs.Util.Lock ( withStdoutTemp, readBinFile )+import Darcs.Util.English ( presentParticiple ) import Darcs.Util.Printer ( vcat, text ) import Darcs.Util.Tree( Tree ) @@ -62,7 +59,6 @@      repoJob         :: pa-        -> [DarcsFlag]         -> (forall rt p wR wU                . ( IsRepoType rt, ApplierRepoTypeConstraint pa rt                  , RepoPatch p, ApplyState p ~ Tree@@ -71,7 +67,7 @@         -> RepoJob ()      applyPatches-        :: forall rt p wR wU wT wX wZ+        :: forall rt p wR wU wZ          . ( ApplierRepoTypeConstraint pa rt, IsRepoType rt            , RepoPatch p, ApplyState p ~ Tree            )@@ -79,108 +75,80 @@         -> PatchProxy p         -> String         -> [DarcsFlag]-        -> String-        -> Repository rt p wR wU wT-        -> FL (PatchInfoAnd rt p) wX wT-        -> FL (PatchInfoAnd rt p) wX wZ -> IO ()+        -> Repository rt p wR wU wR+        -> Fork (PatchSet rt p)+                (FL (PatchInfoAnd rt p))+                (FL (PatchInfoAnd rt p)) Origin wR wZ+        -> IO ()  data StandardPatchApplier = StandardPatchApplier  instance PatchApplier StandardPatchApplier where     type ApplierRepoTypeConstraint StandardPatchApplier rt = ()-    repoJob StandardPatchApplier _opts f = RepoJob (f PatchProxy)+    repoJob StandardPatchApplier f = RepoJob (f PatchProxy)     applyPatches StandardPatchApplier PatchProxy = standardApplyPatches -standardApplyPatches-           :: forall rt p wR wU wT wX wZ-            . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-           => String -> [DarcsFlag] -> String -> Repository rt p wR wU wT-           -> FL (PatchInfoAnd rt p) wX wT -> FL (PatchInfoAnd rt p) wX wZ -> IO ()-standardApplyPatches cmdName opts from_whom repository us' to_be_applied = do-   printDryRunMessageAndExit cmdName-      (verbosity ? opts)-      (O.summary ? opts)-      (dryRun ? opts)-      (xmlOutput ? opts)-      (isInteractive True opts)-      to_be_applied-   when (nullFL to_be_applied && reorder ? opts == O.NoReorder) $ do -           putStrLn $ "You don't want to " ++ cmdName ++ " any patches, so I'm exiting!"-           exitSuccess-   checkPaths opts to_be_applied-   redirectOutput opts from_whom $ do-    unless (nullFL to_be_applied) $ do-        putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:"-        putVerbose opts . vcat $ mapFL description to_be_applied-        setEnvDarcsPatches to_be_applied-    Sealed pw <- tentativelyMergePatches repository cmdName-                         (allowConflicts opts) YesUpdateWorking+standardApplyPatches :: (IsRepoType rt, 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+                     -> IO ()+standardApplyPatches cmdName opts _repository patches@(Fork _ _ to_be_applied) = do+    applyPatchesStart cmdName opts to_be_applied++    Sealed pw <- tentativelyMergePatches _repository cmdName+                         (allowConflicts opts)                          (externalMerge ? opts) (wantGuiPause opts)                          (compress ? opts) (verbosity ? opts)                          (reorder ? opts) (diffingOpts opts)-                         us' to_be_applied-    invalidateIndex repository-    testTentativeAndMaybeExit repository+                         patches+    invalidateIndex _repository+    testTentativeAndMaybeExit _repository          (verbosity ? opts)          (testChanges ? opts)          (setScriptsExecutable ? opts)          (isInteractive True opts)          "those patches do not pass the tests." (cmdName ++ " them") Nothing-    withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compress ? opts)-                            _ <- applyToWorking repository (verbosity ? opts) pw `catch` \(e :: SomeException) ->-                                fail ("Error applying patch to working dir:\n" ++ show e)-                            when (setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $-                              setScriptsExecutablePatches pw-                            return ()-    case (nullFL to_be_applied, reorder ? opts == O.Reorder) of-                (True,True)  -> putInfo opts $ text $ "Nothing to " ++ cmdName ++ ", finished reordering."-                (False,True) -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing and reordering."-                _            -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing." -redirectOutput :: [DarcsFlag] -> String -> IO () -> IO ()-redirectOutput opts to doit = case reply ? opts of-    Nothing -> doit-    Just from -> withStdoutTemp $ \tempf -> doitAndCleanup `catch` sendit tempf from-  where-    -- TODO: I suggest people writing such code should *at least* put in some comments.-    -- It is unclear how this works and how the intertwined exception handlers make-    -- this do what the author wanted.-    doitAndCleanup = doit >> hClose stdout >> hClose stderr-    sendit :: FilePath -> String -> SomeException -> IO a-    sendit tempf from e | Just ExitSuccess <- fromException e =-      do sendSanitizedEmail opts from to "Patch applied" cc tempf-         throwIO e-    sendit tempf from e | Just (_ :: ExitCode) <- fromException e =-      do sendSanitizedEmail opts from to "Patch failed!" cc tempf-         throwIO ExitSuccess-    sendit tempf from e =-      do sendSanitizedEmail opts from to "Darcs error applying patch!" cc $-                   tempf ++ "\n\nCaught exception:\n"++-                   show e++"\n"-         throwIO ExitSuccess-    cc = getCc opts---- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd--- It takes @DacrsFlag@ options a file with the mail contents,--- To:, Subject:, CC:, and mail body-sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO ()-sendSanitizedEmail opts from to subject cc mailtext =-    do scmd <- getSendmailCmd opts-       body <- sanitizeFile mailtext-       sendEmail from to subject cc scmd body+    applyPatchesFinish cmdName opts _repository pw (nullFL to_be_applied) --- sanitizeFile is used to clean up the stdout/stderr before sticking it in--- an email.+applyPatchesStart :: (RepoPatch p, ApplyState p ~ Tree)+                  => String -> [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> IO ()+applyPatchesStart cmdName opts to_be_applied = do+    printDryRunMessageAndExit cmdName+        (verbosity ? opts)+        (O.withSummary ? opts)+        (dryRun ? opts)+        (xmlOutput ? opts)+        (isInteractive True opts)+        to_be_applied+    if nullFL to_be_applied then+        putStrLn $ "You don't want to " ++ cmdName ++ " any patches, and that's fine with me!"+    else do+        putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:"+        putVerbose opts . vcat $ mapFL description to_be_applied+        setEnvDarcsPatches to_be_applied -sanitizeFile :: FilePath -> IO String-sanitizeFile f = sanitize . BC.unpack <$> readBinFile f-    where sanitize s = wash $ remove_backspaces "" s-          wash ('\000':s) = "\\NUL" ++ wash s-          wash ('\026':s) = "\\EOF" ++ wash s-          wash (c:cs) = c : wash cs-          wash [] = []-          remove_backspaces rev_sofar "" = reverse rev_sofar-          remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s-          remove_backspaces "" ('\008':s) = remove_backspaces "" s-          remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss+applyPatchesFinish :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+                   => String+                   -> [DarcsFlag]+                   -> Repository rt p wR 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)+        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"+        _            -> putFinished opts $ presentParticiple cmdName
src/Darcs/UI/Commands.hs view
@@ -18,10 +18,7 @@ {-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands     ( CommandControl ( CommandData, HiddenCommand, GroupName )-    , DarcsCommand ( .. )-    , WrappedCommand(..)-    , wrappedCommandName-    , wrappedCommandDescription+    , DarcsCommand(..)     , commandAlias     , commandStub     , commandOptions@@ -41,6 +38,7 @@     , putVerbose     , putWarning     , putVerboseWarning+    , putFinished     , abortRun     , setEnvDarcsPatches     , setEnvDarcsFiles@@ -51,21 +49,17 @@     , findRepository     ) where -import Prelude ()-import Darcs.Prelude--import Prelude hiding ( (^) ) import Control.Monad ( when, unless ) import Data.List ( sort, isPrefixOf )-import Darcs.Util.Tree ( Tree ) import System.Console.GetOpt ( OptDescr ) import System.IO ( stderr ) import System.IO.Error ( catchIOError ) import System.Environment ( setEnv )++import Darcs.Prelude+ import Darcs.Patch ( listTouchedFiles )-import qualified Darcs.Patch ( summary ) import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Info ( toXml ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )@@ -73,76 +67,67 @@  import qualified Darcs.Repository as R ( amInHashedRepository, amInRepository                                        , amNotInRepository, findRepository )+import Darcs.Repository.Flags ( WorkRepo(..) ) import Darcs.Repository.Prefs ( defaultrepo )  import Darcs.UI.Options ( DarcsOption, DarcsOptDescr, (^), optDescr, odesc, parseFlags, (?) ) import Darcs.UI.Options.All-    ( StdCmdAction, stdCmdActions, anyVerbosity, UseCache, useCache, HooksConfig, hooks-    , Verbosity(..), DryRun(..), dryRun+    ( StdCmdAction, stdCmdActions, debugging, UseCache, useCache, HooksConfig, hooks+    , Verbosity(..), DryRun(..), dryRun, newRepo, verbosity     )  import Darcs.UI.Flags ( DarcsFlag, remoteRepos, workRepo, quiet, verbose )+import Darcs.UI.External ( viewDoc )+import Darcs.UI.PrintPatch ( showWithSummary )  import Darcs.Util.ByteString ( decodeLocale, packStringToUTF8 )-import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Path ( AbsolutePath, anchorPath ) import Darcs.Util.Printer-    ( Doc, text, (<+>), ($$), vcat-    , putDocLnWith, hPutDocLn, errorDoc, renderString+    ( Doc, text, (<+>), ($$), ($+$), hsep, vcat+    , putDocLnWith, hPutDocLn, renderString     )-import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Util.Printer.Color ( fancyPrinters, ePutDocLn ) import Darcs.Util.Progress     ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) -extractCommands :: [CommandControl] -> [WrappedCommand]+extractCommands :: [CommandControl] -> [DarcsCommand] extractCommands ccl = [ cmd | CommandData cmd <- ccl ] -extractHiddenCommands :: [CommandControl] -> [WrappedCommand]+extractHiddenCommands :: [CommandControl] -> [DarcsCommand] extractHiddenCommands ccl = [ cmd | HiddenCommand cmd <- ccl ] -extractAllCommands :: [CommandControl] -> [WrappedCommand]+extractAllCommands :: [CommandControl] -> [DarcsCommand] extractAllCommands ccl = concatMap flatten (extractCommands ccl ++ extractHiddenCommands ccl)-    where flatten c@(WrappedCommand (DarcsCommand {})) = [c]-          flatten c@(WrappedCommand (SuperCommand { commandSubCommands = scs })) = c : extractAllCommands scs---- |A 'WrappedCommand' is a 'DarcsCommand' where the options type has been hidden-data WrappedCommand where-    WrappedCommand :: DarcsCommand parsedFlags -> WrappedCommand+    where flatten c@(DarcsCommand {}) = [c]+          flatten c@(SuperCommand { commandSubCommands = scs }) = c : extractAllCommands scs -normalCommand :: DarcsCommand parsedFlags -> CommandControl-normalCommand c = CommandData (WrappedCommand c)+normalCommand :: DarcsCommand -> CommandControl+normalCommand c = CommandData c -hiddenCommand :: DarcsCommand parsedFlags -> CommandControl-hiddenCommand c = HiddenCommand (WrappedCommand c)+hiddenCommand :: DarcsCommand -> CommandControl+hiddenCommand c = HiddenCommand c  commandGroup :: String -> CommandControl commandGroup = GroupName -wrappedCommandName :: WrappedCommand -> String-wrappedCommandName (WrappedCommand c) = commandName c--wrappedCommandDescription :: WrappedCommand -> String-wrappedCommandDescription (WrappedCommand c) = commandDescription c- data CommandControl-  = CommandData WrappedCommand-  | HiddenCommand WrappedCommand+  = CommandData DarcsCommand+  | HiddenCommand DarcsCommand   | GroupName String  -- |A 'DarcsCommand' represents a command like add, record etc.--- The 'parsedFlags' type represents the options that are--- passed to the command's implementation-data DarcsCommand parsedFlags =+data DarcsCommand =       DarcsCommand           { commandProgramName -- programs that use libdarcs can change the name here-          , commandName-          , commandHelp+          , commandName :: String+          , commandHelp :: Doc           , commandDescription :: String           , commandExtraArgs :: Int           , commandExtraArgHelp :: [String]           , commandCommand :: -- First 'AbsolutePath' is the repository path,                               -- second one is the path where darcs was executed.                               (AbsolutePath, AbsolutePath)-                           -> parsedFlags -> [String] -> IO ()+                           -> [DarcsFlag] -> [String] -> IO ()           , commandPrereq :: [DarcsFlag] -> IO (Either String ())           , commandCompleteArgs :: (AbsolutePath, AbsolutePath)                                 -> [DarcsFlag] -> [String] -> IO [String]@@ -152,96 +137,101 @@           , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]           , commandDefaults :: [DarcsFlag]           , commandCheckOptions :: [DarcsFlag] -> [String]-          , commandParseOptions :: [DarcsFlag] -> parsedFlags           }     | SuperCommand           { commandProgramName-          , commandName-          , commandHelp+          , commandName :: String+          , commandHelp :: Doc           , commandDescription :: String           , commandPrereq :: [DarcsFlag] -> IO (Either String ())           , commandSubCommands :: [CommandControl]           } -withStdOpts :: DarcsOption (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c-            -> DarcsOption (UseCache -> HooksConfig -> a) b+withStdOpts :: DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c+            -> DarcsOption (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b             -> DarcsOption a c withStdOpts basicOpts advancedOpts =-  basicOpts ^ stdCmdActions ^ anyVerbosity ^ advancedOpts ^ useCache ^ hooks+  basicOpts ^ stdCmdActions ^ verbosity ^ advancedOpts ^ useCache ^ hooks ^ debugging -commandAlloptions :: DarcsCommand pf -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])+commandAlloptions :: DarcsCommand -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag]) commandAlloptions DarcsCommand { commandBasicOptions = opts1                                , commandAdvancedOptions = opts2 } =     ( opts1 ++ odesc stdCmdActions-    , odesc anyVerbosity ++ opts2 ++ odesc useCache ++ odesc hooks )+    , odesc verbosity ++ opts2 ++ odesc useCache ++ odesc hooks ++ odesc debugging+    ) commandAlloptions SuperCommand { } = (odesc stdCmdActions, [])  --  Obtain options suitable as input to System.Console.Getopt, including the --  --disable option (which is not listed explicitly in the DarcsCommand --  definitions).-commandOptions :: AbsolutePath -> DarcsCommand pf -> [OptDescr DarcsFlag]+commandOptions :: AbsolutePath -> DarcsCommand -> [OptDescr DarcsFlag] commandOptions cwd = map (optDescr cwd) . uncurry (++) . commandAlloptions  nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] nodefaults _ _ = return -getSubcommands :: DarcsCommand pf -> [CommandControl]+getSubcommands :: DarcsCommand -> [CommandControl] getSubcommands c@(SuperCommand {}) = commandGroup "Subcommands:" : commandSubCommands c getSubcommands _ = [] -commandAlias :: String -> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf-commandAlias n msuper c =-    c { commandName = n-      , commandDescription = "Alias for `" ++ commandProgramName c ++ " "-                             ++ cmdName ++ "'."-      , commandHelp = "The `" ++ commandProgramName c ++ " " ++ n-                      ++ "' command is an alias for " ++ "`"-                      ++ commandProgramName c ++ " " ++ cmdName ++ "'.\n"-                      ++ commandHelp c-      }+commandAlias :: String -> Maybe (DarcsCommand) -> DarcsCommand -> DarcsCommand+commandAlias alias msuper command =+  command+    { commandName = alias+    , commandDescription = "Alias for `" ++ prog ++ " " ++ cmdName ++ "'."+    , commandHelp =+        hsep+          [ "The"+          , "`" <> text prog <+> text alias <> "`"+          , "command is an alias for"+          , "`" <> text prog <+> text cmdName <> "`"+          ]+        $+$ "See description of `" <> text prog <+> text cmdName <> "` for details."+    }   where-    cmdName = unwords . map commandName . maybe id (:) msuper $ [ c ]+    prog = commandProgramName command+    cmdName = unwords . map commandName . maybe id (:) msuper $ [command] -commandStub :: String -> String -> String -> DarcsCommand pf -> DarcsCommand pf+commandStub :: String -> Doc -> String -> DarcsCommand -> DarcsCommand commandStub n h d c = c { commandName = n                         , commandHelp = h                         , commandDescription = d-                        , commandCommand = \_ _ _ -> putStr h+                        , commandCommand = \_ _ _ -> viewDoc h                         } -superName :: Maybe (DarcsCommand pf) -> String+superName :: Maybe (DarcsCommand) -> String superName Nothing  = "" superName (Just x) = commandName x ++ " " -data CommandArgs where-    CommandOnly :: DarcsCommand parsedFlags -> CommandArgs-    SuperCommandOnly :: DarcsCommand parsedFlags -> CommandArgs-    SuperCommandSub :: DarcsCommand parsedFlags1 ->  DarcsCommand parsedFlags2 -> CommandArgs+data CommandArgs+  = CommandOnly DarcsCommand+  | SuperCommandOnly DarcsCommand+  | SuperCommandSub DarcsCommand DarcsCommand  -- Parses a darcs command line with potentially abbreviated commands disambiguateCommands :: [CommandControl] -> String -> [String]                      -> Either String (CommandArgs, [String]) disambiguateCommands allcs cmd args = do-    WrappedCommand c <- extract cmd allcs+    c <- extract cmd allcs     case (getSubcommands c, args) of         ([], _) -> return (CommandOnly c, args)         (_, []) -> return (SuperCommandOnly c, args)         (subcs, a : as) -> case extract a subcs of                                Left _ -> return (SuperCommandOnly c, args)-                               Right (WrappedCommand sc) -> return (SuperCommandSub c sc, as)+                               Right sc -> return (SuperCommandSub c sc, as) -extract :: String -> [CommandControl] -> Either String WrappedCommand+extract :: String -> [CommandControl] -> Either String DarcsCommand extract cmd cs = case potentials of     []  -> Left $ "No such command '" ++ cmd ++ "'\n"     [c] -> Right c     cs' -> Left $ unlines [ "Ambiguous command..."                           , ""                           , "The command '" ++ cmd ++ "' could mean one of:"-                          , unwords . sort . map wrappedCommandName $ cs'+                          , unwords . sort . map commandName $ cs'                           ]   where-    potentials = [c | c <- extractCommands cs, cmd `isPrefixOf` wrappedCommandName c]-                 ++ [h | h <- extractHiddenCommands cs, cmd == wrappedCommandName h]+    potentials = [c | c <- extractCommands cs, cmd `isPrefixOf` commandName c]+                 ++ [h | h <- extractHiddenCommands cs, cmd == commandName h]  putVerbose :: [DarcsFlag] -> Doc -> IO () putVerbose flags = when (verbose flags) . putDocLnWith fancyPrinters@@ -249,8 +239,12 @@ putInfo :: [DarcsFlag] -> Doc -> IO () putInfo flags = unless (quiet flags) . putDocLnWith fancyPrinters +putFinished :: [DarcsFlag] -> String -> IO ()+putFinished flags what =+    putInfo flags $ "Finished" <+> text what <> "."+ putWarning :: [DarcsFlag] -> Doc -> IO ()-putWarning flags = unless (quiet flags) . hPutDocLn stderr+putWarning flags = unless (quiet flags) . ePutDocLn  putVerboseWarning :: [DarcsFlag] -> Doc -> IO () putVerboseWarning flags = when (verbose flags) . hPutDocLn stderr@@ -258,33 +252,34 @@ abortRun :: [DarcsFlag] -> Doc -> IO () abortRun flags msg = if parseFlags dryRun flags == YesDryRun                         then putInfo flags $ "NOTE:" <+> msg-                        else errorDoc msg+                        else fail $ renderString msg  -- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables with -- info about the given patches, for use in post-hooks.-setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree)-                   => FL (PatchInfoAnd rt p) wX wY -> IO ()+setEnvDarcsPatches :: RepoPatch p => FL (PatchInfoAnd rt p) wX wY -> IO () setEnvDarcsPatches ps = do     let k = "Defining set of chosen patches"-    debugMessage $ unlines ("setEnvDarcsPatches:" : listTouchedFiles ps)+    let filepaths = map (anchorPath ".") (listTouchedFiles ps)+    debugMessage $ unlines ("setEnvDarcsPatches:" : filepaths)     beginTedious k     tediousSize k 3     finishedOneIO k "DARCS_PATCHES"-    setEnvCautiously "DARCS_PATCHES" (renderString $ Darcs.Patch.summary ps)+    setEnvCautiously "DARCS_PATCHES" (renderString $ showWithSummary ps)     finishedOneIO k "DARCS_PATCHES_XML"     setEnvCautiously "DARCS_PATCHES_XML" . renderString $         text "<patches>" $$         vcat (mapFL (toXml . info) ps) $$         text "</patches>"     finishedOneIO k "DARCS_FILES"-    setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps)+    setEnvCautiously "DARCS_FILES" $ unlines filepaths     endTedious k  -- | Set the DARCS_FILES environment variable to the files touched by the -- given patch, one per line, for use in post-hooks. setEnvDarcsFiles :: (PatchInspect p) => p wX wY -> IO ()-setEnvDarcsFiles ps =-    setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps)+setEnvDarcsFiles ps = do+    let filepaths = map (anchorPath ".") (listTouchedFiles ps)+    setEnvCautiously "DARCS_FILES" $ unlines filepaths  -- | Set some environment variable to the given value, unless said value is -- longer than 10K characters, in which case do nothing.@@ -304,13 +299,14 @@ defaultRepo fs = defaultrepo (remoteRepos ? fs)  amInHashedRepository :: [DarcsFlag] -> IO (Either String ())-amInHashedRepository fs = R.amInHashedRepository (workRepo ? fs)+amInHashedRepository fs = R.amInHashedRepository (workRepo fs)  amInRepository :: [DarcsFlag] -> IO (Either String ())-amInRepository fs = R.amInRepository (workRepo ? fs)+amInRepository fs = R.amInRepository (workRepo fs)  amNotInRepository :: [DarcsFlag] -> IO (Either String ())-amNotInRepository fs = R.amNotInRepository (workRepo ? fs)+amNotInRepository fs =+  R.amNotInRepository (maybe WorkRepoCurrentDir WorkRepoDir (newRepo ? fs))  findRepository :: [DarcsFlag] -> IO (Either String ())-findRepository fs = R.findRepository (workRepo ? fs)+findRepository fs = R.findRepository (workRepo fs)
src/Darcs/UI/Commands/Add.hs view
@@ -25,21 +25,25 @@  module Darcs.UI.Commands.Add ( add ) where -import Prelude () import Darcs.Prelude  import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless ) import Data.List ( (\\), nub ) import Data.List.Ordered ( nubSort )-import Data.Maybe ( isNothing, maybeToList )-import Darcs.Util.Printer ( text )-import Darcs.Util.Tree ( Tree, findTree, expand )+import Data.Maybe ( fromMaybe, isNothing, maybeToList )+import Darcs.Util.Printer ( Doc, text, vcat )+import Darcs.Util.Tree ( Tree, findTree, expand, explodePaths )+import qualified Darcs.Util.Tree as Tree import Darcs.Util.Path-    ( floatPath, anchorPath, parents-    , SubPath, toFilePath, AbsolutePath+    ( AbsolutePath+    , AnchoredPath+    , displayPath+    , filterPaths+    , parent+    , parents+    , realPath     )-import System.FilePath.Posix ( takeDirectory ) import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink ) import System.Directory ( getPermissions, readable ) @@ -49,25 +53,31 @@     ( DarcsCommand(..), withStdOpts, putInfo, putWarning, putVerboseWarning     , nodefaults, amInHashedRepository) import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase )-import Darcs.UI.Commands.Util ( expandDirs, doesDirectoryReallyExist )+import Darcs.UI.Commands.Util ( doesDirectoryReallyExist ) import Darcs.UI.Completion ( unknownFileArgs ) import Darcs.UI.Flags     ( DarcsFlag     , includeBoring, allowCaseDifferingFilenames, allowWindowsReservedFilenames, useCache, dryRun, umask-    , fixSubPaths, quiet )+    , pathsFromArgs ) import Darcs.UI.Options-    ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )+    ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdateWorking(..) )-import Darcs.Patch ( PrimPatch, applyToTree, addfile, adddir )++import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.Patch ( PrimPatch, applyToTree, addfile, adddir, listTouchedFiles ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Repository.State ( readRecordedAndPending, updateIndex )+import Darcs.Repository.State+    ( TreeFilter(..)+    , readRecordedAndPending+    , readWorking+    , updateIndex+    ) import Darcs.Repository     ( withRepoLock     , RepoJob(..)     , addToPending     )-import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )+import Darcs.Repository.Prefs ( isBoring ) import Darcs.Util.File ( getFileStatus ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )@@ -76,8 +86,8 @@ addDescription = "Add new files to version control."  -addHelp :: String-addHelp =+addHelp :: Doc+addHelp = text $     "Generally the working tree contains both files that should be version\n" ++     "controlled (such as source code) and files that Darcs should ignore\n" ++     "(such as executables compiled from the source code).  The `darcs add`\n" ++@@ -90,8 +100,8 @@     "Adding symbolic links (symlinks) is not supported.\n\n"  -addHelp' :: String-addHelp' =+addHelp' :: Doc+addHelp' = text $     "Darcs will ignore all files and folders that look \"boring\".  The\n" ++     "`--boring` option overrides this behaviour.\n" ++     "\n" ++@@ -102,11 +112,11 @@     "`ReadMe` and `README`).  If `--case-ok` is used, the repository might be\n" ++     "unusable on those systems!\n\n" -add :: DarcsCommand [DarcsFlag]+add :: DarcsCommand add = DarcsCommand     { commandProgramName          = "darcs"     , commandName                 = "add"-    , commandHelp                 = addHelp ++ addHelp'+    , commandHelp                 = addHelp <> addHelp'     , commandDescription          = addDescription     , commandExtraArgs            = -1     , commandExtraArgHelp         = [ "<FILE or DIRECTORY> ..." ]@@ -118,7 +128,6 @@     , commandBasicOptions         = odesc addBasicOpts     , commandDefaults             = defaultFlags addOpts     , commandCheckOptions         = ocheck addOpts-    , commandParseOptions         = onormalise addOpts     }   where     addBasicOpts@@ -135,53 +144,54 @@        -> [DarcsFlag]        -> [String]        -> IO ()-addCmd paths opts args+addCmd fps opts args   | null args = putStrLn $ "Nothing specified, nothing added." ++       "Maybe you wanted to say `darcs add --recursive .'?"   | otherwise = do-      fs <- fixSubPaths paths args-      case fs of-        [] -> fail "No valid arguments were given"-        _ -> addFiles opts fs-+      paths <- pathsFromArgs fps args+      case paths of+        [] -> fail "No valid repository paths were given"+        _ -> addFiles opts paths -addFiles :: [DarcsFlag]  -- ^ Command options-         -> [SubPath]-         -> IO ()-addFiles opts origfiles =-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $+addFiles :: [DarcsFlag] -> [AnchoredPath] -> IO ()+addFiles opts paths =+  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $   RepoJob $ \repository -> do     -- TODO do not expand here, and use findM/findIO or such later     -- (needs adding to hashed-storage first though)     cur <- expand =<< readRecordedAndPending repository-    let parlist = getParents cur (map toFilePath origfiles)-    flist' <- if parseFlags O.recursive opts-              then expandDirs (includeBoring opts) origfiles-              else return origfiles-    let flist = nubSort (parlist ++ toFilePath `map` flist')-    nboring <- if includeBoring opts-               then return darcsdirFilter-               else boringFileFilter+    let parent_paths = notInTreeParents cur paths+    -- (1) note, readWorking already filters out darcsdir paths+    -- (2) note, filterPaths matches if path is parent /or/ child +    working <- readWorking (TreeFilter (Tree.filter (filterPaths paths)))+    -- we first get the boring paths, too, so we can report dropping them+    let all_paths = nubSort $ parent_paths +++                      (if parseFlags O.recursive opts+                        then explodePaths working+                        else id) paths+        all_orig_paths = map displayPath all_paths+    boring <- isBoring+    let nboring s = if includeBoring opts then id else filter (not . boring . s)     mapM_ (putWarning opts . text . ((msgSkipping msgs ++ " boring file ")++)) $-        flist \\ nboring flist-    Sealed ps <- fmap unFreeLeft $ addp msgs opts cur $ nboring flist-    -- TODO whether we fail or not depends on verbosity BAD BAD BAD-    when (nullFL ps && not (null origfiles) && not (quiet opts)) $+        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 YesUpdateWorking ps+      do addToPending repository (O.useIndex ? opts) ps          updateIndex repository+         putInfo opts $ vcat $ map text $ ["Finished adding:"] +++            map displayPath (listTouchedFiles ps)   where     gotDryRun = dryRun ? opts == O.YesDryRun     msgs | gotDryRun = dryRunMessages          | otherwise = normalMessages - addp :: forall prim . (PrimPatch prim, ApplyState prim ~ Tree)      => AddMessages      -> [DarcsFlag]      -> Tree IO-     -> [FilePath]+     -> [AnchoredPath]      -> IO (FreeLeft (FL prim)) addp msgs opts cur0 files = do     (ps, dups) <-@@ -204,7 +214,7 @@        dupMsg <-          case uniq_dups of          [f] -> do-           isDir <- doesDirectoryReallyExist f+           isDir <- doesDirectoryReallyExist (realPath f)            if isDir              then return $                "The following directory " ++@@ -213,7 +223,7 @@                "The following file " ++                msgIs msgs ++ " already in the repository"          fs   -> do-           areDirs <- mapM doesDirectoryReallyExist fs+           areDirs <- mapM (doesDirectoryReallyExist . realPath) fs            if and areDirs              then return $                "The following directories " ++@@ -228,20 +238,20 @@                     msgAre msgs ++ " already in the repository")        putWarning opts . text $ "WARNING: Some files were not added because they are already in the repository."        putVerboseWarning opts . text $ dupMsg ++ caseMsg-       mapM_ (putVerboseWarning opts . text) uniq_dups+       mapM_ (putVerboseWarning opts . text . displayPath) uniq_dups     return $ foldr (joinGap (+>+)) (emptyGap NilFL) ps   where     addp' :: Tree IO-          -> FilePath-          -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)+          -> AnchoredPath+          -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)     addp' cur f = do       already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f-      mstatus <- getFileStatus f+      mstatus <- getFileStatus (realPath f)       case (already_has, is_badfilename, mstatus) of         (True, _, _) -> return (cur, Nothing, Just f)         (_, True, _) -> do             putWarning opts . text $-              "The filename " ++ f ++ " is invalid under Windows.\n" +++              "The filename " ++ displayPath f ++ " is invalid on Windows.\n" ++               "Use --reserved-ok to allow it."             return add_failure         (_, _, Just s)@@ -249,23 +259,23 @@             | isRegularFile s  -> trypatch $ freeGap (addfile f :>: NilFL)             | isSymbolicLink s -> do                 putWarning opts . text $-                    "Sorry, file " ++ f +++                    "Sorry, file " ++ displayPath f ++                     " is a symbolic link, which is unsupported by darcs."                 return add_failure         _ -> do-            putWarning opts . text $ "File "++ f ++" does not exist!"+            putWarning opts . text $ "File "++ displayPath f ++" does not exist!"             return add_failure         where-          is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)+          is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid (realPath f))           add_failure = (cur, Nothing, Nothing)           trypatch :: FreeLeft (FL prim)-                   -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)+                   -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)           trypatch p = do-              perms <- getPermissions f+              perms <- getPermissions (realPath f)               if not $ readable perms                 then do                     putWarning opts . text $-                        msgSkipping msgs ++ " '" ++ f ++ "': permission denied "+                        msgSkipping msgs ++ " '" ++ displayPath f ++ "': permission denied "                     return (cur, Nothing, Nothing)                 else trypatch' p           trypatch' p = do@@ -275,19 +285,20 @@                 then do                     tree <- applyToTree p' cur                     putInfo opts . text $-                        msgAdding msgs ++ " '" ++ f ++ "'"+                        msgAdding msgs ++ " '" ++ displayPath f ++ "'"                     return (tree, Just p, Nothing)                 else do                     putWarning opts . text $-                        msgSkipping msgs ++ " '" ++ f +++                        msgSkipping msgs ++ " '" ++ displayPath f ++                             "' ... couldn't add parent directory '" ++-                            parentdir ++ "' to repository"+                            displayPath parentdir ++ "' to repository"                     return (cur, Nothing, Nothing)               `catch` \(e :: IOException) -> do                   putWarning opts . text $-                      msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e+                      msgSkipping msgs ++ " '" ++ displayPath f ++ "' ... " ++ show e                   return (cur, Nothing, Nothing)-          parentdir = takeDirectory f+          parentdir = fromMaybe (error "cannot take parent of root path") $ parent f+                   gotAllowCaseOnly = allowCaseDifferingFilenames ? opts     gotAllowWindowsReserved = allowWindowsReservedFilenames ? opts @@ -321,9 +332,5 @@     }  -getParents :: Tree IO-           -> [FilePath]-           -> [FilePath]-getParents cur = map (anchorPath "") . go . map floatPath-  where-    go fs = filter (isNothing . findTree cur) $ concatMap parents fs+notInTreeParents :: Tree IO -> [AnchoredPath] -> [AnchoredPath]+notInTreeParents cur = filter (isNothing . findTree cur) . concatMap parents
src/Darcs/UI/Commands/Amend.hs view
@@ -22,17 +22,17 @@ -- Stability   : experimental -- Portability : portable +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Amend     (       amend     , amendrecord     ) where -import Prelude () import Darcs.Prelude +import Control.Monad ( unless ) import Data.Maybe ( isNothing, isJust )-import Control.Monad ( when )  import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts@@ -42,159 +42,107 @@     , setEnvDarcsPatches     , amInHashedRepository     )-import Darcs.UI.Commands.Util ( announceFiles, testTentativeAndMaybeExit )+import Darcs.UI.Commands.Util+    ( announceFiles+    , historyEditHelp+    , testTentativeAndMaybeExit+    ) import Darcs.UI.Completion ( modifiedFileArgs, knownFileArgs )-import Darcs.UI.Flags ( DarcsFlag, diffOpts, fixSubPaths )-import Darcs.UI.Options ( DarcsOption, (^), oparse, odesc, ocheck, defaultFlags, (?) )+import Darcs.UI.Flags ( diffOpts, pathSetFromArgs )+import Darcs.UI.Options ( (^), oparse, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( updatePatchHeader, AskAboutDeps(..)                             , HijackOptions(..)                             , runHijackT )-import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) )++import Darcs.Repository.Flags ( UpdatePending(..), DryRun(NoDryRun) ) import Darcs.Patch ( IsRepoType, RepoPatch, description, PrimOf-                   , effect, invert, invertFL+                   , effect, invert, invertFL, sortCoalesceFL                    ) import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Depends ( 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.Split ( primSplitter ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, patchDesc ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) import Darcs.Patch.Rebase.Name ( RebaseName(..) )-import Darcs.Util.Path ( toFilePath, SubPath(), AbsolutePath )+import Darcs.Util.Path ( AnchoredPath ) import Darcs.Repository     ( Repository     , withRepoLock     , RepoJob(..)-    , RebaseJobFlags(..)+    , identifyRepositoryFor+    , ReadingOrWriting(Reading)     , tentativelyRemovePatches     , tentativelyAddPatch     , withManualRebaseUpdate     , finalizeRepositoryChanges     , invalidateIndex-    , unrecordedChanges+    , readPendingAndWorking     , readRecorded+    , readRepo     )-import Darcs.Repository.Prefs ( globalPrefsDirDoc )+import Darcs.Repository.Pending ( tentativelyRemoveFromPW )+import Darcs.Repository.Prefs ( getDefaultRepo ) import Darcs.UI.SelectChanges     ( WhichChanges(..)-    , selectionContextPrim-    , runSelection-    , withSelectedPatchFromRepo+    , selectionConfigPrim+    , runInvertibleSelection+    , withSelectedPatchFromList     ) import qualified Darcs.UI.SelectChanges as S     ( PatchSelectionOptions(..)     ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Patch.Witnesses.Ordered-    ( FL(..), (:>)(..), (+>+), nullFL, reverseRL, mapFL_FL )+    ( FL(..), RL, (:>)(..), (+>+)+    , nullFL, reverseRL, reverseFL, mapFL_FL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FlippedSeal(..) ) -import Darcs.Util.Printer ( putDocLn )+import Darcs.Util.English ( anyOfClause, itemizeVertical )+import Darcs.Util.Printer ( Doc, formatWords, putDocLn, text, (<+>), ($$), ($+$) )+import Darcs.Util.Printer.Color ( ePutDocLn ) import Darcs.Util.Tree( Tree )-import Darcs.Repository.Pending ( tentativelyRemoveFromPending )   amendDescription :: String amendDescription = "Improve a patch before it leaves your repository."  -amendHelp :: String+amendHelp :: Doc amendHelp =-    "Amend updates a \"draft\" patch with additions or improvements,\n" ++-    "resulting in a single \"finished\" patch.\n" ++-    "\n" ++-    "By default `amend` proposes you to record additional changes.\n" ++-    "If instead you want to remove changes, use the flag `--unrecord`.\n" ++-    "\n" ++-    "When recording a draft patch, it is a good idea to start the name with\n" ++-    "`DRAFT:`. When done, remove it with `darcs amend --edit-long-comment`.\n" ++-    "Alternatively, to change the patch name without starting an editor, \n" ++-    "use the `--name`/`-m` flag:\n" ++-    "\n" ++-    "    darcs amend --match 'name \"DRAFT: foo\"' --name 'foo2'\n" ++-    "\n" ++-    "Like `darcs record`, if you call amend with files as arguments,\n" ++-    "you will only be asked about changes to those files.  So to amend a\n" ++-    "patch to foo.c with improvements in bar.c, you would run:\n" ++-    "\n" ++-    "    darcs amend --match 'touch foo.c' bar.c\n" ++-    "\n" ++-    "It is usually a bad idea to amend another developer's patch.  To make\n" ++-    "amend only ask about your own patches by default, you can add\n" ++-    "something like `amend match David Roundy` to `" ++ globalPrefsDirDoc ++-    "defaults`, \n" ++-    "where `David Roundy` is your name.\n"--amendBasicOpts :: DarcsOption a-                  (Bool-                   -> [O.MatchFlag]-                   -> O.TestChanges-                   -> Maybe Bool-                   -> Maybe String-                   -> Bool-                   -> Maybe String-                   -> Bool-                   -> Maybe O.AskLongComment-                   -> Bool-                   -> O.LookFor-                   -> Maybe String-                   -> O.WithContext-                   -> O.DiffAlgorithm-                   -> a)-amendBasicOpts-    = O.amendUnrecord-    ^ O.matchOneNontag-    ^ O.testChanges-    ^ O.interactive --True-    ^ O.author-    ^ O.selectAuthor-    ^ O.patchname-    ^ O.askDeps-    ^ O.askLongComment-    ^ O.keepDate-    ^ O.lookfor-    ^ O.repoDir-    ^ O.withContext-    ^ O.diffAlgorithm--amendAdvancedOpts :: DarcsOption a-                     (O.Compression-                      -> O.UseIndex-                      -> O.UMask-                      -> O.SetScriptsExecutable-                      -> a)-amendAdvancedOpts = O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable--amendOpts :: DarcsOption a-             (Bool-              -> [O.MatchFlag]-              -> O.TestChanges-              -> Maybe Bool-              -> Maybe String-              -> Bool-              -> Maybe String-              -> Bool-              -> Maybe O.AskLongComment-              -> Bool-              -> O.LookFor-              -> Maybe String-              -> O.WithContext-              -> O.DiffAlgorithm-              -> Maybe O.StdCmdAction-              -> Bool-              -> Bool-              -> O.Verbosity-              -> Bool-              -> O.Compression-              -> O.UseIndex-              -> O.UMask-              -> O.SetScriptsExecutable-              -> O.UseCache-              -> O.HooksConfig-              -> a)-amendOpts = withStdOpts amendBasicOpts amendAdvancedOpts+  formatWords+  [ "Amend updates a \"draft\" patch with additions or improvements,"+  , "resulting in a single \"finished\" patch."+  ]+  $+$ formatWords+  [ "By default `amend` proposes you to record additional changes."+  , "If instead you want to remove changes, use the flag `--unrecord`."+  ]+  $+$ formatWords+  [ "When recording a draft patch, it is a good idea to start the name with"+  , "`DRAFT:`. When done, remove it with `darcs amend --edit-long-comment`."+  , "Alternatively, to change the patch name without starting an editor, "+  , "use the `--name`/`-m` flag:"+  ]+  $+$ text+    "    darcs amend --match 'name \"DRAFT: foo\"' --name 'foo2'"+  $+$ formatWords+  [ "Like `darcs record`, if you call amend with files as arguments,"+  , "you will only be asked about changes to those files.  So to amend a"+  , "patch to foo.c with improvements in bar.c, you would run:"+  ]+  $+$ text+    "    darcs amend --match 'touch foo.c' bar.c"+  $+$ historyEditHelp  data AmendConfig = AmendConfig     { amendUnrecord :: Bool+    , notInRemote :: [O.NotInRemote]     , matchFlags :: [O.MatchFlag]     , testChanges :: O.TestChanges     , interactive :: Maybe Bool@@ -216,11 +164,7 @@     , useCache :: O.UseCache     } -amendConfig :: [DarcsFlag] -> AmendConfig-amendConfig =-  oparse (amendBasicOpts ^ O.verbosity ^ amendAdvancedOpts ^ O.useCache) AmendConfig--amend :: DarcsCommand AmendConfig+amend :: DarcsCommand amend = DarcsCommand     {       commandProgramName          = "darcs"@@ -231,69 +175,90 @@     , commandExtraArgHelp         = ["[FILE or DIRECTORY]..."]     , commandCommand              = amendCmd     , commandPrereq               = amInHashedRepository-    , commandCompleteArgs         = amendFileArgs+    , commandCompleteArgs         = fileArgs     , commandArgdefaults          = nodefaults-    , commandAdvancedOptions      = odesc amendAdvancedOpts-    , commandBasicOptions         = odesc amendBasicOpts-    , commandDefaults             = defaultFlags amendOpts-    , commandCheckOptions         = ocheck amendOpts-    , commandParseOptions         = amendConfig+    , commandAdvancedOptions      = odesc advancedOpts+    , commandBasicOptions         = odesc basicOpts+    , commandDefaults             = defaultFlags allOpts+    , commandCheckOptions         = ocheck allOpts     }   where-    amendFileArgs fps flags args =+    fileArgs fps flags args =       if (O.amendUnrecord ? flags)         then knownFileArgs fps flags args         else modifiedFileArgs fps flags args+    basicOpts+      = O.amendUnrecord+      ^ O.notInRemote+      ^ O.matchOneNontag+      ^ O.testChanges+      ^ O.interactive --True+      ^ O.author+      ^ O.selectAuthor+      ^ O.patchname+      ^ O.askDeps+      ^ O.askLongComment+      ^ O.keepDate+      ^ O.lookfor+      ^ O.repoDir+      ^ O.withContext+      ^ O.diffAlgorithm+    advancedOpts+      = O.compress+      ^ O.useIndex+      ^ 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) -amendrecord :: DarcsCommand AmendConfig+amendrecord :: DarcsCommand amendrecord = commandAlias "amend-record" Nothing amend -amendCmd :: (AbsolutePath, AbsolutePath)-         -> AmendConfig-         -> [String]-         -> IO ()-amendCmd _   cfg [] = doAmend cfg Nothing-amendCmd fps cfg args = do-    files <- fixSubPaths fps args-    if null files-      then fail "No valid arguments were given, nothing to do."-      else doAmend cfg $ Just files--doAmend :: AmendConfig -> Maybe [SubPath] -> IO ()+doAmend :: AmendConfig -> Maybe [AnchoredPath] -> IO () doAmend cfg files =-    let rebaseJobFlags = RebaseJobFlags (compress cfg) (verbosity cfg) YesUpdateWorking in-    withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $-      RebaseAwareJob rebaseJobFlags $ \(repository :: Repository rt p wR wU wR) ->-    withSelectedPatchFromRepo "amend" repository (patchSelOpts cfg) $ \ (_ :> oldp) -> do+  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+        -- 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) = putStrLn "No changes!"+            go NilFL | not (hasEditMetadata cfg) =+              putInfo cfg "No changes!"             go ch =-              do let context = selectionContextPrim First "record"-                                      (patchSelOpts cfg)-                                      --([All,Unified] `intersect` opts)-                                      (Just (primSplitter (diffAlgorithm cfg)))-                                      (map toFilePath <$> files)-                                      (Just pristine)-                 (chosenPatches :> _) <- runSelection ch context-                 addChangesToPatch cfg repository oldp chosenPatches+              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 context = selectionContextPrim Last "unrecord"-                                             (patchSelOpts cfg)-                                             -- ([All,Unified] `intersect` opts)-                                             (Just (primSplitter (diffAlgorithm cfg)))-                                             (map toFilePath <$> files)-                                             (Just pristine)-                           (_ :> chosenPrims) <- runSelection (effect oldp) context+                   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-                   else go =<< unrecordedChanges (diffingOpts cfg)-                                  (O.moves (lookfor cfg)) (O.replaces (lookfor cfg))-                                  repository files+                           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@@ -303,66 +268,123 @@                    else do if hasEditMetadata cfg                                 -- the user already knows that it is possible to edit tag metadata,                                 -- note that s/he is providing editing options!-                             then putStrLn "You cannot add new changes to a tag."+                             then ePutDocLn "You cannot add new changes to a tag."                                 -- the user may not be aware that s/he can edit tag metadata.-                             else putStrLn "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend)."+                             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+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 =-    let rebaseJobFlags = RebaseJobFlags (compress cfg) (verbosity cfg) YesUpdateWorking in-    if nullFL chs && not (hasEditMetadata cfg)-    then putStrLn "You don't want to record anything!"+addChangesToPatch cfg _repository oldp chs pending working =+  if nullFL chs && not (hasEditMetadata cfg)+    then putInfo cfg "You don't want to record anything!"     else do-         invalidateIndex repository-         -- If a rebase is in progress, we want to manually update the rebase state, using-         -- the amendments directly as rebase fixups. This is necessary because otherwise-         -- the normal commute rules for the rebase state will first remove the original-         -- patch then add the amended patch, and this can lead to more conflicts than using-         -- the amendment as a fixup directly. For example, if a rename operation is amended in,-         -- the rename can be propagated to any edits to the file in the rebase state, whereas-         -- a delete then add would just cause a conflict.-         ---         -- We can also signal that any explicit dependencies of the old patch should be rewritten-         -- for the new patch using a 'NameFixup'.-         (repository''', (mlogf, newp)) <- withManualRebaseUpdate rebaseJobFlags repository $ \repository' -> do--             repository'' <- tentativelyRemovePatches repository' (compress cfg) YesUpdateWorking (oldp :>: NilFL)-             (mlogf, newp) <- runHijackT AlwaysRequestHijackPermission $ updatePatchHeader "amend"-                  (if askDeps cfg then AskAboutDeps repository'' else NoAskAboutDeps)-                  (patchSelOpts cfg)-                  (diffAlgorithm cfg)-                  (keepDate cfg)-                  (selectAuthor cfg)-                  (author cfg)-                  (patchname cfg)-                  (askLongComment cfg)-                  oldp chs-             let fixups =-                   mapFL_FL PrimFixup (invert chs) +>+-                   NameFixup (Rename (info newp) (info oldp)) :>:-                   NilFL-             setEnvDarcsFiles newp-             repository''' <- tentativelyAddPatch repository'' (compress cfg) (verbosity cfg) YesUpdateWorking newp-             return (repository''', fixups, (mlogf, newp))-         let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf-         testTentativeAndMaybeExit repository''' (verbosity cfg) (testChanges cfg) (sse cfg) (isInteractive cfg)-              ("you have a bad patch: '" ++ patchDesc newp ++ "'") "amend it"-              (Just failmsg)-         when (O.moves (lookfor cfg) == O.YesLookForMoves || O.replaces (lookfor cfg) == O.YesLookForReplaces)-           $ tentativelyRemoveFromPending repository''' YesUpdateWorking oldp-         finalizeRepositoryChanges repository''' YesUpdateWorking (compress cfg) `clarifyErrors` failmsg-         putStrLn "Finished amending patch:"-         putDocLn $ description newp-         setEnvDarcsPatches (newp :>: NilFL)+      invalidateIndex _repository+      -- If a rebase is in progress, we want to manually update the rebase+      -- state, using the amendments directly as rebase fixups. This is+      -- necessary because otherwise the normal commute rules for the rebase+      -- state will first remove the original patch then add the amended patch,+      -- and this can lead to more conflicts than using the amendment as a fixup+      -- directly. For example, if a rename operation is amended in, the rename+      -- can be propagated to any edits to the file in the rebase state, whereas+      -- a delete then add would just cause a conflict.+      -- +      -- We can also signal that any explicit dependencies of the old patch+      -- should be rewritten for the new patch using a 'NameFixup'.+      (_repository, (mlogf, newp)) <-+        withManualRebaseUpdate _repository $ \_repository -> do+          -- Note we pass NoUpdatePending here and below when re-adding the+          -- amended patch, and instead fix pending explicitly further below.+          _repository <-+            tentativelyRemovePatches+              _repository+              (compress cfg)+              NoUpdatePending+              (oldp :>: NilFL)+          (mlogf, newp) <-+            runHijackT AlwaysRequestHijackPermission $+            updatePatchHeader+              "amend"+              (if askDeps cfg+                 then AskAboutDeps _repository+                 else NoAskAboutDeps)+              (patchSelOpts cfg)+              (diffAlgorithm cfg)+              (keepDate cfg)+              (selectAuthor cfg)+              (author cfg)+              (patchname cfg)+              (askLongComment cfg)+              (fmapFL_Named effect (hopefully oldp))+              chs+          let fixups =+                mapFL_FL PrimFixup (invert chs) +>++                NameFixup (Rename (info newp) (info oldp)) :>:+                NilFL+          setEnvDarcsFiles newp+          _repository <-+            tentativelyAddPatch+              _repository+              (compress cfg)+              (verbosity cfg)+              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)+        ("you have a bad patch: '" ++ patchDesc newp ++ "'")+        "amend it"+        (Just failmsg)+      tentativelyRemoveFromPW _repository chs pending working+      _repository <-+        finalizeRepositoryChanges _repository YesUpdatePending (compress cfg)+          `clarifyErrors` failmsg+      case 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 cfg repository patchSet = do+    nirs <- mapM getNotInRemotePath (notInRemote cfg)+    if null nirs+      then+        return (FlippedSeal (patchSet2RL 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))+  where+    readNir loc = do+      repo <- identifyRepositoryFor Reading repository (useCache cfg) loc+      rps <- readRepo repo+      return (Sealed rps)+    getNotInRemotePath (O.NotInRemotePath p) = return p+    getNotInRemotePath O.NotInDefaultRepo = do+        defaultRepo <- getDefaultRepo+        let err = fail $ "No default push/pull repo configured, please pass a "+                         ++ "repo name to --" ++ O.notInRemoteFlagName+        maybe err return defaultRepo  hasEditMetadata :: AmendConfig -> Bool hasEditMetadata cfg = isJust (author cfg)@@ -389,7 +411,7 @@     , S.matchFlags = matchFlags cfg     , S.interactive = isInteractive cfg     , S.selectDeps = O.PromptDeps -- option not supported, use default-    , S.summary = O.NoSummary -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default     , S.withContext = withContext cfg     } @@ -398,3 +420,6 @@  isInteractive :: AmendConfig -> Bool isInteractive = maybe True id . interactive++putInfo :: AmendConfig -> Doc -> IO ()+putInfo cfg what = unless (verbosity cfg == O.Quiet) $ putDocLn what
src/Darcs/UI/Commands/Annotate.hs view
@@ -18,50 +18,48 @@  module Darcs.UI.Commands.Annotate ( annotate ) where -import Prelude () import Darcs.Prelude -import Control.Arrow ( first ) import Control.Monad ( when )  import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Completion ( knownFileArgs )-import Darcs.UI.Flags ( DarcsFlag, useCache, fixSubPaths, patchIndexYes )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise+import Darcs.UI.External ( viewDocWith )+import Darcs.UI.Flags ( DarcsFlag, useCache, patchIndexYes, pathsFromArgs )+import Darcs.UI.Options ( (^), odesc, ocheck                         , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O+ import Darcs.Repository.State ( readRecorded ) import Darcs.Repository     ( withRepository     , withRepoLockCanFail     , RepoJob(..)     , readRepo-    , repoPatchType     ) import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex ) import Darcs.Patch.Set ( patchSet2RL )-import Darcs.Patch ( invertRL ) import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate ) import Data.ByteString.Lazy ( toChunks ) import Darcs.Patch.ApplyMonad( withFileNames )-import System.FilePath.Posix ( (</>) )-import Darcs.Patch.Match ( haveNonrangeMatch, getNonrangeMatchS  )+import Darcs.Patch.Match ( patchSetMatch, rollbackToPatchSetMatch  ) import Darcs.Repository.Match ( getOnePatchset ) import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal ) import qualified Darcs.Patch.Annotate as A -import Darcs.Util.Tree( TreeItem(..), readBlob, list, expand )+import Darcs.Util.Tree( TreeItem(..) )+import qualified Darcs.Util.Tree as T ( readBlob, list, expand ) import Darcs.Util.Tree.Monad( findM, virtualTreeIO )-import Darcs.Util.Path( floatPath, anchorPath, fp2fn, toFilePath-                      , AbsolutePath, SubPath )+import Darcs.Util.Path( AbsolutePath, AnchoredPath, displayPath, catPaths )+import Darcs.Util.Printer ( Doc, simplePrinters, renderString, text ) import Darcs.Util.Exception ( die )  annotateDescription :: String annotateDescription = "Annotate lines of a file with the last patch that modified it." -annotateHelp :: String-annotateHelp = unlines+annotateHelp :: Doc+annotateHelp = text $ unlines  [ "When `darcs annotate` is called on a file, it will find the patch that"  , "last modified each line in that file. This also works on directories."  , ""@@ -69,7 +67,7 @@  , "machine postprocessing."  ] -annotate :: DarcsCommand [DarcsFlag]+annotate :: DarcsCommand annotate = DarcsCommand     { commandProgramName = "darcs"     , commandName = "annotate"@@ -85,7 +83,6 @@     , commandBasicOptions = odesc annotateBasicOpts     , commandDefaults = defaultFlags annotateOpts     , commandCheckOptions = ocheck annotateOpts-    , commandParseOptions = onormalise annotateOpts     }   where     annotateBasicOpts = O.machineReadable ^ O.matchUpToOne ^ O.repoDir@@ -94,54 +91,57 @@  annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () annotateCmd fps opts args = do-  fixed_paths <- fixSubPaths fps args-  case fixed_paths of-    [] -> die "Error: annotate needs a filename to work with"-    (fixed_path:_) -> do+  paths <- pathsFromArgs fps args+  case paths of+    [path] -> do       when (patchIndexYes ? opts == O.YesPatchIndex)         $ withRepoLockCanFail (useCache ? opts)         $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo)-      annotateCmd' opts fixed_path+      annotateCmd' opts path+    _ -> die "Error: annotate requires a single filepath argument" -annotateCmd' :: [DarcsFlag] -> SubPath -> IO ()+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-  (patches, initial, path') <--    if haveNonrangeMatch (repoPatchType repository) matchFlags-       then do Sealed x <- getOnePatchset repository matchFlags-               let fn = [fp2fn $ toFilePath fixed_path]-                   nonRangeMatch = getNonrangeMatchS matchFlags r-                   (_, [path], _) = withFileNames Nothing fn nonRangeMatch-               initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS matchFlags r) recorded-               return (seal $ patchSet2RL x, initial, toFilePath path)-       else return (seal $ patchSet2RL r, recorded, toFilePath fixed_path)-  let path = "./" ++ path'+  (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')+      Nothing ->+        return (seal $ patchSet2RL r, recorded, fixed_path) -  found <- findM initial (floatPath $ toFilePath path)+  found <- findM initial path   -- TODO need to decide about the --machine flag-  let fmt = if parseFlags O.machineReadable opts then A.machineFormat else A.format+  let (fmt, view) = if parseFlags O.machineReadable opts+                      then (A.machineFormat, putStrLn . renderString)+                      else (A.format, viewDocWith simplePrinters)   usePatchIndex <- (O.yes (O.patchIndexYes ? opts) &&) <$> canUsePatchIndex repository   case found of-    Nothing -> die $ "Error: no such file or directory: " ++ toFilePath path+    Nothing -> die $ "Error: path not found in repository: " ++ displayPath fixed_path     Just (SubTree s) -> do-      s' <- expand s-      let subs = map (fp2fn . (path </>) . anchorPath "" . fst) $ list s'-          showPath (n, File _) = BC.pack (path </> n)-          showPath (n, _) = BC.concat [BC.pack (path </> n), "/"]+      -- TODO the semantics and implementation of annotating of directories need to be revised+      s' <- T.expand s+      let subs = map (catPaths path . fst) $ T.list s'+          showPath (n, File _) = BC.pack $ displayPath $ path `catPaths` n+          showPath (n, _) = BC.concat [BC.pack $ displayPath $ path `catPaths` n, "/"]       (Sealed ans_patches) <- do          if not usePatchIndex             then return patches             else getRelevantSubsequence patches repository r subs-      putStrLn $ fmt (BC.intercalate "\n" $-                        map (showPath . first (anchorPath "")) $ list s') $-        A.annotateDirectory (invertRL ans_patches) (fp2fn path) subs+      view . text $+        fmt (BC.intercalate "\n" $ map showPath $ T.list s') $+        A.annotateDirectory ans_patches path subs     Just (File b) -> do (Sealed ans_patches) <- do                            if not usePatchIndex                               then return patches-                              else getRelevantSubsequence patches repository r [fp2fn path]-                        con <- BC.concat `fmap` toChunks `fmap` readBlob b-                        putStrLn $ fmt con $-                          A.annotateFile (invertRL ans_patches) (fp2fn path) con-    Just (Stub _ _) -> impossible+                              else getRelevantSubsequence patches repository r [path]+                        con <- BC.concat `fmap` toChunks `fmap` T.readBlob b+                        view $ text . fmt con $+                          A.annotateFile ans_patches path con+    Just (Stub _ _) -> error "impossible case"
src/Darcs/UI/Commands/Apply.hs view
@@ -20,29 +20,29 @@     , getPatchBundle -- used by darcsden     ) where -import Prelude () import Darcs.Prelude  import System.Exit ( exitSuccess )-import Control.Monad ( when )+import Control.Monad ( unless, when )+import Data.Maybe ( catMaybes )  import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info ) import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts-    , putVerbose+    , putInfo     , amInHashedRepository     ) import Darcs.UI.Completion ( fileArgs ) import Darcs.UI.Flags     ( DarcsFlag-    , happyForwarding, changesReverse, verbosity, useCache, dryRun+    , changesReverse, verbosity, useCache, dryRun     , reorder, umask-    , fixUrl, getCc, getSendmailCmd-    , withContext, reply+    , fixUrl+    , withContext     )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) import Darcs.Repository     ( Repository@@ -51,93 +51,100 @@     , readRepo     , filterOutConflicts     )-import Darcs.Patch.Set ( Origin, patchSet2RL )+import Darcs.Patch.Set ( PatchSet, Origin ) import Darcs.Patch ( IsRepoType, RepoPatch ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Info ( PatchInfo, displayPatchInfo ) import Darcs.Patch.Witnesses.Ordered-    ( RL(..), (:\/:)(..), (:>)(..)-    , mapRL, nullFL, reverseFL )+    ( Fork(..), (:>)(..)+    , mapFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Util.ByteString ( linesPS, unlinesPS, gzReadStdin )-import Data.List( (\\) )-import qualified Data.ByteString as B (ByteString, null, init, take, drop)-import qualified Data.ByteString.Char8 as BC (unpack, last, pack)+import 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.UI.External-    ( sendEmailDoc-    , resendEmail-    , verifyPS+    ( verifyPS     ) import Darcs.UI.Email ( readEmail )-import Darcs.Patch.Depends ( findUncommon, findCommonWithThem )+import Darcs.Patch.Depends ( findCommonAndUncommon ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..), PatchProxy ) import Darcs.UI.SelectChanges     ( WhichChanges(..)     , runSelection-    , selectionContext+    , selectionConfig     ) import qualified Darcs.UI.SelectChanges as S-import Darcs.Patch.Bundle ( scanBundle )+import Darcs.Patch.Bundle ( interpretBundle, parseBundle ) import Darcs.Util.Printer-    ( packedString, vcat, text, empty+    ( Doc, vcat, text     , renderString+    , ($$)+    , vsep+    , formatWords     ) import Darcs.Util.Tree( Tree )  applyDescription :: String applyDescription = "Apply a patch bundle created by `darcs send'." -applyHelp :: String-applyHelp = unlines- [ "The `darcs apply` command takes a patch bundle and attempts to insert"- , "it into the current repository.  In addition to invoking it directly"- , "on bundles created by `darcs send`, it is used internally by `darcs"- , "push` on the remote end of an SSH connection."- , ""- , "If no file is supplied, the bundle is read from standard input."- , ""- , "If given an email instead of a patch bundle, Darcs will look for the"- , "bundle as a MIME attachment to that email.  Currently this will fail"- , "if the MIME boundary is rewritten, such as in Courier and Mail.app."- , ""- , "If the `--reply noreply@example.net` option is used, and the bundle is"- , "attached to an email, Darcs will send a report (indicating success or"- , "failure) to the sender of the bundle (the `To` field).  The argument to"- , "noreply is the address the report will appear to originate FROM."- , ""- , "The `--cc` option will cause the report to be CC'd to another address,"- , "for example `--cc reports@lists.example.net,admin@lists.example.net`."- , "Using `--cc` without `--reply` is undefined."- , ""- , "If you want to use a command different from the default one for sending mail,"- , "you need to specify a command line with the `--sendmail-command` option."- , "The command line can contain the format specifier `%t` for to"- , "and you can add `%<` to the end of the command line if the command"- , "expects the complete mail on standard input. For example, the command line"- , "for msmtp looks like this:"- , ""- , "    msmtp -t %<"- , ""- , "If gpg(1) is installed, you can use `--verify pubring.gpg` to reject"- , "bundles that aren't signed by a key in `pubring.gpg`."- , ""- , "If `--test` is supplied and a test is defined (see `darcs setpref`), the"- , "bundle will be rejected if the test fails after applying it.  In that"- , "case, the rejection email from `--reply` will include the test output."- ]+applyHelp :: Doc+applyHelp = vsep $ map formatWords+  [ [ "The `darcs apply` command takes a patch bundle and attempts to insert"+    , "it into the current repository.  In addition to invoking it directly"+    , "on bundles created by `darcs send`, it is used internally by `darcs"+    , "push` on the remote end of an SSH connection."+    ]+  , [ "If no file is supplied, the bundle is read from standard input."+    ]+  , [ "If given an email instead of a patch bundle, Darcs will look for the"+    , "bundle as a MIME attachment to that email.  Currently this will fail"+    , "if the MIME boundary is rewritten, such as in Courier and Mail.app."+    ]+  , [ "If gpg(1) is installed, you can use `--verify pubring.gpg` to reject"+    , "bundles that aren't signed by a key in `pubring.gpg`."+    ]+  , [ "If `--test` is supplied and a test is defined (see `darcs setpref`), the"+    , "bundle will be rejected if the test fails after applying it."+    ]+  , [ "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`)."+    ]+  , [ "The `--external-merge` option lets you resolve these 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."+    ]+  , [ "Unlike most Darcs commands, `darcs apply` defaults to `--all`.  Use the"+    , "`--interactive` option to pick which patches to apply from a bundle."+    ]+  ]  stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] stdindefault _ x = return x -apply :: DarcsCommand [DarcsFlag]+apply :: DarcsCommand apply = DarcsCommand     { commandProgramName = "darcs"     , commandName = "apply"-    , commandHelp = applyHelp ++ "\n" ++ applyHelp'+    , commandHelp = applyHelp     , commandDescription = applyDescription     , commandExtraArgs = 1     , commandExtraArgHelp = ["<PATCHFILE>"]@@ -149,7 +156,6 @@     , commandBasicOptions = odesc applyBasicOpts     , commandDefaults = defaultFlags applyOpts     , commandCheckOptions = ocheck applyOpts-    , commandParseOptions = onormalise applyOpts     }   where     applyBasicOpts@@ -165,37 +171,38 @@       ^ O.repoDir       ^ O.diffAlgorithm     applyAdvancedOpts-      = O.reply-      ^ O.ccApply-      ^ O.happyForwarding-      ^ O.sendmail-      ^ O.useIndex+      = O.useIndex       ^ O.compress       ^ O.setScriptsExecutable       ^ O.umask-      ^ O.restrictPaths       ^ O.changesReverse       ^ O.pauseForGui     applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts -applyCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-applyCmd _ _ _ [""] = fail "Empty filename argument given to apply!"-applyCmd patchApplier _ opts ["-"] =-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $-  repoJob patchApplier opts $ \patchProxy repository -> do-    -- for darcs users who try out 'darcs apply' without any arguments-    putVerbose opts $ text "reading patch bundle from stdin..."-    bundle <- gzReadStdin-    applyCmdCommon patchApplier patchProxy opts bundle repository--applyCmd patchApplier (_,o) opts [unfixed_patchesfile] =-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $-  repoJob patchApplier opts $ \patchProxy repository -> do-    patchesfile <- fixUrl o unfixed_patchesfile-    bundle <- gzFetchFilePS (toFilePath patchesfile) Uncachable+applyCmd :: PatchApplier pa+         => pa+         -> (AbsolutePath, AbsolutePath)+         -> [DarcsFlag]+         -> [String]+         -> IO ()+applyCmd patchApplier (_,orig) opts args =+  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+  repoJob patchApplier $ \patchProxy repository -> do+    bundle <- readBundle args     applyCmdCommon patchApplier patchProxy opts bundle repository--applyCmd _ _ _ _ = impossible+  where+    readBundle ["-"] = do+      -- For users who try out 'darcs apply' without any arguments.+      -- FIXME apparently some magic behind the scenes causes an empty argument+      -- list to be converted to a single "-". This is quite obscure and should+      -- be removed.+      putInfo opts $ text "reading patch bundle from stdin..."+      gzReadStdin+    readBundle [""] = fail "Empty filename argument given to apply!"+    readBundle [unfixed_filename] = do+      patchesfile <- fixUrl orig unfixed_filename+      gzFetchFilePS (toFilePath patchesfile) Uncachable+    readBundle _ = error "impossible case"  applyCmdCommon     :: forall rt pa p wR wU@@ -209,36 +216,25 @@     -> Repository rt p wR wU wR     -> IO () applyCmdCommon patchApplier patchProxy opts bundle repository = do-  let from_whom = getFrom bundle   us <- readRepo repository-  either_them <- getPatchBundle opts bundle-  Sealed them-     <- case either_them of-          Right t -> return t-          Left er -> do forwarded <- considerForwarding opts bundle-                        if forwarded-                          then exitSuccess-                          else fail er-  common :> _ <- return $ findCommonWithThem us them--  -- all patches that are in "them" and not in "common" need to be available; check that-  let common_i = mapRL info $ patchSet2RL common-      them_i = mapRL info $ patchSet2RL them-      required = them_i \\ common_i -- FIXME quadratic?-      check :: RL (PatchInfoAnd rt p) wX wY -> [PatchInfo] -> IO ()-      check (ps' :<: p) bad = case hopefullyM p of-        Nothing | info p `elem` required -> check ps' (info p : bad)-        _ -> check ps' bad-      check NilRL [] = return ()-      check NilRL bad = fail . renderString $ vcat $ map displayPatchInfo bad ++-                        [ text "\nFATAL: Cannot apply this bundle. We are missing the above patches." ]+  Sealed them <- either fail return =<< getPatchBundle opts us bundle+  Fork common us' them' <- return $ findCommonAndUncommon us them -  check (patchSet2RL them) []+  -- all patches in them' need to be available; check that+  let check :: PatchInfoAnd rt p wX wY -> Maybe PatchInfo+      check p = case hopefullyM p of+        Nothing -> Just (info p)+        Just _ -> Nothing+      bad = catMaybes (mapFL check them')+  unless (null bad) $+    fail $+    renderString $+      (vcat $ map displayPatchInfo bad) $$ text "" $$+      text "Cannot apply this bundle. We are missing the above patches." -  (us':\/:them') <- return $ findUncommon us them   (hadConflicts, Sealed their_ps)     <- if O.conflictsNo ? opts == Nothing -- skip conflicts-        then filterOutConflicts (reverseFL us') repository them'+        then filterOutConflicts repository us' them'         else return (False, Sealed them')   when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."   when (nullFL their_ps) $@@ -249,25 +245,24 @@                           "Nothing to do.") >> when (reorder ? opts /= O.Reorder) exitSuccess              let direction = if changesReverse ? opts then FirstReversed else First-      context = selectionContext direction "apply" (patchSelOpts opts) Nothing Nothing-  (to_be_applied :> _) <- runSelection their_ps context-  applyPatches patchApplier patchProxy "apply" opts from_whom repository us' to_be_applied---    see the default (False) for the option---    where fixed_opts = if Interactive `elem` opts---                          then opts---                          else All : opts+      selection_config = selectionConfig direction "apply" (patchSelOpts opts) Nothing Nothing+  (to_be_applied :> _) <- runSelection their_ps selection_config+  applyPatches patchApplier patchProxy "apply" opts repository (Fork common us' to_be_applied) -getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString-                 -> IO (Either String (SealedPatchSet rt p Origin))-getPatchBundle opts fps = do+getPatchBundle :: RepoPatch p+               => [DarcsFlag]+               -> PatchSet rt p Origin wR+               -> B.ByteString+               -> IO (Either String (SealedPatchSet rt p Origin))+getPatchBundle opts us fps = do     let opt_verify = parseFlags O.verify opts     mps <- verifyPS opt_verify $ readEmail fps     mops <- verifyPS opt_verify fps     case (mps, mops) of       (Nothing, Nothing) ->           return $ Left "Patch bundle not properly signed, or gpg failed."-      (Just bundle, Nothing) -> return $ scanBundle bundle-      (Nothing, Just bundle) -> return $ scanBundle bundle+      (Just bundle, Nothing) -> return $ parseAndInterpretBundle us bundle+      (Nothing, Just bundle) -> return $ parseAndInterpretBundle us bundle       -- We use careful_scan_bundle only below because in either of the two       -- above case we know the patch was signed, so it really shouldn't       -- need stripping of CRs.@@ -275,8 +270,8 @@                               Left _ -> return $ careful_scan_bundle ps2                               Right x -> return $ Right x           where careful_scan_bundle bundle =-                    case scanBundle bundle of-                    Left e -> case scanBundle $ stripCrPS bundle of+                    case parseAndInterpretBundle us bundle of+                    Left e -> case parseAndInterpretBundle us $ stripCrPS bundle of                               Right x -> Right x                               _ -> Left e                     x -> x@@ -286,70 +281,13 @@                             | BC.last p == '\r' = B.init p                             | otherwise = p -applyHelp' :: String-applyHelp' =- "A patch bundle may introduce unresolved conflicts with existing\n" ++- "patches or with the working tree.  By default, Darcs will add conflict\n" ++- "markers (see `darcs mark-conflicts`).\n" ++- "\n" ++- "The `--external-merge` option lets you resolve these conflicts\n" ++- "using an external merge tool.  In the option, `%a` is replaced with\n" ++- "the common ancestor (merge base), `%1` with the first version, `%2`\n" ++- "with the second version, and `%o` with the path where your resolved\n" ++- "content should go.  For example, to use the xxdiff visual merge tool\n" ++- "you'd specify: `--external-merge='xxdiff -m -O -M %o %1 %a %2'`\n" ++- "\n" ++- "The `--allow-conflicts` option will skip conflict marking; this is\n" ++- "useful when you want to treat a repository as just a bunch of patches,\n" ++- "such as using `darcs pull --union` to download of your co-workers\n" ++- "patches before going offline.\n" ++- "\n" ++- "This can mess up unrecorded changes in the working tree, forcing you\n" ++- "to resolve the conflict immediately.  To simply reject bundles that\n" ++- "introduce unresolved conflicts, using the `--dont-allow-conflicts`\n" ++- "option.  Making this the default in push-based workflows is strongly\n" ++- "recommended.\n" ++- "\n" ++- "Unlike most Darcs commands, `darcs apply` defaults to `--all`.  Use the\n" ++- "`--interactive` option to pick which patches to apply from a bundle.\n"--getFrom :: B.ByteString -> String-getFrom bundle = readFrom $ linesPS bundle-    where readFrom [] = ""-          readFrom (x:xs)-           | B.take 5 x == fromStart = BC.unpack $ B.drop 5 x-           | otherwise = readFrom xs--forwardingMessage :: B.ByteString-forwardingMessage = BC.pack $-    "The following patch was either unsigned, or signed by a non-allowed\n"++-    "key, or there was a GPG failure.\n"--considerForwarding :: [DarcsFlag] -> B.ByteString -> IO Bool-considerForwarding opts bundle = case reply ? opts of-  Nothing -> return False-  Just from -> case break is_from (linesPS bundle) of-    (m1, f:m2) ->-        let m_lines = forwardingMessage:m1 ++ m2-            m' = unlinesPS m_lines-            f' = BC.unpack (B.drop 5 f) in-            if from == f' || from == init f'-            then return False -- Refuse possible email loop.-            else do-              scmd <- getSendmailCmd opts-              if happyForwarding ? opts-               then resendEmail from scmd bundle-               else sendEmailDoc f' from "A forwarded darcs patch" cc-                                 scmd (Just (empty,empty))-                                 (packedString m')-              return True-    _ -> return False -- Don't forward emails lacking headers!-  where-    cc = getCc opts-    is_from l = B.take 5 l == fromStart--fromStart :: B.ByteString-fromStart = BC.pack "From:"+parseAndInterpretBundle :: RepoPatch p+                        => PatchSet rt p Origin wR+                        -> B.ByteString+                        -> Either String (SealedPatchSet rt p Origin)+parseAndInterpretBundle us content = do+    Sealed bundle <- parseBundle content+    Sealed <$> interpretBundle us bundle  patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions@@ -357,7 +295,7 @@     , S.matchFlags = parseFlags O.matchSeveral flags     , S.interactive = maybeIsInteractive flags     , S.selectDeps = O.PromptDeps -- option not supported, use default-    , S.summary = O.NoSummary -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default     , S.withContext = withContext ? flags     }
src/Darcs/UI/Commands/Clone.hs view
@@ -21,40 +21,44 @@     , clone     , makeRepoName     , cloneToSSH+    , otherHelpInheritDefault     ) where -import Prelude () import Darcs.Prelude  import System.Directory ( doesDirectoryExist, doesFileExist                         , setCurrentDirectory ) import System.Exit ( ExitCode(..) )-import Control.Exception ( catch, SomeException ) import Control.Monad ( when, unless )-import Data.Maybe ( listToMaybe )  import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts                       , nodefaults                       , commandStub                       , commandAlias                       , putInfo+                      , putFinished                       ) import Darcs.UI.Completion ( noArgs )-import Darcs.UI.Flags( DarcsFlag( NewRepo-                                  , UpToPattern-                                  , UpToPatch-                                  , UpToHash-                                  , OnePattern-                                  , OnePatch-                                  , OneHash-                                  )-                     , matchAny, useCache, umask, remoteRepos-                     , setDefault, quiet, usePacks-                     , remoteDarcs, cloneKind, verbosity, setScriptsExecutable-                     , withWorkingDir, patchIndexNo )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Flags+    ( DarcsFlag+    , cloneKind+    , patchIndexNo+    , quiet+    , remoteDarcs+    , remoteRepos+    , setDefault+    , setScriptsExecutable+    , umask+    , useCache+    , usePacks+    , verbosity+    , withNewRepo+    , withWorkingDir+    )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands.Util ( getUniqueRepositoryName )+import Darcs.Patch.Match ( MatchFlag(..) ) import Darcs.Repository ( cloneRepository ) import Darcs.Repository.Format ( identifyRepoFormat                                , RepoProperty ( HashedInventory@@ -63,59 +67,60 @@                                , formatHas                                ) import Darcs.Util.Lock ( withTempDir )-import Darcs.Util.Ssh ( getSSH, SSHCmd(SCP) )+import Darcs.Util.Ssh ( getSSH, SSHCmd(SCP,SSH) ) import Darcs.Repository.Flags     ( CloneKind(CompleteClone), SetDefault(NoSetDefault), ForgetParent(..) )-import Darcs.Patch.Bundle ( scanContextFile )-import Darcs.Patch.Dummy ( DummyPatch )-import Darcs.Patch.Set ( PatchSet, Origin ) import Darcs.Repository.Prefs ( showMotd ) import Darcs.Util.Progress ( debugMessage )-import Darcs.Util.Printer ( text, ($$) )-import Darcs.Util.Path ( toFilePath, toPath, ioAbsoluteOrRemote, AbsolutePath )+import Darcs.Util.Printer ( Doc, formatWords, formatText, text, vsep, ($$), ($+$) )+import Darcs.Util.Path ( toPath, ioAbsoluteOrRemote, AbsolutePath ) import Darcs.Util.Workaround ( getCurrentDirectory )-import Darcs.Util.URL ( isSshUrl )+import Darcs.Util.URL ( SshFilePath(..), isSshUrl, splitSshUrl ) import Darcs.Util.Exec ( exec, Redirect(..), )  cloneDescription :: String cloneDescription = "Make a copy of an existing repository." -cloneHelp :: String-cloneHelp =- unlines-  [ "Clone creates a copy of a repository.  The optional second"-  , "argument specifies a destination directory for the new copy;"-  , "if omitted, it is inferred from the source location."-  , ""-  , "By default Darcs will copy every patch from the original repository."-  , "If you expect the original repository to remain accessible, you can"-  , "use `--lazy` to avoid copying patches until they are needed ('copy on"-  , "demand').  This is particularly useful when copying a remote"-  , "repository with a long history that you don't care about."-  , ""-  , "When cloning locally, Darcs automatically uses hard linking where"-  , "possible.  As well as saving time and space, this enables to move or"-  , "delete the original repository without affecting the copy."-  , "Hard linking requires that the copy be on the same filesystem as the"-  , "original repository, and that the filesystem support hard linking."-  , "This includes NTFS, HFS+ and all general-purpose Unix filesystems"-  , "(such as ext, UFS and ZFS). FAT does not support hard links."-  , ""-  , "When cloning from a remote location, Darcs will look for and attempt"-  , "to use packs created by `darcs optimize http` in the remote repository."-  , "Packs are single big files that can be downloaded faster than many"-  , "little files."-  , ""-  , "Darcs clone will not copy unrecorded changes to the source repository's"-  , "working tree."-  , ""-  , "You can copy a repository to a ssh url, in which case the new repository"-  , "will always be complete."-  , ""-  ] ++ cloneHelpTag-    ++ cloneHelpSSE+cloneHelp :: Doc+cloneHelp = vsep $+  map formatWords+  [ [ "Clone creates a copy of a repository.  The optional second"+    , "argument specifies a destination directory for the new copy;"+    , "if omitted, it is inferred from the source location."+    ]+  , [ "By default Darcs will copy every patch from the original repository."+    , "If you expect the original repository to remain accessible, you can"+    , "use `--lazy` to avoid copying patches until they are needed ('copy on"+    , "demand').  This is particularly useful when copying a remote"+    , "repository with a long history that you don't care about."+    ]+  , [ "When cloning locally, Darcs automatically uses hard linking where"+    , "possible.  As well as saving time and space, this enables to move or"+    , "delete the original repository without affecting the copy."+    , "Hard linking requires that the copy be on the same filesystem as the"+    , "original repository, and that the filesystem support hard linking."+    , "This includes NTFS, HFS+ and all general-purpose Unix filesystems"+    , "(such as ext, UFS and ZFS). FAT does not support hard links."+    ]+  , [ "When cloning from a remote location, Darcs will look for and attempt"+    , "to use packs created by `darcs optimize http` in the remote repository."+    , "Packs are single big files that can be downloaded faster than many"+    , "little files."+    ]+  , [ "Darcs clone will not copy unrecorded changes to the source repository's"+    , "working tree."+    ]+  , [ "You can copy a repository to a ssh url, in which case the new repository"+    , "will always be complete."+    ]+  ]+  +++  [ cloneHelpTag+  , cloneHelpSSE+  , cloneHelpInheritDefault+  ] -clone :: DarcsCommand [DarcsFlag]+clone :: DarcsCommand clone = DarcsCommand     { commandProgramName = "darcs"     , commandName = "clone"@@ -124,45 +129,44 @@     , commandExtraArgs = -1     , commandExtraArgHelp = ["<REPOSITORY>", "[<DIRECTORY>]"]     , commandCommand = cloneCmd-    , commandPrereq = validContextFile+    , commandPrereq = \_ -> return $ Right ()     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults     , commandAdvancedOptions = odesc cloneAdvancedOpts     , commandBasicOptions = odesc cloneBasicOpts     , commandDefaults = defaultFlags cloneOpts     , commandCheckOptions = ocheck cloneOpts-    , commandParseOptions = onormalise cloneOpts     }   where     cloneBasicOpts-      = O.reponame+      = O.newRepo       ^ O.cloneKind       ^ O.matchOneContext       ^ O.setDefault+      ^ O.inheritDefault       ^ O.setScriptsExecutable       ^ O.withWorkingDir-    cloneAdvancedOpts = O.usePacks ^ O.patchIndexNo ^ O.network+    cloneAdvancedOpts = O.usePacks ^ O.patchIndexNo ^ O.umask ^ O.network     cloneOpts = cloneBasicOpts `withStdOpts` cloneAdvancedOpts -get :: DarcsCommand [DarcsFlag]+get :: DarcsCommand get = commandAlias "get" Nothing clone  putDescription :: String putDescription = "Deprecated command, replaced by clone." -putHelp :: String-putHelp = unlines+putHelp :: Doc+putHelp = formatText 80  [ "This command is deprecated."- , ""- , "To clone the current repository to a ssh destination,"- , "use the syntax `darcs clone . user@server:path` ."+ , "To clone the current repository to a ssh destination, " +++   "use the syntax `darcs clone . user@server:path` ."  ] -put :: DarcsCommand [DarcsFlag]+put :: DarcsCommand put = commandStub "put" putHelp putDescription clone  cloneCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-cloneCmd fps opts [inrepodir, outname] = cloneCmd fps (NewRepo outname:opts) [inrepodir]+cloneCmd fps opts [inrepodir, outname] = cloneCmd fps (withNewRepo outname opts) [inrepodir] cloneCmd _ opts [inrepodir] = do   debugMessage "Starting work on clone..."   typed_repodir <- ioAbsoluteOrRemote inrepodir@@ -171,12 +175,11 @@   rfsource <- identifyRepoFormat repodir   debugMessage $ "Found the format of "++repodir++"..." -  -- there's no fundamental reason for banning gets of repositories with-  -- rebase in progress, but it seems a bit dubious to actually copy the-  -- rebase state, and removing it is a bit of work since the current-  -- implementation just copies the inventory file+  -- This merely forbids clone from an old-style rebase in progress, which is+  -- exactly what we want. Transferring patches from repos with new-style+  -- rebase in progress is unproblematic and fully supported.   when (formatHas RebaseInProgress rfsource) $-      fail "Can't clone a repository with a rebase in progress"+      fail "Cannot clone a repository with an old-style rebase in progress"    unless (formatHas HashedInventory rfsource) $ putInfo opts $        text "***********************************************************************"@@ -192,6 +195,7 @@   case cloneToSSH opts of     Just repo -> do       withTempDir "clone" $ \_ -> do+         guardRemoteDirDoesNotExist repo          putInfo opts $ text "Creating local clone..."          currentDir <- getCurrentDirectory          mysimplename <- makeRepoName True [] repodir -- give correct name to local clone@@ -199,7 +203,8 @@                          CompleteClone (umask ? opts) (remoteDarcs opts)                          (setScriptsExecutable ? opts)                          (remoteRepos ? opts) (NoSetDefault True)-                         (matchAny ? map convertUpToToOne opts)+                         O.NoInheritDefault -- never inherit defaultrepo when cloning to ssh+                         (map convertUpToToOne (O.matchOneContext ? opts))                          rfsource                          (withWorkingDir ? opts)                          (patchIndexNo ? opts)@@ -217,24 +222,35 @@                   (cloneKind ? opts) (umask ? opts) (remoteDarcs opts)                   (setScriptsExecutable ? opts)                   (remoteRepos ? opts) (setDefault True opts)-                  (matchAny ? map convertUpToToOne opts)+                  (O.inheritDefault ? opts)+                  (map convertUpToToOne (O.matchOneContext ? opts))                   rfsource                   (withWorkingDir ? opts)                   (patchIndexNo ? opts)                   (usePacks ? opts)                   NoForgetParent-      putInfo opts $ text "Finished cloning."+      putFinished opts "cloning"  cloneCmd _ _ _ = fail "You must provide 'clone' with either one or two arguments."  cloneToSSH :: [DarcsFlag] -> Maybe String-cloneToSSH fs = case O.reponame ? fs of+cloneToSSH fs = case O.newRepo ? fs of   Nothing -> Nothing   Just r -> if isSshUrl r then Just r else Nothing +-- | Make sure we do not overwrite an existing remote directory.+guardRemoteDirDoesNotExist :: String -> IO ()+guardRemoteDirDoesNotExist rpath = 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)+  when (r /= ExitSuccess) $+    fail $ "Cannot create remote directory '"  ++ sshRepo sshfp ++ "'."+ makeRepoName :: Bool -> [DarcsFlag] -> FilePath -> IO String makeRepoName talkative fs d =-  case O.reponame ? fs of+  case O.newRepo ? fs of     Just n -> do       exists <- doesDirectoryExist n       file_exists <- doesFileExist n@@ -252,10 +268,10 @@       where mkName = dropWhile (== '.') . reverse .               takeWhile (not . (`elem` "/:")) . dropWhile (== '/') . reverse -cloneHelpTag :: String-cloneHelpTag =- unlines-  [ "It is often desirable to make a copy of a repository that excludes"+cloneHelpTag :: Doc+cloneHelpTag = formatWords+  [ ""+  , "It is often desirable to make a copy of a repository that excludes"   , "some patches.  For example, if releases are tagged then `darcs clone"   , "--tag .` would make a copy of the repository as at the latest release."   , ""@@ -272,48 +288,50 @@   , "patch.  Because these options treat the set of patches as an ordered"   , "sequence, you may get different results after reordering with `darcs"   , "optimize reorder`."-  , ""   ] -cloneHelpSSE :: String-cloneHelpSSE =-    unlines-    [ "The `--set-scripts-executable` option causes scripts to be made"-    , "executable in the working tree. A script is any file that starts"-    , "with a shebang (\"#!\")."-    ]+cloneHelpSSE :: Doc+cloneHelpSSE = formatWords+  [ "The `--set-scripts-executable` option causes scripts to be made"+  , "executable in the working tree. A script is any file that starts"+  , "with a shebang (\"#!\")."+  ] -validContextFile :: [DarcsFlag] -> IO (Either String ())-validContextFile opts =-   case getContext opts of-     Nothing -> return $ Right ()-     Just ctxAbsolutePath -> do-         let ctxFilePath = toFilePath ctxAbsolutePath-         exists <- doesFileExist ctxFilePath-         if exists-             then do-                (ps :: PatchSet rt DummyPatch Origin wX) <--                    scanContextFile ctxFilePath-                (ps `seq` return $ Right ()) `catch` \(_ :: SomeException) ->-                    return . Left $ "File " ++ ctxFilePath-                                    ++ " is not a valid context file"-             else return . Left $-                 "Context file " ++ ctxFilePath ++ " does not exist"+cloneHelpInheritDefault :: Doc+cloneHelpInheritDefault = commonHelpInheritDefault $+$ formatWords+  [ "For the clone command it means the following:"+  , "If the source repository already has a defaultrepo set (either because"+  , "you cloned it or because you explicitly used the --set-default option),"+  , "and both source and target are locally valid paths on the same host,"+  , "then the target repo will get the same defaultrepo as the source repo."+  , "Otherwise the target repo gets the source repo itself as defaultrepo,"+  , "i.e. we fall back to the defalt behavior (--no-inherit-default)."+  ] --- TODO getContext choses arbitrarily the first --context flag--- should instead report an error when more than one is given+otherHelpInheritDefault :: Doc+otherHelpInheritDefault = commonHelpInheritDefault $+$ formatWords+  [ "For the commands push, pull, and send it means the following:"+  , "Changes the meaning of the --set-default option so that it sets the"+  , "(local) defaultrepo to the defaultrepo of the remote repo, instead of"+  , "the remote repo itself. This happens only if the remote repo does have"+  , "a defaultrepo set and both local and remote repositories are locally"+  , "valid paths on the same host, otherwise fall back to the default behavior"+  , "(--no-inherit-default)."+  ] --- | 'getContext' takes a list of flags and returns the context--- specified by @Context c@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--context=FILE@-getContext :: [DarcsFlag] -> Maybe AbsolutePath-getContext fs = listToMaybe [ f | O.Context f <- O.context ? fs ]+commonHelpInheritDefault :: Doc+commonHelpInheritDefault = formatWords+  [ "The --inherit-default option is meant to support a work flow where"+  , "you have different branches of the same upstream repository and want"+  , "all your branches to have the same upstream repo as the defaultrepo."+  , "It is most useful when enabled globally by adding 'ALL --inherit-default'"+  , "to your ~/darcs/defaults file."+  ] --- The 'clone' command takes --to-patch and --to-match as arguments,--- but internally wants to handle them as if they were --patch and --match--- TODO: remove this when we get rid of directly looking at [DarcsFlag]--- for this command.-convertUpToToOne :: DarcsFlag -> DarcsFlag+-- | The 'clone' command takes --to-patch and --to-match as arguments,+-- but internally wants to handle them as if they were --patch and --match.+-- This function does the conversion.+convertUpToToOne :: MatchFlag -> MatchFlag convertUpToToOne (UpToPattern p) = OnePattern p convertUpToToOne (UpToPatch p) = OnePatch p convertUpToToOne (UpToHash p) = OneHash p
src/Darcs/UI/Commands/Convert.hs view
@@ -15,1133 +15,31 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE MagicHash, OverloadedStrings #-}--module Darcs.UI.Commands.Convert ( convert ) where--import Prelude ( lookup )-import Darcs.Prelude hiding ( readFile, lex )--import System.FilePath.Posix ( (</>) )-import System.Directory-    ( doesDirectoryExist-    , doesFileExist-    , removeFile-    )-import System.IO ( stdin )-import Data.IORef ( newIORef, modifyIORef, readIORef )-import Data.Char ( isSpace )-import Control.Arrow ( second, (&&&) )-import Control.Monad ( when, unless, void, forM_ )-import Control.Monad.Trans ( liftIO )-import Control.Monad.State.Strict ( gets, modify )-import Control.Exception ( finally )-import Control.Applicative ( (<|>) )--import System.Time ( toClockTime )-import Data.Maybe ( catMaybes, fromJust, fromMaybe )-import qualified Data.IntMap as M--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import qualified Data.ByteString.Lazy.UTF8 as BLU--import qualified Data.Attoparsec.ByteString.Char8 as A-import Data.Attoparsec.ByteString.Char8( (<?>) )--import Darcs.Util.ByteString ( decodeLocale )-import qualified Darcs.Util.Tree as T-import qualified Darcs.Util.Tree.Monad as TM-import Darcs.Util.Tree.Monad hiding ( createDirectory, exists, rename )-import Darcs.Util.Tree.Hashed ( hashedTreeIO, darcsAddMissingHashes )-import Darcs.Util.Tree( Tree, treeHash, readBlob, TreeItem(..)-                      , emptyTree, listImmediate, findTree )-import Darcs.Util.Path( anchorPath, appendPath, floatPath-                      , parent, anchoredRoot-                      , AnchoredPath(..), makeName-                      , ioAbsoluteOrRemote, toPath, AbsolutePath )-import Darcs.Util.Hash( encodeBase16, sha256, Hash(..) )--import Darcs.Util.DateTime ( formatDateTime, fromClockTime, parseDateTime, startOfTime )-import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Exception ( clarifyErrors )-import Darcs.Util.Lock ( withNewDirectory )-import Darcs.Util.Prompt ( askUser )-import Darcs.Util.Printer ( text, ($$) )-import Darcs.Util.Printer.Color ( traceDoc )-import Darcs.Util.Workaround ( getCurrentDirectory )--import Darcs.Patch.Depends ( getUncovered )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info, hopefully )-import Darcs.Patch-    ( showPatch, ShowPatchFor(..), fromPrim, fromPrims-    , effect, RepoPatch, apply, listTouchedFiles, move )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Effect ( Effect )-import Darcs.Patch.Named-    ( patch2patchinfo-    , infopatch, adddeps, getdeps, patchcontents-    )-import Darcs.Patch.Named.Wrapped ( WrappedNamed(..) )-import qualified Darcs.Patch.Named.Wrapped as Wrapped ( getdeps )-import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=/\=) )-import Darcs.Patch.Witnesses.Ordered-    ( FL(..), RL(..), bunchFL, mapFL_FL,-    concatFL, mapRL, nullFL, (+>+), (+<+)-    , reverseRL, reverseFL, foldFL_M )-import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed(..), unFreeLeft-                                    , mapSeal, flipSeal, unsafeUnsealFlipped )--import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo, patchinfo,-                          piName, piLog, piDate, piAuthor, makePatchname )-import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 )-import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )-import qualified Darcs.Patch.V2 as V2 ( RepoPatchV2 )-import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )-import Darcs.Patch.V1.Commute ( publicUnravel )-import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(PP), isMerger )-import Darcs.Patch.V2.RepoPatch ( mergeUnravelled )-import Darcs.Patch.Prim ( sortCoalesceFL )-import Darcs.Patch.Prim.Class ( PrimOf )-import Darcs.Patch.RepoType ( RepoType(..), IsRepoType(..), RebaseType(..) )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), patchSet2RL, patchSet2FL )-import Darcs.Patch.Progress ( progressFL )--import Darcs.Repository.Flags-    ( UpdateWorking(..)-    , Compression(..)-    , DiffAlgorithm(PatienceDiff) )-import Darcs.Repository-    ( Repository, RepoJob(..), withRepositoryLocation-    , createRepository, invalidateIndex, repoLocation-    , createPristineDirectoryTree, repoCache-    , revertRepositoryChanges, finalizeRepositoryChanges-    , applyToWorking, repoLocation, repoCache-    , readRepo, readTentativeRepo, cleanRepository-    , createRepositoryV2, EmptyRepository(..)-    , withUMaskFlag-    )-import qualified Darcs.Repository as R( setScriptsExecutable )-import Darcs.Repository.InternalTypes ( coerceR )-import Darcs.Repository.State( readRecorded )-import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )-import Darcs.Repository.Hashed-    ( tentativelyAddPatch_-    , UpdatePristine(..)-    , readHashedPristineRoot-    , addToTentativeInventory )-import Darcs.Repository.HashedIO ( cleanHashdir )-import Darcs.Repository.Prefs( FileType(..), showMotd )-import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2))-import Darcs.Util.External ( fetchFilePS, Cachable(Uncachable) )-import Darcs.Repository.Diff( treeDiff )---import Darcs.UI.External ( catchall )-import Darcs.UI.Flags-    ( verbosity, useCache, umask, withWorkingDir, patchIndexNo-    , DarcsFlag ( NewRepo )-    , getRepourl, patchFormat, quiet-    )-import Darcs.UI.Commands ( DarcsCommand(..), amInRepository, nodefaults, putInfo-                         , normalCommand, withStdOpts )-import Darcs.UI.Commands.Util.Tree ( treeHasDir, treeHasFile )-import Darcs.UI.Completion ( noArgs )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )-import qualified Darcs.UI.Options.All as O--type RepoPatchV1 = V1.RepoPatchV1 V1.Prim-type RepoPatchV2 = V2.RepoPatchV2 V2.Prim---convertDescription :: String-convertDescription = "Convert repositories between various formats."--convertHelp :: String-convertHelp = unlines- [ "This command converts a repository that uses the old patch semantics"- , "`darcs-1` to a new repository with current `darcs-2` semantics."- , ""- , convertHelp'- ]---- | This part of the help is split out because it is used twice: in--- the help string, and in the prompt for confirmation.-convertHelp' :: String-convertHelp' = unlines- [ "WARNING: the repository produced by this command is not understood by"- , "Darcs 1.x, and patches cannot be exchanged between repositories in"- , "darcs-1 and darcs-2 formats."- , ""- , "Furthermore, repositories created by different invocations of"- , "this command SHOULD NOT exchange patches."- ]--convertExportHelp :: String-convertExportHelp = unlines- [ "This command enables you to export darcs repositories into git."- , ""- , "For a one-time export you can use the recipe:"- , ""- , "    $ cd repo"- , "    $ git init ../mirror"- , "    $ darcs convert export | (cd ../mirror && git fast-import)"- , ""- , "For incremental export using marksfiles:"- , ""- , "    $ cd repo"- , "    $ git init ../mirror"- , "    $ touch ../mirror/git.marks"- , "    $ darcs convert export --read-marks darcs.marks --write-marks darcs.marks"- , "       | (cd ../mirror && git fast-import --import-marks=git.marks --export-marks=git.marks)"- , ""- , "In the case of incremental export, be careful to never amend, delete or"- , "reorder patches in the source darcs repository."- , ""- , "Also, be aware that exporting a darcs repo to git will not be exactly"- , "faithful in terms of history if the darcs repository contains conflicts."- , ""- , "Limitations:"- , ""- , "* Empty directories are not supported by the fast-export protocol."- , "* Unicode filenames are currently not correctly handled."- , "  See http://bugs.darcs.net/issue2359 ."- ]--convertImportHelp :: String-convertImportHelp = unlines- [ "This command imports git repositories into new darcs repositories."- , "Further options are accepted (see `darcs help init`)."- , ""- , "To convert a git repo to a new darcs one you may run:"- , "    $ (cd gitrepo && git fast-export --all -M) | darcs convert import darcsmirror"- , ""- , "WARNING: git repositories with branches will produce weird results,"- , "         use at your own risks."- , ""- , "Incremental import with marksfiles is currently not supported."- ]--convert :: DarcsCommand [DarcsFlag]-convert = SuperCommand-    { commandProgramName = "darcs"-    , commandName = "convert"-    , commandHelp = ""-    , commandDescription = convertDescription-    , commandPrereq = amInRepository-    , commandSubCommands =-        [ normalCommand convertDarcs2-        , normalCommand convertExport-        , normalCommand convertImport-        ]-    }--convertDarcs2 :: DarcsCommand [DarcsFlag]-convertDarcs2 = DarcsCommand-    { commandProgramName = "darcs"-    , commandName = "darcs-2"-    , commandHelp = convertHelp-    , commandDescription = "Convert darcs-1 repository to the darcs-2 patch format"-    , commandExtraArgs = -1-    , commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"]-    , commandCommand = toDarcs2-    , commandPrereq = \_ -> return $ Right ()-    , commandCompleteArgs = noArgs-    , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc convertDarcs2AdvancedOpts-    , commandBasicOptions = odesc convertDarcs2BasicOpts-    , commandDefaults = defaultFlags (convertDarcs2Opts ^ convertDarcs2SilentOpts)-    , commandCheckOptions = ocheck convertDarcs2Opts-    , commandParseOptions = onormalise convertDarcs2Opts-    }-  where-    convertDarcs2BasicOpts = O.reponame ^ O.setScriptsExecutable ^ O.withWorkingDir-    convertDarcs2AdvancedOpts = O.network ^ O.patchIndexNo-    convertDarcs2Opts = convertDarcs2BasicOpts `withStdOpts` convertDarcs2AdvancedOpts-    convertDarcs2SilentOpts = O.patchFormat--convertExport :: DarcsCommand [DarcsFlag]-convertExport = DarcsCommand-    { commandProgramName = "darcs"-    , commandName = "export"-    , commandHelp = convertExportHelp-    , commandDescription = "Export a darcs repository to a git-fast-import stream"-    , commandExtraArgs = 0-    , commandExtraArgHelp = []-    , commandCommand = fastExport-    , commandPrereq = amInRepository-    , commandCompleteArgs = noArgs-    , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc convertExportAdvancedOpts-    , commandBasicOptions = odesc convertExportBasicOpts-    , commandDefaults = defaultFlags convertExportOpts-    , commandCheckOptions = ocheck convertExportOpts-    , commandParseOptions = onormalise convertExportOpts-    }-  where-    convertExportBasicOpts = O.reponame ^ O.marks-    convertExportAdvancedOpts = O.network-    convertExportOpts = convertExportBasicOpts `withStdOpts` convertExportAdvancedOpts--convertImport :: DarcsCommand [DarcsFlag]-convertImport = DarcsCommand-    { commandProgramName = "darcs"-    , commandName = "import"-    , commandHelp = convertImportHelp-    , commandDescription = "Import from a git-fast-export stream into darcs"-    , commandExtraArgs = -1-    , commandExtraArgHelp = ["[<DIRECTORY>]"]-    , commandCommand = fastImport-    , commandPrereq = \_ -> return $ Right ()-    , commandCompleteArgs = noArgs-    , commandArgdefaults = nodefaults-    , commandAdvancedOptions = odesc convertImportAdvancedOpts-    , commandBasicOptions = odesc convertImportBasicOpts-    , commandDefaults = defaultFlags convertImportOpts-    , commandCheckOptions = ocheck convertImportOpts-    , commandParseOptions = onormalise convertImportOpts-    }-  where-    convertImportBasicOpts-      = O.reponame-      ^ O.setScriptsExecutable-      ^ O.patchFormat-      ^ O.withWorkingDir-    convertImportAdvancedOpts = O.patchIndexNo-    convertImportOpts = convertImportBasicOpts `withStdOpts` convertImportAdvancedOpts--toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-toDarcs2 _ opts' args = do-  (inrepodir, opts) <--    case args of-      [arg1, arg2] -> return (arg1, NewRepo arg2:opts')-      [arg1] -> return (arg1, opts')-      _ -> fail "You must provide either one or two arguments."-  typed_repodir <- ioAbsoluteOrRemote inrepodir-  let repodir = toPath typed_repodir--  format <- identifyRepoFormat repodir-  when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."--  putStrLn convertHelp'-  let vow = "I understand the consequences of my action"-  putStrLn "Please confirm that you have read and understood the above"-  vow' <- askUser ("by typing `" ++ vow ++ "': ")-  when (vow' /= vow) $ fail "User didn't understand the consequences."--  unless (quiet opts) $ showMotd repodir--  mysimplename <- makeRepoName opts repodir-  withUMaskFlag (umask ? opts) $ withNewDirectory mysimplename $ do-    repo <- createRepositoryV2-      (withWorkingDir ? opts) (patchIndexNo ? opts) (O.useCache ? opts)-    revertRepositoryChanges repo NoUpdateWorking--    withRepositoryLocation (useCache ? opts) repodir $ V1Job $ \other -> do-      theirstuff <- readRepo other-      let patches = mapFL_FL (convertNamed . hopefully) $ patchSet2FL theirstuff-          outOfOrderTags = catMaybes $ mapRL oot $ patchSet2RL theirstuff-              where oot t = if isTag (info t) && info t `notElem` inOrderTags theirstuff-                            then Just (info t, Wrapped.getdeps $ hopefully t)-                            else Nothing-          fixDep p = case lookup p outOfOrderTags of-                     Just d -> p : concatMap fixDep d-                     Nothing -> [p]-          primV1toV2 = V2.Prim . V1.unPrim-          convertOne :: RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY-          convertOne x | V1.isMerger x =-            let ex = mapFL_FL primV1toV2 (effect x) in-            case mergeUnravelled $ map (mapSeal (mapFL_FL primV1toV2)) $ publicUnravel x of-             Just (FlippedSeal y) ->-                 case effect y =/\= ex of-                 IsEq -> y :>: NilFL-                 NotEq ->-                     traceDoc (text "lossy conversion:" $$-                               showPatch ForDisplay x)-                     fromPrims ex-             Nothing -> traceDoc (text-                                  "lossy conversion of complicated conflict:" $$-                                  showPatch ForDisplay x)-                        fromPrims ex-          convertOne (V1.PP x) = fromPrim (primV1toV2 x) :>: NilFL-          convertOne _ = impossible-          convertFL :: FL RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY-          convertFL = concatFL . mapFL_FL convertOne-          convertNamed :: WrappedNamed ('RepoType 'NoRebase) RepoPatchV1 wX wY-                       -> PatchInfoAnd ('RepoType 'NoRebase) RepoPatchV2 wX wY-          convertNamed (NormalP n)-                         = n2pia $ NormalP $-                           adddeps (infopatch (convertInfo $ patch2patchinfo n) $-                                              convertFL $ patchcontents n)-                                   (map convertInfo $ concatMap fixDep $ getdeps n)-          convertInfo n | n `elem` inOrderTags theirstuff = n-                        | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n--      -- Note: we use bunchFL so we can commit every 100 patches-      _ <- applyAll opts repo $ bunchFL 100 $ progressFL "Converting patch" patches-      when (parseFlags O.setScriptsExecutable opts == O.YesSetScriptsExecutable)-        R.setScriptsExecutable--      -- Copy over the prefs file-      let prefsRelPath = darcsdir </> "prefs" </> "prefs"-      (fetchFilePS (repodir </> prefsRelPath) Uncachable >>= B.writeFile prefsRelPath)-       `catchall` return ()--      putInfo opts $ text "Finished converting."-  where-    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)-    applyOne opts (W2 r) x = do-      r' <- tentativelyAddPatch_ (updatePristine opts) r-        GzipCompression (verbosity ? opts) (updateWorking opts) x-      r'' <- withTryAgainMsg $ applyToWorking r' (verbosity ? opts) (effect x)-      invalidateIndex r''-      return (W2 r'')--    applySome opts (W3 r) xs = do-      r' <- unW2 <$> foldFL_M (applyOne opts) (W2 r) xs-      -- commit after applying a bunch of patches-      finalizeRepositoryChanges r' (updateWorking opts) GzipCompression-      revertRepositoryChanges r' (updateWorking opts)-      -- finalizeRepositoryChanges and revertRepositoryChanges-      -- do not (yet?) return a repo with properly coerced witnesses.-      -- We should have-      ---      -- > finalizeRepositoryChanges :: ... wR wU wT -> ... wT wU wT-      ---      -- and-      ---      -- > revertRepositoryChanges :: ... wR wU wT -> ... wR wU wR-      ---      -- This is why we must coerce here:-      return (W3 (coerceR r'))--    applyAll :: (IsRepoType rt, 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--    updatePristine :: [DarcsFlag] -> UpdatePristine-    updatePristine opts =-      case withWorkingDir ? opts of-        O.WithWorkingDir -> UpdatePristine-        -- this should not be necessary but currently is, because-        -- some commands (e.g. send) cannot cope with a missing pristine-        -- even if the repo is marked as having no working tree-        O.NoWorkingDir -> {- DontUpdatePristineNorRevert -}UpdatePristine--    updateWorking :: [DarcsFlag] -> UpdateWorking-    updateWorking opts =-      case withWorkingDir ? opts of-        O.WithWorkingDir -> YesUpdateWorking-        O.NoWorkingDir -> NoUpdateWorking--    withTryAgainMsg :: IO a -> IO a-    withTryAgainMsg x = x `clarifyErrors` unlines-      [ "An error occurred while applying patches to the working tree."-      , "You may have more luck if you supply --no-working-dir." ]---- | 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 (NewRepo n:_) _ =-    do exists <- doesDirectoryExist n-       file_exists <- doesFileExist n-       if exists || file_exists-          then fail $ "Directory or file named '" ++ n ++ "' already exists."-          else return n-makeRepoName (_:as) d = makeRepoName as d-makeRepoName [] d =-  case dropWhile (=='.') $ reverse $-       takeWhile (\c -> c /= '/' && c /= ':') $-       dropWhile (=='/') $ reverse d of-  "" -> modifyRepoName "anonymous_repo"-  base -> modifyRepoName base--modifyRepoName :: String -> IO String-modifyRepoName name =-    if head name == '/'-    then mrn name (-1)-    else do cwd <- getCurrentDirectory-            mrn (cwd ++ "/" ++ name) (-1)- where-  mrn :: String -> Int -> IO String-  mrn n i = do-    exists <- doesDirectoryExist thename-    file_exists <- doesFileExist thename-    if not exists && not file_exists-       then do when (i /= -1) $-                    putStrLn $ "Directory '"++ n ++-                               "' already exists, creating repository as '"++-                               thename ++"'"-               return thename-       else mrn n $ i+1-    where thename = if i == -1 then n else n++"_"++show i--fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-fastExport _ opts _ = do-  let repodir = fromMaybe "." $ getRepourl opts-  marks <- case parseFlags O.readMarks opts of-    Nothing -> return emptyMarks-    Just f  -> readMarks f-  newMarks <- withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> fastExport' repo marks-  case parseFlags O.writeMarks opts of-    Nothing -> return ()-    Just f  -> writeMarks f newMarks--fastExport' :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-            => Repository rt p r u r -> Marks -> IO Marks-fastExport' repo marks = do-  putStrLn "progress (reading repository)"-  patchset <- readRepo repo-  marksref <- newIORef marks-  let patches = patchSet2FL patchset-      tags = inOrderTags patchset-      mark :: (PatchInfoAnd rt 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 ()-      checkOne n p = do apply p-                        unless (inOrderTag tags p ||-                                (getMark marks n == Just (patchHash p))) $-                          fail $ "FATAL: Marks do not correspond: expected " ++-                                 show (getMark marks n) ++ ", got " ++ BC.unpack (patchHash p)-      -- build the working tree of the last version exported by convert --export-      check :: (RepoPatch p, ApplyState p ~ Tree)-            => Int -> FL (PatchInfoAnd rt p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd rt p)) y) -      check _ NilFL = return (1, flipSeal NilFL)-      check n allps@(p:>:ps)-        | n <= lastMark marks = checkOne n p >> check (next tags n p) ps-        | n > lastMark marks = return (n, flipSeal allps)-        | lastMark marks == 0 = return (1, flipSeal allps)-        | otherwise = undefined-  ((n, patches'), tree') <- hashedTreeIO (check 1 patches) emptyTree $ darcsdir </> "pristine.hashed"-  let patches'' = unsafeUnsealFlipped patches'-  void $ hashedTreeIO (dumpPatches tags mark n patches'') tree' $ darcsdir </> "pristine.hashed"-  readIORef marksref- `finally` do-  putStrLn "progress (cleaning up)"-  current <- readHashedPristineRoot repo-  cleanHashdir (repoCache repo) HashedPristineDir $ catMaybes [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 ()-dumpPatches _ _ _ NilFL = liftIO $ putStrLn "progress (patches converted)"-dumpPatches tags mark n (p:>:ps) = do-  apply p-  if inOrderTag tags p && n > 0-     then dumpTag p n-     else do dumpPatch mark p n-             dumpFiles $ map floatPath $ listTouchedFiles p-  dumpPatches tags mark (next tags n p) ps--dumpTag :: (PatchInfoAnd rt p) x y  -> Int -> TreeIO () -dumpTag p n =-  dumpBits [ BLU.fromString $ "progress TAG " ++ cleanTagName p-           , BLU.fromString $ "tag " ++ cleanTagName p -- FIXME is this valid?-           , BLU.fromString $ "from :" ++ show (n - 1)-           , BLU.fromString $ unwords ["tagger", patchAuthor p, patchDate p]-           -- -3 == (-4 for "TAG " and +1 for newline)-           , BLU.fromString $ "data "-                 ++ show (BL.length (patchMessage p) - 3)-           , BL.drop 4 $ patchMessage p ]-   where-     -- FIXME forbidden characters and subsequences in tags:-     -- https://www.kernel.org/pub/software/scm/git/docs/git-check-ref-format.html-     cleanTagName = map cleanup . drop 4 . piName . info-         where cleanup x | x `elem` bad = '_'-                         | otherwise = x-               bad :: String-               bad = " ~^:"--dumpFiles :: [AnchoredPath] -> TreeIO ()-dumpFiles files = forM_ files $ \file -> do-  let quotedPath = quotePath $ anchorPath "" file-  isfile <- fileExists file-  isdir <- directoryExists file-  when isfile $ do bits <- readFile file-                   dumpBits [ BLU.fromString $ "M 100644 inline " ++ quotedPath-                            , BLU.fromString $ "data " ++ show (BL.length bits)-                            , bits ]-  when isdir $ do -- Always delete directory before dumping its contents. This fixes-                  -- a corner case when a same patch moves dir1 to dir2, and creates-                  -- another directory dir1.-                  -- As we always dump its contents anyway this is not more costly.-                  liftIO $ putStrLn $ "D " ++ anchorPath "" file-                  tt <- gets tree -- ick-                  let subs = [ file `appendPath` n | (n, _) <--                                  listImmediate $ fromJust $ findTree tt file ]-                  dumpFiles subs-  when (not isfile && not isdir) $ liftIO $ putStrLn $ "D " ++ anchorPath "" file-  where-    -- |quotePath escapes and quotes paths containing newlines, double-quotes-    -- or backslashes.-    quotePath :: FilePath -> String-    quotePath path = case foldr escapeChars ("", False) path of-        (_, False) -> path-        (path', True) -> quote path'--    quote str = "\"" ++ str ++ "\""--    escapeChars c (processed, haveEscaped) = case escapeChar c of-        (escaped, didEscape) ->-            (escaped ++ processed, didEscape || haveEscaped)--    escapeChar c = case c of-        '\n' -> ("\\n", True)-        '\r' -> ("\\r", True)-        '"'  -> ("\\\"", True)-        '\\' -> ("\\\\", True)-        _    -> ([c], False)---dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())-          -> (PatchInfoAnd rt p) x y -> Int-          -> TreeIO ()-dumpPatch mark p n =-  do dumpBits [ BLU.fromString $ "progress " ++ show n ++ ": " ++ piName (info p)-              , "commit refs/heads/master" ]-     mark p n-     dumpBits [ BLU.fromString $ "committer " ++ patchAuthor p ++ " " ++ patchDate p-              , BLU.fromString $ "data " ++ show (BL.length $ patchMessage p)-              , patchMessage p ]-     when (n > 1) $ dumpBits [ BLU.fromString $ "from :" ++ show (n - 1) ]--dumpBits :: [BL.ByteString] -> TreeIO ()-dumpBits = liftIO . BLC.putStrLn . BL.intercalate "\n"---- patchAuthor attempts to fixup malformed author strings--- into format: "Name <Email>"--- e.g.--- <john@home>      -> john <john@home>--- john@home        -> john <john@home>--- john <john@home> -> john <john@home>--- john <john@home  -> john <john@home>--- <john>           -> john <unknown>-patchAuthor :: (PatchInfoAnd rt p) x y -> String-patchAuthor p- | null author = unknownEmail "unknown"- | otherwise = case span (/='<') author of-               -- No name, but have email (nothing spanned)-               ("", email) -> case span (/='@') (tail email) of-                   -- Not a real email address (no @).-                   (n, "") -> case span (/='>') n of-                       (name, _) -> unknownEmail name-                   -- A "real" email address.-                   (user, rest) -> case span (/= '>') (tail rest) of-                       (dom, _) -> mkAuthor user $ emailPad (user ++ "@" ++ dom)-               -- No email (everything spanned)-               (_, "") -> case span (/='@') author of-                   (n, "") -> unknownEmail n-                   (name, _) -> mkAuthor name $ emailPad author-               -- Name and email-               (n, rest) -> case span (/='>') $ tail rest of-                   (email, _) -> n ++ emailPad email- where-   author = dropWhile isSpace $ piAuthor (info p)-   unknownEmail = flip mkAuthor "<unknown>"-   emailPad email = "<" ++ email ++ ">"-   mkAuthor name email = name ++ " " ++ email--patchDate :: (PatchInfoAnd rt p) x y -> String-patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime .-  piDate . info--patchMessage :: (PatchInfoAnd rt p) x y -> BLU.ByteString-patchMessage p = BL.concat [ BLU.fromString (piName $ info p)-                           , case unlines . piLog $ info p of-                                 "" -> BL.empty-                                 plog -> BLU.fromString ("\n\n" ++ plog)-                           ]--type Marked = Maybe Int-type Branch = B.ByteString-type AuthorInfo = B.ByteString-type Message = B.ByteString-type Content = B.ByteString-type Tag = B.ByteString--data RefId = MarkId Int | HashId B.ByteString | Inline-           deriving Show---- Newish (> 1.7.6.1) Git either quotes filenames or has two--- non-special-char-containing paths. Older git doesn't do any quoting, so--- we'll have to manually try and find the correct paths, when we use the--- paths.-data CopyRenameNames = Quoted B.ByteString B.ByteString-                     | Unquoted B.ByteString deriving Show--data Object = Blob (Maybe Int) Content-            | Reset Branch (Maybe RefId)-            | Commit Branch Marked AuthorInfo Message-            | Tag Tag Int AuthorInfo Message-            | Modify (Either Int Content) B.ByteString -- (mark or content), filename-            | Gitlink B.ByteString-            | Copy CopyRenameNames-            | Rename CopyRenameNames-            | Delete B.ByteString -- filename-            | From Int-            | Merge Int-            | Progress B.ByteString-            | End-            deriving Show--type Ancestors = (Marked, [Int])-data State p where-  Toplevel :: Marked -> Branch -> State p-  InCommit :: Marked -> Ancestors -> Branch -> Tree IO -> RL (PrimOf p) cX cY -> PatchInfo -> State p-  Done :: State p--instance Show (State p) where-  show Toplevel {} = "Toplevel"-  show InCommit {} = "InCommit"-  show Done =  "Done"--fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-fastImport _ opts [outrepo] =-  withUMaskFlag (umask ? opts) $ withNewDirectory outrepo $ do-    EmptyRepository repo <- createRepository-      (patchFormat ? opts)-      (withWorkingDir ? opts)-      (patchIndexNo ? opts)-      (useCache ? opts)-    -- TODO implement --dry-run, which would be read-only?-    marks <- fastImport' repo emptyMarks-    createPristineDirectoryTree repo "." (withWorkingDir ? opts)-    return marks-fastImport _ _ _ = fail "I need exactly one output repository."--fastImport' :: forall 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-    marksref <- newIORef marks-    let initial = Toplevel Nothing $ BC.pack "refs/branches/master"--        go :: State p -> B.ByteString -> TreeIO ()-        go state rest = do (rest', item) <- parseObject rest-                           state' <- process state item-                           case state' of-                             Done -> return ()-                             _ -> go state' rest'--        -- sort marks into buckets, since there can be a *lot* of them-        markpath :: Int -> AnchoredPath-        markpath n = floatPath (darcsdir </> "marks")-                        `appendPath` (makeName $ show (n `div` 1000))-                        `appendPath` (makeName $ show (n `mod` 1000))--        makeinfo author message tag = do-          let (name, log) = case BC.unpack message of-                                      "" -> ("Unnamed patch", [])-                                      msg -> (head &&& tail) . lines $ msg-              (author'', date'') = span (/='>') $ BC.unpack author-              date' = dropWhile (`notElem` ("0123456789" :: String)) date''-              author' = author'' ++ ">"-              date = formatDateTime "%Y%m%d%H%M%S" $ fromMaybe startOfTime (parseDateTime "%s %z" date')-          liftIO $ patchinfo date (if tag then "TAG " ++ name else name) author' log--        addtag author msg =-          do info_ <- makeinfo author msg True-             gotany <- liftIO $ doesFileExist $ darcsdir </> "tentative_hashed_pristine"-             deps <- if gotany then liftIO $-                                      getUncovered `fmap`-                                        readTentativeRepo repo (repoLocation repo)-                               else return []-             let ident = NilFL :: FL RepoPatchV2 cX cX-                 patch = NormalP (adddeps (infopatch info_ ident) deps)-             void $ liftIO $ addToTentativeInventory (repoCache repo)-                                                     GzipCompression (n2pia patch)--        -- processing items-        updateHashes = do-          let nodarcs = \(AnchoredPath (x:_)) _ -> x /= makeName darcsdir-              hashblobs (File blob@(T.Blob con NoHash)) =-                do hash <- sha256 `fmap` readBlob blob-                   return $ File (T.Blob con hash)-              hashblobs x = return x-          tree' <- liftIO . T.partiallyUpdateTree hashblobs nodarcs =<< gets tree-          modify $ \s -> s { tree = tree' }-          return $ T.filter nodarcs tree'--        -- Since git doesn't track directores it implicitly deletes-        -- them when they become empty. We should therefore remove any-        -- directories that become empty (except the repo-root-        -- directory!)-        deleteEmptyParents fp = do-          let directParent = parent fp-          unless (directParent == anchoredRoot) $ do-              parentTree <- flip findTree directParent <$> gets tree-              case (null . listImmediate) <$> parentTree of-                      Just True -> do TM.unlink directParent-                                      deleteEmptyParents directParent-                      -- Either missing (not possible) or non-empty.-                      _ -> return ()--        -- generate a Hunk primitive patch 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-          return $ InCommit mark ancestors branch current newps info_-        diffCurrent _ = error "This is never valid outside of a commit."--        process :: State p -> Object -> TreeIO (State p)-        process s (Progress p) = do-          liftIO $ putStrLn ("progress " ++ decodeLocale p)-          return s--        process (Toplevel _ _) End = do-          tree' <- (liftIO . darcsAddMissingHashes) =<< updateHashes-          modify $ \s -> s { tree = tree' } -- lets dump the right tree, without _darcs-          let root = encodeBase16 $ treeHash tree'-          liftIO $ do-            putStrLn "\\o/ It seems we survived. Enjoy your new repo."-            B.writeFile (darcsdir </> "tentative_pristine") $-              BC.concat [BC.pack "pristine:", root]-          return Done--        process (Toplevel n b) (Tag tag what author msg) = do-          if Just what == n-             then addtag author msg-             else liftIO $ putStrLn $-                    "WARNING: Ignoring out-of-order tag " ++ decodeLocale tag-          return (Toplevel n b)--        process (Toplevel n _) (Reset branch from) =-          do case from of-               (Just (MarkId k)) | Just k == n ->-                 addtag (BC.pack "Anonymous Tagger <> 0 +0000") branch-               _ -> liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " ++-                                        BC.unpack branch-             return $ Toplevel n branch--        process (Toplevel n b) (Blob (Just m) bits) = do-          TM.writeFile (markpath m) (BLC.fromChunks [bits])-          return $ Toplevel n b--        process x (Gitlink link) = do-          liftIO $ putStrLn $ "WARNING: Ignoring gitlink " ++ BC.unpack link-          return x--        process (Toplevel previous pbranch) (Commit branch mark author message) = do-          when (pbranch /= branch) $ do-            liftIO $ putStrLn ("Tagging branch: " ++ BC.unpack pbranch)-            addtag author pbranch-          info_ <- makeinfo author message False-          startstate <- updateHashes-          return $ InCommit mark (previous, []) branch startstate NilRL info_--        process s@InCommit {} (Modify (Left m) path) = do-          TM.copy (markpath m) (floatPath $ BC.unpack path)-          diffCurrent s--        process s@InCommit {} (Modify (Right bits) path) = do-          TM.writeFile (floatPath $ BC.unpack path) (BLC.fromChunks [bits])-          diffCurrent s--        process s@InCommit {} (Delete path) = do-          let floatedPath = floatPath $ BC.unpack path-          TM.unlink floatedPath-          deleteEmptyParents floatedPath-          diffCurrent s--        process (InCommit mark (prev, current) branch start ps info_) (From from) =-          return $ InCommit mark (prev, from:current) branch start ps info_--        process (InCommit mark (prev, current) branch start ps info_) (Merge from) =-          return $ InCommit mark (prev, from:current) branch start ps info_--        process s@InCommit {} (Copy names) = do-            (from, to) <- extractNames names-            TM.copy (floatPath $ BC.unpack from) (floatPath $ BC.unpack to)-            -- We can't tell Darcs that a file has been copied, so it'll-            -- show as an addfile.-            diffCurrent s--        process s@(InCommit mark ancestors branch start _ info_) (Rename names) = do-          (from, to) <- extractNames names-          let uFrom = BC.unpack from-              uTo = BC.unpack to-              parentDir = parent $ floatPath uTo-          targetDirExists <- liftIO $ treeHasDir start uTo-          targetFileExists <- liftIO $ treeHasFile start uTo-          parentDirExists <--              liftIO $ treeHasDir start (anchorPath "" parentDir)-          -- If the target exists, remove it; if it doesn't, add all-          -- its parent directories.-          if targetDirExists || targetFileExists-              then TM.unlink $ floatPath uTo-              else unless parentDirExists $ TM.createDirectory parentDir-          (InCommit _ _ _ _ newPs _) <- diffCurrent s-          TM.rename (floatPath uFrom) (floatPath uTo)-          let ps' = newPs :<: move uFrom uTo-          current <- updateHashes-          -- ensure empty dirs get deleted-          deleteEmptyParents (floatPath uFrom)-          -- run diffCurrent to add the dir deletions prims-          diffCurrent (InCommit mark ancestors branch current ps' info_)--        -- When we leave the commit, create a patch for the cumulated-        -- prims.-        process (InCommit mark ancestors branch _ ps info_) x = do-          case ancestors of-            (_, []) -> return () -- OK, previous commit is the ancestor-            (Just n, list)-              | n `elem` list -> return () -- OK, we base off one of the ancestors-              | otherwise -> liftIO $ putStrLn $-                               "WARNING: Linearising non-linear ancestry:" ++-                               " currently at " ++ show n ++ ", ancestors " ++ show list-            (Nothing, list) ->-              liftIO $ putStrLn $ "WARNING: Linearising non-linear ancestry " ++ show list--          {- current <- updateHashes -} -- why not?-          (prims :: FL p cX cY)  <- return $ fromPrims $ sortCoalesceFL $ reverseRL ps-          let patch = NormalP (infopatch info_ ((NilFL :: FL p cX cX) +>+ prims))-          void $ liftIO $ addToTentativeInventory (repoCache repo)-                                                  GzipCompression (n2pia patch)-          case mark of-            Nothing -> return ()-            Just n -> case getMark marks n of-              Nothing -> liftIO $ modifyIORef marksref $ \m -> addMark m n (patchHash $ n2pia patch)-              Just n' -> fail $ "FATAL: Mark already exists: " ++ BC.unpack n'-          process (Toplevel mark branch) x--        process state obj = do-          liftIO $ print obj-          fail $ "Unexpected object in state " ++ show state--        extractNames :: CopyRenameNames-                     -> TreeIO (BC.ByteString, BC.ByteString)-        extractNames names = case names of-            Quoted f t -> return (f, t)-            Unquoted uqNames -> do-                let spaceIndices = BC.elemIndices ' ' uqNames-                    splitStr = second (BC.drop 1) . flip BC.splitAt uqNames-                    -- Reverse the components, so we find the longest-                    -- prefix existing name.-                    spaceComponents = reverse $ map splitStr spaceIndices-                    componentCount = length spaceComponents-                if componentCount == 1-                    then return $ head spaceComponents-                    else do-                        let dieMessage = unwords-                                [ "Couldn't determine move/rename"-                                , "source/destination filenames, with the"-                                , "data produced by this (old) version of"-                                , "git, since it uses unquoted, but"-                                , "special-character-containing paths."-                                ]-                            floatUnpack = floatPath . BC.unpack-                            lPathExists (l,_) =-                                TM.fileExists $ floatUnpack l-                            finder [] = error dieMessage-                            finder (x : rest) = do-                                xExists <- lPathExists x-                                if xExists then return x else finder rest-                        finder spaceComponents--    void $ hashedTreeIO (go initial B.empty) pristine $ darcsdir </> "pristine.hashed"-    finalizeRepositoryChanges repo YesUpdateWorking GzipCompression-    cleanRepository repo--parseObject :: BC.ByteString -> TreeIO ( BC.ByteString, Object )-parseObject = next' mbObject-  where mbObject = A.parse p_maybeObject--        p_maybeObject = Just `fmap` p_object-                        <|> (A.endOfInput >> return Nothing)--        lex p = p >>= \x -> A.skipSpace >> return x-        lexString s = A.string (BC.pack s) >> A.skipSpace-        line = lex $ A.takeWhile (/='\n')--        optional p = Just `fmap` p <|> return Nothing--        p_object = p_blob-                   <|> p_reset-                   <|> p_commit-                   <|> p_tag-                   <|> p_modify-                   <|> p_rename-                   <|> p_copy-                   <|> p_from-                   <|> p_merge-                   <|> p_delete-                   <|> (lexString "progress" >> Progress `fmap` line)--        p_author name = lexString name >> line--        p_reset = do lexString "reset"-                     branch <- line-                     refid <- optional $ lexString "from" >> p_refid-                     return $ Reset branch refid--        p_commit = do lexString "commit"-                      branch <- line-                      mark <- optional p_mark-                      _ <- optional $ p_author "author"-                      committer <- p_author "committer"-                      message <- p_data-                      return $ Commit branch mark committer message--        p_tag = do _ <- lexString "tag"-                   tag <- line-                   lexString "from"-                   mark <- p_marked-                   author <- p_author "tagger"-                   message <- p_data-                   return $ Tag tag mark author message--        p_blob = do lexString "blob"-                    mark <- optional p_mark-                    Blob mark `fmap` p_data-                  <?> "p_blob"--        p_mark = do lexString "mark"-                    p_marked-                  <?> "p_mark"--        p_refid = MarkId `fmap` p_marked-                  <|> (lexString "inline" >> return Inline)-                  <|> HashId `fmap` p_hash--        p_data = do lexString "data"-                    len <- A.decimal-                    _ <- A.char '\n'-                    lex $ A.take len-                  <?> "p_data"--        p_marked = lex $ A.char ':' >> A.decimal-        p_hash = lex $ A.takeWhile1 (A.inClass "0123456789abcdefABCDEF")-        p_from = lexString "from" >> From `fmap` p_marked-        p_merge = lexString "merge" >> Merge `fmap` p_marked-        p_delete = lexString "D" >> Delete `fmap` p_maybeQuotedName-        p_rename = do lexString "R"-                      names <- p_maybeQuotedCopyRenameNames-                      return $ Rename names-        p_copy = do lexString "C"-                    names <- p_maybeQuotedCopyRenameNames-                    return $ Copy names-        p_modify = do lexString "M"-                      mode <- lex $ A.takeWhile (A.inClass "01234567890")-                      mark <- p_refid-                      path <- p_maybeQuotedName-                      case mark of-                        HashId hash | mode == BC.pack "160000" -> return $ Gitlink hash-                                    | otherwise -> fail ":(("-                        MarkId n -> return $ Modify (Left n) path-                        Inline -> do bits <- p_data-                                     return $ Modify (Right bits) path-        p_maybeQuotedCopyRenameNames =-            p_lexTwoQuotedNames <|> Unquoted `fmap` line-        p_lexTwoQuotedNames = do-            n1 <- lex p_quotedName-            n2 <- lex p_quotedName-            return $ Quoted n1 n2-        p_maybeQuotedName = lex (p_quotedName <|> line)-        p_quotedName = do-          _ <- A.char '"'-          -- Take until a non-escaped " character.-          name <- A.scan Nothing-            (\previous char -> if char == '"' && previous /= Just '\\'-               then Nothing else Just (Just char))-          _ <- A.char '"'-          return $ unescape name---        next' :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)-        next' parser rest =-          do chunk <- if B.null rest then liftIO $ B.hGet stdin (64 * 1024)-                                     else return rest-             next_chunk parser chunk--        next_chunk :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)-        next_chunk parser chunk =-          case parser chunk of-             A.Done rest result -> return (rest, maybe End id result) -- not sure about the maybe-             A.Partial cont -> next' cont B.empty-             A.Fail _ ctx err -> do-               liftIO $ putStrLn $ "=== chunk ===\n" ++ BC.unpack chunk ++ "\n=== end chunk ===="-               fail $ "Error parsing stream. " ++ err ++ "\nContext: " ++ show ctx---patchHash :: PatchInfoAnd rt p cX cY -> BC.ByteString-patchHash p = BC.pack $ show $ makePatchname (info p)--inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd rt 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 tags n p = if inOrderTag tags p then n else n + 1--inOrderTags :: PatchSet rt 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'-        go NilRL = []--type Marks = M.IntMap BC.ByteString--emptyMarks :: Marks-emptyMarks = M.empty--lastMark :: Marks -> Int-lastMark m = if M.null m then 0 else fst $ M.findMax m--getMark :: Marks -> Int -> Maybe BC.ByteString-getMark marks key = M.lookup key marks--addMark :: Marks -> Int -> BC.ByteString -> Marks-addMark marks key value = M.insert key value marks--readMarks :: FilePath -> IO Marks-readMarks p = do lines' <- BC.split '\n' `fmap` BC.readFile p-                 return $ foldl merge M.empty lines'-               `catchall` return emptyMarks-  where merge set line = case BC.split ':' line of-          [i, hash] -> M.insert (read $ BC.unpack i) (BC.dropWhile (== ' ') hash) set-          _ -> set -- ignore, although it is maybe not such a great idea...--writeMarks :: FilePath -> Marks -> IO ()-writeMarks fp m = do removeFile fp `catchall` return () -- unlink-                     BC.writeFile fp marks-  where marks = BC.concat $ map format $ M.assocs m-        format (k, s) = BC.concat [BC.pack $ show k, BC.pack ": ", s, BC.pack "\n"]---- |unescape turns \r \n \" \\ into their unescaped form, leaving any--- other \-preceeded characters as they are.-unescape :: BC.ByteString -> BC.ByteString-unescape cs = case BC.uncons cs of-  Nothing -> BC.empty-  Just (c', cs') -> if c' == '\\'-    then case BC.uncons cs' of-      Nothing -> BC.empty-      Just (c'', cs'') -> let unescapedC = case c'' of-                                'r'  -> '\r'-                                'n'  -> '\n'-                                '"'  -> '"'-                                '\\' -> '\\'-                                x    -> x in-        BC.cons unescapedC $ unescape cs''-    else BC.cons c' $ unescape cs'-+module Darcs.UI.Commands.Convert ( convert ) where++import Darcs.Prelude++import Darcs.UI.Commands (DarcsCommand(..), amInRepository, normalCommand)+import Darcs.UI.Commands.Convert.Darcs2 (convertDarcs2)+import Darcs.UI.Commands.Convert.Import (convertImport)+import Darcs.UI.Commands.Convert.Export (convertExport)+import Darcs.Util.Printer ( text, ($+$) )++convertDescription :: String+convertDescription = "Convert repositories between various formats."++convert :: DarcsCommand+convert = SuperCommand+    { commandProgramName = "darcs"+    , commandName = "convert"+    , commandHelp =+        text convertDescription $+$+        text "See description of the subcommands for details."+    , commandDescription = convertDescription+    , commandPrereq = amInRepository+    , commandSubCommands =+        [ normalCommand convertDarcs2+        , normalCommand convertExport+        , normalCommand convertImport+        ]+    }
+ src/Darcs/UI/Commands/Convert/Darcs2.hs view
@@ -0,0 +1,299 @@+--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Convert.Darcs2 ( convertDarcs2 ) where++import Control.Monad ( when, unless )+import qualified Data.ByteString as B+import Data.Maybe ( catMaybes )+import Data.List ( lookup )+import System.FilePath.Posix ( (</>) )+import System.Directory ( doesDirectoryExist, doesFileExist )++import Darcs.Prelude++import Darcs.Patch ( RepoPatch, effect, displayPatch )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Info ( isTag, piRename, piTag )+import Darcs.Patch.Named ( Named(..), getdeps, patch2patchinfo, patchcontents )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia )+import Darcs.Patch.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 )+import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(PP), isMerger )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )+import qualified Darcs.Patch.V2.RepoPatch as V2 ( RepoPatchV2(Normal) )+import Darcs.Patch.V2.RepoPatch ( mergeUnravelled )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=/\=) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , bunchFL+    , concatFL+    , foldFL_M+    , mapFL_FL+    , mapRL+    )+import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), mapSeal )++import Darcs.Repository+    ( RepoJob(..)+    , Repository+    , applyToWorking+    , createRepositoryV2+    , finalizeRepositoryChanges+    , invalidateIndex+    , readRepo+    , revertRepositoryChanges+    , withRepositoryLocation+    , withUMaskFlag+    )+import qualified Darcs.Repository as R ( setScriptsExecutable )+import Darcs.Repository.Flags ( Compression(..), UpdatePending(..) )+import Darcs.Repository.Format+    ( RepoProperty(Darcs2)+    , formatHas+    , identifyRepoFormat+    )+import Darcs.Repository.Hashed ( UpdatePristine(..), tentativelyAddPatch_ )+import Darcs.Repository.Prefs ( showMotd, prefsFilePath )++import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, putFinished, withStdOpts )+import Darcs.UI.Commands.Convert.Util ( updatePending )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags+    ( verbosity, useCache, umask, withWorkingDir, patchIndexNo+    , DarcsFlag, withNewRepo+    , quiet+    )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )+import qualified Darcs.UI.Options.All as O++import Darcs.Util.External ( fetchFilePS, Cachable(Uncachable) )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Lock ( withNewDirectory )+import Darcs.Util.Path( ioAbsoluteOrRemote, toPath, AbsolutePath )+import Darcs.Util.Printer ( Doc, text, ($$) )+import Darcs.Util.Printer.Color ( traceDoc )+import Darcs.Util.Prompt ( askUser )+import Darcs.Util.Tree( Tree )+import Darcs.Util.Workaround ( getCurrentDirectory )++type RepoPatchV1 = V1.RepoPatchV1 V1.Prim+type RepoPatchV2 = V2.RepoPatchV2 V2.Prim++convertDarcs2Help :: Doc+convertDarcs2Help = text $ unlines+ [ "This command converts a repository that uses the old patch semantics"+ , "`darcs-1` to a new repository with current `darcs-2` semantics."+ , ""+ , convertDarcs2Help'+ ]++-- | This part of the help is split out because it is used twice: in+-- the help string, and in the prompt for confirmation.+convertDarcs2Help' :: String+convertDarcs2Help' = unlines+ [ "WARNING: the repository produced by this command is not understood by"+ , "Darcs 1.x, and patches cannot be exchanged between repositories in"+ , "darcs-1 and darcs-2 formats."+ , ""+ , "Furthermore, repositories created by different invocations of"+ , "this command SHOULD NOT exchange patches."+ ]++convertDarcs2 :: DarcsCommand+convertDarcs2 = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "darcs-2"+    , commandHelp = convertDarcs2Help+    , commandDescription = "Convert darcs-1 repository to the darcs-2 patch format"+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"]+    , commandCommand = toDarcs2+    , commandPrereq = \_ -> return $ Right ()+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandAdvancedOptions = odesc convertDarcs2AdvancedOpts+    , commandBasicOptions = odesc convertDarcs2BasicOpts+    , commandDefaults = defaultFlags (convertDarcs2Opts ^ convertDarcs2SilentOpts)+    , commandCheckOptions = ocheck convertDarcs2Opts+    }+  where+    convertDarcs2BasicOpts = O.newRepo ^ O.setScriptsExecutable ^ O.withWorkingDir+    convertDarcs2AdvancedOpts = O.network ^ O.patchIndexNo ^ O.umask+    convertDarcs2Opts = convertDarcs2BasicOpts `withStdOpts` convertDarcs2AdvancedOpts+    convertDarcs2SilentOpts = O.patchFormat++toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+toDarcs2 _ opts' args = do+  (inrepodir, opts) <-+    case args of+      [arg1, arg2] -> return (arg1, withNewRepo arg2 opts')+      [arg1] -> return (arg1, opts')+      _ -> fail "You must provide either one or two arguments."+  typed_repodir <- ioAbsoluteOrRemote inrepodir+  let repodir = toPath typed_repodir++  format <- identifyRepoFormat repodir+  when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."++  putStrLn convertDarcs2Help'+  let vow = "I understand the consequences of my action"+  putStrLn "Please confirm that you have read and understood the above"+  vow' <- askUser ("by typing `" ++ vow ++ "': ")+  when (vow' /= vow) $ fail "User didn't understand the consequences."++  unless (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++    withRepositoryLocation (useCache ? opts) repodir $ V1Job $ \other -> do+      theirstuff <- readRepo other+      let patches = mapFL_FL (convertNamed . hopefully) $ patchSet2FL theirstuff+          outOfOrderTags = catMaybes $ mapRL oot $ patchSet2RL theirstuff+              where oot t = if isTag (info t) && info t `notElem` inOrderTags theirstuff+                            then Just (info t, getdeps $ hopefully t)+                            else Nothing+          fixDep p = case lookup p outOfOrderTags of+                     Just d -> p : concatMap fixDep d+                     Nothing -> [p]+          primV1toV2 = V2.Prim . V1.unPrim+          convertOne :: RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY+          convertOne x | V1.isMerger x =+            let ex = mapFL_FL primV1toV2 (effect x) in+            case mergeUnravelled $ map (mapSeal (mapFL_FL primV1toV2)) $ publicUnravel x of+             Just (FlippedSeal y) ->+                 case effect y =/\= ex of+                 IsEq -> y :>: NilFL+                 NotEq ->+                     traceDoc (text "lossy conversion:" $$+                               displayPatch x) $+                     mapFL_FL V2.Normal ex+             Nothing -> traceDoc (text+                                  "lossy conversion of complicated conflict:" $$+                                  displayPatch x) $+                        mapFL_FL V2.Normal ex+          convertOne (V1.PP x) = V2.Normal (primV1toV2 x) :>: NilFL+          convertOne _ = error "impossible case"+          convertFL :: FL RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY+          convertFL = concatFL . mapFL_FL convertOne+          convertNamed :: Named RepoPatchV1 wX wY+                       -> PatchInfoAnd ('RepoType 'NoRebase) RepoPatchV2 wX wY+          convertNamed n = n2pia $+                           NamedP+                            (convertInfo $ patch2patchinfo n)+                            (map convertInfo $ concatMap fixDep $ getdeps n)+                            (convertFL $ patchcontents n)+          convertInfo n | n `elem` inOrderTags theirstuff = n+                        | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n++      -- Note: we use bunchFL so we can commit every 100 patches+      _ <- applyAll opts _repo $ bunchFL 100 $ progressFL "Converting patch" patches+      when (parseFlags O.setScriptsExecutable opts == O.YesSetScriptsExecutable)+        R.setScriptsExecutable++      -- Copy over the prefs file+      (fetchFilePS (repodir </> prefsFilePath) Uncachable >>= B.writeFile prefsFilePath)+       `catchall` return ()++      putFinished opts "converting"+  where+    applyOne :: (RepoPatch p, ApplyState p ~ Tree)+             => [DarcsFlag]+             -> W2 (Repository rt p wR) wX+             -> PatchInfoAnd rt p wX wY+             -> IO (W2 (Repository rt p wR) wY)+    applyOne opts (W2 _repo) x = do+      _repo <- tentativelyAddPatch_ (updatePristine opts) _repo+        GzipCompression (verbosity ? opts) (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)+             => [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++    updatePristine :: [DarcsFlag] -> UpdatePristine+    updatePristine opts =+      case withWorkingDir ? opts of+        O.WithWorkingDir -> UpdatePristine+        -- this should not be necessary but currently is, because+        -- some commands (e.g. send) cannot cope with a missing pristine+        -- even if the repo is marked as having no working tree+        O.NoWorkingDir -> {- DontUpdatePristineNorRevert -}UpdatePristine++-- | Need this to make 'foldFL_M' work with a function that changes+-- the last two (identical) witnesses at the same time.+newtype W2 r wX = W2 {unW2 :: r wX wX}++-- | 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 =+  case O.newRepo ? opts of+    Just n -> do+      exists <- doesDirectoryExist n+      file_exists <- doesFileExist n+      if exists || file_exists+        then fail $ "Directory or file named '" ++ n ++ "' already exists."+        else return n+    Nothing ->+      case dropWhile (== '.') $+           reverse $+           takeWhile (\c -> c /= '/' && c /= ':') $+           dropWhile (== '/') $ reverse d of+        "" -> modifyRepoName "anonymous_repo"+        base -> modifyRepoName base++modifyRepoName :: String -> IO String+modifyRepoName name =+    if head name == '/'+    then mrn name (-1)+    else do cwd <- getCurrentDirectory+            mrn (cwd ++ "/" ++ name) (-1)+ where+  mrn :: String -> Int -> IO String+  mrn n i = do+    exists <- doesDirectoryExist thename+    file_exists <- doesFileExist thename+    if not exists && not file_exists+       then do when (i /= -1) $+                    putStrLn $ "Directory '"++ n +++                               "' already exists, creating repository as '"+++                               thename ++"'"+               return thename+       else mrn n $ i+1+    where thename = if i == -1 then n else n++"_"++show i
+ src/Darcs/UI/Commands/Convert/Export.hs view
@@ -0,0 +1,368 @@+--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}++module Darcs.UI.Commands.Convert.Export ( convertExport ) where++import Darcs.Prelude hiding ( readFile, lex )++import Control.Exception (finally)+import Control.Monad (forM_, unless, void, when)+import Control.Monad.State.Strict (gets)+import Control.Monad.Trans (liftIO)++import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString.Lazy.UTF8 as BLU+import Data.Char (isSpace)+import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.Maybe (catMaybes, fromJust)+import System.Time (toClockTime)++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch ( RepoPatch, apply, effect, listTouchedFiles )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Effect ( Effect )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , nullFL+    )+import Darcs.Patch.Witnesses.Sealed+    ( FlippedSeal(..)+    , flipSeal+    , unsealFlipped+    )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++import Darcs.Patch.Info+    ( PatchInfo+    , isTag+    , piAuthor+    , piDate+    , piLog+    , piName+    )+import Darcs.Patch.RepoType ( IsRepoType(..) )+import Darcs.Patch.Set ( patchSet2FL, inOrderTags )++import Darcs.Repository+    ( RepoJob(..)+    , Repository+    , readRepo+    , 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.UI.Commands+    ( DarcsCommand(..)+    , amInRepository+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Commands.Convert.Util+    ( Marks+    , addMark+    , emptyMarks+    , getMark+    , lastMark+    , readMarks+    , writeMarks+    , patchHash+    )+import Darcs.UI.Completion (noArgs)+import Darcs.UI.Flags ( DarcsFlag , useCache )+import Darcs.UI.Options+    ( (?)+    , (^)+    , defaultFlags+    , ocheck+    , odesc+    , parseFlags+    )+import qualified Darcs.UI.Options.All as O++import Darcs.Util.DateTime ( formatDateTime, fromClockTime )+import Darcs.Util.Path+    ( AbsolutePath+    , AnchoredPath(..)+    , anchorPath+    , appendPath+    )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Tree+    ( Tree+    , emptyTree+    , findTree+    , listImmediate+    )+import Darcs.Util.Tree.Hashed ( hashedTreeIO )++import Darcs.Util.Tree.Monad ( TreeIO )+import qualified Darcs.Util.Tree.Monad as T+    ( directoryExists+    , fileExists+    , readFile+    , tree+    )+++convertExportHelp :: Doc+convertExportHelp = text $ unlines+ [ "This command enables you to export darcs repositories into git."+ , ""+ , "For a one-time export you can use the recipe:"+ , ""+ , "    $ cd repo"+ , "    $ git init ../mirror"+ , "    $ darcs convert export | (cd ../mirror && git fast-import)"+ , ""+ , "For incremental export using marksfiles:"+ , ""+ , "    $ cd repo"+ , "    $ git init ../mirror"+ , "    $ touch ../mirror/git.marks"+ , "    $ darcs convert export --read-marks darcs.marks --write-marks darcs.marks"+ , "       | (cd ../mirror && git fast-import --import-marks=git.marks --export-marks=git.marks)"+ , ""+ , "In the case of incremental export, be careful to never amend, delete or"+ , "reorder patches in the source darcs repository."+ , ""+ , "Also, be aware that exporting a darcs repo to git will not be exactly"+ , "faithful in terms of history if the darcs repository contains conflicts."+ , ""+ , "Limitations:"+ , ""+ , "  * Empty directories are not supported by the fast-export protocol."+ , "  * Unicode filenames are currently not correctly handled."+ , "    See http://bugs.darcs.net/issue2359 ."+ ]++convertExport :: DarcsCommand+convertExport = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "export"+    , commandHelp = convertExportHelp+    , commandDescription = "Export a darcs repository to a git-fast-import stream"+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = fastExport+    , commandPrereq = amInRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandAdvancedOptions = odesc convertExportAdvancedOpts+    , commandBasicOptions = odesc convertExportBasicOpts+    , commandDefaults = defaultFlags convertExportOpts+    , commandCheckOptions = ocheck convertExportOpts+    }+  where+    convertExportBasicOpts = O.repoDir ^ O.marks+    convertExportAdvancedOpts = O.network+    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+  newMarks <-+    withRepository (useCache ? opts) $ RepoJob $ \repo -> fastExport' repo marks+  case parseFlags O.writeMarks opts of+    Nothing -> return ()+    Just f  -> writeMarks f newMarks++fastExport' :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+            => Repository rt p r u r -> Marks -> IO Marks+fastExport' repo marks = do+  putStrLn "progress (reading repository)"+  patchset <- readRepo repo+  marksref <- newIORef marks+  let patches = patchSet2FL patchset+      tags = inOrderTags patchset+      mark :: (PatchInfoAnd rt 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 ()+      checkOne n p = do apply p+                        unless (inOrderTag tags p ||+                                (getMark marks n == Just (patchHash p))) $+                          fail $ "FATAL: Marks do not correspond: expected " +++                                 show (getMark marks n) ++ ", got " ++ BC.unpack (patchHash p)+      -- build the working tree of the last version exported by convert --export+      check :: (RepoPatch p, ApplyState p ~ Tree)+            => Int -> FL (PatchInfoAnd rt p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd rt 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+  let patches'' = unsealFlipped unsafeCoerceP patches'+  void $ hashedTreeIO (dumpPatches tags mark n patches'') tree' pristineDirPath+  readIORef marksref+ `finally` do+  putStrLn "progress (cleaning up)"+  current <- readHashedPristineRoot repo+  cleanHashdir (repoCache repo) HashedPristineDir $ catMaybes [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 ()+dumpPatches _ _ _ NilFL = liftIO $ putStrLn "progress (patches converted)"+dumpPatches tags mark n (p:>:ps) = do+  apply p+  if inOrderTag tags p && n > 0+     then dumpTag p n+     else do dumpPatch mark p n+             dumpFiles $ listTouchedFiles p+  dumpPatches tags mark (next tags n p) ps++dumpTag :: (PatchInfoAnd rt p) x y  -> Int -> TreeIO () +dumpTag p n =+  dumpBits [ BLU.fromString $ "progress TAG " ++ cleanTagName p+           , BLU.fromString $ "tag " ++ cleanTagName p -- FIXME is this valid?+           , BLU.fromString $ "from :" ++ show (n - 1)+           , BLU.fromString $ unwords ["tagger", patchAuthor p, patchDate p]+           -- -3 == (-4 for "TAG " and +1 for newline)+           , BLU.fromString $ "data "+                 ++ show (BL.length (patchMessage p) - 3)+           , BL.drop 4 $ patchMessage p ]+   where+     -- FIXME forbidden characters and subsequences in tags:+     -- https://www.kernel.org/pub/software/scm/git/docs/git-check-ref-format.html+     cleanTagName = map cleanup . drop 4 . piName . info+         where cleanup x | x `elem` bad = '_'+                         | otherwise = x+               bad :: String+               bad = " ~^:"++dumpFiles :: [AnchoredPath] -> TreeIO ()+dumpFiles files = forM_ files $ \file -> do+  let quotedPath = quotePath $ anchorPath "" file+  isfile <- T.fileExists file+  isdir <- T.directoryExists file+  when isfile $ do bits <- T.readFile file+                   dumpBits [ BLU.fromString $ "M 100644 inline " ++ quotedPath+                            , BLU.fromString $ "data " ++ show (BL.length bits)+                            , bits ]+  when isdir $ do -- Always delete directory before dumping its contents. This fixes+                  -- a corner case when a same patch moves dir1 to dir2, and creates+                  -- another directory dir1.+                  -- As we always dump its contents anyway this is not more costly.+                  liftIO $ putStrLn $ "D " ++ quotedPath+                  tt <- gets T.tree -- ick+                  let subs = [ file `appendPath` n | (n, _) <-+                                  listImmediate $ fromJust $ findTree tt file ]+                  dumpFiles subs+  when (not isfile && not isdir) $ liftIO $ putStrLn $ "D " ++ quotedPath+  where+    -- |quotePath escapes and quotes paths containing newlines, double-quotes+    -- or backslashes.+    quotePath :: FilePath -> String+    quotePath path = case foldr escapeChars ("", False) path of+        (_, False) -> path+        (path', True) -> quote path'++    quote str = "\"" ++ str ++ "\""++    escapeChars c (processed, haveEscaped) = case escapeChar c of+        (escaped, didEscape) ->+            (escaped ++ processed, didEscape || haveEscaped)++    escapeChar c = case c of+        '\n' -> ("\\n", True)+        '\r' -> ("\\r", True)+        '"'  -> ("\\\"", True)+        '\\' -> ("\\\\", True)+        _    -> ([c], False)+++dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())+          -> (PatchInfoAnd rt p) x y -> Int+          -> TreeIO ()+dumpPatch mark p n =+  do dumpBits [ BLU.fromString $ "progress " ++ show n ++ ": " ++ piName (info p)+              , "commit refs/heads/master" ]+     mark p n+     dumpBits [ BLU.fromString $ "committer " ++ patchAuthor p ++ " " ++ patchDate p+              , BLU.fromString $ "data " ++ show (BL.length $ patchMessage p)+              , patchMessage p ]+     when (n > 1) $ dumpBits [ BLU.fromString $ "from :" ++ show (n - 1) ]++dumpBits :: [BL.ByteString] -> TreeIO ()+dumpBits = liftIO . BLC.putStrLn . BL.intercalate "\n"++-- patchAuthor attempts to fixup malformed author strings+-- into format: "Name <Email>"+-- e.g.+-- <john@home>      -> john <john@home>+-- john@home        -> john <john@home>+-- john <john@home> -> john <john@home>+-- john <john@home  -> john <john@home>+-- <john>           -> john <unknown>+patchAuthor :: (PatchInfoAnd rt p) x y -> String+patchAuthor p+ | null author = unknownEmail "unknown"+ | otherwise = case span (/='<') author of+               -- No name, but have email (nothing spanned)+               ("", email) -> case span (/='@') (tail email) of+                   -- Not a real email address (no @).+                   (n, "") -> case span (/='>') n of+                       (name, _) -> unknownEmail name+                   -- A "real" email address.+                   (user, rest) -> case span (/= '>') (tail rest) of+                       (dom, _) -> mkAuthor user $ emailPad (user ++ "@" ++ dom)+               -- No email (everything spanned)+               (_, "") -> case span (/='@') author of+                   (n, "") -> unknownEmail n+                   (name, _) -> mkAuthor name $ emailPad author+               -- Name and email+               (n, rest) -> case span (/='>') $ tail rest of+                   (email, _) -> n ++ emailPad email+ where+   author = dropWhile isSpace $ piAuthor (info p)+   unknownEmail = flip mkAuthor "<unknown>"+   emailPad email = "<" ++ email ++ ">"+   mkAuthor name email = name ++ " " ++ email++patchDate :: (PatchInfoAnd rt p) x y -> String+patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime .+  piDate . info++patchMessage :: (PatchInfoAnd rt 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 tags p = isTag (info p) && info p `elem` tags && nullFL (effect p)++next :: (Effect p) => [PatchInfo] -> Int ->  PatchInfoAnd rt p x y -> Int+next tags n p = if inOrderTag tags p then n else n + 1+
+ src/Darcs/UI/Commands/Convert/Import.hs view
@@ -0,0 +1,615 @@+--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}++module Darcs.UI.Commands.Convert.Import ( convertImport ) where++import Darcs.Prelude hiding ( readFile, lex )++import Control.Applicative ((<|>),many)+import Control.Arrow ((&&&), second)+import Control.Monad (unless, void, when)+import Control.Monad.State.Strict (gets, modify)+import Control.Monad.Trans (liftIO)++import qualified Data.Attoparsec.ByteString.Char8 as A+import Data.Attoparsec.ByteString.Char8 ((<?>))+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.IORef (modifyIORef, newIORef)+import Data.Maybe (fromMaybe)+import Data.Word (Word8)++import System.Directory (doesFileExist)+import System.FilePath.Posix ((</>))+import System.IO (stdin)++import Darcs.Patch.Depends ( getUncovered )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch ( PrimOf, RepoPatch, move )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Named ( Named(..), infopatch )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , RL(..)+    , (+<+)+    , 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.Repository+    ( EmptyRepository(..)+    , Repository+    , cleanRepository+    , createPristineDirectoryTree+    , createRepository+    , finalizeRepositoryChanges+    , readTentativeRepo+    , 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.Prefs (FileType(..))+import Darcs.Repository.State (readRecorded)++import Darcs.UI.Commands+    ( DarcsCommand(..)+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Commands.Convert.Util+    ( Marks+    , addMark+    , emptyMarks+    , getMark+    , patchHash+    , updatePending+    )+import Darcs.UI.Commands.Util.Tree (treeHasDir, treeHasFile)+import Darcs.UI.Completion (noArgs)+import Darcs.UI.Flags+    ( DarcsFlag+    , patchFormat+    , patchIndexNo+    , umask+    , useCache+    , withWorkingDir+    )+import Darcs.UI.Options+    ( (?)+    , (^)+    , defaultFlags+    , ocheck+    , odesc+    )+import qualified Darcs.UI.Options.All as O++import Darcs.Util.ByteString (decodeLocale, unpackPSFromUTF8)+import Darcs.Util.DateTime+    ( formatDateTime+    , parseDateTime+    , startOfTime+    )+import Darcs.Util.Global (darcsdir)+import Darcs.Util.Hash (Hash(..), encodeBase16, sha256)+import Darcs.Util.Lock (withNewDirectory)+import Darcs.Util.Path+    ( AbsolutePath+    , AnchoredPath(..)+    , appendPath+    , floatPath+    , makeName+    , parent+    , darcsdirName+    )+import Darcs.Util.Printer ( Doc, text )+import qualified Darcs.Util.Tree as T+import Darcs.Util.Tree+    ( Tree+    , TreeItem(..)+    , findTree+    , listImmediate+    , readBlob+    , treeHash+    )+import Darcs.Util.Tree.Hashed (darcsAddMissingHashes, hashedTreeIO)+import qualified Darcs.Util.Tree.Monad as TM+import Darcs.Util.Tree.Monad hiding (createDirectory, exists, rename)+++convertImportHelp :: Doc+convertImportHelp = text $ unlines+ [ "This command imports git repositories into new darcs repositories."+ , "Further options are accepted (see `darcs help init`)."+ , ""+ , "To convert a git repo to a new darcs one you may run:"+ , ""+ , "    $ (cd gitrepo && git fast-export --all -M) | darcs convert import darcsmirror"+ , ""+ , "WARNING: git repositories with branches will produce weird results,"+ , "         use at your own risks."+ , ""+ , "Incremental import with marksfiles is currently not supported."+ ]++convertImport :: DarcsCommand+convertImport = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "import"+    , commandHelp = convertImportHelp+    , commandDescription = "Import from a git-fast-export stream into darcs"+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[<DIRECTORY>]"]+    , commandCommand = fastImport+    , commandPrereq = \_ -> return $ Right ()+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandAdvancedOptions = odesc convertImportAdvancedOpts+    , commandBasicOptions = odesc convertImportBasicOpts+    , commandDefaults = defaultFlags convertImportOpts+    , commandCheckOptions = ocheck convertImportOpts+    }+  where+    convertImportBasicOpts+      = O.newRepo+      ^ O.setScriptsExecutable+      ^ O.patchFormat+      ^ O.withWorkingDir+    convertImportAdvancedOpts = O.patchIndexNo ^ O.umask+    convertImportOpts = convertImportBasicOpts `withStdOpts` convertImportAdvancedOpts++type Marked = Maybe Int+type Branch = B.ByteString+type AuthorInfo = B.ByteString+type Message = B.ByteString+type Content = B.ByteString+type Tag = B.ByteString++data RefId = MarkId Int | HashId B.ByteString | Inline+           deriving Show++-- Newish (> 1.7.6.1) Git either quotes filenames or has two+-- non-special-char-containing paths. Older git doesn't do any quoting, so+-- we'll have to manually try and find the correct paths, when we use the+-- paths.+data CopyRenameNames = Quoted B.ByteString B.ByteString+                     | Unquoted B.ByteString deriving Show++data Object = Blob (Maybe Int) Content+            | Reset Branch (Maybe RefId)+            | Commit Branch Marked AuthorInfo Message+            | Tag Tag Int AuthorInfo Message+            | Modify (Either Int Content) B.ByteString -- (mark or content), filename+            | Gitlink B.ByteString+            | Copy CopyRenameNames+            | Rename CopyRenameNames+            | Delete B.ByteString -- filename+            | From Int+            | Merge Int+            | Progress B.ByteString+            | End+            deriving Show++type Ancestors = (Marked, [Int])+data State p where+  Toplevel :: Marked -> Branch -> State p+  InCommit :: Marked -> Ancestors -> Branch -> Tree IO -> RL (PrimOf p) cX cY -> PatchInfo -> State p+  Done :: State p++instance Show (State p) where+  show Toplevel {} = "Toplevel"+  show InCommit {} = "InCommit"+  show Done =  "Done"++fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+fastImport _ opts [outrepo] =+  withUMaskFlag (umask ? opts) $ withNewDirectory outrepo $ do+    EmptyRepository _repo <- createRepository+      (patchFormat ? opts)+      (withWorkingDir ? opts)+      (patchIndexNo ? opts)+      (useCache ? opts)+    -- TODO implement --dry-run, which would be read-only?+    _repo <- revertRepositoryChanges _repo (updatePending opts)+    marks <- fastImport' _repo emptyMarks+    _ <- finalizeRepositoryChanges _repo (updatePending opts) GzipCompression+    cleanRepository _repo+    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+    marksref <- newIORef marks+    let initial = Toplevel Nothing $ BC.pack "refs/branches/master"++        go :: State p -> B.ByteString -> TreeIO ()+        go state rest = do (rest', item) <- parseObject rest+                           state' <- process state item+                           case state' of+                             Done -> return ()+                             _ -> go state' rest'++        -- sort marks into buckets, since there can be a *lot* of them+        markpath :: Int -> AnchoredPath+        markpath n = floatPath (darcsdir </> "marks")+                        `appendPath` (either error id $ makeName $ show (n `div` 1000))+                        `appendPath` (either error id $ makeName $ show (n `mod` 1000))++        makeinfo author message tag = do+          let (name, log) = case unpackPSFromUTF8 message of+                                      "" -> ("Unnamed patch", [])+                                      msg -> (head &&& tail) . lines $ msg+              (author'', date'') = span (/='>') $ unpackPSFromUTF8 author+              date' = dropWhile (`notElem` ("0123456789" :: String)) date''+              author' = author'' ++ ">"+              date = formatDateTime "%Y%m%d%H%M%S" $ fromMaybe startOfTime (parseDateTime "%s %z" date')+          liftIO $ patchinfo date (if tag then "TAG " ++ name else name) author' log++        addtag author msg =+          do info_ <- makeinfo author msg True+             gotany <- liftIO $ doesFileExist tentativePristinePath+             deps <- if gotany then liftIO $+                                      getUncovered `fmap`+                                        readTentativeRepo repo (repoLocation repo)+                               else return []+             let patch :: Named p wA wA+                 patch = NamedP info_ deps NilFL+             liftIO $ addToTentativeInventory (repoCache repo) GzipCompression (n2pia patch)++        -- processing items+        updateHashes = do+          let nodarcs = \(AnchoredPath (x:_)) _ -> x /= darcsdirName+              hashblobs (File blob@(T.Blob con NoHash)) =+                do hash <- sha256 `fmap` readBlob blob+                   return $ File (T.Blob con hash)+              hashblobs x = return x+          tree' <- liftIO . T.partiallyUpdateTree hashblobs nodarcs =<< gets tree+          modify $ \s -> s { tree = tree' }+          return $ T.filter nodarcs tree'++        -- Since git doesn't track directores it implicitly deletes+        -- them when they become empty. We should therefore remove any+        -- directories that become empty (except the repo-root+        -- directory!)+        deleteEmptyParents fp =+          case parent fp of+            Nothing -> return ()+            Just directParent -> do+              parentTree <- flip findTree directParent <$> gets tree+              case (null . listImmediate) <$> parentTree of+                      Just True -> do TM.unlink directParent+                                      deleteEmptyParents directParent+                      -- Either missing (not possible) or non-empty.+                      _ -> return ()++        -- generate a Hunk primitive patch 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+          return $ InCommit mark ancestors branch current newps info_+        diffCurrent _ = error "This is never valid outside of a commit."++        process :: State p -> Object -> TreeIO (State p)+        process s (Progress p) = do+          liftIO $ putStrLn ("progress " ++ decodeLocale p)+          return s++        process (Toplevel _ _) End = do+          tree' <- (liftIO . darcsAddMissingHashes) =<< updateHashes+          modify $ \s -> s { tree = tree' } -- lets dump the right tree, without _darcs+          let root = encodeBase16 $ treeHash tree'+          liftIO $ do+            putStrLn "\\o/ It seems we survived. Enjoy your new repo."+            B.writeFile tentativePristinePath $ BC.concat [BC.pack "pristine:", root]+          return Done++        process (Toplevel n b) (Tag tag what author msg) = do+          if Just what == n+             then addtag author msg+             else liftIO $ putStrLn $+                    "WARNING: Ignoring out-of-order tag " ++ decodeLocale tag+          return (Toplevel n b)++        process (Toplevel n _) (Reset branch from) =+          do case from of+               (Just (MarkId k)) | Just k == n ->+                 addtag (BC.pack "Anonymous Tagger <> 0 +0000") branch+               _ -> liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " +++                                        decodeLocale branch+             return $ Toplevel n branch++        process (Toplevel n b) (Blob (Just m) bits) = do+          TM.writeFile (markpath m) (BLC.fromChunks [bits])+          return $ Toplevel n b++        process x (Gitlink link) = do+          liftIO $ putStrLn $ "WARNING: Ignoring gitlink " ++ decodeLocale link+          return x++        process (Toplevel previous pbranch) (Commit branch mark author message) = do+          when (pbranch /= branch) $ do+            liftIO $ putStrLn ("Tagging branch: " ++ decodeLocale pbranch)+            addtag author pbranch+          info_ <- makeinfo author message False+          startstate <- updateHashes+          return $ InCommit mark (previous, []) branch startstate NilRL info_++        process s@InCommit {} (Modify (Left m) path) = do+          TM.copy (markpath m) (decodePath path)+          diffCurrent s++        process s@InCommit {} (Modify (Right bits) path) = do+          TM.writeFile (decodePath path) (BLC.fromChunks [bits])+          diffCurrent s++        process s@InCommit {} (Delete path) = do+          let floatedPath = decodePath path+          TM.unlink floatedPath+          deleteEmptyParents floatedPath+          diffCurrent s++        process (InCommit mark (prev, current) branch start ps info_) (From from) =+          return $ InCommit mark (prev, from:current) branch start ps info_++        process (InCommit mark (prev, current) branch start ps info_) (Merge from) =+          return $ InCommit mark (prev, from:current) branch start ps info_++        process s@InCommit {} (Copy names) = do+            (from, to) <- extractNames names+            TM.copy (decodePath from) (decodePath to)+            -- We can't tell Darcs that a file has been copied, so it'll+            -- show as an addfile.+            diffCurrent s++        process s@(InCommit mark ancestors branch start _ info_) (Rename names) = do+          (from, to) <- extractNames names+          let uFrom = decodePath from+              uTo = decodePath to+          case parent uTo of+            Nothing ->+              -- no parents i.e. target is root => nothing to do+              return ()+            Just parentDir -> do+              targetDirExists <- liftIO $ treeHasDir start uTo+              targetFileExists <- liftIO $ treeHasFile start uTo+              parentDirExists <-+                  liftIO $ treeHasDir start parentDir+              -- If the target exists, remove it; if it doesn't, add all+              -- its parent directories.+              if targetDirExists || targetFileExists+                  then TM.unlink uTo+                  else unless parentDirExists $ TM.createDirectory parentDir+          (InCommit _ _ _ _ newPs _) <- diffCurrent s+          TM.rename uFrom uTo+          let ps' = newPs :<: move uFrom uTo+          current <- updateHashes+          -- ensure empty dirs get deleted+          deleteEmptyParents uFrom+          -- run diffCurrent to add the dir deletions prims+          diffCurrent (InCommit mark ancestors branch current ps' info_)++        -- When we leave the commit, create a patch for the cumulated+        -- prims.+        process (InCommit mark ancestors branch _ ps info_) x = do+          case ancestors of+            (_, []) -> return () -- OK, previous commit is the ancestor+            (Just n, list)+              | n `elem` list -> return () -- OK, we base off one of the ancestors+              | otherwise -> liftIO $ putStrLn $+                               "WARNING: Linearising non-linear ancestry:" +++                               " currently at " ++ show n ++ ", ancestors " ++ show list+            (Nothing, list) ->+              liftIO $ putStrLn $ "WARNING: Linearising non-linear ancestry " ++ show list++          {- current <- updateHashes -} -- why not?+          (prims :: FL (PrimOf p) cX cY)  <- return $ sortCoalesceFL $ reverseRL ps+          let patch :: Named p cX cY+              patch = infopatch info_ prims+          liftIO $ addToTentativeInventory (repoCache repo)+                                                  GzipCompression (n2pia patch)+          case mark of+            Nothing -> return ()+            Just n -> case getMark marks n of+              Nothing -> liftIO $ modifyIORef marksref $ \m -> addMark m n (patchHash $ n2pia patch)+              Just n' -> fail $ "FATAL: Mark already exists: " ++ decodeLocale n'+          process (Toplevel mark branch) x++        process state obj = do+          liftIO $ print obj+          fail $ "Unexpected object in state " ++ show state++        extractNames :: CopyRenameNames+                     -> TreeIO (BC.ByteString, BC.ByteString)+        extractNames names = case names of+            Quoted f t -> return (f, t)+            Unquoted uqNames -> do+                let spaceIndices = BC.elemIndices ' ' uqNames+                    splitStr = second (BC.drop 1) . flip BC.splitAt uqNames+                    -- Reverse the components, so we find the longest+                    -- prefix existing name.+                    spaceComponents = reverse $ map splitStr spaceIndices+                    componentCount = length spaceComponents+                if componentCount == 1+                    then return $ head spaceComponents+                    else do+                        let dieMessage = unwords+                                [ "Couldn't determine move/rename"+                                , "source/destination filenames, with the"+                                , "data produced by this (old) version of"+                                , "git, since it uses unquoted, but"+                                , "special-character-containing paths."+                                ]+                            lPathExists (l,_) =+                                TM.fileExists $ decodePath l+                            finder [] = error dieMessage+                            finder (x : rest) = do+                                xExists <- lPathExists x+                                if xExists then return x else finder rest+                        finder spaceComponents++    void $ hashedTreeIO (go initial B.empty) pristine pristineDirPath++parseObject :: BC.ByteString -> TreeIO ( BC.ByteString, Object )+parseObject = next' mbObject+  where mbObject = A.parse p_maybeObject++        p_maybeObject = Just `fmap` p_object+                        <|> (A.endOfInput >> return Nothing)++        lex p = p >>= \x -> A.skipSpace >> return x+        lexString s = A.string (BC.pack s) >> A.skipSpace+        line = lex $ A.takeWhile (/='\n')++        optional p = Just `fmap` p <|> return Nothing++        p_object = p_blob+                   <|> p_reset+                   <|> p_commit+                   <|> p_tag+                   <|> p_modify+                   <|> p_rename+                   <|> p_copy+                   <|> p_from+                   <|> p_merge+                   <|> p_delete+                   <|> (lexString "progress" >> Progress `fmap` line)++        p_author name = lexString name >> line++        p_reset = do lexString "reset"+                     branch <- line+                     refid <- optional $ lexString "from" >> p_refid+                     return $ Reset branch refid++        p_commit = do lexString "commit"+                      branch <- line+                      mark <- optional p_mark+                      _ <- optional $ p_author "author"+                      committer <- p_author "committer"+                      message <- p_data+                      return $ Commit branch mark committer message++        p_tag = do _ <- lexString "tag"+                   tag <- line+                   lexString "from"+                   mark <- p_marked+                   author <- p_author "tagger"+                   message <- p_data+                   return $ Tag tag mark author message++        p_blob = do lexString "blob"+                    mark <- optional p_mark+                    Blob mark `fmap` p_data+                  <?> "p_blob"++        p_mark = do lexString "mark"+                    p_marked+                  <?> "p_mark"++        p_refid = MarkId `fmap` p_marked+                  <|> (lexString "inline" >> return Inline)+                  <|> HashId `fmap` p_hash++        p_data = do lexString "data"+                    len <- A.decimal+                    _ <- A.char '\n'+                    lex $ A.take len+                  <?> "p_data"++        p_marked = lex $ A.char ':' >> A.decimal+        p_hash = lex $ A.takeWhile1 (A.inClass "0123456789abcdefABCDEF")+        p_from = lexString "from" >> From `fmap` p_marked+        p_merge = lexString "merge" >> Merge `fmap` p_marked+        p_delete = lexString "D" >> Delete `fmap` p_maybeQuotedName+        p_rename = do lexString "R"+                      names <- p_maybeQuotedCopyRenameNames+                      return $ Rename names+        p_copy = do lexString "C"+                    names <- p_maybeQuotedCopyRenameNames+                    return $ Copy names+        p_modify = do lexString "M"+                      mode <- lex $ A.takeWhile (A.inClass "01234567890")+                      mark <- p_refid+                      path <- p_maybeQuotedName+                      case mark of+                        HashId hash | mode == BC.pack "160000" -> return $ Gitlink hash+                                    | otherwise -> fail ":(("+                        MarkId n -> return $ Modify (Left n) path+                        Inline -> do bits <- p_data+                                     return $ Modify (Right bits) path+        p_maybeQuotedCopyRenameNames =+            p_lexTwoQuotedNames <|> Unquoted `fmap` line+        p_lexTwoQuotedNames = do+            n1 <- lex p_quotedName+            n2 <- lex p_quotedName+            return $ Quoted n1 n2+        p_maybeQuotedName = lex (p_quotedName <|> line)+        p_quotedName = do+          _ <- A.char '"'+          bytes <- many (p_escaped <|> p_unescaped)+          _ <- A.char '"'+          return $ B.concat bytes+        p_unescaped = A.takeWhile1 (\c->c/='"' && c/='\\')+        p_escaped = do+          _ <- A.char '\\'+          p_escaped_octal <|> p_escaped_char+        p_escaped_octal = do+          let octals :: [Char]+              octals = "01234567"+          s <- A.takeWhile1 (`elem` octals)+          let x :: Word8+              x = read ("0o" ++ BC.unpack s)+          return $ B.singleton $ fromIntegral x+        p_escaped_char =+          fmap BC.singleton $+          '\r' <$ A.char 'r' <|> '\n' <$ A.char 'n' <|> A.char '"' <|> A.char '\\'++        next' :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)+        next' parser rest =+          do chunk <- if B.null rest then liftIO $ B.hGet stdin (64 * 1024)+                                     else return rest+             next_chunk parser chunk++        next_chunk :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)+        next_chunk parser chunk =+          case parser chunk of+             A.Done rest result -> return (rest, maybe End id result) -- not sure about the maybe+             A.Partial cont -> next' cont B.empty+             A.Fail _ ctx err -> do+               liftIO $ putStrLn $ "=== chunk ===\n" ++ decodeLocale chunk ++ "\n=== end chunk ===="+               fail $ "Error parsing stream. " ++ err ++ "\nContext: " ++ show ctx++decodePath :: BC.ByteString -> AnchoredPath+decodePath = floatPath . decodeLocale
+ src/Darcs/UI/Commands/Convert/Util.hs view
@@ -0,0 +1,70 @@+module Darcs.UI.Commands.Convert.Util+    ( Marks+    , emptyMarks+    , addMark+    , getMark+    , lastMark+    , readMarks+    , writeMarks+    -- misc+    , patchHash+    , updatePending+    ) where++import Darcs.Prelude++import Darcs.Util.Exception ( catchall )++import qualified Data.ByteString.Char8 as BC+import qualified Data.IntMap as M++import System.Directory ( removeFile )++import Darcs.Patch.Info ( makePatchname )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )++import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.UI.Options ( (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Flags ( DarcsFlag )++-- marks support++type Marks = M.IntMap BC.ByteString++emptyMarks :: Marks+emptyMarks = M.empty++lastMark :: Marks -> Int+lastMark m = if M.null m then 0 else fst $ M.findMax m++getMark :: Marks -> Int -> Maybe BC.ByteString+getMark marks key = M.lookup key marks++addMark :: Marks -> Int -> BC.ByteString -> Marks+addMark marks key value = M.insert key value marks++readMarks :: FilePath -> IO Marks+readMarks p = do lines' <- BC.split '\n' `fmap` BC.readFile p+                 return $ foldl merge M.empty lines'+               `catchall` return emptyMarks+  where merge set line = case BC.split ':' line of+          [i, hash] -> M.insert (read $ BC.unpack i) (BC.dropWhile (== ' ') hash) set+          _ -> set -- ignore, although it is maybe not such a great idea...++writeMarks :: FilePath -> Marks -> IO ()+writeMarks fp m = do removeFile fp `catchall` return () -- unlink+                     BC.writeFile fp marks+  where marks = BC.concat $ map format $ M.assocs m+        format (k, s) = BC.concat [BC.pack $ show k, BC.pack ": ", s, BC.pack "\n"]++-- misc shared functions++patchHash :: PatchInfoAnd rt p cX cY -> BC.ByteString+patchHash p = BC.pack $ show $ makePatchname (info p)++updatePending :: [DarcsFlag] -> UpdatePending+updatePending opts =+  case O.withWorkingDir ? opts of+    O.WithWorkingDir -> YesUpdatePending+    O.NoWorkingDir -> NoUpdatePending
src/Darcs/UI/Commands/Diff.hs view
@@ -15,66 +15,64 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -module Darcs.UI.Commands.Diff ( diffCommand, getDiffDoc ) where+module Darcs.UI.Commands.Diff ( diffCommand ) where -import Prelude () import Darcs.Prelude hiding ( all ) -import Data.Maybe ( fromJust )+import Control.Monad ( unless, when )+import Data.Maybe ( fromMaybe )+import Data.Maybe ( isJust )+import System.Directory ( copyFile, createDirectory, findExecutable, listDirectory ) import System.FilePath.Posix ( takeFileName, (</>) ) -import Darcs.Util.Workaround ( getCurrentDirectory )-import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Util.Prompt ( askEnter )-import Control.Monad ( when )-import Data.List ( (\\) )-import Darcs.Util.Tree.Plain( writePlainTree )-import Darcs.Util.Tree.Hashed( hashedTreeIO )-import Data.Maybe ( isJust )-import System.Directory ( findExecutable )-                          -import Darcs.Util.CommandLine ( parseCmd )-import Darcs.UI.External-    ( diffProgram-    , execPipeIgnoreError-    )-import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )-import Darcs.UI.Completion ( knownFileArgs )-import Darcs.UI.Flags ( DarcsFlag, wantGuiPause, useCache, fixSubPaths )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )-import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( WantGuiPause (..), DiffAlgorithm(MyersDiff) )+import Darcs.Patch ( listTouchedFiles )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Depends ( findCommonWithThem )+import Darcs.Patch.Info ( displayPatchInfo )+import Darcs.Patch.Match ( matchFirstPatchset, matchSecondPatchset, secondMatch )+import Darcs.Patch.Named ( anonymous ) import Darcs.Patch.PatchInfoAnd ( info, n2pia )-import Darcs.Util.Path ( toFilePath, SubPath, simpleSubPath, isSubPathOf, AbsolutePath )-import Darcs.Util.Global ( darcsdir )-import Darcs.Patch.Match-    ( firstMatch-    , secondMatch-    , matchFirstPatchset-    , matchSecondPatchset-    )-import Darcs.Repository ( withRepository, RepoJob(..), readRepo )+import Darcs.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.State-    ( readUnrecorded, restrictSubpaths-    , readRecorded, unrecordedChanges-    , UseIndex(..), ScanKnown(..), applyTreeFilter+    ( ScanKnown(..)+    , applyTreeFilter+    , readRecorded+    , restrictSubpaths+    , unrecordedChanges     )-import Darcs.Patch.Witnesses.Ordered ( mapRL, (:>)(..), (+>+), RL(..) )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd )-import Darcs.Patch.Witnesses.Sealed ( unseal, Sealed(..), seal )-import Darcs.Patch ( RepoPatch, IsRepoType, apply, listTouchedFiles, invert, fromPrims )-import Darcs.Patch.Depends ( findCommonWithThem )-import Darcs.Patch.Named.Wrapped ( anonymous )-import Darcs.Patch.Set ( PatchSet(..), patchSet2RL )-import Darcs.Patch.Info ( PatchInfo, displayPatchInfo )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , withStdOpts+    )+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 qualified Darcs.UI.Options.All as O+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.Printer ( Doc, putDoc, vcat, empty, ($$) )+import Darcs.Util.Path ( AbsolutePath, AnchoredPath, isPrefix, toFilePath )+import Darcs.Util.Printer ( Doc, putDoc, text, vcat )+import Darcs.Util.Prompt ( askEnter )+import Darcs.Util.Tree.Hashed ( hashedTreeIO )+import Darcs.Util.Tree.Plain ( writePlainTree )+import Darcs.Util.Workaround ( getCurrentDirectory )  diffDescription :: String diffDescription = "Create a diff between two versions of the repository." -diffHelp :: String-diffHelp =+diffHelp :: Doc+diffHelp = text $  "The `darcs diff` command compares two versions of the working tree of\n" ++  "the current repository.  Without options, the pristine (recorded) and\n" ++  "unrecorded working trees are compared.  This is lower-level than\n" ++@@ -94,8 +92,9 @@  "ordering of the patch set, so results may be affected by operations\n" ++  "such as `darcs optimize reorder`.\n" ++  "\n" ++- "diff(1) is called with the arguments `-rN`.  The `--unified` option causes\n" ++- "`-u` to be passed to diff(1).  An additional argument can be passed\n" +++ "diff(1) is always called with the arguments `-rN` and by default also\n" +++ "with `-u` to show the differences in unified format. This can be turned\n" +++ "off by passing `--no-unified`. An additional argument can be passed\n" ++  "using `--diff-opts`, such as `--diff-opts=-ud` or `--diff-opts=-wU9`.\n" ++  "\n" ++  "The `--diff-command` option can be used to specify an alternative\n" ++@@ -108,7 +107,7 @@  "\n" ++  "If this option is used, `--diff-opts` is ignored.\n" -diffCommand :: DarcsCommand [DarcsFlag]+diffCommand :: DarcsCommand diffCommand = DarcsCommand     { commandProgramName = "darcs"     , commandName = "diff"@@ -124,38 +123,16 @@     , commandBasicOptions = odesc diffBasicOpts     , commandDefaults = defaultFlags diffOpts     , commandCheckOptions = ocheck diffOpts-    , commandParseOptions = onormalise diffOpts     }   where     diffBasicOpts-      = O.matchRange+      = O.matchOneOrRange       ^ O.extDiff       ^ O.repoDir       ^ O.storeInMemory-    diffAdvancedOpts = O.pauseForGui+    diffAdvancedOpts = O.pauseForGui ^ O.useIndex     diffOpts = diffBasicOpts `withStdOpts` diffAdvancedOpts -getDiffOpts :: O.ExternalDiff -> [String]-getDiffOpts O.ExternalDiff {O.diffOpts=os,O.diffUnified=u} = addUnified os where-  addUnified = if u then ("-u":) else id---- | Returns the command we should use for diff as a tuple (command, arguments).--- This will either be whatever the user specified via --diff-command  or the--- default 'diffProgram'.  Note that this potentially involves parsing the--- user's diff-command, hence the possibility for failure with an exception.-getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String-                      -> Either String (String, [String])-getDiffCmdAndArgs cmd opts f1 f2 = helper (O.extDiff ? opts) where-  helper extDiff =-    case O.diffCmd extDiff of-      Just c ->-        case parseCmd [ ('1', f1) , ('2', f2) ] c of-          Left err      -> Left $ show err-          Right ([],_)  -> bug "parseCmd should never return empty list"-          Right (h:t,_) -> Right (h,t)-      Nothing -> -- if no command specified, use 'diff'-        Right (cmd, "-rN":getDiffOpts extDiff++[f1,f2])- diffCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () diffCmd fps opts args   | not (null (O.matchLast ? opts)) &&@@ -164,98 +141,140 @@           " command doesn't make sense. Use --from-patch to create a diff" ++           " from this patch to the present, or use just '--patch' to view" ++           " this specific patch."-  | null args = doDiff opts Nothing-  | otherwise = doDiff opts . Just =<< fixSubPaths fps args--doDiff :: [DarcsFlag] -> Maybe [SubPath] ->  IO ()-doDiff opts msubpaths = getDiffDoc opts msubpaths >>= putDoc--getDiffDoc :: [DarcsFlag] -> Maybe [SubPath] ->  IO Doc-getDiffDoc opts msubpaths = withRepository (useCache ? opts) $ RepoJob $ \repository -> do-  formerdir <- getCurrentDirectory--  let thename = takeFileName formerdir+  | otherwise = doDiff opts =<< pathSetFromArgs fps args +doDiff :: [DarcsFlag] -> Maybe [AnchoredPath] ->  IO ()+doDiff opts mpaths = withRepository (useCache ? opts) $ RepoJob $ \repository -> do   patchset <- readRepo repository--  unrecorded <- fromPrims `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff)+  -- 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 msubpaths+    repository mpaths+  -- Use of 'anonymous' is unproblematic here as we don't store any patches.+  -- But we must take care not to show its fake patch info to the user.   unrecorded' <- n2pia `fmap` anonymous unrecorded -  let matchFlags = parseFlags O.matchRange opts-  Sealed all <- return $ case (secondMatch matchFlags, patchset) of-    (True, _) -> seal patchset-    (False, PatchSet tagged untagged) -> seal $ PatchSet tagged (untagged :<: unrecorded')--  Sealed ctx <- return $ if firstMatch matchFlags-                            then matchFirstPatchset matchFlags patchset-                            else seal patchset+  let matchFlags = parseFlags O.matchOneOrRange opts -  Sealed match <- return $ if secondMatch matchFlags-                             then matchSecondPatchset matchFlags patchset-                             else seal all+  -- If no secondMatch (--to-xxx) is specified, include unrecorded changes+  Sealed all <- return $+    if secondMatch matchFlags+      then seal patchset+      else seal $ patchSetSnoc patchset unrecorded'+  -- Note how this differs from how firstMatch defaults for log command+  Sealed ctx <- return $+    fromMaybe (seal patchset) $ matchFirstPatchset matchFlags patchset+  Sealed match <- return $+    fromMaybe (seal all) $ matchSecondPatchset matchFlags patchset    (_ :> todiff) <- return $ findCommonWithThem match ctx   (_ :> tounapply) <- return $ findCommonWithThem all match -  base <- if secondMatch matchFlags-           then readRecorded repository-           else readUnrecorded repository Nothing+  Sealed logmatch <- return $+    if secondMatch matchFlags+      then seal match+      else seal patchset+  -- Same as @todiff@ but without trailing @unrecorded'@ changes+  (_ :> tolog) <- return $ findCommonWithThem logmatch ctx -  let touched = map (fromJust . simpleSubPath) $ listTouchedFiles todiff-      files = case msubpaths of+  let touched = listTouchedFiles todiff+      files = case mpaths of                Nothing -> touched-               Just subpaths -> concatMap (\s -> filter (isSubPathOf s) touched) subpaths+               Just paths ->+                  concatMap (\path -> filter (isPrefix path) touched) paths   relevant <- restrictSubpaths repository files-  let filt = applyTreeFilter relevant . snd-      ppath = darcsdir </> "pristine.hashed" -  oldtree <- filt `fmap` hashedTreeIO-                (apply . invert $ unsafeCoercePEnd todiff +>+ tounapply) base ppath-  newtree <- filt `fmap` hashedTreeIO-                (apply . invert $ tounapply) base ppath+  formerdir <- getCurrentDirectory+  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)+      createDirectory odir+      let ndir = toFilePath tmpdir </> ("new-"++thename)+      createDirectory ndir -  withTempDir ("old-"++thename) $ \odir ->-    withTempDir ("new-"++thename) $ \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-        writePlainTree oldtree (toFilePath odir)-        writePlainTree newtree (toFilePath ndir)-        thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $-                       rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir)-        morepatches <- readRepo repository-        return $ changelog (getDiffInfo opts morepatches) $$ thediff-    where rundiff :: String -> String -> IO Doc-          rundiff f1 f2 = do-            cmd <- diffProgram-            case getDiffCmdAndArgs cmd opts f1 f2 of-              Left err -> fail err-              Right (d_cmd, d_args) -> do-                if length (filter (==f1) d_args) /= 1 || length (filter (==f2) d_args) /= 1-                    then fail $ "Invalid argument (%1 or %2) in --diff-command"-                    else return ()-                cmdExists <- findExecutable d_cmd-                if isJust cmdExists-                    then return ()-                    else fail $ d_cmd ++ " is not an executable in --diff-command"-                let pausingForGui = (wantGuiPause opts == YesWantGuiPause) in-                  do when pausingForGui $ putStrLn $-                       "Running command '" ++ unwords (d_cmd:d_args) ++ "'"-                     output <- execPipeIgnoreError d_cmd d_args empty-                     when pausingForGui $-                        askEnter "Hit return to move on..."-                     return output+        -- Make a temporary copy of pristineDirPath where we have write access.+        -- The result (@pdirpath@) serves 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 -getDiffInfo :: (IsRepoType rt, RepoPatch p) => [DarcsFlag] -> PatchSet rt p wStart wX -> [PatchInfo]-getDiffInfo opts ps =-    let matchFlags = parseFlags O.matchRange opts-        infos = mapRL info . patchSet2RL-        handle (match_cond, do_match)-          | match_cond matchFlags = unseal infos (do_match matchFlags ps)-          | otherwise = infos ps-    in handle (secondMatch, matchSecondPatchset)-         \\ handle (firstMatch, matchFirstPatchset)+        pristine <- readRecorded repository -changelog :: [PatchInfo] -> Doc-changelog pis = vcat $ map displayPatchInfo pis+        -- @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 +        newtree <- snd <$> hashedTreeIO (unapply tounapply) base pdirpath+        -- @todiff@ may have our @unrecorded'@ changes as its last element. If+        -- we used our full working tree as @base@, then we would now unapply+        -- filtered changes from an unfiltered 'Tree', so the result would be+        -- the pristine Tree with the filtered-out unrecorded changes /still+        -- applied/. Unapplying the (unfiltered) recorded changes that touch+        -- paths that we filtered out would then fail (issue2639).+        -- We cannot use 'readUnrecorded' and pass it @mpaths@ because that+        -- would filter the whole Tree, so again unapplying recorded changes+        -- that touch irrelevant paths would fail.+        -- A valid alternative solution would be to not pre-filter unrecorded+        -- changes at all, since we filter the resulting Trees anyway (see+        -- below). But that may be less efficient if there are many unrecorded+        -- changes but we are interested in just a small subset of the affected+        -- paths.+        oldtree <- snd <$> hashedTreeIO (unapply todiff) newtree pdirpath++        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++      -- Call the external diff program. Note we are now back in our+      -- temporary directory.+      cmd <- diffProgram+      let old = takeFileName $ toFilePath odir+          new = takeFileName $ toFilePath ndir+      case getDiffCmdAndArgs cmd opts old new of+        Left err -> fail err+        Right (d_cmd, d_args) -> do+          cmdExists <- findExecutable d_cmd+          unless (isJust cmdExists) $+            fail $ d_cmd ++ " is not an executable in --diff-command"+          let pausingForGui = (wantGuiPause opts == YesWantGuiPause)+              cmdline = unwords (d_cmd : d_args)+          when pausingForGui $ putStrLn $ "Running command '" ++ cmdline ++ "'"+          _ <- execInteractive cmdline Nothing+          when pausingForGui $ askEnter "Hit return to move on..."++-- | Returns the command we should use for diff as a tuple (command, arguments).+-- This will either be whatever the user specified via --diff-command  or the+-- default 'diffProgram'.  Note that this potentially involves parsing the+-- user's diff-command, hence the possibility for failure.+getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String+                  -> Either String (String, [String])+getDiffCmdAndArgs cmd opts f1 f2 = helper (O.extDiff ? opts) where+  helper extDiff =+    case O.diffCmd extDiff of+      Just c ->+        case parseCmd [ ('1', f1) , ('2', f2) ] c of+          Left err      -> Left $ show err+          Right ([],_)  -> error "parseCmd should never return empty list"+          Right (cmd':args,_)+            | length (filter (== f1) args) == 1+            , length (filter (== f2) args) == 1 -> Right (cmd',args)+            | otherwise -> Left $ "Invalid argument (%1 or %2) in --diff-command"+      Nothing -> -- if no command specified, use 'diff'+        Right (cmd, "-rN":getDiffOpts extDiff++[f1,f2])++getDiffOpts :: O.ExternalDiff -> [String]+getDiffOpts O.ExternalDiff {O.diffOpts=os,O.diffUnified=u} = addUnified os where+  addUnified = if u then ("-u":) else id
src/Darcs/UI/Commands/Dist.hs view
@@ -30,13 +30,11 @@     , doFastZip'     ) where -import Prelude () import Darcs.Prelude hiding ( writeFile )  import Data.ByteString.Lazy ( writeFile )-import Data.Char ( isAlphaNum ) import Control.Monad ( when )-import System.Directory ( setCurrentDirectory )+import System.Directory ( createDirectory, setCurrentDirectory ) import System.Process ( system ) import System.Exit ( ExitCode(..), exitWith ) import System.FilePath.Posix ( takeFileName, (</>) )@@ -48,15 +46,15 @@  import Codec.Archive.Zip ( emptyArchive, fromArchive, addEntryToArchive, toEntry ) import Darcs.Util.External ( fetchFilePS, Cachable( Uncachable ) )-import Darcs.Util.Global ( darcsdir )-import Darcs.Repository.Hashed ( peekPristineHash )+import Darcs.Repository.Inventory ( peekPristineHash ) import Darcs.Repository.HashedIO ( pathsAndContents )+import Darcs.Repository.Paths ( hashedInventoryPath ) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B import Darcs.UI.Flags as F ( DarcsFlag, useCache ) import qualified Darcs.UI.Flags as F ( setScriptsExecutable ) import Darcs.UI.Options-    ( (^), oid, odesc, ocheck, onormalise+    ( (^), oid, odesc, ocheck     , defaultFlags, parseFlags, (?)     ) import qualified Darcs.UI.Options.All as O@@ -67,24 +65,24 @@     ) import Darcs.UI.Completion ( noArgs ) import Darcs.Util.Lock ( withTempDir )-import Darcs.Patch.Match ( haveNonrangeMatch )-import Darcs.Repository.Match ( getNonrangeMatch )+import Darcs.Patch.Match ( patchSetMatch )+import Darcs.Repository.Match ( getRecordedUpToMatch ) import Darcs.Repository ( withRepository, withRepositoryLocation, RepoJob(..),-                          setScriptsExecutable, repoPatchType, repoCache,+                          setScriptsExecutable, repoCache,                           createPartialsPristineDirectoryTree ) import Darcs.Repository.Prefs ( getPrefval )  import Darcs.Util.DateTime ( getCurrentTime, toSeconds )-import Darcs.Util.Path ( AbsolutePath, toFilePath )+import Darcs.Util.Path ( AbsolutePath, toFilePath, anchoredRoot ) import Darcs.Util.File ( withCurrentDirectory )-import Darcs.Util.Printer ( text, vcat )+import Darcs.Util.Printer ( Doc, text, vcat )   distDescription :: String distDescription = "Create a distribution archive." -distHelp :: String-distHelp = unlines+distHelp :: Doc+distHelp = text $ unlines   [ "`darcs dist` creates a compressed archive in the repository's root"   , "directory, containing the recorded state of the working tree"   , "(unrecorded changes and the `_darcs` directory are excluded)."@@ -102,7 +100,7 @@   , "If `--zip` is used, matchers and the predist command are ignored."   ] -dist :: DarcsCommand [DarcsFlag]+dist :: DarcsCommand dist = DarcsCommand     { commandProgramName = "darcs"     , commandName = "dist"@@ -118,7 +116,6 @@     , commandBasicOptions = odesc distBasicOpts     , commandDefaults = defaultFlags distOpts     , commandCheckOptions = ocheck distOpts-    , commandParseOptions = onormalise distOpts     }   where     distBasicOpts@@ -139,11 +136,12 @@   predist <- getPrefval "predist"   let resultfile = formerdir </> distname ++ ".tar.gz"   withTempDir "darcsdist" $ \tempdir -> do-    setCurrentDirectory formerdir-    withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do-      if haveNonrangeMatch (repoPatchType repository) matchFlags-        then withCurrentDirectory ddir $ getNonrangeMatch repository matchFlags-        else createPartialsPristineDirectoryTree repository [""] (toFilePath ddir)+      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@@ -152,7 +150,7 @@             when               (F.setScriptsExecutable ? opts == O.YesSetScriptsExecutable)               setScriptsExecutable-          doDist opts tempdir ddir resultfile+          doDist opts tempdir distname resultfile         else do           putStrLn "Dist aborted due to predist failure"           exitWith ec@@ -161,21 +159,17 @@ -- | This function performs the actual distribution action itself. -- NB - it does /not/ perform the pre-dist, that should already -- have completed successfully before this is invoked.-doDist :: [DarcsFlag] -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()-doDist opts tempdir ddir resultfile = do+doDist :: [DarcsFlag] -> AbsolutePath -> String -> FilePath -> IO ()+doDist opts tempdir name resultfile = do     setCurrentDirectory (toFilePath tempdir)-    let safeddir = safename $ takeFileName $ toFilePath ddir-    entries <- pack "." [safeddir]+    entries <- pack "." [name]     putVerbose opts $ vcat $ map (text . entryPath) entries     writeFile resultfile $ compress $ write entries     putInfo opts $ text $ "Created dist as " ++ resultfile-  where-    safename n@(c:_) | isAlphaNum c  = n-    safename n = "./" ++ n   getDistName :: FilePath -> Maybe String -> FilePath-getDistName _ (Just dn) = dn+getDistName _ (Just dn) = takeFileName dn getDistName currentDirectory _ = takeFileName currentDirectory  doFastZip :: [DarcsFlag] -> IO ()@@ -194,7 +188,7 @@   when (F.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $     putStrLn "WARNING: Zip archives cannot store executable flag."     let distname = getDistName path (O.distname ? opts)-  i <- fetchFilePS (path </> darcsdir </> "hashed_inventory") Uncachable+  i <- fetchFilePS (path </> hashedInventoryPath) Uncachable   pristine <- pathsAndContents (distname ++ "/") (repoCache repo) (peekPristineHash i)   epochtime <- toSeconds `fmap` getCurrentTime   let entries = [ toEntry filepath epochtime (toLazy contents) | (filepath,contents) <- pristine ]
src/Darcs/UI/Commands/GZCRCs.hs view
@@ -25,7 +25,6 @@     , doCRCWarnings     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when, unless, forM_ )@@ -37,7 +36,7 @@ import Data.Monoid ( Any(..), Sum(..) ) import System.Directory ( doesFileExist, doesDirectoryExist ) import System.Exit ( ExitCode(..), exitWith )-import System.IO ( hPutStr, hPutStrLn, stderr )+import System.IO ( stderr ) import Darcs.Util.File ( getRecursiveContentsFullPath ) import Darcs.Util.ByteString ( isGZFile, gzDecompress ) import Darcs.Util.Global ( getCRCWarnings, resetCRCWarnings )@@ -46,22 +45,26 @@ -- get at the caches and inspect them directly) -- Could move the relevant code into Darcs.Repository modules -- but it doesn't really seem worth it.-import Darcs.Repository.Cache ( Cache(..), writable, isThisRepo,-                                hashedFilePath, allHashedDirs )+import Darcs.Repository.Cache+    ( allHashedDirs+    , cacheEntries+    , hashedFilePath+    , isThisRepo+    , writable+    ) import Darcs.Util.Lock ( gzWriteAtomicFilePSs ) import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository     , putInfo, putVerbose     ) import Darcs.UI.Completion ( noArgs )-import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) import Darcs.UI.Flags ( DarcsFlag, useCache )-import Darcs.Util.Text ( formatText )-import Darcs.Util.Printer ( text )+import Darcs.Util.Printer ( Doc, ($$), formatText, hPutDocLn, pathlist, text ) -gzcrcsHelp :: String+gzcrcsHelp :: Doc gzcrcsHelp = formatText 80     [ "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed "       ++ "files with bad CRCs (but valid data) to be written out. CRCs were "@@ -94,22 +97,20 @@     files <- getCRCWarnings     resetCRCWarnings     unless (null files) $ do-        hPutStr stderr . formatText 80 $-            [""-            , "Warning: CRC errors found. These are probably harmless but "+        hPutDocLn stderr . formatText 80 $+            [ "Warning: CRC errors found. These are probably harmless but "               ++ "should be repaired. See 'darcs gzcrcs --help' for more "               ++ "information."-            , ""             ]         when verbose $-            hPutStrLn stderr . unlines $-                "The following corrupt files were found:" : files+            hPutDocLn stderr $+                text "The following corrupt files were found:" $$ pathlist files  gzcrcsDescription :: String gzcrcsDescription = "Check or repair the CRCs of compressed files in the "                     ++ "repository." -gzcrcs :: DarcsCommand [DarcsFlag]+gzcrcs :: DarcsCommand gzcrcs = DarcsCommand     { commandProgramName = "darcs"     , commandName = "gzcrcs"@@ -125,7 +126,6 @@     , commandBasicOptions = odesc gzcrcsBasicOpts     , commandDefaults = defaultFlags gzcrcsOpts     , commandCheckOptions = ocheck gzcrcsOpts-    , commandParseOptions = onormalise gzcrcsOpts     }   where     gzcrcsBasicOpts = O.gzcrcsActions ^ O.justThisRepo ^ O.repoDir@@ -143,7 +143,7 @@     -- pre-filter the list of locs to check and then decide whether to print     -- the message up front.     warnRelatedRepos <- newIORef $ not isJustThisRepo-    let Ca locs = repoCache repo+    let locs = cacheEntries $ repoCache repo     (_, Any checkFailed) <- runWriterT $ forM_ locs $ \loc ->         unless (isJustThisRepo && not (isThisRepo loc)) $ do             let isWritable = writable loc
src/Darcs/UI/Commands/Help.hs view
@@ -15,81 +15,99 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -module Darcs.UI.Commands.Help (- helpCmd,- commandControlList, environmentHelp,          -- these are for preproc.hs- printVersion,- listAvailableCommands ) where+{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Help+    ( helpCmd+    , commandControlList+    , printVersion+    , listAvailableCommands+    ) where -import Prelude () import Darcs.Prelude -import Darcs.UI.Flags-    ( DarcsFlag-    , environmentHelpEmail-    , environmentHelpSendmail-    )-import Darcs.UI.Options.Markdown ( optionsMarkdown )+import Control.Arrow ( (***) )+import Data.Char ( isAlphaNum, toLower, toUpper )+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.UI.Commands     ( CommandArgs(..)     , CommandControl(..)-    , normalCommand     , DarcsCommand(..)-    , WrappedCommand(..)-    , wrappedCommandName+    , commandName     , disambiguateCommands     , extractCommands     , getSubcommands     , nodefaults+    , normalCommand     ) import Darcs.UI.External ( viewDoc )-import Darcs.UI.Usage-    ( getCommandHelp-    , usage-    , subusage-    )-import Darcs.Util.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir-                       , environmentHelpLocks )-import Darcs.Patch.Match ( helpOnMatchers )-import Darcs.Repository.Prefs ( environmentHelpHome, prefsFilesHelp )-import Darcs.Util.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort )+import Darcs.UI.Flags ( DarcsFlag, environmentHelpEmail, environmentHelpSendmail )+import Darcs.UI.Options ( defaultFlags, ocheck, 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+    , environmentHelpTmpdir+    ) import Darcs.Util.Path ( AbsolutePath )-import Control.Arrow ( (***) )-import Data.Char ( isAlphaNum, toLower, toUpper )-import Data.Either ( partitionEithers )-import Data.List ( groupBy, isPrefixOf, intercalate, nub, lookup )-import Darcs.Util.English ( andClauses )-import Darcs.Util.Printer (text, vcat, vsep, ($$), empty)-import Darcs.Util.Printer.Color ( environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite )-import System.Exit ( exitSuccess )-import Version ( version )-import Darcs.Util.Download ( environmentHelpProxy, environmentHelpProxyPassword )+import Darcs.Util.Printer+    ( Doc+    , empty+    , formatWords+    , quoted+    , renderString+    , text+    , vcat+    , vsep+    , ($$)+    , ($+$)+    , (<+>)+    )+import Darcs.Util.Printer.Color+    ( environmentHelpColor+    , environmentHelpEscape+    , environmentHelpEscapeWhite+    )+import Darcs.Util.Ssh+    ( environmentHelpScp+    , environmentHelpSsh+    , environmentHelpSshPort+    ) import Darcs.Util.Workaround ( getCurrentDirectory )-import Darcs.UI.Options ( defaultFlags, ocheck, onormalise, oid )-import qualified Darcs.UI.TheCommands as TheCommands + helpDescription :: String helpDescription = "Display help about darcs and darcs commands." -helpHelp :: String-helpHelp =- "Without arguments, `darcs help` prints a categorized list of darcs\n" ++- "commands and a short description of each one.  With an extra argument,\n" ++- "`darcs help foo` prints detailed help about the darcs command foo.\n"+helpHelp :: Doc+helpHelp = formatWords+  [ "Without arguments, `darcs help` prints a categorized list of darcs"+  , "commands and a short description of each one.  With an extra argument,"+  , "`darcs help foo` prints detailed help about the darcs command foo."+  ]  -- | Starting from a list of 'CommandControl's, unwrap one level -- to get a list of command names together with their subcommands. unwrapTree :: [CommandControl] -> [(String, [CommandControl])]-unwrapTree cs = [ (wrappedCommandName c, subcmds c) | CommandData c <- cs ]-  where-    subcmds (WrappedCommand sc) = getSubcommands sc+unwrapTree cs = [ (commandName c, getSubcommands c) | CommandData c <- cs ]  -- | Given a list of (normal) arguments to the help command, produce a list -- of possible completions for the next (normal) argument. completeArgs :: [String] -> [String] completeArgs [] = map fst (unwrapTree commandControlList) ++ extraArgs where-  extraArgs = [ "manpage", "markdown", "patterns", "environment" ]+  extraArgs = [ "patterns", "preferences", "environment", "manpage", "markdown" ] completeArgs (arg:args) = exploreTree arg args commandControlList where   exploreTree cmd cmds cs =     case lookup cmd (unwrapTree cs) of@@ -98,7 +116,7 @@         [] -> map fst (unwrapTree cs')         sub:cmds' -> exploreTree sub cmds' cs' -help :: DarcsCommand [DarcsFlag]+help :: DarcsCommand help = DarcsCommand     { commandProgramName = "darcs"     , commandName = "help"@@ -114,25 +132,29 @@     , commandBasicOptions = []     , commandDefaults = defaultFlags oid     , commandCheckOptions = ocheck oid-    , commandParseOptions = onormalise oid     }  helpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-helpCmd _ _ ["manpage"] = putStr $ unlines manpageLines-helpCmd _ _ ["markdown"] = putStr $ unlines markdownLines-helpCmd _ _ ["patterns"] = viewDoc $ text $ unlines helpOnMatchers+helpCmd _ _ ["manpage"] = viewDoc manpage+helpCmd _ _ ["markdown"] = viewDoc $ vcat $ map text markdownLines+helpCmd _ _ ["patterns"] = viewDoc $ vcat $ map text helpOnMatchers+helpCmd _ _ ["preferences"] =+    viewDoc $ header $+$ vcat (map render prefsFilesHelp)+  where+    header = "Preference Files" $$+             "================"+    render (f, h) =+      let item = "_darcs/prefs/" ++ f in+        text item $$ text (replicate (length item) '-') $$ text h helpCmd _ _ ("environment":vs_) =-    viewDoc $ header $$-              vsep (map render known) $$-              footer+    viewDoc $ vsep (header : map render known) $+$ footer   where     header | null known = empty-           | otherwise = text "Environment Variables" $$-                         text "====================="+           | otherwise = "Environment Variables" $$+                         "====================="      footer | null unknown = empty-           | otherwise = text "" $$-                         text ("Unknown environment variables: "+           | otherwise = text ("Unknown environment variables: "                                ++ intercalate ", " unknown)      render (ks, ds) = text (andClauses ks ++ ":") $$@@ -156,12 +178,12 @@          Left err -> fail err          Right (cmds,as) ->              let msg = case cmds of-                         CommandOnly c       -> getCommandHelp Nothing  c+                         CommandOnly c       -> getCommandHelp Nothing c                          SuperCommandOnly c  ->                           if null as then-                            getCommandHelp Nothing  c+                            getSuperCommandHelp c                           else-                            text $ "Invalid subcommand!\n\n" ++ subusage c+                            "Invalid subcommand!" $+$ subusage c                          SuperCommandSub c s -> getCommandHelp (Just c) s              in viewDoc $ msg @@ -169,9 +191,9 @@ listAvailableCommands =     do here <- getCurrentDirectory        is_valid <- mapM-                   (\(WrappedCommand c)-> withCurrentDirectory here $ commandPrereq c [])+                   (\c -> withCurrentDirectory here $ commandPrereq c [])                    (extractCommands commandControlList)-       putStr $ unlines $ map (wrappedCommandName . fst) $+       putStr $ unlines $ map (commandName . fst) $                 filter (isRight.snd) $                 zip (extractCommands commandControlList) is_valid        putStrLn "--help"@@ -214,7 +236,7 @@  environmentHelpProxyPassword,  environmentHelpTimeout] --- | This module is responsible for emitting a darcs "man-page", a+-- | This function is responsible for emitting a darcs "man-page", a -- reference document used widely on Unix-like systems.  Manpages are -- primarily used as a quick reference, or "memory jogger", so the -- output should be terser than the user manual.@@ -222,11 +244,9 @@ -- Before modifying the output, please be sure to read the man(7) and -- man-pages(7) manpages, as these respectively describe the relevant -- syntax and conventions.---- | The lines of the manpage to be printed.-manpageLines :: [String]-manpageLines = [- ".TH DARCS 1 \"" ++ version ++ "\"",+manpage :: Doc+manpage = vcat [+ ".TH DARCS 1" <+> quoted version,  ".SH NAME",  "darcs \\- an advanced revision control system",  ".SH SYNOPSIS",@@ -234,44 +254,22 @@  "",  "Where the", ".I commands", "and their respective", ".I arguments", "are",  "",- unlines synopsis,+ synopsis,  ".SH DESCRIPTION",- -- FIXME: this is copy-and-pasted from darcs.cabal, so- -- it'll get out of date as people forget to maintain- -- both in sync.- "Darcs is a free, open source revision control",- "system. It is:",- ".TP 3", "\\(bu",- "Distributed: Every user has access to the full",- "command set, removing boundaries between server and",- "client or committer and non\\(hycommitters.",- ".TP", "\\(bu",- "Interactive: Darcs is easy to learn and efficient to",- "use because it asks you questions in response to",- "simple commands, giving you choices in your work",- "flow. You can choose to record one change in a file,",- "while ignoring another. As you update from upstream,",- "you can review each patch name, even the full `diff'",- "for interesting patches.",- ".TP", "\\(bu",- "Smart: Originally developed by physicist David",- "Roundy, darcs is based on a unique algebra of",- "patches.",- "This smartness lets you respond to changing demands",- "in ways that would otherwise not be possible. Learn",- "more about spontaneous branches with darcs.",+ description,  ".SH OPTIONS",  "Different options are accepted by different Darcs commands.",  "Each command's most important options are listed in the",  ".B COMMANDS",  "section.  For a full list of all options accepted by",  "a particular command, run `darcs", ".I command", "\\-\\-help'.",- ".SS " ++ escape (unlines helpOnMatchers), -- FIXME: this is a kludge.+ ".SS " <> vcat (map text helpOnMatchers),  ".SH COMMANDS",- unlines commands,- unlines environment,+ commands,+ ".SH ENVIRONMENT",+ environment,  ".SH FILES",- unlines prefFiles,+ prefFiles,  ".SH BUGS",  "At http://bugs.darcs.net/ you can find a list of known",  "bugs in Darcs.  Unknown bugs can be reported at that",@@ -294,43 +292,52 @@       -- | A synopsis line for each command.  Uses 'foldl' because it is       -- necessary to avoid blank lines from Hidden_commands, as groff       -- translates them into annoying vertical padding (unlike TeX).-      synopsis :: [String]-      synopsis = foldl iter [] commandControlList-          where iter :: [String] -> CommandControl -> [String]+      synopsis :: Doc+      synopsis = foldl iter mempty commandControlList+          where iter :: Doc -> CommandControl -> Doc                 iter acc (GroupName _) = acc                 iter acc (HiddenCommand _) = acc-                iter acc (CommandData (WrappedCommand c@SuperCommand {})) =-                    acc ++ concatMap+                iter acc (CommandData (c@SuperCommand {})) =+                    acc $$ vcat (map                             (render (commandName c ++ " "))-                            (extractCommands (commandSubCommands c))-                iter acc (CommandData c) = acc ++ render "" c-                render :: String -> WrappedCommand -> [String]-                render prefix (WrappedCommand c) =-                    [".B darcs " ++ prefix ++ commandName c] ++-                    map mangle_args (commandExtraArgHelp c) +++                            (extractCommands (commandSubCommands c)))+                iter acc (CommandData c) = acc $$ render "" c+                render :: String -> DarcsCommand -> Doc+                render prefix c =+                    ".B darcs " <> text prefix <> text (commandName c) $$+                    vcat (map (text.mangle_args) (commandExtraArgHelp c)) $$                     -- In the output, we want each command to be on its own                     -- line, but we don't want blank lines between them.-                    -- AFAICT this can only be achieved with the .br-                    -- directive, which is probably a GNUism.-                    [".br"]+                    ".br"        -- | As 'synopsis', but make each group a subsection (.SS), and       -- include the help text for each command.-      commands :: [String]-      commands = foldl iter [] commandControlList-          where iter :: [String] -> CommandControl -> [String]-                iter acc (GroupName x) = acc ++ [".SS \"" ++ x ++ "\""]-                iter acc (HiddenCommand _) = acc-                iter acc (CommandData (WrappedCommand c@SuperCommand {})) =-                    acc ++ concatMap-                            (render (commandName c ++ " "))-                            (extractCommands (commandSubCommands c))-                iter acc (CommandData c) = acc ++ render "" c-                render :: String -> WrappedCommand -> [String]-                render prefix (WrappedCommand c) =-                    [".B darcs " ++ prefix ++ commandName c] ++-                    map mangle_args (commandExtraArgHelp c) ++-                    [".RS 4", escape $ commandHelp c, ".RE"]+      commands :: Doc+      commands = vsep $ map iter commandControlList+          where iter :: CommandControl -> Doc+                iter (GroupName x) = ".SS" <+> quoted x+                iter (HiddenCommand _) = mempty+                iter (CommandData (c@SuperCommand {})) =+                  vcat+                  [ ".B darcs " <> text (commandName c)+                  , text (mangle_args "subcommand")+                  , ".RS 4"+                  , commandHelp c+                  , ".RE"+                  ]+                  $+$+                  vsep (map (render (commandName c ++ " "))+                    (extractCommands (commandSubCommands c)))+                iter (CommandData c) = render "" c+                render :: String -> DarcsCommand -> Doc+                render prefix c =+                  vcat+                  [ ".B darcs " <> text prefix <> text (commandName c)+                  , vcat (map (text.mangle_args) (commandExtraArgHelp c))+                  , ".RS 4"+                  , commandHelp c+                  , ".RE"+                  ]        -- | Now I'm showing off: mangle the extra arguments of Darcs commands       -- so as to use the ideal format for manpages, italic words and roman@@ -338,32 +345,37 @@       mangle_args :: String -> String       mangle_args s =           ".RI " ++ unwords (map show (groupBy cmp $ map toLower $ gank s))-              where cmp x y = not $ xor (isAlphaNum x) (isAlphaNum y)-                    xor x y = (x && not y) || (y && not x)+              where cmp x y = isAlphaNum x == isAlphaNum y                     gank (' ':'o':'r':' ':xs) = '|' : gank xs                     gank (x:xs) = x : gank xs                     gank [] = [] -      environment :: [String]-      environment = ".SH ENVIRONMENT" : concat-                    [(".SS \"" ++ andClauses ks ++ "\"") : map escape ds+      environment :: Doc+      environment = vcat $ concat+                    [(".SS" <+> quoted (andClauses ks)) : map text ds                      | (ks, ds) <- environmentHelp] -      escape :: String -> String-      escape = minus . bs       -- Order is important-        where-          minus      = replace "-"     "\\-"-          bs         = replace "\\"    "\\\\"--          replace :: Eq a => [a] -> [a] -> [a] -> [a]-          replace _ _ [] = []-          replace find repl s =-              if find `isPrefixOf` s-                  then repl ++ replace find repl (drop (length find) s)-                  else head s : replace find repl (tail s)+      prefFiles :: Doc+      prefFiles = vcat $ map go prefsFilesHelp+        where go (f,h) = ".SS" <+> quoted("_darcs/prefs/" <> f) $$ text h -      prefFiles = concatMap go prefsFilesHelp-        where go (f,h) = [".SS \"_darcs/prefs/" ++ f ++ "\"", escape h]+      description = vcat+        [ "Unlike conventional revision control systems, Darcs is based on tracking"+        , "changes, rather than versions: it can and does automatically re-order"+        , "independent changes when needed. This means that in Darcs the state of"+        , "a repository should be regarded as a"+        , ".I set of patches"+        , "rather than a"+        , ".I sequence of versions."+        , ""+        , "Another distinguishing feature of darcs is that most commands are"+        , "interactive by default. For instance, `darcs record' (the equivalent of"+        , "what is usually called `commit') presents you with"+        , "each unrecorded change and asks you whether it should be included in"+        , "the patch to be recorded. Similarly, `darcs push' and `darcs pull'"+        , "present you with each patch, allowing you to select which patches to"+        , "push or pull."+        ]  markdownLines :: [String] markdownLines =@@ -389,18 +401,18 @@       iter :: [String] -> CommandControl -> [String]       iter acc (GroupName x) = acc ++ ["## " ++ x, ""]       iter acc (HiddenCommand _) = acc-      iter acc (CommandData (WrappedCommand c@SuperCommand {})) =+      iter acc (CommandData (c@SuperCommand {})) =           acc ++ concatMap                   (render (commandName c ++ " "))                   (extractCommands (commandSubCommands c))       iter acc (CommandData c) = acc ++ render "" c-      render :: String -> WrappedCommand -> [String]-      render prefix (WrappedCommand c) =+      render :: String -> DarcsCommand -> [String]+      render prefix c =           [ "### " ++ prefix ++ commandName c           , "", "darcs " ++ prefix ++ commandName c ++ " [OPTION]... " ++           unwords (commandExtraArgHelp c)           , "", commandDescription c-          , "", commandHelp c+          , "", renderString (commandHelp c)           , "Options:", optionsMarkdown $ commandBasicOptions c           , if null opts2 then ""              else unlines ["Advanced Options:", optionsMarkdown opts2]
src/Darcs/UI/Commands/Init.hs view
@@ -15,44 +15,74 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Init ( initialize, initializeCmd ) where -import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) )+import Control.Monad ( when )++import Darcs.Repository ( createRepository, withUMaskFlag ) import Darcs.UI.Commands-    ( DarcsCommand(..), withStdOpts, nodefaults, amNotInRepository, putInfo )+    ( DarcsCommand(..)+    , amNotInRepository+    , nodefaults+    , putFinished+    , withStdOpts+    , putWarning+    ) import Darcs.UI.Completion ( noArgs )-import Darcs.UI.Flags ( DarcsFlag( WorkRepoDir ) )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Flags ( DarcsFlag, withNewRepo )+import Darcs.UI.Options ( defaultFlags, ocheck, odesc, (?), (^) )+import Darcs.UI.Options.All () import qualified Darcs.UI.Options.All as O-import Darcs.UI.Options.All (  )-import Darcs.Util.Printer ( text ) import Darcs.Util.Path ( AbsolutePath )-import Darcs.Util.Text ( quote )-import Darcs.Repository ( createRepository, withUMaskFlag )+import Darcs.Util.Printer+    ( Doc+    , formatWords+    , quoted+    , renderString+    , text+    , vsep+    , ($$)+    , (<+>)+    )  initializeDescription :: String initializeDescription = "Create an empty repository." -initializeHelp :: String-initializeHelp =- "The `darcs initialize` command creates an empty repository in the\n" ++- "current directory. This repository lives in a new `_darcs` directory,\n"++- "which stores version control metadata and settings.\n" ++- "\n" ++- "Any existing files and subdirectories become UNSAVED changes:\n" ++- "record them with `darcs record --look-for-adds`.\n" ++- "\n" ++- "By default, patches of the new repository are in the darcs-2 semantics.\n" ++- "However it is possible to create a repository in darcs-1 semantics with\n" ++- "the flag `--darcs-1`, althought this is not recommended except for sharing\n" ++- "patches with a project that uses patches in the darcs-1 semantics.\n" ++- "\n" ++- "Initialize is commonly abbreviated to `init`.\n"+initializeHelp :: Doc+initializeHelp = vsep $ map formatWords+  [ [ "The `darcs initialize` command creates an empty repository in the"+    , "current directory. This repository lives in a new `_darcs` directory,"+    , "which stores version control metadata and settings."+    ]+  , [ "Existing files and subdirectories are not touched. You can"+    , "record them with `darcs record --look-for-adds`."+    ]+  , [ "Initialize is commonly abbreviated to `init`."+    ]+  , [ "Darcs currently supports three kinds of patch semantics. These are called"+    , "`darcs-1`, `darcs-2`, and `darcs-3`. They are mutually incompatible, that"+    , "is, you cannot exchange patches between repos with different semantics."+    ]+  , [ "By default, patches of the new repository are in the darcs-2 semantics."+    , "However it is possible to create a repository in darcs-1 semantics with"+    , "the flag `--darcs-1`, althought this is not recommended except for sharing"+    , "patches with a project that uses patches in the darcs-1 semantics."+    ]+  ] ++ [darcs3Warning] -initialize :: DarcsCommand [DarcsFlag]+darcs3Warning :: Doc+darcs3Warning = formatWords+  [ "The `darcs-3` semantics is EXPERIMENTAL and new in version 2.16. It is"+  , "included only as a technology preview and we do NOT recommend to use it"+  , "for any serious work. The on-disk format is not yet finalized and we"+  , "cannot and will not promise that later releases will work with darcs-3"+  , "repos created with any darcs version before 3.0."+  ]++initialize :: DarcsCommand initialize = DarcsCommand     { commandProgramName = "darcs"     , commandName = "initialize"@@ -68,27 +98,36 @@     , commandBasicOptions = odesc initBasicOpts     , commandDefaults = defaultFlags initOpts     , commandCheckOptions = ocheck initOpts-    , commandParseOptions = onormalise initOpts     }   where-    initBasicOpts = O.patchFormat ^ O.withWorkingDir ^ O.repoDir-    initAdvancedOpts = O.patchIndexNo ^ O.hashed+    initBasicOpts = O.patchFormat ^ O.withWorkingDir ^ O.newRepo+    initAdvancedOpts = O.patchIndexNo ^ O.hashed ^ O.umask     initOpts = initBasicOpts `withStdOpts` initAdvancedOpts  initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-initializeCmd aps opts [outname] | null [ () | WorkRepoDir _ <- opts ] =-  initializeCmd aps (WorkRepoDir outname:opts) []-initializeCmd _ opts [] =+initializeCmd _ opts [outname]+  | Nothing <- O.newRepo ? opts = doInit (withNewRepo outname opts)+initializeCmd _ opts [] = doInit opts+initializeCmd _ _ _ =+  fail "You must provide 'initialize' with either zero or one argument."++doInit :: [DarcsFlag] -> IO ()+doInit opts =   withUMaskFlag (O.umask ? opts) $ do     location <- amNotInRepository opts     case location of-      Left msg -> fail $ "Unable to " ++ quote ("darcs " ++ commandName initialize)-                          ++ " here.\n\n" ++ msg+      Left msg -> fail $ renderString $+        "Unable to" <+> quoted ("darcs " ++ commandName initialize)+                    <+> "here:" $$ text msg       Right () -> do+        when (O.patchFormat ? opts == O.PatchFormat3) $+          putWarning opts $+            "============================= WARNING =============================" $$+            darcs3Warning $$+            "==================================================================="         _ <- createRepository           (O.patchFormat ? opts)           (O.withWorkingDir ? opts)           (O.patchIndexNo ? opts)           (O.useCache ? opts)-        putInfo opts $ text "Repository initialized."-initializeCmd _ _ _ = fail "You must provide 'initialize' with either zero or one argument."+        putFinished opts $ "initializing repository"
src/Darcs/UI/Commands/Log.hs view
@@ -15,25 +15,27 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE PatternGuards #-}- module Darcs.UI.Commands.Log-    ( changes, log-    , changelog, getLogInfo+    ( changes+    , log+    , changelog+    , logInfoFL+    , simpleLogInfo -- for darcsden     ) where -import Prelude () import Darcs.Prelude -import Data.List ( intersect, sort, nub, find )-import Data.Maybe ( fromMaybe, fromJust, isJust )+import Data.List ( intersect, find )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( fromMaybe, isJust ) import Control.Arrow ( second ) import Control.Exception ( catch, IOException ) import Control.Monad.State.Strict  import Darcs.UI.PrintPatch ( showFriendly )-import Darcs.Patch.PatchInfoAnd ( fmapFLPIAP, hopefullyM, info )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAndG, fmapFLPIAP, hopefullyM, info ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, findRepository )+import Darcs.UI.Commands.Util ( matchRange ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.External ( viewDocWith ) import Darcs.UI.Flags@@ -41,68 +43,103 @@     , changesReverse, onlyToFiles     , useCache, maxCount, hasXmlOutput     , verbosity, withContext, isInteractive, verbose-    , fixSubPaths, getRepourl )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )+    , getRepourl, pathSetFromArgs )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Util.Path ( SubPath(), toFilePath,-                    fp2fn, fn2fp, normPath, AbsolutePath, simpleSubPath )-import Darcs.Repository ( PatchSet, PatchInfoAnd,+import Darcs.Util.Path+    ( SubPath+    , AbsolutePath+    , simpleSubPath+    , AnchoredPath+    , floatSubPath+    , displayPath+    )+import Darcs.Repository ( PatchInfoAnd,                           withRepositoryLocation, RepoJob(..),                           readRepo, unrecordedChanges,                           withRepoLockCanFail ) import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(MyersDiff) ) import Darcs.Util.Lock ( withTempDir )-import Darcs.Patch.Set ( PatchSet(..), patchSet2RL )-import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )+import Darcs.Patch.Set ( PatchSet, patchSet2RL, Origin ) import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Info ( toXml, toXmlShort, showPatchInfo, displayPatchInfo, escapeXML, PatchInfo )-import Darcs.Patch.Depends ( findCommonWithThem )-import Darcs.Patch.Bundle( contextPatches )-import Darcs.Patch.Prim ( PrimPatchBase )+import Darcs.Patch.Ident ( PatchId )+import Darcs.Patch.Invertible ( mkInvertible )+import Darcs.Patch.Depends ( contextPatches ) import Darcs.Patch.Show ( ShowPatch, ShowPatchFor(..) ) import Darcs.Patch.TouchesFiles ( lookTouch )-import Darcs.Patch.Type ( PatchType(PatchType) )-import Darcs.Patch.Apply ( Apply, ApplyState )-import Darcs.Patch ( IsRepoType, invert, xmlSummary, description,-                     effectOnFilePaths, listTouchedFiles, showPatch )-import Darcs.Patch.Named.Wrapped ( (:~:)(..), getdeps )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch ( PrimPatchBase(..), invert, xmlSummary, description,+                     effectOnPaths, listTouchedFiles, showPatch )+import Darcs.Patch.Named ( HasDeps, getdeps )+import Darcs.Patch.Prim.Class ( PrimDetails )+import Darcs.Patch.Summary ( Summary ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered     ( FL(NilFL), RL(..), filterOutFLFL, filterRL,-    reverseFL, (:>)(..), mapRL )-import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..), seal2 )+    reverseFL, (:>)(..), mapFL, mapRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Match     ( MatchFlag-    , firstMatch-    , secondMatch+    , Matchable+    , MatchableRP     , matchAPatch     , haveNonrangeMatch-    , matchFirstPatchset-    , matchSecondPatchset     )-import Darcs.Patch.Matchable ( Matchable )-import Darcs.Util.Printer ( Doc, simplePrinters, (<+>), prefix, text, vcat,-                 vsep, ($$), errorDoc, insertBeforeLastline, empty )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , (<+>)+    , formatWords+    , hsep+    , insertBeforeLastline+    , prefix+    , simplePrinters+    , text+    , vcat+    , vsep+    ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( setProgressMode, debugMessage )-import Darcs.Util.URL ( isValidLocalPath ) import Darcs.UI.SelectChanges ( viewChanges ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Repository.PatchIndex ( PatchFilter, maybeFilterPatches, attemptCreatePatchIndex ) import Darcs.Util.Tree( Tree ) -logHelp :: String-logHelp = unlines- [ "The `darcs log` command lists patches of the current repository or,"- , "with `--repo`, a remote repository.  Without options or arguments,"- , "ALL patches will be listed."- , ""]- ++ logHelp'- ++ logHelp''+logHelp :: Doc+logHelp = vsep $ map formatWords+  [ [ "The `darcs log` command lists patches of the current repository or,"+    , "with `--repo`, a remote repository.  Without options or arguments,"+    , "ALL patches will be listed."+    ]+  , [ "When given files or directories paths as arguments, only patches which"+    , "affect those paths are listed.  This includes patches that happened to"+    , "files before they were moved or renamed."+    ]+  , [ "When given `--from-tag` or `--from-patch`, only patches since that tag"+    , "or patch are listed.  Similarly, the `--to-tag` and `--to-patch`"+    , "options restrict the list to older patches."+    ]+  , [ "The `--last` and `--max-count` options both limit the number of patches"+    , "listed.  The former applies BEFORE other filters, whereas the latter"+    , "applies AFTER other filters.  For example `darcs log foo.c"+    , "--max-count 3` will print the last three patches that affect foo.c,"+    , "whereas `darcs log --last 3 foo.c` will, of the last three"+    , "patches, print only those that affect foo.c."+    ]+  , [ "Four output formats exist.  The default is `--human-readable`. The slightly"+    , "different `--machine-readable` format enables to see patch dependencies in"+    , "non-interactive mode. You can also select `--context`, which is an internal"+    , "format that can be re-read by Darcs (e.g. `darcs clone --context`)."+    ]+  , [ "Finally, there is `--xml-output`, which emits valid XML... unless a the"+    , "patch metadata (author, name or description) contains a non-ASCII"+    , "character and was recorded in a non-UTF8 locale."+    ]+  ] -log :: DarcsCommand [DarcsFlag]+log :: DarcsCommand log = DarcsCommand     { commandProgramName = "darcs"     , commandName = "log"@@ -118,7 +155,6 @@     , commandBasicOptions = odesc logBasicOpts     , commandDefaults = defaultFlags logOpts     , commandCheckOptions = ocheck logOpts-    , commandParseOptions = onormalise logOpts     }   where     logBasicOpts@@ -126,7 +162,7 @@       ^ O.maxCount       ^ O.onlyToFiles       ^ O.changesFormat-      ^ O.summary+      ^ O.withSummary       ^ O.changesReverse       ^ O.possiblyRemoteRepo       ^ O.repoDir@@ -142,27 +178,26 @@   | hasRemoteRepo opts = do       (fs, es) <- remoteSubPaths args []       if null es then-        withTempDir "darcs.log" (\_ -> showLog opts $ maybeNotNull $ nub $ sort fs)+        withTempDir "darcs.log"+          (\_ -> showLog opts $ maybeNotNull $ nubSort $ map floatSubPath fs)       else         fail $ "For a remote repo I can only handle relative paths.\n"             ++ "Invalid arguments: "++unwords es   | null args = showLog opts Nothing   | otherwise = do-      fs <- fixSubPaths fps args-      case fs of-        [] -> putStrLn "No valid arguments were given, nothing to do."-        _ -> do unless (isInteractive False opts)-                 $ when (O.patchIndexNo ? opts == O.YesPatchIndex)-                  $ withRepoLockCanFail (useCache ? opts)-                    $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo)-                showLog opts $ Just $ nub $ sort fs+      unless (isInteractive False opts)+        $ when (O.patchIndexNo ? opts == O.YesPatchIndex)+          $ withRepoLockCanFail (useCache ? opts)+            $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo)+      paths <- pathSetFromArgs fps args+      showLog opts paths  maybeNotNull :: [a] -> Maybe [a] maybeNotNull [] = Nothing maybeNotNull xs = Just xs  hasRemoteRepo :: [DarcsFlag] -> Bool-hasRemoteRepo = maybe False (not . isValidLocalPath) . parseFlags O.possiblyRemoteRepo+hasRemoteRepo = isJust . getRepourl  remoteSubPaths :: [String] -> [String] -> IO ([SubPath],[String]) remoteSubPaths [] es = return ([], es)@@ -172,7 +207,7 @@     (sps, es') <- remoteSubPaths args es     return (sp:sps, es') -showLog :: [DarcsFlag] -> Maybe [SubPath] -> IO ()+showLog :: [DarcsFlag] -> Maybe [AnchoredPath] -> IO () showLog opts files =   let repodir = fromMaybe "." (getRepourl opts) in   withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do@@ -186,9 +221,7 @@   debugMessage "About to read the repository..."   patches <- readRepo repository   debugMessage "Done reading the repository."-  let normfp = fn2fp . normPath . fp2fn-      undoUnrecordedOnFPs = effectOnFilePaths (invert unrec)-      recFiles = map normfp . undoUnrecordedOnFPs . map toFilePath <$> files+  let recFiles = effectOnPaths (invert unrec) <$> files       filtered_changes p =           maybe_reverse <$>           getLogInfo@@ -199,80 +232,81 @@               (maybeFilterPatches repository patches)               p   if isInteractive False opts-    then do (fp_and_fs, _, _) <- filtered_changes patches-            let fp = map fst fp_and_fs-            viewChanges (logPatchSelOpts opts) fp-    else do let header = if isJust files && hasXmlOutput opts-                          then text $ "Changes to "++unwords (fromJust recFiles)++":\n"-                          else empty+    then do li <- filtered_changes patches+            viewChanges (logPatchSelOpts opts) (map fst (liPatches li))+    else do let header =+                  case recFiles of+                    Just fs | not (hasXmlOutput opts) ->+                      let pathlist = map (text . displayPath) fs+                      in hsep (text "Changes to" : pathlist) <> text ":" $$ text ""+                    _ -> mempty             debugMessage "About to print the patches..."             let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters             ps <- readRepo repository -- read repo again to prevent holding onto                                        -- values forced by filtered_changes-            logOutput <- changelog opts ps `fmap` filtered_changes patches-            viewDocWith printers $ header $$ logOutput-  where maybe_reverse (xs,b,c) = if changesReverse ? opts-                                 then (reverse xs, b, c)-                                 else (xs, b, c)+            logOutput <- changelog opts (patchSet2RL ps) `fmap` filtered_changes patches+            viewDocWith printers (header $$ logOutput)+  where+    maybe_reverse li@(LogInfo xs b c) =+      if changesReverse ? opts then LogInfo (reverse xs) b c else li -logHelp' :: String-logHelp' = unlines- [ "When given files or directories paths as arguments, only patches which"- , "affect those paths are listed.  This includes patches that happened to"- , "files before they were moved or renamed."- , ""- , "When given `--from-tag` or `--from-patch`, only patches since that tag"- , "or patch are listed.  Similarly, the `--to-tag` and `--to-patch`"- , "options restrict the list to older patches."- , ""- , "The `--last` and `--max-count` options both limit the number of patches"- , "listed.  The former applies BEFORE other filters, whereas the latter"- , "applies AFTER other filters.  For example `darcs log foo.c"- , "--max-count 3` will print the last three patches that affect foo.c,"- , "whereas `darcs log --last 3 foo.c` will, of the last three"- , "patches, print only those that affect foo.c."- , ""- ]+data LogInfo p = LogInfo+  { liPatches :: [(Sealed2 p, [AnchoredPath])]+  , liRenames :: [(AnchoredPath, AnchoredPath)]+  , liErrorMsg :: Maybe Doc+  } -getLogInfo :: forall rt p wX wY-                . (IsRepoType rt, Matchable p, ApplyState p ~ Tree)-               => Maybe Int -> [MatchFlag] -> Bool-               -> Maybe [FilePath]-               -> PatchFilter rt p-               -> PatchSet rt p wX wY-               -> IO ( [(Sealed2 (PatchInfoAnd rt p), [FilePath])]-                     , [(FilePath, FilePath)]-                     , Maybe Doc )-getLogInfo maxCountFlag matchFlags onlyToFilesFlag plain_fs patchFilter ps =-    case (sp1s, sp2s) of-      (Sealed p1s, Sealed p2s) ->-          case findCommonWithThem p2s p1s of-            _ :> us ->-              let ps' = filterRL pf (reverseFL us) in-                case plain_fs of-                  Nothing -> return $ foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $-                    maybe id take maxCountFlag ps'-                  Just fs -> let fs' = map (\x -> "./" ++ x) fs in do-                    filterOutUnrelatedChanges <$> do-                       ps'' <- patchFilter fs' ps'-                       return $ filterPatchesByNames maxCountFlag fs' ps''-  where-        sp1s = if firstMatch matchFlags-               then matchFirstPatchset matchFlags ps-               else Sealed $ PatchSet NilRL NilRL-        sp2s = if secondMatch matchFlags-               then matchSecondPatchset matchFlags ps-               else Sealed ps-        pf = if haveNonrangeMatch (PatchType :: PatchType rt p) matchFlags-             then matchAPatch matchFlags-             else \_ -> True+mkLogInfo :: [Sealed2 p] -> LogInfo p+mkLogInfo ps = LogInfo (map (,[]) ps) [] Nothing -        filterOutUnrelatedChanges (pfs, renames, doc)-          | onlyToFilesFlag = (map onlyRelated pfs, renames, doc)-          | otherwise       = (pfs, renames, doc)+logInfoFL :: FL p wX wY -> LogInfo p+logInfoFL = mkLogInfo . mapFL Sealed2 +matchNonrange :: (Matchable p, PatchId p ~ PatchInfo)+              => [MatchFlag] -> RL p wA wB -> [Sealed2 p]+matchNonrange matchFlags+  | haveNonrangeMatch matchFlags = filterRL (matchAPatch matchFlags)+  | otherwise = mapRL Sealed2++simpleLogInfo :: ( MatchableRP p+                 , ApplyState p ~ Tree+                 )+              => AnchoredPath+              -> PatchFilter rt p+              -> PatchSet rt p Origin wY+              -> IO [Sealed2 (PatchInfoAnd rt p)]+simpleLogInfo path pf ps =+  map fst . liPatches <$> getLogInfo Nothing [] False (Just [path]) pf ps++getLogInfo :: forall rt 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))+getLogInfo maxCountFlag matchFlags onlyToFilesFlag paths patchFilter ps =+  case matchRange matchFlags ps of+    Sealed2 range ->+      let ps' = matchNonrange matchFlags (reverseFL range) in+      case paths of+        Nothing -> return $ mkLogInfo $ maybe id take maxCountFlag ps'+        Just fs -> do+          filterOutUnrelatedChanges <$> do+            ps'' <- patchFilter fs ps'+            return $ filterPatchesByNames maxCountFlag fs ps''+  where+        -- What we do here is somewhat unclean: we modify the contents of+        -- our patches and throw out everything not related to our files.+        -- This is okay because we only use the result for display.+        filterOutUnrelatedChanges li+          | onlyToFilesFlag = li { liPatches = map onlyRelated (liPatches li) }+          | otherwise       = li+         onlyRelated (Sealed2 p, fs) =-          (Sealed2 $ fmapFLPIAP (filterOutFLFL (unrelated fs)) (\_ -> ReflPatch) p, fs)+          (Sealed2 $ fmapFLPIAP (filterOutFLFL (unrelated fs)) p, fs)          unrelated fs p           -- If the change does not affect the patches we are looking at,@@ -288,80 +322,79 @@ -- "Just n" -- returns at most n patches touching the file (starting from the -- beginning of the patch list). filterPatchesByNames-    :: forall rt p-     . (Matchable p, ApplyState p ~ Tree)-    => Maybe Int -- ^ maxcount-    -> [FilePath] -- ^ filenames-    -> [Sealed2 (PatchInfoAnd rt p)] -- ^ patchlist-    -> ([(Sealed2 (PatchInfoAnd rt p),[FilePath])], [(FilePath, FilePath)], Maybe Doc)-filterPatchesByNames maxcount fns patches = removeNonRenames $-    evalState (filterPatchesByNames' fns patches) (maxcount, initRenames) where-        removeNonRenames (ps, renames, doc) = (ps, removeIds renames, doc)+    :: forall rt p.+       ( MatchableRP p+       , ApplyState p ~ Tree+       )+    => Maybe Int                      -- ^ maxcount+    -> [AnchoredPath]                 -- ^ paths+    -> [Sealed2 (PatchInfoAnd rt p)]  -- ^ patches+    -> LogInfo (PatchInfoAnd rt p)+filterPatchesByNames maxcount paths patches = removeNonRenames $+    evalState (filterPatchesByNamesM paths patches) (maxcount, initRenames) where+        removeNonRenames li = li { liRenames = removeIds (liRenames li) }         removeIds = filter $ uncurry (/=)-        initRenames = map (\x -> (x, x)) fns-        returnFinal = (\renames -> ([], renames, Nothing)) <$> gets snd-        filterPatchesByNames' [] _ = returnFinal-        filterPatchesByNames' _ [] = returnFinal-        filterPatchesByNames' fs (s2hp@(Sealed2 hp) : ps) = do+        initRenames = map (\x -> (x, x)) paths+        returnFinal = (\renames -> LogInfo [] renames Nothing) <$> gets snd+        filterPatchesByNamesM [] _ = returnFinal+        filterPatchesByNamesM _ [] = returnFinal+        filterPatchesByNamesM fs (s2hp@(Sealed2 hp) : ps) = do             (count, renames) <- get-            let stopNow = case count of-                                Nothing -> False-                                Just c -> c <= 0-            if stopNow-                then returnFinal-                else case hopefullyM hp of+            case count of+                Just c | c <= 0 -> returnFinal+                _ ->+                  case hopefullyM hp of                     Nothing -> do                         let err = text "Can't find patches prior to:"                                   $$ displayPatchInfo (info hp)-                        return ([], renames, Just err)+                        return (LogInfo [] renames (Just err))                     Just p ->-                        case lookTouch (Just renames) fs (invert p) of+                        case lookTouch (Just renames) fs (invert (mkInvertible p)) of                             (True, affected, [], renames') ->-                                return ([(s2hp, affected)], renames', Nothing)+                                return (LogInfo [(s2hp, affected)] renames' Nothing)                             (True, affected, fs', renames') -> do                                 let sub1Mb c = subtract 1 <$> c                                 modify $ \(c, _) -> (sub1Mb c, renames')-                                rest <- filterPatchesByNames' fs' ps-                                return $ (s2hp, affected) -:- rest+                                rest <- filterPatchesByNamesM fs' ps+                                return $ rest {+                                    liPatches = (s2hp, affected) : liPatches rest+                                  }                             (False, _, fs', renames') -> do                                 modify $ second (const renames')-                                filterPatchesByNames' fs' ps---- | Note, lazy pattern matching is required to make functions like--- filterPatchesByNames lazy in case you are only not interested in--- the first element. E.g.:------   let (fs, _, _) = filterPatchesByNames ...-(-:-) :: a -> ([a],b,c) -> ([a],b,c)-x -:- ~(xs,y,z) = (x:xs,y,z)+                                filterPatchesByNamesM fs' ps  changelog :: forall rt p wStart wX-           . ( Apply p, ApplyState p ~ Tree, ShowPatch p, IsHunk p-             , PrimPatchBase p, PatchListFormat p-             , Conflict p, CommuteNoConflicts p+           . ( ShowPatch p, PatchListFormat p+             , Summary p, HasDeps p, PrimDetails (PrimOf p)              )-          => [DarcsFlag] -> PatchSet rt p wStart wX-          -> ([(Sealed2 (PatchInfoAnd rt p), [FilePath])], [(FilePath, FilePath)], Maybe Doc)+          => [DarcsFlag] -> RL (PatchInfoAndG rt p) wStart wX+          -> LogInfo (PatchInfoAndG rt p)           -> Doc-changelog opts patchset (pis_and_fs, createdAsFs, mbErr)-    | O.changesFormat ? opts == Just O.CountPatches = text $ show $ length pis_and_fs-    | hasXmlOutput opts =-         text "<changelog>"-      $$ vcat created_as_xml-      $$ vcat actual_xml_changes-      $$ text "</changelog>"-    | O.yes (O.summary ? opts) || verbose opts =-        mbAppendErr $ vsep (map (number_patch change_with_summary) pis)-    | otherwise = mbAppendErr $ vsep (map (number_patch description') pis)-    where mbAppendErr = maybe id (\err -> ($$ err)) mbErr-          change_with_summary :: Sealed2 (PatchInfoAnd rt p) -> Doc+changelog opts patches li+    | O.changesFormat ? opts == Just O.CountPatches =+        text $ show $ length $ liPatches li+    | hasXmlOutput opts = xml_changelog+    | O.yes (O.withSummary ? opts) || verbose opts =+        vsep (map (number_patch change_with_summary) ps) $$ mbErr+    | otherwise = vsep (map (number_patch description') ps) $$ mbErr+    where ps_and_fs = liPatches li+          mbErr = fromMaybe mempty (liErrorMsg li)+          change_with_summary :: Sealed2 (PatchInfoAndG rt p) -> Doc           change_with_summary (Sealed2 hp)             | Just p <- hopefullyM hp =               if O.changesFormat ? opts == Just O.MachineReadable                 then showPatch ForStorage p-                else showFriendly (verbosity ? opts) (O.summary ? opts) p+                else showFriendly (verbosity ? opts) (O.withSummary ? opts) p             | otherwise = description hp $$ indent (text "[this patch is unavailable]") +          xml_changelog = vcat+            [ text "<changelog>"+            , vcat xml_created_as+            , vcat xml_changes+            , text "</changelog>"+            ]++          xml_with_summary :: Sealed2 (PatchInfoAndG rt p) -> Doc           xml_with_summary (Sealed2 hp) | Just p <- hopefullyM hp =                     let                       deps = getdeps p@@ -375,71 +408,61 @@                       insertBeforeLastline (toXml $ info hp) summary           xml_with_summary (Sealed2 hp) = toXml (info hp)           indent = prefix "    "-          actual_xml_changes =-            case O.summary ? opts of-              O.YesSummary -> map xml_with_summary pis-              O.NoSummary -> map (toXml . unseal2 info) pis--          created_as_xml = map create createdAsFs where+          xml_changes =+            case O.withSummary ? opts of+              O.YesSummary -> map xml_with_summary ps+              O.NoSummary -> map (toXml . unseal2 info) ps+          xml_created_as = map create (liRenames li) where+            create :: (AnchoredPath, AnchoredPath) -> Doc             create rename@(_, as) = createdAsXml (first_change_of as) rename             -- We need to reorder the patches when they haven't been reversed             -- already, so that we find the *first* patch that modifies a given             -- file, not the last (by default, the list is oldest->newest).             reorderer = if not (changesReverse ? opts) then reverse else id-            oldest_first_pis_and_fs = reorderer pis_and_fs+            oldest_first_ps_and_fs = reorderer ps_and_fs             couldnt_find fn = error $ "Couldn't find first patch affecting " ++-                                      fn ++ " in pis_and_fs"-            mb_first_change_of fn = find ((fn `elem`) . snd) oldest_first_pis_and_fs+                                      (displayPath fn) ++ " in ps_and_fs"+            mb_first_change_of fn = find ((fn `elem`) . snd) oldest_first_ps_and_fs             find_first_change_of fn = fromMaybe (couldnt_find fn)               (mb_first_change_of fn)+            first_change_of :: AnchoredPath -> PatchInfo             first_change_of = unseal2 info . fst . find_first_change_of+           number_patch f x = if O.changesFormat ? opts == Just O.NumberPatches                              then case get_number x of                                   Just n -> text (show n++":") <+> f x                                   Nothing -> f x                              else f x-          get_number :: Sealed2 (PatchInfoAnd re p) -> Maybe Int-          get_number (Sealed2 y) = gn 1 (patchSet2RL patchset)++          get_number :: Sealed2 (PatchInfoAndG re p) -> Maybe Int+          get_number (Sealed2 y) = gn 1 patches               where iy = info y-                    gn :: Int -> RL (PatchInfoAnd rt p) wStart wY -> Maybe Int+                    gn :: Int -> RL (PatchInfoAndG rt p) wStart wY -> Maybe Int                     gn n (bs:<:b) | seq n (info b) == iy = Just n                                   | otherwise = gn (n+1) bs                     gn _ NilRL = Nothing-          pis = map fst pis_and_fs+          ps = map fst ps_and_fs           description' = unseal2 description -logHelp'' :: String-logHelp'' = unlines- [ "Four output formats exist.  The default is `--human-readable`. The slightly"- , "different `--machine-readable` format enables to see patch dependencies in"- , "non-interactive mode. You can also select `--context`, which is an internal"- , "format that can be re-read by Darcs (e.g. `darcs clone --context`)."- , ""- , "Finally, there is `--xml-output`, which emits valid XML... unless a the"- , "patch metadata (author, name or description) contains a non-ASCII"- , "character and was recorded in a non-UTF8 locale."- ]- logContext :: [DarcsFlag] -> IO () logContext opts = do   let repodir = fromMaybe "." $ getRepourl opts   withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do-      (_ :> ps') <- contextPatches `fmap` readRepo repository-      let pis = mapRL seal2 ps'+      (_ :> ps) <- contextPatches `fmap` readRepo repository       let header = text "\nContext:\n"-      let logOutput = maybe (vsep $ map (unseal2 (showPatchInfo ForStorage . info)) pis) errorDoc Nothing-      viewDocWith simplePrinters $ header $$ logOutput+      viewDocWith simplePrinters $ vsep+          (header : mapRL (showPatchInfo ForStorage . info) ps)  -- | changes is an alias for log-changes :: DarcsCommand [DarcsFlag]+changes :: DarcsCommand changes = commandAlias "changes" Nothing log -createdAsXml :: PatchInfo -> (String, String) -> Doc+createdAsXml :: PatchInfo -> (AnchoredPath, AnchoredPath) -> Doc createdAsXml pinfo (current, createdAs) =     text "<created_as current_name='"-       <> escapeXML current+       <> escapeXML (displayPath current)        <> text "' original_name='"-       <> escapeXML createdAs+       <> escapeXML (displayPath createdAs)        <> text "'>"     $$    toXml pinfo     $$    text "</created_as>"@@ -450,6 +473,6 @@     , S.matchFlags = parseFlags O.matchSeveralOrRange flags     , S.interactive = isInteractive False flags     , S.selectDeps = O.PromptDeps -- option not supported, use default-    , S.summary = O.summary ? flags+    , S.withSummary = O.withSummary ? flags     , S.withContext = withContext ? flags     }
src/Darcs/UI/Commands/MarkConflicts.hs view
@@ -19,34 +19,36 @@  module Darcs.UI.Commands.MarkConflicts ( markconflicts ) where -import Prelude () import Darcs.Prelude  import System.Exit ( exitSuccess ) import Data.List.Ordered ( nubSort, isect )-import Data.Maybe ( fromJust )-import Control.Monad ( when, unless )-import Control.Exception ( catch, IOException )+import Control.Monad ( when, unless, void )  import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.SignalHandler ( withSignalsBlocked )-import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath, simpleSubPath )+import Darcs.Util.Path ( AbsolutePath, AnchoredPath, anchorPath ) import Darcs.Util.Printer-    ( Doc, putDocLnWith, text, redText, debugDocLn, vsep, (<+>), ($$) )+    ( Doc, pathlist, putDocLnWith, text, redText, debugDocLn, vsep, (<+>), ($$) ) import Darcs.Util.Printer.Color ( fancyPrinters )-import Darcs.Util.Text ( pathlist )  import Darcs.UI.Commands-    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putInfo )+    ( DarcsCommand(..)+    , withStdOpts+    , nodefaults+    , amInHashedRepository+    , putInfo+    , putFinished+    ) import Darcs.UI.Commands.Util ( filterExistingPaths ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.Flags     ( DarcsFlag, diffingOpts, verbosity, dryRun, umask-    , useCache, fixSubPaths )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )+    , useCache, pathSetFromArgs )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O -import Darcs.Repository.Flags ( UpdateWorking (..) )+import Darcs.Repository.Flags ( UpdatePending (..) ) import Darcs.Repository     ( withRepoLock     , RepoJob(..)@@ -55,12 +57,16 @@     , readRepo     , unrecordedChanges ) -import Darcs.Patch ( invert, listTouchedFiles, effectOnFilePaths )+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.Sealed ( Sealed(Sealed) )-import Darcs.Repository.Resolution ( patchsetConflictResolutions )+import Darcs.Repository.Resolution+    ( StandardResolution(..)+    , patchsetConflictResolutions+    , warnUnmangled+    )  -- * The mark-conflicts command @@ -68,8 +74,8 @@ markconflictsDescription =  "Mark unresolved conflicts in working tree, for manual resolution." -markconflictsHelp :: String-markconflictsHelp = unlines+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"@@ -94,7 +100,7 @@  ,"You will be prompted for confirmation before this takes place."  ] -markconflicts :: DarcsCommand [DarcsFlag]+markconflicts :: DarcsCommand markconflicts = DarcsCommand     { commandProgramName = "darcs"     , commandName = "mark-conflicts"@@ -110,7 +116,6 @@     , commandBasicOptions = odesc markconflictsBasicOpts     , commandDefaults = defaultFlags markconflictsOpts     , commandCheckOptions = ocheck markconflictsOpts-    , commandParseOptions = onormalise markconflictsOpts     }   where     markconflictsBasicOpts@@ -123,9 +128,10 @@  markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () markconflictsCmd fps opts args = do-  paths <- if null args then return Everything else sps2ps <$> fixSubPaths fps args -- Applicative IO+  paths <- maybeToOnly <$> pathSetFromArgs fps args   debugDocLn $ "::: paths =" <+>  (text . show) paths-  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do+  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+    RepoJob $ \_repository -> do  {-     What we do here:@@ -149,28 +155,32 @@     let (useidx, scan, _) = diffingOpts opts         verb = verbosity ? opts     classified_paths <--      traverse (filterExistingPaths repository verb useidx scan O.NoLookForMoves) paths+      traverse (filterExistingPaths _repository verb useidx scan O.NoLookForMoves) paths      unrecorded <- unrecordedChanges (diffingOpts opts)       O.NoLookForMoves O.NoLookForReplaces-      repository (fromOnly Everything)+      _repository (fromOnly Everything) -    let forward_renames = liftToPathSet (effectOnFilePaths unrecorded)-        backward_renames = liftToPathSet (effectOnFilePaths (invert unrecorded))+    let forward_renames = effectOnPaths unrecorded+        backward_renames = effectOnPaths (invert unrecorded)         existing_paths = fmap snd classified_paths-        pre_pending_paths = backward_renames existing_paths+        pre_pending_paths = fmap backward_renames existing_paths     debugDocLn $ "::: pre_pending_paths =" <+> (text . show) pre_pending_paths -    r <- readRepo repository+    r <- readRepo _repository     Sealed res <- case patchsetConflictResolutions r of-      Sealed raw_res -> do-        let raw_res_paths = fps2ps (listTouchedFiles raw_res)+      conflicts -> do+        -- FIXME this should warn only about unmangled conflicts+        -- involving the file paths we care about+        warnUnmangled conflicts+        Sealed mangled_res <- return $ mangled conflicts+        let raw_res_paths = pathSet $ listTouchedFiles mangled_res         debugDocLn $ "::: raw_res_paths =" <+>  (text . show) raw_res_paths-        return $ chooseTouching (ps2fps pre_pending_paths) raw_res-    let res_paths = fps2ps (listTouchedFiles res)+        return $ chooseTouching (fromOnly pre_pending_paths) mangled_res+    let res_paths = pathSet $ listTouchedFiles res     debugDocLn $ "::: res_paths =" <+>  (text . show) res_paths -    let affected_paths = isectPathSet res_paths pre_pending_paths+    let affected_paths = res_paths `isectPathSet` pre_pending_paths     debugDocLn $ "::: affected_paths =" <+>  (text . show) affected_paths      when (affected_paths == Only []) $ do@@ -179,9 +189,9 @@      to_revert <- unrecordedChanges (diffingOpts opts)       O.NoLookForMoves O.NoLookForReplaces-      repository (fromOnly affected_paths)+      _repository (fromOnly affected_paths) -    let post_pending_affected_paths = forward_renames 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)@@ -190,8 +200,8 @@         putInfo opts $ "Conflicts will not be marked: this is a dry run."         exitSuccess -    repository' <- case to_revert of-      NilFL -> return repository+    _repository <- case to_revert of+      NilFL -> return _repository       _ -> do         -- TODO:         -- (1) create backups for all files where we revert changes@@ -209,19 +219,16 @@         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 directory."+        debugMessage "About to apply to the working tree." -}          let to_add = invert to_revert-        addToPending repository YesUpdateWorking to_add-        applyToWorking repository (verbosity ? opts) to_add `catch` \(e :: IOException) ->-           bug ("Can't undo pending changes!" ++ show e)+        addToPending _repository (O.useIndex ? opts) to_add+        applyToWorking _repository (verbosity ? opts) to_add     withSignalsBlocked $-      do addToPending repository' YesUpdateWorking res-         _ <- applyToWorking repository' (verbosity ? opts) res `catch` \(e :: IOException) ->-             bug ("Problem marking conflicts in mark-conflicts!" ++ show e)-         return ()-    putInfo opts "Finished marking conflicts."+      do addToPending _repository (O.useIndex ? opts) res+         void $ applyToWorking _repository (verbosity ? opts) res+    putFinished opts "marking conflicts"  -- * Generic 'PathSet' support @@ -269,21 +276,20 @@ fromOnly Everything = Nothing fromOnly (Only x) = Just x -{- | A set of repository paths. 'Everything' means every path in the repo, it-usually originates from an empty list of path arguments. The list of-'SubPath's is always kept in sorted order with no duplicates and normalised-(as in 'FilePath.normalise'). This has the nice effect of getting rid of the-idiotic "./" that Darcs insists on prepending to repo paths (which can make-things like comparing paths returned from different parts of the code base a-nightmare).+maybeToOnly :: Maybe a -> Only a+maybeToOnly Nothing = Everything+maybeToOnly (Just x) = Only x -It uses 'SubPath' for easier compatibility and lists because the number of-elements is expected to be small.+{- | A set of repository paths. 'Everything' means every path in the repo,+it usually originates from an empty list of path arguments. The list of+'AnchoredPath's is always kept in sorted order with no duplicates.++It uses lists because the number of elements is expected to be small. -}-type PathSet = Only [SubPath]+type PathSet a = Only [a]  -- | Intersection of two 'PathSet's-isectPathSet :: PathSet -> PathSet -> PathSet+isectPathSet :: Ord a => PathSet a -> PathSet a -> PathSet a isectPathSet Everything ys = ys isectPathSet xs Everything = xs isectPathSet (Only xs) (Only ys) = Only (isect xs ys)@@ -296,39 +302,11 @@ union (Only xs) (Only ys) = Only (union xs ys) -} --- | Convert a list of 'SubPath's to a 'PathSet'.-sps2ps :: [SubPath] -> PathSet-sps2ps = Only . nubSort---- | Convert a list of repo paths to a 'PathSet'.--- Partial function! Use only with repo paths.-fps2ps :: [FilePath] -> PathSet-fps2ps = sps2ps . map fp2sp---- | Convert a 'PathSet' to something that e.g. 'chooseTouching'--- takes as parameter.-ps2fps :: PathSet -> Maybe [FilePath]-ps2fps = fmap (map sp2fp) . fromOnly+pathSet :: Ord a => [a] -> PathSet a+pathSet = Only . nubSort  -- | Convert a 'PathSet' to a 'Doc'. Uses the English module -- to generate a nicely readable list of file names.-showPathSet :: Only [SubPath] -> Doc+showPathSet :: PathSet AnchoredPath -> Doc showPathSet Everything = text "all paths"-showPathSet (Only xs) = pathlist (map sp2fp xs)---- | Lift a function transforming a list of 'FilePath' to one that--- transforms a 'PathSet'.-liftToPathSet :: ([FilePath] -> [FilePath]) -> PathSet -> PathSet-liftToPathSet f = fmap (nubSort . map fp2sp . f . map sp2fp)---- | Convert a 'FilePath' to a 'SubPath'.------ Note: Should call this only with paths we get from the repository.--- This guarantees that they are relative (to the repo dir).-fp2sp :: FilePath -> SubPath-fp2sp = fromJust . simpleSubPath---- | Convert a 'SubPath' to a 'FilePath'. Same as 'toFilePath' and--- only here for symmetry.-sp2fp :: SubPath -> FilePath-sp2fp = toFilePath+showPathSet (Only xs) = pathlist (map (anchorPath "") xs)
src/Darcs/UI/Commands/Move.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RankNTypes #-} --  Copyright (C) 2002-2003 David Roundy -- --  This program is free software; you can redistribute it and/or modify@@ -18,7 +17,6 @@  module Darcs.UI.Commands.Move ( move, mv ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when, unless, forM_, forM )@@ -33,16 +31,14 @@ import Darcs.UI.Flags     ( DarcsFlag     , allowCaseDifferingFilenames, allowWindowsReservedFilenames-    , useCache, dryRun, umask-    , maybeFixSubPaths, fixSubPaths+    , useCache, dryRun, umask, pathsFromArgs     )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Diff ( treeDiff )-import Darcs.Repository.Flags ( UpdateWorking (..), DiffAlgorithm(..) )+import Darcs.Repository.Flags ( UpdatePending (..), DiffAlgorithm(..) ) import Darcs.Repository.Prefs ( filetypeFunction )-import System.FilePath.Posix ( (</>), takeFileName )-import System.Directory ( renameDirectory )+import System.Directory ( renameDirectory, renameFile ) import Darcs.Repository.State ( readRecordedAndPending, readRecorded, updateIndex ) import Darcs.Repository     ( Repository@@ -56,29 +52,28 @@ import qualified Darcs.Patch import Darcs.Patch ( RepoPatch, PrimPatch ) import Darcs.Patch.Apply( ApplyState )-import Data.List ( nub, sort )+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.Path-    ( floatPath-    , fp2fn-    , fn2fp-    , superName-    , SubPath()-    , toFilePath-    , AbsolutePath+    ( AbsolutePath+    , AnchoredPath+    , displayPath+    , isRoot+    , parent+    , realPath+    , replaceParent     )-import Darcs.Util.Printer ( text, hsep )-import Darcs.Util.Workaround ( renameFile )+import Darcs.Util.Printer ( Doc, text, hsep )  moveDescription :: String moveDescription = "Move or rename files." -moveHelp :: String-moveHelp =+moveHelp :: Doc+moveHelp = text $  "Darcs cannot reliably distinguish between a file being deleted and a\n" ++  "new one added, and a file being moved.  Therefore Darcs always assumes\n" ++  "the former, and provides the `darcs mv` command to let Darcs know when\n" ++@@ -93,7 +88,7 @@  "`ReadMe` and `README`).  If `--case-ok` is used, the repository might be\n" ++  "unusable on those systems!\n" -move :: DarcsCommand [DarcsFlag]+move :: DarcsCommand move = DarcsCommand     { commandProgramName = "darcs"     , commandName = "move"@@ -109,7 +104,6 @@     , commandBasicOptions = odesc moveBasicOpts     , commandDefaults = defaultFlags moveOpts     , commandCheckOptions = ocheck moveOpts-    , commandParseOptions = onormalise moveOpts     }   where     moveBasicOpts = O.allowProblematicFilenames ^ O.repoDir@@ -120,32 +114,26 @@ moveCmd fps opts args   | length args < 2 =       fail "The `darcs move' command requires at least two arguments."-  | length args == 2 = do-      -- NOTE: The extra case for two arguments is necessary because-      -- in this case we allow file -> file moves. Whereas with 3 or-      -- more arguments the last one (i.e. the target) must be a directory.-      xs <- maybeFixSubPaths fps args-      case xs of-        [Just from, Just to]-          | from == to -> fail "Cannot rename a file or directory onto itself."-          | toFilePath from == "" -> fail "Cannot move the root of the repository."-          | otherwise -> moveFile opts from to-        _ -> fail "Both source and destination must be valid."-  | otherwise = let (froms, to) = (init args, last args) in do-      x <- head <$> maybeFixSubPaths fps [to]-      case x of-        Nothing -> fail "Invalid destination directory."-        Just to' -> do-          xs <- nub . sort <$> fixSubPaths fps froms-          if to' `elem` xs-            then fail "Cannot rename a file or directory onto itself."-            else case xs of-              [] -> fail "Nothing to move."-              froms' ->-                if or (map (null . toFilePath) froms') then-                  fail "Cannot move the root of the repository."-                else-                  moveFilesToDir opts froms' to'+  | otherwise = do+      paths <- pathsFromArgs fps args+      when (length paths < 2) $+        fail "Note enough valid path arguments remaining."+      case paths of+        [from, to] -> do+          -- NOTE: The extra case for two arguments is necessary because+          -- in this case we allow file -> file moves. Whereas with 3 or+          -- more arguments the last one (i.e. the target) must be a directory.+          when (from == to) $ fail "Cannot rename a file or directory onto itself."+          when (isRoot from) $ fail "Cannot move the root of the repository."+          moveFile opts from to+        _ -> do+          let froms = init paths+              to = last paths+          when (to `elem` froms) $+            fail "Cannot rename a file or directory onto itself."+          when (any isRoot froms) $+            fail "Cannot move the root of the repository."+          moveFilesToDir opts (nubSort froms) to  data FileKind = Dir | File               deriving (Show, Eq)@@ -153,14 +141,14 @@ data FileStatus =   Nonexistant   | Unadded FileKind-  | Shadow FileKind -- ^ known to darcs, but absent in working copy+  | Shadow FileKind -- ^ known to darcs, but absent in working tree   | Known FileKind   deriving Show  fileStatus :: Tree IO -- ^ tree of the working directory            -> Tree IO -- ^ tree of recorded and pending changes            -> Tree IO -- ^ tree of recorded changes-           -> FilePath+           -> AnchoredPath            -> IO FileStatus fileStatus work cur recorded fp = do   existsInCur <- treeHas cur fp@@ -170,7 +158,8 @@     (_, True, True) -> do       isDirCur <- treeHasDir cur fp       isDirWork <- treeHasDir work fp-      unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ fp+      -- TODO is this an impossible case? else improve the error message!+      unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ displayPath fp       return . Known $ if isDirCur then Dir else File      (_, False, True) -> do@@ -188,34 +177,33 @@ -- | Takes two filenames (as 'Subpath'), and tries to move the first -- into/onto the second. Needs to guess what that means: renaming or moving -- into a directory, and whether it is a post-hoc move.-moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()+moveFile :: [DarcsFlag] -> AnchoredPath -> AnchoredPath -> IO () moveFile opts old new = withRepoAndState opts $ \(repo, work, cur, recorded) -> do-  let old_fp = toFilePath old-      new_fp = toFilePath new-  new_fs <- fileStatus work cur recorded new_fp-  old_fs <- fileStatus work cur recorded old_fp-  let doSimpleMove = simpleMove repo opts cur work old_fp new_fp+  new_fs <- fileStatus work cur recorded new+  old_fs <- fileStatus work cur recorded old+  let doSimpleMove = simpleMove repo opts cur work old new   case (old_fs, new_fs) of-    (Nonexistant, _) -> fail $ old_fp ++ " does not exist."-    (Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded."+    (Nonexistant, _) -> fail $ displayPath old ++ " does not exist."+    (Unadded k, _) -> fail $ show k ++ " " ++ displayPath old ++ " is unadded."     (Known _, Nonexistant) -> doSimpleMove     (Known _, Shadow _) -> doSimpleMove-    (_, Nonexistant) -> fail $ old_fp ++ " is not in the repository."-    (Known _, Known Dir) -> moveToDir repo opts cur work [old_fp] new_fp+    (_, Nonexistant) -> fail $ displayPath old ++ " is not in the repository."+    (Known _, Known Dir) -> moveToDir repo opts cur work [old] new     (Known _, Unadded Dir) -> fail $-        new_fp ++ " is not known to darcs; please add it to the repository."-    (Known _, _) -> fail $ new_fp ++ " already exists."+        displayPath new ++ " is not known to darcs; please add it to the repository."+    (Known _, _) -> fail $ displayPath new ++ " already exists."     (Shadow k, Unadded k') | k == k' -> doSimpleMove-    (Shadow File, Known Dir) -> moveToDir repo opts cur work [old_fp] new_fp+    (Shadow File, Known Dir) -> moveToDir repo opts cur work [old] new     (Shadow Dir, Known Dir) -> doSimpleMove     (Shadow File, Known File) -> doSimpleMove     (Shadow k, _) -> fail $-        "cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp+        "cannot move " ++ show k ++ " " ++ displayPath old ++ " into " ++ displayPath new         ++ " : " ++ "did you already move it elsewhere?" -moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()-moveFilesToDir opts froms to = withRepoAndState opts $ \(repo, work, cur, _) ->-  moveToDir repo opts cur work (map toFilePath froms) $ toFilePath to+moveFilesToDir :: [DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()+moveFilesToDir opts froms to =+  withRepoAndState opts $ \(repo, work, cur, _) ->+    moveToDir repo opts cur work froms to  withRepoAndState :: [DarcsFlag]                  -> (forall rt p wR wU .@@ -224,7 +212,7 @@                                 -> IO ())                  -> IO () withRepoAndState opts f =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repo -> do         work <- readPlainTree "."         cur <- readRecordedAndPending repo@@ -232,27 +220,30 @@         f (repo, work, cur, recorded)  simpleMove :: (RepoPatch p, ApplyState p ~ Tree)-           => Repository rt p wR wU wT-           -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath+           => Repository rt p wR wU wR+           -> [DarcsFlag] -> Tree IO -> Tree IO -> AnchoredPath -> AnchoredPath            -> IO ()-simpleMove repository opts cur work old_fp new_fp = do-    doMoves repository opts cur work [(old_fp, new_fp)]-    putInfo opts $ hsep $ map text ["Moved:", old_fp, "to:", new_fp]+simpleMove repository opts cur work old new = do+    doMoves repository opts cur work [(old, new)]+    putInfo opts $ hsep $ map text ["Finished moving:", displayPath old, "to:", displayPath new]  moveToDir :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository rt p wR wU wT-          -> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath+          => Repository rt p wR wU wR+          -> [DarcsFlag] -> Tree IO -> Tree IO -> [AnchoredPath] -> AnchoredPath           -> IO () moveToDir repository opts cur work moved finaldir = do-    let movetargets = map ((finaldir </>) . takeFileName) moved-        moves = zip moved movetargets+    -- note: we already checked that @moved@ is not the root,+    -- so we know that replaceParentPath can't fail+    let replaceParentPath a1 a2 =+          fromMaybe (error "cannot replace parent of root path") $ replaceParent a1 a2+    let moves = zip moved $ map (replaceParentPath finaldir) moved     doMoves repository opts cur work moves-    putInfo opts $ hsep $ map text $ ["Moved:"] ++ moved ++ ["to:", finaldir]+    putInfo opts $ hsep $ map text $ ["Finished moving:"] ++ map displayPath moved ++ ["to:", displayPath finaldir]  doMoves :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository rt p wR wU wT+          => Repository rt p wR wU wR           -> [DarcsFlag] -> Tree IO -> Tree IO-          -> [(FilePath, FilePath)] -> IO ()+          -> [(AnchoredPath, AnchoredPath)] -> IO () doMoves repository opts cur work moves = do   patches <- forM moves $ \(old, new) -> do         prePatch <- generatePreMovePatches opts cur work (old,new)@@ -263,7 +254,7 @@           pendingDiff = joinGap (+>+)             (fromMaybe (emptyGap NilFL) prePatch)             (freeGap $ Darcs.Patch.move old new :>: NilFL)-      addPendingDiffToPending repository YesUpdateWorking pendingDiff+      addPendingDiffToPending repository pendingDiff       moveFileOrDir work old new     updateIndex repository @@ -272,7 +263,7 @@ -- extra patches that are required to keep the repository consistent, in order -- to allow the move patch to be applied. generatePreMovePatches :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO-                       -> (FilePath, FilePath)+                       -> (AnchoredPath, AnchoredPath)                        -> IO (Maybe (FreeLeft (FL prim))) generatePreMovePatches opts cur work (old,new) = do     -- Only allow Windows-invalid paths if we've been told to do so@@ -280,10 +271,11 @@     -- Check if the first directory above the new path is in the repo (this     -- is the new path if itself is a directory), handling the case where     -- a user moves a file into a directory not known by darcs.-    let dirPath = fn2fp $ superName $ fp2fn new+    let dirPath =+          fromMaybe (error "unexpected root path in generatePreMovePatches") $ parent new     haveNewParent <- treeHasDir cur dirPath     unless haveNewParent $-        fail $ "The target directory " ++ dirPath+        fail $ "The target directory " ++ displayPath dirPath                 ++ " isn't known in the repository, did you forget to add it?"     newInRecorded <- hasNew cur     newInWorking <- hasNew work@@ -303,51 +295,52 @@           -- If we don't have the old or new in working, we're stuck           unless newInWorking $               fail $ "Cannot determine post-hoc move target, "-                     ++ "no file/dir named:\n" ++ new+                     ++ "no file/dir named:\n" ++ displayPath new           Just <$> if newInRecorded                        then deleteNewFromRepoPatches                        else return $ emptyGap NilFL   where     newIsOkWindowsPath =-        allowWindowsReservedFilenames ? opts || WindowsFilePath.isValid new+        allowWindowsReservedFilenames ? opts || WindowsFilePath.isValid (realPath new)      newNotOkWindowsPathMsg =-        "The filename " ++ new ++ " is not valid under Windows.\n"+        "The filename " ++ displayPath new ++ " is not valid under Windows.\n"         ++ "Use --reserved-ok to allow such filenames."      -- If we're moving to a file/dir that was recorded, but has been deleted,     -- we need to add patches to pending that remove the original.     deleteNewFromRepoPatches = do         putInfo opts $ text $-          "Existing recorded contents of " ++ new ++ " will be overwritten."+          "Existing recorded contents of " ++ displayPath new ++ " will be overwritten."         ftf <- filetypeFunction-        let curNoNew = modifyTree cur (floatPath new) Nothing+        let curNoNew = modifyTree cur new Nothing         -- Return patches to remove new, so that the move patch         -- can move onto new         treeDiff MyersDiff ftf cur curNoNew      -- Check if the passed tree has the new filepath. The old path is removed     -- from the tree before checking if the new path is present.-    hasNew s = treeHas_case (modifyTree s (floatPath old) Nothing) new+    hasNew s = treeHas_case (modifyTree s old Nothing) new     treeHas_case = if allowCaseDifferingFilenames ? opts then treeHas else treeHasAnycase      alreadyExists inWhat =         if allowCaseDifferingFilenames ? opts-            then "A file or dir named "++new++" already exists in "+            then "A file or dir named "++displayPath new++" already exists in "                   ++ inWhat ++ "."-            else "A file or dir named "++new++" (or perhaps differing "+            else "A file or dir named "++displayPath new++" (or perhaps differing "                  ++ "only in case)\nalready exists in "++ inWhat ++ ".\n"                  ++ "Use --case-ok to allow files differing only in case." -moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()+moveFileOrDir :: Tree IO -> AnchoredPath -> AnchoredPath -> IO () moveFileOrDir work old new = do   has_file <- treeHasFile work old   has_dir <- treeHasDir work old-  when has_file $ do debugMessage $ unwords ["renameFile",old,new]-                     renameFile old new-  when has_dir $ do debugMessage $ unwords ["renameDirectory",old,new]-                    renameDirectory old new+  when has_file $ do+    debugMessage $ unwords ["renameFile", displayPath old, displayPath new]+    renameFile (realPath old) (realPath new)+  when has_dir $ do+    debugMessage $ unwords ["renameDirectory", displayPath old, displayPath new]+    renameDirectory (realPath old) (realPath new) -mv :: DarcsCommand [DarcsFlag]+mv :: DarcsCommand mv = commandAlias "mv" Nothing move-
src/Darcs/UI/Commands/Optimize.hs view
@@ -19,19 +19,19 @@  module Darcs.UI.Commands.Optimize ( optimize ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when, unless, forM_ ) import Data.List ( nub ) import Data.Maybe ( fromJust, isJust ) import System.Directory-    ( getDirectoryContents+    ( listDirectory     , doesDirectoryExist     , renameFile     , createDirectoryIfMissing     , removeFile     , getHomeDirectory+    , removeDirectoryRecursive     ) import qualified Data.ByteString.Char8 as BC import Darcs.UI.Commands ( DarcsCommand(..), nodefaults@@ -51,13 +51,32 @@     ) import Darcs.Repository.Job ( withOldRepoLock ) import Darcs.Repository.Identify ( findAllReposInDir )-import Darcs.Repository.Hashed ( inventoriesDir, patchesDir, pristineDir,-                                    hashedInventory,-                                    listInventoriesRepoDir,-                                    listPatchesLocalBucketed, diffHashLists, peekPristineHash )+import Darcs.Repository.Traverse+    ( diffHashLists+    , listInventoriesRepoDir+    , listPatchesLocalBucketed+    , specialPatches+    )+import Darcs.Repository.Inventory ( peekPristineHash )+import Darcs.Repository.Paths+    ( formatPath+    , hashedInventoryPath+    , inventoriesDir+    , inventoriesDirPath+    , oldCheckpointDirPath+    , oldCurrentDirPath+    , oldInventoryPath+    , oldPristineDirPath+    , oldTentativeInventoryPath+    , patchesDir+    , patchesDirPath+    , pristineDir+    , pristineDirPath+    , tentativePristinePath+    ) import Darcs.Repository.Packs ( createPacks )-import Darcs.Repository.Pending ( pendingName ) import Darcs.Repository.HashedIO ( getHashedFiles )+import Darcs.Repository.Inventory ( getValidHash ) import Darcs.Patch.Witnesses.Ordered      ( mapFL      , bunchFL@@ -71,12 +90,11 @@     ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Util.ByteString ( gzReadFilePS )-import Darcs.Util.Printer ( text )+import Darcs.Util.Printer ( Doc, formatWords, text, wrapText, ($+$) ) import Darcs.Util.Lock     ( maybeRelink     , gzWriteAtomicFilePS     , writeAtomicFilePS-    , rmRecursive     , removeFileMayNotExist     , writeBinFile     )@@ -85,7 +103,7 @@     , getRecursiveContents     , doesDirectoryReallyExist     )-import Darcs.UI.External ( catchall )+import Darcs.Util.Exception ( catchall ) import Darcs.Util.Progress     ( beginTedious     , endTedious@@ -101,12 +119,12 @@     ) import Text.Printf ( printf ) import Darcs.UI.Flags-    (  DarcsFlag, verbosity, useCache, umask )-import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise+    (  DarcsFlag, useCache, umask )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck                         , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags-    ( UpdateWorking (..), DryRun ( NoDryRun ), UseCache (..), UMask (..)+    ( UpdatePending (..), DryRun ( NoDryRun ), UseCache (..), UMask (..)     , WithWorkingDir(WithWorkingDir), PatchFormat(PatchFormat1) ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Repository.Cache ( hashedDir, bucketFolder,@@ -119,7 +137,14 @@     , RepoProperty ( HashedInventory )     ) import Darcs.Repository.PatchIndex-import qualified Darcs.Repository.Hashed as HashedRepo+import Darcs.Repository.Hashed+    ( writeTentativeInventory+    , finalizeTentativeChanges+    )+import Darcs.Repository.Pristine+    ( ApplyDir(ApplyNormal)+    , applyToTentativePristineCwd+    ) import Darcs.Repository.State ( readRecorded )  import Darcs.Util.Tree@@ -129,7 +154,7 @@     , expand     , emptyTree     )-import Darcs.Util.Path( anchorPath, toFilePath, AbsolutePath )+import Darcs.Util.Path( realPath, toFilePath, AbsolutePath ) import Darcs.Util.Tree.Plain( readPlainTree ) import Darcs.Util.Tree.Hashed     ( writeDarcsHashed@@ -139,12 +164,14 @@ optimizeDescription :: String optimizeDescription = "Optimize the repository." -optimizeHelp :: String-optimizeHelp =- "The `darcs optimize` command modifies the current repository in an\n" ++- "attempt to reduce its resource requirements."+optimizeHelp :: Doc+optimizeHelp = formatWords+  [ "The `darcs optimize` command modifies internal data structures of"+  , "the current repository in an attempt to reduce its resource requirements."+  ]+  $+$ "For further details see the descriptions of the subcommands." -optimize :: DarcsCommand [DarcsFlag]+optimize :: DarcsCommand optimize = SuperCommand {       commandProgramName = "darcs"     , commandName = "optimize"@@ -165,13 +192,13 @@                            ]     } -commonBasicOpts :: DarcsOption a (Maybe String -> UMask -> a)-commonBasicOpts = O.repoDir ^ O.umask+commonBasicOpts :: DarcsOption a (Maybe String -> a)+commonBasicOpts = O.repoDir -commonAdvancedOpts :: DarcsOption a a-commonAdvancedOpts = oid+commonAdvancedOpts :: DarcsOption a (UMask -> a)+commonAdvancedOpts = O.umask -common :: DarcsCommand [DarcsFlag]+common :: DarcsCommand common = DarcsCommand     { commandProgramName = "darcs"     , commandExtraArgs = 0@@ -187,37 +214,37 @@     , commandBasicOptions = odesc commonBasicOpts     , commandDefaults = defaultFlags commonOpts     , commandCheckOptions = ocheck commonOpts-    , commandParseOptions = onormalise commonOpts     }   where     commonOpts = commonBasicOpts `withStdOpts` commonAdvancedOpts  -optimizeClean :: DarcsCommand [DarcsFlag]+optimizeClean :: DarcsCommand optimizeClean = common     { commandName = "clean"-    , commandHelp = "This command deletes obsolete files within the repository."     , commandDescription = "garbage collect pristine, inventories and patches"+    , commandHelp = optimizeHelpClean     , commandCommand = optimizeCleanCmd     }  optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeCleanCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repository -> do       cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories       putInfo opts "Done cleaning repository!" -optimizeUpgrade :: DarcsCommand [DarcsFlag]+optimizeUpgrade :: DarcsCommand optimizeUpgrade = common     { commandName = "upgrade"-    , commandHelp = "Convert old-fashioned repositories to the current default hashed format."+    , commandHelp = wrapText 80+        "Convert old-fashioned repositories to the current default hashed format."     , commandDescription = "upgrade repository to latest compatible format"     , commandPrereq = amInRepository     , commandCommand = optimizeUpgradeCmd     } -optimizeHttp :: DarcsCommand [DarcsFlag]+optimizeHttp :: DarcsCommand optimizeHttp = common     { commandName = "http"     , commandHelp = optimizeHelpHttp@@ -227,30 +254,31 @@  optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeHttpCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repository -> do       cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories       createPacks repository       putInfo opts "Done creating packs!" -optimizePristine :: DarcsCommand [DarcsFlag]+optimizePristine :: DarcsCommand optimizePristine = common     { commandName = "pristine"-    , commandHelp = "This command updates the format of `_darcs/pristine.hashed/`, which was different\n"-                 ++ "before darcs 2.3.1."+    , 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) YesUpdateWorking (umask ? 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 [DarcsFlag]+optimizeCompress :: DarcsCommand optimizeCompress = common     { commandName = "compress"     , commandHelp = optimizeHelpCompression@@ -258,7 +286,7 @@     , commandCommand = optimizeCompressCmd     } -optimizeUncompress :: DarcsCommand [DarcsFlag]+optimizeUncompress :: DarcsCommand optimizeUncompress = common     { commandName = "uncompress"     , commandHelp = optimizeHelpCompression@@ -268,7 +296,7 @@  optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeCompressCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repository -> do       cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories       optimizeCompression O.GzipCompression opts@@ -276,7 +304,7 @@  optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeUncompressCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repository -> do       cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories       optimizeCompression O.NoCompression opts@@ -285,44 +313,45 @@ optimizeCompression :: O.Compression -> [DarcsFlag] -> IO () optimizeCompression compression opts = do     putInfo opts "Optimizing (un)compression of patches..."-    do_compress (darcsdir ++ "/patches")+    do_compress patchesDirPath     putInfo opts "Optimizing (un)compression of inventories..."-    do_compress (darcsdir ++ "/inventories")+    do_compress inventoriesDirPath     where       do_compress f = do         isd <- doesDirectoryExist f         if isd           then withCurrentDirectory f $ do-                 fs <- filter notdot `fmap` getDirectoryContents "."+                 fs <- filter (`notElem` specialPatches) <$> listDirectory "."                  mapM_ do_compress fs           else gzReadFilePS f >>=                case compression of                  O.GzipCompression -> gzWriteAtomicFilePS f                  O.NoCompression -> writeAtomicFilePS f-      notdot ('.':_) = False-      notdot _ = True -optimizeEnablePatchIndex :: DarcsCommand [DarcsFlag]+optimizeEnablePatchIndex :: DarcsCommand optimizeEnablePatchIndex = common     { commandName = "enable-patch-index"-    , commandHelp = "Build the patch index, an internal data structure that accelerates\n"-                 ++ "commands that need to know what patches touch a given file. Such as\n"-                 ++ "annotate and log."+    , commandHelp = formatWords+        [ "Build the patch index, an internal data structure that accelerates"+        , "commands that need to know what patches touch a given file. Such as"+        , "annotate and log."+        ]     , commandDescription = "Enable patch index"     , commandCommand = optimizeEnablePatchIndexCmd     } -optimizeDisablePatchIndex :: DarcsCommand [DarcsFlag]+optimizeDisablePatchIndex :: DarcsCommand optimizeDisablePatchIndex = common     { commandName = "disable-patch-index"-    , commandHelp = "Delete and stop maintaining the patch index from the repository."+    , commandHelp = wrapText 80+        "Delete and stop maintaining the patch index from the repository."     , commandDescription = "Disable patch index"     , commandCommand = optimizeDisablePatchIndexCmd     }  optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeEnablePatchIndexCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repository -> do       ps <- readRepo repository       createOrUpdatePatchIndexDisk repository ps@@ -330,30 +359,32 @@  optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeDisablePatchIndexCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repo -> do       deletePatchIndex (repoLocation repo)       putInfo opts "Done disabling patch index!" -optimizeReorder :: DarcsCommand [DarcsFlag]+optimizeReorder :: DarcsCommand optimizeReorder = common     { commandName = "reorder"-    , commandHelp = "This command moves recent patches (those not included in\n" ++-                    "the latest tag) to the \"front\", reducing the amount that a typical\n" ++-                    "remote command needs to download.  It should also reduce the CPU time\n" ++-                    "needed for some operations."+    , 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."+        ]     , commandDescription = "reorder the patches in the repository"     , commandCommand = optimizeReorderCmd     }  optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeReorderCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repository -> do-      reorderInventory repository (O.compress ? opts) YesUpdateWorking (verbosity ? opts)+      reorderInventory repository (O.compress ? opts)       putInfo opts "Done reordering!" -optimizeRelink :: DarcsCommand [DarcsFlag]+optimizeRelink :: DarcsCommand optimizeRelink = common     { commandName = "relink"     , commandHelp = optimizeHelpRelink @@ -363,7 +394,6 @@     , commandBasicOptions = odesc optimizeRelinkBasicOpts     , commandDefaults = defaultFlags optimizeRelinkOpts     , commandCheckOptions = ocheck optimizeRelinkOpts-    , commandParseOptions = onormalise optimizeRelinkOpts     }   where     optimizeRelinkBasicOpts = commonBasicOpts ^ O.siblings@@ -371,46 +401,59 @@  optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeRelinkCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $     RepoJob $ \repository -> do       cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories       doRelink opts       putInfo opts "Done relinking!" -optimizeHelpHttp :: String-optimizeHelpHttp = unlines-  [ "Using this option creates 'repository packs' that could dramatically"+optimizeHelpHttp :: Doc+optimizeHelpHttp = formatWords+  [ "Using this option creates 'repository packs' that can dramatically"   , "speed up performance when a user does a `darcs clone` of the repository"   , "over HTTP. To make use of packs, the clients must have a darcs of at"   , "least version 2.10."   ] -optimizeHelpCompression :: String+optimizeHelpClean :: Doc+optimizeHelpClean = formatWords+  [ "Darcs normally does not delete hashed files that are no longer"+  , "referenced by the current repository state. This command can be"+  , "use to get rid of these files to save some disk space."+  ]++optimizeHelpCompression :: Doc optimizeHelpCompression =- "By default patches are compressed with zlib (RFC 1951) to reduce\n" ++- "storage (and download) size.  In exceptional circumstances, it may be\n" ++- "preferable to avoid compression.  In this case the `--dont-compress`\n" ++- "option can be used (e.g. with `darcs record`) to avoid compression.\n" ++- "\n" ++- "The `darcs optimize uncompress` and `darcs optimize compress`\n" ++- "commands can be used to ensure existing patches in the current\n" ++- "repository are respectively uncompressed or compressed."+  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."+  ]+  $+$ formatWords+  [ "The `darcs optimize uncompress` and `darcs optimize compress`"+  , "commands can be used to ensure existing patches in the current"+  , "repository are respectively uncompressed or compressed."+  ] -optimizeHelpRelink :: String-optimizeHelpRelink =- "The `darcs optimize relink` command hard-links patches that the\n" ++- "current repository has in common with its peers.  Peers are those\n" ++- "repositories listed in `_darcs/prefs/sources`, or defined with the\n" ++- "`--sibling` option (which can be used multiple times).\n" ++- "\n" ++- "Darcs uses hard-links automatically, so this command is rarely needed.\n" ++- "It is most useful if you used `cp -r` instead of `darcs clone` to copy a\n" ++- "repository, or if you pulled the same patch from a remote repository\n" ++- "into multiple local repositories."+optimizeHelpRelink :: Doc+optimizeHelpRelink = +  formatWords+  [ "The `darcs optimize relink` command hard-links patches that the"+  , "current repository has in common with its peers.  Peers are those"+  , "repositories listed in `_darcs/prefs/sources`, or defined with the"+  , "`--sibling` option (which can be used multiple times)."+  ]+  $+$ formatWords+  [ "Darcs uses hard-links automatically, so this command is rarely needed."+  , "It is most useful if you used `cp -r` instead of `darcs clone` to copy a"+  , "repository, or if you pulled the same patch from a remote repository"+  , "into multiple local repositories."+  ]  doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO () doOptimizePristine opts repo = do-    inv <- BC.readFile (darcsdir </> "hashed_inventory")+    inv <- BC.readFile hashedInventoryPath     let linesInv = BC.split '\n' inv     case linesInv of       [] -> return ()@@ -428,9 +471,9 @@        if null siblings           then putInfo opts "No siblings -- no relinking done."           else do debugMessage "Relinking patches..."-                  patch_tree <- expand =<< readPlainTree (darcsdir </> "patches")-                  let patches = [ anchorPath "" p | (p, File _) <- list patch_tree ]-                  maybeRelinkFiles siblings patches $ darcsdir </> "patches"+                  patch_tree <- expand =<< readPlainTree patchesDirPath+                  let patches = [ realPath p | (p, File _) <- list patch_tree ]+                  maybeRelinkFiles siblings patches patchesDirPath                   debugMessage "Done relinking."  maybeRelinkFiles :: [String] -> [String] -> String -> IO ()@@ -464,41 +507,41 @@   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 "."-  -- TODO Why use the default and not what the user provided?-  -- Is it because the author couldn't be bothered to add the option?-  -- Or is there a more profound reason?-  -- Such things justify a few lines of comment!   let compressDefault = O.compress ? []-  HashedRepo.writeTentativeInventory cache compressDefault patches'+  writeTentativeInventory cache compressDefault patches'   endTedious k   -- convert pristine by applying patches-  -- the faster alternative would be to copy pristine, but the apply method is more reliable+  -- 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   -- We ignore the returned root hash, we don't use it.   _ <- writeDarcsHashed emptyTree $ darcsdir </> hashedDir HashedPristineDir-  writeBinFile (darcsdir++"/tentative_pristine") ""-  sequence_ $ mapFL HashedRepo.applyToTentativePristineCwd $ bunchFL 100 patchesToApply+  writeBinFile tentativePristinePath ""+  sequence_ $+    mapFL (applyToTentativePristineCwd ApplyNormal) $+    bunchFL 100 patchesToApply   -- now make it official-  HashedRepo.finalizeTentativeChanges repository compressDefault-  writeRepoFormat (createRepoFormat PatchFormat1 WithWorkingDir) (darcsdir </> "format")+  finalizeTentativeChanges repository compressDefault+  writeRepoFormat (createRepoFormat PatchFormat1 WithWorkingDir) formatPath   -- clean out old-fashioned junk   debugMessage "Cleaning out old-fashioned repository files..."-  removeFileMayNotExist $ darcsdir </> "inventory"-  removeFileMayNotExist $ darcsdir </> "tentative_inventory"-  rmRecursive (darcsdir </> "pristine") `catchall` rmRecursive (darcsdir </> "current")-  rmGzsIn (darcsdir </> "patches")-  rmGzsIn (darcsdir </> "inventories")-  let checkpointDir = darcsdir </> "checkpoints"-  hasCheckPoints <- doesDirectoryExist checkpointDir-  when hasCheckPoints $ rmRecursive checkpointDir-  removeFileMayNotExist (pendingName ++ ".tentative")-  removeFileMayNotExist pendingName+  removeFileMayNotExist oldInventoryPath+  removeFileMayNotExist oldTentativeInventoryPath+  removeDirectoryRecursive oldPristineDirPath+    `catchall` removeDirectoryRecursive oldCurrentDirPath+  rmGzsIn patchesDirPath+  rmGzsIn inventoriesDirPath+  hasCheckPoints <- doesDirectoryExist oldCheckpointDirPath+  when hasCheckPoints $ removeDirectoryRecursive oldCheckpointDirPath  where   rmGzsIn dir =     withCurrentDirectory dir $ do-      gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "."+      gzs <- filter ((== ".gz") . takeExtension) `fmap` listDirectory "."       mapM_ removeFile gzs  optimizeBucketed :: [DarcsFlag] -> IO ()@@ -526,7 +569,7 @@                 debugMessage $ "Making " ++ src ++ " bucketed in " ++ dest                 forM_ subDirSet $ \subDir ->                   createDirectoryIfMissing True (dest </> subDir)-                fileNames <- getDirectoryContents src+                fileNames <- listDirectory src                 forM_ fileNames $ \file -> do                   exists <- doesDirectoryReallyExist (src </> file)                   if not $ exists@@ -546,7 +589,7 @@     toStrHex = printf "%02x"  -optimizeGlobalCache :: DarcsCommand [DarcsFlag]+optimizeGlobalCache :: DarcsCommand optimizeGlobalCache = common     { commandName = "cache"     , commandExtraArgs            = -1@@ -557,16 +600,17 @@     , commandPrereq = \_ -> return $ Right ()     } -optimizeHelpGlobalCache :: String-optimizeHelpGlobalCache = unlines+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."-  , ""-  , "It also automatically migrates the global cache to the (default)"+  ]+  $+$ formatWords+  [ "It also automatically migrates the global cache to the (default)"   , "bucketed format."   ] @@ -614,8 +658,6 @@       (diffHashLists s1 s2)    getPristine :: String -> IO [String]-  getPristine darcsDir = do-    i <- gzReadFilePS (darcsDir </> darcsdir </> hashedInventory)-    getHashedFiles (darcsDir </> darcsdir </> pristineDir) [peekPristineHash i]--+  getPristine repoDir = do+    i <- gzReadFilePS (repoDir </> hashedInventoryPath)+    getHashedFiles (repoDir </> pristineDirPath) [getValidHash $ peekPristineHash i]
src/Darcs/UI/Commands/Pull.hs view
@@ -15,14 +15,14 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Pull ( -- * Commands.                                 pull, fetch,                                 pullCmd, StandardPatchApplier,                                 -- * Utility functions.-                                fetchPatches, revertable+                                fetchPatches                               ) where -import Prelude () import Darcs.Prelude  import System.Exit ( exitSuccess )@@ -39,6 +39,7 @@     , defaultRepo     , amInHashedRepository     )+import Darcs.UI.Commands.Clone ( otherHelpInheritDefault ) import Darcs.UI.Flags     ( DarcsFlag     , fixUrl, getOutput@@ -47,53 +48,62 @@     , withContext, hasXmlOutput     , isInteractive, quiet     )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdateWorking (..) )+import Darcs.Repository.Flags ( UpdatePending (..) ) import Darcs.Repository     ( Repository     , identifyRepositoryFor+    , ReadingOrWriting(..)     , withRepoLock     , RepoJob(..)     , readRepo     , modifyCache-    , modifyCache-    , Cache(..)+    , mkCache+    , cacheEntries     , CacheLoc(..)     , WritableOrNot(..)+    , CacheType(..)     , filterOutConflicts     ) -import qualified Darcs.Repository.Cache as DarcsCache import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefully, patchDesc ) import Darcs.Patch ( IsRepoType, RepoPatch, description )-import Darcs.Patch.Bundle( makeBundleN, patchFilename )+import qualified Darcs.Patch.Bundle as Bundle ( makeBundle ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet )+import Darcs.Patch.Set ( PatchSet, Origin, emptyPatchSet, SealedPatchSet ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )-import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Ordered-    ( (:>)(..), (:\/:)(..), FL(..), RL(..)-    , mapFL, nullFL, reverseFL, mapFL_FL )+    ( (:>)(..), (:\/:)(..), FL(..), Fork(..)+    , mapFL, nullFL, mapFL_FL ) import Darcs.Patch.Permutations ( partitionFL ) import Darcs.Repository.Prefs ( addToPreflist, addRepoSource, getPreflist, showMotd )-import Darcs.Patch.Depends ( findUncommon, findCommonWithThem,+import Darcs.Patch.Depends ( findUncommon, findCommonAndUncommon,                              patchSetIntersection, patchSetUnion ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..) ) import Darcs.UI.Completion ( prefArgs )-import Darcs.UI.Commands.Util ( checkUnrelatedRepos )+import Darcs.UI.Commands.Util ( checkUnrelatedRepos, getUniqueDPatchName ) import Darcs.UI.SelectChanges     ( WhichChanges(..)     , runSelection-    , selectionContext+    , selectionConfig     ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )-import Darcs.Util.Exception ( clarifyErrors )-import Darcs.Util.Printer ( vcat, ($$), text, putDoc )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , ($+$)+    , (<+>)+    , formatWords+    , hsep+    , putDoc+    , quoted+    , text+    , vcat+    ) import Darcs.Util.Lock ( writeDocBinFile ) import Darcs.Util.Path ( useAbsoluteOrStd, stdOut, AbsolutePath ) import Darcs.Util.Workaround ( getCurrentDirectory )-import Darcs.Util.Text ( quote ) import Darcs.Util.Tree( Tree )  pullDescription :: String@@ -104,38 +114,45 @@ fetchDescription =  "Fetch patches from another repository, but don't apply them." -pullHelp :: String-pullHelp = unlines- [ "Pull is used to bring patches made in another repository into the current"- , "repository (that is, either the one in the current directory, or the one"- , "specified with the `--repodir` option). Pull accepts arguments, which are"- , "URLs from which to pull, and when called without an argument, pull will"- , "use the repository specified at `_darcs/prefs/defaultrepo`."- , ""- , "The default (`--union`) behavior is to pull any patches that are in any of"- , "the specified repositories.  If you specify the `--intersection` flag, darcs"- , "will only pull those patches which are present in all source repositories."- , "If you specify the `--complement` flag, darcs will only pull elements in the"- , "first repository that do not exist in any of the remaining repositories."- , ""- , "If `--reorder` is supplied, the set of patches that exist only in the current"- , "repository is brought at the top of the current history. This will work even"- , "if there are no new patches to pull."- , ""- , "See `darcs help apply` for detailed description of many options."- ]+pullHelp :: Doc+pullHelp =+  formatWords+  [ "Pull is used to bring patches made in another repository into the current"+  , "repository (that is, either the one in the current directory, or the one"+  , "specified with the `--repodir` option). Pull accepts arguments, which are"+  , "URLs from which to pull, and when called without an argument, pull will"+  , "use the repository specified at `_darcs/prefs/defaultrepo`."+  ]+  $+$ formatWords+  [ "The default (`--union`) behavior is to pull any patches that are in any of"+  , "the specified repositories.  If you specify the `--intersection` flag, darcs"+  , "will only pull those patches which are present in all source repositories."+  , "If you specify the `--complement` flag, darcs will only pull elements in the"+  , "first repository that do not exist in any of the remaining repositories."+  ]+  $+$ formatWords+  [ "If `--reorder` is supplied, the set of patches that exist only in the current"+  , "repository is brought at the top of the current history. This will work even"+  , "if there are no new patches to pull."+  ]+  $+$ otherHelpInheritDefault+  $+$ formatWords+  [ "See `darcs help apply` for detailed description of many options."+  ] -fetchHelp :: String-fetchHelp = unlines- [ "Fetch is similar to `pull` except that it does not apply any patches"- , "to the current repository. Instead, it generates a patch bundle that"- , "you can apply later with `apply`."- , ""- , "Fetch's behaviour is essentially similar to pull's, so please consult"- , "the help of `pull` to know more."- ]+fetchHelp :: Doc+fetchHelp =+  formatWords+  [ "Fetch is similar to `pull` except that it does not apply any patches"+  , "to the current repository. Instead, it generates a patch bundle that"+  , "you can apply later with `apply`."+  ]+  $+$ formatWords+  [ "Fetch's behaviour is essentially similar to pull's, so please consult"+  , "the help of `pull` to know more."+  ] -fetch :: DarcsCommand [DarcsFlag]+fetch :: DarcsCommand fetch = DarcsCommand     { commandProgramName = "darcs"     , commandName = "fetch"@@ -151,16 +168,16 @@     , commandBasicOptions = odesc basicOpts     , commandDefaults = defaultFlags allOpts     , commandCheckOptions = ocheck allOpts-    , commandParseOptions = onormalise allOpts     }   where     basicOpts       = O.matchSeveral       ^ O.interactive -- True       ^ O.dryRun-      ^ O.summary+      ^ O.withSummary       ^ O.selectDeps       ^ O.setDefault+      ^ O.inheritDefault       ^ O.repoDir       ^ O.output       ^ O.allowUnrelatedRepos@@ -171,7 +188,7 @@       ^ O.network     allOpts = basicOpts `withStdOpts` advancedOpts -pull :: DarcsCommand [DarcsFlag]+pull :: DarcsCommand pull = DarcsCommand     { commandProgramName = "darcs"     , commandName = "pull"@@ -187,7 +204,6 @@     , commandBasicOptions = odesc basicOpts     , commandDefaults = defaultFlags allOpts     , commandCheckOptions = ocheck allOpts-    , commandParseOptions = onormalise allOpts     }   where     basicOpts@@ -198,9 +214,10 @@       ^ O.externalMerge       ^ O.runTest       ^ O.dryRunXml-      ^ O.summary+      ^ O.withSummary       ^ O.selectDeps       ^ O.setDefault+      ^ O.inheritDefault       ^ O.repoDir       ^ O.allowUnrelatedRepos       ^ O.diffAlgorithm@@ -211,7 +228,6 @@       ^ O.remoteRepos       ^ O.setScriptsExecutable       ^ O.umask-      ^ O.restrictPaths       ^ O.changesReverse       ^ O.pauseForGui       ^ O.network@@ -223,29 +239,28 @@ pullCmd patchApplier (_,o) opts repos =   do     pullingFrom <- mapM (fixUrl o) repos-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $-     repoJob patchApplier opts $ \patchProxy initRepo -> do--      let repository = modifyCache initRepo $ addReposToCache pullingFrom-      (_, Sealed (us' :\/: to_be_pulled))-          <- fetchPatches o opts repos "pull" repository-      let from_whom = error "Internal error: pull shouldn't need a 'from' address"-      applyPatches patchApplier patchProxy "pull" opts from_whom repository us' to_be_pulled+    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+     repoJob patchApplier $ \patchProxy initRepo -> do+      let repository = modifyCache (addReposToCache pullingFrom) initRepo+      Sealed fork <- fetchPatches o opts repos "pull" repository+      applyPatches patchApplier patchProxy "pull" opts repository fork     where-      addReposToCache repos' (Ca cache) = Ca $ [ toReadOnlyCache r | r <- repos' ] ++  cache-      toReadOnlyCache = Cache DarcsCache.Repo NotWritable+      addReposToCache repos' cache =+        mkCache $ [ toReadOnlyCache r | r <- repos' ] ++ cacheEntries cache+      toReadOnlyCache = Cache Repo NotWritable   fetchCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fetchCmd (_,o) opts repos =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $+    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $         fetchPatches o opts repos "fetch" >=> makeBundle opts  fetchPatches :: forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)              => AbsolutePath -> [DarcsFlag] -> [String] -> String              -> Repository rt p wR wU wR-             -> IO (SealedPatchSet rt p Origin,-                    Sealed ((FL (PatchInfoAnd rt p)  :\/: FL (PatchInfoAnd rt p)) wR))+             -> IO (Sealed (Fork (PatchSet rt p)+                                 (FL (PatchInfoAnd rt p))+                                 (FL (PatchInfoAnd rt p)) Origin wR)) fetchPatches o opts unfixedrepodirs@(_:_) jobname repository = do   here <- getCurrentDirectory   repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl o) unfixedrepodirs@@ -257,16 +272,16 @@       let pulling = case dryRun ? opts of                       O.YesDryRun -> "Would pull"                       O.NoDryRun -> "Pulling"-      in  putInfo opts $ text $ pulling++" from "++concatMap quote repodirs++"..."+      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)+  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   checkUnrelatedRepos (parseFlags O.allowUnrelatedRepos opts) us them -  common :> _ <- return $ findCommonWithThem us them-  us' :\/: them' <- return $ findUncommon us them+  Fork common us' them' <- return $ findCommonAndUncommon us them   _   :\/: compl' <- return $ findUncommon us compl    let avoided = mapFL info compl'@@ -282,44 +297,36 @@       vcat (mapFL description ps)   (hadConflicts, Sealed psFiltered)     <- if O.conflictsYes ? opts == Nothing-        then filterOutConflicts (reverseFL us') repository ps+        then filterOutConflicts repository us' ps         else return (False, Sealed ps)   when hadConflicts $ putInfo opts $ text "Skipping some patches which would cause conflicts."   when (nullFL psFiltered) $ do putInfo opts $ text "No remote patches to pull in!"                                 setEnvDarcsPatches psFiltered                                 when (reorder ? opts /= O.Reorder) exitSuccess   let direction = if changesReverse ? opts then FirstReversed else First-      context = selectionContext direction jobname (pullPatchSelOpts opts) Nothing Nothing-  (to_be_pulled :> _) <- runSelection psFiltered context-  return (seal common, seal $ us' :\/: to_be_pulled)+      selection_config = selectionConfig direction jobname (pullPatchSelOpts opts) Nothing Nothing+  (to_be_pulled :> _) <- runSelection psFiltered selection_config+  return (Sealed (Fork common us' to_be_pulled))  fetchPatches _ _ [] jobname _ = fail $   "No default repository to " ++ jobname ++ " from, please specify one"  makeBundle :: forall rt p wR . (RepoPatch p, ApplyState p ~ Tree)            => [DarcsFlag]-           -> (SealedPatchSet rt p Origin,-               Sealed ((FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wR))+           -> (Sealed (Fork (PatchSet rt p)+                      (FL (PatchInfoAnd rt p))+                      (FL (PatchInfoAnd rt p)) Origin wR))            -> IO ()-makeBundle opts (Sealed common, Sealed (_ :\/: to_be_fetched)) =+makeBundle opts (Sealed (Fork common _ to_be_fetched)) =     do-      bundle <- makeBundleN Nothing (unsafeCoercePEnd common) $+      bundle <- Bundle.makeBundle Nothing common $                  mapFL_FL hopefully to_be_fetched-      let fname = case to_be_fetched of-                    (x:>:_)-> patchFilename $ patchDesc x-                    _ -> impossible-          o = fromMaybe stdOut (getOutput opts fname)+      fname <- case to_be_fetched of+                    (x:>:_)-> getUniqueDPatchName $ patchDesc x+                    _ -> error "impossible case"+      let o = fromMaybe stdOut (getOutput opts fname)       useAbsoluteOrStd writeDocBinFile putDoc o bundle -revertable :: IO a -> IO a-revertable x =-    x `clarifyErrors` unlines-          ["Error applying patch to the working directory.","",-           "This may have left your working directory an inconsistent",-           "but recoverable state. If you had no un-recorded changes",-           "by using 'darcs revert' you should be able to make your",-           "working directory consistent again."]- {- Read in the specified pull-from repositories.  Perform Intersection, Union, or Complement read.  In patch-theory terms (stated in set algebra, where + is union and & is intersection@@ -341,15 +348,15 @@ readRepos :: (IsRepoType rt, RepoPatch p)           => Repository rt p wR wU wT -> [DarcsFlag] -> [String]           -> IO (SealedPatchSet rt p Origin,SealedPatchSet rt p Origin)-readRepos _ _ [] = impossible+readRepos _ _ [] = error "impossible case" readRepos to_repo opts us =-    do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo (useCache ? opts) u+    do rs <- mapM (\u -> do r <- identifyRepositoryFor Reading to_repo (useCache ? opts) u                             ps <- readRepo r                             return $ seal ps) us        return $ case parseFlags O.repoCombinator opts of-                  O.Intersection -> (patchSetIntersection rs, seal (PatchSet NilRL NilRL))+                  O.Intersection -> (patchSetIntersection rs, seal emptyPatchSet)                   O.Complement -> (head rs, patchSetUnion $ tail rs)-                  O.Union -> (patchSetUnion rs, seal (PatchSet NilRL NilRL))+                  O.Union -> (patchSetUnion rs, seal emptyPatchSet)  pullPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions pullPatchSelOpts flags = S.PatchSelectionOptions@@ -357,6 +364,6 @@     , S.matchFlags = parseFlags O.matchSeveral flags     , S.interactive = isInteractive True flags     , S.selectDeps = selectDeps ? flags-    , S.summary = O.summary ? flags+    , S.withSummary = O.withSummary ? flags     , S.withContext = withContext ? flags     }
src/Darcs/UI/Commands/Push.hs view
@@ -15,11 +15,9 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE TypeOperators #-}-+{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Push ( push ) where -import Prelude () import Darcs.Prelude  import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ), exitSuccess )@@ -29,11 +27,13 @@     ( DarcsCommand(..), withStdOpts     , putVerbose     , putInfo+    , putFinished     , abortRun     , setEnvDarcsPatches     , defaultRepo     , amInHashedRepository     )+import Darcs.UI.Commands.Clone ( otherHelpInheritDefault ) import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos ) import Darcs.UI.Completion ( prefArgs ) import Darcs.UI.Flags@@ -42,14 +42,20 @@     , xmlOutput, selectDeps, applyAs, remoteDarcs     , changesReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl ) import Darcs.UI.Options-    ( (^), odesc, ocheck, onormalise+    ( (^), odesc, ocheck     , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( DryRun (..) ) import qualified Darcs.Repository.Flags as R ( remoteDarcs ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )-import Darcs.Repository ( Repository, withRepository, RepoJob(..), identifyRepositoryFor,-                          readRepo )+import Darcs.Repository+    ( RepoJob(..)+    , Repository+    , identifyRepositoryFor+    , ReadingOrWriting(..)+    , readRepo+    , withRepository+    ) import Darcs.Patch ( IsRepoType, RepoPatch, description ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered@@ -64,19 +70,29 @@ import Darcs.Util.Path ( AbsolutePath ) import Darcs.UI.SelectChanges     ( WhichChanges(..)-    , selectionContext+    , selectionConfig     , runSelection     ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )-import Darcs.Patch.Bundle ( makeBundleN )+import Darcs.Patch.Bundle ( makeBundle ) import Darcs.Patch.Show( ShowPatch ) import Darcs.Patch.Set ( PatchSet, Origin )-import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$) )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , ($+$)+    , (<+>)+    , empty+    , formatWords+    , quoted+    , text+    , vcat+    ) import Darcs.UI.Email ( makeEmail ) import Darcs.Util.English (englishNum, Noun(..)) import Darcs.Util.Workaround ( getCurrentDirectory )-import Darcs.Util.Text ( quote ) import Darcs.Util.Tree( Tree )  @@ -84,25 +100,30 @@ pushDescription =  "Copy and apply patches from this repository to another one." -pushHelp :: String-pushHelp = unlines- [ "Push is the opposite of pull.  Push allows you to copy patches from the"- , "current repository into another repository."- , ""- , "If you give the `--apply-as` flag, darcs will use `sudo` to apply the"- , "patches as a different user.  This can be useful if you want to set up a"- , "system where several users can modify the same repository, but you don't"- , "want to allow them full write access.  This isn't secure against skilled"- , "malicious attackers, but at least can protect your repository from clumsy,"- , "inept or lazy users."- , ""- , "`darcs push` will compress the patch data before sending it to a remote"- , "location via ssh. This works as long as the remote darcs is not older"- , "than version 2.5. If you get errors that indicate a corrupt patch bundle,"- , "you should try again with the `--no-compress` option."- ]+pushHelp :: Doc+pushHelp =+  formatWords+    [ "Push is the opposite of pull.  Push allows you to copy patches from the"+    , "current repository into another repository."+    ]+  $+$ formatWords+    [ "If you give the `--apply-as` flag, darcs will use `sudo` to apply the"+    , "patches as a different user.  This can be useful if you want to set up a"+    , "system where several users can modify the same repository, but you don't"+    , "want to allow them full write access.  This isn't secure against skilled"+    , "malicious attackers, but at least can protect your repository from clumsy,"+    , "inept or lazy users."+    ]+  $+$ formatWords+    [ "`darcs push` will compress the patch data before sending it to a remote"+    , "location via ssh. This works as long as the remote darcs is not older"+    , "than version 2.5. If you get errors that indicate a corrupt patch bundle,"+    , "you should try again with the `--no-compress` option."+    ]+  $+$+  otherHelpInheritDefault -push :: DarcsCommand [DarcsFlag]+push :: DarcsCommand push = DarcsCommand     { commandProgramName = "darcs"     , commandName = "push"@@ -118,7 +139,6 @@     , commandBasicOptions = odesc pushBasicOpts     , commandDefaults = defaultFlags pushOpts     , commandCheckOptions = ocheck pushOpts-    , commandParseOptions = onormalise pushOpts     }   where     pushBasicOpts@@ -127,9 +147,10 @@       ^ O.interactive       ^ O.sign       ^ O.dryRunXml-      ^ O.summary+      ^ O.withSummary       ^ O.repoDir       ^ O.setDefault+      ^ O.inheritDefault       ^ O.allowUnrelatedRepos     pushAdvancedOpts       = O.applyAs@@ -156,9 +177,9 @@   rval <- remoteApply opts repodir body   case rval of     ExitFailure ec -> do-      putStrLn "Apply failed!"+      ePutDocLn (text "Apply failed!")       exitWith (ExitFailure ec)-    ExitSuccess -> putInfo opts $ text "Push successful."+    ExitSuccess -> putFinished opts "pushing" pushCmd _ _ [] = die "No default repository to push to, please specify one." pushCmd _ _ _ = die "Cannot push to more than one repo." @@ -168,15 +189,16 @@   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 "++quote repodir++"..."-  them <- identifyRepositoryFor repository (useCache ? opts) repodir >>= readRepo-  addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts) (setDefault False opts)+       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   let direction = if changesReverse ? opts then FirstReversed else First-      context = selectionContext direction "push" (pushPatchSelOpts opts) Nothing Nothing-  runSelection us' context+      selection_config = selectionConfig direction "push" (pushPatchSelOpts opts) Nothing Nothing+  runSelection us' selection_config                    >>= bundlePatches opts common  prePushChatter :: forall rt p a wX wY wT . (RepoPatch p, ShowPatch a) =>@@ -203,7 +225,7 @@       setEnvDarcsPatches to_be_pushed       printDryRunMessageAndExit "push"         (verbosity ? opts)-        (O.summary ? opts)+        (O.withSummary ? opts)         (dryRun ? opts)         (xmlOutput ? opts)         (isInteractive True opts)@@ -212,7 +234,7 @@           putInfo opts $             text "You don't want to push any patches, and that's fine with me!"           exitSuccess-      makeBundleN Nothing common (mapFL_FL hopefully to_be_pushed)+      makeBundle Nothing common (mapFL_FL hopefully to_be_pushed)  checkOptionsSanity :: [DarcsFlag] -> String -> IO () checkOptionsSanity opts repodir =@@ -232,7 +254,7 @@     , S.matchFlags = parseFlags O.matchSeveral flags     , S.interactive = isInteractive True flags     , S.selectDeps = selectDeps ? flags-    , S.summary = O.summary ? flags+    , S.withSummary = O.withSummary ? flags     , S.withContext = withContext ? flags     }
src/Darcs/UI/Commands/Rebase.hs view
@@ -2,11 +2,8 @@ -- --  BSD3 -{-# LANGUAGE TypeOperators #-}- module Darcs.UI.Commands.Rebase ( rebase ) where -import Prelude () import Darcs.Prelude  import Darcs.UI.Commands@@ -15,15 +12,12 @@     , commandAlias     , defaultRepo, nodefaults     , putInfo, putVerbose-    , setEnvDarcsPatches     , amInHashedRepository     )-import Darcs.UI.Commands.Util ( printDryRunMessageAndExit ) import Darcs.UI.Commands.Apply ( applyCmd )-import Darcs.UI.Commands.Log ( changelog, getLogInfo )-import Darcs.UI.Commands.Pull ( pullCmd, revertable )-import Darcs.UI.Commands.Unrecord ( getLastPatches, matchingHead )-import Darcs.UI.CommandsAux ( checkPaths )+import Darcs.UI.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.Flags     ( DarcsFlag@@ -31,14 +25,14 @@     , compress, diffingOpts     , dryRun, reorder, verbosity, verbose     , useCache, wantGuiPause-    , umask, matchAny, changesReverse-    , onlyToFiles-    , diffAlgorithm, maxCount, isInteractive-    , selectDeps, xmlOutput, hasXmlOutput+    , umask, changesReverse+    , diffAlgorithm, isInteractive+    , selectDeps, hasXmlOutput     )+import qualified Darcs.UI.Flags as Flags ( getAuthor ) import Darcs.UI.Options-    ( (^), oid, odesc, ocheck, onormalise-    , defaultFlags, parseFlags, (?)+    ( (^), oid, odesc, ocheck+    , defaultFlags, (?)     ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( HijackT, HijackOptions(..), runHijackT@@ -46,49 +40,60 @@                             , updatePatchHeader, AskAboutDeps(..) ) import Darcs.Repository     ( Repository, RepoJob(..), withRepoLock, withRepository-    , RebaseJobFlags(..)     , tentativelyAddPatch, finalizeRepositoryChanges     , invalidateIndex     , tentativelyRemovePatches, readRepo     , tentativelyAddToPending, unrecordedChanges, applyToWorking     , revertRepositoryChanges-    , setScriptsExecutablePatches     )-import Darcs.Repository.Flags ( UpdateWorking(..), ExternalMerge(..) )-import Darcs.Repository.Merge ( tentativelyMergePatches, announceMergeConflicts )-import Darcs.Repository.Resolution ( standardResolution )-import Darcs.Patch ( invert, effect, commute, RepoPatch, description )+import Darcs.Repository.Flags ( UpdatePending(..), ExternalMerge(..) )+import Darcs.Repository.Hashed ( upgradeOldStyleRebase )+import Darcs.Repository.Merge ( tentativelyMergePatches )+import Darcs.Repository.Rebase+    ( readRebase+    , readTentativeRebase+    , writeTentativeRebase+    )+import Darcs.Repository.Resolution+    ( StandardResolution(..)+    , standardResolution+    , announceConflicts+    )++import Darcs.Patch ( invert, effect, commute, RepoPatch, displayPatch ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdFL ) import Darcs.Patch.Info ( displayPatchInfo )-import Darcs.Patch.Match ( firstMatch, secondMatch, splitSecondFL )+import Darcs.Patch.Match ( secondMatch, splitSecondFL ) import Darcs.Patch.Named ( Named, fmapFL_Named, patchcontents, patch2patchinfo )-import Darcs.Patch.Named.Wrapped ( mkRebase, toRebasing, fromRebasing )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia, hopefully )-import Darcs.Patch.Prim ( PrimOf, canonizeFL, fromPrim )-import Darcs.Patch.Rebase ( takeHeadRebase, takeHeadRebaseFL )-import Darcs.Patch.Rebase.Container ( Suspended(..) )-import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims )-import Darcs.Patch.Rebase.Item ( RebaseItem(..), simplifyPush, simplifyPushes )-import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed )-import Darcs.Patch.Rebase.Viewing-    ( RebaseSelect(RSFwd), rsToPia-    , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia )+import Darcs.Patch.Prim ( canonizeFL, PrimPatch )+import Darcs.Patch.Rebase.Change+    ( RebaseChange(RC), rcToPia+    , extractRebaseChange, reifyRebaseChange     , partitionUnconflicted     , WithDroppedDeps(..), WDDNamed, commuterIdWDD     , toRebaseChanges+    , simplifyPush, simplifyPushes     )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims )+import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed )+import Darcs.Patch.Rebase.Suspended ( Suspended(..), addToEditsToSuspended ) import Darcs.Patch.Permutations ( partitionConflictingFL )-import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Progress ( progressRL ) import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) )-import Darcs.Patch.Set ( PatchSet(..), appendPSFL )-import Darcs.Patch.Show ( showNicely )+import Darcs.Patch.Set ( PatchSet, Origin, patchSet2RL ) import Darcs.Patch.Split ( primSplitter )-import Darcs.UI.ApplyPatches ( PatchApplier(..), PatchProxy(..) )+import Darcs.UI.ApplyPatches+    ( PatchApplier(..)+    , PatchProxy(..)+    , applyPatchesStart+    , applyPatchesFinish+    )+import Darcs.UI.External ( viewDocWith ) import Darcs.UI.SelectChanges-    ( runSelection-    , selectionContext, selectionContextGeneric, selectionContextPrim+    ( runSelection, runInvertibleSelection+    , selectionConfig, selectionConfigGeneric, selectionConfigPrim     , WhichChanges(First, Last, LastReversed)     , viewChanges     )@@ -96,9 +101,10 @@ import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered     ( FL(..), (+>+), mapFL_FL-    , concatFL, mapFL, nullFL, lengthFL+    , concatFL, mapFL, nullFL, lengthFL, reverseFL     , (:>)(..)-    , RL(..), reverseRL+    , RL(..), reverseRL, mapRL_RL+    , Fork(..)     ) import Darcs.Patch.Witnesses.Sealed     ( Sealed(..), seal, unseal@@ -108,29 +114,26 @@ import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.English ( englishNum, Noun(Noun) ) import Darcs.Util.Printer-    ( vcat, text, ($$), redText-    , putDocLnWith, simplePrinters+    ( text, ($$), redText+    , simplePrinters     , renderString+    , formatWords+    , formatText+    , ($+$)     ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Path ( AbsolutePath ) +import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Tree ( Tree )+import Darcs.Util.Exception ( die ) -import Control.Exception ( catch, IOException )-import Control.Monad ( when )+import Control.Monad ( when, void ) import Control.Monad.Trans ( liftIO ) import System.Exit ( exitSuccess ) -rebaseDescription :: String-rebaseDescription = "Edit several patches at once."--rebaseHelp :: String-rebaseHelp =- "The `darcs rebase' command is used to edit a collection of darcs patches.\n"--rebase :: DarcsCommand [DarcsFlag]+rebase :: DarcsCommand rebase = SuperCommand     { commandProgramName = "darcs"     , commandName = "rebase"@@ -147,15 +150,50 @@         , normalCommand obliterate         , normalCommand log         , hiddenCommand changes+        , normalCommand upgrade         ]     }+  where+    rebaseDescription = "Edit several patches at once."+    rebaseHelp = formatText 80+      [ "The `darcs rebase' command is used to edit a collection of darcs patches."+      , "The basic idea is that you can suspend patches from the end of\+        \ a repository. These patches are no longer part of the history and\+        \ have no effect on the working tree. Suspended patches are invisible\+        \ to commands that access the repository from the outside, such as\+        \ push, pull, clone, send, etc."+      , "The sequence of suspended patches can be manipulated in ways that are\+        \ not allowed for normal patches. For instance, `darcs rebase obliterate`\+        \ allows you to remove a patch in this sequence, even if other suspended\+        \ patches depend on it. These other patches will as a result become\+        \ conflicted."+      , "You can also operate on the normal patches in the usual way. If you add\+        \ or remove normal patches, the suspended patches will be automatically\+        \ adapted to still apply to the pristine state, possibly becoming\+        \ conflicted in the course."+      , "Note that as soon as a patch gets suspended, it will irrevocably loose\+        \ its identity. This means that suspending a patch is subject to the\+        \ usual warnings about editing the history of your project."+      , "The opposite of suspending a patch is to unsuspend it.\+        \ This turns it back into a normal patch.\+        \ If the patch is conflicted as a result of previous operations on\+        \ either the normal patches or the suspended patches, unsuspending\+        \ will create appropriate conflict markup. Note, however, that the\+        \ unsuspended patch itself WILL NOT BE CONFLICTED itself. This means\+        \ that there is no way to re-generate the conflict markup. Once you\+        \ removed it, by editing files or using `darcs revert`, any information\+        \ about the conflict is lost."+      , "As long as you have suspended patches, darcs will display a short\+        \ message after each command to remind you that your patch editing\+        \ operation is still in progress."+      ] -suspend :: DarcsCommand [DarcsFlag]+suspend :: DarcsCommand suspend = DarcsCommand     { commandProgramName = "darcs"     , commandName = "suspend"-    , commandHelp = "Select patches to move into a suspended state at the end of the repo.\n"-    , commandDescription = "Select patches to move into a suspended state at the end of the repo."+    , commandHelp = text suspendDescription $+$ historyEditHelp+    , commandDescription = suspendDescription     , commandPrereq = amInHashedRepository     , commandExtraArgs = 0     , commandExtraArgHelp = []@@ -166,37 +204,37 @@     , commandBasicOptions = odesc suspendBasicOpts     , commandDefaults = defaultFlags suspendOpts     , commandCheckOptions = ocheck suspendOpts-    , commandParseOptions = onormalise suspendOpts     }   where     suspendBasicOpts-      = O.matchSeveralOrLast+      = O.notInRemote+      ^ O.matchSeveralOrLast       ^ O.selectDeps       ^ O.interactive-      ^ O.summary+      ^ O.withSummary       ^ O.diffAlgorithm     suspendAdvancedOpts       = O.changesReverse       ^ O.useIndex+      ^ O.umask     suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts+    suspendDescription =+      "Select patches to move into a suspended state at the end of the repo."  suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () suspendCmd _ opts _args =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $-    StartRebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $-    \repository -> do-    allpatches <- readRepo repository-    (rOld, suspended, allpatches_tail) <- return $ takeHeadRebase allpatches-    (_ :> patches) <--        return $ if firstMatch (parseFlags O.matchSeveralOrLast opts)-                 then getLastPatches (parseFlags O.matchSeveralOrLast opts) allpatches_tail-                 else matchingHead (parseFlags O.matchSeveralOrLast opts) allpatches_tail+    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+    StartRebaseJob $+    \_repository -> do+    suspended <- readTentativeRebase _repository+    (_ :> candidates) <- preselectPatches opts _repository     let direction = if changesReverse ? opts then Last else LastReversed-        patches_context = selectionContext direction "suspend" (patchSelOpts True opts) Nothing Nothing+        selection_config = selectionConfig+                              direction "suspend" (patchSelOpts True opts) Nothing Nothing     (_ :> psToSuspend) <-         runSelection-            patches-            patches_context+            candidates+            selection_config     when (nullFL psToSuspend) $ do         putStrLn "No patches selected!"         exitSuccess@@ -204,23 +242,23 @@     runHijackT RequestHijackPermission         $ mapM_ (getAuthor "suspend" False Nothing)         $ mapFL info psToSuspend-    repository' <- doSuspend opts repository suspended rOld psToSuspend-    finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts)+    _repository <- doSuspend opts _repository suspended psToSuspend+    _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)     return ()  doSuspend-    :: forall p wR wU wT wX+    :: forall p wR wU wX      . (RepoPatch p, ApplyState p ~ Tree)     => [DarcsFlag]-    -> Repository ('RepoType 'IsRebase) p wR wU wT-    -> Suspended p wT wT-    -> PatchInfoAnd ('RepoType 'IsRebase) p wT wT-    -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wT+    -> 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 (Items qs) rOld psToSuspend = do+doSuspend opts _repository suspended psToSuspend = do+    let (_, _, da) = diffingOpts opts     pend <- unrecordedChanges (diffingOpts opts)       O.NoLookForMoves O.NoLookForReplaces-      repository Nothing+      _repository Nothing     FlippedSeal psAfterPending <-         let effectPsToSuspend = effect psToSuspend in         case commute (effectPsToSuspend :> pend) of@@ -228,84 +266,76 @@             Nothing -> do                 putVerbose opts $                     let invPsEffect = invert effectPsToSuspend-                        doPartition = partitionConflictingFL (commuterIdFL selfCommuter)                     in-                    case (doPartition invPsEffect pend, doPartition pend invPsEffect) of+                    case (partitionConflictingFL invPsEffect pend, partitionConflictingFL pend invPsEffect) of                         (_ :> invSuspendedConflicts, _ :> pendConflicts) ->                             let suspendedConflicts = invert invSuspendedConflicts in                             redText "These changes in the suspended patches:" $$-                            showNicely suspendedConflicts $$+                            displayPatch suspendedConflicts $$                             redText "...conflict with these local changes:" $$-                            showNicely pendConflicts+                            displayPatch pendConflicts                 fail $ "Can't suspend selected patches without reverting some unrecorded change."                     ++ if (verbose opts) then "" else " Use --verbose to see the details."  -    rNew <- mkRebase (Items (mapFL_FL (ToEdit . fromRebasing . hopefully) psToSuspend +>+ qs))-    invalidateIndex repository-    -- remove the old rebase patch and the patches to suspend-    repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (psToSuspend +>+ (rOld :>: NilFL))-    tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect psToSuspend-    -- add the new rebase patch-    repository'' <- tentativelyAddPatch repository' (compress ? opts) (unVerbose (verbosity ? opts)) YesUpdateWorking (n2pia rNew)-    _ <- applyToWorking repository'' (verbosity ? opts) (invert psAfterPending)-            `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e)-    return repository''---- Certain repository functions will display the rebase patch in verbose mode--- so we use this function to suppress it when passing the verbosity.-unVerbose :: O.Verbosity -> O.Verbosity-unVerbose O.Verbose = O.NormalVerbosity-unVerbose x = x+    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 -unsuspend :: DarcsCommand [DarcsFlag]+unsuspend :: DarcsCommand unsuspend = DarcsCommand     { commandProgramName = "darcs"     , commandName = "unsuspend"-    , commandHelp = "Selected patches to restore from a suspended state to the end of the repo.\n"-    , commandDescription = "Select suspended patches to restore to the end of the repo."+    , commandHelp = text unsuspendDescription+    , commandDescription = unsuspendDescription     , commandPrereq = amInHashedRepository     , commandExtraArgs = 0     , commandExtraArgHelp = []-    , commandCommand = unsuspendCmd False+    , commandCommand = unsuspendCmd "unsuspend" False     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults     , commandAdvancedOptions = odesc unsuspendAdvancedOpts     , commandBasicOptions = odesc unsuspendBasicOpts     , commandDefaults = defaultFlags unsuspendOpts     , commandCheckOptions = ocheck unsuspendOpts-    , commandParseOptions = onormalise unsuspendOpts     }   where     unsuspendBasicOpts       = O.conflictsYes       ^ O.matchSeveralOrFirst       ^ O.interactive-      ^ O.summary+      ^ O.withSummary       ^ O.externalMerge       ^ O.keepDate       ^ O.author       ^ O.diffAlgorithm     unsuspendAdvancedOpts = O.useIndex     unsuspendOpts = unsuspendBasicOpts `withStdOpts` unsuspendAdvancedOpts+    unsuspendDescription =+      "Select suspended patches to restore to the end of the repo." -reify :: DarcsCommand [DarcsFlag]+reify :: DarcsCommand reify = DarcsCommand     { commandProgramName = "darcs"     , commandName = "reify"-    , commandHelp = "Select suspended patches to restore to the end of the repo, reifying any fixup patches.\n"-    , commandDescription = "Select suspended patches to restore to the end of the repo, reifying any fixup patches."+    , commandHelp = text reifyDescription+    , commandDescription = reifyDescription     , commandPrereq = amInHashedRepository     , commandExtraArgs = 0     , commandExtraArgHelp = []-    , commandCommand = unsuspendCmd True+    , commandCommand = unsuspendCmd "reify" True     , commandCompleteArgs = noArgs     , commandArgdefaults = nodefaults     , commandAdvancedOptions = []     , commandBasicOptions = odesc reifyBasicOpts     , commandDefaults = defaultFlags reifyOpts     , commandCheckOptions = ocheck reifyOpts-    , commandParseOptions = onormalise reifyOpts     }   where     reifyBasicOpts@@ -314,30 +344,25 @@       ^ O.keepDate       ^ O.author       ^ O.diffAlgorithm-    reifyOpts = reifyBasicOpts `withStdOpts` oid+    reifyOpts = reifyBasicOpts `withStdOpts` O.umask+    reifyDescription =+      "Select suspended patches to restore to the end of the repo,\+      \ reifying any fixup patches." -unsuspendCmd :: Bool -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-unsuspendCmd reifyFixups _ opts _args =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $-    RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $-    \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do-    patches <- readRepo repository-    pend <- unrecordedChanges (diffingOpts opts)-      O.NoLookForMoves O.NoLookForReplaces-      repository Nothing-    let checkChanges :: FL (PrimOf p) wA wB -> IO (EqCheck wA wB)-        checkChanges NilFL = return IsEq-        checkChanges _ = error "can't unsuspend when there are unrecorded changes"-    IsEq <- checkChanges pend :: IO (EqCheck wR wU)-    (rOld, Items ps, _) <- return $ takeHeadRebase patches+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 -    let selects = toRebaseSelect ps+    Items selects <- readTentativeRebase _repository -    let matchFlags = matchAny ? opts+    let matchFlags = O.matchSeveralOrFirst ? opts     inRange :> outOfRange <-         return $             if secondMatch matchFlags then-            splitSecondFL rsToPia matchFlags selects+            splitSecondFL rcToPia matchFlags selects             else selects :> NilFL      offer :> dontoffer <-@@ -346,62 +371,65 @@               Nothing -> partitionUnconflicted inRange -- skip conflicts               Just _ -> inRange :> NilRL -    let warnSkip :: RL q wX wY -> IO ()-        warnSkip NilRL = return ()+    let warnSkip NilRL = return ()         warnSkip _ = putStrLn "Skipping some patches which would cause conflicts."      warnSkip dontoffer -    let patches_context = selectionContextGeneric rsToPia First "unsuspend" (patchSelOpts True opts) Nothing-    (chosen :> keep) <- runSelection offer patches_context+    let selection_config = selectionConfigGeneric rcToPia First "unsuspend" (patchSelOpts True opts) Nothing+    (chosen :> keep) <- runSelection offer selection_config     when (nullFL chosen) $ do putStrLn "No patches selected!"                               exitSuccess -    (ps_to_unsuspend :: FL (WDDNamed p) wR wZ) :> chosen_fixups-           <- (if reifyFixups then reifyRebaseSelect else return . extractRebaseSelect) chosen+    ps_to_unsuspend :> chosen_fixups <-+      if reifyFixups+        then do+          author <- Flags.getAuthor (O.author ? opts) False+          reifyRebaseChange author chosen+        else return $ extractRebaseChange (diffAlgorithm ? opts) chosen      let da = diffAlgorithm ? opts-        ps_to_keep = simplifyPushes da chosen_fixups .-                     fromRebaseSelect $+        ps_to_keep = simplifyPushes da chosen_fixups $                      keep +>+ reverseRL dontoffer +>+ outOfRange -    Sealed standard_resolved_p <- return $ standardResolution $ concatFL-                                         $ progressFL "Examining patches for conflicts"-                                         $ mapFL_FL (patchcontents . wddPatch) ps_to_unsuspend-                                    :: IO (Sealed (FL (PrimOf p) wZ))+    context <- readRepo _repository -    have_conflicts <- announceMergeConflicts "unsuspend"-        (allowConflicts opts) (externalMerge ? opts) standard_resolved_p-    Sealed (resolved_p  :: FL (PrimOf p) wA wB) <-+    let conflicts =+          standardResolution (patchSet2RL context) $+          progressRL "Examining patches for conflicts" $+          mapRL_RL (n2pia . 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 $ seal standard_resolved_p-            (_, False) -> return $ seal standard_resolved_p+                    _ -> return $ mangled conflicts+            (_, False) -> return $ mangled conflicts             (YesExternalMerge _, True) ->                 error "external resolution for unsuspend not implemented yet"      let effect_to_apply = concatFL (mapFL_FL effect ps_to_unsuspend) +>+ resolved_p-    invalidateIndex repository-    repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL)+    invalidateIndex _repository     -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord-    tentativelyAddToPending repository' YesUpdateWorking effect_to_apply+    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-    rNew <- unseal (mkRebase . Items) . unseal (simplifyPushes da (mapFL_FL NameFixup renames)) $ ps_to_keep-    repository''' <- tentativelyAddPatch repository'' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew)-    finalizeRepositoryChanges repository''' YesUpdateWorking (compress ? opts)-    _ <- applyToWorking repository''' (verbosity ? opts) effect_to_apply `catch` \(e :: IOException) ->-        fail ("couldn't apply patch in working dir.\n" ++ show e)-    return ()-   ) :: IO ()+    (_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+     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 p) wT2 wT2)-          doAdd repo NilFL = return (repo, NilFL)-          doAdd repo ((p :: WDDNamed p wT wU) :>:ps) = do+                -> 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               case wddDependedOn p of                   [] -> return ()                   deps -> liftIO $ do@@ -419,36 +447,51 @@                       mapM_ (printIndented 2) deps                       putStr "\n" -              -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord+              -- TODO should catch logfiles (fst value from updatePatchHeader)+              -- and clean them up as in AmendRecord               p' <- snd <$> updatePatchHeader "unsuspend"                       NoAskAboutDeps                       (patchSelOpts True opts)                       (diffAlgorithm ? opts)-                      (parseFlags O.keepDate opts)-                      (parseFlags O.selectAuthor opts)-                      (parseFlags O.author opts)-                      (parseFlags O.patchname opts)-                      (parseFlags O.askLongComment opts)-                      (n2pia (toRebasing (wddPatch p))) NilFL-              repo' <- liftIO $ tentativelyAddPatch repo (compress ? opts) (verbosity ? opts) YesUpdateWorking p'+                      (O.keepDate ? opts)+                      (O.selectAuthor ? opts)+                      (O.author ? opts)+                      (O.patchname ? opts)+                      (O.askLongComment ? 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 p wU wU+              let rename :: RebaseName wU wU                   rename = Rename (info p') (patch2patchinfo (wddPatch p))               -- push it through the remaining patches to fix them up-              Just (ps2 :> (rename2 :: RebaseName p wV wT2)) <- return (commuterIdFL (commuterIdWDD commuteNameNamed) (rename :> ps))+              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+              (_repo, renames) <- doAdd _repo ps2               -- return the renames so that the suspended patch can be fixed up-              return (repo'', rename2 :>: renames)+              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." -inject :: DarcsCommand [DarcsFlag]+inject :: DarcsCommand inject = DarcsCommand     { commandProgramName = "darcs"     , commandName = "inject"-    , commandHelp = "Merge a change from the fixups of a patch into the patch itself.\n"-    , commandDescription = "Merge a change from the fixups of a patch into the patch itself."+    , commandHelp = text injectDescription+    , commandDescription = injectDescription     , commandPrereq = amInHashedRepository     , commandExtraArgs = 0     , commandExtraArgHelp = []@@ -459,39 +502,39 @@     , commandBasicOptions = odesc injectBasicOpts     , commandDefaults = defaultFlags injectOpts     , commandCheckOptions = ocheck injectOpts-    , commandParseOptions = onormalise injectOpts     }   where     injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm-    injectOpts = injectBasicOpts `withStdOpts` oid+    injectOpts = injectBasicOpts `withStdOpts` O.umask+    injectDescription =+      "Merge a change from the fixups of a patch into the patch itself."  injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () injectCmd _ opts _args =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $-    RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $-    \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> do-    patches <- readRepo repository--    (rOld, Items ps, _) <- return $ takeHeadRebase patches--    let selects = toRebaseSelect ps+    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+    RebaseJob $+    \(_repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> do+    Items selects <- readTentativeRebase _repository      -- TODO this selection doesn't need to respect dependencies-    -- TODO we only want to select one patch: generalise withSelectedPatchFromRepo-    let patches_context = selectionContextGeneric rsToPia First "inject into" (patchSelOpts True opts) Nothing-    (chosens :> rest_selects) <- runSelection selects patches_context+    -- 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 -    let extractSingle :: FL (RebaseSelect p) wX wY -> (FL (RebaseFixup p) :> Named p) wX wY-        extractSingle (RSFwd fixups toedit :>: NilFL) = fixups :> toedit-        extractSingle (_ :>: NilFL) = impossible+    let extractSingle :: FL (RebaseChange prim) wX wY -> (FL (RebaseFixup prim) :> Named prim) wX wY+        extractSingle (RC fixups toedit :>: NilFL) = fixups :> toedit         extractSingle _ = error "You must select precisely one patch!"      fixups :> toedit <- return $ extractSingle chosens      name_fixups :> prim_fixups <- return $ flToNamesPrims fixups -    let changes_context = selectionContextPrim Last "inject" (patchSelOpts True opts) (Just (primSplitter (diffAlgorithm ? opts))) Nothing Nothing-    (rest_fixups :> injects) <- runSelection prim_fixups changes_context+    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      when (nullFL injects) $ do         putStrLn "No changes selected!"@@ -499,23 +542,20 @@      -- Don't bother to update patch header since unsuspend will do that later     let da = diffAlgorithm ? opts-        toeditNew = fmapFL_Named (mapFL_FL fromPrim . canonizeFL da . (injects +>+) . effect) toedit-    rNew <- unseal (mkRebase . Items)-                               $ unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups))-                               $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups)-                               $ ToEdit toeditNew :>: fromRebaseSelect rest_selects--    repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL)-    repository'' <- tentativelyAddPatch repository' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew)-    finalizeRepositoryChanges repository'' YesUpdateWorking (compress ? 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 [DarcsFlag]+obliterate :: DarcsCommand obliterate = DarcsCommand     { commandProgramName = "darcs"     , commandName = "obliterate"-    , commandHelp = "Obliterate a patch that is currently suspended.\n"-    , commandDescription = "Obliterate a patch that is currently suspended.\n"+    , commandHelp = text obliterateDescription+    , commandDescription = obliterateDescription     , commandPrereq = amInHashedRepository     , commandExtraArgs = 0     , commandExtraArgHelp = []@@ -526,62 +566,55 @@     , commandBasicOptions = odesc obliterateBasicOpts     , commandDefaults = defaultFlags obliterateOpts     , commandCheckOptions = ocheck obliterateOpts-    , commandParseOptions = onormalise obliterateOpts     }   where     obliterateBasicOpts = O.diffAlgorithm-    obliterateOpts = obliterateBasicOpts `withStdOpts` oid+    obliterateOpts = obliterateBasicOpts `withStdOpts` O.umask+    obliterateDescription =+      "Obliterate a patch that is currently suspended."  obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () obliterateCmd _ opts _args =-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $-    RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $-    \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do-    patches <- readRepo repository--    (rOld, Items ps, _) <- return $ takeHeadRebase patches--    let selects = toRebaseSelect ps+    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+    RebaseJob $+    \(_repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do+    Items selects <- readTentativeRebase _repository      -- TODO this selection doesn't need to respect dependencies-    let patches_context = selectionContextGeneric rsToPia First "obliterate" (obliteratePatchSelOpts opts) Nothing-    (chosen :> keep) <- runSelection selects patches_context+    let selection_config = selectionConfigGeneric rcToPia First "obliterate" (obliteratePatchSelOpts opts) Nothing+    (chosen :> keep) <- runSelection selects selection_config     when (nullFL chosen) $ do putStrLn "No patches selected!"                               exitSuccess      let da = diffAlgorithm ? opts-        do_obliterate :: FL (RebaseItem p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)+        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 (Fixup f :>: qs) = unseal (simplifyPush da f) . do_obliterate qs-        do_obliterate (ToEdit e :>: qs) = -- since Named doesn't have any witness context for the-                                          -- patch names, the AddName here will be inferred to be wX wX-                                          unseal (simplifyPush da (NameFixup (AddName (patch2patchinfo e)))) .-                                          unseal (simplifyPushes da (mapFL_FL PrimFixup (effect (patchcontents e)))) .-                                          do_obliterate qs+        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 = do_obliterate (fromRebaseSelect chosen) (fromRebaseSelect keep)-    rNew <- unseal (mkRebase . 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) -    repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL)-    repository'' <- tentativelyAddPatch repository' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew)-    finalizeRepositoryChanges repository'' YesUpdateWorking (compress ? opts)+    _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)     return ()    ) :: IO ()  -pullDescription :: String-pullDescription =- "Copy and apply patches from another repository, suspending any local patches that conflict."--pullHelp :: String-pullHelp =- "Copy and apply patches from another repository, suspending any local patches that conflict."--pull :: DarcsCommand [DarcsFlag]+pull :: DarcsCommand pull = DarcsCommand     { commandProgramName = "darcs"     , commandName = "pull"-    , commandHelp = pullHelp+    , commandHelp = text pullDescription     , commandDescription = pullDescription     , commandExtraArgs = -1     , commandExtraArgHelp = ["[REPOSITORY]..."]@@ -593,7 +626,6 @@     , commandBasicOptions = odesc pullBasicOpts     , commandDefaults = defaultFlags pullOpts     , commandCheckOptions = ocheck pullOpts-    , commandParseOptions = onormalise pullOpts     }   where     pullBasicOpts@@ -604,9 +636,8 @@       ^ O.externalMerge       ^ O.runTest       ^ O.dryRunXml-      ^ O.summary+      ^ O.withSummary       ^ O.selectDeps-      ^ O.setDefault       ^ O.repoDir       ^ O.allowUnrelatedRepos       ^ O.diffAlgorithm@@ -617,26 +648,22 @@       ^ O.remoteRepos       ^ O.setScriptsExecutable       ^ O.umask-      ^ O.restrictPaths       ^ O.changesReverse       ^ O.network     pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts--applyDescription :: String-applyDescription = "Apply a patch bundle, suspending any local patches that conflict."--applyHelp :: String-applyHelp = "Apply a patch bundle, suspending any local patches that conflict."+    pullDescription =+      "Copy and apply patches from another repository,\+      \ suspending any local patches that conflict."  stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] stdindefault _ x = return x -apply :: DarcsCommand [DarcsFlag]+apply :: DarcsCommand apply = DarcsCommand     { commandProgramName = "darcs"     , commandName = "apply"-    , commandHelp = applyHelp+    , commandHelp = text applyDescription     , commandDescription = applyDescription     , commandExtraArgs = 1     , commandExtraArgHelp = ["<PATCHFILE>"]@@ -648,7 +675,6 @@     , commandBasicOptions = odesc applyBasicOpts     , commandDefaults = defaultFlags applyOpts     , commandCheckOptions = ocheck applyOpts-    , commandParseOptions = onormalise applyOpts     }   where     applyBasicOpts@@ -660,98 +686,76 @@       ^ O.repoDir       ^ O.diffAlgorithm     applyAdvancedOpts-      = O.reply-      ^ O.ccApply-      ^ O.happyForwarding-      ^ O.sendmail-      ^ O.useIndex+      = O.useIndex       ^ O.compress       ^ O.setScriptsExecutable       ^ O.umask-      ^ O.restrictPaths       ^ O.changesReverse       ^ O.pauseForGui     applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts+    applyDescription =+      "Apply a patch bundle, suspending any local patches that conflict."  data RebasePatchApplier = RebasePatchApplier  instance PatchApplier RebasePatchApplier where     type ApplierRepoTypeConstraint RebasePatchApplier rt = rt ~ 'RepoType 'IsRebase -    repoJob RebasePatchApplier opts f =-        StartRebaseJob-          (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking)-          (f PatchProxy)+    repoJob RebasePatchApplier f = StartRebaseJob (f PatchProxy)     applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd  applyPatchesForRebaseCmd-    :: forall p wR wU wX wT wZ+    :: forall p wR wU wZ      . ( RepoPatch p, ApplyState p ~ Tree )     => String     -> [DarcsFlag]-    -> String-    -> Repository ('RepoType 'IsRebase) p wR wU wT-    -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wT-    -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ+    -> 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     -> IO ()-applyPatchesForRebaseCmd cmdName opts _from_whom repository us' to_be_applied = do-    printDryRunMessageAndExit cmdName-        (verbosity ? opts)-        (O.summary ? opts)-        (dryRun ? opts)-        (xmlOutput ? opts)-        (isInteractive True opts)-        to_be_applied-    setEnvDarcsPatches to_be_applied-    when (nullFL to_be_applied) $ do-        putStrLn $ "You don't want to " ++ cmdName ++ " any patches, and that's fine with me!"-        exitSuccess-    checkPaths opts to_be_applied-    putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:"-    putVerbose opts $ vcat $ mapFL description to_be_applied-    usOk :> usConflicted <- return $ partitionConflictingFL (commuterIdFL selfCommuter) us' to_be_applied+applyPatchesForRebaseCmd cmdName opts _repository (Fork common us' to_be_applied) = do+    applyPatchesStart cmdName opts to_be_applied +    usOk :> usConflicted <- return $ partitionConflictingFL us' to_be_applied+     when (lengthFL usConflicted > 0) $         putInfo opts $ text "The following local patches are in conflict:"      -- TODO: we assume the options apply only to the main     -- command, review if there are any we should keep-    let patches_context = selectionContext LastReversed "suspend" applyPatchSelOpts Nothing Nothing+    let selection_config = selectionConfig LastReversed "suspend" applyPatchSelOpts Nothing Nothing -    (usKeep :> usToSuspend) <- runSelection usConflicted patches_context+    (usKeep :> usToSuspend) <- runSelection usConflicted selection_config      -- test all patches for hijacking and abort if rejected     runHijackT RequestHijackPermission         $ mapM_ (getAuthor "suspend" False Nothing)         $ mapFL info usToSuspend -    (rOld, suspended, _) <- return $ takeHeadRebaseFL us'-    repository' <- doSuspend opts repository suspended rOld usToSuspend+    suspended <- readTentativeRebase _repository++    _repository <- doSuspend 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 readUnrecorded-    -- claims to read the tentative state but actual reads the committed state-    -- as a result we have to commit here so that tentativelyMergePatches does-    -- the right thing.-    finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts)-        >> revertRepositoryChanges repository' YesUpdateWorking+    -- 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      Sealed pw <-         tentativelyMergePatches-            repository' cmdName-            (allowConflicts opts) YesUpdateWorking+            _repository cmdName+            (allowConflicts opts)             (externalMerge ? opts)             (wantGuiPause opts) (compress ? opts) (verbosity ? opts)             (reorder ? opts) (diffingOpts opts)-            (usOk +>+ usKeep) to_be_applied+            (Fork common (usOk +>+ usKeep) to_be_applied)+    invalidateIndex _repository -    invalidateIndex repository-    finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts)-    _ <- revertable $ applyToWorking repository' (verbosity ? opts) pw-    when (O.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $-      setScriptsExecutablePatches pw-    putInfo opts $ text $ "Finished " ++ cmdName ++ "ing."+    applyPatchesFinish cmdName opts _repository pw (nullFL to_be_applied)  -- TODO I doubt this is right, e.g. withContext should be inherited applyPatchSelOpts :: S.PatchSelectionOptions@@ -760,7 +764,7 @@     , S.matchFlags = []     , S.interactive = True     , S.selectDeps = O.PromptDeps -- option not supported, use default-    , S.summary = O.NoSummary+    , S.withSummary = O.NoSummary     , S.withContext = O.NoContext     } @@ -772,19 +776,19 @@ patchSelOpts :: Bool -> [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts defInteractive flags = S.PatchSelectionOptions     { S.verbosity = verbosity ? flags-    , S.matchFlags = parseFlags O.matchSeveralOrLast flags+    , S.matchFlags = O.matchSeveralOrLast ? flags     , S.interactive = isInteractive defInteractive flags     , S.selectDeps = selectDeps ? flags-    , S.summary = O.summary ? flags+    , S.withSummary = O.withSummary ? flags     , S.withContext = O.NoContext     } -log :: DarcsCommand [DarcsFlag]+log :: DarcsCommand log = DarcsCommand     { commandProgramName = "darcs"     , commandName = "log"-    , commandHelp = "List the currently suspended changes.\n"-    , commandDescription = "List the currently suspended changes"+    , commandHelp = text logDescription+    , commandDescription = logDescription     , commandPrereq = amInHashedRepository     , commandExtraArgs = 0     , commandExtraArgHelp = []@@ -795,66 +799,78 @@     , commandBasicOptions = odesc logBasicOpts     , commandDefaults = defaultFlags logOpts     , commandCheckOptions = ocheck logOpts-    , commandParseOptions = onormalise logOpts     }   where-    logBasicOpts = O.summary ^ O.interactive -- False+    logBasicOpts = O.withSummary ^ O.interactive -- False     logAdvancedOpts = oid     logOpts = logBasicOpts `withStdOpts` logAdvancedOpts+    logDescription = "List the currently suspended changes."  logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () logCmd _ opts _files =     withRepository (useCache ? opts) $-    RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $ \repository -> do-        patches <- readRepo repository-        (_, Items ps, _) <- return $ takeHeadRebase patches+    RebaseJob $ \_repository -> do+        Items ps <- readRebase _repository         let psToShow = toRebaseChanges ps         if isInteractive False opts             then viewChanges (patchSelOpts False opts) (mapFL Sealed2 psToShow)             else do                 debugMessage "About to print the changes..."                 let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters-                    emptyPatchSet = PatchSet NilRL NilRL-                    patchSet = appendPSFL emptyPatchSet psToShow-                logInfo <--                    getLogInfo-                         (maxCount ? opts)-                         (matchAny ? opts)-                         (onlyToFiles ? opts)-                         Nothing-                         (\_ qs -> return qs)-                         patchSet-                let logDoc = changelog opts patchSet logInfo-                putDocLnWith printers logDoc+                let logDoc = changelog opts (reverseFL psToShow) (logInfoFL psToShow)+                viewDocWith printers logDoc  -- | changes is an alias for log-changes :: DarcsCommand [DarcsFlag]+changes :: DarcsCommand changes = commandAlias "changes" Nothing log +upgrade :: DarcsCommand+upgrade = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "upgrade"+    , commandHelp = help+    , commandDescription = desc+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = upgradeCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandAdvancedOptions = []+    , commandBasicOptions = odesc basicOpts+    , commandDefaults = defaultFlags opts+    , commandCheckOptions = ocheck opts+    }+  where+    basicOpts = oid+    opts = basicOpts `withStdOpts` O.umask+    desc = "Upgrade a repo with an old-style rebase in progress."+    help = text desc $+$ formatWords+      [ "Doing this means you won't be able to use darcs version < 2.15"+      , "with this repository until the rebase is finished."+      ]++upgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+upgradeCmd _ opts _args =+  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $+  OldRebaseJob $ \(_repo :: Repository ('RepoType 'IsRebase) p wR wU wR) ->+    upgradeOldStyleRebase _repo (compress ? opts)+ {- TODO: - - amend-record shows the diff between the conflicted state and the resolution, which is unhelpful- - testing+ - amend-record shows the diff between the conflicted state and the+   resolution, which is unhelpful  - make aggregate commands  - argument handling  - what should happen to patch comment on unsuspend?- - don't just drop explicit dependencies:-    - turn patchnames/explicit deps into patch type and use commutation- - repo representation- - seem to be able to get a messed up unrevert context- - darcs pull/get can setup a rebase patch in a remote repo without the right format-    - rebase patches seem to parse as empty rather than failing??  - warn about suspending conflicts  - indication of expected conflicts on unsuspend     - why isn't ! when you do x accurate?- - rebase obliterate for more efficient removing of suspended patches  - rebase pull needs more UI work     - automatically answer yes re suspension     - offer all patches (so they can be kept in order)        - or perhaps rebase suspend --complement?- - rebase changes for viewing suspended patch- - matching options for rebase unsuspend (etc)  - make unsuspend actually display the patch helpfully like normal selection  - amended patches will often be in both the target repo and in the rebase context, detect?  - can we be more intelligent about conflict resolutions?@@ -862,11 +878,7 @@  - review other conflict options for unsuspend  - warning message on suspend about not being able to unsuspend with unrecorded changes  - aborting during a rebase pull or rebase suspend causes it to leave the repo marked for rebase- - rebase suspend needs --match  - patch count: get English right in <n> suspended patch(es)  - darcs check should check integrity of rebase patch  - review existence of reify and inject commands - bit of an internals hack- - need to move rebase to front before adding amend-record hint (and test this)- - print something while moving rebase to front -}-
src/Darcs/UI/Commands/Record.hs view
@@ -20,16 +20,13 @@ module Darcs.UI.Commands.Record     ( record     , commit-    , recordConfig, RecordConfig(..) -- needed for darcsden     ) where -import Prelude () import Darcs.Prelude import Data.Foldable ( traverse_ )  import Control.Exception ( handleJust ) import Control.Monad ( when, unless, void )-import Data.List ( sort ) import Data.Char ( ord ) import System.Exit ( exitFailure, exitSuccess, ExitCode(..) ) import System.Directory ( removeFile )@@ -42,24 +39,26 @@     , tentativelyAddPatch     , finalizeRepositoryChanges     , invalidateIndex-    , unrecordedChanges+    , readPendingAndWorking     , readRecorded     )-import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, fromPrims )-import Darcs.Patch.Named.Wrapped ( namepatch, adddeps )+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 )+    ( FL(..), (:>)(..), nullFL, (+>+) )+import Darcs.Patch.Info ( PatchInfo, patchinfo ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Split ( primSplitter ) import Darcs.UI.SelectChanges     (  WhichChanges(..)-    , selectionContextPrim-    , runSelection+    , selectionConfigPrim+    , runInvertibleSelection     , askAboutDepends     ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )-import Darcs.Util.Path ( SubPath, toFilePath, AbsolutePath )+import Darcs.Util.Path ( AnchoredPath, displayPath, AbsolutePath ) import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts     , nodefaults@@ -78,31 +77,99 @@     , getDate     , diffOpts     , scanKnown-    , fixSubPaths+    , pathSetFromArgs     ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, oparse, defaultFlags ) import Darcs.UI.PatchHeader ( getLog ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdateWorking (..), DryRun(NoDryRun), ScanKnown(..) )+import Darcs.Repository.Flags ( UpdatePending (..), DryRun(NoDryRun), ScanKnown(..) ) 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.Printer ( putDocLn, text, (<+>) )-import Darcs.Util.Text ( pathlist )+import Darcs.Util.Printer+    ( Doc+    , ($+$)+    , (<+>)+    , formatWords+    , pathlist+    , putDocLn+    , text+    , vcat+    , vsep+    ) import Darcs.Util.Tree( Tree ) -recordDescription :: String-recordDescription = "Create a patch from unrecorded changes."--recordHelp :: String+recordHelp :: Doc recordHelp =- "The `darcs record` command is used to create a patch from changes in\n" ++- "the working tree.  If you specify a set of files and directories,\n" ++- "changes to other files will be skipped.\n" ++- "\n" ++ recordHelp' ++- "\n" ++ recordHelp''+  vsep (map formatWords+  [ [ "The `darcs record` command is used to create a patch from changes in"+    , "the working tree.  If you specify a set of files and directories,"+    , "changes to other files will be skipped."+    ]+  , [ "Every patch has a name, an optional description, an author and a date."+    ]+  , [ "Darcs will launch a text editor (see `darcs help environment`) after the"+    , "interactive selection, to let you enter the patch name (first line) and"+    , "the patch description (subsequent lines)."+    ]+  , [ "You can supply the patch name in advance with the `-m` option, in which"+    , "case no text editor is launched, unless you use `--edit-long-comment`."+    ]+  , [ "The patch description is an optional block of free-form text.  It is"+    , "used to supply additional information that doesn't fit in the patch"+    , "name.  For example, it might include a rationale of WHY the change was"+    , "necessary."+    ]+  , [ "A technical difference between patch name and patch description, is"+    , "that matching with the flag `-p` is only done on patch names."+    ]+  , [ "Finally, the `--logfile` option allows you to supply a file that already"+    , "contains the patch name and description.  This is useful if a previous"+    , "record failed and left a `_darcs/patch_description.txt` file."+    ]+  , fileHelpAuthor+  , [ "If you want to manually define any explicit dependencies for your patch,"+    , "you can use the `--ask-deps` flag. Some dependencies may be automatically"+    , "inferred from the patch's content and cannot be removed. A patch with"+    , "specific dependencies can be empty."+    ]+  , [ "The patch date is generated automatically.  It can only be spoofed by"+    , "using the `--pipe` option."+    ]+  , [ "If you run record with the `--pipe` option, you will be prompted for"+    , "the patch date, author, and the long comment. The long comment will extend"+    , "until the end of file or stdin is reached. This interface is intended for"+    , "scripting darcs, in particular for writing repository conversion scripts."+    , "The prompts are intended mostly as a useful guide (since scripts won't"+    , "need them), to help you understand the input format. Here's an example of"+    , "what the `--pipe` prompts look like:"+    ]+  ])+  $+$ vcat+    [ "    What is the date? Mon Nov 15 13:38:01 EST 2004"+    , "    Who is the author? David Roundy"+    , "    What is the log? One or more comment lines"+    ]+  $+$ vsep (map formatWords+  [ [ "If a test command has been defined with `darcs setpref`, attempting to"+    , "record a patch will cause the test command to be run in a clean copy"+    , "of the working tree (that is, including only recorded changes).  If"+    , "the test fails, you will be offered to abort the record operation."+    ]+  , [ "The `--set-scripts-executable` option causes scripts to be made"+    , "executable in the clean copy of the working tree, prior to running the"+    , "test.  See `darcs clone` for an explanation of the script heuristic."+    ]+  , [ "If your test command is tediously slow (e.g. `make all`) and you are"+    , "recording several patches in a row, you may wish to use `--no-test` to"+    , "skip all but the final test."+    ]+  , [ "To see some context (unchanged lines) around each change, use the"+    , "`--unified` option."+    ]+  ])  recordBasicOpts :: DarcsOption a                    (Maybe String@@ -159,12 +226,12 @@ recordConfig :: [DarcsFlag] -> RecordConfig recordConfig = oparse (recordBasicOpts ^ O.verbosity ^ recordAdvancedOpts ^ O.useCache) RecordConfig -record :: DarcsCommand RecordConfig+record :: DarcsCommand record = DarcsCommand     { commandProgramName = "darcs"     , commandName = "record"     , commandHelp = recordHelp-    , commandDescription = recordDescription+    , commandDescription = "Create a patch from unrecorded changes."     , commandExtraArgs = -1     , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]     , commandCommand = recordCmd@@ -175,30 +242,28 @@     , commandBasicOptions = odesc recordBasicOpts     , commandDefaults = defaultFlags recordOpts     , commandCheckOptions = ocheck recordOpts-    , commandParseOptions = recordConfig     }   where     recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts  -- | commit is an alias for record-commit :: DarcsCommand RecordConfig+commit :: DarcsCommand commit = commandAlias "commit" Nothing record -reportNonExisting :: ScanKnown -> ([SubPath], [SubPath]) -> IO ()+reportNonExisting :: ScanKnown -> ([AnchoredPath], [AnchoredPath]) -> IO () reportNonExisting scan (paths_only_in_working, _) = do   unless (scan /= ScanKnown || null paths_only_in_working) $  putDocLn $     "These paths are not yet in the repository and will be added:" <+>-    pathlist (map toFilePath paths_only_in_working)+    pathlist (map displayPath paths_only_in_working) -recordCmd :: (AbsolutePath, AbsolutePath) -> RecordConfig -> [String] -> IO ()-recordCmd fps cfg args = do+recordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+recordCmd fps flags args = do+    let cfg = recordConfig flags     checkNameIsNotOption (patchname cfg) (isInteractive cfg)-    withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do+    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)       existing_files <- do-        files <- if null args then return Nothing-                 else Just . sort <$> fixSubPaths fps args-        when (files == Just []) $ fail "No valid arguments were given."+        files <- pathSetFromArgs fps args         files' <-           traverse             (filterExistingPaths@@ -212,12 +277,12 @@         return files''       announceFiles (verbosity cfg) existing_files "Recording changes in"       debugMessage "About to get the unrecorded changes."-      changes <- unrecordedChanges (diffingOpts cfg)+      changes <- readPendingAndWorking (diffingOpts cfg)                    (O.moves (lookfor cfg)) (O.replaces (lookfor cfg))                    repository existing_files       debugMessage "I've got unrecorded changes."       case changes of-          NilFL | not (askDeps cfg) -> do+          NilFL :> NilFL | not (askDeps cfg) -> do               -- We need to grab any input waiting for us, since we               -- might break scripts expecting to send it to us; we               -- don't care what that input is, though.@@ -236,18 +301,19 @@         unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure  doRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-         => Repository rt p wR wU wR -> RecordConfig -> Maybe [SubPath] -> FL (PrimOf p) wR wX -> IO ()-doRecord repository cfg files ps = do+         => Repository rt p wR wU wR -> RecordConfig -> 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'm slurping the repository."     pristine <- readRecorded repository     debugMessage "About to select changes..."-    (chs :> _ ) <- runSelection ps $-                  selectionContextPrim First "record" (patchSelOpts cfg)-                                       (Just (primSplitter (diffAlgorithm cfg)))-                                       (map toFilePath <$> files)-                                       (Just pristine)+    (chs :> _ ) <- runInvertibleSelection (sortCoalesceFL $ pending +>+ working) $+                      selectionConfigPrim+                          First "record" (patchSelOpts cfg)+                          (Just (primSplitter (diffAlgorithm cfg)))+                          files (Just pristine)     when (not (askDeps cfg) && nullFL chs) $               do putStrLn "Ok, if you don't want to record anything, that's fine!"                  exitSuccess@@ -261,121 +327,61 @@                   else do setEnvDarcsFiles chs                           (name, my_log, logf) <- getLog (patchname cfg) (pipe cfg) (logfile cfg) (askLongComment cfg) Nothing chs                           debugMessage ("Patch name as received from getLog: " ++ show (map ord name))-                          doActualRecord repository cfg name date my_author my_log logf deps chs+                          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                -> String -> String -> String                -> [String] -> Maybe String-               -> [PatchInfo] -> FL (PrimOf p) wR wX -> IO ()-doActualRecord repository cfg name date my_author my_log logf deps chs =-              do debugMessage "Writing the patch file..."-                 mypatch <- namepatch date name my_author my_log $-                            fromPrims $ progressFL "Writing changes:" chs-                 let pia = n2pia $ adddeps mypatch deps-                 -- We don't care about the returned updated repository-                 _ <- tentativelyAddPatch repository (compress cfg) (verbosity cfg) YesUpdateWorking-                           $ pia-                 invalidateIndex repository-                 debugMessage "Applying to pristine..."-                 testTentativeAndMaybeExit repository-                      (verbosity cfg)-                      (testChanges cfg)-                      (sse cfg)-                      (isInteractive cfg)-                      ("you have a bad patch: '" ++ name ++ "'")-                      "record it" (Just failuremessage)-                 finalizeRepositoryChanges repository YesUpdateWorking (compress cfg)-                                    `clarifyErrors` failuremessage-                 debugMessage "Syncing timestamps..."-                 removeLogFile logf-                 unless (verbosity cfg == O.Quiet) $-                     putDocLn $ text $ "Finished recording patch '" ++ name ++ "'"-                 setEnvDarcsPatches (pia :>: NilFL)-    where-        removeLogFile :: Maybe String -> IO ()-        removeLogFile Nothing = return ()-        removeLogFile (Just lf) | lf == darcsLastMessage = return ()-                                | otherwise              = removeFile lf-        failuremessage = "Failed to record patch '"++name++"'" ++-                           case logf of Just lf -> "\nLogfile left in "++lf++"."-                                        Nothing -> ""--recordHelp' :: String-recordHelp' = unlines- [ "Every patch has a name, an optional description, an author and a date."- , ""- , "Darcs will launch a text editor (see `darcs help environment`) after the"- , "interactive selection, to let you enter the patch name (first line) and"- , "the patch description (subsequent lines)."- , ""- , "You can supply the patch name in advance with the `-m` option, in which"- , "case no text editor is launched, unless you use `--edit-long-comment`."- , ""- , "The patch description is an optional block of free-form text.  It is"- , "used to supply additional information that doesn't fit in the patch"- , "name.  For example, it might include a rationale of WHY the change was"- , "necessary."- , ""- , "A technical difference between patch name and patch description, is"- , "that matching with the flag `-p` is only done on patch names."- , ""- , "Finally, the `--logfile` option allows you to supply a file that already"- , "contains the patch name and description.  This is useful if a previous"- , "record failed and left a `_darcs/patch_description.txt` file."- , ""- , unlines fileHelpAuthor- , "If you want to manually define any explicit dependencies for your patch,"- , "you can use the `--ask-deps` flag. Some dependencies may be automatically"- , "inferred from the patch's content and cannot be removed. A patch with"- , "specific dependencies can be empty."- , ""- , "The patch date is generated automatically.  It can only be spoofed by"- , "using the `--pipe` option."- , ""- , "If you run record with the `--pipe` option, you will be prompted for"- , "the patch date, author, and the long comment. The long comment will extend"- , "until the end of file or stdin is reached. This interface is intended for"- , "scripting darcs, in particular for writing repository conversion scripts."- , "The prompts are intended mostly as a useful guide (since scripts won't"- , "need them), to help you understand the input format. Here's an example of"- , "what the `--pipe` prompts look like:"- , ""- , "    What is the date? Mon Nov 15 13:38:01 EST 2004"- , "    Who is the author? David Roundy"- , "    What is the log? One or more comment lines"- ]+               -> [PatchInfo] -> FL (PrimOf p) wR wX+               -> (FL (PrimOf p) :> FL (PrimOf p)) wR wU -> IO ()+doActualRecord _repository cfg name date my_author my_log logf deps chs+      (pending :> working) = do+    debugMessage "Writing the patch file..."+    myinfo <- patchinfo date name my_author my_log+    let mypatch = infopatch myinfo $ progressFL "Writing changes:" chs+    let pia = n2pia $ adddeps mypatch deps+    _repository <-+      tentativelyAddPatch _repository (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 ++ "'")+      "record it" (Just failuremessage)+    tentativelyRemoveFromPW _repository chs pending working+    _repository <-+      finalizeRepositoryChanges _repository YesUpdatePending (compress cfg)+      `clarifyErrors` failuremessage+    debugMessage "Syncing timestamps..."+    removeLogFile logf+    unless (verbosity cfg == O.Quiet) $+      putDocLn $ text $ "Finished recording patch '" ++ name ++ "'"+    setEnvDarcsPatches (pia :>: NilFL)+  where+    removeLogFile :: Maybe String -> IO ()+    removeLogFile Nothing = return ()+    removeLogFile (Just lf)+      | lf == darcsLastMessage = return ()+      | otherwise = removeFile lf+    failuremessage =+      "Failed to record patch '" ++ name ++ "'" +++        case logf of+          Just lf -> "\nLogfile left in " ++ lf ++ "."+          Nothing -> ""  onlySuccessfulExits :: ExitCode -> Maybe () onlySuccessfulExits ExitSuccess = Just () onlySuccessfulExits _ = Nothing -recordHelp'' :: String-recordHelp'' =- "If a test command has been defined with `darcs setpref`, attempting to\n" ++- "record a patch will cause the test command to be run in a clean copy\n" ++- "of the working tree (that is, including only recorded changes).  If\n" ++- "the test fails, you will be offered to abort the record operation.\n" ++- "\n" ++- "The `--set-scripts-executable` option causes scripts to be made\n" ++- "executable in the clean copy of the working tree, prior to running the\n" ++- "test.  See `darcs clone` for an explanation of the script heuristic.\n" ++- "\n" ++- "If your test command is tediously slow (e.g. `make all`) and you are\n" ++- "recording several patches in a row, you may wish to use `--no-test` to\n" ++- "skip all but the final test.\n" ++- "\n" ++- "To see some context (unchanged lines) around each change, use the\n" ++- "`--unified` option.\n"- patchSelOpts :: RecordConfig -> S.PatchSelectionOptions patchSelOpts cfg = S.PatchSelectionOptions     { S.verbosity = verbosity cfg     , S.matchFlags = []     , S.interactive = isInteractive cfg     , S.selectDeps = O.PromptDeps -- option not supported, use default-    , S.summary = O.NoSummary -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default     , S.withContext = withContext cfg     }
src/Darcs/UI/Commands/Remove.hs view
@@ -17,7 +17,6 @@  module Darcs.UI.Commands.Remove ( remove, rm, unadd ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when, foldM )@@ -28,13 +27,13 @@     , putWarning, putInfo     , amInHashedRepository     )-import Darcs.UI.Commands.Util ( expandDirs ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.Flags-    ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, fixSubPaths, quiet )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )+    ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, quiet, pathsFromArgs )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdateWorking (..) )++import Darcs.Repository.Flags ( UpdatePending (..) ) import Darcs.Repository     ( Repository     , withRepoLock@@ -44,22 +43,23 @@     , readUnrecorded     ) import Darcs.Repository.Diff( treeDiff )+ import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile,                      listTouchedFiles ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft ) import Darcs.Repository.Prefs ( filetypeFunction, FileType )-import Darcs.Util.Tree( Tree, TreeItem(..), find, modifyTree, expand, list )-import Darcs.Util.Path( anchorPath, AnchoredPath, fn2fp, SubPath, sp2fn-                      , AbsolutePath, floatPath )-import Darcs.Util.Printer ( text, vcat )+import Darcs.Util.Tree( Tree, TreeItem(..), explodePaths )+import qualified Darcs.Util.Tree as T ( find, modifyTree, expand, list )+import Darcs.Util.Path( AnchoredPath, displayPath, isRoot, AbsolutePath )+import Darcs.Util.Printer ( Doc, text, vcat )  removeDescription :: String removeDescription = "Remove files from version control." -removeHelp :: String-removeHelp =+removeHelp :: Doc+removeHelp = text $  "The `darcs remove` command exists primarily for symmetry with `darcs\n" ++  "add`, as the normal way to remove a file from version control is\n" ++  "simply to delete it from the working tree.  This command is only\n" ++@@ -69,7 +69,7 @@  "Note that applying a removal patch to a repository (e.g. by pulling\n" ++  "the patch) will ALWAYS affect the working tree of that repository.\n" -remove :: DarcsCommand [DarcsFlag]+remove :: DarcsCommand remove = DarcsCommand     { commandProgramName = "darcs"     , commandName = "remove"@@ -85,50 +85,52 @@     , commandBasicOptions = odesc removeBasicOpts     , commandDefaults = defaultFlags removeOpts     , commandCheckOptions = ocheck removeOpts-    , commandParseOptions = onormalise removeOpts     }   where     removeBasicOpts = O.repoDir ^ O.recursive-    removeAdvancedOpts = O.umask+    removeAdvancedOpts = O.useIndex ^ O.umask     removeOpts = removeBasicOpts `withStdOpts` removeAdvancedOpts  removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () removeCmd fps opts relargs = do     when (null relargs) $         fail "Nothing specified, nothing removed."-    origfiles <- fixSubPaths fps relargs-    when (null origfiles) $-        fail "No valid arguments were given."-    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $+    paths <- pathsFromArgs fps relargs+    when (any isRoot paths) $+        fail "Cannot remove a repository's root directory!"+    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $       RepoJob $ \repository -> do-        args <- if parseFlags O.recursive opts-                then reverse `fmap` expandDirs False origfiles-                else return origfiles-        Sealed p <- makeRemovePatch opts repository args+        recorded_and_pending <- readRecordedAndPending 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 origfiles) && not (quiet opts)) $+        when (nullFL p && not (null paths) && not (quiet opts)) $             fail "No files were removed."-        addToPending repository YesUpdateWorking p-        putInfo opts $ vcat $ map text $ ["Will stop tracking:"] ++ listTouchedFiles p+        addToPending repository (O.useIndex ? opts) p+        putInfo opts $ vcat $ map text $ ["Will stop tracking:"] +++            map displayPath (listTouchedFiles p)  -- | makeRemovePatch builds a list of patches to remove the given filepaths. --   This function does not recursively process directories. The 'Recursive' --   flag should be handled by the caller by adding all offspring of a directory --   to the files list. makeRemovePatch :: (RepoPatch p, ApplyState p ~ Tree)-                => [DarcsFlag] -> Repository rt p wR wU wT-                -> [SubPath] -> IO (Sealed (FL (PrimOf p) wU))+                => [DarcsFlag] -> Repository rt p wR wU wR+                -> [AnchoredPath] -> IO (Sealed (FL (PrimOf p) wU)) makeRemovePatch opts repository files =-                          do recorded <- expand =<< readRecordedAndPending repository-                             unrecorded <- readUnrecorded repository $ Just files+                          do recorded <- T.expand =<< readRecordedAndPending repository+                             unrecorded <- readUnrecorded repository (O.useIndex ? opts) $ Just files                              ftf <- filetypeFunction-                             result <- foldM removeOnePath (ftf,recorded,unrecorded, []) $ map (floatPath . fn2fp . sp2fn) files+                             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' = modifyTree recorded f Nothing-                unrecorded' = modifyTree unrecorded f Nothing+            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@@ -147,22 +149,21 @@ makeRemoveGap :: PrimPatch prim => [DarcsFlag] -> (FilePath -> FileType)                 -> Tree IO -> Tree IO -> Tree IO -> AnchoredPath                 -> IO (Maybe (FreeLeft (FL prim)))-makeRemoveGap opts ftf recorded unrecorded unrecorded' f =-    case (find recorded f, find unrecorded f) of+makeRemoveGap opts ftf recorded unrecorded unrecorded' path =+    case (T.find recorded path, T.find unrecorded path) of         (Just (SubTree _), Just (SubTree unrecordedChildren)) ->-            if not $ null (list unrecordedChildren)+            if not $ null (T.list unrecordedChildren)               then skipAndWarn "it is not empty"-              else return $ Just $ freeGap (rmdir f_fp :>: NilFL)+              else return $ Just $ freeGap (rmdir path :>: NilFL)         (Just (File _), Just (File _)) -> do             Just `fmap` treeDiff (diffAlgorithm ? opts) ftf unrecorded unrecorded'         (Just (File _), _) ->-            return $ Just $ freeGap (addfile f_fp :>: rmfile f_fp :>: NilFL)+            return $ Just $ freeGap (addfile path :>: rmfile path :>: NilFL)         (Just (SubTree _), _) ->-            return  $ Just $ freeGap (adddir f_fp :>: rmdir f_fp :>: NilFL)+            return  $ Just $ freeGap (adddir path :>: rmdir path :>: NilFL)         (_, _) -> skipAndWarn "it is not tracked by darcs"-  where f_fp = anchorPath "" f-        skipAndWarn reason =-            do putWarning opts . text $ "Can't remove " ++ f_fp+  where skipAndWarn reason =+            do putWarning opts . text $ "Can't remove " ++ displayPath path                                         ++ " (" ++ reason ++ ")"                return Nothing @@ -170,17 +171,16 @@ rmDescription :: String rmDescription = "Help newbies find `darcs remove'." -rmHelp :: String-rmHelp =+rmHelp :: Doc+rmHelp = text $  "The `darcs rm' command does nothing.\n" ++  "\n" ++  "The normal way to remove a file from version control is simply to\n" ++  "delete it from the working tree.  To remove a file from version\n" ++  "control WITHOUT affecting the working tree, see `darcs remove'.\n" -rm :: DarcsCommand [DarcsFlag]+rm :: DarcsCommand rm = commandStub "rm" rmHelp rmDescription remove -unadd :: DarcsCommand [DarcsFlag]+unadd :: DarcsCommand unadd = commandAlias "unadd" Nothing remove-
src/Darcs/UI/Commands/Repair.hs view
@@ -15,74 +15,77 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Repair ( repair, check ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when, unless ) import Control.Exception ( catch, IOException ) import System.Exit ( ExitCode(..), exitWith ) import System.Directory( renameFile )-import System.FilePath ( (</>) )+import System.FilePath ( (<.>) )  import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts, nodefaults-    , putInfo, amInHashedRepository+    , putInfo, putWarning, amInHashedRepository     ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags-    ( DarcsFlag, verbosity, dryRun, umask, useIndex+    ( DarcsFlag, verbosity, umask, useIndex     , useCache, compress, diffAlgorithm, quiet     ) import Darcs.UI.Options     ( DarcsOption, (^), oid-    , odesc, ocheck, onormalise, defaultFlags, (?)+    , odesc, ocheck, defaultFlags, (?)     ) import qualified Darcs.UI.Options.All as O -import Darcs.Repository.Flags ( UpdateWorking (..) )+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, writePatchSet+    , withRepoLock, replacePristine, repoCache     )+import qualified Darcs.Repository.Hashed as HashedRepo import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Repository.Diff( treeDiff ) -import Darcs.Patch ( RepoPatch, showNicely, PrimOf )+import Darcs.Patch ( RepoPatch, PrimOf, displayPatch ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft ) -import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Printer ( text, ($$), (<+>) )-import Darcs.Util.Tree( Tree )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Tree ( Tree, expand )+import Darcs.Util.Tree.Hashed ( darcsUpdateHashes )   repairDescription :: String repairDescription = "Repair a corrupted repository." -repairHelp :: String-repairHelp =- "The `darcs repair` command attempts to fix corruption in the current\n" ++- "repository.  Currently it can only repair damage to the pristine tree,\n" ++- "which is where most corruption occurs.\n" ++- "This command rebuilds a pristine tree by applying successively the\n" ++- "patches in the repository to an empty tree.\n" ++- "\n" ++- "The flag `--dry-run` make this operation read-only, making darcs exit\n" ++- "unsuccessfully (with a non-zero exit status) if the rebuilt pristine is\n" ++- "different from the current pristine.\n"+repairHelp :: Doc+repairHelp = text $+  "The `darcs repair` command attempts to fix corruption in the current\n\+  \repository.\n\+  \It works by successively applying all patches in the repository to an\n\+  \empty tree, each time checking that the patch can be cleanly applied\n\+  \to the current pristine tree. If we detect a problem, we try to repair\n\+  \the patch. Finally we compare the existing pristine with the newly\n\+  \reconstructed one and if they differ, replace the existing one.\n\+  \Any problem encountered is reported.\n\+  \The flag `--dry-run` makes this operation read-only and causes it to\n\+  \exit unsuccessfully (with a non-zero exit status) in case any problems\n\+  \are enountered.\n"  commonBasicOpts :: DarcsOption a                    (Maybe String -> O.UseIndex -> O.DiffAlgorithm -> a) commonBasicOpts = O.repoDir ^ O.useIndex ^ O.diffAlgorithm -repair :: DarcsCommand [DarcsFlag]+repair :: DarcsCommand repair = DarcsCommand     { commandProgramName = "darcs"     , commandName = "repair"@@ -104,35 +107,40 @@     commandBasicOptions = odesc basicOpts     commandDefaults = defaultFlags allOpts     commandCheckOptions = ocheck allOpts-    commandParseOptions = onormalise allOpts  withFpsAndArgs :: (b -> d) -> a -> b -> c -> d withFpsAndArgs cmd _ opts _ = cmd opts  repairCmd :: [DarcsFlag] -> IO ()-repairCmd opts = case dryRun ? opts of- O.YesDryRun -> checkCmd opts- O.NoDryRun ->-  withRepoLock O.NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts)-  $ RepoJob $ \repository -> do-    replayRepository (diffAlgorithm ? opts) repository (compress ? opts) (verbosity ? opts) $ \state ->-      case state of-        RepositoryConsistent ->-          putStrLn "The repository is already consistent, no changes made."-        BrokenPristine tree -> do-          putStrLn "Fixing pristine tree..."-          replacePristine repository tree-        BrokenPatches tree newps  -> do-          putStrLn "Writing out repaired patches..."-          _ <- writePatchSet newps (useCache ? opts)-          putStrLn "Fixing pristine tree..."-          replacePristine repository tree-    index_ok <- checkIndex repository (quiet opts)-    unless index_ok $ do renameFile (darcsdir </> "index") (darcsdir </> "index.bad")-                         putStrLn "Bad index discarded."+repairCmd opts+  | O.yes (O.dryRun ? opts) = checkCmd opts+  | otherwise =+    withRepoLock O.NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+    RepoJob $ \repo -> do+      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+            putInfo opts "Writing out repaired patches..."+            HashedRepo.writeTentativeInventory (repoCache repo) (compress ? opts) newps+            HashedRepo.finalizeTentativeChanges repo (compress ? opts)+            putInfo opts "Fixing pristine tree..."+            replacePristine repo tree+      index_ok <- checkIndex repo (quiet opts)+      unless index_ok $ do+        renameFile indexPath (indexPath <.> "bad")+        putInfo opts "Bad index discarded."  -- |check is an alias for repair, with implicit DryRun flag.-check :: DarcsCommand [DarcsFlag]+check :: DarcsCommand check = DarcsCommand     { commandProgramName = "darcs"     , commandName = "check"@@ -153,7 +161,6 @@     commandBasicOptions = odesc basicOpts     commandDefaults = defaultFlags allOpts     commandCheckOptions = ocheck allOpts-    commandParseOptions = onormalise allOpts     commandDescription = "Alias for `darcs " ++ commandName repair ++ " --dry-run'."  checkCmd :: [DarcsFlag] -> IO ()@@ -162,36 +169,36 @@   failed <-     case state of       RepositoryConsistent -> do-        putInfo opts $ text "The repository is consistent!"+        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 $ text "Found broken patches."+        putInfo opts "Found broken patches."         return True   bad_index <- if useIndex ? opts == O.IgnoreIndex                  then return False                  else not <$> checkIndex repository (quiet opts)-  when bad_index $ putInfo opts $ text "Bad index."+  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 $ text "Looks like we have a difference..."-  mc' <- (Just `fmap` readRecorded repository) `catch` (\(_ :: IOException) -> return Nothing)+  putInfo opts "Looks like we have a difference..."+  mc' <-+    (Just `fmap` (readRecorded repository >>= expand >>= darcsUpdateHashes))+      `catch` (\(_ :: IOException) -> return Nothing)   case mc' of     Nothing -> do-      putInfo opts $ text "cannot compute that difference, try repair"-      putInfo opts $ text "" $$ text "Inconsistent repository"+      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 -> text "Nothing"-        patch -> text "Difference: " <+> showNicely patch-      putInfo opts $ text "" $$ text "Inconsistent repository!"+        NilFL -> "Nothing"+        patch -> displayPatch patch
src/Darcs/UI/Commands/Replace.hs view
@@ -20,25 +20,24 @@     , defaultToks     ) where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B import Data.Char ( isSpace )+import Data.List.Ordered ( nubSort ) import Data.Maybe ( fromJust, isJust )-import Control.Exception ( catch, IOException )-import Control.Monad ( unless, filterM, void )+import Control.Monad ( unless, filterM, void, when ) import Darcs.Util.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree                       , makeBlobBS )-import Darcs.Util.Path( SubPath, toFilePath, AbsolutePath )+import Darcs.Util.Path( AbsolutePath ) import Darcs.UI.Flags     ( DarcsFlag-    , verbosity, useCache, dryRun, umask, diffAlgorithm, fixSubPaths )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )+    , verbosity, useCache, dryRun, umask, diffAlgorithm, pathsFromArgs )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.Repository.Diff( treeDiff )@@ -55,15 +54,17 @@     ) import Darcs.Patch.TokenReplace ( defaultToks ) import Darcs.Repository.Prefs ( FileType(TextFile) )-import Darcs.Util.Path ( floatSubPath )+import Darcs.Util.Path ( AnchoredPath, displayPath )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal )  replaceDescription :: String replaceDescription = "Substitute one word for another." -replaceHelp :: String-replaceHelp =+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" ++@@ -118,7 +119,7 @@  "`[[:alnum:]]`) are NOT supported by `--token-chars`, and will be silently\n" ++  "treated as a simple set of characters.\n" -replace :: DarcsCommand [DarcsFlag]+replace :: DarcsCommand replace = DarcsCommand     { commandProgramName = "darcs"     , commandName = "replace"@@ -137,7 +138,6 @@     , commandBasicOptions = odesc replaceBasicOpts     , commandDefaults = defaultFlags replaceOpts     , commandCheckOptions = ocheck replaceOpts-    , commandParseOptions = onormalise replaceOpts     }   where     replaceBasicOpts = O.tokens ^ O.forceReplace ^ O.repoDir@@ -151,35 +151,36 @@     else knownFileArgs fps flags args  replaceCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-replaceCmd fps opts (old : new : relfs@(_ : _)) =-  withRepoLock  (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $+replaceCmd fps opts (old : new : args@(_ : _)) =+  withRepoLock  (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $     \repository -> do-        fs <- fixSubPaths fps relfs+        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 Nothing-        files <- filterM (exists working) fs+        working <- readUnrecorded repository (O.useIndex ? opts) Nothing+        files <- filterM (exists working) paths         Sealed replacePs <- mapSeal concatFL . toFL <$>             mapM (doReplace toks working) files-        -- Note: addToPending takes care of commuting the replace patch and-        -- everything it depends on past the diff between pending and working-        addToPending repository YesUpdateWorking replacePs-        void $ applyToWorking repository (verbosity ? opts) replacePs `catch` \(e :: IOException) ->-            bug $ "Can't do replace on working!\n" ++ show e+        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   where-    exists tree file = if isJust $ findFile tree (floatSubPath file)+    exists tree file = if isJust $ findFile tree file                            then return True                            else do putStrLn $ skipmsg file                                    return False -    skipmsg f = "Skipping file '" ++ toFilePath f+    skipmsg f = "Skipping file '" ++ displayPath f                 ++ "' which isn't in the repository."      doReplace :: forall prim . (PrimPatch prim,               ApplyState prim ~ Tree) => String -> Tree IO-              -> SubPath -> IO (FreeLeft (FL prim))+              -> AnchoredPath -> IO (FreeLeft (FL prim))     doReplace toks work f = do         workReplaced <- maybeApplyToTree replacePatch work         case workReplaced of@@ -189,12 +190,13 @@             | O.forceReplace ? opts -> getForceReplace f toks work             | otherwise -> putStrLn existsMsg >> return gapNilFL       where-        existsMsg = "Skipping file '" ++ fp ++ "'\nPerhaps the working"+        -- FIXME Why do we say "perhaps"? Aren't we sure? Are there other+        -- reasons maybeApplyToTree can fail and what to do about them?+        existsMsg = "Skipping file '" ++ displayPath f ++ "'\nPerhaps the working"                     ++ " version of this file already contains '" ++ new                     ++ "'?\nUse the --force option to override."         gapNilFL = emptyGap NilFL-        fp = toFilePath f-        replacePatch = tokreplace fp toks old new+        replacePatch = tokreplace f toks old new      ftf _ = TextFile @@ -202,10 +204,9 @@     -- hunk patches to normalise all occurences of the target token (changing     -- them back to the source token) and then the replace patches from     -- oldToken -> newToken.-    getForceReplace :: PrimPatch prim => SubPath -> String -> Tree IO-                    -> IO (FreeLeft (FL prim))-    getForceReplace f toks tree = do-        let path = floatSubPath f+    getForceReplace :: PrimPatch prim+                    => AnchoredPath -> String -> Tree IO -> IO (FreeLeft (FL prim))+    getForceReplace path toks tree = do         content <- readBlob $ fromJust $ findFile tree path         let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old)                             (B.concat $ BL.toChunks content)@@ -218,7 +219,7 @@                        ++ "so that darcs replace can token-replace them"                        ++ " back into '" ++ new ++ "' again."         return . joinGap (+>+) normaliseNewTokPatch $ freeGap $-            tokreplace (toFilePath f) toks old new :>: NilFL+            tokreplace path toks old new :>: NilFL replaceCmd _ _ [_, _] = fail "You need to supply a list of files to replace in!" replaceCmd _ _ _ = fail "Usage: darcs replace <OLD> <NEW> <FILE>..."
src/Darcs/UI/Commands/Revert.hs view
@@ -18,24 +18,41 @@ {-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Revert ( revert ) where -import Prelude () import Darcs.Prelude -import Control.Exception ( catch, IOException )-import Data.List ( sort )+import Control.Monad ( void )  import Darcs.UI.Flags-    ( DarcsFlag, diffingOpts, verbosity, diffAlgorithm, isInteractive, withContext-    , dryRun, umask, useCache, fixSubPaths )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )+    ( DarcsFlag+    , diffAlgorithm+    , diffingOpts+    , dryRun+    , isInteractive+    , pathSetFromArgs+    , umask+    , useCache+    , verbosity+    , withContext+    )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdateWorking(..) )-import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putInfo )+import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , putInfo+    , putFinished+    , withStdOpts+    ) import Darcs.UI.Commands.Util ( announceFiles ) import Darcs.UI.Commands.Unrevert ( writeUnrevert ) import Darcs.UI.Completion ( modifiedFileArgs )+ import Darcs.Util.Global ( debugMessage )-import Darcs.Util.Path ( toFilePath, AbsolutePath )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Repository     ( withRepoLock     , RepoJob(..)@@ -44,14 +61,21 @@     , readRecorded     , unrecordedChanges     )-import Darcs.Patch ( invert, effectOnFilePaths, commute )+import Darcs.Patch ( invert, effectOnPaths, commuteFL )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL ) import Darcs.Patch.Split ( reversePrimSplitter )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), nullFL, (+>+) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , (:>)(..)+    , nullFL+    , (+>>+)+    , reverseFL+    ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.UI.SelectChanges     ( WhichChanges(Last)-    , selectionContextPrim-    , runSelection+    , selectionConfigPrim+    , runInvertibleSelection     ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Patch.TouchesFiles ( chooseTouching )@@ -60,8 +84,8 @@ revertDescription :: String revertDescription = "Discard unrecorded changes." -revertHelp :: String-revertHelp =+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" ++@@ -80,11 +104,11 @@     , S.matchFlags = []     , S.interactive = isInteractive True flags     , S.selectDeps = O.PromptDeps -- option not supported, use default-    , S.summary = O.NoSummary -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default     , S.withContext = withContext ? flags     } -revert :: DarcsCommand [DarcsFlag]+revert :: DarcsCommand revert = DarcsCommand     { commandProgramName = "darcs"     , commandName = "revert"@@ -100,7 +124,6 @@     , commandBasicOptions = odesc revertBasicOpts     , commandDefaults = defaultFlags revertOpts     , commandCheckOptions = ocheck revertOpts-    , commandParseOptions = onormalise revertOpts     }   where     revertBasicOpts@@ -113,33 +136,44 @@  revertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () revertCmd fps opts args =- withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do-  files <- if null args then return Nothing-    else Just . sort <$> fixSubPaths fps args+ 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 = effectOnFilePaths (invert changes) . map toFilePath <$> 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 context = selectionContextPrim-                          Last "revert" (patchSelOpts opts)-                          (Just (reversePrimSplitter (diffAlgorithm ? opts)))-                          pre_changed_files (Just recorded)-      (norevert:>p) <- runSelection changes context-      if nullFL p-       then putInfo opts $ "If you don't want to revert after all, that's fine with me!"-       else do-                 addToPending repository YesUpdateWorking $ invert p+      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 $+              "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."-                 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 directory."-                 _ <- applyToWorking repository (verbosity ? opts) (invert p) `catch` \(e :: IOException) ->-                     fail ("Unable to apply inverse patch!" ++ show e)-                 return ()-      putInfo opts "Finished reverting."+                 {- 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.++                    But the unrevert patch also needs to have recorded 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"
src/Darcs/UI/Commands/Rollback.hs view
@@ -17,59 +17,56 @@  module Darcs.UI.Commands.Rollback ( rollback ) where -import Prelude () import Darcs.Prelude -import Control.Exception ( catch, IOException )-import Control.Monad ( when )-import Data.List ( sort )+import Control.Monad ( when, void ) import Darcs.Util.Tree( Tree ) 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, fromPrims, sortCoalesceFL,+import Darcs.Patch ( IsRepoType, RepoPatch, invert, effect, sortCoalesceFL,                      canonize, PrimOf )-import Darcs.Patch.Named.Wrapped ( anonymous )-import Darcs.Patch.Set ( PatchSet(..), patchSet2FL )+import Darcs.Patch.Named ( anonymous )+import Darcs.Patch.Set ( PatchSet, Origin, emptyPatchSet, patchSet2FL ) import Darcs.Patch.Split ( reversePrimSplitter )-import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..), concatFL,-                                       nullFL, mapFL_FL )+import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), concatFL, nullFL, mapFL_FL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Repository.Flags ( AllowConflicts (..), UseIndex(..), Reorder(..),-                                ScanKnown(..), UpdateWorking(..), DryRun(NoDryRun))+                                ScanKnown(..), UpdatePending(..), DryRun(NoDryRun)) import Darcs.Repository ( Repository, withRepoLock, RepoJob(..),                           applyToWorking, readRepo,                           finalizeRepositoryChanges, tentativelyAddToPending,                           considerMergeToWorking ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, setEnvDarcsPatches,                            amInHashedRepository, putInfo )-import Darcs.UI.Commands.Unrecord ( getLastPatches )-import Darcs.UI.Commands.Util ( announceFiles )+import Darcs.UI.Commands.Util ( announceFiles, getLastPatches ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.Flags ( DarcsFlag, verbosity, umask, useCache,                         compress, externalMerge, wantGuiPause,-                        diffAlgorithm, fixSubPaths, isInteractive )+                        diffAlgorithm, isInteractive, pathSetFromArgs ) import Darcs.UI.Options-    ( (^), odesc, ocheck, onormalise+    ( (^), odesc, ocheck     , defaultFlags, parseFlags, (?)     ) import qualified Darcs.UI.Options.All as O import Darcs.UI.SelectChanges ( WhichChanges(..),-                                selectionContext, selectionContextPrim,-                                runSelection )+                                selectionConfig, selectionConfigPrim,+                                runSelection, runInvertibleSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )-import Darcs.Util.Path ( toFilePath, AbsolutePath )-import Darcs.Util.Printer ( text )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.SignalHandler ( withSignalsBlocked ) + rollbackDescription :: String rollbackDescription =  "Apply the inverse of recorded changes to the working tree." -rollbackHelp :: String-rollbackHelp = unlines+rollbackHelp :: Doc+rollbackHelp = text $ unlines     [ "Rollback is used to undo the effects of some changes from patches"     , "in the repository. The selected changes are undone in your working"     , "tree, but the repository is left unchanged. First you are offered a"@@ -88,11 +85,11 @@     , S.matchFlags = parseFlags O.matchSeveralOrLast flags     , S.interactive = isInteractive True flags     , S.selectDeps = O.PromptDeps-    , S.summary = O.NoSummary+    , S.withSummary = O.NoSummary     , S.withContext = O.NoContext     } -rollback :: DarcsCommand [DarcsFlag]+rollback :: DarcsCommand rollback = DarcsCommand     { commandProgramName = "darcs"     , commandName = "rollback"@@ -108,7 +105,6 @@     , commandBasicOptions = odesc rollbackBasicOpts     , commandDefaults = defaultFlags rollbackOpts     , commandCheckOptions = ocheck rollbackOpts-    , commandParseOptions = onormalise rollbackOpts     }   where     rollbackBasicOpts@@ -125,52 +121,49 @@  rollbackCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () rollbackCmd fps opts args = withRepoLock NoDryRun (useCache ? opts)-    YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do-        files <- if null args-                     then return Nothing-                     else Just . sort <$> fixSubPaths fps args-        when (files == Just []) $-            fail "No valid arguments were given."+    YesUpdatePending (umask ? opts) $ RepoJob $ \repository -> do+        files <- pathSetFromArgs fps args         announceFiles (verbosity ? opts) files "Rolling back changes in"         allpatches <- readRepo repository         let matchFlags = parseFlags O.matchSeveralOrLast opts         (_ :> patches) <- return $             if firstMatch matchFlags                 then getLastPatches matchFlags allpatches-                else PatchSet NilRL NilRL :> patchSet2FL allpatches-        let filesFps = map toFilePath <$> files-            patchCtx = selectionContext LastReversed "rollback" (patchSelOpts opts) Nothing filesFps+                else emptyPatchSet :> patchSet2FL allpatches         (_ :> ps) <--            runSelection patches patchCtx+            runSelection patches $+                selectionConfig LastReversed "rollback" (patchSelOpts opts) Nothing files+         exitIfNothingSelected ps "patches"         setEnvDarcsPatches ps-        let hunkContext = selectionContextPrim Last "rollback" (patchSelOpts opts)-                              (Just (reversePrimSplitter (diffAlgorithm ? opts)))-                              filesFps Nothing-            hunks = concatFL . mapFL_FL (canonize $ diffAlgorithm ? opts) . sortCoalesceFL . effect $ ps-        whatToUndo <- runSelection hunks hunkContext-        undoItNow opts repository whatToUndo+        let prim_selection_context =+              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 wT-          -> (q :> FL (PrimOf p)) wA wT -> IO ()-undoItNow opts repo (_ :> prims) = do+          => [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"-    rbp <- n2pia `fmap` anonymous (fromPrims $ invert prims)-    Sealed pw <- considerMergeToWorking repo "rollback"-                     YesAllowConflictsAndMark YesUpdateWorking+    -- 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)-                     NilFL (rbp :>: NilFL)-    tentativelyAddToPending repo YesUpdateWorking pw-    finalizeRepositoryChanges repo YesUpdateWorking-        (compress ? opts)-    _ <- applyToWorking repo (verbosity ? opts) pw-            `catch`-            \(e :: IOException) -> fail $-                "error applying rolled back patch to working directory\n"-                ++ show e+                     (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 directory"+    putInfo opts $ text "Changes rolled back in working tree"
src/Darcs/UI/Commands/Send.hs view
@@ -15,13 +15,13 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, TypeOperators, OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-}  module Darcs.UI.Commands.Send ( send ) where -import Prelude () import Darcs.Prelude +import System.Directory ( renameFile ) import System.Exit     ( exitSuccess #ifndef HAVE_MAPI@@ -29,9 +29,8 @@     , exitWith #endif     )-import System.IO.Error ( ioeGetErrorString ) import System.IO ( hClose )-import Control.Exception ( catch, IOException )+import Control.Exception ( catch, IOException, onException ) import Control.Monad ( when, unless, forM_ ) import Darcs.Util.Tree ( Tree ) import Data.List ( intercalate, isPrefixOf )@@ -46,6 +45,7 @@     , defaultRepo     , amInHashedRepository     )+import Darcs.UI.Commands.Clone ( otherHelpInheritDefault ) import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos ) import Darcs.UI.Flags     ( DarcsFlag@@ -67,7 +67,7 @@     , editDescription     ) import Darcs.UI.Options-    ( (^), odesc, ocheck, onormalise+    ( (^), odesc, ocheck     , defaultFlags, parseFlags, (?)     ) import qualified Darcs.UI.Options.All as O@@ -78,6 +78,7 @@     , repoLocation     , PatchSet     , identifyRepositoryFor+    , ReadingOrWriting(..)     , withRepository     , RepoJob(..)     , readRepo@@ -85,13 +86,17 @@     , prefsUrl ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( IsRepoType, RepoPatch, description, applyToTree, invert )+import Darcs.Patch ( IsRepoType, RepoPatch, description, applyToTree, effect, invert ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Ordered     ( FL(..), (:>)(..), (:\/:)(..),     mapFL, mapFL_FL, lengthFL, nullFL )-import Darcs.Patch.Bundle ( minContext, makeBundleN, scanContextFile, patchFilename )+import Darcs.Patch.Bundle+    ( makeBundle+    , minContext+    , readContextFile+    ) import Darcs.Repository.Prefs ( addRepoSource, getPreflist ) import Darcs.Repository.Flags ( DryRun(..) ) import Darcs.Util.External ( fetchFilePS, Cachable(..) )@@ -100,7 +105,6 @@     , sendEmailDoc     , generateEmail     , editFile-    , catchall     , getSystemEncoding     , isUTF8Locale #ifndef HAVE_MAPI@@ -117,7 +121,7 @@     ) import Darcs.UI.SelectChanges     ( WhichChanges(..)-    , selectionContext+    , selectionConfig     , runSelection     ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )@@ -127,16 +131,16 @@ import Darcs.Util.Progress ( debugMessage ) import Darcs.UI.Email ( makeEmail ) import Darcs.UI.Completion ( prefArgs )+import Darcs.UI.Commands.Util ( getUniqueDPatchName ) import Darcs.Util.Printer-    ( Doc, vsep, text, ($$), (<+>), putDoc, putDocLn-    , renderPS, vcat+    ( Doc, formatWords, vsep, text, ($$), (<+>), putDoc, putDocLn+    , quoted, renderPS, sentence, vcat     ) import Darcs.Util.English ( englishNum, Noun(..) )-import Darcs.Util.Text ( sentence, quote )+import Darcs.Util.Exception ( catchall ) import Darcs.Util.Path ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,                         getCurrentDirectory, useAbsoluteOrStd, makeAbsoluteOrStd )-import Darcs.Util.Download.HTTP ( postUrl )-import Darcs.Util.Workaround ( renameFile )+import Darcs.Util.HTTP ( postUrl ) import Darcs.Util.Global ( darcsSendMessage, darcsSendMessageFinal ) import Darcs.Util.SignalHandler ( catchInterrupt ) @@ -146,11 +150,11 @@     , S.matchFlags = parseFlags O.matchSeveral flags     , S.interactive = isInteractive True flags     , S.selectDeps = selectDeps ? flags-    , S.summary = O.summary ? flags+    , S.withSummary = O.withSummary ? flags     , S.withContext = O.NoContext     } -send :: DarcsCommand [DarcsFlag]+send :: DarcsCommand send = DarcsCommand     { commandProgramName = "darcs"     , commandName = "send"@@ -166,7 +170,6 @@     , commandBasicOptions = odesc sendBasicOpts     , commandDefaults = defaultFlags sendOpts     , commandCheckOptions = ocheck sendOpts-    , commandParseOptions = onormalise sendOpts     }   where     sendBasicOpts@@ -180,9 +183,10 @@       ^ O.output       ^ O.sign       ^ O.dryRunXml-      ^ O.summary+      ^ O.withSummary       ^ O.editDescription       ^ O.setDefault+      ^ O.inheritDefault       ^ O.repoDir       ^ O.minimize       ^ O.allowUnrelatedRepos@@ -199,10 +203,11 @@ sendCmd (_,o) opts [unfixedrepodir] =  withRepository (useCache ? opts) $ RepoJob $   \(repository :: Repository rt p wR wU wR) -> do-  context_ps <- the_context (O.sendToContext ? opts)-  case context_ps of-    Just them -> do+  case O.sendToContext ? opts of+    Just contextfile -> do         wtds <- decideOnBehavior opts (Nothing :: Maybe (Repository rt p wR wU wR))+        ref <- readRepo repository+        Sealed them <- readContextFile ref (toFilePath contextfile)         sendToThem repository opts wtds "CONTEXT" them     Nothing -> do         repodir <- fixUrl o unfixedrepodir@@ -213,15 +218,13 @@         old_default <- getPreflist "defaultrepo"         when (old_default == [repodir]) $             putInfo opts (creatingPatch repodir)-        repo <- identifyRepositoryFor repository (useCache ? opts) repodir+        repo <- identifyRepositoryFor Reading repository (useCache ? opts) repodir         them <- readRepo repo-        addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts) (setDefault False opts)+        addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts)+            (setDefault False opts) (O.inheritDefault ? opts) (isInteractive True opts)         wtds <- decideOnBehavior opts (Just repo)         sendToThem repository opts wtds repodir them-    where-        the_context Nothing = return Nothing-        the_context (Just foo) = Just `fmap` scanContextFile (toFilePath foo)-sendCmd _ _ _ = impossible+sendCmd _ _ _ = error "impossible case"  sendToThem :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)            => Repository rt p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String@@ -246,11 +249,11 @@       _     -> putVerbose opts $ selectionIs (mapFL description us')   pristine <- readRecorded repo   let direction = if changesReverse ? opts then FirstReversed else First-      context = selectionContext direction "send" (patchSelOpts opts) Nothing Nothing-  (to_be_sent :> _) <- runSelection us' context+      selection_config = selectionConfig direction "send" (patchSelOpts opts) Nothing Nothing+  (to_be_sent :> _) <- runSelection us' selection_config   printDryRunMessageAndExit "send"       (verbosity ? opts)-      (O.summary ? opts)+      (O.withSummary ? opts)       (dryRun ? opts)       O.NoXml       (isInteractive True opts)@@ -268,10 +271,10 @@                          Sealed (common' :> to_be_sent') -> prepareBundle opts common' (Left to_be_sent') )                      `catchInterrupt` genFullBundle   here   <- getCurrentDirectory-  let make_fname (tb:>:_) = patchFilename $ patchDesc tb-      make_fname _ = impossible-      fname = make_fname to_be_sent-      outname = case getOutput opts fname of+  let make_fname (tb:>:_) = getUniqueDPatchName $ patchDesc tb+      make_fname _ = error "impossible case"+  fname <- make_fname to_be_sent+  let outname = case getOutput opts fname of                     Just f  -> Just f                     Nothing | fst (O.sendmail ? opts) -> Nothing                             | not $ null [ p | Post p <- wtds] -> Nothing@@ -290,11 +293,11 @@   unsig_bundle <-      case e of        (Right (pristine, us' :\/: to_be_sent)) -> do-         pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine-         makeBundleN (Just pristine')+         pristine' <- applyToTree (invert $ effect us') pristine+         makeBundle (Just pristine')                      (unsafeCoerceP common)                      (mapFL_FL hopefully to_be_sent)-       Left to_be_sent -> makeBundleN Nothing+       Left to_be_sent -> makeBundle Nothing                                       (unsafeCoerceP common)                                       (mapFL_FL hopefully to_be_sent)   signString (parseFlags O.sign opts) unsig_bundle@@ -354,14 +357,14 @@                         (Just fname)                contentAndBundle = Just (mailcontents, bundle) -               sendmail = do+               sendmail =+                (do                  sm_cmd <- getSendmailCmd opts                  let to = generateEmailToString thetargets                  sendEmailDoc from to thesubject (getCc opts)-                               sm_cmd contentAndBundle body >>-                  putInfo opts (success to (getCc opts))-                 `catch` \e -> do warnMailBody-                                  fail $ ioeGetErrorString e+                               sm_cmd contentAndBundle body+                 putInfo opts (success to (getCc opts)))+                 `onException` warnMailBody             when (null [ p | Post p <- thetargets]) sendmail            nbody <- withOpenTemp $ \ (fh,fn) -> do@@ -372,7 +375,7 @@            forM_ [ p | Post p <- thetargets]              (\url -> do                 putInfo opts $ postingPatch url-                postUrl url (BC.unpack nbody) "message/rfc822")+                postUrl url nbody "message/rfc822")              `catch` (\(_ :: IOException) -> sendmail)            cleanup opts mailfile @@ -448,7 +451,7 @@     f url | "http:" `isPrefixOf` url = Post url     f em = SendMail em -getDescription :: (RepoPatch p, ApplyState p ~ Tree)+getDescription :: RepoPatch p                => [DarcsFlag] -> String -> FL (PatchInfoAnd rt p) wX wY -> IO (Doc, Maybe String, Maybe String) getDescription opts their_name patches =     case get_filename of@@ -495,50 +498,51 @@ cmdDescription =     "Prepare a bundle of patches to be applied to some target repository." -cmdHelp :: String-cmdHelp = unlines-    [ "Send is used to prepare a bundle of patches that can be applied to a target"+cmdHelp :: Doc+cmdHelp = vsep $+  map formatWords+  [ [ "Send is used to prepare a bundle of patches that can be applied to a target"     , "repository.  Send accepts the URL of the repository as an argument.  When"     , "called without an argument, send will use the most recent repository that"     , "was either pushed to, pulled from or sent to.  By default, the patch bundle"     , "is saved to a file, although you may directly send it by mail."-    , ""-    , "The `--output`, `--output-auto-name`, and `--to` flags determine"+    ]+  , [ "The `--output`, `--output-auto-name`, and `--to` flags determine"     , "what darcs does with the patch bundle after creating it.  If you provide an"     , "`--output` argument, the patch bundle is saved to that file.  If you"     , "specify `--output-auto-name`, the patch bundle is saved to a file with an"     , "automatically generated name.  If you give one or more `--to` arguments,"     , "the bundle of patches is sent to those locations. The locations may either"     , "be email addresses or urls that the patch should be submitted to via HTTP."-    , ""-    , "If you provide the `--mail` flag, darcs will look at the contents"+    ]+  , [ "If you provide the `--mail` flag, darcs will look at the contents"     , "of the `_darcs/prefs/email` file in the target repository (if it exists),"     , "and send the patch by email to that address.  In this case, you may use"     , "the `--cc` option to specify additional recipients without overriding the"     , "default repository email address."-    , ""-    , "If `_darcs/prefs/post` exists in the target repository, darcs will"+    ]+  , [ "If `_darcs/prefs/post` exists in the target repository, darcs will"     , "upload to the URL contained in that file, which may either be a"     , "`mailto:` URL, or an `http://` URL.  In the latter case, the"     , "patch is posted to that URL."-    , ""-    , "If there is no email address associated with the repository, darcs will"+    ]+  , [ "If there is no email address associated with the repository, darcs will"     , "prompt you for an email address."-    , ""-    , "Use the `--subject` flag to set the subject of the e-mail to be sent."+    ]+  , [ "Use the `--subject` flag to set the subject of the e-mail to be sent."     , "If you don't provide a subject on the command line, darcs will make one up"     , "based on names of the patches in the patch bundle."-    , ""-    , "Use the `--in-reply-to` flag to set the In-Reply-To and References headers"+    ]+  , [ "Use the `--in-reply-to` flag to set the In-Reply-To and References headers"     , "of the e-mail to be sent. By default no additional headers are included so"     , "e-mail will not be treated as reply by mail readers."-    , ""-    , "If you want to include a description or explanation along with the bundle"+    ]+  , [ "If you want to include a description or explanation along with the bundle"     , "of patches, you need to specify the `--edit-description` flag, which"     , "will cause darcs to open up an editor with which you can compose a message"     , "to go along with your patches."-    , ""-    , "If you want to use a command different from the default one for sending"+    ]+  , [ "If you want to use a command different from the default one for sending"     , "email, you need to specify a command line with the `--sendmail-command`"     , "option. The command line can contain some format specifiers which are"     , "replaced by the actual values. Accepted format specifiers are `%s` for"@@ -548,39 +552,58 @@     , "Additionally you can add `%<` to the end of the command line if the command"     , "expects the complete email message on standard input. E.g. the command lines"     , "for evolution and msmtp look like this:"-    , ""-    , "    evolution \"mailto:%T?subject=%S&attach=%A&cc=%C&body=%B\""+    ]+  ]+  +++  -- TODO autoformatting for indented paragraphs+  [ vcat+    [ "    evolution \"mailto:%T?subject=%S&attach=%A&cc=%C&body=%B\""     , "    msmtp -t %<"-    , ""-    , "Do not confuse the `--author` options with the return address"+    ]+  ]+  ++ map formatWords+  [ [ "Do not confuse the `--author` options with the return address"     , "that `darcs send` will set for your patch bundle."-    , ""-    , "For example, if you have two email addresses A and B:"-    , ""-    , "* If you use `--author A` but your machine is configured to send mail from"-    , "  address B by default, then the return address on your message will be B."-    , "* If you use `--from A` and your mail client supports setting the"-    , "  From: address arbitrarily (some non-Unix-like mail clients, especially,"-    , "  may not support this), then the return address will be A; if it does"-    , "  not support this, then the return address will be B."-    , "* If you supply neither `--from` nor `--author` then the return"-    , "  address will be B."-    , ""-    , "In addition, unless you specify the sendmail command with"+    ]+  , [ "For example, if you have two email addresses A and B:"+    ]+  ]+  +++  -- TODO autoformatting for bullet lists+  [ vcat+    [ "  * If you use `--author A` but your machine is configured to send"+    , "    mail from address B by default, then the return address on your"+    , "    message will be B."+    , "  * If you use `--from A` and your mail client supports setting the"+    , "    From: address arbitrarily (some non-Unix-like mail clients,"+    , "    especially, may not support this), then the return address will"+    , "    be A; if it does not support this, then the return address will"+    , "    be B."+    , "  * If you supply neither `--from` nor `--author` then the return"+    , "    address will be B."+    ]+  ]+  +++  [ formatWords+    [ "In addition, unless you specify the sendmail command with"     , "`--sendmail-command`, darcs sends email using the default email"     , "command on your computer. This default command is determined by the"     , "`configure` script. Thus, on some non-Unix-like OSes,"     , "`--from` is likely to not work at all."     ]+  , otherHelpInheritDefault+  ]  cannotSendToSelf :: String cannotSendToSelf = "Can't send to current repository! Did you mean send --context?"  creatingPatch :: String -> Doc-creatingPatch repodir = "Creating patch to" <+> text (quote repodir) <> "..."+creatingPatch repodir = "Creating patch to" <+> quoted repodir <> "..." +#ifndef HAVE_MAPI noWorkingSendmail :: Doc noWorkingSendmail = "No working sendmail instance on your machine!"+#endif  nothingSendable :: Doc nothingSendable = "No recorded local changes to send!"@@ -592,7 +615,7 @@ selectionIsNull = text "You don't want to send any patches, and that's fine with me!"  emailBackedUp :: String -> Doc-emailBackedUp mf = sentence $ "Email body left in" <+> text mf+emailBackedUp mf = sentence $ "Email body left in" <+> text mf <> "."  promptCharSetWarning :: String -> String promptCharSetWarning msg = "Warning: " ++ msg ++ "  Send anyway?"
src/Darcs/UI/Commands/SetPref.hs view
@@ -17,7 +17,6 @@  module Darcs.UI.Commands.SetPref ( setpref ) where -import Prelude () import Darcs.Prelude  import System.Exit ( exitWith, ExitCode(..) )@@ -27,15 +26,16 @@ import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag, useCache, dryRun, umask) import Darcs.UI.Options-    ( odesc, ocheck, onormalise, defaultFlags, (?) )+    ( odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Repository.Flags ( UpdateWorking (..) )+import Darcs.Repository.Flags ( UpdatePending (..) ) import Darcs.Repository ( addToPending, withRepoLock, RepoJob(..) ) import Darcs.Patch ( changepref ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) import Darcs.Repository.Prefs ( getPrefval, changePrefval ) import Darcs.Util.English ( orClauses ) import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, text )  -- | A list of all valid preferences for @_darcs/prefs/prefs@. validPrefData :: [(String, String)] -- ^ (name, one line description)@@ -52,8 +52,8 @@ setprefDescription =     "Set a preference (" ++ orClauses validPrefs ++ ")." -setprefHelp :: String-setprefHelp =+setprefHelp :: Doc+setprefHelp = text $  "When working on project with multiple repositories and contributors,\n" ++  "it is sometimes desirable for a preference to be set consistently\n" ++  "project-wide.  This is achieved by treating a preference set with\n" ++@@ -75,7 +75,7 @@  "the repository will always take precedence.  This is considered a\n" ++  "low-priority bug, because preferences are seldom set.\n" -setpref :: DarcsCommand [DarcsFlag]+setpref :: DarcsCommand setpref = DarcsCommand     { commandProgramName = "darcs"     , commandName = "setpref"@@ -91,7 +91,6 @@     , commandBasicOptions = odesc setprefBasicOpts     , commandDefaults = defaultFlags setprefOpts     , commandCheckOptions = ocheck setprefOpts-    , commandParseOptions = onormalise setprefOpts     }   where     setprefBasicOpts = O.repoDir@@ -102,7 +101,7 @@  setprefCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () setprefCmd _ opts [pref,val] =- withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do+ withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $ \repository -> do   when (' ' `elem` pref) $ do     putStrLn $ "'"++pref++                "' is not a valid preference name: no spaces allowed!"@@ -118,6 +117,6 @@     exitWith $ ExitFailure 1   changePrefval pref old val   putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'"-  addToPending repository YesUpdateWorking (changepref pref old val :>: NilFL)-setprefCmd _ _ _ = impossible+  addToPending repository (O.useIndex ? opts) (changepref pref old val :>: NilFL)+setprefCmd _ _ _ = error "impossible case"
src/Darcs/UI/Commands/Show.hs view
@@ -17,12 +17,11 @@  module Darcs.UI.Commands.Show ( showCommand ) where -import Prelude () import Darcs.Prelude  import Darcs.UI.Commands ( DarcsCommand(..)                          , normalCommand-                         , commandAlias, amInRepository+                         , amInRepository                          ) import Darcs.UI.Commands.ShowAuthors ( showAuthors ) import Darcs.UI.Commands.ShowContents ( showContents )@@ -30,19 +29,20 @@ import Darcs.UI.Commands.ShowFiles ( showFiles ) import Darcs.UI.Commands.ShowTags ( showTags ) import Darcs.UI.Commands.ShowRepo ( showRepo )-import Darcs.UI.Commands.ShowIndex ( showIndex, showPristineCmd )+import Darcs.UI.Commands.ShowIndex ( showIndex, showPristine ) import Darcs.UI.Commands.ShowPatchIndex ( showPatchIndex )-import Darcs.UI.Flags ( DarcsFlag )+import Darcs.Util.Printer ( Doc, formatWords )  showDescription :: String showDescription = "Show information about the given repository." -showHelp :: String-showHelp =- "Use the `--help` option with the subcommands to obtain help for\n"++- "subcommands (for example, `darcs show files --help`).\n"+showHelp :: Doc+showHelp = formatWords+  [ "Display various information about a repository. See description of the"+  , "subcommands for details."+  ] -showCommand :: DarcsCommand [DarcsFlag]+showCommand :: DarcsCommand showCommand = SuperCommand     { commandProgramName = "darcs"     , commandName = "show"@@ -60,17 +60,4 @@       , normalCommand showTags       , normalCommand showPatchIndex ]     }---- unfortunately, aliases for sub-commands have to live in their parent command--- to avoid an import cycle-showPristine :: DarcsCommand [DarcsFlag]-showPristine = (commandAlias "pristine" (Just showCommand) showIndex) {-  commandCommand = showPristineCmd,-  commandDescription = "Dump contents of pristine cache.",-  commandHelp =-      "The `darcs show pristine` command lists all version-controlled files " ++-      "and directories along with the hashes of their pristine copies. " ++-      "For files, the fields correspond to file size, sha256 of the pristine " ++-      "file content and the filename." }-
src/Darcs/UI/Commands/ShowAuthors.hs view
@@ -19,11 +19,6 @@     ( showAuthors, Spelling, compiledAuthorSpellings, canonizeAuthor, rankAuthors     ) where -import Prelude ()-import Darcs.Prelude--import Prelude hiding ( (^) )- import Control.Arrow ( (&&&), (***) ) import Data.Char ( toLower, isSpace ) import Data.Function ( on )@@ -35,8 +30,10 @@ import Text.ParserCombinators.Parsec.Error import Text.Regex ( Regex, mkRegexWithOpts, matchRegex ) +import Darcs.Prelude+ import Darcs.UI.Flags ( DarcsFlag, useCache, verbose )-import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putWarning, amInRepository ) import Darcs.UI.Completion ( noArgs )@@ -47,7 +44,7 @@ import Darcs.Repository ( readRepo, withRepository, RepoJob(..) ) import Darcs.Patch.Witnesses.Ordered ( mapRL ) import Darcs.Util.Lock ( readTextFile )-import Darcs.Util.Printer ( text )+import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Path ( AbsolutePath )  data Spelling = Spelling String String [Regex] -- name, email, regexps@@ -56,8 +53,8 @@ showAuthorsDescription :: String showAuthorsDescription = "List authors by patch count." -showAuthorsHelp :: String-showAuthorsHelp =+showAuthorsHelp :: Doc+showAuthorsHelp = text $  "The `darcs show authors` command lists the authors of the current\n" ++  "repository, sorted by the number of patches contributed.  With the\n" ++  "`--verbose` option, this command simply lists the author of each patch\n" ++@@ -96,7 +93,7 @@  "    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n" ++  "    Chuck Jones\\, Jr. <chuck@pobox.com>, cj\\+user@example.com\n" -showAuthors :: DarcsCommand [DarcsFlag]+showAuthors :: DarcsCommand showAuthors = DarcsCommand     { commandProgramName = "darcs"     , commandName = "authors"@@ -112,7 +109,6 @@     , commandBasicOptions = odesc showAuthorsBasicOpts     , commandDefaults = defaultFlags showAuthorsOpts     , commandCheckOptions = ocheck showAuthorsOpts-    , commandParseOptions = onormalise showAuthorsOpts     }   where     showAuthorsBasicOpts = O.repoDir
src/Darcs/UI/Commands/ShowContents.hs view
@@ -17,40 +17,38 @@  module Darcs.UI.Commands.ShowContents ( showContents ) where -import Prelude ()-import Darcs.Prelude--import Prelude hiding ( (^) )--import Control.Monad ( filterM, forM_, forM )+import Control.Monad ( filterM, forM_, forM, when ) import System.IO ( stdout )  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import Darcs.Prelude+ import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) import Darcs.UI.Completion ( noArgs )-import Darcs.UI.Flags ( DarcsFlag, useCache, fixSubPaths )-import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )+import Darcs.UI.Flags ( DarcsFlag, useCache, pathsFromArgs )+import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Patch.Match ( haveNonrangeMatch )-import Darcs.Repository ( withRepository, RepoJob(..), readRecorded, repoPatchType )+import Darcs.Patch.Match ( patchSetMatch )+import Darcs.Repository ( withRepository, RepoJob(..), readRecorded ) import Darcs.Util.Lock ( withDelayedDir )-import Darcs.Repository.Match ( getNonrangeMatch )+import Darcs.Repository.Match ( getRecordedUpToMatch ) import Darcs.Util.Tree.Plain( readPlainTree ) import qualified Darcs.Util.Tree.Monad as TM-import Darcs.Util.Path( floatPath, sp2fn, toFilePath, AbsolutePath )+import Darcs.Util.Path( AbsolutePath )+import Darcs.Util.Printer ( Doc, text )  showContentsDescription :: String showContentsDescription = "Outputs a specific version of a file." -showContentsHelp :: String-showContentsHelp =+showContentsHelp :: Doc+showContentsHelp = text $   "Show contents can be used to display an earlier version of some file(s).\n"++   "If you give show contents no version arguments, it displays the recorded\n"++   "version of the file(s).\n" -showContents :: DarcsCommand [DarcsFlag]+showContents :: DarcsCommand showContents = DarcsCommand     { commandProgramName = "darcs"     , commandName = "contents"@@ -66,7 +64,6 @@     , commandBasicOptions = odesc showContentsBasicOpts     , commandDefaults = defaultFlags showContentsOpts     , commandCheckOptions = ocheck showContentsOpts-    , commandParseOptions = onormalise showContentsOpts     }   where     showContentsBasicOpts = O.matchUpToOne ^ O.repoDir@@ -75,25 +72,28 @@ showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showContentsCmd _ _ [] = fail "show contents needs at least one argument." showContentsCmd fps opts args = do-  floatedPaths <- map (floatPath . toFilePath . sp2fn) `fmap` fixSubPaths fps args+  paths <- pathsFromArgs fps args+  when (null paths) $ fail "No valid repository paths were given."   let matchFlags = parseFlags O.matchUpToOne opts   withRepository (useCache ? opts) $ RepoJob $ \repository -> do     let readContents = do-          okpaths <- filterM TM.fileExists floatedPaths+          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 <- if haveNonrangeMatch (repoPatchType repository) matchFlags then+    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.-                 getNonrangeMatch repository matchFlags+                 getRecordedUpToMatch repository psm                  readPlainTree "." >>= execReadContents-             else do+        Nothing ->                -- we can use the existing pristine tree because we don't modify                -- anything in this case                readRecorded repository >>= execReadContents
src/Darcs/UI/Commands/ShowDependencies.hs view
@@ -1,44 +1,51 @@-module Darcs.UI.Commands.ShowDependencies-    ( showDeps )-where+{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.ShowDependencies ( showDeps ) where -import Control.Arrow ( (***) )+import Darcs.Prelude -import Data.Maybe( fromMaybe )-import Data.GraphViz-import Data.GraphViz.Algorithms ( transitiveReduction )-import Data.GraphViz.Attributes.Complete-import Data.Graph.Inductive.Graph ( Graph(..), mkGraph, LNode, UEdge )-import Data.Graph.Inductive.PatriciaTree ( Gr )+import qualified Data.Map.Strict as M+import Data.Maybe( fromJust, fromMaybe )+import qualified Data.Set as S -import qualified Data.Text.Lazy as T+import Darcs.Repository ( RepoJob(..), readRepo, withRepositoryLocation ) -import Darcs.Repository ( readRepo, withRepositoryLocation, RepoJob(..) )-import Darcs.UI.Flags ( DarcsFlag(..), getRepourl-                      , useCache )-import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Flags ( DarcsFlag, getRepourl, useCache )+import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts )-import Darcs.UI.Commands.Unrecord ( matchingHead )+import Darcs.UI.Commands.Util ( matchRange ) import Darcs.UI.Completion ( noArgs ) -import Darcs.Util.Text ( formatText )+import Darcs.Util.Hash ( sha1short, showAsHex ) import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer+    ( Doc+    , (<+>)+    , formatText+    , hsep+    , prefixLines+    , putDocLn+    , quoted+    , renderString+    , text+    , vcat+    ) -import Darcs.Patch.Info ( piName )-import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Patch.Named ( Named (..), patch2patchinfo )-import Darcs.Patch.Named.Wrapped ( removeInternalFL )-import Darcs.Patch.Match ( firstMatch, matchFirstPatchset )-import Darcs.Patch.Choices ( unLabel, LabelledPatch, label, getLabelInt )-import Darcs.Patch.Depends ( SPatchAndDeps, getDeps, findCommonWithThem )-import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), seal2, Sealed(..) )-import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:>)(..), foldlFL, mapFL_FL )+import Darcs.Patch.Commute ( Commute, commuteFL )+import Darcs.Patch.Ident ( PatchId, Ident(..) )+import Darcs.Patch.Info ( PatchInfo, piName, makePatchname )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..)+    , FL(..)+    , RL(..)+    , reverseFL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )  showDepsDescription :: String showDepsDescription = "Generate the graph of dependencies." -showDepsHelp :: String+showDepsHelp :: Doc showDepsHelp = formatText 80         [ unwords [ "The `darcs show dependencies` command is used to create"                   , "a graph of the dependencies between patches of the"@@ -50,7 +57,7 @@         , "darcs show dependencies | dot -Tpdf -o FILE.pdf"         ] -showDeps :: DarcsCommand [DarcsFlag]+showDeps :: DarcsCommand showDeps = DarcsCommand     { commandProgramName = "darcs"     , commandName = "dependencies"@@ -66,59 +73,65 @@     , commandBasicOptions = odesc showDepsBasicOpts     , commandDefaults = defaultFlags showDepsOpts     , commandCheckOptions = ocheck showDepsOpts-    , commandParseOptions = onormalise showDepsOpts     }   where-    showDepsBasicOpts = O.matchSeveralOrLast+    showDepsBasicOpts = O.matchRange     showDepsOpts = showDepsBasicOpts `withStdOpts` oid -type DepsGraph = Gr String ()- depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () depsCmd _ opts _ = do     let repodir = fromMaybe "." (getRepourl opts)     withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> do-        Sealed2 rFl <- readRepo repo >>= pruneRepo-        let deps   = getDeps-                        (removeInternalFL . mapFL_FL hopefully $ rFl)-                        rFl-            dGraph = transitiveReduction $-                                graphToDot nodeLabeledParams $ makeGraph deps-        putStrLn $ T.unpack $ printDotGraph dGraph-    where-        nodeLabeledParams :: GraphvizParams n String el () String-        nodeLabeledParams =-                defaultParams { globalAttributes =-                                    [GraphAttrs {attrs = [RankDir FromLeft]}]-                              , fmtNode = \(_,l) ->-                                    [ toLabel l-                                    , ImageScale UniformScale-                                    ]-                              }-        pruneRepo r = let matchFlags = O.matchSeveralOrLast ? opts in-                      if firstMatch matchFlags-                         then case getLastPatches matchFlags r of-                                Sealed2 ps -> return $ seal2 ps-                         else case matchingHead matchFlags r of-                                _ :> patches -> return $ seal2 patches-        getLastPatches matchFlags ps =-                case matchFirstPatchset matchFlags ps of-                    Sealed p1s -> case findCommonWithThem ps p1s of-                                    _ :> ps' -> seal2 ps'+        Sealed2 rFl <- matchRange (O.matchRange ? opts) <$> readRepo repo+        putDocLn $ renderDepsGraphAsDot $ depsGraph $ reverseFL rFl -makeGraph :: [SPatchAndDeps p] -> DepsGraph-makeGraph = uncurry mkGraph . (id *** concat) . unzip . map mkNodeWithEdges-    where-    mkNodeWithEdges :: SPatchAndDeps p -> (LNode String, [UEdge])-    mkNodeWithEdges (Sealed2 father, Sealed2 childs) = (mkLNode father,mkUEdges)-        where-            mkNode :: LabelledPatch (Named p) wX wY -> Int-            mkNode = getLabelInt . label-            mkUEdge :: [UEdge] -> LabelledPatch (Named p) wX wY -> [UEdge]-            mkUEdge les child = (mkNode father, mkNode child,()) : les-            mkLabel :: LabelledPatch (Named p) wX wY -> String-            mkLabel = formatText 20 . (:[]) . piName . patch2patchinfo . unLabel-            mkLNode :: LabelledPatch (Named p) wX wY -> LNode String-            mkLNode p = (mkNode p, mkLabel p)-            mkUEdges :: [UEdge]-            mkUEdges = foldlFL mkUEdge [] childs+-- A 'M.Map' from 'PatchId's to 'Deps'.+type DepsGraph p = M.Map (PatchId p) (Deps p)++-- A pair of (direct, indirect) dependencies.+type Deps p = (S.Set (PatchId p), S.Set (PatchId p))++-- Determine the 'DepsGraph' of an 'RL' of patches.+depsGraph :: forall p wX wY. (Commute p, Ident p) => RL p wX wY -> DepsGraph p+depsGraph NilRL = M.empty+depsGraph (ps :<: p) =+  M.insert i (foldDeps ps (p :>: NilFL) NilFL (S.empty, S.empty)) m+  where+    m = depsGraph ps+    i = ident p+    allDeps j = uncurry S.union . fromJust . M.lookup j+    addDeps j = S.insert j . S.union (allDeps j m)+    foldDeps :: RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p+    foldDeps NilRL _ _ acc = acc+    foldDeps (qs :<: q) p_and_deps non_deps acc@(direct, indirect)+      -- no need to commute or adjust acc if we already know we depend+      -- (indirectly) on q; note that (ident q `S.member` direct) is+      -- impossible+      | j `S.member` indirect = foldDeps qs (q :>: p_and_deps) non_deps acc+      -- if q commutes past p_and_deps then we don't depend on it+      | Just (p_and_deps' :> q') <- commuteFL (q :> p_and_deps) =+        foldDeps qs p_and_deps' (q' :>: non_deps) acc+      -- we have a new dependency which must be a direct one+      | otherwise =+        foldDeps qs (q :>: p_and_deps) non_deps (addDeps j direct, indirect)+      where+        j = ident q++renderDepsGraphAsDot :: M.Map PatchInfo (S.Set PatchInfo, S.Set PatchInfo) -> Doc+renderDepsGraphAsDot g = vcat ["digraph {", indent body, "}"]+  where+    indent = prefixLines ("  ")+    body = vcat+      [ "graph [rankdir=LR];"+      , "node [imagescale=true];"+      , vcat (map showNode (map fst pairs))+      , vcat (map showEdges pairs)+      ]+    pairs = M.toList $ M.map fst g+    showEdges (i, ds)+      | S.null ds = mempty+      | otherwise =+          hsep [showID i, "->", "{" <> hsep (map showID (S.toList ds)) <> "}"]+    showNode i = showID i <+> "[label=" <> showLabel i <> "]"+    showID = quoted . showAsHex . sha1short . makePatchname+    showLabel i = text $ show $ renderString $ formatText 20 [piName i]
src/Darcs/UI/Commands/ShowFiles.hs view
@@ -17,36 +17,42 @@  module Darcs.UI.Commands.ShowFiles ( showFiles ) where -import Prelude () import Darcs.Prelude+import Data.Maybe ( fromJust, isJust ) -import Darcs.UI.Flags ( DarcsFlag, useCache )-import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise-                        , defaultFlags, parseFlags, (?) )-import qualified Darcs.UI.Options.All as O-import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )-import Darcs.UI.Completion ( knownFileArgs )-import Darcs.Repository ( Repository, withRepository,-                          RepoJob(..), repoPatchType ) import Darcs.Patch ( IsRepoType, RepoPatch )-import Darcs.Patch.Apply( ApplyState )+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.Util.Tree( Tree, TreeItem(..), list, expand )-import Darcs.Util.Tree.Plain( readPlainTree )-import Darcs.Util.Path( anchorPath, AbsolutePath )-import System.FilePath ( splitDirectories )--import Data.List( isPrefixOf )--import Darcs.Patch.Match ( haveNonrangeExplicitMatch )-import Darcs.Repository.Match ( getNonrangeMatch )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInRepository+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.Flags ( DarcsFlag, pathsFromArgs, useCache )+import Darcs.UI.Options ( defaultFlags, ocheck, odesc, oid, parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O import Darcs.Util.Lock ( withDelayedDir )+import Darcs.Util.Path+    ( AbsolutePath+    , AnchoredPath+    , anchoredRoot+    , displayPath+    , isPrefix+    )+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." -showFilesHelp :: String-showFilesHelp =+showFilesHelp :: Doc+showFilesHelp = text $  "The `darcs show files` command lists those files and directories in\n" ++  "the working tree that are under version control.  This command is\n" ++  "primarily for scripting purposes; end users will probably want `darcs\n" ++@@ -69,7 +75,7 @@  "\n" ++  "    darcs show files -0 | xargs -0 ls -ldS\n" -showFiles :: DarcsCommand [DarcsFlag]+showFiles :: DarcsCommand showFiles = DarcsCommand     { commandProgramName = "darcs"     , commandName = "files"@@ -77,7 +83,7 @@     , commandDescription = showFilesDescription     , commandExtraArgs = -1     , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]-    , commandCommand = manifestCmd toListFiles+    , commandCommand = manifestCmd     , commandPrereq = amInRepository     , commandCompleteArgs = knownFileArgs     , commandArgdefaults = nodefaults@@ -85,7 +91,6 @@     , commandBasicOptions = odesc showFilesBasicOpts     , commandDefaults = defaultFlags showFilesOpts     , commandCheckOptions = ocheck showFilesOpts-    , commandParseOptions = onormalise showFilesOpts     }   where     showFilesBasicOpts@@ -97,52 +102,46 @@       ^ O.repoDir     showFilesOpts = showFilesBasicOpts `withStdOpts` oid -toListFiles :: [DarcsFlag] -> Tree m -> [FilePath]-toListFiles    opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories opts)--filesDirs :: Bool -> Bool -> Tree m -> [FilePath]-filesDirs False False _ = []-filesDirs False True  t = "." : [ anchorPath "." p | (p, SubTree _) <- list t ]-filesDirs True  False t = [ anchorPath "." p | (p, File _) <- list t ]-filesDirs True  True  t = "." : map (anchorPath "." . fst) (list t)--manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath])-            -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()-manifestCmd to_list _ opts argList =-    mapM_ output =<< manifestHelper to_list opts argList+manifestCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+manifestCmd fps opts args = do+    paths <- pathsFromArgs fps args+    mapM_ output =<< manifestHelper opts paths   where     output_null name = do { putStr name ; putChar '\0' }     output = if parseFlags O.nullFlag opts then output_null else putStrLn -manifestHelper :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO [FilePath]-manifestHelper to_list opts argList = do-    list' <- to_list opts `fmap` withRepository (useCache ? opts) (RepoJob slurp)-    case argList of-        []       -> return list'-        prefixes -> return (onlysubdirs prefixes list')-  where-    matchFlags = parseFlags O.matchUpToOne opts-    slurp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-          => Repository rt p wR wU wR -> IO (Tree IO)-    slurp r = do-      let fUpto = haveNonrangeExplicitMatch (repoPatchType r) matchFlags+manifestHelper :: [DarcsFlag] -> [AnchoredPath] -> IO [FilePath]+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 matchFlags r-        (True, True)  -> error "can't mix match and pending flags"+        (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-    isParentDir a' b' =-      let a = splitDirectories a'-          b = splitDirectories b'-      in (a `isPrefixOf` b) || (("." : a) `isPrefixOf` b)-    onlysubdirs dirs = filter (\p -> any (`isParentDir` p) dirs)+  where+    matchFlags = parseFlags O.matchUpToOne opts +    onlysubdirs [] = id+    onlysubdirs dirs = filter (\p -> any (`isPrefix` p) dirs)++    listFilesOrDirs :: Tree IO -> [AnchoredPath]+    listFilesOrDirs =+        filesDirs (parseFlags O.files opts) (parseFlags O.directories opts)+      where+        filesDirs False False _ = []+        filesDirs False True t = anchoredRoot : [p | (p, SubTree _) <- list t]+        filesDirs True False t = [p | (p, File _) <- list t]+        filesDirs True True t = anchoredRoot : map fst (list t)+ slurpUpto :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)-          => [O.MatchFlag] -> Repository rt p wR wU wR -> IO (Tree IO)-slurpUpto matchFlags r = withDelayedDir "show.files" $ \_ -> do-  getNonrangeMatch r matchFlags+          => 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
@@ -22,17 +22,16 @@  module Darcs.UI.Commands.ShowIndex     ( showIndex-    , showPristineCmd -- for alias+    , showPristine     ) where -import Prelude () 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, onormalise, defaultFlags, (?) )+import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository ( withRepository, RepoJob(..), readIndex ) import Darcs.Repository.State ( readRecorded )@@ -41,6 +40,7 @@ import Darcs.Util.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) ) import Darcs.Util.Index( updateIndex, listFileIDs ) import Darcs.Util.Path( anchorPath, AbsolutePath, floatPath )+import Darcs.Util.Printer ( Doc, text )  import System.Posix.Types ( FileID ) @@ -48,16 +48,19 @@ import Data.Maybe ( fromJust ) import qualified Data.Map as M ( Map, lookup, fromList ) -showIndex :: DarcsCommand [DarcsFlag]+showIndexHelp :: Doc+showIndexHelp = text $+  "The `darcs show index` command lists all version-controlled files and " +++  "directories along with their hashes as stored in `_darcs/index`. " +++  "For files, the fields correspond to file size, sha256 of the current " +++  "file content and the filename."++showIndex :: DarcsCommand showIndex = DarcsCommand     { commandProgramName = "darcs"     , commandName = "index"     , commandDescription = "Dump contents of working tree index."-    , commandHelp =-        "The `darcs show index` command lists all version-controlled files and " ++-        "directories along with their hashes as stored in `_darcs/index`. " ++-        "For files, the fields correspond to file size, sha256 of the current " ++-        "file content and the filename."+    , commandHelp = showIndexHelp     , commandExtraArgs = 0     , commandExtraArgHelp = []     , commandCommand = showIndexCmd@@ -68,7 +71,6 @@     , commandBasicOptions = odesc showIndexBasicOpts     , commandDefaults = defaultFlags showIndexOpts     , commandCheckOptions = ocheck showIndexOpts-    , commandParseOptions = onormalise showIndexOpts     }   where     showIndexBasicOpts = O.nullFlag ^ O.repoDir@@ -104,3 +106,17 @@ showPristineCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $   readRecorded >=> dump opts Nothing +showPristineHelp :: Doc+showPristineHelp = text $+  "The `darcs show pristine` command lists all version-controlled files " +++  "and directories along with the hashes of their pristine copies. " +++  "For files, the fields correspond to file size, sha256 of the pristine " +++  "file content and the filename."++showPristine :: DarcsCommand+showPristine = showIndex+    { commandName = "pristine"+    , commandDescription = "Dump contents of pristine cache."+    , commandHelp = showPristineHelp+    , commandCommand = showPristineCmd+    }
src/Darcs/UI/Commands/ShowPatchIndex.hs view
@@ -1,29 +1,31 @@ module Darcs.UI.Commands.ShowPatchIndex ( showPatchIndex ) where -import Prelude () import Darcs.Prelude  import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, useCache, verbose )-import Prelude hiding ( (^) ) import Darcs.UI.Options-    ( (^), oid, odesc, ocheck, onormalise, defaultFlags, (?) )+    ( (^), oid, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Util.Path ( AbsolutePath ) import Darcs.Repository ( withRepository, RepoJob(..), repoLocation ) import Darcs.Repository.PatchIndex     ( dumpPatchIndex, piTest, doesPatchIndexExist, isPatchIndexInSync)+import Darcs.Util.Printer ( Doc, text ) -showPatchIndex :: DarcsCommand [DarcsFlag]+help :: Doc+help = text $+  "When given the `--verbose` flag, the command dumps the complete content\n" +++  "of the patch index and checks its integrity."++showPatchIndex :: DarcsCommand showPatchIndex = DarcsCommand     { commandProgramName = "darcs"     , commandName = "patch-index"     , commandDescription = "Check integrity of patch index"-    , commandHelp =-        "When given the `--verbose` flag, the command dumps the complete content\n" ++-        "of the patch index and checks its integrity."+    , commandHelp = help     , commandExtraArgs = 0     , commandExtraArgHelp = []     , commandCommand = showPatchIndexCmd@@ -34,7 +36,6 @@     , commandBasicOptions = odesc showPatchIndexBasicOpts     , commandDefaults = defaultFlags showPatchIndexOpts     , commandCheckOptions = ocheck showPatchIndexOpts-    , commandParseOptions = onormalise showPatchIndexOpts     }   where     showPatchIndexBasicOpts = O.nullFlag ^ O.repoDir
src/Darcs/UI/Commands/ShowRepo.hs view
@@ -17,7 +17,6 @@  module Darcs.UI.Commands.ShowRepo ( showRepo ) where -import Prelude () import Darcs.Prelude  import Data.Char ( toLower, isSpace )@@ -26,7 +25,7 @@ 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, onormalise, defaultFlags, (?) )+import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.UI.Completion ( noArgs )@@ -47,10 +46,11 @@ import Darcs.Patch.Witnesses.Ordered ( lengthRL ) import qualified Data.ByteString.Char8 as BC  (unpack) import Darcs.Patch.Apply( ApplyState )+import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Tree ( Tree ) -showRepoHelp :: String-showRepoHelp =+showRepoHelp :: Doc+showRepoHelp = text $  "The `darcs show repo` command displays statistics about the current\n" ++  "repository, allowing third-party scripts to access this information\n" ++  "without inspecting `_darcs` directly (and without breaking when the\n" ++@@ -71,7 +71,7 @@ showRepoDescription :: String showRepoDescription = "Show repository summary information" -showRepo :: DarcsCommand [DarcsFlag]+showRepo :: DarcsCommand showRepo = DarcsCommand     { commandProgramName = "darcs"     , commandName = "repo"@@ -87,7 +87,6 @@     , commandBasicOptions = odesc showRepoBasicOpts     , commandDefaults = defaultFlags showRepoOpts     , commandCheckOptions = ocheck showRepoOpts-    , commandParseOptions = onormalise showRepoOpts     }   where     showRepoBasicOpts = O.repoDir ^ O.xmlOutput ^ O.enumPatches@@ -174,7 +173,7 @@     getPreflist "defaultrepo" >>= out "Default Remote" . unlines   where prefOut = uncurry out . (\(p,v) -> (p++" Pref", dropWhile isSpace v)) . break isSpace -showRepoMOTD :: RepoPatch p => PutInfo -> Repository rt p wR wU wR -> IO ()+showRepoMOTD :: PutInfo -> Repository rt p wR wU wR -> IO () showRepoMOTD out repo = getMotd (repoLocation repo) >>= out "MOTD" . BC.unpack  -- Support routines to provide information used by the PutInfo operations above.
src/Darcs/UI/Commands/ShowTags.hs view
@@ -19,28 +19,26 @@     ( showTags     ) where -import Prelude () import Darcs.Prelude -import Control.Monad ( unless, join )+import Control.Monad ( unless ) import Data.Maybe ( fromMaybe ) import System.IO ( stderr, hPutStrLn ) -import Darcs.Patch.Set ( PatchSet(..) )+import Darcs.Patch.Set ( PatchSet, patchSetTags ) import Darcs.Repository ( readRepo, withRepositoryLocation, RepoJob(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )-import Darcs.UI.Commands.Util ( repoTags ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, useCache, getRepourl )-import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.Util.Text ( formatText ) import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, formatText )  showTagsDescription :: String showTagsDescription = "Show all tags in the repository." -showTagsHelp :: String+showTagsHelp :: Doc showTagsHelp = formatText 80     [ "The tags command writes a list of all tags in the repository to "       ++ "standard output."@@ -49,7 +47,7 @@       ++ "if this happens."     ] -showTags :: DarcsCommand [DarcsFlag]+showTags :: DarcsCommand showTags = DarcsCommand     { commandProgramName = "darcs"     , commandName = "tags"@@ -65,7 +63,6 @@     , commandBasicOptions = odesc showTagsBasicOpts     , commandDefaults = defaultFlags showTagsOpts     , commandCheckOptions = ocheck showTagsOpts-    , commandParseOptions = onormalise showTagsOpts     }   where     showTagsBasicOpts = O.possiblyRemoteRepo@@ -77,7 +74,7 @@         readRepo repo >>= printTags   where     printTags :: PatchSet rt p wW wZ -> IO ()-    printTags = join . fmap (sequence_ . map process) . repoTags+    printTags = mapM_ process . patchSetTags     process :: String -> IO ()     process t = normalize t t False >>= putStrLn     normalize :: String -> String -> Bool -> IO String
src/Darcs/UI/Commands/Tag.hs view
@@ -17,7 +17,6 @@  module Darcs.UI.Commands.Tag ( tag ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( when )@@ -28,49 +27,48 @@ import Darcs.Patch.Depends ( getUncovered ) import Darcs.Patch     ( PrimPatch, PrimOf-    , IsRepoType, RepoPatch+    , RepoPatch     )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )-import Darcs.Patch.Named.Wrapped-    ( infopatch, adddeps, runInternalChecker, namedInternalChecker )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )+import Darcs.Patch.Named ( infopatch, adddeps ) import Darcs.Patch.Set-    ( PatchSet(..), emptyPatchSet, appendPSFL, patchSet2FL )-import Darcs.Patch.Witnesses.Ordered ( FL(..), filterOutRLRL, (:>)(..) )+    ( emptyPatchSet, appendPSFL, patchSet2FL, patchSetTags )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )  import Darcs.Repository     ( withRepoLock, Repository, RepoJob(..), readRepo     , tentativelyAddPatch, finalizeRepositoryChanges,     )-import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) )+import Darcs.Repository.Flags ( UpdatePending(..), DryRun(NoDryRun) )  import Darcs.UI.Commands-    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )-import Darcs.UI.Commands.Util ( repoTags )+    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putFinished ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags     ( DarcsFlag, getDate, compress, verbosity, useCache, umask, getAuthor, author ) import Darcs.UI.Options-    ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )+    ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( getLog ) import Darcs.UI.SelectChanges     ( WhichChanges(..)-    , selectionContext+    , selectionConfig     , runSelection-    , PatchSelectionContext(allowSkipAll)+    , SelectionConfig(allowSkipAll)     ) import qualified Darcs.UI.SelectChanges as S  import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Tree( Tree )   tagDescription :: String tagDescription = "Name the current repository state for future reference." -tagHelp :: String-tagHelp =+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" ++@@ -97,7 +95,7 @@  "The `darcs tag` command accepts the `--pipe` option, which behaves as\n" ++  "described in `darcs record`.\n" -tag :: DarcsCommand [DarcsFlag]+tag :: DarcsCommand tag = DarcsCommand     { commandProgramName = "darcs"     , commandName = "tag"@@ -113,7 +111,6 @@     , commandBasicOptions = odesc tagBasicOpts     , commandDefaults = defaultFlags tagOpts     , commandCheckOptions = ocheck tagOpts-    , commandParseOptions = onormalise tagOpts     }   where     tagBasicOpts@@ -126,32 +123,25 @@     tagAdvancedOpts = O.compress ^ O.umask     tagOpts = tagBasicOpts `withStdOpts` tagAdvancedOpts -filterNonInternal :: IsRepoType rt => PatchSet rt p wX wY -> PatchSet rt p wX wY-filterNonInternal =-  case namedInternalChecker of-    Nothing -> id-    Just f -> \(PatchSet ts ps) -> PatchSet ts (filterOutRLRL (runInternalChecker f . hopefully) ps)- tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () tagCmd _ opts args =-  withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do+  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-    tags <- repoTags patches-    let nonInternalPatches = filterNonInternal patches+    tags <- return $ patchSetTags patches     Sealed chosenPatches <-         if O.askDeps ? opts-            then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (patchSet2FL nonInternalPatches)-            else return $ Sealed nonInternalPatches+            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     myinfo <- patchinfo date name the_author long_comment     let mypatch = infopatch myinfo NilFL-    _ <- tentativelyAddPatch repository (compress ? opts) (verbosity ? opts) YesUpdateWorking+    _ <- tentativelyAddPatch repository (compress ? opts) (verbosity ? opts) YesUpdatePending              $ n2pia $ adddeps mypatch deps-    finalizeRepositoryChanges repository YesUpdateWorking (compress ? opts)-    putStrLn $ "Finished tagging patch '"++name++"'"+    _ <- finalizeRepositoryChanges repository YesUpdatePending (compress ? 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@@ -183,7 +173,7 @@ -- since the last tag, plus that tag itself.  askAboutTagDepends-     :: forall rt p wX wY . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+     :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree)      => [DarcsFlag]      -> FL (PatchInfoAnd rt p) wX wY      -> IO (Sealed (FL (PatchInfoAnd rt p) wX))@@ -193,11 +183,11 @@              , S.matchFlags = []              , S.interactive = True              , S.selectDeps = O.PromptDeps-             , S.summary = O.NoSummary+             , S.withSummary = O.NoSummary              , S.withContext = O.NoContext              }   (deps:>_) <- runSelection ps $-                     ((selectionContext FirstReversed "depend on" opts Nothing Nothing)+                     ((selectionConfig FirstReversed "depend on" opts Nothing Nothing)                           { allowSkipAll = False })   return $ Sealed deps
src/Darcs/UI/Commands/Test.hs view
@@ -20,7 +20,6 @@       test     ) where -import Prelude () import Darcs.Prelude hiding ( init )  import Control.Exception ( catch, IOException )@@ -30,8 +29,6 @@ import System.Exit ( ExitCode(..), exitWith ) import System.IO ( hFlush, stdout ) -import Darcs.Util.Tree( Tree )- import Darcs.UI.Commands     ( DarcsCommand(..), withStdOpts     , nodefaults@@ -39,7 +36,7 @@     , amInHashedRepository ) import Darcs.UI.Completion ( noArgs ) import Darcs.UI.Flags ( DarcsFlag, useCache, verbosity )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Patch.PatchInfoAnd ( hopefully ) import Darcs.Repository (@@ -61,20 +58,16 @@     , mapFL     , mapRL_RL     )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad )-import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Patch.Invert ( Invert ) import Darcs.Patch ( RepoPatch-                   , apply                    , description-                   , invert                    )-import Darcs.Patch.Named.Wrapped ( WrappedNamed )+import Darcs.Patch.Named ( Named ) import Darcs.Patch.Set ( patchSet2RL )-import Darcs.Util.Printer ( putDocLn-               , text-               )+import Darcs.Util.Printer ( Doc, putDocLn, text ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault ) import Darcs.Repository.Test ( getTest )@@ -87,8 +80,8 @@ testDescription :: String testDescription = "Run tests and search for the patch that introduced a bug." -testHelp :: String-testHelp =+testHelp :: Doc+testHelp = text $  unlines  [ "Run test on the current recorded state of the repository.  Given no"   ,"arguments, it uses the default repository test (see `darcs setpref`)."@@ -119,7 +112,7 @@   ,"break the test is found at random."  ] -test :: DarcsCommand [DarcsFlag]+test :: DarcsCommand test = DarcsCommand     { commandProgramName = "darcs"     , commandName = "test"@@ -135,21 +128,33 @@     , commandBasicOptions = odesc testBasicOpts     , commandDefaults = defaultFlags testOpts     , commandCheckOptions = ocheck testOpts-    , commandParseOptions = onormalise testOpts     }   where     testBasicOpts = O.testStrategy ^ O.leaveTestDir ^ O.repoDir     testAdvancedOpts = O.setScriptsExecutable     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 rt p wX wY-               . (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)+type Strategy = forall p wX wY+               . (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)               => [DarcsFlag]-              -> IO ExitCode  -- ^ test command-              -> ExitCode-              -> RL (WrappedNamed rt p) wX wY-              -> IO ()+              -> IO TestResult  -- ^ test command+              -> TestResult+              -> RL (Named p) wX wY+              -> IO (StrategyResult p)  testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () testCommand _ opts args =@@ -158,14 +163,14 @@   (init,testCmd) <- case args of     [] ->       do t <- getTest (verbosity ? opts)-         return (return ExitSuccess, t)+         return (return ExitSuccess, exitCodeToTestResult <$> t)     [cmd] ->       do putStrLn $ "Using test command:\n"++cmd-         return (return ExitSuccess, system cmd)+         return (return ExitSuccess, exitCodeToTestResult <$> system cmd)     [init,cmd] ->       do putStrLn $ "Using initialization command:\n"++init          putStrLn $ "Using test command:\n"++cmd-         return (system init, system cmd)+         return (system init, exitCodeToTestResult <$> system cmd)     _ -> fail "Test expects zero to two arguments."   let wd = case O.leaveTestDir ? opts of             O.YesLeaveTestDir -> withPermDir@@ -176,8 +181,27 @@     putInfo opts $ text "Running test...\n"     testResult <- testCmd     let track = chooseStrategy (O.testStrategy ? opts)-    track opts testCmd testResult (mapRL_RL hopefully . patchSet2RL $ patches)+    result <- track opts testCmd testResult (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"+      RunFailed n -> do+        putInfo opts $ text "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@@ -186,40 +210,48 @@  -- | test only the last recorded state oneTest :: Strategy-oneTest opts _ ExitSuccess _ = putInfo opts $ text "Test ran successfully.\n"-oneTest opts _ testResult  _ = do-    putInfo opts $ text "Test failed!\n"-    exitWith testResult+oneTest _ _ Success _ = return RunSuccess+oneTest _ _ (Failure n)  _ = return $ RunFailed n  -- | linear search (with --linear) trackLinear :: Strategy-trackLinear _ _ ExitSuccess _ = putStrLn "Success!"-trackLinear opts testCmd (ExitFailure _) (ps:<:p) = do-    let ip = invert p-    safeApply ip-    when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches ip+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 ip+    putDocLn $ description p     hFlush stdout     testResult <- testCmd-    trackLinear opts testCmd testResult ps-trackLinear _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"+    case testResult of+        Success -> return $ Blame WasLinear $ Sealed2 p+        Failure _ -> trackNextLinear opts testCmd ps  -- | exponential backoff search (with --backoff) trackBackoff :: Strategy-trackBackoff _ _ ExitSuccess NilRL = putStrLn "Success!"-trackBackoff _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"-trackBackoff _ _ ExitSuccess _ = putStrLn "Test does not fail on head."-trackBackoff opts testCmd (ExitFailure _) ps =+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, ApplyState p ~ Tree)+trackNextBackoff :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)                  => [DarcsFlag]-                 -> IO ExitCode+                 -> IO TestResult                  -> Int -- ^ number of patches to skip-                 -> RL (WrappedNamed rt p) wY wZ -- ^ patches not yet skipped-                 -> IO ()-trackNextBackoff _ _ _ NilRL = putStrLn "Noone passed the test!"+                 -> 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@@ -231,30 +263,30 @@             when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches skipped'             testResult <- testCmd             case testResult of-                ExitFailure _ ->+                Failure _ ->                     trackNextBackoff opts testCmd (2*n) ahead'-                ExitSuccess -> do+                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 _ _ ExitSuccess NilRL = putStrLn "Success!"-trackBisect _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"-trackBisect _ _ ExitSuccess _ = putStrLn "Test does not fail on head."-trackBisect opts testCmd (ExitFailure _) ps =+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, ApplyState p ~ Tree)+initialBisect ::  (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)               => [DarcsFlag]-              -> IO ExitCode-              -> RL (WrappedNamed rt p) wX wY-              -> IO ()+              -> 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) :: BisectState+    currProg = (1, maxProg) :: BisectProgress  -- | Bisect Patch Tree data PatchTree p wX wY where@@ -265,7 +297,7 @@ data BisectDir = BisectLeft | BisectRight deriving Show  -- | Progress of Bisect-type BisectState = (Int, Int)+type BisectProgress = (Int, Int)  -- | Create Bisect PatchTree from the RL patchTreeFromRL :: RL p wX wY -> PatchTree p wX wY@@ -279,13 +311,13 @@ patchTree2RL (Fork l r) = patchTree2RL r +<+ patchTree2RL l  -- | Iterate the Patch Tree-trackNextBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)+trackNextBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)                 => [DarcsFlag]-                -> BisectState-                -> IO ExitCode -- ^ test command+                -> BisectProgress+                -> IO TestResult -- ^ test command                 -> BisectDir-                -> PatchTree (WrappedNamed rt p) wX wY-                -> IO ()+                -> 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@@ -294,15 +326,13 @@     BisectLeft  -> jumpHalfOnLeft  opts r  -- within given direction   testResult <- testCmd -- execute test on repo   case testResult of-    ExitSuccess -> trackNextBisect opts (dnow+1, dtotal) testCmd-                                   BisectLeft l  -- continue left  (to the present)-    _           -> trackNextBisect opts (dnow+1, dtotal) testCmd-                                   BisectRight r -- continue right (to the past)-trackNextBisect _ _ _ _ (Leaf p) = do-  putStrLn "Last recent patch that fails the test (assuming monotony in the given range):"-  putDocLn (description p)+    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 :: (Invert p, Apply p, PatchInspect p,+jumpHalfOnRight :: (Apply p, PatchInspect p,                     ApplyMonad (ApplyState p) DefaultIO)                 => [DarcsFlag] -> PatchTree p wX wY -> IO () jumpHalfOnRight opts l = do unapplyRL ps@@ -321,10 +351,14 @@         => RL p wX wY -> IO () applyRL   patches = sequence_ (mapFL safeApply (reverseRL patches)) -unapplyRL :: (Invert p, Apply p, ApplyMonad (ApplyState p) DefaultIO)+unapplyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)            => RL p wX wY -> IO ()-unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches)+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
src/Darcs/UI/Commands/TransferMode.hs view
@@ -18,7 +18,6 @@ -- The pragma above is only for pattern guards. module Darcs.UI.Commands.TransferMode ( transferMode ) where -import Prelude () import Darcs.Prelude  import Control.Exception ( catch )@@ -29,8 +28,9 @@ 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, onormalise, defaultFlags )+import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags ) import qualified Darcs.UI.Options.All as O+import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Progress ( setProgressMode ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Path ( AbsolutePath )@@ -41,8 +41,8 @@ transferModeDescription :: String transferModeDescription = "Internal command for efficient ssh transfers." -transferModeHelp :: String-transferModeHelp =+transferModeHelp :: Doc+transferModeHelp = text $  "When pulling from or pushing to a remote repository over ssh, if both\n" ++  "the local and remote ends have Darcs 2, the `transfer-mode' command\n" ++  "will be invoked on the remote end.  This allows Darcs to intelligently\n" ++@@ -53,7 +53,7 @@  "who do not run ssh-agent will be prompted for the ssh password tens or\n" ++  "hundreds of times!\n" -transferMode :: DarcsCommand [DarcsFlag]+transferMode :: DarcsCommand transferMode = DarcsCommand     { commandProgramName = "darcs"     , commandName = "transfer-mode"@@ -69,7 +69,6 @@     , commandBasicOptions = odesc transferModeBasicOpts     , commandDefaults = defaultFlags transferModeOpts     , commandCheckOptions = ocheck transferModeOpts-    , commandParseOptions = onormalise transferModeOpts     }   where     transferModeBasicOpts = O.repoDir
src/Darcs/UI/Commands/Unrecord.hs view
@@ -21,77 +21,77 @@     ( unrecord     , unpull     , obliterate-    , getLastPatches-    , matchingHead     ) where -import Prelude ()-import Darcs.Prelude--import Prelude hiding ( (^) )--import Control.Exception ( catch, IOException )-import Control.Monad ( when )-import Data.Maybe( isJust )+import Control.Monad ( when, void )+import Data.Maybe( fromJust, isJust ) import Darcs.Util.Tree( Tree ) import System.Exit ( exitSuccess ) -import Darcs.Patch ( IsRepoType, RepoPatch, invert, commute, effect )+import Darcs.Prelude++import Darcs.Patch ( RepoPatch, invert, commute, effect ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Bundle ( makeBundleN, contextPatches, minContext )-import Darcs.Patch.Depends ( findCommonWithThem, patchSetUnion )-import Darcs.Patch.Match ( firstMatch, matchFirstPatchset, matchAPatch, MatchFlag )+import Darcs.Patch.Bundle ( makeBundle, minContext )+import Darcs.Patch.Depends ( removeFromPatchSet ) import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), appendPSFL, Origin,-                         SealedPatchSet )-import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )-import Darcs.Patch.Witnesses.Ordered ( RL(..), (:>)(..), (+<+), mapFL_FL,-                                       nullFL, reverseRL, mapRL, FL(..) )+import Darcs.Patch.Set ( PatchSet, Origin )+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 )-import Darcs.Repository ( PatchInfoAnd, withRepoLock, RepoJob(..), Repository,-                          tentativelyRemovePatches, finalizeRepositoryChanges,-                          tentativelyAddToPending, applyToWorking, readRepo,-                          invalidateIndex, unrecordedChanges,-                          identifyRepositoryFor )-import Darcs.Repository.Flags( UseIndex(..), ScanKnown(..), UpdateWorking(..), DryRun(NoDryRun) )+import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked )+import Darcs.Repository+    ( PatchInfoAnd+    , RepoJob(..)+    , applyToWorking+    , finalizeRepositoryChanges+    , invalidateIndex+    , readRepo+    , tentativelyAddToPending+    , tentativelyRemovePatches+    , unrecordedChanges+    , withRepoLock+    )+import Darcs.Repository.Flags( UseIndex(..), ScanKnown(..), UpdatePending(..), DryRun(NoDryRun) ) import Darcs.Util.Lock( writeDocBinFile )-import Darcs.Repository.Prefs ( getDefaultRepoPath ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias                          , putVerbose                          , setEnvDarcsPatches, amInHashedRepository-                         , putInfo )-import Darcs.UI.Commands.Util ( getUniqueDPatchName, printDryRunMessageAndExit )+                         , putInfo, putFinished )+import Darcs.UI.Commands.Util+    ( getUniqueDPatchName+    , printDryRunMessageAndExit+    , preselectPatches+    , historyEditHelp+    ) 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, onormalise, defaultFlags, parseFlags, (?) )-import Darcs.UI.Options.All ( notInRemoteFlagName )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.SelectChanges ( WhichChanges(..),-                                selectionContext, runSelection )+                                selectionConfig, runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.English ( presentParticiple )-import Darcs.Util.Printer ( text, putDoc, vcat, (<+>), ($$) )+import Darcs.Util.Printer ( Doc, formatWords, text, putDoc, sentence, (<+>), ($+$) ) import Darcs.Util.Progress ( debugMessage )  unrecordDescription :: String unrecordDescription =     "Remove recorded patches without changing the working tree." -unrecordHelp :: String-unrecordHelp = unlines- [ "Unrecord does the opposite of record: it deletes patches from"- , "the repository, without changing the working tree."- , "Deleting patches from the repository makes active changes again"- , "which you may record or revert later."- , "Beware that you should not use this command if there is a"- , "possibility that another user may have already pulled the patch."- ]+unrecordHelp :: Doc+unrecordHelp = formatWords+  [ "Unrecord does the opposite of record: it deletes patches from"+  , "the repository without changing the working tree. The changes"+  , "are now again visible with `darcs whatsnew` and you can record"+  , "or revert them as you please."+  ]+  $+$ historyEditHelp -unrecord :: DarcsCommand [DarcsFlag]+unrecord :: DarcsCommand unrecord = DarcsCommand     { commandProgramName = "darcs"     , commandName = "unrecord"@@ -107,7 +107,6 @@     , commandBasicOptions = odesc unrecordBasicOpts     , commandDefaults = defaultFlags unrecordOpts     , commandCheckOptions = ocheck unrecordOpts-    , commandParseOptions = onormalise unrecordOpts     }   where     unrecordBasicOpts@@ -124,47 +123,33 @@  unrecordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unrecordCmd _ opts _ =-    withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $-        RepoJob $ \repository -> do-            (_ :> removal_candidates) <- preselectPatches opts repository+    withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $+        RepoJob $ \_repository -> do+            (_ :> removal_candidates) <- preselectPatches opts _repository             let direction = if changesReverse ? opts then Last else LastReversed-                context = selectionContext direction "unrecord" (patchSelOpts opts) Nothing Nothing-            (_ :> to_unrecord) <- runSelection removal_candidates context+                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-            _ <- tentativelyRemovePatches repository (compress ? opts)-                     YesUpdateWorking to_unrecord-            finalizeRepositoryChanges repository YesUpdateWorking (compress ? opts)+            invalidateIndex _repository+            _repository <- tentativelyRemovePatches _repository (compress ? opts)+                     YesUpdatePending to_unrecord+            _ <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)             putInfo opts "Finished unrecording." -getLastPatches :: (IsRepoType rt, RepoPatch p) => [MatchFlag] -> PatchSet rt p Origin wR-               -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR-getLastPatches matchFlags ps = case matchFirstPatchset matchFlags ps of-                                   Sealed p1s -> findCommonWithThem ps p1s- unpullDescription :: String unpullDescription =     "Opposite of pull; unsafe if patch is not in remote repository." -unpullHelp :: String-unpullHelp = unlines- [ "Unpull completely removes recorded patches from your local repository."- , "The changes will be undone in your working tree and the patches"- , "will not be shown in your changes list anymore. Beware that if the"- , "patches are not still present in another repository you will lose"- , "precious code by unpulling!"- , ""- , "One way to save unpulled patches is to use the -O flag. A patch"- , "bundle will be created locally, that you will be able to apply"- , "later to your repository with `darcs apply`."- ]+unpullHelp :: Doc+unpullHelp = text $ "Unpull is an alias for what is nowadays called `obliterate`." -unpull :: DarcsCommand [DarcsFlag]+unpull :: DarcsCommand unpull = (commandAlias "unpull" Nothing obliterate)              { commandHelp = unpullHelp              , commandDescription = unpullDescription@@ -178,19 +163,22 @@ obliterateDescription =     "Delete selected patches from the repository." -obliterateHelp :: String-obliterateHelp = unlines- [ "Obliterate completely removes recorded patches from your local"- , "repository. The changes will be undone in your working tree and the"- , "patches will not be shown in your changes list anymore. Beware that"- , "you can lose precious code by obliterating!"- , ""- , "One way to save obliterated patches is to use the -O flag. A patch"- , "bundle will be created locally, that you will be able to apply"- , "later to your repository with `darcs apply`."- ]+obliterateHelp :: Doc+obliterateHelp = formatWords+  [ "Obliterate completely removes recorded patches from your local"+  , "repository. The changes will be undone in your working tree and the"+  , "patches will not be shown in your changes list anymore. Beware that"+  , "you can lose precious code by obliterating!"+  ]+  $+$ formatWords+  [ "One way to save obliterated patches is to use the -O flag. A patch"+  , "bundle will be created locally, that you will be able to apply"+  , "later to your repository with `darcs apply`. See `darcs send` for"+  , "a more detailed description."+  ]+  $+$ historyEditHelp -obliterate :: DarcsCommand [DarcsFlag]+obliterate :: DarcsCommand obliterate = DarcsCommand     { commandProgramName = "darcs"     , commandName = "obliterate"@@ -206,7 +194,6 @@     , commandBasicOptions = odesc obliterateBasicOpts     , commandDefaults = defaultFlags obliterateOpts     , commandCheckOptions = ocheck obliterateOpts-    , commandParseOptions = onormalise obliterateOpts     }   where     obliterateBasicOpts@@ -215,7 +202,7 @@       ^ O.selectDeps       ^ O.interactive       ^ O.repoDir-      ^ O.summary+      ^ O.withSummary       ^ O.output       ^ O.minimize       ^ O.diffAlgorithm@@ -241,18 +228,19 @@ genericObliterateCmd cmdname _ opts _ =     let cacheOpt = useCache ? opts         verbOpt = verbosity ? opts-    in withRepoLock (dryRun ? opts) cacheOpt YesUpdateWorking (umask ? opts) $-        RepoJob $ \repository -> do+    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-            (auto_kept :> removal_candidates) <- preselectPatches opts repository+              O.NoLookForMoves O.NoLookForReplaces _repository Nothing+            (_ :> removal_candidates) <- preselectPatches opts _repository              let direction = if changesReverse ? opts then Last else LastReversed-                context = selectionContext direction cmdname (patchSelOpts opts) Nothing Nothing-            (kept :> removed) <--                runSelection removal_candidates context+                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@@ -263,112 +251,54 @@                 Just (_ :> p_after_pending) -> do                     printDryRunMessageAndExit "obliterate"                       verbOpt-                      (O.summary ? opts)+                      (O.withSummary ? opts)                       (dryRun ? opts)                       (xmlOutput ? opts)                       (isInteractive True opts)                       removed                     setEnvDarcsPatches removed                     when (isJust $ getOutput opts "") $-                        savetoBundle opts (auto_kept `appendPSFL` kept) removed-                    invalidateIndex repository-                    _ <- tentativelyRemovePatches repository-                        (compress ? opts) YesUpdateWorking removed-                    tentativelyAddToPending repository-                        YesUpdateWorking $ invert $ effect removed-                    finalizeRepositoryChanges repository-                        YesUpdateWorking (compress ? opts)-                    debugMessage "Applying patches to working directory..."-                    _ <- applyToWorking repository verbOpt-                        (invert p_after_pending)-                         `catch` \(e :: IOException) -> fail $-                            "Couldn't undo patch in working dir.\n"-                            ++ show e-                    putInfo opts $ "Finished" <+> text (presentParticiple cmdname) <> "."---- | Get the union of the set of patches in each specified location-remotePatches :: (IsRepoType rt, RepoPatch p)-              => [DarcsFlag]-              -> Repository rt p wX wU wT -> [O.NotInRemote]-              -> IO (SealedPatchSet rt p Origin)-remotePatches opts repository nirs = do-    nirsPaths <- mapM getNotInRemotePath nirs-    putInfo opts $ "Determining patches not in" <+> pluralExtra nirsPaths $$-        itemize nirsPaths-    patchSetUnion `fmap` mapM readNir nirsPaths-  where-    pluralExtra names = if length names > 1 then "any of" else mempty-    itemize = vcat . map (text . ("  - " ++))--    readNir n = do-        r <- identifyRepositoryFor repository (useCache ? opts) n-        rps <- readRepo r-        return $ seal rps--    getNotInRemotePath :: O.NotInRemote -> IO String-    getNotInRemotePath (O.NotInRemotePath p) = return p-    getNotInRemotePath O.NotInDefaultRepo = do-        defaultRepo <- getDefaultRepoPath-        let err = fail $ "No default push/pull repo configured, please pass a "-                         ++ "repo name to --" ++ notInRemoteFlagName-        maybe err return defaultRepo---- | matchingHead returns the repository up to some tag. The tag t is the last--- tag such that there is a patch after t that is matched by the user's query.-matchingHead :: forall rt p wR-              . (IsRepoType rt, RepoPatch p)-             => [MatchFlag] -> PatchSet rt p Origin wR-             -> (PatchSet rt p :> FL (PatchInfoAnd rt 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 s@(PatchSet _ x)-        | or (mapRL (matchAPatch matchFlags) x) = contextPatches s-    mh (PatchSet (ts :<: Tagged t _ ps) x) =-        case mh (PatchSet ts (ps :<: t)) of-            (start :> patches) -> start :> patches +<+ x-    mh ps = ps :> NilRL+                        -- 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) -savetoBundle :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag]-             -> PatchSet rt p Origin wZ -> FL (PatchInfoAnd rt p) wZ wT -> IO ()-savetoBundle opts kept removed@(x :>: _) = do-    let genFullBundle = makeBundleN Nothing kept (mapFL_FL hopefully removed)+savetoBundle :: (RepoPatch p, ApplyState p ~ Tree)+             => [DarcsFlag]+             -> FL (PatchInfoAnd rt p) wX wR+             -> PatchSet rt 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') -> makeBundleN Nothing kept' (mapFL_FL hopefully removed') )+                           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-savetoBundle _ _ NilFL = return ()--preselectPatches-  :: (IsRepoType rt, RepoPatch p)-  => [DarcsFlag]-  -> Repository rt p wR wU wT-  -> IO ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR)-preselectPatches opts repo = do-  allpatches <- readRepo repo-  let matchFlags = parseFlags O.matchSeveralOrLast opts-  case O.notInRemote ? opts of-    [] -> do-      return $-        if firstMatch matchFlags-          then getLastPatches matchFlags allpatches-          else matchingHead matchFlags allpatches-    -- FIXME what about match options when we have --not-in-remote?-    -- It looks like they are simply ignored.-    nirs -> do-      (Sealed thems) <--        remotePatches opts repo nirs-      return $ findCommonWithThem allpatches thems+    putInfo opts $ sentence $+      useAbsoluteOrStd (("Saved patch bundle" <+>) . text . toFilePath) (text "stdout") outname  patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions@@ -376,6 +306,6 @@     , S.matchFlags = parseFlags O.matchSeveralOrLast flags     , S.interactive = isInteractive True flags     , S.selectDeps = selectDeps ? flags-    , S.summary = O.summary ? flags+    , S.withSummary = O.withSummary ? flags     , S.withContext = O.NoContext     }
src/Darcs/UI/Commands/Unrevert.hs view
@@ -17,51 +17,57 @@  module Darcs.UI.Commands.Unrevert ( unrevert, writeUnrevert ) where -import Prelude () import Darcs.Prelude -import Control.Exception ( catch, IOException ) import System.Exit ( exitSuccess ) import Darcs.Util.Tree( Tree ) -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , withStdOpts+    , nodefaults+    , amInHashedRepository+    , putFinished+    ) 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(..), UpdateWorking(..), DryRun(NoDryRun) )+    , WantGuiPause(..), UpdatePending(..), DryRun(NoDryRun) ) import Darcs.UI.Flags ( DarcsFlag )-import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )+import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..),-                          unrevertUrl, considerMergeToWorking,+                          considerMergeToWorking,                           tentativelyAddToPending, finalizeRepositoryChanges,                           readRepo,                           readRecorded,                           applyToWorking, unrecordedChanges )-import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, commute, fromPrims )+import Darcs.Repository.Paths ( unrevertPath )+import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, commute ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Named.Wrapped ( namepatch )-import Darcs.Patch.Rebase ( dropAnyRebase )-import Darcs.Patch.Set ( Origin )+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 ( FL(..), (:>)(..), (+>+) )+import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), (+>+) ) import Darcs.UI.SelectChanges     ( WhichChanges(First)-    , runSelection-    , selectionContextPrim+    , 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.UI.External ( catchall )+import Darcs.Util.Exception ( catchall ) import Darcs.Util.Prompt ( askUser )-import Darcs.Patch.Bundle ( scanBundle, makeBundleN )+import Darcs.Patch.Bundle ( parseBundle, interpretBundle, makeBundle ) import Darcs.Util.IsoDate ( getIsoDateTime ) import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Path ( AbsolutePath ) @@ -69,8 +75,8 @@ unrevertDescription =  "Undo the last revert." -unrevertHelp :: String-unrevertHelp =+unrevertHelp :: Doc+unrevertHelp = text $  "Unrevert is a rescue command in case you accidentally reverted\n" ++  "something you wanted to keep (for example, typing `darcs rev -a`\n" ++  "instead of `darcs rec -a`).\n" ++@@ -85,11 +91,11 @@     , S.matchFlags = []     , S.interactive = isInteractive True flags     , S.selectDeps = O.PromptDeps -- option not supported, use default-    , S.summary = O.NoSummary -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default     , S.withContext = withContext ? flags     } -unrevert :: DarcsCommand [DarcsFlag]+unrevert :: DarcsCommand unrevert = DarcsCommand     { commandProgramName = "darcs"     , commandName = "unrevert"@@ -105,7 +111,6 @@     , commandBasicOptions = odesc unrevertBasicOpts     , commandDefaults = defaultFlags unrevertOpts     , commandCheckOptions = ocheck unrevertOpts-    , commandParseOptions = onormalise unrevertOpts     }   where     unrevertBasicOpts@@ -119,36 +124,37 @@  unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unrevertCmd _ opts [] =- withRepoLock NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts) $ RepoJob $ \repository -> do-  us <- readRepo repository-  Sealed them <- unrevertPatchBundle repository-  recorded <- readRecorded repository+ 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+    O.NoLookForMoves O.NoLookForReplaces _repository Nothing   Sealed h_them <- return $ mergeThem us them-  Sealed pw <- considerMergeToWorking repository "unrevert"-                      YesAllowConflictsAndMark YesUpdateWorking+  Sealed pw <- considerMergeToWorking _repository "unrevert"+                      YesAllowConflictsAndMark                       NoExternalMerge NoWantGuiPause                       (compress ? opts) (verbosity ? opts) NoReorder                       ( UseIndex, ScanKnown, diffAlgorithm ? opts )-                      NilFL h_them-  let context = selectionContextPrim First "unrevert" (patchSelOpts opts) Nothing Nothing (Just recorded)-  (p :> skipped) <- runSelection pw context-  tentativelyAddToPending repository YesUpdateWorking p+                      (Fork us NilFL h_them)+  let selection_config =+        selectionConfigPrim+            First "unrevert" (patchSelOpts opts)+            Nothing Nothing (Just recorded)+  (p :> skipped) <- runInvertibleSelection pw selection_config+  tentativelyAddToPending _repository p   withSignalsBlocked $-      do finalizeRepositoryChanges repository YesUpdateWorking (compress ? opts)-         _ <- applyToWorking repository (verbosity ? opts) p `catch` \(e :: IOException) ->-             fail ("Error applying unrevert to working directory...\n"-                   ++ show e)+      do _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)+         _ <- applyToWorking _repository (verbosity ? opts) p          debugMessage "I'm about to writeUnrevert."-         writeUnrevert repository skipped recorded (unrecorded+>+p)-  debugMessage "Finished unreverting."-unrevertCmd _ _ _ = impossible+         writeUnrevert _repository skipped recorded (unrecorded+>+p)+  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 repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository+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? "@@ -156,19 +162,22 @@                                  _ -> exitSuccess                   writeUnrevert repository NilFL recorded pend     Just (p' :> _) -> do-        rep <- dropAnyRebase <$> readRepo repository+        rep <- readRepo repository         date <- getIsoDateTime-        np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')-        bundle <- makeBundleN (Just recorded) rep (np :>: NilFL)-        writeDocBinFile (unrevertUrl repository) bundle-        where fromRepoPrims :: RepoPatch p => Repository rt p wR wU wT -> FL (PrimOf p) wR wY -> FL p wR wY-              fromRepoPrims _ = fromPrims+        info <- patchinfo date "unrevert" "anon" []+        let np = infopatch info p'+        bundle <- makeBundle (Just recorded) rep (np :>: NilFL)+        writeDocBinFile unrevertPath bundle -unrevertPatchBundle :: RepoPatch p => Repository rt p wR wU wT -> IO (SealedPatchSet rt p Origin)-unrevertPatchBundle repository = do-  pf <- B.readFile (unrevertUrl repository)+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 scanBundle pf of-      Right ps -> return ps+  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
@@ -23,65 +23,86 @@     , printDryRunMessageAndExit     , getUniqueRepositoryName     , getUniqueDPatchName-    , expandDirs     , doesDirectoryReallyExist     , checkUnrelatedRepos-    , repoTags+    , preselectPatches+    , getLastPatches+    , matchRange+    , historyEditHelp     ) where  import Control.Monad ( when, unless )-import Data.Maybe ( catMaybes, fromJust ) -import Prelude () import Darcs.Prelude +import Data.Char ( isAlpha, toLower, isDigit, isSpace )+import Data.Maybe ( fromMaybe )+ import System.Exit ( ExitCode(..), exitWith, exitSuccess )-import System.FilePath.Posix ( (</>) ) import System.Posix.Files ( isDirectory ) -import Darcs.Patch ( RepoPatch, xmlSummary )-import Darcs.Patch.Depends ( areUnrelatedRepos )-import Darcs.Patch.Info ( toXml, piTag )+import Darcs.Patch ( IsRepoType, RepoPatch, xmlSummary )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Depends+    ( areUnrelatedRepos+    , findCommonWithThem+    , patchSetUnion+    )+import Darcs.Patch.Info ( toXml )+import Darcs.Patch.Match+    ( MatchFlag+    , MatchableRP+    , firstMatch+    , matchFirstPatchset+    , matchSecondPatchset+    , matchingHead+    ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM )-import Darcs.Patch.Set ( PatchSet(..), patchSetfMap )-import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet, Origin, emptyPatchSet )+import Darcs.Patch.Witnesses.Ordered ( FL, (:>)(..), mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Sealed2(..) ) -import Darcs.Repository ( Repository, readRecorded, testTentative )-import Darcs.Repository.State-    ( readUnrecordedFiltered, readWorking, restrictBoring-    , TreeFilter(..), applyTreeFilter+import Darcs.Repository+    ( ReadingOrWriting(..)+    , Repository+    , identifyRepositoryFor+    , readRecorded+    , readRepo+    , testTentative     )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Bundle ( patchFilename )+import Darcs.Repository.Prefs ( getDefaultRepo, globalPrefsDirDoc )+import Darcs.Repository.State ( readUnrecordedFiltered ) +import Darcs.UI.Commands ( putInfo )+import Darcs.UI.Flags ( DarcsFlag ) import Darcs.UI.PrintPatch ( showFriendly )+import Darcs.UI.Options ( (?) ) import Darcs.UI.Options.All     ( Verbosity(..), SetScriptsExecutable, TestChanges (..)     , RunTest(..), LeaveTestDir(..), UseIndex, ScanKnown(..)-    , Summary(..), DryRun(..), XmlOutput(..), LookForMoves+    , WithSummary(..), DryRun(..), XmlOutput(..), LookForMoves     )+import qualified Darcs.UI.Options.All as O +import Darcs.Util.English ( anyOfClause, itemizeVertical ) import Darcs.Util.Exception ( clarifyErrors )-import Darcs.Util.File ( getFileStatus, withCurrentDirectory )-import Darcs.Util.Path-    ( SubPath, toFilePath, getUniquePathName, floatPath-    , simpleSubPath, toPath, anchorPath-    )+import Darcs.Util.File ( getFileStatus )+import Darcs.Util.Path ( AnchoredPath, displayPath, getUniquePathName ) import Darcs.Util.Printer-    ( text, (<+>), hsep, ($$), vcat, vsep+    ( Doc, formatWords, ($+$), text, (<+>), hsep, ($$), vcat, vsep     , putDocLn, insertBeforeLastline, prefix+    , putDocLnWith, pathlist     )+import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Prompt ( PromptConfig(..), promptChar, promptYorn )-import Darcs.Util.Text ( pathlist ) import Darcs.Util.Tree.Monad ( virtualTreeIO, exists ) import Darcs.Util.Tree ( Tree )-import qualified Darcs.Util.Tree as Tree  -announceFiles :: Verbosity -> Maybe [SubPath] -> String -> IO ()+announceFiles :: Verbosity -> Maybe [AnchoredPath] -> String -> IO () announceFiles Quiet _ _ = return ()-announceFiles _ (Just subpaths) message = putDocLn $-    text message <> text ":" <+> pathlist (map toFilePath subpaths)+announceFiles _ (Just paths) message = putDocLn $+    text message <> text ":" <+> pathlist (map displayPath paths) announceFiles _ _ _ = return ()  testTentativeAndMaybeExit :: Repository rt p wR wU wT@@ -111,16 +132,16 @@ -- name of the action being taken, like @\"push\"@ @flags@ is the list of flags -- which were sent to darcs @patches@ is the sequence of patches which would be -- touched by @action@.-printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree)+printDryRunMessageAndExit :: RepoPatch p                           => String-                          -> Verbosity -> Summary -> DryRun -> XmlOutput+                          -> Verbosity -> WithSummary -> DryRun -> XmlOutput                           -> Bool -- interactive                           -> FL (PatchInfoAnd rt 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:" ]-        putDocLn put_mode+        putDocLnWith fancyPrinters put_mode         putInfoX $ text ""         putInfoX $ text "Making no changes: this is a dry run."         exitSuccess@@ -147,23 +168,22 @@     indent = prefix "    "  -- | Given a repository and two common command options, classify the given list--- of subpaths according to whether they exist in the pristine or working tree.+-- of paths according to whether they exist in the pristine or working tree. -- Paths which are neither in working nor pristine are reported and dropped. -- The result is a pair of path lists: those that exist only in the working tree, -- and those that exist in pristine or working. filterExistingPaths :: (RepoPatch p, ApplyState p ~ Tree)-                    => Repository rt p wR wU wT+                    => Repository rt p wR wU wR                     -> Verbosity                     -> UseIndex                     -> ScanKnown                     -> LookForMoves-                    -> [SubPath]-                    -> IO ([SubPath],[SubPath])+                    -> [AnchoredPath]+                    -> IO ([AnchoredPath],[AnchoredPath]) filterExistingPaths repo verb useidx scan lfm paths = do       pristine <- readRecorded repo       working <- readUnrecordedFiltered repo useidx scan lfm (Just paths)-      let filepaths = map toFilePath paths-          check = virtualTreeIO $ mapM (exists . floatPath) filepaths+      let check = virtualTreeIO $ mapM exists paths       (in_pristine, _) <- check pristine       (in_working, _) <- check working       let paths_with_info       = zip3 paths in_pristine in_working@@ -173,7 +193,7 @@           or_not_added          = if scan == ScanKnown then " or not added " else " "       unless (verb == Quiet || null paths_in_neither) $ putDocLn $         "Ignoring non-existing" <> or_not_added <> "paths:" <+>-        pathlist (map toFilePath paths_in_neither)+        pathlist (map displayPath paths_in_neither)       return (paths_only_in_working, paths_in_either)  getUniqueRepositoryName :: Bool -> FilePath -> IO FilePath@@ -185,52 +205,127 @@                  n ++"'"  getUniqueDPatchName :: FilePath -> IO FilePath-getUniqueDPatchName name = getUniquePathName True buildMsg buildName+getUniqueDPatchName name = getUniquePathName False (const "") buildName   where-    buildName i = if i == -1 then patchFilename name else patchFilename $ name++"_"++show i-    buildMsg n = "Directory or file '"++ name ++-                 "' already exists, creating dpatch as '"++-                 n ++"'"+    buildName i =+      if i == -1 then patchFilename name else patchFilename $ name++"_"++show i --- | For each directory in the list of 'SubPath's, add all paths--- under that directory to the list. If the first argument is 'True', then--- include even boring files.------ This is used by the add and remove commands to handle the --recursive option.-expandDirs :: Bool -> [SubPath] -> IO [SubPath]-expandDirs includeBoring subpaths =-  do-    boringFilter <--      if includeBoring-        then return (TreeFilter id)-        else restrictBoring Tree.emptyTree-    fmap (map (fromJust . simpleSubPath)) $-      concat `fmap` mapM (expandOne boringFilter . toPath) subpaths+-- |patchFilename maps a patch description string to a safe (lowercased, spaces+-- removed and ascii-only characters) patch filename.+patchFilename :: String -> String+patchFilename the_summary = name ++ ".dpatch"   where-    expandOne boringFilter "" = listFiles boringFilter-    expandOne boringFilter f = do-        isdir <- doesDirectoryReallyExist f-        if not isdir-          then return [f]-          else do-            fs <- withCurrentDirectory f (listFiles boringFilter)-            return $ f: map (f </>) fs-    listFiles boringFilter = do-      working <- applyTreeFilter boringFilter <$> readWorking-      return $ map (anchorPath "" . fst) $ Tree.list working+    name = map safeFileChar the_summary+    safeFileChar c | isAlpha c = toLower c+                   | isDigit c = c+                   | isSpace c = '-'+    safeFileChar _ = '_'  doesDirectoryReallyExist :: FilePath -> IO Bool doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f  checkUnrelatedRepos :: RepoPatch p                     => Bool-                    -> PatchSet rt p wStart wX-                    -> PatchSet rt p wStart wY+                    -> PatchSet rt p Origin wX+                    -> PatchSet rt p Origin wY                     -> IO () checkUnrelatedRepos allowUnrelatedRepos us them =     when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $          do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?"             unless confirmed $ putStrLn "Cancelled." >> exitSuccess -repoTags :: PatchSet rt p wX wY -> IO [String]-repoTags ps = catMaybes `fmap` patchSetfMap (return . piTag . info) ps+-- | Get the union of the set of patches in each specified location+remotePatches :: (IsRepoType rt, RepoPatch p)+              => [DarcsFlag]+              -> Repository rt p wX wU wT -> [O.NotInRemote]+              -> IO (SealedPatchSet rt p Origin)+remotePatches opts repository nirs = do+    nirsPaths <- mapM getNotInRemotePath nirs+    putInfo opts $+      "Determining patches not in" <+>+      anyOfClause nirsPaths $$ itemizeVertical 2 nirsPaths+    patchSetUnion `fmap` mapM readNir nirsPaths+  where+    readNir n = do+        r <- identifyRepositoryFor Reading repository (O.useCache ? opts) n+        rps <- readRepo r+        return (Sealed rps)++    getNotInRemotePath :: O.NotInRemote -> IO String+    getNotInRemotePath (O.NotInRemotePath p) = return p+    getNotInRemotePath O.NotInDefaultRepo = do+        defaultRepo <- getDefaultRepo+        let err = fail $ "No default push/pull repo configured, please pass a "+                         ++ "repo name to --" ++ O.notInRemoteFlagName+        maybe err return defaultRepo++getLastPatches :: RepoPatch p+               => [O.MatchFlag] -> PatchSet rt p Origin wR+               -> (PatchSet rt p :> FL (PatchInfoAnd rt 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)+  => [DarcsFlag]+  -> Repository rt p wR wU wT+  -> IO ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR)+preselectPatches opts repo = do+  allpatches <- readRepo repo+  let matchFlags = O.matchSeveralOrLast ? opts+  case O.notInRemote ? opts of+    [] -> do+      return $+        if firstMatch matchFlags+          then getLastPatches matchFlags allpatches+          else matchingHead matchFlags allpatches+    -- FIXME what about match options when we have --not-in-remote?+    -- It looks like they are simply ignored.+    nirs -> do+      (Sealed thems) <-+        remotePatches opts repo nirs+      return $ findCommonWithThem allpatches thems++matchRange :: MatchableRP p+           => [MatchFlag]+           -> PatchSet rt p Origin wY+           -> Sealed2 (FL (PatchInfoAnd rt p))+matchRange matchFlags ps =+  case (sp1s, sp2s) of+    (Sealed p1s, Sealed p2s) ->+      case findCommonWithThem p2s p1s of+        _ :> us -> Sealed2 us+  where+    sp1s = fromMaybe (Sealed emptyPatchSet) $ matchFirstPatchset matchFlags ps+    sp2s = fromMaybe (Sealed ps) $ matchSecondPatchset matchFlags ps++historyEditHelp :: Doc+historyEditHelp = formatWords+  [ "Note that this command edits the history of your repo. It is"+  , "primarily intended to be used on patches that you authored yourself"+  , "and did not yet publish. Using it for patches that are already"+  , "published, or even ones you did not author yourself, may cause"+  , "confusion and can disrupt your own and other people's work-flow."+  , "This depends a lot on how your project is organized, though, so"+  , "there may be valid exceptions to this rule."+  ]+  $+$ formatWords+  [ "Using the `--not-in-remote` option is a good way to guard against"+  , "accidentally editing published patches. Without arguments, this"+  , "deselects any patches that are also present in the `defaultrepo`."+  , "If you work in a clone of some publically hosted repository,"+  , "then your `defaultrepo` will be that public repo. You can also"+  , "give the option an argument which is a path or URL of some other"+  , "repository; you can use the option multiple times with"+  , "different repositories, which has the effect of treating all"+  , "of them as \"upstream\", that is, it prevents you from selecting"+  , "a patch that is contained in any of these repos."+  ]+  $+$ formatWords+  [ "You can also guard only against editing another developer's patch"+  , "by using an appropriate `--match` option with the `author` keyword."+  , "For instance, you could add something like `<cmd> match Your Name`"+  , "to your `" ++ globalPrefsDirDoc ++ "defaults`."+  ]
src/Darcs/UI/Commands/Util/Tree.hs view
@@ -24,7 +24,6 @@     , treeHasAnycase     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( forM )@@ -37,14 +36,14 @@ import Darcs.Util.Tree ( Tree, listImmediate, findTree )  import Darcs.Util.Path-    ( AnchoredPath(..), floatPath, eqAnycase )+    ( AnchoredPath(..), eqAnycase )  treeHasAnycase :: Monad m                => Tree m-               -> FilePath+               -> AnchoredPath                -> m Bool treeHasAnycase tree path =-    fst `fmap` TM.virtualTreeMonad (existsAnycase $ floatPath path) tree+    fst `fmap` TM.virtualTreeMonad (existsAnycase path) tree   existsAnycase :: Monad m@@ -53,7 +52,7 @@ existsAnycase (AnchoredPath []) = return True existsAnycase (AnchoredPath (x:xs)) = do      wd <- TM.currentDirectory-     tree <- fromMaybe (bug "invalid path passed to existsAnycase") <$>+     tree <- fromMaybe (error "invalid path passed to existsAnycase") <$>              gets (flip findTree wd . TM.tree)      let subs = [ AnchoredPath [n] | (n, _) <- listImmediate tree,                                           eqAnycase n x ]@@ -63,11 +62,11 @@                else TM.withDirectory path (existsAnycase $ AnchoredPath xs))  -treeHas :: Monad m => Tree m -> FilePath -> m Bool-treeHas tree path = fst `fmap` TM.virtualTreeMonad (TM.exists $ floatPath path) tree+treeHas :: Monad m => Tree m -> AnchoredPath -> m Bool+treeHas tree path = fst `fmap` TM.virtualTreeMonad (TM.exists path) tree -treeHasDir :: Monad m => Tree m -> FilePath -> m Bool-treeHasDir tree path = fst `fmap` TM.virtualTreeMonad (TM.directoryExists $ floatPath 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 -> FilePath -> m Bool-treeHasFile tree path = fst `fmap` TM.virtualTreeMonad (TM.fileExists $ floatPath 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
@@ -15,46 +15,45 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.WhatsNew-    (-      whatsnew+    ( whatsnew     , status     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( void, when ) import Control.Monad.Reader ( runReaderT ) import Control.Monad.State ( evalStateT, liftIO )-import Darcs.Util.Tree ( Tree ) import System.Exit ( ExitCode (..), exitSuccess, exitWith )-import Data.List.Ordered ( nubSort )  import Darcs.Patch     ( PrimOf, PrimPatch, RepoPatch     , applyToTree, plainSummaryPrims, primIsHunk     )-import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Choices ( mkPatchChoices, labelPatches, unLabel ) import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.FileHunk ( IsHunk (..) )-import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Inspect ( PatchInspect (..) ) import Darcs.Patch.Permutations ( partitionRL ) import Darcs.Patch.Prim.Class ( PrimDetails (..) )-import Darcs.Patch.Show ( ShowPatch, ShowContextPatch )-import Darcs.Patch.Split ( primSplitter )-import Darcs.Patch.TouchesFiles ( choosePreTouching )+import Darcs.Patch.Show+    ( ShowContextPatch+    , ShowPatch(..)+    , ShowPatchBasic(..)+    , displayPatch+    )+import Darcs.Patch.TouchesFiles ( chooseTouching ) import Darcs.Patch.Witnesses.Ordered-    ( (:>) (..), FL (..), RL (..)-    , lengthFL, reverseFL, reverseRL+    ( (:>) (..), FL (..)+    , reverseFL, reverseRL     ) import Darcs.Patch.Witnesses.Sealed     ( Sealed (..), Sealed2 (..)     , unFreeLeft     )-import Darcs.Patch.Witnesses.WZipper ( FZipper (..) ) import Darcs.Repository     ( RepoJob (..), Repository     , readRecorded@@ -68,38 +67,39 @@     ) import Darcs.UI.Completion ( modifiedFileArgs ) import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths )+import Darcs.UI.External ( viewDocWith ) import Darcs.UI.Flags     ( DarcsFlag, diffAlgorithm-    , withContext, useCache, fixSubPaths+    , withContext, useCache, pathSetFromArgs     , verbosity, isInteractive     , lookForAdds, lookForMoves, lookForReplaces     , scanKnown, useIndex, diffingOpts     ) import Darcs.UI.Options-    ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )+    ( DarcsOption, (^), odesc, ocheck, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O-import Darcs.UI.PrintPatch-    ( contextualPrintPatch, printPatch-    , printPatchPager-    )+import Darcs.UI.PrintPatch ( contextualPrintPatch ) import Darcs.UI.SelectChanges-    ( InteractiveSelectionContext (..)-    , InteractiveSelectionM, KeyPress (..)-    , WhichChanges (..), backAll+    ( InteractiveSelectionM, KeyPress (..)+    , WhichChanges (..)+    , initialSelectionState+    , backAll     , backOne, currentFile     , currentPatch, decide     , decideWholeFile, helpFor     , keysFor, prompt-    , selectionContextPrim, skipMundane-    , skipOne, printSummary+    , selectionConfigPrim, skipMundane+    , skipOne     ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )-import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath )+import Darcs.Util.Path ( AbsolutePath, AnchoredPath ) import Darcs.Util.Printer-    ( putDocLn, renderString-    , text, vcat+    ( Doc, formatWords, putDocLn, 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@@ -110,14 +110,14 @@     , S.matchFlags = []     , S.interactive = isInteractive True flags     , S.selectDeps = O.PromptDeps -- option not supported, use default-    , S.summary = getSummary flags+    , S.withSummary = getSummary flags     , S.withContext = withContext ? flags     }  -- lookForAdds and machineReadable set YesSummary -- unless NoSummary was given expressly -- (or by default e.g. status)-getSummary :: [DarcsFlag] -> O.Summary+getSummary :: [DarcsFlag] -> O.WithSummary getSummary flags = case O.maybeSummary Nothing ? flags of   Just O.NoSummary -> O.NoSummary   Just O.YesSummary -> O.YesSummary@@ -126,7 +126,7 @@     | O.machineReadable ? flags -> O.YesSummary     | otherwise -> O.NoSummary -whatsnew :: DarcsCommand [DarcsFlag]+whatsnew :: DarcsCommand whatsnew = DarcsCommand     { commandProgramName = "darcs"     , commandName = "whatsnew"@@ -142,7 +142,6 @@     , commandBasicOptions = odesc whatsnewBasicOpts     , commandDefaults = defaultFlags whatsnewOpts     , commandCheckOptions = ocheck whatsnewOpts-    , commandParseOptions = onormalise whatsnewOpts     }   where     whatsnewBasicOpts@@ -158,49 +157,54 @@ whatsnewDescription :: String whatsnewDescription = "List unrecorded changes in the working tree." -whatsnewHelp :: String+whatsnewHelp :: Doc whatsnewHelp =- "The `darcs whatsnew` command lists unrecorded changes to the working\n" ++- "tree.  If you specify a set of files and directories, only unrecorded\n" ++- "changes to those files and directories are listed.\n" ++- "\n" ++- "With the `--summary` option, the changes are condensed to one line per\n" ++- "file, with mnemonics to indicate the nature and extent of the change.\n" ++- "The `--look-for-adds` option causes candidates for `darcs add` to be\n" ++- "included in the summary output.  Summary mnemonics are as follows:\n" ++- "\n" ++- "* `A f` and `A d/` respectively mean an added file or directory.\n" ++- "* `R f` and `R d/` respectively mean a removed file or directory.\n" ++- "* `M f -N +M rP` means a modified file, with `N` lines deleted, `M`\n" ++- "  lines added, and `P` lexical replacements.\n" ++- "* `f -> g` means a moved file or directory.\n" ++- "* `a f` and `a d/` respectively mean a new, but unadded, file or\n" ++- "  directory, when using `--look-for-adds`.\n" ++- "\n" ++- "  An exclamation mark (!) as in `R! foo.c`, means the change is known to\n" ++- "  conflict with a change in another patch.  The phrase `duplicated`\n" ++- "  means the change is known to be identical to a change in another patch.\n" ++- "\n" ++- "The `--machine-readable` option implies `--summary` while making it more\n" ++- "parsable. Modified files are only shown as `M f`, and moves are shown in\n" ++- "two lines: `F f` and `T g` (as in 'From f To g').\n" ++- "\n" ++- "By default, `darcs whatsnew` uses Darcs' internal format for changes.\n" ++- "To see some context (unchanged lines) around each change, use the\n" ++- "`--unified` option.  To view changes in conventional `diff` format, use\n" ++- "the `darcs diff` command; but note that `darcs whatsnew` is faster.\n" ++- "\n" ++- "This command exits unsuccessfully (returns a non-zero exit status) if\n" ++- "there are no unrecorded changes.\n"+  formatWords+  [ "The `darcs whatsnew` command lists unrecorded changes to the working"+  , "tree.  If you specify a set of files and directories, only unrecorded"+  , "changes to those files and directories are listed."+  ]+  $+$ formatWords+  [ "With the `--summary` option, the changes are condensed to one line per"+  , "file, with mnemonics to indicate the nature and extent of the change."+  , "The `--look-for-adds` option causes candidates for `darcs add` to be"+  , "included in the summary output.  WithSummary mnemonics are as follows:"+  ]+  -- TODO autoformat bullet lists+  $+$ vcat+  [ "  * `A f` and `A d/` respectively mean an added file or directory."+  , "  * `R f` and `R d/` respectively mean a removed file or directory."+  , "  * `M f -N +M rP` means a modified file, with `N` lines deleted, `M`"+  , "    lines added, and `P` lexical replacements."+  , "  * `f -> g` means a moved file or directory."+  , "  * `a f` and `a d/` respectively mean a new, but unadded, file or"+  , "    directory, when using `--look-for-adds`."+  , "  * An exclamation mark (!) as in `R! foo.c`, means the change"+  , "    conflicts with a change in an earlier patch. The phrase `duplicated`"+  , "    means the change is identical to a change in an earlier patch."+  ]+  $+$ formatWords+  [ "The `--machine-readable` option implies `--summary` while making it more"+  , "parsable. Modified files are only shown as `M f`, and moves are shown in"+  , "two lines: `F f` and `T g` (as in 'From f To g')."+  ]+  $+$ formatWords+  [ "By default, `darcs whatsnew` uses Darcs' internal format for changes."+  , "To see some context (unchanged lines) around each change, use the"+  , "`--unified` option.  To view changes in conventional `diff` format, use"+  , "the `darcs diff` command; but note that `darcs whatsnew` is faster."+  ]+  $+$ formatWords+  [ "This command exits unsuccessfully (returns a non-zero exit status) if"+  , "there are no unrecorded changes."+  ]  whatsnewCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () whatsnewCmd fps opts args =    withRepository (useCache ? opts) $ RepoJob $ \(repo :: Repository rt p wR wU wR) -> do     let scan = scanKnown (lookForAdds opts) (O.includeBoring ? opts)     existing_files <- do-      files <- if null args then return Nothing-               else Just . nubSort <$> fixSubPaths fps args-      when (files == Just []) $ fail "No valid arguments were given."+      files <- pathSetFromArgs fps args       files' <- traverse         (filterExistingPaths           repo (verbosity ? opts) (useIndex ? opts) scan (lookForMoves opts))@@ -252,7 +256,7 @@     if maybeIsInteractive opts       then         runInteractive (interactiveHunks pristine) (patchSelOpts opts)-          (diffAlgorithm ? opts) pristine allInterestingChanges+          pristine allInterestingChanges       else         if haveLookForAddsAndSummary           then do@@ -294,50 +298,39 @@      -- Appropriately print changes, according to the passed flags.     -- Note this cannot make distinction between unadded and added files.-    printChanges :: ( IsHunk p, ShowPatch p, ShowContextPatch p-                    , PatchListFormat p, Apply p-                    , PrimDetails p, ApplyState p ~ Tree)+    printChanges :: ( PrimPatch p, ApplyState p ~ Tree)                  => Tree IO -> FL p wX wY                  -> IO ()     printChanges pristine changes         | haveSummary = putDocLn $ plainSummaryPrims machineReadable changes         | O.yes (withContext ? opts) = contextualPrintPatch pristine changes-        | otherwise = printPatch 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 wT. (RepoPatch p, ApplyState p ~ Tree)+    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 wT -> Maybe [SubPath]-                              -> IO (Sealed (FL (PrimOf p) wT))-    filteredUnrecordedChanges diffing lfm lfr repo files =-        let filePaths = map toFilePath <$> files in-        choosePreTouching filePaths <$>-          unrecordedChanges diffing lfm lfr repo files+                              -> Repository rt p wR wU wR+                              -> Maybe [AnchoredPath]+                              -> IO (Sealed (FL (PrimOf p) wR))+    filteredUnrecordedChanges diffing lfm lfr repo paths =+        chooseTouching paths <$> unrecordedChanges diffing lfm lfr repo paths  -- | Runs the 'InteractiveSelectionM' code-runInteractive :: PrimPatch p-               => InteractiveSelectionM p wX wY () -- Selection to run+runInteractive :: InteractiveSelectionM p wX wY () -- Selection to run                -> S.PatchSelectionOptions-               -> O.DiffAlgorithm                -> Tree IO         -- Pristine                -> FL p wX wY      -- A list of patches                -> IO ()-runInteractive i patchsel diffalg pristine ps' = do+runInteractive i patchsel pristine ps' = do     let lps' = labelPatches Nothing ps'         choices' = mkPatchChoices lps'-        ps = evalStateT i $-             ISC { total   = lengthFL lps'-                 , current = 0-                 , lps     = FZipper NilRL lps'-                 , choices = choices'-                 }-    void $ runReaderT ps $-           selectionContextPrim First "view" patchsel-             (Just (primSplitter diffalg))-             Nothing (Just pristine)+        ps = evalStateT i (initialSelectionState lps' choices')+    void $+      runReaderT ps $+        selectionConfigPrim First "view" patchsel Nothing Nothing (Just pristine)  -- | The interactive part of @darcs whatsnew@ interactiveHunks :: (IsHunk p, ShowPatch p, ShowContextPatch p, Commute p,@@ -348,7 +341,7 @@     case c of         Nothing -> liftIO $ putStrLn "No more changes!"         Just (Sealed2 lp) -> do-            liftIO $ printPatch (unLabel lp)+            liftIO $ printPatchPager (unLabel lp)             repeatThis lp   where     repeatThis lp = do@@ -361,7 +354,7 @@             'v' -> liftIO (contextualPrintPatch pristine (unLabel lp))                    >> repeatThis lp             -- View summary of the change-            'x' -> liftIO (printSummary (unLabel lp))+            'x' -> liftIO (putDocLn $ summary $ unLabel lp)                    >> repeatThis lp             -- View change and move on             'y' -> liftIO (contextualPrintPatch pristine (unLabel lp))@@ -409,21 +402,22 @@     basic_options = [ options_yn ]     adv_options = [ optionsView, optionsNav ] +printPatchPager :: ShowPatchBasic p => p wX wY -> IO ()+printPatchPager = viewDocWith fancyPrinters . displayPatch --- | status is an alias for whatsnew, with implicit Summary and LookForAdds--- flags. We override the default description, to include the implicit flags.-status :: DarcsCommand [DarcsFlag]+-- | 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-    , commandParseOptions = onormalise statusOpts     }   where     statusAlias = commandAlias "status" Nothing whatsnew-    statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."+    statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls`."     statusBasicOpts       = O.maybeSummary (Just O.YesSummary)       ^ O.withContext
− src/Darcs/UI/CommandsAux.hs 
@@ -1,78 +0,0 @@--- Copyright (C) 2006 Tommy Pettersson <ptp@lysator.liu.se>------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.UI.CommandsAux-    ( checkPaths-    , maliciousPatches-    , hasMaliciousPath-    ) where--import Prelude ()-import Darcs.Prelude--import Control.Monad ( when )--import Darcs.UI.Flags ( DarcsFlag )-import Darcs.UI.Options ( parseFlags )-import Darcs.UI.Options.All ( restrictPaths )-import Darcs.Patch.Inspect ( PatchInspect, listTouchedFiles )-import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )-import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2 )-import Darcs.Util.Path ( isMaliciousPath )---- * File paths-{--  Darcs will operate on files and directories with the invoking user's-  privileges. The paths for these files and directories are stored in-  patches, which darcs receives in various ways. Even though darcs will not-  create patches with "unexpected" file paths, there are no such guarantees-  for received patches. A spoofed patch could inflict changes on any file-  or directory which the invoking user is privileged to modify.--  There is no one single "apply" function that can check paths, so each-  command is responsible for not applying patches without first checking-  them with one of these function when appropriate.--}--{- |-  A convenience function to call from all darcs command functions before-  applying any patches. It checks for malicious paths in patches, and-  prints an error message and fails if it finds one.--}-checkPaths :: PatchInspect p => [DarcsFlag] -> FL p wX wY -> IO ()-checkPaths opts patches-  = when (parseFlags restrictPaths opts && or (mapFL hasMaliciousPath patches)) $-        fail $ unlines $ ["Malicious path in patch:"] ++-                         map ("    " ++) (concat $ mapFL maliciousPaths patches) ++-                         ["", "If you are sure this is ok then you can run again with the --dont-restrict-paths option."]-           -- TODO: print patch(es)-           -- NOTE: should use safe Doc printer, this can be evil chars---- | Filter out patches that contains some malicious file path-maliciousPatches :: PatchInspect p => [Sealed2 p] -> [Sealed2 p]-maliciousPatches = filter (unseal2 hasMaliciousPath)--hasMaliciousPath :: PatchInspect p => p wX wY -> Bool-hasMaliciousPath patch =-    case maliciousPaths patch of-      [] -> False-      _ -> True--maliciousPaths :: PatchInspect p => p wX wY -> [String]-maliciousPaths patch =-  let paths = listTouchedFiles patch in-    filter isMaliciousPath paths
src/Darcs/UI/Completion.hs view
@@ -1,11 +1,10 @@ -- | How to complete arguments-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns #-} module Darcs.UI.Completion     ( fileArgs, knownFileArgs, unknownFileArgs, modifiedFileArgs     , noArgs, prefArgs     ) where -import Prelude () import Darcs.Prelude  import Data.List ( (\\), stripPrefix )@@ -110,7 +109,7 @@   case uncurry makeSubPathOf fps of     Nothing -> return []     Just here ->-      return $ mapMaybe (stripPathPrefix (toPath here) . drop 2) new+      return $ mapMaybe (stripPathPrefix (toPath here)) $ map (anchorPath "") new  -- | Return the available prefs of the given kind. prefArgs :: String@@ -127,9 +126,9 @@ -- * unexported helper functions  data RepoTrees m = RepoTrees-  { have  :: Tree m -- ^ working tree-  , known :: Tree m -- ^ recorded and pending-  , new :: [FilePath] -- ^ unrecorded paths+  { have  :: Tree m       -- ^ working tree+  , known :: Tree m       -- ^ recorded and pending+  , new :: [AnchoredPath] -- ^ unrecorded paths   }  repoTrees :: O.UseIndex -> O.ScanKnown -> O.LookForMoves -> O.LookForReplaces
src/Darcs/UI/Defaults.hs view
@@ -1,6 +1,5 @@ module Darcs.UI.Defaults ( applyDefaults ) where -import Prelude () import Darcs.Prelude  import Control.Monad.Writer@@ -20,7 +19,6 @@  import Darcs.UI.Commands     ( DarcsCommand(..), commandAlloptions, extractAllCommands-    , WrappedCommand(..)     ) import Darcs.UI.TheCommands ( commandControlList ) import Darcs.Util.Path ( AbsolutePath )@@ -52,13 +50,14 @@ -- Errors encountered during processing of command line or defaults flags -- are formatted and added as (separate) strings to the list of error messages -- that are returned together with the resulting flag list.-applyDefaults :: Maybe String-              -> DarcsCommand pf-              -> AbsolutePath-              -> [String]-              -> [String]-              -> [DarcsFlag]-              -> ([DarcsFlag], [String])+applyDefaults :: 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     cl_flags  <- runChecks "Command line" check_opts flags     user_defs <- get_flags "User defaults" user@@ -104,11 +103,6 @@ --  * lines matching @ALL@: there must be at least *some* darcs command with --    that option. ----- It is debatable whether these checks are useful. On the one hand they can help--- detect typos in defaults files. On the other hand they make it difficult to--- use different versions of darcs in parallel: a default for an option that is--- only available in a later version will make the earlier version produce an--- error. Maybe reduce this to a warning? parseDefaults :: String               -> AbsolutePath               -> CmdName@@ -236,5 +230,5 @@ -- | List of option switches of all commands (except help but that has no options). allOptionSwitches :: [String] allOptionSwitches = nub $ optionSwitches $-  concatMap (\(WrappedCommand c) -> uncurry (++) . commandAlloptions $ c) $+  concatMap (uncurry (++) . commandAlloptions) $             extractAllCommands commandControlList
src/Darcs/UI/Email.hs view
@@ -6,7 +6,6 @@     , prop_qp_roundtrip     ) where -import Prelude () import Darcs.Prelude  import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper )
src/Darcs/UI/External.hs view
@@ -8,7 +8,6 @@     , signString     , verifyPS     , execDocPipe-    , execPipeIgnoreError     , pipeDoc     , pipeDocSSH     , viewDoc@@ -19,20 +18,17 @@     , darcsProgram     , editText     , editFile-    , catchall     --  * Locales     , setDarcsEncodings     , getSystemEncoding     , isUTF8Locale     ) where -import Prelude () import Darcs.Prelude-import Darcs.Util.Text ( showCommandLine )  import Data.Maybe ( isJust, isNothing, maybeToList ) import Control.Monad ( unless, when, filterM, liftM2, void )-import GHC.MVar ( MVar )+import Control.Concurrent.MVar ( MVar ) import System.Exit ( ExitCode(..) ) import System.Environment     ( getEnv@@ -46,10 +42,12 @@ import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) ) import System.Process.Internals ( ProcessHandle ) +#ifndef WIN32 import GHC.IO.Encoding     ( getFileSystemEncoding     , setForeignEncoding     , setLocaleEncoding )+#endif  import Foreign.C.String ( CString, peekCString ) @@ -68,7 +66,6 @@ import Darcs.Util.Lock ( canonFilename, writeDocBinFile ) #endif -import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.UI.Options.All ( Sign(..), Verify(..), Compression(..) ) import Darcs.Util.Path     ( AbsolutePath@@ -90,6 +87,7 @@     ) import Darcs.Util.Ssh ( getSSH, SSHCmd(..) ) import Darcs.Util.CommandLine ( parseCmd, addUrlencoded )+import Darcs.Util.Exception ( catchall ) import Darcs.Util.Exec ( execInteractive, exec, Redirect(..), withoutNonBlock ) import Darcs.Util.URL ( SshFilePath, sshUhost ) import Darcs.Util.Printer ( Doc, Printers, hPutDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS,@@ -126,7 +124,7 @@  pipeDocInternal :: WhereToPipe -> String -> [String] -> Doc -> IO ExitCode pipeDocInternal whereToPipe c args inp = withoutNonBlock $ withoutProgress $-    do debugMessage $ "Exec: " ++ showCommandLine (c:args)+    do debugMessage $ "Exec: " ++ unwords (map show (c:args))        (Just i,_,_,pid) <- createProcess (proc c args){ std_in = CreatePipe                                                       , delegate_ctlc = True}        debugMessage "Start transferring data"@@ -321,15 +319,6 @@                           "' failed with exit code "++ show ec          ExitSuccess -> return $ packedString out --- The following is needed for diff, which returns non-zero whenever--- the files differ.-execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc-execPipeIgnoreError c args instr = withoutProgress $ do-       (pid, mvare, out) <- execAndGetOutput c args instr-       _ <- waitForProcess pid-       takeMVar mvare-       return $ if B.null out then empty else packedString out- signString :: Sign -> Doc -> IO Doc signString NoSign d = return d signString Sign d = signPGP [] d@@ -507,12 +496,13 @@           -> IO ExitCode runEditor f = do     ed <- getEditor-    execInteractive ed f-         `ortryrunning` execInteractive "vi" f-         `ortryrunning` execInteractive "emacs" f-         `ortryrunning` execInteractive "emacs -nw" f+    let mf = Just f+    execInteractive ed mf+         `ortryrunning` execInteractive "vi" mf+         `ortryrunning` execInteractive "emacs" mf+         `ortryrunning` execInteractive "emacs -nw" mf #ifdef WIN32-         `ortryrunning` execInteractive "edit" f+         `ortryrunning` execInteractive "edit" mf #endif  @@ -520,12 +510,6 @@ getEditor = getEnv "DARCS_EDITOR" `catchall`              getEnv "VISUAL" `catchall`              getEnv "EDITOR" `catchall` return "nano"--catchall :: IO a-         -> IO a-         -> IO a-a `catchall` b = a `catchNonSignal` (\_ -> b)-  -- | On Posix systems, GHC by default uses the user's locale encoding to -- determine how to decode/encode the raw byte sequences in the Posix API
src/Darcs/UI/Flags.hs view
@@ -18,16 +18,6 @@ {-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Flags     ( F.DarcsFlag-        -- FIXME these are temporary exceptions-        ( WorkRepoDir -- init-        , NewRepo     -- convert, clone-        , UpToPattern -- clone --to-xxx -> -xxx hack-        , UpToPatch   -- same-        , UpToHash    -- same-        , OnePattern  -- same-        , OnePatch    -- same-        , OneHash     -- same-        )     , remoteDarcs     , diffingOpts     , diffOpts@@ -49,8 +39,8 @@      , fixRemoteRepos     , fixUrl-    , fixSubPaths-    , maybeFixSubPaths+    , pathsFromArgs+    , pathSetFromArgs     , getRepourl     , getAuthor     , promptAuthor@@ -64,6 +54,8 @@     , environmentHelpSendmail     , getOutput     , getDate+    , workRepo+    , withNewRepo      -- * Re-exports     , O.compress@@ -75,7 +67,6 @@     , O.maxCount     , O.matchAny     , O.withContext-    , O.happyForwarding     , O.allowCaseDifferingFilenames     , O.allowWindowsReservedFilenames     , O.changesReverse@@ -94,13 +85,11 @@     , O.leaveTestDir     , O.remoteRepos     , O.cloneKind-    , O.workRepo     , O.patchIndexNo     , O.patchIndexYes     , O.xmlOutput     , O.selectDeps     , O.author-    , O.reply     , O.patchFormat     , O.charset     , O.siblings@@ -108,10 +97,10 @@     , O.enumPatches     ) where -import Prelude () import Darcs.Prelude -import Data.List ( nub, intercalate )+import Data.List ( intercalate )+import Data.List.Ordered ( nubSort ) import Data.Maybe     ( isJust     , maybeToList@@ -123,40 +112,43 @@ import System.FilePath.Posix ( (</>) ) import System.Environment ( lookupEnv ) -import Darcs.UI.External-    ( catchall )-import qualified Darcs.UI.Options.Flags as F ( DarcsFlag( .. ) )-import Darcs.UI.Options.Core+-- 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 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.Prompt     ( askUser     , askUserListItem     ) import Darcs.Util.Lock ( writeTextFile )+import Darcs.Repository.Flags ( WorkRepo(..) ) import Darcs.Repository.Prefs     ( getPreflist     , getGlobal     , globalPrefsDirDoc     , globalPrefsDir+    , prefsDirPath     )-import Darcs.Util.Global ( darcsdir ) import Darcs.Util.IsoDate ( getIsoDateTime, cleanLocalDate ) import Darcs.Util.Path     ( AbsolutePath     , AbsolutePathOrStd-    , SubPath     , toFilePath     , makeSubPathOf     , ioAbsolute     , makeAbsoluteOrStd+    , AnchoredPath+    , floatSubPath+    , inDarcsdir     )-import Darcs.Util.Printer ( putDocLn, ePutDocLn, text, ($$), (<+>) )+import Darcs.Util.Printer ( pathlist, putDocLn, text, ($$), (<+>) )+import Darcs.Util.Printer.Color ( ePutDocLn ) import Darcs.Util.URL ( isValidLocalPath )-import Darcs.Util.Text ( pathlist ) -type Config = [F.DarcsFlag]- verbose :: Config -> Bool verbose = (== O.Verbose) . parseFlags O.verbosity @@ -231,6 +223,8 @@  -- | 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@@ -243,6 +237,33 @@                 then toFilePath `fmap` withCurrentDirectory d (ioAbsolute f)                 else return f +-- TODO move the following four functions somewhere else,+-- they have nothing to do with flags++-- | Used by commands that expect arguments to be paths in the current repo.+-- Invalid paths are dropped and a warning is issued. This may leave no valid+-- paths to return. Although these commands all fail if there are no remaining+-- valid paths, they do so in various different ways, issuing error messages+-- tailored to the command.+pathsFromArgs :: (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]+pathsFromArgs fps args = catMaybes <$> maybeFixSubPaths fps args++-- | Used by commands that interpret a set of optional path arguments as+-- "restrict to these paths", which affects patch selection (e.g. in log+-- command) or selection of subtrees (e.g. in record). Because of the special+-- meaning of "no arguments", we must distinguish it from "no valid arguments".+-- A result of 'Nothing' here means "no restriction to the set of paths". If+-- 'Just' is returned, the set is guaranteed to be non-empty.+pathSetFromArgs :: (AbsolutePath, AbsolutePath)+                -> [String]+                -> IO (Maybe [AnchoredPath])+pathSetFromArgs _ [] = return Nothing+pathSetFromArgs fps args = do+  pathSet <- nubSort . catMaybes <$> maybeFixSubPaths fps args+  case pathSet of+    [] -> fail "No valid arguments were given."+    _ -> return $ Just pathSet+ -- | @maybeFixSubPaths (repo_path, orig_path) file_paths@ tries to turn -- @file_paths@ into 'SubPath's, taking into account the repository path and -- the original path from which darcs was invoked.@@ -258,28 +279,25 @@ -- position of the path that cannot be converted. -- -- It is intended for validating file arguments to darcs commands.-maybeFixSubPaths :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [Maybe SubPath]+maybeFixSubPaths :: (AbsolutePath, AbsolutePath) -> [String] -> IO [Maybe AnchoredPath] maybeFixSubPaths (r, o) fs = do-  fixedFs <- mapM fixit fs+  fixedFs <- mapM (fmap dropInDarcsdir . fixit) fs   let bads = snd . unzip . filter (isNothing . fst) $ zip fixedFs fs   unless (null bads) $-    ePutDocLn $ text "Ignoring non-repository paths:" <+> pathlist bads+    ePutDocLn $ text "Ignoring invalid repository paths:" <+> pathlist bads   return fixedFs  where+    dropInDarcsdir (Just p) | inDarcsdir p = Nothing+    dropInDarcsdir mp = mp+    -- special case here because fixit otherwise converts+    -- "" to (SubPath "."), which is a valid path+    fixit "" = return Nothing     fixit p = do ap <- withCurrentDirectory o $ ioAbsolute p                  case makeSubPathOf r ap of-                   Just sp -> return $ Just sp+                   Just sp -> return $ Just $ floatSubPath sp                    Nothing -> do                      absolutePathByRepodir <- withCurrentDirectory r $ ioAbsolute p-                     return $ makeSubPathOf r absolutePathByRepodir---- | 'fixSubPaths' is a variant of 'maybeFixSubPaths' that throws out--- non-repository paths and duplicates from the result. See there for details.--- TODO: why filter out null paths from the input? why here and not in--- 'maybeFixSubPaths'?-fixSubPaths :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [SubPath]-fixSubPaths fps fs = nub . catMaybes <$> maybeFixSubPaths fps-    (filter (not . null) fs)+                     return $ floatSubPath <$> makeSubPathOf r absolutePathByRepodir  -- | 'getRepourl' takes a list of flags and returns the url of the -- repository specified by @Repodir \"directory\"@ in that list of flags, if any.@@ -343,21 +361,21 @@           then longPrompt           else return str   askForAuthor storeGlobal askfn1 askfn2 = do-      aminrepo <- doesDirectoryExist (darcsdir </> "prefs")+      aminrepo <- doesDirectoryExist prefsDirPath       if aminrepo && store then do           prefsdir <- if storeGlobal                          then tryGlobalPrefsDir-                         else return $ darcsdir </> "prefs"+                         else return prefsDirPath           putDocLn $             text "Each patch is attributed to its author, usually by email address (for" $$             text "example, `Fred Bloggs <fred@example.net>').  Darcs could not determine" $$             text "your email address, so you will be prompted for it." $$             text "" $$             text ("Your address will be stored in " ++ prefsdir)-          if prefsdir /= darcsdir </> "prefs" then+          if prefsdir /= prefsDirPath then             putDocLn $               text "It will be used for all patches you record in ALL repositories." $$-              text ("If you move that file to " ++ darcsdir </> "prefs" </> "author" ++ ", it will") $$+              text ("If you move that file to " ++ prefsDirPath </> "author" ++ ", it will") $$               text "be used for patches recorded in this repository only."           else             putDocLn $@@ -374,7 +392,7 @@     case maybeprefsdir of       Nothing -> do         putStrLn "WARNING: Global preference directory could not be found."-        return $ darcsdir </> "prefs"+        return prefsDirPath       Just dir -> do exists <- doesDirectoryExist dir                      unless exists $ createDirectory dir                      return dir@@ -456,3 +474,13 @@  hasLogfile :: Config -> Maybe AbsolutePath hasLogfile = O._logfile . parseFlags O.logfile++workRepo :: Config -> WorkRepo+workRepo = oparse (O.repoDir ^ O.possiblyRemoteRepo) go+  where+    go (Just s) _ = WorkRepoDir s+    go Nothing (Just s) = WorkRepoPossibleURL s+    go Nothing Nothing = WorkRepoCurrentDir++withNewRepo :: String -> Config -> Config+withNewRepo dir = unparseOpt O.newRepo (Just dir)
src/Darcs/UI/Options.hs view
@@ -4,9 +4,9 @@     , PrimDarcsOption     , DarcsOptDescr     , optDescr+    , Config     ) where -import Prelude () import Darcs.Prelude  import Data.Functor.Compose ( getCompose )@@ -14,9 +14,11 @@  import Darcs.UI.Options.All ( DarcsOption ) import Darcs.UI.Options.Core-import Darcs.UI.Options.Util ( DarcsOptDescr, PrimDarcsOption )+import Darcs.UI.Options.Util ( DarcsOptDescr, Flag, PrimDarcsOption ) import Darcs.Util.Path ( AbsolutePath )  -- | Instantiate a 'DarcsOptDescr' with an 'AbsolutePath' optDescr :: AbsolutePath -> DarcsOptDescr f -> OptDescr f optDescr path = fmap ($ path) . getCompose++type Config = [Flag]
src/Darcs/UI/Options/All.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} {- | All the concrete options.  Notes:@@ -42,7 +41,7 @@     , Verbosity (..) -- re-export     , verbosity     , timings-    , anyVerbosity+    , debugging     , HooksConfig (..) -- re-export     , HookConfig (..) -- re-export     , preHook@@ -71,13 +70,11 @@     , maxCount      -- local or remote repo(s)-    , WorkRepo (..) -- re-export-    , workRepo     , repoDir     , RemoteRepos (..) -- re-export     , remoteRepos     , possiblyRemoteRepo-    , reponame+    , newRepo     , NotInRemote (..)     , notInRemote     , notInRemoteFlagName@@ -89,6 +86,8 @@     , withWorkingDir     , SetDefault (..) -- re-export     , setDefault+    , InheritDefault (..) -- re-export+    , inheritDefault      -- patch meta-data     , patchname@@ -145,9 +144,6 @@     , sendmailCmd     , charset     , editDescription-    , ccApply-    , reply-    , happyForwarding      -- patch bundles     , applyAs@@ -162,6 +158,7 @@     , conflictsYes     , ExternalMerge (..) -- re-export     , externalMerge+    , reorder      -- optimizations     , Compression (..) -- re-export@@ -171,15 +168,14 @@     , patchIndexNo     , patchIndexYes     , Reorder (..) -- re-export-    , reorder     , minimize     , storeInMemory      -- miscellaneous     , Output (..)     , output-    , Summary (..)-    , summary+    , WithSummary (..)+    , withSummary     , maybeSummary     , RemoteDarcs (..) -- re-export     , NetworkOptions (..)@@ -188,7 +184,6 @@     , umask     , SetScriptsExecutable (..) -- re-export     , setScriptsExecutable-    , restrictPaths      -- command specific @@ -243,16 +238,10 @@      -- optimize     , siblings-    , optimizePatchIndex     ) where -import Prelude () import Darcs.Prelude -import Prelude hiding ( (^) )-import Data.Char ( isDigit )-import Data.List ( intercalate )- import Darcs.Repository.Flags     ( Compression (..)     , RemoteDarcs (..)@@ -270,11 +259,11 @@     , LeaveTestDir (..)     , RemoteRepos (..)     , SetDefault (..)+    , InheritDefault (..)     , UseIndex (..)     , ScanKnown (..)     , CloneKind (..)     , ExternalMerge (..)-    , WorkRepo (..)     , AllowConflicts (..)     , WantGuiPause (..)     , WithPatchIndex (..)@@ -373,6 +362,10 @@   yes NoEnumPatches = False   yes YesEnumPatches = True +instance YesNo InheritDefault where+  yes NoInheritDefault = False+  yes YesInheritDefault = True+ -- * Root command  -- | Options for darcs iself that act like sub-commands.@@ -399,7 +392,7 @@ stdCmdActions :: PrimDarcsOption (Maybe StdCmdAction) stdCmdActions = withDefault Nothing   [ RawNoArg [] ["help"] F.Help (Just Help)-    "show a brief description of the command and its options"+    "show a description of the command and its options"   , RawNoArg [] ["list-options"] F.ListOptions (Just ListOptions)     "show plain list of available options and commands, for auto-completion"   , RawNoArg [] ["disable"] F.Disable (Just Disable) "disable this command" ]@@ -407,7 +400,7 @@ -- ** Verbosity related  debug :: PrimDarcsOption Bool-debug = singleNoArg [] ["debug"] F.Debug "give only debug output"+debug = singleNoArg [] ["debug"] F.Debug "enable general debug output"  debugHttp :: PrimDarcsOption Bool debugHttp = singleNoArg [] ["debug-http"] F.DebugHTTP "debug output from libcurl"@@ -417,13 +410,13 @@   [ RawNoArg ['q'] ["quiet"] F.Quiet Quiet "suppress informational output"   , RawNoArg [] ["standard-verbosity"] F.NormalVerbosity NormalVerbosity       "neither verbose nor quiet output"-  , RawNoArg ['v'] ["verbose"] F.Verbose Verbose "give verbose output" ]+  , RawNoArg ['v'] ["verbose"] F.Verbose Verbose "enable verbose output" ]  timings :: PrimDarcsOption Bool timings = singleNoArg [] ["timings"] F.Timings "provide debugging timings information" -anyVerbosity :: DarcsOption a (Bool -> Bool -> Verbosity -> Bool -> a)-anyVerbosity = debug ^ debugHttp ^ verbosity ^ timings where+debugging :: DarcsOption a (Bool -> Bool -> Bool -> a)+debugging = debug ^ debugHttp ^ timings  -- ** Hooks @@ -480,12 +473,10 @@  -- * Interactivity related -{- TODO: these options interact (no pun intended) in complex ways that are+{- TODO: These options interact (no pun intended) in complex ways that are very hard to figure out for users as well as maintainers. I think the only solution here is a more radical (and probably incompatible) re-design-involving all interactivity related options. That is beyond the goals of-this sub-project (which is already large enough).--}+involving all interactivity related options. -}  data XmlOutput = NoXml | YesXml deriving (Eq, Show) @@ -549,52 +540,31 @@   [ RawNoArg [] ["reverse"] F.Reverse True "show/consider changes in reverse order"   , RawNoArg [] ["no-reverse"] F.Forward False "show/consider changes in the usual order" ] --- | TODO: Returning @-1@ if the argument cannot be parsed as an integer is--- not something I expected to find in a Haskell program. Instead, the flag--- should take either a plain 'String' argument (leaving it to a later stage--- to parse the 'String' to an 'Int'), or else a @'Maybe' 'Int'@, taking--- the possibility of a failed parse into account. maxCount :: PrimDarcsOption (Maybe Int)-maxCount = (withDefault Nothing-    [ RawStrArg [] ["max-count"] F.MaxCount unF toV unV "NUMBER"-      "return only NUMBER results" ])-    {ocheck=check}+maxCount = withDefault Nothing+  [ RawStrArg [] ["max-count"] F.MaxCount unF toV unV "NUMBER" "return only NUMBER results" ]   where     unF f = [ s | F.MaxCount s <- [f] ]-    unV x = [ show s | Just s <- [x] ]-    toV s = if good s then Just (read s) else Nothing-    check fs =-      [ "invalid argument to --max-count: '"++s++"'" | s <- args, not (good s) ] ++-      if length args > 1-        then ["conflicting flags: " ++ intercalate ", " (map ("--max-count="++) args)]-        else []-      where-        args = [ s | F.MaxCount s <- fs ]-    good s = not (null s) && all isDigit s+    unV x = [ showIntArg n | Just n <- [x] ]+    toV = Just . parseIntArg "count" (>=0)  -- * Local or remote repo -workRepo :: PrimDarcsOption WorkRepo-workRepo = imap (Iso fw bw) $ repoDir ^ possiblyRemoteRepo where-  fw k (WorkRepoDir s)         = k (Just s) Nothing-  fw k (WorkRepoPossibleURL s) = k Nothing  (Just s)-  fw k WorkRepoCurrentDir      = k Nothing  Nothing-  bw k (Just s) _              = k (WorkRepoDir s)-  bw k Nothing  (Just s)       = k (WorkRepoPossibleURL s)-  bw k Nothing  Nothing        = k WorkRepoCurrentDir- repoDir :: PrimDarcsOption (Maybe String) repoDir = singleStrArg [] ["repodir"] F.WorkRepoDir arg "DIRECTORY"     "specify the repository directory in which to run"   where arg (F.WorkRepoDir s) = Just s         arg _ = Nothing --- | @--repodir@ is there for compatibility, should be removed eventually+-- | This option is for when a new repo gets created. Used for clone, convert+-- import, convert darcs-2, and initialize. For clone and initialize it has the+-- same effect as giving the name as a normal argument. ----- IMHO the whole option can disappear; it overlaps with using an extra (non-option)--- argument, which is how e.g. @darcs get@ is usually invoked.-reponame :: PrimDarcsOption (Maybe String)-reponame = singleStrArg [] ["repo-name","repodir"] F.NewRepo arg "DIRECTORY" "path of output directory"+-- The @--repodir@ alias is there for compatibility, should be removed eventually.+--+-- TODO We need a way to deprecate options / option names.+newRepo :: PrimDarcsOption (Maybe String)+newRepo = singleStrArg [] ["repo-name","repodir"] F.NewRepo arg "DIRECTORY" "path of output directory"   where arg (F.NewRepo s) = Just s; arg _ = Nothing  possiblyRemoteRepo :: PrimDarcsOption (Maybe String)@@ -652,15 +622,20 @@ withWorkingDir :: PrimDarcsOption WithWorkingDir withWorkingDir = withDefault WithWorkingDir   [ RawNoArg [] ["with-working-dir"] F.UseWorkingDir WithWorkingDir-    "Create a working directory (normal repository)"+    "Create a working tree (normal repository)"   , RawNoArg [] ["no-working-dir"] F.UseNoWorkingDir NoWorkingDir-    "Do not create a working directory (bare repository)" ]+    "Do not create a working tree (bare repository)" ]  setDefault :: PrimDarcsOption (Maybe Bool) setDefault = withDefault Nothing   [ RawNoArg [] ["set-default"] F.SetDefault (Just True) "set default repository"   , RawNoArg [] ["no-set-default"] F.NoSetDefault (Just False) "don't set default repository" ] +inheritDefault :: PrimDarcsOption InheritDefault+inheritDefault = withDefault NoInheritDefault+  [ RawNoArg [] ["inherit-default"] F.InheritDefault YesInheritDefault "inherit default repository"+  , RawNoArg [] ["no-inherit-default"] F.NoInheritDefault NoInheritDefault "don't inherit default repository" ]+ -- * Specifying patch meta-data  patchname :: PrimDarcsOption (Maybe String)@@ -678,7 +653,6 @@ data AskLongComment = NoEditLongComment | YesEditLongComment | PromptLongComment   deriving (Eq, Show) --- TODO: fix non-default behavior askLongComment :: PrimDarcsOption (Maybe AskLongComment) askLongComment = withDefault Nothing   [ RawNoArg [] ["edit-long-comment"] F.EditLongComment (Just YesEditLongComment)@@ -967,27 +941,6 @@   , RawNoArg [] ["dont-edit-description","no-edit-description"] F.NoEditDescription False     "don't edit the patch bundle description" ] --- TODO: turn these two into a combined option--ccApply :: PrimDarcsOption (Maybe String)-ccApply = singleStrArg [] ["cc"] F.Cc arg-    "EMAIL" "mail results to additional EMAIL(s). Requires --reply"-  where arg (F.Cc s) = Just s-        arg _ = Nothing--reply :: PrimDarcsOption (Maybe String)-reply = singleStrArg [] ["reply"] F.Reply arg "FROM"-    "reply to email-based patch using FROM address"-  where arg (F.Reply s) = Just s-        arg _ = Nothing--happyForwarding :: PrimDarcsOption Bool-happyForwarding = withDefault False-  [ RawNoArg [] ["happy-forwarding"] F.HappyForwarding True-    "forward unsigned messages without extra header"-  , RawNoArg [] ["no-happy-forwarding"] F.NoHappyForwarding False-    "don't forward unsigned messages without extra header" ]- -- * Patch bundle related  applyAs :: PrimDarcsOption (Maybe String)@@ -1064,6 +1017,14 @@     fw k (YesExternalMerge s) = k (Just s)     fw k NoExternalMerge = k Nothing +-- | pull, apply, rebase pull, rebase apply+reorder :: PrimDarcsOption Reorder+reorder = withDefault NoReorder+  [ RawNoArg [] ["reorder-patches"] F.Reorder Reorder+    "put local-only patches on top of remote ones"+  , RawNoArg [] ["no-reorder-patches"] F.NoReorder NoReorder+    "put remote-only patches on top of local ones" ]+ -- * Optimizations  compress :: PrimDarcsOption Compression@@ -1122,15 +1083,15 @@  -- * Miscellaneous -data Summary = NoSummary | YesSummary deriving (Eq, Show)+data WithSummary = NoSummary | YesSummary deriving (Eq, Show) -instance YesNo Summary where+instance YesNo WithSummary where   yes NoSummary = False   yes YesSummary = True  -- all commands except whatsnew-summary :: PrimDarcsOption Summary-summary = (imap . cps) (Iso fw bw) $ maybeSummary Nothing+withSummary :: PrimDarcsOption WithSummary+withSummary = (imap . cps) (Iso fw bw) $ maybeSummary Nothing   where     fw Nothing = NoSummary     fw (Just NoSummary) = NoSummary@@ -1139,7 +1100,7 @@     bw YesSummary = Just YesSummary  -- needed for whatsnew-maybeSummary :: Maybe Summary -> PrimDarcsOption (Maybe Summary)+maybeSummary :: Maybe WithSummary -> PrimDarcsOption (Maybe WithSummary) maybeSummary def = withDefault def   [ RawNoArg ['s'] ["summary"] F.Summary (Just YesSummary) "summarize changes"   , RawNoArg [] ["no-summary"] F.NoSummary (Just NoSummary) "don't summarize changes" ]@@ -1182,14 +1143,6 @@   , RawNoArg [] ["dont-set-scripts-executable","no-set-scripts-executable"]     F.DontSetScriptsExecutable NoSetScriptsExecutable "don't make scripts executable" ] -restrictPaths :: PrimDarcsOption Bool-restrictPaths = withDefault True-  [ RawNoArg [] ["restrict-paths"] F.RestrictPaths True-    "don't allow darcs to touch external files or repo metadata"-  , RawNoArg [] ["dont-restrict-paths","no-restrict-paths"]-    F.DontRestrictPaths False-    "allow darcs to modify any file or directory (unsafe)" ]- -- * Specific to a single command  -- ** amend@@ -1211,10 +1164,10 @@   , __machineReadable True ]  __humanReadable :: RawDarcsOption-__humanReadable val = RawNoArg [] ["human-readable"] F.HumanReadable val "give human-readable output"+__humanReadable val = RawNoArg [] ["human-readable"] F.HumanReadable val "normal human-readable output"  __machineReadable :: RawDarcsOption-__machineReadable val = RawNoArg [] ["machine-readable"] F.MachineReadable val "give machine-readable output"+__machineReadable val = RawNoArg [] ["machine-readable"] F.MachineReadable val "machine-readable output"  -- ** clone @@ -1249,7 +1202,9 @@  patchFormat :: PrimDarcsOption PatchFormat patchFormat = withDefault PatchFormat2-  [ RawNoArg [] ["darcs-2"] F.UseFormat2 PatchFormat2+  [ RawNoArg [] ["darcs-3"] F.UseFormat3 PatchFormat3+    "New darcs patch format"+  , RawNoArg [] ["darcs-2"] F.UseFormat2 PatchFormat2     "Standard darcs patch format"   , RawNoArg [] ["darcs-1"] F.UseFormat1 PatchFormat1     "Older patch format (for compatibility)" ]@@ -1277,7 +1232,7 @@  changesFormat :: PrimDarcsOption (Maybe ChangesFormat) changesFormat = withDefault Nothing-  [ RawNoArg [] ["context"] F.GenContext (Just GenContext) "give output suitable for clone --context"+  [ RawNoArg [] ["context"] F.GenContext (Just GenContext) "produce output suitable for clone --context"   , __xmloutput (Just GenXml)   , __humanReadable (Just HumanReadable)   , __machineReadable (Just MachineReadable)@@ -1354,15 +1309,3 @@ siblings = multiAbsPathArg [] ["sibling"] F.Sibling mkV "DIRECTORY"     "specify a sibling directory"   where mkV fs = [ s | F.Sibling s <- fs ]--reorder :: PrimDarcsOption Reorder-reorder = withDefault NoReorder-  [ RawNoArg [] ["reorder-patches"] F.Reorder Reorder-    "reorder the patches in the repository"-  , RawNoArg [] ["no-reorder-patches"] F.NoReorder NoReorder-    "don't reorder the patches in the repository" ]--optimizePatchIndex :: PrimDarcsOption (Maybe WithPatchIndex)-optimizePatchIndex = withDefault Nothing-  [ __patchIndex (Just YesPatchIndex)-  , __noPatchIndex (Just NoPatchIndex) ]
src/Darcs/UI/Options/Core.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} {-| Option specifications using continuations with a changing answer type.  Based on@@ -32,7 +31,6 @@ -} module Darcs.UI.Options.Core where -import Prelude () import Darcs.Prelude  import Darcs.UI.Options.Iso@@ -226,9 +224,7 @@ -- ** Derived combinators  -- | Normalise a flag list by parsing and then unparsing it. This adds all--- implicit (default) flags to the list, which is useful as long as there is--- legacy code that circumvents the 'OptSpec' abstraction and directly tests--- for flag membership.+-- implicit (default) flags to the list. -- -- prop> onormalise opts = (oparse opts . ounparse opts) id onormalise :: OptSpec d f [f] b -> [f] -> [f]@@ -299,7 +295,11 @@ parseFlags :: (forall a. PrimOptSpec d f a v) -> [f] -> v parseFlags o fs = oparse o id fs --- no assoiativity, higher precedence than comparisons operators (4)+-- | Unparse a primitive option spec and append it to a list of flags.+unparseOpt :: (forall a. PrimOptSpec d f a v) -> v -> [f] -> [f]+unparseOpt o v fs = ounparse o (\xfs -> fs ++ xfs) v++-- no associativity, higher precedence than comparisons operators (4) -- and lower than arithemic operators (6,7,8) infix 5 ?
src/Darcs/UI/Options/Flags.hs view
@@ -3,7 +3,6 @@ -- should import 'Darcs.UI.Flags' module Darcs.UI.Options.Flags ( DarcsFlag(..) ) where -import Prelude () import Darcs.Prelude  import Darcs.Util.Path ( AbsolutePath, AbsolutePathOrStd )@@ -24,7 +23,8 @@                | OneHash String                | AfterPatch String | UpToPatch String                | AfterHash String | UpToHash String-               | TagName String | LastN Int | MaxCount String | PatchIndexRange Int Int+               | TagName String | LastN String | MaxCount String+               | IndexRange String | OneIndex String                | NumberPatches                | OneTag String | AfterTag String | UpToTag String                | GenContext | Context AbsolutePath | Count@@ -73,11 +73,13 @@                | AfterPattern String | UpToPattern String                | NonApply | NonVerify | NonForce                | DryRun+               | InheritDefault | NoInheritDefault                | SetDefault | NoSetDefault                | Disable | SetScriptsExecutable | DontSetScriptsExecutable                | Once | Linear | Backoff | Bisect                | Hashed -- deprecated flag, here to output an error message-               | UseFormat1 | UseFormat2 | UseNoWorkingDir | UseWorkingDir+               | UseFormat1 | UseFormat2 | UseFormat3+               | UseNoWorkingDir | UseWorkingDir                | Sibling AbsolutePath                | Files | NoFiles | Directories | NoDirectories                | Pending | NoPending
src/Darcs/UI/Options/Iso.hs view
@@ -1,6 +1,5 @@ module Darcs.UI.Options.Iso where -import Prelude () import Darcs.Prelude  -- * Isomorphisms
src/Darcs/UI/Options/Markdown.hs view
@@ -1,7 +1,6 @@ -- Support for @darcs help markdown@ module Darcs.UI.Options.Markdown ( optionsMarkdown ) where -import Prelude () import Darcs.Prelude  import Data.Functor.Compose ( Compose(..) )
src/Darcs/UI/Options/Matching.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} {-| Patch matching options.  These are all of the same type 'MatchOption' defined below.@@ -20,6 +19,7 @@     , matchSeveralOrFirst     , matchSeveralOrLast     , matchRange+    , matchOneOrRange     , matchSeveralOrRange     -- * exported for for checking     , context@@ -28,11 +28,8 @@     , matchAny -- temporary hack     ) where -import Prelude () import Darcs.Prelude hiding ( last ) -import Data.Char ( isDigit )- import Darcs.Patch.Match ( MatchFlag(..) ) import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) ) import Darcs.UI.Options.Core@@ -78,8 +75,12 @@ matchSeveralOrLast = mconcat [ matchFrom, last, matches, patches, tags, hash ]  -- | Used by: diff+matchOneOrRange :: MatchOption+matchOneOrRange = mconcat [ match, patch, hash ] <> matchRange++-- | Used by: show dependencies matchRange :: MatchOption-matchRange = mconcat [ matchTo, matchFrom, match, patch, hash, last, indexes ]+matchRange = mconcat [ matchTo, matchFrom, last, indexes ]  -- | Used by: log matchSeveralOrRange :: MatchOption@@ -219,34 +220,22 @@     "select patches matching PATTERN" ]  last = OptSpec {..} where-  ounparse k mfs = k [ F.LastN s | LastN s <- mfs ]-  oparse k fs = k [ LastN s | F.LastN s <- fs ]+  ounparse k mfs = k [ F.LastN (showIntArg n) | LastN n <- mfs ]+  oparse k fs = k [ LastN (argparse s) | F.LastN s <- fs ]   ocheck _ = []-  odesc = [ strArg [] ["last"] (F.LastN . toInt) "NUMBER"-    "select the last NUMBER patches" ]-  toInt s = if not (null s) && all isDigit s then read s else (-1)+  odesc = [ strArg [] ["last"] F.LastN "NUMBER" "select the last NUMBER patches" ]+  argparse = parseIntArg "count" (>=0) --- | TODO: see 'Darcs.UI.Options.maxCount'. index = OptSpec {..} where-  ounparse k mfs = k [ F.PatchIndexRange n m | PatchIndexRange n m <- mfs ]-  oparse k fs = k [ PatchIndexRange n m | F.PatchIndexRange n m <- fs ]+  ounparse k mfs = k [ F.OneIndex (showIntArg n) | OneIndex n <- mfs ]+  oparse k fs = k [ OneIndex (argparse s) | F.OneIndex s <- fs ]   ocheck _ = []-  odesc = [ strArg ['n'] ["index"] indexrange "N" "select one patch" ]-  indexrange s = if all isDigit s-                 then F.PatchIndexRange (read s) (read s)-                 else F.PatchIndexRange 0 0+  odesc = [ strArg ['n'] ["index"] F.OneIndex "N" "select one patch" ]+  argparse = parseIntArg "index" (>0) --- | TODO: see 'Darcs.UI.Options.maxCount'. indexes = OptSpec {..} where-  ounparse k mfs = k [ F.PatchIndexRange n m | PatchIndexRange n m <- mfs ]-  oparse k fs = k [ PatchIndexRange n m | F.PatchIndexRange n m <- fs ]+  ounparse k mfs = k [ F.IndexRange (showIndexRangeArg (n,m)) | IndexRange n m <- mfs ]+  oparse k fs = k [ uncurry IndexRange (argparse s) | F.IndexRange s <- fs ]   ocheck _ = []-  odesc = [ strArg ['n'] ["index"] indexrange "N-M" "select a range of patches" ]-  indexrange s = if all isokay s-                 then if '-' `elem` s-                      then let x1 = takeWhile (/= '-') s-                               x2 = reverse $ takeWhile (/= '-') $ reverse s-                           in F.PatchIndexRange (read x1) (read x2)-                      else F.PatchIndexRange (read s) (read s)-                 else F.PatchIndexRange 0 0-  isokay c = isDigit c || c == '-'+  odesc = [ strArg ['n'] ["index"] F.IndexRange "N-M" "select a range of patches" ]+  argparse = parseIndexRangeArg
src/Darcs/UI/Options/Util.hs view
@@ -1,38 +1,49 @@-{-# LANGUAGE RecordWildCards #-} -- | Constructing 'OptSpec's and 'OptDescr's module Darcs.UI.Options.Util     ( Flag-    , PrimDarcsOption+    -- * Instantiating 'OptSpec' and 'PrimOptSpec'     , DarcsOptDescr+    , PrimDarcsOption+    -- * Constructing 'DarcsOptDescr's     , noArg     , strArg     , optStrArg     , absPathArg     , absPathOrStdArg     , optAbsPathArg+      -- * Raw option specs     , RawOptSpec(..)     , withDefault+    -- * Simple primitive scalar valued options     , singleNoArg     , singleStrArg+    -- * Simple primitive list valued options     , multiStrArg     , multiOptStrArg     , singleAbsPathArg     , multiAbsPathArg     , deprecated-    -- Re-exports+    -- * Parsing/showing option arguments+    , parseIntArg+    , parseIndexRangeArg+    , showIntArg+    , showIndexRangeArg+    -- * Re-exports     , AbsolutePath     , AbsolutePathOrStd     , makeAbsolute     , makeAbsoluteOrStd     ) where -import Prelude () import Darcs.Prelude -import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) )+import Control.Exception ( Exception, throw ) import Data.Functor.Compose import Data.List ( intercalate ) import Data.Maybe ( maybeToList, fromMaybe )+import Data.Typeable ( Typeable )+import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) )+ import Darcs.UI.Options.Core import Darcs.UI.Options.Flags ( DarcsFlag ) import Darcs.UI.Options.Iso@@ -53,19 +64,19 @@ 'System.Console.GetOpt.OptDescr'. Instead we (post-) compose it with @(->) 'DarcsUtil.Path.AbsolutePath'@. Modulo newtype noise, this is the same as -@ type 'DarcsOptDescr f = 'System.Console.GetOpt.OptDescr' ('AbsolutePath' -> f)@+@ type 'DarcsOptDescr' f = 'System.Console.GetOpt.OptDescr' ('AbsolutePath' -> f)@  This is so we can pass a directory relative to which an option argument is interpreted (if it has the form of a relative path). -} type DarcsOptDescr = Compose OptDescr ((->) AbsolutePath) --- | This is 'PrimOptSpec' instantiated with 'DarcsOptDescr and 'Flag'.+-- | This is 'PrimOptSpec' instantiated with 'DarcsOptDescr' and 'Flag'. type PrimDarcsOption v = forall a. PrimOptSpec DarcsOptDescr Flag a v --- * Constructing 'OptDescr's+-- * Constructing 'DarcsOptDescr's --- | Construct an 'DarcsOptDescr with no arguments.+-- | Construct a 'DarcsOptDescr' with no arguments. noArg :: [Char] -> [String] -> f -> String -> DarcsOptDescr f noArg s l f h = Compose $ Option s l (NoArg (const f)) h @@ -74,25 +85,25 @@ type SingleArgOptDescr a f =         [Char] -> [String] -> (a -> f) -> String -> String -> DarcsOptDescr f --- | Construct an 'DarcsOptDescr with a 'String' argument.+-- | Construct a 'DarcsOptDescr' with a 'String' argument. strArg :: SingleArgOptDescr String f strArg s l f a h = Compose $ Option s l (ReqArg (\x _ -> f x) a) h --- | Construct an 'DarcsOptDescr with an optional 'String' argument.+-- | Construct a 'DarcsOptDescr' with an optional 'String' argument. optStrArg :: SingleArgOptDescr (Maybe String) f optStrArg s l f a h = Compose $ Option s l (OptArg (\x _ -> f x) a) h --- | Construct an 'DarcsOptDescr with an 'AbsolutePath'+-- | Construct a 'DarcsOptDescr' with an 'AbsolutePath' -- argument. absPathArg :: SingleArgOptDescr AbsolutePath f absPathArg s l f a h = Compose $ Option s l (ReqArg (\x wd -> f $ makeAbsolute wd x) a) h --- | Construct an 'DarcsOptDescr with an 'AbsolutePathOrStd'+-- | Construct a 'DarcsOptDescr' with an 'AbsolutePathOrStd' -- argument. absPathOrStdArg :: SingleArgOptDescr AbsolutePathOrStd f absPathOrStdArg s l f a h = Compose $ Option s l (ReqArg (\x wd -> f $ makeAbsoluteOrStd wd x) a) h --- | Construct an 'DarcsOptDescr with an optional 'AbsolutePath'+-- | Construct a 'DarcsOptDescr' with an optional 'AbsolutePath' -- argument. optAbsPathArg :: [Char] -> [String] -> String -> (AbsolutePath -> f)               -> String -> String -> DarcsOptDescr f@@ -271,3 +282,33 @@   noDefaultHelp (RawAbsPathArg s l mkF _ _ _ a h) = absPathArg s l mkF a h   noDefaultHelp (RawAbsPathOrStdArg s l mkF _ _ _ a h) = absPathOrStdArg s l mkF a h   noDefaultHelp (RawOptAbsPathArg s l mkF _ _ _ d a h) = optAbsPathArg s l d mkF a h++-- * Parsing option arguments++data ArgumentParseError = ArgumentParseError String String+  deriving (Eq, Typeable)++instance Exception ArgumentParseError++instance Show ArgumentParseError where+  show (ArgumentParseError arg expected) =+    unwords ["cannot parse flag argument",show arg,"as",expected]++parseIntArg :: String -> (Int -> Bool) -> String -> Int+parseIntArg expected cond s =+  case reads s of+    (n,""):_ | cond n -> n+    _ -> throw (ArgumentParseError s expected)++parseIndexRangeArg :: String -> (Int,Int)+parseIndexRangeArg s =+  case reads s of+    (n,""):_ | n > 0 -> (n,n)+    (n,'-':s'):_ | n > 0, (m,""):_ <- reads s', m > 0 -> (n,m)+    _ -> throw (ArgumentParseError s "index range")++showIntArg :: Int -> String+showIntArg = show++showIndexRangeArg :: (Int,Int) -> String+showIndexRangeArg (n,m) = show n ++ "-" ++ show m
src/Darcs/UI/PatchHeader.hs view
@@ -6,21 +6,21 @@     , runHijackT     ) where -import Prelude () import Darcs.Prelude  import Darcs.Patch-    ( IsRepoType, RepoPatch, PrimPatch, PrimOf, fromPrims-    , effect+    ( IsRepoType, RepoPatch, PrimPatch, PrimOf     , summaryFL     ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Info ( PatchInfo,                           piAuthor, piName, piLog, piDateString,-                          patchinfo, isInverted, invertName,+                          patchinfo                         )-import Darcs.Patch.Named.Wrapped ( infopatch, getdeps, adddeps )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully, info )+import Darcs.Patch.Named+   ( Named, patchcontents, patch2patchinfo, infopatch, getdeps, adddeps+   )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) import Darcs.Patch.Prim ( canonizeFL )  import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )@@ -51,7 +51,8 @@ import Control.Monad ( when, void ) import Control.Monad.Trans              ( liftIO ) import Control.Monad.Trans.State.Strict ( StateT(..), evalStateT, get, put  )-import Data.List ( isPrefixOf )+import Data.List ( isPrefixOf, stripPrefix )+import Data.Maybe ( fromMaybe ) import System.Exit ( exitSuccess ) import System.IO ( stdin ) @@ -89,10 +90,12 @@        -> FL prim wX wY                         -- ^ changes to record        -> IO (String, [String], Maybe String)   -- ^ patch name, long description and possibly the path                                                 --   to the temporary file that should be removed later-getLog m_name has_pipe log_file ask_long m_old chs = go has_pipe log_file ask_long where+getLog m_name has_pipe log_file ask_long m_old chs =+  restoreTagPrefix <$> go has_pipe log_file ask_long+ where   go True _ _ = do       p <- case patchname_specified of-             FlagPatchName p  -> return p+             FlagPatchName p  -> check_badname p >> return p              PriorPatchName p -> return p              NoPatchName      -> prompt_patchname False       putStrLn "What is the log?"@@ -101,7 +104,7 @@   go _ (O.Logfile { O._logfile = Just f }) _ = do       mlp <- readTextFile f `catch` (\(_ :: IOException) -> return [])       firstname <- case (patchname_specified, mlp) of-                     (FlagPatchName  p, []) -> return p+                     (FlagPatchName  p, []) -> check_badname p >> return p                      (_, p:_)               -> if badName p                                                  then prompt_patchname True                                                  else return p -- logfile trumps prior!@@ -113,64 +116,82 @@       return (name, thelog, if O._rmlogfile log_file then Just $ toFilePath f else Nothing)   go _ _ (Just O.YesEditLongComment) =       case patchname_specified of-          FlagPatchName  p  -> actually_get_log p-          PriorPatchName p  -> actually_get_log p-          NoPatchName       -> actually_get_log ""+          FlagPatchName  p  -> get_log_using_editor p+          PriorPatchName p  -> get_log_using_editor p+          NoPatchName       -> get_log_using_editor ""   go _ _ (Just O.NoEditLongComment) =       case patchname_specified of-          FlagPatchName  p  -> return (p, default_log, Nothing) -- record (or amend) -m+          FlagPatchName  p  -> check_badname p >> return (p, default_log, Nothing) -- record (or amend) -m           PriorPatchName p  -> return (p, default_log, Nothing) -- amend           NoPatchName       -> do p <- prompt_patchname True -- record                                   return (p, [], Nothing)   go _ _ (Just O.PromptLongComment) =       case patchname_specified of-          FlagPatchName p   -> prompt_long_comment p -- record (or amend) -m+          FlagPatchName p   -> check_badname p >> prompt_long_comment p -- record (or amend) -m           PriorPatchName p  -> prompt_long_comment p           NoPatchName       -> prompt_patchname True >>= prompt_long_comment   go _ _ Nothing =       case patchname_specified of-          FlagPatchName  p  -> return (p, default_log, Nothing)  -- record (or amend) -m-          PriorPatchName "" -> actually_get_log ""+          FlagPatchName  p  -> check_badname p >> return (p, default_log, Nothing)  -- record (or amend) -m+          PriorPatchName "" -> get_log_using_editor ""           PriorPatchName p  -> return (p, default_log, Nothing)-          NoPatchName       -> actually_get_log ""+          NoPatchName       -> get_log_using_editor "" -  patchname_specified = case (m_name, m_old) of-                          (Just name, _) | badName name -> NoPatchName-                                         | otherwise    -> FlagPatchName name-                          (Nothing,   Just (name,_))    -> PriorPatchName name-                          (Nothing,   Nothing)          -> NoPatchName+  tagPrefix = "TAG " -  badName "" = True-  badName n  = "TAG" `isPrefixOf` n+  hasTagPrefix name = tagPrefix `isPrefixOf` name +  restoreTagPrefix (name, log, file)+    | Just (old_name, _) <- m_old+    , hasTagPrefix old_name = (tagPrefix ++ name, log, file)+  restoreTagPrefix args = args++  stripTagPrefix name = fromMaybe name $ stripPrefix tagPrefix name++  patchname_specified =+    case (m_name, m_old) of+      (Just name, _)              -> FlagPatchName name+      (Nothing,   Just (name, _)) -> PriorPatchName (stripTagPrefix name)+      (Nothing,   Nothing)        -> NoPatchName++  badName n = null n || hasTagPrefix n+   default_log = case m_old of                   Nothing    -> []                   Just (_,l) -> l -  prompt_patchname retry =-    do n <- askUser "What is the patch name? "-       if badName n-          then if retry then prompt_patchname retry-                        else fail "Bad patch name!"-          else return n+  check_badname = maybe (return ()) fail . just_a_badname +  prompt_patchname retry = do+      n <- askUser "What is the patch name? "+      maybe (return n) prompt_again $ just_a_badname n+    where+      prompt_again msg = do+        putStrLn msg+        if retry then prompt_patchname retry else fail "Bad patch name!"++  just_a_badname n =+    if null n then+      Just "The patch name must not be empty!"+    else if hasTagPrefix n then+      Just "The patch name must not start with \"TAG \"!"+    else+      Nothing+   prompt_long_comment oldname =     do y <- promptYorn "Do you want to add a long comment?"-       if y then actually_get_log oldname+       if y then get_log_using_editor oldname             else return (oldname, [], Nothing) -  actually_get_log p = do let logf = darcsLastMessage+  get_log_using_editor p =+                       do let logf = darcsLastMessage                           -- TODO: make sure encoding used for logf is the same everywhere                           -- probably should be locale because the editor will assume it                           writeTextFile logf $ unlines $ p : default_log                           append_info logf p                           _ <- editFile logf                           (name,long) <- read_long_comment logf p-                          if badName name-                            then do putStrLn "WARNING: empty or incorrect patch name!"-                                    pn <- prompt_patchname True-                                    return (pn, long, Nothing)-                            else return (name,long,Just logf)+                          return (name,long,Just logf)    read_long_comment :: FilePathLike p => p -> String -> IO (String, [String])   read_long_comment f oldname =@@ -178,7 +199,9 @@          let filter_out_info = filter (not.("#" `isPrefixOf`))          case reverse $ dropWhile null $ reverse $ filter_out_info t of             []     -> return (oldname, [])-            (n:ls) -> return (n, ls)+            (n:ls) -> do+                check_badname n+                return (n, ls)    append_info f oldname = do     fc <- readTextFile f@@ -216,29 +239,31 @@                   -> Maybe String -- author                   -> Maybe String -- patchname                   -> Maybe O.AskLongComment-                  -> PatchInfoAnd rt p wT wX-                  -> FL (PrimOf p) wX wY+                  -> 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 -    let newchs = canonizeFL da (effect oldp +>+ chs)+    let newchs = canonizeFL da (patchcontents oldp +>+ chs) -    let old_pdeps = getdeps $ hopefully oldp+    let old_pdeps = getdeps oldp     newdeps <-         case ask_deps of            AskAboutDeps repository -> liftIO $ askAboutDepends repository newchs pSelOpts old_pdeps            NoAskAboutDeps -> return old_pdeps -    let old_pinf = info oldp+    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     liftIO $ do         (new_name, new_log, mlogf) <- getLog             nPatchname False (O.Logfile Nothing False) nAskLongComment (Just prior) chs-        let maybe_invert = if isInverted old_pinf then invertName else id-        new_pinf <- maybe_invert `fmap` patchinfo date new_name new_author new_log-        let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps)+        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,51 +16,56 @@ -- Boston, MA 02110-1301, USA.  module Darcs.UI.PrintPatch-    ( printPatch-    , contextualPrintPatch-    , printPatchPager+    ( contextualPrintPatch+    , printContent+    , printContentWithPager     , printFriendly+    , printSummary     , showFriendly+    , showWithSummary     ) where -import Prelude () import Darcs.Prelude -import Darcs.Util.Tree.Monad( virtualTreeIO )-import Darcs.Util.Tree( Tree )--import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Patch ( description, showContextPatch, content, summary ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch ( showContextPatch, showPatch, showNicely, description,-                     summary )-import Darcs.Patch.Show ( ShowPatch, ShowContextPatch, ShowPatchFor(ForDisplay) )+import Darcs.Patch.Show ( ShowContextPatch, ShowPatch, ShowPatchFor(ForDisplay) ) import Darcs.UI.External ( viewDocWith )-import Darcs.UI.Options.All ( Verbosity(..), Summary(..), WithContext(..) )--import Darcs.Util.Printer ( Doc, putDocLnWith )+import Darcs.UI.Options.All ( Verbosity(..), WithContext(..), 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 -> Summary -> WithContext -> p wX wY -> IO ()+              -> Verbosity -> WithSummary -> WithContext -> p wX wY -> IO () printFriendly (Just pristine) _ _ YesContext = contextualPrintPatch pristine printFriendly _ v s _ = putDocLnWith fancyPrinters . showFriendly v s  -- | @'showFriendly' flags patch@ returns a 'Doc' representing the right -- way to show @patch@ given the list @flags@ of flags darcs was invoked with.-showFriendly :: ShowPatch p => Verbosity -> Summary -> p wX wY -> Doc-showFriendly Verbose _          = showNicely-showFriendly _       YesSummary = summary+showFriendly :: ShowPatch p => Verbosity -> WithSummary -> p wX wY -> Doc+showFriendly Verbose _          = showWithContents+showFriendly _       YesSummary = showWithSummary showFriendly _       NoSummary  = description --- | 'printPatch' prints a patch on standard output.-printPatch :: ShowPatch p => p wX wY -> IO ()-printPatch p = putDocLnWith fancyPrinters $ showPatch ForDisplay p+showWithSummary :: ShowPatch p => p wX wY -> Doc+showWithSummary p = description p $$ prefix "    " (summary p) --- | 'printPatchPager' runs '$PAGER' and shows a patch in it.-printPatchPager :: ShowPatch p => p wX wY -> IO ()-printPatchPager p = viewDocWith fancyPrinters $ showPatch ForDisplay p+showWithContents :: ShowPatch p => p wX wY -> Doc+showWithContents p = description p $$ prefix "    " (content p)++printSummary :: ShowPatch p => p wX wY -> IO ()+printSummary = putDocLnWith fancyPrinters . prefix "    " . summary++printContent :: ShowPatch p => p wX wY -> IO ()+printContent = putDocLnWith fancyPrinters . prefix "    " . content++printContentWithPager :: ShowPatch p => p wX wY -> IO ()+printContentWithPager = viewDocWith fancyPrinters . prefix "    " . content  -- | 'contextualPrintPatch' prints a patch, together with its context, on -- standard output.
src/Darcs/UI/RunCommand.hs view
@@ -15,14 +15,16 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE OverloadedStrings #-} -- | This is the actual heavy lifter code, which is responsible for parsing the -- arguments and then running the command itself.-module Darcs.UI.RunCommand ( runTheCommand ) where+module Darcs.UI.RunCommand+  ( runTheCommand+  , runWithHooks -- exported for darcsden+  ) where -import Prelude () import Darcs.Prelude -import Data.List ( intercalate ) import Control.Monad ( unless, when ) import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),                               OptDescr( Option ),@@ -32,12 +34,12 @@ import Darcs.UI.Options ( (^), odesc, oparse, parseFlags, optDescr, (?) ) import Darcs.UI.Options.All     ( stdCmdActions, StdCmdAction(..)-    , anyVerbosity, verbosity, Verbosity(..), network, NetworkOptions(..)+    , debugging, verbosity, Verbosity(..), network, NetworkOptions(..)     , HooksConfig(..), hooks )  import Darcs.UI.Defaults ( applyDefaults ) import Darcs.UI.External ( viewDoc )-import Darcs.UI.Flags ( DarcsFlag (NewRepo), matchAny, fixRemoteRepos )+import Darcs.UI.Flags ( DarcsFlag, matchAny, fixRemoteRepos, withNewRepo ) import Darcs.UI.Commands     ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub )     , CommandControl@@ -50,8 +52,7 @@     , commandArgdefaults     , commandCompleteArgs     , commandOptions-    , commandParseOptions-    , wrappedCommandName+    , commandName     , disambiguateCommands     , getSubcommands     , extractCommands@@ -73,8 +74,9 @@ import Darcs.Util.Exception ( die ) import Darcs.Util.Global ( setDebugMode, setTimingsMode ) import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute )+import Darcs.Util.Printer ( (<+>), ($+$), renderString, text, vcat )+import Darcs.Util.Printer.Color ( ePutDocLn ) import Darcs.Util.Progress ( setProgressMode )-import Darcs.Util.Text ( chompTrailingNewline, quote )  runTheCommand :: [CommandControl] -> String -> [String] -> IO () runTheCommand commandControlList cmd args =@@ -84,7 +86,7 @@   rtc (SuperCommandOnly c,  as) = runRawSupercommand c as   rtc (SuperCommandSub c s, as) = runCommand (Just c) s as -runCommand :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [String] -> IO ()+runCommand :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO () runCommand _ _ args -- Check for "dangerous" typoes...     | "-all" `elem` args = -- -all indicates --all --look-for-adds!         die "Are you sure you didn't mean --all rather than -all?"@@ -117,26 +119,28 @@           die $ "Command "++commandName cmd++" disabled with --disable option!"         Nothing -> case prereq_errors of           Left complaint -> die $-            "Unable to " ++ quote ("darcs " ++ superName msuper ++ commandName cmd) ++-            " here.\n\n" ++ complaint-          Right () -> case getopt_errs ++ flag_errors of-            [] -> do-              extra <- commandArgdefaults cmd flags old_wd orig_extra-              case extraArgumentsError extra cmd msuper of-                Nothing     -> runWithHooks cmd (new_wd, old_wd) flags extra-                Just msg    -> die msg-            es -> die (intercalate "\n" es)+            "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  fixupMsgs :: (a, b, [String]) -> (a, b, [String]) fixupMsgs (fs,as,es) = (fs,as,map (("command line: "++).chompTrailingNewline) es)+  where+    chompTrailingNewline "" = ""+    chompTrailingNewline s = if last s == '\n' then init s else s -runWithHooks :: DarcsCommand pf+runWithHooks :: DarcsCommand              -> (AbsolutePath, AbsolutePath)              -> [DarcsFlag] -> [String] -> IO () runWithHooks cmd (new_wd, old_wd) flags extra = do    checkMatchSyntax $ matchAny ? flags    -- set any global variables-   oparse (anyVerbosity ^ network) setGlobalVariables flags+   oparse (verbosity ^ debugging ^ network) setGlobalVariables flags    -- actually run the command and its hooks    let hooksCfg = parseFlags hooks flags    let verb = parseFlags verbosity flags@@ -145,13 +149,12 @@       then exitWith preHookExitCode       else do fixedFlags <- fixRemoteRepos old_wd flags               phDir <- getPosthookDir new_wd cmd fixedFlags extra-              let parsedFlags = commandParseOptions cmd fixedFlags-              commandCommand cmd (new_wd, old_wd) parsedFlags extra+              commandCommand cmd (new_wd, old_wd) fixedFlags extra               postHookExitCode <- runPosthook (post hooksCfg) verb phDir               exitWith postHookExitCode -setGlobalVariables :: Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ()-setGlobalVariables debug debugHttp verb timings net = do+setGlobalVariables :: Verbosity -> Bool -> Bool -> Bool -> NetworkOptions -> IO ()+setGlobalVariables verb debug debugHttp timings net = do   when timings setTimingsMode   when debug setDebugMode   when debugHttp setDebugHTTP@@ -162,16 +165,16 @@ -- | Returns the working directory for the posthook. For most commands, the -- first parameter is returned. For the \'get\' command, the path of the newly -- created repository is returned if it is not an ssh url.-getPosthookDir :: AbsolutePath -> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath+getPosthookDir :: AbsolutePath -> DarcsCommand -> [DarcsFlag] -> [String] -> IO AbsolutePath getPosthookDir new_wd cmd flags extra | commandName cmd `elem` ["get","clone"] = do     case extra of-      [inrepodir, outname] -> getPosthookDir new_wd cmd (NewRepo outname:flags) [inrepodir]+      [inrepodir, outname] -> getPosthookDir new_wd cmd (withNewRepo outname flags) [inrepodir]       [inrepodir] ->         case cloneToSSH flags of          Nothing -> do           repodir <- toPath <$> ioAbsoluteOrRemote inrepodir-          reponame <- makeRepoName False flags repodir-          return $ makeAbsolute new_wd reponame+          newRepo <- makeRepoName False flags repodir+          return $ makeAbsolute new_wd newRepo          _ -> return new_wd       _ -> die "You must provide 'clone' with either one or two arguments." getPosthookDir new_wd _ _ _ = return new_wd@@ -182,8 +185,8 @@ -- Extra arguments are arguments that follow the command but aren't -- considered a flag. In `darcs push xyz`, xyz would be an extra argument. extraArgumentsError :: [String]             -- extra commands provided by user-                    -> DarcsCommand pf1-                    -> Maybe (DarcsCommand pf2)+                    -> DarcsCommand+                    -> Maybe DarcsCommand                     -> Maybe String extraArgumentsError extra cmd msuper     | extraArgsCmd < 0 = Nothing@@ -210,10 +213,12 @@     short d o = '-' : o : ";" ++ d     long d o = "--" ++ o ++ ";" ++ d -runRawSupercommand :: DarcsCommand pf -> [String] -> IO ()+runRawSupercommand :: DarcsCommand -> [String] -> IO () runRawSupercommand super [] =-    die $ "Command '"++ commandName super ++"' requires a subcommand!\n\n"-             ++ subusage super+  die $ renderString $+    "Command '" <> text (commandName super) <> "' requires a subcommand!"+    $+$+    subusage super runRawSupercommand super args = do   cwd <- getCurrentDirectory   case fixupMsgs $ getOpt RequireOrder (map (optDescr cwd) (odesc stdCmdActions)) args of@@ -223,10 +228,12 @@         viewDoc $ getCommandHelp Nothing super       Just ListOptions -> do         putStrLn "--help"-        mapM_ (putStrLn . wrappedCommandName) (extractCommands $ getSubcommands super)+        mapM_ (putStrLn . commandName) (extractCommands $ getSubcommands super)       Just Disable -> do-        die $ "Command " ++ commandName super ++-               " disabled with --disable option!"-      Nothing -> die $ case getopt_errs of-        [] -> "Invalid subcommand!\n\n" ++ subusage super-        _ -> intercalate "\n" getopt_errs+        die $ renderString $+          "Command" <+> text (commandName super) <+> "disabled with --disable option!"+      Nothing ->+        die $ renderString $+          case getopt_errs of+            [] -> text "Invalid subcommand!" $+$ subusage super+            _ -> vcat (map text getopt_errs)
src/Darcs/UI/SelectChanges.hs view
@@ -15,28 +15,29 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE RecordWildCards #-} module Darcs.UI.SelectChanges     ( -- * Working with changes       WhichChanges(..)     , viewChanges-    , withSelectedPatchFromRepo+    , withSelectedPatchFromList     , runSelection-    , selectionContextPrim-    , selectionContextGeneric-    , selectionContext-    , PatchSelectionContext(allowSkipAll)-    , printSummary+    , runInvertibleSelection+    , selectionConfigPrim+    , selectionConfigGeneric+    , selectionConfig+    , SelectionConfig(allowSkipAll)     -- * Interactive selection utils     , PatchSelectionOptions(..)     , InteractiveSelectionM-    , InteractiveSelectionContext(..)+    , InteractiveSelectionState(..)+    , initialSelectionState     -- ** Navigating the patchset     , currentPatch     , skipMundane     , skipOne     , backOne     , backAll-    , showCur     -- ** Decisions     , decide     , decideWholeFile@@ -51,7 +52,6 @@     , askAboutDepends     ) where -import Prelude () import Darcs.Prelude  import Control.Monad ( liftM, unless, when, (>=>) )@@ -67,19 +67,18 @@     ) import Control.Monad.Trans ( liftIO ) import Data.List ( intercalate, union )-import Data.Maybe ( isJust, catMaybes )+import Data.Maybe ( isJust ) import System.Exit ( exitSuccess )  import Darcs.Patch     ( IsRepoType, RepoPatch, PrimOf-    , commuteFLorComplain, invert-    , listTouchedFiles, fromPrims+    , commuteFL, invert+    , listTouchedFiles     )-import qualified Darcs.Patch ( thing, things, summary )-import Darcs.Patch.Apply ( Apply, ApplyState )+import qualified Darcs.Patch ( thing, things )+import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Choices     ( PatchChoices, Slot (..), LabelledPatch-    , mkPatchChoices, forceFirsts     , forceFirst, forceLast, forceMatchingFirst     , forceMatchingLast, getChoices     , makeEverythingLater, makeEverythingSooner@@ -91,42 +90,54 @@     , 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 ) import Darcs.Patch.Invert ( Invert )-import Darcs.Patch.Match ( haveNonrangeMatch, matchAPatch )-import Darcs.Patch.Named.Wrapped ( anonymous )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia )-import Darcs.Patch.Set ( PatchSet(..), patchSet2RL )+import Darcs.Patch.Invertible+import Darcs.Patch.Match+    ( Matchable+    , MatchableRP+    , haveNonrangeMatch+    , matchAPatch+    )+import Darcs.Patch.Named ( adddeps, anonymous )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch.Permutations ( commuteWhatWeCanRL ) import Darcs.Patch.Show ( ShowPatch, ShowContextPatch )-import Darcs.Patch.Split ( Splitter(applySplitter,canonizeSplit) )+import Darcs.Patch.Split ( Splitter(..) ) import Darcs.Patch.TouchesFiles ( selectNotTouching, deselectNotTouching )-import Darcs.Patch.Type ( PatchType (..) )-import Darcs.Patch.Witnesses.Eq ( unsafeCompare ) import Darcs.Patch.Witnesses.Ordered     ( (:>) (..), (:||:) (..), FL (..)     , RL (..), filterFL, lengthFL, mapFL     , mapFL_FL, spanFL, spanFL_M-    , (+>+), (+<<+), (+>>+)+    , (+>+), (+<<+)+    , reverseFL, reverseRL     ) import Darcs.Patch.Witnesses.Sealed     ( FlippedSeal (..), Sealed2 (..)     , flipSeal, seal2, unseal2     ) import Darcs.Patch.Witnesses.WZipper-    ( FZipper (..), left, right+    ( FZipper (..), focus, jokers, left, right     , rightmost, toEnd, toStart     )-import Darcs.Repository ( Repository, repoLocation, readRepo, readTentativeRepo )+import Darcs.Repository ( Repository, repoLocation, readTentativeRepo ) import Darcs.UI.External ( editText ) import Darcs.UI.Options.All-    ( Verbosity(..), Summary(..)+    ( Verbosity(..), WithSummary(..)     , WithContext(..), SelectDeps(..), MatchFlag ) import Darcs.UI.PrintPatch-    ( printFriendly, printPatch-    , printPatchPager, showFriendly )+    ( printContent+    , printContentWithPager+    , printFriendly+    , printSummary+    , showFriendly+    ) import Darcs.Util.English ( Noun (..), englishNum, capitalize )-import Darcs.Util.Printer ( prefix, putDocLn, putDocLnWith, greenText )+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.Tree ( Tree )@@ -172,7 +183,7 @@ -- given. data MatchCriterion p = MatchCriterion    { mcHasNonrange :: Bool-   , mcFunction :: forall wA wB. WhichChanges -> LabelledPatch p wA wB -> Bool+   , mcFunction :: forall wA wB. p wA wB -> Bool    }  data PatchSelectionOptions = PatchSelectionOptions@@ -180,31 +191,31 @@   , matchFlags :: [MatchFlag]   , interactive :: Bool   , selectDeps :: SelectDeps-  , summary :: Summary+  , withSummary :: WithSummary   , withContext :: WithContext   } --- | A @PatchSelectionContext@ contains all the static settings for selecting--- patches. See "PatchSelectionM"-data PatchSelectionContext p = PSC { opts :: PatchSelectionOptions-                                   , splitter :: Maybe (Splitter p)-                                   , files :: Maybe [FilePath]-                                   , matchCriterion :: MatchCriterion p-                                   , jobname :: String-                                   , allowSkipAll :: Bool-                                   , pristine :: Maybe (Tree IO)-                                   , whichChanges :: WhichChanges-                                   }+-- | All the static settings for selecting patches.+data SelectionConfig p =+  PSC { opts :: PatchSelectionOptions+      , splitter :: Maybe (Splitter p)+      , files :: Maybe [AnchoredPath]+      , matchCriterion :: MatchCriterion p+      , jobname :: String+      , allowSkipAll :: Bool+      , pristine :: Maybe (Tree IO)+      , whichChanges :: WhichChanges+      } --- | A 'PatchSelectionContext' for selecting 'Prim' patches.-selectionContextPrim :: WhichChanges-                     -> String-                     -> PatchSelectionOptions-                     -> Maybe (Splitter prim)-                     -> Maybe [FilePath]-                     -> Maybe (Tree IO)-                     -> PatchSelectionContext prim-selectionContextPrim whch jn o spl fs p =+-- | A 'SelectionConfig' for selecting 'Prim' patches.+selectionConfigPrim :: WhichChanges+                    -> String+                    -> PatchSelectionOptions+                    -> Maybe (Splitter prim)+                    -> Maybe [AnchoredPath]+                    -> Maybe (Tree IO)+                    -> SelectionConfig prim+selectionConfigPrim whch jn o spl fs p =  PSC { opts = o      , splitter = spl      , files = fs@@ -215,13 +226,15 @@      , whichChanges = whch      } --- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches)-selectionContext :: (IsRepoType rt, RepoPatch p)-                 => WhichChanges -> String -> PatchSelectionOptions-                 -> Maybe (Splitter (PatchInfoAnd rt p))-                 -> Maybe [FilePath]-                 -> PatchSelectionContext (PatchInfoAnd rt p)-selectionContext whch jn o spl fs =+-- | A 'SelectionConfig' for selecting full ('Matchable') patches+selectionConfig :: Matchable p+                 => WhichChanges+                 -> String+                 -> PatchSelectionOptions+                 -> Maybe (Splitter p)+                 -> Maybe [AnchoredPath]+                 -> SelectionConfig p+selectionConfig whch jn o spl fs =  PSC { opts = o      , splitter = spl      , files = fs@@ -232,15 +245,15 @@      , whichChanges = whch      } --- | A generic 'PatchSelectionContext'.-selectionContextGeneric :: (IsRepoType rt, RepoPatch p, Invert q)-                        => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd rt p))-                        -> WhichChanges-                        -> String-                        -> PatchSelectionOptions-                        -> Maybe [FilePath]-                        -> PatchSelectionContext q-selectionContextGeneric extract whch jn o fs =+-- | A generic 'SelectionConfig'.+selectionConfigGeneric :: Matchable p+                       => (forall wX wY . q wX wY -> Sealed2 p)+                       -> WhichChanges+                       -> String+                       -> PatchSelectionOptions+                       -> Maybe [AnchoredPath]+                       -> SelectionConfig q+selectionConfigGeneric extract whch jn o fs =  PSC { opts = o      , splitter = Nothing      , files = fs@@ -252,49 +265,67 @@      }  -- | The dynamic parameters for interactive selection of patches.-data InteractiveSelectionContext p wX wY =+data InteractiveSelectionState p wX wY =  ISC { total :: Int                           -- ^ total number of patches      , current :: Int                         -- ^ number of already-seen patches      , lps :: FZipper (LabelledPatch p) wX wY -- ^ the patches we offer      , choices :: PatchChoices p wX wY        -- ^ the user's choices      } -type PatchSelectionM p a = ReaderT (PatchSelectionContext p) a+type PatchSelectionM p a = ReaderT (SelectionConfig p) a  type InteractiveSelectionM p wX wY a =-    StateT (InteractiveSelectionContext p wX wY)+    StateT (InteractiveSelectionState p wX wY)            (PatchSelectionM p IO) a  -- Common match criteria  -- | For commands without @--match@, 'triv' matches all patches triv :: MatchCriterion p-triv = MatchCriterion { mcHasNonrange = False, mcFunction = \ _ _ -> True }+triv = MatchCriterion { mcHasNonrange = False, mcFunction = \ _ -> True }  -- | 'iswanted' selects patches according to the given match flags-iswanted :: forall rt p q-          . (IsRepoType rt, RepoPatch p, Invert q)-         => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd rt p))+iswanted :: Matchable p+         => (forall wX wY . q wX wY -> Sealed2 p)          -> [MatchFlag]          -> MatchCriterion q iswanted extract mflags = MatchCriterion-    { mcHasNonrange = haveNonrangeMatch (PatchType :: PatchType rt p) mflags-    , mcFunction = isWantedMcFunction+    { mcHasNonrange = haveNonrangeMatch mflags+    , mcFunction = unseal2 (matchAPatch mflags) . extract     }-  where-    isWantedMcFunction w = unseal2 (matchAPatch mflags) . extract_reverse w . unLabel-    -- TODO inverting should not be necessary here, at least I would expect-    ---    -- prop> matchAPatch (invert x) == matchAPatch x-    extract_reverse w = if reversed w then extract . invert else extract --- | Run a 'PatchSelection' action in the given 'PatchSelectionContext'.-runSelection :: forall p wX wY . ( Invert p, Commute p, Apply p, PatchInspect p, ShowPatch p-                                 , ShowContextPatch p, ApplyState p ~ Tree )+-- | Run a 'PatchSelection' action in the given 'SelectionConfig',+-- without assuming that patches are invertible.+runSelection :: ( MatchableRP p, ShowPatch p, ShowContextPatch p+                , ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p)+                )              => FL p wX wY-             -> PatchSelectionContext p+             -> SelectionConfig p              -> IO ((FL p :> FL p) wX wY)-runSelection ps psc = runReaderT (selection ps) psc where+runSelection _ PSC { splitter = Just _ } =+  -- a Splitter makes sense for prim patches only and these are invertible anyway+  error "cannot use runSelection with Splitter"+runSelection ps PSC { matchCriterion = mc, .. } = do+    unwrapOutput <$> runInvertibleSelection (wrapInput ps) ictx+  where+    convertMC :: MatchCriterion p -> MatchCriterion (Invertible p)+    convertMC MatchCriterion { mcFunction = mcf, .. } =+      MatchCriterion { mcFunction = withInvertible mcf, .. }+    ictx = PSC { matchCriterion = convertMC mc, splitter = Nothing, .. }+    wrapInput = mapFL_FL mkInvertible+    unwrapOutput (xs :> ys) =+      mapFL_FL fromPositiveInvertible xs :> mapFL_FL fromPositiveInvertible ys++-- | Run a 'PatchSelection' action in the given 'SelectionConfig',+-- assuming patches are invertible.+runInvertibleSelection :: forall p wX wY .+                          ( Invert p, MatchableRP p, ShowPatch p+                          , ShowContextPatch p, ApplyState p ~ Tree+                          )+                       => FL p wX wY+                       -> SelectionConfig p+                       -> IO ((FL p :> FL p) wX wY)+runInvertibleSelection ps psc = runReaderT (selection ps) psc where   selection     | reversed whch = fmap invert . doit . invert     | otherwise = doit@@ -361,9 +392,9 @@   deselectUnwanted     | backward whch = forceMatchingFirst (not . iswanted_)     | otherwise     = forceMatchingLast (not . iswanted_)-  iswanted_ = mcFunction crit whch+  iswanted_ = mcFunction crit . unLabel -  {- end of runSelection -}+  {- end of runInvertibleSelection -}  -- | The equivalent of 'runSelection' for the @darcs log@ command viewChanges :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)@@ -394,16 +425,15 @@ keysFor = concatMap (map kp)  -- | The function for selecting a patch to amend record. Read at your own risks.-withSelectedPatchFromRepo-    :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)+withSelectedPatchFromList+    :: (Commute p, Matchable p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)     => String   -- name of calling command (always "amend" as of now)-    -> Repository rt p wR wU wT+    -> RL p wO wR     -> PatchSelectionOptions-    -> (forall wA . (FL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wA wR -> IO ())+    -> (forall wA . (FL p :> p) wA wR -> IO ())     -> IO ()-withSelectedPatchFromRepo jn repository o job = do-    patchSet <- readRepo repository-    sp <- wspfr jn (matchAPatch $ matchFlags o) (patchSet2RL patchSet) NilFL+withSelectedPatchFromList jn patches o job = do+    sp <- wspfr jn (matchAPatch $ matchFlags o) patches NilFL     case sp of         Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected')         Nothing ->@@ -419,50 +449,53 @@ -- | 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 rt p wX wY wU. (RepoPatch p, ApplyState p ~ Tree)+wspfr :: forall p wX wY wU.+         (Commute p, Matchable p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)       => String-      -> (forall wA wB . (PatchInfoAnd rt p) wA wB -> Bool)-      -> RL (PatchInfoAnd rt p) wX wY-      -> FL (WithSkipped (PatchInfoAnd rt p)) wY wU-      -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wU))+      -> (forall wA wB . p wA wB -> Bool)+      -> RL p wX wY+      -> FL (WithSkipped p) wY wU+      -> IO (Maybe (FlippedSeal (FL p :> p) wU)) wspfr _ _ NilRL _ = return Nothing wspfr jn matches remaining@(pps:<:p) skipped     | not $ matches p = wspfr jn matches pps                             (WithSkipped SkippedAutomatically p :>: skipped)     | otherwise =-    case commuteFLorComplain (p :> mapFL_FL skippedPatch skipped) of-    Left _  -> do putStrLn "\nSkipping depended-upon patch:"+    case commuteFL (p :> mapFL_FL skippedPatch skipped) of+    Nothing -> do putStrLn "\nSkipping depended-upon patch:"                   defaultPrintFriendly p                   wspfr jn matches pps (WithSkipped SkippedAutomatically p :>: skipped) -    Right (skipped' :> p') -> do+    Just (skipped' :> p') -> do         defaultPrintFriendly p-        yorn <- promptChar+        let repeatThis = do+              yorn <- promptChar                     PromptConfig { pPrompt = prompt'                                  , pBasicCharacters = keysFor basicOptions                                  , pAdvancedCharacters = keysFor advancedOptions                                  , pDefault = Just 'n'                                  , pHelp = "?h" }-        case yorn of-            'y' -> return $ Just $ flipSeal $ skipped' :> p'-            'n' -> nextPatch-            'j' -> nextPatch-            'k' -> previousPatch remaining skipped-            'v' -> printPatch p >> repeatThis-            'p' -> printPatchPager p >> repeatThis-            'x' -> do putDocLn $ prefix "    " $ Darcs.Patch.summary p-                      repeatThis-            'q' -> do putStrLn $ (capitalize jn) ++ " cancelled."-                      exitSuccess-            _   -> do putStrLn $ helpFor jn basicOptions advancedOptions-                      repeatThis-  where repeatThis = wspfr jn matches (pps:<:p) skipped-        prompt' = "Shall I " ++ jn ++ " this patch?"+              case yorn of+                'y' -> return $ Just $ flipSeal $ skipped' :> p'+                'n' -> nextPatch+                'j' -> nextPatch+                'k' -> previousPatch remaining skipped+                'v' -> printContent p >> repeatThis+                'p' -> printContentWithPager p >> repeatThis+                'x' -> do printSummary p+                          repeatThis+                'r' -> defaultPrintFriendly p >> repeatThis+                'q' -> do putStrLn $ (capitalize jn) ++ " cancelled."+                          exitSuccess+                _   -> do putStrLn $ helpFor jn basicOptions advancedOptions+                          repeatThis+        repeatThis+  where prompt' = "Shall I " ++ jn ++ " this patch?"         nextPatch = wspfr jn matches pps (WithSkipped SkippedManually p:>:skipped)-        previousPatch :: RL (PatchInfoAnd rt p) wX wQ-                      -> FL (WithSkipped (PatchInfoAnd rt p)) wQ wU+        previousPatch :: RL p wX wQ+                      -> FL (WithSkipped p) wQ wU                       -> IO (Maybe (FlippedSeal-                              (FL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wU))+                              (FL p :> p) wU))         previousPatch remaining' NilFL = wspfr jn matches remaining' NilFL         previousPatch remaining' (WithSkipped sk prev :>: skipped'') =             case sk of@@ -478,6 +511,7 @@                     [[ KeyPress 'v' "view this patch in full"                      , KeyPress 'p' "view this patch in full with pager"                      , KeyPress 'x' "view a summary of this patch"+                     , KeyPress 'r' "view this patch"                      , KeyPress 'q' ("cancel " ++ jn)                     ]]         defaultPrintFriendly =@@ -496,25 +530,30 @@ justDone :: Int -> InteractiveSelectionM p wX wY () justDone n = modify $ \isc -> isc{ current = current isc + n} +initialSelectionState :: FL (LabelledPatch p) wX wY+                      -> PatchChoices p wX wY+                      -> InteractiveSelectionState p wX wY+initialSelectionState lps pcs =+  ISC { total = lengthFL lps+      , current = 0+      , lps = FZipper NilRL lps+      , choices = pcs+      }+ -- | The actual interactive selection process. textSelect :: ( Commute p, Invert p, ShowPatch p, ShowContextPatch p               , PatchInspect p, ApplyState p ~ Tree )            => FL (LabelledPatch p) wX wY            -> PatchChoices p wX wY            -> PatchSelectionM p IO (PatchChoices p wX wY)-textSelect lps' pcs = do-    userSelection <- execStateT (skipMundane >>-                                 showCur >>-                                 textSelectIfAny)-                     ISC { total = lengthFL lps'-                         , current = 0-                         , lps = FZipper NilRL lps'-                         , choices = pcs }-    return $ choices userSelection-    where textSelectIfAny = do-            z <- gets lps-            unless (rightmost z) $-              textSelect'+textSelect lps' pcs =+  choices <$>+    execStateT (skipMundane >> printCurrent >> textSelectIfAny)+      (initialSelectionState lps' pcs)+  where+    textSelectIfAny = do+      z <- gets lps+      unless (rightmost z) $ textSelect'  textSelect' :: ( Commute p, Invert p, ShowPatch p, ShowContextPatch p                , PatchInspect p, ApplyState p ~ Tree )@@ -541,6 +580,7 @@ optionsView aThing someThings =     [ KeyPress 'v' ("view this "++aThing++" in full")     , KeyPress 'p' ("view this "++aThing++" in full with pager")+    , KeyPress 'r' ("view this "++aThing)     , KeyPress 'l' ("list all selected "++someThings) ]  optionsSummary :: String -> [KeyPress]@@ -594,27 +634,21 @@          ,[optionsSplit split aThing]          ++ [optionsFile jn | single]          ++ [optionsView aThing someThings ++-                if summary o == YesSummary+                if withSummary o == YesSummary                     then []                     else optionsSummary aThing]          ++ [optionsQuit jn allowsa someThings]          ++ [optionsNav aThing False]          ) --- | Returns a @Sealed2@ version of the patch we are asking the user+-- | Returns a 'Sealed2' version of the patch we are asking the user -- about. currentPatch :: InteractiveSelectionM p wX wY (Maybe (Sealed2 (LabelledPatch p)))-currentPatch = do-  FZipper _ lps_todo <- gets lps-  case lps_todo of-    NilFL -> return Nothing-    (lp:>:_) -> return $ Just (Sealed2 lp)+currentPatch = focus <$> gets lps  -- | Returns the patches we have yet to ask the user about. todo :: InteractiveSelectionM p wX wY (FlippedSeal (FL (LabelledPatch p)) wY)-todo = do-    (FZipper _ lps_todo) <- gets lps-    return (FlippedSeal lps_todo)+todo = jokers <$> gets lps  -- | Modify the underlying @PatchChoices@ by some function modifyChoices :: (PatchChoices p wX wY -> PatchChoices p wX wY)@@ -624,7 +658,7 @@ -- | returns @Just f@ if the 'currentPatch' only modifies @f@, -- @Nothing@ otherwise. currentFile :: (PatchInspect p)-            => InteractiveSelectionM p wX wY (Maybe FilePath)+            => InteractiveSelectionM p wX wY (Maybe AnchoredPath) currentFile = do   c <- currentPatch   return $ case c of@@ -648,12 +682,12 @@  -- | like 'decide', but for all patches touching @file@ decideWholeFile :: (Commute p, PatchInspect p)-                => FilePath -> Bool -> InteractiveSelectionM p wX wY ()-decideWholeFile file takeOrDrop =+                => AnchoredPath -> Bool -> InteractiveSelectionM p wX wY ()+decideWholeFile path takeOrDrop =     do       FlippedSeal lps_todo <- todo       let patches_to_skip =-              filterFL (\lp' -> listTouchedFiles lp' == [file]) lps_todo+              filterFL (\lp' -> listTouchedFiles lp' == [path]) lps_todo       mapM_ (unseal2 $ decide takeOrDrop) patches_to_skip  -- | Undecide the current patch.@@ -696,37 +730,21 @@                                                    (choices isc)                                       } --- | Shows the patch that is actually being selected the way the user--- should see it.-repr :: Invert p => WhichChanges -> LabelledPatch p wX wY -> Sealed2 p-repr w p-  | reversed w = Sealed2 (invert (unLabel p))-  | otherwise = Sealed2 (unLabel p)---- | Returns a list of the currently selected patches, in--- their original context, i.e., not commuted past unselected--- patches.-selected :: (Commute p, Invert p) => InteractiveSelectionM p wX wY [Sealed2 p]-selected = do-  w <- asks whichChanges-  chs <- gets choices-  (first_chs :> _ :> last_chs) <- return $ getChoices chs-  return $ if backward w then mapFL (repr w) last_chs else mapFL (repr w) first_chs---- | Prints the list of the selected patches. See 'selected'.-printSelected :: (Invert p, Commute p, ShowPatch p) =>-                InteractiveSelectionM p wX wY ()+-- | Print the list of the selected patches. We currently choose to display+-- them in "commuted" form, that is, in the order in which they have been+-- selected and with deselected patches moved out of the way.+printSelected :: (Commute p, ShowPatch p) => InteractiveSelectionM p wX wY () printSelected = do   someThings <- things   o <- asks opts-  s <- selected-  liftIO $ do-    putDocLnWith fancyPrinters $ greenText $ "---- selected "++someThings++" ----"-    mapM_ (putDocLnWith fancyPrinters . unseal2 (showFriendly (verbosity o) (summary o))) s-    putDocLnWith fancyPrinters $ greenText $ "---- end of selected "++someThings++" ----"--printSummary :: ShowPatch p => p wX wY -> IO ()-printSummary = putDocLn . prefix "    " . Darcs.Patch.summary+  w <- asks whichChanges+  let showFL = vcat . mapFL (showFriendly (verbosity o) (withSummary o) . unLabel)+  (first_chs :> _ :> last_chs) <- getChoices <$> gets choices+  liftIO $ putDocLnWith fancyPrinters $ vcat+    [ greenText $ "---- selected "++someThings++" ----"+    , if backward w then showFL last_chs else showFL first_chs+    , greenText $ "---- end of selected "++someThings++" ----"+    ]  -- | Skips all remaining patches. skipAll ::  InteractiveSelectionM p wX wY ()@@ -786,7 +804,7 @@                                    }  -- | Ask the user what to do with the next patch.-textSelectOne :: ( Invert p, Commute p, ShowPatch p, ShowContextPatch p, PatchInspect p+textSelectOne :: ( Commute p, ShowPatch p, ShowContextPatch p, PatchInspect p                  , ApplyState p ~ Tree )               => InteractiveSelectionM p wX wY Bool textSelectOne = do@@ -799,12 +817,12 @@          spl <- asks splitter          whichch <- asks whichChanges          let singleFile = isSingleFile (unLabel lp)-             reprCur = repr whichch lp+             p = unLabel lp          (basicOptions,advancedOptions) <- options singleFile          theSlot <- liftChoices $ state $ patchSlot lp          let the_default = getDefault (backward whichch) theSlot          yorn <- promptUser singleFile the_default-         let nextPatch = skipMundane >> showCur+         let nextPatch = skipMundane >> printCurrent          case yorn of                'y' -> decide True lp >> skipOne >> nextPatch                       >> return False@@ -812,7 +830,7 @@                       >> return False                'w' -> postponeNext >> skipOne >> nextPatch                       >> return False-               'e' | (Just s) <- spl -> splitCurrent s >> showCur+               'e' | (Just s) <- spl -> splitCurrent s >> printCurrent                                         >> return False                's' -> currentFile >>= maybe                        (return ())@@ -822,12 +840,13 @@                        (return ())                        (\f -> decideWholeFile f True) >> nextPatch                        >> return False-               'v' -> liftIO $ unseal2 printPatch reprCur >> return False-               'p' -> liftIO $ unseal2 printPatchPager reprCur >> return False-               'l' -> printSelected >> showCur >> return False-               'x' -> liftIO $ unseal2 printSummary reprCur >> return False+               'v' -> liftIO $ printContent p >> return False+               'p' -> liftIO $ printContentWithPager p >> return False+               'r' -> printCurrent >> return False+               'l' -> printSelected >> printCurrent >> return False+               'x' -> liftIO $ printSummary p >> return False                'd' -> skipAll >> return True-               'g' -> backAll >> showCur >> return False+               'g' -> backAll >> printCurrent >> return False                'a' ->                    do                      askConfirmation@@ -837,13 +856,13 @@                'q' -> liftIO $                       do putStrLn $ capitalize jn ++ " cancelled."                          exitSuccess-               'j' -> skipOne >> showCur >> return False-               'k' -> backOne >> showCur >> return False+               'j' -> skipOne >> printCurrent >> return False+               'k' -> backOne >> printCurrent >> return False                _   -> do                  liftIO . putStrLn $ helpFor jn basicOptions advancedOptions                  return False -lastQuestion :: (Commute p, Invert p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)+lastQuestion :: (Commute p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)              => InteractiveSelectionM p wX wY Bool lastQuestion = do   jn <- asks jobname@@ -861,27 +880,25 @@                  | c `elem` "qn" -> liftIO $                                     do putStrLn $ jn ++" cancelled."                                        exitSuccess-               'g' -> backAll >> showCur >> return False+               'g' -> backAll >> printCurrent >> return False                'l' -> printSelected >> return False-               'k' -> backOne >> showCur >> return False+               'k' -> backOne >> printCurrent >> return False                _ -> do                  liftIO . putStrLn $ helpFor "this confirmation prompt"                     basicOptions advancedOptions                  return False  -- | Shows the current patch as it should be seen by the user.-showCur :: (Invert p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)-        => InteractiveSelectionM p wX wY ()-showCur = do+printCurrent :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)+             => InteractiveSelectionM p wX wY ()+printCurrent = do   o <- asks opts-  p <- asks pristine+  pr <- asks pristine   c <- currentPatch-  whichch <- asks whichChanges   case c of-      Nothing -> return ()-      Just (Sealed2 lp) -> do-             let reprCur = repr whichch lp-             liftIO . unseal2 (printFriendly p (verbosity o) (summary o) (withContext o)) $ reprCur+    Nothing -> return ()+    Just (Sealed2 lp) ->+      liftIO $ printFriendly pr (verbosity o) (withSummary o) (withContext o) $ unLabel lp  -- | The interactive part of @darcs changes@ textView :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)@@ -891,9 +908,11 @@ textView _ _ _ _ [] = return () textView o n_max n             ps_done ps_todo@(p:ps_todo') = do-      unseal2 (printFriendly Nothing (verbosity o) (summary o) (withContext o)) p+      defaultPrintFriendly p       repeatThis -- prompt the user     where+        defaultPrintFriendly =+          unseal2 (printFriendly Nothing (verbosity o) (withSummary o) (withContext o))         prev_patch :: IO ()         prev_patch = case ps_done of                        [] -> repeatThis@@ -914,7 +933,8 @@           , KeyPress 'n' "skip to the next patch" ]         optionsView' =           [ KeyPress 'v' "view this patch in full"-          , KeyPress 'p' "view this patch in full with pager" ]+          , KeyPress 'p' "view this patch in full with pager"+          , KeyPress 'r' "view this patch" ]         optionsSummary' =           [ KeyPress 'x' "view a summary of this patch" ]         optionsNav' =@@ -926,7 +946,7 @@         basicOptions = [ options_yn ]         advancedOptions =                      (optionsView' ++-                        if summary o == YesSummary then [] else optionsSummary')+                        if withSummary o == YesSummary then [] else optionsSummary')                   : [ optionsNav' ]         prompt' = "Shall I view this patch? "                ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")"@@ -934,12 +954,14 @@         repeatThis = do           yorn <- promptChar (PromptConfig prompt' (keysFor basicOptions) (keysFor advancedOptions) (Just 'n') "?h")           case yorn of-            'y' -> unseal2 printPatch p >> next_patch+            'y' -> unseal2 printContent p >> next_patch             'n' -> next_patch-            'v' -> unseal2 printPatch p >> repeatThis-            'p' -> unseal2 printPatchPager p >> repeatThis-            'x' -> do putDocLn $ prefix "    " $ unseal2 Darcs.Patch.summary p+            'v' -> unseal2 printContent p >> repeatThis+            'p' -> unseal2 printContentWithPager p >> repeatThis+            'r' -> do defaultPrintFriendly p                       repeatThis+            'x' -> do unseal2 printSummary p+                      repeatThis             'q' -> exitSuccess             'k' -> prev_patch             'j' -> next_patch@@ -959,7 +981,6 @@   o <- asks opts   crit <- asks matchCriterion   jn <- asks jobname-  whichch <- asks whichChanges   (skipped :> unskipped) <- liftChoices $ spanFL_M                                  (state . patchSlot >=> return . decided)                                  lps_todo@@ -967,8 +988,7 @@   when (numSkipped > 0) . liftIO $ show_skipped o jn numSkipped skipped   let boringThenInteresting =           if selectDeps o == AutoDeps-          then spanFL (not. mcFunction crit whichch)-                                 unskipped+          then spanFL (not . mcFunction crit . unLabel) unskipped           else NilFL :> unskipped   case boringThenInteresting of     boring :> interesting ->@@ -984,7 +1004,8 @@       _these_ n  = show n ++ " already decided " ++ _elem_ n ""       _elem_ n = englishNum n (Noun "patch")       showskippedpatch :: ShowPatch p => FL (LabelledPatch p) wY wT -> IO ()-      showskippedpatch = sequence_ . mapFL (printSummary . unLabel)+      showskippedpatch =+        putDocLnWith fancyPrinters . vcat . mapFL (showFriendly NormalVerbosity NoSummary . unLabel)  decided :: Slot -> Bool decided InMiddle = False@@ -1004,26 +1025,32 @@                 -> PatchSelectionOptions                 -> [PatchInfo] -> IO [PatchInfo] askAboutDepends repository pa' ps_opts olddeps = do-  -- ideally we'd just default the olddeps to yes but still ask about them.+  -- Ideally we'd just default the olddeps to yes but still ask about them.   -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would   -- have to have this support added first.-  pps <- readTentativeRepo repository (repoLocation repository)-  pa <- n2pia `fmap` anonymous (fromPrims pa')-  -- FIXME: this code is completely unreadable-  FlippedSeal ps <--    return $ case pps of PatchSet _ x -> FlippedSeal (x+>>+(pa:>:NilFL))-  let my_lps = labelPatches Nothing ps-      pc = mkPatchChoices my_lps-      tas =-        case catMaybes (mapFL (\lp -> if pa `unsafeCompare` unLabel lp || info (unLabel lp) `elem` olddeps-                                          then Just (label lp) else Nothing) my_lps) of+  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+  -- and only return a list of PatchInfo+  pa <- n2pia . flip adddeps olddeps <$> anonymous pa'+  -- get rid of all (implicit and explicit) dependencies of pa+  _ :> _ :> non_deps <- return $ commuteWhatWeCanRL (untagged :> pa)+  candidates :> _ <-+    runSelection (reverseRL non_deps) $+      selectionConfig FirstReversed "depend on" ps_opts+        { matchFlags = [], interactive = True } Nothing Nothing+  return $ olddeps `union` independentPatchIds (reverseFL candidates) -                [] -> error "askAboutDepends: []"-                tgs -> tgs-  Sealed2 ps' <- return $-    case getChoices (forceFirsts tas pc) of-      _ :> mc :> _ -> Sealed2 $ mapFL_FL unLabel mc-  (deps:>_) <- runSelection ps' $-                 selectionContext FirstReversed "depend on" ps_opts-                    { matchFlags = [], interactive = True } Nothing Nothing-  return $ olddeps `union` mapFL info deps+-- | From an 'RL' of patches select the identities of those that are+-- not depended upon by later patches.+independentPatchIds :: (Commute p, Ident p) => RL p wX wY -> [PatchId p]+independentPatchIds NilRL = []+independentPatchIds (ps :<: p) =+  case commuteWhatWeCanRL (ps :> p) of+    _ :> _ :> non_deps ->+      ident p : independentPatchIds non_deps
src/Darcs/UI/TheCommands.hs view
@@ -17,7 +17,6 @@  module Darcs.UI.TheCommands ( commandControlList ) where -import Prelude ()  import Darcs.UI.Commands.Add ( add ) import Darcs.UI.Commands.Amend ( amend, amendrecord )
src/Darcs/UI/Usage.hs view
@@ -1,25 +1,12 @@--- | This module provides a variant of 'System.Console.GetOpt.usageInfo'.------  Unlike the standard @usageInfo@ function, lists of long switches are broken---  across multiple lines to economise on columns. For example,------  @---    -r  --recursive           add contents of subdirectories---        --not-recursive,---        --no-recursive        don't add contents of subdirectories---  @- {-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Usage-    ( usageInfo-    , formatOptions-    , getCommandHelp+    ( getCommandHelp+    , getSuperCommandHelp     , getCommandMiniHelp     , usage     , subusage     ) where -import Prelude () import Darcs.Prelude  import Data.Functor.Compose@@ -28,8 +15,8 @@ import Darcs.UI.Commands     ( CommandControl(..)     , DarcsCommand(..)-    , wrappedCommandName-    , wrappedCommandDescription+    , commandName+    , commandDescription     , getSubcommands     , commandAlloptions     )@@ -56,16 +43,6 @@          sameLen xs     = flushLeft ((maximum . map length) xs) xs          flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] --- | Variant of 'System.Console.GetOpt.usageInfo'.--- Return a string describing the usage of a command, derived from the header--- (first argument) and the options described by the second argument.------ Sequences of long switches are presented on separate lines.-usageInfo :: String         -- header-          -> [DarcsOptDescr a]    -- option descriptors-          -> String          -- nicely formatted decription of options-usageInfo header optDescrs = unlines (header:formatOptions optDescrs)- -- Mild variant of the standard definition: 'losFmt' is a list rather than a -- comma separated string. fmtOpt :: DarcsOptDescr a -> [(String,[String],String)]@@ -97,36 +74,34 @@     [ "Usage: darcs COMMAND ..."     , "Commands:" $$ usageHelper cs     , vcat-      [ "Use 'darcs COMMAND --help' for help on a single command."-      , "Use 'darcs --version' to see the darcs version number."-      , "Use 'darcs --exact-version' to see a detailed darcs version."+      [ "Use 'darcs help COMMAND' or 'darcs COMMAND --help' for help on a single command."       , "Use 'darcs help patterns' for help on patch matching."       , "Use 'darcs help environment' for help on environment variables."       , "Use 'darcs help manpage' to display help in the manpage format."       , "Use 'darcs help markdown' to display help in the markdown format."+      , "Use 'darcs --version' to see the darcs version number."+      , "Use 'darcs --exact-version' to see a detailed darcs version."       ]     , "Check bug reports at http://bugs.darcs.net/"     ] -subusage :: DarcsCommand pf -> String-subusage super = renderString $ vsep-    [ header-    , subcommandsHelp+subusage :: DarcsCommand -> Doc+subusage super = vsep+    [ superUsage super $$ text (commandDescription super)+    , usageHelper (getSubcommands super)+    , "Options:"     , vcat $ map text $ formatOptions $ odesc stdCmdActions-    , text $ commandHelp super+    , commandHelp super     ]-  where-    usageHelp = hsep $ map text-        [ "Usage:"-        , commandProgramName super-        , commandName super-        , "SUBCOMMAND ..."-        ]-    header = usageHelp $$ text (commandDescription super)-    subcommandsHelp = case getSubcommands super of-        [] -> mempty-        subcommands -> usageHelper subcommands +superUsage :: DarcsCommand -> Doc+superUsage super = hsep $ map text+    [ "Usage:"+    , commandProgramName super+    , commandName super+    , "SUBCOMMAND [OPTION]..."+    ]+ usageHelper :: [CommandControl] -> Doc usageHelper xs = vsep (groups xs)   where@@ -142,17 +117,17 @@         (g:gs) -> (cmdHelp c $$ g) : gs      cmdHelp c = text $ "  " ++-      padSpaces maxwidth (wrappedCommandName c) ++-      wrappedCommandDescription c+      padSpaces maxwidth (commandName c) +++      commandDescription c      padSpaces n s = s ++ replicate (n - length s) ' '      maxwidth = maximum $ 15 : (map cwidth xs) -    cwidth (CommandData c) = length (wrappedCommandName c) + 2+    cwidth (CommandData c) = length (commandName c) + 2     cwidth _               = 0 -getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String+getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String getCommandMiniHelp msuper cmd = renderString $ vsep     [ getCommandHelpCore msuper cmd     , hsep $ map text@@ -164,13 +139,13 @@         ]     ] -getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc+getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> Doc getCommandHelp msuper cmd = vsep     [ getCommandHelpCore msuper cmd     , subcommandsHelp     , withHeading "Options:" basicOptionsHelp     , withHeading "Advanced options:" advancedOptionsHelp-    , text $ commandHelp cmd+    , commandHelp cmd     ]   where     withHeading _ [] = mempty@@ -184,14 +159,15 @@      subcommandsHelp =       case msuper of-        Nothing ->-          case getSubcommands cmd of-            [] -> mempty-            subcommands -> usageHelper subcommands+        Nothing -> usageHelper (getSubcommands cmd)         -- we don't want to list subcommands if we're already specifying them         Just _ -> mempty -getCommandHelpCore :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc+getSuperCommandHelp :: DarcsCommand -> Doc+getSuperCommandHelp super =+  vsep [superUsage super, usageHelper (getSubcommands super), commandHelp super]++getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> Doc getCommandHelpCore msuper cmd = vcat     [ hsep $         [ "Usage:"
src/Darcs/Util/AtExit.hs view
@@ -34,7 +34,6 @@     , withAtexit     ) where -import Prelude () import Darcs.Prelude  import Control.Concurrent.MVar
src/Darcs/Util/ByteString.hs view
@@ -30,14 +30,12 @@     , gzDecompress     -- * list utilities     , dropSpace-    , breakSpace     , linesPS     , unlinesPS     , hashPS     , breakFirstPS     , breakLastPS     , substrPS-    , readIntPS     , isFunky     , fromHex2PS     , fromPS2Hex@@ -57,7 +55,6 @@     , spec_betweenLinesPS     ) where -import Prelude () import Darcs.Prelude  import Codec.Binary.Base16 ( b16Enc, b16Dec )@@ -75,7 +72,7 @@ import System.IO.Unsafe         ( unsafePerformIO )  import Data.Bits                ( rotateL )-import Data.Char                ( ord, isSpace, toLower, toUpper )+import Data.Char                ( ord, toLower, toUpper ) import Data.Word                ( Word8 ) import Data.Int                 ( Int32, Int64 ) import Data.List                ( intersperse )@@ -94,30 +91,21 @@ import System.Mem( performGC ) import System.Posix.Files( fileSize, getSymbolicLinkStatus ) --- | readIntPS skips any whitespace at the beginning of its argument, and--- reads an Int from the beginning of the PackedString.  If there is no--- integer at the beginning of the string, it returns Nothing, otherwise it--- just returns the int read, along with a B.ByteString containing the--- remainder of its input.--readIntPS :: B.ByteString -> Maybe (Int, B.ByteString)-readIntPS = BC.readInt . BC.dropWhile isSpace- ------------------------------------------------------------------------ -- A locale-independent isspace(3) so patches are interpreted the same everywhere. -- ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r') isSpaceWord8 :: Word8 -> Bool-isSpaceWord8 = (`elem` [0x20, 0x09, 0x0A, 0x0D])+isSpaceWord8 0x20 = True+isSpaceWord8 0x09 = True+isSpaceWord8 0x0A = True+isSpaceWord8 0x0D = True+isSpaceWord8 _    = False {-# INLINE isSpaceWord8 #-}  -- | Drop leading white space, where white space is defined as -- consisting of ' ', '\t', '\n', or '\r'. dropSpace :: B.ByteString -> B.ByteString dropSpace bs = B.dropWhile isSpaceWord8 bs---- | Split at first occurrence of ' ', '\t', '\n', or '\r'.-breakSpace :: B.ByteString -> (B.ByteString, B.ByteString)-breakSpace bs = B.break isSpaceWord8 bs  ------------------------------------------------------------------------
src/Darcs/Util/CommandLine.hs view
@@ -35,7 +35,6 @@     , addUrlencoded     ) where -import Prelude () import Darcs.Prelude  import Control.Arrow ( (***) )
src/Darcs/Util/Compat.hs view
@@ -2,42 +2,26 @@  module Darcs.Util.Compat     ( stdoutIsAPipe-    , mkStdoutTemp     , canonFilename     , maybeRelink     , atomicCreate     , sloppyAtomicCreate     ) where -import Prelude () import Darcs.Prelude  import Darcs.Util.File ( withCurrentDirectory )-#ifdef WIN32-import Data.Bits ( (.&.) )-import System.Random ( randomIO )-import Numeric ( showHex )-#else-#endif  import Control.Monad ( unless ) import Foreign.C.Types ( CInt(..) )-import Foreign.C.String ( CString, withCString-#ifndef WIN32-                        , peekCString-#endif-                        )-+import Foreign.C.String ( CString, withCString ) import Foreign.C.Error ( throwErrno, eEXIST, getErrno ) import System.Directory ( getCurrentDirectory )-import System.IO ( hFlush, stdout, stderr, hSetBuffering,-                   BufferMode(NoBuffering) ) import System.IO.Error ( mkIOError, alreadyExistsErrorType ) import System.Posix.Files ( stdFileMode )-import System.Posix.IO ( openFd, closeFd, stdOutput, stdError,-                         dupTo, defaultFileFlags, exclusive,+import System.Posix.IO ( openFd, closeFd,+                         defaultFileFlags, exclusive,                          OpenMode(WriteOnly) )-import System.Posix.Types ( Fd(..) )  import Darcs.Util.SignalHandler ( stdoutIsAPipe ) @@ -53,48 +37,6 @@                              return $ fd ++ "/" ++ simplefilename     where     simplefilename = reverse $ takeWhile (/='/') $ reverse f--#ifdef WIN32-mkstempCore :: FilePath -> IO (Fd, String)-mkstempCore fp- = do r <- randomIO-      let fp' = fp ++ showHexLen 6 (r .&. 0xFFFFFF :: Int)-      fd <- openFd fp' WriteOnly (Just stdFileMode) flags-      return (fd, fp')-  where flags = defaultFileFlags { exclusive = True }--showHexLen :: (Integral a, Show a)-           => Int-           -> a-           -> String-showHexLen n x = let s = showHex x ""-                 in replicate (n - length s) ' ' ++ s-#else-mkstempCore :: String -> IO (Fd, String)-mkstempCore str = withCString (str++"XXXXXX") $-    \cstr -> do fd <- c_mkstemp cstr-                if fd < 0-                  then throwErrno $ "Failed to create temporary file "++str-                  else do str' <- peekCString cstr-                          fname <- canonFilename str'-                          return (Fd fd, fname)--foreign import ccall unsafe "static stdlib.h mkstemp"-    c_mkstemp :: CString -> IO CInt-#endif--mkStdoutTemp :: String -> IO String-mkStdoutTemp str =   do (fd, fn) <- mkstempCore str-                        hFlush stdout-                        hFlush stderr-                        _ <- dupTo fd stdOutput-                        _ <- dupTo fd stdError-                        hFlush stdout-                        hFlush stderr-                        hSetBuffering stdout NoBuffering-                        hSetBuffering stderr NoBuffering-                        return fn-   foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink
src/Darcs/Util/DateMatcher.hs view
@@ -15,8 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE ExistentialQuantification #-}- -- | -- Module      : Darcs.Util.DateMatcher -- Copyright   : 2004 David Roundy@@ -36,7 +34,6 @@     , testDateAt     ) where -import Prelude () import Darcs.Prelude  import Control.Exception ( catchJust )
src/Darcs/Util/DateTime.hs view
@@ -7,7 +7,6 @@     , formatDateTime, fromClockTime, parseDateTime, startOfTime     ) where -import Prelude () import Darcs.Prelude  import qualified Data.Time.Calendar as Calendar ( fromGregorian )
src/Darcs/Util/Diff.hs view
@@ -3,7 +3,6 @@     , DiffAlgorithm(..)     ) where -import Prelude () import Darcs.Prelude  import qualified Darcs.Util.Diff.Myers as M ( getChanges )
src/Darcs/Util/Diff/Myers.hs view
@@ -58,7 +58,6 @@     , getSlice     ) where -import Prelude () import Darcs.Prelude  import Control.Monad@@ -134,7 +133,7 @@                       Just (_,_,False,_) -> Nothing                       Just (False,True,True,_) -> Just (i, h)                       Just (True,True,True,_) -> Just (i, markColl)-                      Nothing -> impossible+                      Nothing -> error "impossible case"          a' = mapMaybe get [(i, ah!i) | i <- range (bounds ah)]         b' = mapMaybe get [(i, bh!i) | i <- range (bounds bh)]@@ -163,7 +162,7 @@      _ <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b 0 0 (aLen h_a) (aLen h_b)      let unchanged ar = do {xs <- getElems ar; return $ length (filter not xs) -1}      err <- liftM2 (/=) (unchanged c_a) (unchanged c_b)-     when err impossible+     when err $ error "impossible case"      -- Mark common lines at beginning and end      mapM_ (\ i -> writeArray c_a i False ) [1..(off_a - 1)]      mapM_ (\ i -> writeArray c_b i False ) [1..(off_b - 1)]@@ -172,7 +171,7 @@      shiftBoundaries c_a c_b p_a 1 1      shiftBoundaries c_b c_a p_b 1 1      err1 <- liftM2 (/=) (unchanged c_a) (unchanged c_b)-     when err1 impossible+     when err1 $ error "impossible case"      c_a' <- unsafeFreeze c_a      c_b' <- unsafeFreeze c_b      return (c_a', c_b'))@@ -211,7 +210,7 @@                                 off_a' off_b' l_a' l_b' del dodd              when ((xmid == 0 && ymid == 0) || (xmid == l_a' && ymid == l_b')                    || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b'))-                     impossible+                     $ error "impossible case"              c1 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b                           off_a' off_b' xmid ymid              c2 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b@@ -333,10 +332,10 @@                 else return (i2, j2)        shiftBackward start i j =          if start > 1 && p_a!(i-1) == p_a!(start-1)-            then do when (i == start) impossible+            then do when (i == start) $ error "impossible case"                     b1 <- readArray c_a (i-1)                     b2 <- readArray c_a (start-1)-                    when (not b1 || b2) impossible+                    when (not b1 || b2) $ error "impossible case"                     writeArray c_a (i-1) False                     writeArray c_a (start-1) True                     b <- if start > 2 then readArray c_a (start-2)@@ -350,10 +349,10 @@          if i <= aLen p_a && p_a!i == p_a!start &&              -- B.empty at the end of file marks empty line after final newline              not ((i == aLen p_a) && (p_a!i == B.empty))-            then do when (i == start) impossible+            then do when (i == start) $ error "impossible case"                     b1 <- readArray c_a i                     b2 <- readArray c_a start-                    when (not b2 ||  b1) impossible+                    when (not b2 ||  b1) $ error "impossible case"                     writeArray c_a i True                     writeArray c_a start False                     i0 <- nextUnchanged c_a (i+1)@@ -373,8 +372,8 @@             then return (start,i,j)             else do b1 <- readArray c_a (i-1)                     b2 <- readArray c_a (start-1)-                    when (not b1 || b2) impossible-                    when (p_a!(i-1) /= p_a!(start-1)) impossible+                    when (not b1 || b2) $ error "impossible case"+                    when (p_a!(i-1) /= p_a!(start-1)) $ error "impossible case"                     writeArray c_a (i-1) False                     writeArray c_a (start-1) True                     j' <- prevUnchanged c_b (j-1)
src/Darcs/Util/Diff/Patience.hs view
@@ -18,7 +18,6 @@     ( getChanges     ) where -import Prelude () import Darcs.Prelude  import Data.List ( sort )@@ -130,8 +129,8 @@                       (na, _:nb) ->                          i' `seq` easydiff i oa na ++ nc i' xs ob nb                              where i' = i + length (concat na) + length x-                      (_,[]) -> impossible-                (_,[]) -> impossible+                      (_,[]) -> error "impossible case"+                (_,[]) -> error "impossible case"           easydiff i o n = genNestedChanges brs i oo nn               where (oo, nn) = (concat o, concat n) genNestedChanges [] i o n = mkdiff (all (`elem` borings)) i mylcs o n@@ -264,8 +263,8 @@                    (c1,_:c2) -> case break (==b) ds of                                   ([],_:d2) -> b : joinU bs c2 d2                                   (d1,_:d2) -> lcs c1 d1 ++ b : joinU bs c2 d2-                                  _ -> impossible-                   _ -> impossible+                                  _ -> error "impossible case"+                   _ -> error "impossible case"           findUnique xs = S.fromList $ gru $ sort xs           gru (x:x':xs) | x == x' = gru (dropWhile (==x) xs)           gru (x:xs) = x : gru xs
src/Darcs/Util/Download.hs view
@@ -9,21 +9,31 @@ -- Portability : portable  module Darcs.Util.Download-    ( copyUrl-    , copyUrlFirst-    , setDebugHTTP+    ( setDebugHTTP     , disableHTTPPipelining     , maxPipelineLength-    , waitUrl     , Cachable(Cachable, Uncachable, MaxAge)     , environmentHelpProxy     , environmentHelpProxyPassword-    , ConnectionError(..)+    , ConnectionError+#ifdef HAVE_CURL+    , copyUrl+    , copyUrlFirst+    , waitUrl+#endif     ) where -import Prelude ( (^) )+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@@ -34,25 +44,19 @@ import Control.Monad.State ( evalStateT, get, modify, put, StateT ) import Control.Monad.STM ( atomically ) import Control.Monad.Trans ( liftIO )-import Data.IORef ( newIORef, readIORef, writeIORef, IORef ) import Data.Map ( Map ) import qualified Data.Map as Map import Data.Tuple ( swap )-import System.Directory ( copyFile )-import System.IO.Unsafe ( unsafePerformIO )-import System.Random ( randomRIO )+import 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 Darcs.Util.Workaround ( renameFile ) -#ifdef HAVE_CURL+import Darcs.Util.Download.Request import qualified Darcs.Util.Download.Curl as Curl-#else-import qualified Darcs.Util.Download.HTTP as HTTP #endif  {-# NOINLINE maxPipelineLengthRef #-}@@ -69,6 +73,7 @@ maxPipelineLength :: IO Int maxPipelineLength = readIORef maxPipelineLengthRef +#ifdef HAVE_CURL {-# NOINLINE urlNotifications #-} urlNotifications :: MVar (Map String (MVar (Maybe String))) urlNotifications = unsafePerformIO $ newMVar Map.empty@@ -84,11 +89,9 @@  urlThread :: TChan UrlRequest -> IO () urlThread ch = do-    junk <- flip showHex "" `fmap` randomRIO rrange+    junk <- flip showHex "" <$> seedToInteger <$> seedNew     evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk)   where-    rrange = (0, 2 ^ (128 :: Integer) :: Integer)-     urlThread' :: UrlM ()     urlThread' = do         empty <- liftIO $ atomically $ isEmptyTChan ch@@ -165,7 +168,7 @@             Nothing -> return ()             Just (u, rest) -> do                 case Map.lookup u (inProgress st) of-                    Nothing -> bug $ "bug in URL.checkWaitToStart " ++ u+                    Nothing -> error $ "bug in URL.checkWaitToStart " ++ u                     Just (f, _, c) -> do                         dbg $ "URL.requestUrl (" ++ u ++ "\n"                               ++ "-> " ++ f ++ ")"@@ -220,7 +223,7 @@         liftIO $ case Map.lookup u p of             Nothing ->                 -- A url finished downloading, but we don't have a record of it-                bug $ "bug in URL.waitNextUrl: " ++ u+                error $ "bug in URL.waitNextUrl: " ++ u             Just (f, fs, _) -> if null e                 then do -- Succesful download                     renameFile (createDownloadFileName f st) f@@ -266,6 +269,12 @@ 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@@ -273,28 +282,23 @@ minCachable (MaxAge a) _          = MaxAge a minCachable _          (MaxAge b) = MaxAge b minCachable _          _          = Cachable+#endif  disableHTTPPipelining :: IO () disableHTTPPipelining = writeIORef maxPipelineLengthRef 1  setDebugHTTP :: IO ()-requestUrl :: String -> FilePath -> Cachable -> IO String-waitNextUrl' :: IO (String, String, Maybe ConnectionError) pipeliningEnabled :: IO Bool  #ifdef HAVE_CURL  setDebugHTTP = Curl.setDebugHTTP-requestUrl = Curl.requestUrl-waitNextUrl' = Curl.waitNextUrl pipeliningEnabled = Curl.pipeliningEnabled  #else  setDebugHTTP = return ()-requestUrl = HTTP.requestUrl-waitNextUrl' = HTTP.waitNextUrl-pipeliningEnabled = return False+pipeliningEnabled = return True  #endif
src/Darcs/Util/Download/Curl.hs view
@@ -4,7 +4,6 @@  #ifdef HAVE_CURL -import Prelude () import Darcs.Prelude  import Control.Exception ( bracket )
− src/Darcs/Util/Download/HTTP.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE CPP #-}--module Darcs.Util.Download.HTTP-    ( fetchUrl, postUrl, requestUrl, waitNextUrl-    ) where--import Prelude ()-import Darcs.Prelude--import Darcs.Util.Global ( debugFail )--import Darcs.Util.Download.Request ( ConnectionError(..) )--import Control.Exception ( catch, IOException )-import Data.IORef ( newIORef, readIORef, writeIORef, IORef )-import Network.HTTP-import Network.Browser ( browse, request, setCheckForProxy, setErrHandler, setOutHandler )-import Network.URI-import System.IO.Error ( ioeGetErrorString )-import System.IO.Unsafe ( unsafePerformIO )-import Darcs.Util.Global ( debugMessage )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Version ( version )--fetchUrl :: String -> IO String-postUrl-    :: String     -- ^ url-    -> String     -- ^ body-    -> String     -- ^ mime type-    -> IO ()  -- ^ result--requestUrl :: String -> FilePath -> a -> IO String-waitNextUrl :: IO (String, String, Maybe ConnectionError)--headers :: [Header]-headers =  [Header HdrUserAgent $ "darcs-HTTP/" ++ version]--fetchUrl url = case parseURI url of-    Nothing -> fail $ "Invalid URI: " ++ url-    Just uri -> do debugMessage $ "Fetching over HTTP:  "++url-                   resp <- catch (browse $ do-                     setCheckForProxy True-                     setOutHandler debugMessage-                     setErrHandler debugMessage-                     request Request { rqURI = uri,-                                       rqMethod = GET,-                                       rqHeaders = headers,-                                       rqBody = "" })-                     (\(err :: IOException) -> debugFail $ show err)-                   case resp of-                     (_, res@Response { rspCode = (2,0,0) }) -> return (rspBody res)-                     (_, Response { rspCode = (x,y,z) }) ->-                         debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error getting " ++ show uri--postUrl url body mime = case parseURI url of-    Nothing -> fail $ "Invalid URI: " ++ url-    Just uri -> do debugMessage $ "Posting to HTTP:  "++url-                   resp <- catch (browse $ do-                     setCheckForProxy True-                     setOutHandler debugMessage-                     setErrHandler debugMessage-                     request Request { rqURI = uri,-                                       rqMethod = POST,-                                       rqHeaders = headers ++ [Header HdrContentType mime,-                                                               Header HdrAccept "text/plain",-                                                               Header HdrContentLength-                                                                        (show $ length body) ],-                                       rqBody = body })-                     (\(err :: IOException) -> debugFail $ show err)-                   case resp of-                     (_, res@Response { rspCode = (2,y,z) }) -> do-                        putStrLn $ "Success 2" ++ show y ++ show z-                        putStrLn (rspBody res)-                        return ()-                     (_, res@Response { rspCode = (x,y,z) }) -> do-                        putStrLn $ rspBody res-                        debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error posting to " ++ show uri--requestedUrl :: IORef (String, FilePath)-requestedUrl = unsafePerformIO $ newIORef ("", "")--requestUrl u f _ = do-  (u', _) <- readIORef requestedUrl-  if null u'-     then do writeIORef requestedUrl (u, f)-             return ""-     else return "URL already requested"--waitNextUrl = do-  (u, f) <- readIORef requestedUrl-  if null u-     then return ("", "No URL requested", Nothing)-     else do writeIORef requestedUrl ("", "")-             e <- (fetchUrl u >>= \s -> B.writeFile f (BC.pack s) >> return "") `catch` h-             let ce = case e of-                       "timeout" -> Just OperationTimeout-                       _         -> Nothing-             return (u, e, ce)-    where h = return . ioeGetErrorString
src/Darcs/Util/Download/Request.hs view
@@ -15,7 +15,6 @@     , ConnectionError(..)     ) where -import Prelude () import Darcs.Prelude  import Data.List ( delete )
src/Darcs/Util/Encoding.hs view
@@ -27,7 +27,6 @@     , encodeUtf8, decodeUtf8     ) where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString as B
src/Darcs/Util/Encoding/Win32.hs view
@@ -21,12 +21,11 @@ -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE -- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Util.Encoding.Win32     ( encode, decode     ) where -import Prelude () import Darcs.Prelude  import Data.ByteString.Internal ( createAndTrim )@@ -39,6 +38,8 @@     ( CodePage, nullPtr, getConsoleCP, getACP     , LPCSTR, LPWSTR, LPCWSTR, LPBOOL, DWORD ) +#include <windows_cconv.h>+ -- | Encode a Unicode 'String' into a 'ByteString' suitable for the current -- console. encode :: String -> IO B.ByteString@@ -51,7 +52,7 @@ ------------------------ -- Multi-byte conversion -foreign import stdcall "WideCharToMultiByte" wideCharToMultiByte+foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte         :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt                 -> LPCSTR -> LPBOOL -> IO CInt @@ -65,7 +66,7 @@         fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)                     (castPtr outBuff) outSize nullPtr nullPtr -foreign import stdcall "MultiByteToWideChar" multiByteToWideChar+foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar         :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt  codePageToUnicode :: CodePage -> B.ByteString -> IO String
src/Darcs/Util/English.hs view
@@ -32,12 +32,13 @@  module Darcs.Util.English where -import Prelude () import Darcs.Prelude  import Data.Char (toUpper) import Data.List (isSuffixOf) +import Darcs.Util.Printer ( Doc, vcat, text )+ -- | > englishNum 0 (Noun "watch") "" == "watches" --   > englishNum 1 (Noun "watch") "" == "watch" --   > englishNum 2 (Noun "watch") "" == "watches"@@ -87,6 +88,12 @@ andClauses, orClauses :: [String] -> String andClauses = itemize "and" orClauses = itemize "or"++anyOfClause :: [String] -> Doc+anyOfClause names = if length names > 1 then text "any of" else mempty++itemizeVertical :: Int -> [String] -> Doc+itemizeVertical indent = vcat . map (text . ((replicate indent ' ' ++ "- ") ++))  -- Should not be called with an empty list since this usually -- prints an extra space. We allow it for compatibility.
src/Darcs/Util/Exception.hs view
@@ -1,24 +1,37 @@-{-# Language MultiParamTypeClasses #-} module Darcs.Util.Exception     ( firstJustIO     , catchall+    , catchNonExistence     , clarifyErrors     , prettyException     , prettyError     , die+    , handleOnly+    , handleOnlyIOError+    , ifIOError+    , ifDoesNotExistError     ) where  -import Prelude () import Darcs.Prelude -import Control.Exception ( SomeException, Exception(fromException), catch )+import Control.Exception+    ( Exception(fromException)+    , SomeException+    , catch+    , handle+    , throwIO+    ) import Data.Maybe ( isJust )  import System.Exit ( exitFailure ) import System.IO ( stderr, hPutStrLn )-import System.IO.Error ( isUserError, ioeGetErrorString-                       , isDoesNotExistError, ioeGetFileName )+import System.IO.Error+    ( ioeGetErrorString+    , ioeGetFileName+    , isDoesNotExistError+    , isUserError+    )  import Darcs.Util.SignalHandler ( catchNonSignal ) @@ -27,6 +40,12 @@          -> 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+ -- | The firstJustM returns the first Just entry in a list of monadic -- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence -- operator evaluates all monadic members of the list before passing it along@@ -70,3 +89,23 @@ -- | Terminate the program with an error message. die :: String -> IO a die msg = hPutStrLn stderr msg >> exitFailure++-- | Handle only actual IO exceptions i.e. not "user errors" e.g. those raised+-- by calling 'fail'.+--+-- We use 'fail' all over the place to signify erroneous conditions and we+-- normally don't want to handle such errors.+handleOnlyIOError :: IO a -> IO a -> IO a+handleOnlyIOError = handleOnly (not . isUserError)++-- | Like 'handleOnlyIOError' but restricted to returning a given value.+ifIOError :: a -> IO a -> IO a+ifIOError use_instead = handleOnlyIOError (return use_instead)++-- | Like 'ifIOError' but restricted to handling non-existence.+ifDoesNotExistError :: a -> IO a -> IO a+ifDoesNotExistError use_instead = handleOnly isDoesNotExistError (return use_instead)++-- | Handle only a those exceptions for which the predicate succeeds.+handleOnly :: Exception e => (e -> Bool) -> IO a -> IO a -> IO a+handleOnly pred handler = handle (\e -> if pred e then handler else throwIO e)
src/Darcs/Util/Exec.hs view
@@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}  -- | -- Module      : Darcs.Util.Exec@@ -37,11 +37,11 @@     , ExecException(..)     ) where -import Prelude () import Darcs.Prelude  #ifndef WIN32 import Control.Exception ( bracket )+import Control.Monad ( forM_ ) import System.Posix.Env ( setEnv, getEnv, unsetEnv ) import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput ) #else@@ -119,7 +119,10 @@  _devNull :: FilePath #ifdef WIN32-_devNull = "NUL"+-- since GHC 8.6, Windows special devices need to be referred to using+-- "device namespace" syntax. See+-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/win32-dlls.html#windows-file-paths+_devNull = "\\\\.\\NUL" #else _devNull = "/dev/null" #endif@@ -149,7 +152,7 @@     -- because runProcess closes the Handles we pass it.     redirect Stdout             _    = Just `fmap` hDuplicate stdout -execInteractive :: String -> String -> IO ExitCode+execInteractive :: String -> Maybe String -> IO ExitCode #ifndef WIN32 {- This should handle arbitrary commands interpreted by the shell on Unix since@@ -157,18 +160,19 @@ the argument in any way, so we set an environment variable and call cmd "$DARCS_ARGUMENT" -}-execInteractive cmd arg = withoutProgress $ do+execInteractive cmd mArg = withoutProgress $ do     let var = "DARCS_ARGUMENT"     stdin `seq` return ()     withoutNonBlock $ bracket       (do oldval <- getEnv var-          setEnv var arg True+          forM_ mArg $ \arg ->+            setEnv var arg True           return oldval)       (\oldval ->          case oldval of               Nothing -> unsetEnv var               Just val -> setEnv var val True)-      (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"")+      (\_ -> withExit127 $ system $ cmd++ maybe "" (const (" \"$"++var++"\"")) mArg)  #else -- The `system' function passes commands to execute via cmd.exe (or@@ -185,9 +189,9 @@ -- SETLOCAL EnableDelayedExpansion makes sure that !variable! expansion is done -- correctly on systems where that function is not enabled by default. ---execInteractive cmd arg = withoutProgress $+execInteractive cmd mArg = withoutProgress $   withExit127 $ system $ "SETLOCAL EnableDelayedExpansion & " ++-                          cmd ++ " " ++ arg +++                          cmd ++ maybe "" (" " ++) mArg ++                           " & exit !errorlevel!" #endif
src/Darcs/Util/External.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Darcs.Util.External     ( cloneTree     , cloneFile@@ -21,7 +22,7 @@     ) import System.Directory     ( createDirectory-    , getDirectoryContents+    , listDirectory     , doesDirectoryExist     , doesFileExist     , renameFile@@ -37,14 +38,14 @@     , zipWithM_     ) -import Darcs.Util.Global ( defaultRemoteDarcsCmd )-import Darcs.Util.Download-    ( copyUrl-    , copyUrlFirst-    , waitUrl-    , Cachable(..)-    )+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@@ -54,31 +55,15 @@ 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.Browser-    ( browse-    , request-    , setErrHandler-    , setOutHandler-    , setAllowRedirects-    )-import Network.HTTP-    ( RequestMethod(GET)-    , rspCode-    , rspBody-    , rspReason-    , mkRequest-    ) import Network.URI     ( parseURI     , uriScheme     ) - copyFileOrUrl :: String    -- ^ remote darcs executable               -> FilePath  -- ^ path representing the origin file or URL               -> FilePath  -- ^ destination path@@ -93,30 +78,21 @@ copyLocal fou out = createLink fou out `catchall` cloneFile fou out  cloneTree :: FilePath -> FilePath -> IO ()-cloneTree = cloneTreeExcept []--cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()-cloneTreeExcept except source dest =+cloneTree source dest =  do fs <- getSymbolicLinkStatus source     if isDirectory fs then do-        fps <- getDirectoryContents source-        let fps' = filter (`notElem` (".":"..":except)) fps-            mk_source fp = source </> fp-            mk_dest   fp = dest   </> fp-        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')-     else fail ("cloneTreeExcept: Bad source " ++ source)-   `catch` \(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source)+        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 <- getDirectoryContents source-        let fps' = filter (`notElem` [".", ".."]) fps-            mk_source fp = source </> fp-            mk_dest   fp = dest   </> fp-        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')+        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)@@ -178,28 +154,23 @@ -- "fetchFilePS" for details. fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString fetchFileLazyPS x c = case parseURI x of-  Just x' | uriScheme x' == "http:" -> do-    rsp <- fmap snd . browse $ do-      setErrHandler . const $ return ()-      setOutHandler . const $ return ()-      setAllowRedirects True-      request $ mkRequest GET x'-    if rspCode rsp /= (2, 0, 0)-      then fail $ "fetchFileLazyPS: " ++ rspReason rsp-      else return $ rspBody rsp+  Just x' | uriScheme x' == "http:" -> HTTP.copyRemoteLazy x c   _ -> copyAndReadFile BL.readFile x c  gzFetchFilePS :: String -> Cachable -> IO B.ByteString gzFetchFilePS = copyAndReadFile gzReadFilePS -copyRemote :: String -> FilePath -> Cachable -> IO ()-copyRemote u v cache = copyUrlFirst u v cache >> waitUrl u- 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-speculateRemote u v = copyUrl u v 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
@@ -6,32 +6,32 @@     , withCurrentDirectory     , doesDirectoryReallyExist     , removeFileMayNotExist+    , getRecursiveContents+    , getRecursiveContentsFullPath     -- * OS-dependent special directories     , xdgCacheDir     , osxCacheDir-    , getDirectoryContents-    , getRecursiveContents-    , getRecursiveContentsFullPath     ) where -import Prelude ( lookup ) import Darcs.Prelude -import Control.Exception ( catch, bracket )+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, getDirectoryContents )-import System.IO.Error ( isDoesNotExistError, catchIOError )+                          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 )+import Darcs.Util.Exception ( catchall, catchNonExistence ) import Darcs.Util.Path( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )  withCurrentDirectory :: FilePathLike p@@ -57,12 +57,6 @@ removeFileMayNotExist :: FilePathLike p => p -> IO () removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) () -catchNonExistence :: IO a -> a -> IO a-catchNonExistence job nonexistval =-    catch job $-    \e -> if isDoesNotExistError e then return nonexistval-                                   else ioError e- -- |osxCacheDir assumes @~/Library/Caches/@ exists. osxCacheDir :: IO (Maybe FilePath) osxCacheDir = do@@ -95,9 +89,8 @@ -- directories. getRecursiveContents :: FilePath -> IO [FilePath] getRecursiveContents topdir = do-  names <- getDirectoryContents topdir-  let properNames = filter (`notElem` [".", ".."]) names-  paths <- forM properNames $ \name -> do+  entries <- listDirectory topdir+  paths <- forM entries $ \name -> do     let path = topdir </> name     isDir <- doesDirectoryExist path     if isDir@@ -110,9 +103,8 @@ -- Unlike getRecursiveContents this function returns the full path. getRecursiveContentsFullPath :: FilePath -> IO [FilePath] getRecursiveContentsFullPath topdir = do-  names <- getDirectoryContents topdir-  let properNames = filter (`notElem` [".", ".."]) names-  paths <- forM properNames $ \name -> do+  entries <- listDirectory topdir+  paths <- forM entries $ \name -> do     let path = topdir </> name     isDir <- doesDirectoryExist path     if isDir
src/Darcs/Util/Global.hs view
@@ -36,25 +36,18 @@     , withDebugMode     , setDebugMode     , debugMessage-    , debugFail     , putTiming     , addCRCWarning     , getCRCWarnings     , resetCRCWarnings-    , addBadSource-    , getBadSourcesList-    , isBadSource     , darcsdir     , darcsLastMessage     , darcsSendMessage     , darcsSendMessageFinal     , defaultRemoteDarcsCmd-    , isReachableSource-    , addReachableSource     ) where  -import Prelude () import Darcs.Prelude  import Control.Monad ( when )@@ -92,10 +85,6 @@ debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m  -debugFail :: String -> IO a-debugFail m = debugMessage m >> fail m-- putTiming :: IO () putTiming = when timingsMode $ do     t <- getClockTime >>= toCalendarTime@@ -132,44 +121,6 @@  resetCRCWarnings :: IO () resetCRCWarnings = writeIORef _crcWarningList []---_badSourcesList :: IORef [String]-_badSourcesList = unsafePerformIO $ newIORef []-{-# NOINLINE _badSourcesList #-}---addBadSource :: String -> IO ()-addBadSource cache = modifyIORef _badSourcesList (cache:)---getBadSourcesList :: IO [String]-getBadSourcesList = readIORef _badSourcesList---isBadSource :: IO (String -> Bool)-isBadSource = do-    badSources <- getBadSourcesList-    return (`elem` badSources)---_reachableSourcesList :: IORef [String]-_reachableSourcesList = unsafePerformIO $ newIORef []-{-# NOINLINE _reachableSourcesList #-}---addReachableSource :: String -> IO ()-addReachableSource src = modifyIORef _reachableSourcesList (src:)---getReachableSources :: IO [String]-getReachableSources = readIORef _reachableSourcesList---isReachableSource :: IO (String -> Bool)-isReachableSource =  do-    reachableSources <- getReachableSources-    return (`elem` reachableSources)   darcsdir :: String
+ src/Darcs/Util/Graph.hs view
@@ -0,0 +1,262 @@+{- The idea of the ltmis algorithm is based on this paper:++Loukakis, E & Tsouros, Constantin. (1981). A depth first search algorithm to+generate the family of maximal independent sets of a graph+lexicographically. Computing. 27. 349-366. 10.1007/BF02277184.++This is basically the same as Bron-Kerbosch but with two special+optimizations, one to avoid needless backtracking and one to avoid needless+branching. For large graphs the gains in efficiency are significant. On my+computer generating all MIS for the first 100000 graphs of size 12 takes+0.757 seconds with ltmis (True,True) and over 10 seconds with bkmis.++-}++{-# OPTIONS_GHC -Wno-name-shadowing #-}+module Darcs.Util.Graph+  ( Graph+  , Vertex+  , VertexSet+  , Component(..)+  -- * Algorithms+  , ltmis+  , bkmis+  , components+  -- * Generating graphs+  , genGraphs+  , genComponents+  -- * Properties+  , prop_ltmis_eq_bkmis+  , prop_ltmis_maximal_independent_sets+  , prop_ltmis_all_maximal_independent_sets+  , prop_components+  ) where++import Control.Monad ( filterM )+import Control.Monad.ST ( runST, ST )++import Data.List ( sort )+import qualified Data.Set as S++import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU++import Darcs.Prelude++-- | Vertices are represented as 'Int'.+type Vertex = Int++-- | Set of vertices, represented as a list for efficiency (yes, indeed).+type VertexSet = [Vertex]++-- | Undirected graph represented as a 'V.Vector' of adjacency 'VertexSet's.+type Graph = V.Vector VertexSet++data Component = Component Graph VertexSet deriving Show++-- | The neighbors of a 'Vertex' in a 'Graph'.+neighbours :: Graph -> Vertex -> VertexSet+neighbours g v = g V.! v++has_edge :: Graph -> Vertex -> Vertex -> Bool+has_edge g u v = u `elem` neighbours g v++has_any_edge :: Graph -> VertexSet -> Vertex -> Bool+has_any_edge g vs u = any (has_edge g u) vs++all_vertices :: Graph -> VertexSet+all_vertices g = [0..(gsize g - 1)]++-- | The number of vertices in a 'Graph'.+gsize :: Graph -> Int+gsize v = V.length v++-- * Maximal independent sets++-- | Simple helper type used in the 'ltmis' and 'components' algorithms.+type Helper = U.Vector Bool++-- | Determine the maximal independent sets in a 'Component' of a 'Graph'.+ltmis :: (Bool,Bool) -> Component -> [VertexSet]+ltmis (bt1,bt2) (Component g comp) =+    -- the map reverse is because we use (:) to add vertices to r+    -- when branching+    map reverse $ go [] 0 init_h+  where+    size = gsize g+    init_h = U.replicate (gsize g) True U.// zip comp (repeat False)+    -- h[v] = neighbours g v `intersectsWith` r || v `elem` r || v `notElem` comp+    go :: VertexSet -> Vertex -> Helper -> [VertexSet]+    go r !sep h =+      case candidates sep h of+        [] -> [r]+        br:_ ->+          (if bt1 && done_branching sep' h' then [] else go (br:r) sep' h')+          +++          (if bt2 && done_backtracking sep' h br then [] else go r sep' h)+          where+            h' = h U.// zip (br : neighbours g br) (repeat True)+            sep' = br + 1++    candidates :: Vertex -> Helper -> VertexSet+    candidates sep h = filter (not . (h U.!)) $ [sep..(size-1)]++    excludes :: Vertex -> Helper -> [Vertex]+    excludes sep h = filter (not . (h U.!)) [0 .. (sep-1)]++    is_candidate :: Vertex -> Helper -> Vertex -> Bool+    is_candidate sep h v = v >= sep && not ((h U.!) v)++    intersects_candidates :: Vertex -> Helper -> VertexSet -> Bool+    intersects_candidates sep h = any (is_candidate sep h)++    -- for some x in X, N(x) does not intersect C+    -- means whatever candidate we add we won't get an MIS+    -- so can stop branching+    done_branching :: Vertex -> Helper -> Bool+    done_branching sep h =+      any (not . intersects_candidates sep h) $ map (neighbours g) $ excludes sep h++    -- if done_backtracking (neighbours g v), then v must+    -- be a member of any MIS containing R+    done_backtracking :: Vertex -> Helper -> Vertex -> Bool+    done_backtracking sep h v = not $ intersects_candidates sep h $ neighbours g v++-- | The classic Bron-Kerbosch algorithm for determining the maximal+-- independent sets in a 'Graph'.+bkmis :: Graph -> [VertexSet]+bkmis g = reverse $ map reverse $ go [] [] (all_vertices g) where+  go r [] [] = [r]+  go r xs cs = loop xs cs where+    loop _ [] = []+    loop xs (c:cs) = loop (c:xs) cs ++ go (c:r) (res c xs) (res c cs)+    res v = filter (not . has_edge g v)++-- * Generating graphs++genGraph :: Monad m => (Int -> Int -> m VertexSet) -> Int -> m Graph+genGraph genSubset = go 0 where+  go _ 0 = return V.empty+  go s n = do -- list monad+    g <- go (s+1) (n-1)+    vs <- genSubset (s+1) (n-1)+    return $ V.modify (\h -> mapM_ (adjust h) vs) (V.cons vs g)+    where+      adjust g i = do+        vs <- MV.read g (i-s)+        MV.write g (i-s) (s:vs)++-- | Enumerate all (simple) graphs of a given size (number of vertices).+genGraphs :: Int -> [Graph]+genGraphs = genGraph subsets where+  -- Subsets of the n elements [s..(s+n-1)] (each subset is ordered)+  subsets _ 0 = return []+  subsets s n = do+    vs <- subsets (s+1) (n-1)+    [vs,s:vs]++genComponents :: Int -> [Component]+genComponents n = do+  g <- genGraphs n+  components g++-- * Connected components++-- | Split a 'Graph' into connected components. For efficiency we don't+-- represent the result as a list of Graphs, but rather of 'VertexSet's.+components :: Graph -> [Component]+components g = reverse $ map (Component g) $ runST go where+  size = gsize g+  go :: ST s [VertexSet]+  go = do+    mh <- MU.replicate size False+    loop 0 mh []+  loop v mh r+    | v == size = return r+    | otherwise = do+      c <- new_component v+      if null c+        then loop (v + 1) mh r+        else loop (v + 1) mh (c : r)+    where+      new_component v = do+        visited <- MU.read mh v+        if visited+          then return []+          else do+            -- mark v as visited+            MU.write mh v True+            cs <- mapM new_component (neighbours g v)+            return $ v : concat cs++-- * Properties++-- | Whether a 'VertexSet' is independent i.e. no edge exists between any+-- two of its vertices.+prop_is_independent_set :: Graph -> VertexSet -> Bool+prop_is_independent_set g vs = all (not . has_any_edge g vs) vs++-- | Whether a 'VertexSet' is maximally independent i.e. it is independent+-- and no longer independent if we add any other vertex.+prop_is_maximal_independent_set :: Component -> VertexSet -> Bool+prop_is_maximal_independent_set (Component g c) vs =+    prop_is_independent_set g vs &&+    all (has_any_edge g vs) other_vertices+  where+    other_vertices = filter (`notElem` vs) c++-- | Whether 'ltmis' is equivalent to 'bkmis'.+prop_ltmis_eq_bkmis :: Graph -> Bool+prop_ltmis_eq_bkmis g =+  ltmis (True, True) (Component g (all_vertices g)) == bkmis g++-- | Whether 'ltmis' generates only maximal independent sets.+prop_ltmis_maximal_independent_sets :: Component -> Bool+prop_ltmis_maximal_independent_sets sg =+  all (prop_is_maximal_independent_set sg) (ltmis (True, True) sg)++-- | Whether 'ltmis' generates /all/ maximal independent sets.+prop_ltmis_all_maximal_independent_sets :: Component -> Bool+prop_ltmis_all_maximal_independent_sets sg@(Component _ c) =+    all (not . prop_is_maximal_independent_set sg) other_subsets+  where+    mis = ltmis (True, True) sg+    all_subsets = powerset c+    other_subsets = filter (`notElem` mis) all_subsets++-- | Whether a list of 'VertexSet's of a 'Graph' is a partition of+-- the set of all its vertices.+prop_is_partition :: Graph -> [VertexSet] -> Bool+prop_is_partition g cs = sort (concat cs) == all_vertices g++-- | Whether there is no edge between a 'VertexSet' of a 'Graph' and the rest+-- of the 'Graph'.+prop_self_contained :: Graph -> VertexSet -> Bool+prop_self_contained g c =+  S.unions (map (S.fromList . neighbours g) c) `S.isSubsetOf` S.fromList c++-- | Whether a 'VertexSet' of a 'Graph' is connected.+prop_connected :: Graph -> VertexSet -> Bool+prop_connected g = not . any (prop_self_contained g) . proper_non_empty_subsets+  where+    proper_non_empty_subsets = filter (not . null) . tail . powerset++-- | Whether a 'VertexSet' is a connected component of the 'Graph'.+prop_connected_component :: Component -> Bool+prop_connected_component (Component g vs) =+  prop_self_contained g vs && prop_connected g vs++-- | Complete specification of the 'components' function.+prop_components :: Graph -> Bool+prop_components g =+    all prop_connected_component cs &&+      prop_is_partition g (map vertices cs) && all (== g) (map graph cs)+  where+    vertices (Component _ vs) = vs+    graph (Component g _) = g+    cs = components g++powerset :: VertexSet -> [VertexSet]+powerset = map sort . filterM (const [True, False])
+ src/Darcs/Util/HTTP.hs view
@@ -0,0 +1,104 @@+module Darcs.Util.HTTP ( copyRemote, copyRemoteLazy, speculateRemote, postUrl ) where++import Control.Concurrent.Async ( async, cancel, poll )+import Control.Exception ( catch )+import Control.Monad ( void , (>=>) )+import Crypto.Random ( seedNew, seedToInteger )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as BC++import Data.Conduit.Combinators ( sinkLazy )+import Network.HTTP.Simple+    ( HttpException(..)+    , Request+    , httpBS+    , httpSink+    , httpNoBody+    , getResponseBody+    , setRequestHeaders+    , setRequestMethod+    )+import Network.HTTP.Conduit ( parseUrlThrow )+import Network.HTTP.Types.Header+    ( hCacheControl+    , hPragma+    , hContentType+    , hAccept+    , hContentLength+    )+import Numeric ( showHex )+import System.Directory ( renameFile )++import Darcs.Prelude++import Darcs.Util.AtExit ( atexit )+import Darcs.Util.Download.Request ( Cachable(..) )+import Darcs.Util.Global ( debugMessage )++copyRemote :: String -> FilePath -> Cachable -> IO ()+copyRemote url path cachable = do+  junk <- flip showHex "" <$> seedToInteger <$> seedNew+  let tmppath = path ++ ".new_" ++ junk+  handleHttpAndUrlExn url+    (httpBS . 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 =+  handleHttpAndUrlExn url+    (flip httpSink (const sinkLazy) . addCacheControl cachable)++speculateRemote :: String -> FilePath -> IO ()+speculateRemote url path = do+  r <- async $ do+    debugMessage $ "Start speculating on " ++ url+    -- speculations are always Cachable+    copyRemote url path Cachable+    debugMessage $ "Completed speculating on " ++ url+  atexit $ do+    result <- poll r+    case result of+      Just (Right ()) ->+        debugMessage $ "Already completed speculating on " ++ url+      Just (Left e) ->+        debugMessage $ "Speculating on " ++ url ++ " failed: " ++ show e+      Nothing -> do+        debugMessage $ "Abort speculating on " ++ url+        cancel r++postUrl+  :: String -- ^ url+  -> BC.ByteString -- ^ body+  -> String -- ^ mime type+  -> IO () -- ^ result+postUrl url body mime =+    handleHttpAndUrlExn url (void . httpNoBody . setMethodAndHeaders)+  where+    setMethodAndHeaders =+      setRequestMethod (BC.pack "POST") .+      setRequestHeaders+        [ (hContentType, BC.pack mime)+        , (hAccept, BC.pack "text/plain")+        , (hContentLength, BC.pack $ show $ B.length body)+        ]++addCacheControl :: Cachable -> Request -> Request+addCacheControl Uncachable =+  setRequestHeaders [(hCacheControl, noCache), (hPragma, noCache)]+addCacheControl (MaxAge seconds) | seconds > 0 =+  setRequestHeaders [(hCacheControl, BC.pack $ "max-age=" ++ show seconds)]+addCacheControl _ = id++noCache :: BC.ByteString+noCache = BC.pack "no-cache"++handleHttpAndUrlExn :: String -> (Request -> IO a) -> IO a+handleHttpAndUrlExn url action =+  catch (parseUrlThrow url >>= action) (\case+    InvalidUrlException _ reason ->+      fail $ "Invalid URI: " ++ url ++ ", reason: " ++ reason+    HttpExceptionRequest _ hec {- :: HttpExceptionContent -}+     -> fail $ "Error getting " ++ show url ++ ": " ++ show hec)
src/Darcs/Util/Hash.hs view
@@ -1,50 +1,45 @@ --  Copyright (C) 2009-2011 Petr Rockai BSD3 --  Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li> -{-# LANGUAGE CPP, DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}---- TODO switch to cryptonite- module Darcs.Util.Hash     ( Hash(..)     , encodeBase16, decodeBase16, sha256, sha256sum, rawHash     , match     -- SHA1 related (patch metadata hash)-    , sha1PS, SHA1, showAsHex, sha1Xor, sha1zero, sha1short+    , sha1PS, SHA1(..), showAsHex, sha1Xor, sha1zero, sha1short+    , sha1Show, sha1Read  ) where -import qualified Crypto.Hash.SHA256 as SHA256 ( hashlazy, hash )+-- we currently have to depend on the memory package in addition to cryptonite+-- just so that we can import this single function+import Data.ByteArray ( convert )+ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Internal as BI ( toForeignPtr )  import qualified Codec.Binary.Base16 as B16 +import qualified Crypto.Hash as H+ import Data.Maybe( isJust, fromJust )-import Data.Char( toLower, toUpper, intToDigit )+import Data.Char( toLower, toUpper, intToDigit, ord ) -import Data.Binary ( Binary(..) )-import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR)-import Data.Word (Word8, Word32)-import Data.Data( Data )-import Data.Typeable( Typeable )-import Foreign.ForeignPtr ( withForeignPtr )-import Foreign.Ptr (Ptr, castPtr, plusPtr)-import Foreign.Marshal.Array (advancePtr)-import Foreign.Storable (peek, poke)-import System.IO.Unsafe (unsafePerformIO)+import Data.Binary ( Binary(..), decode, encode )+import Data.Bits ( xor, shiftL, (.|.) )+import Data.Word ( Word8, Word32 ) +import Darcs.Prelude + data Hash = SHA256 !B.ByteString           | NoHash-            deriving (Show, Eq, Ord, Read, Typeable, Data)+            deriving (Show, Eq, Ord, Read)  base16 :: B.ByteString -> B.ByteString-debase16 :: B.ByteString -> Maybe B.ByteString- base16 = BC.map toLower . B16.b16Enc++debase16 :: B.ByteString -> Maybe B.ByteString debase16 bs = case B16.b16Dec $ BC.map toUpper bs of                 Right (s, _) -> Just s                 Left _ -> Nothing@@ -63,11 +58,11 @@  -- | Compute a sha256 of a (lazy) ByteString. sha256 :: BL.ByteString -> Hash-sha256 bits = SHA256 $ SHA256.hashlazy bits+sha256 bits = SHA256 (convert (H.hashlazy bits :: H.Digest H.SHA256))  -- | Same as previous but general purpose. sha256sum :: B.ByteString -> String-sha256sum = BC.unpack . base16 . SHA256.hash+sha256sum = BC.unpack . base16 . convert . H.hashWith H.SHA256  rawHash :: Hash -> B.ByteString rawHash NoHash = error "Cannot obtain raw hash from NoHash."@@ -80,18 +75,17 @@  data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32   deriving (Eq,Ord)-data XYZ = XYZ !Word32 !Word32 !Word32  instance Show SHA1 where- show (SHA1 a b c d e) = concatMap showAsHex [a, b, c, d, e]+  show = BC.unpack . sha1Show  instance Binary SHA1 where   put (SHA1 a b c d e) = put a >> put b >> put c >> put d >> put e-  get = do a <- get ; b <- get ; c <- get ; d <- get ; e <- get ; return (SHA1 a b c d e)+  get = do a <- get; b <- get; c <- get; d <- get; e <- get; return (SHA1 a b c d e)  sha1Xor :: SHA1 -> SHA1 -> SHA1 sha1Xor (SHA1 a1 b1 c1 d1 e1) (SHA1 a2 b2 c2 d2 e2) =- SHA1 (a1 `xor` a2) (b1 `xor` b2) (c1 `xor` c2) (d1 `xor` d2) (e1 `xor` e2)+  SHA1 (a1 `xor` a2) (b1 `xor` b2) (c1 `xor` c2) (d1 `xor` d2) (e1 `xor` e2)  sha1zero :: SHA1 sha1zero = SHA1 0 0 0 0 0@@ -99,165 +93,9 @@ sha1short :: SHA1 -> Word32 sha1short (SHA1 a _ _ _ _) = a --- | Do something with the internals of a PackedString. Beware of--- altering the contents!-unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a-unsafeWithInternals ps f- = case BI.toForeignPtr ps of-   (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l- sha1PS:: B.ByteString -> SHA1-sha1PS s = abcde'- where s1_2 = sha1Step12PadLength s-       abcde = sha1Step3Init-       abcde' = unsafePerformIO-              $ unsafeWithInternals s1_2 (\ptr len ->-                    do let ptr' = castPtr ptr-#ifndef BIGENDIAN-                       fiddleEndianness ptr' len-#endif-                       sha1Step4Main abcde ptr' len)--fiddleEndianness :: Ptr Word32 -> Int -> IO ()-fiddleEndianness p 0 = p `seq` return ()-fiddleEndianness p n- = do x <- peek p-      poke p $ shiftL x 24-           .|. shiftL (x .&. 0xff00) 8-           .|. (shiftR x 8 .&. 0xff00)-           .|. shiftR x 24-      fiddleEndianness (p `advancePtr` 1) (n - 4)---- sha1Step12PadLength assumes the length is at most 2^61.--- This seems reasonable as the Int used to represent it is normally 32bit,--- but obviously could go wrong with large inputs on 64bit machines.--- The B.ByteString library should probably move to Word64s if this is an--- issue, though.--sha1Step12PadLength :: B.ByteString -> B.ByteString-sha1Step12PadLength s- = let len = B.length s-       num_nuls = (55 - len) `mod` 64-       padding = 128:replicate num_nuls 0-       len_w8s = reverse $ sizeSplit 8 (fromIntegral len*8)-   in B.concat [s, B.pack padding, B.pack len_w8s]--sizeSplit :: Int -> Integer -> [Word8]-sizeSplit 0 _ = []-sizeSplit p n = fromIntegral d:sizeSplit (p-1) n'- where (n', d) = divMod n 256--sha1Step3Init :: SHA1-sha1Step3Init = SHA1 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0--sha1Step4Main :: SHA1 -> Ptr Word32 -> Int -> IO SHA1-sha1Step4Main abcde _ 0 = return $! abcde-sha1Step4Main (SHA1 a0@a b0@b c0@c d0@d e0@e) s len-    = do-         (e, b) <- doit f1 0x5a827999 (x 0) a b c d e-         (d, a) <- doit f1 0x5a827999 (x 1) e a b c d-         (c, e) <- doit f1 0x5a827999 (x 2) d e a b c-         (b, d) <- doit f1 0x5a827999 (x 3) c d e a b-         (a, c) <- doit f1 0x5a827999 (x 4) b c d e a-         (e, b) <- doit f1 0x5a827999 (x 5) a b c d e-         (d, a) <- doit f1 0x5a827999 (x 6) e a b c d-         (c, e) <- doit f1 0x5a827999 (x 7) d e a b c-         (b, d) <- doit f1 0x5a827999 (x 8) c d e a b-         (a, c) <- doit f1 0x5a827999 (x 9) b c d e a-         (e, b) <- doit f1 0x5a827999 (x 10) a b c d e-         (d, a) <- doit f1 0x5a827999 (x 11) e a b c d-         (c, e) <- doit f1 0x5a827999 (x 12) d e a b c-         (b, d) <- doit f1 0x5a827999 (x 13) c d e a b-         (a, c) <- doit f1 0x5a827999 (x 14) b c d e a-         (e, b) <- doit f1 0x5a827999 (x 15) a b c d e-         (d, a) <- doit f1 0x5a827999 (m 16) e a b c d-         (c, e) <- doit f1 0x5a827999 (m 17) d e a b c-         (b, d) <- doit f1 0x5a827999 (m 18) c d e a b-         (a, c) <- doit f1 0x5a827999 (m 19) b c d e a-         (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e-         (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d-         (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c-         (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b-         (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a-         (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e-         (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d-         (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c-         (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b-         (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a-         (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e-         (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d-         (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c-         (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b-         (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a-         (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e-         (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d-         (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c-         (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b-         (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a-         (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e-         (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d-         (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c-         (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b-         (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a-         (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e-         (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d-         (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c-         (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b-         (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a-         (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e-         (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d-         (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c-         (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b-         (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a-         (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e-         (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d-         (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c-         (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b-         (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a-         (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e-         (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d-         (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c-         (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b-         (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a-         (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e-         (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d-         (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c-         (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b-         (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a-         (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e-         (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d-         (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c-         (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b-         (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a-         (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e-         (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d-         (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c-         (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b-         (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a-         let abcde' = SHA1 (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)-         sha1Step4Main abcde' (s `advancePtr` 16) (len - 64)- where {-# INLINE f1 #-}-       f1 (XYZ x y z) = (x .&. y) .|. (complement x .&. z)-       {-# INLINE f2 #-}-       f2 (XYZ x y z) = x `xor` y `xor` z-       {-# INLINE f3 #-}-       f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)-       {-# INLINE x #-}-       x n = peek (s `advancePtr` n)-       {-# INLINE m #-}-       m n = do let base = s `advancePtr` (n .&. 15)-                x0 <- peek base-                x1 <- peek (s `advancePtr` ((n - 14) .&. 15))-                x2 <- peek (s `advancePtr` ((n - 8) .&. 15))-                x3 <- peek (s `advancePtr` ((n - 3) .&. 15))-                let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1-                poke base res-                return res-       {-# INLINE doit #-}-       doit f k i a b c d e = a `seq` c `seq`-           do i' <- i-              return (rotateL a 5 + f (XYZ b c d) + e + i' + k,-                      rotateL b 30)+sha1PS = fromArray . convert . H.hashWith H.SHA1 where+  fromArray = decode . BL.fromStrict  showAsHex :: Word32 -> String showAsHex n = showIt 8 n ""@@ -267,3 +105,37 @@     showIt i x r = case quotRem x 16 of                        (y, z) -> let c = intToDigit (fromIntegral z)                                  in c `seq` showIt (i-1) y (c:r)++-- | Parse a 'SHA1' directly from its B16 encoding, given as a 'B.ByteString',+-- or return 'Nothing'. The implementation is quite low-level and optimized+-- because the current implementation of RepoPatchV3 has to read lots of 'SHA1'+-- hashes, and profiling showed that this is a bottleneck.+sha1Read :: B.ByteString -> Maybe SHA1+sha1Read bs+  | B.length bs == 40+  , B.all is_hex bs =+    Just $ SHA1 (readWord 0) (readWord 8) (readWord 16) (readWord 24) (readWord 32)+  | otherwise = Nothing+  where+    readWord i = B.foldl' readByte 0 (B.take 8 (B.drop i bs))+    readByte :: Word32 -> Word8 -> Word32+    readByte r b = r `shiftL` 4 .|. (fromHex b)+    fromHex :: Word8 -> Word32+    fromHex b | btw_0_9 b = fromIntegral (b - ord_0)+              | btw_a_f b = fromIntegral (b - ord_a) + 10+              | otherwise = error "impossible case"+    ord_0 :: Word8+    ord_0 = fromIntegral (ord '0')+    ord_9 :: Word8+    ord_9 = fromIntegral (ord '9')+    ord_a :: Word8+    ord_a = fromIntegral (ord 'a')+    ord_f :: Word8+    ord_f = fromIntegral (ord 'f')+    btw_0_9 b = b >= ord_0 && b <= ord_9+    btw_a_f b = b >= ord_a && b <= ord_f+    is_hex b = btw_0_9 b || btw_a_f b++{-# INLINE sha1Show #-}+sha1Show :: SHA1 -> B.ByteString+sha1Show = base16 . BL.toStrict . encode
src/Darcs/Util/Index.hs view
@@ -1,7 +1,7 @@ --  Copyright (C) 2009-2011 Petr Rockai --            (C) 2013 Jose Neder --  BSD3-{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, 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@@ -24,7 +24,7 @@ -- -- For each file, the index has a copy of the file's last modification -- timestamp taken at the instant when the hash has been computed. This means--- that when file size and timestamp of a file in working copy matches those in+-- 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.@@ -39,70 +39,112 @@ -- of its parent directory hashes; moreover this is done efficiently -- each -- directory is updated at most once during an update run. --+-- /Endianness/+--+-- Since version 6 (magic == "HSI6"), the file format depends on the endianness+-- of the architecture. To account for the (rare) case where darcs executables+-- from different architectures operate on the same repo, we make an additional+-- check in indexFormatValid to detect whether the file's endianness differs+-- from what we expect. If this is detected, the file is considered invalid and+-- will be re-created.+-- -- /Index format/ ----- The Index is organised into \"lines\" where each line describes a single--- indexed item. Cf. 'Item'.+-- 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 ----- The first word on the index \"line\" is the length of the file path (which is--- the only variable-length part of the line). Then comes the path itself, then--- fixed-length hash (sha256) of the file in question, then three words, one for--- size, one for "aux", which is used differently for directories and for files, and--- one for the fileid (inode or fhandle) of the file.+-- * size: item size, 8 bytes+-- * aux: timestamp (for file) or offset to sibling (for dir), 8 bytes+-- * fileid: inode or fhandle of the item, 8 bytes+-- * hash: sha256 of content, 32 bytes+-- * descriptor length: >= 2 due to type and null, 4 bytes+-- * descriptor:+--   * type: 'D' or 'F', one byte+--   * path: flattened path, variable >= 0+-- * null: terminating null byte ----- With directories, this aux holds the offset of the next sibling line in the+-- With directories, the aux holds the offset of the next sibling line in the -- index, so we can efficiently skip reading the whole subtree starting at a -- given directory (by just seeking aux bytes forward). The lines are -- pre-ordered with respect to directory structure -- the directory comes first -- and after it come all its items. Cf. 'readIndex''. -- -- For files, the aux field holds a timestamp.+--+-- Internally, the item is stored as a pointer to the first field (iBase)+-- from which we directly read off the first three fields (size, aux, fileid),+-- and a ByteString for the rest (iHashAndDescriptor), up to but not including+-- the terminating null byte.+--+-- Comments by bf:+--+-- 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.+--+-- 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. -module Darcs.Util.Index( readIndex, updateIndexFrom, indexFormatValid-                       , updateIndex, listFileIDs, Index, filter-                       , getFileID+module Darcs.Util.Index+    ( readIndex+    , updateIndexFrom+    , indexFormatValid+    , updateIndex+    , listFileIDs+    , Index+    , filter+    , getFileID     -- for testing     , align-    , xlate32-    , xlate64 )-    where+    ) where -import Prelude hiding ( lookup, readFile, writeFile, filter, (<$>) )+import Darcs.Prelude hiding ( readFile, writeFile, filter )+ import Darcs.Util.ByteString ( readSegment, decodeLocale )-import Darcs.Util.File ( getFileStatus )+import qualified Darcs.Util.File ( getFileStatus ) import Darcs.Util.Hash( sha256, rawHash ) import Darcs.Util.Tree import Darcs.Util.Path-    ( AnchoredPath(..)+    ( AnchoredPath     , anchorPath     , anchoredRoot-    , unsafeMakeName+    , Name+    , rawMakeName     , appendPath     , flatten     ) import Control.Monad( when )-import Control.Exception( catch, SomeException )-import Control.Applicative( (<$>) )+import Control.Exception( catch, throw, SomeException, Exception )  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.ByteString.Unsafe( unsafeHead, unsafeDrop )-import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy-                               , nullForeignPtr, c2w )+import Data.ByteString.Internal+    ( c2w+    , fromForeignPtr+    , memcpy+    , nullForeignPtr+    , toForeignPtr+    ) -import Data.Bits( Bits )-#ifdef BIGENDIAN-import Data.Bits( (.&.), (.|.), shift, shiftL, rotateR )-#endif import Data.Int( Int64, Int32 ) import Data.IORef( ) import Data.Maybe( fromJust, isJust, fromMaybe )+import Data.Typeable( Typeable )  import Foreign.Storable import Foreign.ForeignPtr( ForeignPtr, withForeignPtr, castForeignPtr ) import Foreign.Ptr( Ptr, plusPtr ) -import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) )+import System.IO ( hPutStrLn, stderr )+import System.IO.MMap( mmapFileForeignPtr, Mode(..) ) import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist ) #if mingw32_HOST_OS import System.Directory( renameFile )@@ -112,16 +154,23 @@ #endif  #ifdef WIN32-import System.Win32.File ( createFile, getFileInformationByHandle, BY_HANDLE_FILE_INFORMATION(..),-                           fILE_SHARE_NONE, fILE_FLAG_BACKUP_SEMANTICS,-                           gENERIC_NONE, oPEN_EXISTING, closeHandle )+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 System.FilePath ( (</>) ) import qualified System.Posix.Files as F-    ( modificationTime, fileSize, isDirectory+    ( modificationTime, fileSize, isDirectory, isSymbolicLink     , FileStatus     ) import System.Posix.Types ( FileID, EpochTime, FileOffset )@@ -143,8 +192,19 @@                  , iHashAndDescriptor :: !B.ByteString                  } deriving Show -size_magic :: Int+index_version :: B.ByteString+index_version = BC.pack "HSI6"++-- | Stored to the index to verify we are on the same endianness when reading+-- it back. We will treat the index as invalid in this case so user code will+-- regenerate it.+index_endianness_indicator :: Int32+index_endianness_indicator = 1++size_header, size_magic, size_endianness_indicator :: Int size_magic = 4 -- the magic word, first 4 bytes of the index+size_endianness_indicator = 4 -- second 4 bytes of the index+size_header = size_magic + size_endianness_indicator  size_dsclen, size_hash, size_size, size_aux, size_fileid :: Int size_size = 8 -- file/directory size (Int64)@@ -152,6 +212,9 @@ size_fileid = 8 -- fileid (inode or fhandle FileID) size_dsclen = 4 -- this many bytes store the length of the path size_hash = 32 -- hash representation+size_type, size_null :: Int+size_type = 1 -- ItemType: 'D' for directory, 'F' for file+size_null = 1 -- null byte at the end of path  off_size, off_aux, off_hash, off_dsc, off_dsclen, off_fileid :: Int off_size = 0@@ -162,17 +225,26 @@ off_dsc = off_hash + size_hash  itemAllocSize :: AnchoredPath -> Int-itemAllocSize apath =-    align 4 $ size_hash + size_size + size_aux + size_fileid + size_dsclen + 2 + B.length (flatten apath)+itemAllocSize apath = align 4 $+  size_size + size_aux + size_fileid + size_dsclen + size_hash ++  size_type + B.length (flatten apath) + size_null  itemSize, itemNext :: Item -> Int-itemSize i = size_size + size_aux + size_fileid + size_dsclen + (B.length $ iHashAndDescriptor i)+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) +-- iDescriptor is:+--  * one byte for type of item ('D' or 'F')+--  * flattened path iHash, iDescriptor :: Item -> B.ByteString iDescriptor = unsafeDrop size_hash . iHashAndDescriptor iHash = B.take size_hash . iHashAndDescriptor +-- The "drop 1" here gets rid of the item type. iPath :: Item -> FilePath iPath = decodeLocale . unsafeDrop 1 . iDescriptor @@ -186,16 +258,9 @@ itemIsDir :: Item -> Bool itemIsDir i = unsafeHead (iDescriptor i) == c2w 'D' --- xlatePeek32 = fmap xlate32 . peek-xlatePeek64 :: (Storable a, Num a, Bits a) => Ptr a -> IO a-xlatePeek64 = fmap xlate64 . peek---- xlatePoke32 ptr v = poke ptr (xlate32 v)-xlatePoke64 :: (Storable a, Num a, Bits a) => Ptr a -> a -> IO ()-xlatePoke64 ptr v = poke ptr (xlate64 v)- type FileStatus = Maybe F.FileStatus +-- TODO: upgrade to modificationTimeHiRes for nanosecond resolution modificationTime :: FileStatus -> EpochTime modificationTime = maybe 0 F.modificationTime @@ -213,20 +278,24 @@ -- written out, and a corresponding Item is given back. The remaining bits of -- the item can be filled out using 'update'. createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item-createItem typ apath fp off =- do let dsc = B.concat [ BC.singleton $ if typ == TreeType then 'D' else 'F'-                        , flatten apath-                        , B.singleton 0 ]-        (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc-    withForeignPtr fp $ \p ->-        withForeignPtr dsc_fp $ \dsc_p ->-            do fileid <- fromMaybe 0 <$> getFileID apath-               pokeByteOff p (off + off_fileid) (xlate64 $ fromIntegral fileid :: Int64)-               pokeByteOff p (off + off_dsclen) (xlate32 $ fromIntegral dsc_len :: Int32)-               memcpy (plusPtr p $ off + off_dsc)-                      (plusPtr dsc_p dsc_start)-                      (fromIntegral dsc_len)-               peekItem fp off+createItem typ apath fp off = do+  let dsc =+        B.concat+          [ BC.singleton $ if typ == TreeType then 'D' else 'F'+          , flatten apath -- this (currently) gives "." for anchoredRoot+          , B.singleton 0+          ]+      (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc+  withForeignPtr fp $ \p ->+    withForeignPtr dsc_fp $ \dsc_p -> do+      fileid <- fromMaybe 0 <$> getFileID apath+      pokeByteOff p (off + off_fileid) (fromIntegral fileid :: Int64)+      pokeByteOff p (off + off_dsclen) (fromIntegral dsc_len :: Int32)+      memcpy+        (plusPtr p $ off + off_dsc)+        (plusPtr dsc_p dsc_start)+        (fromIntegral dsc_len)+      peekItem fp off  -- | Read the on-disk representation into internal data structure. --@@ -234,13 +303,19 @@ -- is structured. peekItem :: ForeignPtr () -> Int -> IO Item peekItem fp off =-    withForeignPtr fp $ \p -> do-      nl' :: Int32 <- xlate32 `fmap` peekByteOff p (off + off_dsclen)-      when (nl' <= 2) $ fail "Descriptor too short in peekItem!"-      let nl = fromIntegral nl'-          dsc = fromForeignPtr (castForeignPtr fp) (off + off_hash) (size_hash + nl - 1)-      return $! Item { iBase = plusPtr p off-                     , iHashAndDescriptor = dsc }+  withForeignPtr fp $ \p -> do+    nl' :: Int32 <- peekByteOff p (off + off_dsclen)+    when (nl' <= 2) $ fail "Descriptor too short in peekItem!"+    let nl = fromIntegral nl'+        dsc =+          fromForeignPtr+            (castForeignPtr fp)+            (off + off_hash)+            -- 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)+    return $! Item {iBase = plusPtr p off, iHashAndDescriptor = dsc}  -- | Update an existing item with new hash and optionally mtime (give Nothing -- when updating directory entries).@@ -248,13 +323,13 @@ updateItem item _ NoHash =     fail $ "Index.update NoHash: " ++ iPath item updateItem item size hash =-    do xlatePoke64 (iSize item) size+    do poke (iSize item) size        unsafePokeBS (iHash item) (rawHash hash)  updateFileID :: Item -> FileID -> IO ()-updateFileID item fileid = xlatePoke64 (iFileID item) $ fromIntegral fileid+updateFileID item fileid = poke (iFileID item) $ fromIntegral fileid updateAux :: Item -> Int64 -> IO ()-updateAux item aux = xlatePoke64 (iAux item) $ aux+updateAux item aux = poke (iAux item) $ aux updateTime :: forall a.(Enum a) => Item -> a -> IO () updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime) @@ -266,15 +341,15 @@ -- the index file. mmapIndex will grow the index if it is smaller than this. mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int) mmapIndex indexpath req_size = do-  act_size <- fromIntegral . fileSize <$> getFileStatus indexpath+  act_size <- fromIntegral . fileSize <$> Darcs.Util.File.getFileStatus indexpath   let size = case req_size > 0 of         True -> req_size-        False | act_size >= size_magic -> act_size - size_magic+        False | act_size >= size_header -> act_size - size_header               | otherwise -> 0   case size of     0 -> return (castForeignPtr nullForeignPtr, size)     _ -> do (x, _, _) <- mmapFileForeignPtr indexpath-                                            ReadWriteEx (Just (0, size + size_magic))+                                            ReadWriteEx (Just (0, size + size_header))             return (x, size)  data IndexM m = Index { mmap :: (ForeignPtr ())@@ -285,28 +360,33 @@  type Index = IndexM IO -data State = State { dirlength :: !Int-                   , path :: !AnchoredPath-                   , start :: !Int }+-- FIXME This is not really a state: we modify it only when we recurse+-- down into a dir item, so this is rather more like an environment.+-- Instead of passing it explicitly we could use ReaderT. -data Result = Result { -- | marks if the item has changed since the last update to the index-                       changed :: !Bool-                       -- | next is the position of the next item, in bytes.-                     , next :: !Int-                       -- | treeitem is Nothing in case of the item doesn't exist in the tree-                       -- or is filtered by a FilterTree. Or a TreeItem otherwise.-                     , treeitem :: !(Maybe (TreeItem IO))-                       -- | resitem is the item extracted.-                     , resitem :: !Item }+-- | When we traverse the index, we keep track of some data about the+-- current parent directory.+data State = State+  { dirlength :: !Int     -- ^ length in bytes of current path prefix,+                          --   includes the trailing path separator+  , path :: !AnchoredPath -- ^ path of the current directory+  , start :: !Int         -- ^ offset of current directory in the index+  } -data ResultF = ResultF { -- | nextF is the position of the next item, in bytes.-                         nextF :: !Int-                         -- | resitemF is the item extracted.-                       , resitemF :: !Item-                         -- | _fileIDs contains the fileids of the files and folders inside,-                         -- in a folder item and its own fileid for file item).-                       , _fileIDs :: [((AnchoredPath, ItemType), FileID)] }+-- * Reading items from the index +data Result = Result+  { changed :: !Bool+  -- ^ Whether item has changed since the last update to the index.+  , next :: !Int+  -- ^ Position of the next item, in bytes.+  , treeitem :: !(Maybe (TreeItem IO))+  -- ^ Nothing in case of the item doesn't exist in the tree+  -- or is filtered by a FilterTree. Or a TreeItem otherwise.+  , resitem :: !Item+  -- ^ The item extracted.+  }+ readItem :: Index -> State -> IO Result readItem index state = do   item <- peekItem (mmap index) (start state)@@ -315,33 +395,72 @@               else readFile index state item   return res' +data CorruptIndex = CorruptIndex String deriving (Eq, Typeable)+instance Exception CorruptIndex+instance Show CorruptIndex where show (CorruptIndex s) = s++-- | Get the 'Name' of an 'Item' in the given 'State'. This fails for+-- the root 'Item' because it has no 'Name', so we return 'Nothing'.+nameof :: Item -> State -> Maybe Name+nameof item state+  | iDescriptor item == BC.pack "D." = Nothing+  | otherwise =+      case rawMakeName $ B.drop (dirlength state + 1) $ iDescriptor item of+        Left msg -> throw (CorruptIndex msg)+        Right name -> Just name++-- | 'Maybe' append a 'Name' to an 'AnchoredPath'.+maybeAppendName :: AnchoredPath -> Maybe Name -> AnchoredPath+maybeAppendName parent = maybe parent (parent `appendPath`)++-- | Calculate the next 'State' when entering an 'Item'. Works for the+-- top-level 'Item' i.e. the root directory only because we handle that+-- specially.+substateof :: Item -> State -> State+substateof item state =+  state+    { start = start state + itemNext item+    , path = path state `maybeAppendName` myname+    , dirlength =+        case myname of+          Nothing ->+            -- We are entering the root item. The current path prefix remains+            -- empty, so its length (which must be 0) doesn't change.+            dirlength state+          Just _ ->+            -- This works because the 'iDescriptor' is always one byte larger+            -- than the actual name. So @dirlength state@ will also be greater+            -- by 1, which accounts for the path separator when we strip the+            -- directory prefix from the full path.+            B.length (iDescriptor item)+    }+  where+    myname = nameof item state+ readDir :: Index -> State -> Item -> IO Result readDir index state item = do-       following <- fromIntegral <$> xlatePeek64 (iAux item)+       following <- fromIntegral <$> peek (iAux item)        st <- getFileStatus (iPath item)        let exists = fileExists st && isDirectory st-       fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item)+       fileid <- fromIntegral <$> (peek $ iFileID item)        fileid' <- fromMaybe fileid <$> (getFileID' $ iPath item)        when (fileid == 0) $ updateFileID item fileid'-       let name it dirlen = unsafeMakeName $ (B.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC-           namelength = (B.length $ iDescriptor item) - (dirlength state)-           myname = name item (dirlength state)-           substate = state { start = start state + itemNext item-                            , path = path state `appendPath` myname-                            , dirlength = if myname == unsafeMakeName (BC.singleton '.')-                                             then dirlength state-                                             else dirlength state + namelength }+       let substate = substateof item state             want = exists && (predicate index) (path substate) (Stub undefined NoHash)            oldhash = iHash' item -           subs off | off < following = do-             result <- readItem index $ substate { start = off }-             rest <- subs $ next result-             return $! (name (resitem result) $ dirlength substate, result) : rest-           subs coff | coff == following = return []-                     | otherwise = fail $ "Offset mismatch at " ++ show coff ++-                                          " (ends at " ++ show following ++ ")"+           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 []@@ -349,7 +468,13 @@        let we_changed = or [ changed x | (_, x) <- inferiors ] || nullleaf            nullleaf = null inferiors && oldhash == nullsha            nullsha = SHA256 (B.replicate 32 0)-           tree' = makeTree [ (n, fromJust $ treeitem s) | (n, s) <- inferiors, isJust $ treeitem s ]+           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 } @@ -363,9 +488,9 @@ readFile :: Index -> State -> Item -> IO Result readFile index state item = do        st <- getFileStatus (iPath item)-       mtime <- fromIntegral <$> (xlatePeek64 $ iAux item)-       size <- xlatePeek64 $ iSize item-       fileid <- fromIntegral <$> (xlatePeek64 $ iFileID 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@@ -383,25 +508,30 @@                        , treeitem = if exists then Just $ File $ Blob readblob hash else Nothing                        , resitem = item } -updateIndex :: Index -> IO (Tree IO)-updateIndex EmptyIndex = return emptyTree-updateIndex index =-    do let initial = State { start = size_magic-                           , dirlength = 0-                           , path = AnchoredPath [] }-       res <- readItem index initial-       case treeitem res of-         Just (SubTree tree) -> return $ filter (predicate index) tree-         _ -> fail "Unexpected failure in updateIndex!"+-- * Reading (only) file IDs from the index +-- FIXME this seems copy-pasted from the code above and then adapted+-- to the purpose. Should factor out the traversal of the index as a+-- higher order function.++data ResultF = ResultF+  { nextF :: !Int+  -- ^ Position of the next item, in bytes.+  , resitemF :: !Item+  -- ^ The item extracted.+  , _fileIDs :: [((AnchoredPath, ItemType), FileID)]+  -- ^ The fileids of the files and folders inside,+  -- in a folder item and its own fileid for file item).+  }+ -- | Return a list containing all the file/folder names in an index, with -- their respective ItemType and FileID. listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)]) listFileIDs EmptyIndex = return [] listFileIDs index =-    do let initial = State { start = size_magic+    do let initial = State { start = size_header                            , dirlength = 0-                           , path = AnchoredPath [] }+                           , path = anchoredRoot }        res <- readItemFileIDs index initial        return $ _fileIDs res @@ -415,23 +545,20 @@  readDirFileIDs :: Index -> State -> Item -> IO ResultF readDirFileIDs index state item =-    do fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item)-       following <- fromIntegral <$> xlatePeek64 (iAux item)-       let name it dirlen = unsafeMakeName $ (B.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC-           namelength = (B.length $ iDescriptor item) - (dirlength state)-           myname = name item (dirlength state)-           substate = state { start = start state + itemNext item-                            , path = path state `appendPath` myname-                            , dirlength = if myname == unsafeMakeName (BC.singleton '.')-                                             then dirlength state-                                             else dirlength state + namelength }-           subs off | off < following = do-             result <- readItemFileIDs index $ substate { start = off }-             rest <- subs $ nextF result-             return $! (name (resitemF result) $ dirlength substate, result) : rest-           subs coff | coff == following = return []-                     | otherwise = fail $ "Offset mismatch at " ++ show coff ++-                                          " (ends at " ++ show following ++ ")"+    do fileid <- fromIntegral <$> (peek $ iFileID item)+       following <- fromIntegral <$> peek (iAux item)+       let substate = substateof item state+           subs off =+              case compare off following of+                LT -> do+                  result <- readItemFileIDs index $ substate {start = off}+                  rest <- subs $ nextF result+                  return $! (nameof (resitemF result) substate, result) : rest+                EQ -> return []+                GT ->+                  fail $+                    "Offset mismatch at " ++ show off +++                    " (ends at " ++ show following ++ ")"        inferiors <- subs $ start substate        return $ ResultF { nextF = following                         , resitemF = item@@ -439,13 +566,13 @@  readFileFileID :: Index -> State -> Item -> IO ResultF readFileFileID _ state item =-    do fileid' <- fromIntegral <$> (xlatePeek64 $ iFileID item)-       let name it dirlen = unsafeMakeName $ (B.drop (dirlen + 1) $ iDescriptor it)-           myname = name item (dirlength state)+    do fileid' <- fromIntegral <$> (peek $ iFileID item)+       let myname = nameof item state        return $ ResultF { nextF = start state + itemNext item                         , resitemF = item-                        , _fileIDs = [((path state `appendPath` myname, BlobType), fileid')] }+                        , _fileIDs = [((path state `maybeAppendName` myname, BlobType), fileid')] } +-- * 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 readIndex is not@@ -470,8 +597,10 @@  formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO () formatIndex mmap_ptr old reference =-    do _ <- create (SubTree reference) (AnchoredPath []) size_magic-       unsafePokeBS magic (BC.pack "HSI5")+    do _ <- create (SubTree reference) (anchoredRoot) size_header+       unsafePokeBS magic index_version+       withForeignPtr mmap_ptr $ \ptr ->+         pokeByteOff ptr size_magic index_endianness_indicator     where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4           create (File _) path' off =                do i <- createItem BlobType path' mmap_ptr off@@ -499,7 +628,7 @@                         noff <- subs xs                         create x path'' noff                   lastOff <- subs (listImmediate s)-                  xlatePoke64 (iAux i) (fromIntegral lastOff)+                  poke (iAux i) (fromIntegral lastOff)                   return lastOff           create (Stub _ _) path' _ =                fail $ "Cannot create index from stubbed Tree at " ++ show path'@@ -525,42 +654,63 @@        formatIndex mmap_ptr old_idx reference        readIndex indexpath hashtree' +updateIndex :: Index -> IO (Tree IO)+updateIndex EmptyIndex = return emptyTree+updateIndex index =+    do let initial = State { start = size_header+                           , dirlength = 0+                           , path = anchoredRoot }+       res <- readItem index initial+       case treeitem res of+         Just (SubTree tree) -> return $ filter (predicate index) tree+         _ -> fail "Unexpected failure in updateIndex!"+ -- | Check that a given file is an index file with a format we can handle. You -- should remove and re-create the index whenever this is not true. indexFormatValid :: FilePath -> IO Bool-indexFormatValid path' = do-    v <- do magic <- mmapFileByteString path' (Just (0, size_magic))-            return $ case BC.unpack magic of-                       "HSI5" -> True-                       _ -> False-         `catch` \(_::SomeException) -> return False-    return v+indexFormatValid path' =+  do+    (start, _, _) <- mmapFileForeignPtr path' ReadOnly (Just (0, size_header))+    let magic = fromForeignPtr (castForeignPtr start) 0 4+    endianness_indicator <- withForeignPtr start $ \ptr -> peekByteOff ptr 4+    return $+      index_version == magic && index_endianness_indicator == endianness_indicator+  `catch` \(_::SomeException) -> return False  instance FilterTree IndexM IO where     filter _ EmptyIndex = EmptyIndex     filter p index = index { predicate = \a b -> predicate index a b && p a b }  +-- * Getting the file ID from a path+ -- | For a given file or folder path, get the corresponding fileID from the -- filesystem. getFileID :: AnchoredPath -> IO (Maybe FileID) getFileID = getFileID' . anchorPath ""  getFileID' :: FilePath -> IO (Maybe FileID)-getFileID' fp = do file_exists <- doesFileExist fp-                   dir_exists <- doesDirectoryExist fp-                   if file_exists || dir_exists+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+    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+    then (Just . F.fileID) <$> F.getSymbolicLinkStatus fp #endif-                      else return Nothing+    else return Nothing  +-- * Low-level utilities+ -- Wow, unsafe. unsafePokeBS :: BC.ByteString -> BC.ByteString -> IO () unsafePokeBS to from =@@ -580,30 +730,12 @@                      x -> i + boundary - x {-# INLINE align #-} -xlate32 :: (Num a, Bits a) => a -> a-xlate64 :: (Num a, Bits a) => a -> a--#ifdef LITTLEENDIAN-xlate32 = id-xlate64 = id-#endif--#ifdef BIGENDIAN-bytemask :: (Num a, Bits a) => a-bytemask = 255--xlate32 a = ((a .&. (bytemask `shift`  0)) `shiftL` 24) .|.-            ((a .&. (bytemask `shift`  8)) `shiftL`  8) .|.-            ((a .&. (bytemask `shift` 16)) `rotateR`  8) .|.-            ((a .&. (bytemask `shift` 24)) `rotateR` 24)--xlate64 a = ((a .&. (bytemask `shift`  0)) `shiftL` 56) .|.-            ((a .&. (bytemask `shift`  8)) `shiftL` 40) .|.-            ((a .&. (bytemask `shift` 16)) `shiftL` 24) .|.-            ((a .&. (bytemask `shift` 24)) `shiftL`  8) .|.-            ((a .&. (bytemask `shift` 32)) `rotateR`  8) .|.-            ((a .&. (bytemask `shift` 40)) `rotateR` 24) .|.-            ((a .&. (bytemask `shift` 48)) `rotateR` 40) .|.-            ((a .&. (bytemask `shift` 56)) `rotateR` 56)-#endif-+getFileStatus :: FilePath -> IO FileStatus+getFileStatus path = do+  mst <- Darcs.Util.File.getFileStatus path+  case mst of+    Just st+      | F.isSymbolicLink st -> do+          hPutStrLn stderr $ "Warning: ignoring symbolic link " ++ path+          return Nothing+    _ -> return mst
src/Darcs/Util/IsoDate.hs view
@@ -35,10 +35,11 @@     , toMCalendarTime, unsafeToCalendarTime     , unsetTime, TimeInterval     , showIsoDateTime+    , theBeginning     ) where -import Prelude ( (^) ) import Darcs.Prelude+import Prelude ( (^) )  import Text.ParserCombinators.Parsec import System.Time
src/Darcs/Util/Lock.hs view
@@ -21,7 +21,6 @@     , environmentHelpLocks     , withTemp     , withOpenTemp-    , withStdoutTemp     , withTempDir     , withPermDir     , withDelayedDir@@ -39,7 +38,6 @@     , gzWriteAtomicFilePS     , gzWriteAtomicFilePSs     , gzWriteDocFile-    , rmRecursive     , removeFileMayNotExist     , canonFilename     , maybeRelink@@ -50,7 +48,6 @@     , withNewDirectory     ) where -import Prelude () import Darcs.Prelude  import Data.List ( inits )@@ -75,17 +72,18 @@     , SomeException     ) import System.Directory-    ( removeFile-    , removeDirectory+    ( removePathForcibly     , doesFileExist     , doesDirectoryExist-    , getDirectoryContents     , createDirectory     , getTemporaryDirectory-    , removeDirectoryRecursive+    , removePathForcibly+    , renameFile+    , renameDirectory     )-import System.FilePath.Posix ( splitDirectories )+import System.FilePath.Posix ( splitDirectories, splitFileName ) import System.Environment ( lookupEnv )+import System.IO.Temp ( createTempDirectory )  import Control.Concurrent ( threadDelay ) import Control.Monad ( unless, when, liftM )@@ -100,7 +98,7 @@     , catchall     ) import Darcs.Util.File ( withCurrentDirectory-                       , doesDirectoryReallyExist, removeFileMayNotExist )+                       , removeFileMayNotExist ) import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath,                         getCurrentDirectory, setCurrentDirectory ) @@ -111,10 +109,8 @@ import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs ) import Darcs.Util.AtExit ( atexit ) import Darcs.Util.Global ( darcsdir )-import Darcs.Util.Workaround ( renameFile ) import Darcs.Util.Compat-    ( mkStdoutTemp-    , canonFilename+    ( canonFilename     , maybeRelink     , atomicCreate     , sloppyAtomicCreate@@ -202,9 +198,6 @@           get_empty_file = invert `fmap` openBinaryTempFile "." "darcs"           invert (a,b) = (b,a) -withStdoutTemp :: (FilePath -> IO a) -> IO a-withStdoutTemp = bracket (mkStdoutTemp "stdout_") removeFileMayNotExist- tempdirLoc :: IO FilePath tempdirLoc = liftM fromJust $     firstJustIO [ liftM (Just . head . words) (readFile (darcsdir++"/prefs/tmpdir")) >>= chkdir,@@ -240,31 +233,36 @@ withDir :: WithDirKind  -- specifies if and when directory will be deleted         -> FilePath     -- path parameter         -> (AbsolutePath -> IO a) -> IO a-withDir _ "" _ = bug "withDir called with empty directory name"+withDir _ "" _ = error "withDir called with empty directory name" withDir kind absoluteOrRelativeName job = do   absoluteName <- if isRelative absoluteOrRelativeName                    then fmap (++ absoluteOrRelativeName) tempdirLoc                    else return absoluteOrRelativeName   formerdir <- getCurrentDirectory-  bracket (createDir absoluteName 0)-          (\dir -> do setCurrentDirectory formerdir-                      k <- keepTempDir-                      unless k $ case kind of-                                   Perm -> return ()-                                   Temp -> rmRecursive (toFilePath dir)-                                   Delayed -> atexit $ rmRecursive (toFilePath dir))+  bracket (createDir absoluteName)+          (\dir -> do+              setCurrentDirectory formerdir+              k <- keepTempDir+              unless k $+                  case kind of+                      Perm -> return ()+                      Temp -> cleanup (toFilePath dir)+                      Delayed -> atexit $ cleanup (toFilePath dir))           job-    where newname name 0 = name-          newname name n = name ++ "-" ++ show n-          createDir :: FilePath -> Int -> IO AbsolutePath-          createDir name n-              = do createDirectory $ newname name n-                   setCurrentDirectory $ newname name n+    where createDir :: FilePath -> IO AbsolutePath+          createDir name+              = do let (parent,dir) = splitFileName name+                   createTempDirectory parent dir >>= setCurrentDirectory                    getCurrentDirectory-                `catch` (\e -> if isAlreadyExistsError e-                               then createDir name (n+1)-                               else throwIO e)           keepTempDir = isJust `fmap` lookupEnv "DARCS_KEEP_TMPDIR"+          toDelete dir = dir ++ "_done"+          cleanup path = do+              -- so asynchronous threads cannot add any more+              -- files while we are deleting+              debugMessage $ unwords ["atexit: renaming",path,"to",toDelete path]+              renameDirectory path (toDelete path)+              debugMessage $ unwords ["atexit: deleting",toDelete path]+              removePathForcibly (toDelete path)  environmentHelpKeepTmpdir :: ([String], [String]) environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[@@ -300,19 +298,6 @@ withDelayedDir :: FilePath -> (AbsolutePath -> IO a) -> IO a withDelayedDir = withDir Delayed -rmRecursive :: FilePath -> IO ()-rmRecursive d =-    do isd <- doesDirectoryReallyExist d-       if not isd-          then removeFile d-          else do conts <- actual_dir_contents-                  withCurrentDirectory d $-                    mapM_ rmRecursive conts-                  removeDirectory d-    where actual_dir_contents = -- doesn't include . or ..-              do c <- getDirectoryContents d-                 return $ filter (/=".") $ filter (/="..") c- worldReadableTemp :: FilePath -> IO FilePath worldReadableTemp f = wrt 0     where wrt :: Int -> IO FilePath@@ -417,5 +402,5 @@ withNewDirectory name action = do   createDirectory name   withCurrentDirectory name action `catch` \e -> do-    removeDirectoryRecursive name `catchIOError` (const $ return ())+    removePathForcibly name `catchIOError` (const $ return ())     throwIO (e :: SomeException)
+ src/Darcs/Util/Parser.hs view
@@ -0,0 +1,102 @@+module Darcs.Util.Parser+    ( Parser+    , anyChar+    , char+    , checkConsumes+    , choice+    , endOfInput+    , int+    , lexChar+    , lexString+    , linesStartingWith+    , linesStartingWithEndingWith+    , lexWord+    , option+    , optional+    , parse+    , skipSpace+    , skipWhile+    , string+    , take+    , takeTill+    , takeTillChar+    ) where++import Control.Applicative ( empty, many, optional, (<|>) )++import Darcs.Prelude hiding ( lex, take )++import qualified Data.Attoparsec.ByteString 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++parse :: Parser a -> B.ByteString -> Either String (a, B.ByteString)+parse p bs =+  case AC.parse p bs of+    Fail _ ss s -> Left $ unlines (s:ss)+    Partial k ->+      case k B.empty of+        Fail _ ss s -> Left $ unlines (s:ss)+        Partial _ -> error "impossible"+        Done i r -> Right (r, i)+    Done i r -> Right (r, i)++{-# INLINE skip #-}+skip :: Parser a -> Parser ()+skip p = p >> return ()++{-# INLINE lex #-}+lex :: Parser a -> Parser a+lex p = skipSpace >> p++{-# INLINE lexWord #-}+lexWord :: Parser B.ByteString+lexWord = lex (A.takeWhile1 (not . isSpace_w8))++{-# INLINE lexChar #-}+lexChar :: Char -> Parser ()+lexChar c = lex (char c)++{-# inline lexString #-}+lexString :: B.ByteString -> Parser ()+lexString s = lex (string s)++{-# INLINE char #-}+char :: Char -> Parser ()+char = skip . AC.char++{-# INLINE string #-}+string :: B.ByteString -> Parser ()+string = skip . AC.string++{-# INLINE int #-}+int :: Parser Int+int = lex (signed decimal)++{-# INLINE takeTillChar #-}+takeTillChar :: Char -> Parser B.ByteString+takeTillChar c = takeTill (== c)++{-# INLINE checkConsumes #-}+checkConsumes :: Parser a -> Parser a+checkConsumes parser = do+  (consumed, result) <- match parser+  if B.null consumed+    then empty+    else return result++{-# INLINE linesStartingWith #-}+linesStartingWith :: Char -> Parser [B.ByteString]+linesStartingWith c = many $ do+  char c+  r <- takeTillChar '\n'+  skip (char '\n') <|> endOfInput+  return r++{-# INLINE linesStartingWithEndingWith #-}+linesStartingWithEndingWith :: Char -> Char -> Parser [B.ByteString]+linesStartingWithEndingWith st en = do+  ls <- linesStartingWith st+  char en+  return ls
src/Darcs/Util/Path.hs view
@@ -23,26 +23,14 @@  {-# LANGUAGE CPP #-} module Darcs.Util.Path-    ( FileName( )-    , fp2fn-    , fn2fp-    , fn2ps-    , ps2fn-    , breakOnDir-    , normPath-    , ownName-    , superName-    , movedirfilename-    , encodeWhite+    ( encodeWhite     , decodeWhite     , encodeWhiteName     , decodeWhiteName-    , isParentOrEqOf     -- * AbsolutePath     , AbsolutePath     , makeAbsolute     , ioAbsolute-    , rootDirectory     -- * AbsolutePathOrStd     , AbsolutePathOrStd     , makeAbsoluteOrStd@@ -57,10 +45,8 @@     , SubPath     , makeSubPathOf     , simpleSubPath-    , isSubPathOf     , floatSubPath     -- * Miscellaneous-    , sp2fn     , FilePathOrURL(..)     , FilePathLike(toFilePath)     , getCurrentDirectory@@ -68,27 +54,38 @@     , getUniquePathName     , doesPathExist     -- * Check for malicious paths-    , isMaliciousPath     , isMaliciousSubPath     -- * Tree filtering.-    , filterFilePaths     , filterPaths     -- * AnchoredPaths: relative paths within a Tree. All paths are     -- anchored at a certain root (this is usually the Tree root). They are     -- represented by a list of Names (these are just strict bytestrings).     , Name-    , unsafeMakeName+    , name2fp+    , makeName+    , rawMakeName     , eqAnycase     , AnchoredPath(..)     , anchoredRoot     , appendPath     , anchorPath     , isPrefix-    , parent, parents, catPaths, flatten, makeName, appendToName+    , breakOnDir+    , movedirfilename+    , parent+    , parents+    , replaceParent+    , catPaths+    , flatten+    , inDarcsdir+    , displayPath+    , realPath+    , isRoot+    , darcsdirName     -- * Unsafe AnchoredPath functions.-    , floatPath, replacePrefixPath ) where+    , floatPath+    ) where -import Prelude () import Darcs.Prelude  import Data.List@@ -99,16 +96,17 @@     , inits     ) import Data.Char ( isSpace, chr, ord, toLower )-import Control.Exception ( tryJust, bracket_ )+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.Posix as FilePath ( (</>), normalise, isRelative ) import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )-import System.FilePath( (</>), splitDirectories, normalise, dropTrailingPathSeparator )+import System.FilePath( splitDirectories, normalise, dropTrailingPathSeparator ) import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )  import Darcs.Util.ByteString ( encodeLocale, decodeLocale )@@ -119,37 +117,23 @@ import Darcs.Util.Global ( darcsdir ) import Darcs.Util.URL ( isAbsolute, isRelative, isSshNopath ) --- | FileName is an abstract type intended to facilitate the input and output of--- unicode filenames.-newtype FileName = FN FilePath deriving ( Eq, Ord ) -instance Show FileName where-   showsPrec d (FN fp) = showParen (d > appPrec) $ showString "fp2fn " . showsPrec (appPrec + 1) fp-      where appPrec = 10--instance Binary FileName where-  put (FN h) = put h-  get = FN `fmap` get--{-# INLINE fp2fn #-}-fp2fn :: FilePath -> FileName-fp2fn = FN--{-# INLINE fn2fp #-}-fn2fp :: FileName -> FilePath-fn2fp (FN fp) = fp--{-# INLINE fn2ps #-}-fn2ps :: FileName -> B.ByteString-fn2ps (FN fp) = encodeLocale $ encodeWhite fp+-- Utilities for use by command implementations -{-# INLINE ps2fn #-}-ps2fn :: B.ByteString -> FileName-ps2fn ps = FN $ decodeWhite $ decodeLocale ps+-- | For displaying paths to the user. It should never be used+-- for on-disk patch storage. This adds the "./" for consistency+-- with how repo paths are displayed by 'showPatch' and friends,+-- except for the root path which is displayed as plain ".".+displayPath :: AnchoredPath -> FilePath+displayPath p+  | isRoot p = "."+  | otherwise = anchorPath "." p -{-# INLINE sp2fn #-}-sp2fn :: SubPath -> FileName-sp2fn = fp2fn . toFilePath+-- | Interpret an 'AnchoredPath' as relative the current working+-- directory. Intended for IO operations in the file system.+-- Use with care!+realPath :: AnchoredPath -> FilePath+realPath = anchorPath ""  -- | 'encodeWhite' translates whitespace in filenames to a darcs-specific --   format (numerical representation according to 'ord' surrounded by@@ -181,94 +165,6 @@            _ -> error "malformed filename"        go (c:cs) acc modified = go cs (c:acc) modified -encodeWhiteName :: Name -> B.ByteString-encodeWhiteName = encodeLocale . encodeWhite . decodeLocale . unName--decodeWhiteName :: B.ByteString -> Name-decodeWhiteName = Name . encodeLocale . decodeWhite . decodeLocale--ownName :: FileName -> FileName-ownName (FN f) =  case breakLast '/' f of Nothing -> FN f-                                          Just (_,f') -> FN f'-superName :: FileName -> FileName-superName fn = case normPath fn of-                FN f -> case breakLast '/' f of-                        Nothing -> FN "."-                        Just (d,_) -> FN d-breakOnDir :: FileName -> Maybe (FileName,FileName)-breakOnDir (FN p) = case breakFirst '/' p of-                      Nothing -> Nothing-                      Just (d,f) | d == "." -> breakOnDir $ FN f-                                 | otherwise -> Just (FN d, FN f)---- | convert a path string into a sequence of directories strings---   "/", "." and ".." are generally interpreted as expected.---   Behaviour with too many '..' is to leave them.------   Examples:---     Splitting:---       "aa/bb/cc"       -> ["aa","bb","cc"]---     Ignoring "." and extra "/":---       "aa/./bb"        -> ["aa","bb"]---       "aa//bb"         -> ["aa","bb"]---       "/aa/bb/"        -> ["aa","bb"]---     Handling "..":---       "aa/../bb/cc"    -> ["bb","cc"]---       "aa/bb/../../cc" -> ["cc"]---       "aa/../bb/../cc" -> ["cc"]---       "../cc"          -> ["..","cc"]-normPath :: FileName -> FileName-normPath (FN p) = FN $ norm p--norm :: String -> String-norm ('.':'/':s) = norm s-norm ('/':s)     = norm s-norm "."         = ""-norm s = go s [] False- where go "" _   False = s           -- no modification-       go "" acc True  = reverse acc-       go ('/':r)         acc _ | sep r = go r acc True-       go ('/':'.':r)     acc _ | sep r = go r acc True-       go ('/':'.':'.':r) acc _ | sep r = go r (doDotDot acc) True-       go (c:s') acc changed = go s' (c:acc) changed-       -- remove last path or add "/.." if impossible-       doDotDot ""                       = ".."-       doDotDot acc@('.':'.':r) | sep r  = '.':'.':'/':acc-       doDotDot acc = let a' = dropWhile (/='/') acc in -- eat dir-                       if null a' then "" else tail a'-       -- check if is a path separator-       sep ('/':_) = True-       sep []      = True -- end of string is considered separator-       sep _       = False--breakFirst :: Char -> String -> Maybe (String,String)-breakFirst c = bf []-    where bf a (r:rs) | r == c = Just (reverse a,rs)-                      | otherwise = bf (r:a) rs-          bf _ [] = Nothing-breakLast :: Char -> String -> Maybe (String,String)-breakLast c l = case breakFirst c (reverse l) of-                Nothing -> Nothing-                Just (a,b) -> Just (reverse b, reverse a)--isParentOrEqOf :: FileName -> FileName -> Bool-isParentOrEqOf fn1 fn2 = case stripPrefix (fn2fp fn1) (fn2fp fn2) of-    Just ('/' : _) -> True-    Just [] -> True-    _ -> False--movedirfilename :: FileName -> FileName -> FileName -> FileName-movedirfilename old new name =-    if name' == old'-        then new-        else case stripPrefix old' name' of-            Just rest@('/':_) -> fp2fn $ "./" ++ new' ++ rest-            _ -> name-        where old' = fn2fp $ normPath old-              new' = fn2fp $ normPath new-              name' = fn2fp $ normPath name-- class FilePathOrURL a where   toPath :: a -> String @@ -298,11 +194,6 @@   toPath (AbsP a) = toPath a   toPath (RmtP r) = r -instance FilePathOrURL FileName where-  toPath = fn2fp-instance FilePathLike FileName where-  toFilePath = fn2fp- instance FilePathLike AbsolutePath where   toFilePath (AbsolutePath x) = x instance FilePathLike SubPath where@@ -326,14 +217,10 @@     else Nothing  simpleSubPath :: FilePath -> Maybe SubPath-simpleSubPath x | null x = bug "simpleSubPath called with empty path"+simpleSubPath x | null x = error "simpleSubPath called with empty path"                 | isRelative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x                 | otherwise = Nothing -isSubPathOf :: SubPath -> SubPath -> Bool-isSubPathOf (SubPath p1) (SubPath p2) =-    p1 == "" || p1 == p2 || (p1 ++ "/") `isPrefixOf` p2- -- | Ensure directory exists and is not a symbolic link. doesDirectoryReallyExist :: FilePath -> IO Bool doesDirectoryReallyExist f = do@@ -401,10 +288,6 @@ simpleClean :: String -> String simpleClean = normSlashes . reverse . dropWhile (=='/') . reverse . pathToPosix --- | The root directory as an absolute path.-rootDirectory :: AbsolutePath-rootDirectory = AbsolutePath "/"- makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd makeAbsoluteOrStd _ "-" = APStd makeAbsoluteOrStd a p = AP $ makeAbsolute a p@@ -505,13 +388,7 @@     accepts both path separators, and repositories always use the UNIX     separator anyway. -}-isMaliciousPath :: String -> Bool-isMaliciousPath fp =-    not (isExplicitlyRelative fp) || isGenerallyMalicious fp --- | Warning : this is less rigorous than isMaliciousPath---   but it's to allow for subpath representations that---   don't start with ./ isMaliciousSubPath :: String -> Bool isMaliciousSubPath fp =     not (FilePath.isRelative fp) || isGenerallyMalicious fp@@ -522,29 +399,6 @@  where     contains_any a b = not . null $ intersect a b --isExplicitlyRelative :: String -> Bool-isExplicitlyRelative ('.':'/':_) = True  -- begins with "./"-isExplicitlyRelative _ = False---- | Construct a filter from a list of AnchoredPaths, that will accept any path--- that is either a parent or a child of any of the listed paths, and discard--- everything else.-filterPaths :: [AnchoredPath]-            -> AnchoredPath-            -> t-            -> Bool-filterPaths files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files----- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to--- AnchoredPath).-filterFilePaths :: [FilePath]-                -> AnchoredPath-                -> t-                -> Bool-filterFilePaths = filterPaths . map floatPath- -- | Iteratively tries find first non-existing path generated by -- buildName, it feeds to buildName the number starting with -1.  When -- it generates non-existing path and it isn't first, it displays the@@ -563,23 +417,19 @@        else go $ i+1     where thename = buildName i --- | Transform a SubPath into an AnchoredPath.-floatSubPath :: SubPath -> AnchoredPath-floatSubPath = floatPath . fn2fp . sp2fn-  ------------------------------- -- AnchoredPath utilities -- -newtype Name = Name { unName :: B.ByteString } deriving (Eq, Show, Ord)+newtype Name = Name { unName :: B.ByteString } deriving (Binary, Eq, Show, Ord)  -- | This is a type of "sane" file paths. These are always canonic in the sense -- that there are no stray slashes, no ".." components and similar. They are -- usually used to refer to a location within a Tree, but a relative filesystem -- path works just as well. These are either constructed from individual name -- components (using "appendPath", "catPaths" and "makeName"), or converted--- from a FilePath ("floatPath" -- but take care when doing that) or .-newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord)+-- from a FilePath ("floatPath" -- but take care when doing that).+newtype AnchoredPath = AnchoredPath [Name] deriving (Binary, Eq, Show, Ord)  -- | Check whether a path is a prefix of another path. isPrefix :: AnchoredPath -> AnchoredPath -> Bool@@ -587,81 +437,151 @@  -- | Append an element to the end of a path. appendPath :: AnchoredPath -> Name -> AnchoredPath-appendPath (AnchoredPath p) n =-    case n of-      (Name s) | B.null s -> AnchoredPath p-               | s == BC.pack "." -> AnchoredPath p-               | otherwise -> AnchoredPath $ p ++ [n]+appendPath (AnchoredPath p) n = AnchoredPath $ p ++ [n]  -- | Catenate two paths together. Not very safe, but sometimes useful -- (e.g. when you are representing paths relative to a different point than a -- Tree root). catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath-catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath $ p ++ n+catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath (p ++ n)  -- | Get parent (path) of a given path. foo/bar/baz -> foo/bar-parent :: AnchoredPath -> AnchoredPath-parent (AnchoredPath x) = AnchoredPath (init x)+parent :: AnchoredPath -> Maybe AnchoredPath+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 parents of a given path. foo/bar/baz -> [.,foo, foo/bar] parents :: AnchoredPath -> [AnchoredPath]-parents (AnchoredPath x) = map AnchoredPath . init . inits $ x+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'. anchorPath :: FilePath -> AnchoredPath -> FilePath-anchorPath dir p = dir </> decodeLocale (flatten p)+anchorPath dir p = dir FilePath.</> decodeLocale (flatten p) {-# INLINE anchorPath #-} +name2fp :: Name -> FilePath+name2fp (Name ps) = decodeLocale ps++-- FIXME returning "." for the root is wrong flatten :: AnchoredPath -> BC.ByteString flatten (AnchoredPath []) = BC.singleton '.'-flatten (AnchoredPath p) = BC.intercalate (BC.singleton '/')-                                           [ n | (Name n) <- p ]+flatten (AnchoredPath p) = BC.intercalate (BC.singleton '/') [n | (Name n) <- p] -makeName :: String -> Name-makeName ".." = error ".. is not a valid AnchoredPath component name"-makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name"-           | otherwise = Name $ encodeLocale n+-- | Make a 'Name' from a 'String'. If the input 'String'+-- is invalid, that is, "", ".", "..", or contains a '/', return 'Left'+-- with an error message.+makeName :: String -> Either String Name+makeName = rawMakeName . encodeLocale --- | Take a relative FilePath and turn it into an AnchoredPath. The operation--- is (relatively) unsafe. Basically, by using floatPath, you are testifying--- that the argument is a path relative to some common root -- i.e. the root of--- the associated "Tree" object. Also, there are certain invariants about--- AnchoredPath that this function tries hard to preserve, but probably cannot--- guarantee (i.e. this is a best-effort thing). You should sanitize any+-- | 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+-- 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).+-- (using this function), especially if the FilePath come from any external+-- source (command line, file, environment, network, etc) floatPath :: FilePath -> AnchoredPath-floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator-  where make ["."] = AnchoredPath []-        make x = AnchoredPath $ map (Name . encodeLocale) x-+floatPath =+    AnchoredPath . map internalMakeName . filter sensible .+    splitDirectories . normalise . dropTrailingPathSeparator+  where+    sensible s = s `notElem` ["", "."]  anchoredRoot :: AnchoredPath anchoredRoot = AnchoredPath [] --- | Take a prefix path, the changed prefix path, and a path to change.--- Assumes the prefix path is a valid prefix. If prefix is wrong return--- AnchoredPath [].-replacePrefixPath :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath-replacePrefixPath (AnchoredPath []) b c = catPaths b c-replacePrefixPath (AnchoredPath (r:p)) b (AnchoredPath (r':p'))-    | r == r' = replacePrefixPath (AnchoredPath p) b (AnchoredPath p')-    | otherwise = AnchoredPath []-replacePrefixPath _ _ _ = AnchoredPath []+-- | A view on 'AnchoredPath's.+parentChild :: AnchoredPath -> Maybe (AnchoredPath, Name)+parentChild (AnchoredPath []) = Nothing+parentChild (AnchoredPath xs) = Just (AnchoredPath (init xs), last xs) --- | Append a String to the last Name of an AnchoredPath.-appendToName :: AnchoredPath -> String -> AnchoredPath-appendToName (AnchoredPath p) s = AnchoredPath (init p++[Name finalname])-    where suffix = encodeLocale s-          finalname | suffix `elem` (BC.tails lastname) = lastname-                    | otherwise = BC.append lastname suffix-          lastname = case last p of-                        Name name -> name+-- | Replace the second arg's parent with the first arg.+replaceParent :: AnchoredPath -> AnchoredPath -> Maybe AnchoredPath+replaceParent (AnchoredPath xs) p =+  case parentChild p of+    Nothing -> Nothing+    Just (_,x) -> Just (AnchoredPath (xs ++ [x])) -unsafeMakeName :: B.ByteString -> Name-unsafeMakeName = Name+-- | Make a 'Name' from a 'B.ByteString'.+rawMakeName :: B.ByteString -> Either String Name+rawMakeName s+  | isBadName s =+      Left $ "'"++decodeLocale s++"' is not a valid AnchoredPath component name"+  | otherwise = Right (Name s) +isBadName :: B.ByteString -> Bool+isBadName n = hasPathSeparator n || n `elem` forbiddenNames++-- It would be nice if we could add BC.pack "_darcs" to the list, however+-- "_darcs" could be a valid file or dir name if not inside the top level+-- directory.+forbiddenNames :: [B.ByteString]+forbiddenNames = [BC.empty, BC.pack ".", BC.pack ".."]++hasPathSeparator :: B.ByteString -> Bool+hasPathSeparator = BC.elem '/'+ eqAnycase :: Name -> Name -> Bool eqAnycase (Name a) (Name b) = BC.map toLower a == BC.map toLower b++encodeWhiteName :: Name -> B.ByteString+encodeWhiteName = encodeLocale . encodeWhite . decodeLocale . unName++data CorruptPatch = CorruptPatch String deriving (Eq, Typeable)+instance Exception CorruptPatch+instance Show CorruptPatch where show (CorruptPatch s) = s++decodeWhiteName :: B.ByteString -> Name+decodeWhiteName =+  either (throw . CorruptPatch) id .+  rawMakeName . encodeLocale . decodeWhite . decodeLocale++-- | The effect of renaming on paths.+-- The first argument is the old path, the second is the new path,+-- and the third is the possibly affected path we are interested in.+movedirfilename :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath+movedirfilename (AnchoredPath old) newp@(AnchoredPath new) orig@(AnchoredPath path) =+  case stripPrefix old path of+    Just [] -> newp -- optimization to avoid allocation in this case+    Just rest -> AnchoredPath (new ++ rest)+    Nothing -> orig -- old is not a prefix => no change++-- | Construct a filter from a list of AnchoredPaths, that will accept any path+-- that is either a parent or a child of any of the listed paths, and discard+-- everything else.+filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool+filterPaths files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files+++-- | Transform a SubPath into an AnchoredPath.+floatSubPath :: SubPath -> AnchoredPath+floatSubPath = floatPath . toFilePath++-- | Is the given path in (or equal to) the _darcs metadata directory?+inDarcsdir :: AnchoredPath -> Bool+inDarcsdir (AnchoredPath (x:_)) | x == darcsdirName = True+inDarcsdir _ = False++darcsdirName :: Name+darcsdirName = internalMakeName darcsdir++isRoot :: AnchoredPath -> Bool+isRoot (AnchoredPath xs) = null xs
src/Darcs/Util/Printer.hs view
@@ -1,51 +1,24 @@--- | A 'Document' is at heart 'ShowS' from the prelude------ Essentially, if you give a Doc a string it'll print out whatever it--- wants followed by that string. So @text "foo"@ makes the Doc that--- prints @"foo"@ followed by its argument. The combinator names are taken--- from 'Text.PrettyPrint.HughesPJ', although the behaviour of the two libraries is--- slightly different.------ The advantage of Printer over simple string appending/concatenating is--- that the appends end up associating to the right, e.g.:------ >   (text "foo" <> text "bar") <> (text "baz" <> text "quux") ""--- > = \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) ""--- > = (text "foo" <> text "bar") ((text "baz" <> text "quux") "")--- > = (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "")--- > = text "foo" (text "bar" ((text "baz" <> text "quux") ""))--- > = (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") ""))--- > = "foo" ++ (text "bar" ((text "baz" <> text "quux") ""))--- > = "foo" ++ ("bar" ++ ((text "baz" <> text "quux") ""))--- > = "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) ""))--- > = "foo" ++ ("bar" ++ (text "baz" (text "quux" "")))--- > = "foo" ++ ("bar" ++ ("baz" ++ (text "quux" "")))--- > = "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ "")))------ The Empty alternative comes in because you want------ > text "a" $$ vcat xs $$ text "b"+-- | Darcs pretty printing library ----- '$$' means above, 'vcat' is the list version of '$$'--- (to be @\"a\\nb\"@ when @xs@  is @[]@), but without the concept of an--- Empty Document each @$$@ would add a @'\n'@ and you'd end up with--- @\"a\\n\\nb\"@.--- Note that @Empty \/= text \"\"@ (the latter would cause two--- @'\\n'@).+-- The combinator names are taken from 'Text.PrettyPrint.HughesPJ', although+-- the behaviour of the two libraries is slightly different. -- -- This code was made generic in the element type by Juliusz Chroboczek. module Darcs.Util.Printer     (     -- * 'Doc' type and structural combinators       Doc(Doc,unDoc)-    , empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat, hsep+    , empty, (<>), (<?>), (<+>), ($$), ($+$), vcat, vsep, hcat, hsep     , minus, newline, plus, space, backslash, lparen, rparen-    , parens+    , parens, sentence     -- * Constructing 'Doc's     , text     , hiddenText     , invisibleText     , wrapText, quoted+    , formatText+    , formatWords+    , pathlist     , userchunk, packedString     , prefix     , hiddenPrefix@@ -76,18 +49,15 @@     , hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith     , hPutDocCompr     , debugDocLn-    , ePutDocLn-    , errorDoc     -- * TODO: It is unclear what is unsafe about these constructors     , unsafeText, unsafeBoth, unsafeBothText, unsafeChar     , unsafePackedString     ) where -import Prelude () import Darcs.Prelude  import Data.String ( IsString(..) )-import System.IO ( Handle, stdout, stderr )+import System.IO ( Handle, stdout ) import qualified Data.ByteString as B ( ByteString, hPut, concat ) import qualified Data.ByteString.Char8 as BC ( singleton ) @@ -140,10 +110,17 @@ parens :: Doc -> Doc parens d = lparen <> d <> rparen --- | Fail with a stack trace and the given 'Doc' as error message.-errorDoc :: Doc -> a-errorDoc x = error $ renderString x+-- | Turn a 'Doc' into a sentence. This appends a ".".+sentence :: Doc -> Doc+sentence = (<> text ".") +-- | Format a list of 'FilePath's as quoted text. It deliberately refuses to+-- use English.andClauses but rather separates the quoted strings only with a+-- space, because this makes it usable for copy and paste e.g. as arguments to+-- another shell command.+pathlist :: [FilePath] -> Doc+pathlist paths = hsep (map quoted paths)+ -- | 'putDocWith' puts a 'Doc' on stdout using the given printer. putDocWith :: Printers -> Doc -> IO () putDocWith prs = hPutDocWith prs stdout@@ -162,17 +139,11 @@ putDocLn :: Doc -> IO () putDocLn = hPutDocLn stdout --- | 'eputDocLn' puts a 'Doc', followed by a newline to stderr using--- 'simplePrinters'. Like putDocLn, it encodes with the user's locale.--- This function is the recommended way to output messages that should--- be visible to users on the console, but cannot (or should not) be--- silenced even when --quiet is in effect.-ePutDocLn :: Doc -> IO ()-ePutDocLn = hPutDocLn stderr- -- | 'hputDocWith' puts a 'Doc' on the given handle using the given printer. hPutDocWith :: Printers -> Handle -> Doc -> IO ()-hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d)+hPutDocWith prs h d = do+  p <- prs h+  hPrintPrintables h (renderWith p d)  -- | 'hputDocLnWith' puts a 'Doc', followed by a newline on the given -- handle using the given printer.@@ -221,7 +192,7 @@ -- hanlde, and the current prefix of the document. data St = St { printers :: !Printers',                currentPrefix :: !([Printable] -> [Printable]) }-type Printers = Handle -> Printers'+type Printers = Handle -> IO Printers'  -- | A set of printers to print different types of text to a handle. data Printers' = Printers {colorP :: !(Color -> Printer),@@ -391,12 +362,23 @@ -- | @'wrapText' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters wrapText :: Int -> String -> Doc wrapText n s =-    vcat . map text . reverse $ "" : foldl add_to_line [] (words s)+    vcat . map text . reverse $ foldl add_to_line [] (words s)   where add_to_line [] a = [a]         add_to_line ("":d) a = a:d         add_to_line (l:ls) new | length l + length new > n = new:l:ls         add_to_line (l:ls) new = (l ++ " " ++ new):ls +-- | Given a list of 'String's representing the words of a paragraph, format+-- the paragraphs using 'wrapText' and separate them with an empty line.+formatText :: Int -> [String] -> Doc+formatText w = vsep . map (wrapText w)++-- | A variant of 'wrapText' that takes a list of strings as input.+-- Useful when @{-# LANGUAGE CPP #-}@ makes it impossible to use multiline+-- string literals.+formatWords :: [String] -> Doc+formatWords = wrapText 80 . unwords+ -- | Creates a 'Doc' from any 'Printable'. printable :: Printable -> Doc printable x = Doc $ \st -> defP (printers st) x st@@ -419,7 +401,7 @@ -- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any -- handle. simplePrinters :: Printers-simplePrinters _ = simplePrinters'+simplePrinters _ = return simplePrinters'  -- | A set of default printers suitable for any handle. Does not use color. simplePrinters' :: Printers'@@ -447,7 +429,7 @@  infixr 6 `append` infixr 6 <+>-infixr 5 `vplus`+infixr 5 $+$ infixr 5 $$  -- | The empty 'Doc'@@ -506,9 +488,9 @@                         where pf = currentPrefix st                               sf = lineColorS $ printers st --- | @vplus a b@ is @a@ above @b@ with an empty line in between if both are non-empty-vplus :: Doc -> Doc -> Doc-Doc a `vplus` Doc b =+-- | @a '$+$' b@ is @a@ above @b@ with an empty line in between if both are non-empty+($+$) :: Doc -> Doc -> Doc+Doc a $+$ Doc b =    Doc $ \st -> case a st of                 Empty -> b st                 Document af ->@@ -524,7 +506,7 @@  -- | Pile 'Doc's vertically, with a blank line in between vsep :: [Doc] -> Doc-vsep = foldr vplus empty+vsep = foldr ($+$) empty  -- | Concatenate 'Doc's horizontally hcat :: [Doc] -> Doc
src/Darcs/Util/Printer/Color.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module Darcs.Util.Printer.Color-    ( showDoc, errorDoc, traceDoc, assertDoc, fancyPrinters+    ( unsafeRenderStringColored, traceDoc, debugDoc, fancyPrinters     , environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite+    , ePutDocLn     ) where -import Prelude () import Darcs.Prelude  import Darcs.Util.Printer@@ -12,7 +12,9 @@     , invisiblePrinter, (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat     , unsafeText, unsafePackedString     , renderStringWith, prefix+    , hPutDocLnWith     )+import Darcs.Util.Global ( whenDebugMode, putTiming )  import Debug.Trace ( trace ) import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr )@@ -32,18 +34,25 @@ dollar = unsafeBothText "$" cr     = unsafeBothText "\r" -errorDoc :: Doc -> a-errorDoc = error . showDoc+-- | 'eputDocLn' puts a 'Doc', followed by a newline to stderr using+-- 'fancyPrinters'. Like putDocLn, it encodes with the user's locale.+-- This function is the recommended way to output messages that should+-- be visible to users on the console, but cannot (or should not) be+-- silenced even when --quiet is in effect.+ePutDocLn :: Doc -> IO ()+ePutDocLn = hPutDocLnWith fancyPrinters stderr +debugDoc :: Doc -> IO ()+debugDoc m = whenDebugMode $ do+  putTiming+  hPutDocLnWith fancyPrinters stderr m+ traceDoc :: Doc -> a -> a-traceDoc d = trace (showDoc d)+traceDoc = trace . unsafeRenderStringColored -assertDoc :: Maybe Doc -> a -> a-assertDoc Nothing x = x-assertDoc (Just e) _ = errorDoc e+unsafeRenderStringColored :: Doc -> String+unsafeRenderStringColored = renderStringWith (unsafePerformIO (fancyPrinters stderr)) -showDoc :: Doc -> String-showDoc = renderStringWith (fancyPrinters stderr)  -- | The 'Policy' type is a record containing the variables which control -- how 'Doc's will be rendered on some output.@@ -60,12 +69,11 @@                      , poSpace :: Bool    -- ^ escape spaces (used with poTrailing)                      } -{-# NOINLINE getPolicy #-} -- | 'getPolicy' returns a suitable policy for a given handle. -- The policy is chosen according to environment variables, and to the -- type of terminal which the handle represents-getPolicy :: Handle -> Policy-getPolicy handle = unsafePerformIO $+getPolicy :: Handle -> IO Policy+getPolicy handle =  do isTerminal <- hIsTerminalDevice handle     nColors <- if isTerminal then getTermNColors else return 0 @@ -83,14 +91,13 @@     envDontColor         <- getEnvBool "DARCS_DONT_COLOR"     envAlwaysColor       <- getEnvBool "DARCS_ALWAYS_COLOR"     envAlternativeColor  <- getEnvBool "DARCS_ALTERNATIVE_COLOR"-    envDoColorLines    <- getEnvBool "DARCS_DO_COLOR_LINES"      let haveColor = envAlwaysColor || (isTerminal && (nColors > 4))         doColor   = not envDontColor && haveColor      return Policy { poColor    = doColor,                     poEscape   = not envDontEscapeAnything,-                    poLineColor= doColor && envDoColorLines,+                    poLineColor= doColor && not envAlternativeColor,                     poIsprint  = envDontEscapeIsprint || envUseIsprint,                     po8bit     = not envEscape8bit,                     poNoEscX   = envDontEscapeExtra,@@ -127,15 +134,17 @@ -- | @'fancyPrinters' h@ returns a set of printers suitable for outputting -- to @h@ fancyPrinters :: Printers-fancyPrinters h = let policy = getPolicy h in-                      Printers { colorP = colorPrinter policy,-                             invisibleP = invisiblePrinter,-                             hiddenP = colorPrinter policy Green,-                             userchunkP = userchunkPrinter policy,-                             defP       = escapePrinter policy,-                             lineColorT = lineColorTrans policy,-                             lineColorS = lineColorSuffix policy-                           }+fancyPrinters h = do+  policy <- getPolicy h+  return Printers {+    colorP = colorPrinter policy,+    invisibleP = invisiblePrinter,+    hiddenP = colorPrinter policy Green,+    userchunkP = userchunkPrinter policy,+    defP       = escapePrinter policy,+    lineColorT = lineColorTrans policy,+    lineColorS = lineColorSuffix policy+  }  -- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po. -- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise@@ -309,17 +318,17 @@  environmentHelpColor :: ([String], [String]) environmentHelpColor = (["DARCS_DONT_COLOR", "DARCS_ALWAYS_COLOR",-                         "DARCS_ALTERNATIVE_COLOR", "DARCS_DO_COLOR_LINES"],[+                         "DARCS_ALTERNATIVE_COLOR"],[   "If the terminal understands ANSI color escape sequences, darcs will",-  "highlight certain keywords and delimiters when printing patches. This",-  "can be turned off by setting the environment variable DARCS_DONT_COLOR",-  "to 1. If you use a pager that happens to understand ANSI colors, like",+  "highlight certain keywords and delimiters when printing patches, and",+  "also print hunk lines in color according to whether they are removed",+  "or added. This can be turned off by setting the environment variable",+  "DARCS_DONT_COLOR to 1.",+  "If you use a pager that happens to understand ANSI colors, like",   "`less -R`, darcs can be forced always to highlight the output by setting",   "DARCS_ALWAYS_COLOR to 1. If you can't see colors you can set",   "DARCS_ALTERNATIVE_COLOR to 1, and darcs will use ANSI codes for bold",-  "and reverse video instead of colors. In addition, there is an",-  "extra-colorful mode, which is not enabled by default, which can be",-  "activated with DARCS_DO_COLOR_LINES"])+  "and reverse video instead of colors."])  environmentHelpEscapeWhite :: ([String], [String]) environmentHelpEscapeWhite = ([ "DARCS_DONT_ESCAPE_TRAILING_SPACES",
src/Darcs/Util/Progress.hs view
@@ -14,7 +14,6 @@     , endTedious     , tediousSize     , debugMessage-    , debugFail     , withoutProgress     , progress     , progressKeepLatest@@ -26,11 +25,8 @@     ) where  -import Prelude () import Darcs.Prelude -import Prelude hiding (lookup)- import Control.Arrow ( second ) import Control.Exception ( bracket ) import Control.Monad ( when, unless, void )@@ -46,7 +42,7 @@                    Handle, BufferMode(LineBuffering) ) import System.IO.Unsafe ( unsafePerformIO ) -import Darcs.Util.Global ( withDebugMode, debugMessage, putTiming, debugFail )+import Darcs.Util.Global ( withDebugMode, debugMessage, putTiming )   data ProgressData = ProgressData@@ -55,9 +51,12 @@     , total   :: !(Maybe Int)     } +progressRate :: Int+progressRate = 1000000+ handleProgress :: IO () handleProgress = do-    threadDelay 1000000+    threadDelay progressRate     handleMoreProgress "" 0  @@ -67,13 +66,13 @@                  mp <- getProgressData s                  case mp of                    Nothing -> do-                      threadDelay 1000000+                      threadDelay progressRate                       handleMoreProgress k n                    Just p -> do                       when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p-                      threadDelay 1000000+                      threadDelay progressRate                       handleMoreProgress s (sofar p)-         else do threadDelay 1000000+         else do threadDelay progressRate                  handleMoreProgress k n
src/Darcs/Util/Prompt.hs view
@@ -10,10 +10,10 @@     ) where  -import Prelude () import Darcs.Prelude  import Control.Monad ( void )+import Control.Monad.Trans ( liftIO )  import Data.Char ( toUpper, toLower, isSpace ) @@ -27,7 +27,7 @@         -> IO String -- ^ The string the user entered. askUser prompt = withoutProgress $ runInputT defaultSettings $                     getInputLine prompt-                        >>= maybe (error "askUser: unexpected end of input") return+                        >>= maybe (liftIO $ fail "askUser: unexpected end of input") return  -- | Ask the user to press Enter askEnter :: String  -- ^ The prompt to display@@ -45,7 +45,7 @@   where     loop = do       answer <- getInputLine prompt-                  >>= maybe (error "askUser: unexpected end of input") return+                  >>= maybe (liftIO $ fail "askUser: unexpected end of input") return       case maybeRead answer of         Just n | n > 0 && n <= length xs -> return (xs !! (n-1))         _ -> outputStrLn "Invalid response, try again!" >> loop@@ -78,17 +78,17 @@ --   selected when the user presses the space bar) is shown as uppercase, --   hence users may want to enter it as uppercase. promptChar :: PromptConfig -> IO Char-promptChar (PromptConfig p basic_chs adv_chs md help_chs) =+promptChar (PromptConfig p basic_chs adv_chs def_ch help_chs) =   withoutProgress $ runInputT defaultSettings loopChar  where  chs = basic_chs ++ adv_chs  loopChar = do     let chars = setDefault (basic_chs ++ (if null adv_chs then "" else "..."))         prompt = p ++ " [" ++ chars ++ "]" ++ helpStr-    a <- getInputChar prompt >>= maybe (error "promptChar: unexpected end of input") (return . toLower)+    a <- getInputChar prompt >>= maybe (liftIO $ fail "promptChar: unexpected end of input") (return . toLower)     case () of      _ | a `elem` chs                   -> return a-       | a == ' '                       -> maybe tryAgain return md+       | a == ' '                       -> maybe tryAgain return def_ch        | a `elem` help_chs              -> return a        | otherwise                      -> tryAgain  helpStr = case help_chs of@@ -97,7 +97,7 @@                  | otherwise       -> ", or " ++ (h:" for more options: ")  tryAgain = do outputStrLn "Invalid response, try again!"                loopChar- setDefault s = case md of Nothing -> s-                           Just d  -> map (setUpper d) s+ setDefault s = case def_ch of Nothing -> s+                               Just d  -> map (setUpper d) s  setUpper d c = if d == c then toUpper c else c
src/Darcs/Util/Ratified.hs view
@@ -5,4 +5,4 @@     , hGetContents     ) where -import System.IO( hGetContents )+import System.IO ( hGetContents, readFile )
src/Darcs/Util/Show.hs view
@@ -2,7 +2,6 @@     ( appPrec, BSWrapper(..)     ) where -import Prelude () import Darcs.Prelude  import qualified Data.ByteString as B
src/Darcs/Util/SignalHandler.hs view
@@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}  module Darcs.Util.SignalHandler     ( withSignalsHandled, withSignalsBlocked,@@ -23,7 +23,6 @@       tryNonSignal, stdoutIsAPipe     ) where -import Prelude () import Darcs.Prelude  import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )@@ -53,13 +52,13 @@             return (isNamedPipe stat))         (\(_ :: IOException) -> return False) -withSignalsHandled :: IO a -> IO a newtype SignalException = SignalException Signal deriving (Show, Typeable)  instance Exception SignalException where    toException = SomeException    fromException (SomeException e) = cast e +withSignalsHandled :: IO a -> IO a withSignalsHandled job = do     thid <- myThreadId     mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE]@@ -71,16 +70,16 @@                      | s == sigTERM = ew s "TERM"                      | s == sigPIPE = exitWith $ ExitFailure 1                      | otherwise = ew s "Unhandled signal!"-          ew sig s = do hPutStrLn stderr $ "withSignalsHandled: " ++ s+          ew sig s = do hPutStrLn stderr s                         resethandler sig                         raiseSignal sig -- ensure that our caller knows how we died                         exitWith $ ExitFailure 1           die_with_string e | "STDOUT" `isPrefixOf` e =                 do is_pipe <- stdoutIsAPipe                    unless is_pipe $-                        hPutStrLn stderr $ "\ndarcs failed:  "++drop 6 e+                        hPutStrLn stderr $ drop 6 e                    exitWith $ ExitFailure 2-          die_with_string e = do hPutStrLn stderr $ "\ndarcs failed:  "++e+          die_with_string e = do hPutStrLn stderr e                                  exitWith $ ExitFailure 2 #ifdef WIN32           job' thid =
src/Darcs/Util/Ssh.hs view
@@ -29,9 +29,7 @@     , transferModeHeader     ) where -import Prelude () import Darcs.Prelude-import Prelude hiding ( lookup )  import System.Environment ( getEnv ) import System.Exit ( ExitCode(..) )@@ -50,10 +48,9 @@  import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.URL ( SshFilePath, sshFilePathOf, sshUhost, sshRepo, sshFile )-import Darcs.Util.Text ( breakCommand, showCommandLine ) import Darcs.Util.Exception ( prettyException, catchall ) import Darcs.Util.Exec ( readInteractiveProcess, ExecException(..), Redirect(AsIs) )-import Darcs.Util.Progress ( withoutProgress, debugMessage, debugFail )+import Darcs.Util.Progress ( withoutProgress, debugMessage )  import qualified Darcs.Util.Ratified as Ratified ( hGetContents ) @@ -186,7 +183,7 @@     hSetBinaryMode o True     l <- hGetLine o     unless (l == transferModeHeader) $-      debugFail "Couldn't start darcs transfer-mode on server"+      fail "Couldn't start darcs transfer-mode on server"     return $ Just C { inp = i, out = o, err = e }     `catchNonSignal` \exn -> do       debugMessage $ "Failed to start ssh connection: " ++ prettyException exn@@ -215,7 +212,7 @@                         -- only grabbing stderr, and we're also                         -- about to throw the contents.                       eee <- Ratified.hGetContents (err c)-                      debugFail $ e ++ " grabbing ssh file " +++                      fail $ e ++ " grabbing ssh file " ++                         sshFilePathOf src ++"\n" ++ eee       file = sshFile src   hPutStrLn (inp c) $ "get " ++ file@@ -229,7 +226,7 @@     else if l2 == "error "++file          then do e <- hGetLine (out c)                  case reads e of-                   (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg+                   (msg,_):_ -> fail $ "Error reading file remotely:\n"++msg                    [] -> failwith "An error occurred"          else failwith "Error" @@ -258,6 +255,10 @@         tr '$' = "\\$"         tr c = [c] +-- | Show a command and its arguments for debug messages.+showCommandLine :: [String] -> String+showCommandLine = unwords . map show+ transferModeHeader :: String transferModeHeader = "Hello user, I am darcs transfer mode" @@ -277,7 +278,6 @@ fromSshCmd s SCP  = scp s fromSshCmd s SFTP = sftp s - -- | Return the command and arguments needed to run an ssh command --   First try the appropriate darcs environment variable and SSH_PORT --   defaulting to "ssh" and no specified port.@@ -292,7 +292,10 @@     portFlag SSH  x = ["-p", x]     portFlag SCP  x = ["-P", x]     portFlag SFTP x = ["-oPort=" ++ x]-+    breakCommand s =+      case words s of+        (arg0:args) -> (arg0, args)+        [] -> (s, [])  environmentHelpSsh :: ([String], [String]) environmentHelpSsh = (["DARCS_SSH"], [
− src/Darcs/Util/Text.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Darcs.Util.Text-    (-    -- * Text construction.-      sentence-    -- * Text formatting.-    , formatText-    , formatParas-    , formatPara-    , chompTrailingNewline-    -- * Text processing-    , breakCommand-    , quote-    , pathlist-    , showCommandLine-    ) where--import Prelude ()-import Darcs.Prelude--import Control.Arrow ( first )-import Data.List ( intercalate )--import Darcs.Util.Printer ( Doc, renderString, quoted, hsep )--sentence :: Doc -> Doc-sentence = (<> ".")---- |Take a list of paragraphs and format them to the given line length, with--- a blank line between paragraphs.-formatText :: Int -> [String] -> String-formatText linelen = unlines . formatParas linelen--formatParas :: Int -> [String] -> [String]-formatParas linelen = intercalate [""] .-                      map (map unwords . formatPara linelen . words)---- |Take a list of words and split it up so that each chunk fits into the specified width--- when spaces are included. Any words longer than the specified width end up in a chunk--- of their own.-formatPara :: Int -> [[a]] -> [[[a]]]-formatPara w = para'-  where para' [] = []-        para' xs = uncurry (:) $ para'' w xs-        para'' r (x:xs) | w == r || length x < r = first (x:) $ para'' (r - length x - 1) xs-        para'' _ xs = ([], para' xs)--breakCommand :: String -> (String, [String])-breakCommand s = case words s of-                   (arg0:args) -> (arg0,args)-                   [] -> (s,[])--chompTrailingNewline :: String -> String-chompTrailingNewline "" = ""-chompTrailingNewline s = if last s == '\n' then init s else s---- | Quote a string for screen output.-quote :: String -> String-quote = renderString . quoted---- | Format a list of 'FilePath's as quoted text. It deliberately refuses to--- use English.andClauses but rather separates the quoted strings only with a--- space, because this makes it usable for copy and paste e.g. as arguments to--- another shell command.-pathlist :: [FilePath] -> Doc-pathlist paths = hsep (map quoted paths)---- | Produce a String composed by the elements of [String] each enclosed in--- double quotes.-showCommandLine :: [String] -> String-showCommandLine strings = showCommandLine' ['"'] strings-            where showCommandLine' x xs =-                        x ++ intercalate (x ++ " " ++ x) xs ++ x
src/Darcs/Util/Tree.hs view
@@ -1,7 +1,7 @@ --  Copyright (C) 2009-2011 Petr Rockai -- --  BSD3-{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}  -- | The abstract representation of a Tree and useful abstract utilities to -- handle those.@@ -20,6 +20,7 @@     , items, list, listImmediate, treeHash     , lookup, find, findFile, findTree, itemHash, itemType     , zipCommonFiles, zipFiles, zipTrees, diffTrees+    , explodePath, explodePaths      -- * Files (Blobs).     , readBlob@@ -29,10 +30,14 @@      -- * Manipulating trees.     , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay-    , addMissingHashes ) where+    , addMissingHashes -import Prelude ()+    -- * Properties+    , prop_explodePath+    ) where+ import Darcs.Prelude hiding ( filter )+import qualified Prelude ( filter )  import Control.Exception( catch, IOException ) import Darcs.Util.Path@@ -155,6 +160,17 @@                     concat [ paths subt (appendPath p subn)                              | (subn, SubTree subt) <- listImmediate t ] +-- | Like 'explodePath' but for multiple paths.+explodePaths :: Tree IO -> [AnchoredPath] -> [AnchoredPath]+explodePaths tree paths = concatMap (explodePath tree) paths++-- | All paths in the tree that that have the given path as prefix.+--+-- prop> explodePath t p == Prelude.filter (p `isPrefix`) (map fst (list t))+explodePath :: Tree m -> AnchoredPath -> [AnchoredPath]+explodePath tree path =+  path : maybe [] (map (catPaths path . fst) . list) (findTree tree path)+ expandUpdate :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m) expandUpdate update t_ = go (AnchoredPath []) t_     where go path t = do@@ -261,7 +277,7 @@                 (Just (SubTree _), Stub _ _) -> True                 (Just (File _), File _) -> True                 (Just (Stub _ _), _) ->-                    bug "*sulk* Go away, you, you precondition violator!"+                    error "*sulk* Go away, you, you precondition violator!"                 (_, _) -> False  -- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with@@ -322,7 +338,7 @@         subtree :: TreeItem m -> m (Tree m)         subtree (Stub x _) = x         subtree (SubTree x) = return x-        subtree (File _) = bug "diffTrees tried to descend a File as a subtree"+        subtree (File _) = error "diffTrees tried to descend a File as a subtree"         maybeUnfold (Stub x _) = SubTree `fmap` (x >>= expand)         maybeUnfold (SubTree x) = SubTree `fmap` expand x         maybeUnfold i = return i@@ -352,7 +368,7 @@                              do l' <- maybeUnfold l                                 r' <- maybeUnfold r                                 return (n, Just l', Just r')-                     _ -> bug "n lookups failed"+                     _ -> error "n lookups failed"                    | n <- immediateN left' `union` immediateN right' ]           let is_l = [ (n, l) | (n, Just l, _) <- is ]               is_r = [ (n, r) | (n, _, Just r) <- is ]@@ -386,14 +402,14 @@                     Just (Stub s _) -> (False, Stub (do x <- s                                                         return $! snd $! subtree x) NoHash)                     Nothing -> (False, SubTree $! snd $! subtree emptyTree)-                    _ -> bug $ "Modify tree at " ++ show path+                    _ -> error $ "Modify tree at " ++ show path          go _ (AnchoredPath []) (Just (Stub _ _)) =-            bug $ "descending in modifyTree, case = (Just (Stub _ _)), path = " ++ show p_+            error $ "descending in modifyTree, case = (Just (Stub _ _)), path = " ++ show p_         go _ (AnchoredPath []) (Just (File _)) =-            bug $ "descending in modifyTree, case = (Just (File _)), path = " ++ show p_+            error $ "descending in modifyTree, case = (Just (File _)), path = " ++ show p_         go _ (AnchoredPath []) Nothing =-            bug $ "descending in modifyTree, case = Nothing, path = " ++ show p_+            error $ "descending in modifyTree, case = Nothing, path = " ++ show p_  countmap :: forall a k. M.Map k a -> Int countmap = M.foldr (\_ i -> i + 1) 0@@ -404,7 +420,7 @@             , treeHash = NoHash }   where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s)         update (k, File f) = (k, File f)-        update (_, Stub _ _) = bug "Stubs not supported in updateTreePostorder"+        update (_, Stub _ _) = error "Stubs not supported in updateTreePostorder"  -- | Does /not/ expand the tree. updateTree :: (Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)@@ -420,7 +436,7 @@                                        , treeHash = NoHash }           case subtree of             SubTree t'' -> return t''-            _ -> bug "function passed to partiallyUpdateTree didn't changed SubTree to something else"+            _ -> error "function passed to partiallyUpdateTree changed SubTree to something else"         maybeupdate path (k, item) = if predi (path `appendPath` k) item           then update (path `appendPath` k) (k, item)           else return (k, item)@@ -446,7 +462,7 @@                                                                    b' <- b                                                                    return $ overlay b' o') NoHash                     (Just x, _) -> x-                    (_, _) -> bug $ "Unexpected case in overlay at get " ++ show n ++ "."+                    (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "."  addMissingHashes :: (Monad m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m) addMissingHashes make = updateTree update -- use partiallyUpdateTree here@@ -468,3 +484,9 @@ isSub (File _) = False isSub _ = True +-- Properties++-- | Specification of 'explodePath'+prop_explodePath :: Tree m -> AnchoredPath -> Bool+prop_explodePath t p =+  explodePath t p == Prelude.filter (isPrefix p) (map fst (list t))
src/Darcs/Util/Tree/Hashed.hs view
@@ -1,7 +1,6 @@ --  Copyright (C) 2009-2011 Petr Rockai -- --  BSD3-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}  -- | A few darcs-specific utility functions. These are used for reading and -- writing darcs and darcs-compatible hashed trees.@@ -29,12 +28,10 @@     , darcsUpdateHashes     ) where -import Prelude hiding ( lookup, (<$>) ) import System.FilePath ( (</>) )  import System.Directory( doesFileExist ) import Codec.Compression.GZip( decompress, compress )-import Control.Applicative( (<$>) )  import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BLC@@ -43,14 +40,30 @@  import Data.List( sortBy ) import Data.Maybe( fromJust, isJust )-import Control.Monad.State.Strict+import Control.Monad.State.Strict (liftIO,when,unless) -import Darcs.Util.Path-import Darcs.Util.ByteString ( FileSegment, readSegment )-import Darcs.Util.Hash-import Darcs.Util.Progress ( debugMessage )+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.Tree-import Darcs.Util.Tree.Monad+    ( Blob(..)+    , ItemType(..)+    , Tree(..)+    , TreeItem(..)+    , addMissingHashes+    , expand+    , itemHash+    , list+    , listImmediate+    , makeTreeWithHash+    , readBlob+    , updateSubtrees+    , updateTree+    )+import Darcs.Util.Tree.Monad (TreeIO, initialState, runTreeMonad)  --------------------------------------------------------------------- -- Utilities for coping with the darcs directory format.@@ -76,7 +89,7 @@     where prefix Nothing = ""           prefix (Just s') = formatSize s' ++ "-"           formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n-          hash = BC.unpack (encodeBase16 h)+          hash = showHash h  ---------------------------------------------- -- Darcs directory format.@@ -152,7 +165,7 @@ -- and with a given @hash@. readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)] readDarcsHashedDir dir h = do-  debugMessage $ "readDarcsHashedDir: " ++ dir ++ " " ++ BC.unpack (encodeBase16 (snd h))+  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@@ -194,7 +207,8 @@ -- | Write a Tree into a darcs-style hashed directory. writeDarcsHashed :: Tree IO -> FilePath -> IO Hash writeDarcsHashed tree' dir =-    do t <- darcsUpdateDirHashes <$> expand tree'+    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@@ -211,6 +225,7 @@ fsCreateHashedFile :: FilePath -> BLC.ByteString -> TreeIO () fsCreateHashedFile fn content =     liftIO $ do+      debugMessage $ "fsCreateHashedFile " ++ fn       exist <- doesFileExist fn       unless exist $ BL.writeFile fn content @@ -228,8 +243,9 @@           updateItem _ x = return x            updateFile b@(Blob _ !h) = do+            liftIO $ debugMessage $ "hashedTreeIO.updateFile: " ++ showHash h             content <- liftIO $ readBlob b-            let fn = dir </> BC.unpack (encodeBase16 h)+            let fn = dir </> showHash h                 nblob = Blob (decompress <$> rblob) h                 rblob = BL.fromChunks . return <$> B.readFile fn                 newcontent = compress content@@ -238,7 +254,10 @@           updateSub s = do             let !hash = treeHash s                 Just dirdata = darcsFormatDir s-                fn = dir </> BC.unpack (encodeBase16 hash)+                fn = dir </> showHash hash+            liftIO $ debugMessage $ "hashedTreeIO.updateSub: " ++ showHash hash             fsCreateHashedFile fn (compress dirdata)             return s +showHash :: Hash -> String+showHash = BC.unpack . encodeBase16
src/Darcs/Util/Tree/Monad.hs view
@@ -1,7 +1,6 @@ --  Copyright (C) 2009-2011 Petr Rockai -- --  BSD3-{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-}  -- | An experimental monadic interface to Tree mutation. The main idea is to -- simulate IO-ish manipulation of real filesystem (that's the state part of@@ -21,14 +20,13 @@     , TreeRO, TreeRW     ) where -import Prelude hiding ( readFile, writeFile, (<$>) )+import Darcs.Prelude hiding ( readFile, writeFile ) +import Control.Exception ( throw )+ import Darcs.Util.Path import Darcs.Util.Tree -import Control.Applicative( (<$>) )-import Control.Exception ( throw )- import Data.List( sortBy ) import Data.Int( Int64 ) import Data.Maybe( isNothing, isJust )@@ -58,7 +56,7 @@ type TreeMonad m = RWST AnchoredPath () (TreeState m) m type TreeIO = TreeMonad IO -class (Functor m, Monad m) => TreeRO m where+class Monad m => TreeRO m where     currentDirectory :: m AnchoredPath     withDirectory :: AnchoredPath -> m a -> m a     expandTo :: AnchoredPath -> m AnchoredPath@@ -80,8 +78,10 @@     rename :: AnchoredPath -> AnchoredPath -> m ()     copy   :: AnchoredPath -> AnchoredPath -> m () -initialState :: Tree m -> (TreeItem m -> m Hash)-                -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) -> TreeState m+initialState :: Tree m+             -> (TreeItem m -> m Hash)+             -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))+             -> TreeState m initialState t uh u = TreeState { tree = t                                 , changed = M.empty                                 , changesize = 0@@ -113,8 +113,8 @@ -- read and write -- reads are passed through to the actual filesystem, but the -- writes are held in memory in a form of modified Tree. virtualTreeMonad :: (Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m)-virtualTreeMonad action t = runTreeMonad' action $-                               initialState t (\_ -> return NoHash) (\_ x -> return x)+virtualTreeMonad action t =+  runTreeMonad' action $ initialState t (\_ -> return NoHash) (\_ x -> return x)  virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO) virtualTreeIO = virtualTreeMonad@@ -141,12 +141,15 @@                      , changesize = changesize st + change }  renameChanged :: (Monad m)-               => AnchoredPath -> AnchoredPath -> TreeMonad m ()-renameChanged from to = modify $ \st -> st { changed = rename' $ changed st }-  where rename' = M.fromList . map renameone . M.toList-        renameone (x, d) | from `isPrefix` x = (to `catPaths` relative from x, d)-                         | otherwise = (x, d)-        relative (AnchoredPath from') (AnchoredPath x) = AnchoredPath $ drop (length from') x+              => AnchoredPath -> AnchoredPath -> TreeMonad m ()+renameChanged from to = modify $ \st -> st {changed = rename' $ changed st}+  where+    rename' = M.fromList . map renameone . M.toList+    renameone (x, d)+      | from `isPrefix` x = (to `catPaths` relative from x, d)+      | otherwise = (x, d)+    relative (AnchoredPath from') (AnchoredPath x) =+      AnchoredPath $ drop (length from') x  -- | Replace an item with a new version without modifying the content of the -- tree. This does not do any change tracking. Ought to be only used from a
src/Darcs/Util/Tree/Plain.hs view
@@ -25,14 +25,16 @@     , writePlainTree     ) where +import Control.Monad ( forM ) import Data.Maybe( catMaybes ) import qualified Data.ByteString.Lazy as BL import System.FilePath( (</>) )-import System.Directory( getDirectoryContents-                       , createDirectoryIfMissing )+import System.Directory ( listDirectory, createDirectoryIfMissing ) 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 )@@ -43,17 +45,17 @@  readPlainDir :: FilePath -> IO [(FilePath, FileStatus)] readPlainDir dir =-    withCurrentDirectory dir $ do-      items <- getDirectoryContents "."-      sequence [ do st <- getSymbolicLinkStatus s-                    return (s, st)-                 | s <- items, s `notElem` [ ".", ".." ] ]+  withCurrentDirectory dir $ do+    items <- listDirectory "."+    forM items $ \s -> do+      st <- getSymbolicLinkStatus s+      return (s, st)  readPlainTree :: FilePath -> IO (Tree IO) readPlainTree dir = do   items <- readPlainDir dir   let subs = catMaybes [-       let name = makeName name'+       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)
src/Darcs/Util/URL.hs view
@@ -53,26 +53,32 @@     isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, sshFilePathOf, splitSshUrl   ) where -import Prelude () import Darcs.Prelude  import Darcs.Util.Global ( darcsdir ) import Data.List ( isPrefixOf, isInfixOf ) import Data.Char ( isSpace )-import qualified System.FilePath as FP ( isRelative, isAbsolute, isValid )+import qualified System.FilePath as FP+    ( hasDrive+    , isAbsolute+    , isRelative+    , isValid+    , pathSeparators+    ) import System.FilePath ( (</>) )  isRelative :: String -> Bool-isRelative "" = bug "Empty filename in isRelative"+isRelative "" = error "Empty filename in isRelative" isRelative f  = FP.isRelative f  isAbsolute :: String -> Bool-isAbsolute "" = bug "isAbsolute called with empty filename"+isAbsolute "" = error "isAbsolute called with empty filename" isAbsolute f = FP.isAbsolute f  isValidLocalPath :: String -> Bool-isValidLocalPath f@(_:_:fou) = ':' `notElem` fou && FP.isValid f-isValidLocalPath f = FP.isValid f+isValidLocalPath s =+  FP.isValid s &&+  (FP.hasDrive s || not (':' `elem` takeWhile (`notElem` FP.pathSeparators) s))  isHttpUrl :: String -> Bool isHttpUrl u =
src/Darcs/Util/Workaround.hs view
@@ -9,9 +9,7 @@ -- Portability : portable  module Darcs.Util.Workaround-    (-      renameFile-    , setExecutable+    ( setExecutable     , getCurrentDirectory     , installHandler     , raiseSignal@@ -25,22 +23,17 @@     , sigPIPE     ) where -import Prelude () import Darcs.Prelude  #ifdef WIN32 -import Control.Monad ( unless )-import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile )-import Control.Exception ( catch, IOException )-import qualified Control.Exception ( mask )-import qualified System.IO.Error ( isDoesNotExistError, ioError )+import qualified System.Directory ( getCurrentDirectory )  #else  import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal,                             sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE)-import System.Directory ( renameFile, getCurrentDirectory )+import System.Directory ( getCurrentDirectory ) import System.Posix.Files (fileMode,getFileStatus, setFileMode,                            setFileCreationMask,                            ownerReadMode, ownerWriteMode, ownerExecuteMode,@@ -90,22 +83,6 @@  sigALRM :: Signal sigALRM = 0----- | System.Directory.renameFile incorrectly fails when the new file already--- exists.  This code works around that bug at the cost of losing atomic--- writes.-renameFile :: FilePath-           -> FilePath-           -> IO ()-renameFile old new = Control.Exception.mask $ \_ ->-   System.Directory.renameFile old new-   `catch` \(_ :: IOException) ->-   do System.Directory.removeFile new-        `catch`-         (\e -> unless (System.IO.Error.isDoesNotExistError e) $-                    System.IO.Error.ioError e)-      System.Directory.renameFile old new   setExecutable :: FilePath
src/win32/Darcs/Util/CtrlC.hs view
@@ -1,15 +1,18 @@-{-# LANGUAGE ForeignFunctionInterface #-}-+{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Util.CtrlC ( withCtrlCHandler ) where +import Darcs.Prelude+ import Data.Word ( Word32 ) import Foreign.Ptr ( FunPtr ) import Control.Exception ( bracket_ ) +#include <windows_cconv.h>+ type Handler = Word32 -> IO Int -foreign import ccall "wrapper" wrap :: Handler -> IO (FunPtr Handler)-foreign import stdcall "SetConsoleCtrlHandler" setConsoleCtrlHandler :: FunPtr Handler -> Int -> IO ()+foreign import WINDOWS_CCONV "wrapper" wrap :: Handler -> IO (FunPtr Handler)+foreign import WINDOWS_CCONV "SetConsoleCtrlHandler" setConsoleCtrlHandler :: FunPtr Handler -> Int -> IO ()   withCtrlCHandler :: IO () -> IO a -> IO a
src/win32/System/Posix.hs view
@@ -1,10 +1,14 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}  module System.Posix ( sleep ) where +import Darcs.Prelude+ import Foreign.C.Types ( CInt(..), CUInt(..), CULong(..) ) -foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt+#include <windows_cconv.h>++foreign import WINDOWS_CCONV "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt  sleep :: Integer -> IO CInt sleep n = c_SleepEx (1000 * fromIntegral n) 1
+ src/win32/System/Posix/Files.hs view
@@ -0,0 +1,15 @@+module System.Posix.Files+    ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink+    , getFdStatus, getFileStatus, getSymbolicLinkStatus+    , modificationTime, setFileMode, fileSize, fileMode, fileOwner+    , stdFileMode, FileStatus, fileID+    , linkCount, createLink+    ) where++import System.PosixCompat.Files+    ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink+    , getFdStatus, getFileStatus, getSymbolicLinkStatus+    , modificationTime, setFileMode, fileSize, fileMode, fileOwner+    , stdFileMode, FileStatus, fileID+    , linkCount, createLink+    )
− src/win32/System/Posix/Files.hsc 
@@ -1,31 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-module System.Posix.Files-    ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink-    , getFdStatus, getFileStatus, getSymbolicLinkStatus-    , modificationTime, setFileMode, fileSize, fileMode-    , stdFileMode, FileStatus, fileID-    , linkCount, createLink-    ) where--import System.PosixCompat.Files-    ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink-    , getFdStatus, getFileStatus, getSymbolicLinkStatus-    , modificationTime, setFileMode, fileSize, fileMode-    , stdFileMode, FileStatus, fileID-    )--import Foreign.C.String( CWString, withCWString )-import Foreign.C.Error( throwErrnoPathIf_ )-import Foreign.Ptr( Ptr, nullPtr )-import Foreign.C( CInt(..) )--linkCount :: FileStatus -> Int-linkCount _ = 1--#define _WIN32_WINNT 0x0500-foreign import stdcall "winbase.h CreateHardLinkW" c_CreateHardLink :: CWString -> CWString -> Ptr a -> IO CInt--createLink :: FilePath -> FilePath -> IO ()-createLink old new = withCWString old $ \c_old -> withCWString new $ \c_new ->-        throwErrnoPathIf_ (==0) "createLink" new $-                c_CreateHardLink c_new c_old nullPtr
src/win32/System/Posix/IO.hsc view
@@ -1,6 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} module System.Posix.IO where +import Darcs.Prelude+ #if mingw32_HOST_OS import Foreign.C.String( withCWString ) #else
− src/win32/sys/mman.h 
@@ -1,7 +0,0 @@--#include <sys/types.h>--void *mmap(void *start, size_t length, int prot, int flags, int fd, off_t offset);-int munmap(void *start, size_t length);--
tests/add.sh view
@@ -47,7 +47,7 @@ cd temp1 not darcs add a/ 2> err cat err-grep 'File a does not exist!' err+grep 'does not exist' err cd .. rm -rf temp1
− tests/apply-hunks.sh 
@@ -1,60 +0,0 @@-#!/usr/bin/env bash-. ./lib---# issue701--# step 1-darcs init temp0-cd temp0-echo m1 > foo-darcs record -lam m1-cd ..--# step 2-darcs clone temp0 temp1-cd temp1-echo a1 > foo-darcs record foo -a -m a1-cd ..---# step 3-cd temp0-echo m2 > foo-darcs record -a -m m2-cd ..---# step 4-cd temp1-darcs pull -a-echo m2-a1 > foo-darcs record -a -m 'Fix conflict m2-a1'-cd ..--#step 5-cd temp0-echo m3 > foo-darcs record -a -m m3-cd ..--#step 6-darcs clone temp0 temp2-cd temp2-echo b1 > foo-darcs record -a -m b1-cd ..--#step 7-cd temp0-echo m4 > foo-darcs record -a -m m4-cd ..--#step 8-cd temp1-darcs pull -a-echo m2-a1-m4 > foo-echo y | darcs mark-conflicts-cd ..
+ tests/apply-unclean-tag.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash++## Test that darcs can apply a patch bundle where the tag in the+## context of the bundle is unclean in the current repository.++. lib++rm -rf R S T++darcs init R+cd R+# so that we have something to tag, a tag of an empty repo+# seems to be ignored+echo 'initial content' > initial+darcs rec -lam "initial content"+darcs tag initial++echo A > A+darcs rec -lam "change A"+echo B > B+darcs rec -lam "change B"++cd ..++darcs init S+cd S+# pull the tag + A, but not B+darcs pull ../R -a --tag=initial+darcs pull ../R -a -p 'change A'++cd ../R+# create b.dpatch+darcs send -a -O --no-edit-description ../S++cd ..+mkdir T+cd T+darcs init+# pull the first patch + A, but not the tag or B+darcs pull ../R -a -p 'initial content'+darcs pull ../R -a -p 'change A'+# pull the tag, so now it's unclean+darcs pull ../R -a --tag 'initial'++darcs apply ../R/change-b.dpatch
tests/apply.sh view
@@ -30,7 +30,6 @@ # issue1427: apply gzipped bundles  rm -rf temp1 temp2- darcs init temp1 darcs init temp2 @@ -60,11 +59,10 @@ cd .. cmp temp1/bar temp2/bar -rm -rf temp1 temp2- ## issue2017 - apply should gracefully handle tag missing ## from context (complain, not crash) +rm -rf R* S* T* darcs init R cd R echo 'Example content.' > f@@ -83,7 +81,7 @@ cd .. not darcs apply --repo R0 T0/foo.dpatch > log 2>&1 not grep bug log-grep missing log+grep "Cannot find tag" log  # variant 1 - tag in shared context darcs clone R R1@@ -106,7 +104,7 @@ # the test: can't apply this due to incorrect context not darcs apply --repo R1 T1/foo.dpatch > log 2>&1 not grep 'bug' log-grep missing log+grep "Cannot find tag" log  # variant 2 - tag created after the fact darcs clone R  R2@@ -121,14 +119,13 @@ darcs tag '2'  --repo R2  # only tag after not darcs apply --repo R2 T2/foo.dpatch > log 2>&1 not grep 'bug' log-grep missing log--rm -rf R* S* T*+grep "Cannot find tag" log  # issue1921 # Attempting to apply a patch which depends on a missing tag should not cause # darcs to die. +rm -rf R* S* T* darcs init R cd R @@ -164,8 +161,7 @@ not darcs apply ../patch.dpatch &> apply_output.txt  # A best-attempt at ensuring darcs warns about the missing tag:-grep "tagged file2 tag" apply_output.txt-grep "FATAL: Cannot apply this bundle. We are missing the above patches." apply_output.txt+grep "Cannot find tag file2" apply_output.txt cd .. rm -rf R S @@ -198,11 +194,10 @@ not grep '^  \* d' log # does not complain about an unrelated patch     grep '^  \* y' log # complains about the offending one instead -rm -rf R S- ## Test that apply --skip-conflicts filters the conflicts ## appropriately. +rm -rf R S darcs init R cd R echo 'foo' > foo@@ -222,10 +217,10 @@ darcs apply --skip-conflicts applyme.dpatch test `darcs log --count` -eq 3 cd ..-rm -rf R S  # issue2193 - "darcs apply --test runs the test twice. +rm -rf R S darcs init R darcs clone R S
+ tests/argument_parsing.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash++## test that we cleanly fail with malformed numbers+## and ranges for --max-count, --last, and --index++. ./lib++check_arg_parse_error() {+  not darcs log $1 2>LOG 1>&2+  not grep -i bug LOG+  grep -i "cannot parse" LOG+}++darcs init R+cd R+check_arg_parse_error --max-count=-1+check_arg_parse_error --max-count=x+check_arg_parse_error --last=-1+check_arg_parse_error --last=x+# note zero is not a valid index+check_arg_parse_error --index=-1+check_arg_parse_error --index=0+check_arg_parse_error --index=x+check_arg_parse_error --index=-1-2+check_arg_parse_error --index=1--2+check_arg_parse_error --index=0-1+check_arg_parse_error --index=1-0+check_arg_parse_error --index=x-y+# but indexes and counts may exceed number of patches+darcs log --max-count=1+darcs log --last=1+darcs log --index=1+darcs log --index=1-2+cd ..
tests/bad-format.sh view
@@ -4,7 +4,7 @@  rm -rf temp1 temp2 -gunzip -c  $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf -+unpack_testdata many-files--old-fashioned-inventory mv many-files--old-fashioned-inventory temp1  echo '<UGLY HTML-LIKE GARBAGE RETURNED BY BAD HTTP SERVER>' > temp1/_darcs/format
tests/clone.sh view
@@ -2,6 +2,7 @@  . lib +rm -rf temp1 temp2 darcs init temp1 cd temp1 touch t.t@@ -14,10 +15,10 @@ darcs clone temp1 --context="${abs_to_context}" temp2 darcs log --context --repo temp2 > repo2_context diff -u "${abs_to_context}" repo2_context-rm -rf temp1 temp2  # issue1865: cover interaction of clone --context with tags +rm -rf temp1 temp2 darcs init temp1 cd temp1 touch t.t@@ -32,19 +33,18 @@ darcs clone temp1 --context="${abs_to_context}" temp2 darcs log --context --repo temp2 > repo2_context diff -u "${abs_to_context}" repo2_context-rm -rf temp1 temp2  # issue1041 +rm -rf temp1 temp2 # should fail, since temp1 doesn't exist not darcs clone temp1 temp2 # verify that temp2 wasn't created not cd temp2 -rm -rf temp1 temp2- # issue2199 "darcs clone --tag" gets too much if tag is dirty +rm -rf temp1 temp2 temp3 darcs init temp1 cd temp1 echo 'wibble' > file@@ -69,10 +69,9 @@ darcs log | not grep wobble cd .. -rm -rf temp1 temp2 temp3- # issue885: darcs clone --to-match +rm -rf temp1 temp2 temp3 darcs init temp1 cd temp1 echo first > a@@ -88,10 +87,9 @@ darcs clone --to-hash $firsthash temp1 temp3 test $(darcs log --count --repodir temp3) -eq 1 -rm -rf temp1 temp2 temp3- # various tests for clone --tag +rm -rf temp1 temp2 darcs init temp1 cd temp1 echo ALL ignore-times >> _darcs/prefs/defaults@@ -113,10 +111,10 @@  darcs clone --tag 1.0 --repo-name temp2 temp1 cmp temp2/foo temp1/foo_version_1.0-rm -rf temp1 temp2 temp3  # clone --tag with commuted patches +rm -rf temp1 temp2 temp3 darcs init temp1 cd temp1 cat > file <<EOF@@ -151,10 +149,9 @@ darcs check cd .. -rm -rf temp1 temp2 temp3- # clone --tag : check that pending looks ok +rm -rf temp1 temp2 darcs init temp1 cd temp1 mkdir d@@ -174,15 +171,13 @@ fi cd .. -rm -rf temp1 temp2- # issue2230 - darcs clone --context checks the validity of the context # file too late. +rm -rf temp1 temp2 darcs init temp1 touch fake_context.txt not darcs clone --context fake_context.txt temp1 temp2  # The clone should fail, so we shouldn't have an temp2 repo [[ ! -e temp2 ]]-rm -rf temp1
+ tests/conflict-chain-resolution.sh view
@@ -0,0 +1,140 @@+#!/usr/bin/env bash++# Test of conflict resolution for a "chain" of conflicts+# i.e. where (only) the adjacent patches conflict.++. lib++# Note that this test fails for darcs-2 format.+skip-formats darcs-2++# Establish our baseline:++rm -rf C+darcs init C+cd C+cat <<EOF > f+a+b+c+d+e+f+EOF+darcs record -lam "base"+cd ..++# Record hunk patches p1..p5 in separate repos,+# such that (only) adjacent patches conflict++rm -rf R1+darcs clone -q C R1+cd R1+sed -i -e 's/[ab]/&1/' f+darcs record -am 'p1'+cd ..++rm -rf R2+darcs clone -q C R2+cd R2+sed -i -e 's/[bc]/&2X/' f+darcs record -am 'p2X'+sed -i -e 's/2X/2/' f+darcs record -am 'p2'+cd ..++rm -rf R3+darcs clone -q C R3+cd R3+sed -i -e 's/[cd]/&3/' f+darcs record -am 'p3'+cd ..++rm -rf R4+darcs clone -q C R4+cd R4+sed -i -e 's/[de]/&4/' f+darcs record -am 'p4'+cd ..++rm -rf R5+darcs clone -q C R5+cd R5+sed -i -e 's/[ef]/&5/' f+darcs record -am 'p5'+cd ..++# Pull them all into the common context++cd C+darcs pull -a ../R*+cd ..++# 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.++baseline='+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++# * there are 4 alternatives to the baseline+test $(grep -cF '*************' f) = 3++cd ..
tests/conflict-doppleganger.sh view
@@ -10,9 +10,9 @@ check_conflict() { cat out if test "$format" = darcs-2; then-    not grep 'conflict' out+    not grep 'conflicts' out else-    grep 'conflict' out+    grep 'conflicts' out fi } @@ -24,7 +24,7 @@  touch a.txt darcs add a.txt-darcs record -A base -am 'adding a.txt'+darcs record -am 'adding a.txt' cd ..  darcs get tmp_dopple tmp_ganger@@ -39,7 +39,7 @@  # Now that the conflict has been set up, try pull one patch from the other. cd tmp_ganger-darcs pull -a ../tmp_dopple > out+darcs pull -a ../tmp_dopple 2> out check_conflict cd .. @@ -48,6 +48,8 @@ mkdir temp0 cd temp0 darcs init+touch a.txt+darcs record -la a.txt -m init cd ..  # Create a conflict@@ -55,14 +57,12 @@ cd temp1 darcs show repo echo temp1 > a.txt-darcs add a.txt-darcs record  -A base -am 'adding temp1 a.txt'+darcs record -am temp1 cd .. darcs get temp0 temp2 cd temp2 echo temp2 > a.txt-darcs add a.txt-darcs record  -A base -am 'adding temp2 a.txt'+darcs record -am temp2 cd ..  # Resolve the conflict the same way on both sides@@ -78,5 +78,5 @@  # Now that the conflict has been set up, try pull one patch from the other. cd tmp_ganger-darcs pull -a ../tmp_dopple > out+darcs pull -a ../tmp_dopple 2> out check_conflict
tests/conflict-fight-failure.sh view
@@ -1,4 +1,4 @@-#!/bin/env bash+#!/usr/bin/env bash # # Test darcs conflict fight scenario. #@@ -11,8 +11,11 @@  . ./lib -record="record --ignore-time --all --author X"+# test fails for these obsolete formats:+skip-formats darcs-1 darcs-2 +num_conflicts=40+ rm -rf RA RB mkdir RA @@ -20,7 +23,7 @@ echo 0 > file darcs init darcs add file-darcs $record -m0 file+darcs record -am0 file cd ..  darcs get RA RB@@ -28,27 +31,31 @@ # Create conflict in RB cd RB echo let it b > file-darcs $record -m B+darcs record -am B cd .. -for i in 1 2 3 4 5 # 6 7 8 9 10 11 12+for i in $(seq 1 $num_conflicts) do-  echo Create new patch A$i in RA   cd RA+  echo Create new patch A$i in RA   echo a$i > file-  darcs $record -m A$i+  darcs record -am A$i   cd .. -  echo Pull patch A$i from RA and get a conflict   cd RB-  time darcs pull ../RA --verbose --all --patch "^A$i\$"-  cd ..+  echo Pull patch A$i from RA and get a conflict +  /usr/bin/env time -f %e -o ../elapsed darcs pull ../RA --quiet --all --patch "^A$i\$" --allow-conflicts+  if (( $i == 1 )); then+    start=$(cat ../elapsed)+  else+    elapsed=$(cat ../elapsed)+    # check that the runtime is not more than quadratic in i+    (( $(echo "$elapsed < 1.5 * $i * $i * $start" | bc) ))+  fi+   echo Resolve conflict and start fighting by recording B$i-  cd RB   echo let it b > file-  darcs $record -m B$i+  darcs record -am B$i   cd .. done--rm -rf RA RB
tests/conflict-fight.sh view
@@ -6,25 +6,23 @@ mkdir temp0 cd temp0 darcs init-echo temp0 > _darcs/prefs/author echo m1 > foo darcs add foo-darcs record -a -m m1 --ignore-times+darcs record -a -m m1 cd ..  # step 2 darcs get temp0 temp1 cd temp1-echo temp1 > _darcs/prefs/author echo a1 > foo-darcs record foo -a -m a1 --ignore-times+darcs record foo -a -m a1 cd ..   # step 3 cd temp0 echo m2 > foo-darcs record -a -m m2 --ignore-times+darcs record -a -m m2 cd ..  @@ -32,15 +30,15 @@ cd temp1 darcs pull -a echo m2-a1 > foo-darcs record -a -m 'Fix conflict m2-a1' --ignore-times+darcs record -a -m 'Fix conflict m2-a1' echo a2 > foo-darcs record -a -m a2 --ignore-times+darcs record -a -m a2 cd ..  #step 5 cd temp0 echo m3 > foo-darcs record -a -m m3 --ignore-times+darcs record -a -m m3 cd ..  #step 6@@ -48,23 +46,23 @@ cd temp2 echo temp2 > _darcs/prefs/author echo b1 > foo-darcs record -a -m b1 --ignore-times+darcs record -a -m b1  cd ..  #step 7 cd temp0 echo m4 > foo-darcs record -a -m m4 --ignore-times+darcs record -a -m m4 cd ..  #step 8 cd temp1 darcs pull -a echo m2-a1-m4 > foo-darcs record -a -m 'Fix three-way m2/m2-a1/m4' --ignore-times+darcs record -a -m 'Fix three-way m2/m2-a1/m4' echo a3 > foo-darcs record -a -m a3 --ignore-times+darcs record -a -m a3 cd ..  #step 9
tests/conflict-reporting.sh view
@@ -71,8 +71,8 @@ EOF  darcs rec -am "patch 2"-darcs pull -a ../R2 > pull-output-grep "We have conflicts in the following files" pull-output+darcs pull -a ../R2 2> pull-output+grep "conflicts in the following files" pull-output grep "file1" pull-output not grep "file2" pull-output
tests/convert-darcs2.sh view
@@ -28,21 +28,21 @@  . lib -skip-formats darcs-1+only-format darcs-2  runtest() {     opt=$1     name=$2-    rm -rf temp-    mkdir temp-    cd temp+    rm -rf $opt/$name+    mkdir -p $opt/$name+    cd $opt/$name      mkdir repo     cd repo     darcs init --darcs-1     darcs apply --allow-conflicts $TESTDATA/convert/darcs1/$name.dpatch     cd ..-    echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 $opt+    echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 --$opt     mkdir empty-darcs2     cd empty-darcs2     darcs init --darcs-2@@ -50,10 +50,13 @@     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+    diff -I'1 patch for repository ' -I'patches for repository ' -I'Oct 1' \+      -u $TESTDATA/convert/darcs2/$name.dpatch $name-darcs2.dpatch++    cd ../.. } -for opt in --no-working-dir --with-working-dir; do+for opt in no-working-dir with-working-dir; do     runtest $opt simple     runtest $opt twowayconflict     runtest $opt threewayconflict
+ tests/convert-import-export-non-ascii.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++. lib++# The git repo here deliberately contains file names with+# unusual characters in them (e.g. newline);+# the test therefore makes sense only on Posix systems,+# since Windows does not even allow to create such files.+abort_windows++git --version || exit 200 # no git installed => skip test++rm -rf gitrepo gitrepo2 darcsrepo+unpack_testdata gitrepo+cd gitrepo+git fast-export HEAD > ../git-export+git log >../git-log1+cd ..+darcs convert import darcsrepo <git-export+diff -r gitrepo/src darcsrepo/src++cd darcsrepo+darcs convert export >../darcs-export+cd ..+mkdir gitrepo2+cd gitrepo2+git init+git fast-import < ../darcs-export+git checkout master+git log > ../git-log2+cd ..+diff -I 'commit' -I 'Date:' git-log1 git-log2+diff -r gitrepo/src gitrepo2/src
tests/data/convert/darcs2/threewayanddep.dpatch view
@@ -1,28 +1,28 @@-5 patches for repository /tmp/tmp5530/temp/empty-darcs2:+5 patches for repository /tmp/convert-darcs2/Darcs2/PatienceDiff/convert-darcs2/no-working-dir/threewayanddep/empty-darcs2:  patch 349a0bab437265867f9af955d72127bac4cea1a6 Author: tester-Date:   Sat Oct 16 23:27:54 BST 2010+Date:   Sun Oct 17 00:27:54 CEST 2010   * wibble  patch 650955997f5fac7fa2e14127a25ea5ac70f4dab0 Author: tester-Date:   Sat Oct 16 23:27:54 BST 2010+Date:   Sun Oct 17 00:27:54 CEST 2010   * A1  patch 476d8520cfc9be9b44299e6f4753de6adca83bcf Author: tester-Date:   Sat Oct 16 23:27:54 BST 2010+Date:   Sun Oct 17 00:27:54 CEST 2010   * A2  patch 4d2a18f739f8f4c384b5653a5ad03d5e77724efe Author: tester-Date:   Sat Oct 16 23:27:54 BST 2010+Date:   Sun Oct 17 00:27:54 CEST 2010   * B  patch 81ba98134cf0d725e827318ca2753be4148568b7 Author: tester-Date:   Sat Oct 16 23:27:54 BST 2010+Date:   Sun Oct 17 00:27:54 CEST 2010   * C  New patches:@@ -52,6 +52,7 @@ ] conflictor [ hunk ./wibble 2 +A1+hunk ./wibble 3 +A2 ] :@@ -61,12 +62,16 @@ tester**20101016222754  Ignore-this: 295e8a851b7a936b3d08b0ce7eaaf2ac ] conflictor {{-: hunk ./wibble 2 +A1+:+hunk ./wibble 3 +A2 : hunk ./wibble 2++A1+:+hunk ./wibble 2 +B }} [] :@@ -76,4 +81,4 @@ Context:  Patch bundle hash:-f9974a2fdbdea580b1be0eaba951e6285f9bfb5d+5d566c305f4017424a6b05e87bfc5971e95e877d
tests/data/convert/darcs2/threewayandmultideps.dpatch view
@@ -1,38 +1,38 @@-7 patches for repository /tmp/tmp5411/temp/empty-darcs2:+7 patches for repository /tmp/convert-darcs2/Darcs2/PatienceDiff/convert-darcs2/no-working-dir/threewayandmultideps/empty-darcs2:  patch fd370912c8a92d249e00e7c91856ed9530d6c914 Author: tester-Date:   Sat Oct 16 23:27:21 BST 2010+Date:   Sun Oct 17 00:27:21 CEST 2010   * wibble  patch ac7df6a4761de10b4c440a9adb39c4f0236cb519 Author: tester-Date:   Sat Oct 16 23:27:21 BST 2010+Date:   Sun Oct 17 00:27:21 CEST 2010   * A1  patch 121d6130551316a64fa7a061cfc44f5946213f85 Author: tester-Date:   Sat Oct 16 23:27:21 BST 2010+Date:   Sun Oct 17 00:27:21 CEST 2010   * A2  patch 513848985dfc5b5ea1533d56b597daa7317f35bc Author: tester-Date:   Sat Oct 16 23:27:21 BST 2010+Date:   Sun Oct 17 00:27:21 CEST 2010   * B1  patch 84edd5450901a4d31f1b49a9a6da4563a6ed73fe Author: tester-Date:   Sat Oct 16 23:27:21 BST 2010+Date:   Sun Oct 17 00:27:21 CEST 2010   * B2  patch bec254c63929d83d13929eec63f2e5e5a8aabbb4 Author: tester-Date:   Sat Oct 16 23:27:21 BST 2010+Date:   Sun Oct 17 00:27:21 CEST 2010   * C1  patch 0e08cbe9489dfc7f21e9528b4c6a7d06f4fec25a Author: tester-Date:   Sat Oct 16 23:27:21 BST 2010+Date:   Sun Oct 17 00:27:21 CEST 2010   * C2  New patches:@@ -62,6 +62,7 @@ ] conflictor [ hunk ./wibble 2 +A1+hunk ./wibble 3 +A2 ] :@@ -70,18 +71,43 @@ [B2 tester**20101016222721  Ignore-this: 1d60b6c0ba913fff4d1e32ad26ae07bb-] +] conflictor {{+hunk ./wibble 2++A1+:+hunk ./wibble 3++A2+:+hunk ./wibble 2++A1+:+hunk ./wibble 2++B1+}} []+hunk ./wibble 2++B1+:+hunk ./wibble 3++B2 [C1 tester**20101016222721  Ignore-this: 25b6a6959d19980ad16983a542c6825 ] conflictor {{-: hunk ./wibble 2 +A1+:+hunk ./wibble 3 +A2 : hunk ./wibble 2++A1+:+hunk ./wibble 2 +B1+hunk ./wibble 2++B1+:+hunk ./wibble 3 +B2 }} [] :@@ -91,21 +117,33 @@ tester**20101016222721  Ignore-this: c16d607216c36d5f7727c64d2ec103d4 ] conflictor {{-: hunk ./wibble 2 +A1+:+hunk ./wibble 3 +A2 : hunk ./wibble 2++A1+hunk ./wibble 2 +B1+:+hunk ./wibble 3 +B2-}} [] : hunk ./wibble 2++B1+:+hunk ./wibble 2 +C1+}} []+hunk ./wibble 2++C1+:+hunk ./wibble 3 +C2  Context:  Patch bundle hash:-7f2bd6324e6e1f2d4efe67f98696ca0ead048fe5+8eb9adf3347935c847172e49b6597d14239d217f
+ tests/data/cyrillic_import_stream view
@@ -0,0 +1,14 @@+blob+mark :1+data 160+Широкая электрификация южных губерний даст мощный толчок подъёму сельского хозяйства++reset refs/heads/master+commit refs/heads/master+mark :2+author Andrey Korobkov <alster@vinterdalen.se> 1593449594 +0400+committer Andrey Korobkov <alster@vinterdalen.se> 1593454486 +0400+data 99+Южноэфиопский грач увёл мышь за хобот на съезд ящериц+M 100644 :1 "\320\237\320\260\320\275\320\263\321\200\320\260\320\274\320\274\320\260.txt"+
+ tests/data/gitrepo.tgz view

binary file changed (absent → 12010 bytes)

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

binary file changed (absent → 6809 bytes)

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

binary file changed (absent → 7498 bytes)

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

binary file changed (absent → 6478 bytes)

+ tests/data/tabular.tgz view

binary file changed (absent → 62224 bytes)

+ tests/data/undo.tgz view

binary file changed (absent → 4023 bytes)

+ tests/decoalesce-move.sh view
@@ -0,0 +1,79 @@+#!/bin/sh -e+##+## Checking what happens when we need to remove an add from pending+## after doing a move.+##+## Copyright (C) 2018 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init++echo 'foo' > a+echo 'bar' > b++darcs add a b++mv a c++darcs rec --look-for-moves c -a -m"added c via a"++darcs whatsnew > got+cat >want <<EOF+addfile ./b+hunk ./b 1++bar+EOF++diff want got++cd ..+++rm -rf temp2+mkdir temp2+cd temp2+darcs init++echo 'foo' > a+echo 'bar' > b++darcs add a b++mv b c++darcs rec --look-for-moves c -a -m"added c via b"++darcs whatsnew > got+cat >want <<EOF+addfile ./a+hunk ./a 1++foo+EOF++diff want got++cd ..
tests/diff.sh view
@@ -2,6 +2,7 @@ . ./lib  export DARCS_TMPDIR=`pwd`/tmp+rm -rf tmp mkdir tmp  rm -rf temp1
tests/failed-amend-should-not-break-repo.sh view
@@ -44,14 +44,13 @@ # amending 'move' results in commuting 'move' patch # to the end for removal. The commute changes the "add content" # patch to modify A instead of B. But the amend is interrupted-# because of test failure. Check the consitency after the operation.+# because of test failure. Check consistency after the operation. darcs setpref test false-echo yy | not darcs amend -p move --test+darcs log > ../before+echo yyyn | not darcs amend -p move --test darcs check--# Note: Amend-record in case of test failure is broken as described in issue1406,-# though when trying to fix it I almost managed to break darcs even more.-# This test is to guard against such regressions in the future.+darcs log > ../after+# check that nothing gets unrecorded by the aborted amend (issue1406)+diff ../before ../after  cd ..-rm -rf R
− tests/failing-issue1316-2.sh 
@@ -1,49 +0,0 @@-#!/usr/bin/env bash-## Test for issue1316 - junk left in pending-##-## Copyright (C) 2011 Ganesh Sittampalam-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--# this test is a slightly more complicated variant on failing-issue1316-# it also uses darcs commands to test rather than grepping pending.--. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.--cd R--touch X-darcs rec -lam 'X'--darcs mv X Y-darcs rec -am 'Y'--rm Y-echo 'y' | darcs amend -a--# the bug is that addfile Y shows up in pending-# if pending is empty as it should be, then since-# whatsnew doesn't have -l, it shouldn't report anything-# even after we touch Y.-touch Y-not darcs whatsnew-
− tests/failing-issue1316.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash-## Test for issue1316 - Removing a directory-##-## Copyright (C) 2009 Nathan Gray, Eric Kow-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                           # Load some portability helpers.--mkdir R-darcs init      --repo R        # Create our test repos.--cd R-mkdir d                         # Change the working tree.-darcs record -lam 'Add a directory'-rm -rf d-echo y | darcs amend-record -m 'initial' --all-not grep adddir _darcs/patches/pending
− tests/failing-issue1401_bug_in_get_extra.sh 
@@ -1,39 +0,0 @@-#!/usr/bin/env bash-## Test for issue1401 - when two repos share a HUNK patch, but that-## patch's ADDFILE dependency is met by different patches in each-## repo, it becomes impossible to pull between the two repos.-##-## Copyright (C) 2009  Trent W. Buck-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib--darcs initialize --repodir d/-darcs initialize --repodir e/-touch d/f d/g e/f-darcs record     --repodir d/ -lam 'Add f and g'-darcs record     --repodir e/ -lam 'Add f'-echo >d/f-darcs record     --repodir d/ -am 'Change f'-darcs pull       --repodir e/ -a d/ --allow-conflicts #no conflict mark-up-echo y | darcs obliterate --repodir e/ -ap 'Add f and g'-darcs pull       --repodir e/ -a d/
− tests/failing-issue1442_encoding_round-trip.sh 
@@ -1,50 +0,0 @@-#!/usr/bin/env bash-## -*- coding: utf-8 -*--## Test for issue1442 - if we disable Darcs escaping and don't change-## our encoding, the bytes in a filename should be the same bytes that-## "darcs changes -v" prints to the right of "addfile" and "hunk".-##-## Copyright (C) 2009  Trent W. Buck-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib--rm -rf R                        # Another script may have left a mess.--## Use the first UTF-8 locale we can find.-export LC_ALL=$(locale -a | egrep --text 'utf8|UTF-8' | head -1)-export DARCS_DONT_ESCAPE_ANYTHING=True--## If LC_ALL is the empty string, this system doesn't support UTF-8.-if test -z "$LC_ALL"-then exit 1-fi--darcs init      --repo R-echo '首頁 = א₀' >R/'首頁 = א₀'-darcs record    --repo R -lam '首頁 = א₀' '首頁 = א₀'-darcs changes   --repo R -v '首頁 = א₀' >R/log-#cat R/log                      # Show the humans what the output was.-grep -c '首頁 = א₀' R/log >R/count-echo 5 >R/expected-count-cmp R/count R/expected-count    # Both count files should contain "5\n".-rm -rf R                        # Clean up after ourselves.
tests/failing-issue1461_case_folding.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash ## Test for issue1461 - patches to files whose names only differ by-## case can be wrongly applied to the same file in the working directory.+## case can be wrongly applied to the same file in the working tree. ## ## Copyright (C) 2009 Eric Kow ##@@ -26,9 +26,6 @@  . lib                  # Load some portability helpers. -touch casetest-test -e CASETEST || exit 200- rm -rf lower upper joint        # Another script may have left a mess. mkdir lower upper @@ -80,8 +77,10 @@ cd joint darcs pull ../lower -a darcs pull ../upper -a-grep one a && not grep three a-grep three A && not grep one A+grep one a+not grep three a+grep three A+not grep one A cd .. # clean up after ourselves rm -rf lower upper joint
− tests/failing-issue1522_trailing_slash_borkage.sh 
@@ -1,35 +0,0 @@-#!/usr/bin/env bash-## Test for issue1522 - Trailing slash borkage-##-## Copyright (C) 2012 Andreas Brandt-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib-rm -rf R-mkdir R--cd R-darcs init --repo R-touch R/d-darcs record --repo R -lam Yow! d/--cd ..
tests/failing-issue1610_get_extra.sh view
@@ -27,7 +27,7 @@  . lib                  # Load some portability helpers. -# this test fails only for darcs 2 repositories+# this test fails only for darcs-1 patch format  rm -rf S1  S2  S3               # Another script may have left a mess. darcs init      --repo S1       # Create our test repos.
@@ -0,0 +1,99 @@+#!/usr/bin/env bash+## Test for issue1702 - an optimize --relink does not relink the files+## in ~/.cache/darcs.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf R S+darcs init R++## Create a patch.+echo 'Example content.' > R/f+darcs record -lam 'Add f.' --repodir R++## Get a hard link into the cache.+darcs get R S++inode() {+  stat -c %i $1+}++# number of hard links+links() {+  stat -c %h $1+}++same_inode () {+  test $(inode $1) = $(inode $2)+}++## Are hard links available?+rm -f x y+touch x+if ! (ln x y && same_inode x y && test $(links x) = 2 && test $(links y) = 2); then+    echo This test requires filesystem support for hard links.+    exit 200+fi++inR=(R/_darcs/patches/*-*)+inS=(S/_darcs/patches/*-*)+patch=$(basename $inR)+inC=$(find $HOME/.cache/darcs/patches -name $patch)++## Confirm that all three are hard linked.+same_inode $inR $inS+same_inode $inS $inC+same_inode $inC $inR+# double check+test $(links $inR) = 3+test $(links $inS) = 3+test $(links $inC) = 3++## Break all hard links.+rm -rf S+cp -r R S+rm -rf R+cp -r S R++## Confirm that there are no hard links.+not same_inode $inR $inS+not same_inode $inS $inC+not same_inode $inC $inR+# double check+test $(links $inR) = 1+test $(links $inS) = 1+test $(links $inC) = 1++## Optimize *should* hard-link all three together.+darcs optimize relink --repodir R --sibling S++## Confirm that all three are hard linked.+same_inode $inR $inS+same_inode $inS $inC+same_inode $inC $inR+# double check+test $(links $inR) = 3+test $(links $inS) = 3+test $(links $inC) = 3
− tests/failing-issue1959-unwritable-cache.sh 
@@ -1,38 +0,0 @@-#!/usr/bin/env bash-## Test for issue1959 - if the index becomes unwritable, darcs should not die.-##-## Copyright (C) 2012 Owen Stephens-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib--rm -rf R-darcs init --repo R--cd R--echo test > test-darcs rec -alm 'testing'--chmod a-w _darcs/index--darcs wh
− tests/failing-issue2257-impossible-obliterate-subset.sh 
@@ -1,64 +0,0 @@-#!/usr/bin/env bash-## Test for issue2257 - impossible case encountered when obliterating a subset-## of patches-## Copyright (C) 2012 Owen Stephens-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib--rm -rf issue2257-mkdir issue2257-cd issue2257--darcs init --repo single-patch-darcs init --repo duplicate-patch--cd single-patch--mkdir dir-touch dir/file1-darcs record -alm 'dir and file1'--touch dir/file2-darcs record -alm 'addfile file2'--cd ../duplicate-patch--# Split the dir/file patch into the dir add, and then the file add.-darcs pull -a ../single-patch -p 'dir and file'-darcs unrecord -a--# Only record 'adddir ./dir'-echo yny | darcs record -m 'adddir dir' -# Now record the addfile in a separate patch.-darcs record -am 'addfile file1'--# Pull in the other patches we don't have (which will include the original -# "add dir/file1" patch again since we've amended it to no longer exist, and-# the "addfile file2" patch)-darcs pull -a ../single-patch--# Attempt to obliterate 'addir dir' (but not 'addfile file1'). This seems to be-# a problem with the patch selection, since without -p, we aren't able to-# obliterate 'adddir dir', if we say no to 'addfile file1' (which is-# sensible!).-echo nyy | darcs obliterate -p 'adddir dir'
− tests/failing-issue2275_follows-symlinks.sh 
@@ -1,45 +0,0 @@-#!/usr/bin/env bash-## Test for issue2275 - darcs follows symbolic links instead of properly-## ignoring them.-## When substituting a recorded file with a symbolic link, darcs becomes-## confused and associates the filename label to the content of the file-## pointed by the link.-##-## Copyright (C) 2017 Gian Piero Carrubba-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                           # Load some portability helpers.-abort_windows                   # Skip test on Windows--darcs init      --repo R        # Create the test repo.-cd R--touch g                         # Change the working tree.-echo 'This line should not appear in g.' > f-darcs record -lam 'Add f and g.'--rm -f g                         # Remove g and create a link with the-ln -s f g                       # same name ponting to f--darcs diff g | not grep -F '+This line should not appear in g.'--cd ..
− tests/failing-issue2293-laziness-amend.sh 
@@ -1,35 +0,0 @@-#!/bin/sh -e-##-## Test that amend-record doesn't read too much of the repository-##-## Copyright (C) 2013 Ganesh Sittampalam-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib--gunzip -c $TESTDATA/laziness-cut.tgz | tar xf ---cd repo--echo 'baz' > bar--echo yyyy | darcs amend
− tests/failing-issue2310-rollback-doesnt-readd.sh 
@@ -1,43 +0,0 @@-## Test for issue2310 - darcs rollback of rmfile doesn't add to pending-##-## Copyright (C) 2013 Owen Stephens-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                           # Load some portability helpers.--rm -rf R--darcs init --repo R--cd R--echo foo > foo -darcs rec -alm 'add foo'--rm foo-darcs rec -am 'remove foo'--echo ynya | darcs rollback--# If the file hasn't been re-added in pending, this line will be missing from-# the output of whatsnew-darcs wh | grep 'A ./foo'
− tests/failing-issue2548-inconsistent-pending-after-merge.sh 
@@ -1,43 +0,0 @@-. lib--darcs init r1-cd r1-touch f-darcs record -lam 'added f as file'-cd ..--darcs init r2-cd r2-mkdir f-darcs record -lam 'added f as dir'--darcs pull -a ../r1--# darcs-1 and darcs-2 resolve the conflict-# differently, we allow both-if cd f && cd ..; then-  rmdir f-else-  rm f-fi-mv f.\~0\~ f-# darcs whatsnew at this point reports nothing-not grep . ../whatsnew-# so revert should do nothing-darcs revert -a--# at this point pending should definitely be empty-# and the following should fail (nothing to record)-if not darcs record -lam 'resolve conflict'; then-  exit 0;-else-  # check that what we record is at least consistent-  # i.e. we have either addfile or adddir for f, but not both-  darcs log -v --last=1 > ../log-  if grep 'addfile ./f' ../log; then-    not grep 'adddir ./f' ../log-  fi-  if grep 'adddir ./f' ../log; then-    not grep 'addfile ./f' ../log-  fi-fi
+ tests/failing-issue2640.sh view
@@ -0,0 +1,17 @@+# issue 2640 - rollback with filename may fail to select any patches++. lib++rm -rf R+darcs init R+cd R+echo text > file1+echo text > file2+darcs record -lam file1and2+echo othertext > file2+darcs record -am onlyfile2+darcs rollback -a file1 | tee LOG+not grep -i 'No patches' LOG+darcs whatsnew | tee LOG+grep text LOG+cd ..
tests/failing-issue390_whatsnew.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -# For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory+# For issue390: darcs whatsnew somefile" lstats every file in the working tree and pristine/ directory  . ./lib
− tests/failing-look_for_replaces1.sh 
@@ -1,49 +0,0 @@-#!/usr/bin/env bash-## Failing test for --look-for-replaces-##-## Copyright (C) 2013 Jose Neder-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib--rm -rf R-mkdir R-cd R--# forced replace (the word is in the file) (amend-record)-# amending an addfile patch with a forced replace fails-darcs init-cat > file <<EOF-foo-foo-bar-EOF-darcs record -al -m "add file"-cat > file <<EOF-bar-bar-bar-EOF-echo y | darcs amend-record --look-for-replaces -a-cd ..-rm -rf R-
tests/failing-merging_newlines.sh view
@@ -33,7 +33,7 @@ echo "in tmp2" >> one.txt darcs whatsnew -s | grep M darcs record -A bar -am "add extra line"-darcs push -av > log+darcs push -av 2> log cat log not grep -i conflicts log # BUG HERE
+ tests/failing-rebase-conflicting.sh view
@@ -0,0 +1,26 @@+#!/usr/bin/env bash++. lib++rm -rf R S++darcs init R+cd R+echo R > f+darcs record -l f -a -m 'add f in R'+cd ..+darcs init S+cd S+echo S > f+darcs record -l f -a -m 'add f in S'+cd ../R+darcs pull -a --allow-conflicts ../S+echo X > f+darcs record -l f -a -m 'resolve conflict'+darcs push -a ../S+darcs log -v > ../before_rebase+darcs rebase suspend -a+darcs rebase unsuspend -a+darcs log -v > ../after_rebase+cd ..+diff R/f S/f
tests/git_quoted_filenames.sh view
@@ -55,6 +55,8 @@ # only run if git present git --version | grep -i "git version"   || exit 200 +rm -rf gitsource gitmirror darcssource darcsmirror+ git init gitsource cd gitsource @@ -64,7 +66,8 @@  cd .. -(cd gitsource && git fast-export --all) | darcs convert import darcsmirror+(cd gitsource && git fast-export --all) > gitexport+darcs convert import darcsmirror < gitexport  # working copies should be the same wcDiff gitsource darcsmirror@@ -81,7 +84,8 @@ darcs rec -lam "$commitMsg"  git init ../gitmirror-darcs convert export | (cd ../gitmirror && git fast-import && git checkout) +darcs convert export > ../darcsexport+(cd ../gitmirror && git fast-import && git checkout) < ../darcsexport cd ..  # working copies should be the same
tests/gzcrcs.sh view
@@ -30,7 +30,7 @@  . lib                  # Load some portability helpers. rm -rf maybench-crc-gunzip -c $TESTDATA/maybench-crc.tgz | tar xf -+unpack_testdata maybench-crc cd maybench-crc not darcs gzcrcs --check darcs gzcrcs --repair
tests/hidden_conflict.sh view
@@ -27,6 +27,6 @@ cd ..  cd temp1-darcs pull -a ../temp2 | grep conflict+darcs pull -a ../temp2 2>&1 | grep conflict grep third a cd ..
tests/hidden_conflict2.sh view
@@ -4,14 +4,8 @@ # A test for a missed resolution, inspired by bug #10 in RT  rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-cd ..-mkdir temp2-cd temp2-darcs init-cd ..+darcs init temp1+darcs init temp2  # set up temp1 cd temp1@@ -66,5 +60,3 @@ # now mark-conflicts shouldn't find any unmarked conflicts darcs mark-conflicts | grep "No conflicts to mark" cd ..--rm -rf temp1 temp2
+ tests/inherit-default.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for inherit-default mechanism++. lib+rm -rf U V R1 R2 R3 S++echo 'ALL inherit-default' >> .darcs/defaults++# upstream repos+darcs init U+darcs init V++# branches of U+darcs clone U R1+darcs clone R1 R2+darcs clone R2 R3++# branches of V+darcs clone V S++not test -e U/_darcs/prefs/defaultrepo+not test -e V/_darcs/prefs/defaultrepo+grep '/U$' R1/_darcs/prefs/defaultrepo+grep '/U$' R2/_darcs/prefs/defaultrepo+grep '/U$' R3/_darcs/prefs/defaultrepo+grep '/V$' S/_darcs/prefs/defaultrepo++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+  # but not if remote repo has no defaultrepo+  darcs $cmd ../U --set-default+  grep '/U$' _darcs/prefs/defaultrepo+done+cd ..
tests/issue1105.sh view
@@ -11,29 +11,36 @@ echo changes summary > _darcs/prefs/defaults darcs changes echo changes summary arg > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'takes no argument' LOG echo ALL summary > _darcs/prefs/defaults darcs changes echo ALL summary arg > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'takes no argument' LOG  echo changes last 10 > _darcs/prefs/defaults darcs changes echo changes last > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'requires an argument' LOG echo ALL last 10 > _darcs/prefs/defaults darcs changes echo ALL last > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'requires an argument' LOG  echo changes author me > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'has no option' LOG echo changes author me > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'has no option' LOG echo ALL author me > _darcs/prefs/defaults darcs changes echo ALL unknown > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'has no option' LOG  cd .. rm -rf temp
tests/issue1210-no-global-cache-in-sources.sh view
@@ -25,7 +25,7 @@  . ./lib -cacheDir=$HOME/.darcs/cache+cacheDir=$HOME/.cache/darcs  rm -rf R S darcs init  --repo R
tests/issue1224_convert-darcs2-repository.sh view
@@ -25,7 +25,7 @@ ## SOFTWARE.  # this test is not relevant for other than darcs 2 repositories-grep darcs-2 $HOME/.darcs/defaults || exit 200+only-format darcs-2  . lib
+ tests/issue1316-2.sh view
@@ -0,0 +1,51 @@+#!/usr/bin/env bash+## Test for issue1316 - junk left in pending+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++# this test is a slightly more complicated variant on failing-issue1316+# it also uses darcs commands to test rather than grepping pending.++. lib                           # Load some portability helpers.++rm -rf R+darcs init      --repo R        # Create our test repos.++cd R++touch X+darcs rec -lam 'X'++darcs mv X Y+darcs rec -am 'Y'++rm Y+echo 'y' | darcs amend -a++# the bug is that addfile Y shows up in pending+# if pending is empty as it should be, then since+# whatsnew doesn't have -l, it shouldn't report anything+# even after we touch Y.+touch Y+not darcs whatsnew+
+ tests/issue1316.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+## Test for issue1316 - Removing a directory+##+## Copyright (C) 2009 Nathan Gray, Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf R+darcs init      --repo R        # Create our test repos.++cd R+mkdir d                         # Change the working tree.+darcs record -lam 'Add a directory'+rm -rf d+echo y | darcs amend-record -m 'initial' --all+not grep adddir _darcs/patches/pending
+ tests/issue1401_bug_in_get_extra.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+## Test for issue1401 - when two repos share a HUNK patch, but that+## patch's ADDFILE dependency is met by different patches in each+## repo, it becomes impossible to pull between the two repos.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++# this test fails for darcs-1 and darcs-2 repos and we cannot fix it+skip-formats darcs-1 darcs-2++darcs initialize --repodir d/+darcs initialize --repodir e/+touch d/f d/g e/f+darcs record     --repodir d/ -lam 'Add f and g'+darcs record     --repodir e/ -lam 'Add f'+echo >d/f+darcs record     --repodir d/ -am 'Change f'+darcs pull       --repodir e/ -a d/ --allow-conflicts #no conflict mark-up+echo y | darcs obliterate --repodir e/ -ap 'Add f and g'+darcs pull       --repodir e/ -a d/
+ tests/issue1442_encoding_round-trip.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash+## -*- coding: utf-8 -*-+## Test for issue1442 - if we disable Darcs escaping and don't change+## our encoding, the bytes in a filename should be the same bytes that+## "darcs changes -v" prints to the right of "addfile" and "hunk".+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++abort_windows # doesn't work there at present, not sure why++rm -rf R                        # Another script may have left a mess.++## Use the first UTF-8 locale we can find.+export LC_ALL=$(locale -a | egrep --text 'utf8|UTF-8' | head -1)+export DARCS_DONT_ESCAPE_ANYTHING=True++## If LC_ALL is the empty string, this system doesn't support UTF-8.+if test -z "$LC_ALL"+then exit 1+fi++darcs init      --repo R+echo '首頁 = א₀' >R/'首頁 = א₀'+darcs record    --repo R -lam '首頁 = א₀' '首頁 = א₀'+darcs changes   --repo R -v '首頁 = א₀' >R/log+#cat R/log                      # Show the humans what the output was.+grep -c '首頁 = א₀' R/log >R/count+echo 5 >R/expected-count+cmp R/count R/expected-count    # Both count files should contain "5\n".+rm -rf R                        # Clean up after ourselves.
+ tests/issue1522_trailing_slash_borkage.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue1522 - Trailing slash borkage+##+## Copyright (C) 2012 Andreas Brandt+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf R+darcs init R+cd R+# recording a file with trailing slash should fail+touch f+not darcs record -lam fails f/+# recording a directory with trailing slash is okay+mkdir d+darcs record -lam works d/+cd ..
tests/issue154_pull_dir_not_empty.sh view
@@ -26,23 +26,26 @@  . lib -rm -rf temp1-mkdir temp1-cd temp1-darcs init+rm -rf R S+darcs init R+cd R mkdir d darcs add d darcs record -a -m "Added directory d"-darcs get ./ puller-cd puller+darcs get . ../S+cd ../S touch d/moo darcs add d/moo-cd ..+cd ../R rm -rf d darcs record -a -m "Remove directory d"-cd puller-echo y | darcs pull -a .. > log+cd ../S+echo y | darcs pull -a ../R 2>&1 > log grep -i "backing up" log grep -i "finished pulling" log+# check that moo is not lost (it will be in a backup of d)+find -name moo+# ideally we would preserve the pending 'addfile ./d/moo',+# but we currently do not+#darcs whatsnew | grep 'addfile ./d/moo' cd ..-rm -rf temp1
+ tests/issue1609-conflict-markup-depends-on-patch-order.sh view
@@ -0,0 +1,36 @@+#!/bin/sh+rm -rf darcs.tp2+mkdir darcs.tp2+cd darcs.tp2+mkdir s1+mkdir s2+mkdir s3+cd s1; darcs init+echo -e '1\n2\n3\n4\n5\n' > foo.txt+darcs add foo.txt+darcs record --patch-name=init --author momo --skip-long-comment --all+cd ../s2; darcs init+darcs pull ../s1 --all+cd ../s3; darcs init+darcs pull ../s1 --all+cd ../s1;+echo -e "3i\nX\n.\nw\nq\n" | ed foo.txt+darcs record --patch-name=op1 --author momo --skip-long-comment --all+cd ../s2+echo -e "3d\nw\nq\n" | ed foo.txt+darcs record --patch-name=op2 --author momo --skip-long-comment --all+cd ../s3+echo -e "4i\nY\n.\nw\nq\n" | ed foo.txt+darcs record --patch-name=op3 --author momo --skip-long-comment --all+cd ../s1+darcs pull ../s2 --all+cd ../s2+darcs pull ../s1 --all+cd ../s1+darcs pull ../s3 --all+cd ../s2+darcs pull ../s3 --all+cd ../s3+darcs pull ../s1 --all+if diff ../s1/foo.txt ../s2/foo.txt; then echo 'TP2 ok S1 S2';  else echo 'TP2 ko'; fi+if diff ../s2/foo.txt ../s3/foo.txt; then echo 'TP2 ok S2 S3';  else echo 'TP2 ko'; fi
+ tests/issue1640_apply_stdin.sh view
@@ -0,0 +1,56 @@+#!/usr/bin/env bash+## Test for issue1640 - <SYNOPSIS: darcs Issue 1640 darcs apply+## with no file args should mention stdin>+##+## Copyright (C) 2011  Radoslav Dorcik <dixiecko@gmail.com>+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.++#######################################################+# Test preparation +#######################################################++# Create repository+rm -rf S T T2+darcs init      --repo S+darcs init      --repo T+darcs init      --repo T2+cd S+touch foo bar+darcs add foo bar+darcs record -a -m add_foo_bar -A x+darcs send --output=funpatch -a ../T+++#######################################################+# Apply from stdin and check message+#######################################################++cd ../T+darcs apply < ../S/funpatch | tee output.txt+grep "reading patch bundle from stdin..." output.txt++cd ../T2+darcs apply --quiet < ../S/funpatch | tee output.txt+not grep "reading patch bundle from stdin..." output.txt+cd ..
− tests/issue1640_verbose_stdin.sh 
@@ -1,58 +0,0 @@-#!/usr/bin/env bash-## Test for issue1640 - <SYNOPSIS: darcs Issue 1640 darcs apply-## --verbose with no file args should mention stdin>-##-## Copyright (C) 2011  Radoslav Dorcik <dixiecko@gmail.com>-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                           # Load some portability helpers.--#######################################################-# Test preparation -#######################################################--# Create repository-darcs init      --repo S-darcs init      --repo T-darcs init      --repo T2-cd S-touch foo bar-darcs add foo bar-darcs record -a -m add_foo_bar -A x-darcs send --author=me --output=funpatch -a ../T---#######################################################-# Apply from stdin and check message-#######################################################--# Message when --verbose-cd ../T-darcs apply --verbose < ../S/funpatch | tee output.txt-grep "reading patch bundle from stdin..." output.txt || exit 1---# No message when no --verbose-cd ../T2-darcs apply < ../S/funpatch | tee output.txt-grep "reading patch bundle from stdin..." output.txt && exit 1-exit 0;
@@ -1,77 +0,0 @@-#!/usr/bin/env bash-## Test for issue1702 - an optimize --relink does not relink the files-## in ~/.darcs/cache.-##-## Copyright (C) 2009  Trent W. Buck-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--## Create a patch.-echo 'Example content.' > R/f-darcs record -lam 'Add f.' --repodir R--## Get a hard link into the cache.-darcs get R S--## Are hard links available?-x=(R/_darcs/patches/*-*)-x=${x#R/_darcs/patches/}-if [[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]]-then-    echo This test requires filesystem support for hard links.-    echo This test requires the hashed or darcs-2 repo format.-    exit 200-fi--## IMPORTANT!  In bash [[ ]] is neither a builtin nor a command; it is-## a keyword.  This means it can fail without tripping ./lib's set -e.-## This is why all invocations below have the form [[ ... ]] || false.--## Confirm that all three are hard linked.-ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging-[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false--## Break all hard links.-rm -rf S-cp -r R S-rm -rf R-cp -r S R--## Confirm that there are no hard links.-ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging-[[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ ! S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ ! R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false--## Optimize *should* hard-link all three together.-darcs optimize relink --repodir R --sibling S--## Confirm that all three are hard linked.-ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging-[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false
tests/issue1845-paths-working-copy.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-## Test for issue1845 - darcs wants file paths from root of working copy+## Test for issue1845 - darcs wants file paths from root of working tree ## ## Copyright (C) 2010 Guillaume Hoffmann ##
tests/issue1857-pristine-conversion.sh view
@@ -26,12 +26,16 @@  . lib                           # Load some portability helpers. rm -rf minimal-darcs-2.4-tar zx < $TESTDATA/minimal-darcs-2_4.tgz+unpack_testdata minimal-darcs-2_4  cd minimal-darcs-2.4 darcs check darcs setpref test false echo 'hi' > README-not darcs record -a -m argh --test+not darcs record -a -m argh --test 2> errlog 1> outlog+# check that we are really doing the pristine conversion...+grep 'one-time conversion of pristine' errlog+# ...and not fail for some other reason+grep "Test failed" outlog darcs check cd ..
tests/issue1898-set-default-notification.sh view
@@ -36,19 +36,25 @@ darcs push ../R1 > log grep '/R0$' _darcs/prefs/defaultrepo # notification when using no-set-default-grep "set-default" log+grep -- "--set-default" log+# ...but not when --inherit-default is active+darcs push ../R1 --inherit-default > log+not grep -- "--set-default" log # set-default works darcs push ../R1 --set-default > log grep '/R1$' _darcs/prefs/defaultrepo # no notification when already using --set-default-not grep "set-default" log+not grep -- "--set-default" log # no notification when already pushing to the default repo darcs push > log-not grep "set-default" log+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+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+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/issue1932-colon-breaks-add.sh view
@@ -50,8 +50,8 @@ touch funny/droundy@invalid:     touch funny/invalid:path -# Try to add those files. None should be added, darcs should not fail-darcs add -qr funny+# Try to add those files. None should be added, darcs should fail+not darcs add -qr funny darcs wh -l > log 2>&1  # Check that darcs didn't drop dead as 2.4.4 does
+ tests/issue1959-unwritable-darcsdir.sh view
@@ -0,0 +1,106 @@+#!/usr/bin/env bash+## Test for issue1959 - if the index becomes unwritable,+## read-only commands such as 'darcs whatsnew' should not die.+## Commands that modify the repo should fail with an appropriate+## error message.+##+## Copyright (C) 2012 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf R S+darcs init R+cd R++echo foo > foo+darcs rec -alm 'testing'+echo change > foo++trap "chmod -R +w ." EXIT++chmod -R -w .++# commands that don't take a lock should not+# access the index at all if passed --ignore-times++darcs check+darcs diff --last=1+#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++# ...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 diff --last=1 --no-ignore-times 2>../log+grep "Warning, cannot access the index" ../log+darcs whatsnew --no-ignore-times 2>../log+grep "Warning, cannot access the index" ../log++# made it writable again+chmod -R +w .++# check that we get a decent error message+# for commands that modify the repo+test_cannot_write_index () {+  not darcs record -l foo -am foo 2>record+  grep "Cannot write index" record+  not darcs obliterate 2>record+  grep "Cannot write index" record+  not darcs move foo bar 2>move+  grep "Cannot write index" move+  echo bla > foo+  not darcs add foo 2>add+  grep "Cannot write index" add+  not darcs remove foo 2>remove+  grep "Cannot write index" remove+  not darcs replace x y foo 2>remove+  grep "Cannot write index" remove+}++# ...if the index iself isn't writable (but _darcs is)+chmod -R -w _darcs/index++test_cannot_write_index++# made it writable again+chmod -R +w .++# ...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/issue1978.sh view
@@ -8,10 +8,7 @@ touch titi darcs add titi darcs record -am titi-cat > _darcs/format <<EOF-hashed|gobbledygook-darcs-2-EOF+sed -i 's/hashed/hashed\|gobbledygook/' _darcs/format cat _darcs/format cd ..
tests/issue1987.sh view
@@ -219,7 +219,7 @@ # 34e7e68e2ba4d79facc7ddffdab700608d4abceebbc8ff98d77479b8a5127820 # a8c49fa16eaed0a0a601834c98132a32c24f078e58fcba4d9e036fadb92ca91d # e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855-# The third file represents the empty working copy and is no longer+# The third file represents the empty working tree and is no longer # needed. Therefore 'optimize' must remove it. PRISTINE_DIR_AFTER_RECORD=$(ls -1 $PRISTINE_DIR)
tests/issue2013_send_to_context.sh view
@@ -28,6 +28,7 @@ DARCS_EDITOR=echo export DARCS_EDITOR +rm -rf temp2 mkdir temp2  cd temp2@@ -37,6 +38,7 @@  # setup test cd ..+rm -rf temp1 darcs get temp2 temp1  cd temp1
tests/issue2035-malicious-subpath.sh view
@@ -24,5 +24,5 @@ ## SOFTWARE.  . lib                  # Load some portability helpers.-gunzip -c $TESTDATA/badrepo.tgz | tar xf -+unpack_testdata badrepo not darcs get badrepo
tests/issue2212-add-changes-pending-for-other-files.sh view
@@ -44,7 +44,7 @@ cat _darcs/patches/pending | not grep 'rmfile \./a'  # The same should be true for other commands that have to recompute pending-# from the working directory+# from the working tree darcs revert -a touch b darcs add b
+ tests/issue2257-impossible-obliterate-subset.sh view
@@ -0,0 +1,68 @@+#!/usr/bin/env bash+## Test for issue2257 - impossible case encountered when obliterating a subset+## of patches+## Copyright (C) 2012 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++# this test fails (only) for darcs-2 repos+# and we'll never be able to fix it+skip-formats darcs-2++rm -rf issue2257+mkdir issue2257+cd issue2257++darcs init --repo single-patch+darcs init --repo duplicate-patch++cd single-patch++mkdir dir+touch dir/file1+darcs record -alm 'dir and file1'++touch dir/file2+darcs record -alm 'addfile file2'++cd ../duplicate-patch++# Split the dir/file patch into the dir add, and then the file add.+darcs pull -a ../single-patch -p 'dir and file'+darcs unrecord -a++# Only record 'adddir ./dir'+echo yny | darcs record -m 'adddir dir' +# Now record the addfile in a separate patch.+darcs record -am 'addfile file1'++# Pull in the other patches we don't have (which will include the original +# "add dir/file1" patch again since we've amended it to no longer exist, and+# the "addfile file2" patch)+darcs pull -a ../single-patch++# Attempt to obliterate 'addir dir' (but not 'addfile file1'). This seems to be+# a problem with the patch selection, since without -p, we aren't able to+# obliterate 'adddir dir', if we say no to 'addfile file1' (which is+# sensible!).+echo nyy | darcs obliterate -p 'adddir dir'
tests/issue2271-disable-patch-index.sh view
@@ -25,7 +25,11 @@  . lib                           # Load some portability helpers. +rm -rf R darcs init      --repo R        # Create our test repos.++trap "chmod +w $PWD/R/_darcs/patch_index" EXIT+ cd R touch t.txt darcs add t.txt@@ -34,6 +38,8 @@  chmod -w _darcs/patch_index -not darcs optimize disable-patch-index 2>&1 | grep 'Could not delete patch index'+not darcs optimize disable-patch-index 2>&1 | tee LOG+grep 'Could not delete patch index' LOG +# cleanup cd ../
+ tests/issue2275_follows-symlinks.sh view
@@ -0,0 +1,165 @@+#!/usr/bin/env bash+## Test for issue2275 - darcs follows symbolic links instead of properly+## ignoring them.+## When substituting a recorded file with a symbolic link, darcs becomes+## confused and associates the filename label to the content of the file+## pointed by the link.+##+## Copyright (C) 2017 Gian Piero Carrubba+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib+abort_windows                   # Skip test on Windows++rm -rf R+darcs init R+cd R+touch g+echo 'This line should not appear in g.' > f+darcs record -lam 'Add f and g.'+rm -f g                         # Remove g and create a link with the+ln -s f g                       # same name ponting to f+darcs diff g | not grep -F '+This line should not appear in g.'+cd ..++# extended test extracted from the bug report++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++  # create a symbolic link with the same name of the just removed+  # file pointing to an existent file (does not need to be in the+  # repodir)+  ln -s file maybeFile++  # now you get different opinions about what changed depending on+  # the use of the '--look-for-adds' option. In both case 'maybeFile'+  # is wrongly reported as changed (the current content of 'maybeFile'+  # is assumed to be the one of the file the link points to), anyway+  # using the '-l' option you also get the right information that+  # 'maybeFile' has been removed.+  darcs wh -s > ../log/after-ln-wh-s+  darcs wh -ls > ../log/after-ln-wh-ls++  diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+  diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls++  # trying to record the changes without the use of '-l' leads to+  # the wrong patch being recorded+  darcs rec -am 'Maybe remove maybeFile'+  darcs log --last 1 -s | not grep 'M ./maybeFile'++  # unrecord the wrong patch+  darcs unrec --last 1 -a++  # passing '-l' to the record command leads to the right patch+  # being  recorded.+  darcs rec -lam 'Remove maybeFile'+  darcs log --last 1 -s | grep -F './maybeFile' > ../log/after-record-l++  diff -u -w ../log/after-record-l ../log/after-ln-wh-ls++  # now if you unrecord the last patch the `-l' option does not+  # make a difference anymore+  darcs unrec --last 1 -a+  darcs wh -s > ../log/after-unrec-wh-s+  darcs wh -ls > ../log/after-unrec-wh-ls++  # use -w to ignore different indentation+  diff -u -w ../log/after-record-l ../log/after-unrec-wh-s+  diff -u -w ../log/after-record-l ../log/after-unrec-wh-ls++  # create again the issue, this time giving the file the same+  # content as the file referenced by the link+  echo ImmutableFile > maybeFileThree+  darcs rec -lam 'Add maybeFileThree'+  rm maybeFileThree++  darcs wh -s > ../log/before-ln-wh-s+  darcs wh -ls > ../log/before-ln-wh-ls++  ln -s file maybeFileThree++  darcs wh -s > ../log/after-ln-wh-s+  darcs wh -ls > ../log/after-ln-wh-ls++  diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+  diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls++  darcs rec -lam 'Remove maybeFileThree'++  # create again the problem, pointing the symbolic link to a+  # not-existent file+  echo JustAnotherTemporaryFile > maybeFileFour+  darcs rec -lam 'Add maybeFileFour'+  rm maybeFileFour++  darcs wh -s > ../log/before-ln-wh-s+  darcs wh -ls > ../log/before-ln-wh-ls++  ln -s not-existent maybeFileFour++  darcs wh -s > ../log/after-ln-wh-s+  darcs wh -ls > ../log/after-ln-wh-ls++  diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+  diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls++  darcs rec -lam 'Remove maybeFileFour'++  cd ..+}++echo ############## --ignore-times #################++extended_test++echo ############ --no-ignore-times ################++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++trap "restore_defaults '$PWD'" EXIT+extended_test
tests/issue2286-metadata-encoding.sh view
@@ -26,7 +26,7 @@  . lib -gunzip -c $TESTDATA/metadata-encoding.tgz | tar xf -+unpack_testdata metadata-encoding cd metadata-encoding  darcs log -v
+ tests/issue2293-laziness.sh view
@@ -0,0 +1,57 @@+#!/bin/sh -e+##+## Test that commands don't read too much of the repository+##+## Copyright (C) 2013 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf repo+unpack_testdata laziness-cut++cd repo++# log+darcs log --last=1+# amend+echo 'baz' > bar+echo yyyy | darcs amend+darcs log --last=1+# unrecord+echo yd | darcs unrecord -o+# log --context+darcs log --context > ctx+# record+darcs record -am xxx+darcs log --last=1+# send+echo ydy | darcs send -o xxx.dpatch --context ctx .+# obliterate+echo yd | darcs obliterate -o yyy.dpatch --no-minimize+tail -n +7 xxx.dpatch > zzz.dpatch+diff yyy.dpatch zzz.dpatch+# apply+darcs apply xxx.dpatch --debug+darcs log --last=1++cd ..
+ tests/issue2310-rollback-doesnt-readd.sh view
@@ -0,0 +1,43 @@+## Test for issue2310 - darcs rollback of rmfile doesn't add to pending+##+## Copyright (C) 2013 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf R++darcs init --repo R++cd R++echo foo > foo +darcs rec -alm 'add foo'++rm foo+darcs rec -am 'remove foo'++echo ynya | darcs rollback++# If the file hasn't been re-added in pending, this line will be missing from+# the output of whatsnew+darcs wh | grep -F 'addfile ./foo'
tests/issue2382-mv-dir-to-file-confuses-darcs.sh view
@@ -36,6 +36,7 @@ }  . lib+rm -rf R darcs init --repo R cd R
tests/issue2494-output-of-record-with-file-arguments.sh view
@@ -44,8 +44,8 @@ # Now do the tests echo q | darcs record added not-added recorded removed not-existing /not-repo-path > ../record.out 2>&1 -check_report_yes ../record.out 'non-repository' /not-repo-path-check_report_no ../record.out 'non-repository' added not-added recorded removed not-existing+check_report_yes ../record.out 'invalid repository path' /not-repo-path+check_report_no ../record.out 'invalid repository path' added not-added recorded removed not-existing  check_report_yes ../record.out 'non-existing' not-added not-existing check_report_no ../record.out 'non-existing' added recorded removed /not-repo-path@@ -58,8 +58,8 @@  echo q | darcs record -l added not-added recorded removed not-existing /not-repo-path > ../record-l.out 2>&1 -check_report_yes ../record-l.out 'non-repository' /not-repo-path-check_report_no ../record-l.out 'non-repository' added not-added recorded removed not-existing+check_report_yes ../record-l.out 'invalid repository path' /not-repo-path+check_report_no ../record-l.out 'invalid repository path' added not-added recorded removed not-existing  check_report_yes ../record-l.out 'non-existing' not-existing check_report_no ../record-l.out 'non-existing' added not-added recorded removed /not-repo-path
tests/issue2496-output-of-whatsnew-with-file-arguments.sh view
@@ -44,8 +44,8 @@ # Now do the tests darcs whatsnew added not-added recorded removed not-existing /not-repo-path > ../whatsnew.out 2>&1 -check_report_yes ../whatsnew.out 'non-repository' /not-repo-path-check_report_no ../whatsnew.out 'non-repository' added not-added recorded removed not-existing+check_report_yes ../whatsnew.out 'invalid repository path' /not-repo-path+check_report_no ../whatsnew.out 'invalid repository path' added not-added recorded removed not-existing  check_report_yes ../whatsnew.out 'non-existing' not-added not-existing check_report_no ../whatsnew.out 'non-existing' added recorded removed /not-repo-path@@ -55,8 +55,8 @@  darcs whatsnew -l added not-added recorded removed not-existing /not-repo-path > ../whatsnew-l.out 2>&1 -check_report_yes ../whatsnew-l.out 'non-repository' /not-repo-path-check_report_no ../whatsnew-l.out 'non-repository' added not-added recorded removed not-existing+check_report_yes ../whatsnew-l.out 'invalid repository path' /not-repo-path+check_report_no ../whatsnew-l.out 'invalid repository path' added not-added recorded removed not-existing  check_report_yes ../whatsnew-l.out 'non-existing' not-existing check_report_no ../whatsnew-l.out 'non-existing' added not-added recorded removed /not-repo-path
+ tests/issue2536-show-files--no-files.sh view
@@ -0,0 +1,7 @@+. lib+rm -rf R+darcs init R+cd R+touch foo bar+darcs rec -lam'add foo and bar'+darcs show files --no-files
− tests/issue2545_command-execution-via-ssh-uri.sh 
@@ -1,49 +0,0 @@-#!/usr/bin/env bash-## Test for issue2545 - Argument smuggling in SSH repository URLs-## Darcs allows (almost) arbitrary command execution via a crafted ssh URI.-##-## Copyright (C) 2017  Gian Piero Carrubba-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.-cd R--DARCS_SCP=sftp darcs pull -a ssh://-oProxyCommand='touch FAIL' \-    2>/dev/null || true-not ls FAIL >/dev/null--DARCS_SCP=sftp darcs pull -a -- -oProxyCommand='touch FAIL':dir \-    2>/dev/null || true-not ls FAIL >/dev/null--# Executing the same tests with `clone' instead of `pull'. The results shoud-# be the same, but better safe than sorry.-DARCS_SCP=sftp darcs clone ssh://-oProxyCommand='touch FAIL' S \-    2>/dev/null || true-not ls FAIL >/dev/null--DARCS_SCP=sftp darcs clone -- -oProxyCommand='touch FAIL':dir T \-    2>/dev/null || true-not ls FAIL >/dev/null--cd ..
+ tests/issue2548-inconsistent-pending.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash++. lib++# add a file, turn it into a directory in the working tree,+# then let darcs figure out how to handle that++rm -rf R+darcs init R+cd R+touch f+darcs add f+rm f+mkdir f+darcs whatsnew -l --no-summary | tee ../before+darcs record -lam 'patchname'+darcs log -v | tee ../after+for log in ../before ../after; do+  grep 'adddir ./f' $log+  not grep 'addfile ./f$' $log+done+cd ..++# same with dir and file swapped++rm -rf R+darcs init R+cd R+mkdir f+# for good measure add a file to the directory+touch f/g+darcs add -r f+rm -rf f+touch f+darcs whatsnew -l --no-summary | tee ../before+darcs record -vlam 'patchname'+darcs log -v | tee ../after+for log in ../before ../after; do+  grep 'addfile ./f' $log+  not grep 'adddir ./f' $log+done+cd ..
+ tests/issue2592-pending-look-for.sh view
@@ -0,0 +1,65 @@+#!/usr/bin/env bash+. ./lib++cat << EOF > empty_pending+{+}+EOF++# darcs add a file and then rename without telling darcs++rm -rf test1+darcs init test1+cd test1+touch f+darcs add f+mv f g+# plain darcs whatsnew differs from pending+# because it sees that the file is no longer there+# (because removals are always detected implicitly)+grep 'addfile ./f' _darcs/patches/pending+not darcs whatsnew # No changes+darcs whatsnew --look-for-moves | grep 'addfile ./g'+darcs record -am 'addfile f + move f g = addfile g' --look-for-moves+# make sure pending is now empty+diff ../empty_pending _darcs/patches/pending+cd ..++# add and record a file, darcs move it and then rename it back+# without telling darcs about it++rm -rf test2+darcs init test2+cd test2+touch f+darcs add f+darcs record -lam 'addfile f' f+# make sure pending is empty+diff ../empty_pending _darcs/patches/pending+darcs move f g+darcs whatsnew | grep 'move ./f ./g'+mv g f+# plain darcs whatsnew differs from pending+# because it sees that the file is no longer there+# (because removals are always detected implicitly)+grep 'move ./f ./g' _darcs/patches/pending+darcs whatsnew | grep 'rmfile ./f'+# but with --look-for-moves pending and working cancel each other+not darcs whatsnew --look-for-moves # No changes++# so recording with --look-for-moves sees no changes+darcs record -a --look-for-moves | grep -i "you don't want to record anything"++# the record did nothing, so same checks as above should succeed+darcs whatsnew | grep 'rmfile ./f'+grep 'move ./f ./g' _darcs/patches/pending+not darcs whatsnew --look-for-moves # No changes++# # darcs add has no option --look-for-moves/replaces yet+# # so we have no way to "fix" pending+# darcs add --look-for-moves+# # pending should now be empty+# diff ../empty_pending _darcs/patches/pending+# darcs whatsnew | grep 'rmfile ./f'+# not darcs whatsnew --look-for-moves+cd ..
+ tests/issue2594-darcs-show-index-breaks-replace.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2594 - (originally issue2208) darcs show index+## crashes replace with unrecorded force hunk+##+## Copyright (C) 2012 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf R++darcs init --repo R++cd R++echo -e 'foo\nbar' > testing++darcs rec -alm 'Add testing file'++darcs show index++echo -e 'baz\nbar' > testing++darcs replace bar foo testing
+ tests/issue2603-clone-repo-with-unresolved-conflicts.sh view
@@ -0,0 +1,24 @@+#!/usr/bin/env bash++# issue2603: clone of a repo with unresolved conflicts gives no warning+# and no applies no conflict markup++. lib++rm -rf R+darcs init R+cd R+echo foo > f+darcs record -lam foo+cd ..++rm -rf S+darcs init S+cd S+echo bar > f+darcs record -lam bar+darcs pull ../R -a --allow-conflicts+cd ..++rm -rf T+darcs clone S T 2>&1 | grep conflicts
+ tests/issue2605-duplicates.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash++# This is the scenario described in Appendix B of the camp paper+# to motivate giving identities (there called "names") to prim patches.+# We make the same change A1 and A2 independently in two separate repos,+# then record B that depends on A1. But it doesn't, not really. What it+# depends on is the /change/ made by A1, and since A2 makes the identical+# change we can arrange things so that we replace dependency A1 with the+# alternative dependency A2.++. lib++# this test fails for darcs-1 and darcs-2 repos and we cannot fix it+skip-formats darcs-1 darcs-2++rm -rf R1 R2++darcs init R1+cd R1+echo A > f+darcs record -lam A1 f+echo B > f+darcs record -lam B f+cd ..++darcs init R2+cd R2+echo A > f+darcs record -lam A2 f+darcs pull ../R1 -a --allow-conflicts+# this should fail according to Ian...+darcs obliterate -a -p A1+cd ..++cd R1+# ...instead of this crashing+darcs pull ../R2 -a --allow-conflicts+cd ..++cd R2+# ...or this+darcs pull ../R1 -a --allow-conflicts+cd ..
+ tests/issue2614-clone-unclean-tag.sh view
@@ -0,0 +1,23 @@+. lib++rm -rf R S T+darcs init R+cd R+echo apply allow-conflicts >> _darcs/prefs/defaults+echo bla > foo+darcs record -lam 'bla R'+darcs tag one+cd ..++darcs init S+cd S+echo bla > foo+darcs record -lam 'bla S'+darcs tag one+echo blub > foo+darcs record -lam 'blub S'+darcs tag two+darcs push ../R -a+cd ..++darcs clone R T --tag two
+ tests/issue2618-ask-deps-too-many.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+# Test that --ask-deps adds no more than the specified explicit dependencies+# and not indirect (implicit) dependencies.++. ./lib++rm -rf R+darcs init R+cd R+echo text > file+darcs record -lam 'one'+echo othertext > file+darcs record -am 'two'+echo text > other_file+echo yd | darcs record -lam 'three' --ask-deps+darcs log -s --last=1 | tee LOG+# should depend on patch named 'two'+grep two LOG+# but not on patch named 'one'+not grep one LOG+cd ..
+ tests/issue2634-rebase-conflicted-patches.sh view
@@ -0,0 +1,103 @@+#!/usr/bin/env bash++# Test for issue2634: suspending and unsuspending conflicted patches++. ./lib++# prepare: make two conflicting patches one and two and merge them+rm -rf R S T1 T2+darcs init R+cd R+touch file+darcs record -l file -am 'base'+echo one > file+darcs record file -am 'one'+darcs clone . ../S+echo two > file+echo y|darcs amend -am 'two' -p one+echo y|darcs pull ../S -a --allow-conflicts --reorder-patches+# patch order should be init; one; two+cd ..++# test1: suspend both 'one' and 'two', rebase obliterate 'one', then unsuspend+rm -rf T1+darcs clone R T1+cd T1+# get rid of conflict markup+darcs revert -a+echo yydyy | darcs rebase suspend+echo yd|darcs rebase obliterate+darcs rebase unsuspend -p two -a+cat file >&2+not grep one file+grep two file+cd ..++# test2: suspend 'two' and obliterate 'one', then unsuspend+rm -rf T2+darcs clone R T2+cd T2+# get rid of conflict markup+darcs revert -a+echo ydy | darcs rebase suspend+echo y|darcs obliterate -p one -a+darcs rebase unsuspend -p two -a+cat file >&2+not grep one file+grep two file+cd ..++# prepare: three-way conflict+rm -rf U+darcs clone S U+cd U+echo three > file+echo y|darcs amend -am 'three' -p one+echo y|darcs pull ../R -a --allow-conflicts --reorder-patches+# patch order should be init; one; two; three+cd ..++# test3: suspend 'three', obliterate 'two', then unsuspend+rm -rf T3+darcs clone U T3+cd T3+# get rid of conflict markup+darcs revert -a+echo ydy | darcs rebase suspend+echo y|darcs obliterate -p two -a+darcs rebase unsuspend -p three -a+cat file >&2+grep one file+not grep two file+grep three file+cd ..++# test4: suspend all, rebase obliterate 'one', then unsuspend+rm -rf T4+darcs clone U T4+cd T4+# get rid of conflict markup+darcs revert -a+echo yyydyyy | darcs rebase suspend+echo yd|darcs rebase obliterate+darcs rebase unsuspend -a+cat file >&2+not grep one file+grep two file+grep three file+cd ..++# test5: suspend all, rebase obliterate 'one' and 'two', then unsuspend+rm -rf T5+darcs clone U T5+cd T5+# get rid of conflict markup+darcs revert -a+echo yyydyyy | darcs rebase suspend+echo yyd|darcs rebase obliterate+darcs rebase unsuspend -a+cat file >&2+not grep one file+not grep two file+grep three file+cd ..
+ tests/issue2639-diff-crashes-with-last-and-file.sh view
@@ -0,0 +1,20 @@+# test for issue2639: darcs diff crashes with --last=1 and file name++. lib++darcs init R+cd R+echo a > f+cp f g+darcs record -lam 'a'+echo b > f+cp f g+darcs diff f --last=1+# issue2639: this crashed with+# ### Error applying:+# hunk ./g 1+# -a+# ### to file g:+# b+# ### Reason: Hunk wants to remove content that isn't there+cd ..
+ tests/issue2648_darcs_convert_import_double_encodes_cyrillic.sh view
@@ -0,0 +1,40 @@+#!/bin/sh -e+##+## Test for issue2648 - `darcs convert import` double-encodes cyrillic characters in UTF-8 input stream+##+## Copyright (C) 2020  Andrey Korobkov <alster@vinterdalen.se>+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.++switch_to_utf8_locale++# Import stream into Darcs repo+cat $TESTDATA/cyrillic_import_stream | darcs convert import R++cd R++# Test patch name+darcs log | grep 'Южноэфиопский грач увёл мышь за хобот на съезд ящериц'++# Test filename and patch data+darcs annotate 'Панграмма.txt' | grep 'Широкая электрификация южных губерний даст мощный толчок подъёму сельского хозяйства'
tests/issue279_get_extra.sh view
@@ -8,6 +8,7 @@ # this test fails for darcs-1 repos skip-formats darcs-1 +rm -rf temp1 mkdir temp1 cd temp1 darcs init@@ -17,26 +18,26 @@ cd ..  for r in a b c d; do+  rm -rf temp_$r   darcs get temp1 temp_$r-  cd temp_$r;+  cd temp_$r   echo $r > f-  darcs record -am "patch:$r";+  darcs record -am "patch:$r"   cd .. done  cd temp_d-darcs pull -a ../temp_a-darcs pull -a ../temp_b-darcs pull -a ../temp_c+darcs pull -a ../temp_a --allow-conflicts+darcs pull -a ../temp_b --allow-conflicts+darcs pull -a ../temp_c --allow-conflicts cd .. cd temp_c-darcs pull -a ../temp_a-darcs pull -a ../temp_b+darcs pull -a ../temp_a --allow-conflicts+darcs pull -a ../temp_b --allow-conflicts echo rc > f darcs record -a -m rc cd .. cd temp_d darcs pull -a ../temp_c > log-not grep -i "no remote" log-not grep -i get_extra log+not grep -i "Failed to commute common patches" log cd ..
tests/issue436.sh view
@@ -2,9 +2,6 @@  . ./lib -# this test fails in the darcs 1 format-skip-formats darcs-1- mkdir temp1 cd temp1 darcs init
tests/issue525_amend_duplicates.sh view
@@ -2,9 +2,6 @@  . ./lib -## I would use the builtin !, but that has the wrong semantics.-not () { "$@" && exit 1 || :; }- rm -rf temp1 mkdir temp1 cd temp1@@ -21,4 +18,3 @@ cat output not grep first output cd ..-rm -rf temp1
tests/issue538.sh view
@@ -106,10 +106,10 @@ darcs record -am 'invalid helper' -A test darcs setpref test './test.sh' darcs test --linear --set-scripts-executable > trackdown-out-if grep 'Test failed!' trackdown-out && grep 'Success!' trackdown-out ; then+if grep 'Test failed!' trackdown-out && grep 'Last recent patch' trackdown-out ; then     echo "ok 7" else -    echo "not ok 7 either no failure or no success (both should occur)"+    echo "not ok 7 either no failure or no report of problem patch (both should occur)"     exit 1 fi cd ..
+ tests/issue701.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+. ./lib+++# issue701++# step 1+rm -rf temp0+darcs init temp0+cd temp0+echo m1 > foo+darcs record -lam m1+cd ..++# step 2+rm -rf temp1+darcs clone temp0 temp1+cd temp1+echo a1 > foo+darcs record foo -a -m a1+cd ..+++# step 3+cd temp0+echo m2 > foo+darcs record -a -m m2+cd ..+++# step 4+cd temp1+darcs pull -a+echo m2-a1 > foo+darcs record -a -m 'Fix conflict m2-a1'+cd ..++# step 5+cd temp0+echo m3 > foo+darcs record -a -m m3+cd ..++# step 6+cd temp0+echo m4 > foo+darcs record -a -m m4+cd ..++# step 7+cd temp1+darcs pull -a+echo m2-a1-m4 > foo+echo y | darcs mark-conflicts+cd ..
tests/issue709_pending_look-for-adds.sh view
@@ -25,7 +25,7 @@  echo bar > bar darcs add bar-echo yyd | darcs record -mbar+darcs record -mbar -a bar  cat _darcs/patches/pending @@ -42,7 +42,7 @@ # remove any files added by profiling or hpc... rm -f darcs.tix darcs.prof -echo yyd | darcs record --look-for-adds -mfoo+darcs record --look-for-adds -mfoo -a foo  cat _darcs/patches/pending
+ tests/lazy-conflict-resolution.sh view
@@ -0,0 +1,19 @@+# this tests that when we resolve conflicts, we don't access+# patches in the context if they are not needed.++. lib++rm -rf R S+darcs init R+cd R+touch file+darcs record -l file -a -m add+darcs tag mytag+rm _darcs/patches/*+echo xxx > file+darcs record -l file -a -m edit1+darcs clone --lazy . ../S+echo yyy > file+echo y | darcs amend -a -m edit2+darcs pull -a ../S+cd ..
tests/lazy-optimize-reorder.sh view
@@ -60,5 +60,3 @@ not darcs check  cd ..--rm -rf temp1 temp2 temp3 temp4
+ tests/legacy-inverted.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++# Test that repositories that contain legacy "UNDO" patches, i.e. ones with+# an inverted PatchInfo, are still handled correctly by darcs. These+# patches were written by darcs rollback until the behaviour of rollback+# was changed in 2008; one example of a repo containing them is darcs itself.++. ./lib++rm -rf undo++# undo is a repository containing a legacy "UNDO" patch,+# i.e. one with an inverted PatchInfo.+#+# As darcs hasn't created these  patches for many years, it's not easy to+# build such a repo. This one was created using rebase on the actual darcs+# repo. As a result the UNDO patch isn't actually an inverse of the original+# patch, as its PatchInfo got rewritten during unsuspend. This shouldn't+# matter in practice for this test.++unpack_testdata undo++cd undo++darcs changes | grep "UNDO"+darcs changes --xml | grep "inverted='True'"++echo "empty" > Patch.lhs++echo yy | darcs amend -a -p "get rid of"++darcs changes | not grep "UNDO"+darcs changes --xml | not grep "inverted='True'"
tests/lib view
@@ -1,5 +1,7 @@ # This is a -*- sh -*- library. +. ./env+ ## I would use the builtin !, but that has the wrong semantics. not () { "$@" && exit 1 || :; } @@ -66,44 +68,34 @@     fi } -serve_http() {-    cat > light.conf <<EOF-    server.document-root       = "$PWD"-    server.errorlog            = "/dev/null"-    server.port                = 23032 ## FIXME-    server.bind                = "localhost"-    server.pid-file            = "$PWD/light.pid"-EOF-    trap "finish_http \"$PWD\"" EXIT-    lighttpd -f light.conf || exit 200-    ps `cat light.pid` > /dev/null 2>&1 || exit 200-    baseurl="http://localhost:23032"-}--finish_http() {-    test -e "$1/light.pid" && kill `cat "$1/light.pid"` || true+# check that the specified string appears precisely once in the output+grep-once() {+    grep -c "$@" | grep -w 1 } -check_remote_http() {-  if ! curl -fI "$1"; then-    echo Cannot reach "$1"-    exit 200-  fi+require_ghc() {+    test $GHC_VERSION -ge $1 || exit 200 }  skip-formats() {-    for f in "$@"; do grep $f $HOME/.darcs/defaults && exit 200 || true; done+    for f in "$@"; do grep -q $f $HOME/.darcs/defaults && exit 200 || true; done } -# check that the specified string appears precisely once in the output-grep-once() {-    grep -c "$@" | grep -w 1+only-format() {+    grep -q $1 $HOME/.darcs/defaults || exit 200 } -require_ghc() {-    test $GHC_VERSION -ge $1 || exit 200+unpack_testdata() {+   # Historically we used to have to use 'gunzip -c archive | tar xf -'+   # because the test harness was sometimes run with a tar that didn't support -z.+   # That isn't the case now so we just use -f directly.+   # Note that piping the archive on stdin without a -f flag doesn't work reliably+   # because the default device might not be stdin, e.g. on Windows/msys the default+   # could be a tape device //./tape0, even if that doesn't exist.+   tar -xzf $TESTDATA/$1.tgz } +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
tests/log-duplicate.sh view
@@ -23,8 +23,8 @@  . lib -# this test fails for darcs-1 repos-skip-formats darcs-1+# this tests a property of darcs-2 repos+only-format darcs-2  darcs init --repo R darcs init --repo S
tests/log.sh view
@@ -157,4 +157,16 @@ darcs log --context | grep patch_b cd .. +## log --index=N-M +# re-use the temp6 directory with 3 patches+cd temp6+count=$(darcs log --count)+for N in $(seq 1 $count); do+  for M in $(seq 1 $count); do+    darcs log --index=$N-$M --count | tee LOG+    expected=$(($N <= $M ? $M - $N + 1 : 0))+    grep -w $expected LOG+  done+done+cd ..
tests/log_send_context.sh view
@@ -2,10 +2,9 @@ . ./lib  # RT#544 using context created with 8-bit chars;-rm -rf temp1 +rm -rf temp1 mkdir temp1- cd temp1 darcs init touch foo@@ -14,5 +13,8 @@ date > foo darcs record -a -m 'date foo' | grep 'Finished record' darcs send -a -o patch --context context . | grep 'Wrote patch to'+# again with an absolute path for the context file, see issue1240+# note we must not mix \\ and / so we use /bin/pwd here+cwd=$(/bin/pwd)+darcs send -a -o patch --context "$cwd/context" . | grep 'Wrote patch to' cd ..-rm -rf temp1
tests/look_for_moves.sh view
@@ -2,8 +2,8 @@  . ./lib -rm -rf temp1 temp2-mkdir temp1 temp2+rm -rf temp1+mkdir temp1 cd temp1  # simple add and move@@ -71,7 +71,15 @@ echo 'yyy' | darcs amend-record -p add_file --look-for-moves darcs wh --look-for-moves --look-for-adds >log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log-darcs log -v --machine -p add_file | grep "] addfile ./foo2"+darcs log -v --machine -p add_file >log 2>&1+# 'darcs log --machine' internally calls 'showPatch ForStorage'+# which is why we need to distinguish between darcs-3 and earlier here.+# This behavior of 'darcs log' is questionable at best.+if test "$format" = darcs-3; then+  grep -A1 "] hash 1 " log | grep "addfile ./foo2"+else+  grep "] addfile ./foo2" log+fi rm -rf *  # add, move, add same name and amend-record
tests/look_for_moves_and_replaces.sh view
@@ -9,6 +9,7 @@   shift   paths=$@ +  rm -rf R$num   darcs init R$num   cd R$num @@ -50,10 +51,7 @@ test_setup 3 new # remove the line about What's new in: new sed -i '1d' out.actual-# NOTE: the move is NOT detected in this case-# We might want to change that...-sed '1d' out.expected | sed 's/new/old/' > out.expected3-diff out.actual out.expected3+diff out.actual out.expected  # same but only for old and new
+ tests/look_for_replaces1.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash+## Failing test for --look-for-replaces+##+## Copyright (C) 2013 Jose Neder+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R++# forced replace (the word is in the file) (amend-record)+# amending an addfile patch with a forced replace fails+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+bar+bar+EOF+echo y | darcs amend-record --look-for-replaces -a+cd ..+rm -rf R+
tests/mark-conflicts.sh view
@@ -25,7 +25,7 @@ cd ..  cd temp1-darcs pull -a ../temp2 > log+darcs pull -a ../temp2 2> log grep conflict log grep finished log grep 'v v' child_of_conflict
tests/merging_newlines.sh view
@@ -22,6 +22,6 @@ echo "from temp2" >> one.txt darcs whatsnew -s | grep M darcs record -am "append non-empty line"-darcs push -av > log+darcs push -av 2> log grep -i conflicts log cd ..
tests/mv.sh view
@@ -275,3 +275,38 @@ darcs what | grep "move ./d ./d2" cd .. rm -rf temp1++# it should not crash when given invalid paths+# instead issue a proper error message++rm -rf R+darcs init R+cd R+touch f+darcs record -lam 'add f' f+# 2 path arguments+# target does not exist: OK+darcs move f g+darcs revert -a+# source does not exist: Fail+not darcs move g f >LOG 2>&1+not grep -i bug LOG+grep -i 'does not exist' LOG+# 2nd is un-added existing directory+mkdir d+not darcs move f d >LOG 2>&1+not grep -i bug LOG+grep -i 'not known' LOG+# 3 path arguments+touch g+darcs record -lam 'add g' g+# 3rd arg is un-added existing dir+not darcs move f g d >LOG 2>&1+not grep -i bug LOG+grep -i "isn't known" LOG+# 3rd argument does not exist+rm -rf d+not darcs move f g d >LOG 2>&1+not grep -i bug LOG+grep -i "isn't known" LOG+cd ..
tests/network/clone-http-packed-detect.sh view
@@ -5,8 +5,9 @@ # and does not report when there is none or when --no-packs is passed.  . lib+. httplib -skip-formats darcs-1 # compressed repo is darcs-2+only-format darcs-2 # compressed repo is darcs-2  gunzip -c $TESTDATA/laziness-complete.tgz | tar xf - @@ -20,13 +21,14 @@ serve_http # sets baseurl  # check that default behaviour is to get packs-darcs clone $baseurl/laziness-complete S --verbose |grep "Cloning packed basic repository"+rm -rf S+darcs clone $baseurl/repo S --verbose |grep "Cloning packed basic repository"  # check that it does really not get packs when --no-packs is passed rm -rf S-darcs clone $baseurl/laziness-complete S --no-packs --verbose  |not grep "Cloning packed basic repository"+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 rm -rf S-rm -rf laziness-complete/_darcs/packs/-darcs clone $baseurl/laziness-complete S --verbose |not grep "Cloning packed basic repository"+rm -rf repo/_darcs/packs/+darcs clone $baseurl/repo S --verbose |not grep "Cloning packed basic repository"
tests/network/clone-http-packed.sh view
@@ -2,8 +2,9 @@ # Written in 2010 by Petr Rockai, placed in public domain  . lib+. httplib -skip-formats darcs-1 # compressed repo is darcs-2+only-format darcs-2 # compressed repo is darcs-2  gunzip -c $TESTDATA/laziness-complete.tgz | tar xf - @@ -15,7 +16,8 @@ cd ..  serve_http # sets baseurl-darcs clone --packs $baseurl/laziness-complete S+rm -rf S+darcs clone --packs $baseurl/repo S cd S rm _darcs/prefs/sources # avoid any further contact with the original repository darcs check
tests/network/clone-http.sh view
@@ -25,6 +25,7 @@ ## SOFTWARE.  . lib+. httplib  rm -rf R S && mkdir R cd R
tests/network/clone.sh view
@@ -1,16 +1,20 @@ #!/usr/bin/env bash  . lib--check_remote_http http://hub.darcs.net/kowey/tabular--rm -rf temp temp2 temp3+. httplib -#"$DARCS" clone http://hub.darcs.net/kowey/tabular temp+# this should all work without a cache+if ! grep no-cache $HOME/.darcs/defaults; then+  echo ALL no-cache >> $HOME/.darcs/defaults+fi -darcs clone --lazy http://hub.darcs.net/kowey/tabular temp2+rm -rf tabular+unpack_testdata tabular+serve_http # sets baseurl -darcs clone --lazy --tag . http://hub.darcs.net/kowey/tabular temp3+rm -rf temp2 temp3+darcs clone --lazy $baseurl/tabular temp2+darcs clone --lazy --tag . $baseurl/tabular temp3  cd temp2 darcs obliterate --from-tag . -a
tests/network/failing-issue1599-automatically-expire-unused-caches.sh view
@@ -22,7 +22,9 @@ ## ACTION OF 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
+ tests/network/httplib view
@@ -0,0 +1,26 @@+serve_http() {+    lightpid=$((10000 + $$ % 30000))+    cat > light.conf <<EOF+    server.document-root       = "$PWD"+    server.errorlog            = "$PWD/error.log"+    server.port                = $lightpid+    server.bind                = "localhost"+    server.pid-file            = "$PWD/light.pid"+    index-file.names           = ()+EOF+    trap "finish_http \"$PWD\"" EXIT+    lighttpd -f light.conf || exit 200+    ps `cat light.pid` > /dev/null 2>&1 || exit 200+    baseurl="http://localhost:$lightpid"+}++finish_http() {+    test -e "$1/light.pid" && kill `cat "$1/light.pid"` || true+}++check_remote_http() {+  if ! curl -fI "$1"; then+    echo Cannot reach "$1"+    exit 200+  fi+}
tests/network/issue1503_prefer_local_caches_to_remote_one.sh view
@@ -24,6 +24,7 @@ ## SOFTWARE.  . lib+. httplib  check_remote_http http://darcs.net/testing/repo1
tests/network/issue1923-cache-warning.sh view
@@ -22,12 +22,16 @@ ## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE.+ . lib+. httplib +rm -rf R darcs init --repo R cd R echo a > a darcs rec -lam a+darcs tag x cd ..  serve_http@@ -36,6 +40,7 @@ repo:/some/bogus/local/path repo:$baseurl/R SOURCES+rm -rf S1 S2 darcs clone --lazy R S1 && cp fake-sources S1/_darcs/prefs/sources darcs clone --lazy R S2 && cp fake-sources S2/_darcs/prefs/sources
tests/network/issue1932-remote.sh view
@@ -33,10 +33,10 @@ # 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 "$(fgrep  'ssh: Could not resolve hostname invalid: Name or service not known' log)" ]+[ -n "$(grep 'ssh: Could not resolve hostname invalid' log)" ]  # HTTP repo ( http_proxy= darcs clone http://www.bogus.domain.so.it.will.surely.fail.com || true ) 2>&1 | tee log-egrep 'CouldNotResolveHost|host lookup failure' log+egrep 'CouldNotResolveHost|host lookup failure|Name or service not known' log  # local repos are tested by tests/issue1932-colon-breaks-add.sh
+ tests/network/issue2545_command-execution-via-ssh-uri-local.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+## Test for issue2545 - Argument smuggling in SSH repository URLs+## Darcs allows (almost) arbitrary command execution via a crafted ssh URI.+##+## Copyright (C) 2017  Gian Piero Carrubba+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++# This part of the tests for issue2545 doesn't actually try to connect+# remotely, but is still kept in the network folder as it uses a+# network-based command, allowing developers that have problems with+# those commands to exclude it with --network=no:+# https://lists.osuosl.org/pipermail/darcs-devel/2020-July/021363.html++. lib                           # Load some portability helpers.+darcs init      --repo R        # Create our test repos.+cd R++DARCS_SCP=sftp darcs pull -a ssh://-oProxyCommand='touch FAIL' \+    2>/dev/null || true+not ls FAIL >/dev/null++DARCS_SCP=sftp darcs pull -a -- -oProxyCommand='touch FAIL':dir \+    2>/dev/null || true+not ls FAIL >/dev/null++# Executing the same tests with `clone' instead of `pull'. The results shoud+# be the same, but better safe than sorry.+DARCS_SCP=sftp darcs clone ssh://-oProxyCommand='touch FAIL' S \+    2>/dev/null || true+not ls FAIL >/dev/null++DARCS_SCP=sftp darcs clone -- -oProxyCommand='touch FAIL':dir T \+    2>/dev/null || true+not ls FAIL >/dev/null++cd ..
+ tests/network/issue2608-clone-http-packed-outdated.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash+# test that cloning a repo with not up-to-date packs still gets us all the patches++. lib+. httplib++rm -rf R+darcs init R+cd R+echo foo > foo+darcs record -lam foo+darcs tag foo+echo bar > bar+darcs record -lam bar+darcs optimize http+darcs tag "not packed"+echo qux > qux+darcs record -lam qux+cd ..++serve_http # sets baseurl++rm -rf S+darcs clone $baseurl/R S++cd S+darcs log | grep "not packed"+darcs log | grep "qux"+cd ..
tests/network/lazy-clone.sh view
@@ -1,25 +1,34 @@ #!/usr/bin/env bash  . lib--check_remote_http http://hub.darcs.net/kowey/tabular+. httplib -rm -rf temp temp2 temp3+# this should all work without a cache+if ! grep no-cache $HOME/.darcs/defaults; then+  echo ALL no-cache >> $HOME/.darcs/defaults+fi -darcs clone --lazy http://hub.darcs.net/kowey/tabular temp+rm -rf tabular+unpack_testdata tabular+serve_http # sets baseurl +rm -rf temp temp2 temp3+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- test -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2- cd .. -rm -rf temp temp2 temp3+# test if we can unapply patches after a tag+rm -rf temp4+darcs clone --lazy $baseurl/tabular temp4 --tag '^0.1$'+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 ..
tests/network/log.sh view
@@ -1,6 +1,7 @@ #!/usr/bin/env bash  . lib+. httplib  check_remote_http http://darcs.net
tests/network/show_tags-remote.sh view
@@ -24,6 +24,8 @@ ## SOFTWARE.  . lib                           # Load some portability helpers.+. httplib+ darcs init      --repo R        # Create our test repos. darcs init      --repo S
tests/network/ssh.sh view
@@ -7,12 +7,16 @@ . lib . sshlib +REMOTE_DARCS=$(which darcs)+ # ================ Setting up remote repositories =============== ${SSH} ${REMOTE} " rm -rf ${REMOTE_DIR} mkdir ${REMOTE_DIR} cd ${REMOTE_DIR} +PATH=$(dirname $REMOTE_DARCS):$PATH+ mkdir testrepo; cd testrepo darcs init echo moi > _darcs/prefs/author@@ -58,7 +62,7 @@ # ================ Checking darcs pull ================= darcs clone ${DARCS_SSH_FLAGS} testrepo testrepo-pull cd testrepo-pull-echo yyy | darcs pull ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-pull+darcs pull -a ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-pull # see if the changes got pulled over grep "other line" b @@ -72,10 +76,10 @@ darcs record --skip-long-comment a --ignore-times -am "add second line to a" touch c; darcs add c darcs record --skip-long-comment --ignore-times -am "add file c" c-echo yyy | darcs push ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-push+darcs push -a  --remote-darcs=$REMOTE_DARCS ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-push # check that the file c got pushed over ${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-push/c ]"-echo yyy | darcs send --no-edit-description ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-send -o mybundle.dpatch+darcs send -a --no-edit-description ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-send -o mybundle.dpatch # check that the bundle was created grep "add file c" mybundle.dpatch cd ..@@ -95,11 +99,11 @@ echo moi > _darcs/prefs/author echo 'change for remote' > a darcs record --skip-long-comment --ignore-times -am 'change for remote'-darcs push -a+darcs push -a --remote-darcs=$REMOTE_DARCS darcs ob --last 1 -a echo 'change for local' > a darcs record --skip-long-comment --ignore-times -am 'change for local'-darcs push -a > log 2>&1 || :+darcs push -a --remote-darcs=$REMOTE_DARCS > log 2>&1 || : grep -q 'conflicts options to apply' log  cd ..
tests/network/sshlib view
@@ -31,7 +31,8 @@      ${SSH} ${REMOTE} \         "rm -rf '${REMOTE_DIR}' && mkdir '${REMOTE_DIR}' && \-            cd '${REMOTE_DIR}' && darcs init --repo '$repodir' --$format"+            cd '${REMOTE_DIR}' && darcs init --repo '$repodir' --$format" \+        || exit 200 }  # test if we can connect via ssh, otherwise skip test
tests/oldfashioned.sh view
@@ -28,7 +28,7 @@ . lib                  # Load some portability helpers.  rm -rf old hashed-gunzip -c $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf -+unpack_testdata many-files--old-fashioned-inventory mv many-files--old-fashioned-inventory old  cd old@@ -95,7 +95,7 @@ ## issue1248 - darcs doesn't handle darcs 1 repos with compressed ## inventories -gunzip -c  $TESTDATA/oldfashioned-compressed.tgz | tar xf -+unpack_testdata oldfashioned-compressed cd oldfashioned-compressed darcs optimize upgrade darcs check
tests/optimize.sh view
@@ -3,22 +3,31 @@  # tests for "darcs optimize" -rm -rf temp1-mkdir temp1-cd temp1+## test that darcs optimize reorder works++rm -rf test1+mkdir test1+cd test1 darcs init touch foo-darcs add foo-darcs record -a -m add_foo-darcs optimize reorder| grep -i "done"+darcs record -a -m add_foo -l foo+darcs tag foo_tag+# check tag is initially clean+grep 'Starting with inventory' _darcs/hashed_inventory+touch bar+darcs record -a -m add_bar -l bar+# make the tag unclean+echo y | darcs amend -p foo_tag -a --author me+not grep 'Starting with inventory' _darcs/hashed_inventory+darcs optimize reorder | grep -i "done"+# check it is again clean+grep 'Starting with inventory' _darcs/hashed_inventory cd .. -rm -rf temp1- ## issue2388 - optimize fails if no patches have been recorded -darcs init temp1-cd temp1+rm -rf test2+darcs init test2+cd test2 darcs optimize clean cd ..-rm -rf temp1
tests/patch-index-creation.sh view
@@ -58,14 +58,14 @@ cd ..  rm -rf repo repo2-gunzip -c $TESTDATA/simple-v1.tgz | tar xf -+unpack_testdata simple-v1 echo 'I understand the consequences of my action' | 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-gunzip -c $TESTDATA/simple-v1.tgz | tar xf -+unpack_testdata simple-v1 echo 'I understand the consequences of my action' | 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/patch-index-released.sh view
@@ -9,7 +9,7 @@ # time of writing was the version in use in the last released # version of darcs. -tar -xz < $TESTDATA/patch-index-v2.tgz+unpack_testdata patch-index-v2  cd pi
tests/pull.sh view
@@ -125,7 +125,7 @@  # issue662, which triggered: #  darcs failed:  Error applying hunk to file ./t.t-#  Error applying patch to the working directory.+#  Error applying patch to the working tree.  darcs init temp1 cd temp1@@ -140,7 +140,8 @@ cd temp2 darcs obliterate --last 1 --all echo 'content: local change'> t.t-darcs pull -a ../temp1+# this is now recognized as a conflict with working:+echo y | darcs pull -a ../temp1 darcs w -s darcs revert -a cd ..@@ -315,7 +316,13 @@ cd temp2 echo yny | darcs pull --set-default ../temp1 rm foo-darcs pull -a+# for darcs-1 and darcs-3 this pull conflicts with unrecorded changes+# (which is correct, whereas darcs-2 is buggy)+if test "$format" != "darcs-2"; then+  echo y | darcs pull -a+else+  darcs pull -a+fi cd ..  rm -rf temp1 temp2
tests/rebase-apply.sh view
@@ -54,7 +54,8 @@ echo yyy | darcs rebase apply -a ../R2/2.dpatch  darcs changes --count 2>&1 | grep "Rebase in progress: 2 suspended patches"-echo yny | darcs rebase unsuspend | grep "We have conflicts"+echo yny | darcs rebase unsuspend 2>log+grep conflicts log cat > expected <<EOF v v v v v v v 1@@ -69,7 +70,8 @@ echo 23 > foo echo yyy | darcs amend --patch '3' -echo yy | darcs rebase unsuspend | grep "We have conflicts"+echo yy | darcs rebase unsuspend 2>log+grep conflicts log cat > expected <<EOF v v v v v v v 3
+ tests/rebase-changes-partial-conflict.sh view
@@ -0,0 +1,47 @@+#!/bin/sh -e++# Check that rebase changes correctly identifies which+# parts of a change are in conflict and which aren't++. lib++rm -rf R+mkdir R+cd R+darcs init++echo contents1A > file1+echo contents2A > file2+echo contents3A > file3+echo contents4A > file4+darcs rec -lam "init"++echo contents1B > file1+echo contents3B > file3+darcs rec -am "change 1"++echo contents2B > file2+echo contents4B > file4+darcs rec -am "change 2"++echo contents1C > file1+echo contents2C > file2+echo contents3C > file3+echo contents4C > file4+darcs rec -am "change 3"++# suspend change 3 and obliterate change 2+# this should leave change 3 with fixups+echo "yd" | darcs rebase suspend+echo "yd" | darcs obliterate++darcs rebase changes -s | grep "M ./file1"+darcs rebase changes -s | grep "M\! ./file2"+darcs rebase changes -s | grep "M ./file3"+darcs rebase changes -s | grep "M\! ./file4"++# this is what we expect to appear in the "conflicts" section+darcs rebase changes --verbose | not grep "contents1A"+darcs rebase changes --verbose | grep "contents2A"+darcs rebase changes --verbose | not grep "contents3A"+darcs rebase changes --verbose | grep "contents4A"
+ tests/rebase-changes.sh view
@@ -0,0 +1,40 @@+#!/bin/sh -e++# Basic test for rebase changes++. lib++rm -rf R+mkdir R+cd R+darcs init++echo 'first' > file+darcs rec -lam 'change 1'++echo 'second' > file+darcs rec -am 'change 2'++echo 'third' > file+darcs rec -am 'change 3'++# suspend change 3+echo 'yd' | darcs rebase suspend++darcs rebase changes | grep "change 3"+darcs rebase changes -s | grep "M ./file"+darcs rebase changes --verbose | grep "third"+# we shouldn't see any sign of change 1 or change 2+darcs rebase changes --verbose | not grep "first"++# this turns change 2 into a fixup, so+# subsequence rebase changes should report conflicts+echo 'yd' | darcs obliterate++darcs rebase changes | grep "change 3"+darcs rebase changes -s | grep "M\! ./file"+darcs rebase changes --verbose | grep "third"+# now we should see a conflict with change 2+# which removes the line "first"+darcs rebase changes --verbose | grep "first"+darcs rebase changes --verbose | grep "conflicts:"
+ tests/rebase-conflict-resolution.sh view
@@ -0,0 +1,57 @@+#!/usr/bin/env bash++# test that we can suspend a conflict plus its resolution, then unsuspend them+# and not get any conflicts+. lib++rm -rf R S R-oneatatime R-bothtogether++darcs init R++cd R+echo 'initial content' > f+darcs rec -lam "initial content"+cd ..++darcs clone R S++cd R+echo 'content1' > f+darcs rec -am "content1"+cd ..++cd S+echo 'content2' > f+darcs rec -am "content2"+cd ..++cd R+darcs pull --allow-conflicts -a ../S+echo 'content12' > f+darcs rec -am "content12 (resolution)"++echo yyd | darcs rebase suspend+cd ..++cp -r R R-oneatatime+cp -r R R-bothtogether++cat > f.expected << END+content12+END++cd R-oneatatime+echo yd | darcs rebase unsuspend+ # get rid of conflict markers, since in this case darcs hasn't seen the resolution patch yet+darcs rev -a+echo yd | darcs rebase unsuspend++diff -u ../f.expected f+cd ..++cd R-bothtogether+echo yyd | darcs rebase unsuspend+# this time there shouldn't be any conflict markers in the first place, as the resolution was+# unsuspended at the same time+diff -u ../f.expected f+cd ..
+ tests/rebase-conflict-upgrade.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash++## Test that we can upgrade an old-style rebase repo+## where the suspended patch had a conflict++. lib++rm -rf R log+unpack_testdata old-style-rebase-conflict++cd R+darcs rebase upgrade+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log+cd ..
+ tests/rebase-conflicting-threeeway.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++. lib++rm -rf R S T++darcs init R+cd R+touch f+darcs record -l f -a -m 'baseline'+darcs clone . ../S+darcs clone . ../T+echo R > f+darcs record -l f -a -m 'hunk R'+cd ../S+echo S > f+darcs record -l f -a -m 'hunk S'+cd ../T+echo T > f+darcs record -l f -a -m 'hunk T'+cd ../R+darcs pull -a --allow-conflicts ../S ../T+# echo X > f+# darcs record -l f -a -m 'resolve conflicts'+cd ../S+darcs pull -a ../R --allow-conflicts+cd ../R+darcs log -v > ../before_rebase+darcs rebase suspend -a+cp _darcs/rebase ..+darcs rebase unsuspend -a+darcs log -v > ../after_rebase+cd ..
tests/rebase-move.sh view
@@ -40,8 +40,10 @@ darcs mv wibble wobble echo 'y' | darcs amend -a --patch 'wibble' # there shouldn't be any conflicts-echo 'yy' | darcs rebase unsuspend # | not grep "We have conflicts"+echo 'yy' | darcs rebase unsuspend 2>&1 | not grep conflicts+# we expect the only file to be wobble, containing 'wobble'. not darcs wh--+not test -f wibble+echo wobble > wobble.expected+diff -u wobble.expected wobble
+ tests/rebase-new-style.sh view
@@ -0,0 +1,76 @@+#!/usr/bin/env bash+## Test that all operations except 'rebase upgrade' on old-style+## rebase-in-progress repos fail++. lib++rm -rf R S T log+unpack_testdata old-style-rebase+darcs init S+echo ../S > R/_darcs/prefs/defaultrepo++not darcs clone R T 2>&1 | tee log+grep 'clone a repository with an old-style rebase' log++# TODO for this test I need a tar ball with a darcs-1 repo in it+# not darcs convert darcs-2 R T 2>&1 | tee log+# grep 'old-style rebase is in progress' log++# init, help, and convert import are not an issue++IFS='+'+commands='+record+push+pull+log+diff+show contents f1+show dependencies+show files+show index+show pristine+show repo+show authors+show tags+show patch-index+amend+rebase pull+rebase apply+rebase suspend+rebase unsuspend+rebase obliterate+rebase log+rebase reify+rebase inject+rebase changes+unrecord+obliterate+tag+send+apply+optimize clean+optimize http+optimize reorder+optimize enable-patch-index+optimize disable-patch-index+optimize compress+optimize uncompress+optimize relink+optimize pristine+mark-conflicts+repair+convert export+fetch'++cd R+for cmd in $commands; do+  unset IFS+  not darcs $cmd 2>&1 | tee ../log+  grep 'old-style rebase is in progress' ../log+done+darcs rebase upgrade+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log+cd ..
+ tests/rebase-old-style-not-head.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash++## Test that we can upgrade an old-style rebase repo where the+## special rebase container patch is not at the head of the repo++. lib++rm -rf R log+unpack_testdata old-style-rebase-not-head++cd R+darcs rebase upgrade+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log+echo yd | darcs rebase unsuspend++# check that the suspended patch was properly commuted+# with the patch that was added after it was suspended+cat > file.expected << EOF+1+2+3+A+B+C2+D+EOF+diff -u file.expected file++cd ..
tests/rebase-pull.sh view
@@ -53,7 +53,8 @@ echo yyy | darcs rebase pull -a ../R2  darcs changes --count 2>&1 | grep "Rebase in progress: 2 suspended patches"-echo yny | darcs rebase unsuspend | grep "We have conflicts"+echo yny | darcs rebase unsuspend 2>log+grep conflicts log cat > expected <<EOF v v v v v v v 1@@ -68,7 +69,8 @@ echo 23 > foo echo yyy | darcs amend --patch '3' -echo yy | darcs rebase unsuspend | grep "We have conflicts"+echo yy | darcs rebase unsuspend 2>log+grep conflicts log cat > expected <<EOF v v v v v v v 3
tests/rebase-remote.sh view
@@ -1,7 +1,7 @@ #!/bin/sh -e ##-## Test that remote operations on rebase-in-progress repos fail-## or ignore the rebase patch+## Test that remote operations on rebase-in-progress repos do /not/ fail+## but ignore the rebase patch ## ## Copyright (C) 2012-3 Ganesh Sittampalam ##@@ -32,19 +32,22 @@ cd R1 darcs init echo '1' > foo-darcs rec -lam "add foo"+darcs rec -lam "normal patch" echo '2' > foo-darcs rec -am "change foo"+darcs rec -am "suspended patch" echo yny | darcs rebase suspend cd .. -not darcs get R1 R2-+darcs get R1 R2+cd R2+# this fails because there is no rebase in progress+not darcs rebase unsuspend+cd ..  mkdir R3 cd R3 darcs init-not darcs pull -a ../R1 2>&1 | grep "Cannot transfer patches from a repository where a rebase is in progress"+darcs pull -a ../R1 2>&1 cd ..  mkdir R4@@ -53,6 +56,7 @@ cd ../R1 darcs push -a ../R4 cd ../R4+# this fails because there is no rebase in progress not darcs rebase unsuspend cd .. @@ -62,6 +66,6 @@ cd ../R1 darcs send -a ../R5 -o bundle.dpatch not grep "DO NOT TOUCH" bundle.dpatch-grep "add foo" bundle.dpatch-not grep "change foo" bundle.dpatch+grep "normal patch" bundle.dpatch+not grep "suspended patch" bundle.dpatch cd ..
tests/rebase-repull.sh view
@@ -32,11 +32,47 @@ darcs init echo 'wibble' > wibble darcs rec -lam "add wibble"+darcs tag bla cd .. +# suspend, repull, rebase obliterate++rm -rf R1+darcs get R R1++cd R1+echo yy | darcs rebase suspend+echo yy | darcs rebase suspend+echo yd | darcs pull ../R+echo yd | darcs rebase obliterate+echo yd | darcs rebase obliterate+cd ..++# issue2445: suspend, repull, unsuspend++rm -rf R2 darcs get R R2 -cd R-echo 'yy' | darcs rebase suspend-darcs pull -a ../R2-echo 'yy' | darcs rebase obliterate+cd R2+echo yy | darcs rebase suspend+echo yy | darcs rebase suspend+echo yd | darcs pull -a ../R+echo yd | darcs rebase unsuspend --allow-conflicts+echo yd | darcs pull -a ../R+echo yd | darcs rebase unsuspend+cd ..++# suspend, repull, suspend again, unsuspend++rm -rf R3+darcs get R R3++cd R3+echo yy | darcs rebase suspend+echo yy | darcs rebase suspend+echo yd | darcs pull -a ../R+echo yd | darcs pull -a ../R+echo yy | darcs rebase suspend+echo yy | darcs rebase suspend+echo wwyd | darcs rebase unsuspend+cd ..
+ tests/rebase-simple-conflict.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash++# Test for rebasing a conflict where we don't remove+# patches that are part of the conflict++. ./lib++rm -rf R S+darcs init R+cd R++echo 'initial' > file+darcs rec -lam 'initial'++cd ..+darcs clone R S+cd R++echo 'contentsA' > file+darcs rec -lam 'A'++cd ../S+echo 'contentsB' > file+darcs rec -lam 'B'++cd ../R+darcs pull ../S --mark-conflicts -a+# save the expected conflict markup+cp file file.expected+darcs rev -a # get rid of the markup+echo 'ydy' | darcs rebase suspend+echo 'yd' | darcs rebase unsuspend++diff -u file.expected file++
+ tests/rebase-successive-amends.sh view
@@ -0,0 +1,25 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R+echo A > file+darcs add file+darcs record file -am A+echo B > file+darcs record file -am B+echo C > file+darcs record file -am C+darcs rebase suspend -a -p C+echo B1 > file+echo yd | darcs amend -am B1+echo B2 > file+echo yd | darcs amend -am B2+echo B3 > file+echo yd | darcs amend -am B3+cp _darcs/rebase ../1-before-unsuspend+darcs rebase unsuspend -a 2>../log+grep conflicts ../log+cd ..
tests/record.sh view
@@ -54,10 +54,13 @@  # refuse empty patch name export DARCS_EDITOR="cat -n"-date >> date.t-echo "patchname" | darcs record -a -m ""  | grep WARNING-date >> date.t-darcs record -a -m "some name"+echo "patchname" | not darcs record -a -m ""+not darcs record -a -m ""++# refuse patch name starting with "TAG "+export DARCS_EDITOR="cat -n"+echo "patchname" | not darcs record -a -m "TAG fake"+not darcs record -a -m "TAG fake"  cd .. rm -rf temp1
tests/remove.sh view
@@ -61,4 +61,16 @@ darcs remove * -r  cd ..++# but never allow to remove the root directory itself+ rm -rf temp1+darcs init temp1+cd temp1+not darcs remove .+mkdir x+darcs add x+cd x+not darcs remove ..+cd ..+cd ..
tests/repair.sh view
@@ -4,7 +4,6 @@ rm -rf temp1 darcs init temp1 cd temp1-echo ALL ignore-times >> _darcs/prefs/defaults echo A1 > foo mkdir d echo A2 > d/bar@@ -22,11 +21,18 @@  darcs repair +# 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"+done+ cd ..-rm -rf temp1  # issue1977: repair complains when there is no pristine.hashed directory +rm -rf temp1 darcs init temp1 cd temp1 echo "a" > a@@ -34,19 +40,28 @@ rm -rf _darcs/pristine.hashed/ darcs repair cd ..-rm -rf temp1  # check that repair doesn't do anything to a clean repository++rm -rf temp1 darcs init temp1 cd temp1 touch baz darcs record -lam moo darcs repair | grep 'already consistent' cd ..-rm -rf temp1 +# We cannot currently implement repair for the darcs-3 format+# because that risks inconsistencies in conflictors that refer+# to removed or added prims. Fixing this requires refactoring+# the API for patch repair and is therefore postponed.++# START DISABLED TESTS for darcs-3+if test "$format" != darcs-3; then+ # test that we can repair incorrect adds +rm -rf temp1 darcs init temp1 cd temp1 @@ -70,9 +85,19 @@ darcs repair darcs check cd ..-rm -rf temp1 +# END DISABLED TESTS for darcs-3+fi++# These tests should be fixed but this is hard, since 'darcs record'+# no longer allows recording patches with invalid file paths.++# START DISABLED TESTS+if false; then+ # test for repair of a corrupt repository ++rm -rf temp1 darcs init temp1 cd temp1 @@ -133,12 +158,15 @@ not darcs check darcs repair darcs check+ cd .. -rm -rf temp1+# END DISABLED TESTS+fi  # issue2001: check (alias for repair --dry-run) is not read-only  +rm -rf temp1 darcs init temp1 cd temp1 mkdir d e@@ -151,4 +179,3 @@ not darcs check diff -r _darcs archive cd ..-rm -rf temp1
tests/repoformat.sh view
@@ -16,14 +16,17 @@ touch titi darcs add titi darcs record -am titi-cat > _darcs/format <<EOF-hashed|gobbledygook-darcs-2-EOF+sed -i 's/hashed/hashed|gobbledygook/' _darcs/format cd .. +corrupt_format_file() {+  # mimic format file corruption as in issue2650+  sed -i 's/gobbledygook/Unknown format: gobbledygook/' future/_darcs/format+}+ # check the rules for reading and writing +test_garbage() { ## garbage repo: we don't understand anything rm -rf temp1 not darcs get garbage temp1 2> log@@ -65,14 +68,23 @@ # issue2650 not grep 'Unknown format' _darcs/format cd ..+} +test_garbage +# corrupt once+corrupt_format_file+test_garbage+# corrupt multiple times+corrupt_format_file+corrupt_format_file+test_garbage++ ## future repo: we don't understand one #  alternative of a line of format-#  only look at future vs darcs2 -skip-formats darcs-1-+test_future () { # get future repo: ok # --to-match is needed because of bug### rm -rf temp1@@ -121,3 +133,14 @@ # issue2650 not grep 'Unknown format' _darcs/format cd ..+}++test_future++# corrupt once+corrupt_format_file+test_future+# corrupt multiple times+corrupt_format_file+corrupt_format_file+test_future
+ tests/resolve-conflicts-explicitly.sh view
@@ -0,0 +1,67 @@+# Test that we can resolve a conflict by explicitly depending on+# the conflicting patches, thereby accepting the "default" resolution+# (i.e. not to apply both) as correctly resolving the conflict.++. lib++rm -rf R S+darcs init R+cd R+touch file+darcs record -lam baseline+echo one > file+darcs record -a -m one+darcs clone . ../S+echo two > file+echo y | darcs amend -a -m two+darcs pull -a --allow-conflicts ../S+# make sure we have none of the changes:+test -z "$(cat file)"+# resolve by depending on the last two patches:+echo yyd | darcs record --ask-deps -m resolve_explicitly+darcs mark-conflicts > LOG 2>&1+grep "No conflicts" LOG+not darcs whatsnew+cd ..++# Test that an explicit dependency on a patch containing a+# partial conflict resolution does not turn it into a resolution+# of an unrelated conflict contained the same patch.++rm -rf R S+darcs init R+cd R+touch file1+touch file2+darcs record -lam baseline+echo one > file1+echo one > file2+darcs record -am one+darcs clone . ../S+echo two > file1+echo two > file2+echo y | darcs amend -a -m two+darcs pull -a --allow-conflicts ../S+# make sure we have none of the changes:+test -z "$(cat file1)"+test -z "$(cat file2)"+# resolve (only) the conflict in file1+echo three > file1+darcs record -a -m resolve_file1+# test this indeed resolves only the conflict in file1+darcs mark-conflicts > LOG 2>&1+grep 'Marking conflicts' LOG+grep 'file2' LOG+not grep 'file1' LOG+not darcs whatsnew file1+# remove the markup+darcs revert -a+# explicitly depend on the partial resolution+echo yyd | darcs record --ask-deps -m explicit+# test resolution is still only partial+darcs mark-conflicts > LOG 2>&1+grep 'Marking conflicts' LOG+grep 'file2' LOG+not grep 'file1' LOG+not darcs whatsnew file1+cd ..
tests/send-output-v1.sh view
@@ -26,7 +26,7 @@  . lib                  # Load some portability helpers. -skip-formats darcs-2+only-format darcs-1  rm -rf empty mkdir empty@@ -35,7 +35,7 @@ cd ..  rm -rf repo-gunzip -c $TESTDATA/simple-v1.tgz | tar xf -+unpack_testdata simple-v1 cd repo darcs send --no-minimize -o repo.dpatch -a ../empty @@ -45,7 +45,7 @@  # context-v1 tests that we are including some context lines in hunk patches rm -rf repo-gunzip -c $TESTDATA/context-v1.tgz | tar xf -+unpack_testdata context-v1 cd repo darcs send --no-minimize -o repo.dpatch -a ../empty day=$(grep "Date: " $TESTDATA/context-v1.dpatch | head -n 1 | cut -f1-3 -d' ')
tests/send-output-v2.sh view
@@ -26,7 +26,7 @@  . lib                  # Load some portability helpers. -skip-formats darcs-1+only-format darcs-2  rm -rf empty mkdir empty@@ -35,7 +35,7 @@ cd ..  rm -rf repo-gunzip -c $TESTDATA/simple-v2.tgz | tar xf -+unpack_testdata simple-v2 cd repo darcs send --no-minimize -o repo.dpatch -a ../empty @@ -45,7 +45,7 @@  # context-v1 tests that we are including some context lines in hunk patches rm -rf repo-gunzip -c $TESTDATA/context-v2.tgz | tar xf -+unpack_testdata context-v2 cd repo darcs send --no-minimize -o repo.dpatch -a ../empty
tests/send.sh view
@@ -33,20 +33,26 @@  # Test that the --output-auto-name parameter outputs what we expect darcs send --author=me -a --subject="it works" --output test1.dpatch ../temp2-darcs send --author=me -a --subject="it works" --output-auto-name ../temp2-cmp test1.dpatch add_foo_bar.dpatch+# explicitly given output filename overwrites an existing file+darcs send --author=me -a --subject="it works" --output test1.dpatch ../temp2 > LOG+grep "Wrote patch to" LOG | grep -F test1.dpatch+# but --output-auto-name never does+darcs send --author=me -a --subject="it works" --output-auto-name ../temp2 > LOG+name=$(grep "Wrote patch to" LOG | grep -ho 'add_foo_bar.*\.dpatch')+cmp test1.dpatch "$name"  # test --output-auto-name works with optional argument. mkdir patchdir-darcs send --author=me -a --subject="it works" --output-auto-name=patchdir ../temp2-cmp test1.dpatch patchdir/add_foo_bar.dpatch+darcs send --author=me -a --subject="it works" --output-auto-name=patchdir ../temp2 > LOG+name=$(grep "Wrote patch to" LOG | grep -ho 'patchdir/add_foo_bar.*\.dpatch')+cmp test1.dpatch "$name"  # checking --output-auto-name=dir when run in different directory cd patchdir-rm add_foo_bar.dpatch-darcs send --author=me -a --subject="it works" --output-auto-name=. ../../temp2-cmp ../test1.dpatch add_foo_bar.dpatch+rm add_foo_bar*.dpatch+darcs send --author=me -a --subject="it works" --output-auto-name=. ../../temp2 > LOG+name=$(grep "Wrote patch to" LOG | grep -ho 'add_foo_bar.*\.dpatch')+cmp ../test1.dpatch "$name" cd ..  cd ..-rm -rf temp1 temp2
tests/show_contents.sh view
@@ -22,7 +22,7 @@ darcs show contents foo --match="author author1" first | grep first darcs show contents foo --tag t1 | grep second not darcs show contents foo --match "hash bla" 2>&1 | tee out-grep "Couldn't match pattern" out+grep '"hash bla"' out darcs show contents -n 2 foo | grep third cd ..
tests/split-patches.sh view
@@ -35,7 +35,7 @@ else exit 200; fi  rm -rf split--${format}-gunzip -c $TESTDATA/split--${format}.tgz | tar xf -+unpack_testdata split--${format} cd split--${format} darcs check cd ..
tests/three_way_conflict.sh view
@@ -25,10 +25,10 @@ echo C > foo darcs record -a -A author -m CC -darcs pull -a ../temp2-darcs pull -a ../temp3+darcs pull -a ../temp2 --allow-conflicts+darcs pull -a ../temp3 --allow-conflicts  cd ../temp2-darcs pull -a ../temp3-darcs pull -a ../temp1+darcs pull -a ../temp3 --allow-conflicts+darcs pull -a ../temp1 --allow-conflicts rm -rf temp1 temp2 temp3
+ tests/unrevert-may-conflict.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash++# 'darcs unrevert' may result in a conflict: revert a change,+# record another change that conflicts with what was reverted,+# then unrevert.+# This was originally thought to be a bug (issue2609) but really+# is normal, expected behavior.++. lib++rm -rf R++darcs init R+cd R+echo A > f+darcs record -lam A f+echo V > f+darcs revert -a+echo B > f+darcs record -lam B f+darcs unrevert -a 2>&1 | tee unrevert_log+grep conflicts unrevert_log+cd ..
tests/v1-braced.sh view
@@ -26,10 +26,10 @@  . lib                  # Load some portability helpers. -skip-formats darcs-2+only-format darcs-1  rm -rf braced-gunzip -c $TESTDATA/braced.tgz | tar xf -+unpack_testdata braced cd braced darcs check cd ..
tests/workingdir.sh view
@@ -58,7 +58,7 @@ darcs get temp1 temp2 --tag 1 cd temp2 echo 2-b2 > b-darcs pull -a+echo y | darcs pull -a grep "v v v" b grep "2-b2"  b.~0~ not grep "v v v" b.~0~