packages feed

darcs-beta 2.2.98.4 → 2.3.98.1

raw patch · 252 files changed

+13514/−10619 lines, 252 filesdep ~arraydep ~containersdep ~hashed-storagesetup-changednew-uploaderbinary-added

Dependency ranges changed: array, containers, hashed-storage, unix

Files

Distribution/ShellHarness.hs view
@@ -4,16 +4,18 @@ import Prelude hiding( catch ) import System.Directory ( getCurrentDirectory, setPermissions,                           Permissions(..), getDirectoryContents,-                          findExecutable, createDirectoryIfMissing )+                          findExecutable, createDirectoryIfMissing,+                          renameFile, removeFile ) import System.Environment ( getEnv, getEnvironment ) import System.Exit ( ExitCode (..) ) import System.FilePath import System.IO+import System( system ) import System.Process ( ProcessHandle,                         runInteractiveProcess, waitForProcess,                         getProcessExitCode ) import Data.Maybe-import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy )+import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy, isSuffixOf ) import Control.Concurrent #if __GLASGOW_HASKELL__ >= 610 import Control.OldException@@ -40,12 +42,15 @@                          return True  run :: Maybe FilePath -> [String] -> IO [String]-run set_darcs_path tests= do+run set_darcs_path tests = do     cwd <-  getCurrentDirectory     path <- getEnv "PATH"     env <- getEnvironment+    bash <- find_bash     darcs_path <- case set_darcs_path of-                    Nothing -> get_darcs_path+                    Nothing -> case lookup "DARCS" env of+                                 Nothing -> return (cwd ++ "/..")+                                 Just d  -> return $ takeDirectory d                     Just x -> return x     let myenv = [("HOME",cwd)                 ,("TESTS_WD",cwd)@@ -55,40 +60,48 @@                 ,("PATH",(darcs_path++":"++path))                 ,("DARCS_DONT_COLOR","1")                 ,("DARCS_DONT_ESCAPE_ANYTHING","1")]-    bash <- find_bash-    let shell = takeWhile (/= '\n') bash+        shell = takeWhile (/= '\n') bash     putStrLn $ "Using bash shell in '"++shell++"'"-    set_prefs+    catch (appendFile (".darcs/defaults") "\nALL --ignore-times\n")+          (\e -> fail $ "Unable to set preferences: " ++ show e)     run_helper shell tests []  (set_env myenv env)-  where get_darcs_path = do-           env <- getEnvironment-           cwd <-  getCurrentDirectory-           case lookup "DARCS" env of-                Nothing -> return (cwd ++ "/..")-                Just d  -> return $ takeDirectory d-        set_prefs = do-            finally (catch (appendFile ".darcs/defaults" "\nALL --ignore-times\n")-                           (\e -> fail $ "Unable to set preferences: "-                                         ++ show e))-                    (createDirectoryIfMissing  False ".darcs")++data Status = Success | Failed | Skipped+ run_helper :: String -> [String] -> [String] ->                   [(String,String)] -> IO [String] run_helper _ [] fails _ = return fails run_helper shell (test:ts) fails env = do     putStr $ "Running " ++ test ++ " ..." ++ (replicate (36 - (length test)) ' ')-    (output,success) <- backtick shell test env-    if success then do putStrLn " passed."-                       cleanup_dirs-                       run_helper shell ts fails env-               else do putStrLn " failed."-                       putStrLn $ "Probable reason :" ++ output-                       cleanup_dirs-                       run_helper shell ts (fails++[test]) env-  where cleanup_dirs :: IO ()-        cleanup_dirs =+    (output,result) <- backtick shell test env+    cleanup+    case result of+      Skipped -> do putStrLn " skipped."+                    run_helper shell ts fails env+      Success -> do putStrLn " passed."+                    run_helper shell ts fails env+      Failed -> do putStrLn " failed."+                   putStrLn $ "Probable reason :" ++ output+                   run_helper shell ts (fails++[test]) env+  where cleanup :: IO ()+        cleanup =           do dirfiles <- getDirectoryContents (fromJust $ lookup "TESTS_WD" env)              let tempfiles = (filter ("temp" `isPrefixOf`) dirfiles) ++                              (filter ("tmp" `isPrefixOf`) dirfiles)+             when (isJust $ lookup "HPCTIXDIR" env) $ do+                 let tixdir = fromJust $ lookup "HPCTIXDIR" env+                 tixlist <- getDirectoryContents tixdir+                 oldsum <- if ("sum.tix" `elem` tixlist)+                              then do renameFile (tixdir </> "sum.tix")+                                                 (tixdir </> "oldsum.tix")+                                      return [tixdir </> "oldsum.tix"]+                              else return []+                 let tixfiles = oldsum ++ [ tixdir </> f | f <- tixlist+                                                         , "darcs-" `isPrefixOf` f+                                                         , ".tix" `isSuffixOf` f ]+                 system $ "hpc sum --union --output=" ++ tixdir </> "sum.tix" ++ " " ++ unwords tixfiles+                 forM tixfiles $ \f -> removeFile f+                 return ()              mapM_ (\x->                    setPermissions x (Permissions                                     {readable = True@@ -98,12 +111,13 @@                                    )                  ) tempfiles -backtick :: String -> String -> [(String, String)]-> IO (String,Bool)+backtick :: String -> String -> [(String, String)]-> IO (String,Status) backtick cmd args env = do    (exitcode,res) <- backtick_helper cmd args env    case exitcode of-        ExitSuccess -> return (res, True)-        ExitFailure _ -> return (res, False)+        ExitSuccess -> return (res, Success)+        ExitFailure 200 -> return (res, Skipped)+        ExitFailure _ -> return (res, Failed)  backtick_helper :: String -> String -> [(String,String)] ->                                       IO (ExitCode, String)
+ GNUmakefile view
@@ -0,0 +1,62 @@+### XXX we eventually want building of the manual to be part of Setup.lhs++# hardcode some bits+RUBBER=rubber++PREPROC=./dist/build/darcs/darcs --preprocess-manual+PREPROCHTML=--html+TEXSOURCES = src/darcs.tex $(wildcard src/*.tex) $(filter %.lhs,$(DARCS_FILES))+doc/manual/*.tex: dist/build/darcs/darcs+doc/manual/darcs.tex: $(TEXSOURCES)+	$(PREPROC) darcs.tex $(PREPROCHTML) >$@+doc/manual/darcs_print.tex: $(TEXSOURCES)+	$(PREPROC) darcs.tex >$@+doc/manual/patch-theory.tex: $(TEXSOURCES) $(UNIT_FILES)+	$(PREPROC) Darcs/Patch/Properties.lhs >$@++%.pdf: %.tex+	cd $(<D) && $(RUBBER) --pdf $(<F)+%.ps: %.tex+	cd $(<D) && $(RUBBER) --ps $(<F)++ps pdf: %: doc/manual/darcs.% doc/manual/patch-theory.%+html: doc/manual/index.html+website: ps pdf html doc/manual/bigpage.html++### TODO use latex2html since bigpage seems to needslatex2html anyway;+###      we can restore hevea/tex4ht support when we move this to Setup.lhs+doc/manual/index.html: doc/manual/darcs.tex src/gpl.tex doc/darcs.css+	latex2html -split +1 -dir doc/manual doc/manual/darcs.tex+	cp -f doc/darcs.css doc/manual/darcs.css++doc/manual/bigpage.html: doc/manual/darcs.tex src/gpl.tex doc/darcs.css+	ln -sf darcs.tex doc/manual/bigpage.tex+	latex2html -split 0 -external_file darcs -prefix big \+		-no_auto_link -dir doc/manual doc/manual/bigpage.tex+	cp -f doc/darcs.css doc/manual/bigpage.css++doc/manual/darcs.ps: doc/manual/darcs_print.ps+	cp $< $@+doc/manual/darcs.pdf: doc/manual/darcs_print.pdf+	cp $< $@++# Good for tags.+DARCS_FILES = $(wildcard src/[A-Z]*.hs src/*/[A-Z]*.hs src/*/*/[A-Z]*.hs) \+	      $(wildcard src/[A-Z]*.lhs src/*/[A-Z]*.lhs src/*/*/[A-Z]*.lhs)++tags: $(DARCS_FILES) src/*.c+	hasktags -c $(filter %.lhs %.hs,$^)+	ctags -a $(filter %.c,$^)++# TAGS is for etags, whereas tags is for ctags+TAGS: $(DARCS_FILES) src/*.c+	hasktags -e $(filter %.lhs %.hs,$^)+	etags -a $(filter %.c,$^)++clean:+	rm -f TAGS tags+	rm -f doc/manual/bigpage.tex+	rm -f doc/manual/*.html doc/manual/darcs*.??? doc/manual/darcs.lg+	rm -f doc/manual/darcs.xref c_context.c doc/darcs_print.ps++.PHONY: ps pdf html clean website
+ NEWS view
@@ -0,0 +1,2339 @@+Darcs 2.3.1, 20 Sep 2009++ * Important changes in Darcs 2.3.1++   * Fix bugs introduced by optimizations in 2.3.0 (Petr, Salvatore)+   * Documentation improvements (Taylor, Trent)+   * Remove autoconf build system (Petr)++ * Bugs Fixed in Darcs 2.3.1++   See http://bugs.darcs.net/issueN for details on bug number N.++   * issue1373 darcs manual wrongly promises [^ ] is a valid token spec (Trent)+   * issue1478: document summary mnemonics (Trent)+   * issue1582 DeleteFile: permission denied (Access is denied.) (Salvatore)+   * issue1507 whatsnew does not use 'current' when 'pristine' is missing (Petr)+++Darcs 2.3.0, 23 Jul 2009++ * Important changes in Darcs 2.3.0++   * Lots and lots of documentation changes (Trent).+   * Haskeline improvements (Judah).+   * Cabal as default buildsystem (many contributors).+   * Fixes in darcs check/repair memory usage (Bertram, David).+   * Performance improvement in subtree record (Reinier).+   * New option: --summary --xml (Florian Gilcher).+   * New option: changes --max-count (Eric and Petr).+   * Fix changes --only-to-files for renames (Dmitry).+   * Performance fix in "darcs changes" (Benedikt).+   * Hardlinks on NTFS (Salvatore).+   * Coalesce more changes when creating rollbacks (David).+   * New unit test runner (Reinier).+   * Inclusion of darcs-shell in contrib (László, Trent).+   * Author name/address canonisation: .authorspellings (Simon).+   * Working directory index and substantial "darcs wh" optimisation (Petr).+   * New command: "darcs show index" (Petr).+   * Gzip CRC check and repair feature (Ganesh).++ * Bugs Fixed in Darcs 2.3.0++   See http://bugs.darcs.net/issueN for details on bug number N.++   *  948 darcsman (Trent)+   * 1206 countable nouns (Trent)+   * 1285 cabal test v. cabal clean (Trent)+   * 1302 use resolved, not resolved-in-unstable (Trent)+   * 1235 obliterate --summary (Rob)+   * 1270 no MOTD for --xml-output (Lele)+   * 1311 cover more timezones (Dave)+   * 1292 re-encoding haskeline input (Judah)+   * 1313 clickable ToC and refs in PDF manual Trent)+   * 1310 create merged \darcsCommand{add} (Trent)+   * 1333 better "cannot push to current repository" warning (Petr)+   * 1347 (autoconf) check for unsafeMMapFile if mmap use enabled (Dave)+   * 1361 specify required includes for curl in cabal file (Reinier)+   * 1379 remove libwww support (Trent)+   * 1366 remove unreachable code for direct ncurses use (Trent)+   * 1271 do not install two copies of darcs.pdf (Trent)+   * 1358 encode non-ASCII characters in mail headers (Reinier)+   * 1393 swap "darcs mv" and "darcs move" (Trent)+   * 1405 improve discoverability of global author file (Trent)+   * 1402 don't "phone home" about bugs (Trent)+   * 1301 remove obsolete zsh completion scripts (Trent)+   * 1162 makeAbsolute is now a total function (Ben F)+   * 1269 setpref predist - exitcode ignored bug (Ben M)+   * 1415 --edit-long-comment, not --edit-description, in help (Trent)+   * 1413 remove duplicate documentation (Trent)+   * 1423 complain about empty add/remove (Trent)+   * 1437 Implement darcs changes --max-count (Eric)+   * 1430 lazy pattern matching in (-:-) from Changes command module (Dmitry)+   * 1434 refactor example test (Trent)+   * 1432 refer to %APPDATA%, not %USERPROFILE% (Trent)+   * 1186 give a chance to abort if user did not edit description file (Dmitry)+   * 1446 make amend-record -m foo replace only the patch name (Dmitry)+   * 1435 default to get --hashed from a darcs-1.0 source (Trent)+   * 1312 update and reduce build notes (Trent)+   * 1351 fix repository path handling on Windows (Salvatore)+   * 1173 support hard links on NTFS (Salvatore)+   * 1248 support compressed inventories for darcs-1 repos (Ganesh)+   * 1455 implement "darcs help environment" (Trent)+++Darcs 2.2.0, 16 Jan 2009++ * Important changes in Darcs 2.2.0++   * Support for GHC 6.10.+   * Improved Windows support.+   * Cabal is now supported as a build method for darcs.+   * Low-level optimisations in filesystem code.+   * Overhaul of the make-based build system.+   * Extensive manual and online help improvements.+   * Improved API documentation (haddock) for existing darcs modules.+   * Improvements in the testing infrastructure.+   * Improved performance for "darcs repair".+   * Improved robustness for "darcs check".+   * Numerous major and minor bug fixes, refactorings and cleanups.+   * When recording interactively it is now possible to list all+     currently selected hunks (command 'l').++   * It is now possible to specify --in-reply-to when using darcs send,+     to generate correct references in the mail header.++   * Repositories can no longer be created with --no-pristine-tree.+     This only affects the legacy darcs-1 repository format.++   * Experimental Darcs library, providing increase flexibility and+     efficiency to third-party utilities (compared to the command-line+     interface).  Only built via Cabal.  NOT a stable API yet.++ * Bugs Fixed in Darcs 2.2.0++   See http://bugs.darcs.net/issueN for details on bug number N.++   *  525 amend-record => darcs patches show duplicate additions+   *  971 darcs check fails (case sensitivity on filenames)+   * 1006 darcs check and repair do not look for adds+   * 1043 pull => mergeAfterConflicting failed in geteff (2.0.2+)+   * 1101 darcs send --cc recipient not included in success message+   * 1117 Whatsnew should warn on non-recorded files+   * 1144 Add darcs send --in-reply-to or --header "In-Reply-To:...+   * 1165 get should print last gotten tag+   * 1196 Asking for changes in /. of directory that doesn't exist...+   * 1198 Reproducible "mergeConflictingNons failed in geteff with ix"+   * 1199 Backup files darcs added after external merge+   * 1223 sporadic init.sh test failure (2.1.1rc2+472)+   * 1238 wish: darcs help setpref should list all prefs+   * 1247 make TAGS is broken+   * 1249 2.1.2 (+ 342 patches) local drive detection on Windows error+   * 1272 amend-record not the same as unrecord + record+   * 1273 renameFile: does not exist (No such file or directory)+   * 1223 sporadic init.sh test failure (2.1.1rc2+472)+++darcs (2.1.2)++ * Quality Assurance: Disable a new test that was not yet working+   under Windows++ -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 10:40:00 GMT++darcs (2.1.1)++ -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 08:18:00 GMT++darcs (2.1.1rc2)++  * Portability: Removed accidental QuickCheck 2.1 configure check.+    Note that it may be required in a future version of darcs.++ -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 11:17:00 GMT++darcs (2.1.1rc1)++  * Portability: GHC 6.10.1 support (Petr Ročkai, Eric Kow)++  * Bug Fix: Fix file handle leak and check for exceptions on process+    running on Windows (issue784, Salvatore Insalaco)++  * Quality Assurance: Consolidated regression test suites using+    shell scripts only (Eric Kow, Tommy Petterson, Matthias Kilian)++ -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 09:49:00 GMT++darcs (2.1.0)++  * Bug Fix: Eliminate a 'same URLs with different parameters' error when+    fetching files over HTTP (issue1131, Dmitry Kurochkin)++  * User Experience: Corrections to the default boring file (Ben Franksen)++  * Bug Fix: Fix the %a option in darcs send --sendmail-command (Ben Franksen)++  * Bug Fix: Do not obscure the SSH prompts or text editor output with+    progress reporting (issue1104, issue1109, Dmitry Kurochkin, David Roundy)++  * Bug Fix: pull --intersection work now works as advertised (Tommy+    Pettersson)++ -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 09 Oct 2008 12:05:32 GMT++darcs (2.1.0pre3)++  * Bug Fix: Eliminate an error merging repeated conflicts in darcs-2+    repositories (issue1043, David Roundy)++  * New Feature: Hide 'Ignore-this:' lines which will be generated by future+    versions of darcs to prevent patch-id collisions. (issue1102, Eric Kow,+    David Roundy)++  * Bug Fix: Support darcs repositories which have symbolic links in their+    paths (issue1078, Dmitry Kurochkin)++  * Bug Fix: Make ssh connection sharing (darcs transfer-mode) work with+    old-fashioned repositories (issue1003, David Roundy)++ -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 02 Oct 2008 09:12:41 GMT++darcs (2.1.0pre2)++  * IMPORTANT: Create darcs-2 repositories by default in darcs init (issue806,+    David Roundy)++  * User Experience: Do not allow users to add files to a darcs repository if+    their filenames would be considered invalid under Windows. This can be+    overridden with the --reserved-ok flag (issue53, Eric Kow)++  * Bug Fix: Do not leave behind a half-gotten directory if darcs get fails+    (issue1041, Vlad Dogaru, David Roundy)++  * User Experience: notice when you are trying to pull from a seemingly+    unrelated repository, that is one with a sufficiently different history.+    This can be overridden with the --allow-unrelated-repos flag (Dmitry+    Kurochkin, David Roundy)++  * Bug Fix: Fix hang after a user input error (for example, EOF) (Judah+    Jacobson)++  * Quality Assurance: Improvements to documentation and online help (Simon+    Michael)++ -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 25 Sep 2008 08:10:49 GMT++darcs (2.0.3pre1)++  * New Feature: Optional readline-like functionality when compiled with the+    haskeline package (Judah Jacobson, Gaëtan Lehmann)++  * Bug Fix: No more spurious pending patches (issue709, issue1012, David+    Roundy)++  * Bug Fix: darcs get --to-match now works with hashed repositories+    (issue885, David Roundy)++  * User Experience: Catch mistakes in _darcs/prefs/defaults (issue691, Dmitry+    Kurochkin)++  * User Experience: Improved support for darcs send over http (see also+    tools/upload.cgi) (Dmitry Kurochkin, David Roundy)++  * Bug Fix: Recognize user@example.com: as an ssh path, that is, not+    requiring a path after the server component. (David Roundy)++  * New Feature: Accept an optional directory argument in darcs send+    --output-auto-name (Dmitry Kurochkin)++  * User Experience: New --no-cache option to help debug network issues+    (issue1054, Dmitry Kurochkin)++  * Performance: New --http-pipelining and --no-http-pipelining flags. Passing+    --http-pipelining to darcs can make darcs get and pull faster over HTTP.+    Due to a libcurl bug, this is not the default option unless darcs is+    compiled with libcurl 7.19.1, due 2008-11. (Dmitry Kurochkin)++  * Bug Fix: Eliminate hanging and crashes while fetching files over HTTP+    (issue920, issue977, issue996, issue1037, Dmitry Kurochkin)++  * Security: Fix some insecure uses of printfs in darcs.cgi (Steve Cotton)++  * Bug Fix: Handle filepaths in a simpler and more robust fashion. This fixes+    relative filepaths and recognition of symbolic links and avoids possible+    future bugs (issue950, issue1057, David Roundy, Dmitry Kurochkin)++  * Bug Fix: Make darcs diff --patch work even if the patch is within a tag+    (issue966, darcs 2 regression, Dmitry Kurochkin)++  * Quality Assurance: Extend use of Haskell's GADTs to most of the darcs+    code, fixing many potential bugs along the way (Jason Dagit, David Roundy)++  * Quality Assurance: Several improvements to darcs code quality (Petr+    Ročkai)++  * Bug Fix: Correct assumptions made by darcs about Windows file size types+    (issue1015, Simon Marlow, Ganesh Sittampalam)++  * Bug Fix: Support case insensitive file systems using hashed repositories+    in darcs repair (partial issue971, Petr Ročkai). IMPORTANT: This+    introduces a memory use regression, which affects large repositories. We+    found that doing a darcs repair on the GHC repository requires a machine+    with 2 GB of RAM. The regression is well-understood and should be solved+    in the next darcs release. In the meantime we felt that the improved+    robustness was worth the performance trade-off.++  * Quality Assurance: Simplify building darcs on Windows by optionally using+    the zlib and terminfo Haskell packages (Ganesh Sittampalam, Petr Ročkai)++  * User Experience: Better error reporting when patches that should commute+    fail to do so. (Jason Dagit)++  * New Feature: --match "touch filenames", for example --match 'touch+    foo|bar|splotz.*(c|h)' (issue115, Dmitry Kurochkin)++  * User Experience: Improve debugging and error messages in HTTP code (Dmitry+    Kurochkin, David Roundy)++  * Bug Fix: Ensure that darcs responds to Ctrl-C on Window, even if compiled+    with GHC < 6.10 (issue1016, Simon Marlow)++  * New Feature: darcs changes --context now also works with --human-readable+    and --xml-output (issue995, Dmitry Kurochkin)++  * Bug Fix: Always darcs send with context, as if --unified flag were used+    (was implemented in 2.0.2, but not consistently) (David Roundy)++  * Bug Fix: Make sure that darcs get --tag works even when the user hits+    Ctrl-C to get a lazy repository (Dmitry Kurochkin)++  * Quality Assurance: Improvements to documentation and online help, most+    crucially, user-focused help on upgrading to darcs 2. (Trent Buck, Lele+    Gaifax, Simon Michael, Max Battcher)++  * New Feature: darcs changes --number associates each patch with number,+    counting backwards (see the --index feature) (David Roundy)++  * New Feature: ability to match patches on index, for example, darcs changes+    --index=3-6 shows the last three to six patches (David Roundy)++  * User Experience: slightly reduce the verbosity of darcs pull --verbose+    (David Roundy)++ -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 18 Sep 2008 02:36:45 GMT++darcs (2.0.2)++ -- David Roundy <droundy@darcs.net>  Sun, 24 Jun 2008 01:20:41 GMT++darcs (2.0.1)++  * Bug Fix: Make Ctrl-C work even though darcs is now compiled to use the+    threaded runtime (issue916, David Roundy)++  * New Feature: Include patch count in darcs --version, for example, 2.0.1 (++    32 patches) (David Roundy)++  * Bug Fix: Avoid an error caused by renaming a file on case-insensitive+    file-systems (Eric Kow)++  * Bug Fix and New Feature: Improved XML output (Benjamin Franksen, Lele+    Gaifax, David Roundy)++  * User Experience: Always darcs send with context, as if --unified flag were+    used (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 23 Jun 2008 21:47:07 GMT++darcs (2.0.1rc2)++  * Performance: Faster strings, using Data.Bytestring by default (Gwern+    Branwen, Eric Kow, Ian Lynagh, David Roundy)++  * User Experience: On Windows, use MS-DOS 'edit' as a default editor if+    Emacs and friends are not available (Eric Kow)++  * Bug Fix: On Windows, notice when external programs fail to launch because+    they do not exist (Eric Kow)++  * New Feature: darcs put --no-set-default and --set-default (Nicolas+    Pouillard)++ -- David Roundy <droundy@darcs.net>  Sun, 13 Jun 2008 01:17:45 GMT++darcs (2.0.1rc1)++  * Bug Fix: Fix tag --checkpoint so that darcs get --partial can avoid+    fetching all patches (issue873, David Roundy)++  * User Experience: Better progress reporting [NB: darcs is now compiled with+    threaded runtime by default] (issue739, David Roundy, Bertram Felgenhauer)++  * Performance: Reduce memory usage of darcs put (David Roundy)++  * Bug Fix: Improved date matching (issue793, issue187, Eric Kow)++  * Performance: Fix an optimization in diff-detection (affects darcs whatsnew+    and record) (Pekka Pessi)++  * Quality Assurance: --enable-hpc for checking program coverage (Christopher+    Lane Hinson)++  * Bug Fix: Do not rollback if no primitive patches were selected (issue870,+    Eric Kow)++  * Bug Fix: Make it possible to --dry-run on repositories we cannot write to+    (issue855, Eric Kow, David Roundy)++  * Bug Fix: Avoid a race condition caused by cleaning out the pristine cache+    (issue687, David Roundy)++  * User Experience: When pushing, prints a small reminder when the remote+    repository has patches to pull (Eric Kow, David Roundy)++  * UI changes: --extended-help is now called --overview, no more+    --verify-hash, no more send --unified (David Roundy, Eric Kow)++  * User Experience: Show ssh's stderr output in case it wants to ask the user+    something (issue845, Eric Kow)++  * Bug Fix: Improved interaction with pager (David Roundy, Pekka Pessi, Eric+    Kow)++  * Bug Fix: darcs send -o - (Pekka Pessi)++  * Bug Fix: (regression) Re-enable darcs mv as a means of informing darcs+    about manual renames (issue803, David Roundy)++  * Bug Fix: Fix bugs related to use of threaded runtime (issue776, David+    Roundy)++  * Portability: Respect OS conventions in creation of temporary files (Eric+    Kow)++  * New Feature: Check for and repair patches which remove non-empty files+    (issue815, David Roundy)++  * Bug Fix: Make get --to-match work with hashed repositories (David Roundy)++  * Bug Fix: Conflict-handling with darcs-2 semantics (issue817, David Roundy)++  * Bug Fix: Make --ask-deps ask the right questions (Tommy Pettersson)++  * User Experience: Improved error messages and warnings (issue245, issue371,+    Nicolas Pouillard, David Roundy, Eric Kow)++  * New Feature: darcs trackdown --set-scripts-executable (Reinier Lamers)++  * Quality Assurance: Various improvements to documentation (issue76,+    issue809, Gwern Branwen, Lele Gaifax, Eric Kow, Nicolas Pouillard, David+    Roundy)++  * Bug Fix: Correct detection of incompatibility with future darcs (issue794,+    Eric Kow)++  * User Experience: Make darcs changes --interactive behave more like other+    interactive commands (Eric Kow)++  * Performance: Optimized handling of very large files (Gwern Branwen)++  * New Feature: Colorize added and removed lines, if the environment variable+    DARCS_DO_COLOR_LINES=True (Nicolas Pouillard)++  * New Feature: --remote-repodir flag to allow separate default repositories+    for push, pull and send (issue792, Eric Kow)++  * Performance: Optimized get --to-match handling for darcs 1 repositories+    (Reinier Lamers)++  * Bug Fix: Make changes --repo work when not in a repository (David Roundy)++  * New Feature: darcs changes --count (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 03 Jun 2008 12:43:31 GMT++darcs (2.0.0)++  * Fix silly bug which leads to darcs --version not showing release when it's+    a released version. (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 07 Apr 2008 15:06:38 GMT++darcs (2.0.0rc1)++ -- David Roundy <droundy@darcs.net>  Sun, 01 Apr 2008 15:44:11 GMT++darcs (2.0.0pre4)++  * When darcs encounters a bug, check version versus central server in order+    to decide whether to recommend that the user report the bug.++  * Display duplicate identical changes when using darcs-2 repository format.+    (Issue579)++  * Fix a bug in convert that lead to invalid tags in the converted+    repository. (Issue585)++  * Add an annoying warning when users run convert.++  * Numerous fixes to the time/date matching code, which should now work even+    in central Europe. (Eric Kow)++  * Add support for reading hashed repositories that use SHA256 hashes. The+    plan is to enable writing of SHA256 hashes in the next release. (David+    Roundy)++  * New Feature: Add a 'show authors' command (Eric Kow)++  * darcs.cgi improvements: Patch pages show "Who" and "When" some file+    annotation pages show "who" and "when" with a mouse-over. Also, darcs.cgi+    can now be hosted in a path containing The tilde character. (Zooko, Mark+    Stosberg)++  * User Experience: Improved and added many debugging, error and progress+    messages (David Roundy, Mark Stosberg, Eric Kow)++  * New Feature: New DARCS_PATCHES, DARCS_FILES and DARCS_PATCHES_XML+    environment variables are made available for the posthook system, allowing+    for more easier options to to integrate darcs with other systems. (David+    Roundy, Mark Stosberg)++  * Quality Assurance: Added and updated automated regression tests (Mark+    Stosberg, David Roundy, Eric Kow, Trent Buck, Nicolas Pouillard, Dave+    Love, Tommy Pettersson)++  * Bug Fix: Gzipped files stored in the repo are now handled properly (Zooko,+    David Roundy)++  * Quality Assurance: Various Documentation Improvements (issue347, issue55+    Mark Stosberg, Nicolas Pouillard, Marnix Klooster)++  * Bug Fix: With --repodir, commands could not be disabled (Trent Buck, David+    Roundy)++  * New Feature: tools/update_roundup.pl scripts allows the darcs bug tracker+    to be notified with a darcs patch resolving a particular issue is applied.+    A link to the patch in the web-based repo browser is provided in the+    e-mail notifying bug subscribers. (Mark Stosberg)++  * Internal: Begin work on memory efficiency improvements (David Roundy)++  * Performance: darcs is faster when identifying remote repos handling+    pending changes and running unrecord. (David Roundy)++  * Internal: Source code clean-up and improvements (David Roundy, Jason+    Dagit, Eric Kow, Mark Stosberg)++  * User Experience: A pager is used automatically more often, especially when+    viewing help. (Eric Kow)++  * Bug Fix: push => incorrect return code when couldn't get lock. (issue257,+    VMiklos, David Roundy, Eric Kow, Mark Stosberg)++  * Bug Fix: 'whatsnew' and 'replace' now work together correctly. (Nicolas+    Pouillard, David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 21 Mar 2008 15:31:37 GMT++darcs (2.0.0pre3)++  * Fix issue 244, allowing users of darcs changes to specify the new name of+    a file that has an unrecorded mv. (David Roundy, Mark Stosberg, Tuomo+    Valkonen)++  * Fix issue 600, bug in darcs optimize --relink. (David Roundy, Trent Buck,+    Mark Stosberg, Tommy Pettersson)++  * Add a new framework for outputting progress messages. If darcs takes more+    than about one second to run a command, some sort of feedback should now+    be provided. (David Roundy)++  * Rewrite rollback, changing its behavior to be more useful. Rollback now+    prompts for a name for the new "rollback" patches. It also allows you to+    roll back multiple patches simultaneously, and to roll back only portions+    of the patches selected. Altogether, rollback is now more interactive, and+    should also be more useful. (David Roundy)++  * Bug Fix: date parsing is now improved (Mark Stosberg, David Roundy)++  * Performance: Improved speed of darcs pull on very large repos. (David+    Roundy)++  * Fix issue 586, but in darcs repair on hashed and darcs-2 repositories.+    (Nicolas Pouillard)++  * Improve docs for 'darcs init' (Mark Stosberg)++  * Fix typo in test partial.sh which made part of the tests for --partial+    invalid. (Mark Stosberg)++  * Document that darcs handles some types of binary files automatically.+    (issue55, Mark Stosberg)++  * Fix typo in a test that made it compare a file to itself. (Mark Stosberg)++  * Document that single quotes should be used in .darcs/defaults. (issue347,+    Mark Stosberg)++  * New Feature: Automatically create the the global cache if we define we+    want to use it. (David Roundy, Trent Buck)++  * Performance: Improved HTTP pipelining support (Dmitry Kurochkin)++  * Fix issue 571, build failure when termio.h is not found. (Dave Love)++ -- David Roundy <droundy@darcs.net>  Sun, 22 Jan 2008 20:06:12 GMT++darcs (2.0.0pre2)++  * Add instructions in documentation for how to view patches in Mutt (a mail+    reader). (Gwern Branwen)++  * Fix build on Solaris. (Dave Love)++  * Added "auto-optimize" support for hashed inventories, in that darcs+    automatically optimizes inventories when it seems wise (which is currently+    defined as "every time we modify the inventory").++  * Fix expensive performance bugs involved in conflict handling. Thanks to+    Peter for pointing these out!.++  * Fix reading of hashed repositories to avoid reading patches that we don't+    actually need (i.e. foolish inefficiency bug). Thanks to Simon for+    reporting these performance bugs.++  * Added a new --debug flag for debug output.++  * Added compatibility with ghc 6.4. At this point darcs 2 should work with+    any ghc from 6.4 to 6.8.2.++  * Fix bug where parsing of setpref patch called tailPS unnecessarily. (David+    Roundy)++  * Refactor parsing of commands and command line arguments. Implement hidden+    commands. (Eric Kow)++  * Use a single command to initialize a remote repository. This replaces the+    method of stringing together multiple commands with the shell-dependent &&+    operator. (Tristan Seligmann)++  * Allow for files in _darcs/inventories to be gzipped. This is not+    specifically related to issue553, but it fixes a regression introduced by+    the issue553 fix. (Issue553, Eric Kow)++  * Check for potential hash collision in writeHashFile. (Eric Kow)++  * Don't try to write hash file if it already exists, as you can not+    overwrite an open file on Windows. (Issue553, Eric Kow)++  * Close file handles when done reading it lazily. (Eric Kow)++  * Modernize and enhance buggy renameFile workaround by using the+    hierarchical library structure and only catching 'does not exist' errors.+    (Eric Kow)++  * Add "hidden" printer for decorating patches with color for easier reading+    when printed to screen during verbose or debug output, but hides (removes)+    the decoration when printing to the repository files. This is the+    counterpart of the invisible printer, which makes non-human-friendly patch+    contents invisible when printed to the screen. (David Roundy)++  * Add "hidden" printer, for printing things to screen but not file. (David+    Roundy)++  * Make darcs distinguish between repository sub paths and "normal" relative+    paths. Better handling of absolute paths. (Eric Kow)++  * Fix some bugs introduced by Better handling of file paths. (Eric Kow)++  * Handle corner case when polling from self. (issue354, issue358, Eric Kow)++  * Handle corner cases when pulling from current repository. (Issue354,+    Issue358, Eric Kow)++  * Fix bug in make_dotdots when pushing from a sub directory. (issue268, Eric+    Kow)++  * Fix bug in make_dotdots when pushing from a subdirectory. (Issue268, Eric+    Kow)++  * Better handling of file paths. Distinguish between paths to files+    belonging to the repository as well as not belonging to the repository,+    both in absolute and relative form. (Eric Kow)++  * Add path fixing to darcs send, and don't try sending to self. (issue427,+    Eric Kow)++  * Fix path issue for darcs send. (Issue427, Eric Kow)++  * Disable mmap under Windows. (issue320, Eric Kow)++  * Backup unmanaged working dir files as needed. (issue319, issue440, Eric+    Kow)++  * Backup unmanaged files in the working directory when they are overwritten+    by managed files with the same names in pulled or applied patches.+    (Issue319, Issue440, Eric Kow)++  * Offer some advice if sendmail failed. (issue407, Eric Kow)++  * Document behavior of "boring" managed files. (Issue259, Eric Kow)++  * Make Doc a newtype, so we can define a Show instance. (David Roundy)++  * Make make_changelog GHC 6.8 compliant. (Ganesh Sittampalam)++  * GHC 6.8 needs containers package. (Ganesh Sittampalam)++  * Configure hack to deal with openFd -> fdToHandle' renaming in GHC 6.8.+    (Ganesh Sittampalam)++  * Make makefile summarize calls to GHC when compiling. VERBOSE=1 turns the+    long format back on. (Eric Kow)++  * When building, print summarized call to GHC in makefile, instead of very+    long command lines with many boring options. VERBOSE=1 reverts to showing+    options again. (Eric Kow)++  * Add svg logo. (David Roundy)++  * Add mercurial files to the default boring file. (David Roundy)++  * Add patterns for mercurial files to default boring patterns. (David Roundy)++  * Define color versions of traceDoc and errorDoc for debugging. (David+    Roundy)++  * Clarify error message for --last. (issue537, Eric Kow)++  * Clarify in error message that darcs option --last requires a *positive*+    integer argument. (Issue537, Eric Kow)++  * Optimize getCurrentDirectorySansDarcs a little. (Eric Kow)++  * Never create temporary directories in the _darcs directory. (issue348,+    Eric Kow)++  * Never create temporary directories in the _darcs directory. (Issue348,+    Eric Kow)++  * Make revert short help less cryptic. (Eric Kow)++  * Make revert short help less cryptic. (Eric Kow)++  * Make --checkpoint short help more explicit. (issue520, Eric Kow)++  * Make --checkpoint short help more explicit. (Issue520, Eric Kow)++  * Add format infrastructure for darcs-2 repo format. (David Roundy)++  * Always optimize the inventory in 'darcs tag'. (Eric Kow)++  * Fix bug in Tag --checkpoint where the inventory was not updated. (Eric Kow)++  * Fix accidental regression of --no-ssh-cm flag. (Eric Kow)++  * Move conditional #include from Darcs.External to makefile. The GHC manual+    says that this is *not* the preferred option, but for some reason, the+    include pragmas seem to get ignored. Perhaps it is because the requirement+    that the pragmas be on the top of the file conflict with the #ifdef+    statements. In any case, this patch gets rid of the warning on MacOS X:+    warning: implicit declaration of function 'tgetnum'. (Eric Kow)++  * Pass CFLAGS to the assembler. E.g. -mcpu is essential on sparc. (Lennart+    Kolmodin)++  * Optimize 'darcs optimize --reorder'. (David Roundy)++  * Add a table of environmental variables to the manual. (issue69, Eric Kow)++  * Use System.Directory.copyFile for file copying. (Kevin Quick)++  * Implement darcs show contents command. It shows the contents of a file at+    a given version. (issue141, Eric Kow)++  * Make Changes --context --repodir work. (Issue467, Erik Kow)++  * Rename 'query' to 'show', but keep 'query' as an alias. (There is also an+    extra alias 'list' that means the same as show.) The subcommand 'query+    manifest' is renamed to 'show files', and does not list directories by+    default, unless the alias 'manifest' is used. (Eric Kow)++  * Support record -m --prompt-long-comment. (issue389, Eric Kow)++  * Hide the command 'unpull' in favor of 'obliterate'. (Eric Kow)++  * Make option --no-deps work again. It now also works for obliterate,+    unrecord, push and send. (issue353, Tommy Pettersson)++  * Make Record --ask-deps abort if user types 'q' instead of recording+    without explicit dependencies. User is now required to type 'd' (done). If+    the resulting patch is completely empty (no changes and no dependencies)+    the record is automatically canceled. (issue308, issue329, Kevin Quick)++  * Use pure record-access for PatchInfo in Patch.Info. (David Roundy)++  * Improve error message when unable to access a repository. (David Roundy)++  * Switch to using new Haskell standard library function cloneFile for+    copying files. (Kevin Quick)++  * Remove more GUI code. (Eric Kow)++  * Fix some --dry-run messages: "Would push" instead of "Pushing". (issue386,+    Eric Kow)++  * Ensure that logfile for record has trailing newline. (issue313, Eric Kow)++  * Add a stub command 'commit' that explains how to commit changes with+    darcs. (Eric Kow)++  * Makes non-repository paths in DarcsFlags absolute. (issue427, Zachary P.+    Landau)++  * Fix problem with missing newline in inventory, to simplify for third party+    scripts. (Issue412, Eric Kow)++  * Add all pulled repositories to _darcs/prefs/repos. (Issue368, Eric Kow)++  * Implement Apply --dry-run. (Issue37, Eric Kow)++  * Never change defaultrepo if --dry-run is used (issue186, Eric Kow)++  * Filter out any empty filenames from the command line arguments. (Issue396,+    Eric Kow)++  * Use prettyException in clarify_errors so we don't blame user for darcs'+    own errors. (Issue73, Eric Kow)++  * Rename command 'resolve' to 'mark-conflicts'. 'Resolve' remains as a+    hidden alias. (issue113, Eric Kow)++  * Make 'query manifest' list directories by default. (issue456, Eric Kow)++  * Allow --list-options even if command can not be run. (issue297, Eric Kow)++  * Make 'unadd' an alias for 'remove'. Make 'move' an alias for 'mv'. Add a+    stub for 'rm' that explains how to remove a file from a darcs repository.+    (issue127, Eric Kow)++  * Fix <supercommand> --help. (Issue282, Eric Kow)++  * New --nolinks option to request actual copies instead of hard-links for+    files. (Kevin Quick)++  * Harmonize capitalization in flags help. (Eric Kow)++  * Define datarootdir early enough in autoconf.mk.in. (Issue493, Eric Kow)++  * Fix a bug where Get --partial would use a checkpoint without detecting it+    was invalid. Checkpoints can for example become invalid after an Optimize+    --reorder. (issue490, David Roundy)++  * User Agent size limit for curl gets is removed. (Issue420, Kevin Quick)++  * Don't garb string parameters passed to libcurl, as required by the api+    specification. (Daniel Gorin)++  * Fix handling of --repo with relative paths. (Eric Kow)++  * Check for gzopen in zlib. curl depends on zlib and is detected prior to+    zlib by the configure file, but without the -lz flag on some versions.+    (Andres Loeh)++  * Switch to haskell's System.Process under Unix for execution of external+    commands; requires GHC 6.4. (Eric Kow)++  * Remove (some more) conflictor code. (Eric Kow)++  * Remove (unused) conflictor code. (David Roundy)++  * Support makefile docdir/datarootdir variables. (Dave Love)++  * Added prehooks that works the same as posthooks, but they run before the+    command is executed. This can for example be used to convert line endings+    or check character encodings before every Record. The darcs command aborts+    if the prehook exits with an error status. (Jason Dagit)++  * Use system instead of rawSystem for calling interactive cmds in Windows,+    which lets us support switches, for example, in DARCS_EDITOR. (Eric Kow)++  * add support for partial and lazy downloading of hashed repositories.+    (David Roundy)++  * Fix refactoring bug in Checkpoints where we sometimes looked for things in+    the wrong place. (David Roundy)++  * Fail on error in get_patches_beyond_tag. This will expose any bugs where+    we use this function wrongly. (As was the case in darcs check --partial+    with hashed inventories.) (David Roundy)++  * Restructure the source tree hierarchy from a mostly flat layout to one+    with directories and subdirectories that reflects the modularity of the+    source. (Eric Kow)++  * In tests, don't assume grep has -q and -x flags. (Dave Love)++  * Add --output-auto-name option to Send (Zachary P. Landau)++  * Added regression testing for the "pull --complement" operation. Updated+    documentation to explain why "darcs pull --complement R1 R1" is the same+    as "darcs pull R1" instead of the empty set. (Kevin Quick)++  * Change all "current" to "pristine" in manual and help texts. (Tommy+    Pettersson)++  * Added the ability to specify the --complement argument on the pull command+    as an alternative to --intersect and --union. When --complement is+    specified, candidate patches for a pull are all of the pullable patches+    that exist in the first repository specified but which don't exist in any+    of the remaining repositories (the set-theory complement of the first+    repository to the union of the remaining repositories). (Kevin Quick)++  * Fix bug where darcs would try to write temporary files in the root+    directory (/) if it couldn't find a repository root to write them in. Now+    it uses the current directory in that case. (issue385, Zachary P. Landau)++  * Make write_repo_format use the same syntax as read_repo_format when+    dealing with different repository formats. (Benedikt Schmidt)++  * Remove some unused functions from Population. (Eric Kow)++  * Use IO.bracket instead of Control.Exception.bracket in Exec, to restore+    the old way darcs works on *nix. (Eric Kow)++  * Import bracketOnError from Workaround instead of Control.Exception to+    support GHC 6.4. (Eric Kow)++  * Switch to haskell's System.Process under Windows for execution of external+    commands; requires GHC 6.4. (Simon Marlow)++  * Fix bug where darcs ignored command arguments in the VISUAL environment+    variable. (issue370, Benedikt Schmidt)++  * Make annotate work on files with spaces in the name. (Edwin Thomson)++  * Prettify exceptions in identifyRepository. (Juliusz Chroboczek)++  * QP-encode patch bundles transfered with the Put command. (Juliusz+    Chroboczek)++  * Fix bug in darcs get --tag that left cruft in pending. (David Roundy)++  * Fix bug when trying to 'darcs mv foo foo'. (issue360, David Roundy)++  * Separate comment from OPTIONS pragma for GHC 6.4 compatibility. (Eric Kow)++  * Make hashed inventories support optimize and reordering. (David Roundy)++  * Change all Maybe Patch to the new type Hopefully Patch, which is similar+    to Either String, for storing patches that may or may not exist. This+    should make it much easier to improve error reporting. (David Roundy)++  * Fix pending bug that broke several_commands.sh. (David Roundy)++  * Fix hashed inventory bug in Add. (David Roundy)++  * Make Get and Put reuse code for Initialize. This makes Put accept any+    flags that Init accepts. (David Roundy)++  * Fix new get to not mess up pending. (David Roundy)++  * External resolution can resolve conflicting adds. (Edwin Thomson)++  * Only copy the files that are needed for the resolution, when invoking an+    external resolution tool. This saves much time and resources on+    repositories with many files in them. (Edwin Thomson)++  * Change message in 'darcs check' from "applying" to "checking". (issue147,+    Tommy Pettersson)++  * Add code fore hashed inventories. (David Roundy)++  * New option for Diff: --store-in-memory. darcs diff usually builds the+    version to diff in a temporary file tree, but with --store-in-memory it+    will represent the files in memory, which is much faster (unless the tmp+    directory already is a ram disk). (Edwin Thomson)++  * Fix bug where duplicated file names on the command line would fool darcs.+    (issue273, Tommy Pettersson)++  * When recording with option --pipe, assume users local timezone if none is+    given, instead of UTC. Except if the date is given in raw patch format+    'yyyymmddhhmmss' it is still parsed as UTC. (issue220, Eric Kow)++  * Account for timezone information, e.g. in dates when recording with option+    --pipe. (issue173, Eric Kow)++  * Fix bug in refactoring of get. (David Roundy)++  * Refactor repository handling to allow truly atomic updates. (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 16 Dec 2007 20:16:47 GMT++darcs (1.0.9)++  * Make shell harness failures fatal in Makefile. (Eric Kow)++  * Bugfix, fix bug where we add a file but not its boring parent directory.+    (David Roundy)++  * Allow escaped quotes in 'quoted' for match text. (Dave Love)++  * Don't exit with failure when tests_to_run is used and there are no perl+    tests. (David Roundy)++  * Apply patches "tolerantly" to the working directory; don't quit, but print+    a warning for every problem and continue. This is a workaround for a bug+    in darcs where it sometimes fails to update the working directory. When+    darcs updates the working directory it has already successfully updated+    the inventory and the pristine cache, so the repository itself is not+    corrupted. However, an incomplete update to the working directory results+    in unintended differences between the working and pristine tree, looking+    like spurious unrecorded changes. These can be easily removed with 'darcs+    revert', but spurious changes have to be manually sorted out from real+    unrecorded changes. By darcs no longer quiting at the first problem, more+    of the working tree gets updated, giving less spurious changes and less+    manual work to fix the mess should the bug bite you. (issue434, Eric Kow,+    David Roundy)++  * Add a README file, created from HACKING. (issue287, Eric Kow)++  * New command, query tags (similar to 'darcs changes -t .) (Florian Weimer)++  * Include the query commands in the manual. (Florian Weimer)++  * The ssh control master is now off by default (it seems to hang on some+    large repositories). The option --disable-ssh-cm is replaced by the two+    options --ssh-cm and --no-ssh-cm (default). (Eric Kow)++  * Do not append a colon to host name when calling sftp. This does not solve+    all of issue362, just a minor annoyance along its way. (issue362, Eric Kow)++  * Get 'open' and 'psignal' declared on Solaris. (Dave Love)++  * Zsh completion supports new _darcs/pristine repository format. (Georg Neis)++  * Add documentation for DARCS_PAGER. (Benedikt Schmidt)++  * Turning off and on the ssh control master works for the Changes command.+    (issue383, Georg Neis)++  * Optimize unrecorded file moves with unrecorded file adds and removals.+    That is, if you add, rename and remove files multiple times without+    recording, whatsnew (and record) will only see the final result, not the+    whole sequence of moves. (Marco Tulio Gontijo e Silva)++  * Fix link error with errno for gcc 4.12 / glibc 2.4. (Benedikt Schmidt)++  * Remove the confusing text "user error" from some of GHC's error+    descriptions. (Juliusz Chroboczek)++  * Check for and fail build configuration if module quickcheck isn't+    available. (issue369, David Roundy)++  * Make darcs push QP-encode the bundle before transferring. This should+    hopefully fix issues with scp/sftp corrupting bundles in transit. (Juliusz+    Chroboczek)++  * Make it very clear in the documentation that the options --from and+    --author does NOT have anything to do with the sender or email author when+    sending patches as email with the darcs Send command. (Kirsten Chevalier)++  * Allow commented tests in tests_to_run. (David Roundy)++  * Make it an error to Put into a preexisting directory. Often one could be+    tempted to try to put into a directory, expecting to have the repository+    created as a subdirectory there, and it is confusing to have instead the+    repository contents mingled with whatever was already in that directory.+    (David Roundy)++  * Explicitly flush output on Windows after waiting for a lock, because+    Windows' stdout isn't always in line-buffered mode. (Simon Marlow)++  * Improve unhelpful "fromJust" error message in Push command. (Kirsten+    Chevalier)++  * Support option --all for Obliterate, Unpull and Unrecord. (issue111, David+    Roundy)++  * Ignore failure to set buffering mode for terminal in some places+    (supposedly fixes issue41, issue94, issue146 and issue318). (Tommy+    Pettersson)++  * Buildfix, don't import Control.Exception functions when compiling on+    Windows. (Edwin Thomson)++  * Add make rules for tag files. (Dave Love)++  * Add a semi-automated test for SSH-related things. (Eric Kow)++  * Allow Dist --dist-name to put the tar file in any directory by giving a+    full path as the dist name. (issue323, Wim Lewis)++  * Add rigorous error checking when darcs executes external commands. All+    low-level C return values are checked and turned into exceptions if they+    are error codes. In darcs main ExecExceptions are caught and turned into+    error messages to help the user. (Magnus Jonsson)++  * Redirect error messages from some external commands to stderr. (Tommy+    Pettersson)++  * Make configure fail if a required module is missing. (David Roundy)++  * The options for turning off and on the ssh control master works from the+    defaults file. (issue351, Tommy Pettersson)++  * Amend-record now keeps explicit dependencies (made with --ask-deps) from+    the amended patch. (issue328, Edwin Thomson)++  * Make libcurl use any http authentication. This let darcs use repositories+    protected with digest authentication. (Tobias Gruetzmacher)++  * Turning off and on the ssh control master works for the Send command.+    (Eric Kow)++  * Redirect stderr to Null when exiting SSH control master. This suppresses+    the output "Exit request sent" not suppressed by the quiet flag. (Eric Kow)++  * Fix curses stuff, especially on Solaris 10. (Dave Love)++  * Annotate various boring patterns. (Dave Love)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 03 Jun 2007 21:37:06 GMT++darcs (1.0.9rc2)++  * Pass e-mail address only for %t in --sendmail-command. Msmtp seems to+    require this. Note that the full address is encoded in the message body.+    (Eric Kow)++  * Show error messages on stderr when starting and stopping the ssh control+    master. (Tommy Pettersson)++  * Rewrite check for spoofed patches with malicious paths. The check can now+    be turned off with the option --dont-restrict-paths (issue177). The new+    check only works for Apply and Pull, and it only looks at the remote+    patches. A more complete check is desirable. (Tommy Pettersson)++  * Add LGPL file referenced in fpstring.c (Dave Love).++  * Update FSF address in copyright headers(Dave Love).++  * New default boring file patterns: ,v .# .elc tags SCCS config.log .rej+    .bzr core .obj .a .exe .so .lo .la .darcs-temp-mail .depend and some more+    (Dave Love).++  * Move darcs.ps to the manual directory (Tommy Pettersson).++  * Pass -q flag to scp only, not ssh and scp. Putty's SSH (plink) does not+    recognize the -q flag. (issue334, Eric Kow)++  * Bugfix. Make darcs.cgi look for both pristine and current (Dan).++  * Don't lock the repo during `query manifest' (issue315, Dave Love).++  * Buildfix. Include curses.h with term.h (issue326, Dave Love).++  * Bugfix. Unrecord, Unpull and Obliterate could mess up a repository+    slightly if they removed a tag with a corresponding checkpoint. Only the+    commands Check and Repair were affected by the damage, and Get would also+    copy the damage to the new repository. (issue281, Tommy Pettersson)++  * Add a HACKING file with helpful references to pages on the darcs wiki+    (Jason Dagit).++  * New boring file patterns: hi-boot o-boot (Bulat Ziganshin, Eric Kow).++  * Require 'permission denied' test for MacOS X again. Perhaps something in+    MacOS X was fixed? (Eric Kow).++  * Look for Text.Regex in package regex-compat. Needed for GHC 6.6. (Josef+    Svenningsson)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 16 Nov 2006 14:03:51 GMT++darcs (1.0.9rc1)++  * Improved handling of input, output and error output of external commands.+    Null-redirection on windows now works. Only stderr of ssh is+    null-redirected since putty needs stdin and stdout. (issue219, Eric Kow,+    Tommy Pettersson, Esa Ilari Vuokko)++  * Optimize away reading of non-managed files in summary mode of Whatsnew+    --look-for-adds (issue79, Jason Dagit).++  * Remove direct dependency to mapi32.dll; Improve MAPI compatibility. (Esa+    Ilari Vuokko)++  * Ignore .git if _darcs is found (Juliusz Chroboczek).++  * Add a haskell code policy test to catch uses of unwanted functions, bad+    formating and such. (Tommy Pettersson)++  * If the logfile supplied with option --logfile does not exist, fail instead+    of inserting no long comment. (issue142, Zachary P. Landau)++  * Make the pull 'permission test' work when run as root (Jon Olsson).++  * Handle unsimplified patches when further simplifying the summarized+    output. For unknown reason (a possibly previous version of) darcs allows a+    single patch to Add and Remove the same file in a single patch. The+    Changes command used to combine them, showing just a Remove. (issue185,+    Lele Gaifax)++  * Add workaround for HasBounds that was removed in GHC 6.6 (Esa Ilari+    Vuokko).++  * Really make --disable-ssh-cm work (issue239, Eric Kow).++  * Fix false errors in pull.pl test (David Roundy).++  * Clean up docs on DarcsRepo format (David Roundy).++  * Use stdin for passing the batch file to sftp, to allow password-based+    authentication (issue237, Eric Kow, Ori Avtalion).++  * Make darcs fail if the replace token pattern contains spaces. It would+    otherwise create a non-parsable patch in pending. (issue231, Tommy+    Pettersson)++  * Set a default author in the test suite harness so not every test has to do+    so. (Tommy Pettersson).++  * Run external ssh and scp commands quietly (with the quiet flag), but not+    sftp which doesn't recognize it (issue240). This reduces the amount of+    bogus error messages from putty. (Eric Kow)++  * Implement help --match, which lists all available forms for matching+    patches and tags with the various match options (Eric Kow).++  * Added .elc and .pyc suffixes to default binary file patterns (Juliusz+    Chroboczek ).++  * Added a link to the 'projects' part of the cgi repository interface, so+    that you go back to the project list (Peter Stuifzand).++  * Add a test suite for calling external programs (Eric Kow).++  * Don't warn about non-empty dirs when in quiet mode (Eric Kow).++  * New option --umask. This is best used in a repository's defaults file to+    ensure newly created files in the repository are (not) readable by other+    users. It can also be used when invoking darcs from a mail reader that+    otherwise sets a too restrictive umask. (Issue50, Juliusz Chroboczek)++  * Only check for ssh control master when it might be used. This suppresses+    the annoying "invalid command" error message. (Issue171, Eric Kow)++  * Fail with a sensible message when there is no default repository to pull+    from. (Lele Gaifax)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 08 Oct 2006 17:52:07 GMT++darcs (1.0.7)++  * Fixed bug leading to a spurious "darcs failed: resource vanished" error+    message when darcs output is piped to a program such as head that then+    exits. (Issue160, David Roundy)++  * New option --diff-command overrides the default value of "diff" when darcs+    calls an external program to show differences between versions (Eric Kow).++  * Use the ControlMaster feature in OpenSSH version 3.9 and above to+    multiplex ssh sessions over a single connection, instead of opening a new+    connection for every patch (Issue32, Eric Kow).++  * Add a standalone graphical interface (experimental). The gui code prior to+    this patch allows graphical darcs forms to be run from the command line.+    This builds off that functionality by adding a graphical front-end,+    allowing users to access these forms with a click of a button. In other+    words, this allows users to run darcs without the command line. (Eric Kow)++  * Make unpull, unrecord, obliterate accept --gui (Eric Kow).++  * Freshen GUI code so that it compiles (Eric Kow).++  * Provide more information when a remote repository can't be correctly+    identified. (Juliusz Chroboczek)++  * The Send command can save, reuse and delete the accompanying description+    in a logfile. (Zachary P. Landau)++  * Display list of subcommands when getting help on a supercommand. (Eric Kow)++  * A proper fix for the problem with rmdir when there are non-managed files+    left in the working copy of the directory so it can't really be removed.+    This solves the two related problems with a missguiding error message in+    one case, and an unreported repository corruption in the other. Now there+    is no false warning and no repository coruption. (issue154, Eric Kow)++  * Escaping of trailing spaces and coloring now works with in the pager+    called with 'p' from interactive dialogues. (issue108, Tommy Pettersson)++  * Added default recognized binary file extensions: bmp, mng, pbm, pgm, pnm,+    ppm, tif, tiff. (Daniel Freedman)++  * Added a RSS link to common.xslt. (Peter Stuifzand)++  * Make short option -i a synonym for --interactive (Zachary P. Landau).++  * Improved argument substitution for --external-merger. All apperences of %N+    are replaced, not only those occurring as single words. (Daan Leijen)++  * Transition from _darcs/current to _darcs/pristine completed. New+    repositories are created with a "pristine" directory. Previous versions of+    darcs have been looking for this directory since version 1.0.2, but older+    versions than that can't read the new repository format. (Juliusz+    Chroboczek)++  * If you specify a repository directory, any absolute paths prefixed by this+    directory are converted to be ones relative to the repodir. (issue39, Eric+    Kow)++  * The --repodir flag works with many more commands: changes, dist, get,+    optimize, repair, replace, setpref, tag, trackdown. (RT#196, RT#567, Eric+    Kow)++  * The --repodir flag works with initialize command, and tries to create it+    if it does not exists. (RT#104, Eric Kow)++  * Add autom4te.cache to default boring patterns. (Kirill Smelkov)++  * Don't create temporary copies of the repository for the external merger+    program, unless there is for sure some conflict to resolve. (Edwin Thomson)++  * Modify Changes --interactive dialogue to behave like other interactive+    commands: accept 'y' and 'n' as answers and exit automatically after last+    question. (Zachary P. Landau)++  * Unnamed patches are now called "changes" in the interactive patch+    selection dialogues. (Tommy Pettersson)++  * Treat Enter as an invalid response in single character prompt mode, and+    give feedback instead of being mysteriously silent and unresponsive.+    (RT#261, Eric Kow)++  * Make short option -f a synonym for --force (Zooko).++  * Posthooks no longer cause an output message about success or failure,+    unless the --verbose option is used. (Jason Dagit)++  * Fix crash when using changes --interactive with --patch or --match+    (Zachary P. Landau).++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 13 May 2006 17:14:38 GMT++darcs (1.0.6)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 28 Feb 2006 11:18:41 GMT++darcs (1.0.6rc1)++  * Check paths when applying patches to files and directories to stop+    maliciously handcrafted patches from modifying files outside of the+    repository or inside darcs private directories (issue48, Tommy Pettersson).++  * Revert optimization that sometimes applied patches incorrectly and+    corrupted the repository. This make darcs somewhat slower when applying+    patches. A full pull of the darcs repository itself takes 50% longer.+    (issue128, Tommy Pettersson).++  * Fix bug in Get --tag that produced a corrupt repository (issue67, Edwin+    Thomson).++  * Add newline between long comment and changed files list in dry-run summary+    to remove ambiguity (Edwin Thomson).++  * Extended date matching functionality: ISO 8601 dates and intervals, a+    larger subset of English like "yesterday at noon" (issue31/RT#34, Eric+    Kow).++  * Allow rename to different case (RT #466, Eric Kow).++  * Save long comment in a file if record fails the test run (Zachary P.+    Landau).++  * Fix win32 build breaks (Will Glozer).++  * Make --exact-version work when darcs is built from distributed tar ball+    (Marnix Klooster).++  * Coalesce pending changes created with setpref (issue70/RT#349, Eric Kow).++  * Support --interactive option in changes command (issue59, Zachary P.+    Landau).++  * New help command (RT#307, Eric Kow).++  * Add --without-docs option to configure (Richard Smith).++  * Obey normal autoconf conventions. Allows you to 'make install prefix=...'+    and doesn't change default for sysconfdir. (Dave Love)++  * Fix bug with non-existing directories. (David Roundy)++  * Remote apply does not use cd to change current directory to target+    directory any more. It uses --repodir when invoking remote darcs. This may+    break some darcs wrappers. (Victor Hugo Borja Rodriguez)++  * Support signed push (Esa Ilari Vuokko).++  * Added support for pulling from multiple repositories with one pull. The+    choice of --union/--intersection determines whether all new patches are+    pulled, or just those which are in all source repositories. This feature+    implements a suggestion by Junio Hamano of git. (David Roundy)++  * Patch bundle attachments get a file name, based on the first patch.+    (Zachary P. Landau)++  * The send command now takes a --subject flag. (Joeri van Ruth)++  * Fix --set-scripts-executable to work also when getting a local repository.+    (issue38, Eric Kow)++  * Removed the helper program darcs-createrepo. It was used for guided settup+    of a darcs repository and a corresponding user account to accept patches+    from signed emails. (issue14, Jason Dagit)++  * Print out the patch name when a test fails. (Zachary P. Landau).++  * Bugfix for --sendmail-command in Windows (Esa Ilari Vuokko).++  * Make apply --verify work with GnuPG in Windows (Esa Ilari Vuokko)++  * Bugfix for handling of absolute paths in Windows (issue47, Will Glozer)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 19 Feb 2006 23:19:19 GMT++darcs (1.0.5)++  * Fixes for Windows (Will Glozer).++  * Adapt makefile to work with current ghc 6.4 (Will Glozer).++  * --help and --list-commands ignore other options (issue34, Eric Kow).++  * Fix apply with --verify for patch bundles signed by GnuPG in Windows (Esa+    Ilari Vuokko).++  * Make patch selection options together with --context work again (Daniel+    Bünzli).++  * Make option --commands outside of a repository work again (issue9, David+    Roundy).++  * Bugfix for pushing with ssh under Windows (issue15, Will Glozer).++  * Fix superfluous input bug in test suite (Florian Weimer).++  * Many English and markup fixes (Dave Love).++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 07 Dec 2005 11:27:30 GMT++darcs (1.0.4)++  * Fixed a bug in the external conflict resolution code. (bug #577, David+    Roundy)++  * Fixed a bug which made apply sometimes (but rarely) fail to check the the+    hash on patch bundles corrupted in just the wrong way. (David Roundy)++  * Added a simple check to darcs replace that avoids tokenizing lines that+    don't contain the token we're replacing. I feel a bit bad about+    introducing an optimization this late in the release cycle, but it makes a+    huge difference, and really should be safe. (David Roundy---famous last+    words)++  * Fixed bug where darcs didn't honor the SSH_PORT environment variable when+    calling sftp. (bug #576, fix suggested by Nicolas Frisby)++  * Avoid putting a wrongly-named directory in the tarball generated by darcs+    dist, if the name we wanted already exists in $TMPDIR. (Simon McVittie)++  * Fixed bug which caused "pull_firsts_middles called badly" errors when+    running record with --ask-deps flag. (bug #476, David Roundy)++  * Fixed bug where 'darcs changes --context' created a context that contained+    escapes that prevented its use with send. (bug #544, David Roundy)++  * Make interactive push/pull/send/apply respect the --summary option by+    printing each patch as if you had hit 'x'. (David Roundy, bug #512)++  * Fix bug when calling whatsnew --summary when a file without a trailing+    newline has been deleted. (David Roundy)++  * Fix --set-scripts-executable to work again. This feature had been broken+    since version 1.0.3. (David Roundy)++  * Simple (safe) fix for a bug which caused darcs to run out of file+    descriptors when pulling over 1000 patches. (David Roundy)++  * Fix bug in perl parts of test suite which led to spurious warning+    messages. (David Roundy)++  * Fix bug in configure when compiling darcs from tarball on a system that+    has no darcs present. (David Roundy)++  * Fix bug that shows up when recording in a repository lacking a pristine+    tree. (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 13 Nov 2005 13:44:31 GMT++darcs (1.0.4pre4)++  * Fix error in install target of makefile, which was introduced in+    1.0.4pre3. (Andres Loeh)++  * Fix problem where make install modified the permissions on system+    directories. (David Roundy, bug #494)++  * Fix bug in display when whatsnew is given "-l" twice. (David Roundy, bug+    #501)++  * Added support for --posthook to all commands. (Jason Dagit)++  * Made repair able to work on partial repositories. (fixes bug #189)++  * Changed the delimiter in the long-comment file from ***DARCS*** to ***END+    OF DESCRIPTION*** and clarified its meaning a bit. (Jason Dagit and David+    Roundy)++  * Added code to allow darcs to apply some patch bundles that have had+    carriage returns added to their line endings. (David Roundy, bug #291)++  * Make darcs accept command line flags in any order, rather than requiring+    that they precede file, directory or repository arguments. Fixes bug #477+    (David Roundy)++  * Modified darcs get to display patch numbers rather than a bunch of dots+    while applying patches during a darcs get. Also added similar feedback to+    the check and repair commands. (Mat Lavin, bug #212)++  * Made revert --all not ask for confirmation, so it can be used in+    scripting, as one would use pull --all or record --all. (Jani Monoses)++  * Added file ChangeLog.README explaining how to add entries to the+    changelog. (Mark Stosberg and David Roundy)++  * Fixed incompatibility with somewhat older versions of libcurl. (Kannan+    Goundan)++  * Fixed bug that showed up when after editing a long comment, the long+    comment file is empty. (David Roundy, bug #224)++ -- David Roundy <droundy@darcs.net>  Sun, 01 Sep 2005 11:04:18 GMT++darcs (1.0.4pre2)++  * (EXPERIMENTAL) Added support for reading and writing to git repositories.+    There remain efficiency issues with the handling of git merges and darcs+    is not yet able to either create a new git repository, or to pull from a+    remote git repository. See building darcs chapter in manual for+    instructions on building darcs with git support. (Juliusz Chroboczek,+    configuration contributed by Wim Lewis)++  * Add new "query manifest" command to list files and/or directories in+    repository. Add some related infrastucture to support "subcommands".+    (Florian Weimer)++  * Make configure properly detect that we're on windows when building under+    mingw. (David Roundy)++  * Fixed bug #208: error when specifying pulling from a relative default+    repository if we are ourselves within a subdirectory of our repository.+    (David Roundy)++  * Change internal mechanism for writing the "pending" file to be (hopefully)+    more robust. (David Roundy, original idea by Ian Lynagh)++  * Fixed a bug that caused get --partial to fail sometimes. (David Roundy)++  * Made push/pull --verbose --dry-run now display contents of patches,+    analogous to the behavior of changes --verbose. (Jim Radford)++  * Various build system cleanups. (Peter Simons)++ -- David Roundy <droundy@abridgegame.org>  Sun, 31 Jul 2005 12:10:29 GMT++darcs (1.0.4pre1)++  * Performance improvement: Several commands now read patches lazily, which+    reduces memory usage. A test of 'darcs check' on the Linux kernel+    repository showed the memory usage was nearly cut in half, from about 700+    Megs to 400. Coded by David Roundy.++  * New feature: darcs put, the easiest way to create a remote repo, symmetric+    with 'darcs get'. Coded by Josef Svenningsson.++  * Performance improvement: RT#222: darcs performs better on files with+    massive changes. Coded by Benedikt Schmidt.++  * New Feature: darcs optimize now has "--modernize-patches" and+    "--reorder-patches" flags. See the manual for details.++  * Performance improvement: Using 'darcs diff' is now exponentially faster+    when comparing specific files in the working directory to the most recent+    copy in the repo. Coded by kannan@cakoose.com.++ -- David Roundy <droundy@abridgegame.org>  Sun, 18 Jul 2005 11:22:34 GMT++darcs (1.0.3)++  * Fixed bug #396: error when specifying a removed file on the command line+    of darcs record.++ -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 24 May 2005 21:51:27 GMT++darcs (1.0.3rc2)++  * Internals: darcs' ChangeLog is automatically generated from repo history+    and a database of ChangeLog entries (Tomasz Zielonka)++  * Fixed: RT#370: --tags work in unpull and unrecord (Tommy Pettersson)++  * New feature: added support for displaying patches with pager when+    selecting patches (Benedikt Schmidt)++  * New feature: new match type "exact" (John Goerzen)++  * Feature: unrevert accepts --all and --interactive options (Jani Monoses)++  * Fixed: darcs works with nvi (Benedikt Schmidt)++ -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 15 May 2005 08:56:17 GMT++darcs (1.0.3rc1)++  * New Feature: darcs.cgi now uses appropriate caching headers. This will+    make repeated calls to the same pages by cache-aware browsers much faste+    in some cases. It also means that darcs.cgi can be usefully combined with+    a cache-aware proxy for even better performance. (Will Glozer)++  * New feature: more control over color and escaping in printed patches,+    alternative color scheme, escaping of trailing spaces (Tommy Pettersson)++  * Fixed: fixed bug manifesting with failed createDirectory (David Roundy)++  * Internals: RT#255, several welcome refactors were made to the test suite,+    including comprehensible shell test script output, improved portability,+    and easier maintenance. (Michael Schwern).++  * New Feature: RT#245: Using --look-for-adds with 'whatsnew' implies+    --summary. This should save some typing for the common case. (Karel+    Gardas, Mark Stosberg)++  * New Feature: RT#231: darcs gives better feedback now if you try to record+    nonexistent files or directories. (Karel Gardas, Mark Stosberg)++  * New feature: send accepts --sendmail-command that allows to customize the+    command used for sending patch bundles (Benedikt Schmidt)++  * Fixed: RT#266: Adding a non-existent dir and file gives the expected+    message now. (Tomasz Zielonka).++  * Fixed: RT#10, a missed conflict resolution case. More accurately, we+    noticed at had been fixed some point. A regression test for it was added.+    (Tomasz Zielonka, Mark Stosberg)++  * New feature: darcs tag can now accept the tag name on the command line+    (RT#143). (Josef Svenningsson, Mark Stosberg, David Roundy)++  * New feature: unrecord and unpull have a more powerful interface similar to+    'darcs pull'. This allows for multiple patch selection. Coded by Tommy+    Pettersson.++  * Bug fix: RT#305: Removed '--patch' from the 'changes', which conflicted+    with the new '--patches' option.++  * New feature: Automatically add parent directories for darcs add. (RT#20)+    Coded by Benedikt Schmidt.++  * Add helpful diagnostic message when there is a failure while pulling+    (RT#201)++ -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 26 Apr 2005 00:25:54 GMT++darcs (1.0.2)++  * No changes from 1.0.2rc4.++ -- David Roundy <droundy@darcs.net>  Fri,  4 Feb 2005 07:33:09 -0500++darcs (1.0.2rc4)++  * More documentation improvements, plus one clearer error message.+  * Fixed (new since 1.0.1) bug which broke darcs repair.+  * Fixed problem with makefile which caused spurious relinkings.+  * Fixed bug in new optimize --relink command, which could cause+    repository corruption.++ -- David Roundy <droundy@abridgegame.org>  Wed, 2 Feb 2005 06:24:19 -0500++darcs (1.0.2rc3)++  * Documentation improvements related to Juliusz new code.+  * Fixed longstanding leaks in zlib/threads code.+  * Fixed some bugs in the new optimize --relink code.+  * Fixed bug in darcs diff when the repository name is empty.++ -- David Roundy <droundy@abridgegame.org>  Sat, 29 Jan 2005 07:28:39 -0500++darcs (1.0.2rc2)++  * Fixed bug on win32 when there are spaces in a repositories path and an+    external program (i.e. ssh) is called. (Will Glozer)++ -- David Roundy <droundy@abridgegame.org>  Thu, 27 Jan 2005 06:46:37 -0500++darcs (1.0.2rc1)++  * Added experimental support for repositories without a "pristine tree"+    This is the new name for the cache stored in _darcs/current/.+    (Juliusz Chroboczek)+  * Added an optimize --relink command to save disk space when using+    multiple repositories. (Juliusz Chroboczek)+  * Ignore conflict markers in the boring and binaries files.+  * Fixed bug in get --partial when patches are in an unusual order.+    (Andrew Johnson)+  * Fixed bug which caused a crash on a local get of a repository owned by+    another user.+  * Fixed bug in changes/annotate that shows up when a directory has been+    moved.+  * Allow ncurses in addition to curses in configure.+  * Added --set-scripts-executable option. (Karel Gardas)+  * Added configure option to fix path to sendmail even if it's not+    present.+  * Made bash completion more robust regarding shell special chars.+  * Added konquerer workaround to cgi annotate. (Will Glozer)+  * Addressed bug #114 - provide a better error when you accidently try to+    pull from yourself. (Mark Stosberg)+  * Made a few documentation improvements.+  * Made http user agent reflect the darcs and libcurl version.+  * Fixed commute bug in merger code.+  * Fixed bug in decoding mime messages.++ -- David Roundy <droundy@abridgegame.org>  Wed, 26 Jan 2005 08:51:24 -0500++darcs (1.0.1)++  * Made darcs changes --context work on an empty repo.+  * Fixed bug in relative directories as arguments to pull/push.+  * Fixed bug leading to extraneous changes in pending.+  * Fixed bug #137 - XML escaping for >.+  * Fixed gui code to compile with wxhaskell 0.8 (but it's still buggy).++ -- David Roundy <droundy@abridgegame.org>  Tue, 14 Dec 2004 08:16:10 -0500++darcs (1.0.1rc3)++  * Made it so adding and removing a file doesn't leave changes in pending.+  * Fixed bug in creating the file to be edited for the long comment.+  * Made "bug in get_extra" message explain possible cause of the problem,+    which is related to a bug in commutation that made it into version+    1.0.0.+  * Fixed stubborn bug in annotate.+  * Fixed problem when unrecording binary file patches.++ -- David Roundy <droundy@abridgegame.org>  Sat, 11 Dec 2004 14:23:53 -0500++darcs (1.0.1rc2)++  * Various optimizations.+  * darcs now supports an arbitrary number of transport protocols through the+    use new environment variables. See DARCS_GET_FOO in the 'Configuring+    Darcs' chapter in the manual for more details.+  * darcs now supports an arbitrary number of concurrent connections when+    communicating with remote repos. See the documentation for DARCS_MGET_FOO+    in the 'Configuring Darcs' chapter in the manual for more details.++ -- David Roundy <droundy@abridgegame.org>  Wed,  8 Dec 2004 08:02:48 -0500++darcs (1.0.1rc1)++  * Fixed bug in commutation of adjacent hunks which have either no new or+    no old lines.+  * Numerous newline fixes for windows.+  * On windows, use MAPI to resolve to and from addresses.+  * Fixed problem where the --cc was ignored in apply if the patch+    succeeded.++ -- David Roundy <droundy@abridgegame.org>  Wed,  1 Dec 2004 06:24:08 -0500++darcs (1.0.1pre1)++  * Changed apply to by default refuse to apply patches that would lead to+    conflicts.+  * Removed the old darcs_cgi script, in favor of the darcs.cgi script.+  * Fixed changes to work better in partial repositories.+  * Set stdin and stdout to binary mode to fix end of line problems with+    push under windows.+  * Made send create proper MIME email.+  * Removed reportbug command, really wasn't necesary, and didn't work+    well.  Report bugs by an email to bugs@darcs.net, which creates a+    ticket in our BTS.+  * Allow darcs to work with a password protected proxy.+  * Get multiple files with a single wget call when darcs is compiled+    without libcurl support.+  * Use sftp instead of scp to copy patches via ssh -- this reuses a single+    connection for better speed.+  * Made _darcs/current polymorphic (but not really documented).+  * Made optimize --uncompress work with --partial repos.+  * Various minor interface improvements.+  * Made changes work better when specifying a file, and working in a+    partial repository.+  * Fixed bug in causing "Fail: _darcs/patches/unrevert: removeFile: does+    not exist (No such file or directory)".  Resolves bugs #57, #61.++ -- David Roundy <droundy@abridgegame.org>  Sun, 21 Nov 2004 08:29:24 -0500++darcs (1.0.0)++  * Fixed compile error when antimemoize is enabled.+  * Fixed bug that showed up when dealing with international characters in+    filenames.+  * Various documentation improvements.++ -- David Roundy <droundy@abridgegame.org>  Mon,  8 Nov 2004 06:12:08 -0500++darcs (1.0.0rc4)++  * Use autoconf to check for working install program.+  * Renamed rerecord to amend-record in a futile attempt to avoid+    confusion.+  * Made pull accept the --repodir option.+  * Fixed off-by-one error in annotate that kept users from seeing+    "deleted" version.+  * Check filesystem semantics at runtime to avoid using mmap on+    windows filesystems.+  * Fixed darcs.cgi to work properly when browsing history of renamed+    files.+  * Use anonymous file handle for temporary files in darcs.cgi -- fixes a+    temporary file leak and potentially improves security.+  * Added --summary option to commands that accept --dry-run.+  * Made pull prompt for confirmation when there is a conflict with+    unrecorded changes.+  * Made unrevert interactive.+  * Don't try to generate a new name on get if name was given explicitely.+  * Always mark conflicts, even if there's an obvious solution.+  * Quote conflict attribute values in xml output.+  * Fail if the user gives a newline in the patch name.+  * Fixed bug where new files didn't show up in darcs diff.+  * Really fix newlines in whatsnew -u.+  * Fixed bug in handling of tags in changes and annotate.+  * Fixed bug in default options containing "--".+  * Fixed various other build problems in 1.0.0rc3.+  * Fixed embarrassing failure-to-compile-on-windows bug.++ -- David Roundy <droundy@abridgegame.org>  Mon,  1 Nov 2004 05:19:01 -0500++darcs (1.0.0rc3)++  * Fixed bug leading to creation of empty "hunk" patches.+  * Fixed bug in rollback when there are pending changes.+  * Fixed push bug when default apply is --interactive.+  * Fixed a bug where "darcs pull --list-options" would try to+    complete to "home/.../darcs_repo" instead of "/home/.../darcs_repo".+  * Fixed flushing bug in darcs.cgi.+  * Fixed commutation bug with renames and file adds/removals.+  * Made --summary indicate conflicted changes.+  * Fixed generation of extra hunk in diff algorithm.+  * Added X-Mail-Originator header to emails sent by darcs.+  * Fixed a couple of bugs in the resolve command.+  * Added new cgi diff command to produce unified diff.+  * Notify when there are conflicts on push.+  * Added 'a' key to say yes to all remaining changes for interactive+    commands.+  * Automatically generate AUTHORS file from repo history.+  * Made pull --quiet actually quiet.+  * Fixed bugs in whatsnew -ls, and distinguished between manually added+    files and automatically added files.+  * Fixed bug in darcs --commands when called outside a repo.++ -- David Roundy <droundy@abridgegame.org>  Sun,  3 Oct 2004 07:45:05 -0400++darcs (1.0.0rc2)++  * Added support for comments in prefs files.+  * Added new --enable-antimemoize compile option which reduces memory+    usage at the expense of increased computational time.+  * Added a new command:  "reportbug"+  * Fixed a bug that prevented applying of a patch bundle to an+    "unoptimized" repo.+  * Fixed bug where asking for changes to a nonexistent file in a+    subdirectory would show the patch that created or renamed that+    subdirectory.+  * Improved the robustness of unrevert.  Now actions that will make+    unrevert impossible should warn the user.+  * Fixed bug when moving files or directories to the root directory of+    repo.+  * Various changes to make the --logfile way of specifying the patch name+    and comments in record more friendly:+    - Allows editing of the long comment even when --logfile is specified,+      if the --edit-long-comment option is also used.+    - When editing the long comment, the change summary is included below+      the actual text for reference, and the patch name is included in the+      first line (and thus may be modified).+    - The --logfile option is ignored if such a file doesn't exist.+    - A --delete-logfile option was added, which tells darcs to delete the+      file after doing the record.  This is intended to allow you to stick+      a --logfile=foo option in your defaults without accidentally+      recording multiple patches with the same comments because you forgot+      to modify it.+  * Fixed bug leading to .hi files in tarball.+  * Made ctrl-C work under windows, but only "pure" windows consoles, not+    in cygwin shells or mingw's rxvt (room for improvement here).+  * Fixed bug that led to curl not being tried when darcs is not compiled+    with libcurl.+  * Added an environment variable DARCS_USE_ISPRINT for people who use+    non-ascii characters in their files to indicate if the haskell standard+    library "isPrint" function works properly on their system (which+    depends on locale).+  * Reduced the number of hunks produced by the internal diff algorithm,+    when there are multiple equivalent ways of interpreting a change.+  * Made the --from-{patch,tag,match} options inclusive, and added a+    --{patch,match} option to diff (which was made easier to define by the+    inclusiveness change, since --patch x is now equivalent to+    --from-patch x --to-patch x).+  * Added support for a second argument to get, which specifies the name of+    the new directory.++ -- David Roundy <droundy@abridgegame.org>  Sun, 12 Sep 2004 06:54:45 -0400++darcs (1.0.0rc1)++  * Remove some lazy file IO which may have been causing trouble pushing in+    windows and using windows shares.+  * Various interface improvements and improved error messages.+  * Fixed bug that could cause conflicts in pending when unrecording a+    patch that contained two non-commuting non-hunk patches.+  * Fixed bug in --ask-deps option of record.+  * Added --exact-version option which gives the precise darcs context from+    which darcs was compiled.+  * MIME fixes in patch forwarding.+  * Various improvements to the darcs.cgi script.+  * Added --reverse option to changes.+  * Fixed patch numbering when file or directory arguments are given to an+    interactive command.++ -- David Roundy <droundy@abridgegame.org>  Sun, 15 Aug 2004 07:43:30 -0400++darcs (0.9.23)++  * Added a rerecord command, which will add changes to an existing+    recorded patch+  * Added support for a MOTD.+  * Vastly improved the speed and memory use of darcs optimize --checkpoint+    as well as darcs record, in the case where a record consists primarily+    of adds.++ -- David Roundy <droundy@abridgegame.org>  Mon, 26 Jul 2004 08:11:20 -0400++darcs (0.9.22)++  * add preliminary --context option to changes and get.+  * display change number, e.g. "(1/3)" in interactive commands.+  * show moves in summary format.+  * add hash of patch bundles in darcs send.+  * properly support --verbose and --quiet in add.+  * don't display binary data to screen.+  * fix bug in selecting patches by pattern.+  * fix various locking-related bugs introduced in 0.9.21.+  * fix bug when specifying logfile in a subdirectory.+  * support backslashes for directory separators in windows.+  * fix file modification time bug.++ -- David Roundy <droundy@abridgegame.org>  Sat, 26 Jun 2004 07:42:05 -0400++darcs (0.9.21)++  * made mv work even if you've already mv'ed the file or directory.+  * remember configure settings when reconfiguring.+  * added --leave-test-directory to save the directory in which the test is+    run on record or check.+  * added HTTP redirect support (thanks Benedikt).+  * fixed problems when unrecording a patch with conflits.+  * fixed locking on nfs (thanks Juliusz).+  * added preliminary version of a new cgi script for browsing darcs+    repositories (thanks to Will Glozer for contributing this).+  * add and modify a number of short flag options.+  * fix bug in applying new order patch bundles that are GPG signed.+  * fix bug in diff when a tagged version was requested.++ -- David Roundy <droundy@abridgegame.org>  Sat, 12 Jun 2004 05:39:48 -0400++darcs (0.9.20)++  * fix bug in darcs-createrepo.+  * add support for DARCS_SCP and DARCS_SSH environment variables.+  * add XML support for --summary options of changes and annotate.+  * better command-line completion on commands accepting a list of files or+    directories.+  * fix bug causing empty hunk patches to lead to failures.+  * fix bug where --all overrode file choice in record.+  * fix bug when testing patches that create subdirectories within subdirectories.+  * preserve pending changes when pulling or applying.+  * give better error message in pull when patch isn't readable.+  * allow sendEmail with no "to", just "cc" recipients.  This should fix+    the trouble with trying to --reply to a patch coming from a push rather+    than a send.++ -- David Roundy <droundy@abridgegame.org>  Wed,  5 May 2004 06:01:48 -0400++darcs (0.9.19)++  * fix bugs leading to failures in the wxhaskell interface.+  * fix bug that caused darcs diff to fail.+  * fixed bug in get that lead to _darcs/current/_darcs directories.+  * improved error reporting in several situations.+  * fixed bug when pulling or pushing into an empty repo.+  * added --summary option to changes to summarize the changes made in each+    patch.++ -- David Roundy <droundy@abridgegame.org>  Fri,  9 Apr 2004 07:19:34 -0400++darcs (0.9.18)++  * added support for sending email from windows using the MAPI interface.+    This code attaches the patch bundle in base64-encoded form, which darcs+    can't currently decode (expect that in the next release), but the patch+    bundle can be manually applied if a mail program does the decoding.+  * renamed "darcs push" to "darcs send" and added a new "darcs push"+    command roughly equivalent to the old "darcs push --and-apply".+  * removed support for setting up a test suite by simple creating a file+    named "darcs_test".  You now should use setpref to define the test+    suite command.+  * fixed some problems when working in a --partial repository.+  * lots of code was cleaned up.  We have enabled the -Wall compiler flag+    and are in the process of eliminating all the warnings.  This should+    make the code more friendly to new developers, and also helps with the+    next bullet point:+  * improved handling of errors--informative failure messages are more+    likely than they were before.+  * by default only check changes made since last checkpoint--this greatly+    speeds up check.+  * add --quiet option.  Some commands don't yet support this.  If+    there's a command you want to quiet down, let us know.+  * several performance enhancements: improved SHA1 performance, faster+    check and get on repositories with a long history and improved+    performance with very large files.++ -- David Roundy <droundy@abridgegame.org>  Thu,  1 Apr 2004 05:43:18 -0500++darcs (0.9.17)++  * fixed bug in darcs apply that made the --no-test option fail.+  * fixed bug that caused darcs to set file permissions to be+    non-world-readable.+  * darcs record and whatsnew can now accept file or directory arguments+    and limit their actions to changes in those files or directories.+  * darcs changes now can accept file or directory arguments and limit+    itself to changes affecting those files or directories.++ -- David Roundy <droundy@abridgegame.org>  Sat, 21 Feb 2004 08:12:34 -0500++darcs (0.9.16)++  * Add --sign-as=KEYID option to push command.+  * make optimize split up inventory for faster pulls+  * Allow use of a different make command for tests, such as gmake+  * Can now put prefs that would normally go in _darcs/prefs (defaults,+    binaries and boring) in ~/.darcs/ to set the prefs for all your+    repositories at once.+  * add primitive xml output to annotate of directory.+  * When pushing a patch, add the list of changes in the description.+  * refuse to rollback a patch twice, since that would cause problems.+  * make darcs diff accept optional arguments indicating files and+    directories to diff.+  * preserve permissions on files in working directory.+  * put docs in ...share/doc/darcs not share/darcs/doc.+  * add support for multiple-choice options.  This means that you can now+    set your default option in _darcs/prefs/defaults, and then override+    that default on the command line.+  * shortened --use-external-merge-tool option to --external-merge+  * more "boring" patterns.++ -- David Roundy <droundy@abridgegame.org>  Tue, 10 Feb 2004 07:08:14 -0500++darcs (0.9.15)++  * next step repository format transition--we use the new patch filenames.+  * fix handling of text files with no trailing newline--this will cause+    some trouble.  Darcs will require that you convert your repository+    using convert-repo.  This will leave you with a bunch of changes+    regarding trailing newlines which you will either want to record or+    revert.+  * the windows support is somewhat improved.+  * added simple "repair" command that can repair some kinds of+    inconsistencies in the repository.+  * added primitive "annotate" command to extract information about+    modifications to files and directories.+  * fixed handling of darcs mv to allow moving to directories in a more+    intuitive manner.+  * handling of binary files was dramatically improved in both memory and+    cpu usage.+  * added autoconf testing framework to clean up code dealing with+    different versions of ghc, features that don't exist on windows, bugs+    that only exist on windows, etc.+  * don't accept invalid flags.+  * add more patterns to boring and binary.+  * use autoconf test to handle posix signals and windows '\\' handling.+  * switch to using new patch filenames.+  * XML formatted output for 'changes' command+  * add support for unidiff-like whatsnew output.+  * fix bug in RTS memory calculation for large RAM size+  * add rollback command.+  * improve checkpointing support.+  * add diff-opts option to darcs diff.+  * add support for building docs using htlatex or hevea rather than+    latex2html.+  * use locking whereever it is needed.+  * add safe (atomic) writing of inventory files.++ -- David Roundy <droundy@abridgegame.org>  Fri, 12 Dec 2003 07:59:54 -0500++darcs (0.9.14)++  * darcs changes now shows times formatted according to current locale.+  * add support for automatically treating files containing ^Z or '\0' as+    binary.+  * add experimental checkpointing, allowing get to only download the+    recent change history.+  * allow darcs to be called within subdirectories of a repository.+  * make default be to compress patches.+  * add --summary option to whatsnew.+  * add trackdown command.+  * fix bug in darcs dist --verbose.+  * make darcs diff have closer behavior to cvs diff.  In particular, darcs+    diff with no arguments now gives you the difference between the working+    directory and the latest recorded version.+  * support external graphical merge tools.+  * fix bug where binary patch is created even with no change.+  * support darcs -v for version.  Also mention the darcs version in the+    usage mesage.+  * ignore empty lines in boring file and binary file.+  * preserve pending changes (e.g. file adds or darcs replaces) across+    revert and record.+  * create repositories with new patch filename format.+    The new repo format is now created alongside the old format, but the+    old format is read.  There is a tool called convert-repo that will+    convert an old format repo to have both formats.+  * use iso format for dates in record.+  * New patch-selecting interface.+    This patch only uses the new routine for revert, since it's not+    particularly well tested.  The text method now allows one to go back+    and edit previous patches.  The idea is that eventually all commands+    that need the user to select a subset of patches will use this routine.+  * use hash for cgi cache file names.+  * add preliminary experimental GUI support using wxhaskell.+  * remember author name after first record in a repo.+  * add unrevert command.+  * always match full pathnames when checking boringness or binaryness.+  * rewrite replace tokenizer for more speed.+  * make darcs compile with ghc 6.2 and later.+  * fix some bugs in darcs diff.+  * make --and-apply work locally as well as via ssh.+    Also added a --and-apply-as that uses sudo to run the apply command as+    a different user.++ -- David Roundy <droundy@abridgegame.org>  Mon, 10 Nov 2003 07:08:20 -0500++darcs (0.9.13)++  * Various performance enhancements.+  * add --pipe option to tag and record, which causes them to prompt for+    all their input, including date.  This can be useful when creating+    repository converters.+  * remove '-t' short command line option for '--to' and the '-o' short+    option for '--reponame'.+  * remove the darcs-patcher program.+        The functionality of the darcs-patcher program is taken over by+        the darcs apply command.  Several fancy features have been added,+        as described in the Apply section of the manual.+  * support spaces and (maybe) unicode in filenames.+  * updates to win32 support+  * push via ssh+  * add --without-libcurl option to configure+  * include DarcsURL in push email.+  * add support for reading and writing gzipped patch files.+  * allow multiple --to addresses on push, and also support --cc for+    additional addresses.+  * when pulling or pushing from lastrepo, say where lastrepo is.+  * only save lastrepo in get if the source repo wasn't a relative+    directory path.++ -- David Roundy <droundy@abridgegame.org>++darcs (0.9.12)++  * add manual section on building darcs.+  * improve scaling of checking for and resolving conflicts, which was an+    O(n^2) function.+  * escape ESC char when printing patches.+  * don't reorder patches unless necesary--this avoids an O(n^2) operation+    which was making a darcs record very slow when a lot of files were+    added.+  * fix default regexps for boring file (Thanks Trevor!)+  * replace now ignores files that aren't in the repo.+  * make darcs add refuse to add files whose subdirectories don't exist.+  * implement support for binary files.+  * added support for running external programs to fetch files.+  * fix conflict resolution bug from 0.9.11.+  * make the patcher run the test prior to applying.+  * add repo locking.+  * Fix bug when pulling from a repo containing just one patch (thanks+    Peter).+  * install cgi script in cgi-bin directory.++ -- David Roundy <droundy@abridgegame.org>++darcs (0.9.11)++  * A rewrite of the configure code and makefile (thanks to Peter Simons).+  * Added several new repository configuration options including a setpref+    command which allows you to set preferences options that are pulled+    from repo to repo.+  * Yet another rewrite of the merging code.+  * User can now revert changes on a change-by-change basis.+  * Yet another major improvement in speed and memory consumption.+  * Add a darcs diff command to compare two versions.++ -- David Roundy <droundy@abridgegame.org>  Mon, 30 Jun 2003 06:42:10 -0400++darcs (0.9.10)++  * Added a way to configure the default values for options to darcs+    commands.  See Appendix B of manual.+  * darcs push and pull now default to pulling and pushing from the most+    recently accessed repository (if you don't specify a repo).+  * Numerous bugfixes.++ -- David Roundy <droundy@abridgegame.org>  Wed, 21 May 2003 07:08:40 -0400++darcs (0.9.9)++  * Created a way to have a "centralized server".  (See darcs-patcher+    chapter in manual).+  * Added new darcs-server package.+  * Switch to new repository format.  Note that your repo will only be+    converted to the new format if you use certain commands such as+    unpull.  You can recognize the new format by the presence of a+    _darcs/inventories/ directory.+  * Add the ability to sign patches sent with push using gnupg and to+    verify those signatures when applying.  (This is the authentication+    basis for the above-mentioned server).+  * Fix bug in application of a file rename patch.++ -- David Roundy <droundy@abridgegame.org>  Thu,  8 May 2003 06:58:42 -0400++darcs (0.9.8)++  * Fix rare bug in check when files happen to be a multiple of 1024 bytes+    in length.+  * Fix bug in reading patch ids with long comments from local files.+  * Prepare for a change in the repository format.  The format doesn't+    change for this version, but version 0.9.8 is able to read the new+    repository format.++ -- David Roundy <droundy@abridgegame.org>  Wed, 30 Apr 2003 08:54:18 -0400++darcs (0.9.7)++  * Fix a couple of rename conflict bugs.+  * Add new test suite framework, along with several tests.+  * Several major optimizations for speed and memory.+  * Added --ignore-times option to not assume that when a file+    modification time hasn't changed the file itself hasn't changed.++ -- David Roundy <droundy@abridgegame.org>  Sat, 26 Apr 2003 07:57:01 -0400++darcs (0.9.6)++  * Fixed a couple of bugs in the merging of conflicting renames.+  * Added an interface to include long comments when recording.+  * Improve the interface of pull, allowing for viewing the patches before+    pulling them.+  * Include zsh command completion examples with docs.+  * Massively improved responsiveness in command completion.+  * Use packed strings to save memory.+  * Fixed a bug that shows up in empty repos.+  * Fixed multiple bugs in the mv command.++ -- David Roundy <droundy@abridgegame.org>  Thu, 17 Apr 2003 09:34:34 -0400++darcs (0.9.5)++  * Improve merge of creation of files and directories with the same name.+  * Add darcs push and apply commands, which are the beginning of work+    towards supporting a "centralized server" concept a la CVS.  However,+    they are also useful for a "Linus" style workflow, based on emailing+    patches.  In theory they could also be used to provide a smart server+    that could server pulls using less bandwidth.+  * Add an unpull command analagous to unrecord, but which removes the+    patches from the working directory also.+  * Enable the mv command, since the mv patches have now been supported by+    a couple of versions.+  * Include zsh_completion code, thanks to Aaron Denney <wnoise@ofb.net>.++ -- David Roundy <droundy@abridgegame.org>  Wed,  9 Apr 2003 07:52:01 -0400++darcs (0.9.4)++  * Speed up whatsnew and record in the case where there are huge numbers+    of extra files in the working directory.+  * Small (~10%) speedup in get.++ -- David Roundy <droundy@abridgegame.org>  Fri,  4 Apr 2003 09:08:38 -0500++darcs (0.9.3)++  * Optimized whatsnew and record by seting modification time of "current"+    files equal to that of working files if they are identical, so I won't+    have to check again if the working one hasn't been changed.+  * Rewrite file renaming code (no creation).+  * Add support for replacing tokens in files.+  * Make cgi output work more accurately, and point out which files were+    modified by each patch.+  * Add a caching feature to the cgi script to speed things up a bit.+  * Turn on creation of dependencies when recording.+  * Add a 'tag' command.+  * Rewrote the 'pull' code to hopefully speed it up (and in any case to+    greatly simplify it).++ -- David Roundy <droundy@abridgegame.org>  Thu,  3 Apr 2003 07:08:05 -0500++darcs (0.9.2)++  * Add build dependency on tetex and latex2html+  * Have internal diff code properly respond to deleted files and+    directories.+  * Create file and directory rename patch types. (no creation--which+    means that I am waiting to create commands to create such patches+    until later, to avoid backward compatibility issues of repos.)+  * Add support for patch dependencies. (no creation)+  * Add support for token replacement patches. (no creation)++ -- David Roundy <droundy@abridgegame.org>  Thu, 27 Mar 2003 07:59:09 -0500++darcs (0.9.1)++  * Make darcs get --verbose actually be verbose (which is important+    because it takes so long that the user might be afraid it's hanging.+  * Speed up the merge in complicated cases, possibly dramatically.+  * Add a darcs remove command.++ -- David Roundy <droundy@abridgegame.org>  Mon, 10 Mar 2003 09:48:55 -0500++darcs 0.9.0++  * Initial Release.++ -- David Roundy <droundy@abridgegame.org>  Wed,  3 Mar 2003 13:51:58 -0500++++Local variables:+mode: outline+outline-regexp: "[dD]\\| +\\*+"+paragraph-separate: "[  ]*$"+end:
README view
@@ -11,15 +11,8 @@ Compilation and Installation ============================ -Darcs currently supports two build systems: a cabal-based system and a legacy-autotools-based system, and a cabal-based system. CABAL IS RECOMMENDED and the-autotools system is deprecated: in future releases, autotools support will be-removed.--If a "configure" file is present, autotools is supported.  If a-"Setup.lhs" file is present, cabal is supported.  Currently there is a-separate source tarball for each build system; either can be used in-unstable checkouts.+Building Darcs requires the cabal package, version 1.6 or higher.  The+cabal-install package is also recommended.  Using GHC 6.10.3 or newer is STRONGLY RECOMMENDED. You can compile darcs with GHC 6.8, but there are several caveats. If you are using 6.8.2 or older, please@@ -33,17 +26,12 @@ 64-bit system, darcs may hang when you exit a pager when compiled with GHC older than 6.10.3. Although this is harmless, it is quite inconvenient. -Using Cabal--------------This method requires the cabal package, version 1.6 or higher.  The-cabal-install package is also recommended.- If you have the "cabal-install" package on your system (that is, there is a "cabal" executable in your path), you can use the following command to create an executable in ~/.cabal/bin/darcs (this will also automatically fetch and build dependencies from the Hackage server). +    $ cabal update     $ cabal install  Otherwise, if you have the "cabal" package but not the "cabal-install"@@ -64,33 +52,15 @@ library (and development headers). If, for some reason, you cannot provide cURL, please pass "-f-curl" to the configure step above. -Using Autotools---------------- -If you have the normal, autotools-based tarball, this sequence should work-for you (if you are in doubt, this is likely the case):--    $ ./configure-    $ make-    # make install--You first need to run `autoconf` if you obtained the source tree from the-darcs repository (but this is not needed for release tarballs).--For more information, please see the manual:-- * http://www.darcs.net/manual- * doc/manual/darcs.ps-- Hacking ======= For more information about darcs hacking and best practices please check-the darcs wiki at http://wiki.darcs.net/DarcsWiki+the darcs wiki at http://wiki.darcs.net  Of particular interest are the following documents:-  * http://wiki.darcs.net/index.html/DeveloperFAQ-  * http://wiki.darcs.net/index.html/DeveloperTips+  * http://wiki.darcs.net/Development/GettingStarted+  * http://wiki.darcs.net/Development/FAQ  Testing =======
Setup.lhs view
@@ -42,7 +42,7 @@ import System.IO (openFile, IOMode (..)) import System.Process (runProcess) import System.IO.Error ( isDoesNotExistError )-import Data.List( isSuffixOf, sort, partition )+import Data.List( isPrefixOf, isSuffixOf, sort, partition )  import System.FilePath       ( (</>), splitDirectories, isAbsolute ) import Foreign.Marshal.Utils ( with )@@ -99,7 +99,7 @@                "bugs-darcs-2.dir",                "bugs-hashed.dir",                "bugs-old-fashioned-inventory.dir",-               "tests_network-.dir"],+               "tests-network.dir"],    sDistHook = \ pkg lbi hooks flags -> do     let pkgVer = packageVersion pkg@@ -263,36 +263,41 @@  data TestKind = Bug | Test | Network deriving Eq -instance Show TestKind where-    show Bug = "bugs"-    show Test = "tests"-    show Network = "tests/network"+testDir :: TestKind -> String+testDir Bug = "tests"+testDir Test = "tests"+testDir Network = "tests/network" -flat :: (Show a) => a -> String-flat a = [ if x == '/' then '_' else x | x <- show a ]+deslash :: Char -> Char+deslash '/' = '-'+deslash x  = x -isTest :: FilePath -> Bool-isTest = (".sh" `isSuffixOf`)+isSh :: FilePath -> Bool+isSh = (".sh" `isSuffixOf`) +-- | By convention, a test script starts with "failing-" iff it is+-- expected to fail, i.e. it is a bug that hasn't been fixed yet.+isTest :: TestKind -> FilePath -> Bool+isTest Bug = ("failing-" `isPrefixOf`)+isTest _   = not . isTest Bug+ execTests :: FilePath -> TestKind -> String -> [String] -> IO () execTests darcs_path k fmt tests = do-  let dir = (flat k) ++ "-" ++ fmt ++ ".dir"+  let dir = map deslash (testDir k) ++ (if null fmt then fmt else  "-" ++ fmt) ++ ".dir"   rmRf dir-  cloneTree (show k) dir+  cloneTree (testDir k) dir   withCurrentDirectory dir $ do     createDirectory ".darcs"     when (not $ null fmt) $ appendFile ".darcs/defaults" $ "ALL " ++ fmt ++ "\n"     putStrLn $ "Running tests for format: " ++ fmt-    exec- where exec = do-         fs <- case tests of-                  [] -> sort `fmap` getDirectoryContents "."-                  x -> return x-         cwd <- getCurrentDirectory-         let run = filter isTest fs-         res <- Harness.runTests (Just darcs_path) cwd run-         when ((not res) && (k /= Bug)) $ fail "Tests failed"-         return ()+    fs <- case tests of+            [] -> sort `fmap` getDirectoryContents "."+            x -> return x+    let run = filter (\f -> isSh f && isTest k f) fs+    cwd <- getCurrentDirectory+    res <- Harness.runTests (Just darcs_path) cwd run+    when ((not res) && (k /= Bug)) $ fail "Tests failed"+    return ()  individualTests :: FilePath -> [String] -> IO () individualTests darcs_path tests = do@@ -303,19 +308,18 @@             exec _ [] = return ()             exec kind to_run = allTests darcs_path kind to_run             find t = do-              let c = [t, t ++ ".sh"] ++ tryin "tests" t ++ tryin "bugs" t+              let c = [t, t ++ ".sh"] ++ tryin "tests" t                         ++ tryin "network" t               run <- map kindify `fmap` filterM doesFileExist c               return $ take 1 run             kindify test = case splitDirectories test of-                             [p, y] -> (parse_kind p, y)+                             [p, y] -> (parse_kind p y, y)                              _ -> error $ "Bad format in " ++ test ++                                           ": expected type/test"-            parse_kind "tests" = Test-            parse_kind "bugs" = Bug-            parse_kind "network" = Network-            parse_kind x = error $ "Test prefix must be one of " ++-                           "[tests, bugs, network] in " ++ x+            parse_kind "tests" y   = if isTest Bug y then Bug else Test+            parse_kind "network" _ = Network+            parse_kind x _ = error $ "Test prefix must be one of " +++                              "[tests, network] in " ++ x   allTests :: FilePath -> TestKind -> [String] -> IO ()
− bugs/add_permissions.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash-## Darcs should refuse to add an unreadable file, because unreadable-## files aren't recordable.-##-## Copyright (C) 2005  Mark Stosberg-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. ../tests/lib--abort_windows                   # does not work on Windows.-rm -rf temp1                    # Another script may have left a mess.-darcs initialize --repodir temp1-touch temp1/unreadable-chmod a-r temp1/unreadable      # Make the file unreadable.-not darcs add --repodir temp1 no_perms.txt 2>temp1/log-fgrep -i 'permission denied' temp1/log-rm -rf temp1
− bugs/dist-v.sh 
@@ -1,18 +0,0 @@-#!/usr/bin/env bash-set -ev--# tests for "darcs dist"--not () { "$@" && exit 1 || :; }--rm -rf temp1-mkdir temp1-cd temp1-darcs init-# needs fixed on FreeBSD-darcs dist -v 2> log-not grep error log-cd ..--rm -rf temp1-
− bugs/emailformat.sh 
@@ -1,46 +0,0 @@-#!/usr/bin/env bash--# This appears to hang on Windows--set -ev-# TODO: is this really enough to make all commands interpret the given strings -# as latin1?-export LANG="en_US.ISO-8859-1"--rm -rf temp1-rm -rf temp2-mkdir temp1-mkdir temp2-cd temp1--seventysevenaddy="<aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa@bbbbbbbbbb.cccccccccc.abrasoft.com>"--darcs init--echo "Have you seen the smørrebrød of René Çavésant?" > non_ascii_file-darcs add non_ascii_file-darcs record -am "non-ascii file add" -A test--cd ../temp2-darcs init-cd ../temp1--# long email adress: check that email adresses of <= 77 chars don't get split up-darcs send --from="Kjålt Überström $seventysevenaddy" \-           --subject "Un patch pour le répositoire" \-           --to="Un garçon français <garcon@francais.fr>" \-           --sendmail-command='cp /dev/stdin mail_as_file %<' \-           -a ../temp2--cat mail_as_file-# The long mail address should be in there as a whole-grep $seventysevenaddy mail_as_file--# Check that there are no non-ASCII characters in the mail-ghc -e 'getContents >>= return . not . any (> Data.Char.chr 127)' < mail_as_file | grep '^True$'---cd ..-rm -rf temp1-rm -rf temp2-
− bugs/issue1013_either_dependency.sh 
@@ -1,53 +0,0 @@-#!/usr/bin/env bash-set -ev-export DARCS_EMAIL=test-rm -rf tmp_d1 tmp_d2 tmp_d-# Preparations:-# Set up two repos, each with a patch (d1 and d2 respectively) with both-# an individual change and a change that is identical in both repos,-# and thus auto-merge, i.e., they don't conflict in darcs2.  Pull them-# together and record a patch (problem) on top of the auto-merged change,-# so that it depends on EITHER of two patches.--mkdir tmp_d1; cd tmp_d1-darcs init --darcs-2-echo a > a-echo b > b-echo c > c-darcs rec -alm init-echo a-independent > a-echo c-common > c-darcs rec -am d1-cd ..-darcs get --to-patch init tmp_d1 tmp_d2-cd tmp_d2-echo b-independent > b-echo c-common > c-darcs rec -am d2-darcs pull -a ../tmp_d1-# no conflicts -- c-common is identical-echo c-problem > c-darcs rec -am problem-cd ..--# I want to pull the 'problem' patch, but expect darcs to get confused-# because it doesn't know how to select one of the two dependent patches.--darcs get --to-patch init tmp_d2 tmp_d-cd tmp_d-echo n/n/y |tr / \\012 |darcs pull ../tmp_d2-darcs cha--# This is weird, we got d2 though we said No.  I would have expected-# darcs to skip the 'problem' patch in this case.--# Try to pull d1 and unpull d2.--darcs pull -a ../tmp_d1-exit 1 # darcs hangs here (2.0.2+77)!-echo n/y/d |tr / \\012 |darcs obl -p d2--# The obliterate fails with: patches to commute_to_end does not commutex (1)--cd ..-rm -rf tmp_d1 tmp_d2 tmp_d
− bugs/issue1014_identical_patches.sh 
@@ -1,60 +0,0 @@-#!/usr/bin/env bash-set -ev--# Set up a base repo. Our experiment will start from this point-mkdir base-cd base-darcs init --darcs-2-printf "Line1\nLine2\nLine3\n" > foo-darcs rec -alm Base-cd ..--# Now we want to record patch A, which will turn "Line2" into "Hello"-darcs get base a-cd a-printf "Line1\nHello\nLine3\n" > foo-darcs rec --ignore-times -am A-cd ..--# Make B the same as A-darcs get base b-cd b-printf "Line1\nHello\nLine3\n" > foo-darcs rec --ignore-times -am B-cd ..--# Now we make a patch C that depends on A-darcs get a ac-cd ac-printf "Line1\nWorld\nLine3\n" > foo-darcs rec --ignore-times -am C-cd ..--# Merge A and B-darcs get a ab-cd ab-darcs pull -a ../b-darcs revert -a-cd ..--# And merge in C too-darcs get ab abc-cd abc-darcs pull -a ../ac-darcs revert -a-cd ..--# Now we can pull just B and C into base-darcs get base bc-cd bc-darcs pull ../abc -ap 'B|C'-cd ..--# Now we have base, B and C in a repository.  At this point we're correct.--# Let's try merging AC with BC now, here we discover a bug.--darcs get ac abc2-cd abc2-darcs pull -a ../bc-
− bugs/issue1190_unmarked_hunk_replace_conflict.sh 
@@ -1,43 +0,0 @@-#!/usr/bin/env bash-## Test for issue1190 - conflicts between HUNK and REPLACE are not-## marked by --mark-conflicts.-##-## Copyright (C) 2009  Trent W. Buck-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. ../tests/lib--rm -rf d e                      # Another script may have left a mess.-darcs init    --repo d/-printf %s\\n foo bar baz >d/f-darcs record  --repo d/ -lam f1-darcs get d/ e/-darcs replace --repo e/ --force bar baz f-darcs record  --repo e/ -lam replacement-printf %s\\n foo bar quux >d/f  # replace baz with quux-darcs record  --repo d/ -am f2--## There ought to be a conflict here, and there is.-darcs pull    --repo e/ d/ -a --mark-conflicts-## The file ought to now have conflict markers in it.-grep 'v v v' e/f-rm -rf d/ e/                    # Clean up after ourselves.
− bugs/issue1196_whatsnew_falsely_lists_all_changes.sh 
@@ -1,21 +0,0 @@-#!/usr/bin/env bash-set -ev--not () { "$@" && exit 1 || :; }--rm -rf temp1-mkdir temp1-cd temp1--darcs init-touch aargh-darcs add aargh-echo utrecht > aargh--darcs wh foo foo/../foo/. > out-cat out-not grep utrecht out--cd ..-rm -rf temp1-
− bugs/issue1266_init_inside_a_repo.sh 
@@ -1,33 +0,0 @@-#!/usr/bin/env bash-## Test for issue1266 - attempting to initialize a repository inside-## another repository should cause a warning, because while perfectly-## legitimate, it is likely to be accidental.-##-## Copyright (C) 2009  Trent W. Buck-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. ../tests/lib--rm -rf temp1 out                # Another script may have left a mess.-darcs init --repodir temp1-darcs init --repodir temp1/temp2 2>&1 | tee out-grep -i WARNING out             # A warning should be printed.
− bugs/issue1327.sh 
@@ -1,27 +0,0 @@-#!/usr/bin/env bash-set -ev--# See issue1327.-# results in the error:-# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452---rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-echo fileA version 1 > fileA-echo fileB version 1 > fileB-darcs add fileA fileB-darcs record --author foo@bar --ignore-times --all -m "Add fileA and fileB"-echo fileA version 2 > fileA-darcs record --author foo@bar --ignore-times --all -m "Modify fileA"-cd ..-darcs get temp1 temp2-cd temp2-darcs obliterate -p "Modify fileA" --all-darcs unrecord -p "Add fileA and fileB" --all-darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA"-cd ../temp1-darcs pull --all ../temp2-echo y | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"
− bugs/issue1337_darcs_changes_false_positives.sh 
@@ -1,37 +0,0 @@-#!/usr/bin/env bash-## Test for issue1337 - darcs changes shows unrelated patches-## Asking "darcs changes" about an unrecorded file d/f will list the-## patch that creates the parent directory d/ (instead of no patches).-##-## Copyright (C) 2009  Trent W. Buck-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. ../tests/lib--rm -rf temp1-darcs init --repodir temp1-cd temp1-mkdir d-darcs record -lam d d-# We use --match 'touch d/f' instead of simply d/f because the latter-# prints "Changes to d/f:\n" before the count.-test 0 -eq "$(darcs changes --count --match 'touch d/f')"
− bugs/issue1396_changepref-conflict.sh 
@@ -1,32 +0,0 @@-#!/usr/bin/env bash-set -ev--. ../tests/lib--rm -rf temp1 temp1a temp1b--mkdir temp1-cd temp1-darcs init-darcs setpref test 'echo nothing'-darcs record -am 'null pref'-cd ..--darcs get temp1 temp1a-cd temp1a-darcs setpref test 'echo a'-darcs record -am 'pref a'-cd ..--darcs get temp1 temp1b-cd temp1b-darcs setpref test 'echo b'-darcs record -am 'pref b'-cd ..--cd temp1-darcs pull -a ../temp1a --dont-allow-conflicts-not darcs pull -a ../temp1b --dont-allow-conflicts-cd ..--rm -rf temp1 temp1a temp1b
− bugs/issue1401_bug_in_get_extra.sh 
@@ -1,44 +0,0 @@-#!/usr/bin/env bash-## Test for issue1401 - when two repos share a HUNK patch, but that-## patch's ADDFILE dependency is met by different patches in each-## repo, it becomes impossible to pull between the two repos.-##-## Copyright (C) 2009  Trent W. Buck-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. ../tests/lib--## This bug only affects darcs-2 repositories.-fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 0--rm -rf d e                      # Another script may have left a mess.-darcs initialize --repodir d/-darcs initialize --repodir e/-touch d/f d/g e/f-darcs record     --repodir d/ -lam 'Add f and g'-darcs record     --repodir e/ -lam 'Add f'-echo >d/f-darcs record     --repodir d/ -am 'Change f'-darcs pull       --repodir e/ -a d/-darcs obliterate --repodir e/ -ap 'Add f and g'-darcs pull       --repodir e/ -a d/-rm -rf d/ e/                    # Clean up after ourselves.
− bugs/issue1406.sh 
@@ -1,19 +0,0 @@-#!/bin/sh-rm -rf temp1-darcs init --repodir temp1--cd temp1--echo "test exit 1" > _darcs/prefs/prefs-echo "name" > _darcs/prefs/author-echo "a" > a-darcs record --look-for-adds --no-test --all --patch-name=p1-echo "b" >> a-echo "y" | darcs amend-record --all --patch=p1--# There should be one patch in the repo-test 1 -eq `darcs changes --count` || exit 1--# Another check: there should be nothing new after a is restored-echo "a" > a-darcs whatsnew -l && exit 1 || exit 0
− bugs/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.--. ../tests/lib--rm -rf R                        # Another script may have left a mess.--## Use the first UTF-8 locale we can find.-export LC_ALL=$(locale -a | egrep 'utf8|UTF-8' | head -1)-export DARCS_DONT_ESCAPE_ANYTHING=True--## If LC_ALL is the empty string, this system doesn't support UTF-8.-if test -z "$LC_ALL"-then exit 1-fi--darcs init      --repo R-echo '首頁 = א₀' >R/'首頁 = א₀'-darcs record    --repo R -lam '首頁 = א₀' '首頁 = א₀'-darcs changes   --repo R -v '首頁 = א₀' >R/log-#cat R/log                      # Show the humans what the output was.-grep -c '首頁 = א₀' R/log >R/count-echo 5 >R/expected-count-cmp R/count R/expected-count    # Both count files should contain "5\n".-rm -rf R                        # Clean up after ourselves.
− bugs/issue1461_case_folding.sh 
@@ -1,83 +0,0 @@-#!/usr/bin/env bash-## Test for issue1461 - patches to files whose names only differ by-## case can be wrongly applied to the same file in the working directory.-##-## Copyright (C) 2009 Eric Kow-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. ../tests/lib                  # Load some portability helpers.-rm -rf lower upper joint        # Another script may have left a mess.-mkdir lower upper--cd lower-darcs init-cat > a << EOF-1-2-3-EOF-darcs add a-darcs record -am 'lower init a'-cd ..--cd upper-darcs init-cat > A << EOF-1-2-3-EOF-darcs add A-darcs record -am 'upper init A'-cd ..--darcs get lower joint-cd joint-darcs pull -a ../upper-cd ..--cd lower-cat > a << EOF-one lower-2-3-EOF-darcs record -am 'lower modify'-cd ..--cd upper-cat > A << EOF-1-2-three upper-EOF-darcs record -am 'upper modify'-cd ..--cd joint-darcs pull ../lower -a-darcs pull ../upper -a-grep one a && not grep three a-grep three A && not grep one A-cd ..-# clean up after ourselves-rm -rf lower upper joint
− bugs/issue1473_annotate_repodir.sh 
@@ -1,21 +0,0 @@-#!/usr/bin/env bash-set -ev--. ../tests/lib-rm -rf temp-mkdir temp-cd temp-darcs init-mkdir a b-touch a/a b/b-darcs add --rec .-darcs record -a -m ab -A test-darcs annotate a/a-# annotate --repodir=something '.' should work-cd ..-darcs annotate --repodir temp '.'-cd temp--cd ..-rm -rf temp-
− bugs/issue27.sh 
@@ -1,43 +0,0 @@-#!/bin/sh--set -ev--rm -rf temp1 temp2-mkdir temp1 temp2-cd temp1-darcs init-echo first > a-darcs add a-darcs record --pipe --all --patch-name=first <<EOF-Thu Sep 18 22:37:06 MSD 2008-author-EOF--echo first > b-darcs add b-darcs record --pipe --all --patch-name=first <<EOF-Thu Sep 18 22:37:06 MSD 2008-author-EOF--cd ../temp2-darcs init-darcs pull --all --dont-allow-conflicts ../temp1-echo second >> a-darcs record --pipe --all --patch-name=second <<EOF-Thu Sep 18 22:37:07 MSD 2008-author-EOF--cd ../temp1-echo second >> b-darcs record --pipe --all --patch-name=second <<EOF-Thu Sep 18 22:37:07 MSD 2008-author-EOF--darcs pull --all --dont-allow-conflicts ../temp2-test `darcs changes --count` = "4"-cd ..--rm -rf temp1 temp2
− bugs/issue390_whatsnew.sh 
@@ -1,33 +0,0 @@-#!/usr/bin/env bash--# For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory--set -ev--if ! test -x "$(which strace)"-then echo skipping test since strace was not found-     exit-fi--rm -rf temp-mkdir temp-cd temp-darcs init-date > file1-date > file2-darcs add file*-darcs record -am "test"--strace darcs whatsnew file1 &> out-# we should be accessing file1-grep file1 out-# but shouldn't be accessing file2-if grep file2 out-then-    echo A whatsnew for file1 should not involve a 'stat' call to file2-    exit 1-else-    echo Yay.  We pass.-fi--rm -rf temp
− bugs/issue558_broken_pipe.sh 
@@ -1,29 +0,0 @@-#!/usr/bin/env bash--# For issue588, "amend-record --look-for-adds end up with two "addfile" entries"--set -ev-rm -rf temp1-darcs init --repodir temp1--export EMAIL=me--cd temp1--date > f-darcs add f-darcs rec -am p1-for (( i=0 ; i < 500; i=i+1 )); do-  echo $i >> f;-  darcs rec -am p$i-done--darcs changes 2> err | head--touch correcterr--diff correcterr err--cd ..--rm -rf temp1
− bugs/issue944_partial_inventory.sh 
@@ -1,46 +0,0 @@-#!/usr/bin/env bash--set -ev--test $DARCS || DARCS=$PWD/../darcs-ACTUAL_DARCS=`which $DARCS`-DARCSPATH=`dirname $ACTUAL_DARCS`-PATH="$DARCSPATH:$PATH"-export PATH--# create base repository-rm -rf temp1-mkdir temp1-cd temp1-darcs init--echo first > a-darcs add a-darcs record -am first-darcs tag --checkpoint 'Tag 1'--echo second > b-darcs add b-darcs record -am second-darcs tag --checkpoint 'Tag 2'--echo third > c-darcs add c-darcs record -am third-darcs tag --checkpoint 'Tag 3'--# create a partial copy of the base repository and modify it-cd ..-rm -rf temp2-darcs get --partial temp1 temp2-cd temp2--# instead of the following three commands one could also use darcs optimize-echo mistake > a-darcs record -am mistake-darcs unrecord -ap mistake--# now check the repository-darcs check-# => darcs: failed to read patch: ...-
− bugs/merging_newlines.sh 
@@ -1,47 +0,0 @@-#!/usr/bin/env bash-set -ev--# Note that this is fixed, the lines marked # BUG HERE-# should be moved back into merging_newlines.sh--# trick: requiring something to fail-not () { "$@" && exit 1 || :; }--rm -rf temp1 temp2--# set up the repository-mkdir temp1-cd temp1-darcs init-cd ..--cd temp1-echo "apply allow-conflicts" > _darcs/prefs/defaults-# note: to make this pass, change echo to echo -n-# is that right?-echo "from temp1" > one.txt-darcs add one.txt-darcs record -A bar -am "add one.txt"-echo >> one.txt-darcs wh -u-cd ..--darcs get temp1 temp2-cd temp2-# reality check-darcs show files | grep one.txt-echo "in tmp2" >> one.txt-darcs whatsnew -s | grep M-darcs record -A bar -am "add extra line"-darcs annotate -p . -u-darcs push -av > log-cat log-not grep -i conflicts log-# BUG HERE-# after a conflict, darcs resolve should report a conflict-darcs mark-conflicts > log 2>&1-cat log-not grep -i 'no conflicts' log-cd ..--rm -rf temp1 temp2
− bugs/newlines.sh 
@@ -1,28 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1 temp2--# set up the repository-mkdir temp1-cd temp1-darcs init-cd ..--cd temp1-echo -n "from temp1" > one.txt-darcs add one.txt-darcs record -A bar -am "add one.txt"-echo >> one.txt-cd ..--darcs get temp1 temp2-cd temp2-echo "in tmp2" >> one.txt-darcs record -A bar -am "add extra line"-lines_added=`darcs changes -v --last=1 | grep '\+' | wc -l`-echo $lines_added-test $lines_added -eq 1-cd ..--rm -rf temp1 temp2
− bugs/nfs-failure.sh 
@@ -1,35 +0,0 @@-#!/bin/sh--set -ev--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-echo first > a-darcs add a-darcs record --pipe --all --patch-name=first <<EOF-Thu Sep 18 22:37:06 MSD 2008-author-EOF--echo first > b-darcs add b-darcs record --pipe --all --patch-name=first <<EOF-Thu Sep 18 22:37:06 MSD 2008-author-EOF--# it seems that somehow the following occasionally fails on an nfs-# filesystem when darcs is compiled with ghc 6.6.--darcs get . ../temp2--# it fails with something like:--# darcs: ./_darcs/patches/20080918223706-f64cd-6b512400a8108808b7ba7057f0eac2adf473b3ae.gz: copyFile: resource busy (file is locked)---cd ..--rm -rf temp1 temp2
− bugs/record-scaling.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash-## Test for issueN - darcs record shouldn't access old inventories!-##-## Copyright (C) 2008  David Roundy-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. ../tests/lib                  # Load some portability helpers.-which strace                    # This test requires strace(1).-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repo.-touch R/a-unique-filename-strace -eopen -oR/trace \-  darcs record  --repo R -lam 'A unique commit message.'-grep a-unique-filename R/trace-grep _darcs/hashed_inventory R/trace-not grep _darcs/inventories/ R/trace-rm -rf R                        # Clean up after ourselves.
− bugs/time-stamps.sh 
@@ -1,52 +0,0 @@-#!/usr/bin/env bash--# test for broken time stamps--set -ev--. lib.sh--rm -rf temp-mkdir temp-cd temp-darcs init --hashed--echo this is my favorite test > foobar-darcs add foobar-sleep 2 # so the time stamps won't accidentally be identical-darcs record -am 'add foobar'--HASHVAL=0000000025-4cbbfd8ce543076b132b13b60ae06d0189ee80b4d5908abb5e060d331d25eb5c--if test -d _darcs/pristine.hashed;-then-  ls _darcs/pristine.hashed-  test -f _darcs/pristine.hashed/$HASHVAL-  # verify that the modification time of the file in the pristine cache-  # is identical to the modification time of the file in the working-  # directory.-  not test foobar -ot _darcs/pristine.hashed/$HASHVAL-  not test foobar -nt _darcs/pristine.hashed/$HASHVAL-else-  not test foobar -ot _darcs/pristine/foobar-  not test foobar -nt _darcs/pristine/foobar-fi--# Now let's verify that the test actually works...--sleep 1-touch foobar--if test -d _darcs/pristine.hashed;-then-  not test foobar -ot _darcs/pristine.hashed/$HASHVAL-  test foobar -nt _darcs/pristine.hashed/$HASHVAL-else-  not test foobar -ot _darcs/pristine/foobar-  test foobar -nt _darcs/pristine/foobar-fi---cd ..--rm -rf temp
− contrib/cgi/README.in 
@@ -1,42 +0,0 @@-darcs.cgi is the darcs repository viewer.  It provides a web interface-for viewing darcs repositories, using XSLT to transform darcs' XML-output into XHTML. It is written in perl and is more featureful than-the older haskell cgi program darcs_cgi.lhs (seen in URLs as "darcs").--dependencies--  darcs.cgi requires with the following tools and has been tested with-  the version mentioned:--  darcs-1.0.1           http://www.darcs.net-  libxslt-1.1.6         http://xmlsoft.org/XSLT/-  perl-5.8.0            http://www.perl.com--installation--  1) copy darcs.cgi to your webserver's cgi directory, eg-     /usr/lib/cgi-bin. A symlink probably won't do. Make-     sure it's executable.-  2) copy cgi.conf to @sysconfdir@/darcs/cgi.conf and edit appropriately.-     You can overwrite the cgi.conf used by the old darcs cgi script.-     You probably don't need to change anything here.-  3) copy the xslt directory to @datadir@/darcs/xslt-  4) copy xslt/styles.css to @sysconfdir@/darcs/styles.css--  Test by browsing "http://<host>/cgi-bin/darcs.cgi/".--troubleshooting--  if the configuration is incorrect error messages will be printed to-  the webserver's error log, for example "/var/log/apache/error.log".--  you can also double check the configuration by running darcs.cgi-  from the command line and supplying a --check argument:--     $ ./darcs.cgi --check--character encodings--  if your repositories contain files with characters encoded in-  something other than ASCII or UTF-8, change the 'xml_encoding'-  setting in cgi.conf to the appropriate encoding.
− contrib/cgi/cgi.conf.in 
@@ -1,31 +0,0 @@-# This is an example for cgi.conf--# reposdir is the directory containing the repositories--reposdir = /var/www/repos--# cachedir is a directory writable by www-data (or whatever user your cgi-# scripts run as) which is used to cache the web pages.--cachedir = /var/cache/darcs--# The following are used by darcs.cgi (not darcs_cgi)-PATH = /bin:/usr/bin:/usr/local/bin--# paths to executables, or just the executables if they are in 'PATH'-#darcs = darcs-#xsltproc = xsltproc--# Path to XSLT templates (default is /usr/local/share/darcs/xslt)-xslt_dir = @datadir@/darcs/xslt--# HTTP request path of the style sheet, the default will magically read -# @sysconfdir@/darcs/styles.css-#stylesheet = /cgi-bin/darcs.cgi/styles.css--css_styles  = @sysconfdir@/darcs/styles.css--# encoding to include in XML declaration.  Set this to the encoding used-# by the files in your repositories.--xml_encoding = UTF-8
− contrib/cgi/darcs.cgi.in 
@@ -1,491 +0,0 @@-#!/usr/bin/perl -T-#-# darcs.cgi - the darcs repository viewer-#-# Copyright (c) 2004 Will Glozer-#-# Permission is hereby granted, free of charge, to any person obtaining-# a copy of this software and associated documentation files (the-# "Software"), to deal in the Software without restriction, including-# without limitation the rights to use, copy, modify, merge, publish,-# distribute, sublicense, and/or sell copies of the Software, and to-# permit persons to whom the Software is furnished to do so, subject to-# the following conditions-#-# The above copyright notice and this permission notice shall be-# included in all copies or substantial portions of the Software.-#-# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE-# LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION-# 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 program calls darcs (or its own subroutines) to generate XML-# which is rendered into HTML by XSLT.  It is capable of displaying-# the files in a repository, various patch histories, annotations, etc.-#--use strict;--use CGI qw( :standard );-use CGI::Util;-use File::Basename;-use File::stat;-use IO::File;-use POSIX;--## the following variables can be customized to reflect your system-## configuration by defining them appropriately in the file-## "@sysconfdir@/darcs/cgi.conf".  The syntax accepts equals signs or simply-## blanks separating values from assignments.--$ENV{'PATH'} = read_conf('PATH', $ENV{'PATH'});--# path to executables, or just the executable if they are in $ENV{'PATH'}-my $darcs_program    = read_conf("darcs", "darcs");-my $xslt_program     = read_conf("xsltproc", "xsltproc");--# directory containing repositories-my $repository_root  = read_conf("reposdir", "/var/www");--# XSLT template locations-my $template_root = read_conf("xslt_dir", '@datadir@/darcs/xslt');--my $xslt_annotate = "$template_root/annotate.xslt";-my $xslt_browse   = "$template_root/browse.xslt";-my $xslt_patches  = "$template_root/patches.xslt";-my $xslt_repos    = "$template_root/repos.xslt";-my $xslt_rss      = "$template_root/rss.xslt";--my $xslt_errors   = "$template_root/errors.xslt";--# CSS stylesheet that XSLT templates refer to.  This is a HTTP request-# path, not a local file system path. The default will cause darcs.cgi-# to serve the stylesheet rather than the web server.-my $stylesheet = read_conf("stylesheet", "/cgi-bin/darcs.cgi/styles.css");--# location of the CSS stylesheet that darcs.cgi will serve if it-# receives a request for '/styles.css'-my $css_styles = read_conf("css_styles", '@sysconfdir@/darcs/styles.css');--# location of the favicon that darcs.cgi will serve if it-# receives a request for '/[\w\-]+/favicon.ico'-my $favicon = read_conf("favicon", "/cgi-bin/favicon.ico");--# XML source for the error pages-my $xml_errors = "$template_root/errors.xml";--# encoding to include in XML declaration-my $xml_encoding = read_conf("xml_encoding", "UTF-8");--## end customization--# ------------------------------------------------------------------------# read a value from the cgi.conf file.-{-  my(%conf);--  sub read_conf {-    my ($flag, $val) = @_;-    $val = "" if !defined($val);-    -    if (!%conf && open(CGI_CONF, '@sysconfdir@/darcs/cgi.conf')) {-      while (<CGI_CONF>) {-        chomp;-	next if /^\s*(?:\#.*)?$/;   # Skip blank lines and comment lines-        if (/^\s*(\S+)\s*(?:\=\s*)?(\S+)\s*$/) {-           $conf{$1} = $2;-	   # print "read_conf: $1 = $2\n";-        } else {-           warn "read_conf: $_\n";-        }-      }-      close(CGI_CONF);-    }--    $val = $conf{$flag} if exists($conf{$flag});--    return $val;-  }-}--# open xsltproc to transform and output `xml' with stylesheet file `xslt'-sub transform {-    my ($xslt, $args, $content_type) = @_;--    $| = 1;-    printf "Content-type: %s\r\n\r\n", $content_type || "text/html";-    my $pipe = new IO::File "| $xslt_program $args $xslt -";-    $pipe->autoflush(0);-    return $pipe;-}--sub pristine_dir {-    my ($repo) = @_;-    my $pristine = "current";-    if (! -d "${repository_root}/${repo}/_darcs/$pristine") {-        $pristine = "pristine";-    }-    return "${repository_root}/${repo}/_darcs/$pristine";-}--# begin an XML document with a root element and the repository path-sub make_xml {-    my ($fh, $repo, $dir, $file) = @_;-    my ($full_path, $path) = '/';--    printf $fh qq(<?xml version="1.0" encoding="$xml_encoding"?>\n);--    printf $fh qq(<darcs repository="$repo" target="%s/%s%s">\n),-        $repo, ($dir ? "$dir/" : ''), ($file ? "$file" : '');--    print $fh qq(<path>\n);-    foreach $path (split('/', "$repo/$dir")) {-        $full_path .= "$path/";-        print $fh qq(<directory full-path="$full_path">$path</directory>\n);-    }-    if ($file) {-        print $fh qq(<file full-path="$full_path$file">$file</file>\n) if $file;-    }-    print $fh qq(</path>\n\n);-}--# finish XML output-sub finish_xml {-    my ($fh) = @_;-    print $fh "\n</darcs>\n";-    $fh->flush;-}--# run darcs and wrap the output in an XML document-sub darcs_xml {-    my ($fh, $repo, $cmd, $args, $dir, $file) = @_;--    make_xml($fh, $repo, $dir, $file);--    push(@$args, '--xml-output');-    darcs($fh, $repo, $cmd, $args, $dir, $file);--    finish_xml($fh);-}--# run darcs with output redirected to the specified file handle-sub darcs {-    my ($fh, $repo, $cmd, $args, $dir, $file) = @_;-    my (@darcs_argv) = ($darcs_program, $cmd, @$args);--    # push target only if there is one, otherwise darcs will get an empty param-    if ($dir || $file) {-        push(@darcs_argv, sprintf("%s%s%s", $dir, ($dir ? '/' : ''), $file));-    }--    my($pid) = fork;-    if ($pid) {-	# in the parent process-	my($status) = waitpid($pid, 0);-	die "$darcs_program exited with status $?\n" if $?;-    } elsif(defined($pid)) {-	# in the child process-	open(STDIN, '/dev/null');-	if (defined($fh)) {-	    open(STDOUT, '>&', $fh)-		|| die "can't dup to stdout: $!\n";-	}-	chdir "$repository_root/$repo"-	    || die "chdir: $repository_root/$repo: $!\n";-	exec @darcs_argv;-	die "can't exec ".$darcs_argv[0].": $!\n";-    } else {-	# fork failed-	die "can't fork: $!\n";-    }-}--# get a directory listing as XML output-sub dir_listing {-    my ($fh, $repo, $dir) = @_;-    make_xml($fh, $repo, $dir, '');--    print $fh "<files>\n";-    my $dir_ = pristine_dir ($repo) . "/$dir";-    opendir(DH, $dir_);-    while( defined (my $file_ = readdir(DH)) ) {-        next if $file_ =~ /^\.\.?$/;-        my $file = "$dir_/$file_";-        my $secs  = stat($file)->mtime;-        my $mtime = localtime($secs);-        my $ts = POSIX::strftime("%Y%m%d%H%M%S", gmtime $secs);--        my ($name, $type);--         if (-d $file) {-             ($name, $type) = (basename($file) . '/', 'directory');-         } else {-             ($name, $type) = (basename($file), 'file');-         }-         print $fh qq(  <$type name="$name" modified="$mtime" ts="$ts" />\n);-    }-    closedir(DH);-    print $fh "</files>\n";--    finish_xml($fh);-}--# get a repository listing as XML output-sub repo_listing {-    my($fh) = @_;--    make_xml($fh, "", "", "");--    print $fh "<repositories>\n";-    opendir(DH, $repository_root);-    while( defined (my $name = readdir(DH)) ) {-        next if $name =~ /^\.\.?$/;-        if (-d "$repository_root/$name/_darcs") {-            print $fh qq(  <repository name="$name" />\n);-        }-    }-    closedir(DH);-    print $fh "</repositories>\n";--    finish_xml($fh);-    return $fh;-}--# show an error page-sub show_error {-    my ($type, $code, $message) = @_;-    my $xml;--    # set the xslt processing arguments-    my $xslt_args = qq {-        --stringparam error-type '$type'-        --stringparam stylesheet '$stylesheet'-    };-    $xslt_args =~ s/\s+/ /gm;--    print "Status: $code $message\r\n\r\n";-    system("$xslt_program $xslt_args $xslt_errors $xml_errors");-}--# check if the requested resource has been modified since the client last-# saw it. If not send HTTP status code 304, otherwise set the Last-modified-# and Cache-control headers.-sub is_cached {-    my ($path) = @_;-    my ($stat) = stat($path);--    # stat may fail because the path was renamed or deleted but still referred-    # to by older darcs patches-    if ($stat) {-        my $last_modified = CGI::expires($stat->mtime);--        if (http('If-Modified-Since') eq $last_modified) {-            print("Status: 304 Not Modified\r\n\r\n");-            return 1;-        }--        print("Cache-control: max-age=0, must-revalidate\r\n");-        print("Last-modified: $last_modified\r\n");-    }-    return 0;-}--# safely extract a parameter from the http request.  This applies a regexp-# to the parameter which should group only the appropriate parameter value-sub safe_param {-    my ($param, $regex, $default) = @_;-    my $value = CGI::Util::unescape(param($param));-    return ($value =~ $regex) ? $1 : $default;-}--# common regular expressions for validating passed parameters-my $hash_regex = qr/^([\w\-.]+)$/;-my $path_regex = qr@^([^\\!\$\^&*()\[\]{}<>`|';"?\r\n]+)$@;--# respond to a CGI request-sub respond {-    # untaint the full URL to this CGI-    my $cgi_url = CGI::Util::unescape(url());-    $cgi_url =~ $path_regex or die qq(bad url "$cgi_url");-    $cgi_url = $1;--    # untaint script_name, reasonable to expect only \w, -, /, and . in the name-    my $script_name = CGI::Util::unescape(script_name());-    $script_name =~ qr~^([\w/.\-\~]+)$~ or die qq(bad script_name "$script_name");-    $script_name = $1;--    # untaint simple parameters, which can only have chars matching \w+-    my $cmd  = safe_param('c', '^(\w+)$', 'browse');-    my $sort = safe_param('s', '^(\w+)$', '');--    # set the xslt processing arguments-    my $xslt_args = qq {-        --stringparam cgi-program '$script_name'-        --stringparam cgi-url '$cgi_url'-        --stringparam sort-by '$sort'-        --stringparam stylesheet '$stylesheet'-    };-    $xslt_args =~ s/\s+/ /gm;--    my ($path) = CGI::Util::unescape(path_info());-    # don't allow ./ or ../ in paths-    $path =~ s|[.]+/||g;--    # check whether we're asking for styles.css-    if ($path eq '/styles.css') {-        return if is_cached($css_styles);--        open (STYLES_CSS, $css_styles) or die qq(couldn't open "${css_styles}");-        my $size = stat($css_styles)->size;--        print "Content-length: $size\r\n";-        print "Content-type: text/css\r\n\r\n";--        while (<STYLES_CSS>) {-          print $_;-        }-        close (STYLES_CSS);-        return;-    }--    # check whether we're asking for favicon.ico-    if ($path =~ '/[\w\-]+/favicon.ico') {-        return if is_cached($favicon);--        open (FAVICON, $favicon) or die qq(couldn't open "${favicon}");-        my $size = stat($favicon)->size;--        print "Content-length: $size\r\n";-        print "Content-type: image/x-icon\r\n\r\n";--        while (<FAVICON>) {-          print $_;-        }-        close (FAVICON);-        return;-    }--    # when no repository is requested display available repositories-    if (length($path) < 2) {-        my $fh = transform($xslt_repos, $xslt_args);-        repo_listing($fh);-        return;-    }--    # don't allow any shell meta characters in paths-    $path =~ $path_regex or die qq(bad path_info "$path");-    my @path = split('/', substr($1, 1));--    # split the path into a repository, directory, and file-    my ($repo, $dir, $file, @bits) = ('', '', '');-    while (@path > 0) {-        $repo = join('/', @path);-        # check if remaining path elements refer to a repo-        if (-d "${repository_root}/${repo}/_darcs") {-            if (@bits > 1) {-                $dir  = join('/', @bits[0..$#bits - 1]);-            }-            $file = $bits[$#bits];-            # check if last element of path, stored in $file, is really a dir-            if (-d (pristine_dir ($repo) . "/${dir}/${file}")) {-                $dir = ($dir ? "$dir/$file" : $file);-                $file = '';-            }-            last;-        } else {-            $repo = '';-            unshift(@bits, pop @path);-        }-    }--    # make sure the repository exists-    unless ($repo) {-        show_error('invalid-repository', '404', 'Invalid repository');-        return;-    }--    # don't generate output unless the requested path has been-    # modified since the client last saw it.-    return if is_cached(pristine_dir ($repo) . "/$dir/$file");--    # untaint patches and tags. Tags can have arbitrary values, so-    # never pass these unquoted, on pain of pain!-    my $patch = safe_param('p', $hash_regex);-    my $tag   = safe_param('t', '^(.+)$');--    my @darcs_args;-    push(@darcs_args, '--match', "hash $patch") if $patch;-    push(@darcs_args, '-t', $tag) if $tag;--    # process the requested command-    if ($cmd eq 'browse') {-        my $fh = transform($xslt_browse, $xslt_args);-        dir_listing($fh, $repo, $dir);-    } elsif ($cmd eq 'patches') {-        # patches as an option is used to support "--patches"-        if (my $patches = safe_param('patches','^(.+)$')) {-            push @darcs_args, '--patches', $patches;-        }--        my $fh = transform($xslt_patches, $xslt_args);-        darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file);-    } elsif ($cmd eq 'annotate') {-        push(@darcs_args, '--summary');--        my $creator_hash  = safe_param('ch', $hash_regex);-        my $original_path = safe_param('o', $path_regex);-        my $fh = transform($xslt_annotate, $xslt_args);--        # use the creator hash and original file name when available so-        # annotations can span renames-        if ($creator_hash ne '' && $original_path ne '') {-            push(@darcs_args, '--creator-hash', $creator_hash);-            darcs_xml($fh, $repo, "annotate", \@darcs_args, '', $original_path);-        } else {-            darcs_xml($fh, $repo, "annotate", \@darcs_args, $dir, $file);-        }-    } elsif ($cmd eq 'diff') {-        push(@darcs_args, '-u');-        print "Content-type: text/plain\r\n\r\n";-        darcs(undef, $repo, "diff", \@darcs_args, $dir, $file);-    } elsif ($cmd eq 'rss') {-        push(@darcs_args, '--last', '25');--        my $fh = transform($xslt_rss, $xslt_args, "application/rss+xml");-        darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file);-    } else {-        show_error('invalid-command', '400', 'Invalid command');-    }-}--# run a self-test when the --check argument is supplied-if ($ARGV[0] eq '--check') {-    (read_conf("css_styles", "abc") ne "abc") ||-        die "cannot read config file: $!\n";--    (`$darcs_program`) ||-        die "cannot execute darcs as '$darcs_program': $!\n";-    (`$xslt_program`) ||-        die "cannot execute xstlproc as '$xslt_program': $!\n";--    (-d $repository_root && -r $repository_root) ||-        die "cannot read repository root directory '$repository_root': $!\n";-    (-d $template_root && -r $template_root) ||-        die "cannot read template root directory '$template_root': $!\n";-    (-f $css_styles) ||-        die "cannot read css stylesheet '$css_styles': $!\n";-    (-f $xml_errors) ||-        die "cannot read error messages '$xml_errors': $!\n";--    exit 0;-}--# handle the CGI request-respond();-
− contrib/cgi/xslt/annotate.xslt 
@@ -1,390 +0,0 @@-<?xml version="1.0" encoding="utf-8"?>--<!--- template for converting darcs' `annotate` output from XML to XHTML.  This- template expects the following external variables:--   cgi-program    - path to the CGI executable, to place in links-   sort-by        - field to sort by-   stylesheet     - path to the CSS stylesheet---->-<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">-  <xsl:strip-space elements="*"/>--  <xsl:include href="common.xslt"/>--  <xsl:template match="path">-    <h1 class="target">-        annotations for <span class="path"><a href="{$cgi-program}">projects</a></span> / <span class="path"><xsl:apply-templates/></span>-    </h1>-  </xsl:template>--  <!-- patch annotate tags -->-  <xsl:template match="/darcs/patch">-    <xsl:call-template name="show-patch-info">-      <xsl:with-param name="patch" select="."/>-      <xsl:with-param name="show-comment" select="true()"/>-      <xsl:with-param name="show-author" select="true()"/>-      <xsl:with-param name="show-date" select="true()"/>-    </xsl:call-template>-  </xsl:template>-  -  <xsl:template match="summary">-    <xsl:variable name="hash" select="../patch/@hash"/>-      -    <table>-      <tr class="annotate">-        <th>file</th>-        <th>change</th>-        <th></th>-        <th></th>-      </tr>--      <xsl:apply-templates/>-    </table>--    <form action="{$command}" method="get">-      <p>-        <input type="submit" name="c" value="diff"/>-        <input type="hidden" name="p" value="{$hash}"/>-      </p>-    </form>-  </xsl:template>-  -  <xsl:template match="modify_file">-    <xsl:variable name="file" select="text()"/>-    <xsl:variable name="hash" select="/darcs/patch/@hash" />-      -    <tr class="modified-file">-      <td><xsl:value-of select="$file"/></td>--      <td class="line-count">-        <xsl:for-each select="added_lines">-          +<xsl:value-of select="@num"/>/-        </xsl:for-each>-        <xsl:for-each select="removed_lines">-<xsl:value-of select="@num"/>-        </xsl:for-each>-        lines-      </td>--      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>-      <td><a href="{$command}{$file}?c=patches">patches</a></td>-    </tr>-  </xsl:template>--  <xsl:template match="add_file">-    <xsl:variable name="file" select="text()"/>-    <xsl:variable name="hash" select="/darcs/patch/@hash" />-    -    <tr class="add-remove-file">-      <td><xsl:value-of select="$file"/></td>-      <td>added file</td>-      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>-      <td><a href="{$command}{$file}?c=patches">patches</a></td>-    </tr>-  </xsl:template>--  <xsl:template match="move">-    <xsl:variable name="file" select="@to"/>-    <xsl:variable name="old-file" select="@from"/>    -    <xsl:variable name="hash" select="/darcs/patch/@hash" />-    -    <tr class="add-remove-file">-      <td><xsl:value-of select="$file"/></td>-      <td>moved from <xsl:value-of select="$old-file"/></td>-      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>-      <td><a href="{$command}{$file}?c=patches">patches</a></td>-    </tr>-  </xsl:template>--  <xsl:template match="remove_file">-    <xsl:variable name="file" select="text()"/>-    <xsl:variable name="hash" select="/darcs/patch/@hash" />-    -    <tr class="add-remove-file">-      <td><xsl:value-of select="$file"/></td>-      <td>removed file</td>-      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>-      <td><a href="{$command}{$file}?c=patches">patches</a></td>-    </tr>-  </xsl:template>--  <xsl:template match="add_directory">-    <xsl:variable name="dir" select="text()"/>-    <xsl:variable name="hash" select="/darcs/patch/@hash" />-    -    <tr class="add-remove-file">-      <td><xsl:value-of select="$dir"/></td>-      <td>added directory</td>-      <td><a href="{$command}{$dir}/?c=annotate&amp;p={$hash}">annotate</a></td>-      <td><a href="{$command}{$dir}/?c=patches">patches</a></td>-    </tr>-  </xsl:template>--  <xsl:template match="remove_directory">-    <xsl:variable name="dir" select="text()"/>-    <xsl:variable name="hash" select="/darcs/patch/@hash" />-    -    <tr class="add-remove-file">-      <td><xsl:value-of select="$dir"/></td>-      <td>removed directory</td>-      <td><a href="{$command}{$dir}/?c=annotate&amp;p={$hash}">annotate</a></td>-      <td><a href="{$command}{$dir}/?c=patches">patches</a></td>-    </tr>-  </xsl:template>-  -  <!-- directory annotate templates -->-  <xsl:template match="/darcs/directory">-    <xsl:call-template name="show-patch-info">-      <xsl:with-param name="patch" select="modified/patch"/>-    </xsl:call-template>--    <table>-      <tr class="annotate">-        <th>file</th>-        <th>change</th>-        <th></th>-        <th></th>-      </tr>--      <xsl:apply-templates/>-    </table>-  </xsl:template>-  -  <xsl:template match="directory/modified/modified_how">-    <xsl:variable name="hash" select="../patch/@hash" />-    <xsl:variable name="how" select="substring(text(), 0, 10)"/>-    <xsl:variable name="target" select="/darcs/@target"/>--    <!---      annotating a directory outputs the directory itself as well as-      any contents.  this ugly code checks if the matching element is-      the original directory so that the 'annotate' and 'patch' links-      don't append the directory twice.-    -->-    <xsl:variable name="last" select="//darcs/path/directory[last()]"/>-    <xsl:variable name="name" select="../../@name"/>-    <xsl:variable name="dir">-      <xsl:choose>-        <xsl:when test="$last = $name"></xsl:when>-        <xsl:otherwise><xsl:value-of select="$name"/>/</xsl:otherwise>-      </xsl:choose>-    </xsl:variable>--    <tr class="add-remove-file">-      <td><xsl:value-of select="$name"/></td>-      <td>-        <xsl:choose>-          <xsl:when test="$how = 'Dir added'">added directory</xsl:when>-          <xsl:when test="$how = 'Dir moved'">moved directory</xsl:when>-          <xsl:when test="$how = 'Dir remov'">removed directory</xsl:when>-        </xsl:choose>-      </td>-      <td>-        <a href="{$command}{$dir}?c=annotate&amp;p={$hash}">annotate</a>-      </td>-      <td><a href="{$command}{$dir}?c=patches">patches</a></td>-    </tr>-  </xsl:template>--  <xsl:template match="directory/file/modified/modified_how">-    <xsl:variable name="file" select="../../@name"/>-    <xsl:variable name="hash" select="../patch/@hash" />-    <xsl:variable name="how" select="substring(text(), 0, 11)"/>-    -    <tr class="add-remove-file">-      <td><xsl:value-of select="$file"/></td>-      <td>-        <xsl:choose>-          <xsl:when test="$how = 'File added'">added file</xsl:when>-          <xsl:when test="$how = 'File moved'">moved file</xsl:when>-          <xsl:when test="$how = 'File remov'">removed file</xsl:when>-        </xsl:choose>-      </td>-      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>-      <td><a href="{$command}{$file}?c=patches">patches</a></td>-    </tr>-  </xsl:template>-   -  <!-- file annotate templates -->-  <xsl:template match="/darcs/file">-    <xsl:variable name="modified_how" select="modified/modified_how/text()"/>-    -    <xsl:call-template name="show-patch-info">-      <xsl:with-param name="patch" select="modified/patch"/>-    </xsl:call-template>--    <!-- don't display table of changes when file's contents are modified -->-    <xsl:if test="$modified_how != 'File modified'">-      <xsl:variable name="file" select="@name"/>-      <xsl:variable name="how" select="substring($modified_how, 0, 11)"/>--      <xsl:variable name="annotate-href">-        <xsl:call-template name="make-annotate-href">-          <xsl:with-param name="hash" select="modified/patch/@hash"/>-        </xsl:call-template>-      </xsl:variable>-      -      <table>-        <tr class="annotate">-          <th>file</th>-          <th>change</th>-          <th></th>-          <th></th>-        </tr>--        <tr class="add-remove-file">-          <td><xsl:value-of select="$file"/></td>-          <td>-            <xsl:choose>-              <xsl:when test="$how = 'File added'">added file</xsl:when>-              <xsl:when test="$how = 'File moved'">moved file</xsl:when>-              <xsl:when test="$how = 'File remov'">removed file</xsl:when>-            </xsl:choose>-          </td>-          <td><a href="{$annotate-href}">annotate</a></td>-          <td><a href="{$command}?c=patches">patches</a></td>-        </tr>-      </table>-    </xsl:if>--    <!-- the empty <p/> element is a Konqueror bug workaround -->-    <pre xml:space="preserve"><p/>-      <xsl:apply-templates/>-    </pre>-  </xsl:template>-  -  <xsl:template match="added_line">-    <xsl:variable name="annotate-href">-      <xsl:call-template name="make-annotate-href">-        <xsl:with-param name="hash" select="preceding::modified/patch/@hash"/>-      </xsl:call-template>-    </xsl:variable>--    <xsl:variable name="annotate-name" select="preceding::modified/patch/name"/>-    <xsl:variable name="author" select="preceding::modified/patch/@author"/>-    -    <a class="added-line" href="{$annotate-href}" title="added with '{$annotate-name}' by '{$author}'">-      <pre><xsl:value-of select="text()"/></pre>-    </a>-    <xsl:call-template name="check-removed-by"/>-  </xsl:template>--  <xsl:template match="normal_line">-    <xsl:variable name="annotate-href">-      <xsl:call-template name="make-annotate-href">-        <xsl:with-param name="hash" select="*/patch/@hash"/>-      </xsl:call-template>-    </xsl:variable>--    <xsl:variable name="annotate-name" select="*/patch/name"/>-    <xsl:variable name="author" select="*/patch/@author"/>--    <a class="normal-line" href="{$annotate-href}" title="last changed with '{$annotate-name}' by '{$author}'">-      <pre><xsl:value-of select="text()"/></pre>-    </a>-    <xsl:call-template name="check-removed-by"/>-  </xsl:template>--  <xsl:template match="removed_line">-    <xsl:variable name="annotate-href">-      <xsl:call-template name="make-annotate-href">-        <xsl:with-param name="hash" select="*/patch/@hash"/>-      </xsl:call-template>-    </xsl:variable>--    <xsl:variable name="annotate-name" select="*/patch/name"/>-    <xsl:variable name="author" select="*/patch/@author"/>-    -    <!-- don't display removed lines when a file is removed -->-    <xsl:if test="../modified/modified_how/text() != 'File removed'">-      -        <a class="removed-line" href="{$annotate-href}" title="removed with '{$annotate-name}' by '{$author}'">-        <pre><xsl:value-of select="text()"/></pre>-      </a>-      <xsl:call-template name="check-removed-by"/>-    </xsl:if>-  </xsl:template>--  <xsl:template name="check-removed-by">-    <xsl:variable name="hash" select="removed_by/patch/@hash"/>-    -    <xsl:variable name="annotate-href">-      <xsl:call-template name="make-annotate-href">-        <xsl:with-param name="hash" select="$hash"/>-      </xsl:call-template>-    </xsl:variable>-    -    <xsl:choose>-      <xsl:when test="$hash != ''">-        <a class="removed-by" href="{$annotate-href}">-</a>-      </xsl:when>-    </xsl:choose>--    <!-- put a newline after the hyperlink -->      -    <xsl:text xml:space="preserve">-    </xsl:text>-  </xsl:template>--  <xsl:template name="show-patch-info">-    <xsl:param name="patch"/>-    <xsl:param name="show-comment"/>-    <xsl:param name="show-author"/>-    <xsl:param name="show-date"/>-    -    <xsl:variable name="hash" select="$patch/@hash"/>-    <xsl:variable name="name" select="$patch/name"/>-    <xsl:variable name="author" select="$patch/@author"/>-    <xsl:variable name="local_date" select="$patch/@local_date"/>-    -    <h2 class="patch">-      patch "<span class="path">-      <a href="{$cgi-program}/{$repo}/?c=annotate&amp;p={$hash}">-        <xsl:value-of select="$name"/>-      </a>-      </span>"-    </h2>--    <xsl:if test="$show-comment">-        <xsl:if test="$patch/comment">-          <h2 class="patch">-            comment "<span class="comment">-            <xsl:value-of select="$patch/comment"/>-            </span>"-            </h2>-        </xsl:if>-        </xsl:if>--      <xsl:if test="$show-author"> -          <h2 class="author">-        by <span class="author">-        <xsl:value-of select="$patch/@author"/>-        </span>--      <xsl:if test="$show-date"> -        on <span class="local_date">-        <xsl:value-of select="$patch/@local_date"/>-        </span>-    </xsl:if>-    </h2>-    </xsl:if>--  </xsl:template>--  <xsl:template name="make-annotate-href" xml:space="default">-    <xsl:param name="hash"/>--    <xsl:variable name="created-as" select="/darcs/*/created_as"/>-    <xsl:variable name="creator-hash" select="$created-as/patch/@hash"/>-    <xsl:variable name="original-name" select="$created-as/@original_name"/>-    -    <xsl:value-of select="$command"/>?c=annotate&amp;p=<xsl:value-of select="$hash"/>&amp;ch=<xsl:value-of select="$creator-hash"/>&amp;o=<xsl:value-of select="$original-name"/>-  </xsl:template>--  <!-- ignore <name>, <comment> and <modified_how> children -->-  <xsl:template match="name"/>-  <xsl:template match="comment"/>-  <xsl:template match="author"/>-  <xsl:template match="modified_how"/>-</xsl:stylesheet>
− contrib/cgi/xslt/browse.xslt 
@@ -1,110 +0,0 @@-<?xml version="1.0" encoding="utf-8"?>--<!--- template for converting a darcs current/ directory listing from XML to- XHTML.  This template expects the following external variables:--   cgi-program    - path to the CGI executable, to place in links-   sort-by        - field to sort by-   stylesheet     - path to the CSS stylesheet-- the input XML must have the following structure, aside from what common.xslt- expects:-- <files>-   <directory name="" modified=""/>-   <file name="" modified=""/>- </files>--->-<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">-  <xsl:include href="common.xslt"/>--  <xsl:template match="path">-    <h1 class="target">-      files in <span class="path"><a href="{$cgi-program}">projects</a></span> / <span class="path"><xsl:apply-templates/></span>-    </h1>-  </xsl:template>-  -  <xsl:template match="files">-    <table>-      <tr class="browse">-        <th>-          <a class="sort" href="{$command}?c=browse&amp;s=name">name</a>-          <a class="revsort" href="{$command}?c=browse&amp;s=revname"> (rev)</a>-        </th>-        <th>-          <a class="sort" href="{$command}?c=browse&amp;s=ts">modified</a>-          <a class="revsort" href="{$command}?c=browse&amp;s=revts"> (rev)</a>-        </th>-        <th></th>-        <th></th>-      </tr>-      -      <xsl:choose>-        <xsl:when test="$sort-by = 'ts'">-          <xsl:apply-templates>-            <xsl:sort select="name(self::node())"/>-            <xsl:sort select="@ts"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:when test="$sort-by = 'revts'">-          <xsl:apply-templates>-            <xsl:sort select="name(self::node())"/>-            <xsl:sort select="@ts" order="descending"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:when test="$sort-by = 'name'">-          <xsl:apply-templates>-            <xsl:sort select="name(self::node())"/>-            <xsl:sort select="@name"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:when test="$sort-by = 'revname'">-          <xsl:apply-templates>-            <xsl:sort select="name(self::node())"/>-            <xsl:sort select="@name" order="descending"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:otherwise>-          <xsl:apply-templates>-            <xsl:sort select="name(self::node())"/>-            <xsl:sort select="@name"/>-          </xsl:apply-templates>-        </xsl:otherwise>-      </xsl:choose>-    </table>-  </xsl:template>-  -  <xsl:template match="directory">-    <xsl:variable name="name" select="@name"/>-    <xsl:variable name="type" select="@type"/>-    -    <tr class="directory">-      <td>-        <a href="{$command}{$name}?c=browse"><xsl:value-of select="@name"/></a>-      </td>-      <td><xsl:value-of select="@modified"/></td>-      <td>-        <a href="{$command}{$name}?c=annotate">annotate</a>-      </td>-      <td>-        <a href="{$command}{$name}?c=patches">patches</a>-      </td>-    </tr>--    <xsl:apply-templates/>-  </xsl:template>--  <xsl:template match="file">-    <xsl:variable name="name" select="@name"/>-    -    <tr class="file">-      <td><xsl:value-of select="@name"/></td>-      <td><xsl:value-of select="@modified"/></td>-      <td><a href="{$command}{$name}?c=annotate">annotate</a></td>-      <td><a href="{$command}{$name}?c=patches">patches</a></td>-    </tr>--    <xsl:apply-templates/>-  </xsl:template>-</xsl:stylesheet>
− contrib/cgi/xslt/common.xslt 
@@ -1,66 +0,0 @@-<!--- templates fragments shared by all templates.  This template expects- the following external variables:--   cgi-program    - path to the CGI executable, to place in links-   stylesheet     - path to the CSS stylesheet-- the input XML must have the following structure, plus any elements- that are not common to all templates:-- <darcs repository="">-   <path>-     <element full-path=""></element>-   </path>--   ...- - </darcs>--->-<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">-  <xsl:variable name="command">-    <xsl:value-of select="$cgi-program"/>/<xsl:value-of select="/darcs/@target"/>-  </xsl:variable>--  <xsl:variable name="repo" select="/darcs/@repository"/>-  -  <xsl:template match="/darcs">-    <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">-      <head>-        <title>darcs repository</title>-        <link rel="stylesheet" href="{$stylesheet}"/>-        <link rel="alternate" type="application/rss+xml" title="RSS 2.0" href="{$command}?c=rss" />-      </head>--      <body>-        <xsl:apply-templates/>--        <form action="{$command}" method="get">-          <p>-            <input class="patches" type="submit" name="c" value="patches"/>-            -            <a href="{$command}?c=rss">rss</a>-            -            <span class="version">-              <a class="home" href="http://darcs.net/">darcs.cgi</a>-              v1.0-            </span>-          </p>-        </form>-      </body>-    </html>-  </xsl:template>--  <xsl:template match="path/directory">-    <xsl:variable name="full-path"  select="@full-path"/>-    -    <a href="{$cgi-program}{$full-path}?c=browse">-      <xsl:apply-templates/>-    </a> /-  </xsl:template>--  <xsl:template match="path/file">-    <xsl:apply-templates/>-  </xsl:template>-  -</xsl:stylesheet>
− contrib/cgi/xslt/errors.xml 
@@ -1,22 +0,0 @@-<!---  HTML templates for all potential error pages.  Each <error> element-  should contain all of the HTML <body> content to be output if that-  error occurs--->-<errors>-  <error type="invalid-command" title="Invalid command">-    <h1>Invalid command</h1>--    <p>-      The requested command is invalid.-    </p>-  </error>--  <error type="invalid-repository" title="Invalid repository">-    <h1>Invalid repository</h1>--    <p>-      The requested repository does not exist on this server.-    </p>-  </error>-</errors>
− contrib/cgi/xslt/errors.xslt 
@@ -1,36 +0,0 @@-<?xml version="1.0" encoding="utf-8"?>--<!--- template for converting selected content of errors.xml XML to XHTML. This- template expects the following external variables:--   error-type     - the type of error-   stylesheet     - path to the CSS stylesheet-- the input XML must have the following structure-- <errors>-   <error type="" title="">-     ...-   </error>- </errors>--->-<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">-  <xsl:template match="error[@type = $error-type]">-    <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">-      <head>-        <title>-          <xsl:value-of select="@title"/>-        </title>-        <link rel="stylesheet" href="{$stylesheet}"/>-      </head>--      <body>-        <xsl:copy-of select="*"/>-      </body>-    </html>-  </xsl:template>--  <!-- ignore errors that don't match -->-  <xsl:template match="error"/>-</xsl:stylesheet>
− contrib/cgi/xslt/patches.xslt 
@@ -1,125 +0,0 @@-<?xml version="1.0" encoding="utf-8"?>--<!--- template for converting darcs' `changes` output from XML to XHTML.  This- template expects the following external variables:--   cgi-program    - path to the CGI executable, to place in links-   sort-by        - field to sort by-   stylesheet     - path to the CSS stylesheet-- the input XML must have the following structure, aside from what common.xslt- expects:-- <changelog>-   <patch author="" date="" localdate="" inverted="" hash="">-     <name></name>-   </patch>- </changelog>--->-<xsl:stylesheet version="1.0"-                xmlns:xsl="http://www.w3.org/1999/XSL/Transform"-                xmlns:str="http://exslt.org/strings">-  -  <xsl:include href="common.xslt"/>--  <xsl:template match="path">-    <h1 class="target">-      patches applied to <span class="path"><a href="{$cgi-program}">projects</a></span> / <span class="path"><xsl:apply-templates/></span>-    </h1>-  </xsl:template>-  -  -  <xsl:template match="changelog">-    <table>-      <tr class="patches">-        <th>-          <a class="sort" href="{$command}?c=patches&amp;s=name">name</a>-          <a class="revsort" href="{$command}?c=patches&amp;s=revname"> (rev)</a>-        </th>-        <th>-          <a class="sort" href="{$command}?c=patches&amp;s=date">date</a>-          <a class="revsort" href="{$command}?c=patches&amp;s=revdate"> (rev)</a>-        </th>-        <th>-          <a class="sort" href="{$command}?c=patches&amp;s=author">author</a>-          <a class="revsort" href="{$command}?c=patches&amp;s=revauthor"> (rev)</a>-        </th>-        <th>-        </th>-      </tr>--      <xsl:choose>-        <xsl:when test="$sort-by = 'name'">-          <xsl:apply-templates>-            <xsl:sort select="name"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:when test="$sort-by = 'revname'">-          <xsl:apply-templates>-            <xsl:sort select="name" order="descending"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:when test="$sort-by = 'date'">-          <xsl:apply-templates>-            <xsl:sort select="@date"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:when test="$sort-by = 'revdate'">-          <xsl:apply-templates>-            <xsl:sort select="@date" order="descending"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:when test="$sort-by = 'author'">-          <xsl:apply-templates>-            <xsl:sort select="@author"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:when test="$sort-by = 'revauthor'">-          <xsl:apply-templates>-            <xsl:sort select="@author" order="descending"/>-          </xsl:apply-templates>-        </xsl:when>-        <xsl:otherwise>-          <!-- use the repository's natural order -->-          <xsl:apply-templates/>-        </xsl:otherwise>-      </xsl:choose>-    </table>-  </xsl:template>--  <xsl:template match="patch">-    <xsl:variable name="author" select="@author"/>-    <xsl:variable name="hash"   select="@hash"/>-    <xsl:variable name="name"   select="name"/>-    <xsl:variable name="repo"   select="/darcs/@repository"/>--    <xsl:variable name="created-as" select="/darcs/changelog/created_as"/>-    <xsl:variable name="creator-hash" select="$created-as/patch/@hash"/>-    <xsl:variable name="original-name" select="$created-as/@original_name"/>--    <xsl:variable name="annotate-href">-      <xsl:value-of select="$command"/>?c=annotate&amp;p=<xsl:value-of select="$hash"/>--      <xsl:if test="$creator-hash">&amp;ch=<xsl:value-of select="$creator-hash"/></xsl:if>-      <xsl:if test="$original-name">&amp;o=<xsl:value-of select="$original-name"/></xsl:if>-    </xsl:variable>-    -    <tr class="patch">-      <td><a href="{$annotate-href}"><xsl:value-of select="name"/></a></td>-      <td><xsl:value-of select="@local_date"/></td>-      <td>-        <a href="mailto:{$author}"><xsl:value-of select="$author"/></a>-      </td>-      <td>-        <a href="{$cgi-program}/{$repo}/?c=annotate&amp;p={$hash}">detail</a>-      </td>-    </tr>-    <xsl:apply-templates/>-  </xsl:template>--  <!-- ignore <created_as>, <name> and <comment> children of <patch> -->-  <xsl:template match="created_as"/>-  <xsl:template match="name"/>-  <xsl:template match="comment"/>-</xsl:stylesheet>
− contrib/cgi/xslt/repos.xslt 
@@ -1,59 +0,0 @@-<?xml version="1.0" encoding="utf-8"?>--<!--- template for displaying a list of available repositories, used when a- CGI request has no repository path information.  This template expects- the following external variables:--   cgi-program    - path to the CGI executable, to place in links-   stylesheet     - path to the CSS stylesheet-- the input XML must have the following structure:-- <darcs repository="">-   <repositories>-     <repository name=""/>-   </repositories>- </darcs>--->-<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">-  <xsl:variable name="command">-    <xsl:value-of select="$cgi-program"/>/<xsl:value-of select="/darcs/@target"/>-  </xsl:variable>-  -  <xsl:template match="/darcs">-    <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">-      <head>-        <title>darcs repository viewer</title>-        <link rel="stylesheet" href="{$stylesheet}"/>-      </head>--      <body>-        <h1 class="target">Available Repositories</h1>--        <table>-          <xsl:apply-templates/>-        </table>-      </body>-    </html>-  </xsl:template>--  <xsl:template match="repositories">-    <xsl:apply-templates>-      <xsl:sort select="name(self::node())"/>-      <xsl:sort select="@name"/>-    </xsl:apply-templates>-  </xsl:template>--  <xsl:template match="repositories/repository">-    <xsl:variable name="repository"  select="@name"/>--    <tr>-      <td>-        <a href="{$cgi-program}/{$repository}/?c=browse">-          <xsl:value-of select="$repository"/>-        </a>-      </td>-    </tr>-  </xsl:template>-</xsl:stylesheet>
− contrib/cgi/xslt/rss.xslt 
@@ -1,92 +0,0 @@-<?xml version="1.0" encoding="utf-8"?>--<!--- template for converting darcs' `changes` output from XML to RSS.  This- template expects the following external variables:--   cgi-url    - full URL to the CGI executable, to place in links-- the input XML must have the following structure:-- <darcs repository="">-   <changelog>-     <patch author="" date="" localdate="" inverted="" hash="">-       <name></name>-       <comment></comment>-     </patch>-   </changelog>- </darcs>--->-<xsl:stylesheet version="1.0"-                exclude-result-prefixes="str"-                xmlns:xsl="http://www.w3.org/1999/XSL/Transform"-                xmlns:str="http://exslt.org/strings">--  <xsl:variable name="repo" select="/darcs/@repository"/>--  <xsl:variable name="command">-    <xsl:value-of select="$cgi-url"/>/<xsl:value-of select="/darcs/@target"/>-  </xsl:variable>--  <xsl:template match="changelog">-    <rss version="2.0">-      <channel>-        <title>changes to <xsl:value-of select="$repo"/></title>-        <link><xsl:value-of select="$command"/></link>-        <description>-          Recent patches applied to the darcs repository named-          "<xsl:value-of select='$repo'/>".-        </description>--        <xsl:apply-templates>-          <xsl:sort select="@date"/>-        </xsl:apply-templates>-      </channel>-    </rss>-  </xsl:template>--  <xsl:template match="patch">-    <xsl:variable name="hash"       select="@hash"/>--    <xsl:variable name="created-as" select="/darcs/changelog/created_as"/>-    <xsl:variable name="creator-hash" select="$created-as/patch/@hash"/>-    <xsl:variable name="original-name" select="$created-as/@original_name"/>--    <xsl:variable name="annotate-href">-      <xsl:value-of select="$command"/>?c=annotate&amp;p=<xsl:value-of select="$hash"/>--      <xsl:if test="$creator-hash">&amp;ch=<xsl:value-of select="$creator-hash"/></xsl:if>-      <xsl:if test="$original-name">&amp;o=<xsl:value-of select="$original-name"/></xsl:if>-    </xsl:variable>--    <xsl:variable name="date-nodes" select="str:tokenize(@local_date, ' ')"/>-    <xsl:variable name="rfc-date">-      <xsl:value-of select="$date-nodes[1]"/>-      <xsl:value-of select="', '"/>-      <xsl:if test="$date-nodes[3] &lt; 10">0</xsl:if>-      <xsl:value-of select="$date-nodes[3]"/>-      <xsl:value-of select="' '"/>-      <xsl:value-of select="$date-nodes[2]"/>-      <xsl:value-of select="' '"/>-      <xsl:value-of select="$date-nodes[6]"/>-      <xsl:value-of select="' '"/>-      <xsl:value-of select="$date-nodes[4]"/>-      <xsl:value-of select="' '"/>-      <xsl:value-of select="$date-nodes[5]"/>-    </xsl:variable>--    <item>-      <title><xsl:value-of select="name"/></title>-      <link><xsl:value-of select="$annotate-href"/></link>-      <author><xsl:value-of select="@author"/></author>-      <description><xsl:value-of select="comment"/></description>-      <pubDate><xsl:value-of select="$rfc-date"/></pubDate>-    </item>-  </xsl:template>--  <!-- ignore <path> <created_as>, <name> and <comment> children of <patch> -->-  <xsl:template match="path"/>-  <xsl:template match="created_as"/>-  <xsl:template match="name"/>-  <xsl:template match="comment"/>-</xsl:stylesheet>
− contrib/cgi/xslt/styles.css 
@@ -1,91 +0,0 @@-/**- stylesheet for darcs repository browser-**/--a:link, a:visited {-  color: blue;-  text-decoration: none;-}--a:hover { text-decoration: underline; }-a.sort  { color: black; }-a.revsort  { -  color: black;-  font-size: 75%;-}-a.home  { color: #9292C9; }--body { margin: 10px 10px 10px 10px; }--h1.target {-  font-size: 150%;-  font-weight: bold;-}--h2.patch {-  font-size: 125%;-  font-weight: bold;-  margin-top: -10px;-  padding-left: 10px;-}--h2.author {-  font-size: smaller;-  margin-top: -10px;-  font-weight: bold;-  padding-left: 30px;-}--input.patches {  margin-right: 20px; }-label.tag     {  margin-right: 5px; }--span.path, span.path > a { color: #2A2A6B; }--span.version {-  color: #9292C9;  -  margin-left: 75px;-}--span.comment {-  color: #2A2A6B;-  white-space: pre;-}--th,td {-  text-align: left;-  padding: 5px 10px 5px 10px;  -}--tr.annotate { background-color: #FFAAAA; }-tr.browse { background-color: #FFFF99; }-tr.patches { background-color: #AAFFAA; }-tr.directory { background-color: #CFCFCF; }-tr.file, tr.patch, tr.modified-file { background-color: #DCDCDA; }-tr.modified-file, tr.add-remove-file { background-color: #DCDCDA; }--pre {-    margin: 0 0 0 0;-}--a.added-line {-    color: #00AA00;-    float: left;-}--a.normal-line {-    color: #000000;-    float: left;-}--a.removed-line {-    color: #CC0000;-    float: left;-    text-decoration: line-through;-}--a.removed-by {-    clear: right;-    color: #CC0000;-    float: right;-    font-size: 125%;-}
+ darcs-beta-2.3.98.1.tar.gz view

binary file changed (absent → 45 bytes)

darcs-beta.cabal view
@@ -1,5 +1,5 @@ Name:           darcs-beta-version:        2.2.98.4+version:        2.3.98.1 License:        GPL License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-users@darcs.net>@@ -41,21 +41,17 @@   src/*.h src/Crypt/sha2.h   src/win32/send_email.h src/win32/sys/mman.h -  -- TODO: factor out these standalone executables to other sections-  src/preproc.hs, src/unit.lhs,-   -- The contrib directory would make a sensible 'darcs-contrib' package   contrib/_darcs.zsh, contrib/darcs_completion,   contrib/cygwin-wrapper.bash, contrib/update_roundup.pl, contrib/upload.cgi,-  contrib/cgi/darcs.cgi.in, contrib/cgi/cgi.conf.in, contrib/cgi/README.in-  contrib/cgi/xslt/*.xslt, contrib/cgi/xslt/*.xml, contrib/cgi/xslt/*.css,    -- documentation files   src/best_practices.tex, src/building_darcs.tex, src/configuring_darcs.tex,-  src/features.tex, src/gpl.tex, src/switching.tex,-  contrib/cgi/README.in+  src/features.tex, src/formats.tex, src/gpl.tex, src/switching.tex, src/darcs.tex+  doc/manual/patch-theory.tex,+  doc/darcs.css -  README+  README, NEWS    -- release data   release/distributed-version, release/distributed-context@@ -68,8 +64,9 @@   tests/network/*.sh   tests/lib   tests/example_binary.png-  bugs/*.sh +  GNUmakefile+ source-repository head   type:     darcs   location: http://darcs.net/@@ -86,21 +83,17 @@ flag http   description: Use the pure Haskell HTTP package for HTTP support. --- SUNSET: this should be mandatory after the 2009-07 release is out-flag bytestring-  description: Use the external bytestring package.--flag zlib-  description: Use the external zlib binding package.-  default:     True---- SUNSET: this should be mandatory after the 2009-07 release is out-flag utf8-string-  description: Use the external utf8-string binding package.+flag static+  description: Build static binary+  default:     False  flag terminfo   description: Use the terminfo package for enhanced console support. +flag threaded+  description: Use threading and SMP support.+  default:     True+ flag type-witnesses   description: Use GADT type witnesses.   default:     False@@ -115,6 +108,13 @@   description: Compile unit tests (requires QuickCheck >= 2.1.0.0).   default:     False +flag hpc+  default:     False++flag deps-only+  default:     False+  description: A cunning trick to have cabal install build dependencies+ Executable          witnesses   main-is:          witnesses.hs   hs-source-dirs:   src@@ -123,16 +123,21 @@   -- FIXME...   c-sources:        src/atomic_create.c                     src/fpstring.c-                    src/c_compat.c                     src/maybe_relink.c                     src/umask.c                     src/Crypt/sha2.c++  extensions:+    CPP+    UndecidableInstances+    ScopedTypeVariables+    RankNTypes+    GADTs+    ImpredicativeTypes+   if !flag(type-witnesses)     buildable: False -  if !flag(zlib)-    extra-libraries:  z-   if os(windows)     hs-source-dirs: src/win32     include-dirs:   src/win32@@ -208,16 +213,14 @@                     Darcs.FilePathMonad                     Darcs.Flags                     Darcs.Global-                    Darcs.Gorsvet                     Darcs.Hopefully                     Darcs.IO                     Darcs.Lock                     Darcs.Match-                    Darcs.Ordered+                    Darcs.Witnesses.Ordered                     Darcs.Patch                     Darcs.Patch.Apply                     Darcs.Patch.Bundle-                    Darcs.Patch.Check                     Darcs.Patch.Choices                     Darcs.Patch.Commute                     Darcs.Patch.Core@@ -227,6 +230,7 @@                     Darcs.Patch.Match                     Darcs.Patch.MatchData                     Darcs.Patch.Non+                    Darcs.Patch.OldDate                     Darcs.Patch.Patchy                     Darcs.Patch.Permutations                     Darcs.Patch.Prim@@ -234,8 +238,10 @@                     Darcs.Patch.Read                     Darcs.Patch.ReadMonads                     Darcs.Patch.Real+                    Darcs.Patch.RegChars                     Darcs.Patch.Set                     Darcs.Patch.Show+                    Darcs.Patch.Split                     Darcs.Patch.TouchesFiles                     Darcs.Patch.Viewing                     Darcs.Population@@ -253,20 +259,24 @@                     Darcs.Repository.HashedIO                     Darcs.Repository.HashedRepo                     Darcs.Repository.Internal+                    Darcs.Repository.LowLevel+                    Darcs.Repository.Merge                     Darcs.Repository.InternalTypes                     Darcs.Repository.Motd                     Darcs.Repository.Prefs                     Darcs.Repository.Pristine                     Darcs.Repository.Repair+                    Darcs.Repository.State                     Darcs.Resolution                     Darcs.RunCommand-                    Darcs.Sealed+                    Darcs.Witnesses.Sealed                     Darcs.SelectChanges-                    Darcs.Show+                    Darcs.Witnesses.Show                     Darcs.SignalHandler                     Darcs.SlurpDirectory                     Darcs.SlurpDirectory.Internal                     Darcs.Test+                    Darcs.Test.Patch.Check                     Darcs.TheCommands                     Darcs.URL                     Darcs.Utils@@ -277,21 +287,18 @@                     HTTP                     IsoDate                     Lcs-                    OldDate                     Printer                     Progress-                    RegChars+                    Ratified                     SHA1                     Ssh                     URL-                    UTF8                     Workaround    other-modules:    ThisVersion    c-sources:        src/atomic_create.c                     src/fpstring.c-                    src/c_compat.c                     src/maybe_relink.c                     src/umask.c                     src/Crypt/sha2.c@@ -316,23 +323,29 @@                    html         == 1.0.*,                    filepath     == 1.1.*,                    haskeline    >= 0.6.1 && < 0.7,-                   hashed-storage >= 0.3.6 && < 0.4+                   hashed-storage >= 0.4.2 && < 0.5    if !os(windows)-    build-depends: unix >= 1.0 && < 2.4+    build-depends: unix >= 1.0 && < 2.5    build-depends: base >= 3,+                 bytestring >= 0.9.0 && < 0.10,+                 utf8-string == 0.3.*,                    old-time   == 1.0.*,                    directory  == 1.0.*,                    process    == 1.0.*,-                   containers >= 0.1 && < 0.3,-                   array      >= 0.1 && < 0.3,+                   containers >= 0.1 && < 0.4,+                   array      >= 0.1 && < 0.4,                    random     == 1.0.* +   -- We need optimizations, regardless of what Hackage says-  ghc-options:      -Wall -O2 -funbox-strict-fields+  ghc-options:      -Wall -O2 -funbox-strict-fields -fwarn-tabs   ghc-prof-options: -prof -auto-all +  if flag(hpc)+    ghc-prof-options: -fhpc+   if flag(curl)     extra-libraries:   curl     includes:          curl/curl.h@@ -352,26 +365,14 @@       cpp-options:      -DHAVE_HTTP       x-have-http: -  if !flag(curl) && !flag(http)+  if (!flag(curl) && !flag(http)) || flag(deps-only)       buildable: False    if flag(mmap) && !os(windows)     build-depends:    mmap >= 0.2     cpp-options:      -DHAVE_MMAP -  if flag(bytestring)-    build-depends:    bytestring >= 0.9.0 && < 0.10-    cpp-options:      -DHAVE_BYTESTRING--  if flag(zlib)-    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0-    cpp-options:      -DHAVE_HASKELL_ZLIB-  else-    extra-libraries:  z--  if flag(utf8-string)-    build-depends:    utf8-string == 0.3.*-    cpp-options:      -DHAVE_UTF8STRING+  build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0    -- The terminfo package cannot be built on Windows.   if flag(terminfo) && !os(windows)@@ -390,6 +391,7 @@     UndecidableInstances,     DeriveDataTypeable,     GADTs,+    ImpredicativeTypes,     TypeOperators,     ExistentialQuantification,     FlexibleContexts,@@ -412,18 +414,22 @@   include-dirs:     src   c-sources:        src/atomic_create.c                     src/fpstring.c-                    src/c_compat.c                     src/maybe_relink.c                     src/umask.c                     src/Crypt/sha2.c    -- We need optimizations, regardless of what Hackage says-  ghc-options:      -Wall -O2 -funbox-strict-fields -threaded+  ghc-options:      -Wall -O2 -funbox-strict-fields   ghc-prof-options: -prof -auto-all+  if flag(threaded)+    ghc-options:    -threaded -  if !flag(zlib)-    extra-libraries:  z+  if flag(static)+    ghc-options: -static -optl-static -optl-pthread +  if flag(hpc)+    ghc-prof-options: -fhpc+   cc-options:       -D_REENTRANT    if os(windows)@@ -433,6 +439,7 @@                     System.Posix                     System.Posix.Files                     System.Posix.IO+                    Preproc     cpp-options:    -DWIN32     c-sources:      src/win32/send_email.c @@ -446,17 +453,19 @@                    html         == 1.0.*,                    filepath     == 1.1.*,                    haskeline    >= 0.6.1 && < 0.7,-                   hashed-storage >= 0.3.6 && < 0.4+                   hashed-storage >= 0.4.2 && < 0.5    if !os(windows)-    build-depends: unix >= 1.0 && < 2.4+    build-depends: unix >= 1.0 && < 2.5    build-depends: base >= 3,+                 bytestring >= 0.9.0 && < 0.10,+                 utf8-string == 0.3.*,                    old-time   == 1.0.*,                    directory  == 1.0.*,                    process    == 1.0.*,-                   containers >= 0.1 && < 0.3,-                   array      >= 0.1 && < 0.3,+                   containers >= 0.1 && < 0.4,+                   array      >= 0.1 && < 0.4,                    random     == 1.0.*    if flag(curl)@@ -478,26 +487,14 @@       cpp-options:      -DHAVE_HTTP       x-have-http: -  if !flag(curl) && !flag(http)+  if (!flag(curl) && !flag(http)) || flag(deps-only)       buildable: False    if flag(mmap) && !os(windows)     build-depends:    mmap >= 0.2     cpp-options:      -DHAVE_MMAP -  if flag(bytestring)-    build-depends:    bytestring >= 0.9.0 && < 0.10-    cpp-options:      -DHAVE_BYTESTRING--  if flag(zlib)-    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0-    cpp-options:      -DHAVE_HASKELL_ZLIB-  else-    extra-libraries:  z--  if flag(utf8-string)-    build-depends:    utf8-string == 0.3.*-    cpp-options:      -DHAVE_UTF8STRING+  build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0    -- The terminfo package cannot be built on Windows.   if flag(terminfo) && !os(windows)@@ -516,6 +513,7 @@     UndecidableInstances,     DeriveDataTypeable,     GADTs,+    ImpredicativeTypes,     TypeOperators,     ExistentialQuantification,     FlexibleContexts,@@ -538,14 +536,15 @@   include-dirs:     src   c-sources:        src/atomic_create.c                     src/fpstring.c-                    src/c_compat.c                     src/maybe_relink.c                     src/umask.c                     src/Crypt/sha2.c    -- We need optimizations, regardless of what Hackage says-  ghc-options:      -Wall -O2 -funbox-strict-fields -threaded+  ghc-options:      -Wall -O2 -funbox-strict-fields   ghc-prof-options: -prof -auto-all+  if flag(threaded)+    ghc-options:    -threaded    if !flag(test)     buildable: False@@ -564,9 +563,6 @@                      test-framework-quickcheck2 >= 0.2.2  -  if !flag(zlib)-    extra-libraries:  z-   cc-options:       -D_REENTRANT    if os(windows)@@ -583,29 +579,22 @@     cc-options:     -DHAVE_SIGINFO_H    if !os(windows)-    build-depends: unix >= 1.0 && < 2.4+    build-depends: unix >= 1.0 && < 2.5    build-depends: base >= 3,+                 bytestring >= 0.9.0 && < 0.10,                    old-time   == 1.0.*,                    directory  == 1.0.*,                    process    == 1.0.*,-                   containers >= 0.1 && < 0.3,-                   array      >= 0.1 && < 0.3,+                   containers >= 0.1 && < 0.4,+                   array      >= 0.1 && < 0.4,                    random     == 1.0.*    if flag(mmap) && !os(windows)     build-depends:    mmap >= 0.2     cpp-options:      -DHAVE_MMAP -  if flag(bytestring)-    build-depends:    bytestring >= 0.9.0 && < 0.10-    cpp-options:      -DHAVE_BYTESTRING--  if flag(zlib)-    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0-    cpp-options:      -DHAVE_HASKELL_ZLIB-  else-    extra-libraries:  z+  build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0    -- The terminfo package cannot be built on Windows.   if flag(terminfo) && !os(windows)
+ doc/darcs.css view
@@ -0,0 +1,94 @@+BODY {+  background: white;+  color: black;+  font-family: arial,sans-serif;+  margin: 0;+  padding: 1em;+}++A:link {+  background: transparent;+  color: #494a82;+}++A:visited {+  background: transparent;+  color: #8081b3+}++IMG.thanks-left {+  float: left;+  margin-right: 5px;+  height: 50px;+}++IMG.thanks-right {+  float: right;+  margin-left: 5px;+  height: 50px;+}++PRE     {+  background: #eeeeee;+  border: 1px solid #888888;+  color: black;+  padding: 1em;+  white-space: pre;+}++H1      {+  color: #494a82;+  font-size: 24px ;+}++H2      {+  color: #494a82;+  font-size: 18px;+}++H3      {+  color: #494a82;+  font-size: 16px;+}++H4      {+  color: #494a82;+  font-size: 14px;+}++/* headers for darcs command options */+.cmd-opt-hdr     {+  color: #494a82;+  font-size: 14px;+  font-weight: bold;+}++/* begin styles for RSS Feed This is the most basic style to use for a list with no bullets */++.rss_title, rss_title a {+    margin: 0px 0;+    padding: 0;+}++.rss_items {+       list-style:none;+       margin:0;+       padding:0;+}++.rss_item  {+/*  font-size: x-small; */+  margin-bottom: 1em;;+}++.rss_item a:link, .rss_item a:visited, .rss_item a:active {++    }++.rss_item a:hover { ++    }+    +.rss_date {+    font-size: xx-small;+    }
+ doc/manual/patch-theory.tex view
@@ -0,0 +1,79 @@+%% This file was automatically generated by preproc.+%  Copyright (C) 2007 David Roundy+%+%  This program is free software; you can redistribute it and/or modify+%  it under the terms of the GNU General Public License as published by+%  the Free Software Foundation; either version 2, or (at your option)+%  any later version.+%+%  This program is distributed in the hope that it will be useful,+%  but WITHOUT ANY WARRANTY; without even the implied warranty of+%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+%  GNU General Public License for more details.+%+%  You should have received a copy of the GNU General Public License+%  along with this program; see the file COPYING.  If not, write to+%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+%  Boston, MA 02110-1301, USA.++\documentclass{article}+%\usepackage{color}++\usepackage{verbatim}+\usepackage{hyperref}+\usepackage{fancyvrb}+\newenvironment{code}{\comment}{\endcomment}+% \newenvironment{code}{\color{blue}\verbatim}{\endverbatim}++\newcommand{\commutes}{\longleftrightarrow}++\begin{document}+++\section{Patch properties}++Darcs is built on a hierarchy of patch types.  At the lowest level are+``primitive'' patches, and from these building blocks, a whole hierarchy of+patch types are built.  Each of these patch types must support a number of+functions, which must obey a number of laws.++\subsection{Properties of identity}++\newtheorem{prp}{Property}++\begin{prp}[Identity commutes trivially]+  The identity patch must commute with any patch without modifying said patch.+\end{prp}+++\begin{prp}[Inverse doesn't commute]+  A patch and its inverse will always commute, unless that patch is an+  identity patch (or an identity-like patch that has no effect).+\end{prp}+++\subsection{Commute properties}++\begin{prp}[Recommute]+  $AB \commutes B'A'$ if and only if $B'A' \commutes AB$+\end{prp}+++\begin{prp}[Commute inverses]+  $AB \commutes B'A'$ if and only if $B^{-1}A^{-1} \commutes A'^{-1}B'^{-1}$+\end{prp}+++\begin{prp}[Patch and inverse]+  If $AB \commutes B'A'$ then $A^{-1}B' \commutes BA'^{-1}$+\end{prp}++This property is only true of primitive patches.+++\begin{prp}[Permutivity]+  (to be added...)+\end{prp}+++\end{document}
release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.2.98.4\nPetr Rockai <me@mornfall.net>**20090715100830\n Ignore-this: a5b37c42d10dd5a17b6d00420643aa9f\n] \n"+Just "\nContext:\n\n[TAG 2.3.98.1\nReinier Lamers <tux_rocker@reinier.de>**20100103150819\n Ignore-this: def816d83bf49dc3bc16c7473323385f\n] \n"
src/ByteStringUtils.hs view
@@ -18,7 +18,6 @@ module ByteStringUtils (          unsafeWithInternals,-        unpackPSfromUTF8,          -- IO with mmap or gzip         gzReadFilePS,@@ -28,9 +27,7 @@          -- gzip handling         isGZFile,-#ifdef HAVE_HASKELL_ZLIB         gzDecompress,-#endif          -- list utilities         ifHeadThenTail,@@ -59,27 +56,22 @@ import Data.ByteString (intercalate, uncons) import Data.ByteString.Internal (fromForeignPtr) -#if defined (HAVE_MMAP) || ! defined (HAVE_HASKELL_ZLIB)+#if defined (HAVE_MMAP) import Control.Exception        ( catch ) #endif import System.IO import System.IO.Unsafe         ( unsafePerformIO )  import Foreign.Storable         ( peekElemOff, peek )-import Foreign.Marshal.Alloc    ( free )-import Foreign.Marshal.Array    ( mallocArray, peekArray, advancePtr )+import Foreign.Marshal.Array    ( advancePtr ) import Foreign.C.Types          ( CInt )  import Data.Bits                ( rotateL )-import Data.Char                ( chr, ord, isSpace )+import Data.Char                ( ord, isSpace ) import Data.Word                ( Word8 ) import Data.Int                 ( Int32 ) import Control.Monad            ( when ) -#ifndef HAVE_HASKELL_ZLIB-import Foreign.Ptr              ( nullPtr )-import Foreign.ForeignPtr       ( ForeignPtr )-#endif import Foreign.Ptr              ( plusPtr, Ptr ) import Foreign.ForeignPtr       ( withForeignPtr ) @@ -88,14 +80,10 @@ import Foreign.Ptr              ( FunPtr ) #endif -#if HAVE_HASKELL_ZLIB import qualified Data.ByteString.Lazy as BL import qualified Codec.Compression.GZip as GZ import qualified Codec.Compression.Zlib.Internal as ZI import Darcs.Global ( addCRCWarning )-#else-import Foreign.C.String ( CString, withCString )-#endif  #ifdef HAVE_MMAP import System.IO.MMap( mmapFileByteString )@@ -106,22 +94,6 @@ -- ----------------------------------------------------------------------------- -- obsolete debugging code -# ifndef HAVE_HASKELL_ZLIB-debugForeignPtr :: ForeignPtr a -> String -> IO ()-#ifdef DEBUG_PS-foreign import ccall unsafe "static fpstring.h debug_alloc" debug_alloc-    :: Ptr a -> CString -> IO ()-foreign import ccall unsafe "static fpstring.h & debug_free" debug_free-    :: FunPtr (Ptr a -> IO ())-debugForeignPtr fp n =-    withCString n $ \cname-> withForeignPtr fp $ \p->-    do debug_alloc p cname-       addForeignPtrFinalizer debug_free fp-#else-debugForeignPtr _ _ = return ()-#endif-#endif- -- ----------------------------------------------------------------------------- -- unsafeWithInternals @@ -142,26 +114,6 @@ readIntPS = BC.readInt . BC.dropWhile isSpace  -- -------------------------------------------------------------------------------- Destructor functions (taking PackedStrings apart)--unpackPSfromUTF8 :: B.ByteString -> String-unpackPSfromUTF8 ps =- case BI.toForeignPtr ps of-   (_,_, 0) -> ""-   (x,s,l)  ->-    unsafePerformIO $ withForeignPtr x $ \p->-    do outbuf <- mallocArray l-       lout <- fromIntegral `fmap`-               utf8_to_ints outbuf (p `plusPtr` s) (fromIntegral l)-       when (lout < 0) $ error "Bad UTF8!"-       str <- (map (chr . fromIntegral)) `fmap` peekArray lout outbuf-       free outbuf-       return str--foreign import ccall unsafe "static fpstring.h utf8_to_ints" utf8_to_ints-    :: Ptr Int -> Ptr Word8 -> CInt -> IO CInt---- ----------------------------------------------------------------------------- -- List-mimicking functions for PackedStrings  {-# INLINE ifHeadThenTail #-}@@ -343,8 +295,6 @@ -- ----------------------------------------------------------------------------- -- gzReadFilePS -#ifdef HAVE_HASKELL_ZLIB- -- |Decompress the given bytestring into a lazy list of chunks, along with a boolean -- flag indicating (if True) that the CRC was corrupted. -- Inspecting the flag will cause the entire list of chunks to be evaluated (but if@@ -353,7 +303,7 @@ gzDecompress mbufsize =     -- This is what the code would be without the bad CRC recovery logic:     -- return . BL.toChunks . GZ.decompressWith decompressParams-    toListWarn . ZI.decompressWithErrors ZI.GZip decompressParams+    toListWarn . ZI.decompressWithErrors ZI.gzipFormat decompressParams   where         decompressParams = case mbufsize of                               Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize }@@ -378,19 +328,6 @@         handleBad ZI.DataError "incorrect data check" = ([], True)         handleBad _ msg = error msg -#else--foreign import ccall unsafe "static zlib.h gzopen" c_gzopen-    :: CString -> CString -> IO (Ptr ())-foreign import ccall unsafe "static zlib.h gzclose" c_gzclose-    :: Ptr () -> IO ()-foreign import ccall unsafe "static zlib.h gzread" c_gzread-    :: Ptr () -> Ptr Word8 -> CInt -> IO CInt-foreign import ccall unsafe "static zlib.h gzwrite" c_gzwrite-    :: Ptr () -> Ptr Word8 -> CInt -> IO CInt--#endif- isGZFile :: FilePath -> IO (Maybe Int) isGZFile f = do     h <- openBinaryFile f ReadMode@@ -411,7 +348,6 @@     case mlen of        Nothing -> mmapFilePS f        Just len ->-#ifdef HAVE_HASKELL_ZLIB             do -- Passing the length to gzDecompress means that it produces produces one chunk,                -- which in turn means that B.concat won't need to copy data.                -- If the length is wrong this will just affect efficiency, not correctness@@ -420,19 +356,6 @@                                             return res                compressed <- (BL.fromChunks . return) `fmap` mmapFilePS f                B.concat `fmap` doDecompress compressed-#else-               withCString f $ \fstr-> withCString "rb" $ \rb-> do-                 gzf <- c_gzopen fstr rb-                 when (gzf == nullPtr) $ fail $ "problem opening file "++f-                 fp <- BI.mallocByteString len-                 debugForeignPtr fp $ "gzReadFilePS "++f-                 lread <- withForeignPtr fp $ \p ->-                          c_gzread gzf p (fromIntegral len)-                 c_gzclose gzf-                 when (fromIntegral lread /= len) $-                      fail $ "problem gzreading file "++f-                 return $ fromForeignPtr fp 0 len-#endif  hGetLittleEndInt :: Handle -> IO Int hGetLittleEndInt h = do@@ -447,26 +370,7 @@  gzWriteFilePSs :: FilePath -> [B.ByteString] -> IO () gzWriteFilePSs f pss  =-#ifdef HAVE_HASKELL_ZLIB     BL.writeFile f $ GZ.compress $ BL.fromChunks pss-#else-    withCString f $ \fstr -> withCString "wb" $ \wb -> do-    gzf <- c_gzopen fstr wb-    when (gzf == nullPtr) $ fail $ "problem gzopening file for write: "++f-    mapM_ (gzWriteToGzf gzf) pss `catch`-              \_ -> fail $ "problem gzwriting file: "++f-    c_gzclose gzf--gzWriteToGzf :: Ptr () -> B.ByteString -> IO ()-gzWriteToGzf gzf ps = case BI.toForeignPtr ps of- (_,_,0) -> return () -- avoid calling gzwrite with 0 length this would-                      -- trouble on some versions of zlib, and is always-                      -- unnecessary.- (x,s,l) -> do-    lw <- withForeignPtr x $ \p -> c_gzwrite gzf (p `plusPtr` s)-                                                 (fromIntegral l)-    when (fromIntegral lw /= l) $ fail $ "problem in gzWriteToGzf"-#endif  -- ----------------------------------------------------------------------------- -- mmapFilePS
src/CommandLine.hs view
@@ -109,7 +109,7 @@ parseCmd ftable s = parse (commandline ftable) "" s  urlEncode :: String -> String-urlEncode s = concat $ map escapeC s+urlEncode s = concatMap escapeC s     where escapeC x = if allowed x then [x] else '%':(intToHex $ ord x)           intToHex i = map intToDigit [i `div` 16, i `mod` 16]               allowed x = x `elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']
src/Darcs/ArgumentDefaults.lhs view
@@ -22,10 +22,10 @@ import Darcs.Arguments ( DarcsFlag,                          DarcsOption( DarcsArgOption, DarcsNoArgOption, DarcsMultipleChoiceOption ),                          arein, isin )-import Darcs.Commands ( CommandControl( Command_data ),-                        command_alloptions )-import Darcs.Commands.Help ( command_control_list )-import Darcs.Repository.Prefs ( get_global, get_preflist )+import Darcs.Commands ( CommandControl( CommandData ),+                        commandAlloptions )+import Darcs.Commands.Help ( commandControlList )+import Darcs.Repository.Prefs ( getGlobal, getPreflist ) \end{code}  \paragraph{defaults}\label{defaults}@@ -118,8 +118,8 @@ \begin{code} get_default_flags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag] get_default_flags com com_opts already = do-    repo_defs   <- default_content $ get_preflist "defaults"-    global_defs <- default_content $ get_global   "defaults"+    repo_defs   <- default_content $ getPreflist "defaults"+    global_defs <- default_content $ getGlobal   "defaults"     let repo_flags = get_flags_from com com_opts already repo_defs         global_flags = get_flags_from com com_opts                                           (already++repo_flags) global_defs@@ -132,8 +132,8 @@     where com_defs = filter (\ (c,_,_) -> c == com) defs           all_defs = filter (\ (c,_,_) -> c == "ALL") defs           options_for d o ao = concatMap (find_option o ao already) d-          all_opts = concatMap get_opts command_control_list-          get_opts (Command_data c) = let (o1, o2) = command_alloptions c+          all_opts = concatMap get_opts commandControlList+          get_opts (CommandData c) = let (o1, o2) = commandAlloptions c                                       in o1 ++ o2           get_opts _                = []
src/Darcs/Arguments.lhs view
@@ -16,8 +16,8 @@ %  Boston, MA 02110-1301, USA.  \begin{code}-{-# OPTIONS_GHC -cpp #-}-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp -XPatternGuards #-}+{-# LANGUAGE CPP, PatternGuards #-}  #include "gadts.h" @@ -27,87 +27,96 @@                          definePatches, defineChanges,                          fixFilePathOrStd, fixUrl,                          fixSubPaths, areFileArgs,-                         DarcsOption( .. ), option_from_darcsoption,-                         help, list_options, list_files,-                         any_verbosity, disable, restrict_paths,-                         notest, test, working_repo_dir,+                         DarcsOption( .. ), optionFromDarcsoption,+                         help, listOptions, listFiles,+                         anyVerbosity, disable, restrictPaths,+                         notest, test, workingRepoDir,                          testByDefault,-                         remote_repo,-                         leave_test_dir,-                         possibly_remote_repo_dir, get_repourl,-                         list_registered_files, list_unregistered_files,-                         author, get_author, get_easy_author, get_sendmail_cmd,-                         patchname_option, distname_option,-                         logfile, rmlogfile, from_opt, subject, get_subject,-                         in_reply_to, get_in_reply_to,-                         target, cc, get_cc, output, output_auto_name,-                         recursive, inventory_choices, get_inventory_choices,+                         remoteRepo,+                         leaveTestDir,+                         possiblyRemoteRepoDir, getRepourl,+                         listRegisteredFiles, listUnregisteredFiles,+                         author, getAuthor, getEasyAuthor, getSendmailCmd,+                         fileHelpAuthor, environmentHelpEmail,+                         patchnameOption, distnameOption,+                         logfile, rmlogfile, fromOpt, subject, getSubject,+                         inReplyTo, getInReplyTo,+                         target, ccSend, ccApply, getCc, output, outputAutoName,+                         recursive, inventoryChoices, getInventoryChoices,+                         upgradeFormat,                          askdeps, ignoretimes, lookforadds,-                         ask_long_comment, sendmail_cmd,+                         askLongComment, sendmailCmd,                          environmentHelpSendmail,-                         sign, verify, edit_description,-                         reponame, tagname, creatorhash,-                         apply_conflict_options, reply,-                         pull_conflict_options, use_external_merge,-                         deps_sel, nocompress,-                         uncompress_nocompress, repo_combinator,-                         options_latex, reorder_patches,-                         noskip_boring, allow_problematic_filenames,-                         applyas, human_readable,-                         changes_reverse, only_to_files,-                         changes_format, match_one_context, match_one_nontag,-                         match_maxcount,-                         send_to_context,-                         get_context,-                         pipe_interactive, all_interactive,-                         all_pipe_interactive,+                         sign, verify, editDescription,+                         reponame, creatorhash,+                         applyConflictOptions, reply,+                         pullConflictOptions, useExternalMerge,+                         depsSel, nocompress,+                         uncompressNocompress, repoCombinator,+                         optionsLatex, reorderPatches,+                         noskipBoring, allowProblematicFilenames,+                         applyas, humanReadable,+                         changesReverse, onlyToFiles,+                         changesFormat, matchOneContext, matchOneNontag,+                         matchMaxcount,+                         sendToContext,+                         getContext,+                         pipeInteractive, allInteractive,+                         allPipeInteractive,                          summary, unified, tokens,-                         checkpoint, partial, partial_check,-                         diff_cmd_flag, diffflags, unidiff, xmloutput,-                         force_replace, dry_run, dry_run_noxml,-                         print_dry_run_message_and_exit, showFriendly,-                         match_one, match_several, match_range,-                         match_several_or_range, happy_forwarding,-                         match_several_or_last,-                         set_default,-                         fancy_move_add,-                         set_scripts_executable,-                         sibling, flagsToSiblings, relink, relink_pristine, nolinks,+                         partial, partialCheck,+                         diffCmdFlag, diffflags, unidiff, xmloutput,+                         forceReplace, dryRun, dryRunNoxml,+                         printDryRunMessageAndExit, showFriendly,+                         matchOne, matchSeveral, matchRange,+                         matchSeveralOrRange, happyForwarding,+                         matchSeveralOrLast,+                         setDefault,+                         fancyMoveAdd,+                         setScriptsExecutableOption,+                         sibling, flagsToSiblings, relink, relinkPristine, nolinks,                          files, directories, pending,-                         posthook_cmd, posthook_prompt,-                         get_posthook_cmd,-                         prehook_cmd, prehook_prompt,-                         get_prehook_cmd, nullFlag,-                         umask_option,-                         store_in_memory,-                         patch_select_flag,-                         network_options, no_cache,-                         allow_unrelated_repos,-                         check_or_repair, just_this_repo+                         posthookCmd, posthookPrompt,+                         getPosthookCmd,+                         prehookCmd, prehookPrompt,+                         getPrehookCmd, nullFlag,+                         umaskOption,+                         storeInMemory,+                         patchSelectFlag,+                         networkOptions, noCache,+                         allowUnrelatedRepos,+                         checkOrRepair, justThisRepo, optimizePristine                       ) where import System.Console.GetOpt import System.Directory ( doesDirectoryExist )++import Storage.Hashed.AnchoredPath( anchorPath )+import Storage.Hashed.Plain( readPlainTree )+import Storage.Hashed.Tree( list, expand, emptyTree )+ import Data.List ( (\\), nub ) import Data.Maybe ( fromMaybe, listToMaybe ) import System.Exit ( ExitCode(ExitSuccess), exitWith ) import Data.Maybe ( catMaybes ) import Control.Monad ( when, unless )+import Control.Applicative( (<$>) ) import Data.Char ( isDigit ) #ifndef WIN32 import Printer ( renderString ) import System.Posix.Env ( setEnv )-import Darcs.Patch ( list_touched_files )+import Darcs.Patch ( listTouchedFiles ) import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) #endif  import Darcs.Hopefully ( PatchInfoAnd, info, hopefullyM )-import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xml_summary )+import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xmlSummary ) import Darcs.Patch.Info ( to_xml )-import Darcs.Ordered ( FL, mapFL )+import Darcs.Witnesses.Ordered ( FL, mapFL ) import qualified Darcs.Patch ( summary ) import Darcs.Utils ( askUser, maybeGetEnv, firstNotBlank, firstJustIO,                      withCurrentDirectory )-import Darcs.Repository.Prefs ( boring_file_filter, get_preflist, get_global )+import Darcs.Repository.Prefs ( getPreflist, getGlobal )+import Darcs.Repository.State ( restrictBoring, readRecordedAndPending ) import Darcs.URL ( is_file ) import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd, SubPath, toFilePath,                         makeSubPathOf, simpleSubPath,@@ -115,9 +124,7 @@                         makeAbsolute, makeAbsoluteOrStd, rootDirectory ) import Darcs.Patch.MatchData ( patch_match ) import Darcs.Flags ( DarcsFlag(..), maxCount )-import Darcs.Repository ( slurp_pending, withRepository, ($-) )-import Darcs.Repository.HashedRepo ( slurp_all_but_darcs )-import Darcs.SlurpDirectory ( list_slurpy )+import Darcs.Repository ( withRepository ) import Darcs.Global ( darcsdir ) import Printer ( Doc, putDocLn, text, vsep, ($$), vcat, insert_before_lastline,                  prefix )@@ -132,7 +139,7 @@ -- guarantees that isAnAbsolute, isa, flagToString, etc also work -- properly) --- | 'get_content' returns the content of a flag, if any.+-- | 'getContentString' returns the content of a flag, if any. -- For instance, the content of @Author \"Louis Aragon\"@ is @StringContent -- \"Louis Aragon\"@, while the content of @Pipe@ is @NoContent@ getContent :: DarcsFlag -> FlagContent@@ -144,6 +151,7 @@ getContent Test = NoContent getContent NoTest = NoContent getContent OnlyChangesToFiles = NoContent+getContent ChangesToAllFiles = NoContent getContent LeaveTestDir = NoContent getContent NoLeaveTestDir = NoContent getContent Timings = NoContent@@ -183,6 +191,7 @@ getContent AskDeps = NoContent getContent NoAskDeps = NoContent getContent RmLogFile = NoContent+getContent DontRmLogFile = NoContent getContent (DistName s) = StringContent s getContent (CreatorHash s) = StringContent s getContent (SignAs s) = StringContent s@@ -190,18 +199,22 @@ getContent (Verify s) = AbsoluteContent s getContent (VerifySSL s) = AbsoluteContent s getContent IgnoreTimes = NoContent+getContent DontIgnoreTimes = NoContent getContent LookForAdds = NoContent getContent NoLookForAdds = NoContent getContent AnyOrder = NoContent getContent Intersection = NoContent getContent Unified = NoContent+getContent NonUnified = NoContent getContent Union = NoContent getContent Complement = NoContent getContent Sign = NoContent getContent NoSign = NoContent getContent HappyForwarding = NoContent+getContent NoHappyForwarding = NoContent getContent SSHControlMaster = NoContent getContent NoSSHControlMaster = NoContent+getContent (RemoteDarcs s) = StringContent s getContent (Toks s) = StringContent s getContent (WorkRepoDir s) = StringContent s getContent (WorkRepoUrl s) = StringContent s@@ -216,9 +229,13 @@ getContent AllowConflicts = NoContent getContent MarkConflicts = NoContent getContent NoAllowConflicts = NoContent+getContent SkipConflicts = NoContent getContent Boring = NoContent+getContent SkipBoring = NoContent getContent AllowCaseOnly = NoContent+getContent DontAllowCaseOnly = NoContent getContent AllowWindowsReserved = NoContent+getContent DontAllowWindowsReserved = NoContent getContent DontGrabDeps = NoContent getContent DontPromptForDependencies = NoContent getContent PromptForDependencies = NoContent@@ -240,7 +257,7 @@ getContent (UpToPattern _) = NoContent -- FIXME!!! getContent (AfterPattern _) = NoContent -- FIXME!!! getContent Reverse = NoContent-getContent CheckPoint = NoContent+getContent Forward = NoContent getContent Partial = NoContent getContent Complete = NoContent getContent Lazy = NoContent@@ -265,6 +282,7 @@ getContent PristinePlain = NoContent getContent PristineNone = NoContent getContent NoUpdateWorking = NoContent+getContent UpgradeFormat = NoContent getContent Relink = NoContent getContent RelinkPristine = NoContent getContent NoLinks = NoContent@@ -283,6 +301,7 @@ getContent RunPrehook = NoContent getContent AskPrehook = NoContent getContent StoreInMemory = NoContent+getContent ApplyOnDisk = NoContent getContent HTTPPipelining = NoContent getContent NoHTTPPipelining = NoContent getContent NoCache = NoContent@@ -293,16 +312,18 @@ getContent Check = NoContent getContent Repair = NoContent getContent JustThisRepo = NoContent+getContent OptimizePristine = NoContent -get_content :: DarcsFlag -> Maybe String-get_content f = do StringContent s <- Just $ getContent f-                   return s+getContentString :: DarcsFlag -> Maybe String+getContentString f =+   do StringContent s <- Just $ getContent f+      return s  -- | @a `'isa'` b@ tests whether @a@ is flag @b@ with a string argument. -- @b@ typically is a Flag constructor expecting a string -- For example, @(Author \"Ted Hughes\") `isa` Author@ returns true. isa :: DarcsFlag -> (String -> DarcsFlag) -> Bool-a `isa` b = case get_content a of+a `isa` b = case getContentString a of             Nothing -> False             Just s -> a == b s @@ -378,35 +399,35 @@     -- ^ A constructor for grouping related options together, such as     -- @--hashed@, @--darcs-2@ and @--old-fashioned-inventory@. -option_from_darcsoption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]-option_from_darcsoption _ (DarcsNoArgOption a b c h) = [Option a b (NoArg c) h]-option_from_darcsoption _ (DarcsArgOption a b c n h) = [Option a b (ReqArg c n) h]-option_from_darcsoption wd (DarcsMultipleChoiceOption os) = concatMap (option_from_darcsoption wd) os-option_from_darcsoption wd (DarcsAbsPathOrStdOption a b c n h) = [Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h]-option_from_darcsoption wd (DarcsAbsPathOption a b c n h) = [Option a b (ReqArg (c . makeAbsolute wd) n) h]-option_from_darcsoption wd (DarcsOptAbsPathOption a b d c n h) = [Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h]+optionFromDarcsoption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]+optionFromDarcsoption _ (DarcsNoArgOption a b c h) = [Option a b (NoArg c) h]+optionFromDarcsoption _ (DarcsArgOption a b c n h) = [Option a b (ReqArg c n) h]+optionFromDarcsoption wd (DarcsMultipleChoiceOption os) = concatMap (optionFromDarcsoption wd) os+optionFromDarcsoption wd (DarcsAbsPathOrStdOption a b c n h) = [Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h]+optionFromDarcsoption wd (DarcsAbsPathOption a b c n h) = [Option a b (ReqArg (c . makeAbsolute wd) n) h]+optionFromDarcsoption wd (DarcsOptAbsPathOption a b d c n h) = [Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h]  -- | 'concat_option' creates a DarcsMultipleChoiceOption from a list of -- option, flattening any DarcsMultipleChoiceOption in the list.-concat_options :: [DarcsOption] -> DarcsOption-concat_options os = DarcsMultipleChoiceOption $ concatMap from_option os+concatOptions :: [DarcsOption] -> DarcsOption+concatOptions os = DarcsMultipleChoiceOption $ concatMap from_option os  where   from_option (DarcsMultipleChoiceOption xs) = xs   from_option x = [x] -extract_fix_path :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath)-extract_fix_path [] = Nothing-extract_fix_path ((FixFilePath repo orig):_)  = Just (repo, orig)-extract_fix_path (_:fs) = extract_fix_path fs+extractFixPath :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath)+extractFixPath [] = Nothing+extractFixPath ((FixFilePath repo orig):_)  = Just (repo, orig)+extractFixPath (_:fs) = extractFixPath fs  fixFilePath :: [DarcsFlag] -> FilePath -> IO AbsolutePath-fixFilePath opts f = case extract_fix_path opts of+fixFilePath opts f = case extractFixPath opts of                        Nothing -> bug "Can't fix path in fixFilePath"                        Just (_,o) -> withCurrentDirectory o $ ioAbsolute f  fixFilePathOrStd :: [DarcsFlag] -> FilePath -> IO AbsolutePathOrStd fixFilePathOrStd opts f =-    case extract_fix_path opts of+    case extractFixPath opts of       Nothing -> bug "Can't fix path in fixFilePathOrStd"       Just (_,o) -> withCurrentDirectory o $ ioAbsoluteOrStd f @@ -424,7 +445,7 @@               putStrLn $ "Ignoring non-repository paths: " ++ unwords bad        return $ nub good  where-    (r,o) = case extract_fix_path flags of+    (r,o) = case extractFixPath flags of             Just xxx -> xxx             Nothing -> bug "Can't fix path in fixSubPaths"     fixit p = do ap <- ioAbsolute p@@ -441,13 +462,13 @@ areFileArgs rps = concatMap toFilePath rps /= ""  -- | 'list_option' is an option which lists the command's arguments-list_options :: DarcsOption-list_options = DarcsNoArgOption [] ["list-options"] ListOptions+listOptions :: DarcsOption+listOptions = DarcsNoArgOption [] ["list-options"] ListOptions                "simply list the command's arguments"  flagToString :: [DarcsOption] -> DarcsFlag -> Maybe String flagToString x f = maybeHead $ catMaybes $ map f2o x-    where f2o (DarcsArgOption _ (s:_) c _ _) = do arg <- get_content f+    where f2o (DarcsArgOption _ (s:_) c _ _) = do arg <- getContentString f                                                   if c arg == f                                                       then return $ unwords [('-':'-':s), arg]                                                       else Nothing@@ -458,31 +479,29 @@           maybeHead [] = Nothing  reponame :: DarcsOption-tagname :: DarcsOption-deps_sel :: DarcsOption-checkpoint :: DarcsOption+depsSel :: DarcsOption partial :: DarcsOption-partial_check :: DarcsOption+partialCheck :: DarcsOption tokens :: DarcsOption-working_repo_dir :: DarcsOption-possibly_remote_repo_dir :: DarcsOption+workingRepoDir :: DarcsOption+possiblyRemoteRepoDir :: DarcsOption disable :: DarcsOption-restrict_paths :: DarcsOption+restrictPaths :: DarcsOption -pipe_interactive, all_pipe_interactive, all_interactive, all_patches, interactive, pipe,-  human_readable, diffflags, allow_problematic_filenames, noskip_boring,-  ask_long_comment, match_one_nontag, changes_reverse, creatorhash,-  changes_format, match_one_context, happy_forwarding, send_to_context,-  diff_cmd_flag, store_in_memory, use_external_merge,-  pull_conflict_options, target, cc, apply_conflict_options, reply, xmloutput,-  distname_option, patchname_option, edit_description,-  output, output_auto_name, unidiff, repo_combinator,-  unified, summary, uncompress_nocompress, subject, in_reply_to,-  nocompress, match_several_or_range, match_several_or_last,-  author, askdeps, lookforadds, ignoretimes, test, notest, help, force_replace,-  allow_unrelated_repos,-  match_one, match_range, match_several, fancy_move_add, sendmail_cmd,-  logfile, rmlogfile, leave_test_dir, from_opt, set_default+pipeInteractive, allPipeInteractive, allInteractive, all_patches, interactive, pipe,+  humanReadable, diffflags, allowProblematicFilenames, noskipBoring,+  askLongComment, matchOneNontag, changesReverse, creatorhash,+  changesFormat, matchOneContext, happyForwarding, sendToContext,+  diffCmdFlag, storeInMemory, useExternalMerge,+  pullConflictOptions, target, ccSend, ccApply, applyConflictOptions, reply, xmloutput,+  distnameOption, patchnameOption, editDescription,+  output, outputAutoName, unidiff, repoCombinator,+  unified, summary, uncompressNocompress, subject, inReplyTo,+  nocompress, matchSeveralOrRange, matchSeveralOrLast,+  author, askdeps, lookforadds, ignoretimes, test, notest, help, forceReplace,+  allowUnrelatedRepos,+  matchOne, matchRange, matchSeveral, fancyMoveAdd, sendmailCmd,+  logfile, rmlogfile, leaveTestDir, fromOpt, setDefault        :: DarcsOption @@ -527,8 +546,8 @@ \end{options} Most commands also accept the \verb!--verbose! option, which tells darcs to provide additional output.  The amount of verbosity varies from command to-command.  Commands that accept \verb!--verbose\verb! also accept \verb!--quiet\verb!,-which surpresses non-error output, and \verb!--normal-verbosity\verb! which can be+command.  Commands that accept \verb!--verbose! also accept \verb!--quiet!,+which surpresses non-error output, and \verb!--normal-verbosity! which can be used to restore the default verbosity if \verb!--verbose! or \verb!--quiet! is in the defaults file. @@ -540,8 +559,8 @@ would not be interesting. Option \verb!--debug-http! makes darcs output debugging info for libcurl. \begin{code}-any_verbosity :: [DarcsOption]-any_verbosity =[DarcsMultipleChoiceOption+anyVerbosity :: [DarcsOption]+anyVerbosity =[DarcsMultipleChoiceOption                 [DarcsNoArgOption [] ["debug"] Debug                  "give only debug output",                  DarcsNoArgOption [] ["debug-verbose"] DebugVerbose@@ -569,18 +588,18 @@ when running \verb'apply' from a mailer.  \begin{code}-working_repo_dir = DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY"+workingRepoDir = DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY"              "specify the repository directory in which to run"-possibly_remote_repo_dir = DarcsArgOption [] ["repo"] WorkRepoUrl "URL"+possiblyRemoteRepoDir = DarcsArgOption [] ["repo"] WorkRepoUrl "URL"              "specify the repository URL" --- | 'get_repourl' takes a list of flags and returns the url of the+-- | 'getRepourl' takes a list of flags and returns the url of the -- repository specified by @Repodir \"directory\"@ in that list of flags, if any. -- This flag is present if darcs was invoked with @--repodir=DIRECTORY@-get_repourl :: [DarcsFlag] -> Maybe String-get_repourl [] = Nothing-get_repourl (WorkRepoUrl d:_) | not (is_file d) = Just d-get_repourl (_:fs) = get_repourl fs+getRepourl :: [DarcsFlag] -> Maybe String+getRepourl [] = Nothing+getRepourl (WorkRepoUrl d:_) | not (is_file d) = Just d+getRepourl (_:fs) = getRepourl fs \end{code}  \begin{options}@@ -597,10 +616,10 @@ (and the default repository may be overwritten).  \begin{code}--- | 'remote_repo' is the option used to specify the URL of the remote+-- | 'remoteRepo' is the option used to specify the URL of the remote -- repository to work with-remote_repo :: DarcsOption-remote_repo = DarcsArgOption [] ["remote-repo"] RemoteRepo "URL"+remoteRepo :: DarcsOption+remoteRepo = DarcsArgOption [] ["remote-repo"] RemoteRepo "URL"              "specify the remote repository URL to work with" \end{code} @@ -608,13 +627,13 @@ \input{Darcs/Patch/Match.lhs}  \begin{code}-patchname_option = DarcsArgOption ['m'] ["patch-name"] PatchName "PATCHNAME"+patchnameOption = DarcsArgOption ['m'] ["patch-name"] PatchName "PATCHNAME"                    "name of patch" -send_to_context = DarcsAbsPathOption [] ["context"] Context "FILENAME"+sendToContext = DarcsAbsPathOption [] ["context"] Context "FILENAME"                   "send to context stored in FILENAME" -match_one_context =+matchOneContext =     DarcsMultipleChoiceOption     [DarcsArgOption [] ["to-match"] mp "PATTERN"      "select changes up to a patch matching PATTERN",@@ -626,16 +645,16 @@     ]     where mp s = OnePattern (patch_match s) -match_one = concat_options [__match, __patch, __tag, __index]-match_one_nontag = concat_options [__match, __patch, __index]-match_several    = concat_options [__matches, __patches, __tags]-match_range            = concat_options [match_to, match_from, __match, __patch, __last, __indexes]-match_several_or_range = concat_options [match_to, match_from, __last, __indexes,+matchOne = concatOptions [__match, __patch, __tag, __index]+matchOneNontag = concatOptions [__match, __patch, __index]+matchSeveral    = concatOptions [__matches, __patches, __tags]+matchRange            = concatOptions [matchTo, matchFrom, __match, __patch, __last, __indexes]+matchSeveralOrRange = concatOptions [matchTo, matchFrom, __last, __indexes,                                          __matches, __patches, __tags]-match_several_or_last  = concat_options [match_from, __last, __matches, __patches, __tags]+matchSeveralOrLast  = concatOptions [matchFrom, __last, __matches, __patches, __tags] -match_to, match_from :: DarcsOption-match_to = DarcsMultipleChoiceOption+matchTo, matchFrom :: DarcsOption+matchTo = DarcsMultipleChoiceOption             [DarcsArgOption [] ["to-match"] uptop "PATTERN"              "select changes up to a patch matching PATTERN",              DarcsArgOption [] ["to-patch"] UpToPatch "REGEXP"@@ -643,7 +662,7 @@              DarcsArgOption [] ["to-tag"] UpToTag "REGEXP"              "select changes up to a tag matching REGEXP"]     where uptop s = UpToPattern (patch_match s)-match_from = DarcsMultipleChoiceOption+matchFrom = DarcsMultipleChoiceOption               [DarcsArgOption [] ["from-match"] fromp "PATTERN"                "select changes starting with a patch matching PATTERN",                DarcsArgOption [] ["from-patch"] AfterPatch "REGEXP"@@ -673,7 +692,7 @@  __last = DarcsArgOption [] ["last"] lastn "NUMBER"          "select the last NUMBER patches"-    where lastn = LastN . number_string+    where lastn = LastN . numberString  __index = DarcsArgOption ['n'] ["index"] indexrange "N" "select one patch"     where indexrange s = if all isDigit s@@ -690,17 +709,17 @@                          else PatchIndexRange 0 0           isokay c = isDigit c || c == '-' -match_maxcount :: DarcsOption-match_maxcount = DarcsArgOption [] ["max-count"] mc "NUMBER"+matchMaxcount :: DarcsOption+matchMaxcount = DarcsArgOption [] ["max-count"] mc "NUMBER"          "return only NUMBER results"-    where mc = MaxCount . number_string+    where mc = MaxCount . numberString  --- | 'get_context' takes a list of flags and returns the context+-- | '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@-get_context :: [DarcsFlag] -> Maybe AbsolutePath-get_context xs = listToMaybe [ c | Context c <- xs ]+getContext :: [DarcsFlag] -> Maybe AbsolutePath+getContext xs = listToMaybe [ c | Context c <- xs ]  notest = DarcsMultipleChoiceOption          [DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script",@@ -708,7 +727,7 @@ test = DarcsMultipleChoiceOption           [DarcsNoArgOption [] ["test"] Test "run the test script",            DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script"]-leave_test_dir = DarcsMultipleChoiceOption+leaveTestDir = DarcsMultipleChoiceOption                  [DarcsNoArgOption [] ["leave-test-directory"]                   LeaveTestDir "don't remove the test directory",                   DarcsNoArgOption [] ["remove-test-directory"]@@ -719,7 +738,7 @@ \end{code}  \begin{options}---ignore-times+--ignore-times, --no-ignore-times \end{options} Darcs optimizes its operations by keeping track of the modification times of your files.  This dramatically speeds up commands such as@@ -732,16 +751,22 @@ \verb!--ignore-times! option, which instructs darcs not to trust the file modification times, but instead to check each file's contents explicitly. \begin{code}-ignoretimes = DarcsNoArgOption [] ["ignore-times"] IgnoreTimes-              "don't trust the file modification times"+ignoretimes = +    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["ignore-times"] IgnoreTimes+                         "don't trust the file modification times"+    ,DarcsNoArgOption [] ["no-ignore-times"] DontIgnoreTimes+                      "trust modification times to find modified files [DEFAULT]"+    ]+ lookforadds =     DarcsMultipleChoiceOption     [DarcsNoArgOption ['l'] ["look-for-adds"] LookForAdds      "look for (non-boring) files that could be added",-     DarcsNoArgOption [] ["dont-look-for-adds"] NoLookForAdds+     DarcsNoArgOption [] ["dont-look-for-adds","no-look-for-adds"] NoLookForAdds      "don't look for any files that could be added [DEFAULT]"] -fancy_move_add =+fancyMoveAdd =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["date-trick"] FancyMoveAdd      "add files with date appended to avoid conflict [EXPERIMENTAL] ",@@ -755,7 +780,7 @@      DarcsNoArgOption [] ["no-ask-deps"] NoAskDeps      "don't ask for extra dependencies"] -ask_long_comment =+askLongComment =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["edit-long-comment"] EditLongComment      "edit the long comment by default",@@ -768,45 +793,45 @@ \begin{options} --author \end{options}-\label{env:DARCS_EMAIL}-Several commands need to be able to identify you.  Conventionally, you-provide an email address for this purpose, which can include comments,-e.g.\ \verb!David Roundy <droundy@abridgegame.org>!.  The easiest way to do-this is-to define an environment variable \verb!EMAIL! or \verb!DARCS_EMAIL! (with-the latter overriding the former).  You can also override this using the-\verb!--author! flag to any command.  Alternatively, you could set your-email address on a per-repository basis using the ``defaults'' mechanism-for ``ALL'' commands, as described in Appendix~\ref{repository_format}.-Or, you could specify the author on a per-repository basis using the-\verb!_darcs/prefs/author! file as described in section~\ref{author_prefs}.--Also, a global author file can be created in your home directory with the name-\verb!.darcs/author!, on MS Windows~\ref{ms_win}.  This file overrides the-contents of the environment variables, but a repository-specific author-file overrides the global author file.+\darcsEnv{DARCS_EMAIL}  \begin{code} logfile = DarcsAbsPathOption [] ["logfile"] LogFile "FILE"           "give patch name and comment in file" -rmlogfile = DarcsNoArgOption [] ["delete-logfile"] RmLogFile-            "delete the logfile when done"+rmlogfile = DarcsMultipleChoiceOption+            [DarcsNoArgOption [] ["delete-logfile"] RmLogFile+            "delete the logfile when done",+             DarcsNoArgOption [] ["no-delete-logfile"] DontRmLogFile+            "keep the logfile when done [DEFAULT]"]  author = DarcsArgOption ['A'] ["author"] Author "EMAIL" "specify author id"-from_opt = DarcsArgOption [] ["from"] Author "EMAIL" "specify email address"+fromOpt = DarcsArgOption [] ["from"] Author "EMAIL" "specify email address" --- | 'get_author' takes a list of flags and returns the author of the+fileHelpAuthor :: [String]+fileHelpAuthor = [+ "Each patch is attributed to its author, usually by email address (for",+ "example, `Fred Bloggs <fred@example.net>').  Darcs looks in several",+ "places for this author string: the --author option, the files",+ "_darcs/prefs/author (in the repository) and ~/.darcs/author (in your",+ "home directory), and the environment variables $DARCS_EMAIL and",+ "$EMAIL.  If none of those exist, Darcs will prompt you for an author",+ "string and write it to _darcs/prefs/author."]++environmentHelpEmail :: ([String], [String])+environmentHelpEmail = (["DARCS_EMAIL","EMAIL"], fileHelpAuthor)++-- | 'getAuthor' takes a list of flags and returns the author of the -- change specified by @Author \"Leo Tolstoy\"@ in that list of flags, if any. -- Otherwise, if @Pipe@ is present, asks the user who is the author and -- returns the answer. If neither are present, try to guess the author, -- from @_darcs/prefs@, and if it's not possible, ask the user.-get_author :: [DarcsFlag] -> IO String-get_author (Author a:_) = return a-get_author (Pipe:_) = do askUser "Who is the author? "-get_author (_:flags) = get_author flags-get_author [] = do-  easy_author <- get_easy_author+getAuthor :: [DarcsFlag] -> IO String+getAuthor (Author a:_) = return a+getAuthor (Pipe:_) = do askUser "Who is the author? "+getAuthor (_:flags) = getAuthor flags+getAuthor [] = do+  easy_author <- getEasyAuthor   case easy_author of     Just a -> return a     Nothing -> do@@ -822,16 +847,17 @@             text "If you move that file to ~/.darcs/author, it will be used for patches" $$             text "you record in ALL repositories."           add <- askUser "What is your email address? "-          writeFile (darcsdir++"/prefs/author") add+          writeFile (darcsdir ++ "/prefs/author") $+                    unlines ["# " ++ line | line <- fileHelpAuthor] ++ "\n" ++ add           return add         else askUser "What is your email address (e.g. Fred Bloggs <fred@example.net>)? " --- | 'get_easy_author' tries to get the author name first from the repository preferences,+-- | 'getEasyAuthor' tries to get the author name first from the repository preferences, -- then from global preferences, then from environment variables. Returns 'Nothing' if it -- could not get it.-get_easy_author :: IO (Maybe String)-get_easy_author = firstJustIO [ firstNotBlank `fmap` get_preflist "author",-                                firstNotBlank `fmap` get_global "author",+getEasyAuthor :: IO (Maybe String)+getEasyAuthor = firstJustIO [ firstNotBlank `fmap` getPreflist "author",+                                firstNotBlank `fmap` getGlobal "author",                                 maybeGetEnv "DARCS_EMAIL",                                 maybeGetEnv "EMAIL" ] \end{code}@@ -845,13 +871,13 @@ file.  \begin{code}-nocompress = concat_options [__compress, __dont_compress]-uncompress_nocompress = concat_options [__compress, __dont_compress, __uncompress]+nocompress = concatOptions [__compress, __dontCompress]+uncompressNocompress = concatOptions [__compress, __dontCompress, __uncompress] -__compress, __dont_compress, __uncompress :: DarcsOption+__compress, __dontCompress, __uncompress :: DarcsOption __compress = DarcsNoArgOption [] ["compress"] Compress             "create compressed patches"-__dont_compress = DarcsNoArgOption [] ["dont-compress"] NoCompress+__dontCompress = DarcsNoArgOption [] ["dont-compress","no-compress"] NoCompress                   "don't create compressed patches" __uncompress = DarcsNoArgOption [] ["uncompress"] UnCompress                "uncompress patches"@@ -859,24 +885,37 @@ summary = DarcsMultipleChoiceOption           [DarcsNoArgOption ['s'] ["summary"] Summary "summarize changes",            DarcsNoArgOption [] ["no-summary"] NoSummary "don't summarize changes"]-unified = DarcsNoArgOption ['u'] ["unified"] Unified-          "output patch in a darcs-specific format similar to diff -u"-unidiff = DarcsNoArgOption ['u'] ["unified"] Unified-          "pass -u option to diff"-diff_cmd_flag = DarcsArgOption [] ["diff-command"]+unified = DarcsMultipleChoiceOption+          [DarcsNoArgOption ['u'] ["unified"] Unified+          "output patch in a darcs-specific format similar to diff -u",+           DarcsNoArgOption  [] ["no-unified"] NonUnified+          "output patch in darcs' usual format"]++unidiff = DarcsMultipleChoiceOption+          [DarcsNoArgOption ['u'] ["unified"] Unified+          "pass -u option to diff",+           DarcsNoArgOption  [] ["no-unified"] NonUnified+          "output patch in diff's dumb format"]++diffCmdFlag = DarcsArgOption [] ["diff-command"]        DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)"-store_in_memory = DarcsNoArgOption [] ["store-in-memory"] StoreInMemory-          "do patch application in memory rather than on disk" +storeInMemory = DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["store-in-memory"] StoreInMemory+     "do patch application in memory rather than on disk",+     DarcsNoArgOption [] ["no-store-in-memory"] ApplyOnDisk+     "do patch application on disk [DEFAULT]"]+ target = DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email"-cc = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply"+ccSend = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s)"+ccApply = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply" --- |'get_cc' takes a list of flags and returns the addresses to send a copy of+-- |'getCc' takes a list of flags and returns the addresses to send a copy of -- the patch bundle to when using @darcs send@. -- looks for a cc address specified by @Cc \"address\"@ in that list of flags. -- Returns the addresses as a comma separated string.-get_cc :: [DarcsFlag] -> String-get_cc fs = lt $ catMaybes $ map whatcc fs+getCc :: [DarcsFlag] -> String+getCc fs = lt $ catMaybes $ map whatcc fs             where whatcc (Cc t) = Just t                   whatcc _ = Nothing                   lt [t] = t@@ -886,44 +925,44 @@  subject = DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject" --- |'get_subject' takes a list of flags and returns the subject of the mail+-- |'getSubject' takes a list of flags and returns the subject of the mail -- to be sent by @darcs send@. Looks for a subject specified by -- @Subject \"subject\"@ in that list of flags, if any. -- This flag is present if darcs was invoked with @--subject=SUBJECT@-get_subject :: [DarcsFlag] -> Maybe String-get_subject (Subject s:_) = Just s-get_subject (_:fs) = get_subject fs-get_subject [] = Nothing+getSubject :: [DarcsFlag] -> Maybe String+getSubject (Subject s:_) = Just s+getSubject (_:fs) = getSubject fs+getSubject [] = Nothing -in_reply_to = DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header"-get_in_reply_to :: [DarcsFlag] -> Maybe String-get_in_reply_to (InReplyTo s:_) = Just s-get_in_reply_to (_:fs) = get_in_reply_to fs-get_in_reply_to [] = Nothing+inReplyTo = DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header"+getInReplyTo :: [DarcsFlag] -> Maybe String+getInReplyTo (InReplyTo s:_) = Just s+getInReplyTo (_:fs) = getInReplyTo fs+getInReplyTo [] = Nothing  output = DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE"          "specify output filename" -output_auto_name = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY"+outputAutoName = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY"                    "output to automatically named file in DIRECTORY, default: current directory" -edit_description =+editDescription =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["edit-description"] EditDescription                           "edit the patch bundle description",-     DarcsNoArgOption [] ["dont-edit-description"] NoEditDescription+     DarcsNoArgOption [] ["dont-edit-description","no-edit-description"] NoEditDescription                       "don't edit the patch bundle description"] -distname_option = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME"+distnameOption = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME"                   "name of version"  recursive h     = DarcsMultipleChoiceOption       [DarcsNoArgOption ['r'] ["recursive"] Recursive h,-       DarcsNoArgOption [] ["not-recursive"] NoRecursive ("don't "++h)]+       DarcsNoArgOption [] ["not-recursive","no-recursive"] NoRecursive ("don't "++h)] -inventory_choices :: DarcsOption-inventory_choices =+inventoryChoices :: DarcsOption+inventoryChoices =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["hashed"] UseHashedInventory                           "Some new features. Compatible with older repos",@@ -932,14 +971,19 @@      DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory                           "Minimal features. What older repos use."] -get_inventory_choices :: DarcsOption-get_inventory_choices =+getInventoryChoices :: DarcsOption+getInventoryChoices =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["hashed"] UseHashedInventory                           "Convert darcs-1 format to hashed format",      DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory                           "Convert from hashed to darcs-1 format"] +upgradeFormat :: DarcsOption+upgradeFormat =+    DarcsNoArgOption [] ["upgrade"] UpgradeFormat+         "upgrade repository to latest compatible format"+ xmloutput = DarcsNoArgOption [] ["xml-output"] XMLOutput         "generate XML formatted output" @@ -953,16 +997,21 @@         "sign the patch with a given keyid",         DarcsArgOption [] ["sign-ssl"] SignSSL "IDFILE"         "sign the patch using openssl with a given private key",-        DarcsNoArgOption [] ["dont-sign"] NoSign+        DarcsNoArgOption [] ["dont-sign","no-sign"] NoSign         "don't sign the patch"] applyas = DarcsMultipleChoiceOption            [DarcsArgOption [] ["apply-as"] ApplyAs "USERNAME"             "apply patch as another user using sudo",-            DarcsNoArgOption [] ["apply-as-myself"] NonApply+            DarcsNoArgOption [] ["no-apply-as"] NonApply             "don't use sudo to apply as another user [DEFAULT]"]-happy_forwarding = DarcsNoArgOption [] ["happy-forwarding"] HappyForwarding-                   "forward unsigned messages without extra header"-set_default = DarcsMultipleChoiceOption++happyForwarding = DarcsMultipleChoiceOption+                   [DarcsNoArgOption [] ["happy-forwarding"] HappyForwarding+                   "forward unsigned messages without extra header",+                    DarcsNoArgOption [] ["no-happy-forwarding"] NoHappyForwarding+                   "don't forward unsigned messages without extra header [DEFAULT]"]++setDefault = DarcsMultipleChoiceOption               [DarcsNoArgOption [] ["set-default"] SetDefault                "set default repository [DEFAULT]",                DarcsNoArgOption [] ["no-set-default"] NoSetDefault@@ -979,22 +1028,18 @@ reponame = DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY"            "path of output directory" --repodir is there for compatibility                                       --should be removed eventually-tagname = DarcsArgOption ['t'] ["tag"] TagName "TAGNAME"-          "name of version to checkpoint"-deps_sel = DarcsMultipleChoiceOption+depsSel = DarcsMultipleChoiceOption        [DarcsNoArgOption [] ["no-deps"] DontGrabDeps         "don't automatically fulfill dependencies",         DarcsNoArgOption [] ["dont-prompt-for-dependencies"] DontPromptForDependencies         "don't ask about patches that are depended on by matched patches (with --match or --patch)",         DarcsNoArgOption [] ["prompt-for-dependencies"] PromptForDependencies         "prompt about patches that are depended on by matched patches [DEFAULT]"]-checkpoint = DarcsNoArgOption [] ["checkpoint"] CheckPoint-             "create a checkpoint file (see get --partial)" tokens = DarcsArgOption [] ["token-chars"] Toks "\"[CHARS]\""          "define token to contain these characters" -partial       = concat_options [__partial, __lazy, __ephemeral, __complete]-partial_check = concat_options [__complete, __partial]+partial       = concatOptions [__partial, __lazy, __ephemeral, __complete]+partialCheck = concatOptions [__complete, __partial]  __partial, __lazy, __ephemeral, __complete :: DarcsOption __partial = DarcsNoArgOption [] ["partial"] Partial@@ -1006,14 +1051,14 @@ __complete = DarcsNoArgOption [] ["complete"] Complete              "get a complete copy of the repository" -force_replace = DarcsMultipleChoiceOption+forceReplace = DarcsMultipleChoiceOption                 [DarcsNoArgOption ['f'] ["force"] ForceReplace                  "proceed with replace even if 'new' token already exists",                  DarcsNoArgOption [] ["no-force"]                  NonForce "don't force the replace if it looks scary"]  reply = DarcsArgOption [] ["reply"] Reply "FROM" "reply to email-based patch using FROM address"-apply_conflict_options+applyConflictOptions     = DarcsMultipleChoiceOption       [DarcsNoArgOption [] ["mark-conflicts"]        MarkConflicts "mark conflicts",@@ -1021,17 +1066,23 @@        AllowConflicts "allow conflicts, but don't mark them",        DarcsNoArgOption [] ["no-resolve-conflicts"] NoAllowConflicts        "equivalent to --dont-allow-conflicts, for backwards compatibility",-       DarcsNoArgOption [] ["dont-allow-conflicts"]-       NoAllowConflicts "fail on patches that create conflicts [DEFAULT]"]-pull_conflict_options+       DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"]+       NoAllowConflicts "fail if there are patches that would create conflicts [DEFAULT]",+       DarcsNoArgOption [] ["skip-conflicts"]+       SkipConflicts "filter out any patches that would create conflicts"+      ]+pullConflictOptions     = DarcsMultipleChoiceOption       [DarcsNoArgOption [] ["mark-conflicts"]        MarkConflicts "mark conflicts [DEFAULT]",        DarcsNoArgOption [] ["allow-conflicts"]        AllowConflicts "allow conflicts, but don't mark them",-       DarcsNoArgOption [] ["dont-allow-conflicts"]-       NoAllowConflicts "fail on patches that create conflicts"]-use_external_merge = DarcsArgOption [] ["external-merge"]+       DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"]+       NoAllowConflicts "fail if there patches that would create conflicts",+       DarcsNoArgOption [] ["skip-conflicts"]+       SkipConflicts "filter out any patches that would create conflicts"+      ]+useExternalMerge = DarcsArgOption [] ["external-merge"]                      ExternalMerge "COMMAND" "use external tool to merge conflicts" \end{code} @@ -1079,15 +1130,15 @@ An exclamation mark appears next to any option that has a conflict.  \begin{code}--- NOTE: I'd rather work to have no uses of dry_run_noxml, so that any time+-- NOTE: I'd rather work to have no uses of dryRunNoxml, so that any time -- --dry-run is a possibility, automated users can examine the results more -- easily with --xml.-dry_run_noxml :: DarcsOption-dry_run_noxml = DarcsNoArgOption [] ["dry-run"] DryRun+dryRunNoxml :: DarcsOption+dryRunNoxml = DarcsNoArgOption [] ["dry-run"] DryRun                 "don't actually take the action" -dry_run :: [DarcsOption]-dry_run = [dry_run_noxml, xmloutput]+dryRun :: [DarcsOption]+dryRun = [dryRunNoxml, xmloutput]  -- | @'showFriendly' flags patch@ returns a 'Doc' representing the right -- way to show @patch@ given the list @flags@ of flags darcs was invoked with.@@ -1096,14 +1147,14 @@                     | Summary `elem` opts = Darcs.Patch.summary p                     | otherwise           = description p --- | @'print_dry_run_message_and_exit' action opts patches@ prints a string+-- | @'printDryRunMessageAndExit' action opts patches@ prints a string -- representing the action that would be taken if the @--dry-run@ option -- had not been passed to darcs. Then darcs exits successfully. -- @action@ is the name of the action being taken, like @\"push\"@ -- @opts@ is the list of flags which were sent to darcs -- @patches@ is the sequence of patches which would be touched by @action@.-print_dry_run_message_and_exit :: RepoPatch p => String -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO ()-print_dry_run_message_and_exit action opts patches =+printDryRunMessageAndExit :: RepoPatch p => String -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO ()+printDryRunMessageAndExit action opts patches =      do when (DryRun `elem` opts) $ do           putInfo $ text $ "Would " ++ action ++ " the following changes:"           putDocLn $ put_mode@@ -1125,7 +1176,7 @@                         xml_with_summary hp                | Just p <- hopefullyM hp = insert_before_lastline-                                            (to_xml $ info hp) (indent $ xml_summary p)+                                            (to_xml $ info hp) (indent $ xmlSummary p)            xml_with_summary hp = to_xml (info hp)            indent = prefix "    " @@ -1135,33 +1186,48 @@ \input{Darcs/Resolution.lhs}  \begin{code}-noskip_boring = DarcsNoArgOption [] ["boring"]-                Boring "don't skip boring files"-allow_problematic_filenames = DarcsMultipleChoiceOption+noskipBoring = DarcsMultipleChoiceOption+                [DarcsNoArgOption [] ["boring"]+                 Boring "don't skip boring files",+                 DarcsNoArgOption [] ["no-boring"]+                 SkipBoring "skip borign files [DEFAULT]"]++allowProblematicFilenames = DarcsMultipleChoiceOption                 [DarcsNoArgOption [] ["case-ok"] AllowCaseOnly                  "don't refuse to add files differing only in case"+                ,DarcsNoArgOption [] ["no-case-ok"] DontAllowCaseOnly+                 "refuse to add files whose name differ only in case [DEFAULT]"                 ,DarcsNoArgOption [] ["reserved-ok"] AllowWindowsReserved                  "don't refuse to add files with Windows-reserved names"-                ]+                ,DarcsNoArgOption [] ["no-reserved-ok"] DontAllowWindowsReserved+                 "refuse to add files with Windows-reserved names [DEFAULT]"]+ diffflags = DarcsArgOption [] ["diff-opts"]             DiffFlags "OPTIONS" "options to pass to diff" -changes_format = DarcsMultipleChoiceOption+changesFormat = DarcsMultipleChoiceOption                  [DarcsNoArgOption [] ["context"]                   (Context rootDirectory) "give output suitable for get --context",                   xmloutput,-                  human_readable,+                  humanReadable,                   DarcsNoArgOption [] ["number"] NumberPatches "number the changes",                   DarcsNoArgOption [] ["count"] Count "output count of changes"                  ]-changes_reverse = DarcsNoArgOption [] ["reverse"] Reverse-                  "show changes in reverse order"+changesReverse = DarcsMultipleChoiceOption+                  [DarcsNoArgOption [] ["reverse"] Reverse+                   "show changes in reverse order"+                  ,DarcsNoArgOption [] ["no-reverse"] Forward+                   "show changes in the usual order [DEFAULT]"] -only_to_files :: DarcsOption-only_to_files = DarcsNoArgOption [] ["only-to-files"] OnlyChangesToFiles-                "show only changes to specified files"+onlyToFiles :: DarcsOption+onlyToFiles = DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["only-to-files"] OnlyChangesToFiles+     "show only changes to specified files",+     DarcsNoArgOption [] ["no-only-to-files"] ChangesToAllFiles+     "show changes to all files [DEFAULT]"] -human_readable = DarcsNoArgOption [] ["human-readable"]++humanReadable = DarcsNoArgOption [] ["human-readable"]                  HumanReadable "give human-readable output" pipe = DarcsNoArgOption [] ["pipe"] Pipe "ask user interactively for the patch metadata" @@ -1170,15 +1236,15 @@                          "prompt user interactively" all_patches = DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches" -all_interactive = DarcsMultipleChoiceOption [all_patches, interactive]+allInteractive = DarcsMultipleChoiceOption [all_patches, interactive] -all_pipe_interactive+allPipeInteractive     = DarcsMultipleChoiceOption [all_patches,pipe,interactive] -pipe_interactive =+pipeInteractive =     DarcsMultipleChoiceOption [pipe, interactive] -repo_combinator =+repoCombinator =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["intersection"] Intersection      "take intersection of all repositories",@@ -1187,80 +1253,76 @@      DarcsNoArgOption [] ["complement"] Complement      "take complement of repositories (in order listed)"] --- | 'list_files' returns the list of all non-boring files in the repository-list_files :: IO [String]-list_files = do s <- slurp_all_but_darcs "."-                skip_boring <- boring_file_filter-                return (map drop_dotslash $ skip_boring $ list_slurpy s)--drop_dotslash :: String -> String-drop_dotslash ('.':'/':x) = drop_dotslash x-drop_dotslash x = x+-- | Get a list of all non-boring files and directories in the working copy.+listFiles :: IO [String]+listFiles =  do nonboring <- restrictBoring emptyTree+                working <- expand =<< nonboring <$> readPlainTree "."+                return $ map (anchorPath "" . fst) $ list working --- | 'list_unregistered_files' returns the list of all non-boring unregistered+-- | 'listUnregisteredFiles' returns the list of all non-boring unregistered -- files in the repository.-list_unregistered_files :: IO [String]-list_unregistered_files = withRepository [] $- \repository ->-    do s <- slurp_all_but_darcs "."-       skip_boring <- boring_file_filter-       regs <- slurp_pending repository-       return $ map drop_dotslash $ (skip_boring $ list_slurpy s) \\ (list_slurpy regs)+listUnregisteredFiles :: IO [String]+listUnregisteredFiles =+    do unregd <- listFiles+       regd <- listRegisteredFiles+       return $ unregd \\ regd -- (inefficient) --- | 'list_registered_files' returns the list of all registered files in the repository.-list_registered_files :: IO [String]-list_registered_files =-    (map drop_dotslash . list_slurpy) `fmap` (withRepository [] slurp_pending)+-- | 'listRegisteredFiles' returns the list of all registered files in the repository.+listRegisteredFiles :: IO [String]+listRegisteredFiles =+    do recorded <- expand =<< withRepository [] readRecordedAndPending+       return $ map (anchorPath "" . fst) $ list recorded -options_latex :: [DarcsOption] -> String-options_latex opts = "\\begin{tabular}{lll}\n"++-                     unlines (map option_latex opts)+++optionsLatex :: [DarcsOption] -> String+optionsLatex opts = "\\begin{tabular}{lll}\n"+++                     unlines (map optionLatex opts)++                      "\\end{tabular}\n" -latex_help :: String -> String-latex_help h+latexHelp :: String -> String+latexHelp h     = "\\begin{minipage}{7cm}\n\\raggedright\n" ++ h ++ "\\end{minipage}\n" -option_latex :: DarcsOption -> String-option_latex (DarcsNoArgOption a b _ h) =-    show_short_options a ++ show_long_options b ++ latex_help h ++ "\\\\"-option_latex (DarcsArgOption a b _ arg h) =-    show_short_options a ++-    show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\"-option_latex (DarcsAbsPathOrStdOption a b _ arg h) =-    show_short_options a ++-    show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\"-option_latex (DarcsAbsPathOption a b _ arg h) =-    show_short_options a ++-    show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\"-option_latex (DarcsOptAbsPathOption a b _ _ arg h) =-    show_short_options a ++-    show_long_options (map (++("[="++arg++"]")) b) ++ latex_help h ++ "\\\\"-option_latex (DarcsMultipleChoiceOption os) =-    unlines (map option_latex os)+optionLatex :: DarcsOption -> String+optionLatex (DarcsNoArgOption a b _ h) =+    showShortOptions a ++ showLongOptions b ++ latexHelp h ++ "\\\\"+optionLatex (DarcsArgOption a b _ arg h) =+    showShortOptions a +++    showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"+optionLatex (DarcsAbsPathOrStdOption a b _ arg h) =+    showShortOptions a +++    showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"+optionLatex (DarcsAbsPathOption a b _ arg h) =+    showShortOptions a +++    showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"+optionLatex (DarcsOptAbsPathOption a b _ _ arg h) =+    showShortOptions a +++    showLongOptions (map (++("[="++arg++"]")) b) ++ latexHelp h ++ "\\\\"+optionLatex (DarcsMultipleChoiceOption os) =+    unlines (map optionLatex os) -show_short_options :: [Char] -> String-show_short_options [] = "&"-show_short_options [c] = "\\verb!-"++[c]++"! &"-show_short_options (c:cs) = "\\verb!-"++[c]++"!,"++show_short_options cs+showShortOptions :: [Char] -> String+showShortOptions [] = "&"+showShortOptions [c] = "\\verb!-"++[c]++"! &"+showShortOptions (c:cs) = "\\verb!-"++[c]++"!,"++showShortOptions cs -show_long_options :: [String] -> String-show_long_options [] = " &"-show_long_options [s] = "\\verb!--" ++ s ++ "! &"-show_long_options (s:ss)-    = "\\verb!--" ++ s ++ "!,"++ show_long_options ss+showLongOptions :: [String] -> String+showLongOptions [] = " &"+showLongOptions [s] = "\\verb!--" ++ s ++ "! &"+showLongOptions (s:ss)+    = "\\verb!--" ++ s ++ "!,"++ showLongOptions ss -set_scripts_executable :: DarcsOption-set_scripts_executable = DarcsMultipleChoiceOption+setScriptsExecutableOption :: DarcsOption+setScriptsExecutableOption = DarcsMultipleChoiceOption                               [DarcsNoArgOption [] ["set-scripts-executable"] SetScriptsExecutable                                "make scripts executable",-                               DarcsNoArgOption [] ["dont-set-scripts-executable"] DontSetScriptsExecutable+                               DarcsNoArgOption [] ["dont-set-scripts-executable","no-set-scripts-executable"] DontSetScriptsExecutable                                "don't make scripts executable"] -relink, relink_pristine, sibling :: DarcsOption+relink, relinkPristine, sibling :: DarcsOption relink = DarcsNoArgOption [] ["relink"] Relink          "relink random internal data to a sibling" -relink_pristine = DarcsNoArgOption [] ["relink-pristine"] RelinkPristine+relinkPristine = DarcsNoArgOption [] ["relink-pristine"] RelinkPristine                   "relink pristine tree (not recommended)"  sibling = DarcsAbsPathOption [] ["sibling"] Sibling "URL"@@ -1276,8 +1338,8 @@ nolinks = DarcsNoArgOption [] ["nolinks"] NoLinks           "do not link repository or pristine to sibling" -reorder_patches :: DarcsOption-reorder_patches = DarcsNoArgOption [] ["reorder-patches"] Reorder+reorderPatches :: DarcsOption+reorderPatches = DarcsNoArgOption [] ["reorder-patches"] Reorder                   "reorder the patches in the repository" \end{code} \begin{options}@@ -1286,7 +1348,7 @@ \darcsEnv{SENDMAIL}  \begin{code}-sendmail_cmd = DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command"+sendmailCmd = DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command"  environmentHelpSendmail :: ([String], [String]) environmentHelpSendmail = (["SENDMAIL"], [@@ -1303,15 +1365,15 @@ -- * on a multi-user system without an MTA and on which you haven't --   got root, can be msmtp. --- |'get_sendmail_cmd' takes a list of flags and returns the sendmail command+-- |'getSendmailCmd' takes a list of flags and returns the sendmail command -- to be used by @darcs send@. Looks for a command specified by -- @SendmailCmd \"command\"@ in that list of flags, if any. -- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@ -- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a fallback if present.-get_sendmail_cmd :: [DarcsFlag] -> IO String -get_sendmail_cmd (SendmailCmd a:_) = return a-get_sendmail_cmd (_:flags) = get_sendmail_cmd flags-get_sendmail_cmd [] = do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ]+getSendmailCmd :: [DarcsFlag] -> IO String +getSendmailCmd (SendmailCmd a:_) = return a+getSendmailCmd (_:flags) = getSendmailCmd flags+getSendmailCmd [] =   do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ]                          case easy_sendmail of                             Just a -> return a                             Nothing -> return ""@@ -1341,6 +1403,9 @@ nullFlag = DarcsNoArgOption ['0'] ["null"] NullFlag        "separate file names by NUL characters" \end{code}++\subsection{Posthooks}+ \begin{options} --posthook=COMMAND, --no-posthook \end{options}@@ -1382,7 +1447,7 @@                                                  vcat (mapFL (to_xml . info) ps) $$                                                  text "</patches>")                       finishedOneIO k "DARCS_FILES"-                      setEnvCautiously "DARCS_FILES" (unlines$ list_touched_files ps)+                      setEnvCautiously "DARCS_FILES" (unlines$ listTouchedFiles ps)                       endTedious k  setEnvCautiously :: String -> String -> IO ()@@ -1398,32 +1463,35 @@  defineChanges :: Patchy p => p C(x y) -> IO () #ifndef WIN32-defineChanges ps = setEnvCautiously "DARCS_FILES" (unlines $ list_touched_files ps)+defineChanges ps = setEnvCautiously "DARCS_FILES" (unlines $ listTouchedFiles ps) #else defineChanges _ = return () #endif -posthook_cmd :: DarcsOption-posthook_cmd = DarcsMultipleChoiceOption+posthookCmd :: DarcsOption+posthookCmd = DarcsMultipleChoiceOption                [DarcsArgOption [] ["posthook"] PosthookCmd                 "COMMAND" "specify command to run after this darcs command",                 DarcsNoArgOption [] ["no-posthook"] NoPosthook                 "don't run posthook command"] -posthook_prompt :: DarcsOption-posthook_prompt = DarcsMultipleChoiceOption+posthookPrompt :: DarcsOption+posthookPrompt = DarcsMultipleChoiceOption                   [DarcsNoArgOption [] ["prompt-posthook"] AskPosthook                    "prompt before running posthook [DEFAULT]",                    DarcsNoArgOption [] ["run-posthook"] RunPosthook                    "run posthook command without prompting"] --- | 'get_posthook_cmd' takes a list of flags and returns the posthook command+-- | 'getPosthookCmd' takes a list of flags and returns the posthook command --  specified by @PosthookCmd a@ in that list of flags, if any.-get_posthook_cmd :: [DarcsFlag] -> Maybe String-get_posthook_cmd (PosthookCmd a:_) = Just a-get_posthook_cmd (_:flags) = get_posthook_cmd flags-get_posthook_cmd [] = Nothing+getPosthookCmd :: [DarcsFlag] -> Maybe String+getPosthookCmd (PosthookCmd a:_) = Just a+getPosthookCmd (_:flags) = getPosthookCmd flags+getPosthookCmd [] = Nothing \end{code}++\subsection{Prehooks}+ \begin{options} --prehook=COMMAND, --no-prehook \end{options}@@ -1438,26 +1506,26 @@ These options control prompting before running the prehook.  See the posthook documentation above for details. \begin{code}-prehook_cmd :: DarcsOption-prehook_cmd = DarcsMultipleChoiceOption+prehookCmd :: DarcsOption+prehookCmd = DarcsMultipleChoiceOption                [DarcsArgOption [] ["prehook"] PrehookCmd                 "COMMAND" "specify command to run before this darcs command",                 DarcsNoArgOption [] ["no-prehook"] NoPrehook                 "don't run prehook command"] -prehook_prompt :: DarcsOption-prehook_prompt = DarcsMultipleChoiceOption+prehookPrompt :: DarcsOption+prehookPrompt = DarcsMultipleChoiceOption                   [DarcsNoArgOption [] ["prompt-prehook"] AskPrehook                    "prompt before running prehook [DEFAULT]",                    DarcsNoArgOption [] ["run-prehook"] RunPrehook                    "run prehook command without prompting"] --- | 'get_prehook_cmd' takes a list of flags and returns the prehook command+-- | 'getPrehookCmd' takes a list of flags and returns the prehook command --  specified by @PrehookCmd a@ in that list of flags, if any.-get_prehook_cmd :: [DarcsFlag] -> Maybe String-get_prehook_cmd (PrehookCmd a:_) = Just a-get_prehook_cmd (_:flags) = get_prehook_cmd flags-get_prehook_cmd [] = Nothing+getPrehookCmd :: [DarcsFlag] -> Maybe String+getPrehookCmd (PrehookCmd a:_) = Just a+getPrehookCmd (_:flags) = getPrehookCmd flags+getPrehookCmd [] = Nothing \end{code}  \begin{options}@@ -1486,8 +1554,8 @@  Do not use patch caches. \begin{code}-network_options :: [DarcsOption]-network_options =+networkOptions :: [DarcsOption]+networkOptions =     [DarcsMultipleChoiceOption      [DarcsNoArgOption [] ["ssh-cm"] SSHControlMaster                            "use SSH ControlMaster feature",@@ -1498,7 +1566,7 @@                            pipelining_description,       DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining                            no_pipelining_description],-      no_cache+      noCache, remote_darcs      ]     where pipelining_description =               "enable HTTP pipelining"++@@ -1507,9 +1575,17 @@               "disable HTTP pipelining"++               (if pipeliningEnabledByDefault then "" else " [DEFAULT]") -no_cache :: DarcsOption-no_cache = DarcsNoArgOption [] ["no-cache"] NoCache+remote_darcs :: DarcsOption+remote_darcs =  DarcsArgOption [] ["remote-darcs"] RemoteDarcs "COMMAND"+                "name of the darcs executable on the remote server"++noCache :: DarcsOption+noCache = DarcsNoArgOption [] ["no-cache"] NoCache                           "don't use patch caches"++optimizePristine :: DarcsOption+optimizePristine = DarcsNoArgOption [] ["pristine"] OptimizePristine+                          "optimize hashed pristine layout" \end{code} \begin{options} --umask@@ -1519,8 +1595,8 @@ writing to the repository.  \begin{code}-umask_option :: DarcsOption-umask_option =+umaskOption :: DarcsOption+umaskOption =     DarcsArgOption [] ["umask"] UMask "UMASK"         "specify umask to use when writing" \end{code}@@ -1545,11 +1621,11 @@ the command line, when pulling or applying unknown patches.  \begin{code}-restrict_paths =+restrictPaths =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["restrict-paths"] RestrictPaths      "don't allow darcs to touch external files or repo metadata",-     DarcsNoArgOption [] ["dont-restrict-paths"] DontRestrictPaths+     DarcsNoArgOption [] ["dont-restrict-paths","no-restrict-paths"] DontRestrictPaths      "allow darcs to modify any file or directory (unsafe)"] \end{code} @@ -1560,13 +1636,13 @@ doing pull, push and send. This option makes darcs skip this check.  \begin{code}-allow_unrelated_repos =+allowUnrelatedRepos =     DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos                          "do not check if repositories are unrelated" \end{code}  \begin{code}-just_this_repo :: DarcsOption+justThisRepo :: DarcsOption \end{code}  \begin{options}@@ -1576,13 +1652,13 @@ omits any caches or other repos listed as a source of patches.  \begin{code}-just_this_repo =+justThisRepo =     DarcsNoArgOption [] ["just-this-repo"] JustThisRepo                         "Limit the check or repair to the current repo" \end{code}  \begin{code}-check, repair, check_or_repair :: DarcsOption+check, repair, checkOrRepair :: DarcsOption \end{code}  \begin{options}@@ -1606,30 +1682,31 @@     DarcsNoArgOption [] ["repair"] Repair                         "Specify repair mode" -check_or_repair = concat_options [check, repair]+checkOrRepair = concatOptions [check, repair] --- | @'patch_select_flag' f@ holds whenever @f@ is a way of selecting+-- | @'patchSelectFlag' f@ holds whenever @f@ is a way of selecting -- patches such as @PatchName n@.-patch_select_flag :: DarcsFlag -> Bool-patch_select_flag All = True-patch_select_flag (PatchName _) = True-patch_select_flag (OnePatch _) = True-patch_select_flag (SeveralPatch _) = True-patch_select_flag (AfterPatch _) = True-patch_select_flag (UpToPatch _) = True-patch_select_flag (TagName _) = True-patch_select_flag (LastN _) = True-patch_select_flag (OneTag _) = True-patch_select_flag (AfterTag _) = True-patch_select_flag (UpToTag _) = True-patch_select_flag (OnePattern _) = True-patch_select_flag (SeveralPattern _) = True-patch_select_flag (AfterPattern _) = True-patch_select_flag (UpToPattern _) = True-patch_select_flag _ = False+patchSelectFlag :: DarcsFlag -> Bool+patchSelectFlag All = True+patchSelectFlag (PatchName _) = True+patchSelectFlag (OnePatch _) = True+patchSelectFlag (SeveralPatch _) = True+patchSelectFlag (AfterPatch _) = True+patchSelectFlag (UpToPatch _) = True+patchSelectFlag (TagName _) = True+patchSelectFlag (LastN _) = True+patchSelectFlag (OneTag _) = True+patchSelectFlag (AfterTag _) = True+patchSelectFlag (UpToTag _) = True+patchSelectFlag (OnePattern _) = True+patchSelectFlag (SeveralPattern _) = True+patchSelectFlag (AfterPattern _) = True+patchSelectFlag (UpToPattern _) = True+patchSelectFlag _ = False  -- | The integer corresponding to a string, if it's only composed of digits. --   Otherwise, -1.-number_string :: String -> Int-number_string s = if and (map isDigit s) then read s else (-1)+numberString :: String -> Int+numberString "" = -1+numberString s = if all isDigit s then read s else (-1) \end{code}
src/Darcs/Commands.lhs view
@@ -16,39 +16,40 @@ %  Boston, MA 02110-1301, USA.  \begin{code}-module Darcs.Commands ( CommandControl( Command_data, Hidden_command, Group_name ),-                       DarcsCommand( DarcsCommand, command_name,-                                     command_help, command_description,-                                     command_basic_options, command_advanced_options,-                                     command_command,-                                     command_prereq,-                                     command_extra_arg_help,-                                     command_extra_args,-                                     command_argdefaults,-                                     command_get_arg_possibilities,+module Darcs.Commands ( CommandControl( CommandData, HiddenCommand, GroupName ),+                       DarcsCommand( DarcsCommand, commandName,+                                     commandHelp, commandDescription,+                                     commandBasicOptions, commandAdvancedOptions,+                                     commandCommand,+                                     commandPrereq,+                                     commandExtraArgHelp,+                                     commandExtraArgs,+                                     commandArgdefaults,+                                     commandGetArgPossibilities,                                      SuperCommand,-                                     command_sub_commands ),-                       command_alias, command_stub,-                       command_options, command_alloptions,-                       disambiguate_commands, CommandArgs(..),-                       get_command_help, get_command_mini_help,-                       get_subcommands,-                       usage, subusage, chomp_newline,-                       extract_commands,-                       super_name,+                                     commandSubCommands ),+                       commandAlias, commandStub,+                       commandOptions, commandAlloptions,+                       disambiguateCommands, CommandArgs(..),+                       getCommandHelp, getCommandMiniHelp,+                       getSubcommands,+                       usage, subusage, chompNewline,+                       extractCommands,+                       superName,                        nodefaults,-                       loggers,+                       putInfo, putVerbose, putWarning, abortRun                      ) where  import System.Console.GetOpt( OptDescr, usageInfo )+import Control.Monad (when, unless)  import Data.List ( sort, isPrefixOf )-import Darcs.Arguments ( DarcsFlag, DarcsOption, disable, help,-                         any_verbosity, posthook_cmd, posthook_prompt,-                         prehook_cmd, prehook_prompt, option_from_darcsoption )+import Darcs.Arguments ( DarcsFlag(Quiet,Verbose, DryRun), DarcsOption, disable, help,+                         anyVerbosity, posthookCmd, posthookPrompt,+                         prehookCmd, prehookPrompt, optionFromDarcsoption ) import Darcs.RepoPath ( AbsolutePath, rootDirectory )-import Darcs.Utils ( putStrLnError )-import Printer ( Doc, putDocLn )+import Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc )+import System.IO ( stderr ) \end{code}  The general format of a darcs command is@@ -114,78 +115,78 @@ \end{center}  \begin{code}-extract_commands, extract_hidden_commands :: [CommandControl] -> [DarcsCommand]-extract_commands cs = concatMap (\x -> case x of { Command_data cmd_d -> [cmd_d]; _ -> []}) cs-extract_hidden_commands cs = concatMap (\x -> case x of { Hidden_command cmd_d -> [cmd_d]; _ -> []}) cs+extractCommands, extractHiddenCommands :: [CommandControl] -> [DarcsCommand]+extractCommands cs = concatMap (\x -> case x of { CommandData cmd_d -> [cmd_d]; _ -> []}) cs+extractHiddenCommands cs = concatMap (\x -> case x of { HiddenCommand cmd_d -> [cmd_d]; _ -> []}) cs \end{code}  \input{Darcs/Arguments.lhs}  \begin{code}-data CommandControl = Command_data DarcsCommand-                    | Hidden_command DarcsCommand-                    | Group_name String+data CommandControl = CommandData DarcsCommand+                    | HiddenCommand DarcsCommand+                    | GroupName String  data DarcsCommand =-    DarcsCommand {command_name, command_help, command_description :: String,-                  command_extra_args :: Int,-                  command_extra_arg_help :: [String],-                  command_command :: [DarcsFlag] -> [String] -> IO (),-                  command_prereq :: [DarcsFlag] -> IO (Either String ()),-                  command_get_arg_possibilities :: IO [String],-                  command_argdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String],-                  command_basic_options :: [DarcsOption],-                  command_advanced_options :: [DarcsOption]}-  | SuperCommand {command_name, command_help, command_description :: String,-                  command_prereq :: [DarcsFlag] -> IO (Either String ()),-                  command_sub_commands :: [CommandControl]}+    DarcsCommand {commandName, commandHelp, commandDescription :: String,+                  commandExtraArgs :: Int,+                  commandExtraArgHelp :: [String],+                  commandCommand :: [DarcsFlag] -> [String] -> IO (),+                  commandPrereq :: [DarcsFlag] -> IO (Either String ()),+                  commandGetArgPossibilities :: IO [String],+                  commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String],+                  commandBasicOptions :: [DarcsOption],+                  commandAdvancedOptions :: [DarcsOption]}+  | SuperCommand {commandName, commandHelp, commandDescription :: String,+                  commandPrereq :: [DarcsFlag] -> IO (Either String ()),+                  commandSubCommands :: [CommandControl]} -command_alloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption])-command_alloptions DarcsCommand { command_basic_options = opts1-                                , command_advanced_options = opts2 }+commandAlloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption])+commandAlloptions DarcsCommand { commandBasicOptions = opts1+                                , commandAdvancedOptions = opts2 }     = (opts1 ++ [disable, help],-       any_verbosity ++ opts2 ++-                [posthook_cmd, posthook_prompt-                ,prehook_cmd, prehook_prompt])+       anyVerbosity ++ opts2 +++                [posthookCmd, posthookPrompt+                ,prehookCmd, prehookPrompt])  --  Supercommands cannot be disabled.-command_alloptions SuperCommand { } = ([help],[])+commandAlloptions SuperCommand { } = ([help],[])  --  Obtain options suitable as input to --  System.Console.Getopt, including the --disable option (which is --  not listed explicitly in the DarcsCommand definitions).-command_options :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag])-command_options cwd c = (convert basic, convert advanced)- where (basic, advanced) = command_alloptions c-       convert = concatMap (option_from_darcsoption cwd)+commandOptions :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag])+commandOptions cwd c = (convert basic, convert advanced)+ where (basic, advanced) = commandAlloptions c+       convert = concatMap (optionFromDarcsoption cwd)  nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] nodefaults _ _ xs = return xs -get_subcommands :: DarcsCommand -> [CommandControl]-get_subcommands c@(SuperCommand {}) = command_sub_commands c-get_subcommands _ = []+getSubcommands :: DarcsCommand -> [CommandControl]+getSubcommands c@(SuperCommand {}) = commandSubCommands c+getSubcommands _ = [] -command_alias :: String -> DarcsCommand -> DarcsCommand-command_alias n c =-  c { command_name = n-    , command_description = "Alias for `darcs " ++ command_name c ++ "'."-    , command_help = "The `darcs " ++ n ++ "' command is an alias for " ++-                     "`darcs " ++ command_name c ++ "'.\n" ++-                     command_help c+commandAlias :: String -> DarcsCommand -> DarcsCommand+commandAlias n c =+  c { commandName = n+    , commandDescription = "Alias for `darcs " ++ commandName c ++ "'."+    , commandHelp = "The `darcs " ++ n ++ "' command is an alias for " +++                     "`darcs " ++ commandName c ++ "'.\n" +++                     commandHelp c     } -command_stub :: String -> String -> String -> DarcsCommand -> DarcsCommand-command_stub n h d c =-  c { command_name = n-    , command_help = h-    , command_description = d-    , command_command = \_ _ -> putStr h+commandStub :: String -> String -> String -> DarcsCommand -> DarcsCommand+commandStub n h d c =+  c { commandName = n+    , commandHelp = h+    , commandDescription = d+    , commandCommand = \_ _ -> putStr h     }  usage :: [CommandControl] -> String usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++-           usage_helper cs ++ "\n" +++           usageHelper cs ++ "\n" ++            "Use 'darcs COMMAND --help' for help on a single command.\n" ++            "Use 'darcs --version' to see the darcs version number.\n" ++            "Use 'darcs --exact-version' to get the exact version of this darcs instance.\n" ++@@ -197,67 +198,67 @@ subusage :: DarcsCommand -> String subusage super =     (usageInfo-     ("Usage: darcs "++command_name super++" SUBCOMMAND ... " ++-      "\n\n"++ command_description super++-      "\n\nSubcommands:\n" ++ usage_helper (get_subcommands super) ++ "\nOptions:")-     (option_from_darcsoption rootDirectory help))-    ++ "\n" ++ command_help super+     ("Usage: darcs "++commandName super++" SUBCOMMAND ... " +++      "\n\n"++ commandDescription super+++      "\n\nSubcommands:\n" ++ usageHelper (getSubcommands super) ++ "\nOptions:")+     (optionFromDarcsoption rootDirectory help))+    ++ "\n" ++ commandHelp super -usage_helper :: [CommandControl] -> String-usage_helper [] = ""-usage_helper (Hidden_command _:cs) = usage_helper cs-usage_helper ((Command_data c):cs) = "  "++pad_spaces (command_name c) 15 ++-                      chomp_newline (command_description c)++"\n"++usage_helper cs-usage_helper ((Group_name n):cs) = "\n" ++ n ++ "\n" ++ usage_helper cs+usageHelper :: [CommandControl] -> String+usageHelper [] = ""+usageHelper (HiddenCommand _:cs) = usageHelper cs+usageHelper ((CommandData c):cs) = "  "++padSpaces (commandName c) 15 +++                      chompNewline (commandDescription c)++"\n"++usageHelper cs+usageHelper ((GroupName n):cs) = "\n" ++ n ++ "\n" ++ usageHelper cs -chomp_newline :: String -> String-chomp_newline "" = ""-chomp_newline s = if last s == '\n' then init s else s+chompNewline :: String -> String+chompNewline "" = ""+chompNewline s = if last s == '\n' then init s else s -pad_spaces :: String -> Int -> String-pad_spaces s n = s ++ replicate (n - length s) ' '+padSpaces :: String -> Int -> String+padSpaces s n = s ++ replicate (n - length s) ' ' -super_name :: Maybe DarcsCommand -> String-super_name Nothing  = ""-super_name (Just x) = command_name x ++ " "+superName :: Maybe DarcsCommand -> String+superName Nothing  = ""+superName (Just x) = commandName x ++ " " -get_command_mini_help :: Maybe DarcsCommand -> DarcsCommand -> String-get_command_mini_help msuper cmd =-  get_command_help_core msuper cmd +++getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String+getCommandMiniHelp msuper cmd =+  getCommandHelpCore msuper cmd ++   "\n\nSee darcs help "-  ++ (maybe "" (\c -> command_name c ++ " ") msuper)-  ++ command_name cmd ++ " for details."+  ++ (maybe "" (\c -> commandName c ++ " ") msuper)+  ++ commandName cmd ++ " for details." -get_command_help :: Maybe DarcsCommand -> DarcsCommand -> String-get_command_help msuper cmd =+getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> String+getCommandHelp msuper cmd =     unlines (reverse basicR)     ++ (if null advanced then ""         else "\nAdvanced options:\n" ++ unlines (reverse advancedR))-    ++ "\n" ++ command_help cmd+    ++ "\n" ++ commandHelp cmd     where -- we could just call usageInfo twice, but then the advanced           -- options might not line up with the basic ones (no short flags)           (advancedR, basicR) =              splitAt (length advanced) $ reverse $ lines combinedUsage           combinedUsage = usageInfo-            (get_command_help_core msuper cmd ++ subcommands ++ "\n\nOptions:")+            (getCommandHelpCore msuper cmd ++ subcommands ++ "\n\nOptions:")             (basic ++ advanced)-          (basic, advanced) = command_options rootDirectory cmd+          (basic, advanced) = commandOptions rootDirectory cmd           subcommands =             case msuper of-            Nothing -> case get_subcommands cmd of+            Nothing -> case getSubcommands cmd of                        [] -> []-                       s  -> "\n\nSubcommands:\n" ++ (usage_helper s)+                       s  -> "\n\nSubcommands:\n" ++ (usageHelper s)             -- we don't want to list subcommands if we're already specifying them             Just _  -> "" -get_command_help_core :: Maybe DarcsCommand -> DarcsCommand -> String-get_command_help_core msuper cmd =-    "Usage: darcs "++super_name msuper++command_name cmd+++getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> String+getCommandHelpCore msuper cmd =+    "Usage: darcs "++superName msuper++commandName cmd++     " [OPTION]... " ++ unwords args_help ++-    "\n"++ command_description cmd+    "\n"++ commandDescription cmd     where args_help = case cmd of             (DarcsCommand _ _ _ _ _ _ _ _ _ _ _) ->-              command_extra_arg_help cmd+              commandExtraArgHelp cmd             _ -> []  data CommandArgs = CommandOnly      DarcsCommand@@ -265,11 +266,11 @@                  | SuperCommandSub  DarcsCommand DarcsCommand  -- Parses a darcs command line with potentially abbreviated commands-disambiguate_commands :: [CommandControl] -> String -> [String]+disambiguateCommands :: [CommandControl] -> String -> [String]                       -> Either String (CommandArgs, [String])-disambiguate_commands allcs cmd args =+disambiguateCommands allcs cmd args =  do c <- extract cmd allcs-    case (get_subcommands c, args) of+    case (getSubcommands c, args) of       ([], _)         -> return (CommandOnly c, args)       (_ ,[])         -> return (SuperCommandOnly c, args)       (subcs, (a:as)) -> case extract a subcs of@@ -278,17 +279,31 @@  extract :: String -> [CommandControl] -> Either String DarcsCommand extract cmd cs =- case [ c | c <- extract_commands cs, cmd `isPrefixOf` command_name c ] ++-      [ h | h <- extract_hidden_commands cs,    cmd == command_name h ] of+ case [ c | c <- extractCommands cs, cmd `isPrefixOf` commandName c ] +++      [ h | h <- extractHiddenCommands cs,    cmd == commandName h ] of    []  -> Left $ "No such command '" ++ cmd ++ "'\n"    [c] -> Right c    cs' -> Left $ "Ambiguous command...\n\n" ++                     "The command '"++cmd++"' could mean one of:\n" ++-                    unwords (sort $ map command_name cs')+                    unwords (sort $ map commandName cs') --- | Output functions equivalent to (putStrLn, hPutStrLn stderr, putDocLn)-loggers :: [DarcsFlag] -> ( String -> IO ()-                          , String -> IO ()-                          , Doc -> IO ())-loggers _ = (putStrLn, putStrLnError, putDocLn)+amVerbose :: [DarcsFlag] -> Bool+amVerbose = elem Verbose++amQuiet :: [DarcsFlag] -> Bool+amQuiet = elem Quiet++putVerbose :: [DarcsFlag] -> Doc -> IO ()+putVerbose opts = when (amVerbose opts) . putDocLn+     +putInfo :: [DarcsFlag] -> Doc -> IO ()+putInfo opts = unless (amQuiet opts) . putDocLn++putWarning :: [DarcsFlag] -> Doc -> IO ()+putWarning opts = unless (amQuiet opts) . hPutDocLn stderr++abortRun :: [DarcsFlag] -> Doc -> IO ()+abortRun opts msg = if DryRun `elem` opts+                    then putInfo opts $ text "NOTE:" <+> msg+                    else errorDoc msg \end{code}
src/Darcs/Commands/Add.lhs view
@@ -17,44 +17,43 @@  \darcsCommand{add} \begin{code}-module Darcs.Commands.Add ( add ) where+module Darcs.Commands.Add ( add, expandDirs ) where  import Data.List ( (\\), nub) -import Darcs.Commands-import Darcs.Arguments (noskip_boring, allow_problematic_filenames,-                       fancy_move_add,-                       recursive, working_repo_dir, dry_run_noxml, umask_option,-                       list_files, list_unregistered_files,-                        DarcsFlag (AllowCaseOnly, AllowWindowsReserved, Boring, Recursive,-                                   Verbose, Quiet, FancyMoveAdd, DryRun),+import Darcs.Commands(DarcsCommand(..), putVerbose, putWarning, nodefaults)+import Darcs.Arguments (noskipBoring, allowProblematicFilenames,+                       fancyMoveAdd,+                       recursive, workingRepoDir, dryRunNoxml, umaskOption,+                       listFiles, listUnregisteredFiles,+                        DarcsFlag ( Recursive, FancyMoveAdd, DryRun, Verbose),                         fixSubPaths,                       )+import Darcs.Flags( includeBoring, doAllowCaseOnly, doAllowWindowsReserved,) import Darcs.Utils ( withCurrentDirectory, nubsort ) import IsoDate ( getIsoDateTime ) import Darcs.Repository ( amInRepository, withRepoLock, ($-),                     slurp_pending, add_to_pending )-import Darcs.Patch ( Prim, apply_to_slurpy, addfile, adddir, move )-import Darcs.Ordered ( FL(..), unsafeFL, concatFL, nullFL )+import Darcs.Patch ( Prim, applyToSlurpy, addfile, adddir, move )+import Darcs.Witnesses.Ordered ( FL(..), unsafeFL, concatFL, nullFL ) import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has,                         isFileReallySymlink, doesDirectoryReallyExist,                          doesFileReallyExist, slurp_hasdir,                       ) import Darcs.Patch.FileName ( fp2fn )-import Darcs.RepoPath ( toFilePath )-import Control.Monad ( when, unless )-import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter )-import Data.Maybe ( maybeToList )+import Darcs.RepoPath ( SubPath, toFilePath, simpleSubPath, toPath )+import Control.Monad ( when, unless, liftM )+import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )+import Data.Maybe ( maybeToList, fromJust ) import System.FilePath.Posix ( takeDirectory, (</>) )-import System.IO ( hPutStrLn, stderr ) import qualified System.FilePath.Windows as WindowsFilePath-import Darcs.Gorsvet( invalidateIndex )+import Printer( text ) -add_description :: String-add_description = "Add one or more new files or directories."+addDescription :: String+addDescription = "Add one or more new files or directories." -add_help :: String-add_help =+addHelp :: String+addHelp =  "Generally a repository contains both files that should be version\n" ++  "controlled (such as source code) and files that Darcs should ignore\n" ++  "(such as executables compiled from the source code).  The `darcs add'\n" ++@@ -67,24 +66,24 @@  "Adding symbolic links (symlinks) is not supported.\n\n"  add :: DarcsCommand-add = DarcsCommand {command_name = "add",-                    command_help = add_help ++ add_help' ++ add_help'',-                    command_description = add_description,-                    command_extra_args = -1,-                    command_extra_arg_help = ["<FILE or DIRECTORY> ..."],-                    command_command = add_cmd,-                    command_prereq = amInRepository,-                    command_get_arg_possibilities = list_unregistered_files,-                    command_argdefaults = nodefaults,-                    command_advanced_options = [umask_option],-                    command_basic_options =-                    [noskip_boring, allow_problematic_filenames,+add = DarcsCommand {commandName = "add",+                    commandHelp = addHelp ++ addHelp' ++ addHelp'',+                    commandDescription = addDescription,+                    commandExtraArgs = -1,+                    commandExtraArgHelp = ["<FILE or DIRECTORY> ..."],+                    commandCommand = addCmd,+                    commandPrereq = amInRepository,+                    commandGetArgPossibilities = listUnregisteredFiles,+                    commandArgdefaults = nodefaults,+                    commandAdvancedOptions = [umaskOption],+                    commandBasicOptions =+                    [noskipBoring, allowProblematicFilenames,                      recursive "add contents of subdirectories",-                     fancy_move_add,-                     working_repo_dir, dry_run_noxml]}+                     fancyMoveAdd,+                     workingRepoDir, dryRunNoxml]} -add_help' :: String-add_help' =+addHelp' :: String+addHelp' =  "Darcs will ignore all files and folders that look `boring'.  The\n" ++  "--boring option overrides this behaviour.\n" ++  "\n" ++@@ -95,28 +94,27 @@  "`ReadMe' and `README').  If --case-ok is used, the repository might be\n" ++  "unusable on those systems!\n\n" -add_cmd :: [DarcsFlag] -> [String] -> IO ()-add_cmd opts args = withRepoLock opts $- \repository ->+addCmd :: [DarcsFlag] -> [String] -> IO ()+addCmd opts args = withRepoLock opts $- \repository ->  do cur <- slurp_pending repository-    origfiles <- map toFilePath `fmap` fixSubPaths opts args+    origfiles <- fixSubPaths opts args     when (null origfiles) $        putStrLn "Nothing specified, nothing added." >>        putStrLn "Maybe you wanted to say `darcs add --recursive .'?"-    parlist <- get_parents cur origfiles+    parlist <- getParents cur (map toFilePath origfiles)     flist' <- if Recursive `elem` opts-              then expand_dirs origfiles+              then expandDirs origfiles               else return origfiles-    let flist = nubsort (parlist ++ flist')+    let flist = nubsort (parlist ++ toFilePath `map` flist')     -- refuse to add boring files recursively:-    nboring <- if Boring `elem` opts-               then return darcsdir_filter-               else boring_file_filter-    let putInfoLn = if Quiet `elem` opts then \_ -> return () else putStrLn-    mapM_ (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $+    nboring <- if includeBoring opts+               then return darcsdirFilter+               else boringFileFilter+    let fixedOpts = if DryRun `elem` opts then Verbose:opts else opts+    mapM_ (putWarning fixedOpts . text . ((msg_skipping msgs ++ " boring file ")++)) $       flist \\ nboring flist     date <- getIsoDateTime-    invalidateIndex repository-    ps <- addp msgs opts date cur $ nboring flist+    ps <- addp msgs fixedOpts date cur $ nboring flist     when (nullFL ps && not (null args)) $         fail "No files were added"     unless gotDryRun $ add_to_pending repository ps@@ -164,8 +162,8 @@                         msg_are msgs ++ " already in the repository"                       else return $                         "The following files " ++ msg_are msgs ++ " already in the repository")-       putInfo $ dupMsg ++ caseMsg-       mapM_ putInfo uniq_dups+       putWarning opts . text $ dupMsg ++ caseMsg+       mapM_ (putWarning opts . text) uniq_dups     return $ concatFL $ unsafeFL ps  where   addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath)@@ -174,7 +172,8 @@     then return (cur, Nothing, Just f)     else     if is_badfilename-       then do putInfo $ "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it."+       then do putWarning opts . text $+                              "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it."                return add_failure        else do       isdir <- doesDirectoryReallyExist f@@ -185,8 +184,9 @@                     then trypatch $ myaddfile f                     else do islink <- isFileReallySymlink f                             if islink then-                               putInfo $ "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs."-                               else putInfo $ "File "++ f ++" does not exist!"+                               putWarning opts . text $+                                 "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs."+                               else putWarning opts . text $ "File "++ f ++" does not exist!"                             return add_failure       where already_has = if gotAllowCaseOnly                           then slurp_has f cur@@ -194,10 +194,10 @@             is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)             add_failure = (cur, Nothing, Nothing)             trypatch p =-                case apply_to_slurpy p cur of-                Nothing -> do putInfo $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error+                case applyToSlurpy p cur of+                Nothing -> do putWarning opts . text $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error                               return (cur, Nothing, Nothing)-                Just s' -> do putVerbose $ msg_adding msgs++" '"++f++"'"+                Just s' -> do putVerbose opts . text $ msg_adding msgs++" '"++f++"'"                               return (s', Just p, Nothing)             parentdir = takeDirectory f             have_parentdir = slurp_hasdir (fp2fn parentdir) cur@@ -213,13 +213,9 @@                           then addfile (d++"-"++date) :>:                                move (d++"-"++date) d :>: NilFL                           else addfile d :>: NilFL-  putVerbose = if Verbose `elem` opts || DryRun `elem` opts-               then putStrLn-               else \_ -> return ()-  putInfo = if Quiet `elem` opts then \_ -> return () else hPutStrLn stderr   gotFancyMoveAdd = FancyMoveAdd `elem` opts-  gotAllowCaseOnly = AllowCaseOnly `elem` opts-  gotAllowWindowsReserved = AllowWindowsReserved `elem` opts+  gotAllowCaseOnly = doAllowCaseOnly opts+  gotAllowWindowsReserved = doAllowWindowsReserved opts  data AddMessages =     AddMessages@@ -247,31 +243,32 @@  -- |FIXME: this documentation makes *no* sense to me, and the -- ramifications of using this option are not clear. --twb, 2008-add_help'' :: String-add_help'' =+addHelp'' :: String+addHelp'' =  "The --date-trick option allows you to enable an experimental trick to\n" ++  "make add conflicts, in which two users each add a file or directory\n" ++  "with the same name, less problematic.  While this trick is completely\n" ++  "safe, it is not clear to what extent it is beneficial.\n" -expand_dirs :: [FilePath] -> IO [FilePath]-expand_dirs fs = concat `fmap` mapM expand_one fs-expand_one :: FilePath -> IO [FilePath]-expand_one "" = list_files-expand_one f = do+expandDirs :: [SubPath] -> IO [SubPath]+expandDirs fs = liftM (map (fromJust . simpleSubPath)) (concat `fmap` mapM (expandOne . toPath) fs)++expandOne :: FilePath -> IO [FilePath]+expandOne "" = listFiles+expandOne f = do   isdir <- doesDirectoryReallyExist f   if not isdir then return [f]-     else do fs <- withCurrentDirectory f list_files+     else do fs <- withCurrentDirectory f listFiles              return $ f: map (f </>) fs -get_parents :: Slurpy -> [FilePath] -> IO [FilePath]-get_parents cur fs =-  concat `fmap` mapM (get_parent cur) fs-get_parent :: Slurpy -> FilePath -> IO [FilePath]-get_parent cur f =+getParents :: Slurpy -> [FilePath] -> IO [FilePath]+getParents cur fs =+  concat `fmap` mapM (getParent cur) fs+getParent :: Slurpy -> FilePath -> IO [FilePath]+getParent cur f =   if slurp_hasdir (fp2fn parentdir) cur   then return []-  else do grandparents <- get_parent cur parentdir+  else do grandparents <- getParent cur parentdir           return (grandparents ++ [parentdir])     where parentdir = takeDirectory f \end{code}
src/Darcs/Commands/AmendRecord.lhs view
@@ -20,52 +20,52 @@ module Darcs.Commands.AmendRecord ( amendrecord ) where import Data.List ( sort ) import Data.Maybe ( isJust )+import System.Directory ( removeFile ) import System.Exit ( ExitCode(..), exitWith ) import Control.Monad ( when )  import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName,                                EditLongComment, PromptLongComment) ) import Darcs.Lock ( world_readable_temp )-import Darcs.RepoPath ( toFilePath, sp2fn )+import Darcs.RepoPath ( toFilePath ) import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully, info )-import Darcs.Repository ( withRepoLock, ($-), withGutsOf,-                    get_unrecorded_in_files, get_unrecorded_in_files_unsorted,+import Darcs.Repository ( Repository, withRepoLock, ($-), withGutsOf,                     tentativelyRemovePatches, tentativelyAddPatch, finalizeRepositoryChanges,-                    sync_repo, amInRepository,+                    amInRepository+                        , invalidateIndex, unrecordedChanges                   ) import Darcs.Patch ( RepoPatch, description, Prim, fromPrims,                      infopatch, getdeps, adddeps, effect,-                     sort_coalesceFL,-                     canonize )+                   )+import Darcs.Patch.Prim ( canonizeFL ) import Darcs.Patch.Info ( pi_author, pi_name, pi_log,                           PatchInfo, patchinfo, is_inverted, invert_name,                         )-import Darcs.Ordered ( FL(..), (:>)(..), (+>+),-                             nullFL, mapFL_FL, concatFL )+import Darcs.Patch.Split ( primSplitter )+import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL ) import Darcs.SelectChanges ( with_selected_changes_to_files',                              with_selected_patch_from_repo ) import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Commands.Record ( get_date, get_log )+import Darcs.Commands.Record ( getDate, getLog ) import Darcs.Arguments ( DarcsFlag ( All ),                          areFileArgs, fixSubPaths, defineChanges,-                        all_interactive, ignoretimes,-                        ask_long_comment, author, patchname_option,-                        leave_test_dir, nocompress, lookforadds,-                         working_repo_dir,-                        match_one_nontag, umask_option,-                        notest, testByDefault, list_registered_files,-                        get_easy_author, set_scripts_executable+                        allInteractive, ignoretimes,+                        askLongComment, author, patchnameOption,+                        leaveTestDir, nocompress, lookforadds,+                         workingRepoDir,+                        matchOneNontag, umaskOption,+                        notest, testByDefault, listRegisteredFiles,+                        getEasyAuthor, setScriptsExecutableOption                       )-import Darcs.Utils ( askUser )+import Darcs.Utils ( askUser, clarifyErrors ) import Printer ( putDocLn )-import Darcs.Gorsvet( invalidateIndex ) -amendrecord_description :: String-amendrecord_description =+amendrecordDescription :: String+amendrecordDescription =  "Improve a patch before it leaves your repository." -amendrecord_help :: String-amendrecord_help =+amendrecordHelp :: String+amendrecordHelp =  "Amend-record updates a `draft' patch with additions or improvements,\n" ++  "resulting in a single `finished' patch.  This is better than recording\n" ++  "the additions and improvements as separate patches, because then\n" ++@@ -100,96 +100,107 @@  "On Windows use C:/Documents And Settings/user/Application Data/darcs/defaults\n"  amendrecord :: DarcsCommand-amendrecord = DarcsCommand {command_name = "amend-record",-                            command_help = amendrecord_help,-                            command_description = amendrecord_description,-                            command_extra_args = -1,-                            command_extra_arg_help = ["[FILE or DIRECTORY]..."],-                            command_command = amendrecord_cmd,-                            command_prereq = amInRepository,-                            command_get_arg_possibilities = list_registered_files,-                            command_argdefaults = nodefaults,-                            command_advanced_options = [nocompress, ignoretimes, umask_option,-                                                        set_scripts_executable],-                            command_basic_options = [match_one_nontag,+amendrecord = DarcsCommand {commandName = "amend-record",+                            commandHelp = amendrecordHelp,+                            commandDescription = amendrecordDescription,+                            commandExtraArgs = -1,+                            commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+                            commandCommand = amendrecordCmd,+                            commandPrereq = amInRepository,+                            commandGetArgPossibilities = listRegisteredFiles,+                            commandArgdefaults = nodefaults,+                            commandAdvancedOptions = [nocompress, ignoretimes, umaskOption,+                                                        setScriptsExecutableOption],+                            commandBasicOptions = [matchOneNontag,                                                      notest,-                                                    leave_test_dir,-                                                    all_interactive,-                                                    author, patchname_option, ask_long_comment,+                                                    leaveTestDir,+                                                    allInteractive,+                                                    author, patchnameOption, askLongComment,                                                     lookforadds,-                                                    working_repo_dir]}+                                                    workingRepoDir]} -amendrecord_cmd :: [DarcsFlag] -> [String] -> IO ()-amendrecord_cmd opts args =-    let edit_metadata = has_edit_metadata opts in+amendrecordCmd :: [DarcsFlag] -> [String] -> IO ()+amendrecordCmd opts args =     withRepoLock (testByDefault opts) $- \repository -> do     files  <- sort `fmap` fixSubPaths opts args     when (areFileArgs files) $          putStrLn $ "Amending changes in "++unwords (map show files)++":\n"     with_selected_patch_from_repo "amend" repository opts $ \ (_ :> oldp) -> do-        ch <- if All `elem` opts -              then get_unrecorded_in_files_unsorted repository (map sp2fn files)-              else get_unrecorded_in_files repository (map sp2fn files)+        ch <- unrecordedChanges opts repository files         case ch of-          NilFL | not edit_metadata -> putStrLn "No changes!"-          _ -> do-              date <- get_date opts-              with_selected_changes_to_files' "add" (filter (==All) opts)-                (map toFilePath files) ch $ \ (chs:>_) ->-                  if (nullFL chs && not edit_metadata)+          NilFL | not (hasEditMetadata opts) -> putStrLn "No changes!"+          _ ->+               with_selected_changes_to_files' "add" (filter (==All) opts) (Just primSplitter)+                (map toFilePath files) ch $ addChangesToPatch opts repository oldp++addChangesToPatch :: forall t p . (RepoPatch p) => [DarcsFlag] -> Repository p -> PatchInfoAnd p+                  -> (FL Prim :> t) -> IO ()+addChangesToPatch opts repository oldp (chs:>_) =    +                  if (nullFL chs && not (hasEditMetadata opts))                   then putStrLn "You don't want to record anything!"                   else do+                       (mlogf, newp) <- updatePatchHeader opts oldp chs+                       defineChanges newp+                       invalidateIndex repository+                       withGutsOf repository $ do+                         tentativelyRemovePatches repository opts (hopefully oldp :>: NilFL)+                         tentativelyAddPatch repository opts newp+                         let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf+                         finalizeRepositoryChanges repository `clarifyErrors` failmsg+                       maybe (return ()) removeFile mlogf+                       putStrLn "Finished amending patch:"+                       putDocLn $ description newp++updatePatchHeader :: forall p. (RepoPatch p) => [DarcsFlag] -> PatchInfoAnd p -> FL Prim+                  -> IO (Maybe String, PatchInfoAnd p)+updatePatchHeader opts oldp chs = do                        let old_pinf = info oldp                            prior    = (pi_name old_pinf, pi_log old_pinf)                            make_log = world_readable_temp "darcs-amend-record"                            old_author = pi_author old_pinf-                       author_here <- get_easy_author-                       case author_here of-                         Nothing -> return ()-                         Just ah -> let edit_author = isJust (get_author opts)-                                    in if (edit_author || ah == old_author)-                                       then return ()-                                       else do yorn <- askUser $ "You're not "++old_author-                                                                 ++"! Amend anyway? "-                                               case yorn of ('y':_) -> return ()-                                                            _ -> exitWith $ ExitSuccess-                       (new_name, new_log, _) <- get_log opts (Just prior) make_log chs-                       let new_author = case get_author opts of+                       date <- getDate opts+                       warnIfHijacking opts old_author+                       (new_name, new_log, mlogf) <- getLog opts (Just prior) make_log chs+                       let new_author = case getAuthor opts of                                         Just a  -> a                                         Nothing -> pi_author old_pinf                            maybe_invert = if is_inverted old_pinf then invert_name else id                        new_pinf <- maybe_invert `fmap` patchinfo date new_name                                                                  new_author new_log-                       let newp = fixp oldp chs new_pinf-                       defineChanges newp-                       invalidateIndex repository-                       withGutsOf repository $ do-                         tentativelyRemovePatches repository opts (hopefully oldp :>: NilFL)-                         tentativelyAddPatch repository opts newp-                         finalizeRepositoryChanges repository-                       sync_repo repository-                       putStrLn "Finished amending patch:"-                       putDocLn $ description newp+                       return $ (mlogf, fixp oldp chs new_pinf) -has_edit_metadata :: [DarcsFlag] -> Bool-has_edit_metadata (Author _:_) = True-has_edit_metadata (LogFile _:_) = True-has_edit_metadata (PatchName _:_) = True-has_edit_metadata (EditLongComment:_) = True-has_edit_metadata (PromptLongComment:_) = True-has_edit_metadata (_:fs) = has_edit_metadata fs-has_edit_metadata [] = False+warnIfHijacking :: [DarcsFlag] -> String -> IO ()+warnIfHijacking opts old_author = do+  author_here <- getEasyAuthor+  case author_here of+    Nothing -> return ()+    Just ah -> let edit_author = isJust (getAuthor opts)+              in if (edit_author || ah == old_author)+                 then return ()+                 else do yorn <- askUser $ +                                "You're not "++old_author ++"! Amend anyway? "+                         case yorn of ('y':_) -> return ()+                                      _ -> exitWith $ ExitSuccess -get_author :: [DarcsFlag] -> Maybe String-get_author (Author a:_) = Just a-get_author (_:as) = get_author as-get_author []     = Nothing+hasEditMetadata :: [DarcsFlag] -> Bool+hasEditMetadata (Author _:_) = True+hasEditMetadata (LogFile _:_) = True+hasEditMetadata (PatchName _:_) = True+hasEditMetadata (EditLongComment:_) = True+hasEditMetadata (PromptLongComment:_) = True+hasEditMetadata (_:fs) = hasEditMetadata fs+hasEditMetadata [] = False +getAuthor :: [DarcsFlag] -> Maybe String+getAuthor (Author a:_) = Just a+getAuthor (_:as) = getAuthor as+getAuthor []     = Nothing+ fixp :: RepoPatch p => PatchInfoAnd p -> FL Prim -> PatchInfo -> PatchInfoAnd p fixp oldp chs new_pinf =     let pdeps = getdeps $ hopefully oldp         oldchs = effect oldp         infodepspatch pinfo deps p = adddeps (infopatch pinfo p) deps-    in n2pia $ infodepspatch new_pinf pdeps $ fromPrims $ concatFL $ mapFL_FL canonize-           $ sort_coalesceFL $ concatFL $ mapFL_FL canonize $ oldchs +>+ chs+    in n2pia $ infodepspatch new_pinf pdeps $ fromPrims $ canonizeFL+             $ oldchs +>+ chs \end{code}
src/Darcs/Commands/Annotate.lhs view
@@ -22,25 +22,26 @@  #include "gadts.h" -module Darcs.Commands.Annotate ( annotate, created_as_xml ) where+module Darcs.Commands.Annotate ( annotate, createdAsXml ) where  import Control.Monad ( when ) import Data.List ( sort )  import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(..), working_repo_dir,-                         summary, unified, human_readable,+import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,+                         summary, unified, humanReadable,                         xmloutput, creatorhash,                         fixSubPaths,-                        list_registered_files,-                        match_one,+                        listRegisteredFiles,+                        matchOne,                       )-import Darcs.SlurpDirectory ( slurp )+import Darcs.Flags ( isUnified )+import Storage.Hashed.Plain( readPlainTree ) import Darcs.Repository ( Repository, PatchSet, amInRepository, withRepository, ($-), read_repo,                           getMarkedupFile )-import Darcs.Patch ( RepoPatch, Named, LineMark(..), patch2patchinfo, xml_summary )+import Darcs.Patch ( RepoPatch, Named, LineMark(..), patch2patchinfo, xmlSummary ) import qualified Darcs.Patch ( summary )-import Darcs.Ordered ( mapRL, concatRL )+import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import qualified Data.ByteString.Char8 as BC ( unpack, ByteString ) import Darcs.PrintPatch ( printPatch, contextualPrintPatch ) import Darcs.Patch.Info ( PatchInfo, human_friendly, to_xml, make_filename,@@ -54,70 +55,66 @@                   ) import Darcs.Hopefully ( info ) import Darcs.RepoPath ( SubPath, toFilePath )-import Darcs.Match ( match_patch, have_nonrange_match, get_first_match )+import Darcs.Match ( matchPatch, haveNonrangeMatch, getFirstMatch ) import Darcs.Lock ( withTempDir )-import Darcs.Sealed ( Sealed2(..), unseal2 )+import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2 ) import Printer ( putDocLn, text, errorDoc, ($$), prefix, (<+>),                  Doc, empty, vcat, (<>), renderString, packedString ) #include "impossible.h" -annotate_description :: String-annotate_description = "Display which patch last modified something."+annotateDescription :: String+annotateDescription = "Display which patch last modified something." -annotate_help :: String-annotate_help =- "Annotate displays which patches created or last modified a directory\n"++- "file or line. It can also display the contents of a particular patch\n"++- "in darcs format.\n"+annotateHelp :: String+annotateHelp =+ "The `darcs annotate' command provides two unrelated operations.  When\n" +++ "called on a file, it will find the patch that last modified each line\n" +++ "in that file.  When called on a patch (e.g. using --patch), it will\n" +++ "print the internal representation of that patch.\n" +++ "\n" +++ "The --summary option will result in a summarized patch annotation,\n" +++ "similar to `darcs whatsnew'.  It has no effect on file annotations.\n" +++ "\n" +++ "By default, output is in a human-readable format.  The --xml-output\n" +++ "option can be used to generate output for machine postprocessing.\n"  annotate :: DarcsCommand-annotate = DarcsCommand {command_name = "annotate",-                         command_help = annotate_help,-                         command_description = annotate_description,-                         command_extra_args = -1,-                         command_extra_arg_help = ["[FILE or DIRECTORY]..."],-                         command_command = annotate_cmd,-                         command_prereq = amInRepository,-                         command_get_arg_possibilities = list_registered_files,-                         command_argdefaults = nodefaults,-                         command_advanced_options = [],-                         command_basic_options = [summary,unified,-                                                 human_readable,+annotate = DarcsCommand {commandName = "annotate",+                         commandHelp = annotateHelp,+                         commandDescription = annotateDescription,+                         commandExtraArgs = -1,+                         commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+                         commandCommand = annotateCmd,+                         commandPrereq = amInRepository,+                         commandGetArgPossibilities = listRegisteredFiles,+                         commandArgdefaults = nodefaults,+                         commandAdvancedOptions = [],+                         commandBasicOptions = [summary,unified,+                                                 humanReadable,                                                  xmloutput,-                                                 match_one, creatorhash,-                                                 working_repo_dir]}-\end{code}--\begin{options}---human-readable, --summary, --unified, --xml--output-\end{options}--When called with just a patch name, annotate outputs the patch in darcs format,-which is the same as \verb!--human-readable!.--\verb!--xml-output! is the alternative to \verb!--human-readable!.--\verb!--summary! can be used with either the \verb!--xml-output! or the  -\verb!--human-readable! options to alter the results. It is documented-fully in the `common options' portion of the manual. +                                                 matchOne, creatorhash,+                                                 workingRepoDir]} +\end{code}+%% FIXME: AFAICT -u does nothing.  Remove it from anno's options?+%% --twb, 2009-09-20 Giving the \verb!--unified! flag implies \verb!--human-readable!, and causes the output to remain in a darcs-specific format that is similar to that produced by \verb!diff --unified!. \begin{code}-annotate_cmd :: [DarcsFlag] -> [String] -> IO ()-annotate_cmd opts [] = withRepository opts $- \repository -> do-  when (not $ have_nonrange_match opts) $+annotateCmd :: [DarcsFlag] -> [String] -> IO ()+annotateCmd opts [] = withRepository opts $- \repository -> do+  when (not $ haveNonrangeMatch opts) $       fail $ "Annotate requires either a patch pattern or a " ++                "file or directory argument."-  Sealed2 p <- match_patch opts `fmap` read_repo repository+  Sealed2 p <- matchPatch opts `fmap` read_repo repository   if Summary `elem` opts      then do putDocLn $ showpi $ patch2patchinfo p              putDocLn $ show_summary p-     else if Unified `elem` opts+     else if isUnified opts           then withTempDir "context" $ \_ ->-               do get_first_match repository opts-                  c <- slurp "."+               do getFirstMatch repository opts+                  c <- readPlainTree "."                   contextualPrintPatch c p           else printPatch p     where showpi | MachineReadable `elem` opts = showPatchInfo@@ -125,7 +122,7 @@                  | otherwise                   = human_friendly           show_summary :: RepoPatch p => Named p C(x y) -> Doc           show_summary = if XMLOutput `elem` opts-                         then xml_summary+                         then xmlSummary                          else Darcs.Patch.summary \end{code} @@ -143,25 +140,25 @@ that patch was applied.  If a directory and a tag name are given, the details of the patches involved in the specified tagged version will be output. \begin{code}-annotate_cmd opts args@[_] = withRepository opts $- \repository -> do+annotateCmd opts args@[_] = withRepository opts $- \repository -> do   r <- read_repo repository   (rel_file_or_directory:_) <- fixSubPaths opts args   let file_or_directory = rel_file_or_directory-  pinfo <- if have_nonrange_match opts-           then return $ patch2patchinfo `unseal2` (match_patch opts r)+  pinfo <- if haveNonrangeMatch opts+           then return $ patch2patchinfo `unseal2` (matchPatch opts r)            else case mapRL info $ concatRL r of                 [] -> fail "Annotate does not currently work correctly on empty repositories."                 (x:_) -> return x   pop <- getRepoPopVersion "." pinfo    -- deal with --creator-hash option-  let maybe_creation_pi = find_creation_patchinfo opts r+  let maybe_creation_pi = findCreationPatchinfo opts r       lookup_thing = case maybe_creation_pi of                      Nothing -> lookup_pop                      Just cp -> lookup_creation_pop cp    if toFilePath file_or_directory == ""-    then case pop of (Pop _ pt) -> annotate_pop opts pinfo pt+    then case pop of (Pop _ pt) -> annotatePop opts pinfo pt     else case lookup_thing (toFilePath file_or_directory) pop of       Nothing -> fail $ "There is no file or directory named '"++                  toFilePath file_or_directory++"'"@@ -170,18 +167,18 @@               errorDoc $ text ("The directory '" ++ toFilePath rel_file_or_directory ++                                "' was removed by")                       $$ human_friendly (modifiedByI i)-          | otherwise -> annotate_pop opts pinfo pt+          | otherwise -> annotatePop opts pinfo pt       Just (Pop _ pt@(PopFile i))           | modifiedHowI i == RemovedFile && modifiedByI i /= pinfo ->               errorDoc $ text ("The file '" ++ toFilePath rel_file_or_directory ++                                "' was removed by")                       $$ human_friendly (modifiedByI i)-          | otherwise -> annotate_file repository opts pinfo file_or_directory pt+          | otherwise -> annotateFile repository opts pinfo file_or_directory pt -annotate_cmd _ _ = fail "annotate accepts at most one argument"+annotateCmd _ _ = fail "annotate accepts at most one argument" -annotate_pop :: [DarcsFlag] -> PatchInfo -> PopTree -> IO ()-annotate_pop opts pinfo pt = putDocLn $ p2format pinfo pt+annotatePop :: [DarcsFlag] -> PatchInfo -> PopTree -> IO ()+annotatePop opts pinfo pt = putDocLn $ p2format pinfo pt     where p2format = if XMLOutput `elem` opts                      then p2xml                      else p2s@@ -234,8 +231,8 @@   | x == z    = y ++ (strReplace x y zs)   | otherwise = z : (strReplace x y zs) -created_as_xml :: PatchInfo -> String -> Doc-created_as_xml pinfo as = text "<created_as original_name='"+createdAsXml :: PatchInfo -> String -> Doc+createdAsXml pinfo as = text "<created_as original_name='"                        <> escapeXML as                        <> text "'>"                     $$    to_xml pinfo@@ -243,37 +240,37 @@ --removed_by_xml :: PatchInfo -> String --removed_by_xml pinfo = "<removed_by>\n"++to_xml pinfo++"</removed_by>\n" -p2xml_open :: PatchInfo -> PopTree -> Doc-p2xml_open _ (PopFile inf) =+p2xmlOpen :: PatchInfo -> PopTree -> Doc+p2xmlOpen _ (PopFile inf) =     text "<file name='" <> escapeXML f <> text "'>"  $$ created  $$ modified     where f = BC.unpack $ nameI inf           created = case createdByI inf of                     Nothing -> empty-                    Just ci -> created_as_xml ci+                    Just ci -> createdAsXml ci                                (BC.unpack $ fromJust $ creationNameI inf)           modified = modified_to_xml inf-p2xml_open _ (PopDir inf _) =+p2xmlOpen _ (PopDir inf _) =     text "<directory name='" <> escapeXML f <> text "'>"  $$ created  $$ modified     where f = BC.unpack $ nameI inf           created = case createdByI inf of                     Nothing -> empty-                    Just ci -> created_as_xml ci+                    Just ci -> createdAsXml ci                                (BC.unpack $ fromJust $ creationNameI inf)           modified = modified_to_xml inf -p2xml_close :: PatchInfo -> PopTree -> Doc-p2xml_close _(PopFile _) = text "</file>"-p2xml_close _ (PopDir _ _) = text "</directory>"+p2xmlClose :: PatchInfo -> PopTree -> Doc+p2xmlClose _(PopFile _) = text "</file>"+p2xmlClose _ (PopDir _ _) = text "</directory>"  p2xml :: PatchInfo -> PopTree -> Doc-p2xml pinf p@(PopFile _) = p2xml_open pinf p $$ p2xml_close pinf p-p2xml pinf p@(PopDir _ pops) = p2xml_open pinf p+p2xml pinf p@(PopFile _) = p2xmlOpen pinf p $$ p2xmlClose pinf p+p2xml pinf p@(PopDir _ pops) = p2xmlOpen pinf p                             $$ vcat (map (p2xml pinf) $ sort pops)-                            $$ p2xml_close pinf p+                            $$ p2xmlClose pinf p \end{code}  If a file name is given, the last modifying patch details of that file will be output, along@@ -283,40 +280,40 @@ that patch was applied.  \begin{code}-annotate_file :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> PatchInfo -> SubPath -> PopTree -> IO ()-annotate_file repository opts pinfo f (PopFile inf) = do+annotateFile :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> PatchInfo -> SubPath -> PopTree -> IO ()+annotateFile repository opts pinfo f (PopFile inf) = do   if XMLOutput `elem` opts-     then putDocLn $ p2xml_open pinfo (PopFile inf)+     then putDocLn $ p2xmlOpen pinfo (PopFile inf)      else if createdByI inf /= Nothing           then putAnn $ text ("File "++toFilePath f++" created by ")                      <> showPatchInfo ci <> text (" as " ++ createdname)           else putAnn $ text $ "File "++toFilePath f   mk <- getMarkedupFile repository ci createdname   old_pis <- (dropWhile (/= pinfo).mapRL info.concatRL) `fmap` read_repo repository-  mapM_ (annotate_markedup opts pinfo old_pis) mk-  when (XMLOutput `elem` opts) $  putDocLn $ p2xml_close pinfo (PopFile inf)+  mapM_ (annotateMarkedup opts pinfo old_pis) mk+  when (XMLOutput `elem` opts) $  putDocLn $ p2xmlClose pinfo (PopFile inf)   where ci = fromJust $ createdByI inf         createdname = BC.unpack $ fromJust $ creationNameI inf-annotate_file _ _ _ _ _ = impossible+annotateFile _ _ _ _ _ = impossible -annotate_markedup :: [DarcsFlag] -> PatchInfo -> [PatchInfo]+annotateMarkedup :: [DarcsFlag] -> PatchInfo -> [PatchInfo]                   -> (BC.ByteString, LineMark) -> IO ()-annotate_markedup opts | XMLOutput `elem` opts = xml_markedup-                       | otherwise = text_markedup+annotateMarkedup opts | XMLOutput `elem` opts = xmlMarkedup+                       | otherwise = textMarkedup -text_markedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO ()-text_markedup _ _ (l,None) = putLine ' ' l-text_markedup pinfo old_pis (l,RemovedLine wheni)+textMarkedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO ()+textMarkedup _ _ (l,None) = putLine ' ' l+textMarkedup pinfo old_pis (l,RemovedLine wheni)     | wheni == pinfo       = putLine '-' l     | wheni `elem` old_pis = return ()     | otherwise            = putLine ' ' l-text_markedup pinfo old_pis (l,AddedLine wheni)+textMarkedup pinfo old_pis (l,AddedLine wheni)     | wheni == pinfo       = putLine '+' l     | wheni `elem` old_pis = do putAnn $ text "Following line added by "                                       <> showPatchInfo wheni                                 putLine ' ' l     | otherwise            = return ()-text_markedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem)+textMarkedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem)     | whenadd == pinfo = do putAnn $ text "Following line removed by "                                   <> showPatchInfo whenrem                             putLine '+' l@@ -334,9 +331,9 @@ putAnn :: Doc -> IO () putAnn s = putDocLn $ prefix "# " s -xml_markedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO ()-xml_markedup _ _ (l,None) = putLine ' ' l-xml_markedup pinfo old_pis (l,RemovedLine wheni)+xmlMarkedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO ()+xmlMarkedup _ _ (l,None) = putLine ' ' l+xmlMarkedup pinfo old_pis (l,RemovedLine wheni)     | wheni == pinfo       = putDocLn $ text "<removed_line>"                              $$ escapeXML (BC.unpack l)                              $$ text "</removed_line>"@@ -347,7 +344,7 @@                              $$ text "</removed_by>"                              $$ escapeXML (BC.unpack l)                              $$ text "</normal_line>"-xml_markedup pinfo old_pis (l,AddedLine wheni)+xmlMarkedup pinfo old_pis (l,AddedLine wheni)     | wheni == pinfo       = putDocLn $ text "<added_line>"                              $$ escapeXML (BC.unpack l)                              $$ text "</added_line>"@@ -358,7 +355,7 @@                              $$ escapeXML (BC.unpack l)                              $$ text "</normal_line>"     | otherwise            = return ()-xml_markedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem)+xmlMarkedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem)     | whenadd == pinfo =         putDocLn $ text "<added_line>"                 $$ text "<removed_by>"@@ -398,14 +395,14 @@ examine a file even if it has been renamed multiple times.  \begin{code}-find_creation_patchinfo :: [DarcsFlag] -> PatchSet p C(x) -> Maybe PatchInfo-find_creation_patchinfo [] _ = Nothing-find_creation_patchinfo (CreatorHash h:_) r = find_hash h $ mapRL info $ concatRL r-find_creation_patchinfo (_:fs) r = find_creation_patchinfo fs r+findCreationPatchinfo :: [DarcsFlag] -> PatchSet p C(x) -> Maybe PatchInfo+findCreationPatchinfo [] _ = Nothing+findCreationPatchinfo (CreatorHash h:_) r = findHash h $ mapRL info $ concatRL r+findCreationPatchinfo (_:fs) r = findCreationPatchinfo fs r -find_hash :: String -> [PatchInfo] -> Maybe PatchInfo-find_hash _ [] = Nothing-find_hash h (pinf:pinfs)+findHash :: String -> [PatchInfo] -> Maybe PatchInfo+findHash _ [] = Nothing+findHash h (pinf:pinfs)     | take (length h) (make_filename pinf) == h = Just pinf-    | otherwise = find_hash h pinfs+    | otherwise = findHash h pinfs \end{code}
src/Darcs/Commands/Apply.lhs view
@@ -27,38 +27,37 @@ import Control.Exception ( catch, throw, Exception( ExitException ) ) import Control.Monad ( when ) -import Darcs.Hopefully ( n2pia, conscientiously, info )+import Darcs.Hopefully ( PatchInfoAnd, n2pia, conscientiously, info ) import Darcs.SignalHandler ( withSignalsBlocked )-import Darcs.Commands ( DarcsCommand(..) )+import Darcs.Commands ( DarcsCommand(..), putVerbose ) import Darcs.CommandsAux ( check_paths )-import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All,-                                    Verbose, HappyForwarding ),+import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All ),                          definePatches,-                         get_cc, working_repo_dir,-                        notest, nocompress, apply_conflict_options,-                        use_external_merge,-                        ignoretimes, get_sendmail_cmd,-                        reply, verify, list_files,-                        fixFilePathOrStd, umask_option,-                        all_interactive, sendmail_cmd,-                        leave_test_dir, happy_forwarding, -                        dry_run, print_dry_run_message_and_exit,-                        set_scripts_executable, restrict_paths+                         getCc, workingRepoDir,+                        notest, nocompress, applyConflictOptions,+                        useExternalMerge,+                        ignoretimes, getSendmailCmd,+                        reply, verify, listFiles,+                        fixFilePathOrStd, umaskOption,+                        allInteractive, sendmailCmd,+                        leaveTestDir, happyForwarding, +                        dryRun, printDryRunMessageAndExit,+                        setScriptsExecutableOption, restrictPaths                       )-import qualified Darcs.Arguments as DarcsArguments ( cc )+import Darcs.Flags(doHappyForwarding)++import qualified Darcs.Arguments as DarcsArguments ( ccApply ) import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd )-import Darcs.Repository ( SealedPatchSet, withRepoLock, ($-), amInRepository,+import Darcs.Repository ( Repository, SealedPatchSet, withRepoLock, ($-), amInRepository,                           tentativelyMergePatches,-                    sync_repo, read_repo,+                    read_repo,                     finalizeRepositoryChanges,-                    applyToWorking,+                    applyToWorking, invalidateIndex                   ) import Darcs.Patch ( RepoPatch, description )-import Darcs.Patch.Info ( human_friendly )-import Darcs.Ordered ( (:\/:)(..), (:>)(..), unsafeUnRL,-                             mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL )-import Darcs.SlurpDirectory ( wait_a_moment )-+import Darcs.Patch.Info ( PatchInfo, human_friendly )+import Darcs.Witnesses.Ordered ( FL, RL, (:\/:)(..), (:>)(..),+                       mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL ) import ByteStringUtils ( linesPS, unlinesPS ) import qualified Data.ByteString as B (ByteString, null, readFile, hGetContents, init, take, drop) import qualified Data.ByteString.Char8 as BC (unpack, last, pack)@@ -68,60 +67,86 @@ import Darcs.Email ( read_email ) import Darcs.Lock ( withStdoutTemp, readBinFile ) import Darcs.Patch.Depends ( get_common_and_uncommon_or_missing )-import Darcs.SelectChanges ( with_selected_changes )+import Darcs.SelectChanges ( with_selected_changes, filterOutConflicts ) import Darcs.Patch.Bundle ( scan_bundle )-import Darcs.Sealed ( Sealed(Sealed) )-import Printer ( packedString, putDocLn, vcat, text, ($$), errorDoc, empty )-import Darcs.Gorsvet( invalidateIndex )+import Darcs.Witnesses.Sealed ( Sealed(Sealed) )+import Printer ( packedString, vcat, text, ($$), errorDoc, empty )+ #include "impossible.h" -apply_description :: String-apply_description = "Apply a patch bundle created by `darcs send'."+#include "gadts.h" -apply_help :: String-apply_help =- "Apply is used to apply a bundle of patches to this repository.\n"++- "Such a bundle may be created using send.\n"+applyDescription :: String+applyDescription = "Apply a patch bundle created by `darcs send'." +applyHelp :: String+applyHelp =+ "The `darcs apply' command takes a patch bundle and attempts to insert\n" +++ "it into the current repository.  In addition to invoking it directly\n" +++ "on bundles created by `darcs send', it is used internally by `darcs\n" +++ "push' and `darcs put' on the remote end of an SSH connection.\n" +++ "\n" +++ "If no file is supplied, the bundle is read from standard input.\n" +++ "\n" +++ "If given an email instead of a patch bundle, Darcs will look for the\n" +++ "bundle as a MIME attachment to that email.  Currently this will fail\n" +++ "if the MIME boundary is rewritten, such as in Courier and Mail.app.\n" +++ "\n" +++ "If the `--reply noreply@example.net' option is used, and the bundle is\n" +++ "attached to an email, Darcs will send a report (indicating success or\n" +++ "failure) to the sender of the bundle (the To field).  The argument to\n" +++ "noreply is the address the report will appear to originate FROM.\n" +++ "\n" +++ "The --cc option will cause the report to be CC'd to another address,\n" +++ "for example `--cc reports@lists.example.net,admin@lists.example.net'.\n" +++ "Using --cc without --reply is undefined.\n" +++ "\n" +++ "If gpg(1) is installed, you can use `--verify pubring.gpg' to reject\n" +++ "bundles that aren't signed by a key in pubring.gpg.\n" +++ "\n" +++ "If --test is supplied and a test is defined (see `darcs setpref'), the\n" +++ "bundle will be rejected if the test fails after applying it.  In that\n" +++ "case, the rejection email from --reply will include the test output.\n"+ stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] stdindefault _ x = return x apply :: DarcsCommand-apply = DarcsCommand {command_name = "apply",-                      command_help = apply_help,-                      command_description = apply_description,-                      command_extra_args = 1,-                      command_extra_arg_help = ["<PATCHFILE>"],-                      command_command = apply_cmd,-                      command_prereq = amInRepository,-                      command_get_arg_possibilities = list_files,-                      command_argdefaults = const stdindefault,-                      command_advanced_options = [reply, DarcsArguments.cc,-                                                  happy_forwarding,-                                                  sendmail_cmd,+apply = DarcsCommand {commandName = "apply",+                      commandHelp = applyHelp ++ "\n" ++ applyHelp',+                      commandDescription = applyDescription,+                      commandExtraArgs = 1,+                      commandExtraArgHelp = ["<PATCHFILE>"],+                      commandCommand = applyCmd,+                      commandPrereq = amInRepository,+                      commandGetArgPossibilities = listFiles,+                      commandArgdefaults = const stdindefault,+                      commandAdvancedOptions = [reply, DarcsArguments.ccApply,+                                                  happyForwarding,+                                                  sendmailCmd,                                                   ignoretimes, nocompress,-                                                  set_scripts_executable, umask_option,-                                                  restrict_paths],-                      command_basic_options = [verify,-                                              all_interactive]++dry_run++-                                              [apply_conflict_options,-                                              use_external_merge,+                                                  setScriptsExecutableOption, umaskOption,+                                                  restrictPaths],+                      commandBasicOptions = [verify,+                                              allInteractive]++dryRun+++                                              [applyConflictOptions,+                                              useExternalMerge,                                               notest,-                                              leave_test_dir,-                                              working_repo_dir]}+                                              leaveTestDir,+                                              workingRepoDir]} -apply_cmd :: [DarcsFlag] -> [String] -> IO ()-apply_cmd _ [""] = fail "Empty filename argument given to apply!"-apply_cmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do+applyCmd :: [DarcsFlag] -> [String] -> IO ()+applyCmd _ [""] = fail "Empty filename argument given to apply!"+applyCmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do   patchesfile <- fixFilePathOrStd opts unfixed_patchesfile   ps <- useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) patchesfile-  am_verbose <- return $ Verbose `elem` opts-  let from_whom = get_from ps+  let from_whom = getFrom ps   us <- read_repo repository-  either_them <- get_patch_bundle opts ps-  them <- case either_them of-          Right (Sealed t) -> return t-          Left er -> do forwarded <- consider_forwarding opts ps+  either_them <- getPatchBundle opts ps+  Sealed them+     <- case either_them of+          Right t -> return t+          Left er -> do forwarded <- considerForwarding opts ps                         if forwarded                           then exitWith ExitSuccess                           else fail er@@ -131,47 +156,57 @@                                 then cannotApplyPartialRepo pinfo ""                                 else cannotApplyMissing pinfo                          Right x -> return x-  when (null $ unsafeUnRL $ head $ unsafeUnRL them') $+  let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch "+                                                          ++"bundle, since we're missing:") $$))+                 $ reverseRL them'+  (hadConflicts, Sealed their_ps_filtered) <- filterOutConflicts opts us' repository their_ps+  when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."+  when (nullFL their_ps_filtered) $        do putStr $ "All these patches have already been applied.  " ++                      "Nothing to do.\n"           exitWith ExitSuccess-  let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch "-                                                          ++"bundle, since we're missing:") $$))-                 $ reverseRL $ head $ unsafeUnRL them'-  with_selected_changes "apply" fixed_opts their_ps $-                            \ (to_be_applied:>_) -> do-   print_dry_run_message_and_exit "apply" opts to_be_applied+  with_selected_changes "apply" fixed_opts Nothing their_ps_filtered $+                            \ (to_be_applied:>_) ->+                                applyItNow opts from_whom repository us' to_be_applied+    where fixed_opts = if Interactive `elem` opts+                         then opts+                         else All : opts+applyCmd _ _ = impossible++applyItNow :: FORALL(p r u t x y z) RepoPatch p =>+             [DarcsFlag] -> String -> Repository p C(r u t)+           -> RL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x z) -> IO ()+applyItNow opts from_whom repository us' to_be_applied = do+   printDryRunMessageAndExit "apply" opts to_be_applied    when (nullFL to_be_applied) $         do putStrLn "You don't want to apply any patches, so I'm exiting!"            exitWith ExitSuccess    check_paths opts to_be_applied-   redirect_output opts from_whom $ do-    when am_verbose $ putStrLn "We have the following extra patches:"-    when am_verbose $ putDocLn $ vcat $ mapRL description $ head $ unsafeUnRL us'-    when am_verbose $ putStrLn "Will apply the following patches:"-    when am_verbose $ putDocLn $ vcat $ mapFL description to_be_applied+   redirectOutput opts from_whom $ do+    putVerbose opts $ text "We have the following extra patches:"+    putVerbose opts . vcat $ mapRL description us'+    putVerbose opts $ text "Will apply the following patches:"+    putVerbose opts . vcat $ mapFL description to_be_applied     definePatches to_be_applied     Sealed pw <- tentativelyMergePatches repository "apply" opts-                 (reverseRL $ head $ unsafeUnRL us') to_be_applied+                 (reverseRL us') to_be_applied     invalidateIndex repository     withSignalsBlocked $ do finalizeRepositoryChanges repository-                            wait_a_moment -- so work will be more recent than rec                             applyToWorking repository opts pw `catch` \e ->                                 fail ("Error applying patch to working dir:\n" ++ show e)-    sync_repo repository     putStrLn "Finished applying..."-     where fixed_opts = if Interactive `elem` opts-                        then opts-                        else All : opts-           cannotApplyMissing pinfo-               = errorDoc $ text "Cannot apply this patch bundle, since we're missing:"-                         $$ human_friendly pinfo-           cannotApplyPartialRepo pinfo e-               = errorDoc $ text ("Cannot apply this patch bundle, "-                               ++ "this is a \"--partial repository")-                         $$ text "We don't have the following patch:"-                         $$ human_friendly pinfo $$ text e-apply_cmd _ _ = impossible++cannotApplyMissing :: PatchInfo -> a+cannotApplyMissing pinfo+    = errorDoc $ text "Cannot apply this patch bundle, since we're missing:"+      $$ human_friendly pinfo++cannotApplyPartialRepo :: PatchInfo -> String -> a+cannotApplyPartialRepo pinfo e+    = errorDoc $ text ("Cannot apply this patch bundle, "+                       ++ "this is a \"--partial repository")+      $$ text "We don't have the following patch:"+             $$ human_friendly pinfo $$ text e \end{code}  Darcs apply accepts a single argument, which is the name of the patch@@ -184,14 +219,11 @@ --verify \end{options} -If you specify the \verb!--verify PUBRING! option, darcs will check that-the patch was GPG-signed by a key which is in \verb!PUBRING! and will-refuse to apply the patch otherwise.- \begin{code}-get_patch_bundle :: RepoPatch p => [DarcsFlag] -> B.ByteString++getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString                  -> IO (Either String (SealedPatchSet p))-get_patch_bundle opts fps = do+getPatchBundle opts fps = do     mps <- verifyPS opts $ read_email fps     mops <- verifyPS opts fps     case (mps, mops) of@@ -216,81 +248,28 @@                 stripline p | B.null p = p                             | BC.last p == '\r' = B.init p                             | otherwise = p-\end{code} -\begin{options}---cc, --reply-\end{options}--If you give the \verb!--reply FROM! option to \verb!darcs apply!, it will send the-results of the application to the sender of the patch.  This only works if-the patch is in the form of email with its headers intact, so that darcs-can actually know the origin of the patch.  The reply email will indicate-whether or not the patch was successfully applied.  The \verb!FROM! flag is-the email address that will be used as the ``from'' address when replying.-If the darcs apply is being done automatically, it is important that this-address not be the same as the address at which the patch was received, in-order to avoid automatic email loops.--If you want to also send the apply email to another address (for example,-to create something like a ``commits'' mailing list), you can use the-\verb!--cc! option to specify additional recipients.  Note that the-\verb!--cc! option \emph{requires} the \verb!--reply! option, which-provides the ``From'' address.--The \verb!--reply! feature of apply is intended primarily for two uses.-When used by itself, it is handy for when you want to apply patches sent to-you by other developers so that they will know when their patch has been-applied.  For example, in my \verb!.muttrc! (the config file for my mailer)-I have:-\begin{verbatim}-macro pager A "<pipe-entry>darcs apply --verbose \-        --reply droundy@abridgegame.org --repodir ~/darcs-\end{verbatim}-which allows me to apply a patch to darcs directly from my mailer, with the-originator of that patch being sent a confirmation when the patch is-successfully applied.  NOTE: In an attempt to make sure no one else-can read your email, mutt seems to set the umask-such that patches created with the above macro are not world-readable, so-use it with care.--When used in combination with the \verb!--verify! option, the-\verb!--reply! option allows for a nice pushable repository.  When these-two options are used together, any patches that don't pass the verify will-be forwarded to the \verb!FROM! address of the \verb!--reply! option.  This-allows you to set up a repository so that anyone who is authorized can push-to it and have it automatically applied, but if a stranger pushes to it,-the patch will be forwarded to you.  Please (for your own sake!)\ be certain-that the \verb!--reply FROM! address is different from the one used to send-patches to a pushable repository, since otherwise an unsigned patch will be-forwarded to the repository in an infinite loop.--If you use \verb!darcs apply --verify PUBRING --reply! to create a-pushable repository by applying patches automatically as they are received by-email, you will also want to use the \verb!--dont-allow-conflicts! option.--\begin{options}---dont-allow-conflicts-\end{options}-The \verb!--dont-allow-conflicts! flag causes apply to fail when applying a-patch would cause conflicts.  This flag is recommended on repositories-which will be pushed to or sent to.--\begin{options}---allow-conflicts-\end{options}--\verb!--allow-conflicts! will allow conflicts, but will keep the local and-recorded versions in sync on the repository.  This means the conflict will exist-in both locations until it is resolved.--\begin{options}---mark-conflicts-\end{options}--\verb!--mark-conflicts! will add conflict markers to illustrate the the-conflict.+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 --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" +\end{code} \begin{options} --external-merge \end{options}@@ -300,16 +279,6 @@ subsection~\ref{resolution}.  \begin{options}---all, --interactive-\end{options}--If you provide the \verb!--interactive! flag, darcs will-ask you for each change in the patch bundle whether or not you wish to-apply that change.  The opposite is the \verb!--all! flag, which can be-used to override an \verb!interactive! which might be set in your-``defaults'' file.--\begin{options} --sendmail-command \end{options} @@ -326,17 +295,17 @@   \begin{code}-get_from :: B.ByteString -> String-get_from ps = readFrom $ linesPS ps+getFrom :: B.ByteString -> String+getFrom ps = readFrom $ linesPS ps     where readFrom [] = ""           readFrom (x:xs)-           | B.take 5 x == from_start = BC.unpack $ B.drop 5 x+           | B.take 5 x == fromStart = BC.unpack $ B.drop 5 x            | otherwise = readFrom xs -redirect_output :: [DarcsFlag] -> String -> IO a -> IO a-redirect_output opts to doit = ro opts+redirectOutput :: [DarcsFlag] -> String -> IO a -> IO a+redirectOutput opts to doit = ro opts     where-  cc = get_cc opts+  cc = getCc opts   ro [] = doit   ro (Reply f:_) =     withStdoutTemp $ \tempf-> do {a <- doit;@@ -362,7 +331,7 @@ -- To:, Subject:, CC:, and mail body sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO () sendSanitizedEmail opts file to subject cc mailtext =-    do scmd <- get_sendmail_cmd opts+    do scmd <- getSendmailCmd opts        body <- sanitizeFile mailtext        sendEmail file to subject cc scmd body @@ -384,25 +353,25 @@ throwIO :: Exception -> IO a throwIO e = return $ throw e -forwarding_message :: B.ByteString-forwarding_message = BC.pack $+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" -consider_forwarding :: [DarcsFlag] -> B.ByteString -> IO Bool-consider_forwarding opts m = cf opts (get_cc opts)+considerForwarding :: [DarcsFlag] -> B.ByteString -> IO Bool+considerForwarding opts m = cf opts (getCc opts)     where cf [] _ = return False           cf (Reply t:_) cc =               case break is_from (linesPS m) of               (m1, f:m2) ->-                  let m_lines = forwarding_message:m1 ++ m2+                  let m_lines = forwardingMessage:m1 ++ m2                       m' = unlinesPS m_lines                       f' = BC.unpack (B.drop 5 f) in                       if t == f' || t == init f'                       then return False -- Refuse possible email loop.                       else do-                        scmd <- get_sendmail_cmd opts-                        if HappyForwarding `elem` opts+                        scmd <- getSendmailCmd opts+                        if doHappyForwarding opts                          then resendEmail t scmd m                          else sendEmailDoc f' t "A forwarded darcs patch" cc                                            scmd (Just (empty,empty))@@ -410,22 +379,8 @@                         return True               _ -> return False -- Don't forward emails lacking headers!           cf (_:fs) cc = cf fs cc-          is_from l = B.take 5 l == from_start+          is_from l = B.take 5 l == fromStart -from_start :: B.ByteString-from_start = BC.pack "From:"+fromStart :: B.ByteString+fromStart = BC.pack "From:" \end{code}--\begin{options}---no-test, --test-\end{options}--If you specify the \verb!--test! option, apply will run the test (if a test-exists) prior to applying the patch.  If the test fails, the patch is not-applied.  In this case, if the \verb!--reply! option was used, the results-of the test are sent in the reply email.  You can also specify the-\verb!--no-test! option, which will override the \verb!--test! option, and-prevent the test from being run.  This is helpful when setting up a-pushable repository, to keep users from running code.--
src/Darcs/Commands/Changes.lhs view
@@ -20,7 +20,8 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts #-} {-# LANGUAGE CPP, PatternGuards #-} -module Darcs.Commands.Changes ( changes ) where+module Darcs.Commands.Changes ( changes, log ) where+import Prelude hiding ( log )  import Data.List ( intersect, sort ) import Data.Maybe ( fromMaybe )@@ -28,93 +29,96 @@  import Darcs.Hopefully ( hopefullyM, info ) import Darcs.Patch.Depends ( slightly_optimize_patchset )-import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) import Darcs.Arguments ( DarcsFlag(Context, HumanReadable, MachineReadable,-                                   Interactive, OnlyChangesToFiles, Count,+                                   Interactive, Count,                                    NumberPatches, XMLOutput, Summary,-                                   Reverse, Verbose, Debug),-                         fixSubPaths, changes_format,-                         possibly_remote_repo_dir, get_repourl,-                         working_repo_dir, only_to_files,-                         summary, changes_reverse,-                         match_several_or_range,-                         match_maxcount, maxCount,-                         all_interactive, showFriendly,-                         network_options+                                   Verbose, Debug),+                         fixSubPaths, changesFormat,+                         possiblyRemoteRepoDir, getRepourl,+                         workingRepoDir, onlyToFiles,+                         summary, changesReverse,+                         matchSeveralOrRange,+                         matchMaxcount, maxCount,+                         allInteractive, showFriendly,+                         networkOptions                       )+import Darcs.Flags ( doReverse, showChangesOnlyToFiles ) import Darcs.RepoPath ( toFilePath, rootDirectory ) import Darcs.Patch.FileName ( fp2fn, fn2fp, norm_path ) import Darcs.Repository ( Repository, PatchSet, PatchInfoAnd,-                          get_unrecorded_in_files_unsorted,                           withRepositoryDirectory, ($-), findRepository,-                          read_repo )+                          read_repo, unrecordedChanges ) import Darcs.Patch.Info ( to_xml, showPatchInfo ) import Darcs.Patch.Depends ( get_common_and_uncommon ) import Darcs.Patch.TouchesFiles ( look_touch )-import Darcs.Patch ( RepoPatch, invert, xml_summary, description, apply_to_filepaths,-                     list_touched_files, effect, identity )-import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL,+import Darcs.Patch ( RepoPatch, invert, xmlSummary, description, applyToFilepaths,+                     listTouchedFiles, effect, identity )+import Darcs.Witnesses.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL,                              EqCheck(..), filterFL )-import Darcs.Match ( first_match, second_match,-               match_a_patchread, have_nonrange_match,-               match_first_patchset, match_second_patchset,+import Darcs.Match ( firstMatch, secondMatch,+               matchAPatchread, haveNonrangeMatch,+               matchFirstPatchset, matchSecondPatchset,              )-import Darcs.Commands.Annotate ( created_as_xml )+import Darcs.Commands.Annotate ( createdAsXml ) import Printer ( Doc, putDocLnWith, simplePrinters, (<+>),                  renderString, prefix, text, vcat, vsep,                   ($$), empty, errorDoc, insert_before_lastline ) import Darcs.ColorPrinter ( fancyPrinters ) import Progress ( setProgressMode, debugMessage ) import Darcs.SelectChanges ( view_changes )-import Darcs.Sealed ( unsafeUnseal )+import Darcs.Witnesses.Sealed ( unsafeUnseal ) #include "impossible.h" -changes_description :: String-changes_description = "Gives a changelog-style summary of the repository history."+changesDescription :: String+changesDescription = "List patches in the repository." -changes_help :: String-changes_help =- "Changes gives a changelog-style summary of the repository history,\n"++- "including options for altering how the patches are selected and displayed.\n"+changesHelp :: String+changesHelp =+ "The `darcs changes' command lists the patches that constitute the\n" +++ "current repository or, with --repo, a remote repository.  Without\n" +++ "options or arguments, ALL patches will be listed.\n" +++ "\n" ++ changesHelp' +++ "\n" ++ changesHelp''  changes :: DarcsCommand-changes = DarcsCommand {command_name = "changes",-                        command_help = changes_help,-                        command_description = changes_description,-                        command_extra_args = -1,-                        command_extra_arg_help = ["[FILE or DIRECTORY]..."],-                        command_get_arg_possibilities = return [],-                        command_command = changes_cmd,-                        command_prereq = findRepository,-                        command_argdefaults = nodefaults,-                        command_advanced_options = network_options,-                        command_basic_options = [match_several_or_range,-                                                 match_maxcount,-                                                 only_to_files,-                                                 changes_format,+changes = DarcsCommand {commandName = "changes",+                        commandHelp = changesHelp,+                        commandDescription = changesDescription,+                        commandExtraArgs = -1,+                        commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+                        commandGetArgPossibilities = return [],+                        commandCommand = changesCmd,+                        commandPrereq = findRepository,+                        commandArgdefaults = nodefaults,+                        commandAdvancedOptions = networkOptions,+                        commandBasicOptions = [matchSeveralOrRange,+                                                 matchMaxcount,+                                                 onlyToFiles,+                                                 changesFormat,                                                  summary,-                                                 changes_reverse,-                                                 possibly_remote_repo_dir,-                                                 working_repo_dir,-                                                 all_interactive]}+                                                 changesReverse,+                                                 possiblyRemoteRepoDir,+                                                 workingRepoDir,+                                                 allInteractive]} -changes_cmd :: [DarcsFlag] -> [String] -> IO ()-changes_cmd [Context _] [] = return ()-changes_cmd opts args | Context rootDirectory `elem` opts =-  let repodir = fromMaybe "." (get_repourl opts) in+changesCmd :: [DarcsFlag] -> [String] -> IO ()+changesCmd [Context _] [] = return ()+changesCmd opts args | Context rootDirectory `elem` opts =+  let repodir = fromMaybe "." (getRepourl opts) in   withRepositoryDirectory opts repodir $- \repository -> do   when (args /= []) $ fail "changes --context cannot accept other arguments"-  changes_context repository opts-changes_cmd opts args =-  let repodir = fromMaybe "." (get_repourl opts) in+  changesContext repository opts+changesCmd opts args =+  let repodir = fromMaybe "." (getRepourl opts) in   withRepositoryDirectory opts repodir $- \repository -> do   unless (Debug `elem` opts) $ setProgressMode False   files <- sort `fmap` fixSubPaths opts args   unrec <- if null files then return identity-             else get_unrecorded_in_files_unsorted repository (map (fp2fn . toFilePath) files)+             else unrecordedChanges opts repository files            `catch` \_ -> return identity -- this is triggered when repository is remote-  let filez = map (fn2fp . norm_path . fp2fn) $ apply_to_filepaths (invert unrec) $ map toFilePath files-      filtered_changes p = maybe_reverse $ get_changes_info opts filez p+  let filez = map (fn2fp . norm_path . fp2fn) $ applyToFilepaths (invert unrec) $ map toFilePath files+      filtered_changes p = maybe_reverse $ getChangesInfo opts filez p   debugMessage "About to read the repository..."   patches <- read_repo repository   debugMessage "Done reading the repository."@@ -129,47 +133,42 @@             ps <- read_repo repository -- read repo again to prevent holding onto                                        -- values forced by filtered_changes             putDocLnWith printers $ changelog opts ps $ filtered_changes patches-  where maybe_reverse (xs,b,c) = if Reverse `elem` opts+  where maybe_reverse (xs,b,c) = if doReverse opts                                  then (reverse xs, b, c)                                  else (xs, b, c)-\end{code} -When given one or more files or directories as an argument, changes lists only-those patches which affect those files or the contents of those directories or,-of course, the directories themselves. This includes changes that happened to-files before they were moved or renamed. -\begin{options}---from-match, --from-patch, --from-tag-\end{options}--If changes is given a \verb!--from-patch!, \verb!--from-match!, or-\verb!--from-tag! option, it outputs only those changes since that tag or-patch.--Without any options to limit the scope of the changes, history will be displayed-going back as far as possible.--\begin{options}---max-count-\end{options}--If changes is given a \verb!--max-count! option, it only outputs up to as that-number of changes.+-- FIXME: this prose is unreadable. --twb, 2009-08+changesHelp' :: String+changesHelp' =+ "When given one or more files or directories as arguments, only\n" +++ "patches which affect those files or directories are listed. This\n" +++ "includes changes that happened to files before they were moved or\n" +++ "renamed.\n" +++ "\n" +++ "When given a --from-tag, --from-patch or --from-match, only changes\n" +++ "since that tag or patch are listed.  Similarly, the --to-tag,\n" +++ "--to-patch and --to-match options restrict the list to older patches.\n" +++ "\n" +++ "The --last and --max-count options both limit the number of patches\n" +++ "listed.  The former applies BEFORE other filters, whereas the latter\n" +++ "applies AFTER other filters.  For example `darcs changes foo.c\n" +++ "--max-count 3' will print the last three patches that affect foo.c,\n" +++ "whereas `darcs changes --last 3 foo.c' will, of the last three\n" +++ "patches, print only those that affect foo.c.\n" -\begin{code}-get_changes_info :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p+getChangesInfo :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p                  -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)-get_changes_info opts plain_fs ps =+getChangesInfo opts plain_fs ps =   case get_common_and_uncommon (p2s,p1s) of-  (_,us:\/:_) -> filter_patches_by_names (maxCount opts) fs $ filter pf $ unsafeUnRL $ concatRL us+  (_,us:\/:_) -> filterPatchesByNames (maxCount opts) fs $ filter pf $ unsafeUnRL us   where fs = map (\x -> "./" ++ x) $ plain_fs-        p1s = if first_match opts then unsafeUnseal $ match_first_patchset opts ps+        p1s = if firstMatch opts then unsafeUnseal $ matchFirstPatchset opts ps                                   else NilRL:<:NilRL-        p2s = if second_match opts then unsafeUnseal $ match_second_patchset opts ps+        p2s = if secondMatch opts then unsafeUnseal $ matchSecondPatchset opts ps                                    else ps-        pf = if have_nonrange_match opts-             then match_a_patchread opts+        pf = if haveNonrangeMatch opts+             then matchAPatchread opts              else \_ -> True  -- | Take a list of filenames and patches and produce a list of@@ -180,30 +179,30 @@ -- limit" -- maxcount, that could be Nothing (return everything) or -- "Just n" -- returns at most n patches touching the file (starting -- from the beginning of the patch list).-filter_patches_by_names :: RepoPatch p =>+filterPatchesByNames :: RepoPatch p =>                            Maybe Int -- ^ maxcount                         -> [FilePath] -- ^ filenames                         -> [PatchInfoAnd p] -- ^ patchlist                         -> ([(PatchInfoAnd p,[FilePath])], [FilePath], Doc)-filter_patches_by_names (Just 0) _ _ = ([], [], empty)-filter_patches_by_names _ _ [] = ([], [], empty)-filter_patches_by_names maxcount [] (hp:ps) =-    (hp, []) -:- filter_patches_by_names (subtract 1 `fmap` maxcount) [] ps-filter_patches_by_names maxcount fs (hp:ps)+filterPatchesByNames (Just 0) _ _ = ([], [], empty)+filterPatchesByNames _ _ [] = ([], [], empty)+filterPatchesByNames maxcount [] (hp:ps) =+    (hp, []) -:- filterPatchesByNames (subtract 1 `fmap` maxcount) [] ps+filterPatchesByNames maxcount fs (hp:ps)     | Just p <- hopefullyM hp =     case look_touch fs (invert p) of     (True, []) -> ([(hp, fs)], fs, empty)-    (True, fs') -> (hp, fs) -:- filter_patches_by_names+    (True, fs') -> (hp, fs) -:- filterPatchesByNames                                 (subtract 1 `fmap` maxcount) fs' ps-    (False, fs') -> filter_patches_by_names maxcount fs' ps-filter_patches_by_names _ _ (hp:_) =+    (False, fs') -> filterPatchesByNames maxcount fs' ps+filterPatchesByNames _ _ (hp:_) =     ([], [], text "Can't find changes prior to:" $$ description hp)  -- | Note, lazy pattern matching is required to make functions like--- filter_patches_by_names lazy in case you are only not interested in+-- filterPatchesByNames lazy in case you are only not interested in -- the first element. E.g.: -----   let (fs, _, _) = filter_patches_by_names ...+--   let (fs, _, _) = filterPatchesByNames ... (-:-) :: a -> ([a],b,c) -> ([a],b,c) x -:- ~(xs,y,z) = (x:xs,y,z) @@ -226,25 +225,25 @@     | otherwise = vsep (map (number_patch description') pis_and_fs)                $$ errstring     where change_with_summary (hp, fs)-              | Just p <- hopefullyM hp = if OnlyChangesToFiles `elem` opts+              | Just p <- hopefullyM hp = if showChangesOnlyToFiles opts                                           then description hp $$ text "" $$                                                indent (showFriendly opts (filterFL xx $ effect p))                                           else showFriendly opts p               | otherwise = description hp                             $$ indent (text "[this patch is unavailable]")-              where xx x = case list_touched_files x of+              where xx x = case listTouchedFiles x of                              ys | null $ ys `intersect` fs -> IsEq                              _ -> NotEq           xml_with_summary hp               | Just p <- hopefullyM hp = insert_before_lastline-                                           (to_xml $ info hp) (indent $ xml_summary p)+                                           (to_xml $ info hp) (indent $ xmlSummary p)           xml_with_summary hp = to_xml (info hp)           indent = prefix "    "           actual_xml_changes = if Summary `elem` opts                                then map xml_with_summary pis                                else map (to_xml.info) pis-          xml_file_names = map (created_as_xml first_change) orig_fs-          first_change = if Reverse `elem` opts+          xml_file_names = map (createdAsXml first_change) orig_fs+          first_change = if doReverse opts                          then info $ head pis                          else info $ last pis           number_patch f x = if NumberPatches `elem` opts@@ -261,34 +260,38 @@           pis = map fst pis_and_fs           description' = description . fst -\end{code}--\begin{options}---context, --human-readable, --xml-output-\end{options}+-- FIXME: this prose is unreadable. --twb, 2009-08+changesHelp'' :: String+changesHelp'' =+ "Three output formats exist.  The default is --human-readable.  You can\n" +++ "also select --context, which is the internal format (as seen in patch\n" +++ "bundles) that can be re-read by Darcs (e.g. `darcs get --context').\n" +++ "\n" +++ "Finally, there is --xml-output, which emits valid XML... unless a the\n" +++ "patch metadata (author, name or description) contains a non-ASCII\n" +++ "character and was recorded in a non-UTF8 locale.\n" +++ "\n" +++ -- FIXME: can't we just disallow the following usage?+ "Note that while the --context flag may be used in conjunction with\n" +++ "--xml-output or --human-readable, in neither case will darcs get be\n" +++ "able to read the output.  On the other hand, sufficient information\n" +++ "WILL be output for a knowledgeable human to recreate the current state\n" +++ "of the repository.\n" -When given the \verb!--context! flag, darcs changes outputs sufficient-information to allow the current state of the repository to be-recreated at a later date.  This information should generally be piped to a-file, and then can be used later in conjunction with-\verb!darcs get --context! to recreate the current version.  Note that-while the \verb!--context! flag may be used in conjunction with-\verb!--xml-output! or \verb!--human-readable!, in neither case will darcs-get be able to read the output.  On the other hand, sufficient information-\emph{will} be output for a knowledgeable human to recreate the current-state of the repository.-\begin{code}-changes_context :: RepoPatch p => Repository p -> [DarcsFlag] -> IO ()-changes_context repository opts = do+changesContext :: RepoPatch p => Repository p -> [DarcsFlag] -> IO ()+changesContext repository opts = do   r <- read_repo repository   putStrLn "\nContext:\n"   when (not $ null (unsafeUnRL r) || null (unsafeUnRL $ head $ unsafeUnRL r)) $     putDocLnWith simplePrinters $ changelog opts' NilRL $-                 get_changes_info opts' []+                 getChangesInfo opts' []                  (headRL (slightly_optimize_patchset r) :<: NilRL)     where opts' = if HumanReadable `elem` opts || XMLOutput `elem` opts                   then opts                   else MachineReadable : opts           headRL (x:<:_) = x           headRL NilRL = impossible++log :: DarcsCommand+log = commandAlias "log" changes \end{code}
src/Darcs/Commands/Check.lhs view
@@ -19,28 +19,33 @@ \begin{code} module Darcs.Commands.Check ( check ) where import Control.Monad ( when )+import Control.Applicative( (<$>) ) import System.Exit ( ExitCode(..), exitWith ) -import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag( Quiet ),-                        partial_check, notest, testByDefault,-                        leave_test_dir, working_repo_dir,+++import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )+import Darcs.Arguments ( DarcsFlag(Quiet),+                        partialCheck, notest, testByDefault,+                        leaveTestDir, workingRepoDir, ignoretimes                       )-import Darcs.Repository.Repair( replayRepository,-                              RepositoryConsistency(..) )-import Darcs.Repository ( Repository, amInRepository, withRepository, slurp_recorded,-                          testRecorded )+import Darcs.Flags(willIgnoreTimes)+import Darcs.Repository.Repair( replayRepository, checkIndex+                              , RepositoryConsistency(..) )+import Darcs.Repository ( Repository, amInRepository, withRepository,+                          testRecorded, readRecorded ) import Darcs.Patch ( RepoPatch, showPatch )-import Darcs.Ordered ( FL(..) )-import Darcs.Diff ( unsafeDiff )-import Darcs.Repository.Prefs ( filetype_function )-import Printer ( putDocLn, text, ($$), (<+>) )+import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.Diff( treeDiff )+import Printer ( text, ($$), (<+>) ) -check_description :: String-check_description = "Check the repository for consistency." -check_help :: String-check_help =+checkDescription :: String+checkDescription = "Check the repository for consistency."++checkHelp :: String+checkHelp =  "This command verifies that the patches in the repository, when applied\n" ++  "successively to an empty tree, result in the pristine tree.  If not,\n" ++  "the differences are printed and Darcs exits unsucessfully (with a\n" ++@@ -55,51 +60,57 @@  "by `darcs check'.  Use the --no-test option to disable this.\n"  check :: DarcsCommand-check = DarcsCommand {command_name = "check",-                      command_help = check_help,-                      command_description = check_description,-                      command_extra_args = 0,-                      command_extra_arg_help = [],-                      command_command = check_cmd,-                      command_prereq = amInRepository,-                      command_get_arg_possibilities = return [],-                      command_argdefaults = nodefaults,-                      command_advanced_options = [],-                      command_basic_options = [partial_check,+check = DarcsCommand {commandName = "check",+                      commandHelp = checkHelp,+                      commandDescription = checkDescription,+                      commandExtraArgs = 0,+                      commandExtraArgHelp = [],+                      commandCommand = checkCmd,+                      commandPrereq = amInRepository,+                      commandGetArgPossibilities = return [],+                      commandArgdefaults = nodefaults,+                      commandAdvancedOptions = [],+                      commandBasicOptions = [partialCheck,                                               notest,-                                              leave_test_dir,-                                              working_repo_dir+                                              leaveTestDir,+                                              workingRepoDir,+                                               ignoretimes                                              ]} -check_cmd :: [DarcsFlag] -> [String] -> IO ()-check_cmd opts _ = withRepository opts (check' opts)+checkCmd :: [DarcsFlag] -> [String] -> IO ()+checkCmd opts _ = withRepository opts (check' opts)  check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO () check' opts repository = do-    replayRepository repository (testByDefault opts) $ \ state -> do+    failed <- replayRepository repository (testByDefault opts) $ \ state -> do       case state of         RepositoryConsistent -> do-          putInfo $ text "The repository is consistent!"+          putInfo opts $ text "The repository is consistent!"           testRecorded repository-          exitWith ExitSuccess+          return False         BrokenPristine newpris -> do           brokenPristine newpris-          exitWith $ ExitFailure 1+          return True         BrokenPatches newpris _ -> do           brokenPristine newpris-          putInfo $ text "Found broken patches."-          exitWith $ ExitFailure 1-   where +          putInfo opts $ text "Found broken patches."+          return True+    bad_index <- case willIgnoreTimes opts of+                   False -> not <$> checkIndex repository (Quiet `elem` opts)+                   True -> return False+    when bad_index $ putInfo opts $ text "Bad index."+    exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess+   where      brokenPristine newpris = do-         putInfo $ text "Looks like we have a difference..."-         mc <- slurp_recorded repository-         ftf <- filetype_function-         putInfo $ case unsafeDiff opts ftf newpris mc of+         putInfo opts $ text "Looks like we have a difference..."+         mc <- readRecorded repository+         ftf <- filetypeFunction+         diff <- treeDiff ftf newpris mc+         putInfo opts $ case diff of                         NilFL -> text "Nothing"                         patch -> text "Difference: " <+> showPatch patch-         putInfo $ text ""+         putInfo opts $ text ""                      $$ text "Inconsistent repository!"-     putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s  \end{code} %% FIXME: this should go in "common options" or something, since
src/Darcs/Commands/Convert.lhs view
@@ -33,47 +33,46 @@ import Data.Maybe ( catMaybes )  import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully )-import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo, putVerbose ) import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo,-                                    SetScriptsExecutable, UseFormat2, NoUpdateWorking,-                                    Verbose, Quiet ),+                                    SetScriptsExecutable, UseFormat2, NoUpdateWorking),                         reponame,-                        set_scripts_executable,-                        network_options )+                        setScriptsExecutableOption,+                        networkOptions ) import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo,-                          createRepository,+                          createRepository, invalidateIndex,                           slurp_recorded, optimizeInventory,                           tentativelyMergePatches, patchSetToPatches,                           createPristineDirectoryTree,-                          revertRepositoryChanges, finalizeRepositoryChanges, sync_repo )+                          revertRepositoryChanges, finalizeRepositoryChanges ) import Darcs.Global ( darcsdir ) import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch,-                     modernize_patch,-                     adddeps, getdeps, effect, flattenFL, is_merger, patchcontents )-import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL,+                     modernizePatch,+                     adddeps, getdeps, effect, flattenFL, isMerger, patchcontents )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL,                              concatFL, concatRL, mapRL ) import Darcs.Patch.Info ( pi_rename, pi_tag, is_tag ) import Darcs.Patch.Commute ( public_unravel ) import Darcs.Patch.Real ( mergeUnravelled ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )+import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2)) import Darcs.Repository.Motd ( show_motd )-import Darcs.Utils ( clarify_errors, askUser )+import Darcs.Utils ( clarifyErrors, askUser ) import Darcs.ProgressPatches ( progressFL )-import Darcs.Sealed ( FlippedSeal(..) )-import Printer ( text, putDocLn, ($$) )+import Darcs.Witnesses.Sealed ( FlippedSeal(..) )+import Printer ( text, ($$) ) import Darcs.ColorPrinter ( traceDoc ) import Darcs.SlurpDirectory ( list_slurpy_files ) import Darcs.Lock ( writeBinFile ) import Workaround ( setExecutable ) import qualified Data.ByteString as B (isPrefixOf, readFile) import qualified Data.ByteString.Char8 as BC (pack)-import Darcs.Gorsvet( invalidateIndex ) -convert_description :: String-convert_description = "Convert a repository from a legacy format."+convertDescription :: String+convertDescription = "Convert a repository from a legacy format." -convert_help :: String-convert_help =+convertHelp :: String+convertHelp =  "The current repository format is called `darcs-2'.  It was introduced\n" ++  "in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" ++  "The `darcs convert' command allows existing projects to migrate to\n" ++@@ -83,7 +82,7 @@  "repository is created.  It is safe to run this command more than once\n" ++  "on a repository (e.g. for testing), before the final conversion.\n" ++  "\n" ++- convert_help' +++ convertHelp' ++  "\n" ++  "Due to this limitation, migrating a multi-branch project is a little\n" ++  "awkward.  Sorry!  Here is the recommended process:\n" ++@@ -98,8 +97,8 @@  -- | This part of the help is split out because it is used twice: in -- the help string, and in the prompt for confirmation.-convert_help' :: String-convert_help' =+convertHelp' :: String+convertHelp' =  "WARNING: the repository produced by this command is not understood by\n" ++  "Darcs 1.x, and patches cannot be exchanged between repositories in\n" ++  "darcs-1 and darcs-2 formats.\n" ++@@ -111,31 +110,38 @@  "than once.)\n"  convert :: DarcsCommand-convert = DarcsCommand {command_name = "convert",-                    command_help = convert_help,-                    command_description = convert_description,-                    command_extra_args = -1,-                    command_extra_arg_help = ["<SOURCE>", "[<DESTINATION>]"],-                    command_command = convert_cmd,-                    command_prereq = \_ -> return $ Right (),-                    command_get_arg_possibilities = return [],-                    command_argdefaults = nodefaults,-                    command_advanced_options = network_options,-                    command_basic_options = [reponame,set_scripts_executable]}+convert = DarcsCommand {commandName = "convert",+                    commandHelp = convertHelp,+                    commandDescription = convertDescription,+                    commandExtraArgs = -1,+                    commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"],+                    commandCommand = convertCmd,+                    commandPrereq = \_ -> return $ Right (),+                    commandGetArgPossibilities = return [],+                    commandArgdefaults = nodefaults,+                    commandAdvancedOptions = networkOptions,+                    commandBasicOptions = [reponame,setScriptsExecutableOption]} -convert_cmd :: [DarcsFlag] -> [String] -> IO ()-convert_cmd opts [inrepodir, outname] = convert_cmd (NewRepo outname:opts) [inrepodir]-convert_cmd orig_opts [inrepodir] = do-  putStrLn convert_help'+convertCmd :: [DarcsFlag] -> [String] -> IO ()+convertCmd opts [inrepodir, outname] = convertCmd (NewRepo outname:opts) [inrepodir]+convertCmd orig_opts [inrepodir] = do+  +  typed_repodir <- ioAbsoluteOrRemote inrepodir+  let repodir = toPath typed_repodir+  +  --test for converting darcs-2 repository+  Right format <- identifyRepoFormat repodir -- just fail in case of error +  when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."+    +  putStrLn convertHelp'   let vow = "I understand the consequences of my action"   putStrLn "Please confirm that you have read and understood the above"   vow' <- askUser ("by typing `" ++ vow ++ "': ")   when (vow' /= vow) $ fail "User didn't understand the consequences."+     let opts = UseFormat2:orig_opts-  typed_repodir <- ioAbsoluteOrRemote inrepodir-  let repodir = toPath typed_repodir   show_motd opts repodir-  mysimplename <- make_repo_name opts repodir+  mysimplename <- makeRepoName opts repodir   createDirectory mysimplename   setCurrentDirectory mysimplename   createRepository opts@@ -170,7 +176,7 @@                      Just d -> p : concatMap fixDep d                      Nothing -> [p]           convertOne :: Patch -> FL RealPatch-          convertOne x | is_merger x = case mergeUnravelled $ public_unravel $ modernize_patch x of+          convertOne x | isMerger x = case mergeUnravelled $ public_unravel $ modernizePatch x of                                        Just (FlippedSeal y) ->                                            case effect y =/\= effect x of                                            IsEq -> y :>: NilFL@@ -200,45 +206,40 @@       invalidateIndex repository       revertable $ createPristineDirectoryTree repository "."       when (SetScriptsExecutable `elem` opts) $-               do putVerbose $ text "Making scripts executable"+               do putVerbose opts $ text "Making scripts executable"                   c <- list_slurpy_files `fmap` slurp_recorded repository                   let setExecutableIfScript f =                             do contents <- B.readFile f                                when (BC.pack "#!" `B.isPrefixOf` contents) $ do-                                 putVerbose $ text ("Making executable: " ++ f)+                                 putVerbose opts $ text ("Making executable: " ++ f)                                  setExecutable f True                   mapM_ setExecutableIfScript c-      sync_repo repository       optimizeInventory repository-      putInfo $ text "Finished converting."-      where am_verbose = Verbose `elem` orig_opts-            am_informative = not $ Quiet `elem` orig_opts-            putVerbose s = when am_verbose $ putDocLn s-            putInfo s = when am_informative $ putDocLn s-            revertable x = x `clarify_errors` unlines+      putInfo opts $ text "Finished converting."+      where revertable x = x `clarifyErrors` unlines                   ["An error may have left your new working directory an inconsistent",                    "but recoverable state. You should be able to make the new",                    "repository consistent again by running darcs revert -a."] -convert_cmd _ _ = fail "You must provide 'convert' with either one or two arguments."+convertCmd _ _ = fail "You must provide 'convert' with either one or two arguments." -make_repo_name :: [DarcsFlag] -> FilePath -> IO String-make_repo_name (NewRepo n:_) _ =+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-make_repo_name (_:as) d = make_repo_name as d-make_repo_name [] d =+makeRepoName (_:as) d = makeRepoName as d+makeRepoName [] d =   case dropWhile (=='.') $ reverse $        takeWhile (\c -> c /= '/' && c /= ':') $        dropWhile (=='/') $ reverse d of-  "" -> modify_repo_name "anonymous_repo"-  base -> modify_repo_name base+  "" -> modifyRepoName "anonymous_repo"+  base -> modifyRepoName base -modify_repo_name :: String -> IO String-modify_repo_name name =+modifyRepoName :: String -> IO String+modifyRepoName name =     if head name == '/'     then mrn name (-1)     else do cwd <- getCurrentDirectory
src/Darcs/Commands/Diff.lhs view
@@ -20,7 +20,7 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Commands.Diff ( diff_command ) where+module Darcs.Commands.Diff ( diffCommand ) where  import System.FilePath.Posix ( takeFileName ) import System.Directory ( setCurrentDirectory )@@ -32,58 +32,61 @@ import Darcs.External( diff_program ) import CommandLine ( parseCmd ) import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(DiffFlags, Unified, DiffCmd,+import Darcs.Arguments ( DarcsFlag(DiffFlags, DiffCmd,                                    LastN, AfterPatch),-                        match_range, store_in_memory, -                        diff_cmd_flag, diffflags, unidiff,-                         working_repo_dir, fixSubPaths,+                        matchRange, storeInMemory, +                        diffCmdFlag, diffflags, unidiff,+                         workingRepoDir, fixSubPaths,                       )+import Darcs.Flags ( isUnified ) import Darcs.Hopefully ( info ) import Darcs.RepoPath ( toFilePath, sp2fn )-import Darcs.Match ( get_partial_first_match, get_partial_second_match,-                     first_match, second_match,-                     match_first_patchset, match_second_patchset )+import Darcs.Match ( getPartialFirstMatch, getPartialSecondMatch,+                     firstMatch, secondMatch,+                     matchFirstPatchset, matchSecondPatchset ) import Darcs.Repository ( PatchSet, withRepository, ($-), read_repo,                           amInRepository, slurp_recorded_and_unrecorded,                           createPristineDirectoryTree,                           createPartialsPristineDirectoryTree ) import Darcs.SlurpDirectory ( get_path_list, writeSlurpy ) import Darcs.Patch ( RepoPatch )-import Darcs.Ordered ( mapRL, concatRL )+import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import Darcs.Patch.Info ( PatchInfo, human_friendly ) import Darcs.External ( execPipeIgnoreError, clonePaths ) import Darcs.Lock ( withTempDir )-import Darcs.Sealed ( unsafeUnseal )+import Darcs.Witnesses.Sealed ( unseal ) import Printer ( Doc, putDoc, vcat, empty, ($$) ) #include "impossible.h" -diff_description :: String-diff_description = "Create a diff between two versions of the repository."+#include "gadts.h" -diff_help :: String-diff_help =+diffDescription :: String+diffDescription = "Create a diff between two versions of the repository."++diffHelp :: String+diffHelp =  "Diff can be used to create a diff between two versions which are in your\n"++  "repository.  Specifying just --from-patch will get you a diff against\n"++  "your working copy.  If you give diff no version arguments, it gives\n"++  "you the same information as whatsnew except that the patch is\n"++  "formatted as the output of a diff command\n" -diff_command :: DarcsCommand-diff_command = DarcsCommand {command_name = "diff",-                             command_help = diff_help,-                             command_description = diff_description,-                             command_extra_args = -1,-                             command_extra_arg_help+diffCommand :: DarcsCommand+diffCommand = DarcsCommand {commandName = "diff",+                             commandHelp = diffHelp,+                             commandDescription = diffDescription,+                             commandExtraArgs = -1,+                             commandExtraArgHelp                                  = ["[FILE or DIRECTORY]..."],-                             command_command = diff_cmd,-                             command_prereq = amInRepository,-                             command_get_arg_possibilities = return [],-                             command_argdefaults = nodefaults,-                             command_advanced_options = [],-                             command_basic_options = [match_range,-                                                     diff_cmd_flag,+                             commandCommand = diffCmd,+                             commandPrereq = amInRepository,+                             commandGetArgPossibilities = return [],+                             commandArgdefaults = nodefaults,+                             commandAdvancedOptions = [],+                             commandBasicOptions = [matchRange,+                                                     diffCmdFlag,                                                      diffflags, unidiff,-                                                     working_repo_dir, store_in_memory]}+                                                     workingRepoDir, storeInMemory]} \end{code}  \begin{options}@@ -110,31 +113,32 @@ to your \verb!_darcs/prefs/defaults! file.  \begin{code}-get_diff_opts :: [DarcsFlag] -> [String]-get_diff_opts [] = []-get_diff_opts (Unified:fs) = "-u" : get_diff_opts fs-get_diff_opts (DiffFlags f:fs) = f : get_diff_opts fs-get_diff_opts (_:fs) = get_diff_opts fs+getDiffOpts :: [DarcsFlag] -> [String]+getDiffOpts opts | isUnified opts = "-u" : get_nonU_diff_opts opts+                   | otherwise      = get_nonU_diff_opts opts+    where get_nonU_diff_opts (DiffFlags f:fs) = f : get_nonU_diff_opts fs+          get_nonU_diff_opts (_:fs) = get_nonU_diff_opts fs+          get_nonU_diff_opts [] = [] -has_diff_cmd_flag :: [DarcsFlag] -> Bool-has_diff_cmd_flag (DiffCmd _:_) = True-has_diff_cmd_flag (_:t) = has_diff_cmd_flag t-has_diff_cmd_flag []  = False+hasDiffCmdFlag :: [DarcsFlag] -> Bool+hasDiffCmdFlag (DiffCmd _:_) = True+hasDiffCmdFlag (_:t) = hasDiffCmdFlag t+hasDiffCmdFlag []  = False  -- | 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 'diff_program'.  Note that this potentially involves parsing the -- user's diff-command, hence the possibility for failure with an exception.-get_diff_cmd_and_args :: String -> [DarcsFlag] -> String -> String+getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String                       -> Either String (String, [String])-get_diff_cmd_and_args cmd opts f1 f2 = helper opts where+getDiffCmdAndArgs cmd opts f1 f2 = helper opts where   helper (DiffCmd c:_) =     case parseCmd [ ('1', f1) , ('2', f2) ] c of     Left err        -> Left $ show err     Right ([],_)    -> bug $ "parseCmd should never return empty list"     Right ((h:t),_) -> Right (h,t)   helper [] = -- if no command specified, use 'diff'-    Right (cmd, ("-rN":get_diff_opts opts++[f1,f2]))+    Right (cmd, ("-rN":getDiffOpts opts++[f1,f2]))   helper (_:t) = helper t \end{code} @@ -173,8 +177,8 @@ Note also that the \verb!--diff-opts! flag is ignored if you use this option.  \begin{code}-diff_cmd :: [DarcsFlag] -> [String] -> IO ()-diff_cmd opts args = withRepository opts $- \repository -> do+diffCmd :: [DarcsFlag] -> [String] -> IO ()+diffCmd opts args = withRepository opts $- \repository -> do   when (not (null [i | LastN i <- opts])        && not (null [p | AfterPatch p <- opts])        ) $@@ -190,15 +194,15 @@   withTempDir ("old-"++thename) $ \odir -> do     setCurrentDirectory formerdir     withTempDir ("new-"++thename) $ \ndir -> do-    if first_match opts+    if firstMatch opts        then withCurrentDirectory odir $-            get_partial_first_match repository opts path_list+            getPartialFirstMatch repository opts path_list        else if null path_list             then createPristineDirectoryTree repository (toFilePath odir)             else createPartialsPristineDirectoryTree repository path_list (toFilePath odir)-    if second_match opts+    if secondMatch opts        then withCurrentDirectory ndir $-            get_partial_second_match repository opts path_list+            getPartialSecondMatch repository opts path_list        else do (_, s) <- slurp_recorded_and_unrecorded repository                let ps = concatMap (get_path_list s . toFilePath) path_list                if null path_list@@ -212,15 +216,15 @@                                (takeFileName (toFilePath odir) ++ "/" ++ toFilePath f)                                (takeFileName (toFilePath ndir) ++ "/" ++ toFilePath f)) fs     morepatches <- read_repo repository-    putDoc $ changelog (get_diff_info opts morepatches)+    putDoc $ changelog (getDiffInfo opts morepatches)             $$ thediff     where rundiff :: String -> String -> IO Doc           rundiff f1 f2 = do             cmd <- diff_program-            case get_diff_cmd_and_args cmd opts f1 f2 of+            case getDiffCmdAndArgs cmd opts f1 f2 of              Left err -> fail err              Right (d_cmd, d_args) ->-              let other_diff = has_diff_cmd_flag opts in+              let other_diff = hasDiffCmdFlag opts in               do when other_diff $ putStrLn $                    "Running command '" ++ unwords (d_cmd:d_args) ++ "'"                  output <- execPipeIgnoreError d_cmd d_args empty@@ -229,15 +233,14 @@                     return ()                  return output -get_diff_info :: RepoPatch p => [DarcsFlag] -> PatchSet p -> [PatchInfo]-get_diff_info opts ps =-    let pi1s = mapRL info $ concatRL $ if first_match opts-                                       then unsafeUnseal $ match_first_patchset opts ps-                                       else ps-        pi2s = mapRL info $ concatRL $ if second_match opts-                                       then unsafeUnseal $ match_second_patchset opts ps-                                       else ps-        in pi2s \\ pi1s+getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> [PatchInfo]+getDiffInfo opts ps =+    let infos = mapRL info . concatRL+        handle (match_cond, do_match)+          | match_cond opts = unseal infos (do_match opts ps)+          | otherwise = infos ps+    in handle (secondMatch, matchSecondPatchset)+         \\ handle (firstMatch, matchFirstPatchset)  changelog :: [PatchInfo] -> Doc changelog pis = vcat $ map human_friendly pis
src/Darcs/Commands/Dist.lhs view
@@ -26,30 +26,30 @@ import Data.Char ( isAlphaNum ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help,-                        command_description, command_extra_args,-                        command_extra_arg_help, command_command,-                        command_prereq, command_get_arg_possibilities,-                        command_argdefaults,-                        command_advanced_options, command_basic_options),+import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp,+                        commandDescription, commandExtraArgs,+                        commandExtraArgHelp, commandCommand,+                        commandPrereq, commandGetArgPossibilities,+                        commandArgdefaults,+                        commandAdvancedOptions, commandBasicOptions),                         nodefaults )-import Darcs.Arguments ( DarcsFlag(Verbose, DistName), distname_option,-                         working_repo_dir, match_one, store_in_memory,+import Darcs.Arguments ( DarcsFlag(Verbose, DistName), distnameOption,+                         workingRepoDir, matchOne, storeInMemory,                          fixSubPaths )-import Darcs.Match ( get_nonrange_match, have_nonrange_match )+import Darcs.Match ( getNonrangeMatch, haveNonrangeMatch ) import Darcs.Repository ( amInRepository, withRepoReadLock, ($-), --withRecorded,                           createPartialsPristineDirectoryTree )-import Darcs.Repository.Prefs ( get_prefval )+import Darcs.Repository.Prefs ( getPrefval ) import Darcs.Lock ( withTemp, withTempDir, readBinFile ) import Darcs.RepoPath ( AbsolutePath, toFilePath ) import Darcs.Utils ( withCurrentDirectory ) import Exec ( exec, Redirect(..) ) -dist_description :: String-dist_description = "Create a distribution tarball."+distDescription :: String+distDescription = "Create a distribution tarball." -dist_help :: String-dist_help =+distHelp :: String+distHelp =  "The `darcs dist' command creates a compressed archive (a `tarball') in\n" ++  "the repository's root directory, containing the recorded state of the\n" ++  "working tree (unrecorded changes and the _darcs directory are\n" ++@@ -81,26 +81,26 @@  -}  dist :: DarcsCommand-dist = DarcsCommand {command_name = "dist",-                     command_help = dist_help,-                     command_description = dist_description,-                     command_extra_args = 0,-                     command_extra_arg_help = [],-                     command_command = dist_cmd,-                     command_prereq = amInRepository,-                     command_get_arg_possibilities = return [],-                     command_argdefaults = nodefaults,-                     command_advanced_options = [],-                     command_basic_options = [distname_option,-                                              working_repo_dir,-                                              match_one,-                                              store_in_memory]}+dist = DarcsCommand {commandName = "dist",+                     commandHelp = distHelp,+                     commandDescription = distDescription,+                     commandExtraArgs = 0,+                     commandExtraArgHelp = [],+                     commandCommand = distCmd,+                     commandPrereq = amInRepository,+                     commandGetArgPossibilities = return [],+                     commandArgdefaults = nodefaults,+                     commandAdvancedOptions = [],+                     commandBasicOptions = [distnameOption,+                                              workingRepoDir,+                                              matchOne,+                                              storeInMemory]} -dist_cmd :: [DarcsFlag] -> [String] -> IO ()-dist_cmd opts args = withRepoReadLock opts $- \repository -> do-  distname <- get_dist_name opts+distCmd :: [DarcsFlag] -> [String] -> IO ()+distCmd opts args = withRepoReadLock opts $- \repository -> do+  distname <- getDistName opts   verb <- return $ Verbose `elem` opts-  predist <- get_prefval "predist"+  predist <- getPrefval "predist"   formerdir <- getCurrentDirectory   path_list <- if null args                then return [""]@@ -110,12 +110,12 @@     withTempDir "darcsdist" $ \tempdir -> do       setCurrentDirectory (formerdir)       withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do-        if have_nonrange_match opts-          then withCurrentDirectory ddir $ get_nonrange_match repository opts+        if haveNonrangeMatch opts+          then withCurrentDirectory ddir $ getNonrangeMatch repository opts           else createPartialsPristineDirectoryTree repository path_list (toFilePath ddir)         ec <- case predist of Nothing -> return ExitSuccess                               Just pd -> system pd-        if (ec == ExitSuccess) then do_dist verb tarfile tempdir ddir resultfile+        if (ec == ExitSuccess) then doDist verb tarfile tempdir ddir resultfile             else                 do                 putStrLn "Dist aborted due to predist failure"@@ -124,8 +124,8 @@ -- | 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.-do_dist :: Bool -> FilePath -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()-do_dist verb tarfile tempdir ddir resultfile = do+doDist :: Bool -> FilePath -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()+doDist verb tarfile tempdir ddir resultfile = do   setCurrentDirectory (toFilePath tempdir)   exec "tar" ["-cf", "-", safename $ takeFileName $ toFilePath ddir]              (Null, File tarfile, AsIs)@@ -141,16 +141,16 @@     safename n@(c:_) | isAlphaNum c  = n     safename n = "./" ++ n -guess_repo_name :: IO String-guess_repo_name = do+guessRepoName :: IO String+guessRepoName = do   pwd <- getCurrentDirectory   if '/' `elem` pwd      then return $ reverse $ takeWhile (/='/') $ reverse pwd      else return "cantguessreponame" -get_dist_name :: [DarcsFlag] -> IO String-get_dist_name (DistName dn:_) = return dn-get_dist_name (_:fs) = get_dist_name fs-get_dist_name _ = guess_repo_name+getDistName :: [DarcsFlag] -> IO String+getDistName (DistName dn:_) = return dn+getDistName (_:fs) = getDistName fs+getDistName _ = guessRepoName \end{code}
src/Darcs/Commands/GZCRCs.lhs view
@@ -1,19 +1,24 @@ %  Copyright (C) 2009 Ganesh Sittampalam %-%  This program is free software; you can redistribute it and/or modify-%  it under the terms of the GNU General Public License as published by-%  the Free Software Foundation; either version 2, or (at your option)-%  any later version.+% Permission is hereby granted, free of charge, to any person+% obtaining a copy of this software and associated documentation+% files (the "Software"), to deal in the Software without+% restriction, including without limitation the rights to use, copy,+% modify, merge, publish, distribute, sublicense, and/or sell copies+% of the Software, and to permit persons to whom the Software is+% furnished to do so, subject to the following conditions: %-%  This program is distributed in the hope that it will be useful,-%  but WITHOUT ANY WARRANTY; without even the implied warranty of-%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-%  GNU General Public License for more details.+% The above copyright notice and this permission notice shall be+% included in all copies or substantial portions of the Software. %-%  You should have received a copy of the GNU General Public License-%  along with this program; see the file COPYING.  If not, write to-%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-%  Boston, MA 02110-1301, USA.+% THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+% EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+% MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+% NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+% BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+% ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+% CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+% SOFTWARE.  \subsection{darcs gzcrcs} \darcsCommand{gzcrcs}@@ -21,7 +26,7 @@ {-# LANGUAGE CPP #-} module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where -import Control.Arrow ( (***) )+import Control.Arrow ( first ) import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO ) import Control.Monad.Writer ( runWriterT, tell )@@ -33,10 +38,11 @@  import System.Directory ( getDirectoryContents, doesFileExist, doesDirectoryExist ) import System.Exit ( ExitCode(..), exitWith )+import Data.IORef ( newIORef, readIORef, writeIORef )  import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo ),-                        check_or_repair, working_repo_dir, just_this_repo+                        checkOrRepair, workingRepoDir, justThisRepo                       ) import Darcs.Repository ( Repository, amInRepository, withRepository ) import Darcs.Patch ( RepoPatch )@@ -52,30 +58,16 @@ import Darcs.Repository.Cache ( Cache(..), writable, isthisrepo, hashedFilePath, allHashedDirs )  -#ifdef HAVE_HASKELL_ZLIB import Darcs.Global ( getCRCWarnings, resetCRCWarnings ) import ByteStringUtils ( gzDecompress )-#else--- These functions aren't available unless we have the Haskell zlib.--- The gzcrcs command shouldn't be enabled in this case, but we would--- still like to typecheck this module as much as possible so we include--- dummy versions -noChecking :: String -> a-noChecking what = error $ "Darcs.Commands.GZCRCs." ++ what ++ ": gz CRC checking is not possible unless " ++-                          "darcs has been built with the Haskell zlib. This code should be unreachable."-getCRCWarnings :: IO [FilePath]-getCRCWarnings = noChecking "getCRCWarnings"-resetCRCWarnings :: IO ()-resetCRCWarnings = noChecking "resetCRCWarnings"-gzDecompress :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool)-gzDecompress = noChecking "gzDecompress"-#endif -gzcrcs_description :: String-gzcrcs_description = "Check or repair the CRCs of compressed files in the repository."+#include "gadts.h" -gzcrcs_help :: String-gzcrcs_help = formatText+gzcrcsDescription :: String+gzcrcsDescription = "Check or repair the CRCs of compressed files in the repository."++gzcrcsHelp :: String+gzcrcsHelp = formatText   [    "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " ++    "with bad CRCs (but valid data) to be written out. CRCs were not checked on " ++@@ -109,7 +101,7 @@ para w = para'   where para' [] = []         para' xs = uncurry (:) $ para'' w xs-        para'' r (x:xs) | w == r || length x < r = ((x:) *** id) $ para'' (r - length x - 1) xs+        para'' r (x:xs) | w == r || length x < r = first (x:) $ para'' (r - length x - 1) xs         para'' _ xs = ([], para' xs)  -- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand@@ -126,32 +118,33 @@       when verbose $ putStrLn $ unlines ("The following corrupt files were found:":files)  gzcrcs :: DarcsCommand-gzcrcs = DarcsCommand {command_name = "gzcrcs",-                       command_help = gzcrcs_help,-                       command_description = gzcrcs_description,-                       command_extra_args = 0,-                       command_extra_arg_help = [],-                       command_command = gzcrcs_cmd,-                       command_prereq = amInRepository,-                       command_get_arg_possibilities = return [],-                       command_argdefaults = nodefaults,-                       command_advanced_options = [],-                       command_basic_options = [check_or_repair,-                                                just_this_repo,-                                                working_repo_dir+gzcrcs = DarcsCommand {commandName = "gzcrcs",+                       commandHelp = gzcrcsHelp,+                       commandDescription = gzcrcsDescription,+                       commandExtraArgs = 0,+                       commandExtraArgHelp = [],+                       commandCommand = gzcrcsCmd,+                       commandPrereq = amInRepository,+                       commandGetArgPossibilities = return [],+                       commandArgdefaults = nodefaults,+                       commandAdvancedOptions = [],+                       commandBasicOptions = [checkOrRepair,+                                                justThisRepo,+                                                workingRepoDir                                                ]} -gzcrcs_cmd :: [DarcsFlag] -> [String] -> IO ()-gzcrcs_cmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts)-gzcrcs_cmd _ _ = error "You must specify --check or --repair for gzcrcs"+gzcrcsCmd :: [DarcsFlag] -> [String] -> IO ()+gzcrcsCmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts)+gzcrcsCmd _ _ = error "You must specify --check or --repair for gzcrcs" -#ifdef GADT_WITNESSES-gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p r u t -> IO ()-#else-gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()-#endif+gzcrcs'+   :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) -> IO () gzcrcs' opts repo = do   let Ca locs = extractCache repo+  -- Somewhat ugly IORef use here because it's convenient, would be nicer+  -- to pre-filter the list of locs to check and then decide whether to+  -- print the message up front.+  warnRelatedRepos <- newIORef (JustThisRepo `notElem` opts)   ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do     unless (JustThisRepo `elem` opts && not (isthisrepo loc)) $ do      let w = writable loc@@ -159,6 +152,11 @@         let dir = hashedFilePath loc hdir ""         exists <- liftIO $ doesDirectoryExist dir         when exists $ do+           liftIO $ do+              warn <- readIORef warnRelatedRepos+              when (warn && not (isthisrepo loc)) $ do+                 writeIORef warnRelatedRepos False+                 putInfo $ text "Also checking related repos and caches; use --just-this-repo to disable."            liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)")            files <- liftIO $ getDirectoryContents dir            ((), Sum count) <- runWriterT $ flip mapM_ files $ \file -> do
src/Darcs/Commands/Get.lhs view
@@ -28,21 +28,22 @@ import Data.Maybe ( isJust ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )+import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, putInfo ) import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy,                                     UseFormat2, UseOldFashionedInventory, UseHashedInventory,-                                    SetScriptsExecutable, Quiet, OnePattern ),-                        get_context, get_inventory_choices,+                                    SetScriptsExecutable, OnePattern ),+                        getContext, getInventoryChoices,                         partial, reponame,-                        match_one_context, set_default, set_scripts_executable, nolinks,-                        network_options )+                        matchOneContext, setDefault, setScriptsExecutableOption, nolinks,+                        networkOptions ) import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo,                           createPristineDirectoryTree,                           tentativelyRemovePatches, patchSetToPatches, patchSetToRepository,                           copyRepository, tentativelyAddToPending,-                          finalizeRepositoryChanges, sync_repo, setScriptsExecutable )+                          finalizeRepositoryChanges, setScriptsExecutable+                        , invalidateIndex ) import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat,-                                 RepoProperty ( Darcs2, HashedInventory ), format_has )+                                 RepoProperty ( Darcs2, HashedInventory ), formatHas ) import Darcs.Repository.DarcsRepo ( write_inventory ) import qualified Darcs.Repository.DarcsRepo as DR ( read_repo ) import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches,@@ -51,31 +52,30 @@ import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint ) import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert,                      effect, description )-import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeUnRL, mapRL, concatRL, reverseRL, lengthFL )+import Darcs.Witnesses.Ordered ( (:\/:)(..), RL(..), mapRL, concatRL, reverseRL, lengthFL ) import Darcs.External ( copyFileOrUrl, Cachable(..) ) import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag )-import Darcs.Repository.Prefs ( set_defaultrepo )+import Darcs.Repository.Prefs ( setDefaultrepo ) import Darcs.Repository.Motd ( show_motd ) import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, ) import Darcs.SignalHandler ( catchInterrupt ) import Darcs.Commands.Init ( initialize )-import Darcs.Match ( have_patchset_match, get_one_patchset )+import Darcs.Match ( havePatchsetMatch, getOnePatchset ) import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError ) import Progress ( debugMessage )-import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, )+import Printer ( text, vcat, errorDoc, ($$) ) import Darcs.Lock ( writeBinFile ) import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote)-import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal )+import Darcs.Witnesses.Sealed ( Sealed(..), unsafeUnflippedseal ) import Darcs.Global ( darcsdir ) import English ( englishNum, Noun(..) )-import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" -get_description :: String-get_description = "Create a local copy of a repository."+getDescription :: String+getDescription = "Create a local copy of a repository." -get_help :: String-get_help =+getHelp :: String+getHelp =  "Get creates a local copy of a repository.  The optional second\n" ++  "argument specifies a destination directory for the new copy; if\n" ++  "omitted, it is inferred from the source location.\n" ++@@ -100,10 +100,10 @@  "Darcs get will not copy unrecorded changes to the source repository's\n" ++  "working tree.\n" ++  "\n" ++- get_help_tag +++ getHelpTag ++  "\n" ++  -- The remaining help text covers backwards-compatibility options.- get_help_partial +++ getHelpPartial ++  "\n" ++  "A repository created by `darcs get' will be in the best available\n" ++  "format: it will be able to exchange patches with the source\n" ++@@ -112,31 +112,31 @@  "is required.\n"  get :: DarcsCommand-get = DarcsCommand {command_name = "get",-                    command_help = get_help,-                    command_description = get_description,-                    command_extra_args = -1,-                    command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"],-                    command_command = get_cmd,-                    command_prereq = contextExists,-                    command_get_arg_possibilities = return [],-                    command_argdefaults = nodefaults,-                    command_advanced_options = network_options ++-                                               command_advanced_options initialize,-                    command_basic_options = [reponame,+get = DarcsCommand {commandName = "get",+                    commandHelp = getHelp,+                    commandDescription = getDescription,+                    commandExtraArgs = -1,+                    commandExtraArgHelp = ["<REPOSITORY>", "[<DIRECTORY>]"],+                    commandCommand = getCmd,+                    commandPrereq = contextExists,+                    commandGetArgPossibilities = return [],+                    commandArgdefaults = nodefaults,+                    commandAdvancedOptions = networkOptions +++                                               commandAdvancedOptions initialize,+                    commandBasicOptions = [reponame,                                             partial,-                                            match_one_context,-                                            set_default,-                                            set_scripts_executable,+                                            matchOneContext,+                                            setDefault,+                                            setScriptsExecutableOption,                                              nolinks,-                                             get_inventory_choices]}+                                             getInventoryChoices]}  clone :: DarcsCommand-clone = command_alias "clone" get+clone = commandAlias "clone" get -get_cmd :: [DarcsFlag] -> [String] -> IO ()-get_cmd opts [inrepodir, outname] = get_cmd (NewRepo outname:opts) [inrepodir]-get_cmd opts [inrepodir] = do+getCmd :: [DarcsFlag] -> [String] -> IO ()+getCmd opts [inrepodir, outname] = getCmd (NewRepo outname:opts) [inrepodir]+getCmd opts [inrepodir] = do   debugMessage "Starting work on get..."   typed_repodir <- ioAbsoluteOrRemote inrepodir   let repodir = toPath typed_repodir@@ -146,24 +146,24 @@   rfsource <- case rfsource_or_e of Left e -> fail e                                     Right x -> return x   debugMessage $ "Found the format of "++repodir++"..."-  mysimplename <- make_repo_name opts repodir+  mysimplename <- makeRepoName opts repodir   createDirectory mysimplename   setCurrentDirectory mysimplename-  when (format_has Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $-    putInfo $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n"-  let opts' = if format_has Darcs2 rfsource+  when (formatHas Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $+    putInfo opts $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n"+  let opts' = if formatHas Darcs2 rfsource               then UseFormat2:opts               else if not (UseOldFashionedInventory `elem` opts)                    then UseHashedInventory:filter (/= UseFormat2) opts                    else UseOldFashionedInventory:filter (/= UseFormat2) opts   createRepository opts'   debugMessage "Finished initializing new directory."-  set_defaultrepo repodir opts+  setDefaultrepo repodir opts    rf_or_e <- identifyRepoFormat "."   rf <- case rf_or_e of Left e -> fail e                         Right x -> return x-  if format_has HashedInventory rf -- refactor this into repository+  if formatHas HashedInventory rf -- refactor this into repository     then writeBinFile (darcsdir++"/hashed_inventory") ""     else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch) @@ -172,48 +172,60 @@     then withRepository opts $- \repository -> do       debugMessage "Using economical get --to-match handling"       fromrepo <- identifyRepositoryFor  repository repodir-      Sealed patches_to_get <- get_one_patchset fromrepo opts+      Sealed patches_to_get <- getOnePatchset fromrepo opts       patchSetToRepository fromrepo patches_to_get opts       debugMessage "Finished converting selected patch set to new repository"-    else copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo-        where am_informative = not $ Quiet `elem` opts-              putInfo s = when am_informative $ putDocLn s--get_cmd _ _ = fail "You must provide 'get' with either one or two arguments."+    else copyRepoAndGoToChosenVersion opts repodir rfsource rf+getCmd _ _ = fail "You must provide 'get' with either one or two arguments." --- | called by get_cmd+-- | called by getCmd -- assumes that the target repo of the get is the current directory, and that an inventory in the -- right format has already been created.-copy_repo_and_go_to_chosen_version :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> (Doc -> IO ()) -> IO ()-copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo = do-  copy_repo `catchInterrupt` (putInfo $ text "Using lazy repository.")-  withRepository opts $- \repository -> go_to_chosen_version repository putInfo opts-  putInfo $ text "Finished getting."+copyRepoAndGoToChosenVersion :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> IO ()+copyRepoAndGoToChosenVersion opts repodir rfsource rf = do+  copy_repo `catchInterrupt` (when (formatHas HashedInventory rfsource)+                                   (putInfo opts $ text "Using lazy repository."))+  withRepository opts $- \repository -> goToChosenVersion repository opts+  putInfo opts $ text "Finished getting."       where copy_repo =                 withRepository opts $- \repository -> do-                  if format_has HashedInventory rf || format_has HashedInventory rfsource-                     then do debugMessage "Identifying and copying repository..."-                             identifyRepositoryFor repository repodir >>= copyRepository-                             when (SetScriptsExecutable `elem` opts) setScriptsExecutable-                     else copy_repo_old_fashioned repository opts repodir+                  let hashUs   = formatHas HashedInventory rf+                      hashThem = formatHas HashedInventory rfsource+                  case () of _ | hashUs && hashThem -> do+                                   debugMessage "Identifying and copying repository..."+                                   copyRepoHashed repository+                               | hashUs -> do+                                   putInfo opts $  text "Converting old-fashioned repository to hashed format..."+                                               $$ text "*******************************************************************************"+                                               $$ text "Fetching a hashed repository would be faster.  Perhaps you could persuade"+                                               $$ text "the maintainer to run darcs optimize --upgrade with darcs 2.4.0 or higher?"+                                               $$ text "*******************************************************************************"+                                   copyRepoHashed repository+                               | hashThem -> do+                                   putInfo opts $ text "Fetching a hashed repository as an old-fashioned one..."+                                   copyRepoHashed repository+                               | otherwise -> copyRepoOldFashioned repository opts repodir+            copyRepoHashed repository =+              do identifyRepositoryFor repository repodir >>= copyRepository+                 when (SetScriptsExecutable `elem` opts) setScriptsExecutable -make_repo_name :: [DarcsFlag] -> FilePath -> IO String-make_repo_name (NewRepo n:_) _ =+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-make_repo_name (_:as) d = make_repo_name as d-make_repo_name [] d =+makeRepoName (_:as) d = makeRepoName as d+makeRepoName [] d =   case dropWhile (=='.') $ reverse $        takeWhile (\c -> c /= '/' && c /= ':') $        dropWhile (=='/') $ reverse d of-  "" -> modify_repo_name "anonymous_repo"-  base -> modify_repo_name base+  "" -> modifyRepoName "anonymous_repo"+  base -> modifyRepoName base -modify_repo_name :: String -> IO String-modify_repo_name name =+modifyRepoName :: String -> IO String+modifyRepoName name =     if head name == '/'     then mrn name (-1)     else do cwd <- getCurrentDirectory@@ -232,8 +244,8 @@        else mrn n $ i+1     where thename = if i == -1 then n else n++"_"++show i -get_help_tag :: String-get_help_tag =+getHelpTag :: String+getHelpTag =  "It is often desirable to make a copy of a repository that excludes\n" ++  "some patches.  For example, if releases are tagged then `darcs get\n" ++  "--tag .' would make a copy of the repository as at the latest release.\n" ++@@ -254,27 +266,27 @@  contextExists :: [DarcsFlag] -> IO (Either String ()) contextExists opts =-   case get_context opts of+   case getContext opts of      Nothing -> return $ Right ()      Just f  -> do exists <- doesFileExist $ toFilePath f                    if exists                       then return $ Right ()                       else return . Left $ "Context file "++toFilePath f++" does not exist" -go_to_chosen_version :: RepoPatch p => Repository p -> (Doc -> IO ())+goToChosenVersion :: RepoPatch p => Repository p                      -> [DarcsFlag] -> IO ()-go_to_chosen_version repository putInfo opts =-    when (have_patchset_match opts) $ do+goToChosenVersion repository opts =+    when (havePatchsetMatch opts) $ do        debugMessage "Going to specified version..."        patches <- read_repo repository-       Sealed context <- get_one_patchset repository opts+       Sealed context <- getOnePatchset repository opts        let (_,us':\/:them') = get_common_and_uncommon (patches, context)        case them' of-           NilRL:<:NilRL -> return ()+           NilRL -> return ()            _ -> errorDoc $ text "Missing these patches from context:"-                        $$ (vcat $ mapRL description $ head $ unsafeUnRL them')-       let ps = patchSetToPatches us'-       putInfo $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " +++                        $$ (vcat $ mapRL description them')+       let ps = patchSetToPatches (us':<:NilRL)+       putInfo opts $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++                    (englishNum (lengthFL ps) (Noun "patch") "")        invalidateIndex repository        withRepoLock opts $- \_ ->@@ -283,11 +295,10 @@               finalizeRepositoryChanges repository               apply opts (invert $ effect ps) `catch` \e ->                   fail ("Couldn't undo patch in working dir.\n" ++ show e)-              sync_repo repository  -get_help_partial :: String-get_help_partial =+getHelpPartial :: String+getHelpPartial =  "If the source repository is in a legacy darcs-1 format and contains at\n" ++  "least one checkpoint (see `darcs optimize'), the --partial option will\n" ++  "create a partial repository.  A partial repository discards history\n" ++@@ -295,8 +306,8 @@  "For modern darcs-2 repositories, --partial is a deprecated alias for\n" ++  "the --lazy option.\n" -copy_repo_old_fashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO ()-copy_repo_old_fashioned repository opts repodir = do+copyRepoOldFashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO ()+copyRepoOldFashioned repository opts repodir = do   myname <- getCurrentDirectory   fromrepo <- identifyRepositoryFor repository repodir   mch <- get_checkpoint fromrepo@@ -329,7 +340,7 @@        if Partial `elem` opts && isJust mch           then let Sealed p_ch = fromJust mch                    pi_ch = patch2patchinfo p_ch-                   needed_patches = reverseRL $ concatRL $ unsafeUnflippedseal $+                   needed_patches = reverseRL $ unsafeUnflippedseal $                                     get_patches_beyond_tag pi_ch local_patches                    in do write_checkpoint_patch p_ch                          apply opts p_ch `catch`@@ -340,8 +351,5 @@   pristine <- identifyPristine   createPristineFromWorking pristine   setCurrentDirectory myname-  debugMessage "Syncing the repository..."-  sync_repo repository-  debugMessage "Repository synced."  \end{code}
src/Darcs/Commands/Help.lhs view
@@ -18,19 +18,19 @@ \darcsCommand{help} \begin{code} module Darcs.Commands.Help (- help_cmd,- command_control_list, environmentHelp,          -- these are for preproc.hs- print_version,- list_available_commands ) where+ helpCmd,+ commandControlList, environmentHelp,          -- these are for preproc.hs+ printVersion,+ listAvailableCommands ) where -import Darcs.Arguments ( DarcsFlag(..), environmentHelpSendmail )+import Darcs.Arguments ( DarcsFlag(..), environmentHelpEmail, environmentHelpSendmail ) import Darcs.Commands (  CommandArgs(..), CommandControl(..), DarcsCommand(..),- disambiguate_commands, extract_commands, get_command_help, nodefaults, usage )+ disambiguateCommands, extractCommands, getCommandHelp, nodefaults, usage ) import Darcs.External ( viewDoc ) import Darcs.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir ) import Darcs.Patch.Match ( helpOnMatchers )-import Darcs.Repository.Prefs ( binaries_file_help, environmentHelpHome )+import Darcs.Repository.Prefs ( binariesFileHelp, environmentHelpHome ) import Darcs.Utils ( withCurrentDirectory, environmentHelpEditor, environmentHelpPager ) import Data.Char ( isAlphaNum, toLower ) import Data.List ( groupBy )@@ -43,54 +43,54 @@ import Workaround ( getCurrentDirectory ) import qualified Darcs.TheCommands as TheCommands -help_description :: String-help_description = "Display help about darcs and darcs commands."+helpDescription :: String+helpDescription = "Display help about darcs and darcs commands." -help_help :: String-help_help =+helpHelp :: String+helpHelp =  "Without arguments, `darcs help' prints a categorized list of darcs\n" ++  "commands and a short description of each one.  With an extra argument,\n" ++  "`darcs help foo' prints detailed help about the darcs command foo.\n"  help :: DarcsCommand-help = DarcsCommand {command_name = "help",-                     command_help = help_help,-                     command_description = help_description,-                     command_extra_args = -1,-                     command_extra_arg_help = ["[<DARCS_COMMAND> [DARCS_SUBCOMMAND]]  "],-                     command_command = \ x y -> help_cmd x y >> exitWith ExitSuccess,-                     command_prereq = \_ -> return $ Right (),-                     command_get_arg_possibilities = return [],-                     command_argdefaults = nodefaults,-                     command_advanced_options = [],-                     command_basic_options = []}+help = DarcsCommand {commandName = "help",+                     commandHelp = helpHelp,+                     commandDescription = helpDescription,+                     commandExtraArgs = -1,+                     commandExtraArgHelp = ["[<DARCS_COMMAND> [DARCS_SUBCOMMAND]]  "],+                     commandCommand = \ x y -> helpCmd x y >> exitWith ExitSuccess,+                     commandPrereq = \_ -> return $ Right (),+                     commandGetArgPossibilities = return [],+                     commandArgdefaults = nodefaults,+                     commandAdvancedOptions = [],+                     commandBasicOptions = []} -help_cmd :: [DarcsFlag] -> [String] -> IO ()-help_cmd _ ["manpage"] = putStr $ unlines manpageLines-help_cmd _ ["patterns"] = viewDoc $ text $ helpOnMatchers-help_cmd _ ["environment"] = viewDoc $ text $ helpOnEnvironment-help_cmd _ [] = viewDoc $ text $ usage command_control_list+helpCmd :: [DarcsFlag] -> [String] -> IO ()+helpCmd _ ["manpage"] = putStr $ unlines manpageLines+helpCmd _ ["patterns"] = viewDoc $ text $ helpOnMatchers+helpCmd _ ["environment"] = viewDoc $ text $ helpOnEnvironment+helpCmd _ [] = viewDoc $ text $ usage commandControlList -help_cmd _ (cmd:args) =-    let disambiguated = disambiguate_commands command_control_list cmd args+helpCmd _ (cmd:args) =+    let disambiguated = disambiguateCommands commandControlList cmd args     in case disambiguated of          Left err -> fail err          Right (cmds,_) ->              let msg = case cmds of-                         CommandOnly c       -> get_command_help Nothing  c-                         SuperCommandOnly c  -> get_command_help Nothing  c-                         SuperCommandSub c s -> get_command_help (Just c) s+                         CommandOnly c       -> getCommandHelp Nothing  c+                         SuperCommandOnly c  -> getCommandHelp Nothing  c+                         SuperCommandSub c s -> getCommandHelp (Just c) s              in viewDoc $ text msg -list_available_commands :: IO ()-list_available_commands =+listAvailableCommands :: IO ()+listAvailableCommands =     do here <- getCurrentDirectory-       is_valid <- sequence $ map-                   (\c-> withCurrentDirectory here $ (command_prereq c) [])-                   (extract_commands command_control_list)-       putStr $ unlines $ map (command_name . fst) $+       is_valid <- mapM+                   (\c-> withCurrentDirectory here $ (commandPrereq c) [])+                   (extractCommands commandControlList)+       putStr $ unlines $ map (commandName . fst) $                 filter (isRight.snd) $-                zip (extract_commands command_control_list) is_valid+                zip (extractCommands commandControlList) is_valid        putStrLn "--help"        putStrLn "--version"        putStrLn "--exact-version"@@ -98,14 +98,17 @@     where isRight (Right _) = True           isRight _ = False -print_version :: IO () -print_version = putStrLn $ "darcs version " ++ darcs_version+printVersion :: IO ()+printVersion = putStrLn $ "darcs version " ++ darcs_version  -- avoiding a module import cycle between Help and TheCommands-command_control_list :: [CommandControl] -command_control_list =-  Command_data help : TheCommands.command_control_list+commandControlList :: [CommandControl]+commandControlList =+  CommandData help : TheCommands.commandControlList +-- FIXME: the "grouping" comments below should made subsections in the+-- manpage, as we already do for DarcsCommand groups. --twb, 2009+ -- | Help on each environment variable in which Darcs is interested. environmentHelp :: [([String], [String])] environmentHelp = [@@ -115,6 +118,7 @@  environmentHelpPager,  environmentHelpTmpdir,  environmentHelpKeepTmpdir,+ environmentHelpEmail,  environmentHelpSendmail,  -- Remote Repositories  environmentHelpSsh,@@ -162,7 +166,7 @@  ".TP 3", "\\(bu",  "Distributed: Every user has access to the full",  "command set, removing boundaries between server and",- "client or committer and non-committers.",+ "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",@@ -183,14 +187,14 @@  "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 " ++ helpOnMatchers, -- FIXME: this is a kludge.+ "a particular command, run `darcs", ".I command", "\\-\\-help'.",+ ".SS " ++ escape helpOnMatchers, -- FIXME: this is a kludge.  ".SH COMMANDS",  unlines commands,  unlines environment,  ".SH FILES",  ".SS \"_darcs/prefs/binaries\"",- unlines binaries_file_help,+ escape $ unlines binariesFileHelp,  ".SH BUGS",  "At http://bugs.darcs.net/ you can find a list of known",  "bugs in Darcs.  Unknown bugs can be reported at that",@@ -209,19 +213,19 @@       -- necessary to avoid blank lines from Hidden_commands, as groff       -- translates them into annoying vertical padding (unlike TeX).       synopsis :: [String]-      synopsis = foldl iter [] command_control_list+      synopsis = foldl iter [] commandControlList           where iter :: [String] -> CommandControl -> [String]-                iter acc (Group_name _) = acc-                iter acc (Hidden_command _) = acc-                iter acc (Command_data c@SuperCommand {}) =+                iter acc (GroupName _) = acc+                iter acc (HiddenCommand _) = acc+                iter acc (CommandData c@SuperCommand {}) =                     acc ++ concatMap-                            (render (command_name c ++ " "))-                            (extract_commands (command_sub_commands c))-                iter acc (Command_data c) = acc ++ render "" c+                            (render (commandName c ++ " "))+                            (extractCommands (commandSubCommands c))+                iter acc (CommandData c) = acc ++ render "" c                 render :: String -> DarcsCommand -> [String]                 render prefix c =-                    [".B darcs " ++ prefix ++ command_name c] ++-                    (map mangle_args $ command_extra_arg_help c) +++                    [".B darcs " ++ prefix ++ commandName c] +++                    (map mangle_args $ commandExtraArgHelp c) ++                     -- In the output, we want each command to be on its own                     -- line, but we don't want blank lines between them.                     -- AFAICT this can only be achieved with the .br@@ -231,20 +235,20 @@       -- | As 'synopsis', but make each group a subsection (.SS), and       -- include the help text for each command.       commands :: [String]-      commands = foldl iter [] command_control_list+      commands = foldl iter [] commandControlList           where iter :: [String] -> CommandControl -> [String]-                iter acc (Group_name x) = acc ++ [".SS \"" ++ x ++ "\""]-                iter acc (Hidden_command _) = acc-                iter acc (Command_data c@SuperCommand {}) =+                iter acc (GroupName x) = acc ++ [".SS \"" ++ x ++ "\""]+                iter acc (HiddenCommand _) = acc+                iter acc (CommandData c@SuperCommand {}) =                     acc ++ concatMap-                            (render (command_name c ++ " "))-                            (extract_commands (command_sub_commands c))-                iter acc (Command_data c) = acc ++ render "" c+                            (render (commandName c ++ " "))+                            (extractCommands (commandSubCommands c))+                iter acc (CommandData c) = acc ++ render "" c                 render :: String -> DarcsCommand -> [String]                 render prefix c =-                    [".B darcs " ++ prefix ++ command_name c] ++-                    (map mangle_args $ command_extra_arg_help c) ++-                    [".RS 4", command_help c, ".RE"]+                    [".B darcs " ++ prefix ++ commandName c] +++                    (map mangle_args $ commandExtraArgHelp c) +++                    [".RS 4", escape $ commandHelp c, ".RE"]        -- | Now I'm showing off: mangle the extra arguments of Darcs commands       -- so as to use the ideal format for manpages, italic words and roman@@ -260,7 +264,21 @@        environment :: [String]       environment = ".SH ENVIRONMENT" : concat-                    [(".SS \"" ++ andClauses ks ++ "\"") : ds+                    [(".SS \"" ++ andClauses ks ++ "\"") : map escape ds                      | (ks, ds) <- environmentHelp]++      -- | Copied from Preproc.escape_latex_specials.+      escape :: String -> String+      escape = minus . bs       -- Order is important+        where+          minus      = replace "-"     "\\-"+          bs         = replace "\\"    "\\\\"++          replace :: Eq a => [a] -> [a] -> [a] -> [a]+          replace _ _ [] = []+          replace find repl s =+              if take (length find) s == find+                  then repl ++ (replace find repl (drop (length find) s))+                  else [head s] ++ replace find repl (tail s)  \end{code}
src/Darcs/Commands/Init.lhs view
@@ -17,17 +17,17 @@  \darcsCommand{initialize} \begin{code}-module Darcs.Commands.Init ( initialize, initialize_cmd ) where+module Darcs.Commands.Init ( initialize, initializeCmd ) where import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, working_repo_dir,-                        inventory_choices )+import Darcs.Arguments ( DarcsFlag, workingRepoDir,+                        inventoryChoices ) import Darcs.Repository ( amNotInRepository, createRepository ) -initialize_description :: String-initialize_description = "Make the current directory a repository."+initializeDescription :: String+initializeDescription = "Make the current directory a repository." -initialize_help :: String-initialize_help =+initializeHelp :: String+initializeHelp =  "The `darcs initialize' command turns the current directory into a\n" ++  "Darcs repository.  Any existing files and subdirectories become\n" ++  "UNSAVED changes in the working tree: record them with `darcs add -r'\n" ++@@ -70,20 +70,20 @@  "Initialize is commonly abbreviated to `init'.\n"  initialize :: DarcsCommand-initialize = DarcsCommand {command_name = "initialize",-                         command_help = initialize_help,-                         command_description = initialize_description,-                         command_extra_args = 0,-                         command_extra_arg_help = [],-                         command_prereq = amNotInRepository,-                         command_command = initialize_cmd,-                         command_get_arg_possibilities = return [],-                         command_argdefaults = nodefaults,-                         command_advanced_options = [],-                         command_basic_options = [inventory_choices,-                                                  working_repo_dir]}+initialize = DarcsCommand {commandName = "initialize",+                         commandHelp = initializeHelp,+                         commandDescription = initializeDescription,+                         commandExtraArgs = 0,+                         commandExtraArgHelp = [],+                         commandPrereq = amNotInRepository,+                         commandCommand = initializeCmd,+                         commandGetArgPossibilities = return [],+                         commandArgdefaults = nodefaults,+                         commandAdvancedOptions = [],+                         commandBasicOptions = [inventoryChoices,+                                                  workingRepoDir]} -initialize_cmd :: [DarcsFlag] -> [String] -> IO ()-initialize_cmd opts _ = createRepository opts+initializeCmd :: [DarcsFlag] -> [String] -> IO ()+initializeCmd opts _ = createRepository opts \end{code}
src/Darcs/Commands/MarkConflicts.lhs view
@@ -25,25 +25,25 @@ import Darcs.SignalHandler ( withSignalsBlocked ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )-import Darcs.Arguments ( DarcsFlag, ignoretimes, working_repo_dir, umask_option )+import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )+import Darcs.Arguments ( DarcsFlag, ignoretimes, workingRepoDir, umaskOption ) import Darcs.Repository ( withRepoLock, ($-), amInRepository, add_to_pending,                     applyToWorking,-                    read_repo, sync_repo, get_unrecorded_unsorted,+                    read_repo, unrecordedChanges                     ) import Darcs.Patch ( invert )-import Darcs.Ordered ( FL(..) )-import Darcs.Sealed ( Sealed(Sealed) )+import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Resolution ( patchset_conflict_resolutions ) import Darcs.Utils ( promptYorn ) #include "impossible.h" -markconflicts_description :: String-markconflicts_description =+markconflictsDescription :: String+markconflictsDescription =  "Mark unresolved conflicts in working tree, for manual resolution." -markconflicts_help :: String-markconflicts_help =+markconflictsHelp :: String+markconflictsHelp =  "Darcs requires human guidance to unify changes to the same part of a\n" ++  "source file.  When a conflict first occurs, darcs will add both\n" ++  "choices to the working tree, delimited by the markers `v v v',\n" ++@@ -63,22 +63,22 @@  "alias still exists for backwards-compatibility.\n"  markconflicts :: DarcsCommand-markconflicts = DarcsCommand {command_name = "mark-conflicts",-                              command_help = markconflicts_help,-                              command_description = markconflicts_description,-                              command_extra_args = 0,-                              command_extra_arg_help = [],-                              command_command = markconflicts_cmd,-                              command_prereq = amInRepository,-                              command_get_arg_possibilities = return [],-                              command_argdefaults = nodefaults,-                              command_advanced_options = [umask_option],-                              command_basic_options = [ignoretimes,-                                                      working_repo_dir]}+markconflicts = DarcsCommand {commandName = "mark-conflicts",+                              commandHelp = markconflictsHelp,+                              commandDescription = markconflictsDescription,+                              commandExtraArgs = 0,+                              commandExtraArgHelp = [],+                              commandCommand = markconflictsCmd,+                              commandPrereq = amInRepository,+                              commandGetArgPossibilities = return [],+                              commandArgdefaults = nodefaults,+                              commandAdvancedOptions = [umaskOption],+                              commandBasicOptions = [ignoretimes,+                                                      workingRepoDir]} -markconflicts_cmd :: [DarcsFlag] -> [String] -> IO ()-markconflicts_cmd opts [] = withRepoLock opts $- \repository -> do-  pend <- get_unrecorded_unsorted repository+markconflictsCmd :: [DarcsFlag] -> [String] -> IO ()+markconflictsCmd opts [] = withRepoLock opts $- \repository -> do+  pend <- unrecordedChanges opts repository []   r <- read_repo repository   Sealed res <- return $ patchset_conflict_resolutions r   case res of NilFL -> do putStrLn "No conflicts to mark."@@ -86,21 +86,20 @@               _ -> return ()   case pend of     NilFL -> return ()-    _ ->      do yorn <- promptYorn-                         ("This will trash any unrecorded changes"++-                          " in the working directory.\nAre you sure? ")+    _ ->      do putStrLn ("This will trash any unrecorded changes"+++                          " in the working directory.")+                 yorn <- promptYorn "Are you sure? "                  when (yorn /= 'y') $ exitWith ExitSuccess                  applyToWorking repository opts (invert pend) `catch` \e ->                     bug ("Can't undo pending changes!" ++ show e)-                 sync_repo repository   withSignalsBlocked $     do add_to_pending repository res        applyToWorking repository opts res `catch` \e ->            bug ("Problem marking conflicts in mark-conflicts!" ++ show e)   putStrLn "Finished marking conflicts."-markconflicts_cmd _ _ = impossible+markconflictsCmd _ _ = impossible  -- |resolve is an alias for mark-conflicts. resolve :: DarcsCommand-resolve = command_alias "resolve" markconflicts+resolve = commandAlias "resolve" markconflicts \end{code}
src/Darcs/Commands/Move.lhs view
@@ -25,11 +25,12 @@ import Data.Maybe ( catMaybes ) import Darcs.SignalHandler ( withSignalsBlocked ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )-import Darcs.Arguments ( DarcsFlag( AllowCaseOnly, AllowWindowsReserved ),-                         fixSubPaths, working_repo_dir,-                        list_files, allow_problematic_filenames, umask_option,+import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )+import Darcs.Arguments ( DarcsFlag(),+                         fixSubPaths, workingRepoDir,+                        listFiles, allowProblematicFilenames, umaskOption,                       )+import Darcs.Flags ( doAllowCaseOnly, doAllowWindowsReserved ) import Darcs.RepoPath ( toFilePath, sp2fn ) import System.FilePath.Posix ( (</>), takeFileName ) import System.Directory ( renameDirectory )@@ -37,28 +38,27 @@ import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository,                     slurp_pending, add_to_pending,                   )-import Darcs.Ordered ( FL(..), unsafeFL )+import Darcs.Witnesses.Ordered ( FL(..), unsafeFL ) import Darcs.Global ( debugMessage ) import qualified Darcs.Patch import Darcs.Patch ( RepoPatch, Prim ) import Darcs.SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_has_anycase,                         slurp_remove, slurp_hasdir, slurp_hasfile )-import Darcs.Patch.FileName ( fp2fn, fn2fp, super_name )+import Darcs.Patch.FileName ( fp2fn, fn2fp, superName ) import qualified System.FilePath.Windows as WindowsFilePath -import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" -move_description :: String-move_description = "Move or rename files."+moveDescription :: String+moveDescription = "Move or rename files." -move_help :: String-move_help =+moveHelp :: String+moveHelp =  "Darcs cannot reliably distinguish between a file being deleted and a\n" ++  "new one added, and a file being moved.  Therefore Darcs always assumes\n" ++  "the former, and provides the `darcs mv' command to let Darcs know when\n" ++  "you want the latter.  This command will also move the file in the\n" ++- "working tree (unlike `darcs remove').\n" +++ "working tree (unlike `darcs remove'), unless it has already been moved.\n" ++  "\n" ++  -- Note that this paragraph is very similar to one in ./Add.lhs.  "Darcs will not rename a file if another file in the same folder has\n" ++@@ -69,51 +69,50 @@  "unusable on those systems!\n"  move :: DarcsCommand-move = DarcsCommand {command_name = "move",-                   command_help = move_help,-                   command_description = move_description,-                   command_extra_args = -1,-                   command_extra_arg_help = ["<SOURCE> ... <DESTINATION>"],-                   command_command = move_cmd,-                   command_prereq = amInRepository,-                   command_get_arg_possibilities = list_files,-                   command_argdefaults = nodefaults,-                   command_advanced_options = [umask_option],-                   command_basic_options = [allow_problematic_filenames, working_repo_dir]}-move_cmd :: [DarcsFlag] -> [String] -> IO ()-move_cmd _ [] = fail "The `darcs move' command requires at least two arguments."-move_cmd _ [_] = fail "The `darcs move' command requires at least two arguments."+move = DarcsCommand {commandName = "move",+                   commandHelp = moveHelp,+                   commandDescription = moveDescription,+                   commandExtraArgs = -1,+                   commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"],+                   commandCommand = moveCmd,+                   commandPrereq = amInRepository,+                   commandGetArgPossibilities = listFiles,+                   commandArgdefaults = nodefaults,+                   commandAdvancedOptions = [umaskOption],+                   commandBasicOptions = [allowProblematicFilenames, workingRepoDir]}+moveCmd :: [DarcsFlag] -> [String] -> IO ()+moveCmd _ [] = fail "The `darcs move' command requires at least two arguments."+moveCmd _ [_] = fail "The `darcs move' command requires at least two arguments." -move_cmd opts args@[_,_] = withRepoLock opts $- \repository -> do+moveCmd opts args@[_,_] = withRepoLock opts $- \repository -> do   two_files <- fixSubPaths opts args   [old,new] <- return $ case two_files of                         [_,_] -> two_files                         [_] -> error "Cannot rename a file or directory onto itself!"-                        xs -> bug $ "Problem in move_cmd: " ++ show xs+                        xs -> bug $ "Problem in moveCmd: " ++ show xs   work <- slurp "."   let old_fp = toFilePath old       new_fp = toFilePath new   if slurp_hasdir (sp2fn new) work && slurp_has old_fp work-   then move_to_dir repository opts [old_fp] new_fp+   then moveToDir repository opts [old_fp] new_fp    else do     cur <- slurp_pending repository     addpatch <- check_new_and_old_filenames opts cur work (old_fp,new_fp)-    invalidateIndex repository     withSignalsBlocked $ do       case addpatch of         Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)         Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)-      move_file_or_dir work old_fp new_fp+      moveFileOrDir work old_fp new_fp -move_cmd opts args =+moveCmd opts args =    withRepoLock opts $- \repository -> do      relpaths <- map toFilePath `fmap` fixSubPaths opts args      let moved = init relpaths          finaldir = last relpaths-     move_to_dir repository opts moved finaldir+     moveToDir repository opts moved finaldir -move_to_dir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()-move_to_dir repository opts moved finaldir =+moveToDir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()+moveToDir repository opts moved finaldir =   let movefns = map takeFileName moved       movetargets = map (finaldir </>) movefns       movepatches = zipWith Darcs.Patch.move moved movetargets@@ -121,31 +120,30 @@     cur <- slurp_pending repository     work <- slurp "."     addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets-    invalidateIndex repository     withSignalsBlocked $ do       add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches-      zipWithM_ (move_file_or_dir work) moved movetargets+      zipWithM_ (moveFileOrDir work) moved movetargets  check_new_and_old_filenames     :: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO (Maybe Prim) check_new_and_old_filenames opts cur work (old,new) = do-  unless (AllowWindowsReserved `elem` opts || WindowsFilePath.isValid new) $+  unless (doAllowWindowsReserved opts || WindowsFilePath.isValid new) $      fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++             "Use --reserved-ok to allow such filenames."   maybe_add_file_thats_been_moved <-      if slurp_has old work -- We need to move the object-     then do unless (slurp_hasdir (super_name $ fp2fn new) work) $+     then do unless (slurp_hasdir (superName $ fp2fn new) work) $                     fail $ "The target directory " ++-                             (fn2fp $ super_name $ fp2fn new)+++                             (fn2fp $ superName $ fp2fn new)++                              " isn't known in working directory, did you forget to add it?"              when (it_has new work) $ fail $ already_exists "working directory"              return Nothing      else do unless (slurp_has new work) $ fail $ doesnt_exist "working directory"              return $ Just $ Darcs.Patch.addfile old   if slurp_has old cur-     then do unless (slurp_hasdir (super_name $ fp2fn new) cur) $+     then do unless (slurp_hasdir (superName $ fp2fn new) cur) $                     fail $ "The target directory " ++-                             (fn2fp $ super_name $ fp2fn new)+++                             (fn2fp $ superName $ fp2fn new)++                              " isn't known in working directory, did you forget to add it?"              when (it_has new cur) $ fail $ already_exists "repository"      else fail $ doesnt_exist "repository"@@ -154,11 +152,11 @@             let ms2 = slurp_remove (fp2fn old) s             in case ms2 of                Nothing -> False-               Just s2 -> if AllowCaseOnly `elem` opts +               Just s2 -> if doAllowCaseOnly opts                           then slurp_has f s2                           else slurp_has_anycase f s2           already_exists what_slurpy =-              if AllowCaseOnly `elem` opts+              if doAllowCaseOnly opts               then "A file or dir named "++new++" already exists in "                        ++ what_slurpy ++ "."               else "A file or dir named "++new++" (or perhaps differing"++@@ -169,18 +167,18 @@               "There is no file or dir named " ++ old ++               " in the "++ what_slurpy ++ "." -move_file_or_dir :: Slurpy -> FilePath -> FilePath -> IO ()-move_file_or_dir work old new =-    if slurp_hasfile (fp2fn old) work-       then do debugMessage $ unwords ["renameFile",old,new]-               renameFile old new-       else if slurp_hasdir (fp2fn old) work-            then do debugMessage $ unwords ["renameDirectory",old,new]-                    renameDirectory old new-            else return ()+moveFileOrDir :: Slurpy -> FilePath -> FilePath -> IO ()+moveFileOrDir work old new+  | slurp_hasfile (fp2fn old) work =+    do debugMessage $ unwords ["renameFile",old,new]+       renameFile old new+  | slurp_hasdir (fp2fn old) work =+    do debugMessage $ unwords ["renameDirectory",old,new]+       renameDirectory old new+  | otherwise = return ()  mv :: DarcsCommand-mv = command_alias "mv" move+mv = commandAlias "mv" move \end{code}
src/Darcs/Commands/Optimize.lhs view
@@ -23,60 +23,81 @@ module Darcs.Commands.Optimize ( optimize ) where import Control.Monad ( when, unless ) import Data.Maybe ( isJust )-import Text.Regex ( mkRegex, matchRegex )-import System.Directory ( getDirectoryContents, doesDirectoryExist )+import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist )+import qualified Data.ByteString.Char8 as BS +import Storage.Hashed.Darcs( decodeDarcsSize )+ import Darcs.Hopefully ( hopefully, info ) import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag( Compress, UnCompress,+import Darcs.Arguments ( DarcsFlag( UpgradeFormat, UseHashedInventory,+                                    Compress, UnCompress,                                     NoCompress, Reorder,-                                    TagName, CheckPoint,-                                    Relink, RelinkPristine ),-                        tagname, checkpoint, reorder_patches,-                        uncompress_nocompress,-                        relink, relink_pristine, sibling,+                                    Relink, RelinkPristine, OptimizePristine ),+                        reorderPatches,+                        uncompressNocompress,+                        relink, relinkPristine, sibling,                         flagsToSiblings,-                        working_repo_dir, umask_option,+                        upgradeFormat,+                        workingRepoDir, umaskOption, optimizePristine                       )-import Darcs.Repository.Prefs ( get_preflist )+import Darcs.Repository.Prefs ( getPreflist ) import Darcs.Repository ( Repository, PatchSet, withRepoLock, ($-), withGutsOf,                           read_repo, optimizeInventory, slurp_recorded,                           tentativelyReplacePatches, cleanRepository,-                          amInRepository, finalizeRepositoryChanges )-import Darcs.Repository.Checkpoint ( write_checkpoint )-import Darcs.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL )-import Darcs.Patch.Info ( PatchInfo, just_name, human_friendly )+                          amInRepository, finalizeRepositoryChanges, replacePristine )+import Darcs.Witnesses.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL )+import Darcs.Patch.Info ( PatchInfo, just_name ) import Darcs.Patch ( RepoPatch ) import ByteStringUtils ( gzReadFilePS )-import Darcs.Patch.Depends ( deep_optimize_patchset, slightly_optimize_patchset,+import Darcs.Patch.Depends ( slightly_optimize_patchset,                  get_patches_beyond_tag, get_patches_in_tag,                ) import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS ) import Darcs.RepoPath ( toFilePath ) import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage )-import Printer ( putDocLn, text, ($$) ) import Darcs.SlurpDirectory ( slurp, list_slurpy_files ) import Darcs.Repository.Pristine ( identifyPristine, pristineDirectory )-import Darcs.Sealed ( FlippedSeal(..), unsafeUnseal )+import Darcs.Witnesses.Sealed ( FlippedSeal(..), unsafeUnseal ) import Darcs.Global ( darcsdir ) #include "impossible.h"+-- imports for optimize --upgrade; to be tidied+import qualified Data.ByteString as B (empty)+import System.Directory ( createDirectoryIfMissing, removeFile )+import System.FilePath.Posix ( takeExtension, (</>) ) -optimize_description :: String-optimize_description = "Optimize the repository."+import Progress ( beginTedious, endTedious, tediousSize, progress )+import SHA1 ( sha1PS )+import Darcs.Flags ( compression )+import Darcs.Lock ( rm_recursive )+import Darcs.Witnesses.Ordered ( mapFL, mapRL_RL, bunchFL, lengthRL )+import Darcs.ProgressPatches ( progressFL )+import Darcs.Repository.Cache ( hashedDir, HashedDir(HashedPristineDir) )+import Darcs.Repository.Format ( identifyRepoFormat,+                                 createRepoFormat, writeRepoFormat, formatHas,+                                 RepoProperty ( HashedInventory ) )+import qualified Darcs.Repository.HashedRepo as HashedRepo+import Darcs.Repository.Prefs ( getCaches )+import Darcs.Repository.Repair ( replayRepository, RepositoryConsistency(..) )+import Darcs.Repository.State ( readRecorded )+import Darcs.Utils ( catchall )+#include "gadts.h" -optimize_help :: String-optimize_help =+optimizeDescription :: String+optimizeDescription = "Optimize the repository."++optimizeHelp :: String+optimizeHelp =  "The `darcs optimize' command modifies the current repository in an\n" ++  "attempt to reduce its resource requirements.  By default a single\n" ++  "fast, safe optimization is performed; additional optimization\n" ++  "techniques can be enabled by passing options to `darcs optimize'.\n" ++- "\n" ++ optimize_help_inventory +++ "\n" ++ optimizeHelpInventory ++  -- "\n" ++ optimize_help_reorder ++- "\n" ++ optimize_help_relink ++- -- checkpoints and uncompression are least useful, so they are last.- "\n" ++ optimize_help_compression ++- "\n" ++ optimize_help_checkpoint +++ "\n" ++ optimizeHelpRelink +++ -- uncompression is least useful, so it is last.+ "\n" ++ optimizeHelpCompression ++  "\n" ++  "There is one more optimization which CAN NOT be performed by this\n" ++  "command.  Every time your record a patch, a new inventory file is\n" ++@@ -89,102 +110,56 @@  "unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n"  optimize :: DarcsCommand-optimize = DarcsCommand {command_name = "optimize",-                         command_help = optimize_help,-                         command_description = optimize_description,-                         command_extra_args = 0,-                         command_extra_arg_help = [],-                         command_command = optimize_cmd,-                         command_prereq = amInRepository,-                         command_get_arg_possibilities = return [],-                         command_argdefaults = nodefaults,-                         command_advanced_options = [uncompress_nocompress, umask_option],-                         command_basic_options = [checkpoint,-                                                 tagname,-                                                 working_repo_dir,-                                                 reorder_patches,+optimize = DarcsCommand {commandName = "optimize",+                         commandHelp = optimizeHelp,+                         commandDescription = optimizeDescription,+                         commandExtraArgs = 0,+                         commandExtraArgHelp = [],+                         commandCommand = optimizeCmd,+                         commandPrereq = amInRepository,+                         commandGetArgPossibilities = return [],+                         commandArgdefaults = nodefaults,+                         commandAdvancedOptions = [uncompressNocompress, umaskOption],+                         commandBasicOptions = [workingRepoDir,+                                                 reorderPatches,                                                  sibling, relink,-                                                 relink_pristine]}+                                                 relinkPristine,+                                                  upgradeFormat,+                                                 optimizePristine]} -optimize_cmd :: [DarcsFlag] -> [String] -> IO ()-optimize_cmd origopts _ = withRepoLock opts $- \repository -> do-    cleanRepository repository-    do_reorder opts repository-    do_optimize_inventory repository-    when (CheckPoint `elem` opts) $ do_checkpoint opts repository-    when (Compress `elem` opts || UnCompress `elem` opts) $ optimize_compression opts-    when (Relink `elem` opts || (RelinkPristine `elem` opts)) $-        do_relink opts repository+optimizeCmd :: [DarcsFlag] -> [String] -> IO ()+optimizeCmd origopts _ = do+    when (UpgradeFormat `elem` origopts) optimizeUpgradeFormat+    withRepoLock opts $- \repository -> do+    if (OptimizePristine `elem` opts)+       then doOptimizePristine repository+       else do cleanRepository repository+               doReorder opts repository+               doOptimizeInventory repository+               when (Compress `elem` opts || UnCompress `elem` opts) $+                    optimizeCompression opts+               when (Relink `elem` opts || (RelinkPristine `elem` opts)) $+                    doRelink opts repository     putStrLn "Done optimizing!"   where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts-is_tag :: PatchInfo -> Bool-is_tag pinfo = take 4 (just_name pinfo) == "TAG "+isTag :: PatchInfo -> Bool+isTag pinfo = take 4 (just_name pinfo) == "TAG " -optimize_help_inventory :: String-optimize_help_inventory =+optimizeHelpInventory :: String+optimizeHelpInventory =  "The default optimization moves recent patches (those not included in\n" ++  "the latest tag) to the `front', reducing the amount that a typical\n" ++  "remote command needs to download.  It should also reduce the CPU time\n" ++  "needed for some operations.\n" -do_optimize_inventory :: RepoPatch p => Repository p -> IO ()-do_optimize_inventory repository = do+doOptimizeInventory :: RepoPatch p => Repository p -> IO ()+doOptimizeInventory repository = do     debugMessage "Writing out a nice copy of the inventory."     optimizeInventory repository     debugMessage "Done writing out a nice copy of the inventory." -optimize_help_checkpoint :: String-optimize_help_checkpoint =- "If the repository is in `old-fashioned-inventory' format, the `darcs\n" ++- "optimize --checkpoint' command creates a checkpoint of the latest tag.\n" ++- "This checkpoint is used by `darcs get --partial' to create partial\n" ++- "repositories.  With the `--tag' option, checkpoints for older tags can\n" ++- "be created.  In newer repository formats, this feature has been\n" ++- "replaced by `darcs get --lazy', which does not require checkpoints.\n"--do_checkpoint :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()-do_checkpoint opts repository = do-    mpi <- get_tag opts repository-    case mpi of-      Nothing -> return ()-      Just pinfo -> do putDocLn $ text "Checkpointing tag:"-                               $$ human_friendly pinfo-                       write_checkpoint repository pinfo--get_tag :: RepoPatch p => [DarcsFlag] -> Repository p -> IO (Maybe PatchInfo)-get_tag [] r = do ps <- read_repo r-                  case filter is_tag $ lasts $ mapRL (mapRL info) ps of-                      [] -> do putStrLn "There is no tag to checkpoint!"-                               return Nothing-                      (pinfo:_) -> return $ Just pinfo-get_tag (TagName t:_) r =-    do ps <- read_repo r-       case filter (match_tag t) $ lasts $ mapRL (mapRL info) ps of-         (pinfo:_) -> return $ Just pinfo-         _ -> case filter (match_tag t) $-                   lasts $ mapRL (mapRL info) $ deep_optimize_patchset ps of-              (pinfo:_) -> return $ Just pinfo-              _ -> do putStr "Cannot checkpoint any tag "-                      putStr $ "matching '"++t++"'\n"-                      return Nothing-get_tag (_:fs) r = get_tag fs r--lasts :: [[a]] -> [a]-lasts [] = []-lasts (x@(_:_):ls) = last x : lasts ls-lasts ([]:ls) = lasts ls--mymatch :: String -> PatchInfo -> Bool-mymatch r = match_name $ matchRegex (mkRegex r)-match_name :: (String -> Maybe a) -> PatchInfo -> Bool-match_name ch pinfo = isJust $ ch (just_name pinfo)-match_tag :: String -> PatchInfo -> Bool-match_tag ('^':n) = mymatch $ "^TAG "++n-match_tag n = mymatch $ "^TAG .*"++n---optimize_help_compression :: String-optimize_help_compression =+optimizeHelpCompression :: String+optimizeHelpCompression =  "By default patches are compressed with zlib (RFC 1951) to reduce\n" ++  "storage (and download) size.  In exceptional circumstances, it may be\n" ++  "preferable to avoid compression.  In this case the `--dont-compress'\n" ++@@ -196,8 +171,8 @@  "repositories in the legacy `old-fashioned-inventory' format have a .gz\n" ++  "extension on patch files even when uncompressed.\n" -optimize_compression :: [DarcsFlag] -> IO ()-optimize_compression opts = do+optimizeCompression :: [DarcsFlag] -> IO ()+optimizeCompression opts = do     putStrLn "Optimizing (un)compression of patches..."     do_compress (darcsdir++"/patches")     putStrLn "Optimizing (un)compression of inventories..."@@ -213,8 +188,8 @@           notdot ('.':_) = False           notdot _ = True -optimize_help_relink :: String-optimize_help_relink =+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" ++@@ -229,10 +204,24 @@  "generally SHOULD NOT be used.  It results in a relatively small space\n" ++  "saving at the cost of making many Darcs commands MUCH slower.\n" -do_relink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()-do_relink opts repository =+doOptimizePristine :: RepoPatch p => Repository p -> IO ()+doOptimizePristine repo = do+  hashed <- doesFileExist $ "_darcs" </> "hashed_inventory"+  when hashed $ do+    inv <- BS.readFile ("_darcs" </> "hashed_inventory")+    let linesInv = BS.split '\n' inv+    case linesInv of+      [] -> return ()+      (pris_line:_) ->+          let size = decodeDarcsSize $ BS.drop 9 pris_line+           in when (isJust size) $ do putStrLn "Optimizing hashed pristine..."+                                      readRecorded repo >>= replacePristine repo+                                      cleanRepository repo++doRelink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()+doRelink opts repository =     do some_siblings <- return (flagsToSiblings opts)-       defrepolist <- get_preflist "defaultrepo"+       defrepolist <- getPreflist "defaultrepo"        siblings <- return (map toFilePath some_siblings ++ defrepolist)        if (siblings == [])            then putStrLn "No siblings -- no relinking done."@@ -281,7 +270,7 @@ \begin{code}  -- FIXME: someone needs to grovel through the source and determine--- just how optimizeInventory differs from do_reorder.  The following+-- just how optimizeInventory differs from doReorder.  The following -- is purely speculation. --twb, 2009-04 -- optimize_help_reorder :: String -- optimize_help_reorder =@@ -289,26 +278,88 @@ --  "of the default optimization.  It reorders patches with respect to ALL\n" ++ --  "tags, rather than just the latest tag.\n" -do_reorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()-do_reorder opts _ | not (Reorder `elem` opts) = return ()-do_reorder opts repository = do+doReorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()+doReorder opts _ | not (Reorder `elem` opts) = return ()+doReorder opts repository = do     debugMessage "Reordering the inventory."-    psnew <- choose_order `fmap` read_repo repository+    psnew <- chooseOrder `fmap` read_repo repository     let ps = mapFL_FL hopefully $ reverseRL $ head $ unsafeUnRL psnew     withGutsOf repository $ do tentativelyReplacePatches repository opts ps                                finalizeRepositoryChanges repository     debugMessage "Done reordering the inventory." -choose_order :: RepoPatch p => PatchSet p -> PatchSet p-choose_order ps | isJust last_tag =+chooseOrder :: RepoPatch p => PatchSet p -> PatchSet p+chooseOrder ps | isJust last_tag =     case slightly_optimize_patchset $ unsafeUnseal $ get_patches_in_tag lt ps of      ((t:<:NilRL):<:pps) -> case get_patches_beyond_tag lt ps of-                           FlippedSeal (p :<: NilRL) -> (p+<+(t:<:NilRL)) :<: pps-                           _ -> impossible+                           FlippedSeal p -> (p+<+(t:<:NilRL)) :<: pps     _ -> impossible             -    where last_tag = case filter is_tag $ mapRL info $ concatRL ps of+    where last_tag = case filter isTag $ mapRL info $ concatRL ps of                      (t:_) -> Just t                      _ -> Nothing           lt = fromJust last_tag-choose_order ps = ps+chooseOrder ps = ps+\end{code}++The \verb|--upgrade| option for \verb!darcs optimize! performs an inplace+upgrade of your repository to the lastest \emph{compatible} format.  Right now+means that darcs 1 old-fashioned repositories will be upgraded to darcs-1+hashed repositories (and notably, not to darcs 2 repositories as that would not+be compatible; see \verb!darcs convert!).++\begin{code}+optimizeUpgradeFormat :: IO ()+optimizeUpgradeFormat = do+  debugMessage $ "Upgrading to hashed..."+  rf <- either fail return =<< identifyRepoFormat "."+  debugMessage $ "Found our format"+  if formatHas HashedInventory rf+     then putStrLn "No action taken because this repository already is hashed."+     else do putStrLn "Checking repository in case of corruption..."+             withRepoLock [] $- \repository -> do+             state <- replayRepository repository [] return+             case state of+               RepositoryConsistent -> do+                 putStrLn "The repository is consistent."+                 actuallyUpgradeFormat repository+               _repoIsBroken ->+                 putStrLn "Corruption detected! Please run darcs repair first."++actuallyUpgradeFormat :: RepoPatch p => Repository p C(r u t) -> IO ()+actuallyUpgradeFormat repository = do+  -- convert patches/inventory+  patches <- read_repo repository+  let k = "Hashing patch"+  beginTedious k+  tediousSize k (lengthRL $ concatRL patches)+  let patches' = mapRL_RL (mapRL_RL (progress k)) patches+  cache <- getCaches [] "."+  let compr = compression [] -- default compression+  HashedRepo.write_tentative_inventory cache compr patches'+  endTedious k+  -- convert pristine by applying patches+  -- the faster alternative would be to copy pristine, but the apply method is more reliable+  let patchesToApply = progressFL "Applying patch" $ reverseRL $ concatRL $ patches'+  createDirectoryIfMissing False $ darcsdir </> hashedDir HashedPristineDir+  writeFile (darcsdir </> hashedDir HashedPristineDir </> sha1PS B.empty) ""+  sequence_ $ mapFL (HashedRepo.apply_to_tentative_pristine cache []) $ bunchFL 100 patchesToApply+  -- now make it official+  HashedRepo.finalize_tentative_changes repository compr+  writeRepoFormat (createRepoFormat [UseHashedInventory]) (darcsdir </> "format")+  -- clean out old-fashioned junk+  debugMessage "Cleaning out old-fashioned repository files..."+  removeFile   $ darcsdir </> "inventory"+  removeFile   $ darcsdir </> "tentative_inventory"+  rm_recursive (darcsdir </> "pristine") `catchall` rm_recursive (darcsdir </> "current")+  rmGzsIn (darcsdir </> "patches")+  rmGzsIn (darcsdir </> "inventories")+  let checkpointDir = darcsdir </> "checkpoints"+  hasCheckPoints <- doesDirectoryExist checkpointDir+  when hasCheckPoints $ rm_recursive checkpointDir+  putStrLn "Done upgrading!"+ where+  rmGzsIn dir =+    withCurrentDirectory dir $ do+      gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "."+      mapM_ removeFile gzs \end{code}
src/Darcs/Commands/Pull.lhs view
@@ -26,47 +26,48 @@ import Control.Monad ( when ) import Data.List ( nub ) -import Darcs.Commands ( DarcsCommand(..), loggers )+import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo ) import Darcs.CommandsAux ( check_paths )-import Darcs.Arguments ( DarcsFlag( Verbose, Quiet, DryRun, MarkConflicts, XMLOutput,-                                   Intersection, Complement, AllowConflicts, NoAllowConflicts ),+import Darcs.Arguments ( DarcsFlag( Verbose, DryRun, MarkConflicts,+                                   Intersection, Complement, AllowConflicts,+                                   NoAllowConflicts ),                          nocompress, ignoretimes, definePatches,-                         deps_sel, pull_conflict_options, use_external_merge,-                         match_several, fixUrl,-                         all_interactive, repo_combinator,-                         print_dry_run_message_and_exit,-                         test, dry_run,-                         set_default, summary, working_repo_dir, remote_repo,-                         set_scripts_executable, nolinks,-                         network_options, umask_option, allow_unrelated_repos, restrict_paths+                         depsSel, pullConflictOptions, useExternalMerge,+                         matchSeveral, fixUrl,+                         allInteractive, repoCombinator,+                         printDryRunMessageAndExit,+                         test, dryRun,+                         setDefault, summary, workingRepoDir, remoteRepo,+                         setScriptsExecutableOption, nolinks,+                         networkOptions, umaskOption, allowUnrelatedRepos, restrictPaths                       ) import Darcs.Repository ( Repository, SealedPatchSet, identifyRepositoryFor, withGutsOf,                           amInRepository, withRepoLock, ($-), tentativelyMergePatches,-                          sync_repo, finalizeRepositoryChanges, applyToWorking,-                          read_repo, checkUnrelatedRepos )+                          finalizeRepositoryChanges, applyToWorking,+                          read_repo, checkUnrelatedRepos, invalidateIndex ) import Darcs.Hopefully ( info ) import Darcs.Patch ( RepoPatch, description )-import Darcs.Ordered ( (:>)(..), (:\/:)(..), RL(..), unsafeUnRL, concatRL,+import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), RL(..),                              mapFL, nullFL, reverseRL, mapRL ) import Darcs.Patch.Permutations ( partitionFL )-import Darcs.SlurpDirectory ( wait_a_moment )-import Darcs.Repository.Prefs ( add_to_preflist, defaultrepo, set_defaultrepo, get_preflist )+import Darcs.Repository.Prefs ( addToPreflist, defaultrepo, setDefaultrepo, getPreflist ) import Darcs.Repository.Motd (show_motd ) import Darcs.Patch.Depends ( get_common_and_uncommon,                              patchset_intersection, patchset_union )-import Darcs.SelectChanges ( with_selected_changes )-import Darcs.Utils ( clarify_errors, formatPath )-import Darcs.Sealed ( Sealed(..), seal )+import Darcs.SelectChanges ( with_selected_changes, filterOutConflicts )+import Darcs.Utils ( clarifyErrors, formatPath )+import Darcs.Witnesses.Sealed ( Sealed(..), seal ) import Printer ( putDocLn, vcat, ($$), text )-import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" -pull_description :: String-pull_description =+#include "gadts.h"++pullDescription :: String+pullDescription =  "Copy and apply patches from another repository to this one." -pull_help :: String-pull_help =+pullHelp :: String+pullHelp =  "Pull is used to bring changes made in another repository into the current\n"++  "repository (that is, either the one in the current directory, or the one\n"++  "specified with the --repodir option). Pull allows you to bring over all or\n"++@@ -76,99 +77,99 @@  "recently either pushed or pulled.\n"  pull :: DarcsCommand-pull = DarcsCommand {command_name = "pull",-                     command_help = pull_help,-                     command_description = pull_description,-                     command_extra_args = -1,-                     command_extra_arg_help = ["[REPOSITORY]..."],-                     command_command = pull_cmd,-                     command_prereq = amInRepository,-                     command_get_arg_possibilities = get_preflist "repos",-                     command_argdefaults = defaultrepo,-                     command_advanced_options = [repo_combinator,+pull = DarcsCommand {commandName = "pull",+                     commandHelp = pullHelp,+                     commandDescription = pullDescription,+                     commandExtraArgs = -1,+                     commandExtraArgHelp = ["[REPOSITORY]..."],+                     commandCommand = pullCmd,+                     commandPrereq = amInRepository,+                     commandGetArgPossibilities = getPreflist "repos",+                     commandArgdefaults = defaultrepo,+                     commandAdvancedOptions = [repoCombinator,                                                  nocompress, nolinks,                                                  ignoretimes,-                                                 remote_repo,-                                                 set_scripts_executable,-                                                 umask_option,-                                                 restrict_paths] ++-                                                network_options,-                     command_basic_options = [match_several,-                                              all_interactive,-                                              pull_conflict_options,-                                              use_external_merge,-                                              test]++dry_run++[summary,-                                              deps_sel,-                                              set_default,-                                              working_repo_dir,-                                              allow_unrelated_repos]}--pull_cmd :: [DarcsFlag] -> [String] -> IO ()+                                                 remoteRepo,+                                                 setScriptsExecutableOption,+                                                 umaskOption,+                                                 restrictPaths] +++                                                networkOptions,+                     commandBasicOptions = [matchSeveral,+                                              allInteractive,+                                              pullConflictOptions,+                                              useExternalMerge,+                                              test]++dryRun++[summary,+                                              depsSel,+                                              setDefault,+                                              workingRepoDir,+                                              allowUnrelatedRepos]} -pull_cmd opts unfixedrepodirs@(_:_) =-  let (logMessage, _, logDocLn) = loggers opts-      putInfo = if (Quiet `elem` opts || XMLOutput `elem` opts) then \_ -> return () else logDocLn-      putVerbose = if Verbose `elem` opts then putDocLn else \_ -> return ()-  in withRepoLock opts $- \repository -> do+pullCmd :: [DarcsFlag] -> [String] -> IO ()+pullCmd opts unfixedrepodirs@(_:_) = withRepoLock opts $- \repository -> do   here <- getCurrentDirectory   repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl opts) unfixedrepodirs   -- Test to make sure we aren't trying to pull from the current repo   when (null repodirs) $         fail "Can't pull from current repository!"-  (Sealed them, Sealed compl) <- read_repos repository opts repodirs-  old_default <- get_preflist "defaultrepo"-  set_defaultrepo (head repodirs) opts-  mapM_ (add_to_preflist "repos") repodirs+  (Sealed them, Sealed compl) <- readRepos repository opts repodirs+  old_default <- getPreflist "defaultrepo"+  setDefaultrepo (head repodirs) opts+  mapM_ (addToPreflist "repos") repodirs   when (old_default == repodirs) $       let pulling = if DryRun `elem` opts then "Would pull" else "Pulling"-      in  putInfo $ text $ pulling++" from "++concatMap formatPath repodirs++"..."+      in  putInfo opts $ text $ pulling++" from "++concatMap formatPath repodirs++"..."   mapM_ (show_motd opts) repodirs   us <- read_repo repository   (common, us' :\/: them'') <- return $ get_common_and_uncommon (us, them)   (_     ,   _ :\/: compl') <- return $ get_common_and_uncommon (us, compl)   checkUnrelatedRepos opts common us them-  let avoided = mapRL info (concatRL compl')-  ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) $ reverseRL $ concatRL them''+  let avoided = mapRL info compl'+  ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) $ reverseRL them''   do when (Verbose `elem` opts) $           do case us' of-               (x@(_:<:_):<:_) -> putDocLn $ text "We have the following new (to them) patches:"-                                             $$ (vcat $ mapRL description x)+               (x@(_:<:_)) -> putDocLn $ text "We have the following new (to them) patches:"+                                         $$ (vcat $ mapRL description x)                _ -> return ()              when (not $ nullFL ps) $ putDocLn $ text "They have the following patches to pull:"-                                                 $$ (vcat $ mapFL description ps)-     when (nullFL ps) $ do putInfo $ text "No remote changes to pull in!"-                           definePatches ps+                      $$ (vcat $ mapFL description ps)+     let merge_opts | NoAllowConflicts `elem` opts = opts+                    | AllowConflicts   `elem` opts = opts+                    | otherwise                    = MarkConflicts : opts+     (hadConflicts, Sealed psFiltered) <- filterOutConflicts merge_opts us' repository ps+     when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."+     when (nullFL psFiltered)+                      $ do putInfo opts $ text "No remote changes to pull in!"+                           definePatches psFiltered                            exitWith ExitSuccess-     with_selected_changes "pull" opts ps $-      \ (to_be_pulled:>_) -> do-      print_dry_run_message_and_exit "pull" opts to_be_pulled-      definePatches to_be_pulled-      when (nullFL to_be_pulled) $ do-          logMessage "You don't want to pull any patches, and that's fine with me!"-          exitWith ExitSuccess-      check_paths opts to_be_pulled-      putVerbose $ text "Getting and merging the following patches:"-      putVerbose $ vcat $ mapFL description to_be_pulled-      let merge_opts | NoAllowConflicts `elem` opts = opts-                     | AllowConflicts   `elem` opts = opts-                     | otherwise                    = MarkConflicts : opts-      Sealed pw <- tentativelyMergePatches repository "pull" merge_opts-                   (reverseRL $ head $ unsafeUnRL us') to_be_pulled-      invalidateIndex repository-      withGutsOf repository $ do finalizeRepositoryChanges repository-                                 -- so work will be more recent than rec:-                                 revertable $ do wait_a_moment-                                                 applyToWorking repository opts pw-      sync_repo repository-      putInfo $ text "Finished pulling and applying."-          where revertable x = x `clarify_errors` 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."]-pull_cmd _ [] = fail "No default repository to pull from, please specify one"+     with_selected_changes "pull" opts Nothing psFiltered $+      \ (to_be_pulled:>_) ->+         do+           printDryRunMessageAndExit "pull" opts to_be_pulled+           definePatches to_be_pulled+           when (nullFL to_be_pulled) $ do+                               putStrLn "You don't want to pull any patches, and that's fine with me!"+                               exitWith ExitSuccess+           check_paths opts to_be_pulled+           putVerbose opts $ text "Getting and merging the following patches:"+           putVerbose opts $ vcat $ mapFL description to_be_pulled+           Sealed pw <- tentativelyMergePatches repository "pull" merge_opts+                       (reverseRL us') to_be_pulled+           invalidateIndex repository+           withGutsOf repository $ do finalizeRepositoryChanges repository+                                      revertable $ applyToWorking repository opts pw+           putInfo opts $ text "Finished pulling and applying." +pullCmd _ [] = fail "No default repository to pull from, please specify one"++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@@ -182,14 +183,14 @@                               R1 = 1st specified pull repo                               R2, R3, Rn = other specified pull repo -Since Rc is not provided here yet, the result of read_repos is a+Since Rc is not provided here yet, the result of readRepos is a tuple: the first patchset(s) to be complemented against Rc and then the second patchset(s) to be complemented against Rc. -} -read_repos :: RepoPatch p => Repository p -> [DarcsFlag] -> [String] -> IO (SealedPatchSet p,SealedPatchSet p)-read_repos _ _ [] = impossible-read_repos to_repo opts us =+readRepos :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [String] -> IO (SealedPatchSet p,SealedPatchSet p)+readRepos _ _ [] = impossible+readRepos to_repo opts us =     do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo u                             ps <- read_repo r                             return $ seal ps) us
src/Darcs/Commands/Push.lhs view
@@ -18,166 +18,173 @@ \darcsCommand{push} \begin{code} {-# OPTIONS_GHC -cpp #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, TypeOperators #-}  module Darcs.Commands.Push ( push ) where import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ) ) import Control.Monad ( when ) import Data.Char ( toUpper ) import Workaround ( getCurrentDirectory )-import Darcs.Commands ( DarcsCommand(..) )-import Darcs.Arguments ( DarcsFlag( DryRun, Verbose, Quiet, Sign, SignAs, NoSign, SignSSL ),+import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo, abortRun )+import Darcs.Arguments ( DarcsFlag( DryRun, Sign, SignAs, NoSign, SignSSL ),                          definePatches,-                         working_repo_dir, summary,-                         print_dry_run_message_and_exit,-                         applyas, match_several, fixUrl, deps_sel,-                         all_interactive, dry_run, nolinks,-                         remote_repo, network_options,-                         set_default, sign, allow_unrelated_repos+                         workingRepoDir, summary,+                         printDryRunMessageAndExit,+                         applyas, matchSeveral, fixUrl, depsSel,+                         allInteractive, dryRun, nolinks,+                         remoteRepo, networkOptions,+                         setDefault, sign, allowUnrelatedRepos                       )-import Darcs.Hopefully ( hopefully )-import Darcs.Repository ( withRepoReadLock, ($-), identifyRepositoryFor,+import Darcs.Hopefully ( PatchInfoAnd, hopefully )+import Darcs.Repository ( Repository, withRepoReadLock, ($-), identifyRepositoryFor,                           read_repo, amInRepository, checkUnrelatedRepos )-import Darcs.Patch ( description )-import Darcs.Ordered ( RL(..), (:>)(..), (:\/:)(..),-                             nullFL, reverseRL, mapFL_FL, unsafeUnRL, mapRL, lengthRL )-import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist )+import Darcs.Patch ( RepoPatch, description )+import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), RL, FL, nullRL,+                             nullFL, reverseRL, mapFL_FL, mapRL, lengthRL )+import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist ) import Darcs.External ( maybeURLCmd, signString ) import Darcs.URL ( is_url, is_file ) import Darcs.SelectChanges ( with_selected_changes ) import Darcs.Utils ( formatPath ) import Darcs.Patch.Depends ( get_common_and_uncommon ) import Darcs.Patch.Bundle ( make_bundle )-import Printer ( vcat, empty, text, ($$), (<+>), putDocLn, errorDoc )+import Darcs.Patch.Patchy( ShowPatch )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Set ( PatchSet )+import Printer ( Doc, vcat, empty, text, ($$) ) import Darcs.RemoteApply ( remote_apply, apply_as ) import Darcs.Email ( make_email ) import English (englishNum, Noun(..)) #include "impossible.h" -push_description :: String-push_description =+#include "gadts.h"++pushDescription :: String+pushDescription =  "Copy and apply patches from this repository to another one." -push_help :: String-push_help =+pushHelp :: String+pushHelp =  "Push is the opposite of pull.  Push allows you to copy changes from the\n"++  "current repository into another repository.\n"  push :: DarcsCommand-push = DarcsCommand {command_name = "push",-                     command_help = push_help,-                     command_description = push_description,-                     command_extra_args = 1,-                     command_extra_arg_help = ["[REPOSITORY]"],-                     command_command = push_cmd,-                     command_prereq = amInRepository,-                     command_get_arg_possibilities = get_preflist "repos",-                     command_argdefaults = defaultrepo,-                     command_advanced_options = [applyas,+push = DarcsCommand {commandName = "push",+                     commandHelp = pushHelp,+                     commandDescription = pushDescription,+                     commandExtraArgs = 1,+                     commandExtraArgHelp = ["[REPOSITORY]"],+                     commandCommand = pushCmd,+                     commandPrereq = amInRepository,+                     commandGetArgPossibilities = getPreflist "repos",+                     commandArgdefaults = defaultrepo,+                     commandAdvancedOptions = [applyas,                                                  nolinks,-                                                 remote_repo] ++-                                                network_options,-                     command_basic_options = [match_several, deps_sel,-                                              all_interactive,-                                              sign]++dry_run++[summary,-                                              working_repo_dir,-                                              set_default,-                                              allow_unrelated_repos]}+                                                 remoteRepo] +++                                                networkOptions,+                     commandBasicOptions = [matchSeveral, depsSel,+                                              allInteractive,+                                              sign]++dryRun++[summary,+                                              workingRepoDir,+                                              setDefault,+                                              allowUnrelatedRepos]} -push_cmd :: [DarcsFlag] -> [String] -> IO ()-push_cmd opts [""] = push_cmd opts []-push_cmd opts [unfixedrepodir] =-  let am_verbose = Verbose `elem` opts-      am_quiet = Quiet `elem` opts-      putVerbose s = when am_verbose $ putDocLn s-      putInfo s = when (not am_quiet) $ putDocLn s-  in+pushCmd :: [DarcsFlag] -> [String] -> IO ()+pushCmd _ [""] = impossible+pushCmd opts [unfixedrepodir] =  do  repodir <- fixUrl opts unfixedrepodir  -- Test to make sure we aren't trying to push to the current repo  here <- getCurrentDirectory+ checkOptionsSanity opts repodir  when (repodir == here) $        fail "Cannot push from repository to itself."        -- absolute '.' also taken into account by fix_filepath- (bundle,num_to_pull) <- withRepoReadLock opts $- \repository -> do-  if is_url repodir then do-       when (apply_as opts /= Nothing) $-           let msg = text "Cannot --apply-as when pushing to URLs" in-             if DryRun `elem` opts-             then putInfo $ text "NOTE: " <+> msg-                         $$ text ""-             else errorDoc msg-       maybeapply <- maybeURLCmd "APPLY" repodir-       when (maybeapply == Nothing) $-         let lprot = takeWhile (/= ':') repodir-             prot = map toUpper lprot-             msg = text ("Pushing to "++lprot++" URLs is not supported.\n"++-                         "You may be able to hack this to work"++-                         " using DARCS_APPLY_"++prot) in-           if DryRun `elem` opts-           then putInfo $ text "NOTE:" <+> msg-                       $$ text ""-           else errorDoc msg-   else do-       when (want_sign opts) $-        let msg = text "Signing doesn't make sense for local repositories or when pushing over ssh."-        in if DryRun `elem` opts-            then putInfo $ text "NOTE:" <+> msg-            else errorDoc msg+ (bundle) <- withRepoReadLock opts $-+                          prepareBundle opts repodir+ sbundle <- signString opts bundle+ let body = if is_file repodir+            then sbundle+            else make_email repodir [] Nothing sbundle Nothing+ rval <- remote_apply opts repodir body+ case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"+                                   exitWith (ExitFailure ec)+              ExitSuccess -> putInfo opts $ text "Push successful."+pushCmd _ _ = impossible++prepareBundle :: forall p C(r u t) . (RepoPatch p) => [DarcsFlag] -> String -> Repository p C(r u t) ->+                IO (Doc)+prepareBundle opts repodir repository = do   them <- identifyRepositoryFor repository repodir >>= read_repo-  old_default <- get_preflist "defaultrepo"-  set_defaultrepo repodir opts+  old_default <- getPreflist "defaultrepo"+  setDefaultrepo repodir opts   when (old_default == [repodir]) $        let pushing = if DryRun `elem` opts then "Would push" else "Pushing"-       in  putInfo $ text $ pushing++" to "++formatPath repodir++"..."+       in  putInfo opts $ text $ pushing++" to "++formatPath repodir++"..."   us <- read_repo repository   case get_common_and_uncommon (us, them) of     (common, us' :\/: them') -> do-     checkUnrelatedRepos opts common us them-     putVerbose $ text "We have the following patches to push:"-               $$ (vcat $ mapRL description $ head $ unsafeUnRL us')-     firstUs <- case us' of-                   NilRL:<:NilRL -> do putInfo $ text "No recorded local changes to push!"-                                       exitWith ExitSuccess-                   NilRL -> bug "push_cmd: us' is empty!"-                   (x:<:_) -> return x-     with_selected_changes "push" opts (reverseRL firstUs) $-      \ (to_be_pushed:>_) -> do+      prePushChatter opts common us us' them them'+      with_selected_changes "push" opts Nothing (reverseRL us') $ bundlePatches opts common++prePushChatter :: forall p a C(x y t) . (ShowPatch a) =>+                 [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) ->+                 RL a C(t x) -> PatchSet p C(y) -> RL a C(t y) -> IO ()+prePushChatter opts common us us' them them' = do+  checkUnrelatedRepos opts common us them+  let num_to_pull = lengthRL them'+  let pull_reminder = if num_to_pull > 0+                      then text $ "The remote repository has " ++ show num_to_pull +                      ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull."+                      else empty+  putVerbose opts $ text "We have the following patches to push:" $$ (vcat $ mapRL description us')+  when (not $ nullRL us') $ do putInfo opts $ pull_reminder+  when (nullRL us') $ do putInfo opts $ text "No recorded local changes to push!"+                         exitWith ExitSuccess++bundlePatches :: forall t p C(x y z w). RepoPatch p => [DarcsFlag] -> [PatchInfo]+                                          -> (FL (PatchInfoAnd p) :> t) C(z w)+                                          -> IO (Doc)+bundlePatches opts common (to_be_pushed :> _) =+    do       definePatches to_be_pushed-      print_dry_run_message_and_exit "push" opts to_be_pushed+      printDryRunMessageAndExit "push" opts to_be_pushed       when (nullFL to_be_pushed) $ do-          putInfo $+          putInfo opts $             text "You don't want to push any patches, and that's fine with me!"           exitWith ExitSuccess-      let num_to_pull = lengthRL $ head $ unsafeUnRL them'-          bundle = make_bundle []+      bundle <- make_bundle []                      (bug "using slurpy in make_bundle called from Push")                      common (mapFL_FL hopefully to_be_pushed)-      return (bundle, num_to_pull)- sbundle <- signString opts bundle- let body = if is_file repodir-            then sbundle-            else make_email repodir [] Nothing sbundle Nothing- rval <- remote_apply opts repodir body- let pull_reminder =-         if num_to_pull > 0-         then text $ "(By the way, the remote repository has " ++ show num_to_pull ++ " "-                     ++ englishNum num_to_pull (Noun "patch") " to pull.)"-         else empty- case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"-                                   exitWith (ExitFailure ec)-              ExitSuccess -> putInfo $ text "Push successful." $$ pull_reminder--push_cmd _ _ = impossible+      return (bundle) -want_sign :: [DarcsFlag] -> Bool-want_sign opts = case opts of+wantSign :: [DarcsFlag] -> Bool+wantSign opts = case opts of     []            -> False     Sign:_        -> True     (SignAs _):_  -> True     (SignSSL _):_ -> True     NoSign:_      -> False-    _:opts'       -> want_sign opts'+    _:opts'       -> wantSign opts'+++checkOptionsSanity :: [DarcsFlag] -> String -> IO ()+checkOptionsSanity opts repodir =+  if is_url repodir then do+       when (apply_as opts /= Nothing) $+           abortRun opts $ text "Cannot --apply-as when pushing to URLs"+       maybeapply <- maybeURLCmd "APPLY" repodir+       when (maybeapply == Nothing) $+         let lprot = takeWhile (/= ':') repodir+             prot = map toUpper lprot+             msg = text ("Pushing to "++lprot++" URLs is not supported.\n"+++                         "You may be able to hack this to work"+++                         " using DARCS_APPLY_"++prot) in+         abortRun opts msg+   else do+       when (wantSign opts) $+        abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh."+ \end{code}  For obvious reasons, you can only push to repositories to which you have
src/Darcs/Commands/Put.lhs view
@@ -8,38 +8,38 @@ import Control.Monad ( when ) import Data.Maybe ( catMaybes ) import System.Directory ( createDirectory )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag( Quiet, Verbose,-                                    UseFormat2, UseHashedInventory, UseOldFashionedInventory ),-                        applyas, match_one_context, fixUrl,-                        network_options, flagToString, get_inventory_choices,-                        set_scripts_executable, working_repo_dir, set_default+import Storage.Hashed.Tree( emptyTree )+import Darcs.Commands ( DarcsCommand(..), nodefaults, putVerbose, putInfo )+import Darcs.Arguments ( DarcsFlag( UseFormat2, UseHashedInventory, UseOldFashionedInventory ),+                        applyas, matchOneContext, fixUrl,+                        networkOptions, flagToString, getInventoryChoices,+                        setScriptsExecutableOption, workingRepoDir, setDefault                       ) import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, read_repo, amInRepository ) import Darcs.Repository.Format ( identifyRepoFormat,-                                 RepoProperty ( Darcs2, HashedInventory ), format_has )+                                 RepoProperty ( Darcs2, HashedInventory ), formatHas ) import Darcs.Patch.Bundle ( make_bundle2 )-import Darcs.Ordered ( FL(..) )-import Darcs.Match ( have_patchset_match, get_one_patchset )-import Darcs.Repository.Prefs ( get_preflist, set_defaultrepo )+import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Match ( havePatchsetMatch, getOnePatchset )+import Darcs.Repository.Prefs ( getPreflist, setDefaultrepo ) import Darcs.URL ( is_url, is_file ) import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )-import Darcs.SlurpDirectory ( empty_slurpy ) import Darcs.External ( execSSH ) import Darcs.RemoteApply ( remote_apply ) import Darcs.Commands.Init ( initialize ) import Darcs.Email ( make_email )-import Darcs.Sealed ( Sealed(..), seal )+import Darcs.Witnesses.Sealed ( Sealed(..), seal )+import Printer ( text ) #include "impossible.h" -put_description :: String -put_description =+putDescription :: String +putDescription =  "Makes a copy of the repository" -put_help :: String-put_help =+putHelp :: String+putHelp =  "The `darcs put' command creates a copy of the current repository.  It\n" ++  "is currently very inefficient, so when creating local copies you\n" ++  "should use `darcs get . x' instead of `darcs put x'.\n" ++@@ -50,27 +50,23 @@  "appropriate.  See those commands for an explanation of each option.\n"  put ::DarcsCommand-put = DarcsCommand {command_name = "put",-                    command_help = put_help,-                    command_description = put_description,-                    command_extra_args = 1,-                    command_extra_arg_help = ["<NEW REPOSITORY>"],-                    command_command = put_cmd,-                    command_prereq = amInRepository,-                    command_get_arg_possibilities = get_preflist "repos",-                    command_argdefaults = nodefaults,-                    command_advanced_options = [applyas] ++ network_options,-                    command_basic_options = [match_one_context, set_scripts_executable,-                                             get_inventory_choices,-                                             set_default, working_repo_dir]}+put = DarcsCommand {commandName = "put",+                    commandHelp = putHelp,+                    commandDescription = putDescription,+                    commandExtraArgs = 1,+                    commandExtraArgHelp = ["<NEW REPOSITORY>"],+                    commandCommand = putCmd,+                    commandPrereq = amInRepository,+                    commandGetArgPossibilities = getPreflist "repos",+                    commandArgdefaults = nodefaults,+                    commandAdvancedOptions = [applyas] ++ networkOptions,+                    commandBasicOptions = [matchOneContext, setScriptsExecutableOption,+                                             getInventoryChoices,+                                             setDefault, workingRepoDir]} -put_cmd :: [DarcsFlag] -> [String] -> IO ()-put_cmd _ [""] = fail "Empty repository argument given to put."-put_cmd opts [unfixedrepodir] =-  let am_quiet = Quiet `elem` opts-      putInfo s = when (not am_quiet) $ putStrLn s-      putVerbose = when (Verbose `elem` opts) . putStrLn-  in+putCmd :: [DarcsFlag] -> [String] -> IO ()+putCmd _ [""] = fail "Empty repository argument given to put."+putCmd opts [unfixedrepodir] =  do  repodir <- fixUrl opts unfixedrepodir  -- Test to make sure we aren't trying to push to the current repo@@ -83,52 +79,52 @@  when (is_url req_absolute_repo_dir) $ error "Can't put to a URL!"   debugMessage "Creating repository"- putVerbose "Creating repository"+ putVerbose opts $ text "Creating repository"  rf_or_e <- identifyRepoFormat "."  rf <- case rf_or_e of Left e -> fail e                        Right x -> return x- let initopts = if format_has Darcs2 rf+ let initopts = if formatHas Darcs2 rf                 then UseFormat2:filter (/= UseOldFashionedInventory) opts-                else if format_has HashedInventory rf &&+                else if formatHas HashedInventory rf &&                         not (UseOldFashionedInventory `elem` opts)                      then UseHashedInventory:filter (/= UseFormat2) opts                      else UseOldFashionedInventory:filter (/= UseFormat2) opts  if is_file req_absolute_repo_dir      then do createDirectory req_absolute_repo_dir-             withCurrentDirectory req_absolute_repo_dir $ (command_command initialize) initopts []+             withCurrentDirectory req_absolute_repo_dir $ (commandCommand initialize) initopts []      else do -- is_ssh req_absolute_repo_dir              remoteInit req_absolute_repo_dir initopts   withCurrentDirectory cur_absolute_repo_dir $                       withRepoReadLock opts $- \repository -> do-  set_defaultrepo req_absolute_repo_dir opts-  Sealed patchset <- if have_patchset_match opts-                     then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type+  setDefaultrepo req_absolute_repo_dir opts+  Sealed patchset <- if havePatchsetMatch opts+                     then getOnePatchset repository opts  -- todo: make sure getOnePatchset has the right type                      else read_repo repository >>= (return . seal)-  Sealed patchset2 <- if have_patchset_match opts-                      then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type+  Sealed patchset2 <- if havePatchsetMatch opts+                      then getOnePatchset repository opts  -- todo: make sure getOnePatchset has the right type                       else read_repo repository >>= (return . seal)   let patches = patchSetToPatches patchset       patches2 = patchSetToPatches patchset2       nullFL NilFL = True       nullFL _ = False   when (nullFL patches) $ do-          putInfo "No patches were selected to put. Nothing to be done."+          putInfo opts $ text "No patches were selected to put. Nothing to be done."           exitWith ExitSuccess-  let bundle = (make_bundle2 opts empty_slurpy [] patches patches2)-      message = if is_file req_absolute_repo_dir+  bundle <- make_bundle2 opts emptyTree [] patches patches2+  let message = if is_file req_absolute_repo_dir                 then bundle                 else make_email req_absolute_repo_dir [] Nothing bundle Nothing-  putVerbose "Applying patches in new repository..."+  putVerbose opts $ text "Applying patches in new repository..."   rval <- remote_apply opts req_absolute_repo_dir message   case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"                                     exitWith (ExitFailure ec)-               ExitSuccess -> putInfo "Put successful."-put_cmd _ _ = impossible+               ExitSuccess -> putInfo opts $ text "Put successful."+putCmd _ _ = impossible  remoteInit :: FilePath -> [DarcsFlag] -> IO () remoteInit repo opts = do-    let args = catMaybes $ map (flagToString $ command_basic_options initialize) opts+    let args = catMaybes $ map (flagToString $ commandBasicOptions initialize) opts         command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords args     exitCode <- execSSH addr command     when (exitCode /= ExitSuccess) $
src/Darcs/Commands/Record.lhs view
@@ -17,148 +17,142 @@  \darcsCommand{record} \begin{code}-{-# OPTIONS_GHC -cpp -fglasgow-exts #-} {-# LANGUAGE CPP, PatternGuards #-} -module Darcs.Commands.Record ( record, commit, get_date, get_log, file_exists ) where+module Darcs.Commands.Record ( record, commit, getDate, getLog, fileExists ) where+import qualified Ratified( hGetContents ) import Control.Exception ( handleJust, Exception( ExitException ) ) import Control.Monad ( filterM, when )-import System.IO ( hGetContents, stdin )+import System.IO ( stdin ) import Data.List ( sort, isPrefixOf ) import System.Exit ( exitWith, exitFailure, ExitCode(..) ) import System.IO ( hPutStrLn ) import System.Directory ( doesFileExist, doesDirectoryExist, removeFile ) import Data.Maybe ( isJust ) -import Darcs.Lock ( readBinFile, writeBinFile, world_readable_temp, appendToFile, removeFileMayNotExist )+import Darcs.Lock ( readBinFile, writeBinFile, world_readable_temp, appendToFile ) import Darcs.Hopefully ( info, n2pia ) import Darcs.Repository ( Repository, amInRepository, withRepoLock, ($-),-                          get_unrecorded_in_files,-                          get_unrecorded_in_files_unsorted, withGutsOf,-                    sync_repo, read_repo,+                          withGutsOf,+                    read_repo,                     slurp_recorded,-                    tentativelyAddPatch, finalizeRepositoryChanges,-                  )+                    tentativelyAddPatch, finalizeRepositoryChanges+                        , invalidateIndex, unrecordedChanges ) import Darcs.Patch ( RepoPatch, Patch, Prim, namepatch, summary, anonymous,                      adddeps, fromPrims )-import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+),+import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+),                              unsafeUnFL, unsafeCompare,                              reverseRL, mapFL, mapFL_FL, nullFL ) import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Split ( primSplitter ) import Darcs.SlurpDirectory ( slurp_hasfile, slurp_hasdir )-import Darcs.Patch.Choices ( patch_choices_tps, tp_patch,-                             force_first, get_choices, tag )+import Darcs.Patch.Choices ( patchChoicesTps, tpPatch,+                             forceFirst, getChoices, tag ) import Darcs.SelectChanges ( with_selected_changes_to_files',                              with_selected_changes_reversed ) import Darcs.RepoPath ( FilePathLike, SubPath, sp2fn, toFilePath ) import Darcs.SlurpDirectory ( Slurpy, empty_slurpy )-import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_stub )+import Darcs.Commands ( DarcsCommand(..), nodefaults, commandStub ) import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment,-                                    EditLongComment, RmLogFile, LogFile, Pipe,+                                    EditLongComment, LogFile, Pipe,                                     PatchName, AskDeps, All ),-                         get_author, working_repo_dir, lookforadds,+                         fileHelpAuthor,+                         getAuthor, workingRepoDir, lookforadds,                          fixSubPaths, defineChanges, testByDefault,-                         ask_long_comment, askdeps, patch_select_flag,-                         all_pipe_interactive, leave_test_dir, notest,-                         author, patchname_option, umask_option, ignoretimes,-                         nocompress, rmlogfile, logfile, list_registered_files,-                         set_scripts_executable )-import Darcs.Utils ( askUser, promptYorn, edit_file, clarify_errors )+                         askLongComment, askdeps, patchSelectFlag,+                         allPipeInteractive, leaveTestDir, notest,+                         author, patchnameOption, umaskOption, ignoretimes,+                         nocompress, rmlogfile, logfile, listRegisteredFiles,+                         setScriptsExecutableOption )+import Darcs.Flags (willRemoveLogFile)+import Darcs.Utils ( askUser, promptYorn, edit_file, clarifyErrors ) import Progress ( debugMessage) import Darcs.ProgressPatches( progressFL) import IsoDate ( getIsoDateTime, cleanLocalDate )-import Printer ( hPutDocLn, text, wrap_text, ($$), renderString )-import Darcs.Gorsvet( invalidateIndex )+import Printer ( hPutDocLn, text, wrap_text, ($$) ) #include "impossible.h" -record_description :: String-record_description =- "Save changes in the working copy to the repository as a patch."-\end{code}+recordDescription :: String+recordDescription = "Create a patch from unrecorded changes." -If you provide one or more files or directories as additional arguments-to record, you will only be prompted to changes in those files or-directories.-\begin{code}-record_help :: String-record_help = renderString $ wrap_text 80 $- "Record is used to name a set of changes and record the patch to the "++- "repository."+recordHelp :: String+recordHelp =+ "The `darcs record' command is used to create a patch from changes in\n" +++ "the working tree.  If you specify a set of files and directories,\n" +++ "changes to other files will be skipped.\n" +++ "\n" ++ recordHelp' +++ "\n" ++ recordHelp''  record :: DarcsCommand-record = DarcsCommand {command_name = "record",-                       command_help = record_help,-                       command_description = record_description,-                       command_extra_args = -1,-                       command_extra_arg_help = ["[FILE or DIRECTORY]..."],-                       command_command = record_cmd,-                       command_prereq = amInRepository,-                       command_get_arg_possibilities = list_registered_files,-                       command_argdefaults = nodefaults,-                       command_advanced_options = [logfile, rmlogfile,+record = DarcsCommand {commandName = "record",+                       commandHelp = recordHelp,+                       commandDescription = recordDescription,+                       commandExtraArgs = -1,+                       commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+                       commandCommand = recordCmd,+                       commandPrereq = amInRepository,+                       commandGetArgPossibilities = listRegisteredFiles,+                       commandArgdefaults = nodefaults,+                       commandAdvancedOptions = [logfile, rmlogfile,                                                    nocompress, ignoretimes,-                                                   umask_option,-                                                   set_scripts_executable],-                       command_basic_options = [patchname_option, author,+                                                   umaskOption,+                                                   setScriptsExecutableOption],+                       commandBasicOptions = [patchnameOption, author,                                                notest,-                                               leave_test_dir,-                                               all_pipe_interactive,+                                               leaveTestDir,+                                               allPipeInteractive,                                                askdeps,-                                               ask_long_comment,+                                               askLongComment,                                                lookforadds,-                                               working_repo_dir]}+                                               workingRepoDir]} -commit_description :: String-commit_description =- "Does not actually do anything, but offers advice on saving changes"+commitDescription :: String+commitDescription = "Redirect the user to record, push or send." -commit_help :: String-commit_help =+commitHelp :: String+commitHelp =  "This command does not do anything.\n"++  "If you want to save changes locally, use the `darcs record' command.\n"++  "If you want to save a recorded patch to another repository, use the\n"++  "`darcs push' or `darcs send' commands instead.\n"  commit :: DarcsCommand-commit = command_stub "commit" commit_help commit_description record+commit = commandStub "commit" commitHelp commitDescription record -file_exists :: Slurpy -> SubPath -> IO Bool-file_exists s rp = do file <- doesFileExist fp+fileExists :: Slurpy -> SubPath -> IO Bool+fileExists s rp =  do file <- doesFileExist fp                       dir <- doesDirectoryExist fp                       return (file || dir ||                               slurp_hasfile (sp2fn rp) s ||                               slurp_hasdir (sp2fn rp) s)                    where fp = toFilePath rp -record_cmd :: [DarcsFlag] -> [String] -> IO ()-record_cmd opts args = do-    check_name_is_not_option opts-    let (logMessage,_, _) = loggers opts+recordCmd :: [DarcsFlag] -> [String] -> IO ()+recordCmd opts args = do+    checkNameIsNotOption opts     withRepoLock (testByDefault opts) $- \repository -> do     rec <- if null args then return empty_slurpy            else slurp_recorded repository     files <- sort `fmap` fixSubPaths opts args     let non_repo_files = if null files && (not $ null args) then args else []-    existing_files <- filterM (file_exists rec) files-    non_existent_files <- filterM (fmap not . file_exists rec) files+    existing_files <- filterM (fileExists rec) files+    non_existent_files <- filterM (fmap not . fileExists rec) files     when (not $ null existing_files) $-         logMessage $ "Recording changes in "++unwords (map show existing_files)++":\n"+         putStrLn $ "Recording changes in "++unwords (map show existing_files)++":\n"     when (not $ null non_existent_files) $-         logMessage $ "Non existent files or directories: "++unwords (map show non_existent_files)++"\n"+         putStrLn $ "Non existent files or directories: "++unwords (map show non_existent_files)++"\n"     when (((not $ null non_existent_files) || (not $ null non_repo_files)) && null existing_files) $          fail "None of the files you specified exist!"     debugMessage "About to get the unrecorded changes."-    let existing_fns = map sp2fn existing_files-    changes <- if All `elem` opts then get_unrecorded_in_files_unsorted repository existing_fns-                                  else get_unrecorded_in_files repository existing_fns+    changes <- unrecordedChanges opts repository files     debugMessage "I've gotten unrecorded."     case allow_empty_with_askdeps changes of-      Nothing -> do when (Pipe `elem` opts) $ do get_date opts+      Nothing -> do when (Pipe `elem` opts) $ do getDate opts                                                  return ()                     if ((not $ null existing_files) || (not $ null non_existent_files))-                       then logMessage "No changes in selected files or directories!"-                       else logMessage "No changes!"-      Just ch -> do_record repository opts existing_files ch+                       then putStrLn "No changes in selected files or directories!"+                       else putStrLn "No changes!"+      Just ch -> doRecord repository opts existing_files ch     where allow_empty_with_askdeps NilFL               | AskDeps `elem` opts = Just NilFL               | otherwise = Nothing@@ -166,10 +160,9 @@   -- check that what we treat as the patch name is not accidentally a command  -- line flag-check_name_is_not_option :: [DarcsFlag] -> IO ()-check_name_is_not_option opts = do-    let (logMessage, _, _) = loggers opts-        patchNames = [n | PatchName n <- opts]+checkNameIsNotOption :: [DarcsFlag] -> IO ()+checkNameIsNotOption opts = do+    let patchNames = [n | PatchName n <- opts]     when (length patchNames == 1) $ do         let n = head patchNames             oneLetterName = length n == 1 || (length n == 2 && head n == '-')@@ -180,45 +173,45 @@                     case yorn of                          'y' -> return ()                         'n' -> do-                                   logMessage "Okay, aborting the record."+                                   putStrLn "Okay, aborting the record."                                    exitFailure                         _   -> keepAsking                 keepAsking             else return ()  -do_record :: RepoPatch p => Repository p -> [DarcsFlag] -> [SubPath] -> FL Prim -> IO ()-do_record repository opts files ps = do+doRecord :: RepoPatch p => Repository p -> [DarcsFlag] -> [SubPath] -> FL Prim -> IO ()+doRecord repository opts files ps = do     let make_log = world_readable_temp "darcs-record"-    date <- get_date opts-    my_author <- get_author opts+    date <- getDate opts+    my_author <- getAuthor opts     debugMessage "I'm slurping the repository."     debugMessage "About to select changes..."-    with_selected_changes_to_files' "record" opts+    with_selected_changes_to_files' "record" opts (Just primSplitter)       (map toFilePath files) ps $ \ (chs:>_) ->       do when (is_empty_but_not_askdeps chs) $               do putStrLn "Ok, if you don't want to record anything, that's fine!"                  exitWith ExitSuccess-         handleJust only_successful_exits (\_ -> return ()) $+         handleJust onlySuccessfulExits (\_ -> return ()) $              do deps <- if AskDeps `elem` opts-                        then ask_about_depends repository chs opts+                        then askAboutDepends repository chs opts                         else return []                 when (AskDeps `elem` opts) $ debugMessage "I've asked about dependencies."                 if nullFL chs && null deps                   then putStrLn "Ok, if you don't want to record anything, that's fine!"                   else do defineChanges chs-                          (name, my_log, logf) <- get_log opts Nothing make_log chs-                          do_actual_record repository opts name date+                          (name, my_log, logf) <- getLog opts Nothing make_log chs+                          doActualRecord repository opts name date                                  my_author my_log logf deps chs     where is_empty_but_not_askdeps l               | AskDeps `elem` opts = False                                       -- a "partial tag" patch; see below.               | otherwise = nullFL l -do_actual_record :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> String -> String+doActualRecord :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> String -> String                  -> [String] -> Maybe String                  -> [PatchInfo] -> FL Prim -> IO ()-do_actual_record repository opts name date my_author my_log logf deps chs =+doActualRecord repository opts name date my_author my_log logf deps chs =               do debugMessage "Writing the patch file..."                  mypatch <- namepatch date name my_author my_log $                             fromPrims $ progressFL "Writing changes:" chs@@ -226,62 +219,47 @@                  invalidateIndex repository                  debugMessage "Applying to pristine..."                  withGutsOf repository (finalizeRepositoryChanges repository)-                                    `clarify_errors` failuremessage+                                    `clarifyErrors` failuremessage                  debugMessage "Syncing timestamps..."-                 sync_repo repository                  when (isJust logf) $ removeFile (fromJust logf)-                 logMessage $ "Finished recording patch '"++name++"'"-    where (logMessage,_,_) = loggers opts-          failuremessage = "Failed to record patch '"++name++"'" +++                 putStrLn $ "Finished recording patch '"++name++"'"+    where failuremessage = "Failed to record patch '"++name++"'" ++                            case logf of Just lf -> "\nLogfile left in "++lf++"."                                         Nothing -> ""-\end{code}-Each patch is given a name, which typically would consist of a brief-description of the changes.  This name is later used to describe the patch.-The name must fit on one line (i.e.\ cannot have any embedded newlines).  If-you have more to say, stick it in the log.-\begin{code}-\end{code} -The patch is also flagged with the author of the change, taken by default-from the \verb!DARCS_EMAIL! environment variable, and if that doesn't-exist, from the \verb!EMAIL! environment variable.  The date on which the-patch was recorded is also included.  Currently there is no provision for-keeping track of when a patch enters a given repository.-\begin{code}-get_date :: [DarcsFlag] -> IO String-get_date opts- | Pipe `elem` opts = do cleanLocalDate `fmap` askUser "What is the date? "-get_date _ = getIsoDateTime-\end{code}-\label{DARCS_EDITOR}-Finally, each changeset should have a full log (which may be empty).  This-log is for detailed notes which are too lengthy to fit in the name.  If you-answer that you do want to create a comment file, darcs will open an editor-so that you can enter the comment in.  The choice of editor proceeds as-follows.  If one of the \verb!$DARCS_EDITOR!, \verb!$VISUAL! or-\verb!$EDITOR! environment variables is defined, its value is used (with-precedence proceeding in the order listed).  If not, ``vi'', ``emacs'',-``emacs~-nw'' and ``nano'' are tried in that order.--\begin{options}---logfile-\end{options}+recordHelp' :: String+recordHelp' =+ "Every patch has a name, an optional description, an author and a date.\n" +++ "\n" +++ "The patch name should be a short sentence that concisely describes the\n" +++ "patch, such as `Add error handling to main event loop.'  You can\n" +++ "supply it in advance with the -m option, or provide it when prompted.\n" +++ "\n" +++ "The patch description is an optional block of free-form text.  It is\n" +++ "used to supply additional information that doesn't fit in the patch\n" +++ "name.  For example, it might include a rationale of WHY the change was\n" +++ "necessary.  By default Darcs asks if you want to add a description;\n" +++ "the --edit-long-comment and --skip-long-comment can be used to answer\n" +++ "`yes' or `no' (respectively) to this prompt.  Finally, the --logfile\n" +++ "option allows you to supply a file that already contains the patch\n" +++ "name (first line) and patch description (subsequent lines).  This is\n" +++ "useful if a previous record failed and left a darcs-record-0 file.\n" +++ "\n" +++ unlines fileHelpAuthor +++ "\n" +++ "The patch date is generated automatically.  It can only be spoofed by\n" +++ "using the --pipe option.\n" -If you wish, you may specify the patch name and log using the-\verb!--logfile! flag.  If you do so, the first line of the specified file-will be taken to be the patch name, and the remainder will be the ``long-comment''.  This feature can be especially handy if you have a test that-fails several times on the record (thus aborting the record), so you don't-have to type in the long comment multiple times. The file's contents will-override the \verb!--patch-name! option.+getDate :: [DarcsFlag] -> IO String+getDate opts+ | Pipe `elem` opts = do cleanLocalDate `fmap` askUser "What is the date? "+getDate _ = getIsoDateTime -\begin{code} data PName = FlagPatchName String | PriorPatchName String | NoPatchName -get_log :: [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL Prim ->+getLog :: [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL Prim ->            IO (String, [String], Maybe String)-get_log opts m_old make_log chs = gl opts+getLog opts m_old make_log chs = gl opts     where patchname_specified = patchname_helper opts           patchname_helper (PatchName n:_) | take 4 n == "TAG " = FlagPatchName $ '.':n                                            | otherwise          = FlagPatchName n@@ -296,7 +274,7 @@                                   PriorPatchName p -> return p                                   NoPatchName      -> prompt_patchname False                            putStrLn "What is the log?"-                           thelog <- lines `fmap` hGetContents stdin -- ratify hGetContents: stdin not deleted+                           thelog <- lines `fmap` Ratified.hGetContents stdin                            return (p, thelog, Nothing)           gl (LogFile f:fs) =               do -- round 1 (patchname)@@ -311,8 +289,10 @@                  when (EditLongComment `elem` fs) $ do edit_file f                                                        return ()                  (name, thelog, _) <- read_long_comment f firstname-                 when (RmLogFile `elem` opts) $ removeFileMayNotExist f-                 return (name, thelog, Nothing)+                 let toRemove = if willRemoveLogFile opts+                        then Just $ toFilePath f+                        else Nothing+                 return (name, thelog, toRemove)           gl (EditLongComment:_) =                   case patchname_specified of                     FlagPatchName  p -> actually_get_log p@@ -408,49 +388,45 @@ depended-upon patches.  \begin{code}-ask_about_depends :: RepoPatch p => Repository p -> FL Prim -> [DarcsFlag] -> IO [PatchInfo]-ask_about_depends repository pa' opts = do+askAboutDepends :: RepoPatch p => Repository p -> FL Prim -> [DarcsFlag] -> IO [PatchInfo]+askAboutDepends repository pa' opts = do   pps <- read_repo repository   pa <- n2pia `fmap` anonymous (fromPrims pa')   let ps = (reverseRL $ headRL pps)+>+(pa:>:NilFL)-      (pc, tps) = patch_choices_tps ps-      ta = case filter ((pa `unsafeCompare`) . tp_patch) $ unsafeUnFL tps of+      (pc, tps) = patchChoicesTps ps+      ta = case filter ((pa `unsafeCompare`) . tpPatch) $ unsafeUnFL tps of                 [tp] -> tag tp-                [] -> error "ask_about_depends: []"-                _ -> error "ask_about_depends: many"-      ps' = mapFL_FL tp_patch $ middle_choice $ force_first ta pc-  with_selected_changes_reversed "depend on" (filter askdep_allowed opts) ps'+                [] -> error "askAboutDepends: []"+                _ -> error "askAboutDepends: many"+      ps' = mapFL_FL tpPatch $ middle_choice $ forceFirst ta pc+  with_selected_changes_reversed "depend on" (filter askdep_allowed opts) Nothing ps'              $ \(deps:>_) -> return $ mapFL info deps  where headRL (x:<:_) = x        headRL NilRL = impossible-       askdep_allowed = not . patch_select_flag-       middle_choice p = mc where (_ :> mc :> _) = get_choices p+       askdep_allowed = not . patchSelectFlag+       middle_choice p = mc where (_ :> mc :> _) = getChoices p  -only_successful_exits :: Exception -> Maybe ()-only_successful_exits (ExitException ExitSuccess) = Just ()-only_successful_exits _ = Nothing-\end{code}--\begin{options}---no-test,  --test-\end{options}--If you configure darcs to run a test suite, darcs will run this test on the-recorded repository to make sure it is valid.  Darcs first creates a pristine-copy of the source tree (in a temporary directory), then it runs the test,-using its return value to decide if the record is valid.  If it is not valid,-the record will be aborted.  This is a handy way to avoid making stupid-mistakes like forgetting to `darcs add' a new file.  It also can be-tediously slow, so there is an option (\verb!--no-test!) to skip the test.--\begin{options}---set-scripts-executable-\end{options}+onlySuccessfulExits :: Exception -> Maybe ()+onlySuccessfulExits (ExitException ExitSuccess) = Just ()+onlySuccessfulExits _ = Nothing -If you pass \verb!--set-scripts-executable! to \verb!darcs record!, darcs will set scripts-executable in the test directory before running the test.+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, the record operation will be aborted.\n" +++ "\n" +++ "The --set-scripts-executable option causes scripts to be made\n" +++ "executable in the clean copy of the working tree, prior to running the\n" +++ "test.  See `darcs get' for an explanation of the script heuristic.\n" +++ "\n" +++ "If your test command is tediously slow (e.g. `make all') and you are\n" +++ "recording several patches in a row, you may wish to use --no-test to\n" +++ "skip all but the final test.\n" +\end{code} \begin{options} --pipe \end{options}
src/Darcs/Commands/Remove.lhs view
@@ -24,29 +24,37 @@  import Control.Monad ( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults,-                        command_alias, command_stub,+                        commandAlias, commandStub,+                        putWarning                       )-import Darcs.Arguments ( DarcsFlag, fixSubPaths,-                        list_registered_files,-                        working_repo_dir, umask_option+import Darcs.Arguments ( DarcsFlag (Recursive), fixSubPaths,+                        listRegisteredFiles,+                        workingRepoDir, umaskOption,+                        recursive                        )-import Darcs.RepoPath ( SubPath, toFilePath, sp2fn )+import Darcs.RepoPath ( SubPath, sp2fn ) import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository,-                          slurp_pending, slurp_recorded,-                          get_unrecorded_in_files, add_to_pending )-import Darcs.Patch ( RepoPatch, Prim, apply_to_slurpy, adddir, rmdir, addfile, rmfile )-import Darcs.Ordered ( FL(..), (+>+) )-import Darcs.SlurpDirectory ( slurp_removedir, slurp_removefile )-import Darcs.Repository.Prefs ( filetype_function )-import Darcs.Diff ( unsafeDiff )-import Darcs.Gorsvet( invalidateIndex )-#include "impossible.h"+                          add_to_pending, readRecordedAndPending, readUnrecorded )+import Darcs.Diff( treeDiff )+import Darcs.Patch ( RepoPatch, Prim, adddir, rmdir, addfile, rmfile )+import Darcs.Patch.FileName( fn2fp )+import Darcs.Witnesses.Ordered ( FL(..), (+>+) )+import Darcs.Witnesses.Sealed ( Sealed(..) )+import Darcs.Repository.Prefs ( filetypeFunction )+import Storage.Hashed.Tree( TreeItem(..), find, modifyTree, expand )+import Storage.Hashed.AnchoredPath( anchorPath )+import Storage.Hashed( floatPath ) -remove_description :: String-remove_description = "Remove files from version control."+import Darcs.Commands.Add( expandDirs )+import Printer ( text ) -remove_help :: String-remove_help =+#include "gadts.h"++removeDescription :: String+removeDescription = "Remove files from version control."++removeHelp :: String+removeHelp =  "The `darcs remove' command exists primarily for symmetry with `darcs\n" ++  "add', as the normal way to remove a file from version control is\n" ++  "simply to delete it from the working tree.  This command is only\n" ++@@ -57,64 +65,65 @@  "the patch) will ALWAYS affect the working tree of that repository.\n"  remove :: DarcsCommand-remove = DarcsCommand {command_name = "remove",-                       command_help = remove_help,-                       command_description = remove_description,-                       command_extra_args = -1,-                       command_extra_arg_help = ["<FILE or DIRECTORY> ..."],-                       command_command = remove_cmd,-                       command_prereq = amInRepository,-                       command_get_arg_possibilities = list_registered_files,-                       command_argdefaults = nodefaults,-                       command_advanced_options = [umask_option],-                       command_basic_options =-                           [working_repo_dir]}+remove = DarcsCommand {commandName = "remove",+                       commandHelp = removeHelp,+                       commandDescription = removeDescription,+                       commandExtraArgs = -1,+                       commandExtraArgHelp = ["<FILE or DIRECTORY> ..."],+                       commandCommand = removeCmd,+                       commandPrereq = amInRepository,+                       commandGetArgPossibilities = listRegisteredFiles,+                       commandArgdefaults = nodefaults,+                       commandAdvancedOptions = [umaskOption],+                       commandBasicOptions =+                           [workingRepoDir, recursive "recurse into subdirectories"]} -remove_cmd :: [DarcsFlag] -> [String] -> IO ()-remove_cmd opts relargs =+removeCmd :: [DarcsFlag] -> [String] -> IO ()+removeCmd opts relargs =     withRepoLock opts $- \repository -> do-    args <- fixSubPaths opts relargs+    origfiles <- fixSubPaths opts relargs+    args <- if Recursive `elem` opts+            then reverse `fmap` expandDirs origfiles+            else return origfiles     when (null args) $       putStrLn "Nothing specified, nothing removed."-    p <- make_remove_patch repository args-    invalidateIndex repository+    Sealed p <- makeRemovePatch opts repository args     add_to_pending repository p -make_remove_patch :: RepoPatch p => Repository p -> [SubPath] -> IO (FL Prim)-make_remove_patch repository files =-                          do s <- slurp_pending repository-                             srecorded <- slurp_recorded repository-                             pend <- get_unrecorded_in_files repository (map sp2fn files)-                             let sunrec = fromJust $ apply_to_slurpy pend srecorded-                             wt <- filetype_function-                             mrp wt s sunrec files-    where mrp wt s sunrec (f:fs) =-              case slurp_removedir fn s of-              Just s' ->-                  case slurp_removedir fn sunrec of-                  Just sunrec' -> do rest <- mrp wt s' sunrec' fs-                                     return $ rmdir f_fp :>: rest-                  Nothing -> do rest <- mrp wt s' sunrec fs-                                return $ adddir f_fp :>: rmdir f_fp :>: rest-              Nothing ->-                  case slurp_removefile fn s of-                  Nothing -> fail $ "Can't remove "++f_fp-                  Just s' ->-                      case slurp_removefile fn sunrec of-                      Nothing -> do rest <- mrp wt s' sunrec fs-                                    return $ addfile f_fp :>: rmfile f_fp :>: rest-                      Just sunrec' -> do rest <- mrp wt s' sunrec' fs-                                         let newp = unsafeDiff [] wt sunrec sunrec'-                                         return $ newp +>+ rest-            where fn = sp2fn f-                  f_fp = toFilePath f-          mrp _ _ _ [] = return NilFL+makeRemovePatch :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)+                  -> [SubPath] -> IO (Sealed (FL Prim C(u)))+makeRemovePatch opts repository files =+                          do recorded <- expand =<< readRecordedAndPending repository+                             unrecorded <- readUnrecorded repository+                             ftf <- filetypeFunction+                             mrp ftf recorded unrecorded $ map (floatPath . fn2fp . sp2fn) files+    where mrp ftf recorded unrecorded (f:fs) = do+            let recorded' = modifyTree recorded f Nothing+                unrecorded' = modifyTree unrecorded f Nothing+            Sealed rest <- mrp ftf recorded' unrecorded' fs+            let f_fp = anchorPath "" f -rm_description :: String-rm_description = "Help newbies find `darcs remove'."+            case (find recorded f, find unrecorded f) of+              (Just (SubTree _), Just (SubTree _)) ->+                  return . Sealed $ rmdir f_fp :>: rest+              (Just (File _), Just (File _)) ->+                  do diff <- treeDiff ftf unrecorded unrecorded'+                     return . Sealed $ diff +>+ rest+              (Just (File _), _) ->+                  return . Sealed $ addfile f_fp :>: rmfile f_fp :>: rest+              (Just (SubTree _), _) ->+                  return . Sealed $ adddir f_fp :>: rmdir f_fp :>: rest+              (_, _) -> do putWarning opts . text $ "Can't remove " ++ f_fp+                           return $ Sealed rest+                             -rm_help :: String-rm_help =+          mrp _ _ _ [] = return (Sealed NilFL)++rmDescription :: String+rmDescription = "Help newbies find `darcs remove'."++rmHelp :: String+rmHelp =  "The `darcs rm' command does nothing.\n" ++  "\n" ++  "The normal way to remove a file from version control is simply to\n" ++@@ -122,10 +131,10 @@  "control WITHOUT affecting the working tree, see `darcs remove'.\n"  rm :: DarcsCommand-rm = command_stub "rm" rm_help rm_description remove+rm = commandStub "rm" rmHelp rmDescription remove  unadd :: DarcsCommand-unadd = command_alias "unadd" remove+unadd = commandAlias "unadd" remove \end{code}
src/Darcs/Commands/Repair.lhs view
@@ -17,54 +17,59 @@  \darcsCommand{repair} \begin{code}-module Darcs.Commands.Repair ( repair ) where+module Darcs.Commands.Repair ( repair, repairCmd ) where import System.IO+import Control.Monad( unless )+import System.Directory( renameFile )  import Darcs.Commands-import Darcs.Arguments ( DarcsFlag(),-                        working_repo_dir, umask_option,+import Darcs.Arguments ( DarcsFlag( Quiet ),+                        workingRepoDir, umaskOption,                       ) import Darcs.Repository ( withRepoLock, ($-), amInRepository,-                          replacePristineFromSlurpy, writePatchSet )-import Darcs.Repository.Repair( replayRepository,-                                RepositoryConsistency(..) )+                          replacePristine, writePatchSet )+import Darcs.Repository.Repair( replayRepository, checkIndex+                              , RepositoryConsistency(..) ) -repair_description :: String-repair_description = "Repair a corrupted repository."+repairDescription :: String+repairDescription = "Repair a corrupted repository." -repair_help :: String-repair_help =+repairHelp :: String+repairHelp =  "The `darcs repair' command attempts to fix corruption in the current\n" ++  "repository.  Currently it can only repair damage to the pristine tree,\n" ++  "which is where most corruption occurs.\n"  repair :: DarcsCommand-repair = DarcsCommand {command_name = "repair",-                       command_help = repair_help,-                       command_description = repair_description,-                       command_extra_args = 0,-                       command_extra_arg_help = [],-                       command_command = repair_cmd,-                       command_prereq = amInRepository,-                       command_get_arg_possibilities = return [],-                       command_argdefaults = nodefaults,-                       command_advanced_options = [umask_option],-                       command_basic_options = [working_repo_dir]}+repair = DarcsCommand {commandName = "repair",+                       commandHelp = repairHelp,+                       commandDescription = repairDescription,+                       commandExtraArgs = 0,+                       commandExtraArgHelp = [],+                       commandCommand = repairCmd,+                       commandPrereq = amInRepository,+                       commandGetArgPossibilities = return [],+                       commandArgdefaults = nodefaults,+                       commandAdvancedOptions = [umaskOption],+                       commandBasicOptions = [workingRepoDir]} -repair_cmd :: [DarcsFlag] -> [String] -> IO ()-repair_cmd opts _ = withRepoLock opts $- \repository -> do+repairCmd :: [DarcsFlag] -> [String] -> IO ()+repairCmd opts _ = withRepoLock opts $- \repository -> do   replayRepository repository opts $ \state ->     case state of       RepositoryConsistent ->           putStrLn "The repository is already consistent, no changes made."-      BrokenPristine s -> do+      BrokenPristine tree -> do                putStrLn "Fixing pristine tree..."-               replacePristineFromSlurpy repository s-      BrokenPatches s newps  -> do+               replacePristine repository tree+      BrokenPatches tree newps  -> do                putStrLn "Writing out repaired patches..."                writePatchSet newps opts                putStrLn "Fixing pristine tree..."-               replacePristineFromSlurpy repository s+               replacePristine repository tree                return ()+  index_ok <- checkIndex repository (Quiet `elem` opts)+  unless index_ok $ do renameFile "_darcs/index" "_darcs/index.bad"+                       putStrLn "Bad index discarded."  \end{code}
src/Darcs/Commands/Replace.lhs view
@@ -23,37 +23,46 @@ module Darcs.Commands.Replace ( replace ) where  import Data.Maybe ( isJust )-import Control.Monad ( unless )+import Control.Monad ( unless, filterM )+import Control.Applicative( (<$>) ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help,-                        command_description, command_extra_args,-                        command_extra_arg_help, command_command, command_prereq,-                        command_get_arg_possibilities, command_argdefaults,-                        command_advanced_options, command_basic_options),+import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp,+                        commandDescription, commandExtraArgs,+                        commandExtraArgHelp, commandCommand, commandPrereq,+                        commandGetArgPossibilities, commandArgdefaults,+                        commandAdvancedOptions, commandBasicOptions),                         nodefaults )-import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), list_registered_files,-                         ignoretimes, umask_option, tokens, force_replace,-                         working_repo_dir, fixSubPaths )+import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), listRegisteredFiles,+                         ignoretimes, umaskOption, tokens, forceReplace,+                         workingRepoDir, fixSubPaths ) import Darcs.Repository ( withRepoLock, ($-),-                    add_to_pending, slurp_pending,-                    amInRepository, slurp_recorded_and_unrecorded,+                    add_to_pending,+                    amInRepository,                     applyToWorking,+                    readUnrecorded, readRecordedAndPending                   )-import Darcs.Patch ( Prim, apply_to_slurpy, tokreplace, force_replace_slurpy )-import Darcs.Ordered ( FL(..), unsafeFL, (+>+), concatFL )-import Darcs.SlurpDirectory ( slurp_hasfile, Slurpy )-import RegChars ( regChars )+import Darcs.Patch ( Prim, tokreplace, applyToTree )+import Darcs.Patch.Apply ( forceTokReplace )+import Darcs.Patch.FileName( fn2fp )+import Darcs.Patch.Patchy ( Apply )+import Darcs.Witnesses.Ordered ( FL(..), unsafeFL, (+>+), concatFL )+import Darcs.Patch.RegChars ( regChars ) import Data.Char ( isSpace )-import Darcs.Diff ( unsafeDiff )-import Darcs.RepoPath ( SubPath, sp2fn, toFilePath )+import Darcs.RepoPath ( SubPath, toFilePath, sp2fn ) import Darcs.Repository.Prefs ( FileType(TextFile) )+import Darcs.Diff( treeDiff )+import Storage.Hashed.Tree( readBlob, modifyTree , findFile, TreeItem(..), Tree, makeBlobBS )+import Storage.Hashed.AnchoredPath( AnchoredPath, floatPath )++import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS #include "impossible.h" -replace_description :: String-replace_description = "Substitute one word for another."+replaceDescription :: String+replaceDescription = "Substitute one word for another." -replace_help :: String-replace_help =+replaceHelp :: String+replaceHelp =  "In addition to line-based patches, Darcs supports a limited form of\n" ++  "lexical substitution.  Files are treated as sequences of words, and\n" ++  "each occurrence of the old word is replaced by the new word.\n" ++@@ -64,30 +73,20 @@  "\n" ++  "Files are tokenized according to one simple rule: words are strings of\n" ++  "valid token characters, and everything between them (punctuation and\n" ++- "whitespace) is discarded.\n" ++- "\n" ++- "The tokenizer treats files as byte strings, so it is not possible for\n" ++- "--token-chars to include multi-byte characters, such as the non-ASCII\n" ++- "parts of UTF-8.  Similarly, trying to replace a `high-bit' character\n" ++- "from a unibyte encoding will also result in replacement of the same\n" ++- "byte in files with different encodings.  For example, an acute a from\n" ++- "ISO 8859-1 will also match an alpha from ISO 8859-7.\n" ++- "\n" ++  -- FIXME: this heuristic is ham-fisted and silly.  Can we drop it?- "By default, valid token characters are letters, numbers and the\n" ++- "underscore (i.e. [A-Za-z0-9_]).  However if the old and/or new token\n" ++- "contains either a hyphen or period, BOTH hyphen and period are treated\n" ++- "as valid by default (i.e. [A-Za-z0-9_.-]).\n" +++ "whitespace) is discarded.  By default, valid token characters are\n" +++ "letters, numbers and the underscore (i.e. [A-Za-z0-9_]).  However if\n" +++ "the old and/or new token contains either a hyphen or period, BOTH\n" +++ "hyphen and period are treated as valid (i.e. [A-Za-z0-9_.-]).\n" ++  "\n" ++  "The set of valid characters can be customized using the --token-chars\n" ++  "option.  The argument must be surrounded by square brackets.  If a\n" ++  "hyphen occurs between two characters in the set, it is treated as a\n" ++  "set range.  For example, in most locales [A-Z] denotes all uppercase\n" ++  "letters.  If the first character is a caret, valid tokens are taken to\n" ++- "be the complement of the remaining characters.  For example, [^ \\n\\t]\n" ++- "declares all characters except the space, tab and newline as valid\n" ++- "within a word.  Unlike the tr(1) and grep(1) utilities, character\n" ++- "classes (such as [[:alnum:]]) are NOT supported.\n" +++ "be the complement of the remaining characters.  For example, [^:\\n]\n" +++ "could be used to match fields in the passwd(5), where records and\n" +++ "fields are separated by newlines and colons respectively.\n" ++  "\n" ++  "If you choose to use --token-chars, you are STRONGLY encouraged to do\n" ++  "so consistently.  The consequences of using multiple replace patches\n" ++@@ -98,7 +97,25 @@  "is already in use, because the replacements would be not be\n" ++  "distinguishable from the existing tokens.  This behaviour can be\n" ++  "overridden by supplying the --force option, but an attempt to `darcs\n" ++- "rollback' the resulting patch will affect these existing tokens.\n"+ "rollback' the resulting patch will affect these existing tokens.\n" +++ "\n" +++ "Limitations:\n" +++ "\n" +++ "The tokenizer treats files as byte strings, so it is not possible for\n" +++ "--token-chars to include multi-byte characters, such as the non-ASCII\n" +++ "parts of UTF-8.  Similarly, trying to replace a `high-bit' character\n" +++ "from a unibyte encoding will also result in replacement of the same\n" +++ "byte in files with different encodings.  For example, an acute a from\n" +++ "ISO 8859-1 will also match an alpha from ISO 8859-7.\n" +++ "\n" +++ "Due to limitations in the patch file format, --token-chars arguments\n" +++ "cannot contain literal whitespace.  For example, [^ \\n\\t] cannot be\n" +++ "used to declare all characters except the space, tab and newline as\n" +++ "valid within a word, because it contains a literal space.\n" +++ "\n" +++ "Unlike POSIX regex(7) bracket expressions, character classes (such as\n" +++ "[[:alnum:]]) are NOT supported by --token-chars, and will be silently\n" +++ "treated as a simple set of characters.\n"  -- FIXME: can  we just  delete the remaining  text?  It seems  more an -- instance of "look how clever  I am; I made commutation work" rather@@ -127,85 +144,99 @@ \begin{code}  replace :: DarcsCommand-replace = DarcsCommand {command_name = "replace",-                        command_help = replace_help,-                        command_description = replace_description,-                        command_extra_args = -1,-                        command_extra_arg_help = ["<OLD>","<NEW>",+replace = DarcsCommand {commandName = "replace",+                        commandHelp = replaceHelp,+                        commandDescription = replaceDescription,+                        commandExtraArgs = -1,+                        commandExtraArgHelp = ["<OLD>","<NEW>",                                                   "<FILE> ..."],-                        command_command = replace_cmd,-                        command_prereq = amInRepository,-                        command_get_arg_possibilities = list_registered_files,-                        command_argdefaults = nodefaults,-                        command_advanced_options = [ignoretimes, umask_option],-                        command_basic_options =-                            [tokens, force_replace, working_repo_dir]}+                        commandCommand = replaceCmd,+                        commandPrereq = amInRepository,+                        commandGetArgPossibilities = listRegisteredFiles,+                        commandArgdefaults = nodefaults,+                        commandAdvancedOptions = [ignoretimes, umaskOption],+                        commandBasicOptions =+                            [tokens, forceReplace, workingRepoDir]} -replace_cmd :: [DarcsFlag] -> [String] -> IO ()-replace_cmd opts (old:new:relfs) = withRepoLock opts $- \repository -> do+replaceCmd :: [DarcsFlag] -> [String] -> IO ()+replaceCmd opts (old:new:relfs) = withRepoLock opts $- \repository -> do   fs <- fixSubPaths opts relfs-  toks <- choose_toks opts old new+  toks <- chooseToks opts old new   let checkToken tok =-        unless (is_tok toks tok) $ fail $ "'"++tok++"' is not a valid token!"+        unless (isTok toks tok) $ fail $ "'"++tok++"' is not a valid token!"   checkToken old   checkToken new-  (_, work) <- slurp_recorded_and_unrecorded repository-  cur <- slurp_pending repository-  pswork <- (concatFL . unsafeFL) `fmap` sequence (map (repl toks cur work) fs)+  work <- readUnrecorded repository+  cur <- readRecordedAndPending repository+  files <- filterM (exists work) fs+  pswork <- concatFL . unsafeFL <$> mapM (repl toks cur work) files   add_to_pending repository pswork   applyToWorking repository opts pswork `catch` \e ->       fail $ "Can't do replace on working!\n"           ++ "Perhaps one of the files already contains '"++ new++"'?\n"           ++ show e   where ftf _ = TextFile--        repl :: String -> Slurpy -> Slurpy -> SubPath -> IO (FL Prim)+        skipmsg f = "Skipping file '" ++ toFilePath f ++ "' which isn't in the repository."+        exists tree file = if isJust $ findFile tree (floatSubPath file)+                              then return True+                              else do putStrLn $ skipmsg file+                                      return False+        repl :: String -> Tree IO -> Tree IO -> SubPath -> IO (FL Prim)         repl toks cur work f =-          if not $ slurp_hasfile (sp2fn f) work-          then do putStrLn $ "Skipping file '"++f_fp++"' which isn't in the repository."-                  return NilFL-          else if ForceReplace `elem` opts ||-                  isJust (apply_to_slurpy (tokreplace f_fp toks old new) work) ||-                  isJust (apply_to_slurpy (tokreplace f_fp toks old new) cur)-               then return (get_force_replace f toks work)-               else do putStrLn $ "Skipping file '"++f_fp++"'"-                       putStrLn $ "Perhaps the recorded version of this " ++-                                  "file already contains '" ++new++"'?"-                       putStrLn $ "Use the --force option to override."-                       return NilFL+          do work_replaced <- maybeApplyToTree replace_patch work+             cur_replaced <- maybeApplyToTree replace_patch cur+             if ForceReplace `elem` opts || isJust work_replaced || isJust cur_replaced+                then get_force_replace f toks work+                else do putStrLn $ "Skipping file '"++f_fp++"'"+                        putStrLn $ "Perhaps the recorded version of this " +++                                   "file already contains '" ++new++"'?"+                        putStrLn $ "Use the --force option to override."+                        return NilFL           where f_fp = toFilePath f+                replace_patch = tokreplace f_fp toks old new -        get_force_replace :: SubPath -> String -> Slurpy -> FL Prim-        get_force_replace f toks s =-            case force_replace_slurpy (tokreplace f_fp toks new old) s of-            Nothing -> bug "weird forcing bug in replace."-            Just s' -> case unsafeDiff [] ftf s s' of-                       pfix -> pfix +>+ (tokreplace f_fp toks old new :>: NilFL)+        get_force_replace :: SubPath -> String -> Tree IO -> IO (FL Prim)+        get_force_replace f toks tree = do+            let path = floatSubPath f+            content <- readBlob $ fromJust $ findFile tree path+            let newcontent = forceTokReplace toks new old (BS.concat $ BL.toChunks content)+                tree' = modifyTree tree path (File . makeBlobBS <$> newcontent)+            case newcontent of+              Nothing -> bug "weird forcing bug in replace."+              Just _ -> do pfix <- treeDiff ftf tree tree'+                           return $ pfix +>+ (tokreplace f_fp toks old new :>: NilFL)             where f_fp = toFilePath f -replace_cmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]"+replaceCmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]" -default_toks :: String-default_toks = "A-Za-z_0-9"-filename_toks :: String-filename_toks = "A-Za-z_0-9\\-\\."+floatSubPath :: SubPath -> AnchoredPath+floatSubPath = floatPath . fn2fp . sp2fn +maybeApplyToTree :: Apply p => p -> Tree IO -> IO (Maybe (Tree IO))+maybeApplyToTree patch tree = catch (Just `fmap` applyToTree patch tree)+                                    (\_ -> return Nothing)++defaultToks :: String+defaultToks = "A-Za-z_0-9"+filenameToks :: String+filenameToks = "A-Za-z_0-9\\-\\."+ -- | Given a set of characters and a string, returns true iff the -- string contains only characters from the set.  A set beginning with -- a caret (@^@) is treated as a complementary set.-is_tok :: String -> String -> Bool-is_tok _ "" = False-is_tok toks s = and $ map (regChars toks) s+isTok :: String -> String -> Bool+isTok _ "" = False+isTok toks s = and $ map (regChars toks) s  -- | This function checks for @--token-chars@ on the command-line.  If -- found, it validates the argument and returns it, without the -- surrounding square brackets.  Otherwise, it returns either--- 'default_toks' or 'filename_toks' as explained in 'replace_help'.+-- 'defaultToks' or 'filenameToks' as explained in 'replaceHelp'. --  -- Note: Limitations in the current replace patch file format prevents -- tokens and token-char specifiers from containing any whitespace.-choose_toks :: [DarcsFlag] -> String -> String -> IO String-choose_toks (Toks t:_) a b+chooseToks :: [DarcsFlag] -> String -> String -> IO String+chooseToks (Toks t:_) a b     | length t <= 2 =         bad_token_spec $ "It must contain more than 2 characters, because " ++                          "it should be enclosed in square brackets"@@ -217,16 +248,16 @@         bad_token_spec "Space is not allowed in the spec"     | any isSpace a = bad_token_spec $ spacey_token a     | any isSpace b = bad_token_spec $ spacey_token b-    | not (is_tok tok a) = bad_token_spec $ not_a_token a-    | not (is_tok tok b) = bad_token_spec $ not_a_token b+    | not (isTok tok a) = bad_token_spec $ not_a_token a+    | not (isTok tok b) = bad_token_spec $ not_a_token b     | otherwise          = return tok     where tok = init $ tail t :: String           bad_token_spec msg = fail $ "Bad token spec: '"++ t ++"' ("++ msg ++")"           spacey_token x = x ++ " must not contain any space"           not_a_token x = x ++ " is not a token, according to your spec"-choose_toks (_:fs) a b = choose_toks fs a b-choose_toks [] a b = if is_tok default_toks a && is_tok default_toks b-                     then return default_toks-                     else return filename_toks+chooseToks (_:fs) a b = chooseToks fs a b+chooseToks [] a b = if isTok defaultToks a && isTok defaultToks b+                     then return defaultToks+                     else return filenameToks \end{code}
src/Darcs/Commands/Revert.lhs view
@@ -25,33 +25,31 @@ import English (englishNum, This(..), Noun(..)) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag( All, Debug ),-                        ignoretimes, working_repo_dir,-                        all_interactive,+                        ignoretimes, workingRepoDir,+                        allInteractive,                         fixSubPaths, areFileArgs,-                        list_registered_files, umask_option,+                        listRegisteredFiles, umaskOption,                       ) import Darcs.Utils ( askUser )-import Darcs.RepoPath ( toFilePath, sp2fn )+import Darcs.RepoPath ( toFilePath ) import Darcs.Repository ( withRepoLock, ($-), withGutsOf,-                    get_unrecorded_in_files,-                    get_unrecorded_in_files_unsorted,-                    add_to_pending, sync_repo,+                    add_to_pending,                     applyToWorking,-                    amInRepository, slurp_recorded,+                    amInRepository, readRecorded,+                    unrecordedChanges                   )-import Darcs.Patch ( invert, apply_to_filepaths, commute )-import Darcs.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) )+import Darcs.Patch ( invert, applyToFilepaths, commute )+import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) ) import Darcs.SelectChanges ( with_selected_last_changes_to_files' ) import Darcs.Patch.TouchesFiles ( choose_touching )-import Darcs.Commands.Unrevert ( write_unrevert )-import Darcs.Sealed ( unsafeUnseal )-import Darcs.Gorsvet( invalidateIndex )+import Darcs.Commands.Unrevert ( writeUnrevert )+import Darcs.Witnesses.Sealed ( unsafeUnseal ) -revert_description :: String-revert_description = "Discard unrecorded changes."+revertDescription :: String+revertDescription = "Discard unrecorded changes." -revert_help :: String-revert_help =+revertHelp :: String+revertHelp =  "The `darcs revert' command discards unrecorded changes the working\n" ++  "tree.  As with `darcs record', you will be asked which hunks (changes)\n" ++  "to revert.  The --all switch can be used to avoid such prompting. If\n" ++@@ -65,33 +63,30 @@  "revert' ran.\n"  revert :: DarcsCommand-revert = DarcsCommand {command_name = "revert",-                       command_help = revert_help,-                       command_description = revert_description,-                       command_extra_args = -1,-                       command_extra_arg_help = ["[FILE or DIRECTORY]..."],-                       command_command = revert_cmd,-                       command_prereq = amInRepository,-                       command_get_arg_possibilities = list_registered_files,-                       command_argdefaults = nodefaults,-                       command_advanced_options = [ignoretimes, umask_option],-                       command_basic_options = [all_interactive,-                                               working_repo_dir]}+revert = DarcsCommand {commandName = "revert",+                       commandHelp = revertHelp,+                       commandDescription = revertDescription,+                       commandExtraArgs = -1,+                       commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+                       commandCommand = revertCmd,+                       commandPrereq = amInRepository,+                       commandGetArgPossibilities = listRegisteredFiles,+                       commandArgdefaults = nodefaults,+                       commandAdvancedOptions = [ignoretimes, umaskOption],+                       commandBasicOptions = [allInteractive,+                                               workingRepoDir]} -revert_cmd :: [DarcsFlag] -> [String] -> IO ()-revert_cmd opts args = withRepoLock opts $- \repository -> do+revertCmd :: [DarcsFlag] -> [String] -> IO ()+revertCmd opts args = withRepoLock opts $- \repository -> do   files <- sort `fmap` fixSubPaths opts args-  let files_fn = map sp2fn files   when (areFileArgs files) $        putStrLn $ "Reverting changes in "++unwords (map show files)++"..\n"-  changes <- if All `elem` opts-                   then get_unrecorded_in_files_unsorted repository files_fn-                   else get_unrecorded_in_files repository files_fn-  let pre_changed_files = apply_to_filepaths (invert changes) (map toFilePath files)-  rec <- slurp_recorded repository+  changes <- unrecordedChanges opts repository files+  let pre_changed_files = applyToFilepaths (invert changes) (map toFilePath files)+  rec <- readRecorded repository   case unsafeUnseal $ choose_touching pre_changed_files changes of     NilFL -> putStrLn "There are no changes to revert!"-    _ -> with_selected_last_changes_to_files' "revert" opts+    _ -> with_selected_last_changes_to_files' "revert" opts Nothing                pre_changed_files changes $ \ (norevert:>p) ->         if nullFL p         then putStrLn $ "If you don't want to revert after all," ++@@ -104,16 +99,14 @@              case yorn of ('y':_) -> return ()                           _ -> exitWith $ ExitSuccess              withGutsOf repository $ do-                 invalidateIndex repository                  add_to_pending repository $ invert p                  when (Debug `elem` opts) $ putStrLn "About to write the unrevert file."                  case commute (norevert:>p) of-                   Just (p':>_) -> write_unrevert repository p' rec NilFL-                   Nothing -> write_unrevert repository (norevert+>+p) rec NilFL+                   Just (p':>_) -> writeUnrevert repository p' rec NilFL+                   Nothing -> writeUnrevert repository (norevert+>+p) rec NilFL                  when (Debug `elem` opts) $ putStrLn "About to apply to the working directory."                  applyToWorking repository opts (invert p) `catch` \e ->                      fail ("Unable to apply inverse patch!" ++ show e)-  sync_repo repository   putStrLn "Finished reverting." \end{code}
src/Darcs/Commands/Rollback.lhs view
@@ -28,54 +28,45 @@ import Data.Maybe ( isJust ) import System.Directory ( removeFile ) -import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers )-import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, get_author,+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, getAuthor,                          definePatches,-                         working_repo_dir, nocompress,-                         author, patchname_option, ask_long_comment,-                         leave_test_dir, notest, list_registered_files,-                         match_several_or_last, all_interactive, umask_option+                         workingRepoDir, nocompress,+                         author, patchnameOption, askLongComment,+                         leaveTestDir, notest, listRegisteredFiles,+                         matchSeveralOrLast, allInteractive, umaskOption                        ) import Darcs.RepoPath ( toFilePath )-import Darcs.Repository ( amInRepository, withRepoLock, ($-), applyToWorking,+import Darcs.Repository ( Repository, amInRepository, withRepoLock, ($-),+                          applyToWorking,                           read_repo, slurp_recorded,                           tentativelyMergePatches, withGutsOf,-                          finalizeRepositoryChanges, sync_repo )-import Darcs.Patch ( summary, invert, namepatch, effect, fromPrims,-                     sort_coalesceFL, canonize )-import Darcs.Ordered-import Darcs.Hopefully ( n2pia )+                          finalizeRepositoryChanges, invalidateIndex )+import Darcs.Patch ( RepoPatch, summary, invert, namepatch, effect, fromPrims,+                     sortCoalesceFL, canonize )+import Darcs.Patch.Prim ( Prim )+import Darcs.Witnesses.Ordered+import Darcs.Hopefully ( PatchInfoAnd, n2pia ) import Darcs.Lock ( world_readable_temp )-import Darcs.SlurpDirectory ( empty_slurpy, wait_a_moment )-import Darcs.Match ( first_match )+import Darcs.SlurpDirectory ( empty_slurpy )+import Darcs.Match ( firstMatch ) import Darcs.SelectChanges ( with_selected_last_changes_to_files_reversed,                              with_selected_last_changes_to_files' )-import Darcs.Commands.Record ( file_exists, get_log )-import Darcs.Commands.Unrecord ( get_last_patches )-import Darcs.Utils ( clarify_errors )+import Darcs.Commands.Record ( fileExists, getLog )+import Darcs.Commands.Unrecord ( getLastPatches )+import Darcs.Utils ( clarifyErrors ) import Printer ( renderString ) import Progress ( debugMessage )-import Darcs.Sealed ( Sealed(..), FlippedSeal(..) )+import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..) ) import IsoDate ( getIsoDateTime )-import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" -rollback_description :: String-rollback_description =+rollbackDescription :: String+rollbackDescription =  "Record a new patch reversing some recorded changes."-\end{code} -If you decide you didn't want to roll back a patch-after all, you can reverse its effect by obliterating the rolled-back patch.--Rollback can actually allow you to roll back a subset of the changes made-by the selected patch or patches.  Many of the options available in-rollback behave similarly to the options for unrecord~\ref{unrecord} and-record~\ref{record}.--\begin{code}-rollback_help :: String-rollback_help =+rollbackHelp :: String+rollbackHelp =  "Rollback is used to undo the effects of one or more patches without actually\n"++  "deleting them.  Instead, it creates a new patch reversing selected portions.\n"++  "of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"++@@ -83,57 +74,60 @@  "of its changes.\n"  rollback :: DarcsCommand-rollback = DarcsCommand {command_name = "rollback",-                         command_help = rollback_help,-                         command_description = rollback_description,-                         command_extra_args = -1,-                         command_extra_arg_help = ["[FILE or DIRECTORY]..."],-                         command_command = rollback_cmd,-                         command_prereq = amInRepository,-                         command_get_arg_possibilities = list_registered_files,-                         command_argdefaults = nodefaults,-                         command_advanced_options = [nocompress,umask_option],-                         command_basic_options = [match_several_or_last,-                                                  all_interactive,-                                                  author, patchname_option, ask_long_comment,-                                                  notest, leave_test_dir,-                                                  working_repo_dir]}+rollback = DarcsCommand {commandName = "rollback",+                         commandHelp = rollbackHelp,+                         commandDescription = rollbackDescription,+                         commandExtraArgs = -1,+                         commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+                         commandCommand = rollbackCmd,+                         commandPrereq = amInRepository,+                         commandGetArgPossibilities = listRegisteredFiles,+                         commandArgdefaults = nodefaults,+                         commandAdvancedOptions = [nocompress,umaskOption],+                         commandBasicOptions = [matchSeveralOrLast,+                                                  allInteractive,+                                                  author, patchnameOption, askLongComment,+                                                  notest, leaveTestDir,+                                                  workingRepoDir]} -rollback_cmd :: [DarcsFlag] -> [String] -> IO ()-rollback_cmd opts args = withRepoLock opts $- \repository -> do-  let (logMessage,_,_) = loggers opts+rollbackCmd :: [DarcsFlag] -> [String] -> IO ()+rollbackCmd opts args = withRepoLock opts $- \repository -> do   rec <- if null args then return empty_slurpy          else slurp_recorded repository   files <- sort `fmap` fixSubPaths opts args-  existing_files <- map toFilePath `fmap` filterM (file_exists rec) files-  non_existent_files <- map toFilePath `fmap` filterM (fmap not . file_exists rec) files+  existing_files <- map toFilePath `fmap` filterM (fileExists rec) files+  non_existent_files <- map toFilePath `fmap` filterM (fmap not . fileExists rec) files   when (not $ null existing_files) $-       logMessage $ "Recording changes in "++unwords existing_files++":\n"+       putStrLn $ "Recording changes in "++unwords existing_files++":\n"   when (not $ null non_existent_files) $-       logMessage $ "Non existent files or directories: "++unwords non_existent_files++"\n"+       putStrLn $ "Non existent files or directories: "++unwords non_existent_files++"\n"   when ((not $ null non_existent_files) && null existing_files) $        fail "None of the files you specified exist!"   allpatches <- read_repo repository-  FlippedSeal patches <- return $ if first_match opts-                                  then get_last_patches opts allpatches+  FlippedSeal patches <- return $ if firstMatch opts+                                  then getLastPatches opts allpatches                                   else FlippedSeal $ concatRL allpatches-  with_selected_last_changes_to_files_reversed "rollback" opts existing_files-      (reverseRL patches) $-    \ (_ :> ps) ->-    do when (nullFL ps) $ do logMessage "No patches selected!"-                             exitWith ExitSuccess-       definePatches ps-       with_selected_last_changes_to_files' "rollback" opts-               existing_files (concatFL $ mapFL_FL canonize $-                               sort_coalesceFL $ effect ps) $ \ (_:>ps'') ->-         do when (nullFL ps'') $ do logMessage "No changes selected!"+  with_selected_last_changes_to_files_reversed "rollback" opts Nothing existing_files+      (reverseRL patches) $ \ (_ :> ps) ->+          do when (nullFL ps) $ do putStrLn "No patches selected!"+                                   exitWith ExitSuccess+             definePatches ps+             with_selected_last_changes_to_files' "rollback" opts Nothing+               existing_files (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps)+               (rollItBackNow opts repository ps)++rollItBackNow :: (RepoPatch p1, RepoPatch p) =>+                [DarcsFlag] -> Repository p1 ->  FL (PatchInfoAnd p)+                            -> (t :> FL Prim) -> IO ()+rollItBackNow opts repository  ps (_ :> ps'') =+         do when (nullFL ps'') $ do putStrLn "No changes selected!"                                     exitWith ExitSuccess             let make_log = world_readable_temp "darcs-rollback"                 newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps ))             --tentativelyRemovePatches repository opts (mapFL_FL hopefully ps)-            (name, my_log, logf) <- get_log opts newlog make_log $ invert ps''+            (name, my_log, logf) <- getLog opts newlog make_log $ invert ps''             date <- getIsoDateTime-            my_author <- get_author opts+            my_author <- getAuthor opts             rbp <- n2pia `fmap` namepatch date name my_author my_log                                           (fromPrims $ invert ps'')             debugMessage "Adding rollback patch to repository."@@ -144,13 +138,10 @@             withGutsOf repository $ do               finalizeRepositoryChanges repository               debugMessage "About to apply rolled-back changes to working directory."-              -- so work will be more recent than rec:-              revertable $ do wait_a_moment-                              applyToWorking repository opts pw+              revertable $ applyToWorking repository opts pw             when (isJust logf) $ removeFile (fromJust logf)-            sync_repo repository-            logMessage $ "Finished rolling back."-          where revertable x = x `clarify_errors` unlines+            putStrLn "Finished rolling back."+          where revertable x = x `clarifyErrors` unlines                   ["Error applying patch to the working directory.","",                    "This may have left your working directory an inconsistent",                    "but recoverable state. If you had no un-recorded changes",
src/Darcs/Commands/Send.lhs view
@@ -28,33 +28,34 @@ import Control.Monad ( when, unless, forM_ ) import Data.Maybe ( isJust, isNothing ) -import Darcs.Commands ( DarcsCommand(..) )-import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile, RmLogFile,+import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose )+import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile,                                     Target, OutputAutoName, Output, Context,-                                    DryRun, Verbose, Quiet, Unified+                                    DryRun, Quiet, Unified                                   ),                          fixUrl, definePatches,-                         get_cc, get_author, working_repo_dir,-                         edit_description, logfile, rmlogfile,-                         sign, get_subject, deps_sel, get_in_reply_to,-                         match_several, set_default, output_auto_name,-                         output, cc, subject, target, author, sendmail_cmd,-                         in_reply_to, remote_repo, network_options,-                         all_interactive, get_sendmail_cmd,-                         print_dry_run_message_and_exit,-                         summary, allow_unrelated_repos,-                         from_opt, dry_run, send_to_context,+                         getCc, getAuthor, workingRepoDir,+                         editDescription, logfile, rmlogfile,+                         sign, getSubject, depsSel, getInReplyTo,+                         matchSeveral, setDefault, outputAutoName,+                         output, ccSend, subject, target, author, sendmailCmd,+                         inReplyTo, remoteRepo, networkOptions,+                         allInteractive, getSendmailCmd,+                         printDryRunMessageAndExit,+                         summary, allowUnrelatedRepos,+                         fromOpt, dryRun, sendToContext,                        )+import Darcs.Flags ( willRemoveLogFile ) import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) import Darcs.Repository ( PatchSet, Repository,                           amInRepository, identifyRepositoryFor, withRepoReadLock, ($-),-                          read_repo, slurp_recorded, prefsUrl, checkUnrelatedRepos )-import Darcs.Patch ( RepoPatch, description, apply_to_slurpy, invert )-import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..), unsafeUnRL,+                          read_repo, readRecorded, prefsUrl, checkUnrelatedRepos )+import Darcs.Patch ( RepoPatch, description, applyToTree, invert )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..),                        mapRL_RL, mapFL, mapRL, reverseRL, mapFL_FL, lengthFL, nullFL ) import Darcs.Patch.Bundle ( make_bundle, scan_context ) import Darcs.Patch.Info ( just_name )-import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist )+import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist ) import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail ) import ByteStringUtils ( mmapFilePS ) import qualified Data.ByteString.Char8 as BC (unpack)@@ -64,18 +65,20 @@ import Darcs.Utils ( askUser, catchall, edit_file, formatPath ) import Progress ( debugMessage ) import Darcs.Email ( make_email )-import Printer ( Doc, vsep, vcat, text, ($$), putDocLn, putDoc )-import Darcs.RepoPath ( toFilePath, AbsolutePath, AbsolutePathOrStd,+import Printer ( Doc, vsep, vcat, text, ($$), (<+>), (<>), putDoc )+import Darcs.RepoPath ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,                         getCurrentDirectory, makeAbsoluteOrStd, useAbsoluteOrStd ) import HTTP ( postUrl ) #include "impossible.h" -send_description :: String-send_description =+#include "gadts.h"++sendDescription :: String+sendDescription =  "Send by email a bundle of one or more patches." -send_help :: String-send_help =+sendHelp :: String+sendHelp =  "Send is used to prepare a bundle of patches that can be applied to a target\n"++  "repository.  Send accepts the URL of the repository as an argument.  When\n"++  "called without an argument, send will use the most recent repository that\n"++@@ -109,36 +112,36 @@  \begin{code} send :: DarcsCommand-send = DarcsCommand {command_name = "send",-                     command_help = send_help,-                     command_description = send_description,-                     command_extra_args = 1,-                     command_extra_arg_help = ["[REPOSITORY]"],-                     command_command = send_cmd,-                     command_prereq = amInRepository,-                     command_get_arg_possibilities = get_preflist "repos",-                     command_argdefaults = defaultrepo,-                     command_advanced_options = [logfile, rmlogfile,-                                                 remote_repo,-                                                 send_to_context] ++-                                                network_options,-                     command_basic_options = [match_several, deps_sel,-                                              all_interactive,-                                              from_opt, author,-                                              target,cc,subject, in_reply_to,-                                              output,output_auto_name,sign]-                                              ++dry_run++[summary,-                                              edit_description,-                                              set_default, working_repo_dir,-                                              sendmail_cmd,-                                              allow_unrelated_repos]}+send = DarcsCommand {commandName = "send",+                     commandHelp = sendHelp,+                     commandDescription = sendDescription,+                     commandExtraArgs = 1,+                     commandExtraArgHelp = ["[REPOSITORY]"],+                     commandCommand = sendCmd,+                     commandPrereq = amInRepository,+                     commandGetArgPossibilities = getPreflist "repos",+                     commandArgdefaults = defaultrepo,+                     commandAdvancedOptions = [logfile, rmlogfile,+                                                 remoteRepo,+                                                 sendToContext] +++                                                networkOptions,+                     commandBasicOptions = [matchSeveral, depsSel,+                                              allInteractive,+                                              fromOpt, author,+                                              target,ccSend,subject, inReplyTo,+                                              output,outputAutoName,sign]+                                              ++dryRun++[summary,+                                              editDescription,+                                              setDefault, workingRepoDir,+                                              sendmailCmd,+                                              allowUnrelatedRepos]} -send_cmd :: [DarcsFlag] -> [String] -> IO ()-send_cmd input_opts [""] = send_cmd input_opts []-send_cmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do+sendCmd :: [DarcsFlag] -> [String] -> IO ()+sendCmd input_opts [""] = sendCmd input_opts []+sendCmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do   context_ps <- the_context input_opts   case context_ps of-    Just them -> send_to_them repository input_opts [] "CONTEXT" them+    Just them -> sendToThem repository input_opts [] "CONTEXT" them     Nothing -> do         repodir <- fixUrl input_opts unfixedrepodir         -- Test to make sure we aren't trying to push to the current repo@@ -147,88 +150,84 @@            fail ("Can't send to current repository! Did you mean send -"++"-context?")         repo <- identifyRepositoryFor repository repodir         them <- read_repo repo-        old_default <- get_preflist "defaultrepo"-        set_defaultrepo repodir input_opts+        old_default <- getPreflist "defaultrepo"+        setDefaultrepo repodir input_opts         when (old_default == [repodir] && not (Quiet `elem` input_opts)) $              putStrLn $ "Creating patch to "++formatPath repodir++"..."-        wtds <- decide_on_behavior input_opts repo-        send_to_them repository input_opts wtds repodir them+        wtds <- decideOnBehavior input_opts repo+        sendToThem repository input_opts wtds repodir them     where the_context [] = return Nothing           the_context (Context foo:_)               = (Just . scan_context )`fmap` mmapFilePS (toFilePath foo)           the_context (_:fs) = the_context fs-send_cmd _ _ = impossible+sendCmd _ _ = impossible -send_to_them :: RepoPatch p => Repository p -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p -> IO ()-send_to_them repo opts wtds their_name them = do-  let am_verbose = Verbose `elem` opts-      am_quiet = Quiet `elem` opts-      putVerbose s = when am_verbose $ putDocLn s-      putInfo s = when (not am_quiet) $ putStrLn s-      patch_desc p = just_name $ info p-      make_fname tbs = patch_filename $ patch_desc $ headFL tbs-      headFL (x:>:_) = x-      headFL _ = impossible+sendToThem :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p C(x) -> IO ()+sendToThem repo opts wtds their_name them = do   us <- read_repo repo   case get_common_and_uncommon (us, them) of     (common, us' :\/: _) -> do      checkUnrelatedRepos opts common us them-     case us' of-         NilRL:<:NilRL -> do putInfo "No recorded local changes to send!"-                             exitWith ExitSuccess-         _ -> putVerbose $ text "We have the following patches to send:"-                        $$ (vcat $ mapRL description $ head $ unsafeUnRL us')-     s <- slurp_recorded repo-     let our_ps = reverseRL $ head $ unsafeUnRL us'-     with_selected_changes "send" opts our_ps $+     (case us' of+         NilRL -> do putInfo opts $ text "No recorded local changes to send!"+                     exitWith ExitSuccess+         _ -> putVerbose opts $ text "We have the following patches to send:"+                        $$ (vcat $ mapRL description us')) :: IO ()+     pristine <- readRecorded repo+     let our_ps = reverseRL us'+     with_selected_changes "send" opts Nothing our_ps $       \ (to_be_sent :> _) -> do-      print_dry_run_message_and_exit "send" opts to_be_sent+      printDryRunMessageAndExit "send" opts to_be_sent       when (nullFL to_be_sent) $ do-          putInfo "You don't want to send any patches, and that's fine with me!"+          putInfo opts $ text "You don't want to send any patches, and that's fine with me!"           exitWith ExitSuccess       definePatches to_be_sent-      bundle <- signString opts $ make_bundle (Unified:opts)-                (fromJust $ apply_to_slurpy-                 (invert $-                  mapRL_RL hopefully $ head $ unsafeUnRL us') s)-                common (mapFL_FL hopefully to_be_sent)-      let outname = get_output opts (make_fname to_be_sent)+      pristine' <- applyToTree (invert $ mapRL_RL hopefully us') pristine+      unsig_bundle <- make_bundle (Unified:opts) pristine' common (mapFL_FL hopefully to_be_sent)+      bundle <- signString opts unsig_bundle+      let make_fname (tb:>:_) = patchFilename $ patchDesc tb+          make_fname _ = impossible+          fname = make_fname to_be_sent+          outname = getOutput opts fname       case outname of-        Just fname -> do (d,f) <- get_description opts to_be_sent-                         let putabs a = do writeDocBinFile a (d $$ bundle)-                                           putStrLn $ "Wrote patch to " ++ toFilePath a ++ "."-                             putstd = putDoc (d $$ bundle)-                         useAbsoluteOrStd putabs putstd fname-                         cleanup f-        Nothing ->+        Just fname' -> writeBundleToFile opts to_be_sent bundle fname' their_name+        Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name++patchDesc :: forall p C(x y) . PatchInfoAnd p C(x y) -> String+patchDesc p = just_name $ info p++sendBundle :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y)+             -> Doc -> String -> [WhatToDo] -> String -> IO ()+sendBundle opts to_be_sent bundle fname wtds their_name=          let-           auto_subject (p:>:NilFL)  = "darcs patch: " ++ trim (patch_desc p) 57-           auto_subject (p:>:ps) = "darcs patch: " ++ trim (patch_desc p) 43 +++           auto_subject :: forall pp C(x y) . FL (PatchInfoAnd pp) C(x y) -> String+           auto_subject (p:>:NilFL)  = "darcs patch: " ++ trim (patchDesc p) 57+           auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 ++                             " (and " ++ show (lengthFL ps) ++ " more)"            auto_subject _ = error "Tried to get a name from empty patch list."            trim st n = if length st <= n then st                        else take (n-3) st ++ "..."            in do-           thetargets <- get_targets wtds-           from <- get_author opts-           let thesubject = case get_subject opts of+           thetargets <- getTargets wtds+           from <- getAuthor opts+           let thesubject = case getSubject opts of                             Nothing -> auto_subject to_be_sent                             Just subj -> subj-           (mailcontents, mailfile) <- get_description opts to_be_sent+           (mailcontents, mailfile) <- getDescription opts their_name to_be_sent            let body = make_email their_name-                        (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . get_in_reply_to $ opts)+                        (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts)                         (Just mailcontents)                         bundle-                        (Just $ make_fname to_be_sent)+                        (Just fname)                contentAndBundle = Just (mailcontents, bundle)                                sendmail = do-                 sm_cmd <- get_sendmail_cmd opts-                 (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (get_cc opts)+                 sm_cmd <- getSendmailCmd opts+                 (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (getCc opts)                                sm_cmd contentAndBundle body >>-                  putInfo ("Successfully sent patch bundle to: "+                  (putInfo opts . text $ ("Successfully sent patch bundle to: "                             ++ lt [ t | SendMail t <- thetargets ]-                            ++ ccs (get_cc opts) ++"."))+                            ++ ccs (getCc opts) ++".")))                  `catch` \e -> let msg = "Email body left in " in                                do case mailfile of                                     Just mf -> putStrLn $ msg++mf++"."@@ -239,32 +238,44 @@             when (null [ p | Post p <- thetargets]) sendmail            nbody <- withOpenTemp $ \ (fh,fn) -> do-               generateEmail fh from (lt [t | SendMail t <- thetargets]) thesubject (get_cc opts) body+               generateEmail fh from (lt [t | SendMail t <- thetargets]) thesubject (getCc opts) body                hClose fh                mmapFilePS fn            forM_ [ p | Post p <- thetargets]              (\url -> do-                putInfo $ "Posting patch to " ++ url+                putInfo opts . text $ "Posting patch to " ++ url                 postUrl url (BC.unpack nbody) "message/rfc822")              `catch` const sendmail-           cleanup mailfile+           cleanup opts mailfile+         where+          lt [t] = t+          lt [t,""] = t+          lt (t:ts) = t++" , "++lt ts+          lt [] = "" -      where cleanup (Just mailfile) = when (isNothing (get_fileopt opts) || (RmLogFile `elem` opts)) $+cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO ()+cleanup opts (Just mailfile) = when (isNothing (getFileopt opts) || (willRemoveLogFile opts)) $                                       removeFileMayNotExist mailfile-            cleanup Nothing = return ()-            lt [t] = t-            lt [t,""] = t-            lt (t:ts) = t++" , "++lt ts-            lt [] = ""+cleanup _ Nothing = return () +writeBundleToFile :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> Doc ->+                    AbsolutePathOrStd -> String -> IO ()+writeBundleToFile opts to_be_sent bundle fname their_name =+    do (d,f) <- getDescription opts their_name to_be_sent+       let putabs a = do writeDocBinFile a (d $$ bundle)+                         putStrLn $ "Wrote patch to " ++ toFilePath a ++ "."+           putstd = putDoc (d $$ bundle)+       useAbsoluteOrStd putabs putstd fname+       cleanup opts f+ safeFileChar :: Char -> Char safeFileChar c | isAlpha c = toLower c                | isDigit c = c                | isSpace c = '-' safeFileChar _ = '_' -patch_filename :: String -> String-patch_filename the_summary = name ++ ".dpatch"+patchFilename :: String -> String+patchFilename the_summary = name ++ ".dpatch"     where name = map safeFileChar the_summary \end{code} @@ -317,11 +328,11 @@     | SendMail String    -- ^ send patch via email  -decide_on_behavior :: RepoPatch p => [DarcsFlag] -> Repository p -> IO [WhatToDo]-decide_on_behavior opts the_remote_repo =+decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO [WhatToDo]+decideOnBehavior opts the_remote_repo =     case the_targets of     [] ->-          if isJust $ get_output opts ""+          if isJust $ getOutput opts ""           then return []           else           do wtds <- check_post@@ -329,7 +340,7 @@              return wtds     ts -> do announce_recipients ts              return ts-    where the_targets = collect_targets opts+    where the_targets = collectTargets opts #ifdef HAVE_HTTP           -- the ifdef above is to so that darcs only checks the remote           -- _darcs/post if we have an implementation of postUrl.  See@@ -352,27 +363,26 @@                           `catchall` return ""                  if '@' `elem` email then return . map SendMail $ lines email                                      else return []-          putInfoLn s = unless (Quiet `elem` opts) $ putStrLn s           announce_recipients emails =             let pn (SendMail s) = s                 pn (Post p) = p             in if DryRun `elem` opts-            then putInfoLn $ "Patch bundle would be sent to: "++unwords (map pn emails)+            then putInfo opts . text $ "Patch bundle would be sent to: "++unwords (map pn emails)             else when (null the_targets) $-                 putInfoLn $ "Patch bundle will be sent to: "++unwords (map pn emails)+                 putInfo opts . text $ "Patch bundle will be sent to: "++unwords (map pn emails) -get_output :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd-get_output (Output a:_) _ = return a-get_output (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f-get_output (_:flags) f = get_output flags f-get_output [] _ = Nothing+getOutput :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd+getOutput (Output a:_) _ = return a+getOutput (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f+getOutput (_:flags) f = getOutput flags f+getOutput [] _ = Nothing -get_targets :: [WhatToDo] -> IO [WhatToDo]-get_targets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? "-get_targets wtds = return wtds+getTargets :: [WhatToDo] -> IO [WhatToDo]+getTargets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? "+getTargets wtds = return wtds -collect_targets :: [DarcsFlag] -> [WhatToDo]-collect_targets flags = [ f t | Target t <- flags ] where+collectTargets :: [DarcsFlag] -> [WhatToDo]+collectTargets flags = [ f t | Target t <- flags ] where     f url@('h':'t':'t':'p':':':_) = Post url     f em = SendMail em @@ -416,12 +426,12 @@ \end{verbatim}  \begin{code}-get_description :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) -> IO (Doc, Maybe String)-get_description opts patches =+getDescription :: RepoPatch p => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO (Doc, Maybe String)+getDescription opts their_name patches =     case get_filename of         Just f -> do file <- f                      when (EditDescription `elem` opts) $ do-                       when (isNothing $ get_fileopt opts) $+                       when (isNothing $ getFileopt opts) $                             writeDocBinFile file patchdesc                        debugMessage $ "About to edit file " ++ file                        edit_file file@@ -429,16 +439,21 @@                      doc <- readDocBinFile file                      return (doc, Just file)         Nothing -> return (patchdesc, Nothing)-    where patchdesc = vsep $ mapFL description patches-          get_filename = case get_fileopt opts of+    where patchdesc = text (if lengthFL patches == 1+                               then "1 patch"+                               else show (lengthFL patches) ++ " patches")+                      <+> text "for repository" <+> text their_name <> text ":"+                      $$ text ""+                      $$ vsep (mapFL description patches)+          get_filename = case getFileopt opts of                                 Just f -> Just $ return $ toFilePath f                                 Nothing -> if EditDescription `elem` opts                                               then Just tempfile                                               else Nothing           tempfile = world_readable_temp "darcs-temp-mail" -get_fileopt :: [DarcsFlag] -> Maybe AbsolutePath-get_fileopt (LogFile f:_) = Just f-get_fileopt (_:flags) = get_fileopt flags-get_fileopt [] = Nothing+getFileopt :: [DarcsFlag] -> Maybe AbsolutePath+getFileopt (LogFile f:_) = Just f+getFileopt (_:flags) = getFileopt flags+getFileopt [] = Nothing \end{code}
src/Darcs/Commands/SetPref.lhs view
@@ -26,31 +26,31 @@ import Control.Monad (when)  import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, working_repo_dir, umask_option )+import Darcs.Arguments ( DarcsFlag, workingRepoDir, umaskOption ) import Darcs.Repository ( amInRepository, add_to_pending, withRepoLock, ($-) ) import Darcs.Patch ( changepref )-import Darcs.Ordered ( FL(..) )-import Darcs.Repository.Prefs ( get_prefval, change_prefval, )+import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Repository.Prefs ( getPrefval, changePrefval, ) import English ( orClauses ) #include "impossible.h"  -- | A list of all valid preferences for @_darcs/prefs/prefs@.-valid_pref_data :: [(String, String)] -- ^ (name, one line description)-valid_pref_data =+validPrefData :: [(String, String)] -- ^ (name, one line description)+validPrefData =     [("test", "a shell command that runs regression tests"),      ("predist", "a shell command to run before `darcs dist'"),      ("boringfile", "the path to a version-controlled boring file"),      ("binariesfile", "the path to a version-controlled binaries file")] -valid_prefs :: [String]-valid_prefs = map fst valid_pref_data+validPrefs :: [String]+validPrefs = map fst validPrefData -setpref_description :: String-setpref_description =-    "Set a preference (" ++ orClauses valid_prefs ++ ")."+setprefDescription :: String+setprefDescription =+    "Set a preference (" ++ orClauses validPrefs ++ ")." -setpref_help :: String-setpref_help =+setprefHelp :: String+setprefHelp =  "When working on project with multiple repositories and contributors,\n" ++  "it is sometimes desirable for a preference to be set consistently\n" ++  "project-wide.  This is achieved by treating a preference set with\n" ++@@ -59,7 +59,7 @@  "\n" ++  "Valid preferences are:\n" ++  "\n" ++- unlines ["  "++x++" -- "++y | (x,y) <- valid_pref_data] +++ unlines ["  "++x++" -- "++y | (x,y) <- validPrefData] ++  "\n" ++  "For example, a project using GNU autotools, with a `make test' target\n" ++  "to perform regression tests, might enable Darcs' integrated regression\n" ++@@ -73,36 +73,36 @@  "low-priority bug, because preferences are seldom set.\n"  setpref :: DarcsCommand-setpref = DarcsCommand {command_name = "setpref",-                        command_help = setpref_help,-                        command_description = setpref_description,-                        command_extra_args = 2,-                        command_extra_arg_help = ["<PREF>",+setpref = DarcsCommand {commandName = "setpref",+                        commandHelp = setprefHelp,+                        commandDescription = setprefDescription,+                        commandExtraArgs = 2,+                        commandExtraArgHelp = ["<PREF>",                                                   "<VALUE>"],-                        command_command = setpref_cmd,-                        command_prereq = amInRepository,-                        command_get_arg_possibilities = return valid_prefs,-                        command_argdefaults = nodefaults,-                        command_advanced_options = [umask_option],-                        command_basic_options =-                            [working_repo_dir]}+                        commandCommand = setprefCmd,+                        commandPrereq = amInRepository,+                        commandGetArgPossibilities = return validPrefs,+                        commandArgdefaults = nodefaults,+                        commandAdvancedOptions = [umaskOption],+                        commandBasicOptions =+                            [workingRepoDir]} -setpref_cmd :: [DarcsFlag] -> [String] -> IO ()-setpref_cmd opts [pref,val] = withRepoLock opts $- \repository -> do+setprefCmd :: [DarcsFlag] -> [String] -> IO ()+setprefCmd opts [pref,val] = withRepoLock opts $- \repository -> do   when (' ' `elem` pref) $ do     putStrLn $ "'"++pref++                "' is not a valid preference name:  no spaces allowed!"     exitWith $ ExitFailure 1-  when (not $ pref `elem` valid_prefs) $ do+  when (not $ pref `elem` validPrefs) $ do     putStrLn $ "'"++pref++"' is not a valid preference name!"-    putStrLn $ "Try one of: " ++ unwords valid_prefs+    putStrLn $ "Try one of: " ++ unwords validPrefs     exitWith $ ExitFailure 1-  oval <- get_prefval pref+  oval <- getPrefval pref   old <- case oval of Just v -> return v                       Nothing -> return ""-  change_prefval pref old val+  changePrefval pref old val   putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'"   add_to_pending repository (changepref pref old val :>: NilFL)-setpref_cmd _ _ = impossible+setprefCmd _ _ = impossible \end{code}
src/Darcs/Commands/Show.lhs view
@@ -16,52 +16,52 @@ %  Boston, MA 02110-1301, USA.  \begin{code}-module Darcs.Commands.Show ( show_command, list, query ) where+module Darcs.Commands.Show ( showCommand, list, query ) where  import Darcs.Commands ( DarcsCommand(..),-                        CommandControl(Command_data, Hidden_command),-                        command_alias,+                        CommandControl(CommandData, HiddenCommand),+                        commandAlias,                       )-import Darcs.Commands.ShowAuthors ( show_authors )-import Darcs.Commands.ShowBug ( show_bug )-import Darcs.Commands.ShowContents ( show_contents )-import Darcs.Commands.ShowFiles ( show_files, show_manifest )-import Darcs.Commands.ShowTags ( show_tags )-import Darcs.Commands.ShowRepo ( show_repo )-import Darcs.Commands.ShowIndex ( show_index, show_pristine )+import Darcs.Commands.ShowAuthors ( showAuthors )+import Darcs.Commands.ShowBug ( showBug )+import Darcs.Commands.ShowContents ( showContents )+import Darcs.Commands.ShowFiles ( showFiles, showManifest )+import Darcs.Commands.ShowTags ( showTags )+import Darcs.Commands.ShowRepo ( showRepo )+import Darcs.Commands.ShowIndex ( showIndex, showPristine ) import Darcs.Repository ( amInRepository ) -show_description :: String-show_description = "Show information which is stored by darcs."+showDescription :: String+showDescription = "Show information which is stored by darcs." -show_help :: String-show_help =+showHelp :: String+showHelp =  "Use the --help option with the subcommands to obtain help for\n"++  "subcommands (for example, \"darcs show files --help\").\n" ++  "\n" ++  "In previous releases, this command was called `darcs query'.\n" ++  "Currently this is a deprecated alias.\n" -show_command :: DarcsCommand-show_command = SuperCommand {command_name = "show",-                      command_help = show_help,-                      command_description = show_description,-                      command_prereq = amInRepository,-                      command_sub_commands = [Hidden_command show_bug,-                                              Command_data show_contents,-                                              Command_data show_files, Hidden_command show_manifest,-                                              Command_data show_index,-                                              Command_data show_pristine,-                                              Command_data show_repo,-                                              Command_data show_authors,-                                              Command_data show_tags]+showCommand :: DarcsCommand+showCommand = SuperCommand {commandName = "show",+                      commandHelp = showHelp,+                      commandDescription = showDescription,+                      commandPrereq = amInRepository,+                      commandSubCommands = [HiddenCommand showBug,+                                              CommandData showContents,+                                              CommandData showFiles, HiddenCommand showManifest,+                                              CommandData showIndex,+                                              CommandData showPristine,+                                              CommandData showRepo,+                                              CommandData showAuthors,+                                              CommandData showTags]                      }  query :: DarcsCommand-query = command_alias "query" show_command+query = commandAlias "query" showCommand  list :: DarcsCommand-list = command_alias "list" show_command+list = commandAlias "list" showCommand \end{code}  \subsection{darcs show}
src/Darcs/Commands/ShowAuthors.lhs view
@@ -1,4 +1,4 @@-%  Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael+%  Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael, Tomas Caithaml % %  This program is free software; you can redistribute it and/or modify %  it under the terms of the GNU General Public License as published by@@ -17,30 +17,37 @@  \darcsCommand{show authors} \begin{code}-{-# OPTIONS_GHC -cpp #-}-module Darcs.Commands.ShowAuthors ( show_authors ) where+module Darcs.Commands.ShowAuthors ( showAuthors ) where +import qualified Ratified( readFile ) import Control.Arrow ((&&&), (***))-import Data.List ( sort, sortBy, group, groupBy, isInfixOf, isPrefixOf )+import Data.List ( isInfixOf, sortBy, groupBy, group, sort) import Data.Ord (comparing) import Data.Char ( toLower, isSpace )+import Data.Maybe( isJust )+import Text.ParserCombinators.Parsec hiding (lower, count, Line)+import Text.ParserCombinators.Parsec.Error import Text.Regex ( Regex, mkRegexWithOpts, matchRegex ) -import Darcs.Arguments ( DarcsFlag(..), working_repo_dir )-import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag(..), workingRepoDir )+import Darcs.Commands ( DarcsCommand(..), nodefaults, putWarning ) import Darcs.External ( viewDoc ) import Darcs.Hopefully ( info ) import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) ) import Darcs.Patch.Info ( pi_author )-import Darcs.Ordered ( mapRL, concatRL )+import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import Printer ( text ) import Data.Function (on) -show_authors_description :: String-show_authors_description = "List authors by patch count."+data Spelling = Spelling String String [Regex] -- name, email, regexps+type ParsedLine = Maybe Spelling -- Nothing for blank lines -show_authors_help :: String-show_authors_help =++showAuthorsDescription :: String+showAuthorsDescription = "List authors by patch count."++showAuthorsHelp :: String+showAuthorsHelp =  "The `darcs show authors' command lists the authors of the current\n" ++  "repository, sorted by the number of patches contributed.  With the\n" ++  "--verbose option, this command simply lists the author of each patch\n" ++@@ -50,14 +57,23 @@  "when multiple author strings refer to the same individual, create an\n" ++  "`.authorspellings' file in the root of the working tree.  Each line in\n" ++  "this file begins with an author's canonical name and address, and may\n" ++- "be followed by a comma and zero or more extended regular expressions,\n" ++- "separated by commas.  Blank lines and lines beginning with two\n" ++- "hyphens, are ignored.\n" +++ "be followed by a comma separated list of extended regular expressions.\n" +++ "Blank lines and lines beginning with two hyphens are ignored.\n" +++ "The format of .authorspelling can be described by this pattern:\n" ++  "\n" +++ " name <address> [, regexp ]*\n" +++ "\n" +++ "There are some pitfalls concerning special characters:\n" +++ "Whitespaces are stripped, if you need space in regexp use [ ]. \n" +++ "Because comma serves as a separator you have to escape it if you want\n" +++ "it in regexp. Note that .authorspelingfile use extended regular\n" +++ "expressions so +, ? and so on are metacharacters and you need to \n" +++ "escape them to be interpreted literally.\n" +++ "\n" ++  "Any patch with an author string that matches the canonical address or\n" ++  "any of the associated regexps is considered to be the work of that\n" ++  "author.  All matching is case-insensitive and partial (it can match a\n" ++- "substring).\n" +++ "substring). Use ^,$ to match the whole string in regexps\n" ++  "\n" ++  "Currently this canonicalization step is done only in `darcs show\n" ++  "authors'.  Other commands, such as `darcs changes' use author strings\n" ++@@ -67,26 +83,27 @@  "\n" ++  "    -- This is a comment.\n" ++  "    Fred Nurk <fred@example.com>\n" ++- "    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n"+ "    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n" +++ "    Chuck Jones\\, Jr. <chuck@pobox.com>, cj\\+user@example.com\n" -show_authors :: DarcsCommand-show_authors = DarcsCommand {-  command_name = "authors",-  command_help = show_authors_help,-  command_description = show_authors_description,-  command_extra_args = 0,-  command_extra_arg_help = [],-  command_command = authors_cmd,-  command_prereq = amInRepository,-  command_get_arg_possibilities = return [],-  command_argdefaults = nodefaults,-  command_advanced_options = [],-  command_basic_options = [working_repo_dir] }+showAuthors :: DarcsCommand+showAuthors = DarcsCommand {+  commandName = "authors",+  commandHelp = showAuthorsHelp,+  commandDescription = showAuthorsDescription,+  commandExtraArgs = 0,+  commandExtraArgHelp = [],+  commandCommand = authorsCmd,+  commandPrereq = amInRepository,+  commandGetArgPossibilities = return [],+  commandArgdefaults = nodefaults,+  commandAdvancedOptions = [],+  commandBasicOptions = [workingRepoDir] } -authors_cmd :: [DarcsFlag] -> [String] -> IO ()-authors_cmd opts _ = withRepository opts $- \repository -> do+authorsCmd :: [DarcsFlag] -> [String] -> IO ()+authorsCmd opts _ = withRepository opts $- \repository -> do   patches <- read_repo repository-  spellings <- compiled_author_spellings+  spellings <- compiledAuthorSpellings opts   let authors = mapRL (pi_author . info) $ concatRL patches   viewDoc $ text $ unlines $    if Verbose `elem` opts@@ -105,56 +122,72 @@       -- Because it would take a long time to canonize "foo" into       -- "foo <foo@bar.baz>" once per patch, the code below       -- generates a list [(count, canonized name)].-      map (length &&& (canonize_author spellings . head)) $+      map (length &&& (canonizeAuthor spellings . head)) $       group $ sort authors -canonize_author :: [(String,[Regex])] -> String -> String-canonize_author [] a = a-canonize_author spellings a = safehead a $ canonicalsfor a-    where-      safehead x xs = if null xs then x else head xs-      canonicalsfor s = map fst $ filter (ismatch s) spellings-      ismatch s (canonical,regexps) =-          (not (null email) && (s `contains` email)) || (any (s `contains_regex`) regexps)-          where email = takeWhile (/= '>') $ drop 1 $ dropWhile (/= '<') canonical--contains :: String -> String -> Bool-a `contains` b = lower b `isInfixOf` (lower a) where lower = map toLower+canonizeAuthor :: [Spelling] -> String -> String+canonizeAuthor spells author = getName canonicals+ where+   getName [] = author+   getName ((Spelling name email _):_) = name ++ " <" ++ email ++ ">"+   canonicals = filter (ismatch author) spells+   ismatch s (Spelling _ mail regexps) =+     s `correspondsTo` mail || any (s `contains_regex`) regexps+   contains_regex a r = isJust $ matchRegex r a+   correspondsTo a b = lower b `isInfixOf` lower a+   lower = map toLower -contains_regex :: String -> Regex -> Bool-a `contains_regex` r = case matchRegex r a of-                         Just _ -> True-                         _ -> False+compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling]+compiledAuthorSpellings opts = do+  let as_file = ".authorspellings"+  contents <- (Ratified.readFile -- never unlinked from within darcs+               as_file `catch` (\_ -> return ""))+  let parse_results = map (parse sentence as_file) $ lines contents+  clean 1 parse_results+ where+  clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling]+  clean _ [] = return []+  -- print parse error+  clean n ((Left err):xs) = do+    let npos = setSourceLine (errorPos err) n+    putWarning opts . text . show $ setErrorPos npos err+    clean (n+1) xs+  -- skip blank line+  clean n ((Right Nothing):xs)  = clean (n+1) xs+  -- unwrap Spelling+  clean n ((Right (Just a):xs)) = do+    as <- clean (n+1) xs+    return (a:as) -compiled_author_spellings :: IO [(String,[Regex])]-compiled_author_spellings = do-  ss <- author_spellings_from_file-  return $ map compile $ ss-    where-      compile [] = error "each author spelling should contain at least the canonical form"-      compile (canonical:pats) = (canonical, map mkregex pats)-      mkregex pat = mkRegexWithOpts pat True False+----------+-- PARSERS -authorspellingsfile :: FilePath-authorspellingsfile = ".authorspellings"+sentence :: Parser ParsedLine+sentence = spaces >> (comment <|> blank <|> addressline)+  where+    comment = string "--" >> return Nothing+    blank = eof >> return Nothing -author_spellings_from_file :: IO [[String]]-author_spellings_from_file = do-  s <- readFile -- ratify readFile: never unlinked from within darcs-         authorspellingsfile `catch` (\_ -> return "")-  let noncomments = filter (not . ("--" `isPrefixOf`)) $-                    filter (not . null) $ map strip $ lines s-  return $ map (map strip . split_on ',') noncomments+addressline :: Parser ParsedLine+addressline = do+  name <- canonicalName <?> "Canonical name"+  addr <- between (char '<') (char '>') (many1 (noneOf ">")) <?> "Address"+  spaces+  rest <- option [] (char ',' >> regexp `sepBy` char ',') <?> "List of regexps"+  return $ Just $ Spelling (strip name) addr (compile rest)+  where+    strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse+    makeRegex s = mkRegexWithOpts s True False+    compile = map makeRegex . filter (not . null) . map strip -split_on :: Eq a => a -> [a] -> [[a]]-split_on e l =-    case dropWhile (e==) l of-      [] -> []-      l' -> first : split_on e rest-        where-          (first,rest) = break (e==) l'+regexp :: Parser String+regexp = many1 p <?> "Regular expression"+  where p = try (string "\\," >> return ',')+            <|> noneOf "," -strip :: String -> String-strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse+canonicalName :: Parser String+canonicalName = many1 p+  where p = try (string "\\," >> return ',')+            <|> noneOf ",<"  \end{code}
src/Darcs/Commands/ShowBug.lhs view
@@ -20,34 +20,34 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Commands.ShowBug ( show_bug ) where+module Darcs.Commands.ShowBug ( showBug ) where  import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, working_repo_dir )+import Darcs.Arguments ( DarcsFlag, workingRepoDir ) import Darcs.Repository ( findRepository ) #include "impossible.h" -show_bug_description :: String-show_bug_description = "Simulate a run-time failure."+showBugDescription :: String+showBugDescription = "Simulate a run-time failure." -show_bug_help :: String-show_bug_help =+showBugHelp :: String+showBugHelp =   "Show bug can be used to see what darcs would show you if you encountered.\n"   ++"a bug in darcs.\n" -show_bug :: DarcsCommand-show_bug = DarcsCommand {command_name = "bug",-                         command_help = show_bug_help,-                         command_description = show_bug_description,-                         command_extra_args = 0,-                         command_extra_arg_help = [],-                         command_command = show_bug_cmd,-                         command_prereq = findRepository,-                         command_get_arg_possibilities = return [],-                         command_argdefaults = nodefaults,-                         command_advanced_options = [],-                         command_basic_options = [working_repo_dir]}+showBug :: DarcsCommand+showBug = DarcsCommand {commandName = "bug",+                         commandHelp = showBugHelp,+                         commandDescription = showBugDescription,+                         commandExtraArgs = 0,+                         commandExtraArgHelp = [],+                         commandCommand = showBugCmd,+                         commandPrereq = findRepository,+                         commandGetArgPossibilities = return [],+                         commandArgdefaults = nodefaults,+                         commandAdvancedOptions = [],+                         commandBasicOptions = [workingRepoDir]} -show_bug_cmd :: [DarcsFlag] -> [String] -> IO ()-show_bug_cmd _ _ = bug "This is actually a fake bug in darcs."+showBugCmd :: [DarcsFlag] -> [String] -> IO ()+showBugCmd _ _ = bug "This is actually a fake bug in darcs." \end{code}
src/Darcs/Commands/ShowContents.lhs view
@@ -17,56 +17,70 @@  \darcsCommand{show contents} \begin{code}-module Darcs.Commands.ShowContents ( show_contents ) where+module Darcs.Commands.ShowContents ( showContents ) where -import Control.Monad ( filterM )+import Control.Monad ( filterM, forM_, unless )+import Control.Monad.Trans( liftIO ) import System.IO ( stdout )-import System.FilePath.Posix ( takeFileName )+import Data.Maybe( fromJust )  import qualified Data.ByteString as B-import Workaround ( getCurrentDirectory )  import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, match_one,-                         working_repo_dir, fixSubPaths )-import Darcs.RepoPath ( toFilePath, sp2fn )+import Darcs.Arguments ( DarcsFlag, matchOne,+                         workingRepoDir, fixSubPaths )+import Darcs.RepoPath ( sp2fn ) import Darcs.IO ( mReadFilePS, mDoesFileExist )-import Darcs.Match ( get_partial_nonrange_match, have_nonrange_match )-import Darcs.Repository ( withRepository, ($-), findRepository,-                          createPartialsPristineDirectoryTree )-import Darcs.Lock ( withTempDir )+import Darcs.Patch.Match( Matcher )+import Darcs.Match ( haveNonrangeMatch, applyInvToMatcher, nonrangeMatcher+                   , InclusiveOrExclusive(..), matchExists )+import Darcs.Repository ( withRepository, ($-), findRepository, read_repo, readRecorded )+import Darcs.Patch( RepoPatch )+import Storage.Hashed.Monad( virtualTreeIO ) -show_contents_description :: String-show_contents_description = "Outputs a specific version of a file."+showContentsDescription :: String+showContentsDescription = "Outputs a specific version of a file." -show_contents_help :: String-show_contents_help =+showContentsHelp :: String+showContentsHelp =   "Show contents can be used to display an earlier version of some file(s).\n"++   "If you give show contents no version arguments, it displays the recorded\n"++   "version of the file(s).\n" -show_contents :: DarcsCommand-show_contents = DarcsCommand {command_name = "contents",-                              command_help = show_contents_help,-                              command_description = show_contents_description,-                              command_extra_args = -1,-                              command_extra_arg_help+showContents :: DarcsCommand+showContents = DarcsCommand {commandName = "contents",+                              commandHelp = showContentsHelp,+                              commandDescription = showContentsDescription,+                              commandExtraArgs = -1,+                              commandExtraArgHelp                                     = ["[FILE]..."],-                              command_command = show_contents_cmd,-                              command_prereq = findRepository,-                              command_get_arg_possibilities = return [],-                              command_argdefaults = nodefaults,-                              command_advanced_options = [],-                              command_basic_options = [match_one, working_repo_dir]}+                              commandCommand = showContentsCmd,+                              commandPrereq = findRepository,+                              commandGetArgPossibilities = return [],+                              commandArgdefaults = nodefaults,+                              commandAdvancedOptions = [],+                              commandBasicOptions = [matchOne, workingRepoDir]} -show_contents_cmd :: [DarcsFlag] -> [String] -> IO ()-show_contents_cmd opts args = withRepository opts $- \repository -> do-  formerdir <- getCurrentDirectory+getMatcher :: (RepoPatch p) => [DarcsFlag] -> Matcher p+getMatcher = fromJust . nonrangeMatcher++showContentsCmd :: [DarcsFlag] -> [String] -> IO ()+showContentsCmd _ [] = fail+ "show contents needs at least one argument."+showContentsCmd opts args = withRepository opts $- \repository -> do   path_list <- map sp2fn `fmap` fixSubPaths opts args-  thename <- return $ takeFileName formerdir-  withTempDir thename $ \dir -> do-     if have_nonrange_match opts-        then get_partial_nonrange_match repository opts path_list-        else createPartialsPristineDirectoryTree repository path_list (toFilePath dir)-     filterM mDoesFileExist path_list >>= mapM_ (\f -> mReadFilePS f >>= B.hPut stdout)+  pristine <- readRecorded repository+  let matcher = getMatcher opts+      unapply_to_match = applyInvToMatcher Exclusive matcher+  matched <- if (haveNonrangeMatch opts)+                 then do patchset <- read_repo repository+                         unless (matchExists matcher patchset) $+                                fail $ "Couldn't match pattern " ++ show matcher+                         snd `fmap` virtualTreeIO (unapply_to_match patchset) pristine+                 else return pristine+  let dump = do okpaths <- filterM mDoesFileExist path_list+                forM_ okpaths $ \f -> do content <- mReadFilePS f+                                         liftIO (B.hPut stdout content)+  virtualTreeIO dump matched+  return () \end{code}
src/Darcs/Commands/ShowFiles.lhs view
@@ -20,20 +20,24 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} #include "gadts.h"-module Darcs.Commands.ShowFiles ( show_files, show_manifest ) where-import Darcs.Arguments ( DarcsFlag(..), working_repo_dir,-                        files, directories, pending, nullFlag )-import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )+module Darcs.Commands.ShowFiles ( showFiles, showManifest ) where+import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,+                        files, directories, pending, nullFlag, matchOne )+import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) import Darcs.Repository ( Repository, amInRepository, slurp_pending, slurp_recorded,                           withRepository ) import Darcs.Patch ( RepoPatch )-import Darcs.SlurpDirectory ( Slurpy, list_slurpy, list_slurpy_files, list_slurpy_dirs )+import Darcs.SlurpDirectory ( Slurpy, list_slurpy, list_slurpy_files, list_slurpy_dirs, slurp )+import Data.List( isPrefixOf ) -show_files_description :: String-show_files_description = "Show version-controlled files in the working copy."+import Darcs.Match ( haveNonrangeMatch, getNonrangeMatch )+import Workaround ( getCurrentDirectory )+import Darcs.Lock ( withDelayedDir )+showFilesDescription :: String+showFilesDescription = "Show version-controlled files in the working copy." -show_files_help :: String-show_files_help =+showFilesHelp :: String+showFilesHelp =  "The `darcs show files' command lists those files and directories in\n" ++  "the working tree that are under version control.  This command is\n" ++  "primarily for scripting purposes; end users will probably want `darcs\n" ++@@ -57,43 +61,65 @@  "\n" ++  "    darcs show files -0 | xargs -0 ls -ldS\n" -show_files :: DarcsCommand-show_files = DarcsCommand {-  command_name = "files",-  command_help = show_files_help,-  command_description = show_files_description,-  command_extra_args = 0,-  command_extra_arg_help = [],-  command_command = manifest_cmd to_list_files,-  command_prereq = amInRepository,-  command_get_arg_possibilities = return [],-  command_argdefaults = nodefaults,-  command_advanced_options = [],-  command_basic_options = [files, directories, pending, nullFlag,-                          working_repo_dir] }+showFiles :: DarcsCommand+showFiles = DarcsCommand {+  commandName = "files",+  commandHelp = showFilesHelp,+  commandDescription = showFilesDescription,+  commandExtraArgs = -1,+  commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+  commandCommand = manifestCmd toListFiles,+  commandPrereq = amInRepository,+  commandGetArgPossibilities = return [],+  commandArgdefaults = nodefaults,+  commandAdvancedOptions = [],+  commandBasicOptions = [files, directories, pending, nullFlag, matchOne,+                          workingRepoDir] } -show_manifest :: DarcsCommand-show_manifest = command_alias "manifest" show_files {-  command_command = manifest_cmd to_list_manifest+showManifest :: DarcsCommand+showManifest = commandAlias "manifest" showFiles {+  commandCommand = manifestCmd toListManifest } -to_list_files, to_list_manifest :: [DarcsFlag] -> Slurpy -> [FilePath]-to_list_files    opts = files_dirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts)-to_list_manifest opts = files_dirs (NoFiles `notElem` opts) (Directories `elem` opts)+toListFiles, toListManifest :: [DarcsFlag] -> Slurpy -> [FilePath]+toListFiles    opts = filesDirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts)+toListManifest opts = filesDirs (NoFiles `notElem` opts) (Directories `elem` opts) -files_dirs :: Bool -> Bool -> Slurpy -> [FilePath]-files_dirs False False = \_ -> []-files_dirs False True  = list_slurpy_dirs-files_dirs True  False = list_slurpy_files-files_dirs True  True  = list_slurpy+filesDirs :: Bool -> Bool -> Slurpy -> [FilePath]+filesDirs False False = \_ -> []+filesDirs False True  = list_slurpy_dirs+filesDirs True  False = list_slurpy_files+filesDirs True  True  = list_slurpy -manifest_cmd :: ([DarcsFlag] -> Slurpy -> [FilePath]) -> [DarcsFlag] -> [String] -> IO ()-manifest_cmd to_list opts _ = do-    list <- (to_list opts) `fmap` withRepository opts slurp-    mapM_ output list-    where slurp :: RepoPatch p => Repository p C(r u r) -> IO Slurpy-          slurp = if NoPending `notElem` opts-                  then slurp_pending else slurp_recorded+manifestCmd :: ([DarcsFlag] -> Slurpy -> [FilePath]) -> [DarcsFlag] -> [String] -> IO ()+manifestCmd to_list opts argList = do+    list <- (to_list opts) `fmap` withRepository opts myslurp+    case argList of +        [] -> mapM_ output list+        prefixes -> mapM_ output (onlysubdirs prefixes list)+    where myslurp :: RepoPatch p => Repository p C(r u r) -> IO Slurpy+          myslurp = do let fRevisioned = haveNonrangeMatch opts+                           fPending = Pending `elem` opts+                           fNoPending = NoPending `elem` opts +                       -- this covers all 8 options+                       case (fRevisioned,fPending,fNoPending) of+                            (True,False,_) -> slurp_revision opts+                            (True,True,_) -> error $ "can't mix revisioned and pending flags"+                            (False,False,True) -> slurp_recorded+                            (False,_,False) -> slurp_pending -- pending is default+                            (False,True,True) -> error $ "can't mix pending and no-pending flags"           output_null name = do { putStr name ; putChar '\0' }           output = if NullFlag `elem` opts then output_null else putStrLn+          isParentDir a b = a == b  +                            || (a  ++ "/") `isPrefixOf` b +                            || ("./" ++ a ++ "/") `isPrefixOf` b +                            || "./" ++ a == b+          onlysubdirs suffixes = filter $ or . mapM isParentDir suffixes++slurp_revision :: RepoPatch p => [DarcsFlag] -> Repository p C(r u r) -> IO Slurpy+slurp_revision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do +  getNonrangeMatch r opts +  slurp =<< getCurrentDirectory++ \end{code}
src/Darcs/Commands/ShowIndex.lhs view
@@ -25,56 +25,57 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} #include "gadts.h"-module Darcs.Commands.ShowIndex ( show_index, show_pristine ) where-import Darcs.Arguments ( DarcsFlag(..), working_repo_dir,+module Darcs.Commands.ShowIndex ( showIndex, showPristine ) where+import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,                         files, directories, nullFlag )-import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )-import Darcs.Repository ( amInRepository, withRepository, ($-) )+import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )+import Darcs.Repository ( amInRepository, withRepository, ($-), readIndex )+import Darcs.Repository.State ( readRecorded ) -import Darcs.Gorsvet( readIndex )-import Storage.Hashed( readDarcsPristine, floatPath )-import Storage.Hashed.Darcs( darcsFormatHash )+import Storage.Hashed( floatPath )+import Storage.Hashed.Hash( encodeBase16, Hash( NoHash ) ) import Storage.Hashed.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )+import Storage.Hashed.Index( updateIndex ) import Storage.Hashed.AnchoredPath( anchorPath )  import qualified Data.ByteString.Char8 as BS -show_index :: DarcsCommand-show_index = DarcsCommand {-  command_name = "index",-  command_description = "Dump contents of working tree index.",-  command_help =+showIndex :: DarcsCommand+showIndex = DarcsCommand {+  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.",-  command_extra_args = 0,-  command_extra_arg_help = [],-  command_command = show_index_cmd,-  command_prereq = amInRepository,-  command_get_arg_possibilities = return [],-  command_argdefaults = nodefaults,-  command_advanced_options = [],-  command_basic_options = [files, directories, nullFlag, working_repo_dir] }+  commandExtraArgs = 0,+  commandExtraArgHelp = [],+  commandCommand = showIndexCmd,+  commandPrereq = amInRepository,+  commandGetArgPossibilities = return [],+  commandArgdefaults = nodefaults,+  commandAdvancedOptions = [],+  commandBasicOptions = [files, directories, nullFlag, workingRepoDir] } -show_pristine :: DarcsCommand-show_pristine = command_alias "pristine" show_index {-  command_command = show_pristine_cmd,-  command_description = "Dump contents of pristine cache.",-  command_help =+showPristine :: DarcsCommand+showPristine = commandAlias "pristine" 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." } -dump :: [DarcsFlag] -> Tree -> IO ()+dump :: [DarcsFlag] -> Tree IO -> IO () dump opts tree = do   let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0'            | otherwise = putStrLn       output (p, i) = do         let hash = case itemHash i of-                     Just h -> BS.unpack $ darcsFormatHash h-                     Nothing -> "(no hash available)"+                     NoHash -> "(no hash available)"+                     h -> BS.unpack $ encodeBase16 h             path = anchorPath "" p             isdir = case i of                       SubTree _ -> "/"@@ -83,12 +84,12 @@   x <- expand tree   mapM_ output $ (floatPath ".", SubTree x) : list x -show_index_cmd :: [DarcsFlag] -> [String] -> IO ()-show_index_cmd opts _ = withRepository opts $- \repo -> do-  readIndex repo >>= dump opts+showIndexCmd :: [DarcsFlag] -> [String] -> IO ()+showIndexCmd opts _ = withRepository opts $- \repo -> do+  readIndex repo >>= updateIndex >>= dump opts -show_pristine_cmd :: [DarcsFlag] -> [String] -> IO ()-show_pristine_cmd opts _ = withRepository opts $- \_ -> do-  readDarcsPristine "." >>= dump opts+showPristineCmd :: [DarcsFlag] -> [String] -> IO ()+showPristineCmd opts _ = withRepository opts $- \repo -> do+  readRecorded repo >>= dump opts  \end{code}
src/Darcs/Commands/ShowRepo.lhs view
@@ -17,89 +17,60 @@  \darcsCommand{show repo} -The \verb!show repo! displays information about-the current repository: the location, the type, etc.--This is provided as informational output for two purposes: curious-users and scripts invoking darcs.  For the latter, this information-can be parsed to facilitate the script; for example,-\verb!darcs show repo | grep Root: | awk {print $2}!-can be used to locate the-top-level \verb!_darcs! directory from anyplace within a darcs repository-working directory.- \begin{code} {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} #include "gadts.h"-module Darcs.Commands.ShowRepo ( show_repo ) where+module Darcs.Commands.ShowRepo ( showRepo ) where  import Data.Char ( toLower, isSpace ) import Data.List ( intersperse ) import Control.Monad ( when, unless ) import Text.Html ( tag, stringToHtml )-import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, files, xmloutput )+import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, files, xmloutput ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Repository ( withRepository, ($-), amInRepository, read_repo ) import Darcs.Repository.Internal ( Repository(..), RepoType(..) ) import Darcs.Repository.Format ( RepoFormat(..) )-import Darcs.Repository.Prefs ( get_preflist )+import Darcs.Repository.Prefs ( getPreflist ) import Darcs.Repository.Motd ( get_motd ) import Darcs.Patch ( RepoPatch )-import Darcs.Ordered ( lengthRL, concatRL )+import Darcs.Witnesses.Ordered ( lengthRL, concatRL ) import qualified Data.ByteString.Char8 as BC  (unpack) -show_repo_help :: String-show_repo_help =- "The repo command displays information about the current repository\n" ++- "(location, type, etc.).  Some of this information is already available\n" ++- "by inspecting files within the _darcs directory and some is internal\n" ++- "information that is informational only (i.e. for developers).  This\n" ++- "command collects all of the repository information into a readily\n" ++- "available source.\n"--show_repo_description :: String-show_repo_description = "Show repository summary information"--show_repo :: DarcsCommand-show_repo = DarcsCommand { command_name = "repo",-                           command_help = show_repo_help,-                           command_description = show_repo_description,-                           command_extra_args = 0,-                           command_extra_arg_help = [],-                           command_command = repo_cmd,-                           command_prereq = amInRepository,-                           command_get_arg_possibilities = return [],-                           command_argdefaults = nodefaults,-                           command_advanced_options = [],-                           command_basic_options = [working_repo_dir, files, xmloutput] }-\end{code}--\begin{options}---files, --no-files-\end{options}--If the \verb!--files! option is specified (the default), then the-\verb!show repo! operation will read patch information from the-repository and display the number of patches in the repository.  The-\verb!--no-files! option can be used to suppress this operation (and-improve performance).+showRepoHelp :: String+showRepoHelp =+ "The `darcs show repo' command displays statistics about the current\n" +++ "repository, allowing third-party scripts to access this information\n" +++ "without inspecting _darcs directly (and without breaking when the\n" +++ "_darcs format changes).\n" +++ "\n" +++ "By default, the number of patches is shown.  If this data isn't\n" +++ "needed, use --no-files to accelerate this command from O(n) to O(1).\n" +++ "\n" +++ "By default, output is in a human-readable format.  The --xml-output\n" +++ "option can be used to generate output for machine postprocessing.\n" -\begin{code}-repo_cmd :: [DarcsFlag] -> [String] -> IO ()-repo_cmd opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr-                  in withRepository opts $- \repository -> showRepo (putInfo put_mode) repository-\end{code}+showRepoDescription :: String+showRepoDescription = "Show repository summary information" -\begin{options}---human-readable, --xml-output-\end{options}+showRepo :: DarcsCommand+showRepo = DarcsCommand { commandName = "repo",+                           commandHelp = showRepoHelp,+                           commandDescription = showRepoDescription,+                           commandExtraArgs = 0,+                           commandExtraArgHelp = [],+                           commandCommand = repoCmd,+                           commandPrereq = amInRepository,+                           commandGetArgPossibilities = return [],+                           commandArgdefaults = nodefaults,+                           commandAdvancedOptions = [],+                           commandBasicOptions = [workingRepoDir, files, xmloutput] } -By default, the \verb!show repo! displays output in human readable-form, but the \verb!--xml-output! option can be used to obtain-XML-formatted to facilitate regular parsing by external tools.+repoCmd :: [DarcsFlag] -> [String] -> IO ()+repoCmd opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr+                  in withRepository opts $- \repository -> actuallyShowRepo (putInfo put_mode) repository -\begin{code} -- Some convenience functions to output a labelled text string or an -- XML tag + value (same API).  If no value, output is suppressed -- entirely.  Borrow some help from Text.Html to perform XML output.@@ -129,8 +100,8 @@ -- sub-displays.  The `out' argument is one of the above operations to -- output a labelled text string or an XML tag and contained value. -showRepo :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO ()-showRepo out r@(Repo loc opts rf rt) = do+actuallyShowRepo :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO ()+actuallyShowRepo out r@(Repo loc opts rf rt) = do          when (XMLOutput `elem` opts) (putStr "<repository>\n")          showRepoType out rt          when (Verbose `elem` opts) (out "Show" $ show r)@@ -162,9 +133,9 @@  showRepoPrefs :: PutInfo -> IO () showRepoPrefs out = do-    get_preflist "prefs" >>= mapM_ prefOut-    get_preflist "author" >>= out "Author" . unlines-    get_preflist "defaultrepo" >>= out "Default Remote" . unlines+    getPreflist "prefs" >>= mapM_ prefOut+    getPreflist "author" >>= out "Author" . unlines+    getPreflist "defaultrepo" >>= out "Default Remote" . unlines   where prefOut = uncurry out . (\(p,v) -> (p++" Pref", (dropWhile isSpace v))) . break isSpace  showRepoMOTD :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO ()
src/Darcs/Commands/ShowTags.lhs view
@@ -17,21 +17,21 @@  \darcsCommand{show tags} \begin{code}-module Darcs.Commands.ShowTags ( show_tags ) where-import Darcs.Arguments ( DarcsFlag(..), working_repo_dir )+module Darcs.Commands.ShowTags ( showTags ) where+import Darcs.Arguments ( DarcsFlag(..), workingRepoDir ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Hopefully ( info ) import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) ) import Darcs.Patch.Info ( pi_tag )-import Darcs.Ordered ( mapRL, concatRL )+import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import System.IO ( stderr, hPutStrLn ) -- import Printer ( renderPS ) -show_tags_description :: String-show_tags_description = "Show all tags in the repository."+showTagsDescription :: String+showTagsDescription = "Show all tags in the repository." -show_tags_help :: String-show_tags_help =+showTagsHelp :: String+showTagsHelp =  "The tags command writes a list of all tags in the repository to standard\n"++  "output.\n" ++  "\n" ++@@ -39,22 +39,22 @@  "for better interoperability with shell tools.  A warning is printed if\n" ++  "this happens." -show_tags :: DarcsCommand-show_tags = DarcsCommand {-  command_name = "tags",-  command_help = show_tags_help,-  command_description = show_tags_description,-  command_extra_args = 0,-  command_extra_arg_help = [],-  command_command = tags_cmd,-  command_prereq = amInRepository,-  command_get_arg_possibilities = return [],-  command_argdefaults = nodefaults,-  command_advanced_options = [],-  command_basic_options = [working_repo_dir] }+showTags :: DarcsCommand+showTags = DarcsCommand {+  commandName = "tags",+  commandHelp = showTagsHelp,+  commandDescription = showTagsDescription,+  commandExtraArgs = 0,+  commandExtraArgHelp = [],+  commandCommand = tagsCmd,+  commandPrereq = amInRepository,+  commandGetArgPossibilities = return [],+  commandArgdefaults = nodefaults,+  commandAdvancedOptions = [],+  commandBasicOptions = [workingRepoDir] } -tags_cmd :: [DarcsFlag] -> [String] -> IO ()-tags_cmd opts _ = withRepository opts $- \repository -> do+tagsCmd :: [DarcsFlag] -> [String] -> IO ()+tagsCmd opts _ = withRepository opts $- \repository -> do   patches <- read_repo repository   sequence_ $ mapRL process $ concatRL patches   where process hp =
src/Darcs/Commands/Tag.lhs view
@@ -18,36 +18,36 @@ \darcsCommand{tag} \begin{code} module Darcs.Commands.Tag ( tag ) where+import System.Directory ( removeFile ) import Control.Monad ( when ) -import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help,-                        command_description, command_extra_args,-                        command_extra_arg_help, command_command, command_prereq,-                        command_get_arg_possibilities, command_argdefaults,-                        command_advanced_options, command_basic_options),+import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp,+                        commandDescription, commandExtraArgs,+                        commandExtraArgHelp, commandCommand, commandPrereq,+                        commandGetArgPossibilities, commandArgdefaults,+                        commandAdvancedOptions, commandBasicOptions),                         nodefaults )-import Darcs.Arguments ( nocompress, umask_option, patchname_option, author,-                         checkpoint, pipe_interactive, ask_long_comment,-                         working_repo_dir, get_author )+import Darcs.Arguments ( nocompress, umaskOption, patchnameOption, author,+                         pipeInteractive, askLongComment,+                         workingRepoDir, getAuthor ) import Darcs.Hopefully ( n2pia ) import Darcs.Repository ( amInRepository, withRepoLock, ($-), read_repo,                     tentativelyAddPatch, finalizeRepositoryChanges,                    )-import Darcs.Repository.Checkpoint ( write_recorded_checkpoint ) import Darcs.Patch ( infopatch, identity, adddeps ) import Darcs.Patch.Info ( patchinfo ) import Darcs.Patch.Depends ( get_tags_right )-import Darcs.Commands.Record ( get_date, get_log )-import Darcs.Ordered ( FL(..) )+import Darcs.Commands.Record ( getDate, getLog )+import Darcs.Witnesses.Ordered ( FL(..) ) import Darcs.Lock ( world_readable_temp ) import Darcs.Flags ( DarcsFlag(..) ) import System.IO ( hPutStr, stderr ) -tag_description :: String-tag_description = "Name the current repository state for future reference."+tagDescription :: String+tagDescription = "Name the current repository state for future reference." -tag_help :: String-tag_help =+tagHelp :: String+tagHelp =  "The `darcs tag' command names the current repository state, so that it\n" ++  "can easily be referred to later.  Every `important' state should be\n" ++  "tagged; in particular it is good practice to tag each stable release\n" ++@@ -67,46 +67,44 @@  "A tag can have any name, but it is generally best to pick a naming\n" ++  "scheme and stick to it.\n" ++  "\n" ++- "The `darcs tag' command accepts the --pipe and --checkpoint options,\n" ++- "which behave as described in `darcs record' and `darcs optimize'\n" ++- "respectively.\n"+ "The `darcs tag' command accepts the --pipe option, which behaves as\n" +++ "described in `darcs record'.\n"  tag :: DarcsCommand-tag = DarcsCommand {command_name = "tag",-                    command_help = tag_help,-                    command_description = tag_description,-                    command_extra_args = -1,-                    command_extra_arg_help = ["[TAGNAME]"],-                    command_command = tag_cmd,-                    command_prereq = amInRepository,-                    command_get_arg_possibilities = return [],-                    command_argdefaults = nodefaults,-                    command_advanced_options = [nocompress,umask_option],-                    command_basic_options = [patchname_option, author,-                                            checkpoint,-                                            pipe_interactive,-                                            ask_long_comment,-                                            working_repo_dir]}+tag = DarcsCommand {commandName = "tag",+                    commandHelp = tagHelp,+                    commandDescription = tagDescription,+                    commandExtraArgs = -1,+                    commandExtraArgHelp = ["[TAGNAME]"],+                    commandCommand = tagCmd,+                    commandPrereq = amInRepository,+                    commandGetArgPossibilities = return [],+                    commandArgdefaults = nodefaults,+                    commandAdvancedOptions = [nocompress,umaskOption],+                    commandBasicOptions = [patchnameOption, author,+                                            pipeInteractive,+                                            askLongComment,+                                            workingRepoDir]} -tag_cmd :: [DarcsFlag] -> [String] -> IO ()-tag_cmd opts args = withRepoLock opts $- \repository -> do-    date <- get_date opts-    the_author <- get_author opts+tagCmd :: [DarcsFlag] -> [String] -> IO ()+tagCmd opts args = withRepoLock opts $- \repository -> do+    date <- getDate opts+    the_author <- getAuthor opts     deps <- get_tags_right `fmap` read_repo repository-    (name, long_comment)  <- get_name_log opts args+    (name, long_comment, mlogf)  <- get_name_log opts args     myinfo <- patchinfo date name the_author long_comment     let mypatch = infopatch myinfo identity     tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps     finalizeRepositoryChanges repository-    when (CheckPoint `elem` opts) $ write_recorded_checkpoint repository myinfo+    maybe (return ()) removeFile mlogf     putStrLn $ "Finished tagging patch '"++name++"'"-  where  get_name_log :: [DarcsFlag] -> [String] -> IO (String, [String])+  where  get_name_log :: [DarcsFlag] -> [String] -> IO (String, [String], Maybe String)          get_name_log o a = do let o2 = if null a then o else (add_patch_name o (unwords a))-                               (name, comment, _) <- get_log o2 Nothing (world_readable_temp "darcs-tag") NilFL+                               (name, comment, mlogf) <- getLog o2 Nothing (world_readable_temp "darcs-tag") NilFL                                when (length name < 2) $ hPutStr stderr $                                  "Do you really want to tag '"                                  ++name++"'? If not type: darcs obliterate --last=1\n"-                               return ("TAG " ++ name, comment)+                               return ("TAG " ++ name, comment, mlogf)          add_patch_name :: [DarcsFlag] -> String -> [DarcsFlag]          add_patch_name o a| has_patch_name o = o                            | otherwise = [PatchName a] ++ o
src/Darcs/Commands/TrackDown.lhs view
@@ -25,22 +25,24 @@ import Control.Monad( when )  import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable), working_repo_dir,-                         set_scripts_executable )+import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable), workingRepoDir,+                         setScriptsExecutableOption ) import Darcs.Hopefully ( hopefully ) import Darcs.Repository ( amInRepository, read_repo, withRepoReadLock, ($-), withRecorded,                           setScriptsExecutable )-import Darcs.Ordered ( unsafeUnRL, concatRL )-import Darcs.Patch ( RepoPatch, Named, description, apply, invert )+import Darcs.Witnesses.Ordered ( FL(..), mapRL_RL, concatRL )+import Darcs.Patch ( RepoPatch, Named, description, apply, invert, invertRL ) import Printer ( putDocLn ) import Darcs.Test ( get_test ) import Darcs.Lock ( withTempDir ) -trackdown_description :: String-trackdown_description = "Locate the most recent version lacking an error."+#include "gadts.h" -trackdown_help :: String-trackdown_help =+trackdownDescription :: String+trackdownDescription = "Locate the most recent version lacking an error."++trackdownHelp :: String+trackdownHelp =  "Trackdown tries to find the most recent version in the repository which\n"++  "passes a test.  Given no arguments, it uses the default repository test.\n"++  "Given one argument, it treats it as a test command.  Given two arguments,\n"++@@ -48,21 +50,21 @@  "second is the test command.\n"  trackdown :: DarcsCommand-trackdown = DarcsCommand {command_name = "trackdown",-                          command_help = trackdown_help,-                          command_description = trackdown_description,-                          command_extra_args = -1,-                          command_extra_arg_help = ["[[INITIALIZATION]",+trackdown = DarcsCommand {commandName = "trackdown",+                          commandHelp = trackdownHelp,+                          commandDescription = trackdownDescription,+                          commandExtraArgs = -1,+                          commandExtraArgHelp = ["[[INITIALIZATION]",                                                     "COMMAND]"],-                          command_command = trackdown_cmd,-                          command_prereq = amInRepository,-                          command_get_arg_possibilities = return [],-                          command_argdefaults = nodefaults,-                          command_advanced_options = [set_scripts_executable],-                          command_basic_options = [working_repo_dir]}+                          commandCommand = trackdownCmd,+                          commandPrereq = amInRepository,+                          commandGetArgPossibilities = return [],+                          commandArgdefaults = nodefaults,+                          commandAdvancedOptions = [setScriptsExecutableOption],+                          commandBasicOptions = [workingRepoDir]} -trackdown_cmd :: [DarcsFlag] -> [String] -> IO ()-trackdown_cmd opts args = withRepoReadLock opts $- \repository -> do+trackdownCmd :: [DarcsFlag] -> [String] -> IO ()+trackdownCmd opts args = withRepoReadLock opts $- \repository -> do   patches <- read_repo repository   (init,test) <- case args of           [] ->@@ -79,10 +81,10 @@   withRecorded repository (withTempDir "trackingdown") $ \_ -> do     when (SetScriptsExecutable `elem` opts) setScriptsExecutable     init-    track_next opts test $ map (invert . hopefully) $ unsafeUnRL $ concatRL patches+    trackNext opts test . invertRL . mapRL_RL hopefully . concatRL $ patches -track_next :: RepoPatch p => [DarcsFlag] -> (IO ExitCode) -> [Named p] -> IO ()-track_next opts test (p:ps) = do+trackNext :: RepoPatch p => [DarcsFlag] -> (IO ExitCode) -> FL (Named p) C(x y) -> IO ()+trackNext opts test (p:>:ps) = do     test_result <- test     if test_result == ExitSuccess        then putStrLn "Success!"@@ -90,8 +92,8 @@                putStrLn "Trying without the patch:"                putDocLn $ description $ invert p                hFlush stdout-               track_next opts test ps-track_next _ _ [] = putStrLn "Noone passed the test!"+               trackNext opts test ps+trackNext _ _ NilFL = putStrLn "Noone passed the test!" \end{code}  Trackdown is helpful for locating when something was broken.  It creates
src/Darcs/Commands/TransferMode.lhs view
@@ -21,7 +21,7 @@ {-# LANGUAGE CPP, PatternGuards #-}  -- The pragma above is only for pattern guards.-module Darcs.Commands.TransferMode ( transfer_mode ) where+module Darcs.Commands.TransferMode ( transferMode ) where  import Prelude hiding ( catch ) import Control.Exception ( catch )@@ -29,18 +29,18 @@  import Darcs.Utils ( withCurrentDirectory, prettyException ) import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, working_repo_dir )+import Darcs.Arguments ( DarcsFlag, workingRepoDir ) import Darcs.Repository ( amInRepository ) import Progress ( setProgressMode ) import Darcs.Global ( darcsdir )  import qualified Data.ByteString as B (hPut, readFile, length, ByteString) -transfer_mode_description :: String-transfer_mode_description = "Internal command for efficient ssh transfers."+transferModeDescription :: String+transferModeDescription = "Internal command for efficient ssh transfers." -transfer_mode_help :: String-transfer_mode_help =+transferModeHelp :: String+transferModeHelp =  "When pulling from or pushing to a remote repository over ssh, if both\n" ++  "the local and remote ends have Darcs 2, the `transfer-mode' command\n" ++  "will be invoked on the remote end.  This allows Darcs to intelligently\n" ++@@ -51,21 +51,21 @@  "who do not run ssh-agent will be prompted for the ssh password tens or\n" ++  "hundreds of times!\n" -transfer_mode :: DarcsCommand-transfer_mode = DarcsCommand {command_name = "transfer-mode",-                              command_help = transfer_mode_help,-                              command_description = transfer_mode_description,-                              command_extra_args = 0,-                              command_extra_arg_help = [],-                              command_get_arg_possibilities = return [],-                              command_command = transfer_mode_cmd,-                              command_prereq = amInRepository,-                              command_argdefaults = nodefaults,-                              command_advanced_options = [],-                              command_basic_options = [working_repo_dir]}+transferMode :: DarcsCommand+transferMode = DarcsCommand {commandName = "transfer-mode",+                              commandHelp = transferModeHelp,+                              commandDescription = transferModeDescription,+                              commandExtraArgs = 0,+                              commandExtraArgHelp = [],+                              commandGetArgPossibilities = return [],+                              commandCommand = transferModeCmd,+                              commandPrereq = amInRepository,+                              commandArgdefaults = nodefaults,+                              commandAdvancedOptions = [],+                              commandBasicOptions = [workingRepoDir]} -transfer_mode_cmd :: [DarcsFlag] -> [String] -> IO ()-transfer_mode_cmd _ _ = do setProgressMode False+transferModeCmd :: [DarcsFlag] -> [String] -> IO ()+transferModeCmd _ _ =   do setProgressMode False                            putStrLn "Hello user, I am darcs transfer mode"                            hFlush stdout                            withCurrentDirectory darcsdir $ transfer
src/Darcs/Commands/Unrecord.lhs view
@@ -20,41 +20,41 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, get_last_patches ) where+module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, getLastPatches ) where import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) -import Darcs.SlurpDirectory ( wait_a_moment )+import Printer ( text ) import Darcs.Hopefully ( hopefully )-import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_alias )-import Darcs.Arguments ( DarcsFlag( Verbose ),-                         working_repo_dir, nocompress, definePatches,-                        match_several_or_last, deps_sel,+import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias,+                        putVerbose )+import Darcs.Arguments ( DarcsFlag,+                         workingRepoDir, nocompress, definePatches,+                        matchSeveralOrLast, depsSel,                         ignoretimes,-                        all_interactive, umask_option, summary+                        allInteractive, umaskOption, summary, dryRun,+                        printDryRunMessageAndExit                       )-import Darcs.Match ( first_match, match_first_patchset, match_a_patchread )+import Darcs.Match ( firstMatch, matchFirstPatchset, matchAPatchread ) import Darcs.Repository ( PatchSet, PatchInfoAnd, withGutsOf,                           withRepoLock, ($-),                     tentativelyRemovePatches, finalizeRepositoryChanges,                     tentativelyAddToPending,                     applyToWorking,-                    get_unrecorded, read_repo, amInRepository,-                    sync_repo,-                  )-import Darcs.Patch ( Patchy, RepoPatch, invert, commutex, effect )-import Darcs.Ordered ( RL(..), (:<)(..), (:>)(..), (:\/:)(..), (+<+),+                    read_repo, amInRepository+                        , invalidateIndex, unrecordedChanges )+import Darcs.Patch ( Patchy, RepoPatch, invert, commute, effect )+import Darcs.Witnesses.Ordered ( RL(..), (:>)(..), (:\/:)(..), (+<+),                              mapFL_FL, nullFL,-                             concatRL, reverseRL, mapRL )+                             reverseRL, mapRL ) import Darcs.Patch.Depends ( get_common_and_uncommon ) import Darcs.SelectChanges ( with_selected_last_changes_reversed ) import Progress ( debugMessage )-import Darcs.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped )-import Darcs.Gorsvet( invalidateIndex )+import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped ) #include "gadts.h" -unrecord_description :: String-unrecord_description =+unrecordDescription :: String+unrecordDescription =  "Remove recorded patches without changing the working copy." \end{code} @@ -124,8 +124,8 @@ more or fewer patches.  \begin{code}-unrecord_help :: String-unrecord_help =+unrecordHelp :: String+unrecordHelp =  "Unrecord does the opposite of record in that it makes the changes from\n"++  "patches active changes again which you may record or revert later.  The\n"++  "working copy itself will not change.\n"++@@ -134,56 +134,54 @@  "another user may have already pulled the patch.\n"  unrecord :: DarcsCommand-unrecord = DarcsCommand {command_name = "unrecord",-                         command_help = unrecord_help,-                         command_description = unrecord_description,-                         command_extra_args = 0,-                         command_extra_arg_help = [],-                         command_command = unrecord_cmd,-                         command_prereq = amInRepository,-                         command_get_arg_possibilities = return [],-                         command_argdefaults = nodefaults,-                         command_advanced_options = [nocompress,umask_option],-                         command_basic_options = [match_several_or_last,-                                                 deps_sel,-                                                 all_interactive,-                                                 working_repo_dir]}+unrecord = DarcsCommand {commandName = "unrecord",+                         commandHelp = unrecordHelp,+                         commandDescription = unrecordDescription,+                         commandExtraArgs = 0,+                         commandExtraArgHelp = [],+                         commandCommand = unrecordCmd,+                         commandPrereq = amInRepository,+                         commandGetArgPossibilities = return [],+                         commandArgdefaults = nodefaults,+                         commandAdvancedOptions = [nocompress,umaskOption],+                         commandBasicOptions = [matchSeveralOrLast,+                                                 depsSel,+                                                 allInteractive,+                                                 workingRepoDir]} -unrecord_cmd :: [DarcsFlag] -> [String] -> IO ()-unrecord_cmd opts _ = withRepoLock opts $- \repository -> do-  let (logMessage,_,_) = loggers opts+unrecordCmd :: [DarcsFlag] -> [String] -> IO ()+unrecordCmd opts _ = withRepoLock opts $- \repository -> do   allpatches <- read_repo repository-  FlippedSeal patches <- return $ if first_match opts-                                  then get_last_patches opts allpatches+  FlippedSeal patches <- return $ if firstMatch opts+                                  then getLastPatches opts allpatches                                   else matchingHead opts allpatches-  with_selected_last_changes_reversed "unrecord" opts+  with_selected_last_changes_reversed "unrecord" opts Nothing       (reverseRL patches) $     \ (_ :> to_unrecord) -> do-       when (nullFL to_unrecord) $ do logMessage "No patches selected!"+       when (nullFL to_unrecord) $ do putStrLn "No patches selected!"                                       exitWith ExitSuccess-       when (Verbose `elem` opts) $-            logMessage "About to write out (potentially) modified patches..."+       putVerbose opts $ text +                      "About to write out (potentially) modified patches..."        definePatches to_unrecord        invalidateIndex repository        withGutsOf repository $ do tentativelyRemovePatches repository opts $                                                            mapFL_FL hopefully to_unrecord                                   finalizeRepositoryChanges repository-       sync_repo repository-       logMessage "Finished unrecording."+       putStrLn "Finished unrecording." -get_last_patches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(r)+getLastPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(r)                  -> FlippedSeal (RL (PatchInfoAnd p)) C(r)-get_last_patches opts ps =-  case match_first_patchset opts ps of+getLastPatches opts ps =+  case matchFirstPatchset opts ps of   Sealed p1s -> case get_common_and_uncommon (ps,p1s) of-                (_,us :\/: _) -> FlippedSeal $ concatRL us+                (_,us :\/: _) -> FlippedSeal us -unpull_description :: String-unpull_description =+unpullDescription :: String+unpullDescription =  "Opposite of pull; unsafe if patch is not in remote repository." -unpull_help :: String-unpull_help =+unpullHelp :: String+unpullHelp =  "Unpull completely removes recorded patches from your local repository.\n"++  "The changes will be undone in your working copy and the patches will not be\n"++  "shown in your changes list anymore.\n"++@@ -191,24 +189,24 @@  "will lose precious code by unpulling!\n"  unpull :: DarcsCommand-unpull = (command_alias "unpull" obliterate)-                      {command_help = unpull_help,-                       command_description = unpull_description,-                       command_command = unpull_cmd}+unpull = (commandAlias "unpull" obliterate)+                      {commandHelp = unpullHelp,+                       commandDescription = unpullDescription,+                       commandCommand = unpullCmd} -unpull_cmd :: [DarcsFlag] -> [String] -> IO ()-unpull_cmd = generic_obliterate_cmd "unpull"+unpullCmd :: [DarcsFlag] -> [String] -> IO ()+unpullCmd = genericObliterateCmd "unpull"  \end{code} \darcsCommand{obliterate} \begin{code} -obliterate_description :: String-obliterate_description =+obliterateDescription :: String+obliterateDescription =  "Delete selected patches from the repository. (UNSAFE!)" -obliterate_help :: String-obliterate_help =+obliterateHelp :: String+obliterateHelp =  "Obliterate completely removes recorded patches from your local repository.\n"++  "The changes will be undone in your working copy and the patches will not be\n"++  "shown in your changes list anymore.\n"++@@ -260,67 +258,65 @@  \begin{code} obliterate :: DarcsCommand-obliterate = DarcsCommand {command_name = "obliterate",-                           command_help = obliterate_help,-                           command_description = obliterate_description,-                           command_extra_args = 0,-                           command_extra_arg_help = [],-                           command_command = obliterate_cmd,-                           command_prereq = amInRepository,-                           command_get_arg_possibilities = return [],-                           command_argdefaults = nodefaults,-                           command_advanced_options = [nocompress,ignoretimes,umask_option],-                           command_basic_options = [match_several_or_last,-                                                   deps_sel,-                                                   all_interactive,-                                                   working_repo_dir,-                                                   summary]}-obliterate_cmd :: [DarcsFlag] -> [String] -> IO ()-obliterate_cmd = generic_obliterate_cmd "obliterate"+obliterate = DarcsCommand {commandName = "obliterate",+                           commandHelp = obliterateHelp,+                           commandDescription = obliterateDescription,+                           commandExtraArgs = 0,+                           commandExtraArgHelp = [],+                           commandCommand = obliterateCmd,+                           commandPrereq = amInRepository,+                           commandGetArgPossibilities = return [],+                           commandArgdefaults = nodefaults,+                           commandAdvancedOptions = [nocompress,ignoretimes,umaskOption],+                           commandBasicOptions = [matchSeveralOrLast,+                                                   depsSel,+                                                   allInteractive,+                                                   workingRepoDir,+                                                   summary]+++                                                   dryRun}+obliterateCmd :: [DarcsFlag] -> [String] -> IO ()+obliterateCmd = genericObliterateCmd "obliterate" --- | generic_obliterate_cmd is the function that executes the "obliterate" and+-- | genericObliterateCmd is the function that executes the "obliterate" and --   "unpull" commands.-generic_obliterate_cmd :: String      -- ^ The name under which the command is invoked (@unpull@ or @obliterate@)+genericObliterateCmd :: String      -- ^ The name under which the command is invoked (@unpull@ or @obliterate@)                        -> [DarcsFlag] -- ^ The flags given on the command line                        -> [String]    -- ^ Files given on the command line (unused)                        -> IO ()-generic_obliterate_cmd cmdname opts _ = withRepoLock opts $- \repository -> do-  let (logMessage,_,_) = loggers opts-  pend <- get_unrecorded repository+genericObliterateCmd cmdname opts _ = withRepoLock opts $- \repository -> do+  pend <- unrecordedChanges opts repository []   allpatches <- read_repo repository-  FlippedSeal patches <- return $ if first_match opts-                                  then get_last_patches opts allpatches+  FlippedSeal patches <- return $ if firstMatch opts+                                  then getLastPatches opts allpatches                                   else matchingHead opts allpatches-  with_selected_last_changes_reversed cmdname opts+  with_selected_last_changes_reversed cmdname opts Nothing       (reverseRL patches) $     \ (_ :> ps) ->-    case commutex (pend :< effect ps) of+    case commute (effect ps :> pend) of     Nothing -> fail $ "Can't "++ cmdname ++                " patch without reverting some unrecorded change."-    Just (p_after_pending:<_) -> do-        when (nullFL ps) $ do logMessage "No patches selected!"+    Just (_ :> p_after_pending) -> do+        when (nullFL ps) $ do putStrLn "No patches selected!"                               exitWith ExitSuccess+        printDryRunMessageAndExit "obliterate" opts ps         definePatches ps         invalidateIndex repository         withGutsOf repository $                              do tentativelyRemovePatches repository opts (mapFL_FL hopefully ps)                                 tentativelyAddToPending repository opts $ invert $ effect ps                                 finalizeRepositoryChanges repository-                                debugMessage "Waiting a bit for timestamps to differ..."-                                wait_a_moment                                 debugMessage "Applying patches to working directory..."                                 applyToWorking repository opts (invert p_after_pending) `catch` \e ->                                     fail ("Couldn't undo patch in working dir.\n" ++ show e)-        sync_repo repository-        logMessage $ "Finished " ++ present_participle cmdname ++ "."+        putStrLn $ "Finished " ++ presentParticiple cmdname ++ "."  matchingHead :: Patchy p => [DarcsFlag] -> PatchSet p C(r) -> FlippedSeal (RL (PatchInfoAnd p)) C(r)-matchingHead opts (x:<:_) | or (mapRL (match_a_patchread opts) x) = FlippedSeal x+matchingHead opts (x:<:_) | or (mapRL (matchAPatchread opts) x) = FlippedSeal x matchingHead opts (x:<:xs) = (x +<+) `mapFlipped` matchingHead opts xs matchingHead _ NilRL = FlippedSeal NilRL -present_participle :: String -> String-present_participle v | last v == 'e' = init v ++ "ing"+presentParticiple :: String -> String+presentParticiple v | last v == 'e' = init v ++ "ing"                      | otherwise = v ++ "ing" \end{code}
src/Darcs/Commands/Unrevert.lhs view
@@ -18,30 +18,29 @@ \darcsCommand{unrevert} \begin{code} {-# OPTIONS_GHC -cpp #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, GADTs #-}  #include "gadts.h" -module Darcs.Commands.Unrevert ( unrevert, write_unrevert ) where+module Darcs.Commands.Unrevert ( unrevert, writeUnrevert ) where import System.Exit ( ExitCode(..), exitWith )+import Storage.Hashed.Tree( Tree )  import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag( Unified, MarkConflicts ),-                         ignoretimes, working_repo_dir,-                        all_interactive, umask_option,+                         ignoretimes, workingRepoDir,+                        allInteractive, umaskOption,                       ) import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, ($-),                           unrevertUrl, considerMergeToWorking,                           tentativelyAddToPending, finalizeRepositoryChanges,-                          sync_repo, get_unrecorded,                           read_repo, amInRepository,-                          slurp_recorded,-                          applyToWorking )-import Darcs.Patch ( RepoPatch, Prim, commutex, namepatch, fromPrims )-import Darcs.Ordered ( RL(..), FL(..), (:<)(..), (:>)(..), (:\/:)(..), reverseRL,+                          readRecorded,+                          applyToWorking, unrecordedChanges )+import Darcs.Patch ( RepoPatch, Prim, commute, namepatch, fromPrims )+import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), reverseRL,                        (+>+) ) import Darcs.SelectChanges ( with_selected_changes_to_files' )-import Darcs.SlurpDirectory ( Slurpy ) import qualified Data.ByteString as B import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist ) import Darcs.Patch.Depends ( get_common_and_uncommon )@@ -50,15 +49,15 @@ import IsoDate ( getIsoDateTime ) import Darcs.SignalHandler ( withSignalsBlocked ) import Progress ( debugMessage )-import Darcs.Sealed ( Sealed(Sealed) )+import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) #include "impossible.h" -unrevert_description :: String-unrevert_description =+unrevertDescription :: String+unrevertDescription =  "Undo the last revert (may fail if changes after the revert)." -unrevert_help :: String-unrevert_help =+unrevertHelp :: String+unrevertHelp =  "Unrevert is a rescue command in case you accidentally reverted\n" ++  "something you wanted to keep (for example, typing `darcs rev -a'\n" ++  "instead of `darcs rec -a').\n" ++@@ -68,31 +67,31 @@  "interactive command that will DEFINITELY prevent unreversion.\n"  unrevert :: DarcsCommand-unrevert = DarcsCommand {command_name = "unrevert",-                         command_help = unrevert_help,-                         command_description = unrevert_description,-                         command_extra_args = 0,-                         command_extra_arg_help = [],-                         command_command = unrevert_cmd,-                         command_prereq = amInRepository,-                         command_get_arg_possibilities = return [],-                         command_argdefaults = nodefaults,-                         command_advanced_options = [umask_option],-                         command_basic_options = [ignoretimes,-                                                  all_interactive,-                                                  working_repo_dir]}+unrevert = DarcsCommand {commandName = "unrevert",+                         commandHelp = unrevertHelp,+                         commandDescription = unrevertDescription,+                         commandExtraArgs = 0,+                         commandExtraArgHelp = [],+                         commandCommand = unrevertCmd,+                         commandPrereq = amInRepository,+                         commandGetArgPossibilities = return [],+                         commandArgdefaults = nodefaults,+                         commandAdvancedOptions = [umaskOption],+                         commandBasicOptions = [ignoretimes,+                                                  allInteractive,+                                                  workingRepoDir]} -unrevert_cmd :: [DarcsFlag] -> [String] -> IO ()-unrevert_cmd opts [] = withRepoLock opts $- \repository -> do+unrevertCmd :: [DarcsFlag] -> [String] -> IO ()+unrevertCmd opts [] = withRepoLock opts $- \repository -> do   us <- read_repo repository-  Sealed them <- unrevert_patch_bundle repository-  rec <- slurp_recorded repository-  unrec <- get_unrecorded repository+  Sealed them <- unrevertPatchBundle repository+  rec <- readRecorded repository+  unrec <- unrecordedChanges opts repository []   case get_common_and_uncommon (us, them) of-    (_, (h_us:<:NilRL) :\/: (h_them:<:NilRL)) -> do+    (_, h_us :\/: h_them) -> do       Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts)                    (reverseRL h_us) (reverseRL h_them)-      with_selected_changes_to_files' "unrevert" opts [] pw $+      with_selected_changes_to_files' "unrevert" opts Nothing [] pw $                             \ (p :> skipped) -> do         tentativelyAddToPending repository opts p         withSignalsBlocked $@@ -100,34 +99,33 @@              applyToWorking repository opts p `catch` \e ->                  fail ("Error applying unrevert to working directory...\n"                        ++ show e)-             debugMessage "I'm about to write_unrevert."-             write_unrevert repository skipped rec (unrec+>+p)-        sync_repo repository+             debugMessage "I'm about to writeUnrevert."+             writeUnrevert repository skipped rec (unrec+>+p)         debugMessage "Finished unreverting."-    _ -> impossible-unrevert_cmd _ _ = impossible+unrevertCmd _ _ = impossible -write_unrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> Slurpy -> FL Prim C(r x) -> IO ()-write_unrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository-write_unrevert repository ps rec pend = do-  case commutex (ps :< pend) of+writeUnrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y)+               -> Tree IO -> FL Prim C(r x) -> IO ()+writeUnrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository+writeUnrevert repository ps rec pend = do+  case commute (pend :> ps) of     Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? "                   case really of ('y':_) -> return ()                                  _ -> exitWith $ ExitSuccess-                  write_unrevert repository NilFL rec pend-    Just (_ :< p') -> do+                  writeUnrevert repository NilFL rec pend+    Just (p' :> _) -> do         rep <- read_repo repository         case get_common_and_uncommon (rep,rep) of             (common,_ :\/: _) -> do                 date <- getIsoDateTime                 np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')-                writeDocBinFile (unrevertUrl repository) $-                             make_bundle [Unified] rec common (np :>: NilFL)+                bundle <- make_bundle [Unified] rec common (np :>: NilFL)+                writeDocBinFile (unrevertUrl repository) bundle                 where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y)                       fromRepoPrims _ xs = fromPrims xs -unrevert_patch_bundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p)-unrevert_patch_bundle repository = do+unrevertPatchBundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p)+unrevertPatchBundle repository = do   pf <- B.readFile (unrevertUrl repository)         `catchall` fail "There's nothing to unrevert!"   case scan_bundle pf of
src/Darcs/Commands/WhatsNew.lhs view
@@ -24,43 +24,43 @@  module Darcs.Commands.WhatsNew ( whatsnew ) where import System.Exit ( ExitCode(..), exitWith )-import Data.List ( sort )+import Data.List ( sort, (\\) ) import Control.Monad ( when )  import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, lookforadds,-                        ignoretimes, noskip_boring,-                        unified, summary, no_cache,+import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds,+                        ignoretimes, noskipBoring,+                        unified, summary, noCache,                          areFileArgs, fixSubPaths,-                        list_registered_files,+                        listRegisteredFiles,                       )+import Darcs.Flags( isUnified ) import Darcs.RepoPath ( SubPath, sp2fn ) -import Darcs.Repository ( Repository, withRepository, ($-), slurp_recorded,-                          get_unrecorded_no_look_for_adds,-                          get_unrecorded_in_files, amInRepository )-import Darcs.Repository.Prefs ( filetype_function )-import Darcs.Diff ( unsafeDiff )-import Darcs.Patch ( RepoPatch, Prim, summarize, apply_to_slurpy, is_hunk )+import Darcs.Repository ( Repository, withRepository, ($-),+                          amInRepository+                        , unrecordedChanges, readRecordedAndPending, readRecorded, readUnrecorded )+import Darcs.Repository.State( restrictBoring )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.Patch ( RepoPatch, Prim, plainSummary, primIsHunk, applyToTree ) import Darcs.Patch.Permutations ( partitionRL ) import Darcs.Patch.Real ( RealPatch, prim2real ) import Darcs.Patch.FileName ( fn2fp ) import Darcs.PrintPatch ( printPatch, contextualPrintPatch )-import Darcs.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), nullFL )+import Darcs.Witnesses.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), nullFL )+import Darcs.Diff( treeDiff ) -import Darcs.Gorsvet( unrecordedChanges, restrictBoring, readRecordedAndPending ) import Storage.Hashed.Monad( virtualTreeIO, exists ) import Storage.Hashed( readPlainTree ) import Storage.Hashed( floatPath )  import Printer ( putDocLn, renderString, vcat, text )-#include "impossible.h" -whatsnew_description :: String-whatsnew_description = "List unrecorded changes in the working tree."+whatsnewDescription :: String+whatsnewDescription = "List unrecorded changes in the working tree." -whatsnew_help :: String-whatsnew_help =+whatsnewHelp :: String+whatsnewHelp =  "The `darcs whatsnew' command lists unrecorded changes to the working\n" ++  "tree.  If you specify a set of files and directories, only unrecorded\n" ++  "changes to those files and directories are listed.\n" ++@@ -68,37 +68,50 @@  "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.\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" +++ "\n" +++ "  An exclamation mark (!) as in `R! foo.c', means the hunk is known to\n" +++ "  conflict with a hunk in another patch.  The phrase `duplicated'\n" +++ "  means the hunk is known to be identical to a hunk in another patch.\n" +++ "\n" ++  "By default, `darcs whatsnew' uses Darcs' internal format for changes.\n" ++  "To see some context (unchanged lines) around each change, use the\n" ++  "--unified option.  To view changes in conventional `diff' format, use\n" ++- "the `darcs diff' comand; but note that `darcs whatsnew' is faster.\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"  whatsnew :: DarcsCommand-whatsnew = DarcsCommand {command_name = "whatsnew",-                         command_help = whatsnew_help,-                         command_description = whatsnew_description,-                         command_extra_args = -1,-                         command_extra_arg_help = ["[FILE or DIRECTORY]..."],-                         command_command = whatsnew_cmd,-                         command_prereq = amInRepository,-                         command_get_arg_possibilities = list_registered_files,-                         command_argdefaults = nodefaults,-                         command_advanced_options = [ignoretimes, noskip_boring, no_cache],-                         command_basic_options = [summary, unified,+whatsnew = DarcsCommand {commandName = "whatsnew",+                         commandHelp = whatsnewHelp,+                         commandDescription = whatsnewDescription,+                         commandExtraArgs = -1,+                         commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+                         commandCommand = whatsnewCmd,+                         commandPrereq = amInRepository,+                         commandGetArgPossibilities = listRegisteredFiles,+                         commandArgdefaults = nodefaults,+                         commandAdvancedOptions = [ignoretimes, noskipBoring, noCache],+                         commandBasicOptions = [summary, unified,                                                  lookforadds,-                                                 working_repo_dir]}+                                                 workingRepoDir]} -announce_files :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO ()-announce_files repo files =+announceFiles :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO ()+announceFiles repo files =     when (areFileArgs files) $ do-      nonboring <- restrictBoring-      working <- nonboring `fmap` readPlainTree "."       pristine <- readRecordedAndPending repo+      -- TODO this is slightly inefficient, since we should really somehow+      -- extract the unrecorded state as a side-effect of unrecordedChanges+      index <- readUnrecorded repo+      nonboring <- restrictBoring index+      working <- nonboring `fmap` readPlainTree "."       let paths = map (fn2fp . sp2fn) files           check = virtualTreeIO (mapM exists $ map floatPath paths)       (in_working, _) <- check working@@ -111,25 +124,27 @@               putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!"           maybe_warn _ = return () -whatsnew_cmd :: [DarcsFlag] -> [String] -> IO ()-whatsnew_cmd opts' args +whatsnewCmd :: [DarcsFlag] -> [String] -> IO ()+whatsnewCmd opts' args    | LookForAdds `elem` opts' && NoSummary `notElem` opts' =     -- add Summary to the opts since 'darcs whatsnew --look-for-adds'     -- implies summary     withRepository (Summary:opts') $- \repository -> do     files <- fixSubPaths opts' args-    announce_files repository files-    all_changes <- get_unrecorded_in_files repository (map sp2fn files)-    chold <- get_unrecorded_no_look_for_adds repository (map sp2fn files)-    s <- slurp_recorded repository-    ftf <- filetype_function-    cho_adds :> _ <- return $ partitionRL is_hunk $ reverseFL chold-    cha :> _ <- return $ partitionRL is_hunk $ reverseFL all_changes-    let chn    = unsafeDiff [LookForAdds,Summary] ftf-                            (fromJust $ apply_to_slurpy (reverseRL cho_adds) s)-                            (fromJust $ apply_to_slurpy (reverseRL cha) s)+    announceFiles repository files+    all_changes <- unrecordedChanges opts' repository files+    chold <- unrecordedChanges (opts' \\ [LookForAdds]) repository files+    pristine <- readRecorded repository+    ftf <- filetypeFunction+    cho_adds :> _ <- return $ partitionRL primIsHunk $ reverseFL chold+    cha :> _ <- return $ partitionRL primIsHunk $ reverseFL all_changes++    cho_adds_t <- applyToTree (reverseRL cho_adds) pristine+    cha_t <- applyToTree (reverseRL cha) pristine+    chn <- treeDiff ftf cho_adds_t cha_t+     exitOnNoChanges (chn, chold)-    putDocLn $ summarize chold+    putDocLn $ plainSummary chold     printSummary chn     where lower_as x = vcat $ map (text . l_as) $ lines x           l_as ('A':x) = 'a':x@@ -140,21 +155,21 @@           exitOnNoChanges _ = return ()           printSummary :: FL Prim C(x y) -> IO ()           printSummary NilFL = return ()-          printSummary new = putDocLn $ lower_as $ renderString $ summarize new+          printSummary new = putDocLn $ lower_as $ renderString $ plainSummary new -whatsnew_cmd opts args+whatsnewCmd opts args   | otherwise =     withRepository opts $- \repository -> do     files <- sort `fmap` fixSubPaths opts args-    announce_files repository files+    announceFiles repository files     changes <- unrecordedChanges opts repository files     when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ ExitFailure 1)     printSummary repository $ mapFL_FL prim2real changes        where printSummary :: RepoPatch p => Repository p C(r u t) -> FL RealPatch C(r y) -> IO ()              printSummary _ NilFL = do putStrLn "No changes!"                                        exitWith $ ExitFailure 1-             printSummary r ch | Summary `elem` opts = putDocLn $ summarize ch-                               | Unified `elem` opts = do s <- slurp_recorded r-                                                          contextualPrintPatch s ch+             printSummary r ch | Summary `elem` opts = putDocLn $ plainSummary ch+                               | isUnified opts = do pristine <- readRecorded r+                                                     contextualPrintPatch pristine ch                                | otherwise           = printPatch ch \end{code}
src/Darcs/CommandsAux.hs view
@@ -23,9 +23,9 @@ module Darcs.CommandsAux ( check_paths, malicious_patches, has_malicious_path,                         ) where import Darcs.Flags ( DarcsFlag( RestrictPaths, DontRestrictPaths ) )-import Darcs.Patch ( Patchy, list_touched_files )-import Darcs.Ordered ( FL, mapFL )-import Darcs.Sealed ( Sealed2(..), unseal2 )+import Darcs.Patch ( Patchy, listTouchedFiles )+import Darcs.Witnesses.Ordered ( FL, mapFL )+import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2 ) import Darcs.Global ( darcsdir ) import Data.List ( intersect ) import System.FilePath ( splitDirectories )@@ -74,7 +74,7 @@  malicious_paths :: Patchy p => p C(x y) -> [String] malicious_paths patch =-  let paths = list_touched_files patch in+  let paths = listTouchedFiles patch in     filter is_malicious_path paths  {-|
src/Darcs/Diff.hs view
@@ -1,375 +1,85 @@--- Copyright (C) 2002-2003 David Roundy+-- Copyright (C) 2009 Petr Rockai ----- This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.+-- Permission is hereby granted, free of charge, to any person+-- obtaining a copy of this software and associated documentation+-- files (the "Software"), to deal in the Software without+-- restriction, including without limitation the rights to use, copy,+-- modify, merge, publish, distribute, sublicense, and/or sell copies+-- of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions: ----- This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.+-- The above copyright notice and this permission notice shall be+-- included in all copies or substantial portions of the Software. ----- You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -cpp -fglasgow-exts #-}-{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff, sync, cmp-#ifndef GADT_WITNESSES-                  , diff_files-#endif-                  ) where--import System.Posix-     ( setFileTimes )-import System.IO ( IOMode(ReadMode), hFileSize, hClose )-import System.Directory ( doesDirectoryExist, doesFileExist,-                   getDirectoryContents,-                 )-import Control.Monad ( when )-import Data.List ( sort-#ifndef GADT_WITNESSES-                 , intersperse, isPrefixOf-#endif-                 )-#ifndef GADT_WITNESSES-import Data.Maybe ( catMaybes )-#endif--#ifndef GADT_WITNESSES-import ByteStringUtils ( is_funky, linesPS)-import qualified Data.ByteString.Char8 as BC (last)-import qualified Data.ByteString as B       (null, empty, take, ByteString)-#endif-import qualified Data.ByteString as B       (hGet, length)+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE. -import Darcs.SlurpDirectory ( Slurpy, slurp_name, is_dir, is_file,-#ifndef GADT_WITNESSES-                        get_slurp,-#endif-                        get_dircontents, get_filecontents,-                        get_mtime, get_length,-                        undefined_time-#ifndef GADT_WITNESSES-                        , FileContents, undefined_size-#endif-                      )-#ifndef GADT_WITNESSES-import System.FilePath.Posix ( (</>) )-#endif-import Darcs.Patch ( Prim-#ifndef GADT_WITNESSES-                   , hunk, canonize, rmfile, rmdir-                   , addfile, adddir-                   , binary, invert-#endif-                   )-#ifndef GADT_WITNESSES-import Darcs.Patch.FileName( fp2fn, breakup )-#endif-import System.IO ( openBinaryFile )+module Darcs.Diff( treeDiff ) where+import Darcs.Witnesses.Ordered ( FL(..), (+>+) ) import Darcs.Repository.Prefs ( FileType(..) )-import Darcs.Flags ( DarcsFlag(..) )-import Darcs.Utils ( catchall )-import Darcs.Ordered ( FL(..)-#ifndef GADT_WITNESSES-                           , (+>+)-#endif-                           )-#ifndef GADT_WITNESSES-#include "impossible.h"-#endif---- | The unsafeDiffAtPaths function calls diff_at_path for a set of files and---   and directories, and returns all changes to those files. It recurses into---   given directories when searching for changes.------   Comparing paths and not slurpies is useful when the user---   requests a diff for a file that is created or removed in the working copy:---   then there is no slurpy for the file in the /current/ or /working/ slurpy---   respectively.------   The given paths must always be fixed repository paths starting with a---   ".". It is safe to pass overlapping paths.------   The booleans in the first argument tell whether to ignore mtimes, whether---   we must look for additions and if we're diffing for a summary only.------   It returns an FL of patches, that contains all the changes that have been---   made at all those paths.-unsafeDiffAtPaths :: (Bool, Bool, Bool) -> (FilePath -> FileType) ->-               Slurpy -> Slurpy -> [FilePath] -> FL Prim C(x y)-#ifdef GADT_WITNESSES-unsafeDiffAtPaths = undefined-#else-unsafeDiffAtPaths flags filetypeFunction s1 s2 paths =-    foldr (+>+) NilFL (catMaybes diffsPerPath)-  where diffsPerPath = map differ safePaths-        differ       = diff_at_path flags filetypeFunction s1 s2-        safePaths    = make_nonoverlapping_path_set paths+import Darcs.Patch ( Prim, hunk, canonize, binary+                   , addfile, rmfile, adddir, rmdir, invert) -diff_at_path :: (Bool, Bool, Bool) -> (FilePath -> FileType)-                -> Slurpy -> Slurpy -> FilePath -> Maybe (FL Prim)-diff_at_path (ignoreTimes, lookForAdds, summary) filetypeFunction s1 s2 path =-    case (pathIn1, pathIn2) of-        (Nothing, Nothing) -> Nothing-        (Nothing, Just s2PathSlurpy) -> do-            Just $ diff_added summary filetypeFunction initialFps s2PathSlurpy NilFL-        (Just s1PathSlurpy, Nothing) -> do-            Just $ diff_removed filetypeFunction initialFps s1PathSlurpy NilFL-        (Just s1PathSlurpy, Just s2PathSlurpy) ->-            Just $ gendiff (ignoreTimes, lookForAdds, summary) filetypeFunction-                           initialFps s1PathSlurpy s2PathSlurpy NilFL-  where pathIn1 = get_slurp (fp2fn path) s1-        pathIn2 = get_slurp (fp2fn path) s2-        initialFps = tail $ reverse (breakup path)+import Storage.Hashed.Tree( diffTrees, zipTrees, TreeItem(..), Tree+                          , readBlob, emptyBlob )+import Storage.Hashed.AnchoredPath( AnchoredPath, anchorPath ) -make_nonoverlapping_path_set :: [FilePath] -> [FilePath]-make_nonoverlapping_path_set = map unbreakup . delete_overlapping . map breakup . sort-  where-    delete_overlapping :: [[FilePath]] -> [[FilePath]]-    delete_overlapping (p1:p2:ps) = if p1 `isPrefixOf` p2-                                      then delete_overlapping (p1:ps)-                                      else p1 : delete_overlapping (p2:ps)-    delete_overlapping ps         = ps-    unbreakup = concat . intersperse "/"-#endif+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import ByteStringUtils( is_funky ) --- The diff function takes a recursive diff of two slurped-up directory trees.--- The code involved is actually pretty trivial.  \verb!paranoid_diff! runs a--- diff in which we don't make the assumption that files with the same--- modification time are identical.+#include "gadts.h" -unsafeDiff :: [DarcsFlag]-           -> (FilePath -> FileType) -> Slurpy -> Slurpy -> FL Prim C(x y)+treeDiff :: (FilePath -> FileType) -> Tree IO -> Tree IO -> IO (FL Prim C(x y)) #ifdef GADT_WITNESSES-unsafeDiff = undefined+treeDiff = undefined -- Sigh. #else-unsafeDiff opts wt s1 s2-    = case diff_at_path (ignoreTimes, lookForAdds, summary)  wt s1 s2 "" of-          Just d -> d-          _      -> impossible -- because "" always exists in a slurpy -  where -- NoSummary/Summary both present gives False-        -- Just Summary gives True-        -- Just NoSummary gives False-        -- Neither gives False-        summary = Summary `elem` opts && NoSummary `notElem` opts-        lookForAdds = LookForAdds `elem` opts-        ignoreTimes = IgnoreTimes `elem` opts--mk_filepath :: [FilePath] -> FilePath-mk_filepath fps = concat $ intersperse "/" $ reverse fps--gendiff :: (Bool,Bool,Bool)-        -> (FilePath -> FileType) -> [FilePath] -> Slurpy -> Slurpy-        -> (FL Prim -> FL Prim)-gendiff opts@(isparanoid,_,_) wt fps s1 s2-    | is_file s1 && is_file s2 = diff_regular_files isparanoid wt f s1 s2-    | is_dir s1 && is_dir s2 =-          let fps' = case n2 of-                         "." -> fps-                         _ -> n2:fps-          in fps' `seq` recur_diff opts (wt . (n2</>)) fps' dc1 dc2-    | otherwise = id-    where n2 = slurp_name s2-          f = mk_filepath (n2:fps)-          dc1 = get_dircontents s1-          dc2 = get_dircontents s2---- recur_diff or recursive diff--- First parameter is (IgnoreTimes?, LookforAdds?, Summary?)-recur_diff :: (Bool,Bool,Bool)-           -> (FilePath -> FileType) -> [FilePath] -> [Slurpy] -> [Slurpy]-           -> (FL Prim -> FL Prim)-recur_diff _ _ _ [] [] = id-recur_diff opts@(_,doadd,summary) wt fps (s:ss) (s':ss')-    -- this is the case if a file has been removed in the working directory-    | s < s' = diff_removed wt fps s . recur_diff opts wt fps ss (s':ss')-    -- this next case is when there is a file in the directory that is not-    -- in the repository (ie, not managed by darcs)-    | s > s' = let rest = recur_diff opts wt fps (s:ss) ss'-               in if not doadd then                        rest-                               else diff_added summary wt fps s' . rest-    -- actually compare the files because the names match-    | s == s' = gendiff opts wt fps s s' . recur_diff opts wt fps ss ss'-recur_diff opts wt fps (s:ss) [] =-    diff_removed wt fps s . recur_diff opts wt fps ss []-recur_diff opts@(_,True,summary) wt fps [] (s':ss') =-    diff_added summary wt fps s' . recur_diff opts wt fps [] ss'-recur_diff (_,False,_) _ _ [] _ = id-recur_diff _ _ _ _ _ = impossible---- diff, taking into account paranoidness and file type, two regular files-diff_regular_files :: Bool -> (FilePath -> FileType) -> FilePath -> Slurpy -> Slurpy -> (FL Prim -> FL Prim)-diff_regular_files ignoreTimes filetypeFunction f s1 s2 = -    if maybe_differ   -        then case filetypeFunction (slurp_name s2) of                                     -               TextFile -> diff_files f b1 b2                    -               BinaryFile -> if b1 /= b2 then (binary f b1 b2:>:)-                                         else id                 -        else id-  where maybe_differ = ignoreTimes-                     || get_mtime s1 == undefined_time-                     || get_mtime s1 /= get_mtime s2-                     || get_length s1 == undefined_size-                     || get_length s1 /= get_length s2-        b1 = get_filecontents s1-        b2 = get_filecontents s2---- creates a diff for a file or directory which needs to be added to the--- repository-diff_added :: Bool -> (FilePath -> FileType) -> [FilePath] -> Slurpy-           -> (FL Prim -> FL Prim)-diff_added summary wt fps s-    | is_file s = case wt n of-                  TextFile -> (addfile f:>:) .-                              (if summary-                               then id-                               else diff_from_empty id f (get_filecontents s))-                  BinaryFile -> (addfile f:>:) .-                                (if summary then id else-                                (bin_patch f B.empty (get_filecontents s)))-    | otherwise {- is_dir s -} =-        (adddir f:>:)-      . foldr (.) id (map (diff_added summary wt (n:fps)) (get_dircontents s))-    where n = slurp_name s-          f = mk_filepath (n:fps)--get_text :: FileContents -> [B.ByteString]-get_text = linesPS--empt :: FileContents-empt = B.empty--diff_files :: FilePath -> FileContents -> FileContents-           -> (FL Prim -> FL Prim)-diff_files f o n | get_text o == [B.empty] && get_text n == [B.empty] = id-                 | get_text o == [B.empty] = diff_from_empty id f n-                 | get_text n == [B.empty] = diff_from_empty invert f o-diff_files f o n = if o == n-                   then id-                   else if has_bin o || has_bin n-                        then (binary f o n:>:)-                        else (canonize (hunk f 1 (linesPS o) (linesPS n)) +>+)--diff_from_empty :: (Prim -> Prim) -> FilePath -> FileContents-                -> (FL Prim -> FL Prim)-diff_from_empty inv f b =-    if b == B.empty-    then id-    else let p = if has_bin b-                 then binary f B.empty b-                 else if BC.last b == '\n'-                      then hunk f 1 [] $ init $ linesPS b-                      else hunk f 1 [B.empty] $ linesPS b-         in (inv p:>:)--{- | We take a B.ByteString which represents a file's contents, and we check to see-whether it is a 'binary' file or a 'textual' file. We define a textual file as any file-which does not contain two magic characters, '\0' (the NULL character on Unix) and '^Z'-(Control-Z, a DOS convention).--Note that to improve performance, we won't examine *all* of the string, because that-falls down on large files, but just the first 4096 characters. -}-has_bin :: FileContents -> Bool-has_bin = is_funky . B.take 4096-#endif--#ifndef GADT_WITNESSES-bin_patch :: FilePath -> B.ByteString -> B.ByteString-          -> FL Prim -> FL Prim-bin_patch f o n | B.null o && B.null n = id-                | otherwise = (binary f o n:>:)-#endif--#ifndef GADT_WITNESSES-diff_removed :: (FilePath -> FileType) -> [FilePath] -> Slurpy-             -> (FL Prim -> FL Prim)-diff_removed wt fps s-    | is_file s = case wt n of-                  TextFile -> diff_files f (get_filecontents s) empt-                            . (rmfile f:>:)-                  BinaryFile -> (bin_patch f-                                 (get_filecontents s) B.empty)-                              . (rmfile f:>:)-    | otherwise {- is_dir s -}-        = foldr (.) (rmdir f:>:)-        $ map (diff_removed wt (n:fps)) (get_dircontents s)-    where n = slurp_name s-          f = mk_filepath (n:fps)+treeDiff ft t1 t2 = do+  (from, to) <- diffTrees t1 t2+  diffs <- sequence $ zipTrees diff from to+  return $ foldr (+>+) NilFL diffs+    where diff :: AnchoredPath -> Maybe (TreeItem IO) -> Maybe (TreeItem IO)+               -> IO (FL Prim)+          diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL+          diff p (Just (SubTree _)) Nothing =+              return $ rmdir (anchorPath "" p) :>: NilFL+          diff p Nothing (Just (SubTree _)) =+              return $ adddir (anchorPath "" p) :>: NilFL+          diff p Nothing b'@(Just (File _)) =+              do diff' <- diff p (Just (File emptyBlob)) b'+                 return $ addfile (anchorPath "" p) :>: diff'+          diff p a'@(Just (File _)) Nothing =+              do diff' <- diff p a' (Just (File emptyBlob))+                 return $ diff' +>+ (rmfile (anchorPath "" p) :>: NilFL)+          diff p (Just (File a')) (Just (File b')) =+              do a <- readBlob a'+                 b <- readBlob b'+                 let path = anchorPath "" p+                 case ft path of+                   TextFile | no_bin a && no_bin b ->+                                return $ text_diff path a b+                   _ -> return $ if a /= b+                                    then binary path (strict a) (strict b) :>: NilFL+                                    else NilFL+          diff p _ _ = fail $ "Missing case at path " ++ show p+          text_diff p a b+              | BL.null a && BL.null b = NilFL+              | BL.null a = diff_from_empty p b+              | BL.null b = diff_to_empty p a+              | otherwise = line_diff p (linesB a) (linesB b)+          line_diff p a b = canonize (hunk p 1 a b)+          diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) []+                            | otherwise = line_diff p (linesB x) [BS.empty]+          diff_from_empty p x = invert (diff_to_empty p x)+          no_bin = not . is_funky . strict . BL.take 4096+          linesB = map strict . BLC.split '\n'+          strict = BS.concat . BL.toChunks #endif -sync :: String -> Slurpy -> Slurpy -> IO ()-sync path s1 s2-    | is_file s1 && is_file s2 &&-      (get_mtime s1 == undefined_time || get_mtime s1 /= get_mtime s2) &&-      get_length s1 == get_length s2 &&-      get_filecontents s1 == get_filecontents s2 =-        set_mtime n (get_mtime s2)-    | is_dir s1 && is_dir s2-        = n2 `seq` recur_sync n (get_dircontents s1) (get_dircontents s2)-    | otherwise = return ()-    where n2 = slurp_name s2-          n = path++"/"++n2-          set_mtime fname ctime = setFileTimes fname ctime ctime-                       `catchall` return ()-          recur_sync _ [] _ = return ()-          recur_sync _ _ [] = return ()-          recur_sync p (s:ss) (s':ss')-              | s < s' = recur_sync p ss (s':ss')-              | s > s' = recur_sync p (s:ss) ss'-              | otherwise = do sync p s s'-                               recur_sync p ss ss'---cmp :: FilePath -> FilePath -> IO Bool-cmp p1 p2 = do-  dir1 <- doesDirectoryExist p1-  dir2 <- doesDirectoryExist p2-  file1 <- doesFileExist p1-  file2 <- doesFileExist p2-  if dir1 && dir2-     then cmpdir p1 p2-     else if file1 && file2-          then cmpfile p1 p2-          else return False-cmpdir :: FilePath -> FilePath -> IO Bool-cmpdir d1 d2 = do-  fn1 <- fmap (filter (\f->f/="." && f /="..")) $ getDirectoryContents d1-  fn2 <- fmap (filter (\f->f/="." && f /="..")) $ getDirectoryContents d2-  if sort fn1 /= sort fn2-     then return False-     else andIO $ map (\fn-> cmp (d1++"/"++fn) (d2++"/"++fn)) fn1-andIO :: [IO Bool] -> IO Bool-andIO (iob:iobs) = do b <- iob-                      if b then andIO iobs else return False-andIO [] = return True-cmpfile :: FilePath -> FilePath -> IO Bool-cmpfile f1 f2 = do-  h1 <- openBinaryFile f1 ReadMode-  h2 <- openBinaryFile f2 ReadMode-  l1 <- hFileSize h1-  l2 <- hFileSize h2-  if l1 /= l2-     then do hClose h1-             hClose h2-             putStrLn $ "different file lengths for "++f1++" and "++f2-             return False-     else do b <- hcmp h1 h2-             when (not b) $ putStrLn $ "files "++f1++" and "++f2++" differ"-             hClose h1-             hClose h2-             return b-    where hcmp h1 h2 = do c1 <- B.hGet h1 1024-                          c2 <- B.hGet h2 1024-                          if c1 /= c2-                             then return False-                             else if B.length c1 == 1024-                                  then hcmp h1 h2-                                  else return True
src/Darcs/Email.hs view
@@ -4,7 +4,7 @@  import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) import Data.List ( isInfixOf )-import qualified UTF8 ( encode )+import qualified Codec.Binary.UTF8.String as UTF8 ( encode ) import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS)  import ByteStringUtils (dropSpace, linesPS, betweenLinesPS )@@ -53,7 +53,7 @@       -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte       safeEncChunkLength = (qline_max - B.length encoded_word_start                                       - B.length encoded_word_end) `div` 12-      (curSpace, afterCurSpace) = break (not . (== ' ')) s+      (curSpace, afterCurSpace) = span (== ' ') s       (curWord,  afterCurWord)  = break (== ' ') afterCurSpace       qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord)                | otherwise       = qEncode curWord
src/Darcs/External.hs view
@@ -10,17 +10,19 @@     execDocPipe, execPipeIgnoreError,     getTermNColors,     pipeDoc, pipeDocSSH, execSSH,+    remoteDarcsCmd,     maybeURLCmd,     Cachable(Cachable, Uncachable, MaxAge),     viewDoc, viewDocWith,-    sendmail_path, diff_program+    sendmail_path, diff_program, darcs_program   ) where +import qualified Ratified import Data.Maybe ( isJust, isNothing, maybeToList ) import Control.Monad ( when, zipWithM_, filterM, liftM2 ) import System.Exit ( ExitCode(..) )-import System.Environment ( getEnv )-import System.IO ( hPutStr, hPutStrLn, hGetContents, hClose,+import System.Environment ( getEnv, getProgName )+import System.IO ( hPutStr, hPutStrLn, hClose,                    openBinaryFile, IOMode( ReadMode ),                    openBinaryTempFile,                    hIsTerminalDevice, stdout, stderr, Handle )@@ -49,14 +51,14 @@ import System.FilePath.Posix ( (</>), takeDirectory, normalise )  import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL, NoLinks,-                                Verify, VerifySSL ) )+                                Verify, VerifySSL, RemoteDarcs ) ) import Darcs.RepoPath ( AbsolutePath, toFilePath ) import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, ) import Progress ( withoutProgress, progressList, debugMessage )  import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS)-import qualified Data.ByteString as B (ByteString, empty, null, readFile -- ratify readFile: Just an import from ByteString-            ,hGetContents, writeFile, hPut, length -- ratify hGetContents: importing from ByteString+import qualified Data.ByteString as B (ByteString, empty, null, readFile+            ,hGetContents, writeFile, hPut, length             ,take, concat, drop, isPrefixOf, singleton, append) import qualified Data.ByteString.Char8 as BC (unpack, pack) @@ -88,6 +90,11 @@   when (null l) $ fail "Cannot find the \"diff\" program."   return $ head l +-- |Get the name of the darcs executable (as supplied by @getProgName@)+darcs_program :: IO String+darcs_program = getProgName+-- Another option: getEnv "DARCS" `catch` \_ -> getProgName+ backupByRenaming :: FilePath -> IO () backupByRenaming = backupBy rename  where rename x y = do@@ -123,19 +130,23 @@ -- will use a cache as required by its second argument. fetchFilePS :: String -> Cachable -> IO B.ByteString fetchFilePS fou _ | is_file fou = B.readFile fou-fetchFilePS fou cache = withTemp $ \t -> do copyFileOrUrl [] fou t cache+fetchFilePS fou cache = withTemp $ \t -> do let opts = [] -- FIXME: no network flags+                                            copyFileOrUrl opts fou t cache                                             B.readFile t  gzFetchFilePS :: String -> Cachable -> IO B.ByteString gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou-gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl [] fou t cache+gzFetchFilePS fou cache = withTemp $ \t-> do let opts = [] -- FIXME: no network flags+                                             copyFileOrUrl opts fou t cache                                              gzReadFilePS t +remoteDarcsCmd :: [DarcsFlag] -> String+remoteDarcsCmd flags = head $ [ c | (RemoteDarcs c) <- flags ] ++ ["darcs"]  copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO () copyFileOrUrl opts fou out _     | is_file fou = copyLocal opts fou out copyFileOrUrl _    fou out cache | is_url  fou = copyRemote fou out cache-copyFileOrUrl _    fou out _     | is_ssh  fou = copySSH fou out+copyFileOrUrl opts fou out _     | is_ssh  fou = copySSH (remoteDarcsCmd opts) fou out copyFileOrUrl _    fou _   _     = fail $ "unknown transport protocol: " ++ fou  speculateFileOrUrl :: String -> FilePath -> IO ()@@ -240,7 +251,7 @@ copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO () copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out copyFilesOrUrls _ dou ns out c    | is_url  dou = copyRemotes dou ns out c-copyFilesOrUrls _ dou ns out _    | is_ssh  dou = copySSHs dou ns out+copyFilesOrUrls opts dou ns out _ | is_ssh  dou = copySSHs (remoteDarcsCmd opts) dou ns out copyFilesOrUrls _ dou _  _   _    = fail $ "unknown transport protocol: "++dou  @@ -306,11 +317,11 @@     do debugMessage $ unwords (c:args)        (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing        mvare <- newEmptyMVar-       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed+       forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed                 hPutStr stderr)                `finally` putMVar mvare ())        mvaro <- newEmptyMVar-       forkIO ((hGetContents o >>= -- ratify hGetContents: it's immediately consumed+       forkIO ((Ratified.hGetContents o >>= -- ratify: immediately consumed                 hPutStr stdout)                `finally` putMVar mvaro ())        hPutDoc i inp@@ -485,7 +496,7 @@     do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing        forkIO $ hPutDoc i instr >> hClose i        mvare <- newEmptyMVar-       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed+       forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed                 hPutStr stderr)                `finally` putMVar mvare ())        out <- B.hGetContents o@@ -503,7 +514,7 @@     do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing        forkIO $ hPutDoc i instr >> hClose i        mvare <- newEmptyMVar-       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed+       forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed                 hPutStr stderr)                `finally` putMVar mvare ())        out <- B.hGetContents o@@ -620,8 +631,9 @@ viewDocWith pr msg = do   isTerminal <- hIsTerminalDevice stdout   if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)-     then do viewer <- get_viewer-             pipeDocToPager viewer [] pr msg+     then do viewerPlusArgs <- get_viewer+             let (viewer:args) = words viewerPlusArgs+             pipeDocToPager viewer args pr msg                `ortryrunning` pipeDocToPager  "less" [] pr msg                `ortryrunning` pipeDocToPager  "more" [] pr msg #ifdef WIN32
src/Darcs/FilePathMonad.hs view
@@ -25,7 +25,7 @@ import Data.Maybe ( catMaybes )  import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )-import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, super_name, break_on_dir,+import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, superName, break_on_dir,                               norm_path, movedirfilename ) #include "impossible.h" @@ -60,7 +60,7 @@                            if d == d' then Just f'                                       else Nothing     mGetDirectoryContents =-        FPM $ \fs -> (fs, filter (\f -> fp2fn "." == super_name f) fs)+        FPM $ \fs -> (fs, filter (\f -> fp2fn "." == superName f) fs)     mReadFilePS = bug "can't mReadFilePS in FilePathMonad!"  instance WriteableDirectory FilePathMonad where
src/Darcs/Flags.hs view
@@ -15,16 +15,21 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Flags ( DarcsFlag( .. ), Compression( .. ), compression, want_external_merge, isInteractive,-                     maxCount,+module Darcs.Flags ( DarcsFlag( .. ), Compression( .. ), compression, +                     want_external_merge, isInteractive,+                     maxCount, willIgnoreTimes, willRemoveLogFile, isUnified,+                     willStoreInMemory, doHappyForwarding, includeBoring,+                     doAllowCaseOnly, doAllowWindowsReserved, doReverse,+                     showChangesOnlyToFiles                    ) where+import Data.Maybe( fromMaybe ) import Darcs.Patch.MatchData ( PatchMatch ) import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd )  -- | The 'DarcsFlag' type is a list of all flags that can ever be -- passed to darcs, or to one of its commands. data DarcsFlag = Help | ListOptions | NoTest | Test-               | OnlyChangesToFiles+               | OnlyChangesToFiles | ChangesToAllFiles                | LeaveTestDir | NoLeaveTestDir                | Timings | Debug | DebugVerbose | DebugHTTP                | Verbose | NormalVerbosity | Quiet@@ -38,22 +43,27 @@                | NumberPatches                | OneTag String | AfterTag String | UpToTag String                | Context AbsolutePath | Count-               | LogFile AbsolutePath | RmLogFile+               | LogFile AbsolutePath | RmLogFile | DontRmLogFile                | DistName String | All                | Recursive | NoRecursive | Reorder                | RestrictPaths | DontRestrictPaths-               | AskDeps | NoAskDeps | IgnoreTimes | LookForAdds | NoLookForAdds+               | AskDeps | NoAskDeps | IgnoreTimes | DontIgnoreTimes+               | LookForAdds | NoLookForAdds                | AnyOrder | CreatorHash String                | Intersection | Union | Complement                | Sign | SignAs String | NoSign | SignSSL String-               | HappyForwarding+               | HappyForwarding | NoHappyForwarding                | Verify AbsolutePath | VerifySSL AbsolutePath                | SSHControlMaster | NoSSHControlMaster+               | RemoteDarcs String                | EditDescription | NoEditDescription                | Toks String                | EditLongComment | NoEditLongComment | PromptLongComment                | AllowConflicts | MarkConflicts | NoAllowConflicts-               | Boring | AllowCaseOnly | AllowWindowsReserved+               | SkipConflicts+               | Boring | SkipBoring+               | AllowCaseOnly | DontAllowCaseOnly+               | AllowWindowsReserved | DontAllowWindowsReserved                | DontGrabDeps | DontPromptForDependencies | PromptForDependencies                | Compress | NoCompress | UnCompress                | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String@@ -63,8 +73,8 @@                | Pipe | Interactive                | DiffCmd String                | ExternalMerge String | Summary | NoSummary-               | Unified | Reverse-               | CheckPoint | Partial | Complete | Lazy | Ephemeral+               | Unified | NonUnified | Reverse | Forward+               | Partial | Complete | Lazy | Ephemeral                | FixFilePath AbsolutePath AbsolutePath | DiffFlags String                | XMLOutput                | ForceReplace@@ -78,12 +88,14 @@                | UseFormat2                | PristinePlain | PristineNone | NoUpdateWorking                | Sibling AbsolutePath | Relink | RelinkPristine | NoLinks+               | OptimizePristine+               | UpgradeFormat                | Files | NoFiles | Directories | NoDirectories                | Pending | NoPending                | PosthookCmd String | NoPosthook | AskPosthook | RunPosthook                | PrehookCmd String  | NoPrehook  | AskPrehook  | RunPrehook                | UMask String-               | StoreInMemory+               | StoreInMemory | ApplyOnDisk                | HTTPPipelining | NoHTTPPipelining                | NoCache                | AllowUnrelatedRepos@@ -114,3 +126,43 @@ maxCount (MaxCount n : _) = Just n maxCount (_:xs) = maxCount xs maxCount [] = Nothing++-- | @lastWord [(flag, value)] default opts@ scans @opts@ for a flag+-- in the list and returns the value of the first match, or @default@+-- if none is found.+lastWord :: [(DarcsFlag,a)] -> a -> [DarcsFlag] -> a+lastWord known_flags = foldr . flip $ \ def -> fromMaybe def . flip lookup known_flags++getBoolFlag :: DarcsFlag -> DarcsFlag -> [DarcsFlag] -> Bool+getBoolFlag t f = lastWord [(t, True), (f, False)] False++willIgnoreTimes :: [DarcsFlag] -> Bool+willIgnoreTimes = getBoolFlag IgnoreTimes DontIgnoreTimes++willRemoveLogFile :: [DarcsFlag] -> Bool+willRemoveLogFile = getBoolFlag RmLogFile DontRmLogFile++isUnified :: [DarcsFlag] -> Bool+isUnified = getBoolFlag Unified NonUnified++willStoreInMemory :: [DarcsFlag] -> Bool+willStoreInMemory = getBoolFlag Unified NonUnified++doHappyForwarding :: [DarcsFlag] -> Bool+doHappyForwarding = getBoolFlag HappyForwarding NoHappyForwarding++includeBoring :: [DarcsFlag] -> Bool+includeBoring = getBoolFlag Boring SkipBoring++doAllowCaseOnly :: [DarcsFlag] -> Bool+doAllowCaseOnly = getBoolFlag AllowCaseOnly DontAllowCaseOnly+++doAllowWindowsReserved :: [DarcsFlag] -> Bool+doAllowWindowsReserved = getBoolFlag AllowWindowsReserved DontAllowWindowsReserved++doReverse :: [DarcsFlag] -> Bool+doReverse = getBoolFlag Reverse Forward++showChangesOnlyToFiles :: [DarcsFlag] -> Bool+showChangesOnlyToFiles = getBoolFlag OnlyChangesToFiles ChangesToAllFiles
src/Darcs/Global.hs view
@@ -26,9 +26,7 @@                       timingsMode, setTimingsMode,                       whenDebugMode, withDebugMode, setDebugMode,                       debugMessage, debugFail, putTiming,-#ifdef HAVE_HASKELL_ZLIB                       addCRCWarning, getCRCWarnings, resetCRCWarnings,-#endif                       darcsdir     ) where @@ -36,9 +34,7 @@ import Control.Concurrent.MVar import Control.Exception (bracket_, catch, block, unblock) import Data.IORef ( IORef, newIORef, readIORef, writeIORef )-#ifdef HAVE_HASKELL_ZLIB import Data.IORef ( modifyIORef )-#endif import System.IO.Unsafe (unsafePerformIO) import System.IO (hPutStrLn, hPutStr, stderr) import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )@@ -139,7 +135,6 @@ sshControlMasterDisabled :: Bool sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled -#ifdef HAVE_HASKELL_ZLIB type CRCWarningList = [FilePath] {-# NOINLINE _crcWarningList #-} _crcWarningList :: IORef CRCWarningList@@ -153,7 +148,6 @@  resetCRCWarnings :: IO () resetCRCWarnings = writeIORef _crcWarningList []-#endif  darcsdir :: String darcsdir = "_darcs"
− src/Darcs/Gorsvet.hs 
@@ -1,256 +0,0 @@-{-# LANGUAGE CPP, FlexibleInstances #-}-{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}---- Copyright (C) 2009 Petr Rockai------ Permission is hereby granted, free of charge, to any person--- obtaining a copy of this software and associated documentation--- files (the "Software"), to deal in the Software without--- restriction, including without limitation the rights to use, copy,--- modify, merge, publish, distribute, sublicense, and/or sell copies--- of the Software, and to permit persons to whom the Software is--- furnished to do so, subject to the following conditions:------ The above copyright notice and this permission notice shall be--- included in all copies or substantial portions of the Software.------ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,--- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF--- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND--- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS--- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN--- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN--- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE--- SOFTWARE.--#include "gadts.h"--module Darcs.Gorsvet where--import Prelude hiding ( all, filter, lines, read, readFile, writeFile )---- darcs stuff-import ByteStringUtils( is_funky )-import Darcs.Repository ( Repository, slurp_pending )-import Darcs.Repository.Internal ( read_pending )-import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply-                   , sort_coalesceFL, addfile, rmfile, adddir, rmdir, invert)-import Darcs.Ordered ( FL(..), (+>+) )-import Darcs.Repository.Prefs ( filetype_function, FileType(..) )-import Darcs.IO-import Darcs.Sealed ( Sealed(Sealed), seal )-import Darcs.Patch( apply_to_filepaths )-import Darcs.Patch.Patchy ( Apply )-import Darcs.Patch.TouchesFiles ( choose_touching )-import Darcs.Patch.FileName ( fn2fp, FileName )--import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.ByteString.Char8 as BS-import Control.Monad.State.Strict-import System.Directory( removeFile, doesFileExist )-import Data.Maybe-import Data.List( union )--import Darcs.Arguments ( DarcsFlag( LookForAdds, IgnoreTimes ) )-import Darcs.RepoPath ( SubPath, sp2fn )--import Text.Regex( matchRegex )-import Darcs.Repository.Prefs( boring_regexps )--import Storage.Hashed-import Storage.Hashed.Tree-import qualified Storage.Hashed.Index as I-import Storage.Hashed.AnchoredPath-import Storage.Hashed.Darcs( darcsFormatHash, darcsTreeHash )-import Storage.Hashed.Monad-    ( virtualTreeIO, hashedTreeIO, plainTreeIO-    , unlink, rename, createDirectory, writeFile-    , readFile -- ratify readFile: haskell_policy je natvrdlá-    , cwd, tree, TreeIO )-import Storage.Hashed--floatFn :: FileName -> AnchoredPath-floatFn = floatPath . fn2fp--instance ReadableDirectory TreeIO where-    mDoesDirectoryExist d = gets (\x -> isJust $ findTree (tree x) (floatFn d))-    mDoesFileExist f = gets (\x -> isJust $ findFile (tree x) (floatFn f))-    mInCurrentDirectory d action = do -- TODO bracket?-      wd <- gets cwd-      modify (\x -> x { cwd = floatFn d })-      x <- action-      modify (\x' -> x' { cwd = wd })-      return x-    mGetDirectoryContents = error "get dir contents"-    mReadFilePS p = do x <- readFile (floatFn p) -- ratify readFile: ...-                       return $ BS.concat (BL.toChunks x)--instance WriteableDirectory TreeIO where-    mWithCurrentDirectory = mInCurrentDirectory-    mSetFileExecutable _ _ = return ()-    mWriteFilePS p ps = writeFile -- ratify readFile: haskell_policy is stupid.-          (floatFn p) (BL.fromChunks [ps])-    mCreateDirectory p = createDirectory (floatFn p)-    mRename from to = rename (floatFn from) (floatFn to)-    mRemoveDirectory = unlink . floatFn-    mRemoveFile = unlink . floatFn--treeDiff :: (FilePath -> FileType) -> Tree -> Tree -> IO (FL Prim C(x y))-#ifdef GADT_WITNESSES-treeDiff = undefined -- Sigh.-#else-treeDiff ft t1 t2 = do-  (from, to) <- diffTrees t1 t2-  diffs <- sequence $ zipTrees diff from to-  return $ foldr (+>+) NilFL diffs-    where diff :: AnchoredPath -> Maybe TreeItem -> Maybe TreeItem-               -> IO (FL Prim)-          diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL-          diff p (Just (SubTree _)) Nothing =-              return $ rmdir (anchorPath "" p) :>: NilFL-          diff p Nothing (Just (SubTree _)) =-              return $ adddir (anchorPath "" p) :>: NilFL-          diff p Nothing b'@(Just (File _)) =-              do diff' <- diff p (Just (File emptyBlob)) b'-                 return $ addfile (anchorPath "" p) :>: diff'-          diff p a'@(Just (File _)) Nothing =-              do diff' <- diff p a' (Just (File emptyBlob))-                 return $ diff' +>+ (rmfile (anchorPath "" p) :>: NilFL)-          diff p (Just (File a')) (Just (File b')) =-              do a <- read a'-                 b <- read b'-                 let path = anchorPath "" p-                 case ft path of-                   TextFile | no_bin a && no_bin b ->-                                return $ text_diff path a b-                   _ -> return $ if a /= b-                                    then binary path (strict a) (strict b) :>: NilFL-                                    else NilFL-          diff p _ _ = fail $ "Missing case at path " ++ show p-          text_diff p a b-              | BL.null a && BL.null b = NilFL-              | BL.null a = diff_from_empty p b-              | BL.null b = diff_to_empty p a-              | otherwise = line_diff p (lines a) (lines b)-          line_diff p a b = canonize (hunk p 1 a b)-          diff_to_empty p x | BL.last x == '\n' = line_diff p (init $ lines x) []-                            | otherwise = line_diff p (lines x) [BS.empty]-          diff_from_empty p x = invert (diff_to_empty p x)-          no_bin = not . is_funky . strict . BL.take 4096-          lines = map strict . BL.split '\n'-          strict = BS.concat . BL.toChunks-#endif--readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO Tree-readRecorded _ = readDarcsPristine "."--readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO Tree-readRecordedAndPending repo = do-  pristine <- readRecorded repo-  Sealed pending <- pendingChanges repo []-  applyToTree pending pristine--pendingChanges :: (RepoPatch p) => Repository p C(r u t)-               -> [SubPath] -> IO (Sealed (FL Prim C(r)))-pendingChanges repo paths = do-  slurp_pending repo -- XXX: only here to get us the "pending conflicts" check-                     -- that I don't know yet how to implement properly-  Sealed pending <- read_pending repo-  let files = map (fn2fp . sp2fn) paths-      pre_files = apply_to_filepaths (invert pending) files-      relevant = case paths of-                   [] -> seal pending-                   _ -> choose_touching pre_files pending-  return relevant--applyToTree :: (Apply p) => p C(x y) -> Tree -> IO Tree-applyToTree patch t = snd `fmap` virtualTreeIO (apply [] patch) t--unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t)-                  -> [SubPath] -> IO (FL Prim C(r y))-unrecordedChanges opts repo paths = do-  pristine <- readDarcsPristine "."-  Sealed pending <- pendingChanges repo paths-  (_, current') <- virtualTreeIO (apply [] pending) pristine-  relevant <- restrictSubpaths repo paths-  nonboring <- restrictBoring--  let current = relevant current'-  working <- case (LookForAdds `elem` opts, IgnoreTimes `elem` opts) of-               (False, False) -> do-                 all <- readIndex repo-                 expand (relevant all)-               (False, True) -> do-                 guide <- expand current-                 all <- readPlainTree "."-                 return $ relevant $ (restrict guide) all-               -- TODO (True, False) could use a more efficient implementation...-               (True, _) -> do-                 all <- readPlainTree "."-                 return $ relevant $ nonboring all--  ft <- filetype_function-  diff <- treeDiff ft current working-  return $ sort_coalesceFL (pending +>+ diff)--applyToTentativePristine :: (Apply p) => t -> p C(x y) -> IO ()-applyToTentativePristine _ patches =-    do pristine <- readDarcsPristine "."-       (_, t) <- hashedTreeIO (apply [] patches)-                 pristine "_darcs/pristine.hashed"-       BS.writeFile "_darcs/tentative_pristine" $-         BS.concat [BS.pack "pristine:"-                   , darcsFormatHash (fromJust $ treeHash t)]--applyToWorking :: (RepoPatch p) => Repository p C(r u t)-               -> Sealed (FL Prim C(u)) -> IO Tree-applyToWorking repo (Sealed patches) =-    do working <- readIndex repo-       snd `fmap` plainTreeIO (apply [] patches) working "."--filter_paths :: [AnchoredPath] -> AnchoredPath -> t -> Bool-filter_paths files =-    \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files--restrict_paths :: [AnchoredPath] -> Tree -> Tree-restrict_paths files = if null files-                          then id-                          else filter $ filter_paths files--restrict_subpaths :: [SubPath] -> Tree -> Tree-restrict_subpaths = restrict_paths . map (floatPath . fn2fp . sp2fn)--restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO (Tree -> Tree)-restrictSubpaths repo subpaths = do-  Sealed pending <- read_pending repo-  let paths = map (fn2fp . sp2fn) subpaths-      paths' = paths `union` apply_to_filepaths pending paths-      anchored = map floatPath paths'-  return $ restrict_paths anchored--restrictBoring :: IO (Tree -> Tree)-restrictBoring = do-  boring <- boring_regexps-  let boring' (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False-      boring' p _ = not $ any (\rx -> isJust $ matchRegex rx p') boring-          where p' = anchorPath "" p-  return $ filter boring'--readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO Tree-readIndex repo = do-  invalid <- doesFileExist "_darcs/index_invalid"-  exist <- doesFileExist "_darcs/index"-  format_valid <- if exist-                     then I.indexFormatValid "_darcs/index"-                     else return True-  when (exist && not format_valid) $ removeFile "_darcs/index"-  if (not exist || invalid || not format_valid)-     then do pris <- readRecordedAndPending repo-             idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris-             when invalid $ removeFile "_darcs/index_invalid"-             return idx-     else I.readIndex "_darcs/index" darcsTreeHash--invalidateIndex :: t -> IO ()-invalidateIndex _ = do-  BS.writeFile "_darcs/index_invalid" BS.empty
src/Darcs/Hopefully.hs view
@@ -35,8 +35,8 @@ import Darcs.Patch.Prim ( Effect(..), Conflict(..) ) import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..),                             ShowPatch(..), Commute(..) )-import Darcs.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) )-import Darcs.Sealed ( Sealed(Sealed), seal, mapSeal )+import Darcs.Witnesses.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) )+import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal ) import Darcs.Utils ( prettyException )  -- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a@@ -73,7 +73,7 @@ piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b) piap i p = PIAP i (Hopefully $ Actually p) --- | @n2pia@ creates a PatchInfoAnd represeting a @Named@ patch.+-- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch. n2pia :: Named p C(x y) -> PatchInfoAnd p C(x y) n2pia x = patch2patchinfo x `piap` x @@ -140,9 +140,9 @@     showPatch (PIAP n p) = case hopefully2either p of                            Right x -> showPatch x                            Left _ -> human_friendly n-    showContextPatch s (PIAP n p) = case hopefully2either p of-                                    Right x -> showContextPatch s x-                                    Left _ -> human_friendly n+    showContextPatch (PIAP n p) = case hopefully2either p of+                                    Right x -> showContextPatch x+                                    Left _ -> return $ human_friendly n     description (PIAP n _) = human_friendly n     summary (PIAP n p) = case hopefully2either p of                          Right x -> summary x@@ -154,9 +154,10 @@ instance Commute p => Commute (PatchInfoAnd p) where     commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y)                           return $ (info y `piap` y') :> (info x `piap` x')-    list_touched_files = list_touched_files . hopefully+    listTouchedFiles = listTouchedFiles . hopefully     merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of                        y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x')+    hunkMatches _ _ = error "hunkmatches not implemented for PatchInfoAnd"  instance Apply p => Apply (PatchInfoAnd p) where     apply opts p = apply opts $ hopefully p@@ -176,8 +177,8 @@     effectRL = effectRL . hopefully  instance Conflict p => Conflict (PatchInfoAnd p) where-    list_conflicted_files = list_conflicted_files . hopefully-    resolve_conflicts = resolve_conflicts . hopefully+    listConflictedFiles = listConflictedFiles . hopefully+    resolveConflicts = resolveConflicts . hopefully     commute_no_conflicts (x:>y) = do y':>x' <- commute_no_conflicts (hopefully x :> hopefully y)                                      return (info y `piap` y' :> info x `piap` x')     conflictedEffect = conflictedEffect . hopefully
src/Darcs/IO.hs view
@@ -33,7 +33,8 @@                         )  import ByteStringUtils ( linesPS, unlinesPS)-import qualified Data.ByteString as B (ByteString, empty, null, readFile)+import qualified Data.ByteString as B (ByteString, empty, null, readFile, concat)+import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BC (unpack, pack)  import Darcs.Utils ( withCurrentDirectory, prettyException )@@ -43,6 +44,9 @@ import Darcs.Lock ( writeBinFile, readBinFile, writeAtomicFilePS ) import Workaround ( setExecutable ) +import qualified Storage.Hashed.Monad as HSM+import Storage.Hashed.AnchoredPath( AnchoredPath, floatPath )+ class (Functor m, MonadPlus m) => ReadableDirectory m where     mDoesDirectoryExist :: FileName -> m Bool     mDoesFileExist :: FileName -> m Bool@@ -247,3 +251,23 @@  backup :: FileName -> IO () backup f = backupByRenaming $ fn2fp f++floatFn :: FileName -> AnchoredPath+floatFn = floatPath . fn2fp++instance (MonadPlus m, MonadError e m) => ReadableDirectory (HSM.TreeMonad m) where+    mDoesDirectoryExist d = HSM.directoryExists (floatFn d)+    mDoesFileExist f = HSM.fileExists (floatFn f)+    mInCurrentDirectory d action = HSM.withDirectory (floatFn d) action+    mGetDirectoryContents = error "get dir contents"+    mReadFilePS p = do x <- HSM.readFile (floatFn p)+                       return $ B.concat (BL.toChunks x)++instance (Functor m, MonadPlus m, MonadError e m) => WriteableDirectory (HSM.TreeMonad m) where+    mWithCurrentDirectory = mInCurrentDirectory+    mSetFileExecutable _ _ = return ()+    mWriteFilePS p ps = HSM.writeFile (floatFn p) (BL.fromChunks [ps])+    mCreateDirectory p = HSM.createDirectory (floatFn p)+    mRename from to = HSM.rename (floatFn from) (floatFn to)+    mRemoveDirectory = HSM.unlink . floatFn+    mRemoveFile = HSM.unlink . floatFn
src/Darcs/Lock.hs view
@@ -28,6 +28,7 @@               rm_recursive, removeFileMayNotExist,               canonFilename, maybeRelink,               world_readable_temp, tempdir_loc,+              editText,               environmentHelpTmpdir, environmentHelpKeepTmpdir             ) where @@ -48,7 +49,7 @@                  ) import System.FilePath.Posix ( splitDirectories ) import Workaround ( renameFile )-import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO )+import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO, run_editor ) import Control.Monad ( unless, when )  import Darcs.URL ( is_relative )@@ -57,7 +58,7 @@                         getCurrentDirectory, setCurrentDirectory )  import ByteStringUtils ( gzWriteFilePSs)-import qualified Data.ByteString as B (null, readFile, hPut, ByteString)+import qualified Data.ByteString as B (null, readFile, writeFile, hPut, ByteString) import qualified Data.ByteString.Char8 as BC (unpack)  import Darcs.SignalHandler ( withSignalsBlocked )@@ -272,13 +273,18 @@           wrt 100 = fail $ "Failure creating temp named "++f           wrt n = let f_new = f++"-"++show n                   in do ok <- takeFile f_new-                        if ok then do atexit $ removeFileMayNotExist f_new-                                      return f_new+                        if ok then return f_new                               else wrt (n+1)  withNamedTemp :: String -> (String -> IO a) -> IO a withNamedTemp n = bracket get_empty_file removeFileMayNotExist     where get_empty_file = world_readable_temp n++editText :: String -> B.ByteString -> IO B.ByteString+editText desc txt = withNamedTemp desc $ \f -> do+  B.writeFile f txt+  run_editor f+  B.readFile f  readBinFile :: FilePathLike p => p -> IO String readBinFile = fmap BC.unpack . B.readFile . toFilePath
src/Darcs/Match.lhs view
@@ -21,19 +21,20 @@  #include "gadts.h" -module Darcs.Match ( match_first_patchset, match_second_patchset,-               match_patch,-               match_a_patch, match_a_patchread,-               get_first_match, get_nonrange_match,-               get_partial_first_match, get_partial_second_match,-               get_partial_nonrange_match,-               first_match, second_match, have_nonrange_match,-               have_patchset_match, get_one_patchset,-               checkMatchSyntax,+module Darcs.Match ( matchFirstPatchset, matchSecondPatchset,+               matchPatch,+               matchAPatch, matchAPatchread,+               getFirstMatch, getNonrangeMatch,+               getPartialFirstMatch, getPartialSecondMatch,+               getPartialNonrangeMatch,+               firstMatch, secondMatch, haveNonrangeMatch,+               havePatchsetMatch, getOnePatchset,+               checkMatchSyntax, applyInvToMatcher, nonrangeMatcher,+               InclusiveOrExclusive(..), matchExists              ) where  import Text.Regex ( mkRegex, matchRegex )-import Control.Monad ( when )+import Control.Monad ( when, unless ) import Data.Maybe ( isJust )  import Darcs.Hopefully ( PatchInfoAnd, info, piap,@@ -44,17 +45,16 @@                     slurp_recorded, createPristineDirectoryTree ) import Darcs.Repository.ApplyPatches ( apply_patches ) import Darcs.Patch.Depends ( get_patches_in_tag, get_patches_beyond_tag )-import Darcs.Ordered ( RL(..), concatRL, consRLSealed )+import Darcs.Witnesses.Ordered ( RL(..), concatRL, consRLSealed )  import ByteStringUtils ( mmapFilePS ) import qualified Data.ByteString as B (ByteString)  import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,-                                StoreInMemory,                                AfterPatch, UpToPatch, LastN, PatchIndexRange,                                OneTag, AfterTag, UpToTag,                                OnePattern, SeveralPattern,-                               AfterPattern, UpToPattern ) )+                               AfterPattern, UpToPattern ), willStoreInMemory ) import Darcs.Patch.Bundle ( scan_context ) import Darcs.Patch.Match ( Matcher, MatchFun, match_pattern, apply_matcher, make_matcher, parseMatch ) import Darcs.Patch.MatchData ( PatchMatch )@@ -63,8 +63,8 @@ import Darcs.RepoPath ( toFilePath ) import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) ) import Darcs.SlurpDirectory ( SlurpMonad, writeSlurpy, withSlurpy )-import Darcs.Patch.FileName ( FileName, super_name, norm_path, (///) )-import Darcs.Sealed ( FlippedSeal(..), Sealed2(..),+import Darcs.Patch.FileName ( FileName, superName, norm_path, (///) )+import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..),                       seal, flipSeal, seal2, unsealFlipped, unseal2, unseal ) #include "impossible.h" \end{code}@@ -107,96 +107,96 @@ \begin{code} data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq --- | @have_nonrange_match flags@ tells whether there is a flag in+-- | @haveNonrangeMatch flags@ tells whether there is a flag in -- @flags@ which corresponds to a match that is "non-range". Thus,--- @--match@, @--patch@ and @--index@ make @have_nonrange_match@+-- @--match@, @--patch@ and @--index@ make @haveNonrangeMatch@ -- true, but not @--from-patch@ or @--to-patch@.-have_nonrange_match :: [DarcsFlag] -> Bool-have_nonrange_match fs = isJust (has_index_range fs) || isJust (nonrange_matcher fs::Maybe (Matcher Patch))+haveNonrangeMatch :: [DarcsFlag] -> Bool+haveNonrangeMatch fs = isJust (hasIndexRange fs) || isJust (nonrangeMatcher fs::Maybe (Matcher Patch)) --- | @have_patchset_match flags@ tells whether there is a "patchset+-- | @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 @have_nonrange_match@?-have_patchset_match :: [DarcsFlag] -> Bool-have_patchset_match fs = isJust (nonrange_matcher fs::Maybe (Matcher Patch)) || hasC fs+-- Question: Is it supposed not to be a subset of @haveNonrangeMatch@?+havePatchsetMatch :: [DarcsFlag] -> Bool+havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher Patch)) || hasC fs     where hasC [] = False           hasC (Context _:_) = True           hasC (_:xs) = hasC xs -get_nonrange_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()-get_nonrange_match r fs = withRecordedMatchSmart fs r (get_nonrange_match_s fs)+getNonrangeMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()+getNonrangeMatch r fs = withRecordedMatchSmart fs r (getNonrangeMatchS fs) -get_partial_nonrange_match :: RepoPatch p => Repository p C(r u t)+getPartialNonrangeMatch :: RepoPatch p => Repository p C(r u t)                            -> [DarcsFlag] -> [FileName] -> IO ()-get_partial_nonrange_match r fs files =-    withRecordedMatchOnlySomeSmart fs r files (get_nonrange_match_s fs)+getPartialNonrangeMatch r fs files =+    withRecordedMatchOnlySomeSmart fs r files (getNonrangeMatchS fs) -get_nonrange_match_s :: (MatchMonad m p, RepoPatch p) =>+getNonrangeMatchS :: (MatchMonad m p, RepoPatch p) =>                         [DarcsFlag] -> PatchSet p C(x) -> m ()-get_nonrange_match_s fs repo =-    case nonrange_matcher fs of-        Just m -> if nonrange_matcher_is_tag fs-                        then get_tag_s m repo-                        else get_matcher_s Exclusive m repo-        Nothing -> fail "Pattern not specified in get_nonrange_match."+getNonrangeMatchS fs repo =+    case nonrangeMatcher fs of+        Just m -> if nonrangeMatcherIsTag fs+                        then getTagS m repo+                        else getMatcherS Exclusive m repo+        Nothing -> fail "Pattern not specified in getNonrangeMatch." --- | @first_match fs@ tells whether @fs@ implies a "first match", that+-- | @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.-first_match :: [DarcsFlag] -> Bool-first_match fs = isJust (has_lastn fs)-                 || isJust (first_matcher fs::Maybe (Matcher Patch))-                 || isJust (has_index_range fs)+firstMatch :: [DarcsFlag] -> Bool+firstMatch fs = isJust (hasLastn fs)+                 || isJust (firstMatcher fs::Maybe (Matcher Patch))+                 || isJust (hasIndexRange fs) -get_first_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()-get_first_match r fs = withRecordedMatchSmart fs r (get_first_match_s fs)+getFirstMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()+getFirstMatch r fs = withRecordedMatchSmart fs r (getFirstMatchS fs) -get_partial_first_match :: RepoPatch p => Repository p C(r u t)+getPartialFirstMatch :: RepoPatch p => Repository p C(r u t)                         -> [DarcsFlag] -> [FileName] -> IO ()-get_partial_first_match r fs files =-    withRecordedMatchOnlySomeSmart fs r files (get_first_match_s fs)+getPartialFirstMatch r fs files =+    withRecordedMatchOnlySomeSmart fs r files (getFirstMatchS fs) -get_first_match_s :: (MatchMonad m p, RepoPatch p) =>+getFirstMatchS :: (MatchMonad m p, RepoPatch p) =>                      [DarcsFlag] -> PatchSet p C(x) -> m ()-get_first_match_s fs repo =-    case has_lastn fs of+getFirstMatchS fs repo =+    case hasLastn fs of     Just n -> applyInvRL `unsealFlipped` (safetake n $ concatRL repo)-    Nothing -> case first_matcher fs of-               Nothing -> fail "Pattern not specified in get_first_match."-               Just m -> if first_matcher_is_tag fs-                         then get_tag_s m repo-                         else get_matcher_s Inclusive m repo+    Nothing -> case firstMatcher fs of+               Nothing -> fail "Pattern not specified in getFirstMatch."+               Just m -> if firstMatcherIsTag fs+                         then getTagS m repo+                         else getMatcherS Inclusive m repo  --- | @second_match fs@ tells whether @fs@ implies a "second match", that+-- | @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.-second_match :: [DarcsFlag] -> Bool-second_match fs = isJust (second_matcher fs::Maybe (Matcher Patch)) || isJust (has_index_range fs)+secondMatch :: [DarcsFlag] -> Bool+secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher Patch)) || isJust (hasIndexRange fs) -get_partial_second_match :: RepoPatch p => Repository p C(r u t)+getPartialSecondMatch :: RepoPatch p => Repository p C(r u t)                         -> [DarcsFlag] -> [FileName] -> IO ()-get_partial_second_match r fs files =+getPartialSecondMatch r fs files =     withRecordedMatchOnlySomeSmart fs r files $ \repo ->-    case second_matcher fs of+    case secondMatcher fs of     Nothing -> fail "Two patterns not specified in get_second_match."-    Just m -> if second_matcher_is_tag fs-              then get_tag_s m repo-              else get_matcher_s Exclusive m repo+    Just m -> if secondMatcherIsTag fs+              then getTagS m repo+              else getMatcherS Exclusive m repo  checkMatchSyntax :: [DarcsFlag] -> IO () checkMatchSyntax opts = do- case get_match_pattern opts of+ case getMatchPattern opts of   Nothing -> return ()   Just p  -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun Patch)) -get_match_pattern :: [DarcsFlag] -> Maybe PatchMatch-get_match_pattern [] = Nothing-get_match_pattern (OnePattern m:_) = Just m-get_match_pattern (SeveralPattern m:_) = Just m-get_match_pattern (_:fs) = get_match_pattern fs+getMatchPattern :: [DarcsFlag] -> Maybe PatchMatch+getMatchPattern [] = Nothing+getMatchPattern (OnePattern m:_) = Just m+getMatchPattern (SeveralPattern m:_) = Just m+getMatchPattern (_:fs) = getMatchPattern fs  tagmatch :: String -> Matcher p tagmatch r = make_matcher ("tag-name "++r) tm@@ -219,138 +219,138 @@ -- subset. This subset is formed by the patches in a given interval -- which match a given criterion. If we represent time going left to -- right (which means the 'PatchSet' is written right to left), then--- we have (up to) three 'Matcher's: the 'nonrange_matcher' is the+-- we have (up to) three 'Matcher's: the 'nonrangeMatcher' is the -- criterion we use to select among patches in the interval, the--- 'first_matcher' is the left bound of the interval, and the+-- 'firstMatcher' is the left bound of the interval, and the -- 'last_matcher' is the right bound. Each of these matchers can be -- present or not according to the options. strictJust :: a -> Maybe a strictJust x = Just $! x --- | @nonrange_matcher@ is the criterion that is used to match against+-- | @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).-nonrange_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-nonrange_matcher [] = Nothing-nonrange_matcher (OnePattern m:_) = strictJust $ match_pattern m-nonrange_matcher (OneTag t:_) = strictJust $ tagmatch t-nonrange_matcher (OnePatch p:_) = strictJust $ mymatch p-nonrange_matcher (SeveralPattern m:_) = strictJust $ match_pattern m-nonrange_matcher (SeveralPatch p:_) = strictJust $ mymatch p-nonrange_matcher (_:fs) = nonrange_matcher fs+nonrangeMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)+nonrangeMatcher [] = Nothing+nonrangeMatcher (OnePattern m:_) = strictJust $ match_pattern m+nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t+nonrangeMatcher (OnePatch p:_) = strictJust $ mymatch p+nonrangeMatcher (SeveralPattern m:_) = strictJust $ match_pattern m+nonrangeMatcher (SeveralPatch p:_) = strictJust $ mymatch p+nonrangeMatcher (_:fs) = nonrangeMatcher fs --- | @nonrange_matcher_is_tag@ returns true if the matching option was+-- | @nonrangeMatcherIsTag@ returns true if the matching option was -- '--tag'-nonrange_matcher_is_tag :: [DarcsFlag] -> Bool-nonrange_matcher_is_tag [] = False-nonrange_matcher_is_tag (OneTag _:_) = True-nonrange_matcher_is_tag (_:fs) = nonrange_matcher_is_tag fs+nonrangeMatcherIsTag :: [DarcsFlag] -> Bool+nonrangeMatcherIsTag [] = False+nonrangeMatcherIsTag (OneTag _:_) = True+nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs --- | @first_matcher@ returns the left bound of the matched interval.+-- | @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, @first_matcher@+-- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@ -- returns @Nothing@.-first_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-first_matcher [] = Nothing-first_matcher (OnePattern m:_) = strictJust $ match_pattern m-first_matcher (AfterPattern m:_) = strictJust $ match_pattern m-first_matcher (AfterTag t:_) = strictJust $ tagmatch t-first_matcher (OnePatch p:_) = strictJust $ mymatch p-first_matcher (AfterPatch p:_) = strictJust $ mymatch p-first_matcher (_:fs) = first_matcher fs+firstMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)+firstMatcher [] = Nothing+firstMatcher (OnePattern m:_) = strictJust $ match_pattern m+firstMatcher (AfterPattern m:_) = strictJust $ match_pattern m+firstMatcher (AfterTag t:_) = strictJust $ tagmatch t+firstMatcher (OnePatch p:_) = strictJust $ mymatch p+firstMatcher (AfterPatch p:_) = strictJust $ mymatch p+firstMatcher (_:fs) = firstMatcher fs -first_matcher_is_tag :: [DarcsFlag] -> Bool-first_matcher_is_tag [] = False-first_matcher_is_tag (AfterTag _:_) = True-first_matcher_is_tag (_:fs) = first_matcher_is_tag fs+firstMatcherIsTag :: [DarcsFlag] -> Bool+firstMatcherIsTag [] = False+firstMatcherIsTag (AfterTag _:_) = True+firstMatcherIsTag (_:fs) = firstMatcherIsTag fs -second_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-second_matcher [] = Nothing-second_matcher (OnePattern m:_) = strictJust $ match_pattern m-second_matcher (UpToPattern m:_) = strictJust $ match_pattern m-second_matcher (OnePatch p:_) = strictJust $ mymatch p-second_matcher (UpToPatch p:_) = strictJust $ mymatch p-second_matcher (UpToTag t:_) = strictJust $ tagmatch t-second_matcher (_:fs) = second_matcher fs+secondMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)+secondMatcher [] = Nothing+secondMatcher (OnePattern m:_) = strictJust $ match_pattern m+secondMatcher (UpToPattern m:_) = strictJust $ match_pattern m+secondMatcher (OnePatch p:_) = strictJust $ mymatch p+secondMatcher (UpToPatch p:_) = strictJust $ mymatch p+secondMatcher (UpToTag t:_) = strictJust $ tagmatch t+secondMatcher (_:fs) = secondMatcher fs -second_matcher_is_tag :: [DarcsFlag] -> Bool-second_matcher_is_tag [] = False-second_matcher_is_tag (UpToTag _:_) = True-second_matcher_is_tag (_:fs) = second_matcher_is_tag fs+secondMatcherIsTag :: [DarcsFlag] -> Bool+secondMatcherIsTag [] = False+secondMatcherIsTag (UpToTag _:_) = True+secondMatcherIsTag (_:fs) = secondMatcherIsTag fs --- | @match_a_patchread fs p@ tells whether @p@ matches the matchers in+-- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in -- the flags listed in @fs@.-match_a_patchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool-match_a_patchread fs = case nonrange_matcher fs of+matchAPatchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool+matchAPatchread fs = case nonrangeMatcher fs of                        Nothing -> const True                        Just m -> apply_matcher m --- | @match_a_patch fs p@ tells whether @p@ matches the matchers in+-- | @matchAPatch fs p@ tells whether @p@ matches the matchers in -- the flags @fs@-match_a_patch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool-match_a_patch fs p =-    case nonrange_matcher fs of+matchAPatch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool+matchAPatch fs p =+    case nonrangeMatcher fs of     Nothing -> True     Just m -> apply_matcher m (patch2patchinfo p `piap` p) -match_patch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p)-match_patch fs ps =-    case has_index_range fs of+matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p)+matchPatch fs ps =+    case hasIndexRange fs of     Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of                              Just (Sealed2 p) -> seal2 $ hopefully p                              Nothing -> error "Patch out of range!"-                | otherwise -> bug ("Invalid index range match given to match_patch: "+++                | otherwise -> bug ("Invalid index range match given to matchPatch: "++                                     show (PatchIndexRange a a'))                 where myhead :: PatchSet p C(x) -> Maybe (Sealed2 (PatchInfoAnd p))                       myhead (NilRL:<:x) = myhead x                       myhead ((x:<:_):<:_) = Just $ seal2 x                       myhead NilRL = Nothing-    Nothing -> case nonrange_matcher fs of-                    Nothing -> bug "Couldn't match_patch"-                    Just m -> find_a_patch m ps+    Nothing -> case nonrangeMatcher fs of+                    Nothing -> bug "Couldn't matchPatch"+                    Just m -> findAPatch m ps -get_one_patchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p)-get_one_patchset repository fs =-    case nonrange_matcher fs of+getOnePatchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p)+getOnePatchset repository fs =+    case nonrangeMatcher fs of         Just m -> do ps <- read_repo repository-                     if nonrange_matcher_is_tag fs-                        then return $ get_matching_tag m ps-                        else return $ match_a_patchset m ps+                     if nonrangeMatcherIsTag fs+                        then return $ getMatchingTag m ps+                        else return $ matchAPatchset m ps         Nothing -> (seal . scan_context) `fmap` mmapFilePS (toFilePath $ context_f fs)     where context_f [] = bug "Couldn't match_nonrange_patchset"           context_f (Context f:_) = f           context_f (_:xs) = context_f xs --- | @has_lastn fs@ return the @--last@ argument in @fs@, if any.-has_lastn :: [DarcsFlag] -> Maybe Int-has_lastn [] = Nothing-has_lastn (LastN (-1):_) = error "--last requires a positive integer argument."-has_lastn (LastN n:_) = Just n-has_lastn (_:fs) = has_lastn fs+-- | @hasLastn fs@ return the @--last@ argument in @fs@, if any.+hasLastn :: [DarcsFlag] -> Maybe Int+hasLastn [] = Nothing+hasLastn (LastN (-1):_) = error "--last requires a positive integer argument."+hasLastn (LastN n:_) = Just n+hasLastn (_:fs) = hasLastn fs -has_index_range :: [DarcsFlag] -> Maybe (Int,Int)-has_index_range [] = Nothing-has_index_range (PatchIndexRange x y:_) = Just (x,y)-has_index_range (_:fs) = has_index_range fs+hasIndexRange :: [DarcsFlag] -> Maybe (Int,Int)+hasIndexRange [] = Nothing+hasIndexRange (PatchIndexRange x y:_) = Just (x,y)+hasIndexRange (_:fs) = hasIndexRange fs --- | @match_first_patchset fs ps@ returns the part of @ps@ before its+-- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its -- first matcher, ie the one that comes first dependencywise. Hence,--- patches in @match_first_patchset fs ps@ are the ones we don't want.+-- patches in @matchFirstPatchset fs ps@ are the ones we don't want. -- -- Question: are they really? Florent-match_first_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p-match_first_patchset fs patchset =-    case has_lastn fs of+matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p+matchFirstPatchset fs patchset =+    case hasLastn fs of     Just n -> dropn n patchset     Nothing ->-        case has_index_range fs of+        case hasIndexRange fs of         Just (_,b) -> dropn b patchset         Nothing ->-               case first_matcher fs of-               Nothing -> bug "Couldn't match_first_patchset"-               Just m -> unseal (dropn 1) $ if first_matcher_is_tag fs-                                            then get_matching_tag m patchset-                                            else match_a_patchset m patchset+               case firstMatcher fs of+               Nothing -> bug "Couldn't matchFirstPatchset"+               Just m -> unseal (dropn 1) $ if firstMatcherIsTag fs+                                            then getMatchingTag m patchset+                                            else matchAPatchset m patchset  -- | @dropn n ps@ drops the @n@ last patches from @ps@. dropn :: Int -> PatchSet p C(x) -> SealedPatchSet p@@ -359,67 +359,67 @@ dropn _ NilRL = seal $ NilRL:<:NilRL dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs --- | @match_second_patchset fs ps@ returns the part of @ps@ before its+-- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its -- second matcher, ie the one that comes last dependencywise.-match_second_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p-match_second_patchset fs ps =-  case has_index_range fs of+matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p+matchSecondPatchset fs ps =+  case hasIndexRange fs of   Just (a,_) -> dropn (a-1) ps   Nothing ->-    case second_matcher fs of-    Nothing -> bug "Couldn't match_second_patchset"-    Just m -> if second_matcher_is_tag fs-              then get_matching_tag m ps-              else match_a_patchset m ps+    case secondMatcher fs of+    Nothing -> bug "Couldn't matchSecondPatchset"+    Just m -> if secondMatcherIsTag fs+              then getMatchingTag m ps+              else matchAPatchset m ps --- | @find_a_patch m ps@ returns the last patch in @ps@ matching @m@, and+-- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and -- calls 'error' if there is none.-find_a_patch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p)-find_a_patch m NilRL = error $ "Couldn't find patch matching " ++ show m-find_a_patch m (NilRL:<:xs) = find_a_patch m xs-find_a_patch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p-                               | otherwise = find_a_patch m (ps:<:xs)+findAPatch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p)+findAPatch m NilRL = error $ "Couldn't find patch matching " ++ show m+findAPatch m (NilRL:<:xs) = findAPatch m xs+findAPatch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p+                               | otherwise = findAPatch m (ps:<:xs) --- | @match_a_patchset m ps@ returns a (the largest?) subset of @ps@+-- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@ -- ending in patch which matches @m@. Calls 'error' if there is none.-match_a_patchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p-match_a_patchset m NilRL = error $ "Couldn't find patch matching " ++ show m-match_a_patchset m (NilRL:<:xs) = match_a_patchset m xs-match_a_patchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs)-                                   | otherwise = match_a_patchset m (ps:<:xs)+matchAPatchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p+matchAPatchset m NilRL = error $ "Couldn't find patch matching " ++ show m+matchAPatchset m (NilRL:<:xs) = matchAPatchset m xs+matchAPatchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs)+                                   | otherwise = matchAPatchset m (ps:<:xs) --- | @get_matching_tag m ps@, where @m@ is a 'Matcher' which matches tags+-- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags -- returns a 'SealedPatchSet' containing all patches in the last tag which -- matches @m@. Last tag means the most recent tag in repository order, -- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls -- 'error' if there is no matching tag.-get_matching_tag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p-get_matching_tag m NilRL = error $ "Couldn't find a tag matching " ++ show m-get_matching_tag m (NilRL:<:xs) = get_matching_tag m xs-get_matching_tag m xxx@((p:<:ps):<:xs)+getMatchingTag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p+getMatchingTag m NilRL = error $ "Couldn't find a tag matching " ++ show m+getMatchingTag m (NilRL:<:xs) = getMatchingTag m xs+getMatchingTag m xxx@((p:<:ps):<:xs)     | apply_matcher m p = get_patches_in_tag (info p) xxx-    | otherwise = get_matching_tag m (ps:<:xs)+    | otherwise = getMatchingTag m (ps:<:xs) --- | @match_exists m ps@ tells whether there is a patch matching+-- | @matchExists m ps@ tells whether there is a patch matching -- @m@ in @ps@-match_exists :: Matcher p -> PatchSet p C(x) -> Bool-match_exists _ NilRL = False-match_exists m (NilRL:<:xs) = match_exists m xs-match_exists m ((p:<:ps):<:xs) | apply_matcher m $ p = True-                               | otherwise = match_exists m (ps:<:xs)+matchExists :: Matcher p -> PatchSet p C(x) -> Bool+matchExists _ NilRL = False+matchExists m (NilRL:<:xs) = matchExists m xs+matchExists m ((p:<:ps):<:xs) | apply_matcher m $ p = True+                               | otherwise = matchExists m (ps:<:xs) -apply_inv_to_matcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()-apply_inv_to_matcher _ _ NilRL = impossible-apply_inv_to_matcher ioe m (NilRL:<:xs) = apply_inv_to_matcher ioe m xs-apply_inv_to_matcher ioe m ((p:<:ps):<:xs)-    | apply_matcher m p = when (ioe == Inclusive) (apply_invp p)-    | otherwise = apply_invp p >> apply_inv_to_matcher ioe m (ps:<:xs)+applyInvToMatcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()+applyInvToMatcher _ _ NilRL = impossible+applyInvToMatcher ioe m (NilRL:<:xs) = applyInvToMatcher ioe m xs+applyInvToMatcher ioe m ((p:<:ps):<:xs)+    | apply_matcher m p = when (ioe == Inclusive) (applyInvp p)+    | otherwise = applyInvp p >> applyInvToMatcher ioe m (ps:<:xs) --- | @maybe_read_file@ recursively gets the contents of all files+-- | @maybeReadFile@ recursively gets the contents of all files -- in a directory, or just the contents of a file if called on a -- simple file.-maybe_read_file :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)])-maybe_read_file file = do+maybeReadFile :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)])+maybeReadFile file = do     d <- mDoesDirectoryExist file     if d       then do@@ -434,31 +434,30 @@            else return []   where maybe_read_files [] =  return []         maybe_read_files (f:fs) = do-                      x <- maybe_read_file f+                      x <- maybeReadFile f                       y <- maybe_read_files fs                       return $ concat [x,y] -get_matcher_s :: (MatchMonad m p, RepoPatch p) =>+getMatcherS :: (MatchMonad m p, RepoPatch p) =>                  InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()-get_matcher_s ioe m repo =-    if match_exists m repo-    then apply_inv_to_matcher ioe m repo+getMatcherS ioe m repo =+    if matchExists m repo+    then applyInvToMatcher ioe m repo     else fail $ "Couldn't match pattern "++ show m -get_tag_s :: (MatchMonad m p, RepoPatch p) =>+getTagS :: (MatchMonad m p, RepoPatch p) =>              Matcher p -> PatchSet p C(x) -> m ()-get_tag_s match repo = do-    let pinfo = patch2patchinfo `unseal2` (find_a_patch match repo)+getTagS match repo = do+    let pinfo = patch2patchinfo `unseal2` (findAPatch match repo)     case get_patches_beyond_tag pinfo repo of-        FlippedSeal (extras:<:NilRL) -> applyInvRL $ extras-        _ -> impossible+        FlippedSeal extras -> applyInvRL extras --- | @apply_invp@ tries to get the patch that's in a 'PatchInfoAnd+-- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd -- patch', and to apply its inverse. If we fail to fetch the patch -- (presumably in a partial repositiory), then we share our sorrow -- with the user.-apply_invp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m ()-apply_invp hp = apply [] (invert $ fromHopefully hp)+applyInvp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m ()+applyInvp hp = apply [] (invert $ fromHopefully hp)     where fromHopefully = conscientiously $ \e ->                      text "Sorry, partial repository problem.  Patch not available:"                      $$ e@@ -495,7 +494,7 @@     withRecordedMatchOnlySomeFiles r _ j = withRecordedMatch r j     applyInvRL :: RL (PatchInfoAnd p) C(x r) -> m ()     applyInvRL NilRL = return ()-    applyInvRL (p:<:ps) = apply_invp p >> applyInvRL ps+    applyInvRL (p:<:ps) = applyInvp p >> applyInvRL ps  withRecordedMatchIO :: RepoPatch p => Repository p C(r u t)                     -> (PatchSet p C(r) -> IO ()) -> IO ()@@ -513,8 +512,8 @@                        -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())                        -> IO () withRecordedMatchSmart opts r j =- do if StoreInMemory `elem` opts then withSM r j-                                 else withRecordedMatchIO r j+ do if willStoreInMemory opts then withSM r j+                              else withRecordedMatchIO r j     where withSM :: RepoPatch p => Repository p C(r u t)                  -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()           withSM = withRecordedMatch@@ -529,8 +528,8 @@                        -> IO () withRecordedMatchOnlySomeSmart opts r [] j = withRecordedMatchSmart opts r j withRecordedMatchOnlySomeSmart opts r files j =- do if StoreInMemory `elem` opts then withSM r files j-                                 else withIO r files j+ do if willStoreInMemory opts then withSM r files j+                              else withIO r files j     where withSM :: RepoPatch p => Repository p C(r u t) -> [FileName]                  -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()           withSM = withRecordedMatchOnlySomeFiles@@ -553,16 +552,15 @@     withRecordedMatchOnlySomeFiles r fs job =         do ps <- read_repo r            s <- slurp_recorded r-           case withSlurpy s (job ps >> mapM maybe_read_file fs) of+           case withSlurpy s (job ps >> mapM maybeReadFile fs) of              Left err -> fail err              Right (_,fcs) -> mapM_ createAFile $ concat fcs-               where createAFile (p,c) = do ensureDirectories $ super_name p+               where createAFile (p,c) = do ensureDirectories $ superName p                                             mWriteFilePS p c                      ensureDirectories d =                          do isPar <- mDoesDirectoryExist d-                            if isPar-                              then return ()-                              else do ensureDirectories $ super_name d-                                      mCreateDirectory d+                            unless isPar $ do+                               ensureDirectories $ superName d+                               mCreateDirectory d  \end{code}
− src/Darcs/Ordered.hs 
@@ -1,277 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -cpp -fglasgow-exts #-}-{-# LANGUAGE CPP #-}--- , MagicHash, TypeOperators, GADTs #-}--#include "gadts.h"--module Darcs.Ordered ( EqCheck(..), isEq, (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..),-                             FL(..), RL(..),Proof(..),-#ifndef GADT_WITNESSES-                             unsafeUnFL, unsafeFL, unsafeRL, unsafeUnRL,-#endif-                             lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL,-                             splitAtFL, bunchFL, foldlRL,-                             lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL,-                             unsafeMap_l2f, filterE, filterFL,-                             reverseFL, reverseRL, (+>+), (+<+),-                             nullFL, concatFL, concatRL, concatReverseFL, headRL,-                             MyEq, unsafeCompare, (=\/=), (=/\=),-                             consRLSealed, nullRL,-                             unsafeCoerceP, unsafeCoerceP2-                           ) where--#include "impossible.h"-import GHC.Base (unsafeCoerce#)-import Darcs.Show-import Darcs.Sealed ( FlippedSeal(..), flipSeal )--data EqCheck C(a b) where-    IsEq :: EqCheck C(a a)-    NotEq :: EqCheck C(a b)--instance Eq (EqCheck C(a b)) where-    IsEq == IsEq = True-    NotEq == NotEq = True-    _ == _ = False--isEq :: EqCheck C(a b) -> Bool-isEq IsEq = True-isEq NotEq = False--instance Show (EqCheck C(a b)) where-    show IsEq = "IsEq"-    show NotEq = "NotEq"--data Proof a C(x y) where-    Proof :: a -> Proof a C(x x)--data (a1 :> a2) C(x y) = FORALL(z) (a1 C(x z)) :> (a2 C(z y))-infixr 1 :>-data (a1 :< a2) C(x y) = FORALL(z) (a1 C(z y)) :< (a2 C(x z))-infix 1 :<-infix 1 :/\:, :\/:-data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y))-data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z))-class MyEq p where-    -- Minimal definition defines any one of unsafeCompare, =\/= and =/\=.-    unsafeCompare :: p C(a b) -> p C(c d) -> Bool-    unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b)-    (=\/=) :: p C(a b) -> p C(a c) -> EqCheck C(b c)-    a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq-             | otherwise = NotEq-    (=/\=) :: p C(a c) -> p C(b c) -> EqCheck C(a b)-    a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq-             | otherwise = NotEq--infix 4 =\/=, =/\=--unsafeCoerceP :: a C(x y) -> a C(b c)-unsafeCoerceP = unsafeCoerce#--unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d)-unsafeCoerceP2 = unsafeCoerce#--instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where-    showsPrec d (x :> y) = showOp2 1 ":>" d x y--instance (Show2 a, Show2 b) => Show2 (a :> b) where-    showsPrec2 = showsPrec--instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where-    showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y--instance (Show2 a, Show2 b) => Show2 (a :\/: b) where-    showsPrec2 = showsPrec--infixr 5 :>:, :<:, +>+, +<+---- forward list-data FL a C(x z) where-    (:>:) :: a C(x y) -> FL a C(y z) -> FL a C(x z)-    NilFL :: FL a C(x x)--instance Show2 a => Show (FL a C(x z)) where-   showsPrec _ NilFL = showString "NilFL"-   showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .-                            showString " :>: " . showsPrec (prec + 1) xs-       where prec = 5--instance Show2 a => Show2 (FL a) where-   showsPrec2 = showsPrec---- reverse list-data RL a C(x z) where-    (:<:) :: a C(y z) -> RL a C(x y) -> RL a C(x z)-    NilRL :: RL a C(x x)--nullFL :: FL a C(x z) -> Bool-nullFL NilFL = True-nullFL _ = False--nullRL :: RL a C(x z) -> Bool-nullRL NilRL = True-nullRL _ = False--filterFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z)-filterFL _ NilFL = NilFL-filterFL f (x:>:xs) | IsEq <- f x = filterFL f xs-                    | otherwise = x :>: filterFL f xs--filterE :: (a -> EqCheck C(x y)) -> [a] -> [Proof a C(x y)]-filterE _ [] = []-filterE p (x:xs)-    | IsEq <- p x = Proof x : filterE p xs-    | otherwise   = filterE p xs--(+>+) :: FL a C(x y) -> FL a C(y z) -> FL a C(x z)-NilFL +>+ ys = ys-(x:>:xs) +>+ ys = x :>: xs +>+ ys--(+<+) :: RL a C(y z) -> RL a C(x y) -> RL a C(x z)-NilRL +<+ ys = ys-(x:<:xs) +<+ ys = x :<: xs +<+ ys--reverseFL :: FL a C(x z) -> RL a C(x z)-reverseFL xs = r NilRL xs-  where r :: RL a C(l m) -> FL a C(m o) -> RL a C(l o)-        r ls NilFL = ls-        r ls (a:>:as) = r (a:<:ls) as--reverseRL :: RL a C(x z) -> FL a C(x z)-reverseRL xs = r NilFL xs -- r (xs :> NilFL)-  where r :: FL a C(m o) -> RL a C(l m) -> FL a C(l o)-        r ls NilRL = ls-        r ls (a:<:as) = r (a:>:ls) as--concatFL :: FL (FL a) C(x z) -> FL a C(x z)-concatFL NilFL = NilFL-concatFL (a:>:as) = a +>+ concatFL as--concatRL :: RL (RL a) C(x z) -> RL a C(x z)-concatRL NilRL = NilRL-concatRL (a:<:as) = a +<+ concatRL as--spanFL :: (FORALL(w y) a C(w y) -> Bool) -> FL a C(x z) -> (FL a :> FL a) C(x z)-spanFL f (x:>:xs) | f x = case spanFL f xs of-                            ys :> zs -> (x:>:ys) :> zs-spanFL _ xs = NilFL :> xs--splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z)-splitAtFL 0 xs = NilFL :> xs-splitAtFL _ NilFL = NilFL :> NilFL-splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of-                       (xs':>xs'') -> (x:>:xs' :> xs'')---- 'bunchFL n' groups patches into batches of n, except that it always puts--- the first patch in its own group, this being a recognition that the--- first patch is often *very* large.--bunchFL :: Int -> FL a C(x y) -> FL (FL a) C(x y)-bunchFL _ NilFL = NilFL-bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs-    where bFL :: FL a C(x y) -> FL (FL a) C(x y)-          bFL NilFL = NilFL-          bFL bs = case splitAtFL n bs of-                   a :> b -> a :>: bFL b---allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool-allFL f xs = and $ mapFL f xs--foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a-foldlFL _ x NilFL = x-foldlFL f x (y:>:ys) = foldlFL f (f x y) ys--foldlRL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> RL b C(x z) -> a-foldlRL _ x NilRL = x-foldlRL f x (y:<:ys) = foldlRL f (f x y) ys--mapFL_FL :: (FORALL(w y) a C(w y) -> b C(w y)) -> FL a C(x z) -> FL b C(x z)-mapFL_FL _ NilFL = NilFL-mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as--zipWithFL :: (FORALL(x y) a -> p C(x y) -> q C(x y))-          -> [a] -> FL p C(w z) -> FL q C(w z)-zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys-zipWithFL _ _ NilFL = NilFL-zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list"--mapRL_RL :: (FORALL(w y) a C(w y) -> b C(w y)) -> RL a C(x z) -> RL b C(x z)-mapRL_RL _ NilRL = NilRL-mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as--mapFL :: (FORALL(w z) a C(w z) -> b) -> FL a C(x y) -> [b]-mapFL _ NilFL = []-mapFL f (a :>: b) = f a : mapFL f b--mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b]-mapRL _ NilRL = []-mapRL f (a :<: b) = f a : mapRL f b--unsafeMap_l2f :: (FORALL(w z) a -> b C(w z)) -> [a] -> FL b C(x y)-unsafeMap_l2f _ [] = unsafeCoerceP NilFL-unsafeMap_l2f f (x:xs) = f x :>: unsafeMap_l2f f xs--lengthFL :: FL a C(x z) -> Int-lengthFL xs = l xs 0-  where l :: FL a C(x z) -> Int -> Int-        l NilFL n = n-        l (_:>:as) n = l as $! n+1--lengthRL :: RL a C(x z) -> Int-lengthRL xs = l xs 0-  where l :: RL a C(x z) -> Int -> Int-        l NilRL n = n-        l (_:<:as) n = l as $! n+1--isShorterThanRL :: RL a C(x y) -> Int -> Bool-isShorterThanRL _ n | n <= 0 = False-isShorterThanRL NilRL _ = True-isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1)--concatReverseFL :: FL (RL a) C(x y) -> RL a C(x y)-concatReverseFL = concatRL . reverseFL--headRL :: RL a C(x y) -> FlippedSeal a C(y)-headRL (x:<:_) = flipSeal x-headRL _ = impossible--consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z)-consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as--#ifndef GADT_WITNESSES--- These are useful for interfacing with modules outside of--- patch theory, such as Show.lhs-unsafeUnFL :: FL a -> [a]-unsafeUnFL NilFL = []-unsafeUnFL (a:>:as) = a : unsafeUnFL as--unsafeUnRL :: RL a -> [a]-unsafeUnRL NilRL = []-unsafeUnRL (a:<:as) = a : unsafeUnRL as--unsafeFL :: [a] -> FL a-unsafeFL [] = NilFL-unsafeFL (a:as) = a :>: unsafeFL as--unsafeRL :: [a] -> RL a-unsafeRL [] = NilRL-unsafeRL (a:as) = a :<: unsafeRL as-#endif
src/Darcs/Patch.lhs view
@@ -45,7 +45,7 @@ module Darcs.Patch ( RepoPatch, Prim, Patch, RealPatch, Named, Patchy,                      flattenFL, joinPatches,                      fromPrim, fromPrims,-               is_null_patch, nullP,+               isNullPatch, nullP,                rmfile, addfile, rmdir, adddir, move,                hunk, tokreplace, namepatch, anonymous,                binary,@@ -53,32 +53,33 @@                showContextPatch, showPatch, showNicely,                infopatch, changepref,                thing, things,-               is_similar, is_addfile, is_hunk, is_setpref,+               isSimilar, primIsAddfile, primIsHunk, primIsSetpref, #ifndef GADT_WITNESSES-               merger, is_merger, merge,-               commute, commutex, list_touched_files,+               merger, isMerger, merge,+               commute, listTouchedFiles, hunkMatches,                -- for PatchTest-               unravel, elegant_merge,+               unravel, elegantMerge, #else                Commute(..), #endif-               resolve_conflicts,+               resolveConflicts,                Effect, effect,-               is_binary, gzWritePatch, writePatch, is_adddir,+               primIsBinary, gzWritePatch, writePatch, primIsAdddir,                invert, invertFL, invertRL, identity,                commuteFL, commuteRL,                readPatch,-               canonize, sort_coalesceFL,-               try_to_shrink,-               apply_to_slurpy, patchname, patchcontents,-               apply_to_filepaths, force_replace_slurpy, apply,+               canonize, sortCoalesceFL,+               tryToShrink,+               applyToSlurpy, patchname, patchcontents,+               applyToFilepaths, forceReplaceSlurpy, apply,+               applyToTree,                patch2patchinfo,                LineMark(AddedLine, RemovedLine, AddedRemovedLine, None),-               MarkedUpFile, markup_file, empty_markedup_file,-               summary, summarize, xml_summary,+               MarkedUpFile, markupFile, emptyMarkedupFile,+               summary, plainSummary, xmlSummary,                adddeps, getdeps,-               list_conflicted_files,-               modernize_patch,+               listConflictedFiles,+               modernizePatch,                -- for Population                DirMark(..), patchChanges, applyToPop,              ) where@@ -88,10 +89,10 @@                           adddeps, namepatch,                           anonymous, #ifndef GADT_WITNESSES-                          is_merger,+                          isMerger, #endif                           getdeps,-                          is_null_patch, nullP, infopatch,+                          isNullPatch, nullP, infopatch,                           patch2patchinfo, patchname, patchcontents ) import Darcs.Patch.Read ( readPatch ) import Darcs.Patch.Patchy ( Patchy, writePatch, gzWritePatch,@@ -101,33 +102,33 @@                             commuteFL, commuteRL, apply,                             description, summary, #ifndef GADT_WITNESSES-                            commute, commutex, list_touched_files,+                            commute, listTouchedFiles, hunkMatches, #else                             Commute(..) #endif                           )-import Darcs.Patch.Viewing ( xml_summary, summarize )-import Darcs.Patch.Apply ( applyToPop, patchChanges, empty_markedup_file,-                           markup_file, force_replace_slurpy,-                           apply_to_filepaths, apply_to_slurpy,-                           LineMark(..), MarkedUpFile )-import Darcs.Patch.Commute ( modernize_patch,+import Darcs.Patch.Viewing ( xmlSummary, plainSummary )+import Darcs.Patch.Apply ( applyToPop, patchChanges, emptyMarkedupFile,+                           markupFile, forceReplaceSlurpy,+                           applyToFilepaths, applyToSlurpy,+                           LineMark(..), MarkedUpFile, applyToTree )+import Darcs.Patch.Commute ( modernizePatch, #ifndef GADT_WITNESSES                              unravel,-                             merger, merge, elegant_merge,+                             merger, merge, elegantMerge, #endif                             ) import Darcs.Patch.Prim ( FromPrims, fromPrims, joinPatches, FromPrim, fromPrim,-                          Conflict, Effect(effect), list_conflicted_files, resolve_conflicts,+                          Conflict, Effect(effect), listConflictedFiles, resolveConflicts,                           Prim, canonize,-                          sort_coalesceFL,+                          sortCoalesceFL,                           rmdir, rmfile, tokreplace, adddir, addfile,                           binary, changepref, hunk, move, -                          is_adddir, is_addfile,-                          is_hunk, is_binary, is_setpref,-                          is_similar,-                          try_to_shrink )-import Darcs.Ordered ( FL )+                          primIsAdddir, primIsAddfile,+                          primIsHunk, primIsBinary, primIsSetpref,+                          isSimilar,+                          tryToShrink )+import Darcs.Witnesses.Ordered ( FL ) import Darcs.Patch.Real ( RealPatch )  instance Patchy Patch
src/Darcs/Patch/Apply.lhs view
@@ -22,13 +22,14 @@  #include "gadts.h" -module Darcs.Patch.Apply ( apply_to_filepaths, apply_to_slurpy,+module Darcs.Patch.Apply ( applyToFilepaths, applyToSlurpy,                            forceTokReplace,-                           markup_file, empty_markedup_file,+                           markupFile, emptyMarkedupFile,                            patchChanges,                            applyToPop,+                           applyToTree,                            LineMark(..), MarkedUpFile,-                           force_replace_slurpy )+                           forceReplaceSlurpy )     where  import Prelude hiding ( catch, pi )@@ -54,14 +55,17 @@ import Darcs.Patch.Info ( PatchInfo ) import Control.Monad ( when ) import Darcs.SlurpDirectory ( FileContents, Slurpy, withSlurpy, slurp_modfile )-import RegChars ( regChars )-import Darcs.Repository.Prefs ( change_prefval )+import Darcs.Patch.RegChars ( regChars )+import Darcs.Repository.Prefs ( changePrefval ) import Darcs.Global ( darcsdir ) import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) ) import Darcs.FilePathMonad ( withFilePaths ) #include "impossible.h"-import Darcs.Ordered ( FL(..), (:>)(..),+import Darcs.Witnesses.Ordered ( FL(..), (:>)(..),                              mapFL, mapFL_FL, spanFL, foldlFL )++import Storage.Hashed.Tree( Tree )+import Storage.Hashed.Monad( virtualTreeIO ) \end{code}  @@ -107,11 +111,11 @@   \begin{code}-apply_to_filepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath]-apply_to_filepaths pa fs = withFilePaths fs (apply [] pa)+applyToFilepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath]+applyToFilepaths pa fs = withFilePaths fs (apply [] pa) -apply_to_slurpy :: (Apply p, Monad m) => p C(x y) -> Slurpy -> m Slurpy-apply_to_slurpy p s = case withSlurpy s (apply [] p) of+applyToSlurpy :: (Apply p, Monad m) => p C(x y) -> Slurpy -> m Slurpy+applyToSlurpy p s = case withSlurpy s (apply [] p) of                           Left err -> fail err                           Right (s', ()) -> return s' @@ -127,10 +131,10 @@     applyAndTryToFix (ComP xs) = mapMaybeSnd ComP `fmap` applyAndTryToFix xs     applyAndTryToFix x = do mapMaybeSnd ComP `fmap` applyAndTryToFixFL x -force_replace_slurpy :: Prim C(x y) -> Slurpy -> Maybe Slurpy-force_replace_slurpy (FP f (TokReplace tcs old new)) s =+forceReplaceSlurpy :: Prim C(x y) -> Slurpy -> Maybe Slurpy+forceReplaceSlurpy (FP f (TokReplace tcs old new)) s =     slurp_modfile f (forceTokReplace tcs old new) s-force_replace_slurpy _ _ = bug "Can only force_replace_slurpy on a replace."+forceReplaceSlurpy _ _ = bug "Can only forceReplaceSlurpy on a replace."  instance Apply Prim where     apply opts (Split ps) = applyFL opts ps@@ -154,7 +158,7 @@     apply _ (Move f f') = mRename f f'     apply _ (ChangePref p f t) =         do b <- mDoesDirectoryExist (fp2fn $ darcsdir++"/prefs")-           when b $ change_prefval p f t+           when b $ changePrefval p f t     applyAndTryToFixFL (FP f RmFile) =         do x <- mReadFilePS f            if B.null x then do mRemoveFile f@@ -296,12 +300,12 @@               | AddedRemovedLine PatchInfo PatchInfo | None                 deriving (Show) type MarkedUpFile = [(B.ByteString, LineMark)]-empty_markedup_file :: MarkedUpFile-empty_markedup_file = [(B.empty, None)]+emptyMarkedupFile :: MarkedUpFile+emptyMarkedupFile = [(B.empty, None)] -markup_file :: Effect p => PatchInfo -> p C(x y)+markupFile :: Effect p => PatchInfo -> p C(x y)             -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)-markup_file x p = mps (effect p)+markupFile x p = mps (effect p)     where mps :: FL Prim C(a b) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)           mps NilFL = id           mps (pp:>:pps) = mps pps . markup_prim x pp@@ -518,5 +522,10 @@ pname :: PopTree -> B.ByteString pname (PopDir i _) = nameI i pname (PopFile i) = nameI i++-- | Apply a patch to a 'Tree', yielding a new 'Tree'.+applyToTree :: (Apply p) => p C(x y) -> Tree IO -> IO (Tree IO)+applyToTree patch t = snd `fmap` virtualTreeIO (apply [] patch) t+ \end{code}
src/Darcs/Patch/Bundle.hs view
@@ -24,31 +24,33 @@                      make_context, scan_context,                    ) where -import Darcs.Flags ( DarcsFlag( Unified ) )+import Darcs.Flags ( DarcsFlag, isUnified ) import Darcs.Hopefully ( PatchInfoAnd, piap,                          patchInfoAndPatch,                          unavailable, hopefully ) import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatch ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly, is_tag ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet )-import Darcs.Ordered ( RL(..), FL(..), unsafeCoerceP,+import Darcs.Witnesses.Ordered ( RL(..), FL(..), unsafeCoerceP,                              reverseFL, (+<+), mapFL, mapFL_FL ) import Printer ( Doc, renderPS, newline, text, ($$),                  (<>), vcat, vsep, renderString )-import Darcs.SlurpDirectory ( Slurpy )  import ByteStringUtils ( linesPS, unlinesPS, dropSpace, substrPS) import qualified Data.ByteString as B (ByteString, length, null, drop, isPrefixOf) import qualified Data.ByteString.Char8 as BC (unpack, break, pack)  import SHA1( sha1PS )-import Darcs.Sealed ( Sealed(Sealed), mapSeal )+import Darcs.Witnesses.Sealed ( Sealed(Sealed), mapSeal ) +import Storage.Hashed.Tree( Tree )+import Storage.Hashed.Monad( virtualTreeIO )+ hash_bundle :: RepoPatch p => [PatchInfo] -> FL (Named p) C(x y) -> String hash_bundle _ to_be_sent = sha1PS $ renderPS                          $ vcat (mapFL showPatch to_be_sent) <> newline -make_bundle :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] -> FL (Named p) C(x y) -> Doc+make_bundle :: RepoPatch p => [DarcsFlag] -> Tree IO -> [PatchInfo] -> FL (Named p) C(x y) -> IO Doc make_bundle opts the_s common to_be_sent = make_bundle2 opts the_s common to_be_sent to_be_sent  -- | In make_bundle2, it is presumed that the two patch sequences are@@ -56,23 +58,24 @@ -- 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.-make_bundle2 :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo]-             -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> Doc+make_bundle2 :: RepoPatch p => [DarcsFlag] -> Tree IO -> [PatchInfo]+             -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> IO Doc make_bundle2 opts the_s common to_be_sent to_be_sent2 =-    text ""- $$ text "New patches:"- $$ text ""- $$ the_new- $$ text ""- $$ text "Context:"- $$ text ""- $$ (vcat $ map showPatchInfo common)- $$ text "Patch bundle hash:"- $$ text (hash_bundle common to_be_sent2)- $$ text ""-      where the_new = if Unified `elem` opts-                      then showContextPatch the_s to_be_sent-                      else vsep $ mapFL showPatch to_be_sent+    do patches <- case (isUnified opts) of+                    True -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) the_s+                    False -> return (vsep $ mapFL showPatch to_be_sent)+       return $ format patches+    where format the_new = text ""+                           $$ text "New patches:"+                           $$ text ""+                           $$ the_new+                           $$ text ""+                           $$ text "Context:"+                           $$ text ""+                           $$ (vcat $ map showPatchInfo common)+                           $$ text "Patch bundle hash:"+                           $$ text (hash_bundle common to_be_sent2)+                           $$ text ""  scan_bundle :: RepoPatch p => B.ByteString -> Either String (SealedPatchSet p) scan_bundle ps@@ -84,7 +87,7 @@         (Sealed patches, rest') ->             case silly_lex rest' of             ("Context:", rest'') ->-                case get_context rest'' of+                case getContext rest'' of                 (cont,maybe_hash) ->                     case substrPS (BC.pack "Patch bundle hash:")                          maybe_hash of@@ -102,7 +105,7 @@             (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'"                      ++ "\n" ++ BC.unpack r     ("Context:",rest) ->-        case get_context rest of+        case getContext rest of         (cont, rest') ->             case silly_lex rest' of             ("New patches:", rest'') ->@@ -153,11 +156,11 @@ pi_unavailable i = (i `patchInfoAndPatch`                       unavailable ("Patch not stored in patch bundle:\n" ++                                    renderString (human_friendly i)))-get_context :: B.ByteString -> ([PatchInfo],B.ByteString)-get_context ps =+getContext :: B.ByteString -> ([PatchInfo],B.ByteString)+getContext ps =     case readPatchInfo ps of     Just (pinfo,r') ->-        case get_context r' of+        case getContext r' of         (pis,r'') -> (pinfo:pis, r'')     Nothing -> ([],ps) (-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b)@@ -204,7 +207,7 @@   | otherwise =     case silly_lex ps of     ("Context:",rest) ->-        case get_context rest of+        case getContext rest of         (cont, _) -> unavailable_patches cont :<: NilRL     ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->             scan_context $ filter_gpg_dashes rest
− src/Darcs/Patch/Check.hs 
@@ -1,335 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists,-                    remove_file, remove_dir, create_file, create_dir,-                    insert_line, delete_line, is_valid, do_verbose_check,-                    file_empty,-                    check_move, modify_file, FileContents(..)-                  ) where--import System.IO.Unsafe ( unsafePerformIO )-import qualified Data.ByteString as B (ByteString)-import Data.List ( isPrefixOf, inits )-import Control.Monad.State ( State, evalState, runState )-import Control.Monad.State.Class ( get, put, modify )--- use Map, not IntMap, because Map has mapKeys and IntMap hasn't-import Data.Map ( Map )-import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null )-import System.FilePath ( joinPath, splitDirectories )---- | File contents are represented by a map from line numbers to line contents.---   If for a certain line number, the line contents are Nothing, that means---   that we are sure that that line exists, but we don't know its contents.---   We must also store the greatest line number that is known to exist in a---   file, to be able to exclude the possibility of it being empty without---   knowing its contents.-data FileContents = FC { fc_lines   :: Map Int B.ByteString-                       , fc_maxline :: Int-                       } deriving (Eq, Show)-data Prop = FileEx String | DirEx String | NotEx String-          | FileLines String FileContents-            deriving (Eq)--- | A @KnownState@ is a simulated repository state. The repository is either--- inconsistent, or it has two lists of properties: one list with properties--- that hold for this repo, and one with properties that do not hold for this--- repo. These two lists may not have any common elements: if they had, the--- repository would be inconsistent.-data KnownState = P [Prop] [Prop]-                | Inconsistent-                  deriving (Show)-instance  Show Prop  where-    show (FileEx f) = "FileEx "++f-    show (DirEx d)  = "DirEx "++d-    show (NotEx f) = "NotEx"++f-    show (FileLines f l)  = "FileLines "++f++": "++show l---- | PatchCheck is a state monad with a simulated repository state-type PatchCheck = State KnownState---- | The @FileContents@ structure for an empty file-empty_filecontents :: FileContents-empty_filecontents = FC M.empty 0---- | Returns a given value if the repository state is inconsistent, and performs---   a given action otherwise.-handle_inconsistent :: a            -- ^ The value to return if the state is inconsistent-                   -> PatchCheck a -- ^ The action to perform otherwise-                   -> PatchCheck a-handle_inconsistent v a = do state <- get-                             case state of-                               Inconsistent -> return v-                               _            -> a--do_check :: PatchCheck a -> a-do_check p = evalState p (P [] [])---- | Run a check, and print the final repository state-do_verbose_check :: PatchCheck a -> a-do_verbose_check p =-    case runState p (P [] []) of-    (b, pc) -> unsafePerformIO $ do putStrLn $ show pc-                                    return b---- | Returns true if the current repository state is not inconsistent-is_valid :: PatchCheck Bool-is_valid = handle_inconsistent False (return True)--has :: Prop -> [Prop] -> Bool-has _ [] = False-has k (k':ks) = k == k' || has k ks--modify_file :: String-            -> (Maybe FileContents -> Maybe FileContents)-            -> PatchCheck Bool-modify_file f change = do-    file_exists f-    c <- file_contents f-    case change c of-      Nothing -> assert_not $ FileEx f -- shorthand for "FAIL"-      Just c' -> do set_contents f c'-                    is_valid--insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool-insert_line f n l = do-    c <- file_contents f-    case c of-      Nothing -> assert_not $ FileEx f -- in this case, the repo is inconsistent-      Just c' -> do-        let lines'   = M.mapKeys (\k -> if k >= n then k+1 else k) (fc_lines c')-            lines''  = M.insert n l lines'-            maxline' = max n (fc_maxline c')-        set_contents f (FC lines'' maxline')-        return True---- deletes a line from a hunk patch (third argument) in the given file (first--- argument) at the given line number (second argument)-delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool-delete_line f n l = do-    c <- file_contents f-    case c of-      Nothing -> assert_not $ FileEx f-      Just c' ->-        let flines  = fc_lines c'-            flines' = M.mapKeys (\k -> if k > n then k-1 else k)-                                (M.delete n flines)-            maxlinenum' | n <= fc_maxline c'  = fc_maxline c' - 1-                        | otherwise           = n - 1-            c'' = FC flines' maxlinenum'-            do_delete = do-              set_contents f c''-              is_valid-        in case M.lookup n flines of-          Nothing -> do_delete-          Just l' -> if l == l'-                       then do_delete-                       else assert_not $ FileEx f--set_contents :: String -> FileContents -> PatchCheck ()-set_contents f c = handle_inconsistent () $ do-    P ks nots <- get-    let ks' = FileLines f c : filter (not . is_file_lines_for f) ks-    put (P ks' nots)-  where is_file_lines_for file prop = case prop of -                                        FileLines f' _ -> file == f'-                                        _              -> False---- | Get (as much as we know about) the contents of a file in the current state.---   Returns Nothing if the state is inconsistent.-file_contents :: String -> PatchCheck (Maybe FileContents)-file_contents f = handle_inconsistent Nothing $ do-      P ks _ <- get-      return (fic ks)-    where fic (FileLines f' c:_) | f == f' = Just c-          fic (_:ks) = fic ks-          fic [] = Just empty_filecontents---- | Checks if a file is empty-file_empty :: String          -- ^ Name of the file to check-           -> PatchCheck Bool-file_empty f = do-  c <- file_contents f-  let empty = case c of-               Just c' -> fc_maxline c' == 0 && M.null (fc_lines c')-               Nothing -> True-  if empty-     then do set_contents f empty_filecontents-             is_valid-     -- Crude way to make it inconsistent and return false:-     else assert_not $ FileEx f-  return empty--movedirfilename :: String -> String -> String -> String-movedirfilename d d' f =-    if (d ++ "/") `isPrefixOf` f-    then d'++drop (length d) f-    else if f == d-         then d'-         else f---- | Replaces a filename by another in all paths. Returns True if the repository---   is consistent, False if it is not.-do_swap :: String -> String -> PatchCheck Bool-do_swap f f' = handle_inconsistent False $ do-    modify (\(P ks nots) -> P (map sw ks) (map sw nots))-    return True-  where sw (FileEx a) | f  `is_soe` a = FileEx $ movedirfilename f f' a-                      | f' `is_soe` a = FileEx $ movedirfilename f' f a-        sw (DirEx a) | f  `is_soe` a = DirEx $ movedirfilename f f' a-                     | f' `is_soe` a = DirEx $ movedirfilename f' f a-        sw (FileLines a c) | f  `is_soe` a = FileLines (movedirfilename f f' a) c-                           | f' `is_soe` a = FileLines (movedirfilename f' f a) c-        sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a-                     | f' `is_soe` a = NotEx $ movedirfilename f' f a-        sw p = p-        is_soe d1 d2 = -- is_superdir_or_equal-            d1 == d2 || (d1 ++ "/") `isPrefixOf` d2---- | Assert a property about the repository. If the property is already present--- in the repo state, nothing changes, and the function returns True. If it is--- not present yet, it is added to the repo state, and the function is True. If--- the property is already in the list of properties that do not hold for the--- repo, the state becomes inconsistent, and the function returns false.-assert :: Prop -> PatchCheck Bool-assert p = handle_inconsistent False $ do-    P ks nots <- get-    if has p nots-      then do-        put Inconsistent-        return False-      else if has p ks-             then return True-             else do-               put (P (p:ks) nots)-               return True---- | Like @assert@, but negatively: state that some property must not hold for---   the current repo.-assert_not :: Prop -> PatchCheck Bool-assert_not p = handle_inconsistent False $ do-    P ks nots <- get-    if has p ks-      then do-        put Inconsistent-        return False-      else if has p nots-             then return True-             else do-               put (P ks (p:nots))-               return True---- | Remove a property from the list of properties that do not hold for this--- repo (if it's there), and add it to the list of properties that hold.--- Returns False if the repo is inconsistent, True otherwise.-change_to_true :: Prop -> PatchCheck Bool-change_to_true p = handle_inconsistent False $ do-    modify (\(P ks nots) -> P (p:ks) (filter (p /=) nots))-    return True---- | Remove a property from the list of properties that hold for this repo (if--- it's in there), and add it to the list of properties that do not hold.--- Returns False if the repo is inconsistent, True otherwise.-change_to_false :: Prop -> PatchCheck Bool-change_to_false p = handle_inconsistent False $ do-    modify (\(P ks nots) -> P (filter (p /=) ks) (p:nots))-    return True--assert_file_exists :: String -> PatchCheck Bool-assert_file_exists f = do assert_not $ NotEx f-                          assert_not $ DirEx f-                          assert $ FileEx f-assert_dir_exists :: String -> PatchCheck Bool-assert_dir_exists d = do assert_not $ NotEx d-                         assert_not $ FileEx d-                         assert $ DirEx d-assert_exists :: String -> PatchCheck Bool-assert_exists f = assert_not $ NotEx f--assert_no_such :: String -> PatchCheck Bool-assert_no_such f = do assert_not $ FileEx f-                      assert_not $ DirEx f-                      assert $ NotEx f--create_file :: String -> PatchCheck Bool-create_file fn = do-  superdirs_exist fn-  assert_no_such fn-  change_to_true (FileEx fn)-  change_to_false (NotEx fn)--create_dir :: String -> PatchCheck Bool-create_dir fn = do-  substuff_dont_exist fn-  superdirs_exist fn-  assert_no_such fn-  change_to_true (DirEx fn)-  change_to_false (NotEx fn)--remove_file :: String -> PatchCheck Bool-remove_file fn = do-  superdirs_exist fn-  assert_file_exists fn-  file_empty fn-  change_to_false (FileEx fn)-  change_to_true (NotEx fn)--remove_dir :: String -> PatchCheck Bool-remove_dir fn = do-  substuff_dont_exist fn-  superdirs_exist fn-  assert_dir_exists fn-  change_to_false (DirEx fn)-  change_to_true (NotEx fn)--check_move :: String -> String -> PatchCheck Bool-check_move f f' = do-  superdirs_exist f-  superdirs_exist f'-  assert_exists f-  assert_no_such f'-  do_swap f f'--substuff_dont_exist :: String -> PatchCheck Bool-substuff_dont_exist d = handle_inconsistent False $ do-    P ks _ <- get-    if all noss ks-      then return True-      else do-        put Inconsistent-        return False-  where noss (FileEx f) = not (is_within_dir f)-        noss (DirEx f) = not (is_within_dir f)-        noss _ = True-        is_within_dir f = (d ++ "/") `isPrefixOf` f---- the init and tail calls dump the final init (which is just the path itself--- again), the first init (which is empty), and the initial "." from--- splitDirectories-superdirs_exist :: String -> PatchCheck Bool-superdirs_exist fn = and `fmap` mapM assert_dir_exists superdirs-  where superdirs =  map (("./"++) . joinPath) -                         (init (tail (inits (tail (splitDirectories fn)))))--file_exists :: String -> PatchCheck Bool-file_exists fn = do-  superdirs_exist fn-  assert_file_exists fn--dir_exists :: String -> PatchCheck Bool-dir_exists fn = do-  superdirs_exist fn-  assert_dir_exists fn
src/Darcs/Patch/Choices.hs view
@@ -29,7 +29,7 @@ -- type and associated functions are here to deal with many of the common -- cases that come up when choosing a subset of a group of patches. ----- 'force_last' tells PatchChoices that a particular patch is required to be in+-- 'forceLast' tells PatchChoices that a particular patch is required to be in -- the "last" group, which also means that any patches that depend on it -- must be in the "last" group. --@@ -40,17 +40,19 @@ -- about the first-middle-last language, it's because in some cases the -- "yes" answers will be last (as is the case for the revert command), and -- in others first (as in record, pull and push).-module Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps,-                      patch_slot,-                      get_choices,-                      separate_first_middle_from_last,-                      separate_first_from_middle_last,-                      force_first, force_firsts, force_last, force_lasts,-                      force_matching_first, force_matching_last,-                      select_all_middles,-                      make_uncertain, make_everything_later,-                      TaggedPatch, Tag, tag, tp_patch,+module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps,+                             patchChoicesTpsSub,+                      patchSlot,+                      getChoices,+                      separateFirstMiddleFromLast,+                      separateFirstFromMiddleLast,+                      forceFirst, forceFirsts, forceLast, forceLasts,+                      forceMatchingFirst, forceMatchingLast,+                      selectAllMiddles,+                      makeUncertain, makeEverythingLater,+                      TaggedPatch, Tag, tag, tpPatch,                              Slot(..),+                      substitute,                     ) where  import System.IO.Unsafe ( unsafePerformIO )@@ -58,55 +60,86 @@ import Darcs.Patch import Darcs.Patch.Permutations ( commuteWhatWeCanRL ) import Darcs.Patch.Patchy ( Invert, Commute )-import Darcs.Ordered ( FL(..), RL(..), MyEq, unsafeCompare,-                             (:>)(..), (:\/:)(..), (:/\:)(..),-                             zipWithFL, mapFL_FL, mapFL,+import Darcs.Witnesses.Ordered ( FL(..), RL(..), MyEq, unsafeCompare, EqCheck(..),+                             (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),+                             zipWithFL, mapFL_FL, mapFL, concatFL,                              (+>+), reverseRL, unsafeCoerceP )+import Darcs.Witnesses.Sealed ( Sealed2(..) )  -newtype Tag = TG Integer deriving ( Num, Show, Eq, Ord, Enum )+-- | 'TG' @mp i@ acts as a temporary identifier to help us keep track of patches+--   during the selection process.  These are useful for finding patches that+--   may have moved around during patch selection (being pushed forwards or+--   backwards as dependencies arise).+--+--   The identifier is implemented as a tuple @TG mp i@. The @i@ is just some+--   arbitrary label, expected to be unique within the patches being+--   scrutinised.  The @mp@ is motivated by patch splitting; it+--   provides a convenient way to generate a new identifier from the patch+--   being split.  For example, if we split a patch identified as @TG Nothing+--   5@, the resulting sub-patches could be identified as @TG (TG Nothing 5)+--   1@, @TG (TG Nothing 5) 2@, etc.+data Tag = TG (Maybe Tag) Integer deriving ( Eq, Ord ) data TaggedPatch p C(x y) = TP Tag (p C(x y))+ data PatchChoice p C(x y) = PC (TaggedPatch p C(x y)) Slot newtype PatchChoices p C(x y) = PCs (FL (PatchChoice p) C(x y)) +-- | See module documentation for 'Darcs.Patch.Choices' data Slot = InFirst | InMiddle | InLast +negTag :: Tag -> Tag+negTag (TG k n) = TG k (-n)+ invertTag :: Slot -> Slot invertTag InFirst = InLast invertTag InLast  = InFirst invertTag t = t  tag :: TaggedPatch p C(x y) -> Tag-tag (TP (TG t) _) = TG t+tag (TP tg _) = tg -tp_patch :: TaggedPatch p C(x y) -> p C(x y)-tp_patch (TP _ p) = p+tpPatch :: TaggedPatch p C(x y) -> p C(x y)+tpPatch (TP _ p) = p  liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b)) liftTP f (TP t p) = TP t (f p) +-- This is dangerous if two patches from different tagged series are compared+-- ideally Tag (and hence TaggedPatch/PatchChoices) would have a witness type+-- to represent the originally tagged sequence.+compareTags :: TaggedPatch p C(a b) -> TaggedPatch p C(c d) -> EqCheck C((a, b) (c, d))+compareTags (TP t1 _) (TP t2 _) = if t1 == t2 then unsafeCoerceP IsEq else NotEq+ instance MyEq p => MyEq (TaggedPatch p) where     unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2  instance Invert p => Invert (TaggedPatch p) where     invert = liftTP invert-    identity = TP (-1) identity+    identity = TP (TG Nothing (-1)) identity  instance Commute p => Commute (TaggedPatch p) where     commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2)                                         return (TP t2 p2' :> TP t1 p1')-    list_touched_files (TP _ p) = list_touched_files p+    listTouchedFiles (TP _ p) = listTouchedFiles p+    hunkMatches f (TP _ p) = hunkMatches f p     merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of                                      p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1' -patch_choices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y)-patch_choices = fst . patch_choices_tps+patchChoices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y)+patchChoices = fst . patchChoicesTps -patch_choices_tps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))-patch_choices_tps ps = let tps = zipWithFL TP [1..] ps-                       in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps)+-- |Tag a sequence of patches as subpatches of an existing tag. This is intended for+-- use when substituting a patch for an equivalent patch or patches.+patchChoicesTpsSub :: Patchy p+                      => Maybe Tag -> FL p C(x y)+                      -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))+patchChoicesTpsSub tg ps = let tps = zipWithFL TP (map (TG tg) [1..]) ps+                              in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps) -make_everything_later :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)+-- |Tag a sequence of patches.+patchChoicesTps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))+patchChoicesTps = patchChoicesTpsSub Nothing  instance MyEq p => MyEq (PatchChoice p) where     unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2@@ -122,26 +155,41 @@     merge (PC t1 x1 :\/: PC t2 x2)         = case merge (t1 :\/: t2) of           t2' :/\: t1' -> PC t2' x2 :/\: PC t1' x1-    list_touched_files (PC t _) = list_touched_files t+    listTouchedFiles (PC t _) = listTouchedFiles t+    hunkMatches f (PC t _) = hunkMatches f t  invertSeq :: (Invert p, Invert q) => (p :> q) C(x y) -> (q :> p) C(y x) invertSeq (x :> y) = (invert y :> invert x) -separate_first_from_middle_last :: Patchy p => PatchChoices p C(x z)+separateFirstFromMiddleLast :: Patchy p => PatchChoices p C(x z)                                 -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)-separate_first_from_middle_last (PCs e) = pull_only_firsts e+separateFirstFromMiddleLast (PCs e) = pull_only_firsts e -separate_first_middle_from_last :: Patchy p => PatchChoices p C(x z)+separateFirstMiddleFromLast :: Patchy p => PatchChoices p C(x z)                                 -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)-separate_first_middle_from_last (PCs e) = pull_firsts_middles e+separateFirstMiddleFromLast (PCs e) = pull_firsts_middles e -get_choices :: Patchy p => PatchChoices p C(x y)+getChoices :: Patchy p => PatchChoices p C(x y)             -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)-get_choices (PCs e) = case pull_firsts e of+getChoices (PCs e) = case pull_firsts e of                       f :> ml -> case pull_firsts (invert ml) of                                  l :> m -> f :> mapFL_FL pc2tp (invert m) :> invert l   where pc2tp (PC tp _) = tp +{-+This unsafePerformIO hack was reported by Igloo as being necessary for+constant space performance when working with a very large set of changes+(e.g. from an initial import) where the second element of the returned tuple+is expected to be small, and will only be accessed after the entire first+element has been forced.+On a quick scan on 20080729 it seemed like only revert/unrevert actually+make use of both elements of the tuple.+We should (a) add a test case that checks on constant space usage and+(b) clean up this interface and code, perhaps by replacing the FL :> FL+with a custom structure that forces traversal of the first element to+get at the second (but then how would we commute/pattern-match? messy...)+-}+ pull_firsts_middles :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) pull_firsts_middles easyPC =     let r = unsafePerformIO@@ -214,21 +262,23 @@     Just (TP t2 p2 :> e') ->         case commute (p:>p2) of         Just (p2':>p') -> Just (TP t2 p2' :> (PC (TP t p') InMiddle:>:e'))-        Nothing -> Just (tp :> PC (TP (-t2) p2) InFirst:>:e')+        Nothing -> Just (tp :> PC (TP (negTag t2) p2) InFirst:>:e')     Nothing -> Nothing -patch_slot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot-patch_slot tp (PCs e) = ipf e+patchSlot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot+patchSlot tp (PCs e) = ipf e   where ipf :: FL (PatchChoice p) C(u v) -> Slot         ipf (PC a mb:>:e') | tag a == tag tp = mb                            | otherwise = ipf e'         -- actually, the following should be impossible, but this is a reasonable answer         ipf NilFL = InLast -set_simplys :: [Tag] -> Bool -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y)-set_simplys ts b e = mapFL_FL ch e+-- | 'setSimplys' @ts s ps@ assigns all patches in @ps@ with a tag in @ts@ to slot @s@+--   (and any other patch to slot 'InMiddle')+setSimplys :: [Tag] -> Slot -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y)+setSimplys ts s e = mapFL_FL ch e     where ch (PC tp@(TP t _) _)-           | t `elem` ts = PC tp (if b then InFirst else InLast)+           | t `elem` ts = PC tp s            | otherwise   = PC tp InMiddle  @@ -238,55 +288,69 @@  | otherwise = m2ids m e m2ids _ NilFL = [] -force_matching_first :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)+forceMatchingFirst :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)                      -> PatchChoices p C(a b) -> PatchChoices p C(a b)-force_matching_first m (PCs e) =+forceMatchingFirst m (PCs e) =     let thd (PC (TP t _) _) = t         xs = m2ids m e-        not_needed = case pull_firsts $ set_simplys xs True e of+        not_needed = case pull_firsts $ setSimplys xs InFirst e of                      _ :> rest -> mapFL thd rest         ch pc@(PC tp@(TP t _) _)          | t `elem` not_needed = pc          | otherwise = PC tp InFirst     in PCs $ mapFL_FL ch e -force_firsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)-force_firsts ps pc = force_matching_first ((`elem` ps) . tag) pc+forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+forceFirsts ps pc = forceMatchingFirst ((`elem` ps) . tag) pc -force_first :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)-force_first p pc = force_matching_first ((== p) . tag) pc+forceFirst :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)+forceFirst p pc = forceMatchingFirst ((== p) . tag) pc -select_all_middles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y)-select_all_middles b (PCs e) = PCs (mapFL_FL f e)+selectAllMiddles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y)+selectAllMiddles b (PCs e) = PCs (mapFL_FL f e)     where f (PC tp InMiddle) = PC tp (if b then InLast else InFirst)           f pc = pc  reverse_pc :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(y x) reverse_pc (PCs e) = PCs $ invert e -force_matching_last :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)+forceMatchingLast :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)                     -> PatchChoices p C(a b) -> PatchChoices p C(a b)-force_matching_last m (PCs e) =+forceMatchingLast m (PCs e) =     let thd (PC (TP t _) _) = t         xs = m2ids m e-        not_needed = case pull_lasts $ set_simplys xs False e of+        not_needed = case pull_lasts $ setSimplys xs InLast e of                      rest :> _ -> mapFL thd rest         ch pc@(PC tp@(TP t _) _)          | t `elem` not_needed = pc          | otherwise = PC tp InLast     in PCs $ mapFL_FL ch e -force_last :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)-force_last p pc = reverse_pc $ force_first p $ reverse_pc pc+forceLast :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)+forceLast p pc = reverse_pc $ forceFirst p $ reverse_pc pc -force_lasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)-force_lasts ps pc = reverse_pc $ force_firsts ps $ reverse_pc pc+forceLasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+forceLasts ps pc = reverse_pc $ forceFirsts ps $ reverse_pc pc -make_uncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)-make_uncertain t (PCs e) = PCs $ mapFL_FL ch e+makeUncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)+makeUncertain t (PCs e) = PCs $ mapFL_FL ch e     where ch pc@(PC x _) = if t == tag x then PC x InMiddle else pc -make_everything_later (PCs e) = PCs $ mapFL_FL ch e+makeEverythingLater :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)+makeEverythingLater (PCs e) = PCs $ mapFL_FL ch e     where ch (PC tp InMiddle) = PC tp InLast           ch (PC tp InFirst)  = PC tp InMiddle           ch x = x++-- | 'substitute' @(a :||: bs)@ @pcs@ replaces @a@ with @bs@ in @pcs@ preserving the choice+--   associated with @a@+substitute :: forall p C(x y)+            . Patchy p+           => Sealed2 (TaggedPatch p :||: FL (TaggedPatch p))+           -> PatchChoices p C(x y)+           -> PatchChoices p C(x y)+substitute (Sealed2 (tp :||: new_tps)) (PCs pcs) = PCs (concatFL (mapFL_FL translate pcs))+   where translate :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b)+         translate (PC tp' c)+             | IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps+             | otherwise = PC tp' c :>: NilFL
src/Darcs/Patch/Commute.lhs view
@@ -24,9 +24,9 @@ #include "gadts.h"  module Darcs.Patch.Commute ( fromPrims,-                             modernize_patch,+                             modernizePatch, #ifndef GADT_WITNESSES-                             merge, elegant_merge,+                             merge, elegantMerge,                              merger, unravel, #endif                              public_unravel, mangle_unravelled,@@ -40,23 +40,23 @@  import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn ) import Darcs.Patch.Info ( invert_name, idpatchinfo )-import Darcs.Patch.Patchy ( Commute(..), Invert(..) )+import Darcs.Patch.Patchy ( Commute(..), Invert(..), toFwdCommute, toRevCommute ) import Darcs.Patch.Core ( Patch(..), Named(..), #ifndef GADT_WITNESSES                           flattenFL,-                          is_merger,+                          isMerger, #endif                           merger_undo,                           join_patchesFL ) import Darcs.Patch.Prim ( Prim(..), FromPrims(..),                           Conflict(..), Effect(..),-                          is_filepatch, sort_coalesceFL,+                          is_filepatch, sortCoalesceFL, #ifndef GADT_WITNESSES                           FilePatchType(..), DirPatchType(..), #else                           FilePatchType(Hunk), #endif-                          is_hunk, modernizePrim )+                          primIsHunk, modernizePrim ) import qualified Data.ByteString.Char8 as BC (pack, last) import qualified Data.ByteString       as B (null, ByteString) import Data.Maybe ( isJust )@@ -67,12 +67,12 @@ import Darcs.Patch.Patchy ( invertRL ) import Darcs.Patch.Show ( showPatch_ ) import Data.List ( nubBy )-import Darcs.Sealed ( unsafeUnseal )+import Darcs.Witnesses.Sealed ( unsafeUnseal ) #endif import Darcs.Utils ( nubsort ) #include "impossible.h"-import Darcs.Sealed ( Sealed(..), mapSeal )-import Darcs.Ordered ( mapFL, mapFL_FL, unsafeCoerceP,+import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal )+import Darcs.Witnesses.Ordered ( mapFL, mapFL_FL, unsafeCoerceP,                              FL(..), RL(..),                              (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..), #ifndef GADT_WITNESSES@@ -196,17 +196,18 @@     merge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2)         = case merge (p1 :\/: p2) of           (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1'-    list_touched_files (NamedP _ _ p) = list_touched_files p+    listTouchedFiles (NamedP _ _ p) = listTouchedFiles p+    hunkMatches f (NamedP _ _ p) = hunkMatches f p  instance Conflict p => Conflict (Named p) where-    list_conflicted_files (NamedP _ _ p) = list_conflicted_files p-    resolve_conflicts (NamedP _ _ p) = resolve_conflicts p+    listConflictedFiles (NamedP _ _ p) = listConflictedFiles p+    resolveConflicts (NamedP _ _ p) = resolveConflicts p  everything_else_commute :: MaybeCommute -> CommuteFunction everything_else_commute c x = eec x     where     eec :: CommuteFunction-    eec (PP px :< PP py) = toPerhaps $ do y' :< x' <- commutex (px :< py)+    eec (PP px :< PP py) = toPerhaps $ do x' :> y' <- commute (py :> px)                                           return (PP y' :< PP x')     eec (ComP NilFL :< p1) = Succeeded (unsafeCoerceP p1 :< (ComP NilFL))     eec (p2 :< ComP NilFL) = Succeeded (ComP NilFL :< unsafeCoerceP p2)@@ -260,30 +261,36 @@     merge (y :\/: z) = #ifndef GADT_WITNESSES         case actual_merge (y:\/:z) of-        y' -> case commutex (y' :< z) of+        y' -> case commute (z :> y') of                          Nothing -> bugDoc $ text "merge_patches bug"                                     $$ showPatch_ y                                    $$ showPatch_ z                                    $$ showPatch_ y'-                         Just (z' :< _) -> z' :/\: y'+                         Just (_ :> z') -> z' :/\: y' #else-        case elegant_merge (y:\/:z) of+        case elegantMerge (y:\/:z) of         Just (z' :/\: y') -> z' :/\: y'         Nothing -> undefined #endif-    commutex x = toMaybe $ msum [speedy_commute x,+    commute x = toMaybe $ msum+                  [toFwdCommute speedy_commute x, #ifndef GADT_WITNESSES-                                 clever_commute merger_commute x,+                   toFwdCommute (clever_commute merger_commute) x, #endif-                                 everything_else_commute commutex x-                        ]+                   toFwdCommute (everything_else_commute (toRevCommute commute)) x+                  ]     -- Recurse on everything, these are potentially spoofed patches-    list_touched_files (ComP ps) = nubsort $ concat $ mapFL list_touched_files ps-    list_touched_files (Merger _ _ p1 p2) = nubsort $ list_touched_files p1-                                            ++ list_touched_files p2-    list_touched_files c@(Regrem _ _ _ _) = list_touched_files $ invert c-    list_touched_files (PP p) = list_touched_files p+    listTouchedFiles (ComP ps) = nubsort $ concat $ mapFL listTouchedFiles ps+    listTouchedFiles (Merger _ _ p1 p2) = nubsort $ listTouchedFiles p1+                                            ++ listTouchedFiles p2+    listTouchedFiles c@(Regrem _ _ _ _) = listTouchedFiles $ invert c+    listTouchedFiles (PP p) = listTouchedFiles p +    hunkMatches f (ComP ps) = or $ mapFL (hunkMatches f) ps+    hunkMatches f (Merger _ _ p1 p2) = hunkMatches f p1 || hunkMatches f p2+    hunkMatches f c@(Regrem _ _ _ _) = hunkMatches f $ invert c+    hunkMatches f (PP p) = hunkMatches f p+ commute_no_merger :: MaybeCommute commute_no_merger x = #ifndef GADT_WITNESSES@@ -306,19 +313,19 @@ #ifndef GADT_WITNESSES commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch) commute_recursive_merger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $-  do (pA' :< _) <- commutex (undo :< pA)-     commutex (invert undo :< pA')-     (pAmid :< _) <- commutex (invert p1 :< pA)-     (pAx :< p1') <- commutex (p1 :< pAmid)+  do (_ :> pA') <- commute (pA :> undo)+     commute (pA' :> invert undo)+     (_ :> pAmid) <- commute (pA :> invert p1)+     (p1' :> pAx) <- commute (pAmid :> p1)      assert (pAx `unsafeCompare` pA)-     (_ :<p2') <- commutex (p2 :< pAmid)-     (_ :< p2o) <- commutex (p2' :< invert pAmid)+     (p2' :> _) <- commute (pAmid :> p2)+     (p2o :> _) <- commute (invert pAmid :> p2')      assert (p2o `unsafeCompare` p2)      let p' = if unsafeCompare p1' p1 && unsafeCompare p2' p2               then p               else merger "0.0" p1' p2'          undo' = merger_undo p'-     (_ :< pAo) <- commutex (pA' :< undo')+     (pAo :> _) <- commute (undo' :> pA')      assert (pAo `unsafeCompare` pA)      return (pA' :< p')     where undo = merger_undo p@@ -327,19 +334,19 @@ other_commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch) other_commute_recursive_merger (pA':< p_old@(Merger _ _ p1' p2')) =   toPerhaps $-  do (_ :< pA) <- commutex (pA' :< merger_undo p_old)-     (p1 :< pAmid) <- commutex (pA :< p1')-     (pAmido :< _) <- commutex (invert p1 :< pA)+  do (pA :> _) <- commute (merger_undo p_old :> pA')+     (pAmid :> p1) <- commute (p1' :> pA)+     (_ :> pAmido) <- commute (pA :> invert p1)      assert (pAmido `unsafeCompare` pAmid)-     (_ :< p2) <- commutex (p2' :< invert pAmid)-     (_ :< p2o') <- commutex (p2 :< pAmid)+     (p2 :> _) <- commute (invert pAmid :> p2')+     (p2o' :> _) <- commute (pAmid :> p2)      assert (p2o' `unsafeCompare` p2')      let p = if p1 `unsafeCompare` p1' && p2 `unsafeCompare` p2'              then p_old              else merger "0.0" p1 p2          undo = merger_undo p      assert (not $ pA `unsafeCompare` p1) -- special case here...-     (pAo' :< _) <- commutex (undo :<pA)+     (_ :> pAo') <- commute (pA :> undo)      assert (pAo' `unsafeCompare` pA')      return (p :< pA) other_commute_recursive_merger _ = Unknown@@ -411,16 +418,14 @@  \begin{code} -elegant_merge :: (Patch :\/: Patch) C(x y)+elegantMerge :: (Patch :\/: Patch) C(x y)               -> Maybe ((Patch :/\: Patch) C(x y))-elegant_merge (p1 :\/: p2) =-  case commutex (p1 :< invert p2) of-  Just (ip2':<p1') -> case commutex (p1' :< p2) of-                      Nothing -> Nothing -- should be a redundant check-                      Just (_:<p1o) -> if unsafeCompare p1o p1-                                       then Just (invert ip2' :/\: p1')-                                       else Nothing-  Nothing -> Nothing+elegantMerge (p1 :\/: p2) = do+  p1' :> ip2' <- commute (invert p2 :> p1)+  p1o :> _    <- commute (p2 :> p1')+  if unsafeCompare p1o p1 -- should be a redundant check+    then return $ invert ip2' :/\: p1'+    else Nothing  \end{code} @@ -455,7 +460,7 @@                               join_patchesFL $ merge_patches_after_patch p1s p2 actual_merge (p1 :\/: ComP p2s) = seq p1 $ merge_patch_after_patches p1 p2s -actual_merge (p1 :\/: p2) = case elegant_merge (p1:\/:p2) of+actual_merge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of                             Just (_ :/\: p1') -> p1'                             Nothing -> merger "0.0" p2 p1 @@ -466,8 +471,8 @@  merge_patches_after_patch :: FL Patch -> Patch -> FL Patch merge_patches_after_patch p2s p =-    case commutex (merge_patch_after_patches p p2s :< join_patchesFL p2s) of-    Just (ComP p2s':< _) -> p2s'+    case commute (join_patchesFL p2s :> merge_patch_after_patches p p2s) of+    Just (_ :> ComP p2s') -> p2s'     _ -> impossible #endif \end{code}@@ -602,8 +607,8 @@  put_before :: Patch -> FL Patch -> Maybe (FL Patch) put_before p1 (p2:>:p2s) =-    do p2':<p1' <- commutex (invert p1:<p2)-       commutex (p1:<p2')+    do p1' :> p2' <- commute (p2 :> invert p1)+       commute (p2' :> p1)        (p2' :>:) `fmap` put_before p1' p2s put_before _ NilFL = Just NilFL #endif@@ -636,7 +641,7 @@   commute_no_conflicts (x:>y) = do x' :< y' <- commute_no_merger (y :< x)                                    return (y':>x') #ifndef GADT_WITNESSES-  resolve_conflicts patch = rcs NilFL $ reverseFL $ flattenFL patch+  resolveConflicts patch = rcs NilFL $ reverseFL $ flattenFL patch     where rcs :: FL Patch C(w y) -> RL Patch C(x y) -> [[Sealed (FL Prim C(w))]]           rcs _ NilRL = []           rcs passedby (p@(Merger _ _ _ _):<:ps) =@@ -649,7 +654,7 @@           rcs passedby (p:<:ps) = seq passedby $                                   rcs (p :>: passedby) ps #else-  resolve_conflicts = bug "haven't defined resolve_conflicts with type witnesses."+  resolveConflicts = bug "haven't defined resolveConflicts with type witnesses." #endif  public_unravel :: Patch C(x y) -> [Sealed (FL Prim C(y))]@@ -662,7 +667,7 @@ #ifndef GADT_WITNESSES unravel :: Patch -> [FL Prim] unravel p = nubBy unsafeCompare $-            map (sort_coalesceFL . concatFL . mapFL_FL effect) $+            map (sortCoalesceFL . concatFL . mapFL_FL effect) $             get_supers $ map reverseRL $ new_ur p $ unwind p  get_supers :: [FL Patch] -> [FL Patch]@@ -695,7 +700,7 @@           unwindings = true_unwind fake_p           p = Merger identity unwindings p1 p2           undoit =-              case (is_merger p1, is_merger p2) of+              case (isMerger p1, isMerger p2) of               (True ,True ) -> join_patchesFL $ invertRL $ tailRL $ unwind p                                where tailRL (_:<:t) = t                                      tailRL _ = impossible@@ -721,8 +726,8 @@ only_hunks pss = fn2fp f /= "" && all oh pss     where f = get_a_filename pss           oh :: Sealed (FL Prim C(x)) -> Bool-          oh (Sealed (p:>:ps)) = is_hunk p &&-                                 [fn2fp f] == list_touched_files p &&+          oh (Sealed (p:>:ps)) = primIsHunk p &&+                                 [fn2fp f] == listTouchedFiles p &&                                  oh (Sealed ps)           oh (Sealed NilFL) = True @@ -785,17 +790,17 @@                    else ""  instance Effect Patch where-    effect p@(Merger _ _ _ _) = sort_coalesceFL $ effect $ merger_undo p+    effect p@(Merger _ _ _ _) = sortCoalesceFL $ effect $ merger_undo p     effect p@(Regrem _ _ _ _) = invert $ effect $ invert p     effect (ComP ps) = concatFL $ mapFL_FL effect ps     effect (PP p) = effect p     isHunk p = do PP p' <- return p                   isHunk p' -modernize_patch :: Patch C(x y) -> Patch C(x y)-modernize_patch p@(Merger _ _ _ _) = fromPrims $ effect p-modernize_patch p@(Regrem _ _ _ _) = fromPrims $ effect p-modernize_patch (ComP ps) = ComP $ filtermv $ mapFL_FL modernize_patch ps+modernizePatch :: Patch C(x y) -> Patch C(x y)+modernizePatch p@(Merger _ _ _ _) = fromPrims $ effect p+modernizePatch p@(Regrem _ _ _ _) = fromPrims $ effect p+modernizePatch (ComP ps) = ComP $ filtermv $ mapFL_FL modernizePatch ps     where filtermv :: FL Patch C(x y) -> FL Patch C(x y) #ifndef GADT_WITNESSES           filtermv (PP (Move _ b):>:xs) | hasadd xs = filtermv xs@@ -809,7 +814,7 @@           filtermv (x:>:xs) = x :>: filtermv xs           filtermv NilFL = NilFL -modernize_patch (PP p) = fromPrims $ modernizePrim p+modernizePatch (PP p) = fromPrims $ modernizePrim p  instance FromPrims Patch where     fromPrims (p :>: NilFL) = PP p@@ -828,7 +833,7 @@               $$ vcat (mapRL showPatch_ $ unwind p)  new_ur op ps =-    case filter (is_merger.headRL) $ head_permutationsRL ps of+    case filter (isMerger.headRL) $ head_permutationsRL ps of     [] -> [ps]     (ps':_) -> new_ur op ps'
src/Darcs/Patch/Core.lhs view
@@ -28,10 +28,10 @@ module Darcs.Patch.Core        ( Patch(..), Named(..),          join_patchesFL, concatFL, flattenFL,-         nullP, is_null_patch, infopatch,+         nullP, isNullPatch, infopatch,          n_fn,          adddeps, namepatch, anonymous,-         merger_undo, is_merger,+         merger_undo, isMerger,          getdeps,          patch2patchinfo, patchname, patchcontents,        )@@ -40,7 +40,7 @@ import Prelude hiding ( pi ) import Darcs.Patch.Info ( PatchInfo, patchinfo, make_filename ) import Darcs.Patch.Patchy ( Patchy )-import Darcs.Ordered+import Darcs.Witnesses.Ordered import Darcs.Patch.Prim ( Prim(..), FromPrim(..), Effect(effect, effectRL), n_fn ) #include "impossible.h" @@ -61,26 +61,34 @@ instance FromPrim Patch where     fromPrim = PP +-- | The @Named@ type adds a patch info about a patch, that is a name. data Named p C(x y) where-    NamedP :: !PatchInfo -> ![PatchInfo] -> !(p C(x y)) -> Named p C(x y)+    NamedP :: !PatchInfo+           -> ![PatchInfo]+           -> !(p C(x y))+           -> Named p C(x y)+-- ^ @NamedP info deps p@ represents patch @p@ with name+-- @info@. @deps@ is a list of dependencies added at the named patch+-- level, compared with the unnamed level (ie, dependencies added with+-- @darcs record --ask-deps@).  instance Effect p => Effect (Named p) where     effect (NamedP _ _ p) = effect p     effectRL (NamedP _ _ p) = effectRL p -is_null_patch :: Patch C(x y) -> Bool-is_null_patch (ComP ps) = and $ mapFL is_null_patch ps-is_null_patch _ = False+isNullPatch :: Patch C(x y) -> Bool+isNullPatch (ComP ps) = and $ mapFL isNullPatch ps+isNullPatch _ = False  nullP :: Patch C(x y) -> EqCheck C(x y) nullP (ComP NilFL) = IsEq nullP (ComP (x:>:xs)) | IsEq <- nullP x = nullP (ComP xs) nullP _ = NotEq -is_merger :: Patch C(a b) -> Bool-is_merger (Merger _ _ _ _) = True-is_merger (Regrem _ _ _ _) = True-is_merger _ = False+isMerger :: Patch C(a b) -> Bool+isMerger (Merger _ _ _ _) = True+isMerger (Regrem _ _ _ _) = True+isMerger _ = False  merger_undo :: Patch C(x y) -> Patch C(x y) merger_undo (Merger undo _ _ _) = undo
src/Darcs/Patch/Depends.hs view
@@ -33,10 +33,10 @@ import Control.Monad ( liftM2 ) import Control.Monad.Error ( Error(..) ) -import Darcs.Patch ( RepoPatch, Named, getdeps, commutex,+import Darcs.Patch ( RepoPatch, Named, getdeps, commute,                      commuteFL,                      patch2patchinfo, merge )-import Darcs.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..),+import Darcs.Witnesses.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..),                              RL(..), FL(..),                              (+<+),                              reverseFL, mapFL_FL, mapFL, concatReverseFL,@@ -49,15 +49,15 @@ import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia,                          hopefully, conscientiously, hopefullyM ) import Darcs.ProgressPatches ( progressRL )-import Darcs.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..)-                    , flipSeal, seal, unseal )+import Darcs.Witnesses.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..)+                    , flipSeal, seal, unseal, mapFlipped ) import Printer ( errorDoc, renderString, ($$), text ) #include "impossible.h"  get_common_and_uncommon :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->-                           ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+                           ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) get_common_and_uncommon_or_missing :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->-                                      Either PatchInfo ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+                                      Either PatchInfo ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))  get_common_and_uncommon =      either missingPatchError id . get_common_and_uncommon_err@@ -66,7 +66,7 @@     either (\(MissingPatch x _) -> Left x) Right . get_common_and_uncommon_err  get_common_and_uncommon_err :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->-                               Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+                               Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) get_common_and_uncommon_err (ps1,ps2) = gcau (optimize_patchset ps1) ps2  {-|@@ -184,15 +184,15 @@ -}  gcau :: forall p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y)-     -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))-gcau NilRL ps2 = return ([], NilRL:<:NilRL :\/: concatRL ps2 :<: NilRL)-gcau ps1 NilRL = return ([], concatRL ps1 :<: NilRL :\/: NilRL:<:NilRL)+     -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))+gcau NilRL ps2 = return ([], NilRL :\/: concatRL ps2)+gcau ps1 NilRL = return ([], concatRL ps1 :\/: NilRL) gcau (NilRL:<:ps1) ps2 = gcau ps1 ps2 gcau ps1 (NilRL:<:ps2) = gcau ps1 ps2 gcau ((pi1:<:NilRL):<:_) ((pi2:<:NilRL):<:_)  | info pi1 == info pi2  , IsEq <- sloppyIdentity pi1- , IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL:<:NilRL :\/: unsafeCoerceP (NilRL:<:NilRL))+ , IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL :\/: unsafeCoerceP NilRL) gcau (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s)  = f (lengthRL orig_ps1) (unseal info $ lastRL orig_ps1) (orig_ps1:>:NilFL) orig_ps1s      (lengthRL orig_ps2) (unseal info $ lastRL orig_ps2) (orig_ps2:>:NilFL) orig_ps2s@@ -200,7 +200,7 @@                          lx = last $ concatReverseFL psx   -}           f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r)             -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u)-            -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+            -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))           f _n1 l1 ps1 _ps1s _n2 l2 ps2 _ps2s            | l1 == l2 = gcau_simple (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2))           f n1 l1 ps1 ps1s n2 l2 ps2 ps2s@@ -242,12 +242,12 @@ -- | Filters the common elements from @ps1@ and @ps2@ and returns the simplified sequences. gcau_simple :: RepoPatch p => RL (PatchInfoAnd p) C(x y) -- ^ @ps1@             -> RL (PatchInfoAnd p) C(u v) -- ^ @ps2@-            -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(y v))+            -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(y v)) gcau_simple ps1 ps2 = do  FlippedSeal ex1 <- get_extra common ps1  FlippedSeal ex2 <- get_extra common ps2  let ps1' = filter (`elem` common) $ ps1_info- return (ps1', (unsafeCoerceP ex1 :<: NilRL) :\/: ex2 :<: NilRL)+ return (ps1', (unsafeCoerceP ex1 :\/: ex2))   where common   = ps1_info `intersect` mapRL info ps2         ps1_info = mapRL info ps1 @@ -258,7 +258,33 @@     noMsg = bug "MissingPatch doesn't define noMsg."  -- | Returns a sub-sequence from @patches@, where all the elements of @common@ have--- been removed by commuting them out.+--   been removed by commuting them back into the early part of the history.+--+--  An informal illustration of this process as it traverses a mixed list of patches+--  where C and x denote common patches and extra patches accordingly.  Variants of+--  patches obtained through commutation are indicated by letters following the+--  patch name.+--+--  > in: x6 < x5 < C4 < x3 < C2 < x1  skip:           extra:+--  > in:      x5 < C4 < x3 < C2 < x1  skip:           extra:                  x6+--  > in:           C4 < x3 < C2 < x1  skip:           extra:             x5 > x6+--  > in:                x3 < C2 < x1  skip: C4        extra:             x5 > x6+--  > in:                     C2 < x1  skip: C4b       extra:       x3b > x5 > x6+--  > in:                          x1  skip: C2  > C4b extra:       x3b > x5 > x6+--  > in:                              skip: C2b > C4c extra: x1b > x3b > x5 > x6+--+--  This function is undefined if for any reason we fail to commute an extra+--  patch past one of the common ones.  Such a failure would indicate that the+--  common patch depends on the extra one, contradicting the claim that the+--  \"common\" patch is shared with another repository lacking the extra patches.+--  Unfortunately, such cases have crept up in practice.  Some notable cases can+--  be found on the bugtracker as:+--+--   * issue27   - different patches with identical patch info; mistaken identity.+--                 Note how @common@ consists only of a list of 'PatchInfo' which+--                 we trust to uniquely identify such patches.+--+--   * issue1014 - duplicate patches get_extra :: RepoPatch p => [PatchInfo] -- ^ @common@           -> RL (PatchInfoAnd p) C(u x) -- ^ @patches@           -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y))@@ -313,19 +339,14 @@ get_extra_old common pps =     either missingPatchError id (get_extra common pps) -get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x)-get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal $ NilRL :<: NilRL+get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (PatchInfoAnd p)) C(x)+get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal NilRL get_patches_beyond_tag t patchset@((hp:<:ps):<:pps) =     if info hp == t     then if get_tags_right patchset == [info hp]-         then flipSeal $ NilRL :<: NilRL -- special case to avoid looking at redundant patches-         else case get_extra_old [t] (concatRL patchset) of-              FlippedSeal x -> flipSeal $ x :<: NilRL-    else hp `prepend` get_patches_beyond_tag t (ps:<:pps)- where- prepend :: (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(y)- prepend pp (FlippedSeal NilRL)     = flipSeal $ (pp:<:NilRL) :<: NilRL- prepend pp (FlippedSeal (p:<:ps')) = flipSeal $ (pp:<:p)     :<: ps'+         then flipSeal NilRL -- special case to avoid looking at redundant patches+         else get_extra_old [t] (concatRL patchset)+    else mapFlipped (hp:<:) $ get_patches_beyond_tag t (ps:<:pps) get_patches_beyond_tag t (NilRL:<:pps) = get_patches_beyond_tag t pps get_patches_beyond_tag t NilRL = bug $ "tag\n" ++                                  renderString (human_friendly t) ++@@ -367,9 +388,9 @@                      -> FL (PatchInfoAnd p) C(w z)           commute_by NilFL _ = unsafeCoerceP NilFL           commute_by (hpa:>:xs') p =-              case commutex (hopefully hpa :< p) of+              case commute (p :> hopefully hpa) of                 Nothing -> bug "Failure commuting patches in commute_by called by gpit!"-                Just (p':<a') -> (info hpa `piap` a') :>: commute_by xs' p'+                Just (a' :> p') -> (info hpa `piap` a') :>: commute_by xs' p'  get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag"                                  $$ human_friendly t@@ -481,13 +502,12 @@   f common a b = g_s $ gcau_simple a b     where       g_s :: Either MissingPatch-                    ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+                    ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))           -> SealedPatchSet p       g_s (Left e) = missingPatchError e-      g_s (Right (_, (a' :<: NilRL) :\/: (b' :<: NilRL))) =+      g_s (Right (_, a' :\/: b')) =           case (merge_sets (a' :\/: b')) of           Sealed a'b' -> seal $ (a'b' +<+ b) :<: common-      g_s _ = impossible  merge_sets :: RepoPatch p => (RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y) -> Sealed (RL (PatchInfoAnd p) C(y)) merge_sets (l :\/: r) =
src/Darcs/Patch/FileName.hs view
@@ -21,7 +21,7 @@                               fp2fn, fn2fp,                               fn2ps, ps2fn,                               niceps2fn, fn2niceps,-                              break_on_dir, norm_path, own_name, super_name,+                              break_on_dir, norm_path, own_name, superName,                               movedirfilename,                               encode_white, decode_white,                               (///),@@ -30,9 +30,9 @@  import System.IO import Data.Char ( isSpace, chr, ord )-import qualified UTF8 ( encode )+import qualified Codec.Binary.UTF8.String as UTF8 ( encode )+import Codec.Binary.UTF8.Generic ( toString ) import Data.Word ( Word8( ) )-import ByteStringUtils ( unpackPSfromUTF8 ) import qualified Data.ByteString.Char8 as BC (unpack, pack) import qualified Data.ByteString       as B  (ByteString, pack) @@ -66,7 +66,7 @@  {-# INLINE ps2fn #-} ps2fn :: B.ByteString -> FileName-ps2fn ps = FN $ decode_white $ unpackPSfromUTF8 ps+ps2fn ps = FN $ decode_white $ toString ps  -- | 'encode_white' translates whitespace in filenames to a darcs-specific --   format (backslash followed by numerical representation according to 'ord').@@ -98,8 +98,8 @@ own_name :: FileName -> FileName own_name (FN f) = case breakLast '/' f of Nothing -> FN f                                           Just (_,f') -> FN f'-super_name :: FileName -> FileName-super_name fn = case norm_path fn of+superName :: FileName -> FileName+superName fn = case norm_path fn of                 FN f -> case breakLast '/' f of                         Nothing -> FN "."                         Just (d,_) -> FN d
src/Darcs/Patch/Info.hs view
@@ -32,10 +32,11 @@ import qualified Data.ByteString       as B  (length, splitAt, null, drop                                              ,isPrefixOf, tail, concat, ByteString ) import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack, break)+import Data.List( isPrefixOf )  import Printer ( renderString, Doc, packedString,                  empty, ($$), (<>), (<+>), vcat, text, blueText, prefix )-import OldDate ( readUTCDate, showIsoDateTime )+import Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime,                      toCalendarTime ) import System.IO.Unsafe ( unsafePerformIO )@@ -72,7 +73,8 @@ add_junk pinf =     do x <- randomRIO (0,2^(128 ::Integer) :: Integer)        when (_pi_log pinf /= ignore_junk (_pi_log pinf)) $-            do yorn <- promptYorn "Lines beginning with 'Ignore-this: ' will be ignored.\nProceed? "+            do putStrLn "Lines beginning with 'Ignore-this: ' will be ignored."+               yorn <- promptYorn "Proceed? "                when (yorn == 'n') $ fail "User cancelled because of Ignore-this."        return $ pinf { _pi_log = BC.pack (head ignored++showHex x ""):                                  _pi_log pinf }@@ -118,7 +120,7 @@ pi_author = BC.unpack . _pi_author  is_tag :: PatchInfo -> Bool-is_tag pinfo = take 4 (just_name pinfo) == "TAG "+is_tag pinfo = "TAG " `isPrefixOf` just_name pinfo   -- | Note: we ignore timezone information in the date string,
src/Darcs/Patch/Match.lhs view
@@ -35,13 +35,14 @@ import System.IO.Unsafe ( unsafePerformIO )  import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )-import Darcs.Patch ( Patch, Patchy, list_touched_files, patchcontents )+import Darcs.Patch ( Patch, Patchy, hunkMatches, listTouchedFiles, patchcontents ) import Darcs.Patch.Info ( just_name, just_author, make_filename,                           pi_date )-import Darcs.Sealed ( Sealed2(..), seal2 )+import Darcs.Witnesses.Sealed ( Sealed2(..), seal2 ) import DateMatcher ( parseDateMatcher )  import Darcs.Patch.MatchData ( PatchMatch(..), patch_match )+import qualified Data.ByteString.Char8 as BC  -- | A type for predicates over patches which do not care about -- contexts@@ -78,7 +79,7 @@ trivial = const True \end{code} -\paragraph{Match}+\subsection{Match}  Currently \verb!--match! accepts six primitive match types, although there are plans to expand it to match more patterns.  Also, note that the@@ -304,6 +305,9 @@  , ("author", "check a regular expression against the author name"             , ["\"David Roundy\"", "droundy", "droundy@darcs.net"]             , authormatch )+ , ("hunk", "check a regular expression against the contents of a hunk patch"+            , ["foo = 2", "^instance .* Foo where$"]+            , hunkmatch )  , ("hash",  "match the darcs hash for a patch"           ,  ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"]           ,  hashmatch )@@ -327,7 +331,7 @@          <|> between spaces spaces (many $ noneOf " ()")          <?> "string" -mymatch, exactmatch, authormatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p+mymatch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p  mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ just_name (info hp) @@ -335,12 +339,17 @@  authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ just_author (info hp) ++hunkmatch r (Sealed2 hp) = let patch = patchcontents $ hopefully hp+                               regexMatcher = isJust . (matchRegex (mkRegex r) . BC.unpack)+                           in hunkMatches regexMatcher patch+ hashmatch h (Sealed2 hp) = let rh = make_filename (info hp) in                                   (rh == h) || (rh == h++".gz")  datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d                                   in dm $ pi_date (info hp) -touchmatch r (Sealed2 hp) = let files = list_touched_files $ patchcontents $ hopefully hp+touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp                             in or $ map (isJust . matchRegex (mkRegex r)) files \end{code}
src/Darcs/Patch/Non.hs view
@@ -34,15 +34,15 @@ import Data.List ( delete ) import Control.Monad ( liftM ) import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Effect(..),-                          showPrim, FileNameFormat(..), sort_coalesceFL )+                          showPrim, FileNameFormat(..), sortCoalesceFL ) import Darcs.Patch.Patchy import Darcs.Patch.ReadMonads ( ParserM, lex_char )-import Darcs.Ordered+import Darcs.Witnesses.Ordered import Darcs.Patch.Read ( readPrim ) import Darcs.Patch.Viewing () import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL )-import Darcs.Show-import Darcs.Sealed ( Sealed(Sealed) )+import Darcs.Witnesses.Show+import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) import Printer ( Doc, empty, vcat, hiddenPrefix, blueText, redText, ($$) )  --import Darcs.ColorPrinter ( traceDoc )@@ -62,7 +62,7 @@     where rns = peekfor "}}" (return []) $                 do Just (Sealed ps) <- readPatch' False                    lex_char ':'-                   Just (Sealed p) <- readPrim NewFormat False+                   Just (Sealed p) <- readPrim NewFormat                    (Non ps p :) `liftM` rns  readNon :: (ReadPatch p, ParserM m) => m (Maybe (Non p C(x)))@@ -90,10 +90,28 @@ class Nonable p where     non :: p C(x y) -> Non p C(x) +-- | 'addP' @x cy@ tries to commute @x@ past @cy@ and always returns some+-- variant @cy'@.  -- commutation suceeds, the variant is just+-- straightforwardly the commuted versian.  If commutation fails, the variant+-- consists of @x@ prepended to the context of @cy@. addP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Non p C(x) addP p n | Just n' <- p >* n = n' addP p (Non c x) = Non (p:>:c) x +-- | 'addPs' @xs cy@ commutes as many patches of @xs@ past @cy@ as+--   possible, stopping at the first patch that fails to commute.+--   Note the fact @xs@ is a 'RL'+--+--   Suppose we have+--+--   > x1 x2 x3 [c1 c2 y]+--+--   and that in our example @c1@ fails to commute past @x1@, this+--   function would commute down to+--+--   > x1 [c1'' c2'' y''] x2' x3'+--+--   and return @[x1 c1'' c2'' y'']@ addPs :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y) -> Non p C(x) addPs NilRL n = n addPs (p:<:ps) n = addPs ps $ addP p n@@ -112,7 +130,7 @@ remNonHelper [] x = NilFL :> x remNonHelper ns (c:>:cs)     | non c `elem` ns = case remNonHelper (map (addP $ invert c) $ delete (non c) ns) cs of-                        a :> z -> sort_coalesceFL (effect c+>+a) :> z+                        a :> z -> sortCoalesceFL (effect c+>+a) :> z     | otherwise = case commuteWhatWeCanFL (c :> cs) of                   b :> c' :> d ->                       case remNonHelper ns b of
+ src/Darcs/Patch/OldDate.hs view
@@ -0,0 +1,350 @@+-- Copyright (C) 2003 Peter Simons+-- Copyright (C) 2003,2008 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- This module is intended to provide backwards-compatibility in the parsing+-- of darcs patches.  In other words: don't change it, new features don't get+-- added here.  The only user should be Darcs.Patch.Info.++module Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) where++import Text.ParserCombinators.Parsec+import System.Time+import Data.Char ( toUpper, isDigit )+import Control.Monad ( liftM, liftM2 )+import qualified Data.ByteString.Char8 as B+import Data.Maybe ( fromMaybe )++-- | Read/interpret a date string, assuming UTC if timezone+--   is not specified in the string+readUTCDate :: String -> CalendarTime+readUTCDate = readDate 0++readDate :: Int -> String -> CalendarTime+readDate tz d =+             case parseDate tz d of+             Left e -> error e+             Right ct -> ct++parseDate :: Int -> String -> Either String CalendarTime+parseDate tz d =+              if length d >= 14 && B.all isDigit bd+              then Right $+                   CalendarTime (readI $ B.take 4 bd)+                                (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)+                                (readI $ B.take 2 $ B.drop 6 bd) -- Day+                                (readI $ B.take 2 $ B.drop 8 bd) -- Hour+                                (readI $ B.take 2 $ B.drop 10 bd) -- Minute+                                (readI $ B.take 2 $ B.drop 12 bd) -- Second+                                0 Sunday 0 -- Picosecond, weekday and day of year unknown+                                "GMT" 0 False+              else let dt = do { x <- date_time tz; eof; return x }+                   in case parse dt "" d of+                      Left e -> Left $ "bad date: "++d++" - "++show e+                      Right ct -> Right ct+  where bd = B.pack (take 14 d)+        readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)++showIsoDateTime :: CalendarTime -> String+showIsoDateTime ct = concat [ show $ ctYear ct+                            , twoDigit . show . (+1) . fromEnum $ ctMonth ct+                            , twoDigit . show $ ctDay ct+                            , twoDigit . show $ ctHour ct+                            , twoDigit . show $ ctMin ct+                            , twoDigit . show $ ctSec ct+                            ]+    where twoDigit []          = undefined+          twoDigit x@(_:[])    = '0' : x+          twoDigit x@(_:_:[])  = x+          twoDigit _           = undefined++----- Parser Combinators ---------------------------------------------++-- |Case-insensitive variant of Parsec's 'char' function.++caseChar        :: Char -> GenParser Char a Char+caseChar c       = satisfy (\x -> toUpper x == toUpper c)++-- |Case-insensitive variant of Parsec's 'string' function.++caseString      :: String -> GenParser Char a ()+caseString cs    = mapM_ caseChar cs <?> cs++-- |Match a parser at least @n@ times.++manyN           :: Int -> GenParser a b c -> GenParser a b [c]+manyN n p+    | n <= 0     = return []+    | otherwise  = liftM2 (++) (count n p) (many p)++-- |Match a parser at least @n@ times, but no more than @m@ times.++manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]+manyNtoM n m p+    | n < 0      = return []+    | n > m      = return []+    | n == m     = count n p+    | n == 0     = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))+    | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)+++----- Date/Time Parser -----------------------------------------------++date_time :: Int -> CharParser a CalendarTime+date_time tz =+            choice [try $ cvs_date_time tz,+                    try $ iso8601_date_time tz,+                    old_date_time]++cvs_date_time :: Int -> CharParser a CalendarTime+cvs_date_time tz =+                do y <- year+                   char '/'+                   mon <- month_num +                   char '/'+                   d <- day+                   my_spaces+                   h <- hour+                   char ':'+                   m <- minute+                   char ':'+                   s <- second+                   z <- option tz $ my_spaces >> zone+                   return (CalendarTime y mon d h m s 0 Monday 0 "" z False)++old_date_time   :: CharParser a CalendarTime+old_date_time    = do wd <- day_name+                      my_spaces+                      mon <- month_name+                      my_spaces+                      d <- day+                      my_spaces+                      h <- hour+                      char ':'+                      m <- minute+                      char ':'+                      s <- second+                      my_spaces+                      z <- zone+                      my_spaces+                      y <- year+                      return (CalendarTime y mon d h m s 0 wd 0 "" z False)++{- FIXME: In case you ever want to use this outside of darcs, you should note +   that this implementation of ISO 8601 is not complete.  ++   reluctant to implement (ambiguous!): +     * years > 9999  +     * truncated representations with implied century (89 for 1989) +   unimplemented: +     * repeated durations (not relevant)+     * lowest order component fractions in intervals+     * negative dates (BC)                    +   unverified or too relaxed:+     * the difference between 24h and 0h+     * allows stuff like 2005-1212; either you use the hyphen all the way +       (2005-12-12) or you don't use it at all (20051212), but you don't use+       it halfway, likewise with time +     * No bounds checking whatsoever on intervals! +       (next action: read iso doc to see if bounds-checking required?) -}+iso8601_date_time   :: Int -> CharParser a CalendarTime+iso8601_date_time localTz = try $ +  do d <- iso8601_date+     t <- option id $ try $ do optional $ oneOf " T" +                               iso8601_time  +     return $ t $ d { ctTZ = localTz }++iso8601_date :: CharParser a CalendarTime+iso8601_date = +  do d <- calendar_date <|> week_date <|> ordinal_date+     return $ foldr ($) nullCalendar d+  where +    calendar_date = -- yyyy-mm-dd+      try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]+               -- allow other variants to be parsed correctly +               notFollowedBy (digit <|> char 'W')+               return d+    week_date = --yyyy-Www-dd +      try $ do yfn <- year_+               optional dash+               char 'W'+               -- offset human 'week 1' -> computer 'week 0'+               w'  <- (\x -> x-1) `liftM` two_digits+               wd  <- option 1 $ do { optional dash; n_digits 1 }+               let y = yfn nullCalendar+                   firstDay = ctWDay y+               -- things that make this complicated+               -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday+               -- 2. the first week is the one that contains at least Thursday+               --    if the year starts after Thursday, then some days of the year+               --    will have already passed before the first week+               let afterThursday = firstDay == Sunday || firstDay > Thursday+                   w  = if afterThursday then w'+1 else w'+                   diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) }+               return [(toUTCTime.toClockTime.diff.yfn)]+    ordinal_date = -- yyyy-ddd+      try $ optchain year_ [ (dash, yearDay_) ]+    --+    year_  = try $ do y <- four_digits <?> "year (0000-9999)"+                      return $ \c -> c { ctYear = y }+    month_ = try $ do m <- two_digits <?> "month (1 to 12)"+                      -- we (artificially) use ctPicosec to indicate+                      -- whether the month has been specified.+                      return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 }+    day_   = try $ do d <- two_digits <?> "day in month (1 to 31)"+                      return $ \c -> c { ctDay = d }+    yearDay_ = try $ do d <- n_digits 3 <?> "day in year (1 to 366)"+                        return $ \c -> c { ctYDay = d }+    dash = char '-'++-- we return a function which sets the time on another calendar+iso8601_time :: CharParser a (CalendarTime -> CalendarTime)+iso8601_time = try $+  do ts <- optchain hour_ [ (colon     , min_)+                          , (colon     , sec_)+                          , (oneOf ",.", pico_) ] +     z  <- option id $ choice [ zulu , offset ]+     return $ foldr (.) id (z:ts)+  where +    hour_ = do h <- two_digits+               return $ \c -> c { ctHour = h }+    min_  = do m <- two_digits+               return $ \c -> c { ctMin = m }+    sec_  = do s <- two_digits+               return $ \c -> c { ctSec = s }+    pico_ = do digs <- many digit+               let picoExp = 12+                   digsExp = length digs+               let frac | null digs = 0+                        | digsExp > picoExp = read $ take picoExp digs+                        | otherwise = 10 ^ (picoExp - digsExp) * (read digs)+               return $ \c -> c { ctPicosec = frac }+    zulu   = do { char 'Z'; return (\c -> c { ctTZ = 0 }) }+    offset = do sign <- choice [ do { char '+' >> return   1  }+                               , do { char '-' >> return (-1) } ]+                h <- two_digits+                m <- option 0 $ do { optional colon; two_digits }+                return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) }+    colon = char ':'++optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]+optchain p next = try $ +  do r1 <- p+     r2 <- case next of +           [] -> return []+           ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }+     return (r1:r2)++n_digits :: Int -> CharParser a Int +n_digits n = read `liftM` count n digit++two_digits, four_digits :: CharParser a Int+two_digits = n_digits 2+four_digits = n_digits 4++my_spaces :: CharParser a String+my_spaces = manyN 1 $ char ' '++day_name        :: CharParser a Day+day_name         = choice+                       [ caseString "Mon"       >> return Monday+                       , try (caseString "Tue") >> return Tuesday+                       , caseString "Wed"       >> return Wednesday+                       , caseString "Thu"       >> return Thursday+                       , caseString "Fri"       >> return Friday+                       , try (caseString "Sat") >> return Saturday+                       , caseString "Sun"       >> return Sunday+                       ]++year            :: CharParser a Int+year             = four_digits++month_num       :: CharParser a Month+month_num = do mn <- manyNtoM 1 2 digit +               return $ intToMonth $ (read mn :: Int)++intToMonth :: Int -> Month+intToMonth 1 = January+intToMonth 2 = February+intToMonth 3 = March+intToMonth 4 = April+intToMonth 5 = May+intToMonth 6 = June+intToMonth 7 = July+intToMonth 8 = August+intToMonth 9 = September+intToMonth 10 = October+intToMonth 11 = November+intToMonth 12 = December+intToMonth _  = error "invalid month!"++month_name      :: CharParser a Month+month_name       = choice+                       [ try (caseString "Jan") >> return January+                       , caseString "Feb"       >> return February+                       , try (caseString "Mar") >> return March+                       , try (caseString "Apr") >> return April+                       , caseString "May"       >> return May+                       , try (caseString "Jun") >> return June+                       , caseString "Jul"       >> return July+                       , caseString "Aug"       >> return August+                       , caseString "Sep"       >> return September+                       , caseString "Oct"       >> return October+                       , caseString "Nov"       >> return November+                       , caseString "Dec"       >> return December+                       ]++day             :: CharParser a Int+day              = do d <- manyNtoM 1 2 digit+                      return (read d :: Int)++hour            :: CharParser a Int+hour             = two_digits++minute          :: CharParser a Int+minute           = two_digits++second          :: CharParser a Int+second           = two_digits++zone            :: CharParser a Int+zone             = choice+                       [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }+                       , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }+                       , mkZone "UTC"  0+                       , mkZone "UT"  0+                       , mkZone "GMT" 0+                       , mkZone "EST" (-5)+                       , mkZone "EDT" (-4)+                       , mkZone "CST" (-6)+                       , mkZone "CDT" (-5)+                       , mkZone "MST" (-7)+                       , mkZone "MDT" (-6)+                       , mkZone "PST" (-8)+                       , mkZone "PDT" (-7)+                       , mkZone "CEST" 2+                       , mkZone "EEST" 3+                         -- if we don't understand it, just give a GMT answer...+                       , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])+                                       (lookAhead space_digit);+                              return 0 }+                       ]+     where mkZone n o  = try $ do { caseString n; return (o*60*60) }+           space_digit = try $ do { char ' '; oneOf ['0'..'9'] }++nullCalendar :: CalendarTime +nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False
src/Darcs/Patch/Patchy.hs view
@@ -25,7 +25,7 @@                             Apply, apply, applyAndTryToFix, applyAndTryToFixFL,                             mapMaybeSnd,                             Commute(..), commuteFL, commuteRL, commuteRLFL,-                            mergeFL,+                            mergeFL, toFwdCommute, toRevCommute,                             ShowPatch(..),                             ReadPatch, readPatch', bracketedFL, peekfor,                             Invert(..), invertFL, invertRL ) where@@ -35,10 +35,10 @@ import Data.Word ( Word8 ) import Data.List ( nub ) -import Darcs.SlurpDirectory ( Slurpy )-import Darcs.Sealed ( Sealed(..), Sealed2(..), seal2 )+import Storage.Hashed.Monad( TreeIO )+import Darcs.Witnesses.Sealed ( Sealed(..), Sealed2(..), seal2 ) import Darcs.Patch.ReadMonads ( ParserM, lex_eof, peek_input, my_lex, work, alter_input )-import Darcs.Ordered+import Darcs.Witnesses.Ordered import Printer ( Doc, (<>), text ) import Darcs.Lock ( writeDocBinFile, gzWriteDocFile ) import Darcs.IO ( WriteableDirectory )@@ -69,22 +69,35 @@ mapMaybeSnd f (Just (a,b)) = Just (a,f b) mapMaybeSnd _ Nothing = Nothing +-- | Things that can commute. class Commute p where     commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))-    commutex :: (p :< p) C(x y) -> Maybe ((p :< p) C(x y))-    commute (x :> y) = do x' :< y' <- commutex (y :< x)-                          return (y' :> x')-    commutex (x :< y) = do x' :> y' <- commute (y :> x)-                           return (y' :< x')     merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y)-    list_touched_files :: p C(x y) -> [FilePath]+    listTouchedFiles :: p C(x y) -> [FilePath]+    hunkMatches :: (BC.ByteString -> Bool) -> p C(x y) -> Bool +-- | Swaps the ordered pair type so that commute can be+-- called directly.+toFwdCommute :: (Commute p, Commute q, Monad m)+             => ((p :< q) C(x y) -> m ((q :< p) C(x y)))+             -> (q :> p) C(x y) -> m ((p :> q) C(x y))+toFwdCommute c (x :> y) = do x' :< y' <- c (y :< x)+                             return (y' :> x')++-- | Swaps the ordered pair type from the order expected+-- by commute to the reverse order.+toRevCommute :: (Commute p, Commute q, Monad m)+             => ((p :> q) C(x y) -> m ((q :> p) C(x y)))+             -> (q :< p) C(x y) -> m ((p :< q) C(x y))+toRevCommute c (x :< y) = do x' :> y' <- c (y :> x)+                             return (y' :< x')+ class Commute p => ShowPatch p where     showPatch :: p C(x y) -> Doc     showNicely :: p C(x y) -> Doc     showNicely = showPatch-    showContextPatch :: Slurpy -> p C(x y) -> Doc-    showContextPatch _ p = showPatch p+    showContextPatch :: p C(x y) -> TreeIO Doc+    showContextPatch p = return $ showPatch p     description :: p C(x y) -> Doc     description = showPatch     summary :: p C(x y) -> Doc@@ -131,7 +144,8 @@     merge ((x:>:xs) :\/: ys) = fromJust $ do ys' :/\: x' <- return $ mergeFL (x :\/: ys)                                              xs' :/\: ys'' <- return $ merge (ys' :\/: xs)                                              return (ys'' :/\: (x' :>: xs'))-    list_touched_files xs = nub $ concat $ mapFL list_touched_files xs+    listTouchedFiles xs = nub $ concat $ mapFL listTouchedFiles xs+    hunkMatches f = or . mapFL (hunkMatches f)  mergeFL :: Commute p => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y) mergeFL (p :\/: NilFL) = NilFL :/\: p@@ -216,7 +230,8 @@                             return (reverseFL fys' :> xs')     merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of                        (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx'-    list_touched_files = list_touched_files . reverseRL+    listTouchedFiles = listTouchedFiles . reverseRL+    hunkMatches f = hunkMatches f . reverseRL instance ReadPatch p => ReadPatch (RL p) where     readPatch' want_eof = do Just (Sealed fl) <- readPatch' want_eof                              return $ Just $ Sealed $ reverseFL fl
src/Darcs/Patch/Permutations.hs view
@@ -1,4 +1,5 @@ -- Copyright (C) 2002-2003 David Roundy+-- Copyright (C) 2009 Ganesh Sittampalam -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by@@ -27,11 +28,14 @@                                   partitionFL, partitionRL,                                   head_permutationsFL, head_permutationsRL,                                   headPermutationsFL,-                                  remove_subsequenceFL, remove_subsequenceRL ) where+                                  remove_subsequenceFL, remove_subsequenceRL,+                                  partitionConflictingFL,+                                  CommuteFn, selfCommuter, commuterIdRL,+                                ) where  import Data.Maybe ( catMaybes ) import Darcs.Patch.Patchy ( Commute, commute, commuteFL, commuteRL, Invert(..), invertFL, invertRL )-import Darcs.Ordered+import Darcs.Witnesses.Ordered #include "impossible.h"  -- |split an 'FL' into "left" and "right" lists according to a predicate, using commutation as necessary.@@ -230,3 +234,37 @@     sloppyIdentity NilRL = IsEq     sloppyIdentity (x:<:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs     sloppyIdentity _ = NotEq++-- |CommuteFn is the basis of a general framework for building up commutation+-- operations between different patch types in a generic manner. Unfortunately+-- type classes are not well suited to the problem because of the multiple possible+-- routes by which the commuter for (FL p1, FL p2) can be built out of the+-- commuter for (p1, p2) - and more complicated problems when we start building+-- multiple constructors on top of each other. The type class resolution machinery+-- really can't cope with selecting some route, because it doesn't know that all+-- possible routes should be equivalent.+type CommuteFn p1 p2 = FORALL(x y) (p1 :> p2) C(x y) -> Maybe ((p2 :> p1) C(x y))++-- |Build a commuter between a patch and itself using the operation from the type class.+selfCommuter :: Commute p => CommuteFn p p+selfCommuter = commute++commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2)+commuterIdRL _ (x :> NilRL) = return (NilRL :> x)+commuterIdRL commuter (x :> (y :<: ys))+  = do ys' :> x' <- commuterIdRL commuter (x :> ys)+       y' :> x'' <- commuter (x' :> y)+       return ((y' :<: ys') :> x'')++-- |Partition a list into the patches that commute with the given patch and those that don't (including dependencies)+partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 C(x y) -> p2 C(x z) -> (FL p1 :> FL p1) C(x y)+partitionConflictingFL _ NilFL _ = (NilFL :> NilFL)+partitionConflictingFL commuter (x :>: xs) y =+   case commuter (invert x :> y) of+     Nothing -> case commuteWhatWeCanFL (x :> xs) of+                 xs_ok :> x' :> xs_deps ->+                   case partitionConflictingFL commuter xs_ok y of+                     xs_clean :> xs_conflicts -> xs_clean :> (xs_conflicts +>+ (x' :>: xs_deps))+     Just (y' :> _) ->+       case partitionConflictingFL commuter xs y' of+          xs_clean :> xs_conflicts -> (x :>: xs_clean) :> xs_conflicts
src/Darcs/Patch/Prim.lhs view
@@ -26,15 +26,15 @@        ( Prim(..), IsConflictedPrim(IsC), ConflictState(..), showPrim,          DirPatchType(..), FilePatchType(..),          CommuteFunction, Perhaps(..),-         null_patch, nullP, is_null_patch,+         null_patch, nullP, isNullPatch,          is_identity,          formatFileName, FileNameFormat(..),          adddir, addfile, binary, changepref,          hunk, move, rmdir, rmfile, tokreplace,-         is_addfile, is_hunk, is_binary, is_setpref,-         is_similar, is_adddir, is_filepatch,-         canonize, try_to_shrink, modernizePrim,-         subcommutes, sort_coalesceFL, join,+         primIsAddfile, primIsHunk, primIsBinary, primIsSetpref,+         isSimilar, primIsAdddir, is_filepatch,+         canonize, tryToShrink, modernizePrim,+         subcommutes, sortCoalesceFL, join, canonizeFL,          try_tok_internal,          try_shrinking_inverse,          n_fn,@@ -56,14 +56,14 @@  import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, norm_path,                               movedirfilename, encode_white )-import Darcs.Ordered-import Darcs.Sealed ( Sealed, unseal )-import Darcs.Patch.Patchy ( Invert(..), Commute(..) )+import Darcs.Witnesses.Ordered+import Darcs.Witnesses.Sealed ( Sealed, unseal )+import Darcs.Patch.Patchy ( Invert(..), Commute(..), toFwdCommute, toRevCommute ) import Darcs.Patch.Permutations () -- for Invert instance of FL-import Darcs.Show+import Darcs.Witnesses.Show import Darcs.Utils ( nubsort ) import Lcs ( getChanges )-import RegChars ( regChars )+import Darcs.Patch.RegChars ( regChars ) import Printer ( Doc, vcat, packedString, Color(Cyan,Magenta), lineColor,                  text, userchunk, invisibleText, invisiblePS, blueText,                  ($$), (<+>), (<>), prefix, userchunkPS,@@ -97,11 +97,11 @@ null_patch :: Prim C(x x) null_patch = Identity -is_null_patch :: Prim C(x y) -> Bool-is_null_patch (FP _ (Binary x y)) = B.null x && B.null y-is_null_patch (FP _ (Hunk _ [] [])) = True-is_null_patch Identity = True-is_null_patch _ = False+isNullPatch :: Prim C(x y) -> Bool+isNullPatch (FP _ (Binary x y)) = B.null x && B.null y+isNullPatch (FP _ (Hunk _ [] [])) = True+isNullPatch Identity = True+isNullPatch _ = False  nullP :: Prim C(x y) -> EqCheck C(x y) nullP = sloppyIdentity@@ -119,30 +119,30 @@ -- | Tells you if two patches are in the same category, human-wise. -- Currently just returns true if they are filepatches on the same -- file.-is_similar :: Prim C(x y) -> Prim C(a b) -> Bool-is_similar (FP f _) (FP f' _) = f == f'-is_similar (DP f _) (DP f' _) = f == f'-is_similar _ _ = False+isSimilar :: Prim C(x y) -> Prim C(a b) -> Bool+isSimilar (FP f _) (FP f' _) = f == f'+isSimilar (DP f _) (DP f' _) = f == f'+isSimilar _ _ = False -is_addfile :: Prim C(x y) -> Bool-is_addfile (FP _ AddFile) = True-is_addfile _ = False+primIsAddfile :: Prim C(x y) -> Bool+primIsAddfile (FP _ AddFile) = True+primIsAddfile _ = False -is_adddir :: Prim C(x y) -> Bool-is_adddir (DP _ AddDir) = True-is_adddir _ = False+primIsAdddir :: Prim C(x y) -> Bool+primIsAdddir (DP _ AddDir) = True+primIsAdddir _ = False -is_hunk :: Prim C(x y) -> Bool-is_hunk (FP _ (Hunk _ _ _)) = True-is_hunk _ = False+primIsHunk :: Prim C(x y) -> Bool+primIsHunk (FP _ (Hunk _ _ _)) = True+primIsHunk _ = False -is_binary :: Prim C(x y) -> Bool-is_binary (FP _ (Binary _ _)) = True-is_binary _ = False+primIsBinary :: Prim C(x y) -> Bool+primIsBinary (FP _ (Binary _ _)) = True+primIsBinary _ = False -is_setpref :: Prim C(x y) -> Bool-is_setpref (ChangePref _ _ _) = True-is_setpref _ = False+primIsSetpref :: Prim C(x y) -> Bool+primIsSetpref (ChangePref _ _ _) = True+primIsSetpref _ = False  addfile :: FilePath -> Prim C(x y) rmfile :: FilePath -> Prim C(x y)@@ -406,19 +406,19 @@     toPerhaps $ cs (patches :< patch) >>= sc     where cs :: ((FL Prim) :< Prim) C(x y) -> Maybe ((Prim :< (FL Prim)) C(x y))           cs (NilFL :< p1) = return (p1 :< NilFL)-          cs (p:>:ps :< p1) = do p1' :< p' <- commutex (p :< p1)+          cs (p:>:ps :< p1) = do p' :> p1' <- commute (p1 :> p)                                  p1'' :< ps' <- cs (ps :< p1')                                  return (p1'' :< p':>:ps')           sc :: (Prim :< (FL Prim)) C(x y) -> Maybe ((Prim :< Prim) C(x y))-          sc (p1 :< ps) = scFL $ p1 :< (sort_coalesceFL ps)+          sc (p1 :< ps) = scFL $ p1 :< (sortCoalesceFL ps)             where scFL :: (Prim :< (FL Prim)) C(x y)                        -> Maybe ((Prim :< Prim) C(x y))                   scFL (p1' :< (p :>: NilFL)) = return (p1' :< p)                   scFL (p1' :< ps') = return (p1' :< Split ps') commute_split _ = Unknown -try_to_shrink :: FL Prim C(x y) -> FL Prim C(x y)-try_to_shrink = mapPrimFL try_harder_to_shrink+tryToShrink :: FL Prim C(x y) -> FL Prim C(x y)+tryToShrink = mapPrimFL try_harder_to_shrink  mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y))              -> FL Prim C(w z) -> FL Prim C(w z)@@ -462,7 +462,7 @@  try_to_shrink2 :: FL Prim C(x y) -> FL Prim C(x y) try_to_shrink2 psold =-    let ps = sort_coalesceFL psold+    let ps = sortCoalesceFL psold         ps_shrunk = shrink_a_bit ps                     in     if lengthFL ps_shrunk < lengthFL ps@@ -492,17 +492,33 @@ try_one sofar p (p1:>:ps) =     case coalesce (p1 :< p) of     Just p' -> Just (reverseRL sofar +>+ p':>:NilFL +>+ ps)-    Nothing -> case commutex (p1 :< p) of+    Nothing -> case commute (p :> p1) of                Nothing -> Nothing-               Just (p' :< p1') -> try_one (p1':<:sofar) p' ps+               Just (p1' :> p') -> try_one (p1':<:sofar) p' ps --- | 'sort_coalesceFL' @ps@ coalesces as many patches in @ps@ as+-- | 'canonizeFL' @ps@ puts a sequence of primitive patches into+-- canonical form. Even if the patches are just hunk patches,+-- this is not necessarily the same set of results as you would get+-- if you applied the sequence to a specific tree and recalculated+-- a diff.+--+-- Note that this process does not preserve the commutation behaviour+-- of the patches and is therefore not appropriate for use when+-- working with already recorded patches (unless doing amend-record+-- or the like).+canonizeFL :: FL Prim C(x y) -> FL Prim C(x y)+-- Running canonize twice is apparently necessary to fix issue525;+-- would be nice to understand why.+canonizeFL = concatFL . mapFL_FL canonize . sortCoalesceFL .+             concatFL . mapFL_FL canonize++-- | 'sortCoalesceFL' @ps@ coalesces as many patches in @ps@ as --   possible, sorting the results according to the scheme defined --   in 'comparePrim'-sort_coalesceFL :: FL Prim C(x y) -> FL Prim C(x y)-sort_coalesceFL = mapPrimFL sort_coalesceFL2+sortCoalesceFL :: FL Prim C(x y) -> FL Prim C(x y)+sortCoalesceFL = mapPrimFL sort_coalesceFL2 --- | The heart of "sort_coalesceFL"+-- | The heart of "sortCoalesceFL" sort_coalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y) sort_coalesceFL2 NilFL = NilFL sort_coalesceFL2 (x:>:xs) | IsEq <- nullP x = sort_coalesceFL2 xs@@ -535,8 +551,8 @@       Just new' | IsEq <- nullP new' -> Right ps'                 | otherwise -> Right $ either id id $ push_coalesce_patch new' ps'       Nothing -> if comparePrim new p == LT then Left (new:>:ps)-                            else case commutex (p :< new) of-                                 Just (new' :< p') ->+                            else case commute (new :> p) of+                                 Just (p' :> new') ->                                      case push_coalesce_patch new' ps' of                                      Right r -> Right $ either id id $                                                 push_coalesce_patch p' r@@ -628,20 +644,29 @@  instance Commute Prim where     merge (y :\/: z) =-        case elegant_merge (y:\/:z) of+        case elegantMerge (y:\/:z) of         Just (z' :/\: y') -> z' :/\: y'         Nothing -> error "Commute Prim merge"-    commutex x = toMaybe $ msum [speedy_commute x,-                                 everything_else_commute x-                                ]+    commute x = toMaybe $ msum [toFwdCommute speedy_commute x,+                                toFwdCommute everything_else_commute x+                               ]     -- Recurse on everything, these are potentially spoofed patches-    list_touched_files (Move f1 f2) = map fn2fp [f1, f2]-    list_touched_files (Split ps) = nubsort $ concat $ mapFL list_touched_files ps-    list_touched_files (FP f _) = [fn2fp f]-    list_touched_files (DP d _) = [fn2fp d]-    list_touched_files (ChangePref _ _ _) = []-    list_touched_files Identity = []+    listTouchedFiles (Move f1 f2) = map fn2fp [f1, f2]+    listTouchedFiles (Split ps) = nubsort $ concat $ mapFL listTouchedFiles ps+    listTouchedFiles (FP f _) = [fn2fp f]+    listTouchedFiles (DP d _) = [fn2fp d]+    listTouchedFiles (ChangePref _ _ _) = []+    listTouchedFiles Identity = [] +    hunkMatches f (FP _ (Hunk _ remove add)) = anyMatches remove || anyMatches add+        where anyMatches = foldr ((||) . f) False+    hunkMatches _ (FP _ _) = False+    hunkMatches f (Split ps) = or $ mapFL (hunkMatches f) ps+    hunkMatches _ (DP _ _) = False+    hunkMatches _ (ChangePref _ _ _) = False+    hunkMatches _ Identity = False+    hunkMatches _ (Move _ _) = False+ is_filepatch :: Prim C(x y) -> Maybe FileName is_filepatch (FP f _) = Just f is_filepatch _ = Nothing@@ -690,12 +715,12 @@     [("speedy_commute", speedy_commute),      ("commute_filedir", clever_commute commute_filedir),      ("commute_filepatches", clever_commute commute_filepatches),-     ("commutex", toPerhaps . commutex)+     ("commutex", toPerhaps . toRevCommute commute)     ] -elegant_merge :: (Prim :\/: Prim) C(x y)+elegantMerge :: (Prim :\/: Prim) C(x y)               -> Maybe ((Prim :/\: Prim) C(x y))-elegant_merge (p1 :\/: p2) =+elegantMerge (p1 :\/: p2) =     do p1':>ip2' <- commute (invert p2 :> p1)        -- The following should be a redundant check        p1o:>_ <- commute (p2 :> p1')@@ -711,7 +736,7 @@ old and new version of a file. \begin{code} canonize :: Prim C(x y) -> FL Prim C(x y)-canonize (Split ps) = sort_coalesceFL ps+canonize (Split ps) = sortCoalesceFL ps canonize p | IsEq <- is_identity p = NilFL canonize (FP f (Hunk line old new)) = canonizeHunk f line old new canonize p = p :>: NilFL@@ -998,11 +1023,11 @@     joinPatches = concatRL . reverseFL  class (Invert p, Commute p, Effect p) => Conflict p where-    list_conflicted_files :: p C(x y) -> [FilePath]-    list_conflicted_files p =-        nubsort $ concatMap (unseal list_touched_files) $ concat $ resolve_conflicts p-    resolve_conflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]]-    resolve_conflicts _ = []+    listConflictedFiles :: p C(x y) -> [FilePath]+    listConflictedFiles p =+        nubsort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p+    resolveConflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]]+    resolveConflicts _ = []     -- | If 'commute_no_conflicts' @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@@ -1045,14 +1070,14 @@            IsEq <- return $ ix'' =\/= invert x'            return (y':>x')     conflictedEffect :: p C(x y) -> [IsConflictedPrim]-    conflictedEffect x = case list_conflicted_files x of+    conflictedEffect x = case listConflictedFiles x of                          [] -> mapFL (IsC Okay) $ effect x                          _ -> mapFL (IsC Conflicted) $ effect x  instance Conflict p => Conflict (FL p) where-    list_conflicted_files = nubsort . concat . mapFL list_conflicted_files-    resolve_conflicts NilFL = []-    resolve_conflicts x = resolve_conflicts $ reverseFL x+    listConflictedFiles = nubsort . concat . mapFL listConflictedFiles+    resolveConflicts NilFL = []+    resolveConflicts x = resolveConflicts $ reverseFL x     commute_no_conflicts (NilFL :> x) = Just (x :> NilFL)     commute_no_conflicts (x :> NilFL) = Just (NilFL :> x)     commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (reverseFL xs :> ys)@@ -1060,13 +1085,13 @@     conflictedEffect = concat . mapFL conflictedEffect  instance Conflict p => Conflict (RL p) where-    list_conflicted_files = nubsort . concat . mapRL list_conflicted_files-    resolve_conflicts x = rcs x NilFL+    listConflictedFiles = nubsort . concat . mapRL listConflictedFiles+    resolveConflicts x = rcs x NilFL         where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL Prim C(w))]]               rcs NilRL _ = []-              rcs (p:<:ps) passedby | (_:_) <- resolve_conflicts p =+              rcs (p:<:ps) passedby | (_:_) <- resolveConflicts p =                   case commute_no_conflictsFL (p:>passedby) of-                    Just (_:> p') -> resolve_conflicts p' ++ rcs ps (p:>:passedby)+                    Just (_:> p') -> resolveConflicts p' ++ rcs ps (p:>:passedby)                     Nothing -> rcs ps (p:>:passedby)               rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby)     commute_no_conflicts (NilRL :> x) = Just (x :> NilRL)@@ -1096,7 +1121,7 @@              | otherwise = p :>: NilFL     effectRL p | IsEq <- sloppyIdentity p = NilRL                | otherwise = p :<: NilRL-    isHunk p = if is_hunk p then Just p else Nothing+    isHunk p = if primIsHunk p then Just p else Nothing  instance Conflict Prim
src/Darcs/Patch/Properties.lhs view
@@ -42,13 +42,13 @@                                 join_inverses, join_commute ) where  import Control.Monad ( msum, mplus )-import Darcs.Show ( Show2(..) )+import Darcs.Witnesses.Show ( Show2(..) ) import Darcs.Patch.Patchy import Darcs.Patch.Prim import Darcs.Patch () import Darcs.Patch.Read ( readPatch )-import Darcs.Ordered-import Darcs.Sealed ( Sealed(Sealed) )+import Darcs.Witnesses.Ordered+import Darcs.Witnesses.Sealed ( Sealed(Sealed) ) import Printer ( Doc, renderPS, redText, greenText, ($$) ) --import Darcs.ColorPrinter ( traceDoc ) \end{code}
src/Darcs/Patch/Read.hs view
@@ -44,8 +44,8 @@                                parse_strictly, peek_input, lex_string, lex_eof, my_lex) #include "impossible.h" import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL )-import Darcs.Ordered ( FL(..) )-import Darcs.Sealed ( Sealed(..), seal, mapSeal )+import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal )  readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString) readPatch ps = case parse_strictly (readPatch' False) ps of@@ -60,10 +60,10 @@           _ -> return Nothing  instance ReadPatch Prim where- readPatch' w = readPrim OldFormat w+ readPatch' _ = readPrim OldFormat -readPrim :: ParserM m => FileNameFormat -> Bool -> m (Maybe (Sealed (Prim C(x ))))-readPrim x _+readPrim :: ParserM m => FileNameFormat -> m (Maybe (Sealed (Prim C(x ))))+readPrim x    = do s <- peek_input         case liftM (BC.unpack . fst) $ my_lex s of           Just "{}" ->         do work my_lex@@ -95,7 +95,7 @@  read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x ))) read_patches x str want_eof- = do mp <- readPrim x False+ = do mp <- readPrim x       case mp of           Nothing -> do unit <- lex_string str                         case unit of
src/Darcs/Patch/Real.hs view
@@ -33,7 +33,7 @@                           IsConflictedPrim(..), ConflictState(..) ) import Darcs.Patch.Read ( readPrim ) import Darcs.Patch.Patchy-import Darcs.Ordered+import Darcs.Witnesses.Ordered --import Darcs.Patch.Read () --import Darcs.Patch.Viewing () --import Darcs.Patch.Apply ()@@ -45,11 +45,11 @@ import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL,                                   genCommuteWhatWeCanRL,                                   removeRL, removeFL, remove_subsequenceFL )-import qualified Data.ByteString.Char8 as BC ( unpack )-import Darcs.Patch.ReadMonads (work, peek_input, my_lex )+import qualified Data.ByteString.Char8 as BC ( ByteString, unpack )+import Darcs.Patch.ReadMonads ( work, peek_input, my_lex ) import Darcs.Utils ( nubsort )-import Darcs.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal )-import Darcs.Show+import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal )+import Darcs.Witnesses.Show import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) ) import Darcs.ColorPrinter ( errorDoc, assertDoc ) --import Printer ( greenText )@@ -291,7 +291,7 @@     conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]     conflictedEffect (InvConflictor _ _ _) = impossible     conflictedEffect (Normal x) = [IsC Okay x]-    resolve_conflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled]+    resolveConflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled]             where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx)                   nonxx = nonxx_ (nonxx_aux ix xx)                   nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y)@@ -303,7 +303,7 @@                   isn :: Sealed (FL p C(x)) -> Bool                   isn (Sealed NilFL) = False                   isn _ = True-    resolve_conflicts _ = []+    resolveConflicts _ = []      -- cA     commute_no_conflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x)@@ -406,8 +406,11 @@     where nix = Normal $ invert x  nonTouches :: Non RealPatch C(x) -> [FilePath]-nonTouches (Non c x) = list_touched_files (c +>+ fromPrim x :>: NilFL)+nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL) +nonHunkMatches :: (BC.ByteString -> Bool) -> Non RealPatch C(x) -> Bool+nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x+ toNons :: (Conflict p, Patchy p, ToFromPrim p, Nonable p) => FL p C(x y) -> [Non p C(x)] toNons xs = map lastNon $ initsFL xs     where lastNon :: (Conflict p, Patchy p, Nonable p) => Sealed ((p :> FL p) C(x)) -> Non p C(x)@@ -592,14 +595,20 @@             Nothing -> impossible pullInContext fromNons --    merge _ = error "haven't finished fixing merge" -    list_touched_files (Duplicate p) = nonTouches p-    list_touched_files (Etacilpud p) = nonTouches p-    list_touched_files (Normal p) = list_touched_files p-    list_touched_files (Conflictor x c p) =-        nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p-    list_touched_files (InvConflictor x c p) =-        nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p+    listTouchedFiles (Duplicate p) = nonTouches p+    listTouchedFiles (Etacilpud p) = nonTouches p+    listTouchedFiles (Normal p) = listTouchedFiles p+    listTouchedFiles (Conflictor x c p) =+        nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p+    listTouchedFiles (InvConflictor x c p) =+        nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p +    hunkMatches f (Duplicate p) = nonHunkMatches f p+    hunkMatches f (Etacilpud p) = nonHunkMatches f p+    hunkMatches f (Normal p) = hunkMatches f p+    hunkMatches f (Conflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p]+    hunkMatches f (InvConflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p]+ {- all_conflicts_withFL :: FL Prim C(x y) -> [Non RealPatch C(x)]                      -> ([Non RealPatch C(x)], [Non RealPatch C(x)])@@ -714,11 +723,11 @@         showPatch cs $$         blueText "]" $$         showNon p-    showContextPatch s (Normal p) = showContextPatch s p-    showContextPatch _ c = showPatch c+    showContextPatch (Normal p) = showContextPatch p+    showContextPatch c = return $ showPatch c  instance ReadPatch RealPatch where- readPatch' want_eof =+ readPatch' _ =      do s <- peek_input         case fmap (BC.unpack . fst) $ my_lex s of           Just "duplicate" ->@@ -744,7 +753,7 @@                  Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')                  Just p <- readNon                  return $ Just $ Sealed $ InvConflictor i ps p-          _ -> do mp <- readPrim NewFormat want_eof+          _ -> do mp <- readPrim NewFormat                   case mp of                     Just p -> return $ Just $ Normal `mapSeal` p                     Nothing -> return Nothing
+ src/Darcs/Patch/RegChars.hs view
@@ -0,0 +1,75 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.+++module Darcs.Patch.RegChars ( regChars,+                ) where++(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+(&&&) a b c = a c && b c++(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+(|||) a b c = a c || b c++{-# INLINE regChars #-}++-- | 'regChars' returns a filter function that tells if a char is a member+-- of the regChar expression or not. The regChar expression is basically a+-- set of chars, but it can contain ranges with use of the '-' (dash), and+-- it can also be specified as a complement set by prefixing with '^'+-- (caret). The dash and caret, as well as the backslash, can all be+-- escaped with a backslash to suppress their special meaning.+-- +-- NOTE: The '.' (dot) is allowed to be escaped. It has no special meaning+-- if it is not escaped, but the default 'filename_toks' in+-- Darcs.Commands.Replace uses an escaped dot (WHY?).++regChars :: String -> (Char -> Bool)+regChars ('^':cs) = not . normalRegChars (unescapeChars cs)+regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs+regChars cs = normalRegChars $ unescapeChars cs++{-# INLINE unescapeChars #-}++-- | 'unescapeChars' unescapes whitespace, which is escaped in the replace+-- patch file format. It will also unescape escaped carets, which is useful+-- for escaping a leading caret that should not invert the regChars. All+-- other escapes are left for the unescaping in 'normalRegChars'.++unescapeChars :: String -> String+unescapeChars ('\\':'n':cs) = '\n' : unescapeChars cs+unescapeChars ('\\':'t':cs) = '\t' : unescapeChars cs+unescapeChars ('\\':'^':cs) = '^' : unescapeChars cs+unescapeChars (c:cs) = c : unescapeChars cs+unescapeChars [] = []++{-# INLINE normalRegChars #-}++-- | 'normalRegChars' assembles the filter function. It handles special+-- chars, and also unescaping of escaped special chars. If a non-special+-- char is still escaped by now we get a failure.++normalRegChars :: String -> (Char -> Bool)+normalRegChars ('\\':'.':cs) = (=='.') ||| normalRegChars cs+normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs+normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs+normalRegChars ('\\':c:_) = error $ "'\\"++[c]++"' not supported."+normalRegChars (c1:'-':c2:cs) = ((>= c1) &&& (<= c2)) ||| normalRegChars cs+normalRegChars (c:cs) = (== c) ||| normalRegChars cs+normalRegChars [] = \_ -> False++
src/Darcs/Patch/Set.hs view
@@ -23,8 +23,8 @@ module Darcs.Patch.Set ( PatchSet, SealedPatchSet ) where  import Darcs.Hopefully ( PatchInfoAnd )-import Darcs.Ordered ( RL )-import Darcs.Sealed ( Sealed )+import Darcs.Witnesses.Ordered ( RL )+import Darcs.Witnesses.Sealed ( Sealed )  -- | A PatchSet is in reverse order, plus has information about which -- tags are clean, meaning all patches applied prior to them are in
src/Darcs/Patch/Show.lhs view
@@ -31,7 +31,7 @@ import Darcs.Patch.Core ( Patch(..) ) import Darcs.Patch.Prim ( showPrim, FileNameFormat(..) ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo )-import Darcs.Ordered ( FL(NilFL), mapFL )+import Darcs.Witnesses.Ordered ( FL(NilFL), mapFL ) #include "gadts.h" \end{code}
+ src/Darcs/Patch/Split.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE CPP, RankNTypes, GADTs #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+-- Copyright (C) 2009 Ganesh Sittampalam+--+-- Permission is hereby granted, free of charge, to any person+-- obtaining a copy of this software and associated documentation+-- files (the "Software"), to deal in the Software without+-- restriction, including without limitation the rights to use, copy,+-- modify, merge, publish, distribute, sublicense, and/or sell copies+-- of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:+--+-- The above copyright notice and this permission notice shall be+-- included in all copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE.++module Darcs.Patch.Split ( Splitter(..), rawSplitter, noSplitter, primSplitter ) where++import Data.List ( intersperse )++import Darcs.Witnesses.Ordered+import Darcs.Witnesses.Sealed++import Darcs.Patch.Patchy ( ReadPatch(..), ShowPatch(..), Invert(..) )+import Darcs.Patch.Prim ( Prim(..), FilePatchType(..), canonize, canonizeFL )+import Darcs.Patch.ReadMonads ( parse_strictly )+import Darcs.Patch.Read ()+import Darcs.Patch.Viewing ()++import Printer ( renderPS )++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC++#include "gadts.h"++-- |A splitter is something that can take a patch and (possibly) render it+-- as text in some format of its own choosing.+-- This text can then be presented to the user for editing, and the result+-- given to the splitter for parsing.+-- If the parse succeeds, the result is a list of patches that could replace+-- the original patch in any context.+-- Typically this list will contain the changed version of the patch, along+-- with fixup pieces to ensure that the overall effect of the list is the same+-- as the original patch.+-- The individual elements of the list can then be offered separately to the+-- user, allowing them to accept some and reject others.+--+-- There's no immediate application for a splitter for anything other than+-- Prim (you shouldn't go editing named patches, you'll break them!)+-- However you might want to compose splitters for FilePatchType to make+-- splitters for Prim etc, and the generality doesn't cost anything.+data Splitter p+  = Splitter {+              applySplitter :: FORALL(x y) p C(x y)+                              -> Maybe (B.ByteString,+                                        B.ByteString -> Maybe (FL p C(x y)))+              -- canonization is needed to undo the effects of splitting+              -- Typically, the list returned by applySplitter will not+              -- be in the simplest possible form (since the user will have+              -- deliberately added extra stuff). Once the user has selected+              -- the pieces they want, we need to make sure that we eliminate+              -- any remaining redundancy in the selected pieces, otherwise+              -- we might record (or whatever) a rather strange looking patch.+              -- This hook allows the splitter to provide an appropriate+              -- function for doing this.+             ,canonizeSplit :: FORALL(x y) FL p C(x y) -> FL p C(x y)+             }++{- Some facts that probably ought to be true about splitters: should make some QC+properties++applySplitter p = Just (bs, f) ==> f bs == Just (p :>: NilFL)++applySplitter p = Just (bs, f) ; f bs' = Just ps ==> canonizeSplit ps = p :>: NilFL++-}++-- Does not canonize as there is no generic operation to do this.+withEditedHead :: Invert p => p C(x y) -> p C(x z) -> FL p C(x y)+withEditedHead p res = res :>: invert res :>: p :>: NilFL++-- |This generic splitter just lets the user edit the printed representation of the patch+-- Should not be used expect for testing and experimentation.+rawSplitter :: (ShowPatch p, ReadPatch p, Invert p) => Splitter p+rawSplitter = Splitter {+                  applySplitter =+                     \p -> Just (renderPS . showPatch $ p,+                                 \str -> case parse_strictly (readPatch' False) str of+                                          Just (Just (Sealed res), _) -> Just (withEditedHead p res)+                                          _ -> Nothing+                                )+                 ,canonizeSplit = id+                }++-- |Never splits. In other code we normally pass around Maybe Splitter instead of using this+-- as the default, because it saves clients that don't care about splitting from having to+-- import this module just to get noSplitter.+noSplitter :: Splitter p+noSplitter = Splitter { applySplitter = const Nothing, canonizeSplit = id }+++doPrimSplit :: Prim C(x y) -> Maybe (B.ByteString, B.ByteString -> Maybe (FL Prim C(x y)))+doPrimSplit (FP fn (Hunk n before after))+ = Just (B.concat $ intersperse (BC.pack "\n") $ (helptext ++ [sep] ++ before ++ [sep] ++ after ++ [sep]),+         \bs -> do let ls = BC.split '\n' bs+                   (_, ls') <- breakSep ls+                   (before', ls'') <- breakSep ls'+                   (after', _) <- breakSep ls''+                   return (hunk before before' +>+ hunk before' after' +>+ hunk after' after))+    where sep = BC.pack "==="+          helptext = map BC.pack ["Interactive hunk edit:",+                                  " - Edit the first set of lines to insert a new change before the current one.",+                                  " - Edit the second set of lines to insert a new change after the current one."]+          hunk b a = canonize (FP fn (Hunk n b a))+          breakSep xs = case break (==sep) xs of+                           (_, []) -> Nothing+                           (ys, _:zs) -> Just (ys, zs)+doPrimSplit _ = Nothing++-- |Split a primitive hunk patch up+-- by allowing the user to edit both the before and after lines, then insert fixup patches+-- to clean up the mess.+primSplitter :: Splitter Prim+primSplitter = Splitter { applySplitter = doPrimSplit, canonizeSplit = canonizeFL }
src/Darcs/Patch/TouchesFiles.hs view
@@ -24,67 +24,69 @@                       select_touching,                       deselect_not_touching, select_not_touching,                     ) where-import Data.List ( sort )+import Data.List ( sort, isSuffixOf )  import Darcs.Patch.Choices ( PatchChoices, Tag, TaggedPatch,-                             patch_choices, tag, get_choices,-                      force_firsts, force_lasts, tp_patch,+                             patchChoices, tag, getChoices,+                      forceFirsts, forceLasts, tpPatch,                     )-import Darcs.Patch ( Patchy, apply_to_filepaths, list_touched_files )-import Darcs.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) )-import Darcs.Sealed ( Sealed, seal )+import Darcs.Patch ( Patchy, applyToFilepaths, listTouchedFiles )+import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) )+import Darcs.Witnesses.Sealed ( Sealed, seal )  select_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) select_touching [] pc = pc-select_touching files pc = force_firsts xs pc+select_touching files pc = forceFirsts xs pc     where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]           ct _ NilFL = []-          ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of+          ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of                              (True, fs') -> tag tp:ct fs' tps                              (False, fs') -> ct fs' tps-          xs = case get_choices pc of+          xs = case getChoices pc of                _ :> mc :> lc -> ct (map fix files) (mc +>+ lc)  deselect_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) deselect_not_touching [] pc = pc-deselect_not_touching files pc = force_lasts xs pc+deselect_not_touching files pc = forceLasts xs pc     where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]           ct _ NilFL = []-          ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of+          ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of                              (True, fs') -> ct fs' tps                              (False, fs') -> tag tp:ct fs' tps-          xs = case get_choices pc of+          xs = case getChoices pc of                fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)  select_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) select_not_touching [] pc = pc-select_not_touching files pc = force_firsts xs pc+select_not_touching files pc = forceFirsts xs pc     where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]           ct _ NilFL = []-          ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of+          ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of                              (True, fs') -> ct fs' tps                              (False, fs') -> tag tp:ct fs' tps-          xs = case get_choices pc of+          xs = case getChoices pc of                fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)  fix :: FilePath -> FilePath-fix f | take 1 (reverse f) == "/" = fix $ reverse $ drop 1 $ reverse f+fix f | "/" `isSuffixOf` f = fix $ init f fix "" = "." fix "." = "." fix f = "./" ++ f  choose_touching :: Patchy p => [FilePath] -> FL p C(x y) -> Sealed (FL p C(x)) choose_touching [] p = seal p-choose_touching files p = case get_choices $ select_touching files $ patch_choices p of-                          fc :> _ :> _ -> seal $ mapFL_FL tp_patch fc+choose_touching files p = case getChoices $ select_touching files $ patchChoices p of+                          fc :> _ :> _ -> seal $ mapFL_FL tpPatch fc  look_touch :: Patchy p => [FilePath] -> p C(x y) -> (Bool, [FilePath])-look_touch fs p = (any (\tf -> any (affects tf) fs) (list_touched_files p)+look_touch fs p = (any (\tf -> any (affects tf) fs) (listTouchedFiles p)                    || fs' /= fs, fs')-    where affects touched f | touched == f = True-          affects t f = case splitAt (length f) t of-                        (t', '/':_) -> t' == f-                        _ -> case splitAt (length t) f of-                             (f', '/':_) -> f' == t-                             _ -> False-          fs' = sort $ apply_to_filepaths p fs+    where affects :: FilePath -> FilePath -> Bool+          affects touched f =  touched == f+                            || touched `isSubPathOf` f+                            || f `isSubPathOf` touched+          isSubPathOf :: FilePath -> FilePath -> Bool+          isSubPathOf sub path = case splitAt (length sub) path of+                                 (path', '/':_) -> path' == sub+                                 _ -> False+          fs' = sort $ applyToFilepaths p fs
src/Darcs/Patch/Viewing.hs view
@@ -18,17 +18,19 @@ {-# OPTIONS_GHC -cpp -fno-warn-orphans #-} {-# LANGUAGE CPP #-} -module Darcs.Patch.Viewing ( xml_summary, summarize )+module Darcs.Patch.Viewing ( xmlSummary, plainSummary )              where -import Prelude hiding ( pi )-import Control.Monad ( liftM )-import Data.List ( sort )+import Prelude hiding ( pi, readFile )+import Control.Monad.State.Strict ( gets )+import Control.Monad.Trans ( liftIO ) -import Darcs.SlurpDirectory ( Slurpy, get_slurp, get_filecontents )+import Storage.Hashed.Monad( TreeIO, fileExists, readFile, tree, virtualTreeIO )+import Storage.Hashed.AnchoredPath( floatPath ) import ByteStringUtils (linesPS )-import qualified Data.ByteString as B (null)-import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp )+import qualified Data.ByteString as BS (null, concat)+import qualified Data.ByteString.Lazy as BL (toChunks)+import Darcs.Patch.FileName ( FileName, fn2fp ) import Printer ( Doc, empty, vcat,                  text, blueText, Color(Cyan,Magenta), lineColor,                  minus, plus, ($$), (<+>), (<>),@@ -37,69 +39,76 @@                ) import Darcs.Patch.Core ( Patch(..), Named(..),                           patchcontents )-import Darcs.Patch.Prim ( Prim(..), is_hunk, isHunk, formatFileName, showPrim, FileNameFormat(..), Conflict(..),+import Darcs.Patch.Prim ( Prim(..), primIsHunk, isHunk, formatFileName, showPrim, FileNameFormat(..), Conflict(..),                           Effect, IsConflictedPrim(IsC), ConflictState(..),                           DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Patchy ( Patchy, Apply, ShowPatch(..), identity ) import Darcs.Patch.Show ( showPatch_, showNamedPrefix ) import Darcs.Patch.Info ( showPatchInfo, human_friendly )-import Darcs.Patch.Apply ( apply_to_slurpy )+import Darcs.Patch.Apply ( applyToTree ) #include "impossible.h" #include "gadts.h"-import Darcs.Ordered ( RL(..), FL(..),+import Darcs.Witnesses.Ordered ( RL(..), FL(..),                              mapFL, mapFL_FL, reverseRL )  instance ShowPatch Prim where     showPatch = showPrim OldFormat-    showContextPatch s p@(FP _ (Hunk _ _ _)) = showContextHunk s (PP p)-    showContextPatch s (Split ps) =-        blueText "(" $$ showContextSeries s (mapFL_FL PP ps)-                     <> blueText ")"-    showContextPatch _ p = showPatch p-    summary = gen_summary False . (:[]) . IsC Okay+    showContextPatch p@(FP _ (Hunk _ _ _)) = showContextHunk (PP p)+    showContextPatch (Split ps) =+        do x <- showContextSeries (mapFL_FL PP ps)+           return $ blueText "(" $$ x <> blueText ")"+    showContextPatch p = return $ showPatch p+    summary = vcat . map summChunkToLine . genSummary . (:[]) . IsC Okay     thing _ = "change" -summarize :: (Conflict e, Effect e) => e C(x y) -> Doc-summarize = gen_summary False . conflictedEffect+plainSummary :: (Conflict e, Effect e) => e C(x y) -> Doc+plainSummary = vcat . map summChunkToLine . genSummary . conflictedEffect  instance ShowPatch Patch where     showPatch = showPatch_-    showContextPatch s (PP x) | is_hunk x = showContextHunk s (PP x)-    showContextPatch _ (ComP NilFL) = blueText "{" $$ blueText "}"-    showContextPatch s (ComP ps) = blueText "{" $$ showContextSeries s ps-                                   $$ blueText "}"-    showContextPatch _ p = showPatch p-    summary = summarize+    showContextPatch (PP x) | primIsHunk x = showContextHunk (PP x)+    showContextPatch (ComP NilFL) = return $ blueText "{" $$ blueText "}"+    showContextPatch (ComP ps) =+        do x <- showContextSeries ps+           return $ blueText "{" $$ x $$ blueText "}"+    showContextPatch p = return $ showPatch p+    summary = plainSummary     thing _ = "change" -showContextSeries :: (Apply p, ShowPatch p, Effect p) => Slurpy -> FL p C(x y) -> Doc-showContextSeries slur patches = scs slur identity patches-    where scs :: (Apply p, ShowPatch p, Effect p) => Slurpy -> Prim C(w x) -> FL p C(x y) -> Doc-          scs s pold (p:>:ps) =-              case isHunk p of-              Nothing -> showContextPatch s p $$ scs s' identity ps+showContextSeries :: (Apply p, ShowPatch p, Effect p) => FL p C(x y) -> TreeIO Doc+showContextSeries patches = scs identity patches+    where scs :: (Apply p, ShowPatch p, Effect p) => Prim C(w x) -> FL p C(x y) -> TreeIO Doc+          scs pold (p:>:ps) = do+            s' <- gets tree >>= liftIO . applyToTree p+            case isHunk p of+              Nothing -> do a <- showContextPatch p+                            b <- liftIO $ virtualTreeIO (scs identity ps) s'+                            return $ a $$ fst b               Just hp ->                   case ps of-                  NilFL -> coolContextHunk s pold hp identity+                  NilFL -> coolContextHunk pold hp identity                   (p2:>:_) ->                       case isHunk p2 of-                      Nothing -> coolContextHunk s pold hp identity $$ scs s' hp ps-                      Just hp2 -> coolContextHunk s pold hp hp2 $$-                                  scs s' hp ps-              where s' =-                        fromJust $ apply_to_slurpy p s-          scs _ _ NilFL = empty+                      Nothing -> do a <- coolContextHunk pold hp identity+                                    b <- liftIO $ virtualTreeIO (scs hp ps) s'+                                    return $ a $$ fst b+                      Just hp2 -> do a <- coolContextHunk pold hp hp2+                                     b <- liftIO $ virtualTreeIO (scs hp ps) s'+                                     return $ a $$ fst b+          scs _ NilFL = return empty -showContextHunk :: (Apply p, ShowPatch p, Effect p) => Slurpy -> p C(x y) -> Doc-showContextHunk s p = case isHunk p of-                        Just h -> coolContextHunk s identity h identity-                        Nothing -> showPatch p+showContextHunk :: (Apply p, ShowPatch p, Effect p) => p C(x y) -> TreeIO Doc+showContextHunk p = case isHunk p of+                      Just h -> coolContextHunk identity h identity+                      Nothing -> return $ showPatch p -coolContextHunk :: Slurpy -> Prim C(a b) -> Prim C(b c)-                -> Prim C(c d) -> Doc-coolContextHunk s prev p@(FP f (Hunk l o n)) next =-    case (linesPS . get_filecontents) `liftM` get_slurp f s of-    Nothing -> showPatch p -- This is a weird error...+coolContextHunk :: Prim C(a b) -> Prim C(b c) -> Prim C(c d) -> TreeIO Doc+coolContextHunk prev p@(FP f (Hunk l o n)) next = do+  let path = floatPath $ fn2fp f+  have <- fileExists path+  content <- if have then Just `fmap` readFile path else return Nothing+  case (linesPS . BS.concat . BL.toChunks) `fmap` content of -- sigh+    Nothing -> return $ showPatch p -- This is a weird error...     Just ls ->         let numpre = case prev of                      (FP f' (Hunk lprev _ nprev))@@ -116,19 +125,19 @@                               lnext - (l+length n)                       _ -> 3             cleanedls = case reverse ls of-                        (x:xs) | B.null x -> reverse xs+                        (x:xs) | BS.null x -> reverse xs                         _ -> ls             post = take numpost $ drop (max 0 $ l+length o-1) cleanedls-            in blueText "hunk" <+> formatFileName OldFormat f <+> text (show l)+            in return $ blueText "hunk" <+> formatFileName OldFormat f <+> text (show l)             $$ prefix " " (vcat $ map userchunkPS pre)             $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o))             $$ lineColor Cyan    (prefix "+" (vcat $ map userchunkPS n))             $$ prefix " " (vcat $ map userchunkPS post)-coolContextHunk _ _ _ _ = impossible+coolContextHunk _ _ _ = impossible -xml_summary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc-xml_summary p = text "<summary>"-             $$ gen_summary True (conflictedEffect $ patchcontents p)+xmlSummary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc+xmlSummary p = text "<summary>"+             $$ (vcat . map summChunkToXML . genSummary . conflictedEffect . patchcontents $ p)              $$ text "</summary>"  -- Yuck duplicated code below...@@ -143,165 +152,124 @@   | otherwise = z : (strReplace x y zs) -- end yuck duplicated code. -gen_summary :: Bool -> [IsConflictedPrim] -> Doc-gen_summary use_xml p-    = vcat themoves-   $$ vcat themods-    where themods = map summ $ combine $ sort $ concatMap s2 p-          s2 :: IsConflictedPrim -> [(FileName, Int, Int, Int, Bool, ConflictState)]-          s2 (IsC c x) = map (append56 c) $ s x-          s :: Prim C(x y) -> [(FileName, Int, Int, Int, Bool)]-          s (FP f (Hunk _ o n)) = [(f, length o, length n, 0, False)]-          s (FP f (Binary _ _)) = [(f, 0, 0, 0, False)]-          s (FP f AddFile) = [(f, -1, 0, 0, False)]-          s (FP f RmFile) = [(f, 0, -1, 0, False)]-          s (FP f (TokReplace _ _ _)) = [(f, 0, 0, 1, False)]-          s (DP d AddDir) = [(d, -1, 0, 0, True)]-          s (DP d RmDir) = [(d, 0, -1, 0, True)]+-- | High-level representation of a piece of patch summary+data SummChunk = SummChunk SummDetail ConflictState+   deriving (Ord, Eq)++data SummDetail = SummAddDir FileName+                | SummRmDir  FileName+                | SummFile SummOp FileName Int Int Int+                | SummMv   FileName FileName+                | SummNone+  deriving (Ord, Eq)++data SummOp = SummAdd | SummRm | SummMod deriving (Ord, Eq)++genSummary :: [IsConflictedPrim] -> [SummChunk]+genSummary p+    = combine $ concatMap s2 p+    where s2 :: IsConflictedPrim -> [SummChunk]+          s2 (IsC c x) = map (\d -> SummChunk d c) $ s x+          s :: Prim C(x y) -> [SummDetail]+          s (FP f (Hunk _ o n)) = [SummFile SummMod f (length o) (length n) 0]+          s (FP f (Binary _ _)) = [SummFile SummMod f 0 0 0]+          s (FP f AddFile) = [SummFile SummAdd f 0 0 0]+          s (FP f RmFile) = [SummFile SummRm f 0 0 0]+          s (FP f (TokReplace _ _ _)) = [SummFile SummMod f 0 0 1]+          s (DP d AddDir) = [SummAddDir d]+          s (DP d RmDir) = [SummRmDir d]           s (Split xs) = concat $ mapFL s xs-          s (Move _ _) = [(fp2fn "", 0, 0, 0, False)]-          s (ChangePref _ _ _) = [(fp2fn "", 0, 0, 0, False)]-          s Identity = [(fp2fn "", 0, 0, 0, False)]-          append56 f (a,b,c,d,e) = (a,b,c,d,e,f)-          (-1) .+ _ = -1-          _ .+ (-1) = -1-          a .+ b = a + b-          combine ((f,a,b,r,isd,c):(f',a',b',r',_,c'):ss)-              -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs-              -- allows a single patch to add and remove the same file, see issue 185-              | f == f' && (a /= -1 || b' /= -1) && (a' /= -1 || b /= -1) =-                  combine ((f,a.+a',b.+b',r+r',isd,combineConflitStates c c'):ss)-          combine ((f,a,b,r,isd,c):ss) = (f,a,b,r,isd,c) : combine ss+          s (Move f1 f2) = [SummMv f1 f2]+          s (ChangePref _ _ _) = [SummNone]+          s Identity = [SummNone]+          combine (x1@(SummChunk d1 c1) : x2@(SummChunk d2 c2) : ss)+              = case combineDetail d1 d2 of+                  Nothing -> x1 : combine (x2:ss)+                  Just d3 -> combine $ SummChunk d3 (combineConflitStates c1 c2) : ss+          combine (x:ss) = x  : combine ss           combine [] = []+          --+          combineDetail (SummFile o1 f1 r1 a1 x1) (SummFile o2 f2 r2 a2 x2) | f1 == f2 =+            do o3 <- combineOp o1 o2+               return $ SummFile o3 f1 (r1 + r2) (a1 + a2) (x1 + x2)+          combineDetail _ _ = Nothing+          --           combineConflitStates Conflicted _ = Conflicted           combineConflitStates _ Conflicted = Conflicted           combineConflitStates Duplicated _ = Duplicated           combineConflitStates _ Duplicated = Duplicated           combineConflitStates Okay Okay = Okay+          -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs+          -- allows a single patch to add and remove the same file, see issue 185+          combineOp SummAdd SummRm  = Nothing+          combineOp SummRm  SummAdd = Nothing+          combineOp SummAdd _ = Just SummAdd+          combineOp _ SummAdd = Just SummAdd+          combineOp SummRm  _ = Just SummRm+          combineOp _ SummRm  = Just SummRm+          combineOp SummMod SummMod = Just SummMod -          summ (f,_,-1,_,False,Okay)-              = if use_xml then text "<remove_file>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</remove_file>"-                           else text "R" <+> text (fn2fp f)-          summ (f,_,-1,_,False,Conflicted)-              = if use_xml then text "<remove_file conflict='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</remove_file>"-                           else text "R!" <+> text (fn2fp f)-          summ (f,_,-1,_,False,Duplicated)-              = if use_xml then text "<remove_file duplicate='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</remove_file>"-                           else text "R" <+> text (fn2fp f) <+> text "(duplicate)"-          summ (f,-1,_,_,False,Okay)-              = if use_xml then text "<add_file>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</add_file>"-                           else text "A" <+> text (fn2fp f)-          summ (f,-1,_,_,False,Conflicted)-              = if use_xml then text "<add_file conflict='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</add_file>"-                           else text "A!" <+> text (fn2fp f)-          summ (f,-1,_,_,False,Duplicated)-              = if use_xml then text "<add_file duplicate='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</add_file>"-                           else text "A" <+> text (fn2fp f) <+> text "(duplicate)"-          summ (f,0,0,0,False,Okay) | f == fp2fn "" = empty-          summ (f,0,0,0,False,Conflicted) | f == fp2fn ""-              = if use_xml then empty -- don't know what to do here...-                           else text "!" <+> text (fn2fp f)-          summ (f,0,0,0,False,Duplicated) | f == fp2fn ""-              = if use_xml then empty -- don't know what to do here...-                           else text (fn2fp f) <+> text "(duplicate)"-          summ (f,a,b,r,False,Okay)-              = if use_xml then text "<modify_file>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                                    <> xrm a <> xad b <> xrp r-                             $$ text "</modify_file>"-                           else text "M" <+> text (fn2fp f)-                                         <+> rm a <+> ad b <+> rp r-          summ (f,a,b,r,False,Conflicted)-              = if use_xml then text "<modify_file conflict='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                                    <> xrm a <> xad b <> xrp r-                             $$ text "</modify_file>"-                           else text "M!" <+> text (fn2fp f)-                                    <+> rm a <+> ad b <+> rp r-          summ (f,a,b,r,False,Duplicated)-              = if use_xml then text "<modify_file duplicate='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                                    <> xrm a <> xad b <> xrp r-                             $$ text "</modify_file>"-                           else text "M" <+> text (fn2fp f)-                                    <+> rm a <+> ad b <+> rp r <+> text "(duplicate)"-          summ (f,_,-1,_,True,Okay)-              = if use_xml then text "<remove_directory>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</remove_directory>"-                           else text "R" <+> text (fn2fp f) <> text "/"-          summ (f,_,-1,_,True,Conflicted)-              = if use_xml then text "<remove_directory conflict='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</remove_directory>"-                           else text "R!" <+> text (fn2fp f) <> text "/"-          summ (f,_,-1,_,True,Duplicated)-              = if use_xml then text "<remove_directory duplicate='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</remove_directory>"-                           else text "R" <+> text (fn2fp f) <> text "/ (duplicate)"-          summ (f,-1,_,_,True,Okay)-              = if use_xml then text "<add_directory>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</add_directory>"-                           else text "A" <+> text (fn2fp f) <> text "/"-          summ (f,-1,_,_,True,Conflicted)-              = if use_xml then text "<add_directory conflict='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</add_directory>"-                           else text "A!" <+> text (fn2fp f) <> text "/"-          summ (f,-1,_,_,True,Duplicated)-              = if use_xml then text "<add_directory duplicate='true'>"-                             $$ escapeXML (drop_dotslash $ fn2fp f)-                             $$ text "</add_directory>"-                           else text "A!" <+> text (fn2fp f) <> text "/ (duplicate)"-          summ _ = empty-          ad 0 = empty-          ad a = plus <> text (show a)-          xad 0 = empty-          xad a = text "<added_lines num='" <> text (show a) <> text "'/>"-          rm 0 = empty-          rm a = minus <> text (show a)-          xrm 0 = empty-          xrm a = text "<removed_lines num='" <> text (show a) <> text "'/>"-          rp 0 = empty-          rp a = text "r" <> text (show a)-          xrp 0 = empty-          xrp a = text "<replaced_tokens num='" <> text (show a) <> text "'/>"-          drop_dotslash ('.':'/':str) = drop_dotslash str-          drop_dotslash str = str-          themoves :: [Doc]-          themoves = map showmoves p-          showmoves :: IsConflictedPrim -> Doc-          showmoves (IsC _ (Move a b))-              = if use_xml-                then text "<move from=\""-                  <> escapeXML (drop_dotslash $ fn2fp a) <> text "\" to=\""-                  <> escapeXML (drop_dotslash $ fn2fp b) <> text"\"/>"-                else text " "    <> text (fn2fp a)-                  <> text " -> " <> text (fn2fp b)-          showmoves _ = empty+summChunkToXML :: SummChunk -> Doc+summChunkToXML (SummChunk detail c) =+ case detail of+   SummRmDir f  -> xconf c "remove_directory" (xfn f)+   SummAddDir f -> xconf c "add_directory"    (xfn f)+   SummFile SummRm  f _ _ _ -> xconf c "remove_file" (xfn f)+   SummFile SummAdd f _ _ _ -> xconf c "add_file"    (xfn f)+   SummFile SummMod f r a x -> xconf c "modify_file" $ xfn f <> xrm r <> xad a <> xrp x+   SummMv f1 f2  -> text "<move from=\"" <> xfn f1+                      <> text "\" to=\"" <> xfn f2 <> text"\"/>"+   SummNone      -> empty+ where+   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+   --+   xad 0 = empty+   xad a = text "<added_lines num='" <> text (show a) <> text "'/>"+   xrm 0 = empty+   xrm a = text "<removed_lines num='" <> text (show a) <> text "'/>"+   xrp 0 = empty+   xrp a = text "<replaced_tokens num='" <> text (show a) <> text "'/>" +summChunkToLine :: SummChunk -> Doc+summChunkToLine (SummChunk detail c) =+  case detail of+   SummRmDir f   -> lconf c "R" $ text (fn2fp f) <> text "/"+   SummAddDir f  -> lconf c "A" $ text (fn2fp f) <> text "/"+   SummFile SummRm  f _ _ _ -> lconf c "R" $ text (fn2fp f)+   SummFile SummAdd f _ _ _ -> lconf c "A" $ text (fn2fp f)+   SummFile SummMod f r a x -> lconf c "M" $ text (fn2fp f) <+> rm r <+> ad a <+> rp x+   SummMv f1 f2 -> text " "    <> text (fn2fp f1)+                <> text " -> " <> text (fn2fp f2)+   SummNone -> case c of+               Okay -> empty+               _    -> lconf c ""  empty+  where+   lconf Okay       t x = text t <+> x+   lconf Conflicted t x = text (t ++ "!") <+> x+   lconf Duplicated t x = text t <+> x <+> text "duplicate"+   --+   ad 0 = empty+   ad a = plus <> text (show a)+   rm 0 = empty+   rm a = minus <> text (show a)+   rp 0 = empty+   rp a = text "r" <> text (show a)++dropDotSlash :: FilePath -> FilePath+dropDotSlash ('.':'/':str) = dropDotSlash str+dropDotSlash str = str+ instance (Conflict p, ShowPatch p) => ShowPatch (Named p) where     showPatch (NamedP n [] p) = showPatchInfo n <> showPatch p     showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p-    showContextPatch s (NamedP n [] p) = showPatchInfo n <> showContextPatch s p-    showContextPatch s (NamedP n d p) = showNamedPrefix n d <+> showContextPatch s p+    showContextPatch (NamedP n [] p) = showContextPatch p >>= return . (showPatchInfo n <>)+    showContextPatch (NamedP n d p) = showContextPatch p >>= return . (showNamedPrefix n d <+>)     description (NamedP n _ _) = human_friendly n     summary p = description p $$ text "" $$-                prefix "    " (summarize p) -- this isn't summary because summary does the+                prefix "    " (plainSummary p) -- this isn't summary because summary does the                                             -- wrong thing with (Named (FL p)) so that it can                                             -- get the summary of a sequence of named patches                                             -- right.@@ -323,7 +291,7 @@  instance (Conflict p, Apply p, ShowPatch p) => ShowPatch (RL p) where     showPatch = showPatch . reverseRL-    showContextPatch s = showContextPatch s . reverseRL+    showContextPatch = showContextPatch . reverseRL     description = description . reverseRL     summary = summary . reverseRL     thing = thing . reverseRL
src/Darcs/Population.hs view
@@ -37,10 +37,10 @@ import Darcs.Patch.FileName ( fn2fp, fp2fn, fn2ps, norm_path ) import Darcs.Patch ( RepoPatch, applyToPop, patchcontents, patchChanges,                      Effect, effect )-import Darcs.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL ) import Darcs.Patch.Info ( PatchInfo, idpatchinfo, to_xml ) import Darcs.Patch.Set ( PatchSet )-import Darcs.Sealed ( Sealed(..), seal, unseal )+import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal ) import Darcs.Repository ( withRepositoryDirectory, ($-), read_repo ) import Darcs.Repository.Pristine ( identifyPristine, getPristinePop ) import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..),
src/Darcs/PopulationData.hs view
@@ -103,7 +103,7 @@           then do            fnames <- getDirectoryContents dirname            sl <- withCurrentDirectory dirname-                 (sequence $ map getPopFrom_helper $ filter not_hidden fnames)+                 (mapM getPopFrom_helper $ filter not_hidden fnames)            let i = Info {nameI = n,                          modifiedByI = pinfo,                          modifiedHowI = DullDir,
src/Darcs/PrintPatch.hs view
@@ -24,7 +24,8 @@                           printPatchPager, printFriendly ) where  import Darcs.Patch ( Patchy, showContextPatch, showPatch )-import Darcs.SlurpDirectory ( Slurpy )+import Storage.Hashed.Tree( Tree )+import Storage.Hashed.Monad( virtualTreeIO ) import Darcs.Arguments ( DarcsFlag, showFriendly ) import Printer ( putDocLnWith ) import Darcs.ColorPrinter ( fancyPrinters )@@ -46,5 +47,5 @@  -- | 'contextualPrintPatch' prints a patch, together with its context, -- on standard output.-contextualPrintPatch :: Patchy p => Slurpy -> p C(x y) -> IO ()-contextualPrintPatch s p = putDocLnWith fancyPrinters $ showContextPatch s p+contextualPrintPatch :: Patchy p => Tree IO -> p C(x y) -> IO ()+contextualPrintPatch s p = virtualTreeIO (showContextPatch p) s >>= putDocLnWith fancyPrinters . fst
src/Darcs/ProgressPatches.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, GADTs #-}  #include "gadts.h" module Darcs.ProgressPatches (progressRL, progressFL, progressRLShowTags) where-import Darcs.Ordered ( FL(..), RL(..), lengthRL, lengthFL )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthRL, lengthFL ) import Darcs.Hopefully (PatchInfoAnd,info) import System.IO.Unsafe ( unsafePerformIO ) import Progress (minlist, beginTedious,
src/Darcs/RemoteApply.hs view
@@ -20,7 +20,7 @@                         then apply_via_url opts repodir bundle                         else apply_via_local opts repodir bundle         Just un -> if is_ssh repodir-                   then apply_via_ssh_and_sudo repodir un bundle+                   then apply_via_ssh_and_sudo opts repodir un bundle                    else apply_via_sudo un repodir bundle  apply_as :: [DarcsFlag] -> Maybe String@@ -29,10 +29,12 @@ apply_as [] = Nothing apply_via_sudo :: String -> String -> Doc -> IO ExitCode apply_via_sudo user repo bundle =-    pipeDoc "sudo" ["-u",user,"darcs","apply","--all","--repodir",repo] bundle+    darcs_program >>= \darcs ->+    pipeDoc "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle apply_via_local :: [DarcsFlag] -> String -> Doc -> IO ExitCode apply_via_local opts repo bundle =-    pipeDoc "darcs" ("apply":"--all":"--repodir":repo:applyopts opts) bundle+    darcs_program >>= \darcs ->+    pipeDoc darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle  apply_via_url :: [DarcsFlag] -> String -> Doc -> IO ExitCode apply_via_url opts repo bundle =@@ -45,13 +47,14 @@  apply_via_ssh :: [DarcsFlag] -> String -> Doc -> IO ExitCode apply_via_ssh opts repo bundle =-    pipeDocSSH addr ["darcs apply --all "++unwords (applyopts opts)++" --repodir '"++path++"'"] bundle+    pipeDocSSH addr [remoteDarcsCmd opts++" apply --all "++unwords (applyopts opts)+++                     " --repodir '"++path++"'"] bundle         where (addr,':':path) = break (==':') repo -apply_via_ssh_and_sudo :: String -> String -> Doc -> IO ExitCode-apply_via_ssh_and_sudo repo username bundle =-    pipeDocSSH addr ["sudo -u "++username++-                         " darcs apply --all --repodir '"++path++"'"] bundle+apply_via_ssh_and_sudo :: [DarcsFlag] -> String -> String -> Doc -> IO ExitCode+apply_via_ssh_and_sudo opts repo username bundle =+    pipeDocSSH addr ["sudo -u "++username++" "++remoteDarcsCmd opts+++                     " apply --all --repodir '"++path++"'"] bundle         where (addr,':':path) = break (==':') repo  applyopts :: [DarcsFlag] -> [String]
src/Darcs/Repository.hs view
@@ -21,56 +21,47 @@  #include "gadts.h" -module Darcs.Repository ( Repository, ($-), maybeIdentifyRepository,-                          identifyRepositoryFor,-                          withRepoLock, withRepoReadLock,-                          withRepository, withRepositoryDirectory, withGutsOf,-                          makePatchLazy, writePatchSet,-                    findRepository, amInRepository, amNotInRepository,-                    slurp_pending, replacePristineFromSlurpy,-                    slurp_recorded, slurp_recorded_and_unrecorded,-                    withRecorded,-                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,-                    get_unrecorded_in_files, get_unrecorded_in_files_unsorted,-                    read_repo, sync_repo,-                    prefsUrl,-                    add_to_pending,-                    tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,-                    tentativelyReplacePatches,-                    tentativelyMergePatches, considerMergeToWorking,-                    revertRepositoryChanges, finalizeRepositoryChanges,-                          createRepository, copyRepository, copy_oldrepo_patches,-                    patchSetToRepository,-                    unrevertUrl,-                    applyToWorking, patchSetToPatches,-                    createPristineDirectoryTree, createPartialsPristineDirectoryTree,-                    optimizeInventory, cleanRepository,-                    checkPristineAgainstSlurpy, getMarkedupFile,-                    PatchSet, SealedPatchSet, PatchInfoAnd,-                    setScriptsExecutable,-                    checkUnrelatedRepos,-                    testTentative, testRecorded-                  ) where+module Darcs.Repository+    ( Repository, ($-), maybeIdentifyRepository, identifyRepositoryFor+    , withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory+    , withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository+    , amNotInRepository, slurp_pending, replacePristine, slurp_recorded+    , slurp_recorded_and_unrecorded, withRecorded, read_repo, prefsUrl+    , add_to_pending, tentativelyAddPatch, tentativelyRemovePatches+    , tentativelyAddToPending, tentativelyReplacePatches+    , tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges+    , finalizeRepositoryChanges, createRepository, copyRepository+    , copy_oldrepo_patches, patchSetToRepository, unrevertUrl, applyToWorking+    , patchSetToPatches, createPristineDirectoryTree+    , createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository+    , getMarkedupFile, PatchSet, SealedPatchSet, PatchInfoAnd+    , setScriptsExecutable, checkUnrelatedRepos, testTentative, testRecorded+    -- * Recorded and unrecorded and pending.+    , readRecorded, readUnrecorded, unrecordedChanges, readPending, pendingChanges+    , readRecordedAndPending+    -- * Index.+    , readIndex, invalidateIndex+    ) where  import System.Exit ( ExitCode(..), exitWith ) +import Darcs.Repository.State( readRecorded, readUnrecorded, unrecordedChanges+                             , readPending, pendingChanges, readIndex, invalidateIndex+                             , readRecordedAndPending )+ import Darcs.Repository.Internal-    (Repository(..), RepoType(..), ($-), pristineFromWorking,+    (Repository(..), RepoType(..), ($-),      maybeIdentifyRepository, identifyRepositoryFor,      findRepository, amInRepository, amNotInRepository,      makePatchLazy,-     slurp_pending, replacePristineFromSlurpy,+     slurp_pending,      slurp_recorded, slurp_recorded_and_unrecorded,      withRecorded,-     get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,-     get_unrecorded_in_files, get_unrecorded_in_files_unsorted,-     read_repo, sync_repo,-     prefsUrl, checkPristineAgainstSlurpy,-     add_to_pending,+     read_repo,+     prefsUrl,      withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,      tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,      tentativelyReplacePatches,-     tentativelyMergePatches, considerMergeToWorking,      revertRepositoryChanges, finalizeRepositoryChanges,      unrevertUrl,      applyToWorking, patchSetToPatches,@@ -78,14 +69,16 @@      optimizeInventory, cleanRepository,      getMarkedupFile,      setScriptsExecutable,-     testTentative, testRecorded+     testTentative, testRecorded,+     make_new_pending     )+import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking ) import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet )  import Control.Monad ( unless, when ) import Data.Either(Either(..))-import System.Directory ( createDirectory )+import System.Directory ( createDirectory, renameDirectory ) import System.IO.Error ( isAlreadyExistsError )  import qualified Darcs.Repository.DarcsRepo as DarcsRepo@@ -94,30 +87,40 @@ import Darcs.Hopefully ( PatchInfoAnd, info, extractHash ) import Darcs.Repository.Checkpoint ( identify_checkpoint, write_checkpoint_patch, get_checkpoint ) import Darcs.Repository.ApplyPatches ( apply_patches )-import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine )-import Darcs.Patch ( RepoPatch, Named, Patch, patch2patchinfo, apply )-import Darcs.Ordered ( RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL, reverseRL,-                       concatRL, lengthRL, isShorterThanRL )+import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine, pris2inv )+import Darcs.Repository.InternalTypes ( Pristine(..) )+import Darcs.Patch ( RepoPatch, Named, Prim, Patch, patch2patchinfo, apply )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL+                     , reverseRL ,concatRL, lengthRL, isShorterThanRL, (+>+) ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Repository.Format ( RepoProperty ( HashedInventory ),-                                 create_repo_format, format_has, writeRepoFormat )-import Darcs.Repository.Prefs ( write_default_prefs )-import Darcs.Repository.Pristine ( createPristine, flagsToPristine )+                                 createRepoFormat, formatHas, writeRepoFormat )+import Darcs.Repository.Prefs ( writeDefaultPrefs )+import Darcs.Repository.Pristine ( createPristine, flagsToPristine, createPristineFromWorking ) import Darcs.Patch.Depends ( get_patches_beyond_tag )-import Darcs.SlurpDirectory ( empty_slurpy ) import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError ) import Darcs.External ( copyFileOrUrl, Cachable(..) ) import Progress ( debugMessage, tediousSize,                         beginTedious, endTedious, progress ) import Darcs.ProgressPatches (progressRLShowTags, progressFL)-import Darcs.Lock ( writeBinFile )-import Darcs.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped )+import Darcs.Lock ( writeBinFile, writeDocBinFile, rm_recursive )+import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped ) -import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral,-                                AllowUnrelatedRepos-                              ),-                     compression )+import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral, Complete,+                                AllowUnrelatedRepos, NoUpdateWorking )+                   , compression ) import Darcs.Global ( darcsdir )++import Storage.Hashed.Tree( Tree, emptyTree )+import Storage.Hashed.Hash( encodeBase16 )+import Storage.Hashed.Darcs( writeDarcsHashed )+import Storage.Hashed( writePlainTree )+import ByteStringUtils( gzReadFilePS )++import System.FilePath( (</>) )++import qualified Data.ByteString.Char8 as BS+ #include "impossible.h"  createRepository :: [DarcsFlag] -> IO ()@@ -126,19 +129,19 @@       (\e-> if isAlreadyExistsError e             then fail "Tree has already been initialized!"             else fail $ "Error creating directory `"++darcsdir++"'.")-  let rf = create_repo_format opts+  let rf = createRepoFormat opts   createPristine $ flagsToPristine opts rf   createDirectory $ darcsdir ++ "/patches"   createDirectory $ darcsdir ++ "/prefs"-  write_default_prefs+  writeDefaultPrefs   writeRepoFormat rf (darcsdir++"/format")-  if format_has HashedInventory rf+  if formatHas HashedInventory rf       then writeBinFile (darcsdir++"/hashed_inventory") ""       else DarcsRepo.write_inventory "." ((NilRL:<:NilRL) :: PatchSet Patch C(())) -- YUCK!  copyRepository :: RepoPatch p => Repository p C(r u t) -> IO () copyRepository fromrepository@(Repo _ opts rf _)-    | Partial `elem` opts && not (format_has HashedInventory rf) =+    | Partial `elem` opts && not (formatHas HashedInventory rf) =         do isPartial <- copyPartialRepository fromrepository            unless (isPartial == IsPartial) $ copyFullRepository fromrepository     | otherwise = copyFullRepository fromrepository@@ -156,11 +159,11 @@       copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir       copyAnythingToOld r = withCurrentDirectory todir $ read_repo r >>=                             DarcsRepo.write_inventory_and_patches opts-      repoSort rfx | format_has HashedInventory rfx = Hashed+      repoSort rfx | formatHas HashedInventory rfx = Hashed                    | otherwise = Old   case repoSort rf2 of     Hashed ->-        if format_has HashedInventory rf+        if formatHas HashedInventory rf         then copyHashedHashed         else withCurrentDirectory todir $              do HashedRepo.revert_tentative_changes@@ -207,7 +210,7 @@            local_patches <- read_repo torepository            let pi_ch = patch2patchinfo ch            FlippedSeal ps <- return $ get_patches_beyond_tag pi_ch local_patches-           let needed_patches = reverseRL $ concatRL ps+           let needed_patches = reverseRL ps            apply opts ch `catch`                              \e -> fail ("Bad checkpoint!\n" ++ prettyError e)            apply_patches opts needed_patches@@ -223,15 +226,15 @@                      `catchall` return ()   debugMessage "Grabbing lock in new repository..."   withRepoLock opts $- \torepository@(Repo _ _ rfto (DarcsRepository _ c)) ->-      if format_has HashedInventory rffrom && format_has HashedInventory rfto+      if formatHas HashedInventory rffrom && formatHas HashedInventory rfto       then do debugMessage "Writing working directory contents..."               createPristineDirectoryTree torepository "."               fetch_patches_if_necessary opts torepository               when (Partial `elem` opts) $ putStrLn $                        "--partial: hashed or darcs-2 repository detected, using --lazy instead"-      else if format_has HashedInventory rfto+      else if formatHas HashedInventory rfto            then do local_patches <- read_repo torepository-                   replacePristineFromSlurpy torepository empty_slurpy+                   replacePristine torepository emptyTree                    let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $                                         mapRL_RL reverseRL local_patches                    sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply@@ -252,7 +255,7 @@             Right r -> r             Left e  -> bug ("Current directory not repository in writePatchSet: " ++ e)     debugMessage "Writing inventory"-    if format_has HashedInventory rf2+    if formatHas HashedInventory rf2        then do HashedRepo.write_tentative_inventory c (compression opts) patchset                HashedRepo.finalize_tentative_changes repo (compression opts)        else DarcsRepo.write_inventory_and_patches opts patchset@@ -266,7 +269,7 @@ patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(x)                      -> [DarcsFlag] -> IO (Repository p C(r u t)) patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do-    when (format_has HashedInventory rf) $ -- set up sources and all that+    when (formatHas HashedInventory rf) $ -- set up sources and all that        do writeFile "_darcs/tentative_pristine" "" -- this is hokey           repox <- writePatchSet patchset opts           HashedRepo.copy_repo repox opts fromrepo@@ -276,7 +279,7 @@     pristineFromWorking repo     return repo -checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(x) -> IO ()+checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(y) -> IO () checkUnrelatedRepos opts common us them     | AllowUnrelatedRepos `elem` opts || not (null common)        || concatRL us `isShorterThanRL` 5 || concatRL them `isShorterThanRL` 5@@ -292,7 +295,8 @@ fetch_patches_if_necessary :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO () fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) =      unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $-             do putInfo "Copying patches, to get lazy repository hit ctrl-C..."+             do unless (Complete `elem` opts) $+                       putInfo "Copying patches, to get lazy repository hit ctrl-C..."                 r <- read_repo torepository                 let peekaboo :: PatchInfoAnd p C(x y) -> IO ()                     peekaboo x = case extractHash x of@@ -300,3 +304,37 @@                                  Right h -> fetchFileUsingCache c HashedPatchesDir h >> return ()                 sequence_ $ mapRL peekaboo $ progressRLShowTags "Copying patches" $ concatRL r   where putInfo = when (not $ Quiet `elem` opts) . putStrLn++add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()+add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()+add_to_pending repo@(Repo _ opts _ _) p =+    do pend <- unrecordedChanges opts repo []+       invalidateIndex repo+       make_new_pending repo (pend +>+ p)++-- | Replace the existing pristine with a new one (loaded up in a Tree object).+replacePristine :: Repository p C(r u t) -> Tree IO -> IO ()+replacePristine (Repo r _opts _rf (DarcsRepository pris _c)) tree =+    withCurrentDirectory r $ replace pris+    where replace HashedPristine =+              do let t = "_darcs" </> "hashed_inventory"+                 i <- gzReadFilePS t+                 root <- writeDarcsHashed tree $ "_darcs" </> "pristine.hashed"+                 writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i+          replace (PlainPristine n) =+              do rm_recursive nold `catchall` return ()+                 writePlainTree tree ntmp+                 renameDirectory n nold+                 renameDirectory ntmp n+                 return ()+          replace (NoPristine _) = return ()+          nold = darcsdir </> "pristine-old"+          ntmp = darcsdir </> "pristine-tmp"++pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()+pristineFromWorking repo@(Repo dir _ rf _)+    | formatHas HashedInventory rf =+        withCurrentDirectory dir $ readUnrecorded repo >>= replacePristine repo+pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) =+  withCurrentDirectory dir $ createPristineFromWorking p+
src/Darcs/Repository/ApplyPatches.hs view
@@ -25,7 +25,7 @@ import Darcs.Patch ( Patchy, apply ) import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) import Darcs.Patch.Info ( human_friendly )-import Darcs.Ordered ( FL(..), lengthFL, mapFL )+import Darcs.Witnesses.Ordered ( FL(..), lengthFL, mapFL ) import Darcs.Flags ( DarcsFlag ) import Darcs.Utils ( putDocLnError ) import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )
src/Darcs/Repository/Cache.hs view
@@ -9,7 +9,7 @@                    HashedDir(..), hashedDir,                    unionCaches, cleanCaches, cleanCachesWithHint,                    fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache,-                   findFileMtimeUsingCache, setFileMtimeUsingCache, peekInCache,+                   peekInCache,                    repo2cache,                    writable, isthisrepo, hashedFilePath, allHashedDirs                  ) where@@ -18,9 +18,7 @@ import Data.List ( nub ) import Data.Maybe ( listToMaybe ) import System.Directory ( removeFile, doesFileExist, getDirectoryContents )-import System.Posix ( setFileTimes )-import System.Posix.Files ( linkCount, modificationTime, getSymbolicLinkStatus )-import System.Posix.Types ( EpochTime )+import System.Posix.Files ( linkCount, getSymbolicLinkStatus ) import System.IO ( hPutStrLn, stderr )  import Crypt.SHA256 ( sha256sum )@@ -39,7 +37,6 @@ import Darcs.Global ( darcsdir ) import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS ) import Progress ( progressList, debugMessage, debugFail )-import Darcs.SlurpDirectory ( undefined_time ) import Darcs.URL ( is_file ) import Darcs.Utils ( withCurrentDirectory, catchall ) @@ -97,21 +94,6 @@               | length h == 75 = B.length s == read (take 10 h) && sha256sum s == drop 11 h               | otherwise = False --findFileMtimeUsingCache :: Cache -> HashedDir -> String -> IO EpochTime-findFileMtimeUsingCache (Ca cache) subdir f = mt cache-    where mt [] = return undefined_time-          mt (Cache Repo Writable r:_) = (modificationTime `fmap`-                                          getSymbolicLinkStatus (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f))-                                         `catchall` return undefined_time-          mt (_:cs) = mt cs--setFileMtimeUsingCache :: Cache -> HashedDir -> String -> EpochTime -> IO ()-setFileMtimeUsingCache (Ca cache) subdir f t = st cache-    where st [] = return ()-          st (Cache Repo Writable r:_) = setFileTimes (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f) t t-                                         `catchall` return ()-          st (_:cs) = st cs  fetchFileUsingCache :: Cache -> HashedDir -> String -> IO (String, B.ByteString) fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere
src/Darcs/Repository/Checkpoint.hs view
@@ -22,45 +22,31 @@  module Darcs.Repository.Checkpoint ( get_checkpoint, get_checkpoint_by_default,                                      identify_checkpoint,-                                     write_checkpoint, write_recorded_checkpoint,                                      write_checkpoint_patch,                                    ) where -import System.Directory ( setCurrentDirectory, createDirectoryIfMissing )-import Workaround ( getCurrentDirectory )+import System.Directory ( createDirectoryIfMissing ) import System.IO.Unsafe ( unsafeInterleaveIO ) import Data.Maybe ( listToMaybe, catMaybes )-import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )+import Darcs.Hopefully ( PatchInfoAnd, info ) import qualified Data.ByteString as B ( null, empty, ByteString ) -import Darcs.Lock ( withTempDir, writeDocBinFile )-import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, mmap_slurp, )-import Darcs.Patch ( RepoPatch, Patch, Named, Prim, invertRL, patch2patchinfo,-                     apply_to_slurpy, patchcontents,-                     effect, fromPrims,-                     is_setpref, infopatch,-                     readPatch,-                     gzWritePatch-                   )-import Darcs.Ordered ( RL(..), FL(..), EqCheck(IsEq,NotEq),-                             (+>+), filterFL, unsafeCoerceP,-                             mapRL, mapFL_FL, mapRL_RL, reverseRL, concatRL, concatFL )-import Darcs.Repository.Internal ( Repository(..), read_repo, slurp_recorded, withRecorded )-import Darcs.Repository.ApplyPatches ( apply_patches )+import Darcs.Lock ( writeDocBinFile )+import Darcs.SlurpDirectory ( Slurpy, empty_slurpy )+import Darcs.Patch ( RepoPatch, Patch, Named, patch2patchinfo,+                     applyToSlurpy, readPatch, gzWritePatch )+import Darcs.Witnesses.Ordered ( RL(..), FL(..), mapRL, reverseRL )+import Darcs.Repository.Internal ( Repository(..), read_repo ) import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo,                           showPatchInfo                         )-import Darcs.Diff ( unsafeDiff ) import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) )-import Darcs.Flags ( DarcsFlag(LookForAdds, Partial, Complete ) )-import Darcs.Patch.Depends ( get_patches_beyond_tag, get_patches_in_tag )-import Darcs.Repository.Prefs ( filetype_function )+import Darcs.Flags ( DarcsFlag( Partial, Complete ) ) import Darcs.Utils ( catchall ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import Darcs.Global ( darcsdir ) import Printer ( Doc, ($$), empty )-#include "impossible.h"-import Darcs.Sealed ( Sealed(Sealed), FlippedSeal(..), Sealed2(Sealed2), seal, seal2 )+import Darcs.Witnesses.Sealed ( Sealed(Sealed), Sealed2(Sealed2), seal, seal2 ) import Control.Monad ( liftM )  read_patch_ids :: B.ByteString -> [PatchInfo]@@ -83,7 +69,7 @@                     (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable                 case fst `fmap` (readPatch pstr :: Maybe (Sealed (Named Patch C(x)), B.ByteString)) of                   Nothing -> return Nothing-                  Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy+                  Just (Sealed p) -> return $ applyToSlurpy p empty_slurpy  get_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) get_checkpoint repository@(Repo _ opts _ _) = if Partial `elem` opts@@ -126,36 +112,6 @@ format_inv (pinfo:ps) = showPatchInfo pinfo                      $$ format_inv ps -write_recorded_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO ()-write_recorded_checkpoint r@(Repo _ _ _ _) pinfo = do-    Sealed ps <- (seal . mapFL_FL hopefully.reverseRL.concatRL) `liftM` read_repo r-    ftf <- filetype_function-    s <- slurp_recorded r-    write_checkpoint_patch $ infopatch pinfo-        (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y))-    where changeps = filterFL is_setprefFL .-                     effect . patchcontents-          changepps = concatFL . mapFL_FL changeps--is_setprefFL :: Prim C(x y) -> EqCheck C(x y)-is_setprefFL p | is_setpref p = NotEq-               | otherwise = unsafeCoerceP IsEq--write_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO ()-write_checkpoint repo@(Repo _ _ _ _) pinfo = do-    repodir <- getCurrentDirectory-    Sealed pit <- get_patches_in_tag pinfo `liftM` read_repo repo-    let ps = (reverseRL.mapRL_RL hopefully.concatRL) pit-    ftf <- filetype_function-    with_tag repo pinfo $ do-      s <- mmap_slurp "."-      setCurrentDirectory repodir-      write_checkpoint_patch $ infopatch pinfo $-          (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y))-    where changeps = filterFL is_setprefFL .-                     effect . patchcontents-          changepps = concatFL . mapFL_FL changeps- write_checkpoint_patch :: RepoPatch p => Named p C(x y) -> IO () write_checkpoint_patch p =  do createDirectoryIfMissing False (darcsdir++"/checkpoints")@@ -163,12 +119,3 @@     cpi <- (map fst) `fmap` read_checkpoints "."     writeDocBinFile (darcsdir++"/checkpoints/inventory")         $ format_inv $ reverse $ patch2patchinfo p:cpi--with_tag :: RepoPatch p  => Repository p C(r u t) -> PatchInfo -> (IO ()) -> IO ()-with_tag r pinfo job = do-    ps <- read_repo r-    case get_patches_beyond_tag pinfo ps of-        FlippedSeal (extras :<: NilRL) -> withRecorded r (withTempDir "checkpoint") $ \_ -> do-                                            apply_patches [] $ invertRL extras-                                            job-        _ -> bug "with_tag"
src/Darcs/Repository/DarcsRepo.lhs view
@@ -61,7 +61,7 @@  import System.Directory ( doesDirectoryExist, createDirectoryIfMissing ) import Workaround ( renameFile )-import Darcs.Utils ( clarify_errors )+import Darcs.Utils ( clarifyErrors ) import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr )@@ -80,10 +80,10 @@ import Darcs.Patch ( RepoPatch, Effect, Prim, Named, Patch, invert,                      effect,                      patch2patchinfo,-                     apply_to_slurpy,+                     applyToSlurpy,                      readPatch,                      writePatch, gzWritePatch, showPatch )-import Darcs.Ordered ( FL(..), RL(..), (:<)(..),+import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:<)(..),                              reverseFL, mapFL, unsafeCoerceP,                              reverseRL, concatRL, mapRL, mapRL_RL ) import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo,@@ -100,7 +100,7 @@ import Darcs.Utils ( catchall ) import Darcs.ProgressPatches ( progressFL ) import Printer ( text, (<>), Doc, ($$), empty )-import Darcs.Sealed ( Sealed(Sealed), seal, unseal )+import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal ) \end{code}  There is a very special patch which may be stored in \verb!patches! which@@ -221,7 +221,7 @@                                    Nothing -> seal $ NilFL  repairable :: IO a -> IO a-repairable x = x `clarify_errors` unlines+repairable x = x `clarifyErrors` unlines                ["Your repository is now in an inconsistent state.",                 "This must be fixed by running darcs repair."] @@ -315,7 +315,7 @@                     (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable                 case fst `liftM` readPatch_ pstr of                   Nothing -> return Nothing-                  Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy+                  Just (Sealed p) -> return $ applyToSlurpy p empty_slurpy             readPatch_ :: B.ByteString -> Maybe (Sealed (Named Patch C(x)), B.ByteString)             readPatch_ = readPatch
src/Darcs/Repository/Format.hs view
@@ -6,9 +6,9 @@ {-# LANGUAGE CPP #-}  module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..), identifyRepoFormat,-                    create_repo_format, writeRepoFormat,-                    write_problem, read_problem, readfrom_and_writeto_problem,-                    format_has, format_has_together,+                    createRepoFormat, writeRepoFormat,+                    writeProblem, readProblem, readfromAndWritetoProblem,+                    formatHas, formatHasTogether,                   ) where  import Data.List ( sort )@@ -56,9 +56,9 @@           then do finishedOneIO k "inventory"                   have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory")                   case have_inventory of-                    Right _ -> return $ Right default_repo_format+                    Right _ -> return $ Right defaultRepoFormat                     Left e -> return $ Left $ "Not a repository: "++repo++" ("++e++")"-          else return $ Right $ parse_repo_format dff+          else return $ Right $ parseRepoFormat dff     endTedious k     return rf     where drfe x = fetchFilePS x Cachable >> return True@@ -70,16 +70,16 @@ writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $                               map (BC.unpack . BU.intercalate (BC.singleton '|')) rf -parse_repo_format :: B.ByteString -> RepoFormat-parse_repo_format ps =+parseRepoFormat :: B.ByteString -> RepoFormat+parseRepoFormat ps =     RF $ map (BC.split '|') $ filter (not . B.null) $ linesPS ps  -- | The repo format we assume if we do not find a format file.-default_repo_format :: RepoFormat-default_repo_format = RF [[rp2ps Darcs1_0]]+defaultRepoFormat :: RepoFormat+defaultRepoFormat = RF [[rp2ps Darcs1_0]] -create_repo_format :: [DarcsFlag] -> RepoFormat-create_repo_format fs = RF ([map rp2ps flags2inv] ++ maybe2)+createRepoFormat :: [DarcsFlag] -> RepoFormat+createRepoFormat fs = RF ([map rp2ps flags2inv] ++ maybe2)     where flags2inv | UseFormat2 `elem` fs = [HashedInventory]                     | UseHashedInventory `elem` fs = [HashedInventory]                     | UseOldFashionedInventory `elem` fs = [Darcs1_0]@@ -90,47 +90,47 @@                    then []                    else [[rp2ps Darcs2]] --- | @write_problem from@ tells if we can write to a repo in format @form@.+-- | @writeProblem from@ tells if we can write to a repo in format @form@. -- it returns @Nothing@ if there's no problem writing to such a repository.-write_problem :: RepoFormat -> Maybe String-write_problem rf | isJust $ read_problem rf = read_problem rf-write_problem (RF ks) = unlines `fmap` justsOrNothing (map wp ks)-    where wp x | all is_known x = Nothing+writeProblem :: RepoFormat -> Maybe String+writeProblem rf | isJust $ readProblem rf = readProblem rf+writeProblem (RF ks) = unlines `fmap` justsOrNothing (map wp ks)+    where wp x | all isKnown x = Nothing           wp [] = impossible           wp x = Just $ unwords $ "Can't write repository format: " :-                 map BC.unpack (filter (not . is_known) x)+                 map BC.unpack (filter (not . isKnown) x)  --- | @write_problem from@ tells if we can read and write to a repo in+-- | @writeProblem from@ tells if we can read and write to a repo in -- format @form@.  it returns @Nothing@ if there's no problem reading -- and writing to such a repository.-readfrom_and_writeto_problem :: RepoFormat -> RepoFormat -> Maybe String-readfrom_and_writeto_problem inrf outrf-    | format_has Darcs2 inrf /= format_has Darcs2 outrf+readfromAndWritetoProblem :: RepoFormat -> RepoFormat -> Maybe String+readfromAndWritetoProblem inrf outrf+    | formatHas Darcs2 inrf /= formatHas Darcs2 outrf         = Just "Cannot mix darcs-2 repositories with older formats" -    | otherwise = msum [read_problem inrf, write_problem outrf]+    | otherwise = msum [readProblem inrf, writeProblem outrf]  --- | @read_problem from@ tells if we can write to a repo in format @form@.+-- | @readProblem from@ tells if we can write to a repo in format @form@. -- it returns @Nothing@ if there's no problem reading from such a repository.-read_problem :: RepoFormat -> Maybe String-read_problem rf | format_has Darcs1_0 rf && format_has Darcs2 rf+readProblem :: RepoFormat -> Maybe String+readProblem rf | formatHas Darcs1_0 rf && formatHas Darcs2 rf                     = Just "Invalid repositoryformat:  format 2 is incompatible with format 1"-read_problem (RF ks) = unlines `fmap` justsOrNothing (map rp ks)-    where rp x | any is_known x = Nothing+readProblem (RF ks) = unlines `fmap` justsOrNothing (map rp ks)+    where rp x | any isKnown x = Nothing           rp [] = impossible           rp x = Just $ unwords $                  "Can't understand repository format:" : map BC.unpack x   -- | Does this version of darcs know how to handle this property?-is_known :: B.ByteString -> Bool-is_known p = p `elem` map rp2ps known_properties+isKnown :: B.ByteString -> Bool+isKnown p = p `elem` map rp2ps knownProperties  -- | This is the list of properties which this version of darcs knows -- how to handle.-known_properties :: [RepoProperty]-known_properties = [Darcs1_0, Darcs2, HashedInventory]+knownProperties :: [RepoProperty]+knownProperties = [Darcs1_0, Darcs2, HashedInventory]  justsOrNothing :: [Maybe x] -> Maybe [x] justsOrNothing mxs =@@ -138,11 +138,11 @@    [] -> Nothing    xs -> Just xs -format_has :: RepoProperty -> RepoFormat -> Bool-format_has f (RF ks) = rp2ps f `elem` concat ks+formatHas :: RepoProperty -> RepoFormat -> Bool+formatHas f (RF ks) = rp2ps f `elem` concat ks -format_has_together :: [RepoProperty] -> RepoFormat -> Bool-format_has_together fs (RF ks) = fht (sort $ map rp2ps fs) ks+formatHasTogether :: [RepoProperty] -> RepoFormat -> Bool+formatHasTogether fs (RF ks) = fht (sort $ map rp2ps fs) ks     where fht _ [] = False           fht x (y:ys) | x == sort y = True                        | otherwise = fht x ys
src/Darcs/Repository/HashedIO.hs view
@@ -20,25 +20,24 @@ #include "gadts.h"  module Darcs.Repository.HashedIO ( HashedIO, applyHashed,-                                   copyHashed, syncHashedPristine, copyPartialsHashed, listHashedContents,+                                   copyHashed, copyPartialsHashed, listHashedContents,                                    slurpHashedPristine, writeHashedPristine,                                    clean_hashdir ) where  import Darcs.Global ( darcsdir )-import Data.List ( (\\) )+import qualified Data.Set as Set import qualified Data.Map as Map import System.Directory ( getDirectoryContents, createDirectoryIfMissing )-import System.Posix.Types ( EpochTime ) import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift ) import Control.Monad ( when )+import Control.Applicative ( (<$>) ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafeInterleaveIO )  import Darcs.SlurpDirectory.Internal ( Slurpy(..), SlurpyContents(..), map_to_slurpies, slurpies_to_map )-import Darcs.SlurpDirectory ( withSlurpy, undefined_time, undefined_size )+import Darcs.SlurpDirectory ( withSlurpy, undefined_size ) import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache,                                 peekInCache, speculateFileUsingCache,-                                findFileMtimeUsingCache, setFileMtimeUsingCache,                                 okayHash, cleanCachesWithHint, HashedDir(..), hashedDir ) import Darcs.Patch ( Patchy, apply ) import Darcs.RepoPath ( FilePathLike, toFilePath )@@ -48,7 +47,7 @@ import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress ) import Darcs.Patch.FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn,-                              break_on_dir, own_name, super_name )+                              break_on_dir, own_name, superName )  import ByteStringUtils ( linesPS, unlinesPS ) import qualified Data.ByteString       as B  (ByteString, length, empty)@@ -111,7 +110,7 @@                                                        Just h -> inh h $ mInCurrentDirectory fn'' j         where fn' = norm_path fn     mGetDirectoryContents = map (\ (_,f,_) -> f) `fmap` readroot-    mReadFilePS fn = mInCurrentDirectory (super_name fn) $ do+    mReadFilePS fn = mInCurrentDirectory (superName fn) $ do                                           c <- readroot                                           case geta F (own_name fn) c of                                             Nothing -> fail $ " file don't exist... "++ fn2fp fn@@ -170,11 +169,11 @@         where fn' = norm_path fn  makeThing :: FileName -> (ObjType,String) -> HashedIO RW p ()-makeThing fn (o,h) = mWithCurrentDirectory (super_name $ norm_path fn) $+makeThing fn (o,h) = mWithCurrentDirectory (superName $ norm_path fn) $                      seta o (own_name $ norm_path fn) h `fmap` readroot >>= writeroot  rmThing :: FileName -> HashedIO RW p ()-rmThing fn = mWithCurrentDirectory (super_name $ norm_path fn) $+rmThing fn = mWithCurrentDirectory (superName $ norm_path fn) $              do c <- readroot                 let c' = filter (\(_,x,_)->x/= own_name (norm_path fn)) c                 if length c' == length c - 1@@ -191,10 +190,6 @@ readTediousHash k h = do lift $ finishedOneIO k h                          readhash h -gethashmtime :: String -> HashedIO r p EpochTime-gethashmtime h = do HashDir _ c _ _ <- get-                    lift $ unsafeInterleaveIO $ findFileMtimeUsingCache c HashedPristineDir h- withh :: String -> HashedIO RW p a -> HashedIO RW p (String,a) withh h j = do hd <- get                put $ hd { rootHash = h }@@ -286,10 +281,9 @@          lift $ beginTedious k          safeInterleave $ (Slurpy rootdir . SlurpDir (Just hroot) . slurpies_to_map) `fmap` mapM sl c     where sl (F,n,h) = do ps <- safeInterleave $ readTediousHash k h-                          t <- gethashmtime h                           let len = if length h == 75 then read (take 10 h)                                                       else undefined_size-                          return $ Slurpy n $ SlurpFile (Just h, t, len) ps+                          return $ Slurpy n $ SlurpFile (Just h, 0, len) ps           sl (D,n,h) = inh h $ do c <- readroot                                   lift $ tediousSize k (length c)                                   lift $ finishedOneIO k h@@ -327,33 +321,6 @@                                                return (F, f, h)           k = "Writing pristine" -grab :: FileName -> Slurpy -> Maybe Slurpy-grab _ (Slurpy _ (SlurpFile _ _)) = Nothing-grab fn (Slurpy _ (SlurpDir _ ss)) = fmap (Slurpy fn) $ Map.lookup fn ss---- | Update timestamps on pristine files to match those in the working directory--- (which is passed to this function in form of a Slurpy). It needed for the--- mtime-based unsafeDiff optimisation to work efficiently.-syncHashedPristine :: Cache -> Slurpy -> String -> IO ()-syncHashedPristine c s r = do runStateT sh $ HashDir { permissions=RW, cache=c,-                                                       compress=compression [], rootHash=r }-                              return ()-    where sh = do cc <- readroot-                  lift $ tediousSize k (length cc)-                  mapM_ sh' cc-          sh' (D,n,h) = case progress k $ grab n s of-                        Just s' -> lift $ syncHashedPristine c s' h-                        Nothing -> return ()-          sh' (F,n,h) = case progress k $ grab n s of-                        Just (Slurpy _ (SlurpFile (_,t',l) x)) ->-                            do t <- lift $ findFileMtimeUsingCache c HashedPristineDir h-                               when (t' /= undefined_time && t' /= t) $-                                    do ps <- readhash h-                                       when (B.length ps == fromIntegral l && ps == x) $-                                            lift $ setFileMtimeUsingCache c HashedPristineDir h t'-                        _ -> return ()-          k = "Synchronizing pristine"- copyHashed :: String -> Cache -> Compression -> String -> IO () copyHashed k c compr z = do runStateT cph $ HashDir { permissions = RO, cache = c,                                                       compress = compr, rootHash = z }@@ -409,9 +376,11 @@    do -- we'll remove obsolete bits of "dir"       debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..."       let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/"-      hs <- concat `fmap` (mapM (listHashedContents "cleaning up..." c) hashroots)-      fs <- filter okayHash `fmap` getDirectoryContents hashdir-      mapM_ (removeFileMayNotExist . (hashdir++)) (fs \\ hs)+      hs <- set . concat <$> mapM (listHashedContents "cleaning up..." c) 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_ (fs \\ hs)+      cleanCachesWithHint c dir_ (unset $ fs `Set.difference` hs)+   where set = Set.fromList . map BC.pack+         unset = map BC.unpack . Set.toList
src/Darcs/Repository/HashedRepo.hs view
@@ -20,14 +20,13 @@ #include "gadts.h"  module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes,-                                     slurp_pristine, sync_repo, clean_pristine,-                                     copy_pristine, copy_partials_pristine, pristine_from_working,+                                     slurp_pristine, clean_pristine,+                                     copy_pristine, copy_partials_pristine,                                      apply_to_tentative_pristine,-                                     replacePristineFromSlurpy,                                      add_to_tentative_inventory, remove_from_tentative_inventory,                                      read_repo, read_tentative_repo, write_and_read_patch,                                      write_tentative_inventory, copy_repo, slurp_all_but_darcs,-                                     readHashedPristineRoot+                                     readHashedPristineRoot, pris2inv                                    ) where  import System.Directory ( doesFileExist, createDirectoryIfMissing )@@ -45,8 +44,8 @@                                 unionCaches, repo2cache, okayHash, takeHash,                                 HashedDir(..), hashedDir ) import Darcs.Repository.HashedIO ( applyHashed, slurpHashedPristine,-                                   copyHashed, syncHashedPristine, copyPartialsHashed,-                                   writeHashedPristine, clean_hashdir )+                                   copyHashed, copyPartialsHashed,+                                   clean_hashdir ) import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, n2pia, info,                          extractHash, createHashed )@@ -54,11 +53,11 @@ import Darcs.Patch ( RepoPatch, Patchy, Named, showPatch, patch2patchinfo, readPatch ) import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo, human_friendly, readPatchInfo )-import Darcs.Ordered ( unsafeCoerceP, (:<)(..) )+import Darcs.Witnesses.Ordered ( unsafeCoerceP, (:<)(..) ) import Darcs.Patch.FileName ( fp2fn )  import ByteStringUtils ( gzReadFilePS, dropSpace )-import qualified Data.ByteString as B (null, length, readFile, empty+import qualified Data.ByteString as B (null, length, empty                                       ,tail, take, drop, ByteString) import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack) @@ -69,9 +68,9 @@ import Darcs.Utils ( withCurrentDirectory ) import Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO ) #include "impossible.h"-import Darcs.Ordered ( FL(..), RL(..),+import Darcs.Witnesses.Ordered ( FL(..), RL(..),                              mapRL, mapFL, lengthRL )-import Darcs.Sealed ( Sealed(..), seal, unseal )+import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal ) import Darcs.Global ( darcsdir )  revert_tentative_changes :: IO ()@@ -338,18 +337,6 @@                                     h | h == sha1PS B.empty -> return empty_slurpy                                       | otherwise -> slurpHashedPristine c compr h -pristine_from_working :: Cache -> Compression -> IO ()-pristine_from_working c compr = do-  s <- slurp_all_but_darcs "."-  replacePristineFromSlurpy c compr s--replacePristineFromSlurpy :: Cache -> Compression -> Slurpy -> IO ()-replacePristineFromSlurpy c compr s = do -  h <- writeHashedPristine c compr s-  let t = darcsdir++"/hashed_inventory"-  i <- gzReadFilePS t-  writeDocBinFile t $ pris2inv h i- copy_pristine :: Cache -> Compression -> String -> String -> IO () copy_pristine c compr d iname = do     i <- fetchFilePS (d++"/"++iname) Uncachable@@ -358,13 +345,6 @@     beginTedious k     copyHashed k c compr $ inv2pris i     endTedious k--sync_repo :: Cache -> IO ()-sync_repo c = do i <- B.readFile $ darcsdir++"/hashed_inventory"-                 s <- slurp_all_but_darcs "."-                 beginTedious "Synchronizing pristine"-                 syncHashedPristine c s $ inv2pris i-                   copy_partials_pristine :: FilePathLike fp =>                           Cache -> Compression -> String -> String -> [fp] -> IO ()
src/Darcs/Repository/Internal.hs view
@@ -24,131 +24,122 @@ module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-),                     maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor,                     findRepository, amInRepository, amNotInRepository,-                    slurp_pending, pristineFromWorking, revertRepositoryChanges,+                    slurp_pending, revertRepositoryChanges,                     slurp_recorded, slurp_recorded_and_unrecorded,-                    read_pending, announce_merge_conflicts, setTentativePending,+                    announce_merge_conflicts, setTentativePending,                     check_unrecorded_conflicts,                     withRecorded,-                    checkPristineAgainstSlurpy,-                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,-                    get_unrecorded_in_files, get_unrecorded_in_files_unsorted,-                    read_repo, sync_repo,+                    read_repo,                     prefsUrl, makePatchLazy,-                    add_to_pending,                     withRepoLock, withRepoReadLock,                     withRepository, withRepositoryDirectory, withGutsOf,                     tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,+                    tentativelyAddPatch_,                     tentativelyReplacePatches,-                    tentativelyMergePatches, considerMergeToWorking,                     finalizeRepositoryChanges,                     unrevertUrl,                     applyToWorking, patchSetToPatches,                     createPristineDirectoryTree, createPartialsPristineDirectoryTree,-                    replacePristineFromSlurpy,                     optimizeInventory, cleanRepository,                     getMarkedupFile,                     PatchSet, SealedPatchSet,                     setScriptsExecutable,                     getRepository, rIO,-                    testTentative, testRecorded+                    testTentative, testRecorded,+                    UpdatePristine(..), MakeChanges(..), applyToTentativePristine,+                    make_new_pending                   ) where  import Printer ( putDocLn, (<+>), text, ($$) )  import Data.Maybe ( isJust, isNothing )-import Darcs.Repository.Prefs ( get_prefval )-import Darcs.Resolution ( standard_resolution, external_resolution )+import Darcs.Repository.Prefs ( getPrefval )+import Darcs.Repository.State ( readRecorded )+import Darcs.Repository.LowLevel ( read_pending, pendingName, readPrims, read_pendingfile ) import System.Exit ( ExitCode(..), exitWith ) import System.Cmd ( system )-import Darcs.External ( backupByCopying, clonePartialsTree )+import Darcs.External ( clonePartialsTree ) import Darcs.IO ( runTolerantly, runSilently ) import Darcs.Repository.Pristine ( identifyPristine, nopristine,-                                   easyCreatePristineDirectoryTree, slurpPristine, syncPristine,-                                   easyCreatePartialsPristineDirectoryTree,-                                   createPristineFromWorking )-import qualified Darcs.Repository.Pristine as Pristine ( replacePristineFromSlurpy )-                                                         +                                   easyCreatePristineDirectoryTree, slurpPristine,+                                   easyCreatePartialsPristineDirectoryTree )+ import Data.List ( (\\) ) import Darcs.SignalHandler ( withSignalsBlocked ) import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ),-                                 identifyRepoFormat, format_has,-                                 write_problem, read_problem, readfrom_and_writeto_problem )+                                 identifyRepoFormat, formatHas,+                                 writeProblem, readProblem, readfromAndWritetoProblem ) import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile,                           createDirectoryIfMissing ) import Control.Monad ( liftM, when, unless ) import Workaround ( getCurrentDirectory, renameFile, setExecutable )  import ByteStringUtils ( gzReadFilePS )-import qualified Data.ByteString as B (ByteString, empty, readFile, isPrefixOf)+import qualified Data.ByteString as B ( empty, readFile, isPrefixOf ) import qualified Data.ByteString.Char8 as BC (pack) -import Darcs.Patch ( Patch, RealPatch, Effect, is_hunk, is_binary, description,+import Darcs.Patch ( Patch, RealPatch, Effect, primIsHunk, primIsBinary, description, -                     try_to_shrink, commuteFL, commute, apply_to_filepaths )+                     tryToShrink, commuteFL, commute ) import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict ) import Darcs.Patch.Bundle ( scan_bundle, make_bundle )-import Darcs.Patch.FileName ( FileName, fn2fp )-import Darcs.Patch.TouchesFiles ( choose_touching )-import Darcs.SlurpDirectory ( Slurpy, slurp_unboring, mmap_slurp, co_slurp,-                              slurp_has, list_slurpy_files )+import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, list_slurpy_files ) import Darcs.Hopefully ( PatchInfoAnd, info, n2pia,                          hopefully, hopefullyM ) import Darcs.Repository.ApplyPatches ( apply_patches ) import qualified Darcs.Repository.HashedRepo as HashedRepo                             ( revert_tentative_changes, finalize_tentative_changes,-                              remove_from_tentative_inventory, sync_repo,+                              remove_from_tentative_inventory,                               copy_pristine, copy_partials_pristine, slurp_pristine,-                              apply_to_tentative_pristine, pristine_from_working,+                              apply_to_tentative_pristine,                               write_tentative_inventory, write_and_read_patch,                               add_to_tentative_inventory,                               read_repo, read_tentative_repo, clean_pristine,-                              replacePristineFromSlurpy,                               slurp_all_but_darcs ) import qualified Darcs.Repository.DarcsRepo as DarcsRepo-import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet,+import Darcs.Flags ( DarcsFlag(Verbose, Quiet,                                MarkConflicts, AllowConflicts, NoUpdateWorking,                                WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir,-                               SetScriptsExecutable, DryRun, IgnoreTimes,-                               Summary, NoSummary),+                               SetScriptsExecutable, DryRun ),                      want_external_merge, compression )-import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,+import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,                              (:\/:)(..), (:/\:)(..), (:>)(..),-                             (+>+), lengthFL, nullFL,+                             (+>+), lengthFL,                              allFL, filterFL,                              reverseRL, reverseFL, concatRL, mapFL,                              mapFL_FL, concatFL ) import Darcs.Patch ( RepoPatch, Patchy, Prim, merge,-                     joinPatches, sort_coalesceFL,-                     list_conflicted_files, list_touched_files,-                     Named, patchcontents, anonymous,+                     joinPatches,+                     listConflictedFiles, listTouchedFiles,+                     Named, patchcontents,                      commuteRL, fromPrims,                      patch2patchinfo, readPatch,                      writePatch, effect, invert,-                     is_addfile, is_adddir,-                     is_setpref,-                     apply, apply_to_slurpy,-                     empty_markedup_file, MarkedUpFile+                     primIsAddfile, primIsAdddir,+                     primIsSetpref,+                     apply, applyToSlurpy,+                     emptyMarkedupFile, MarkedUpFile                    ) import Darcs.Patch.Patchy ( Invert(..) ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet )-import Darcs.Patch.Apply ( markup_file, LineMark(None) )+import Darcs.Patch.Apply ( markupFile, LineMark(None) ) import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset )-import Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff ) import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath,                         ioAbsoluteOrRemote, toPath ) import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort ) import Progress ( debugMessage ) import Darcs.ProgressPatches (progressFL) import Darcs.URL ( is_file )-import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function,-                                getCaches )+import Darcs.Repository.Prefs ( getCaches ) import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist,                     withTempDir, withPermDir )-import Darcs.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal )+import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal ) import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) ) import Darcs.Global ( darcsdir )+import System.Mem( performGC )+ #include "impossible.h"  -- | Repository IO monad.  This monad-like datatype is responsible for@@ -206,7 +197,7 @@        case rf_or_e of          Left err -> return $ Left err          Right rf ->-             case read_problem rf of+             case readProblem rf of              Just err -> return $ Left err              Nothing -> if darcs then do pris <- identifyPristine                                          cs <- getCaches opts here@@ -217,7 +208,7 @@     rf_or_e <- identifyRepoFormat url     case rf_or_e of       Left e -> return $ Left e-      Right rf -> case read_problem rf of+      Right rf -> case readProblem rf of                   Just err -> return $ Left err                   Nothing ->  do cs <- getCaches opts url                                  return $ Right $ Repo url opts rf (DarcsRepository nopristine cs)@@ -233,7 +224,7 @@ identifyRepositoryFor (Repo _ opts rf _) url =     do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url        let t' = case t of DarcsRepository x c -> DarcsRepository x c-       case readfrom_and_writeto_problem rf_ rf of+       case readfromAndWritetoProblem rf_ rf of          Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e          Nothing -> return $ Repo absurl opts rf_ t' @@ -275,8 +266,12 @@                   else do setCurrentDirectory startpwd                           return onFail +-- The performGC in this function is a workaround for a library/GHC bug,+-- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a+-- problem on fast machines, but virtual ones trip this from time to time) amNotInRepository :: [DarcsFlag] -> IO (Either String ()) amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d+                                            `catchall` (performGC >> createDirectoryIfMissing False d)                                          -- note that the above could always fail                                          setCurrentDirectory d                                          amNotInRepository []@@ -300,7 +295,7 @@ slurp_pending repo@(Repo _ _ _ rt) = do   cur <- slurp_recorded repo   Sealed pend <- read_pending repo-  case apply_to_slurpy pend cur of+  case applyToSlurpy pend cur of     Just pendcur -> return pendcur     Nothing -> do putStrLn "Yikes, pending has conflicts.  Renaming file as_darcs/patches/pending_buggy"                   renameFile (pendingName rt) (pendingName rt++"_buggy")@@ -308,7 +303,7 @@  slurp_recorded :: RepoPatch p => Repository p C(r u t) -> IO Slurpy slurp_recorded (Repo dir opts rf (DarcsRepository _ c))-    | format_has HashedInventory rf =+    | formatHas HashedInventory rf =         HashedRepo.slurp_pristine c (compression opts) dir $ darcsdir++"/hashed_inventory" slurp_recorded repository@(Repo dir _ _ (DarcsRepository p _)) = do     mc <- withCurrentDirectory dir $ slurpPristine p@@ -323,34 +318,11 @@   cur <- slurp_recorded repo   Sealed pend <- read_pending repo   withCurrentDirectory r $-      case apply_to_slurpy pend cur of+      case applyToSlurpy pend cur of       Nothing -> fail "Yikes, pending has conflicts!"       Just pendslurp -> do unrec <- co_slurp pendslurp "."                            return (cur, unrec) -pendingName :: RepoType p -> String-pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending"--read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r)))-read_pending (Repo r _ _ tp) =-    withCurrentDirectory r (read_pendingfile (pendingName tp))--add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()-add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-add_to_pending repo p =-    do pend <- get_unrecorded repo-       make_new_pending repo (pend +>+ p)--readPrims :: B.ByteString -> Sealed (FL Prim C(x))-readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), B.ByteString) of-              Nothing -> Sealed NilFL-              Just (Sealed p,_) -> Sealed (effect p)--read_pendingfile :: String -> IO (Sealed (FL Prim C(x)))-read_pendingfile name = do-  pend <- gzReadFilePS name `catchall` return B.empty-  return $ readPrims pend- make_new_pending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> IO () make_new_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () make_new_pending repo@(Repo r _ _ tp) origp =@@ -361,7 +333,7 @@        writeSealedPatch newname $ seal $ fromPrims $ sfp        cur <- slurp_recorded repo        Sealed p <- read_pendingfile newname-       when (isNothing $ apply_to_slurpy p cur) $ do+       when (isNothing $ applyToSlurpy p cur) $ do          let buggyname = pendingName tp ++ "_buggy"          renameFile newname buggyname          bugDoc $ text "There was an attempt to write an invalid pending!"@@ -376,113 +348,45 @@ sift_for_pending :: FL Prim C(x y) -> Sealed (FL Prim C(x)) sift_for_pending simple_ps =  let oldps = maybe simple_ps id $ try_shrinking_inverse $ crude_sift simple_ps- in if allFL (\p -> is_addfile p || is_adddir p) $ oldps+ in if allFL (\p -> primIsAddfile p || primIsAdddir p) $ oldps     then seal oldps     else fromJust $ do       Sealed x <- return $ sfp NilFL $ reverseFL oldps-      return (case try_to_shrink x of+      return (case tryToShrink x of               ps | lengthFL ps < lengthFL oldps -> sift_for_pending ps                  | otherwise -> seal ps)       where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c))             sfp sofar NilRL = seal sofar             sfp sofar (p:<:ps)-                | is_hunk p || is_binary p+                | primIsHunk p || primIsBinary p                     = case commuteFL (p :> sofar) of                       Right (sofar' :> _) -> sfp sofar' ps                       Left _ -> sfp (p:>:sofar) ps             sfp sofar (p:<:ps) = sfp (p:>:sofar) ps -get_unrecorded_no_look_for_adds :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y))-get_unrecorded_no_look_for_adds r paths = get_unrecorded_private (filter (/= LookForAdds)) r paths --get_unrecorded_unsorted :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u))-get_unrecorded_unsorted r = get_unrecorded_in_files_unsorted r []--get_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u))-get_unrecorded r = get_unrecorded_private id r []---- | Gets the unrecorded changes in the given paths in the current repository,---   without sorting them for presentation to the user-get_unrecorded_in_files_unsorted :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u))-get_unrecorded_in_files_unsorted = get_unrecorded_private (AnyOrder:)---- | Gets the unrecorded changes in the given paths in the current repository.-get_unrecorded_in_files :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u))-get_unrecorded_in_files = get_unrecorded_private id ---- | The /unrecorded/ includes the pending and the working directory changes.---   The third argument is a list of paths: if this list is [], it will diff---   the whole repo, but if there are elements in it, the function will return---   only changes to files under those paths. The paths must be fixed paths ---   starting with ".", but need not yet be unique.-get_unrecorded_private :: RepoPatch p => ([DarcsFlag]->[DarcsFlag]) -> Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y))-get_unrecorded_private _ (Repo _ opts _ _) _-    | NoUpdateWorking `elem` opts = return $ unsafeCoerceP NilFL-get_unrecorded_private modopts repository@(Repo r oldopts _ _) files =-  withCurrentDirectory r (do-    debugMessage "Looking for unrecorded changes..."-    cur <- slurp_pending repository-    work <- if LookForAdds `elem` opts-            then do nboring <- if Boring `elem` opts-                               then return $ darcsdir_filter-                               else boring_file_filter-                    slurp_unboring (myfilt cur nboring) "."-            else co_slurp cur "."-    ftf <- filetype_function-    Sealed pend <- read_pending repository-    let changed_files = apply_to_filepaths pend filesFP-        pre_changed_files = apply_to_filepaths (invert pend) filesFP-    Sealed relevantPend <- return $ if null files-                                      then seal pend-                                      else choose_touching pre_changed_files pend-    debugMessage "diffing dir..."-    let diffs = if null files-                  then unsafeDiff opts ftf cur work-                  else unsafeDiffAtPaths (ignoreTimes, lookForAdds, summary) ftf cur work changed_files-        dif = if AnyOrder `elem` opts-                  then relevantPend +>+ diffs-                  else sort_coalesceFL $ relevantPend +>+ diffs-    seq dif $ debugMessage "Found unrecorded changes."-    return dif)-    where myfilt s nboring f = slurp_has f s || nboring [f] /= []-          opts = modopts oldopts-          -- NoSummary/Summary both present gives False-          -- Just Summary gives True-          -- Just NoSummary gives False-          -- Neither gives False-          summary = Summary `elem` opts && NoSummary `notElem` opts-          lookForAdds = LookForAdds `elem` opts-          ignoreTimes = IgnoreTimes `elem` opts-          filesFP = map fn2fp files- -- @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. read_repo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(r)) read_repo repo@(Repo r opts rf _)-    | format_has HashedInventory rf = do ps <- HashedRepo.read_repo repo r+    | formatHas HashedInventory rf =  do ps <- HashedRepo.read_repo repo r                                          return ps     | otherwise = do Sealed ps <- DarcsRepo.read_repo opts r                      return $ unsafeCoerceP ps  readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(t)) readTentativeRepo repo@(Repo r opts rf _)-    | format_has HashedInventory rf = do ps <- HashedRepo.read_tentative_repo repo r+    | formatHas HashedInventory rf = do  ps <- HashedRepo.read_tentative_repo repo r                                          return ps     | otherwise = do Sealed ps <- DarcsRepo.read_tentative_repo opts r                      return $ unsafeCoerceP ps  makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y)) makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p-    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p+    | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p     | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p -sync_repo :: Repository p C(r u t) -> IO ()-sync_repo (Repo r _ rf (DarcsRepository _ c))-    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.sync_repo c-sync_repo (Repo r _ _ (DarcsRepository p _)) = withCurrentDirectory r $ syncPristine p- prefsUrl :: Repository p C(r u t) -> String prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs" @@ -524,91 +428,26 @@           fromPrims_ = fromPrims  is_simple :: Prim C(x y) -> Bool-is_simple x = is_hunk x || is_binary x || is_setpref x+is_simple x = primIsHunk x || primIsBinary x || primIsSetpref x  crude_sift :: FL Prim C(x y) -> FL Prim C(x y) crude_sift xs = if allFL is_simple xs then filterFL ishunkbinary xs else xs     where ishunkbinary :: Prim C(x y) -> EqCheck C(x y)-          ishunkbinary x | is_hunk x || is_binary x = unsafeCoerceP IsEq+          ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq                          | otherwise = NotEq  data HashedVsOld a = HvsO { old, hashed :: a }  decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a decideHashedOrNormal rf (HvsO { hashed = h, old = o })-    | format_has HashedInventory rf = h+    | formatHas HashedInventory rf = h     | otherwise = o --tentativelyMergePatches :: RepoPatch p-                        => Repository p C(r u t) -> String -> [DarcsFlag]-                        -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)-                        -> IO (Sealed (FL Prim C(u)))-tentativelyMergePatches = tentativelyMergePatches_ MakeChanges--considerMergeToWorking :: RepoPatch p-                       => Repository p C(r u t) -> String -> [DarcsFlag]-                       -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)-                       -> IO (Sealed (FL Prim C(u)))-considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges- data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) -tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p-                         => MakeChanges-                         -> Repository p C(r u t) -> String -> [DarcsFlag]-                         -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)-                         -> IO (Sealed (FL Prim C(u)))-tentativelyMergePatches_ mc r cmd opts usi themi =-  do let us = mapFL_FL hopefully usi-         them = mapFL_FL hopefully themi-     _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us)-     pend <- get_unrecorded_unsorted r -- we don't care if it looks pretty...-     anonpend <- anonymous (fromPrims pend)-     pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)-     let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw-     Sealed standard_resolved_pw <- return $ standard_resolution pwprim-     debugMessage "Checking for conflicts..."-     mapM_ backupByCopying $ list_touched_files standard_resolved_pw-     debugMessage "Announcing conflicts..."-     have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw-     debugMessage "Checking for unrecorded conflicts..."-     have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc-     debugMessage "Reading working directory..."-     (_, working) <- slurp_recorded_and_unrecorded r-     debugMessage "Working out conflicts in actual working directory..."-     Sealed pw_resolution <--          case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of-          (Nothing,_) -> return $ if AllowConflicts `elem` opts-                                  then seal NilFL-                                  else seal standard_resolved_pw-          (_,False) -> return $ seal standard_resolved_pw-          (Just c, True) -> external_resolution working c-                                                    (effect us +>+ pend)-                                                    (effect them) pwprim-     debugMessage "Applying patches to the local directories..."-     when (mc == MakeChanges) $-          do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO ()-                 doChanges NilFL = applyps r themi-                 doChanges _     = applyps r (mapFL_FL n2pia pc)-             doChanges usi-             setTentativePending r (effect pend' +>+ pw_resolution)-     return $ seal (effect pwprim +>+ pw_resolution)-  where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()]-        mapAdd _ NilFL = []-        mapAdd r'@(Repo dir df rf dr) (a:>:as) =-               -- we construct a new Repository object on the recursive case so that the-               -- recordedstate of the repository can match the fact that we just wrote a patch-               tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as-        applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO ()-        applyps repo ps = do debugMessage "Adding patches to inventory..."-                             sequence_ $ mapAdd repo ps-                             debugMessage "Applying patches to pristine..."-                             applyToTentativePristine repo ps- announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool announce_merge_conflicts cmd opts resolved_pw =-    case nubsort $ list_touched_files $ resolved_pw of+    case nubsort $ listTouchedFiles $ resolved_pw of     [] -> return False     cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts               || want_external_merge opts /= Nothing@@ -636,11 +475,11 @@                        pend ->                            case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of                            _ :/\: pend' ->-                               case list_conflicted_files pend' of+                               case listConflictedFiles pend' of                                [] -> return False-                               fs -> do yorn <- promptYorn-                                                ("You have conflicting local changes to:\n"-                                                 ++ unwords fs++"\nProceed?")+                               fs -> do putStrLn ("You have conflicting local changes to:\n"+                                                 ++ unwords fs)+                                        yorn <- promptYorn "Proceed?"                                         when (yorn /= 'y') $                                              do putStrLn "Cancelled."                                                 exitWith ExitSuccess@@ -736,7 +575,7 @@                                        prepend repository $ effect ps       remove_from_unrevert_context repository ps       debugMessage "Removing changes from tentative inventory..."-      if format_has HashedInventory rf+      if formatHas HashedInventory rf         then do HashedRepo.remove_from_tentative_inventory repository (compression opts) ps                 when (up == UpdatePristine) $                      HashedRepo.apply_to_tentative_pristine c opts $@@ -773,7 +612,7 @@ finalizeRepositoryChanges (Repo _ opts _ _)     | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified" finalizeRepositoryChanges repository@(Repo dir opts rf _)-    | format_has HashedInventory rf =+    | formatHas HashedInventory rf =         withCurrentDirectory dir $ do debugMessage "Considering whether to test..."                                       testTentative repository                                       debugMessage "Finalizing changes..."@@ -802,7 +641,7 @@     when (Test `elem` opts) $ withCurrentDirectory dir $     do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ())        debugMessage "About to run test if it exists."-       testline <- get_prefval "test"+       testline <- getPrefval "test"        case testline of          Nothing -> return ()          Just testcode ->@@ -837,7 +676,7 @@ getUMask (_:l) = getUMask l  withGutsOf :: Repository p C(r u t) -> IO () -> IO ()-withGutsOf (Repo _ _ rf _) | format_has HashedInventory rf = id+withGutsOf (Repo _ _ rf _) | formatHas HashedInventory rf = id                            | otherwise = withSignalsBlocked  withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a@@ -848,7 +687,7 @@ withRepositoryDirectory opts1 url job =     do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url        let rt' = case rt of DarcsRepository t c -> DarcsRepository t c-       if format_has Darcs2 rf+       if formatHas Darcs2 rf          then do debugMessage $ "Identified darcs-2 repo: " ++ dir                  job1_ (Repo dir opts rf rt')          else do debugMessage $ "Identified darcs-1 repo: " ++ dir@@ -868,7 +707,7 @@ withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepoLock opts job =     withRepository opts $- \repository@(Repo _ _ rf _) ->-    do case write_problem rf of+    do case writeProblem rf of          Nothing -> return ()          Just err -> fail err        let name = "./"++darcsdir++"/lock"@@ -882,13 +721,13 @@ withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepoReadLock opts job =     withRepository opts $- \repository@(Repo _ _ rf _) ->-    do case write_problem rf of+    do case writeProblem rf of          Nothing -> return ()          Just err -> fail err        let name = "./"++darcsdir++"/lock"            wu = case (getUMask opts) of Nothing -> id                                         Just u -> withUMask u-       wu $ if format_has HashedInventory rf || DryRun `elem` opts+       wu $ if formatHas HashedInventory rf || DryRun `elem` opts             then job repository             else withLock name (revertRepositoryChanges repository >> job repository) @@ -898,7 +737,8 @@   Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (NilRL:<:NilRL))   remove_from_unrevert_context_ bundle   where unrevert_impossible unrevert_loc =-            do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?"+            do putStrLn "This operation will make unrevert impossible!"+               yorn <- promptYorn "Proceed?"                case yorn of                  'n' -> fail "Cancelled."                  'y' -> removeFile unrevert_loc `catchall` return ()@@ -916,15 +756,14 @@             debugMessage "Adjusting the context of the unrevert changes..."             ref <- readTentativeRepo repository             case get_common_and_uncommon (bundle, ref) of-                 (common,(h_us:<:NilRL):<:NilRL :\/: NilRL:<:NilRL) ->+                 (common,(h_us:<:NilRL) :\/: NilRL) ->                     case commuteRL (reverseFL ps :> hopefully h_us) of                     Nothing -> unrevert_impossible unrevert_loc                     Just (us' :> _) -> do-                        s <- slurp_recorded repository-                        writeDocBinFile unrevert_loc $-                             make_bundle [] s-                             (common \\ pis) (us':>:NilFL)-                 (common,(x:<:NilRL):<:NilRL:\/:_)+                        s <- readRecorded repository+                        bundle' <- make_bundle [] s (common \\ pis) (us' :>: NilFL)+                        writeDocBinFile unrevert_loc bundle'+                 (common,(x:<:NilRL):\/:_)                         | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc                         | isr -> return ()                         where isr = isJust $ hopefullyM x@@ -957,14 +796,9 @@     HvsO { hashed = HashedRepo.clean_pristine repository,            old = return () } -replacePristineFromSlurpy :: Repository p C(r u t) -> Slurpy -> IO ()-replacePristineFromSlurpy (Repo r opts rf (DarcsRepository pris c)) s-    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristineFromSlurpy c (compression opts) s-    | otherwise = withCurrentDirectory r $ Pristine.replacePristineFromSlurpy s pris- createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO () createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir-    | format_has HashedInventory rf =+    | formatHas HashedInventory rf =         do createDirectoryIfMissing True reldir            withCurrentDirectory reldir $ HashedRepo.copy_pristine c (compression opts) r (darcsdir++"/hashed_inventory")     | otherwise =@@ -977,7 +811,7 @@ -- fp below really should be FileName createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO () createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir-    | format_has HashedInventory rf =+    | formatHas HashedInventory rf =         do createDirectoryIfMissing True dir            withCurrentDirectory dir $                HashedRepo.copy_partials_pristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs@@ -987,34 +821,17 @@       unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do           clonePartialsTree "." dir (map toFilePath prefs) -pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()-pristineFromWorking (Repo dir opts rf (DarcsRepository _ c))-    | format_has HashedInventory rf =-        withCurrentDirectory dir $ HashedRepo.pristine_from_working c (compression opts)-pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) =-  withCurrentDirectory dir $ createPristineFromWorking p- withRecorded :: RepoPatch p => Repository p C(r u t)              -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a withRecorded repository mk_dir f     = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d)                         f d -checkPristineAgainstSlurpy :: RepoPatch p => Repository p C(r u t) -> Slurpy -> IO Bool-checkPristineAgainstSlurpy repository@(Repo _ opts _ _) s2 =-    do s1 <- slurp_recorded repository-       ftf <- filetype_function-       -- The @$!@ is necessary because some code called from this function uses-       -- unsafeInterleaveIO around functions that throw exceptions. If one used-       -- @$@ instead of @$!@ here, those exceptions might not be caught by code-       -- that runs this function inside a @catch@.-       return $! nullFL $ unsafeDiff (LookForAdds:IgnoreTimes:opts) ftf s1 s2- withTentative :: forall p a C(r u t). RepoPatch p =>                  Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a)               -> (AbsolutePath -> IO a) -> IO a withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f-    | format_has HashedInventory rf =+    | formatHas HashedInventory rf =         mk_dir $ \d -> do HashedRepo.copy_pristine c (compression opts) dir (darcsdir++"/tentative_pristine")                           f d withTentative repository@(Repo dir opts _ _) mk_dir f =@@ -1032,7 +849,7 @@ getMarkedupFile repository pinfo f = do   Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info)                                   . reverseRL . concatRL) `liftM` read_repo repository-  return $ snd $ do_mark_all patches (f, empty_markedup_file)+  return $ snd $ do_mark_all patches (f, emptyMarkedupFile)   where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v)         dropWhileFL _ NilFL       = flipSeal NilFL         dropWhileFL p xs@(x:>:xs')@@ -1042,7 +859,7 @@             -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) do_mark_all (hp:>:pps) (f, mk) =     case hopefullyM hp of-    Just p -> do_mark_all pps $ markup_file (info hp) (patchcontents p) (f, mk)+    Just p -> do_mark_all pps $ markupFile (info hp) (patchcontents p) (f, mk)     Nothing -> (f, [(BC.pack "Error reading a patch!",None)]) do_mark_all NilFL (f, mk) = (f, mk)
+ src/Darcs/Repository/LowLevel.hs view
@@ -0,0 +1,51 @@+-- Copyright (C) 2002-2004,2007-2008 David Roundy+-- Copyright (C) 2005 Juliusz Chroboczek+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Repository.LowLevel ( read_pending, read_pendingfile, pendingName, readPrims ) where++import Darcs.Repository.InternalTypes ( RepoType(..), Repository(..) )+import Darcs.Patch ( readPatch, Prim, Patch, RepoPatch, effect )+import Darcs.Global ( darcsdir )+import Darcs.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Utils ( catchall, withCurrentDirectory )+import ByteStringUtils ( gzReadFilePS )+import qualified Data.ByteString as BS ( ByteString, empty )++pendingName :: RepoType p -> String+pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending"++read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r)))+read_pending (Repo r _ _ tp) =+    withCurrentDirectory r (read_pendingfile (pendingName tp))++read_pendingfile :: String -> IO (Sealed (FL Prim C(x)))+read_pendingfile name = do+  pend <- gzReadFilePS name `catchall` return BS.empty+  return $ readPrims pend++readPrims :: BS.ByteString -> Sealed (FL Prim C(x))+readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), BS.ByteString) of+              Nothing -> Sealed NilFL+              Just (Sealed p,_) -> Sealed (effect p)+
+ src/Darcs/Repository/Merge.hs view
@@ -0,0 +1,113 @@+-- Copyright (C) 2002-2004,2007-2008 David Roundy+-- Copyright (C) 2005 Juliusz Chroboczek+-- Copyright (C) 2009 Petr Rockai+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++#include "gadts.h"++module Darcs.Repository.Merge where++import Darcs.Resolution ( standard_resolution, external_resolution )+import Darcs.External ( backupByCopying )+import Control.Monad ( when )++import Darcs.Patch ( Effect )+import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully )+import Darcs.Flags+    ( DarcsFlag( AllowConflicts ), want_external_merge )+import Darcs.Witnesses.Ordered+    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL )+import Darcs.Patch+    ( RepoPatch, Prim, merge, joinPatches, listTouchedFiles+    , patchcontents, anonymous, fromPrims, effect )+import Progress( debugMessage )+import Darcs.ProgressPatches( progressFL )+import Darcs.Witnesses.Sealed( Sealed(Sealed), seal )+import Darcs.Repository.InternalTypes( Repository(..) )++import Darcs.Repository.State( unrecordedChanges, readUnrecorded )++import Darcs.Repository.Internal+    ( announce_merge_conflicts, check_unrecorded_conflicts+    , MakeChanges(..), setTentativePending+    , tentativelyAddPatch_, applyToTentativePristine, UpdatePristine(..) )++tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p+                         => MakeChanges+                         -> Repository p C(r u t) -> String -> [DarcsFlag]+                         -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)+                         -> IO (Sealed (FL Prim C(u)))+tentativelyMergePatches_ mc r cmd opts usi themi =+  do let us = mapFL_FL hopefully usi+         them = mapFL_FL hopefully themi+     _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us)+     pend <- unrecordedChanges opts r []+     anonpend <- anonymous (fromPrims pend)+     pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)+     let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw+     Sealed standard_resolved_pw <- return $ standard_resolution pwprim+     debugMessage "Checking for conflicts..."+     mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw+     debugMessage "Announcing conflicts..."+     have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw+     debugMessage "Checking for unrecorded conflicts..."+     have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc+     debugMessage "Reading working directory..."+     working <- readUnrecorded r+     debugMessage "Working out conflicts in actual working directory..."+     Sealed pw_resolution <-+          case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of+          (Nothing,_) -> return $ if AllowConflicts `elem` opts+                                  then seal NilFL+                                  else seal standard_resolved_pw+          (_,False) -> return $ seal standard_resolved_pw+          (Just c, True) -> external_resolution working c+                                                    (effect us +>+ pend)+                                                    (effect them) pwprim+     debugMessage "Applying patches to the local directories..."+     when (mc == MakeChanges) $+          do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO ()+                 doChanges NilFL = applyps r themi+                 doChanges _     = applyps r (mapFL_FL n2pia pc)+             doChanges usi+             setTentativePending r (effect pend' +>+ pw_resolution)+     return $ seal (effect pwprim +>+ pw_resolution)+  where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()]+        mapAdd _ NilFL = []+        mapAdd r'@(Repo dir df rf dr) (a:>:as) =+               -- we construct a new Repository object on the recursive case so that the+               -- recordedstate of the repository can match the fact that we just wrote a patch+               tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as+        applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO ()+        applyps repo ps = do debugMessage "Adding patches to inventory..."+                             sequence_ $ mapAdd repo ps+                             debugMessage "Applying patches to pristine..."+                             applyToTentativePristine repo ps++tentativelyMergePatches :: RepoPatch p+                        => Repository p C(r u t) -> String -> [DarcsFlag]+                        -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)+                        -> IO (Sealed (FL Prim C(u)))+tentativelyMergePatches = tentativelyMergePatches_ MakeChanges+++considerMergeToWorking :: RepoPatch p+                       => Repository p C(r u t) -> String -> [DarcsFlag]+                       -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)+                       -> IO (Sealed (FL Prim C(u)))+considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges+
src/Darcs/Repository/Prefs.lhs view
@@ -22,16 +22,16 @@  #include "gadts.h" -module Darcs.Repository.Prefs ( add_to_preflist, get_preflist, set_preflist,-                   get_global, environmentHelpHome,-                   defaultrepo, set_defaultrepo,-                   get_prefval, set_prefval, change_prefval,-                   def_prefval,-                   write_default_prefs,-                   boring_regexps, boring_file_filter, darcsdir_filter,-                   FileType(..), filetype_function,+module Darcs.Repository.Prefs ( addToPreflist, getPreflist, setPreflist,+                   getGlobal, environmentHelpHome,+                   defaultrepo, setDefaultrepo,+                   getPrefval, setPrefval, changePrefval,+                   defPrefval,+                   writeDefaultPrefs,+                   boringRegexps, boringFileFilter, darcsdirFilter,+                   FileType(..), filetypeFunction,                    getCaches,-                   binaries_file_help+                   binariesFileHelp                  ) where  import System.IO.Error ( isDoesNotExistError )@@ -71,10 +71,10 @@ \input{Darcs/ArgumentDefaults.lhs}  \begin{code}-write_default_prefs :: IO ()-write_default_prefs = do set_preflist "boring" default_boring-                         set_preflist "binaries" default_binaries-                         set_preflist "motd" []+writeDefaultPrefs :: IO ()+writeDefaultPrefs =   do setPreflist "boring" defaultBoring+                         setPreflist "binaries" defaultBinaries+                         setPreflist "motd" [] \end{code}  \paragraph{repos}@@ -132,9 +132,9 @@ boring, even if it matches the boring file filter.  \begin{code}-{-# NOINLINE default_boring #-}-default_boring :: [String]-default_boring = ["# Boring file regexps:",+{-# NOINLINE defaultBoring #-}+defaultBoring :: [String]+defaultBoring = ["# Boring file regexps:",                   "",                   "### compiler and interpreter intermediate files",                   "# haskell (ghc) interfaces",@@ -229,20 +229,20 @@                   "# mac os finder",                   "(^|/)\\.DS_Store$" ] -darcsdir_filter :: [FilePath] -> [FilePath]-darcsdir_filter = filter (not.is_darcsdir)-is_darcsdir :: FilePath -> Bool-is_darcsdir ('.':'/':f) = is_darcsdir f-is_darcsdir "." = True-is_darcsdir "" = True-is_darcsdir ".." = True-is_darcsdir "../" = True-is_darcsdir fp = darcsdir `isPrefixOf` fp+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  -- | The path of the global preference directory; @~/.darcs@ on Unix, -- and @%APPDATA%/darcs@ on Windows.-global_prefs_dir :: IO (Maybe FilePath)-global_prefs_dir = do+globalPrefsDir :: IO (Maybe FilePath)+globalPrefsDir = do   env <- getEnvironment   case lookup "DARCS_TESTING_PREFS_DIR" env of     Just d -> return (Just d)@@ -255,26 +255,26 @@  "%APPDATA%/darcs (on Windows).  This is also the default location of",  "the cache."]) -get_global :: String -> IO [String]-get_global f = do-  dir <- global_prefs_dir+getGlobal :: String -> IO [String]+getGlobal f = do+  dir <- globalPrefsDir   case dir of-    (Just d) -> get_preffile $ d </> f+    (Just d) -> getPreffile $ d </> f     Nothing -> return [] -global_cache_dir :: IO (Maybe FilePath)-global_cache_dir = slash_cache `fmap` global_prefs_dir+globalCacheDir :: IO (Maybe FilePath)+globalCacheDir = slash_cache `fmap` globalPrefsDir   where slash_cache = fmap (</> "cache") -boring_regexps :: IO [Regex]-boring_regexps = do-    borefile <- def_prefval "boringfile" (darcsdir ++ "/prefs/boring")-    bores <- get_lines borefile `catchall` return []-    gbs <- get_global "boring"+boringRegexps :: IO [Regex]+boringRegexps = do+    borefile <- defPrefval "boringfile" (darcsdir ++ "/prefs/boring")+    bores <- getPrefLines borefile `catchall` return []+    gbs <- getGlobal "boring"     return $ map mkRegex $ bores ++ gbs -boring_file_filter :: IO ([FilePath] -> [FilePath])-boring_file_filter = boring_regexps >>= return . actual_boring_file_filter+boringFileFilter :: IO ([FilePath] -> [FilePath])+boringFileFilter = boringRegexps >>= return . actualBoringFileFilter  noncomments :: [String] -> [String] noncomments ss = filter is_ok ss@@ -282,8 +282,8 @@                        is_ok ('#':_) = False                        is_ok _ = True -get_lines :: ReadableDirectory m => FilePath -> m [String]-get_lines f = (notconflicts . noncomments . map stripCr . lines)+getPrefLines :: ReadableDirectory m => FilePath -> m [String]+getPrefLines f = (notconflicts . noncomments . map stripCr . lines)               `fmap` mReadBinFile (fp2fn f)     where notconflicts = filter nc           startswith [] _ = True@@ -296,9 +296,9 @@  -- | From a list of paths, filter out any that are within @_darcs@ or -- match a boring regexp.-actual_boring_file_filter :: [Regex] -> [FilePath] -> [FilePath]-actual_boring_file_filter regexps files = filter (not . boring . normalize) files-    where boring file = is_darcsdir file ||+actualBoringFileFilter :: [Regex] -> [FilePath] -> [FilePath]+actualBoringFileFilter regexps files = filter (not . boring . normalize) files+    where boring file = isDarcsdir file ||                         any (\regexp -> isJust $ matchRegex regexp file) regexps  normalize :: FilePath -> FilePath@@ -326,23 +326,23 @@ data FileType = BinaryFile | TextFile                 deriving (Eq) -{-# NOINLINE default_binaries #-}+{-# NOINLINE defaultBinaries #-} -- | The lines that will be inserted into @_darcs/prefs/binaries@ when -- @darcs init@ is run.  Hence, a list of comments, blank lines and -- regular expressions (ERE dialect). -- -- Note that while this matches .gz and .GZ, it will not match .gZ, -- i.e. it is not truly case insensitive.-default_binaries :: [String]-default_binaries = help +++defaultBinaries :: [String]+defaultBinaries = help ++                    ["\\.(" ++ e ++ "|" ++ map toUpper e ++ ")$" | e <- extensions ]     where extensions = ["a","bmp","bz2","doc","elc","exe","gif","gz","iso",                         "jar","jpe?g","mng","mpe?g","p[nbgp]m","pdf","png",                         "pyc","so","tar","tgz","tiff?","z","zip"]-          help = map ("# "++) binaries_file_help+          help = map ("# "++) binariesFileHelp -binaries_file_help :: [String]-binaries_file_help =+binariesFileHelp :: [String]+binariesFileHelp =   ["This file contains a list of extended regular expressions, one per",    "line.  A file path matching any of these expressions is assumed to",    "contain binary data (not text).  The entries in ~/.darcs/binaries (if",@@ -351,12 +351,12 @@    "Blank lines, and lines beginning with an octothorpe (#) are ignored.",    "See regex(7) for a description of extended regular expressions."] -filetype_function :: IO (FilePath -> FileType)-filetype_function = do-    binsfile <- def_prefval "binariesfile" (darcsdir ++ "/prefs/binaries")-    bins <- get_lines binsfile `catch`+filetypeFunction :: IO (FilePath -> FileType)+filetypeFunction = do+    binsfile <- defPrefval "binariesfile" (darcsdir ++ "/prefs/binaries")+    bins <- getPrefLines binsfile `catch`              (\e-> if isDoesNotExistError e then return [] else ioError e)-    gbs <- get_global "binaries"+    gbs <- getGlobal "binaries"     regexes <- return (map (\r -> mkRegex r) (bins ++ gbs))     let isbin f = or $ map (\r -> isJust $ matchRegex r f) regexes         ftf f = if isbin $ normalize f then BinaryFile else TextFile@@ -375,60 +375,60 @@ withPrefsDirectory j = do prefs <- prefsDirectory `mplus` return "x"                           when (prefs /= "x") $ j prefs -add_to_preflist :: WriteableDirectory m => String -> String -> m ()-add_to_preflist p s = withPrefsDirectory $ \prefs -> do+addToPreflist :: WriteableDirectory m => String -> String -> m ()+addToPreflist p s = withPrefsDirectory $ \prefs -> do   hasprefs <- mDoesDirectoryExist $ fp2fn prefs   unless hasprefs $ mCreateDirectory $ fp2fn prefs-  pl <- get_preflist p+  pl <- getPreflist p   mWriteBinFile (fp2fn $ prefs ++ p) $ unlines $ union [s] pl -get_preflist :: ReadableDirectory m => String -> m [String]-get_preflist p = do prefs <- prefsDirectory `mplus` return "x"-                    if (prefs /= "x") then get_preffile $ prefs ++ p+getPreflist :: ReadableDirectory m => String -> m [String]+getPreflist p =  do prefs <- prefsDirectory `mplus` return "x"+                    if (prefs /= "x") then getPreffile $ prefs ++ p                                       else return [] -get_preffile :: ReadableDirectory m => FilePath -> m [String]-get_preffile f = do+getPreffile :: ReadableDirectory m => FilePath -> m [String]+getPreffile f = do   hasprefs <- mDoesFileExist (fp2fn f)   if hasprefs-    then get_lines f+    then getPrefLines f     else return [] -set_preflist :: WriteableDirectory m => String -> [String] -> m ()-set_preflist p ls = withPrefsDirectory $ \prefs -> do+setPreflist :: WriteableDirectory m => String -> [String] -> m ()+setPreflist p ls = withPrefsDirectory $ \prefs -> do   haspref <- mDoesDirectoryExist $ fp2fn prefs   if haspref      then mWriteBinFile (fp2fn $ prefs ++ p) (unlines ls)      else return () -def_prefval :: String -> String -> IO String-def_prefval p d = do-  pv <- get_prefval p+defPrefval :: String -> String -> IO String+defPrefval p d = do+  pv <- getPrefval p   case pv of Nothing -> return d              Just v -> return v -get_prefval :: ReadableDirectory m => String -> m (Maybe String)-get_prefval p =-    do pl <- get_preflist "prefs"+getPrefval :: ReadableDirectory m => String -> m (Maybe String)+getPrefval p =+    do pl <- getPreflist "prefs"        case map snd $ filter ((==p).fst) $ map (break (==' ')) pl of            [val] -> case words val of                [] -> return Nothing                _ -> return $ Just $ tail val            _ -> return Nothing -set_prefval :: WriteableDirectory m => String -> String -> m ()-set_prefval p v = do pl <- get_preflist "prefs"-                     set_preflist "prefs" $+setPrefval :: WriteableDirectory m => String -> String -> m ()+setPrefval p v =  do pl <- getPreflist "prefs"+                     setPreflist "prefs" $                        filter ((/=p).fst.(break (==' '))) pl ++ [p++" "++v] -change_prefval :: WriteableDirectory m => String -> String -> String -> m ()-change_prefval p f t =-    do pl <- get_preflist "prefs"-       ov <- get_prefval p+changePrefval :: WriteableDirectory m => String -> String -> String -> m ()+changePrefval p f t =+    do pl <- getPreflist "prefs"+       ov <- getPrefval p        newval <- case ov of                  Nothing -> return t                  Just old -> if old == f then return t else return old-       set_preflist "prefs" $+       setPreflist "prefs" $                     filter ((/=p).fst.(break(==' '))) pl ++ [p++" "++newval]  defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]@@ -437,22 +437,22 @@                 | otherwise = do absr <- ioAbsolute r                                  return $ toFilePath absr      case [r | RemoteRepo r <- opts] of-       [] -> do defrepo <- get_preflist "defaultrepo"+       [] -> do defrepo <- getPreflist "defaultrepo"                 case defrepo of                   [r] -> (:[]) `fmap` fixR r                   _ -> return []        rs -> mapM fixR rs defaultrepo _ _ r = return r -set_defaultrepo :: String -> [DarcsFlag] -> IO ()-set_defaultrepo r opts = do doit <- if (NoSetDefault `notElem` opts && DryRun `notElem` opts && r_is_not_tmp)+setDefaultrepo :: String -> [DarcsFlag] -> IO ()+setDefaultrepo r opts =  do doit <- if (NoSetDefault `notElem` opts && DryRun `notElem` opts && r_is_not_tmp)                                     then return True                                     else do olddef <--                                                get_preflist "defaultrepo"+                                                getPreflist "defaultrepo"                                             return (olddef == [])                             when doit-                                (set_preflist "defaultrepo" [r])-                            add_to_preflist "repos" r+                                (setPreflist "defaultrepo" [r])+                            addToPreflist "repos" r                          `catchall` return () -- we don't care if this fails!  where   r_is_not_tmp = not $ r `elem` [x | RemoteRepo x <- opts]@@ -503,16 +503,16 @@ \begin{code} getCaches :: [DarcsFlag] -> String -> IO Cache getCaches opts repodir =-    do here <- parsehs `fmap` get_preffile (darcsdir ++ "/prefs/sources")+    do here <- parsehs `fmap` getPreffile (darcsdir ++ "/prefs/sources")        there <- (parsehs . lines . BC.unpack) `fmap`                 (gzFetchFilePS (repodir ++ "/" ++ darcsdir ++ "/prefs/sources") Cachable                  `catchall` return B.empty)-       globalcachedir <- global_cache_dir+       globalcachedir <- globalCacheDir        let globalcache = case (nocache,globalcachedir) of                            (True,_) -> []                            (_,Just d) -> [Cache Directory Writable d]                            _ -> []-       globalsources <- parsehs `fmap` get_global "sources"+       globalsources <- parsehs `fmap` getGlobal "sources"        thisdir <- getCurrentDirectory        let thisrepo = if Ephemeral `elem` opts                       then [Cache Repo NotWritable $ toFilePath thisdir]
src/Darcs/Repository/Pristine.hs view
@@ -25,7 +25,6 @@                  createPristine, removePristine, identifyPristine,                  slurpPristine,                  applyPristine, createPristineFromWorking,-                 syncPristine, replacePristineFromSlurpy,                  getPristinePop,                  pristineDirectory, pristineToFlagString,                  easyCreatePristineDirectoryTree,@@ -34,17 +33,14 @@  import Data.Maybe ( isJust ) import Control.Monad ( when, liftM )-import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist,-                   renameDirectory, removeFile )+import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, removeFile ) import Darcs.Lock ( rm_recursive, writeBinFile )-import Darcs.Diff ( sync ) import Workaround ( getCurrentDirectory )-import Darcs.SlurpDirectory ( Slurpy,  mmap_slurp, co_slurp, writeSlurpy )-import Darcs.Utils ( catchall )+import Darcs.SlurpDirectory ( Slurpy,  mmap_slurp )  import Darcs.PopulationData ( Population, getPopFrom ) import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) )-import Darcs.Repository.Format ( RepoFormat, format_has,+import Darcs.Repository.Format ( RepoFormat, formatHas,                                  RepoProperty(HashedInventory) ) import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) ) import Darcs.Patch ( Patchy, apply )@@ -97,7 +93,7 @@                      n2 = darcsdir++"/current" ++ ext  flagsToPristine :: [DarcsFlag] -> RepoFormat -> Pristine-flagsToPristine _ rf | format_has HashedInventory rf = HashedPristine+flagsToPristine _ rf | formatHas HashedInventory rf = HashedPristine flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none") flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName) flagsToPristine (_ : t) rf = flagsToPristine t rf@@ -143,28 +139,6 @@ createPristineFromWorking (NoPristine _) = return () createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n createPristineFromWorking HashedPristine =-    bug "HashedPristine is not implemented yet."--syncPristine :: Pristine -> IO ()-syncPristine (NoPristine _) = return ()-syncPristine (PlainPristine n) =-    do ocur <- mmap_slurp n-       owork <- co_slurp ocur "."-       sync n ocur owork-syncPristine HashedPristine = return () -- FIXME this should be implemented!--replacePristineFromSlurpy :: Slurpy -> Pristine -> IO ()-replacePristineFromSlurpy _ (NoPristine _) = return ()-replacePristineFromSlurpy s (PlainPristine n) =-    do rm_recursive nold-           `catchall` return ()-       writeSlurpy s ntmp-       renameDirectory n nold-       renameDirectory ntmp n-       return ()-           where nold = darcsdir ++ "/" ++ pristineName ++ "-old"-                 ntmp = darcsdir ++ "/" ++ pristineName ++ "-tmp"-replacePristineFromSlurpy _ HashedPristine =     bug "HashedPristine is not implemented yet."  getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population)
src/Darcs/Repository/Repair.hs view
@@ -1,63 +1,59 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Repository.Repair ( replayRepository,-                                 RepositoryConsistency(..) )+module Darcs.Repository.Repair ( replayRepository, checkIndex+                               , RepositoryConsistency(..) )        where         import Control.Monad ( when, unless )+import Control.Monad.Trans ( liftIO )+import Control.Applicative( (<$>) ) import Control.Exception ( finally ) import Data.Maybe ( catMaybes )-import Data.List ( sort )+import Data.List ( sort, (\\) ) import System.Directory ( createDirectoryIfMissing ) -import Darcs.SlurpDirectory ( empty_slurpy, withSlurpy, Slurpy, SlurpMonad, syncSlurpy ) import Darcs.Lock( rm_recursive ) import Darcs.Hopefully ( PatchInfoAnd, info ) -import Darcs.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL,+import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL,                      mapRL )-import Darcs.Patch.Depends ( get_patches_beyond_tag ) import Darcs.Patch.Patchy ( applyAndTryToFix ) import Darcs.Patch.Info ( PatchInfo( .. ), human_friendly ) import Darcs.Patch.Set ( PatchSet )-import Darcs.Patch ( RepoPatch, patch2patchinfo )+import Darcs.Patch ( RepoPatch )  import Darcs.Repository.Format ( identifyRepoFormat, -                                 RepoProperty ( HashedInventory ), format_has )-import Darcs.Repository.Cache ( Cache, HashedDir( HashedPristineDir ) )-import Darcs.Repository.HashedIO ( slurpHashedPristine, writeHashedPristine,-                                   clean_hashdir )+                                 RepoProperty ( HashedInventory ), formatHas )+import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )+import Darcs.Repository.HashedIO ( clean_hashdir ) import Darcs.Repository.HashedRepo ( readHashedPristineRoot )-import Darcs.Repository.Checkpoint ( get_checkpoint_by_default ) import Darcs.Repository.InternalTypes ( extractCache )-import Darcs.Repository ( Repository, read_repo,-                          checkPristineAgainstSlurpy,-                          makePatchLazy )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.Repository ( Repository, read_repo, makePatchLazy+                        , readRecorded, readIndex, readRecordedAndPending ) -import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) import Darcs.Utils ( catchall ) import Darcs.Global ( darcsdir )-import Darcs.Flags ( compression ) import Printer ( Doc, putDocLn, text ) import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) )-#include "impossible.h" -run_slurpy :: Slurpy -> SlurpMonad a -> IO (Slurpy, a)-run_slurpy s f =-    case withSlurpy s f of-      Left err -> fail err-      Right x -> return x+import Darcs.Diff( treeDiff )+import Storage.Hashed.Monad( TreeIO )+import Storage.Hashed.Darcs( hashedTreeIO )+import Storage.Hashed.Tree( Tree, emptyTree )+import Storage.Hashed.AnchoredPath( anchorPath )+import Storage.Hashed.Hash( Hash(NoHash), encodeBase16 )+import Storage.Hashed.Tree( list, restrict, expand, itemHash, zipTrees )+import Storage.Hashed.Darcs( darcsUpdateHashes )+import Storage.Hashed.Index( updateIndex )+import Storage.Hashed( readPlainTree ) -update_slurpy :: Repository p -> Cache -> [DarcsFlag] -> Slurpy -> IO Slurpy-update_slurpy r c opts s = do-  current <- readHashedPristineRoot r-  h <- writeHashedPristine c (compression opts) s-  s' <- slurpHashedPristine c (compression opts) h-  clean_hashdir c HashedPristineDir $ catMaybes [Just h, current]-  return s'+import qualified Data.ByteString.Char8 as BS +#include "impossible.h"+ replaceInFL :: FL (PatchInfoAnd a)             -> [(PatchInfo, PatchInfoAnd a)]             -> FL (PatchInfoAnd a)@@ -67,33 +63,33 @@     | info o == o' = c:>:replaceInFL orig ch_rest     | otherwise = o:>:replaceInFL orig ch -applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO (FL (PatchInfoAnd p), Slurpy, Bool)-applyAndFix _ _ s _ NilFL = return (NilFL, s, True)-applyAndFix c opts s_ r psin =-    do beginTedious k-       tediousSize k $ lengthFL psin-       (repaired, slurpy, ok) <- aaf s_ psin-       endTedious k-       orig <- (reverseRL . concatRL) `fmap` read_repo r-       return (replaceInFL orig repaired, slurpy, ok)+applyAndFix :: forall p. RepoPatch p => Repository p -> FL (PatchInfoAnd p) -> TreeIO (FL (PatchInfoAnd p), Bool)+applyAndFix _ NilFL = return (NilFL, True)+applyAndFix r psin =+    do liftIO $ beginTedious k+       liftIO $ tediousSize k $ lengthFL psin+       (repaired, ok) <- aaf psin+       liftIO $ endTedious k+       orig <- liftIO $ (reverseRL . concatRL) `fmap` read_repo r+       return (replaceInFL orig repaired, ok)     where k = "Replaying patch"-          aaf s NilFL = return ([], s, True)-          aaf s (p:>:ps) = do-            (s', mp') <- run_slurpy s $ applyAndTryToFix p+          aaf :: FL (PatchInfoAnd p) -> TreeIO ([(PatchInfo, PatchInfoAnd p)], Bool)+          aaf NilFL = return ([], True)+          aaf (p:>:ps) = do+            mp' <- applyAndTryToFix p             let !infp = info p -- assure that 'p' can be garbage collected.-            finishedOneIO k $ show $ human_friendly $ infp-            s'' <- syncSlurpy (update_slurpy r c opts) s'-            (ps', s''', restok) <- aaf s'' ps+            liftIO $ finishedOneIO k $ show $ human_friendly $ infp+            (ps', restok) <- aaf ps             case mp' of-              Nothing -> return (ps', s''', restok)-              Just (e,pp) -> do putStrLn e-                                p' <- makePatchLazy r pp-                                return ((infp, p'):ps', s''', False)+              Nothing -> return (ps', restok)+              Just (e,pp) -> do liftIO $ putStrLn e+                                p' <- liftIO $ makePatchLazy r pp+                                return ((infp, p'):ps', False)  data RepositoryConsistency p =     RepositoryConsistent-  | BrokenPristine Slurpy-  | BrokenPatches Slurpy (PatchSet p)+  | BrokenPristine (Tree IO)+  | BrokenPatches (Tree IO) (PatchSet p)  check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO () check_uniqueness putVerbose putInfo repository =@@ -116,35 +112,32 @@   let putVerbose s = when (Verbose `elem` opts) $ putDocLn s       putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s   check_uniqueness putVerbose putInfo repo-  maybe_chk <- get_checkpoint_by_default repo-  let c = extractCache repo   createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed"-  rooth <- writeHashedPristine c (compression opts) empty_slurpy-  s <- slurpHashedPristine c (compression opts) rooth+  putVerbose $ text "Reading recorded state..."+  pris <- readRecorded repo `catch` \_ -> return emptyTree   putVerbose $ text "Applying patches..."   patches <- read_repo repo-  (s', newpatches, patches_ok) <- case maybe_chk of-    Just (Sealed chk) ->-        do let chtg = patch2patchinfo chk-           putVerbose $ text "I am repairing from a checkpoint."-           (s'', _) <- run_slurpy s $ applyAndTryToFix chk-           (_, s_, ok) <- applyAndFix c opts s'' repo-                      (reverseRL $ concatRL $ unsafeUnflippedseal $ get_patches_beyond_tag chtg patches)-           return (s_, patches, ok)-    Nothing -> do debugMessage "Fixing any broken patches..."-                  let psin = reverseRL $ concatRL patches-                  (ps, s_, ok) <- applyAndFix c opts s repo psin-                  debugMessage "Done fixing broken patches..."-                  return (s_, (reverseFL ps :<: NilRL), ok)+  debugMessage "Fixing any broken patches..."+  let psin = reverseRL $ concatRL patches+      repair = applyAndFix repo psin+  ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree "_darcs/pristine.hashed"+  debugMessage "Done fixing broken patches..."+  let newpatches = reverseFL ps :<: NilRL+   debugMessage "Checking pristine against slurpy"-  is_same <- checkPristineAgainstSlurpy repo s' `catchall` return False+  ftf <- filetypeFunction+  is_same <- do diff <- treeDiff ftf pris newpris+                return $ case diff of+                           NilFL -> True+                           _ -> False+              `catchall` return False   -- TODO is the latter condition needed? Does a broken patch imply pristine   -- difference? Why, or why not?   return (if is_same && patches_ok      then RepositoryConsistent      else if patches_ok-            then BrokenPristine s'-            else BrokenPatches s' newpatches)+            then BrokenPristine newpris+            else BrokenPatches newpris newpatches)  cleanupRepositoryReplay :: Repository p -> IO () cleanupRepositoryReplay r = do@@ -152,9 +145,9 @@   rf_or_e <- identifyRepoFormat "."   rf <- case rf_or_e of Left e -> fail e                         Right x -> return x-  unless (format_has HashedInventory rf) $+  unless (formatHas HashedInventory rf) $          rm_recursive $ darcsdir ++ "/pristine.hashed" -  when (format_has HashedInventory rf) $ do+  when (formatHas HashedInventory rf) $ do        current <- readHashedPristineRoot r        clean_hashdir c HashedPristineDir $ catMaybes [current] @@ -163,3 +156,33 @@     where run = do             st <- replayRepository' r opt             f st++checkIndex :: (RepoPatch p) => Repository p -> Bool -> IO Bool+checkIndex repo quiet = do+  index <- updateIndex =<< readIndex repo+  pristine <- expand =<< readRecordedAndPending repo+  working <- expand =<< restrict pristine <$> readPlainTree "."+  working_hashed <- darcsUpdateHashes working+  let index_paths = [ p | (p, _) <- list index ]+      pristine_paths = [ p | (p, _) <- list pristine ]+      index_extra = index_paths \\ pristine_paths+      pristine_extra = pristine_paths \\ index_paths+      gethashes p (Just i1) (Just i2) = (p, itemHash i1, itemHash i2)+      gethashes p (Just i1) Nothing   = (p, itemHash i1, NoHash)+      gethashes p   Nothing (Just i2) = (p,      NoHash, itemHash i2)+      gethashes p   Nothing Nothing   = error $ "Bad case at " ++ show p+      mismatches = [ miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2 ]++      format paths = unlines $ (map $ (("  " ++) . anchorPath "")) paths+      mismatches_disp = unlines [ anchorPath "" p +++                                    "\n    index: " ++ BS.unpack (encodeBase16 h1) +++                                    "\n  working: " ++ BS.unpack (encodeBase16 h2)+                                  | (p, h1, h2) <- mismatches ]+  unless (quiet || null index_extra) $+         putStrLn $ "Extra items in index!\n" ++ format index_extra+  unless (quiet || null pristine_extra) $+         putStrLn $ "Missing items in index!\n" ++ format pristine_extra+  unless (quiet || null mismatches) $+         putStrLn $ "Hash mismatch(es)!\n" ++ mismatches_disp+  return $ null index_extra && null pristine_extra && null mismatches+
+ src/Darcs/Repository/State.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}++-- Copyright (C) 2009 Petr Rockai+--+-- Permission is hereby granted, free of charge, to any person+-- obtaining a copy of this software and associated documentation+-- files (the "Software"), to deal in the Software without+-- restriction, including without limitation the rights to use, copy,+-- modify, merge, publish, distribute, sublicense, and/or sell copies+-- of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:+--+-- The above copyright notice and this permission notice shall be+-- included in all copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE.++module Darcs.Repository.State+    ( restrictSubpaths, restrictBoring+    -- * Diffs.+    , unrecordedChanges, readPending, pendingChanges+    -- * Trees.+    , readRecorded, readUnrecorded, readRecordedAndPending+    -- * Index.+    , readIndex, invalidateIndex ) where++import Prelude hiding ( filter )+import Control.Monad( when )+import Control.Applicative( (<$>) )+import Data.Maybe( isJust )+import Data.List( union )+import Text.Regex( matchRegex )++import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile )+import System.FilePath ( (</>) )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++import Darcs.Patch ( RepoPatch, Prim, invert, applyToTree, applyToFilepaths+                   , sortCoalesceFL )+import Darcs.Patch.TouchesFiles ( choose_touching )+import Darcs.Witnesses.Ordered ( FL(..), (+>+) )+import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal )+import Darcs.Diff ( treeDiff )+import Darcs.Flags ( DarcsFlag( LookForAdds ), willIgnoreTimes )+import Darcs.Utils ( filterPaths )++import Darcs.Repository.InternalTypes ( Repository )+import Darcs.Repository.LowLevel( read_pending )+import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps )++import Darcs.Patch.FileName ( fn2fp )+import Darcs.RepoPath ( SubPath, sp2fn )++import Storage.Hashed.AnchoredPath( AnchoredPath(..), anchorPath, floatPath, Name(..) )+import Storage.Hashed.Tree( Tree, restrict, FilterTree, expand, filter, emptyTree, overlay, find )+import Storage.Hashed.Plain( readPlainTree )+import Storage.Hashed.Darcs( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )+import Storage.Hashed.Hash( Hash( NoHash ) )+import qualified Storage.Hashed.Index as I++#include "gadts.h"++-- | From a repository and a list of SubPath's, construct a filter that can be+-- used on a Tree (recorded or unrecorded state) of this repository. This+-- constructed filter will take pending into account, so the subpaths will be+-- translated correctly relative to pending move patches. As an exception for+-- convenience, if the subpath list is empty, the filter constructed is an+-- identity.+restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath]+                 -> IO (forall t m. FilterTree t m => t m -> t m)+restrictSubpaths repo subpaths = do+  Sealed pending <- read_pending repo+  let paths = map (fn2fp . sp2fn) subpaths+      paths' = paths `union` applyToFilepaths pending paths+      anchored = map floatPath paths'+      restrictPaths :: FilterTree t m => t m -> t m+      restrictPaths = if null subpaths then id else filter (filterPaths anchored)+  return restrictPaths++-- | Construct a Tree filter that removes any boring files the Tree might have+-- contained. Additionally, you should (in most cases) pass an (expanded) Tree+-- that corresponds to the recorded content of the repository. This is+-- important in the cases when the repository contains files that would be+-- boring otherwise. (If you pass emptyTree instead, such files will simply be+-- discarded by the filter, which is usually not what you want.)+--+-- This function is most useful when you have a plain Tree corresponding to the+-- full working copy of the repository, including untracked+-- files. Cf. whatsnew, record --look-for-adds.  NB. Assumes that our CWD is+-- the repository root.+restrictBoring :: forall t m. Tree m -> IO (FilterTree t m => t m -> t m)+restrictBoring guide = do+  boring <- boringRegexps+  let boring' (AnchoredPath (Name x:_)) | x == BSC.pack "_darcs" = False+      boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring+          where p' = anchorPath "" p+      restrictTree :: FilterTree t m => t m -> t m+      restrictTree = filter $ \p _ -> case find guide p of+                                        Nothing -> boring' p+                                        _ -> True+  return restrictTree++-- | For a repository and a list of paths (when empty, 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 non-empty list of paths is given, exactly+-- the files that live under any of these paths in either recorded or+-- unrecorded will be included in the resulting patch.+--+-- This also depends on the options given: with LookForAdds, we will include+-- any non-boring files (i.e. also those that do not exist in the "recorded"+-- state) in the working in the "unrecorded" state, and therefore they will+-- show up in the patches as addfiles.+--+-- The IgnoreTimes option disables index usage completely -- for each file, we+-- read both the unrecorded and the recorded copy and run a diff on them. This+-- is very inefficient, although in extremely rare cases, the index could go+-- out of sync (file is modified, index is updated and file is modified again+-- within a single second).+unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t)+                  -> [SubPath] -> IO (FL Prim C(r y))+unrecordedChanges opts repo paths = do+  (all_current, _) <- readPending repo+  Sealed pending <- pendingChanges repo paths++  relevant <- restrictSubpaths repo paths+  let getIndex = I.updateIndex =<< (relevant <$> readIndex repo)+      current = relevant all_current++  working <- case (LookForAdds `elem` opts, willIgnoreTimes opts) of+               (False, False) -> getIndex+               (False, True) -> do+                 guide <- expand current+                 relevant <$> restrict guide <$> readPlainTree "."+               (True, ignoretimes) -> do+                 index <- getIndex+                 nonboring <- restrictBoring index+                 plain <- relevant <$> nonboring <$> readPlainTree "."+                 return $ if ignoretimes then plain else plain `overlay` index++  ft <- filetypeFunction+  diff <- treeDiff ft current working+  return $ sortCoalesceFL (pending +>+ diff)++-- | Obtains a Tree corresponding to the "recorded" state of the repository:+-- this is the same as the pristine cache, which is the same as the result of+-- applying all the repository's patches to an empty directory.+--+-- Handles the plain and hashed pristine cases. Currently does not handle the+-- no-pristine case, as that requires replaying patches. Cf. 'readDarcsHashed'+-- and 'readPlainTree' in hashed-storage that are used to do the actual 'Tree'+-- construction.+readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)+readRecorded _repo = do+  let darcs = "_darcs"+      h_inventory = darcs </> "hashed_inventory"+  hashed <- doesFileExist h_inventory+  if hashed+     then do inv <- BS.readFile h_inventory+             let linesInv = BSC.split '\n' inv+             case linesInv of+               [] -> return emptyTree+               (pris_line:_) -> do+                          let hash = decodeDarcsHash $ BS.drop 9 pris_line+                              size = decodeDarcsSize $ BS.drop 9 pris_line+                          when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line+                          readDarcsHashed (darcs </> "pristine.hashed") (size, hash)+     else do have_pristine <- doesDirectoryExist $ darcs </> "pristine"+             have_current <- doesDirectoryExist $ darcs </> "current"+             case (have_pristine, have_current) of+               (True, _) -> readPlainTree $ darcs </> "pristine"+               (False, True) -> readPlainTree $ darcs </> "current"+               (_, _) -> fail "No pristine tree is available!"++-- | Obtains a Tree corresponding to the "unrecorded" state of the repository:+-- the working tree plus the "pending" patch.+readUnrecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)+readUnrecorded repo = readIndex repo >>= I.updateIndex++readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)+readRecordedAndPending repo = do+  pristine <- readRecorded repo+  Sealed pending <- pendingChanges repo []+  applyToTree pending pristine++readPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO, Sealed (FL Prim C(r)))+readPending repo =+  do Sealed pending <- read_pending repo+     pristine <- readRecorded repo+     catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ err -> do+       putStrLn $ "Yikes, pending has conflicts! " ++ show err+       putStrLn $ "Stashing the buggy pending as _darcs/patches/pending_buggy"+       renameFile "_darcs/patches/pending"+                  "_darcs/patches/pending_buggy"+       return (pristine, seal NilFL)++pendingChanges :: (RepoPatch p) => Repository p C(r u t)+               -> [SubPath] -> IO (Sealed (FL Prim C(r)))+pendingChanges repo paths = do+  Sealed pending <- snd `fmap` readPending repo+  let files = map (fn2fp . sp2fn) paths+      pre_files = applyToFilepaths (invert pending) files+      relevant = case paths of+                   [] -> seal pending+                   _ -> choose_touching pre_files pending+  return relevant++-- | Mark the existing index as invalid. This has to be called whenever the+-- listing of pristine changes and will cause darcs to update the index next+-- time it tries to read it. (NB. This is about files added and removed from+-- pristine: changes to file content in either pristine or working are handled+-- transparently by the index reading code.)+invalidateIndex :: t -> IO ()+invalidateIndex _ = do+  BS.writeFile "_darcs/index_invalid" BS.empty++readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO I.Index+readIndex repo = do+  invalid <- doesFileExist "_darcs/index_invalid"+  exist <- doesFileExist "_darcs/index"+  format_valid <- if exist+                     then I.indexFormatValid "_darcs/index"+                     else return True+  when (exist && not format_valid) $+#if mingw32_HOST_OS+       renameFile "_darcs/index" "_darcs/index.old"+#else+       removeFile "_darcs/index"+#endif+  if (not exist || invalid || not format_valid)+     then do pris <- readRecordedAndPending repo+             idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris+             when invalid $ removeFile "_darcs/index_invalid"+             return idx+     else I.readIndex "_darcs/index" darcsTreeHash
src/Darcs/Resolution.lhs view
@@ -32,33 +32,35 @@ import Data.List ( zip4 ) import Control.Monad ( when ) -import Darcs.Patch ( RepoPatch, Prim, joinPatches, resolve_conflicts,+import Darcs.Diff( treeDiff )+import Darcs.Patch ( RepoPatch, Prim, joinPatches, resolveConflicts,                      effect,-                     apply_to_filepaths, patchcontents,-                     invert, list_conflicted_files, commute )+                     applyToFilepaths, patchcontents,+                     invert, listConflictedFiles, commute, applyToTree ) import Darcs.RepoPath ( toFilePath )-import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+),-                             mapFL_FL, reverseRL, lengthFL )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+),+                             mapFL_FL, reverseRL )  import CommandLine ( parseCmd ) import Darcs.Hopefully ( hopefully )-import Darcs.Utils ( askUser )-import Darcs.SlurpDirectory ( Slurpy, slurp, write_files )+import Darcs.Utils ( askUser, filterFilePaths ) import Darcs.Patch.Set ( PatchSet )-import Darcs.Diff ( unsafeDiff )-import Darcs.Sealed ( Sealed(..) )-import Darcs.Repository.Prefs ( filetype_function )+import Darcs.Witnesses.Sealed ( seal )+import Darcs.Witnesses.Sealed ( Sealed(..) )+import Darcs.Repository.Prefs ( filetypeFunction ) import Exec ( exec, Redirect(..) ) import Darcs.Lock ( withTempDir ) import Darcs.External ( cloneTree )-import Darcs.Patch.Apply ( apply_to_slurpy ) +import qualified Storage.Hashed.Tree as Tree+import Storage.Hashed ( writePlainTree, readPlainTree )+ --import Darcs.ColorPrinter ( traceDoc ) --import Printer ( greenText, ($$), Doc ) --import Darcs.Patch ( showPatch )  standard_resolution :: RepoPatch p => p C(x y) -> Sealed (FL Prim C(y))-standard_resolution p = merge_list $ map head $ resolve_conflicts p+standard_resolution p = merge_list $ map head $ resolveConflicts p  merge_list :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) merge_list patches = doml NilFL patches@@ -156,18 +158,19 @@ Note that the defaults file does not want quotes around the command.  \begin{code}-external_resolution :: RepoPatch p => Slurpy -> String -> FL Prim C(x y) -> FL Prim C(x z)+external_resolution :: RepoPatch p => Tree.Tree IO -> String -> FL Prim C(x y) -> FL Prim C(x z)                     -> p C(y a)                     -> IO (Sealed (FL Prim C(a))) external_resolution s1 c p1 p2 pmerged = do- sa <- apply_to_slurpy (invert p1) s1- sm <- apply_to_slurpy pmerged s1- s2 <- apply_to_slurpy p2 sa- let nms = list_conflicted_files pmerged-     nas = apply_to_filepaths (invert pmerged) nms-     n1s = apply_to_filepaths p1 nas-     n2s = apply_to_filepaths p2 nas+ sa <- applyToTree (invert p1) s1+ sm <- applyToTree pmerged s1+ s2 <- applyToTree p2 sa+ let nms = listConflictedFiles pmerged+     nas = applyToFilepaths (invert pmerged) nms+     n1s = applyToFilepaths p1 nas+     n2s = applyToFilepaths p2 nas      ns = zip4 nas n1s n2s nms+     write_files tree fs = writePlainTree (Tree.filter (filterFilePaths fs) tree) "."   in do    former_dir <- getCurrentDirectory    withTempDir "version1" $ \absd1 -> do@@ -190,13 +193,10 @@              let d2 = toFilePath absd2              write_files s2 n2s              mapM_ (externally_resolve_file c da d1 d2 dm) ns-             sc <- slurp dc-             sfixed <- slurp dm-             ftf <- filetype_function-             case unsafeDiff [] ftf sc sfixed of-               di -> lengthFL di `seq` return (Sealed di)-               -- The `seq` above forces the two slurpies to be read before-               -- we delete their directories.+             sc <- readPlainTree dc+             sfixed <- readPlainTree dm+             ftf <- filetypeFunction+             seal `fmap` treeDiff ftf sc sfixed  externally_resolve_file :: String -> String -> String -> String -> String                         -> (FilePath, FilePath, FilePath, FilePath)@@ -226,9 +226,9 @@                                       Sealed NilFL patchset_conflict_resolutions (xs:<:_)     = --traceDoc (greenText "looking at resolutions" $$-      --         (sh $ resolve_conflicts $ joinPatches $+      --         (sh $ resolveConflicts $ joinPatches $       --              mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $-      merge_list $ map head $ resolve_conflicts $ joinPatches $+      merge_list $ map head $ resolveConflicts $ joinPatches $       mapFL_FL (patchcontents . hopefully) $ reverseRL xs     --where sh :: [[Sealed (FL Prim)]] -> Doc     --      sh [] = greenText "no more conflicts"
src/Darcs/RunCommand.hs view
@@ -26,30 +26,28 @@  import Darcs.Arguments ( DarcsFlag(..),                          help,-                         option_from_darcsoption,-                         list_options )+                         optionFromDarcsoption,+                         listOptions ) import Darcs.ArgumentDefaults ( get_default_flags ) import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ),                         DarcsCommand,-                        command_name,-                        command_command,-                        command_prereq,-                        command_extra_arg_help,-                        command_extra_args,-                        command_argdefaults,-                        command_get_arg_possibilities,-                        command_options, command_alloptions,-                        disambiguate_commands,-                        get_command_help, get_command_mini_help,-                        get_subcommands,-                        extract_commands,-                        super_name,-                        subusage, chomp_newline )-#ifdef HAVE_HASKELL_ZLIB+                        commandName,+                        commandCommand,+                        commandPrereq,+                        commandExtraArgHelp,+                        commandExtraArgs,+                        commandArgdefaults,+                        commandGetArgPossibilities,+                        commandOptions, commandAlloptions,+                        disambiguateCommands,+                        getCommandHelp, getCommandMiniHelp,+                        getSubcommands,+                        extractCommands,+                        superName,+                        subusage, chompNewline ) import Darcs.Commands.GZCRCs ( doCRCWarnings ) import Darcs.Global ( atexit )-#endif-import Darcs.Commands.Help ( command_control_list )+import Darcs.Commands.Help ( commandControlList ) import Darcs.External ( viewDoc ) import Darcs.Global ( setDebugMode, setSshControlMasterDisabled,                       setTimingsMode, setVerboseMode )@@ -63,7 +61,7 @@  run_the_command :: String -> [String] -> IO () run_the_command cmd args =-  either fail rtc $ disambiguate_commands command_control_list cmd args+  either fail rtc $ disambiguateCommands commandControlList cmd args  where   rtc (CommandOnly c, as)       = run_command Nothing c  as   rtc (SuperCommandOnly c,  as) = run_raw_supercommand c as@@ -80,18 +78,18 @@ run_command msuper cmd args = do    cwd <- getCurrentDirectory    let options = opts1 ++ opts2-       (opts1, opts2) = command_options cwd cmd+       (opts1, opts2) = commandOptions cwd cmd    case getOpt Permute-             (option_from_darcsoption cwd list_options++options) args of+             (optionFromDarcsoption cwd listOptions++options) args of     (opts,extra,[])-      | Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd+      | Help `elem` opts -> viewDoc $ text $ getCommandHelp msuper cmd       | ListOptions `elem` opts  -> do            setProgressMode False-           command_prereq cmd opts-           file_args <- command_get_arg_possibilities cmd+           commandPrereq cmd opts+           file_args <- commandGetArgPossibilities cmd            putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args       | otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra-    (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)+    (_,_,ermsgs) -> do fail $ chompNewline(unlines ermsgs)     where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts                                  | otherwise = opts @@ -99,27 +97,27 @@                  -> [DarcsFlag] -> [String] -> IO () consider_running msuper cmd opts old_extra = do  cwd <- getCurrentDirectory- location <- command_prereq cmd opts+ location <- commandPrereq cmd opts  case location of    Left complaint -> fail $ "Unable to " ++-                     formatPath ("darcs " ++ super_name msuper ++ command_name cmd) +++                     formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++                      " here.\n\n" ++ complaint    Right () -> do     specops <- add_command_defaults cmd opts-    extra <- (command_argdefaults cmd) specops cwd old_extra+    extra <- (commandArgdefaults cmd) specops cwd old_extra     when (Disable `elem` specops) $-      fail $ "Command "++command_name cmd++" disabled with --disable option!"-    if command_extra_args cmd < 0+      fail $ "Command "++commandName cmd++" disabled with --disable option!"+    if commandExtraArgs cmd < 0       then runWithHooks specops extra-      else if length extra > command_extra_args cmd+      else if length extra > commandExtraArgs cmd            then fail $ "Bad argument: `"++unwords extra++"'\n"++-                       get_command_mini_help msuper cmd-           else if length extra < command_extra_args cmd+                       getCommandMiniHelp msuper cmd+           else if length extra < commandExtraArgs cmd                 then fail $ "Missing argument:  " ++                             nth_arg (length extra + 1) ++-                            "\n" ++ get_command_mini_help msuper cmd+                            "\n" ++ getCommandMiniHelp msuper cmd                 else runWithHooks specops extra-       where nth_arg n = nth_of n (command_extra_arg_help cmd)+       where nth_arg n = nth_of n (commandExtraArgHelp cmd)              nth_of 1 (h:_) = h              nth_of n (_:hs) = nth_of (n-1) hs              nth_of _ [] = "UNDOCUMENTED"@@ -135,22 +133,20 @@                when (HTTPPipelining `elem` os) $ setHTTPPipelining True                when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False                unless (SSHControlMaster `elem` os) setSshControlMasterDisabled-#ifdef HAVE_HASKELL_ZLIB                unless (Quiet `elem` os) $ atexit $ doCRCWarnings (Verbose `elem` os)-#endif                -- actually run the command and its hooks                preHookExitCode <- run_prehook os here                if preHookExitCode /= ExitSuccess                   then exitWith preHookExitCode                   else do let fixFlag = FixFilePath here cwd-                          (command_command cmd) (fixFlag : os) ex+                          (commandCommand cmd) (fixFlag : os) ex                           postHookExitCode <- run_posthook os here                           exitWith postHookExitCode  add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag] add_command_defaults cmd already = do-  let (opts1, opts2) = command_alloptions cmd-  defaults <- get_default_flags (command_name cmd) (opts1 ++ opts2) already+  let (opts1, opts2) = commandAlloptions cmd+  defaults <- get_default_flags (commandName cmd) (opts1 ++ opts2) already   return $ already ++ defaults  get_options_options :: [OptDescr DarcsFlag] -> String@@ -165,22 +161,22 @@  run_raw_supercommand :: DarcsCommand -> [String] -> IO () run_raw_supercommand super [] =-    fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n"+    fail $ "Command '"++ commandName super ++"' requires subcommand!\n\n"              ++ subusage super run_raw_supercommand super args = do   cwd <- getCurrentDirectory   case getOpt RequireOrder-             (option_from_darcsoption cwd help++-              option_from_darcsoption cwd list_options) args of+             (optionFromDarcsoption cwd help+++              optionFromDarcsoption cwd listOptions) args of     (opts,_,[])       | Help `elem` opts ->-            viewDoc $ text $ get_command_help Nothing super+            viewDoc $ text $ getCommandHelp Nothing super       | ListOptions `elem` opts -> do             putStrLn "--help"-            mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super)+            mapM_ (putStrLn . commandName) (extractCommands $ getSubcommands super)       | otherwise ->             if Disable `elem` opts-            then fail $ "Command " ++ (command_name super) +++            then fail $ "Command " ++ (commandName super) ++                       " disabled with --disable option!"             else fail $ "Invalid subcommand!\n\n" ++ subusage super-    (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)+    (_,_,ermsgs) -> do fail $ chompNewline(unlines ermsgs)
− src/Darcs/Sealed.hs 
@@ -1,103 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -cpp -fglasgow-exts #-}-{-# LANGUAGE CPP #-}--- , MagicHash, GADTs #-}--#include "gadts.h"--module Darcs.Sealed ( Sealed(..), seal, unseal, mapSeal,-#ifndef GADT_WITNESSES-                      unsafeUnseal, unsafeUnflippedseal, unsafeUnseal2,-#endif-                      Sealed2(..), seal2, unseal2, mapSeal2,-                      FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped,-                      unsealM, liftSM-                    ) where--import GHC.Base ( unsafeCoerce# )-import Darcs.Show--data Sealed a where-    Sealed :: a C(x ) -> Sealed a--seal :: a C(x ) -> Sealed a-seal = Sealed--data Sealed2 a where-    Sealed2 :: !(a C(x y )) -> Sealed2 a--seal2 :: a C(x y ) -> Sealed2 a-seal2 = Sealed2--data FlippedSeal a C(y) where-    FlippedSeal :: !(a C(x y)) -> FlippedSeal a C(y)--flipSeal :: a C(x y) -> FlippedSeal a C(y)-flipSeal = FlippedSeal--#ifndef GADT_WITNESSES-unsafeUnseal :: Sealed a -> a-unsafeUnseal (Sealed a) = a--unsafeUnflippedseal :: FlippedSeal a -> a-unsafeUnflippedseal (FlippedSeal a) = a--unsafeUnseal2 :: Sealed2 a -> a-unsafeUnseal2 (Sealed2 a) = a-#endif--seriouslyUnsafeUnseal :: Sealed a -> a C(())-seriouslyUnsafeUnseal (Sealed a) = unsafeCoerce# a--unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b-unseal f x = f (seriouslyUnsafeUnseal x)---- laziness property:--- unseal (const True) undefined == True--unsealM :: Monad m => m (Sealed a) -> (FORALL(x) a C(x) -> m b) -> m b-unsealM m1 m2 = do sx <- m1-                   unseal m2 sx--liftSM :: Monad m => (FORALL(x) a C(x) -> b) -> m (Sealed a) -> m b-liftSM f m = do sx <- m-                return (unseal f sx)--mapSeal :: (FORALL(x) a C(x ) -> b C(x )) -> Sealed a -> Sealed b-mapSeal f = unseal (seal . f)--mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z)-mapFlipped f (FlippedSeal x) = FlippedSeal (f x)--seriouslyUnsafeUnseal2 :: Sealed2 a -> a C(() ())-seriouslyUnsafeUnseal2 (Sealed2 a) = unsafeCoerce# a--unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b-unseal2 f a = f (seriouslyUnsafeUnseal2 a)--mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b-mapSeal2 f = unseal2 (seal2 . f)--unsealFlipped :: (FORALL(x y) a C(x y) -> b) -> FlippedSeal a C(z) -> b-unsealFlipped f (FlippedSeal a) = f a--instance Show1 a => Show (Sealed a) where-    showsPrec d (Sealed x) = showParen (d > app_prec) $ showString "Sealed " . showsPrec1 (app_prec + 1) x-instance Show2 a => Show (Sealed2 a) where-    showsPrec d (Sealed2 x) = showParen (d > app_prec) $ showString "Sealed2 " . showsPrec2 (app_prec + 1) x
src/Darcs/SelectChanges.hs view
@@ -33,6 +33,7 @@                        with_selected_last_changes_reversed,                        view_changes,                        with_selected_patch_from_repo,+                       filterOutConflicts,                      ) where import System.IO import Data.List ( intersperse )@@ -43,33 +44,38 @@  import English ( Noun(..), englishNum  ) import Darcs.Arguments ( showFriendly )-import Darcs.Hopefully ( PatchInfoAnd, hopefully )-import Darcs.Repository ( Repository, read_repo )+import Darcs.Hopefully ( PatchInfoAnd, hopefully, n2pia )+import Darcs.Repository ( Repository, read_repo, unrecordedChanges ) import Darcs.Patch ( RepoPatch, Patchy, Prim, summary,-                     invert, list_touched_files,-                     commuteFL )+                     invert, listTouchedFiles,+                     commuteFL, fromPrims, anonymous ) import qualified Darcs.Patch ( thing, things )-import Darcs.Ordered ( FL(..), RL(..), (:>)(..),+import Darcs.Patch.Split ( Splitter(..) )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:||:)(..),                        (+>+), lengthFL, lengthRL, concatRL, mapFL_FL,                        spanFL, reverseFL, (+<+), mapFL,                        unsafeCoerceP )-import Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps,-                             force_first, force_last, make_uncertain, tag,-                      get_choices,-                      separate_first_middle_from_last,-                      separate_first_from_middle_last,-                      patch_slot,-                      select_all_middles,-                      force_matching_last,-                      force_matching_first, make_everything_later,-                             TaggedPatch, tp_patch, Slot(..),+import Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps,+                             patchChoicesTpsSub,+                             forceFirst, forceLast, makeUncertain, tag,+                      getChoices,+                      separateFirstMiddleFromLast,+                      separateFirstFromMiddleLast,+                      patchSlot,+                      selectAllMiddles,+                      forceMatchingLast,+                      forceMatchingFirst, makeEverythingLater,+                             TaggedPatch, tpPatch, Slot(..),+                      substitute,                     )+import Darcs.Patch.Permutations ( partitionConflictingFL, selfCommuter, commuterIdRL ) import Darcs.Patch.TouchesFiles ( deselect_not_touching, select_not_touching ) import Darcs.PrintPatch ( printFriendly, printPatch, printPatchPager )-import Darcs.Match ( have_nonrange_match, match_a_patch, match_a_patchread )-import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies), isInteractive )-import Darcs.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2 )+import Darcs.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread )+import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies, SkipConflicts), isInteractive )+import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2, Sealed(..) ) import Darcs.Utils ( askUser, promptCharFancy )+import Darcs.Lock ( editText ) import Printer ( prefix, putDocLn ) #include "impossible.h" @@ -80,6 +86,7 @@ type WithPatches p a C(x y) =         String              -- jobname      -> [DarcsFlag]         -- opts+     -> Maybe (Splitter p)  -- for interactive editing      -> FL p C(x y)         -- patches to select among      -> ((FL p :> FL p) C(x y) -> IO a) -- job      -> IO a                -- result of running job@@ -88,6 +95,7 @@ type WithPatchesToFiles p a C(x y) =         String              -- jobname      -> [DarcsFlag]         -- opts+     -> Maybe (Splitter p)  -- for interactive editing      -> [FilePath]          -- files      -> FL p C(x y)         -- patches to select among      -> ((FL p :> FL p) C(x y) -> IO a) -- job@@ -107,8 +115,8 @@ triv _ _ _ = True  iswanted :: Patchy p => MatchCriterion (PatchInfoAnd p)-iswanted First opts p = match_a_patch opts . hopefully $ p-iswanted LastReversed opts p = match_a_patch opts . hopefully . invert $ p+iswanted First opts p = matchAPatch opts . hopefully $ p+iswanted LastReversed opts p = matchAPatch opts . hopefully . invert $ p iswanted Last _ _ = bug "don't support patch matching with Last in wasp" iswanted FirstReversed _ _ = bug "don't support patch matching with FirstReversed in wasp" @@ -133,34 +141,34 @@  -- | wasc and wasc_ are just shorthand for with_any_selected_changes wasc  :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatches p a C(x y)-wasc mwch crit j o = wasc_ mwch crit j o []+wasc mwch crit j o spl = wasc_ mwch crit j o spl [] wasc_ :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y) wasc_ = with_any_selected_changes  with_any_selected_changes :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y)-with_any_selected_changes Last crit jn opts fs =+with_any_selected_changes Last crit jn opts splitter fs =     with_any_selected_changes_last         (patches_to_consider_last' fs opts crit)-        crit jn opts fs-with_any_selected_changes First crit jn opts fs =+        crit jn opts splitter fs+with_any_selected_changes First crit jn opts splitter fs =     with_any_selected_changes_first        (patches_to_consider_first' fs opts crit)-       crit jn opts fs-with_any_selected_changes FirstReversed crit jn opts fs =+       crit jn opts splitter fs+with_any_selected_changes FirstReversed crit jn opts splitter fs =     with_any_selected_changes_first_reversed        (patches_to_consider_first_reversed' fs opts crit)-       crit jn opts fs-with_any_selected_changes LastReversed crit jn opts fs =+       crit jn opts splitter fs+with_any_selected_changes LastReversed crit jn opts splitter fs =     with_any_selected_changes_last_reversed         (patches_to_consider_last_reversed' fs opts crit)-        crit jn opts fs+        crit jn opts splitter fs   view_changes :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () view_changes opts ps = do   text_view opts Nothing 0 NilRL init_tps init_pc   return ()-    where (init_pc, init_tps) = patch_choices_tps ps+    where (init_pc, init_tps) = patchChoicesTps ps  data KeyPress a = KeyPress { kp     :: Char                            , kpHelp :: String }@@ -183,7 +191,7 @@                               -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ()) -> IO () with_selected_patch_from_repo jn repository opts job = do     p_s <- read_repo repository-    sp <- wspfr jn (match_a_patchread opts)+    sp <- wspfr jn (matchAPatchread opts)                               (concatRL p_s) NilFL     case sp of      Just (FlippedSeal (skipped :> selected)) -> job (skipped :> selected)@@ -228,69 +236,76 @@                   repeat_this   where jn_cap = (toUpper $ head jn) : tail jn +-- After selecting with a splitter, the results may not be canonical+canonizeWith :: Maybe (Splitter p) -> (FL p :> FL p) C(x y) -> (FL p :> FL p) C(x y)+canonizeWith Nothing xy = xy+canonizeWith (Just spl) (x :> y) = canonizeSplit spl x :> canonizeSplit spl y+ with_any_selected_changes_last :: forall p a C(x y). Patchy p                                => (FL p C(x y) -> (FL p :> FL p) C(x y))                                -> MatchCriterion p                                -> WithPatchesToFiles p a C(x y)-with_any_selected_changes_last p2c crit jobname opts _ ps job =+with_any_selected_changes_last p2c crit jobname opts splitter _ ps job =  case p2c ps of  ps_to_consider :> other_ps ->          if not $ isInteractive opts          then job $ ps_to_consider :> other_ps-         else do pc <- tentatively_text_select "" jobname (Noun "patch") Last crit+         else do pc <- tentatively_text_select splitter "" jobname (Noun "patch") Last crit                                               opts ps_len 0 NilRL init_tps init_pc-                 job $ selected_patches_last rejected_ps pc+                 job $ canonizeWith splitter $ selected_patches_last rejected_ps pc          where rejected_ps = ps_to_consider                ps_len = lengthFL init_tps-               (init_pc, init_tps) = patch_choices_tps $ other_ps+               (init_pc, init_tps) = patchChoicesTps $ other_ps  with_any_selected_changes_first :: forall p a C(x y). Patchy p                                 => (FL p C(x y) -> (FL p :> FL p) C(x y))                                 -> MatchCriterion p                                 -> WithPatchesToFiles p a C(x y)-with_any_selected_changes_first p2c crit jobname opts _ ps job =+with_any_selected_changes_first p2c crit jobname opts splitter _ ps job =  case p2c ps of  ps_to_consider :> other_ps ->          if not $ isInteractive opts          then job $ ps_to_consider :> other_ps-         else do pc <- tentatively_text_select "" jobname (Noun "patch") First crit+         else do pc <- tentatively_text_select splitter "" jobname (Noun "patch") First crit                                               opts ps_len 0 NilRL init_tps init_pc-                 job $ selected_patches_first rejected_ps pc+                 job $ canonizeWith splitter $ selected_patches_first rejected_ps pc          where rejected_ps = other_ps                ps_len = lengthFL init_tps-               (init_pc, init_tps) = patch_choices_tps $ ps_to_consider+               (init_pc, init_tps) = patchChoicesTps $ ps_to_consider  with_any_selected_changes_first_reversed :: forall p a C(x y). Patchy p                                 => (FL p C(x y) -> (FL p :> FL p) C(y x))                                 -> MatchCriterion p                                 -> WithPatchesToFiles p a C(x y)-with_any_selected_changes_first_reversed p2c crit jobname opts _ ps job =+with_any_selected_changes_first_reversed p2c crit jobname opts splitter _ ps job =  case p2c ps of  ps_to_consider :> other_ps ->          if not $ isInteractive opts          then job $ invert other_ps :> invert ps_to_consider-         else do pc <- tentatively_text_select "" jobname (Noun "patch") FirstReversed crit+         else do pc <- tentatively_text_select splitter+                                             "" jobname (Noun "patch") FirstReversed crit                                              opts ps_len 0 NilRL init_tps init_pc-                 job $ selected_patches_first_reversed rejected_ps pc+                 job $ canonizeWith splitter $ selected_patches_first_reversed rejected_ps pc          where rejected_ps = ps_to_consider                ps_len = lengthFL init_tps-               (init_pc, init_tps) = patch_choices_tps other_ps+               (init_pc, init_tps) = patchChoicesTps other_ps  with_any_selected_changes_last_reversed :: forall p a C(x y). Patchy p                                 => (FL p C(x y) -> (FL p :> FL p) C(y x))                                 -> MatchCriterion p                                 -> WithPatchesToFiles p a C(x y)-with_any_selected_changes_last_reversed p2c crit jobname opts _ ps job =+with_any_selected_changes_last_reversed p2c crit jobname opts splitter _ ps job =  case p2c ps of  ps_to_consider :> other_ps ->          if not $ isInteractive opts          then job $ invert other_ps :> invert ps_to_consider-         else do pc <- tentatively_text_select "" jobname (Noun "patch") LastReversed crit+         else do pc <- tentatively_text_select splitter+                                             "" jobname (Noun "patch") LastReversed crit                                              opts ps_len 0 NilRL init_tps init_pc-                 job $ selected_patches_last_reversed rejected_ps pc+                 job $ canonizeWith splitter $ selected_patches_last_reversed rejected_ps pc          where rejected_ps = other_ps                ps_len = lengthFL init_tps-               (init_pc, init_tps) = patch_choices_tps ps_to_consider+               (init_pc, init_tps) = patchChoicesTps ps_to_consider   patches_to_consider_first' :: Patchy p@@ -301,16 +316,16 @@                      -> (FL p :> FL p) C(x y) patches_to_consider_first' fs opts crit ps =   let deselect_unwanted pc =-        if have_nonrange_match opts+        if haveNonrangeMatch opts         then if DontGrabDeps `elem` opts-                  then force_matching_last (not.iswanted_) pc-                  else make_everything_later $ force_matching_first iswanted_ pc+                  then forceMatchingLast (not.iswanted_) pc+                  else makeEverythingLater $ forceMatchingFirst iswanted_ pc         else pc-      iswanted_ = crit First opts . tp_patch-  in if null fs && not (have_nonrange_match opts)+      iswanted_ = crit First opts . tpPatch+  in if null fs && not (haveNonrangeMatch opts)      then ps :> NilFL-     else tp_patches $ separate_first_middle_from_last $ deselect_not_touching fs-                     $ deselect_unwanted $ patch_choices ps+     else tp_patches $ separateFirstMiddleFromLast $ deselect_not_touching fs+                     $ deselect_unwanted $ patchChoices ps  patches_to_consider_last' :: Patchy p                      => [FilePath]  -- ^ files@@ -320,15 +335,15 @@                      -> (FL p :> FL p) C(x y) patches_to_consider_last' fs opts crit ps =   let deselect_unwanted pc =-        if have_nonrange_match opts+        if haveNonrangeMatch opts         then if DontGrabDeps `elem` opts-                  then force_matching_last (not.iswanted_) pc-                  else make_everything_later $ force_matching_first iswanted_ pc+                  then forceMatchingLast (not.iswanted_) pc+                  else makeEverythingLater $ forceMatchingFirst iswanted_ pc         else pc-      iswanted_ = crit Last opts . tp_patch-  in if null fs && not (have_nonrange_match opts)+      iswanted_ = crit Last opts . tpPatch+  in if null fs && not (haveNonrangeMatch opts)      then NilFL :> ps-     else case get_choices $ select_not_touching fs $ deselect_unwanted $ patch_choices ps of+     else case getChoices $ select_not_touching fs $ deselect_unwanted $ patchChoices ps of            fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc  patches_to_consider_first_reversed' :: Patchy p@@ -339,15 +354,15 @@                      -> (FL p :> FL p) C(y x) patches_to_consider_first_reversed' fs opts crit ps =   let deselect_unwanted pc =-        if have_nonrange_match opts+        if haveNonrangeMatch opts         then if DontGrabDeps `elem` opts-                  then force_matching_last (not.iswanted_) pc-                  else make_everything_later $ force_matching_first iswanted_ pc+                  then forceMatchingLast (not.iswanted_) pc+                  else makeEverythingLater $ forceMatchingFirst iswanted_ pc         else pc-      iswanted_ = crit FirstReversed opts . tp_patch-  in if null fs && not (have_nonrange_match opts)+      iswanted_ = crit FirstReversed opts . tpPatch+  in if null fs && not (haveNonrangeMatch opts)      then NilFL :> (invert ps)-     else case get_choices $ select_not_touching fs $ deselect_unwanted $ patch_choices $ invert ps of+     else case getChoices $ select_not_touching fs $ deselect_unwanted $ patchChoices $ invert ps of            fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc  patches_to_consider_last_reversed' :: Patchy p@@ -358,55 +373,55 @@                      -> (FL p :> FL p) C(y x) patches_to_consider_last_reversed' fs opts crit ps =   let deselect_unwanted pc =-        if have_nonrange_match opts+        if haveNonrangeMatch opts         then if DontGrabDeps `elem` opts-             then force_matching_last (not.iswanted_) pc-             else make_everything_later $ force_matching_first iswanted_ pc+             then forceMatchingLast (not.iswanted_) pc+             else makeEverythingLater $ forceMatchingFirst iswanted_ pc         else pc-      iswanted_ = crit LastReversed opts . tp_patch+      iswanted_ = crit LastReversed opts . tpPatch   in-    if null fs && not (have_nonrange_match opts)+    if null fs && not (haveNonrangeMatch opts)     then (invert ps) :> NilFL-    else tp_patches $ separate_first_middle_from_last $ deselect_not_touching fs-                     $ deselect_unwanted $ patch_choices $ invert ps+    else tp_patches $ separateFirstMiddleFromLast $ deselect_not_touching fs+                     $ deselect_unwanted $ patchChoices $ invert ps  -- | Returns the results of a patch selection user interaction selected_patches_last :: Patchy p => FL p C(x y) -> PatchChoices p C(y z)                       -> (FL p :> FL p) C(x z) selected_patches_last other_ps pc =-  case get_choices pc of-   fc :> mc :> lc -> other_ps +>+ mapFL_FL tp_patch (fc +>+ mc) :> mapFL_FL tp_patch lc+  case getChoices pc of+   fc :> mc :> lc -> other_ps +>+ mapFL_FL tpPatch (fc +>+ mc) :> mapFL_FL tpPatch lc  selected_patches_first :: Patchy p => FL p C(y z) -> PatchChoices p C(x y)                        -> (FL p :> FL p) C(x z) selected_patches_first other_ps pc =-  case separate_first_from_middle_last pc of-  xs :> ys -> mapFL_FL tp_patch xs :> mapFL_FL tp_patch ys +>+ other_ps+  case separateFirstFromMiddleLast pc of+  xs :> ys -> mapFL_FL tpPatch xs :> mapFL_FL tpPatch ys +>+ other_ps  selected_patches_last_reversed :: Patchy p => FL p C(y x) -> PatchChoices p C(z y)                                -> (FL p :> FL p) C(x z) selected_patches_last_reversed other_ps pc =-  case separate_first_from_middle_last pc of-  xs :> ys -> invert (mapFL_FL tp_patch ys +>+ other_ps) :> invert (mapFL_FL tp_patch xs)+  case separateFirstFromMiddleLast pc of+  xs :> ys -> invert (mapFL_FL tpPatch ys +>+ other_ps) :> invert (mapFL_FL tpPatch xs)  selected_patches_first_reversed :: Patchy p => FL p C(z y) -> PatchChoices p C(y x)                                 -> (FL p :> FL p) C(x z) selected_patches_first_reversed other_ps pc =-  case get_choices pc of-  fc :> mc :> lc -> invert (mapFL_FL tp_patch lc) :> invert (other_ps +>+ mapFL_FL tp_patch (fc +>+ mc))+  case getChoices pc of+  fc :> mc :> lc -> invert (mapFL_FL tpPatch lc) :> invert (other_ps +>+ mapFL_FL tpPatch (fc +>+ mc)) -text_select :: forall p C(x y z). Patchy p => String -> WhichChanges+text_select :: forall p C(x y z). Patchy p => Maybe (Splitter p) -> String -> WhichChanges             ->  MatchCriterion p -> [DarcsFlag] -> Int -> Int             -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z) -> PatchChoices p C(x z)             -> IO ((PatchChoices p) C(x z)) -text_select _ _ _ _ _ _ _ NilFL pc = return pc-text_select jn whichch crit opts n_max n+text_select _ _ _ _ _ _ _ _ NilFL pc = return pc+text_select splitter jn whichch crit opts n_max n             tps_done tps_todo@(tp:>:tps_todo') pc = do       (printFriendly opts) `unseal2` viewp       repeat_this -- prompt the user     where-        do_next_action ja je = tentatively_text_select ja jn je whichch crit opts+        do_next_action ja je = tentatively_text_select splitter ja jn je whichch crit opts                                           n_max                                           (n+1) (tp:<:tps_done) tps_todo'         do_next = do_next_action "" (Noun "patch")@@ -414,6 +429,7 @@         helper = undefined         thing  = Darcs.Patch.thing (helper pc)         things = Darcs.Patch.things (helper pc)+        split = splitter >>= flip applySplitter (tpPatch tp)         options_basic =            [ KeyPress 'y' (jn++" this "++thing)            , KeyPress 'n' ("don't "++jn++" it")@@ -434,7 +450,12 @@         options_nav =            [ KeyPress 'j' ("skip to next "++thing)            , KeyPress 'k' ("back up to previous "++thing) ]+        options_split+           | Just _ <- split+                 = [ KeyPress 'e' ("interactively edit this "++thing) ]+           | otherwise = []         options = [options_basic]+                  ++ [options_split]                   ++ (if is_single_file_patch then [options_file] else [])                   ++ [options_view ++                       if Summary `elem` opts then [] else options_summary]@@ -448,18 +469,28 @@           case yorn of             'y' -> do_next $ force_yes (tag tp) pc             'n' -> do_next $ force_no (tag tp) pc-            'w' -> do_next $ make_uncertain (tag tp) pc+            'w' -> do_next $ makeUncertain (tag tp) pc+            'e' | Just (text, parse) <- split+                -> do newText <- editText "darcs-patch-edit" text+                      case parse newText of+                        Nothing -> repeat_this+                        Just ps -> do let tps_new = snd $ patchChoicesTpsSub (Just (tag tp)) ps+                                      text_select splitter+                                                  jn whichch crit opts (n_max + lengthFL tps_new - 1) n+                                                  tps_done (tps_new+>+tps_todo')+                                                  (substitute (seal2 (tp :||: tps_new)) pc)+             's' -> do_next_action "Skipped"  (Noun "change") $ skip_file             'f' -> do_next_action "Included" (Noun "change") $ do_file             'v' -> printPatch `unseal2` viewp >> repeat_this             'p' -> printPatchPager `unseal2` viewp >> repeat_this-            'l' -> do let selected = case get_choices pc of+            'l' -> do let selected = case getChoices pc of                                           (first_chs:>_:>last_chs) ->                                              if whichch == Last || whichch == FirstReversed                                                 then map_patches last_chs                                                 else map_patches first_chs                           map_patches = mapFL (\a ->-                                           (showFriendly opts) `unseal2` (seal2 $ tp_patch a))+                                           (showFriendly opts) `unseal2` (seal2 $ tpPatch a))                       putStrLn $ "---- Already selected "++things++" ----"                       mapM_ putDocLn $ selected                       putStrLn $ "---- end of already selected "++things++" ----"@@ -469,38 +500,38 @@                       repeat_this             'd' -> return pc             'a' -> do ask_confirmation-                      return $ select_all_middles (whichch == Last || whichch == FirstReversed) pc+                      return $ selectAllMiddles (whichch == Last || whichch == FirstReversed) pc             'q' -> do putStrLn $ jn_cap++" cancelled."                       exitWith $ ExitSuccess             'j' -> case tps_todo' of                        NilFL -> -- May as well work out the length now we have all                                 -- the patches in memory-                                text_select jn whichch crit opts+                                text_select splitter jn whichch crit opts                                     n_max n tps_done tps_todo pc-                       _ -> text_select jn whichch crit opts+                       _ -> text_select splitter jn whichch crit opts                                 n_max (n+1) (tp:<:tps_done) tps_todo' pc             'k' -> case tps_done of                         NilRL -> repeat_this                         (tp':<:tps_done') ->-                           text_select jn whichch crit opts+                           text_select splitter jn whichch crit opts                                n_max (n-1) tps_done' (tp':>:tps_todo) pc-            'c' -> text_select jn whichch crit opts+            'c' -> text_select splitter jn whichch crit opts                                         n_max n tps_done tps_todo pc             _   -> do putStrLn $ helpFor jn options                       repeat_this-        force_yes = if whichch == Last || whichch == FirstReversed then force_last else force_first-        force_no  = if whichch == Last || whichch == FirstReversed then force_first else force_last+        force_yes = if whichch == Last || whichch == FirstReversed then forceLast else forceFirst+        force_no  = if whichch == Last || whichch == FirstReversed then forceFirst else forceLast         patches_to_skip = (tag tp:) $ catMaybes-                        $ mapFL (\tp' -> if list_touched_files tp' == touched_files+                        $ mapFL (\tp' -> if listTouchedFiles tp' == touched_files                                          then Just (tag tp')                                          else Nothing) tps_todo'         skip_file = foldr force_no pc patches_to_skip         do_file = foldr force_yes pc patches_to_skip-        the_default = get_default (whichch == Last || whichch == FirstReversed) $ patch_slot tp pc+        the_default = get_default (whichch == Last || whichch == FirstReversed) $ patchSlot tp pc         jn_cap = (toUpper $ head jn) : tail jn-        touched_files = list_touched_files $ tp_patch tp+        touched_files = listTouchedFiles $ tpPatch tp         is_single_file_patch = length touched_files == 1-        viewp = if whichch == LastReversed || whichch == FirstReversed then seal2 $ invert (tp_patch tp) else seal2 $ tp_patch tp+        viewp = if whichch == LastReversed || whichch == FirstReversed then seal2 $ invert (tpPatch tp) else seal2 $ tpPatch tp         ask_confirmation =             if jn `elem` ["unpull", "unrecord", "obliterate"]             then do yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? "@@ -512,10 +543,10 @@ text_view :: forall p C(x y u r s). Patchy p => [DarcsFlag] -> Maybe Int -> Int             -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y u) -> PatchChoices p C(r s)             -> IO ((PatchChoices p) C(r s))-text_view _ _ _ _ NilFL _ = return $ patch_choices $ unsafeCoerceP NilFL --return pc+text_view _ _ _ _ NilFL _ = return $ patchChoices $ unsafeCoerceP NilFL --return pc text_view opts n_max n             tps_done tps_todo@(tp:>:tps_todo') pc = do-      printFriendly opts (tp_patch tp)+      printFriendly opts (tpPatch tp)       putStr "\n"       repeat_this -- prompt the user     where@@ -556,11 +587,11 @@         repeat_this = do           yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h"           case yorn of-            'y' -> printPatch (tp_patch tp) >> next_patch+            'y' -> printPatch (tpPatch tp) >> next_patch             'n' -> next_patch-            'v' -> printPatch (tp_patch tp) >> repeat_this-            'p' -> printPatchPager (tp_patch tp) >> repeat_this-            'x' -> do putDocLn $ prefix "    " $ summary (tp_patch tp)+            'v' -> printPatch (tpPatch tp) >> repeat_this+            'p' -> printPatchPager (tpPatch tp) >> repeat_this+            'x' -> do putDocLn $ prefix "    " $ summary (tpPatch tp)                       repeat_this             'q' -> exitWith ExitSuccess             'k' -> prev_patch@@ -571,25 +602,25 @@                       repeat_this         count_n_max | isJust n_max = n_max                     | otherwise    = Just $ lengthFL tps_todo + lengthRL tps_done-tentatively_text_select :: Patchy p => String -> String -> Noun -> WhichChanges+tentatively_text_select :: Patchy p => Maybe (Splitter p) -> String -> String -> Noun -> WhichChanges                         -> MatchCriterion p -> [DarcsFlag]                         -> Int -> Int -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z)                         -> PatchChoices p C(x z)                         -> IO ((PatchChoices p) C(x z))-tentatively_text_select _ _ _ _ _ _ _ _ _ NilFL pc = return pc-tentatively_text_select jobaction jobname jobelement whichch crit+tentatively_text_select _ _ _ _ _ _ _ _ _ _ NilFL pc = return pc+tentatively_text_select splitter jobaction jobname jobelement whichch crit                         opts n_max n ps_done ps_todo pc =-  case spanFL (\p -> decided $ patch_slot p pc) ps_todo of+  case spanFL (\p -> decided $ patchSlot p pc) ps_todo of   skipped :> unskipped -> do    when (numSkipped > 0) show_skipped    let (boringThenInteresting) =                           if DontPromptForDependencies `elem` opts-                          then spanFL (not.(crit whichch opts).tp_patch) unskipped+                          then spanFL (not.(crit whichch opts).tpPatch) unskipped                           else NilFL :> unskipped    case boringThenInteresting of      boring :> interesting -> do      let numNotConsidered = lengthFL boring + numSkipped-     text_select jobname whichch crit opts n_max (n + numNotConsidered)+     text_select splitter jobname whichch crit opts n_max (n + numNotConsidered)                  (reverseFL boring +<+ reverseFL skipped +<+ ps_done) interesting pc    where    numSkipped  = lengthFL skipped@@ -601,7 +632,7 @@       _action_ = if (length jobaction) == 0 then "Skipped" else jobaction       _elem_ = englishNum numSkipped jobelement       showskippedpatch :: Patchy p => FL (TaggedPatch p) C(y t) -> IO ()-      showskippedpatch (tp:>:tps) = (putDocLn $ prefix "    " $ summary (tp_patch tp)) >> showskippedpatch tps+      showskippedpatch (tp:>:tps) = (putDocLn $ prefix "    " $ summary (tpPatch tp)) >> showskippedpatch tps       showskippedpatch NilFL = return ()  decided :: Slot -> Bool@@ -617,4 +648,26 @@  tp_patches :: (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)            -> (FL p :> FL p) C(x y)-tp_patches (x:>y) = mapFL_FL tp_patch x :> mapFL_FL tp_patch y+tp_patches (x:>y) = mapFL_FL tpPatch x :> mapFL_FL tpPatch y++-- |Optionally remove any patches (+dependencies) from a sequence that+-- conflict with the recorded or unrecorded changes in a repo+filterOutConflicts :: RepoPatch p+                   => [DarcsFlag]                                    -- ^Command-line options. Only 'SkipConflicts' is+                                                                     -- significant; filtering will happen iff it is present+                   -> RL (PatchInfoAnd p) C(x r)                     -- ^Recorded patches from repository, starting from+                                                                     -- same context as the patches to filter+                   -> Repository p C(r u t)                          -- ^Repository itself, used for grabbing unrecorded changes+                   -> FL (PatchInfoAnd p) C(x z)                     -- ^Patches to filter+                   -> IO (Bool, Sealed (FL (PatchInfoAnd p) C(x)))   -- ^(True iff any patches were removed, possibly filtered patches)+filterOutConflicts opts us repository them+  | SkipConflicts `elem` opts+     = do let commuter = commuterIdRL selfCommuter+          unrec <- fmap n2pia . (anonymous . fromPrims) =<< unrecordedChanges [] repository []+          them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us)+          return (check rest, Sealed them')+  | otherwise+     = return (False, Sealed them)+  where check :: FL p C(a b) -> Bool+        check NilFL = False+        check _ = True
− src/Darcs/Show.hs 
@@ -1,25 +0,0 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}-{-# LANGUAGE CPP #-}--module Darcs.Show(Show1(..), Show2(..), showOp2, app_prec) where--#include "gadts.h"--class Show1 a where-    show1 :: a C(x) -> String-    show1 x = showsPrec1 0 x ""-    showsPrec1 :: Int -> a C(x) -> ShowS-    showsPrec1 _ x s = show1 x ++ s--class Show2 a where-    show2 :: a C(x y) -> String-    show2 x = showsPrec2 0 x ""-    showsPrec2 :: Int -> a C(x y) -> ShowS-    showsPrec2 _ x s = show2 x ++ s--showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String-showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x .-                          showString opstr . showsPrec2 (prec + 1) y--app_prec :: Int-app_prec = 10
src/Darcs/SlurpDirectory.hs view
@@ -21,7 +21,6 @@   FileContents,   undefined_time, undefined_size,   doesFileReallyExist, doesDirectoryReallyExist, isFileReallySymlink,-  wait_a_moment,   is_dir, is_file,   get_slurp, slurp_name,   slurp_has, slurp_has_anycase, slurp_hasfile, slurp_hasdir,
src/Darcs/SlurpDirectory/Internal.hs view
@@ -30,7 +30,7 @@                         slurp_removefile, slurp_removedir,                         slurp_remove,                         slurp_modfile, slurp_hasfile, slurp_hasdir,-                        slurp_has_anycase, wait_a_moment, undefined_time,+                        slurp_has_anycase, undefined_time,                         undefined_size,                         slurp_has, list_slurpy, list_slurpy_files,                         get_path_list,@@ -56,7 +56,6 @@           fileSize,           isRegularFile, isDirectory, isSymbolicLink         )-import System.Posix ( sleep ) import Data.Maybe ( catMaybes, isJust, maybeToList ) import Data.Map (Map) import qualified Data.Map as Map@@ -69,7 +68,7 @@ import qualified Data.ByteString as B  import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, norm_path, break_on_dir,-                              own_name, super_name )+                              own_name, superName ) #if mingw32_HOST_OS import Data.Int ( Int64 ) #else@@ -183,7 +182,7 @@ write_file s fn = case withSlurpy s $ smReadFilePS fn of                      Left err -> fail err                      Right (_, c) -> do-                       ensureDirectories (super_name fn)+                       ensureDirectories (superName fn)                        mWriteFilePS fn c                         try_write_file :: Slurpy -> FilePath -> IO ()@@ -199,7 +198,7 @@           isPar <- mDoesDirectoryExist d           if isPar              then return ()-            else ensureDirectories (super_name d) >> (mCreateDirectory d)+            else ensureDirectories (superName d) >> (mCreateDirectory d)  write_files ::  Slurpy -> [FilePath] -> IO () write_files s fps = mapM_ (try_write_file s) fps@@ -256,7 +255,7 @@  insertSlurpy :: FileName -> Slurpy -> SlurpMonad () insertSlurpy f news = mksm $ \s ->-                      if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s)+                      if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (superName f) s)                       then Left $ "Error creating file "++fn2fp f                       else Right (addslurp f news s, ()) @@ -341,13 +340,6 @@ undef_time_size :: (Maybe String, EpochTime, FileOffset) undef_time_size = (Nothing, undefined_time, undefined_size) -wait_a_moment :: IO ()-wait_a_moment = do { sleep 1; return () }-    -- HACKERY: In ghc 6.1, sleep has the type signature IO Int; it-    -- returns an integer just like sleep(3) does. To stay compatible-    -- with older versions, though, we just ignore sleep's return-    -- value. Hackery, like I said.- isFileReallySymlink :: FilePath -> IO Bool isFileReallySymlink f = do fs <- getSymbolicLinkStatus f                            return (isSymbolicLink fs)@@ -536,7 +528,7 @@  slurp_move :: FileName -> FileName -> Slurpy -> Maybe Slurpy slurp_move f f' s =-    if not (slurp_has (fn2fp f') s) && slurp_hasdir (super_name f') s+    if not (slurp_has (fn2fp f') s) && slurp_hasdir (superName f') s     then case get_slurp f s of          Nothing -> Nothing          Just sf ->@@ -549,7 +541,7 @@  addslurp :: FileName -> Slurpy -> Slurpy -> Slurpy addslurp fname s s' =-    case get_slurp_context (super_name fname) s' of+    case get_slurp_context (superName fname) s' of         Just (ctx, Slurpy d (SlurpDir _ c)) -> ctx (Slurpy d (SlurpDir Nothing (uncurry Map.insert (slurpy_to_pair s) c)))         _ -> s' @@ -567,7 +559,7 @@  slurp_adddir :: FileName -> Slurpy -> Maybe Slurpy slurp_adddir f s =-  if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s)+  if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (superName f) s)   then Nothing   else Just $ addslurp f (Slurpy (own_name f) (SlurpDir Nothing Map.empty)) s
src/Darcs/Test.lhs view
@@ -27,8 +27,8 @@  import Darcs.Arguments ( DarcsFlag( Quiet,                                     AskPosthook, AskPrehook ),-                        get_posthook_cmd, get_prehook_cmd )-import Darcs.Repository.Prefs ( get_prefval )+                        getPosthookCmd, getPrehookCmd )+import Darcs.Repository.Prefs ( getPrefval ) import Darcs.Utils ( askUser ) import System.IO ( hPutStrLn, stderr ) \end{code}@@ -61,7 +61,7 @@ get_test opts =  let putInfo s = when (not $ Quiet `elem` opts) $ putStr s  in do- testline <- get_prefval "test"+ testline <- getPrefval "test"  return $    case testline of    Nothing -> return ExitSuccess@@ -78,13 +78,14 @@                                withCurrentDirectory repodir $ run_hook opts "Posthook" ph  get_posthook :: [DarcsFlag] -> IO (Maybe String)-get_posthook opts = case get_posthook_cmd opts of+get_posthook opts = case getPosthookCmd opts of                     Nothing -> return Nothing                     Just command ->                        if AskPosthook `elem` opts-                       then do yorn <- askUser ("\nThe following command is set to execute.\n"+++                       then do putStr ("\nThe following command is set to execute.\n"++                                                 "Execute the following command now (yes or no)?\n"++                                                 command++"\n")+                               yorn <- askUser ""                                case yorn of ('y':_) -> return $ Just command                                             _ -> do putStrLn "Posthook cancelled..."                                                     return Nothing@@ -95,13 +96,14 @@                               withCurrentDirectory repodir $ run_hook opts "Prehook" ph  get_prehook :: [DarcsFlag] -> IO (Maybe String)-get_prehook opts = case get_prehook_cmd opts of+get_prehook opts = case getPrehookCmd opts of                    Nothing -> return Nothing                    Just command ->                        if AskPrehook `elem` opts-                       then do yorn <- askUser ("\nThe following command is set to execute.\n"+++                       then do putStr ("\nThe following command is set to execute.\n"++                                                 "Execute the following command now (yes or no)?\n"++                                                 command++"\n")+                               yorn <- askUser ""                                case yorn of ('y':_) -> return $ Just command                                             _ -> do putStrLn "Prehook cancelled..."                                                     return Nothing
+ src/Darcs/Test/Patch/Check.hs view
@@ -0,0 +1,333 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Test.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists,+                                remove_file, remove_dir, create_file, create_dir,+                                insert_line, delete_line, is_valid, do_verbose_check,+                                file_empty,+                                check_move, modify_file, FileContents(..)+                              ) where++import System.IO.Unsafe ( unsafePerformIO )+import qualified Data.ByteString as B (ByteString)+import Data.List ( isPrefixOf, inits )+import Control.Monad.State ( State, evalState, runState )+import Control.Monad.State.Class ( get, put, modify )+-- use Map, not IntMap, because Map has mapKeys and IntMap hasn't+import Data.Map ( Map )+import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null )+import System.FilePath ( joinPath, splitDirectories )++-- | File contents are represented by a map from line numbers to line contents.+--   If for a certain line number, the line contents are Nothing, that means+--   that we are sure that that line exists, but we don't know its contents.+--   We must also store the greatest line number that is known to exist in a+--   file, to be able to exclude the possibility of it being empty without+--   knowing its contents.+data FileContents = FC { fc_lines   :: Map Int B.ByteString+                       , fc_maxline :: Int+                       } deriving (Eq, Show)+data Prop = FileEx String | DirEx String | NotEx String+          | FileLines String FileContents+            deriving (Eq)+-- | A @KnownState@ is a simulated repository state. The repository is either+-- inconsistent, or it has two lists of properties: one list with properties+-- that hold for this repo, and one with properties that do not hold for this+-- repo. These two lists may not have any common elements: if they had, the+-- repository would be inconsistent.+data KnownState = P [Prop] [Prop]+                | Inconsistent+                  deriving (Show)+instance  Show Prop  where+    show (FileEx f) = "FileEx "++f+    show (DirEx d)  = "DirEx "++d+    show (NotEx f) = "NotEx"++f+    show (FileLines f l)  = "FileLines "++f++": "++show l++-- | PatchCheck is a state monad with a simulated repository state+type PatchCheck = State KnownState++-- | The @FileContents@ structure for an empty file+empty_filecontents :: FileContents+empty_filecontents = FC M.empty 0++-- | Returns a given value if the repository state is inconsistent, and performs+--   a given action otherwise.+handle_inconsistent :: a            -- ^ The value to return if the state is inconsistent+                   -> PatchCheck a -- ^ The action to perform otherwise+                   -> PatchCheck a+handle_inconsistent v a = do state <- get+                             case state of+                               Inconsistent -> return v+                               _            -> a++do_check :: PatchCheck a -> a+do_check p = evalState p (P [] [])++-- | Run a check, and print the final repository state+do_verbose_check :: PatchCheck a -> a+do_verbose_check p =+    case runState p (P [] []) of+    (b, pc) -> unsafePerformIO $ do putStrLn $ show pc+                                    return b++-- | Returns true if the current repository state is not inconsistent+is_valid :: PatchCheck Bool+is_valid = handle_inconsistent False (return True)++has :: Prop -> [Prop] -> Bool+has _ [] = False+has k (k':ks) = k == k' || has k ks++modify_file :: String+            -> (Maybe FileContents -> Maybe FileContents)+            -> PatchCheck Bool+modify_file f change = do+    file_exists f+    c <- file_contents f+    case change c of+      Nothing -> assert_not $ FileEx f -- shorthand for "FAIL"+      Just c' -> do set_contents f c'+                    is_valid++insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool+insert_line f n l = do+    c <- file_contents f+    case c of+      Nothing -> assert_not $ FileEx f -- in this case, the repo is inconsistent+      Just c' -> do+        let lines'   = M.mapKeys (\k -> if k >= n then k+1 else k) (fc_lines c')+            lines''  = M.insert n l lines'+            maxline' = max n (fc_maxline c')+        set_contents f (FC lines'' maxline')+        return True++-- deletes a line from a hunk patch (third argument) in the given file (first+-- argument) at the given line number (second argument)+delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool+delete_line f n l = do+    c <- file_contents f+    case c of+      Nothing -> assert_not $ FileEx f+      Just c' ->+        let flines  = fc_lines c'+            flines' = M.mapKeys (\k -> if k > n then k-1 else k)+                                (M.delete n flines)+            maxlinenum' | n <= fc_maxline c'  = fc_maxline c' - 1+                        | otherwise           = n - 1+            c'' = FC flines' maxlinenum'+            do_delete = do+              set_contents f c''+              is_valid+        in case M.lookup n flines of+          Nothing -> do_delete+          Just l' -> if l == l'+                       then do_delete+                       else assert_not $ FileEx f++set_contents :: String -> FileContents -> PatchCheck ()+set_contents f c = handle_inconsistent () $ do+    P ks nots <- get+    let ks' = FileLines f c : filter (not . is_file_lines_for f) ks+    put (P ks' nots)+  where is_file_lines_for file prop = case prop of +                                        FileLines f' _ -> file == f'+                                        _              -> False++-- | Get (as much as we know about) the contents of a file in the current state.+--   Returns Nothing if the state is inconsistent.+file_contents :: String -> PatchCheck (Maybe FileContents)+file_contents f = handle_inconsistent Nothing $ do+      P ks _ <- get+      return (fic ks)+    where fic (FileLines f' c:_) | f == f' = Just c+          fic (_:ks) = fic ks+          fic [] = Just empty_filecontents++-- | Checks if a file is empty+file_empty :: String          -- ^ Name of the file to check+           -> PatchCheck Bool+file_empty f = do+  c <- file_contents f+  let empty = case c of+               Just c' -> fc_maxline c' == 0 && M.null (fc_lines c')+               Nothing -> True+  if empty+     then do set_contents f empty_filecontents+             is_valid+     -- Crude way to make it inconsistent and return false:+     else assert_not $ FileEx f+  return empty++movedirfilename :: String -> String -> String -> String+movedirfilename d d' f+  | (d ++ "/") `isPrefixOf` f = d' ++ drop (length d) f+  | f == d = d'+  | otherwise = f++-- | Replaces a filename by another in all paths. Returns True if the repository+--   is consistent, False if it is not.+do_swap :: String -> String -> PatchCheck Bool+do_swap f f' = handle_inconsistent False $ do+    modify (\(P ks nots) -> P (map sw ks) (map sw nots))+    return True+  where sw (FileEx a) | f  `is_soe` a = FileEx $ movedirfilename f f' a+                      | f' `is_soe` a = FileEx $ movedirfilename f' f a+        sw (DirEx a) | f  `is_soe` a = DirEx $ movedirfilename f f' a+                     | f' `is_soe` a = DirEx $ movedirfilename f' f a+        sw (FileLines a c) | f  `is_soe` a = FileLines (movedirfilename f f' a) c+                           | f' `is_soe` a = FileLines (movedirfilename f' f a) c+        sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a+                     | f' `is_soe` a = NotEx $ movedirfilename f' f a+        sw p = p+        is_soe d1 d2 = -- is_superdir_or_equal+            d1 == d2 || (d1 ++ "/") `isPrefixOf` d2++-- | Assert a property about the repository. If the property is already present+-- in the repo state, nothing changes, and the function returns True. If it is+-- not present yet, it is added to the repo state, and the function is True. If+-- the property is already in the list of properties that do not hold for the+-- repo, the state becomes inconsistent, and the function returns false.+assert :: Prop -> PatchCheck Bool+assert p = handle_inconsistent False $ do+    P ks nots <- get+    if has p nots+      then do+        put Inconsistent+        return False+      else if has p ks+             then return True+             else do+               put (P (p:ks) nots)+               return True++-- | Like @assert@, but negatively: state that some property must not hold for+--   the current repo.+assert_not :: Prop -> PatchCheck Bool+assert_not p = handle_inconsistent False $ do+    P ks nots <- get+    if has p ks+      then do+        put Inconsistent+        return False+      else if has p nots+             then return True+             else do+               put (P ks (p:nots))+               return True++-- | Remove a property from the list of properties that do not hold for this+-- repo (if it's there), and add it to the list of properties that hold.+-- Returns False if the repo is inconsistent, True otherwise.+change_to_true :: Prop -> PatchCheck Bool+change_to_true p = handle_inconsistent False $ do+    modify (\(P ks nots) -> P (p:ks) (filter (p /=) nots))+    return True++-- | Remove a property from the list of properties that hold for this repo (if+-- it's in there), and add it to the list of properties that do not hold.+-- Returns False if the repo is inconsistent, True otherwise.+change_to_false :: Prop -> PatchCheck Bool+change_to_false p = handle_inconsistent False $ do+    modify (\(P ks nots) -> P (filter (p /=) ks) (p:nots))+    return True++assert_file_exists :: String -> PatchCheck Bool+assert_file_exists f = do assert_not $ NotEx f+                          assert_not $ DirEx f+                          assert $ FileEx f+assert_dir_exists :: String -> PatchCheck Bool+assert_dir_exists d = do assert_not $ NotEx d+                         assert_not $ FileEx d+                         assert $ DirEx d+assert_exists :: String -> PatchCheck Bool+assert_exists f = assert_not $ NotEx f++assert_no_such :: String -> PatchCheck Bool+assert_no_such f = do assert_not $ FileEx f+                      assert_not $ DirEx f+                      assert $ NotEx f++create_file :: String -> PatchCheck Bool+create_file fn = do+  superdirs_exist fn+  assert_no_such fn+  change_to_true (FileEx fn)+  change_to_false (NotEx fn)++create_dir :: String -> PatchCheck Bool+create_dir fn = do+  substuff_dont_exist fn+  superdirs_exist fn+  assert_no_such fn+  change_to_true (DirEx fn)+  change_to_false (NotEx fn)++remove_file :: String -> PatchCheck Bool+remove_file fn = do+  superdirs_exist fn+  assert_file_exists fn+  file_empty fn+  change_to_false (FileEx fn)+  change_to_true (NotEx fn)++remove_dir :: String -> PatchCheck Bool+remove_dir fn = do+  substuff_dont_exist fn+  superdirs_exist fn+  assert_dir_exists fn+  change_to_false (DirEx fn)+  change_to_true (NotEx fn)++check_move :: String -> String -> PatchCheck Bool+check_move f f' = do+  superdirs_exist f+  superdirs_exist f'+  assert_exists f+  assert_no_such f'+  do_swap f f'++substuff_dont_exist :: String -> PatchCheck Bool+substuff_dont_exist d = handle_inconsistent False $ do+    P ks _ <- get+    if all noss ks+      then return True+      else do+        put Inconsistent+        return False+  where noss (FileEx f) = not (is_within_dir f)+        noss (DirEx f) = not (is_within_dir f)+        noss _ = True+        is_within_dir f = (d ++ "/") `isPrefixOf` f++-- the init and tail calls dump the final init (which is just the path itself+-- again), the first init (which is empty), and the initial "." from+-- splitDirectories+superdirs_exist :: String -> PatchCheck Bool+superdirs_exist fn = and `fmap` mapM assert_dir_exists superdirs+  where superdirs =  map (("./"++) . joinPath) +                         (init (tail (inits (tail (splitDirectories fn)))))++file_exists :: String -> PatchCheck Bool+file_exists fn = do+  superdirs_exist fn+  assert_file_exists fn++dir_exists :: String -> PatchCheck Bool+dir_exists fn = do+  superdirs_exist fn+  assert_dir_exists fn
src/Darcs/TheCommands.hs view
@@ -16,26 +16,22 @@ -- Boston, MA 02110-1301, USA.  {-# LANGUAGE CPP #-}-module Darcs.TheCommands ( command_control_list ) where+module Darcs.TheCommands ( commandControlList ) where +import Prelude hiding ( log ) import Darcs.Commands.Add ( add ) import Darcs.Commands.AmendRecord ( amendrecord ) import Darcs.Commands.Annotate ( annotate ) import Darcs.Commands.Apply ( apply )-import Darcs.Commands.Changes ( changes )+import Darcs.Commands.Changes ( changes, log ) import Darcs.Commands.Check ( check ) import Darcs.Commands.Convert ( convert ) import Darcs.Commands.Diff import Darcs.Commands.Dist ( dist ) import Darcs.Commands.Get ( get, clone )-#ifdef HAVE_HASKELL_ZLIB import Darcs.Commands.GZCRCs ( gzcrcs )-#else--- import just to check it compiles-import Darcs.Commands.GZCRCs ()-#endif import Darcs.Commands.Init ( initialize )-import Darcs.Commands.Show ( show_command, list, query )+import Darcs.Commands.Show ( showCommand, list, query ) import Darcs.Commands.MarkConflicts ( markconflicts, resolve ) import Darcs.Commands.Move ( move, mv ) import Darcs.Commands.Optimize ( optimize )@@ -52,56 +48,54 @@ import Darcs.Commands.SetPref ( setpref ) import Darcs.Commands.Tag ( tag ) import Darcs.Commands.TrackDown ( trackdown )-import Darcs.Commands.TransferMode ( transfer_mode )+import Darcs.Commands.TransferMode ( transferMode ) import Darcs.Commands.Unrecord ( unrecord, unpull, obliterate ) import Darcs.Commands.Unrevert ( unrevert ) import Darcs.Commands.WhatsNew ( whatsnew )-import Darcs.Commands ( CommandControl(Command_data,Hidden_command,Group_name) )+import Darcs.Commands ( CommandControl(CommandData,HiddenCommand,GroupName) )  -- | The commands that darcs knows about (e.g. whatsnew, record), --   organized into thematic groups.  Note that hidden commands --   are also listed here.-command_control_list :: [CommandControl]-command_control_list = [Group_name "Changing and querying the working copy:",-                Command_data add,-                Command_data remove, Hidden_command unadd, Hidden_command rm,-                Command_data move, Hidden_command mv,-                Command_data replace,-                Command_data revert,-                Command_data unrevert,-                Command_data whatsnew,-                Group_name "Copying changes between the working copy and the repository:",-                Command_data record, Hidden_command commit,-                Command_data unrecord,-                Command_data amendrecord,-                Command_data markconflicts, Hidden_command resolve,-                Group_name "Direct modification of the repository:",-                Command_data tag,-                Command_data setpref,-                Group_name "Querying the repository:",-                Command_data diff_command,-                Command_data changes,-                Command_data annotate,-                Command_data dist,-                Command_data trackdown,-                Command_data show_command, Hidden_command list, Hidden_command query,-                Hidden_command transfer_mode,-                Group_name "Copying patches between repositories with working copy update:",-                Command_data pull,-                Command_data obliterate, Hidden_command unpull,-                Command_data rollback,-                Command_data push,-                Command_data send,-                Command_data apply,-                Command_data get, Hidden_command clone,-                Command_data put,-                Group_name "Administrating repositories:",-                Command_data initialize,-                Command_data optimize,-                Command_data check,-                Command_data repair,-                Command_data convert-#ifdef HAVE_HASKELL_ZLIB-                ,Hidden_command gzcrcs-#endif+commandControlList :: [CommandControl]+commandControlList = [GroupName "Changing and querying the working copy:",+                CommandData add,+                CommandData remove, HiddenCommand unadd, HiddenCommand rm,+                CommandData move, HiddenCommand mv,+                CommandData replace,+                CommandData revert,+                CommandData unrevert,+                CommandData whatsnew,+                GroupName "Copying changes between the working copy and the repository:",+                CommandData record, HiddenCommand commit,+                CommandData unrecord,+                CommandData amendrecord,+                CommandData markconflicts, HiddenCommand resolve,+                GroupName "Direct modification of the repository:",+                CommandData tag,+                CommandData setpref,+                GroupName "Querying the repository:",+                CommandData diffCommand,+                CommandData changes, HiddenCommand log,+                CommandData annotate,+                CommandData dist,+                CommandData trackdown,+                CommandData showCommand, HiddenCommand list, HiddenCommand query,+                HiddenCommand transferMode,+                GroupName "Copying patches between repositories with working copy update:",+                CommandData pull,+                CommandData obliterate, HiddenCommand unpull,+                CommandData rollback,+                CommandData push,+                CommandData send,+                CommandData apply,+                CommandData get, HiddenCommand clone,+                CommandData put,+                GroupName "Administrating repositories:",+                CommandData initialize,+                CommandData optimize,+                CommandData check,+                CommandData repair,+                CommandData convert+                ,HiddenCommand gzcrcs                ]
src/Darcs/Utils.hs view
@@ -3,16 +3,20 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}  module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,-                     clarify_errors, prettyException, prettyError,+                     clarifyErrors, prettyException, prettyError,                     putStrLnError, putDocLnError,                     withCurrentDirectory,                     withUMask, askUser, stripCr,                     showHexLen, add_to_error_loc,                     maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,                     isUnsupportedOperationError, isHardwareFaultError,-                    get_viewer, edit_file, promptYorn, promptCharFancy,+                    get_viewer, edit_file, run_editor,+                    promptYorn, promptCharFancy,                     environmentHelpEditor, environmentHelpPager,-                    formatPath ) where+                    formatPath+                    -- * Tree filtering.+                   , filterFilePaths, filterPaths+                   ) where  import Prelude hiding ( catch ) import Control.Exception ( bracket, bracket_, catch, Exception(IOException), try )@@ -39,6 +43,8 @@  import Progress ( withoutProgress ) +import Storage.Hashed.AnchoredPath( AnchoredPath, isPrefix, floatPath )+ import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,                                   getInputChar, outputStrLn ) import System.Console.Haskeline.Encoding ( encode )@@ -91,8 +97,8 @@ firstJustIO = firstJustM . map (\o -> o `catchall` return Nothing)  -clarify_errors :: IO a -> String -> IO a-clarify_errors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])+clarifyErrors :: IO a -> String -> IO a+clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])  prettyException :: Control.Exception.Exception -> String prettyException (IOException e) | isUserError e = ioeGetErrorString e@@ -184,15 +190,8 @@  edit_file :: FilePathLike p => p -> IO ExitCode edit_file ff = do-  ed <- get_editor   old_content <- file_content-  ec <- exec_interactive ed f-             `ortryrunning` exec_interactive "emacs" f-             `ortryrunning` exec_interactive "emacs -nw" f-             `ortryrunning` exec_interactive "nano" f-#ifdef WIN32-             `ortryrunning` exec_interactive "edit" f-#endif+  ec <- run_editor f   new_content <- file_content   when (new_content == old_content) $ do     yorn <- promptYorn "File content did not change. Continue anyway?"@@ -206,6 +205,17 @@                                 return $ Just content                         else return Nothing +run_editor :: FilePath -> IO ExitCode+run_editor f = do+  ed <- get_editor+  exec_interactive ed f+       `ortryrunning` exec_interactive "emacs" f+       `ortryrunning` exec_interactive "emacs -nw" f+       `ortryrunning` exec_interactive "nano" f+#ifdef WIN32+       `ortryrunning` exec_interactive "edit" f+#endif+ get_editor :: IO String get_editor = getEnv "DARCS_EDITOR" `catchall`              getEnv "DARCSEDITOR" `catchall`@@ -256,3 +266,16 @@  setDefault s = case md of Nothing -> s                            Just d  -> map (setUpper d) s  setUpper d c = if d == c then toUpper c else c++-- | Construct a filter from a list of AnchoredPaths, that will accept any path+-- that is either a parent or a child of any of the listed paths, and discard+-- everything else.+filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool+filterPaths files =+    \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files++-- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to+-- AnchoredPath).+filterFilePaths :: [FilePath] -> AnchoredPath -> t -> Bool+filterFilePaths = filterPaths . map floatPath+
+ src/Darcs/Witnesses/Ordered.hs view
@@ -0,0 +1,277 @@+-- Copyright (C) 2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , MagicHash, TypeOperators, GADTs #-}++#include "gadts.h"++module Darcs.Witnesses.Ordered ( EqCheck(..), isEq, (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),+                             FL(..), RL(..),Proof(..),+#ifndef GADT_WITNESSES+                             unsafeUnFL, unsafeFL, unsafeRL, unsafeUnRL,+#endif+                             lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL,+                             splitAtFL, bunchFL, foldlRL,+                             lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL,+                             unsafeMap_l2f, filterE, filterFL,+                             reverseFL, reverseRL, (+>+), (+<+),+                             nullFL, concatFL, concatRL, concatReverseFL, headRL,+                             MyEq, unsafeCompare, (=\/=), (=/\=),+                             consRLSealed, nullRL,+                             unsafeCoerceP, unsafeCoerceP2+                           ) where++#include "impossible.h"+import GHC.Base (unsafeCoerce#)+import Darcs.Witnesses.Show+import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal )++data EqCheck C(a b) where+    IsEq :: EqCheck C(a a)+    NotEq :: EqCheck C(a b)++instance Eq (EqCheck C(a b)) where+    IsEq == IsEq = True+    NotEq == NotEq = True+    _ == _ = False++isEq :: EqCheck C(a b) -> Bool+isEq IsEq = True+isEq NotEq = False++instance Show (EqCheck C(a b)) where+    show IsEq = "IsEq"+    show NotEq = "NotEq"++data Proof a C(x y) where+    Proof :: a -> Proof a C(x x)++data (a1 :> a2) C(x y) = FORALL(z) (a1 C(x z)) :> (a2 C(z y))+infixr 1 :>+data (a1 :< a2) C(x y) = FORALL(z) (a1 C(z y)) :< (a2 C(x z))+infix 1 :<+infix 1 :/\:, :\/:, :||:+data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y))+data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z))+data (a1 :||: a2) C(x y) = (a1 C(x y)) :||: (a2 C(x y))+class MyEq p where+    -- Minimal definition defines any one of unsafeCompare, =\/= and =/\=.+    unsafeCompare :: p C(a b) -> p C(c d) -> Bool+    unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b)+    (=\/=) :: p C(a b) -> p C(a c) -> EqCheck C(b c)+    a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq+             | otherwise = NotEq+    (=/\=) :: p C(a c) -> p C(b c) -> EqCheck C(a b)+    a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq+             | otherwise = NotEq++infix 4 =\/=, =/\=++unsafeCoerceP :: a C(x y) -> a C(b c)+unsafeCoerceP = unsafeCoerce#++unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d)+unsafeCoerceP2 = unsafeCoerce#++instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where+    showsPrec d (x :> y) = showOp2 1 ":>" d x y++instance (Show2 a, Show2 b) => Show2 (a :> b) where+    showsPrec2 = showsPrec++instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where+    showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y++instance (Show2 a, Show2 b) => Show2 (a :\/: b) where+    showsPrec2 = showsPrec++infixr 5 :>:, :<:, +>+, +<+++-- forward list+data FL a C(x z) where+    (:>:) :: a C(x y) -> FL a C(y z) -> FL a C(x z)+    NilFL :: FL a C(x x)++instance Show2 a => Show (FL a C(x z)) where+   showsPrec _ NilFL = showString "NilFL"+   showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .+                            showString " :>: " . showsPrec (prec + 1) xs+       where prec = 5++instance Show2 a => Show2 (FL a) where+   showsPrec2 = showsPrec++-- reverse list+data RL a C(x z) where+    (:<:) :: a C(y z) -> RL a C(x y) -> RL a C(x z)+    NilRL :: RL a C(x x)++nullFL :: FL a C(x z) -> Bool+nullFL NilFL = True+nullFL _ = False++nullRL :: RL a C(x z) -> Bool+nullRL NilRL = True+nullRL _ = False++filterFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z)+filterFL _ NilFL = NilFL+filterFL f (x:>:xs) | IsEq <- f x = filterFL f xs+                    | otherwise = x :>: filterFL f xs++filterE :: (a -> EqCheck C(x y)) -> [a] -> [Proof a C(x y)]+filterE _ [] = []+filterE p (x:xs)+    | IsEq <- p x = Proof x : filterE p xs+    | otherwise   = filterE p xs++(+>+) :: FL a C(x y) -> FL a C(y z) -> FL a C(x z)+NilFL +>+ ys = ys+(x:>:xs) +>+ ys = x :>: xs +>+ ys++(+<+) :: RL a C(y z) -> RL a C(x y) -> RL a C(x z)+NilRL +<+ ys = ys+(x:<:xs) +<+ ys = x :<: xs +<+ ys++reverseFL :: FL a C(x z) -> RL a C(x z)+reverseFL xs = r NilRL xs+  where r :: RL a C(l m) -> FL a C(m o) -> RL a C(l o)+        r ls NilFL = ls+        r ls (a:>:as) = r (a:<:ls) as++reverseRL :: RL a C(x z) -> FL a C(x z)+reverseRL xs = r NilFL xs -- r (xs :> NilFL)+  where r :: FL a C(m o) -> RL a C(l m) -> FL a C(l o)+        r ls NilRL = ls+        r ls (a:<:as) = r (a:>:ls) as++concatFL :: FL (FL a) C(x z) -> FL a C(x z)+concatFL NilFL = NilFL+concatFL (a:>:as) = a +>+ concatFL as++concatRL :: RL (RL a) C(x z) -> RL a C(x z)+concatRL NilRL = NilRL+concatRL (a:<:as) = a +<+ concatRL as++spanFL :: (FORALL(w y) a C(w y) -> Bool) -> FL a C(x z) -> (FL a :> FL a) C(x z)+spanFL f (x:>:xs) | f x = case spanFL f xs of+                            ys :> zs -> (x:>:ys) :> zs+spanFL _ xs = NilFL :> xs++splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z)+splitAtFL 0 xs = NilFL :> xs+splitAtFL _ NilFL = NilFL :> NilFL+splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of+                       (xs':>xs'') -> (x:>:xs' :> xs'')++-- 'bunchFL n' groups patches into batches of n, except that it always puts+-- the first patch in its own group, this being a recognition that the+-- first patch is often *very* large.++bunchFL :: Int -> FL a C(x y) -> FL (FL a) C(x y)+bunchFL _ NilFL = NilFL+bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs+    where bFL :: FL a C(x y) -> FL (FL a) C(x y)+          bFL NilFL = NilFL+          bFL bs = case splitAtFL n bs of+                   a :> b -> a :>: bFL b+++allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool+allFL f xs = and $ mapFL f xs++foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a+foldlFL _ x NilFL = x+foldlFL f x (y:>:ys) = foldlFL f (f x y) ys++foldlRL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> RL b C(x z) -> a+foldlRL _ x NilRL = x+foldlRL f x (y:<:ys) = foldlRL f (f x y) ys++mapFL_FL :: (FORALL(w y) a C(w y) -> b C(w y)) -> FL a C(x z) -> FL b C(x z)+mapFL_FL _ NilFL = NilFL+mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as++zipWithFL :: (FORALL(x y) a -> p C(x y) -> q C(x y))+          -> [a] -> FL p C(w z) -> FL q C(w z)+zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys+zipWithFL _ _ NilFL = NilFL+zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list"++mapRL_RL :: (FORALL(w y) a C(w y) -> b C(w y)) -> RL a C(x z) -> RL b C(x z)+mapRL_RL _ NilRL = NilRL+mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as++mapFL :: (FORALL(w z) a C(w z) -> b) -> FL a C(x y) -> [b]+mapFL _ NilFL = []+mapFL f (a :>: b) = f a : mapFL f b++mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b]+mapRL _ NilRL = []+mapRL f (a :<: b) = f a : mapRL f b++unsafeMap_l2f :: (FORALL(w z) a -> b C(w z)) -> [a] -> FL b C(x y)+unsafeMap_l2f _ [] = unsafeCoerceP NilFL+unsafeMap_l2f f (x:xs) = f x :>: unsafeMap_l2f f xs++lengthFL :: FL a C(x z) -> Int+lengthFL xs = l xs 0+  where l :: FL a C(x z) -> Int -> Int+        l NilFL n = n+        l (_:>:as) n = l as $! n+1++lengthRL :: RL a C(x z) -> Int+lengthRL xs = l xs 0+  where l :: RL a C(x z) -> Int -> Int+        l NilRL n = n+        l (_:<:as) n = l as $! n+1++isShorterThanRL :: RL a C(x y) -> Int -> Bool+isShorterThanRL _ n | n <= 0 = False+isShorterThanRL NilRL _ = True+isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1)++concatReverseFL :: FL (RL a) C(x y) -> RL a C(x y)+concatReverseFL = concatRL . reverseFL++headRL :: RL a C(x y) -> FlippedSeal a C(y)+headRL (x:<:_) = flipSeal x+headRL _ = impossible++consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z)+consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as++#ifndef GADT_WITNESSES+-- These are useful for interfacing with modules which do not yet use type witnesses+unsafeUnFL :: FL a -> [a]+unsafeUnFL NilFL = []+unsafeUnFL (a:>:as) = a : unsafeUnFL as++unsafeUnRL :: RL a -> [a]+unsafeUnRL NilRL = []+unsafeUnRL (a:<:as) = a : unsafeUnRL as++unsafeFL :: [a] -> FL a+unsafeFL [] = NilFL+unsafeFL (a:as) = a :>: unsafeFL as++unsafeRL :: [a] -> RL a+unsafeRL [] = NilRL+unsafeRL (a:as) = a :<: unsafeRL as+#endif
+ src/Darcs/Witnesses/Sealed.hs view
@@ -0,0 +1,103 @@+-- Copyright (C) 2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , MagicHash, GADTs #-}++#include "gadts.h"++module Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal,+#ifndef GADT_WITNESSES+                      unsafeUnseal, unsafeUnflippedseal, unsafeUnseal2,+#endif+                      Sealed2(..), seal2, unseal2, mapSeal2,+                      FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped,+                      unsealM, liftSM+                    ) where++import GHC.Base ( unsafeCoerce# )+import Darcs.Witnesses.Show++data Sealed a where+    Sealed :: a C(x ) -> Sealed a++seal :: a C(x ) -> Sealed a+seal = Sealed++data Sealed2 a where+    Sealed2 :: !(a C(x y )) -> Sealed2 a++seal2 :: a C(x y ) -> Sealed2 a+seal2 = Sealed2++data FlippedSeal a C(y) where+    FlippedSeal :: !(a C(x y)) -> FlippedSeal a C(y)++flipSeal :: a C(x y) -> FlippedSeal a C(y)+flipSeal = FlippedSeal++#ifndef GADT_WITNESSES+unsafeUnseal :: Sealed a -> a+unsafeUnseal (Sealed a) = a++unsafeUnflippedseal :: FlippedSeal a -> a+unsafeUnflippedseal (FlippedSeal a) = a++unsafeUnseal2 :: Sealed2 a -> a+unsafeUnseal2 (Sealed2 a) = a+#endif++seriouslyUnsafeUnseal :: Sealed a -> a C(())+seriouslyUnsafeUnseal (Sealed a) = unsafeCoerce# a++unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b+unseal f x = f (seriouslyUnsafeUnseal x)++-- laziness property:+-- unseal (const True) undefined == True++unsealM :: Monad m => m (Sealed a) -> (FORALL(x) a C(x) -> m b) -> m b+unsealM m1 m2 = do sx <- m1+                   unseal m2 sx++liftSM :: Monad m => (FORALL(x) a C(x) -> b) -> m (Sealed a) -> m b+liftSM f m = do sx <- m+                return (unseal f sx)++mapSeal :: (FORALL(x) a C(x ) -> b C(x )) -> Sealed a -> Sealed b+mapSeal f = unseal (seal . f)++mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z)+mapFlipped f (FlippedSeal x) = FlippedSeal (f x)++seriouslyUnsafeUnseal2 :: Sealed2 a -> a C(() ())+seriouslyUnsafeUnseal2 (Sealed2 a) = unsafeCoerce# a++unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b+unseal2 f a = f (seriouslyUnsafeUnseal2 a)++mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b+mapSeal2 f = unseal2 (seal2 . f)++unsealFlipped :: (FORALL(x y) a C(x y) -> b) -> FlippedSeal a C(z) -> b+unsealFlipped f (FlippedSeal a) = f a++instance Show1 a => Show (Sealed a) where+    showsPrec d (Sealed x) = showParen (d > app_prec) $ showString "Sealed " . showsPrec1 (app_prec + 1) x+instance Show2 a => Show (Sealed2 a) where+    showsPrec d (Sealed2 x) = showParen (d > app_prec) $ showString "Sealed2 " . showsPrec2 (app_prec + 1) x
+ src/Darcs/Witnesses/Show.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++module Darcs.Witnesses.Show(Show1(..), Show2(..), showOp2, app_prec) where++#include "gadts.h"++class Show1 a where+    show1 :: a C(x) -> String+    show1 x = showsPrec1 0 x ""+    showsPrec1 :: Int -> a C(x) -> ShowS+    showsPrec1 _ x s = show1 x ++ s++class Show2 a where+    show2 :: a C(x y) -> String+    show2 x = showsPrec2 0 x ""+    showsPrec2 :: Int -> a C(x y) -> ShowS+    showsPrec2 _ x s = show2 x ++ s++showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String+showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x .+                          showString opstr . showsPrec2 (prec + 1) y++app_prec :: Int+app_prec = 10
src/Exec.hs view
@@ -32,7 +32,7 @@ import Control.Exception ( bracket ) import System.Posix.Env ( setEnv, getEnv, unsetEnv ) import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput )-import System.IO	( stdin )+import System.IO ( stdin ) #else import Control.Exception ( catchJust, Exception(IOException) ) import Data.List ( isInfixOf )@@ -40,9 +40,9 @@  import System.Exit ( ExitCode (..) ) import System.Cmd ( system )-import System.IO	( IOMode(..), openBinaryFile, stdout )+import System.IO ( IOMode(..), openBinaryFile, stdout ) import System.Process   ( runProcess, terminateProcess, waitForProcess )-import GHC.Handle	( hDuplicate )+import GHC.Handle ( hDuplicate )         -- urgh.  hDuplicate isn't available from a standard place. import Control.Exception ( bracketOnError )
− src/OldDate.hs 
@@ -1,350 +0,0 @@--- Copyright (C) 2003 Peter Simons--- Copyright (C) 2003,2008 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- This module is intended to provide backwards-compatibility in the parsing--- of darcs patches.  In other words: don't change it, new features don't get--- added here.  The only user should be Darcs.Patch.Info.--module OldDate ( readUTCDate, showIsoDateTime ) where--import Text.ParserCombinators.Parsec-import System.Time-import Data.Char ( toUpper, isDigit )-import Control.Monad ( liftM, liftM2 )-import qualified Data.ByteString.Char8 as B-import Data.Maybe ( fromMaybe )---- | Read/interpret a date string, assuming UTC if timezone---   is not specified in the string-readUTCDate :: String -> CalendarTime-readUTCDate = readDate 0--readDate :: Int -> String -> CalendarTime-readDate tz d =-             case parseDate tz d of-             Left e -> error e-             Right ct -> ct--parseDate :: Int -> String -> Either String CalendarTime-parseDate tz d =-              if length d >= 14 && B.all isDigit bd-              then Right $-                   CalendarTime (readI $ B.take 4 bd)-                                (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)-                                (readI $ B.take 2 $ B.drop 6 bd) -- Day-                                (readI $ B.take 2 $ B.drop 8 bd) -- Hour-                                (readI $ B.take 2 $ B.drop 10 bd) -- Minute-                                (readI $ B.take 2 $ B.drop 12 bd) -- Second-                                0 Sunday 0 -- Picosecond, weekday and day of year unknown-                                "GMT" 0 False-              else let dt = do { x <- date_time tz; eof; return x }-                   in case parse dt "" d of-                      Left e -> Left $ "bad date: "++d++" - "++show e-                      Right ct -> Right ct-  where bd = B.pack (take 14 d)-        readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)--showIsoDateTime :: CalendarTime -> String-showIsoDateTime ct = concat [ show $ ctYear ct-                            , twoDigit . show . (+1) . fromEnum $ ctMonth ct-                            , twoDigit . show $ ctDay ct-                            , twoDigit . show $ ctHour ct-                            , twoDigit . show $ ctMin ct-                            , twoDigit . show $ ctSec ct-                            ]-    where twoDigit []          = undefined-          twoDigit x@(_:[])    = '0' : x-          twoDigit x@(_:_:[])  = x-          twoDigit _           = undefined------- Parser Combinators ------------------------------------------------- |Case-insensitive variant of Parsec's 'char' function.--caseChar        :: Char -> GenParser Char a Char-caseChar c       = satisfy (\x -> toUpper x == toUpper c)---- |Case-insensitive variant of Parsec's 'string' function.--caseString      :: String -> GenParser Char a ()-caseString cs    = mapM_ caseChar cs <?> cs---- |Match a parser at least @n@ times.--manyN           :: Int -> GenParser a b c -> GenParser a b [c]-manyN n p-    | n <= 0     = return []-    | otherwise  = liftM2 (++) (count n p) (many p)---- |Match a parser at least @n@ times, but no more than @m@ times.--manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]-manyNtoM n m p-    | n < 0      = return []-    | n > m      = return []-    | n == m     = count n p-    | n == 0     = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))-    | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)-------- Date/Time Parser -------------------------------------------------date_time :: Int -> CharParser a CalendarTime-date_time tz =-            choice [try $ cvs_date_time tz,-                    try $ iso8601_date_time tz,-                    old_date_time]--cvs_date_time :: Int -> CharParser a CalendarTime-cvs_date_time tz =-                do y <- year-                   char '/'-                   mon <- month_num -                   char '/'-                   d <- day-                   my_spaces-                   h <- hour-                   char ':'-                   m <- minute-                   char ':'-                   s <- second-                   z <- option tz $ my_spaces >> zone-                   return (CalendarTime y mon d h m s 0 Monday 0 "" z False)--old_date_time   :: CharParser a CalendarTime-old_date_time    = do wd <- day_name-                      my_spaces-                      mon <- month_name-                      my_spaces-                      d <- day-                      my_spaces-                      h <- hour-                      char ':'-                      m <- minute-                      char ':'-                      s <- second-                      my_spaces-                      z <- zone-                      my_spaces-                      y <- year-                      return (CalendarTime y mon d h m s 0 wd 0 "" z False)--{- FIXME: In case you ever want to use this outside of darcs, you should note -   that this implementation of ISO 8601 is not complete.  --   reluctant to implement (ambiguous!): -     * years > 9999  -     * truncated representations with implied century (89 for 1989) -   unimplemented: -     * repeated durations (not relevant)-     * lowest order component fractions in intervals-     * negative dates (BC)                    -   unverified or too relaxed:-     * the difference between 24h and 0h-     * allows stuff like 2005-1212; either you use the hyphen all the way -       (2005-12-12) or you don't use it at all (20051212), but you don't use-       it halfway, likewise with time -     * No bounds checking whatsoever on intervals! -       (next action: read iso doc to see if bounds-checking required?) -}-iso8601_date_time   :: Int -> CharParser a CalendarTime-iso8601_date_time localTz = try $ -  do d <- iso8601_date-     t <- option id $ try $ do optional $ oneOf " T" -                               iso8601_time  -     return $ t $ d { ctTZ = localTz }--iso8601_date :: CharParser a CalendarTime-iso8601_date = -  do d <- calendar_date <|> week_date <|> ordinal_date-     return $ foldr ($) nullCalendar d-  where -    calendar_date = -- yyyy-mm-dd-      try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]-               -- allow other variants to be parsed correctly -               notFollowedBy (digit <|> char 'W')-               return d-    week_date = --yyyy-Www-dd -      try $ do yfn <- year_-               optional dash-               char 'W'-               -- offset human 'week 1' -> computer 'week 0'-               w'  <- (\x -> x-1) `liftM` two_digits-               wd  <- option 1 $ do { optional dash; n_digits 1 }-               let y = yfn nullCalendar-                   firstDay = ctWDay y-               -- things that make this complicated-               -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday-               -- 2. the first week is the one that contains at least Thursday-               --    if the year starts after Thursday, then some days of the year-               --    will have already passed before the first week-               let afterThursday = firstDay == Sunday || firstDay > Thursday-                   w  = if afterThursday then w'+1 else w'-                   diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) }-               return [(toUTCTime.toClockTime.diff.yfn)]-    ordinal_date = -- yyyy-ddd-      try $ optchain year_ [ (dash, yearDay_) ]-    ---    year_  = try $ do y <- four_digits <?> "year (0000-9999)"-                      return $ \c -> c { ctYear = y }-    month_ = try $ do m <- two_digits <?> "month (1 to 12)"-                      -- we (artificially) use ctPicosec to indicate-                      -- whether the month has been specified.-                      return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 }-    day_   = try $ do d <- two_digits <?> "day in month (1 to 31)"-                      return $ \c -> c { ctDay = d }-    yearDay_ = try $ do d <- n_digits 3 <?> "day in year (1 to 366)"-                        return $ \c -> c { ctYDay = d }-    dash = char '-'---- we return a function which sets the time on another calendar-iso8601_time :: CharParser a (CalendarTime -> CalendarTime)-iso8601_time = try $-  do ts <- optchain hour_ [ (colon     , min_)-                          , (colon     , sec_)-                          , (oneOf ",.", pico_) ] -     z  <- option id $ choice [ zulu , offset ]-     return $ foldr (.) id (z:ts)-  where -    hour_ = do h <- two_digits-               return $ \c -> c { ctHour = h }-    min_  = do m <- two_digits-               return $ \c -> c { ctMin = m }-    sec_  = do s <- two_digits-               return $ \c -> c { ctSec = s }-    pico_ = do digs <- many digit-               let picoExp = 12-                   digsExp = length digs-               let frac | null digs = 0-                        | digsExp > picoExp = read $ take picoExp digs-                        | otherwise = 10 ^ (picoExp - digsExp) * (read digs)-               return $ \c -> c { ctPicosec = frac }-    zulu   = do { char 'Z'; return (\c -> c { ctTZ = 0 }) }-    offset = do sign <- choice [ do { char '+' >> return   1  }-                               , do { char '-' >> return (-1) } ]-                h <- two_digits-                m <- option 0 $ do { optional colon; two_digits }-                return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) }-    colon = char ':'--optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]-optchain p next = try $ -  do r1 <- p-     r2 <- case next of -           [] -> return []-           ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }-     return (r1:r2)--n_digits :: Int -> CharParser a Int -n_digits n = read `liftM` count n digit--two_digits, four_digits :: CharParser a Int-two_digits = n_digits 2-four_digits = n_digits 4--my_spaces :: CharParser a String-my_spaces = manyN 1 $ char ' '--day_name        :: CharParser a Day-day_name         = choice-                       [ caseString "Mon"       >> return Monday-                       , try (caseString "Tue") >> return Tuesday-                       , caseString "Wed"       >> return Wednesday-                       , caseString "Thu"       >> return Thursday-                       , caseString "Fri"       >> return Friday-                       , try (caseString "Sat") >> return Saturday-                       , caseString "Sun"       >> return Sunday-                       ]--year            :: CharParser a Int-year             = four_digits--month_num       :: CharParser a Month-month_num = do mn <- manyNtoM 1 2 digit -               return $ intToMonth $ (read mn :: Int)--intToMonth :: Int -> Month-intToMonth 1 = January-intToMonth 2 = February-intToMonth 3 = March-intToMonth 4 = April-intToMonth 5 = May-intToMonth 6 = June-intToMonth 7 = July-intToMonth 8 = August-intToMonth 9 = September-intToMonth 10 = October-intToMonth 11 = November-intToMonth 12 = December-intToMonth _  = error "invalid month!"--month_name      :: CharParser a Month-month_name       = choice-                       [ try (caseString "Jan") >> return January-                       , caseString "Feb"       >> return February-                       , try (caseString "Mar") >> return March-                       , try (caseString "Apr") >> return April-                       , caseString "May"       >> return May-                       , try (caseString "Jun") >> return June-                       , caseString "Jul"       >> return July-                       , caseString "Aug"       >> return August-                       , caseString "Sep"       >> return September-                       , caseString "Oct"       >> return October-                       , caseString "Nov"       >> return November-                       , caseString "Dec"       >> return December-                       ]--day             :: CharParser a Int-day              = do d <- manyNtoM 1 2 digit-                      return (read d :: Int)--hour            :: CharParser a Int-hour             = two_digits--minute          :: CharParser a Int-minute           = two_digits--second          :: CharParser a Int-second           = two_digits--zone            :: CharParser a Int-zone             = choice-                       [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }-                       , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }-                       , mkZone "UTC"  0-                       , mkZone "UT"  0-                       , mkZone "GMT" 0-                       , mkZone "EST" (-5)-                       , mkZone "EDT" (-4)-                       , mkZone "CST" (-6)-                       , mkZone "CDT" (-5)-                       , mkZone "MST" (-7)-                       , mkZone "MDT" (-6)-                       , mkZone "PST" (-8)-                       , mkZone "PDT" (-7)-                       , mkZone "CEST" 2-                       , mkZone "EEST" 3-                         -- if we don't understand it, just give a GMT answer...-                       , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])-                                       (lookAhead space_digit);-                              return 0 }-                       ]-     where mkZone n o  = try $ do { caseString n; return (o*60*60) }-           space_digit = try $ do { char ' '; oneOf ['0'..'9'] }--nullCalendar :: CalendarTime -nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False
+ src/Preproc.hs view
@@ -0,0 +1,184 @@+-- | This program mangles a pseudo-LaTeX document into actual LaTeX.+-- There are three key changes to the input:+--+--   * \\input{foo} is replaced by the contents of the file foo (after+--     it, too, is mangled).  Note that this is relative to the+--     working directory, *not* relative to the file being parsed.+--+--   * Anything between \\begin{code} and \\end{code} is deleted.+--     Note that this is quite unlike normal literate documentation+--     (for which we use Haddock, not LaTeX).+--+--   * Some nonstandard pseudo-LaTeX commands are expanded into actual+--     LaTeX text.  In particular, \\darcsCommand{foo} is replaced by+--     LaTeX markup describing the command @foo@.+module Preproc ( preproc_main ) where+import qualified Ratified( readFile )+import System.FilePath ( (</>) )+import System.Environment ( getArgs )+import System.Exit ( exitWith, ExitCode(..) )+import Text.Regex ( matchRegex, mkRegex )+import Darcs.Commands ( DarcsCommand(SuperCommand,+                        commandSubCommands, commandName,+                        commandExtraArgHelp, commandBasicOptions,+                        commandAdvancedOptions, commandHelp,+                        commandDescription),+                        extractCommands )+import Darcs.Arguments ( optionsLatex )+import Darcs.Commands.Help ( commandControlList, environmentHelp )+import English ( andClauses )+import ThisVersion ( darcs_version )++the_commands :: [DarcsCommand]+the_commands = extractCommands commandControlList++-- | The entry point for this program.  The path to the TeX master+-- file is supplied as the first argument.  Bootstrapping into+-- 'preproc' then happens by passing it a pseudo-document that+-- contains a single input (include) line.+preproc_main :: [String] -> IO ()+preproc_main args = do+  if length args < 1+     then exitWith $ ExitFailure 1+     else return ()+  putStrLn "%% This file was automatically generated by preproc."+  c <- preproc ["\\input{"++head args++"}"]+  mapM_ putStrLn c++-- | Depending on whether pdflatex or htlatex is to be used, the LaTeX+-- output of this program must vary subtly.  This procedure returns+-- true iff the command-line arguments contain @--html@.+am_html :: IO Bool+am_html = do args <- getArgs+             return $ elem "--html" args++-- | Given a list of input lines in pseudo-LaTeX, return the same+-- document in LaTeX.  The pseudo-LaTeX lines are replaced, other+-- lines are used unmodified.+preproc :: [String] -> IO [String]+preproc [] = return []              -- Empty input, empty output.+preproc ("\\usepackage{html}":ss) = -- only use html package with latex2html+    do rest <- preproc ss+       ah <- am_html+       if ah then return $ "\\usepackage{html}" : rest+             else return $ "\\usepackage{hyperref}" : rest+preproc ("\\begin{code}":ss) = ignore ss+    where ignore :: [String] -> IO [String]+          ignore ("\\end{code}":ss') = preproc ss'+          ignore (_:ss') = ignore ss'+          ignore [] = return []+preproc ("\\begin{options}":ss) =+    do rest <- preproc ss+       ah <- am_html+       if ah then return $ "\\begin{rawhtml}" : "<div class=\"cmd-opt-hdr\">" : rest+             else return $ ("\\begin{Verbatim}[frame=lines,xleftmargin=1cm," +++                            "xrightmargin=1cm]") : rest+preproc ("\\end{options}":ss) =+    do rest <- preproc ss+       ah <- am_html+       if ah then return $ "</div>" : "\\end{rawhtml}" : rest+             else return $ "\\end{Verbatim}" : rest+preproc ("\\darcsVersion":ss) = do+  rest <- preproc ss+  return $ darcs_version:rest+preproc (s:ss) = do+  rest <- preproc ss+  let rx = mkRegex "^\\\\(input|darcs(Command|Env))\\{(.+)\\}$"+  case matchRegex rx s of+    Just ["input", _, path] ->+        do cs <- Ratified.readFile $ "src" </> path -- not part of normal darcs operation+           this <- preproc $ lines cs+           return $ this ++ rest+    Just ["darcsCommand", _, command] ->+        return $ latexCommandHelp command : rest+    Just ["darcsEnv", _, variable] ->+        return $ envHelp variable : rest+    -- The base case for the whole preproc function.  Nothing to+    -- mangle, so this is an ordinary line of TeX, and we append it to+    -- the result unmodified.+    _ -> return $ s : rest++latexCommandHelp :: String -> String+latexCommandHelp command = section ++ "{darcs " ++ command ++ "}\n" +++                      "\\label{" ++ command ++ "}\n" +++                      gh ++ get_options command ++ gd+    where+      section = if ' ' `elem` command then "\\subsubsection" else "\\subsection"+      -- | Given a Darcs command name as a string, return that command's (multi-line) help string.+      gh :: String+      gh =  escape_latex_specials $ command_property commandHelp the_commands command+      -- | Given a Darcs command name as a string, return that command's (one-line) description string.+      gd :: String+      gd = command_property commandDescription the_commands command++get_options :: String -> String+get_options comm = get_com_options $ get_c names the_commands+    where names = words comm++get_c :: [String] -> [DarcsCommand] -> [DarcsCommand]+get_c (name:ns) commands =+    case ns of+    [] -> [get name commands]+    _ -> case get name commands of+         c@SuperCommand { } ->+             c:(get_c ns $ extractCommands $ commandSubCommands c)+         _ ->+             error $ "Not a supercommand: " ++ name+    where get n (c:cs) | commandName c == n = c+                       | otherwise = get n cs+          get n [] = error $ "No such command:  "++n+get_c [] _ = error "no command specified"++get_com_options :: [DarcsCommand] -> String+get_com_options c =+    "\\par\\verb!Usage: darcs " ++ cmd ++ " [OPTION]... " +++    args ++ "!\n\n" ++ "Options:\n\n" ++ optionsLatex opts1 +++    (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ optionsLatex opts2)+    where cmd = unwords $ map commandName c+          args = unwords $ commandExtraArgHelp $ last c+          opts1 = commandBasicOptions $ last c+          opts2 = commandAdvancedOptions $ last c++command_property :: (DarcsCommand -> String) -> [DarcsCommand] -> String+                 -> String+command_property property commands name =+    property $ last c+    where names = words name+          c = get_c names commands++++envHelp :: String -> String+envHelp var = unlines $ render $ entry environmentHelp+    where render (ks, ds) =+              ("\\paragraph{" ++ escape_latex_specials (andClauses ks) ++ "}") :+              ("\\label{env:" ++ var ++ "}") :+              map escape_latex_specials ds+          entry [] = undefined+          entry (x:xs) | elem var $ fst x = x+                       | otherwise = entry xs++-- | LaTeX treats a number of characters or sequences specially.+-- Therefore when including ordinary help text in a LaTeX document, it+-- is necessary to escape these characters in the way LaTeX expects.+escape_latex_specials :: String -> String+-- Order is important+escape_latex_specials =+  (bs2 . amp . percent . carrot . dollar . underscore . rbrace . lbrace . bs1)+  where+    amp        = replace "&"  "\\&"+    bs1        = replace "\\" "\001"+    bs2        = replace "\001" "$\\backslash$"+    carrot     = replace "^"  "\\^{}"+    dollar     = replace "$"  "\\$"+    lbrace     = replace "{"  "\\{"+    percent    = replace "%"  "\\%"+    rbrace     = replace "}"  "\\}"+    underscore = replace "_"  "\\_"++    replace :: Eq a => [a] -> [a] -> [a] -> [a]+    replace _ _ [] = []+    replace find repl s =+        if take (length find) s == find+            then repl ++ (replace find repl (drop (length find) s))+            else [head s] ++ replace find repl (tail s)
src/Progress.hs view
@@ -46,11 +46,12 @@  printProgress :: String -> ProgressData -> IO () printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =-    myput (k++" "++show s++"/"++show t++" : "++l) (k++" "++show s++"/"++show t)+    myput output output+        where output = (k++" "++show s++" done, "++show (t - s)++" queued. "++l) printProgress k (ProgressData {latest=Just l}) =     myput (k++" "++l) k printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =-    myput (k++" "++show s++"/"++show t) (k++" "++show s)+    myput (k++" "++show s++" done, "++show (t - s)++" queued") (k++" "++show s) printProgress k (ProgressData {sofar=s}) =     myput (k++" "++show s) k
+ src/Ratified.hs view
@@ -0,0 +1,2 @@+module Ratified( readFile, hGetContents ) where+import System.IO( hGetContents )
− src/RegChars.hs 
@@ -1,75 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---module RegChars ( regChars,-                ) where--(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)-(&&&) a b c = a c && b c--(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)-(|||) a b c = a c || b c--{-# INLINE regChars #-}---- | 'regChars' returns a filter function that tells if a char is a member--- of the regChar expression or not. The regChar expression is basically a--- set of chars, but it can contain ranges with use of the '-' (dash), and--- it can also be specified as a complement set by prefixing with '^'--- (caret). The dash and caret, as well as the backslash, can all be--- escaped with a backslash to suppress their special meaning.--- --- NOTE: The '.' (dot) is allowed to be escaped. It has no special meaning--- if it is not escaped, but the default 'filename_toks' in--- Darcs.Commands.Replace uses an escaped dot (WHY?).--regChars :: String -> (Char -> Bool)-regChars ('^':cs) = not . normalRegChars (unescapeChars cs)-regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs-regChars cs = normalRegChars $ unescapeChars cs--{-# INLINE unescapeChars #-}---- | 'unescapeChars' unescapes whitespace, which is escaped in the replace--- patch file format. It will also unescape escaped carets, which is useful--- for escaping a leading caret that should not invert the regChars. All--- other escapes are left for the unescaping in 'normalRegChars'.--unescapeChars :: String -> String-unescapeChars ('\\':'n':cs) = '\n' : unescapeChars cs-unescapeChars ('\\':'t':cs) = '\t' : unescapeChars cs-unescapeChars ('\\':'^':cs) = '^' : unescapeChars cs-unescapeChars (c:cs) = c : unescapeChars cs-unescapeChars [] = []--{-# INLINE normalRegChars #-}---- | 'normalRegChars' assembles the filter function. It handles special--- chars, and also unescaping of escaped special chars. If a non-special--- char is still escaped by now we get a failure.--normalRegChars :: String -> (Char -> Bool)-normalRegChars ('\\':'.':cs) = (=='.') ||| normalRegChars cs-normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs-normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs-normalRegChars ('\\':c:_) = error $ "'\\"++[c]++"' not supported."-normalRegChars (c1:'-':c2:cs) = ((>= c1) &&& (<= c2)) ||| normalRegChars cs-normalRegChars (c:cs) = (== c) ||| normalRegChars cs-normalRegChars [] = \_ -> False--
src/Ssh.hs view
@@ -5,6 +5,7 @@            ) where  import Prelude hiding ( lookup, catch )+import qualified Ratified( hGetContents )  import System.Exit ( ExitCode(..) ) import System.Environment ( getEnv )@@ -15,7 +16,7 @@ import Data.Bits ( (.&.) ) import System.Random ( randomIO ) #endif-import System.IO ( Handle, hPutStr, hPutStrLn, hGetLine, hGetContents, hClose, hFlush )+import System.IO ( Handle, hPutStr, hPutStrLn, hGetLine, hClose, hFlush ) import System.IO.Unsafe ( unsafePerformIO ) import System.Directory ( doesFileExist, createDirectoryIfMissing ) import Control.Monad ( when )@@ -42,18 +43,19 @@  data Connection = C { inp :: !Handle, out :: !Handle, err :: !Handle, deb :: String -> IO () } -withSSHConnection :: String -> (Connection -> IO a) -> IO a -> IO a-withSSHConnection x withconnection withoutconnection =+withSSHConnection :: String -> String -> (Connection -> IO a) -> IO a -> IO a+withSSHConnection rdarcs repoid withconnection withoutconnection =     withoutProgress $     do cs <- readIORef sshConnections-       let uhost = takeWhile (/= ':') x-           url = cleanrepourl x+       let uhost = takeWhile (/= ':') repoid+           url = cleanrepourl repoid        case lookup url (cs :: Map String (Maybe Connection)) of          Just Nothing -> withoutconnection          Just (Just c) -> withconnection c          Nothing ->            do mc <- do (ssh,sshargs_) <- getSSHOnly SSH-                       let sshargs = sshargs_ ++ [uhost,"darcs","transfer-mode","--repodir",cleanrepodir x]+                       let sshargs = sshargs_ ++ [uhost,rdarcs,+                                                  "transfer-mode","--repodir",cleanrepodir repoid]                        debugMessage $ "ssh "++unwords sshargs                        (i,o,e,_) <- runInteractiveProcess ssh sshargs Nothing Nothing                        l <- hGetLine o@@ -67,7 +69,7 @@                     `catchNonSignal`                             \e -> do debugMessage $ "Failed to start ssh connection:\n    "++                                                     prettyException e-                                     severSSHConnection x+                                     severSSHConnection repoid                                      debugMessage $ unlines $                                          [ "NOTE: the server may be running a version of darcs prior to 2.0.0."                                          , ""@@ -98,10 +100,10 @@                    clean "" = bug $ "Buggy path in grabSSH: "++x                    file = clean dir                    failwith e = do severSSHConnection x-                                   eee <- hGetContents (err c) -- ratify hGetContents: it's okay-                                                               -- here because we're only grabbing-                                                               -- stderr, and we're also about to-                                                               -- throw the contents.+                                   -- hGetContents is ok here because we're+                                   -- only grabbing stderr, and we're also+                                   -- about to throw the contents.+                                   eee <- Ratified.hGetContents (err c)                                    debugFail $ e ++ " grabbing ssh file "++x++"\n"++eee                deb c $ "get "++file                hPutStrLn (inp c) $ "get " ++ file@@ -123,8 +125,8 @@ sshStdErrMode = withDebugMode $ \amdebugging ->                 return $ if amdebugging then AsIs else Null -copySSH :: String -> FilePath -> IO ()-copySSH uRaw f = withSSHConnection uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $+copySSH :: String -> String -> FilePath -> IO ()+copySSH rdarcs uRaw f = withSSHConnection rdarcs uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $               do let u = escape_dollar uRaw                  stderr_behavior <- sshStdErrMode                  r <- runSSH SCP u [] [u,f] (AsIs,AsIs,stderr_behavior)@@ -136,11 +138,11 @@            where tr '$' = "\\$"                  tr c = [c] -copySSHs :: String -> [String] -> FilePath -> IO ()-copySSHs u ns d =-  withSSHConnection u (\c -> withCurrentDirectory d $-                             mapM_ (\n -> grabSSH (u++"/"++n) c >>= B.writeFile n) $-                             progressList "Copying via ssh" ns) $+copySSHs :: String -> String -> [String] -> FilePath -> IO ()+copySSHs rdarcs u ns d =+  withSSHConnection rdarcs u (\c -> withCurrentDirectory d $+                                mapM_ (\n -> grabSSH (u++"/"++n) c >>= B.writeFile n) $+                                progressList "Copying via ssh" ns) $   do let path = drop 1 $ dropWhile (/= ':') u          host = takeWhile (/= ':') u          cd = "cd "++path++"\n"
− src/UTF8.lhs 
@@ -1,173 +0,0 @@-Copyright (c) 2002, members of the Haskell Internationalisation Working-Group 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 the Haskell Internationalisation Working Group nor-   the names of its contributors may be used to endorse or promote products-   derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE 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.--This module provides lazy stream encoding/decoding facilities for UTF-8,-the Unicode Transformation Format with 8-bit words.--2002-09-02  Sven Moritz Hallberg <pesco@gmx.de>---> {-# OPTIONS_GHC -cpp #-}-> module UTF8->   ( encode ) where---SUNSET: we should remove this module after the 2009-07 release-of darcs and just use Codec.Binary.UTF8.String instead--#ifdef HAVE_UTF8STRING-> import qualified Codec.Binary.UTF8.String (encode)-> import Data.Word (Word8)-#else-> import Data.Char (ord)-> import Data.Word (Word8, Word16, Word32)-> import Data.Bits (Bits, shiftR, (.&.), (.|.))-#endif----///- UTF-8 in General -///--Adapted from the Unicode standard, version 3.2,-Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings):--  Scalar                    1st Byte  2nd Byte  3rd Byte  4th Byte-          000000000xxxxxxx  0xxxxxxx-          00000yyyyyxxxxxx  110yyyyy  10xxxxxx-          zzzzyyyyyyxxxxxx  1110zzzz  10yyyyyy  10xxxxxx-  000uuuzzzzzzyyyyyyxxxxxx  11110uuu  10zzzzzz  10yyyyyy  10xxxxxx--Also from the Unicode standard, version 3.2,-Table 3.1B "Legal UTF-8 Byte Sequences":--  Code Points         1st Byte  2nd Byte  3rd Byte  4th Byte-    U+0000..U+007F    00..7F-    U+0080..U+07FF    C2..DF    80..BF-    U+0800..U+0FFF    E0        A0..BF    80..BF-    U+1000..U+CFFF    E1..EC    80..BF    80..BF-    U+D000..U+D7FF    ED        80..9F    80..BF-    U+D800..U+DFFF    ill-formed-    U+E000..U+FFFF    EE..EF    80..BF    80..BF-   U+10000..U+3FFFF   F0        90..BF    80..BF    80..BF-   U+40000..U+FFFFF   F1..F3    80..BF    80..BF    80..BF-  U+100000..U+10FFFF  F4        80..8F    80..BF    80..BF----///- Encoding Functions -///--Must the encoder ensure that no illegal byte sequences are output or-can we trust the Haskell system to supply only legal values?-For now I include error case for the surrogate values U+D800..U+DFFF and-out-of-range scalars.--The function is pretty much a transscript of table 3.1B with error checks.-It dispatches the actual encoding to functions specific to the number of-required bytes.--#ifndef HAVE_UTF8STRING-> encodeOne :: Char -> [Word8]-> encodeOne c->-- The report guarantees in (6.1.2) that this won't happen:->--   | n < 0       = error "encodeUTF8: ord returned a negative value"->     | n < 0x0080  = encodeOne_onebyte n8->     | n < 0x0800  = encodeOne_twobyte n16->     | n < 0xD800  = encodeOne_threebyte n16->     | n < 0xE000  = error "encodeUTF8: ord returned a surrogate value"->     | n < 0x10000       = encodeOne_threebyte n16->-- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1.->     | n < 0x10FFFF      = encodeOne_fourbyte n32->     | otherwise  = error "encodeUTF8: ord returned a value above 0x10FFFF"->     where->     n = ord c            :: Int->     n8 = fromIntegral n  :: Word8->     n16 = fromIntegral n :: Word16->     n32 = fromIntegral n :: Word32-#endif---With the above, a stream decoder is trivial:---> encode :: [Char] -> [Word8]-#ifdef HAVE_UTF8STRING-> encode = Codec.Binary.UTF8.String.encode-#else-> encode = concatMap encodeOne-#endif---Now follow the individual encoders for certain numbers of bytes...-          _-         / |  __  ___  __ __-        / ^| //  /__/ // //-       /.==| \\ //_  // //-It's  //  || // \_/_//_//_  and it's here to stay!--#ifndef HAVE_UTF8STRING-> encodeOne_onebyte :: Word8 -> [Word8]-> encodeOne_onebyte cp = [cp]-#endif---00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx--#ifndef HAVE_UTF8STRING-> encodeOne_twobyte :: Word16 -> [Word8]-> encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)]->     where->     xs, ys :: Word8->     ys = fromIntegral (shiftR cp 6)->     xs = (fromIntegral cp) .&. 0x3F-#endif---zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx--#ifndef HAVE_UTF8STRING-> encodeOne_threebyte :: Word16 -> [Word8]-> encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)]->     where->     xs, ys, zs :: Word8->     xs = (fromIntegral cp) .&. 0x3F->     ys = (fromIntegral (shiftR cp 6)) .&. 0x3F->     zs = fromIntegral (shiftR cp 12)-#endif---000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx--#ifndef HAVE_UTF8STRING-> encodeOne_fourbyte :: Word32 -> [Word8]-> encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs]->     where->     xs, ys, zs, us :: Word8->     xs = (fromIntegral cp) .&. 0x3F->     ys = (fromIntegral (shiftR cp 6)) .&. 0x3F->     zs = (fromIntegral (shiftR cp 12)) .&. 0x3F->     us = fromIntegral (shiftR cp 18)-#endif
src/atomic_create.h view
@@ -12,14 +12,6 @@ int renamefile(const char *from, const char *to); #endif -int open_read(const char *fname);-int open_write(const char *fname);-int smart_wait(int pid);--int execvp_no_vtalarm(const char *file, char *const argv[]);--int is_symlink(const char *file);- int stdout_is_a_pipe();  int maybe_relink(const char *src, const char *dst, int careful);
src/building_darcs.tex view
@@ -74,20 +74,3 @@   \item zlib 0.5.   \end{itemize} \end{itemize}--\section{The Old Way}-Darcs can still be built with GNU autotools; this approach is-deprecated and will be removed after the 2.3 release.  Run-\begin{verbatim}-autoconf-./configure-make-make install-\end{verbatim}--The build dependencies are identical to the previous approach, except-that instead of the \texttt{Cabal} package, you will need-\begin{itemize}-\item GNU Make; and-\item GNU autoconf 2.50 or higher.-\end{itemize}
− src/c_compat.c 
@@ -1,88 +0,0 @@--#include <sys/types.h>-#include <sys/stat.h>-#include <fcntl.h>-#include <string.h>-#include <stdio.h>-#include <stdlib.h>--#include <unistd.h>-#include <errno.h>-#include <sys/time.h>-#include <time.h>--#ifdef _WIN32-#include <windows.h>-#include <io.h>-#endif--#ifndef _WIN32--int open_read(const char *fname) {-  return open(fname, O_RDONLY);-}--int open_write(const char *fname) {-  return open(fname, O_WRONLY | O_TRUNC | O_CREAT,-              S_IWUSR | S_IRUSR | S_IROTH | S_IRGRP);-}--int get_errno() {-  return errno;-}--#include <sys/wait.h>-#include <signal.h>-#if  HAVE_SIGINFO_H-#include <siginfo.h>-#endif--/* This waits and then returns the exit status of the process that was-   waited for. */-int smart_wait(int pid) {-  int stat;-  pid_t rc;--  do {-      rc = waitpid(pid, &stat, 0);-  } while(rc < 0 && errno == EINTR);--  if(rc < 0) {-    perror("waitpid");-    return -138;-  } else if (WIFEXITED(stat)) {-    return WEXITSTATUS(stat);-  } else if (WIFSIGNALED(stat)) {-    /* Fixme: psignal isn't portable (not in POSIX).  */-    psignal(WTERMSIG(stat), "Error in subprocess");-    return - WTERMSIG(stat);-  } else {-    return -137;-  }-}--#include <unistd.h>-#include <sys/time.h>-#include <errno.h>-#include <stdio.h>--int execvp_no_vtalarm(const char *file, char *const argv[]) {-  /* Reset the itimers in the child, so it doesn't get plagued-   * by SIGVTALRM interrupts.-   */-  struct timeval tv_null = { 0, 0 };-  struct itimerval itv;-  itv.it_interval = tv_null;-  itv.it_value = tv_null;-  setitimer(ITIMER_REAL, &itv, NULL);-  setitimer(ITIMER_VIRTUAL, &itv, NULL);-  setitimer(ITIMER_PROF, &itv, NULL);-  execvp(file, argv);-  perror("Error in execvp");-  return errno;-}--#include <sys/types.h>-#include <sys/stat.h>-#endif-
− src/compat.h 
@@ -1,12 +0,0 @@--#include <sys/stat.h>-#include <string.h>-#include <stdlib.h>--int open_read(const char *fname);-int open_write(const char *fname);-int smart_wait(int pid);-int get_errno();--int execvp_no_vtalarm(const char *file, char *const argv[]);-
src/darcs.hs view
@@ -28,11 +28,12 @@  import Darcs.RunCommand ( run_the_command ) import Darcs.Flags ( DarcsFlag(Verbose) )-import Darcs.Commands.Help ( help_cmd, list_available_commands, print_version )+import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion ) import ThisVersion ( darcs_version ) import Darcs.SignalHandler ( withSignalsHandled ) import Context ( context ) import Darcs.Global ( with_atexit )+import Preproc( preproc_main ) import Exec ( ExecException(..) ) #include "impossible.h" @@ -54,17 +55,18 @@   argv <- getArgs   case argv of     -- User called "darcs" without arguments.-    []                  -> print_version >> help_cmd [] []+    []                  -> printVersion >> helpCmd [] []     -- User called "darcs --foo" for some special foo.-    ["-h"]              -> help_cmd [] []-    ["--help"]          -> help_cmd [] []-    ["--overview"]      -> help_cmd [Verbose] []-    ["--commands"]      -> list_available_commands+    ["-h"]              -> helpCmd [] []+    ["--help"]          -> helpCmd [] []+    ["--overview"]      -> helpCmd [Verbose] []+    ["--commands"]      -> listAvailableCommands     ["-v"]              -> putStrLn darcs_version     ["--version"]       -> putStrLn darcs_version     ["--exact-version"] -> do               putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__               putStrLn context+    ("--preprocess-manual":rest) -> preproc_main rest     -- User called a normal darcs command, "darcs foo [args]".     _ -> do       hSetBinaryMode stdin True
+ src/darcs.tex view
@@ -0,0 +1,674 @@+%  Copyright (C) 2002-2003 David Roundy+%+%  This program is free software; you can redistribute it and/or modify+%  it under the terms of the GNU General Public License as published by+%  the Free Software Foundation; either version 2, or (at your option)+%  any later version.+%+%  This program is distributed in the hope that it will be useful,+%  but WITHOUT ANY WARRANTY; without even the implied warranty of+%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+%  GNU General Public License for more details.+%+%  You should have received a copy of the GNU General Public License+%  along with this program; see the file COPYING.  If not, write to+%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+%  Boston, MA 02110-1301, USA.++\documentclass{book}+%\usepackage{color}++\usepackage{verbatim}+\usepackage{html}+\usepackage{fancyvrb}+\newenvironment{code}{\comment}{\endcomment}+% \newenvironment{code}{\color{blue}\verbatim}{\endverbatim}++\begin{document}+++% Definition of title page:+\title{Darcs User Manual}+\date{+\darcsVersion+} % icky newline before closing brace is to appease preproc.hs.+\author{David Roundy}++\maketitle++\tableofcontents++\chapter{Introduction}++%% FIXME: DVCS is no longer distinctive; it is the norm.++Darcs is a revision control system, along the lines of CVS or arch.  That+means that it keeps track of various revisions and branches of your+project, allows for changes to propagate from one branch to another.  Darcs+is intended to be an ``advanced'' revision control system.  Darcs has two+particularly distinctive features which differ from other revision control+systems: 1) each copy of the source is a fully functional branch, and 2)+underlying darcs is a consistent and powerful theory of patches.++%% FIXME: don't talk about CVS and arch as if they are our+%% contemporaries, it makes us sound as dated as they are.  Our key+%% competitors are git, hg, bzr and svn.++\paragraph{Every source tree a branch}+The primary simplifying notion of darcs is that \emph{every} copy of your+source code is a full repository. This is dramatically different from CVS,+in which the normal usage is for there to be one central repository from+which source code will be checked out. It is closer to the notion of arch,+since the `normal' use of arch is for each developer to create his own+repository. However, darcs makes it even easier, since simply checking out+the code is all it takes to create a new repository. This has several+advantages, since you can harness the full power of darcs in any scratch+copy of your code, without committing your possibly destabilizing changes to+a central repository.++%% FIXME: unbound personal pronoun (me).  Use third person, passive voice.++\paragraph{Theory of patches}+The development of a simplified theory of patches is what originally+motivated me to create darcs. This patch formalism means that darcs patches+have a set of properties, which make possible manipulations that couldn't be+done in other revision control systems. First, every patch is invertible.+Secondly, sequential patches (i.e.\ patches that are created in sequence, one+after the other) can be reordered, although this reordering can fail, which+means the second patch is dependent on the first. Thirdly, patches which are+in parallel (i.e.\ both patches were created by modifying identical trees)+can be merged, and the result of a set of merges is independent of the order+in which the merges are performed. This last property is critical to darcs'+philosophy, as it means that a particular version of a source tree is fully+defined by the list of patches that are in it, i.e.\ there is no issue+regarding the order in which merges are performed. For a more thorough+discussion of darcs' theory of patches, see Appendix~\ref{Patch}.++%% FIXME: clarify - the theory is advanced, the UI is simple.++\paragraph{A simple advanced tool}+Besides being ``advanced'' as discussed above, darcs is actually also quite+simple. Versioning tools can be seen as three layers. At the foundation is+the ability to manipulate changes. On top of that must be placed some kind+of database system to keep track of the changes. Finally, at the very top is+some sort of distribution system for getting changes from one place to+another.++Really, only the first of these three layers is of particular interest to+me, so the other two are done as simply as possible.  At the database+layer, darcs just has an ordered list of patches along with the patches+themselves, each stored as an individual file.  Darcs' distribution system+is strongly inspired by that of arch.  Like arch, darcs uses a dumb server,+typically apache or just a local or network file system when pulling+patches.  darcs has built-in support for using \verb!ssh! to write to a remote file+system. A darcs executable is called on the remote system to apply the patches.+Arbitrary other transport protocols are supported, through an environment+variable describing a command that will run darcs on the remote system.+See the documentation for DARCS\_APPLY\_FOO in Chapter~\ref{configuring}+for details.++The recommended method is to send patches through gpg-signed email+messages, which has the advantage of being mostly asynchronous.++\paragraph{Keeping track of changes rather than versions}++In the last paragraph, I explained revision control systems in terms of+three layers.  One can also look at them as having two distinct uses.  One+is to provide a history of previous versions.  The other is to keep track+of changes that are made to the repository, and to allow these changes to+be merged and moved from one repository to another.  These two uses are+distinct, and almost orthogonal, in the sense that a tool can support one+of the two uses optimally while providing no support for the other.  Darcs+is not intended to maintain a history of versions, although it is possible+to kludge together such a revision history, either by making each new patch+depend on all previous patches, or by tagging regularly.  In a sense, this+is what the tag feature is for, but the intention is that tagging will be+used only to mark particularly notable versions (e.g.\ released versions, or+perhaps versions that pass a time consuming test suite).++Other revision control systems are centered upon the job of keeping track+of a history of versions, with the ability to merge changes being added as+it was seen that this would be desirable.  But the fundamental object+remained the versions themselves.++In such a system, a patch (I am using patch here to mean an encapsulated+set of changes) is uniquely determined by two trees.  Merging changes that+are in two trees consists of finding a common parent tree, computing the+diffs of each tree with their parent, and then cleverly combining those two+diffs and applying the combined diff to the parent tree, possibly at some+point in the process allowing human intervention, to allow for fixing up+problems in the merge such as conflicts.++In the world of darcs, the source tree is \emph{not} the fundamental+object, but rather the patch is the fundamental object.  Rather than a+patch being defined in terms of the difference between two trees, a tree is+defined as the result of applying a given set of patches to an empty tree.+Moreover, these patches may be reordered (unless there are dependencies+between the patches involved) without changing the tree.  As a result,+there is no need to find a common parent when performing a merge.  Or, if+you like, their common parent is defined by the set of common patches, and+may not correspond to any version in the version history.++One useful consequence of darcs' patch-oriented philosophy is that since a+patch need not be uniquely defined by a pair of trees (old and new), we can+have several ways of representing the same change, which differ only in how+they commute and what the result of merging them is.  Of course, creating+such a patch will require some sort of user input.  This is a Good Thing,+since the user \emph{creating} the patch should be the one forced to think+about what he really wants to change, rather than the users merging the+patch.  An example of this is the token replace patch (See+Section~\ref{token_replace}).  This feature makes it possible to create a+patch, for example, which changes every instance of the variable+``stupidly\_named\_var'' to ``better\_var\_name'', while leaving+``other\_stupidly\_named\_var'' untouched.  When this patch is merged with+any other patch involving the ``stupidly\_named\_var'', that instance will+also be modified to ``better\_var\_name''.  This is in contrast to a more+conventional merging method which would not only fail to change new+instances of the variable, but would also involve conflicts when merging+with any patch that modifies lines containing the variable.  By more using+additional information about the programmer's intent, darcs is thus able to+make the process of changing a variable name the trivial task that it+really is, which is really just a trivial search and replace, modulo+tokenizing the code appropriately.++The patch formalism discussed in Appendix~\ref{Patch} is what makes darcs'+approach possible.  In order for a tree to consist of a set of patches,+there must be a deterministic merge of any set of patches, regardless of the+order in which they must be merged.  This requires that one be able to+reorder patches.  While I don't know that the patches are required to be+invertible as well, my implementation certainly requires invertibility.  In+particular, invertibility is required to make use of+Theorem~\ref{merge_thm}, which is used extensively in the manipulation of+merges.++\input{features.tex}++\chapter{Getting started}++This chapter will lead you through an example use of darcs, which hopefully+will allow you to get started using darcs with your project.++\section{Creating your repository}++Creating your repository in the first place just involves telling darcs to+create the special directory (called {\tt \_darcs}) in your project tree,+which will hold the revision information.  This is done by simply calling+from the root directory of your project:+\begin{verbatim}+$ cd my_project/+$ darcs initialize+\end{verbatim}+This creates the \verb|_darcs| directory and populates it with whatever+files and directories are needed to describe an empty project.  You now+need to tell darcs what files and directories in your project should be+under revision control.  You do this using the command \verb|darcs add|%+\footnote{Note that darcs does not do wildcard expansion, instead relying+on the command shell.  The Windows port of darcs has a limited form of+expansion provided by the C runtime}:+\begin{verbatim}+$ darcs add *.c Makefile.am configure.ac+\end{verbatim}+When you have added all your files (or at least, think you have), you will+want to record your changes.  ``Recording'' always includes adding a note+as to why the change was made, or what it does.  In this case, we'll just+note that this is the initial version.+\begin{verbatim}+$ darcs record --all+What is the patch name? Initial revision.+\end{verbatim}+Note that since we didn't specify a patch name on the command line we were+prompted for one.  If the environment variable `EMAIL' isn't set, you will+also be prompted for your email address.  Each patch that is recorded is+given a unique identifier consisting of the patch name, its creator's email+address, and the date when it was created.++\section{Making changes}++Now that we have created our repository, make a change to one or more of+your files.  After making the modification run:+\begin{verbatim}+$ darcs whatsnew+\end{verbatim}+This should show you the modifications that you just made, in the darcs+patch format.  If you prefer to see your changes in a different format,+read Section~\ref{whatsnew}, which describes the whatsnew command in+detail.++Let's say you have now made a change to your project.  The next thing to do+is to record a patch.  Recording a patch consists of grouping together a+set of related changes, and giving them a name.  It also tags the patch+with the date it was recorded and your email address.++To record a patch simply type:+\begin{verbatim}+$ darcs record+\end{verbatim}+darcs will then prompt you with all the changes that you have made that+have not yet been recorded, asking you which ones you want to include in+the new patch.  Finally, darcs will ask you for a name for the patch.++You can now rerun whatsnew, and see that indeed the changes you have+recorded are no longer marked as new.++\section{Making your repository visible to others}+How do you let the world know about these wonderful changes?  Obviously,+they must be able to see your repository.  Currently the easiest way to do+this is typically by http using any web server.  The recommended way to do+this (using apache in a UNIX environment) is to create a directory called+{\tt /var/www/repos}, and then put a symlink to your repository there:+\begin{verbatim}+$ cd /var/www/repos+$ ln -s /home/username/myproject .+\end{verbatim}++\section{Getting changes made to another repository}+Ok, so I can now browse your repository using my web browser\ldots\ so+what? How do I get your changes into \emph{my} repository, where they can+do some good? It couldn't be easier.  I just \verb|cd| into my repository,+and there type:+\begin{verbatim}+$ darcs pull http://your.server.org/repos/yourproject+\end{verbatim}+Darcs will check to see if you have recorded any changes that aren't in my+current repository.  If so, it'll prompt me for each one, to see which ones+I want to add to my repository.  Note that you may see a different series+of prompts depending on your answers, since sometimes one patch depends on+another, so if you answer yes to the first one, you won't be prompted for+the second if the first depends on it.++Of course, maybe I don't even have a copy of your repository.  In that case+I'd want to do a+\begin{verbatim}+$ darcs get http://your.server.org/repos/yourproject+\end{verbatim}+which gets the whole repository.++I could instead create an empty repository and fetch all of your patches+with pull.  Get is just a more efficient way to clone a whole repository.++Get, pull and push also work over ssh.  Ssh-paths are of the same form+accepted by scp, namely \verb|[username@]host:/path/to/repository|.++\section{Moving patches from one repository to another}++Darcs is flexible as to how you move patches from one repository to another.+This section will introduce all the ways you can get patches from one place+to another, starting with the simplest and moving to the most complicated.++\subsection{All pulls}++The simplest method is the ``all-pull'' method.  This involves making each+repository readable (by http, ftp, nfs-mounted disk, whatever), and you+run \verb|darcs pull| in the repository you want to move the patch to.  This is nice,+as it doesn't require you to give write access to anyone else, and is+reasonably simple.++\subsection{Send and apply manually}++Sometimes you have a machine on which it is not convenient to set up a web+server, perhaps because it's behind a firewall or perhaps for security+reasons, or because it is often turned off.  In this case you can use+\verb|darcs send|+from that computer to generate a patch bundle destined for another+repository.  You can either let darcs email the patch for you, or save it+as a file and transfer it by hand.  Then in the destination repository you+(or the owner of that repository) run \verb|darcs apply| to apply the patches contained+in the bundle.  This is also quite a simple method since, like the all-pull+method, it doesn't require that you give anyone write access to your+repository.  But it's less convenient, since you have to keep track of the+patch bundle (in the email, or whatever).++If you use the send and apply method with email, you'll probably want to+create a \verb!_darcs/prefs/email! file containing your email address.+This way anyone who sends to your repository will automatically send the+patch bundle to your email address.++If you receive many patches by email, you probably will benefit by running+darcs apply directly from your mail program.  I have in my \verb!.muttrc!+the following:+\begin{verbatim}+auto_view text/x-patch text/x-darcs-patch+macro pager A "<pipe-entry>darcs apply --verbose --mark-conflicts \+        --reply droundy@abridgegame.org --repodir ~/darcs"+\end{verbatim}+which allows me to view a sent patch, and then apply the patch directly from \verb!mutt!, sending a+confirmation email to the person who sent me the patch. The autoview line relies on on the following+lines, or something like them, being present in one's \verb!.mailcap!:+\begin{verbatim}+text/x-patch;                           cat; copiousoutput+text/x-darcs-patch;                     cat; copiousoutput+\end{verbatim}++\subsection{Push}++If you use ssh (and preferably also ssh-agent, so you won't have to keep+retyping your password), you can use the push method to transfer changes+(using the scp protocol for communication).  This method is again not very+complicated, since you presumably already have the ssh permissions set up.+Push can also be used when the target repository is local, in which case+ssh isn't needed.  On the other hand, in this situation you could as easily+run a pull, so there isn't much benefit.++Note that you can use push to administer a multiple-user repository.  You+just need to create a user for the repository (or repositories), and give+everyone with write access ssh access, perhaps using+\verb!.ssh/authorized_keys!.  Then they run+\begin{verbatim}+$ darcs push repouser@repo.server:repo/directory+\end{verbatim}++\subsection{Push ---apply-as}++Now we get more subtle.  If you like the idea in the previous paragraph+about creating a repository user to own a repository which is writable by+a number of users, you have one other option.++Push \verb!--apply-as! can run on either a local repository or one accessed+with ssh, but uses \verb!sudo! to run a darcs apply command (having created+a patch bundle as in send) as another user.  You can add the following line+in your \verb|sudoers| file to allow the users to apply their patches to a+centralized repository:+{\small+\begin{verbatim}+ALL   ALL = (repo-user) NOPASSWD: /usr/bin/darcs apply --all --repodir /repo/path*+\end{verbatim}+}+This method is ideal for a centralized repository when all the users have+accounts on the same computer, if you don't want your users to be able to+run arbitrary commands as repo-user.++\subsection{Sending signed patches by email}++Most of the previous methods are a bit clumsy if you don't want to give+each person with write access to a repository an account on your server.  Darcs+send can be configured to send a cryptographically signed patch by email.+You can then set up your mail system to have darcs verify that patches were+signed by an authorized user and apply them when a patch is received by+email.  The results of the apply can be returned to the user by email.+Unsigned patches (or patches signed by unauthorized users) will be+forwarded to the repository owner (or whoever you configure them to be+forwarded to\ldots).++This method is especially nice when combined with the \verb!--test! option+of darcs apply, since it allows you to run the test suite (assuming you+have one) and reject patches that fail---and it's all done on the server,+so you can happily go on working on your development machine without+slowdown while the server runs the tests.++Setting up darcs to run automatically in response to email is by far the+most complicated way to get patches from one repository to another\ldots\ so it'll+take a few sections to explain how to go about it.++\paragraph{Security considerations}++When you set up darcs to run apply on signed patches, you should assume+that a user with write access can write to any file or directory that is+writable by the user under which the apply process runs.  Unless you+specify the \verb!--no-test! flag to darcs apply (and this is \emph{not}+the default), you are also allowing anyone with write access to that+repository to run arbitrary code on your machine (since they can run a test+suite---which they can modify however they like).  This is quite a+potential security hole.++For these reasons, if you don't implicitly trust your users, it is+recommended that you create a user for each repository to limit the damage+an attacker can do with access to your repository.  When considering who to+trust, keep in mind that a security breach on any developer's machine could+give an attacker access to their private key and passphrase, and thus to+your repository.++\paragraph{Installing necessary programs}++You also must install the following programs: gnupg, a mailer configured to+receive mail (e.g.\ exim, sendmail or postfix), and a web server (usually+apache).++\paragraph{Granting access to a repository}++You create your gpg key by running (as your normal user):+\begin{verbatim}+$ gpg --gen-key+\end{verbatim}+You will be prompted for your name and email address, among other options.+%%To add your public key to the allowed keys keyring.+Of course, you can+skip this step if you already have a gpg key you wish to use.++You now need to export the public key so we can tell the patcher about it.+You can do this with the following command (again as your normal user):+\begin{verbatim}+$ gpg --export "email@address" > /tmp/exported_key+\end{verbatim}+And now we can add your key to the \verb!allowed_keys!:+\begin{verbatim}+(as root)> gpg --keyring /var/lib/darcs/repos/myproject/allowed_keys \+               --no-default-keyring --import /tmp/exported_key+\end{verbatim}+You can repeat this process any number of times to authorize multiple users+to send patches to the repository.++You should now be able to send a patch to the repository by running as your+normal user, in a working copy of the repository:+\begin{verbatim}+$ darcs send --sign http://your.computer/repos/myproject+\end{verbatim}+You may want to add ``send sign'' to the file \verb!_darcs/prefs/defaults!+so that you won't need to type \verb!--sign! every time you want to+send\ldots++If your gpg key is protected by a passphrase, then executing \verb!send!+with the \verb!--sign! option might give you the following error:+\begin{verbatim}+darcs failed:  Error running external program 'gpg'+\end{verbatim}+The most likely cause of this error is that you have a misconfigured+gpg that tries to automatically use a non-existent gpg-agent+program. GnuPG will still work without gpg-agent when you try to sign+or encrypt your data with a passphrase protected key. However, it will+exit with an error code 2 (\verb!ENOENT!) causing \verb!darcs! to+fail. To fix this, you will need to edit your \verb!~/.gnupg/gpg.conf!+file and comment out or remove the line that says:+\begin{verbatim}+use-agent+\end{verbatim}+If after commenting out or removing the \verb!use-agent! line in your+gpg configuration file you still get the same error, then you probably+have a modified GnuPG with use-agent as a hard-coded option. In that+case, you should change \verb!use-agent! to \verb!no-use-agent! to+disable it explicitly.++\paragraph{Setting up a sendable repository using procmail}+If you don't have root access on your machine, or perhaps simply don't want+to bother creating a separate user, you can set up a darcs repository using+procmail to filter your mail.  I will assume that you already use procmail+to filter your email.  If not, you will need to read up on it, or perhaps+should use a different method for routing the email to darcs.++To begin with, you must configure your repository so that a darcs send to+your repository will know where to send the email.  Do this by creating a+file in \verb!/path/to/your/repo/_darcs/prefs! called \verb!email!+containing your email address.  As a trick (to be explained below), we will+create the email address with ``darcs repo'' as your name, in an email+address of the form ``David Roundy $<$droundy@abridgegame.org$>$.''+\begin{verbatim}+$ echo 'my darcs repo <user@host.com>' \+      > /path/to/your/repo/_darcs/prefs/email+\end{verbatim}++The next step is to set up a gnupg keyring containing the public keys of+people authorized to send to your repository.  Here I'll give a second way of+going about this (see above for the first).  This time I'll assume you+want to give me write access to your repository.  You can do this by:+\begin{verbatim}+gpg --no-default-keyring \+    --keyring /path/to/the/allowed_keys --recv-keys D3D5BCEC+\end{verbatim}+This works because ``D3D5BCEC'' is the ID of my gpg key, and I have+uploaded my key to the gpg keyservers.  Actually, this also requires that+you have configured gpg to access a valid keyserver.  You can, of course,+repeat this command for all keys you want to allow access to.++Finally, we add a few lines to your \verb!.procmailrc!:+\begin{verbatim}+:0+* ^TOmy darcs repo+|(umask 022; darcs apply --reply user@host.com \+    --repodir /path/to/your/repo --verify /path/to/the/allowed_keys)+\end{verbatim}+The purpose for the ``my darcs repo'' trick is partially to make it easier+to recognize patches sent to the repository, but is even more crucial to+avoid nasty bounce loops by making the \verb!--reply! option have an email+address that won't go back to the repository.  This means that unsigned+patches that are sent to your repository will be forwarded to your ordinary+email.++Like most mail-processing programs, Procmail by default sets a tight umask.+However, this will prevent the repository from remaining world-readable;+thus, the ``umask 022'' is required to relax the umask.+(Alternatively, you could set Procmail's global \verb!UMASK! variable+to a more suitable value.)++\paragraph{Checking if your e-mail patch was applied}++After sending a patch with \verb!darcs send!, you may not receive any feedback,+even if the patch is applied. You can confirm whether or not your patch was applied+to the remote repository by pointing \verb!darcs changes! at a remote repository:+\begin{verbatim}+darcs changes --last=10 --repo=http://darcs.net/+\end{verbatim}++That shows you the last 10 changes in the remote repository. You can adjust the options given+to \verb!changes! if a more advanced query is needed.++\input{configuring_darcs.tex}++\input{best_practices.tex}++\input{formats.tex}++\chapter{Darcs commands}++\input{Darcs/Commands.lhs}++\section{Options apart from darcs commands}+\begin{options}+--help+\end{options}+Calling darcs with just \verb|--help| as an argument gives a brief+summary of what commands are available.+\begin{options}+--version, --exact-version+\end{options}+Calling darcs with the flag \verb|--version| tells you the version of+darcs you are using.  Calling darcs with the flag \verb|--exact-version|+gives the precise version of darcs, even if that version doesn't correspond+to a released version number.  This is helpful with bug reports, especially+when running with a ``latest'' version of darcs.+\begin{options}+--commands+\end{options}+Similarly calling darcs with only \verb|--commands| gives a simple list+of available commands.  This latter arrangement is primarily intended for+the use of command-line autocompletion facilities, as are available in+bash.++\section{Getting help}++\input{Darcs/Commands/Help.lhs}++\section{Creating repositories}++\input{Darcs/Commands/Init.lhs}++\input{Darcs/Commands/Get.lhs}++\input{Darcs/Commands/Put.lhs}++\section{Modifying the contents of a repository}++\input{Darcs/Commands/Add.lhs}++\input{Darcs/Commands/Remove.lhs}++\input{Darcs/Commands/Move.lhs}++\input{Darcs/Commands/Replace.lhs}++\section{Working with changes}++\input{Darcs/Commands/Record.lhs}++\input{Darcs/Commands/Pull.lhs}++\input{Darcs/Commands/Push.lhs}++\input{Darcs/Commands/Send.lhs}++\input{Darcs/Commands/Apply.lhs}++\section{Seeing what you've done}++\input{Darcs/Commands/WhatsNew.lhs}++\input{Darcs/Commands/Changes.lhs}++\input{Darcs/Commands/Show.lhs}++\section{More advanced commands}++\input{Darcs/Commands/Tag.lhs}++\input{Darcs/Commands/SetPref.lhs}++\input{Darcs/Commands/Check.lhs}++\input{Darcs/Commands/Optimize.lhs}++\section{Undoing, redoing and running in circles}++\input{Darcs/Commands/AmendRecord.lhs}++\input{Darcs/Commands/Rollback.lhs}++\input{Darcs/Commands/Unrecord.lhs}++\input{Darcs/Commands/Revert.lhs}++\input{Darcs/Commands/Unrevert.lhs}++\section{Advanced examination of the repository}++\input{Darcs/Commands/Diff.lhs}++\input{Darcs/Commands/Annotate.lhs}++% Includes the show commands.+\input{Darcs/Commands/Show.lhs}++\section{Rarely needed and obscure commands}++\input{Darcs/Commands/Convert.lhs}++\input{Darcs/Commands/MarkConflicts.lhs}++\input{Darcs/Commands/Dist.lhs}++\input{Darcs/Commands/TrackDown.lhs}++\input{Darcs/Commands/Repair.lhs}++\appendix++\input{switching.tex}++\input{building_darcs.tex}++\input{Darcs/Patch.lhs}++\input{Darcs/Repository/DarcsRepo.lhs}++\input{gpl.tex}++\end{document}++
+ src/formats.tex view
@@ -0,0 +1,69 @@+\chapter{Repository Formats}++Darcs 2 supports three repository formats:++\begin{itemize}+\item The current format, called `darcs-2'.  It has the most features.+\item The original format, called `darcs-1' or `old-fashioned inventory'.+  It is the only format supported by Darcs releases prior to 2.0.+  Patches cannot be shared between darcs-2 and darcs-1 repositories.+\item An intermediary format, called `hashed'.  It provides some of+  the features of darcs-2, while retaining the ability to exchange+  patches with darcs-1.  Patches cannot be shared between darcs-2 and+  hashed repositories.+\end{itemize}++Note that references to the hashed format refer to hashed darcs-1+repositories.  All darcs-2 repositories are also hashed, and `darcs+show repo' in a darcs-2 repository will report the format as `hashed,+darcs-2'.++The hashed (and darcs-2) format improves on the darcs-1 format in the+following ways:++\begin{itemize}+\item Improved atomicity of operations.  This improves the safety and+  efficiency of those operations.+\item File names in the `pristine' copy of the working tree are+  hashed.  This greatly reduces the chance of a program accidentally+  treating files in \_darcs/pristine as part of the working tree.++  For example, in darcs-1 running \verb|find -name "*.gif" -delete|+  instead of \verb|find -name _darcs -prune -o -name "*.gif" -delete|+  would result in GIF files in pristine files being deleted.++\item Support for `lazy' repositories.  This causes patches to be+  copied from the parent repository on demand, rather than during the+  initial `darcs get'.  For repositories that only operate on recent+  patches (such as feature branches), this reduces the repository's+  size, and the time and bandwidth taken to create it.++  Lazy repositories are first-class repositories, and all operations+  are supported as long as the parent repository remains accessible.+  This isn't the case for the `partial' feature of the darcs-1 format.++\item Support for caches that are shared by all repositories.  When+  operating on many similar repositories, the patches and pristine+  files they have in common are hard links to the cache.  This greatly+  reduces storage requirements, and the time and bandwidth needed to+  make similar repositories.+\end{itemize}++The darcs-2 format improves on the hashed format in the following+ways:++\begin{itemize}+\item The `exponential merge' problem is \emph{far} less likely to+  occur (it can still be produced in deliberately pathological cases).+\item Identical primitive changes no longer conflict.  For example, if+  two patches both attempt to add a directory `tests', these patches+  will not conflict.+\end{itemize}++% The following reference is particularly important because init+% explains *when* to use each format, which I don't want to+% copy-and-paste here because then the two copies will get out of+% sync.++See also `darcs initialize' (\ref{initialize}), `darcs convert'+(\ref{convert}) and `darcs get' (\ref{get}).
src/fpstring.c view
@@ -26,132 +26,12 @@ #include <sys/mman.h> #endif -/* A locale-independent isspace(3) so patches are interpreted the same- * everywhere. */-// #define ISSPACE(c) \-//     ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r')--// int first_white(const char *s, int len)-// {-//     const char *start;-//     const char *end;-// -//     for (start = s, end = s + len; s < end && !ISSPACE(*s); s++);-// -//     return s - start;-// }--// int first_nonwhite(const char *s, int len)-// {-//     const char *start;-//     const char *end;-// -//     for (start = s, end = s + len; s < end && ISSPACE(*s); s++);-// -//     return s - start;-// }- int has_funky_char(const char *s, int len) {   // We check first for the more likely \0 so we can break out of   // memchr that much sooner.   return !!(memchr(s, 0, len) || memchr(s, 26, len)); -}--// ForeignPtr debugging stuff...--static int num_alloced = 0;--void debug_free(void *p) {-  num_alloced--;-  fprintf(stderr, "Freeing %p (%d left)\n", p, num_alloced);-}--void debug_alloc(void *p, const char *name) {-  num_alloced++;-  fprintf(stderr, "Allocating %p named %s (%d left)\n",-          p, name, num_alloced);-}--/* Specification: RFC 2279 */--int utf8_to_ints(HsInt *pwc, const unsigned char *s, int n) {-  /* returns number of unicode chars in the output.  The output array is-     assumed to have the same number of elements as the input array, which-     is n. */--  HsInt *pwc_original = pwc;-  while (n > 0) {-    unsigned char c = s[0];--    if (c < 0x80) {-      *pwc++ = c;-      n--;-      s++;-    } else if (c < 0xc2) {-      return -1;-    } else if (c < 0xe0) {-      if (n < 2) return -1;-      if (!((s[1] ^ 0x80) < 0x40)) return -1;-      *pwc++ = ((unsigned) (c & 0x1f) << 6)-        | (unsigned) (s[1] ^ 0x80);-      n -= 2;-      s += 2;-    } else if (c < 0xf0) {-      if (n < 3) return -1;-      if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40-            && (c >= 0xe1 || s[1] >= 0xa0)))-        return -1;-      *pwc++ = ((unsigned) (c & 0x0f) << 12)-        | ((unsigned) (s[1] ^ 0x80) << 6)-        | (unsigned) (s[2] ^ 0x80);-      n -= 3;-      s += 3;-    } else if (c < 0xf8 && sizeof(unsigned)*8 >= 32) {-      if (n < 4) return -1;-      if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40-            && (s[3] ^ 0x80) < 0x40-            && (c >= 0xf1 || s[1] >= 0x90)))-        return -1;-      *pwc++ = ((unsigned) (c & 0x07) << 18)-        | ((unsigned) (s[1] ^ 0x80) << 12)-        | ((unsigned) (s[2] ^ 0x80) << 6)-        | (unsigned) (s[3] ^ 0x80);-      n -= 4;-      s += 4;-    } else if (c < 0xfc && sizeof(unsigned)*8 >= 32) {-      if (n < 5) return -1;-      if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40-            && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40-            && (c >= 0xf9 || s[1] >= 0x88)))-        return -1;-      *pwc++ = ((unsigned) (c & 0x03) << 24)-        | ((unsigned) (s[1] ^ 0x80) << 18)-        | ((unsigned) (s[2] ^ 0x80) << 12)-        | ((unsigned) (s[3] ^ 0x80) << 6)-        | (unsigned) (s[4] ^ 0x80);-      n -= 5;-      s += 5;-    } else if (c < 0xfe && sizeof(unsigned)*8 >= 32) {-      if (n < 6) return -1;-      if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40-            && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40-            && (s[5] ^ 0x80) < 0x40-            && (c >= 0xfd || s[1] >= 0x84)))-        return -1;-      *pwc++ = ((unsigned) (c & 0x01) << 30)-        | ((unsigned) (s[1] ^ 0x80) << 24)-        | ((unsigned) (s[2] ^ 0x80) << 18)-        | ((unsigned) (s[3] ^ 0x80) << 12)-        | ((unsigned) (s[4] ^ 0x80) << 6)-        | (unsigned) (s[5] ^ 0x80);-      n -= 6;-      s += 6;-    } else-      return -1;-  }-  return pwc - pwc_original; }  /* Conversion to and from hex */
src/fpstring.h view
@@ -1,15 +1,7 @@ #include <HsFFI.h> #include <sys/types.h> -int wfindps_helper(char c, const char *s, int len);-void debug_free(void *p);-void debug_alloc(void *p, const char *name);--// int first_white(const char *s, int len);-// int first_nonwhite(const char *s, int len); int has_funky_char(const char *s, int len);--int utf8_to_ints(HsInt *pwc, const unsigned char *s, int n);  void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars); void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars);
− src/preproc.hs 
@@ -1,184 +0,0 @@--- | This program mangles a pseudo-LaTeX document into actual LaTeX.--- There are three key changes to the input:------   * \\input{foo} is replaced by the contents of the file foo (after---     it, too, is mangled).  Note that this is relative to the---     working directory, *not* relative to the file being parsed.------   * Anything between \\begin{code} and \\end{code} is deleted.---     Note that this is quite unlike normal literate documentation---     (for which we use Haddock, not LaTeX).------   * Some nonstandard pseudo-LaTeX commands are expanded into actual---     LaTeX text.  In particular, \\darcsCommand{foo} is replaced by---     LaTeX markup describing the command @foo@.-module Main (main) where-import System.FilePath ( (</>) )-import System.Environment ( getArgs )-import System.Exit ( exitWith, ExitCode(..) )-import Text.Regex ( matchRegex, mkRegex )-import Darcs.Commands ( DarcsCommand(SuperCommand,-                        command_sub_commands, command_name,-                        command_extra_arg_help, command_basic_options,-                        command_advanced_options, command_help,-                        command_description),-                        extract_commands )-import Darcs.Arguments ( options_latex )-import Darcs.Commands.Help ( command_control_list, environmentHelp )-import English ( andClauses )-import ThisVersion ( darcs_version )--the_commands :: [DarcsCommand]-the_commands = extract_commands command_control_list---- | The entry point for this program.  The path to the TeX master--- file is supplied as the first argument.  Bootstrapping into--- 'preproc' then happens by passing it a pseudo-document that--- contains a single input (include) line.-main :: IO ()-main = do-  args <- getArgs-  if length args < 1-     then exitWith $ ExitFailure 1-     else return ()-  putStrLn "%% This file was automatically generated by preproc."-  c <- preproc ["\\input{"++head args++"}"]-  mapM_ putStrLn c---- | Depending on whether pdflatex or htlatex is to be used, the LaTeX--- output of this program must vary subtly.  This procedure returns--- true iff the command-line arguments contain @--html@.-am_html :: IO Bool-am_html = do args <- getArgs-             return $ elem "--html" args---- | Given a list of input lines in pseudo-LaTeX, return the same--- document in LaTeX.  The pseudo-LaTeX lines are replaced, other--- lines are used unmodified.-preproc :: [String] -> IO [String]-preproc [] = return []              -- Empty input, empty output.-preproc ("\\usepackage{html}":ss) = -- only use html package with latex2html-    do rest <- preproc ss-       ah <- am_html-       if ah then return $ "\\usepackage{html}" : rest-             else return $ "\\usepackage{hyperref}" : rest-preproc ("\\begin{code}":ss) = ignore ss-    where ignore :: [String] -> IO [String]-          ignore ("\\end{code}":ss') = preproc ss'-          ignore (_:ss') = ignore ss'-          ignore [] = return []-preproc ("\\begin{options}":ss) =-    do rest <- preproc ss-       ah <- am_html-       if ah then return $ "\\begin{rawhtml}" : "<div class=\"cmd-opt-hdr\">" : rest-             else return $ ("\\begin{Verbatim}[frame=lines,xleftmargin=1cm," ++-                            "xrightmargin=1cm]") : rest-preproc ("\\end{options}":ss) =-    do rest <- preproc ss-       ah <- am_html-       if ah then return $ "</div>" : "\\end{rawhtml}" : rest-             else return $ "\\end{Verbatim}" : rest-preproc ("\\darcsVersion":ss) = do-  rest <- preproc ss-  return $ darcs_version:rest-preproc (s:ss) = do-  rest <- preproc ss-  let rx = mkRegex "^\\\\(input|darcs(Command|Env))\\{(.+)\\}$"-  case matchRegex rx s of-    Just ["input", _, path] ->-        do cs <- readFile $ "src" </> path -- ratify readFile: not part of darcs executable-           this <- preproc $ lines cs-           return $ this ++ rest-    Just ["darcsCommand", _, command] ->-        return $ commandHelp command : rest-    Just ["darcsEnv", _, variable] ->-        return $ envHelp variable : rest-    -- The base case for the whole preproc function.  Nothing to-    -- mangle, so this is an ordinary line of TeX, and we append it to-    -- the result unmodified.-    _ -> return $ s : rest--commandHelp :: String -> String-commandHelp command = section ++ "{darcs " ++ command ++ "}\n" ++-                      "\\label{" ++ command ++ "}\n" ++-                      gh ++ get_options command ++ gd-    where-      section = if ' ' `elem` command then "\\subsubsection" else "\\subsection"-      -- | Given a Darcs command name as a string, return that command's (multi-line) help string.-      gh :: String-      gh =  escape_latex_specials $ command_property command_help the_commands command-      -- | Given a Darcs command name as a string, return that command's (one-line) description string.-      gd :: String-      gd = command_property command_description the_commands command--get_options :: String -> String-get_options comm = get_com_options $ get_c names the_commands-    where names = words comm--get_c :: [String] -> [DarcsCommand] -> [DarcsCommand]-get_c (name:ns) commands =-    case ns of-    [] -> [get name commands]-    _ -> case get name commands of-         c@SuperCommand { } ->-             c:(get_c ns $ extract_commands $ command_sub_commands c)-         _ ->-             error $ "Not a supercommand: " ++ name-    where get n (c:cs) | command_name c == n = c-                       | otherwise = get n cs-          get n [] = error $ "No such command:  "++n-get_c [] _ = error "no command specified"--get_com_options :: [DarcsCommand] -> String-get_com_options c =-    "\\par\\verb!Usage: darcs " ++ cmd ++ " [OPTION]... " ++-    args ++ "!\n\n" ++ "Options:\n\n" ++ options_latex opts1 ++-    (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ options_latex opts2)-    where cmd = unwords $ map command_name c-          args = unwords $ command_extra_arg_help $ last c-          opts1 = command_basic_options $ last c-          opts2 = command_advanced_options $ last c--command_property :: (DarcsCommand -> String) -> [DarcsCommand] -> String-                 -> String-command_property property commands name =-    property $ last c-    where names = words name-          c = get_c names commands----envHelp :: String -> String-envHelp var = unlines $ render $ entry environmentHelp-    where render (ks, ds) =-              ("\\paragraph{" ++ escape_latex_specials (andClauses ks) ++ "}") :-              ("\\label{env:" ++ var ++ "}") :-              map escape_latex_specials ds-          entry [] = undefined-          entry (x:xs) | elem var $ fst x = x-                       | otherwise = entry xs---- | LaTeX treats a number of characters or sequences specially.--- Therefore when including ordinary help text in a LaTeX document, it--- is necessary to escape these characters in the way LaTeX expects.-escape_latex_specials :: String -> String--- Order is important-escape_latex_specials =-  (bs2 . amp . percent . carrot . dollar . underscore . rbrace . lbrace . bs1)-  where-    amp        = replace "&"  "\\&"-    bs1        = replace "\\" "\001"-    bs2        = replace "\001" "$\\backslash$"-    carrot     = replace "^"  "\\^{}"-    dollar     = replace "$"  "\\$"-    lbrace     = replace "{"  "\\{"-    percent    = replace "%"  "\\%"-    rbrace     = replace "}"  "\\}"-    underscore = replace "_"  "\\_"--    replace :: Eq a => [a] -> [a] -> [a] -> [a]-    replace _ _ [] = []-    replace find repl s =-        if take (length find) s == find-            then repl ++ (replace find repl (drop (length find) s))-            else [head s] ++ replace find repl (tail s)
src/unit.lhs view
@@ -48,23 +48,24 @@  import System.IO.Unsafe ( unsafePerformIO ) import ByteStringUtils hiding ( intercalate )+import Codec.Binary.UTF8.Generic ( toString ) import qualified Data.ByteString.Char8 as BC ( unpack, pack )-import qualified Data.ByteString as B ( empty, concat, length, unpack, foldr,-                                        cons, ByteString, null, filter, head )-import Data.Char ( isPrint )+import qualified Data.ByteString as B ( concat, empty ) import Darcs.Patch-import Darcs.Patch.Test-import Darcs.Patch.Unit ( patch_unit_tests )+import Darcs.Test.Patch.Test+import Darcs.Test.Patch.Unit ( patch_unit_tests )+import Darcs.Test.Email ( email_parsing, email_header_no_long_lines,+                          email_header_ascii_chars, email_header_lines_start,+                          email_header_no_empty_lines ) import Lcs ( shiftBoundaries ) import Test.QuickCheck-import Printer ( renderPS, text )+import Printer ( renderPS ) import Darcs.Patch.Commute import Data.Array.Base import Data.Array.Unboxed import Control.Monad.ST-import Darcs.Ordered-import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal )-import Darcs.Email ( make_email, read_email, formatHeader )+import Darcs.Witnesses.Ordered+import Darcs.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal ) import Test.HUnit ( assertBool, assertFailure ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework.Providers.HUnit ( testCase )@@ -99,27 +100,22 @@ tests :: [Test] tests = patch_unit_tests ++         [testBool "Checking that UTF-8 packing and unpacking preserves 'hello world'"-                  (unpackPSfromUTF8 (BC.pack "hello world") == "hello world"),+                  (toString (BC.pack "hello world") == "hello world"),          testBool "Checking that hex packing and unpacking preserves 'hello world'"                   (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world")                        == "hello world"),-         testProperty "Checking that email can be parsed"-          (\s ->-            unlines ("":s++["", ""]) ==-              BC.unpack (read_email (renderPS-                    $ make_email "reponame" [] (Just (text "contents\n"))-                                 (text $ unlines s) (Just "filename")))),-         testProperty "Checking email header line length" email_header_no_long_lines,-         testProperty "Checking email for illegal characters" email_header_ascii_chars,-         testProperty "Checking for spaces at start of folded email header lines" email_header_lines_start,-         testProperty "Checking that there are no empty lines in email headers" email_header_no_empty_lines,+         email_parsing,+         email_header_no_long_lines,+         email_header_ascii_chars,+         email_header_lines_start,+         email_header_no_empty_lines,          testProperty "Checking that B.concat works" prop_concatPS,          testProperty "Checking that hex conversion works" prop_hex_conversion,          testProperty "Checking that show and read work right" prop_read_show,          testStringList "Checking known commutes" commute_tests,          testStringList "Checking known merges" merge_tests,          testStringList "Checking known canons" canonization_tests]-        ++ check_subcommutes subcommutes_inverse "patch and inverse both commutex"+        ++ check_subcommutes subcommutes_inverse "patch and inverse both commute"         ++ check_subcommutes subcommutes_nontrivial_inverse "nontrivial commutes are correct"         ++ check_subcommutes subcommutes_failure "inverses fail"         ++@@ -147,18 +143,18 @@          --runQuickCheckTest returnval prop_unravel_seq_merge          testProperty "Checking inverse of inverse" prop_inverse_composition,          testProperty "Checking the order of commutes" prop_commute_either_order,-         testProperty "Checking commutex either way" prop_commute_either_way,-         testProperty "Checking the double commutex" prop_commute_twice,-         testProperty "Checking that merges commutex and are well behaved" prop_merge_is_commutable_and_correct,+         testProperty "Checking commute either way" prop_commute_either_way,+         testProperty "Checking the double commute" prop_commute_twice,+         testProperty "Checking that merges commute and are well behaved" prop_merge_is_commutable_and_correct,          testProperty "Checking that merges can be swapped" prop_merge_is_swapable,          testProperty "Checking again that merges can be swapped (I'm paranoid) " prop_merge_is_swapable,          testStringList "Checking that the patch validation works" test_check,-         testStringList "Checking commutex/recommute" commute_recommute_tests,+         testStringList "Checking commute/recommute" commute_recommute_tests,          testStringList "Checking merge properties" generic_merge_tests,          testStringList "Testing the lcs code" show_lcs_tests,          testStringList "Checking primitive patch IO functions" primitive_show_read_tests,          testStringList "Checking IO functions" show_read_tests,-         testStringList "Checking primitive commutex/recommute" primitive_commute_recommute_tests+         testStringList "Checking primitive commute/recommute" primitive_commute_recommute_tests         ] \end{code} @@ -183,54 +179,6 @@     = (thetest p1 p2)++(pair_unit_tester thetest ps) \end{code} -\chapter{Email format tests}--These tests check whether the emails generated by darcs meet a few criteria.-We check for line length and non-ASCII characters. We apparently do not have to-check for CR-LF newlines because that's handled by sendmail.--\begin{code}---- Check that formatHeader never creates lines longer  than 78 characters--- (excluding the carriage return and line feed)-email_header_no_long_lines :: String -> String -> Bool-email_header_no_long_lines field value =-    not $ any (>78) $ map B.length $ bs_lines $ formatHeader cleanField value-  where cleanField = clean_field_string field--bs_lines :: B.ByteString -> [B.ByteString]-bs_lines = finalizeFold . B.foldr splitAtLines (B.empty, [])-  where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines)-        splitAtLines c  (thisLine, prevLines) = (B.cons c thisLine, prevLines)-        finalizeFold (lastLine, otherLines) = lastLine : otherLines---- Check that an email header does not contain non-ASCII characters--- formatHeader doesn't escape field names, there is no such thing as non-ascii--- field names afaik-email_header_ascii_chars :: String -> String -> Bool-email_header_ascii_chars field value-    = not (any (>127) (B.unpack (formatHeader cleanField value)))-  where cleanField = clean_field_string field---- Check that header the second and later lines of a header start with a space-email_header_lines_start :: String -> String -> Bool-email_header_lines_start field value =-    all (\l -> B.null l || B.head l == 32) (tail headerLines)-  where headerLines = bs_lines (formatHeader cleanField value)-        cleanField  = clean_field_string field---- Checks that there are no lines in email headers with only whitespace-email_header_no_empty_lines :: String -> String -> Bool-email_header_no_empty_lines field value =-    all (not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines-  where headerLines = bs_lines (formatHeader cleanField value)-        cleanField  = clean_field_string field--clean_field_string :: String -> String-clean_field_string = filter (\c -> isPrint c && c < '\x80' && c /= ':')--\end{code}- \chapter{LCS}  Here are a few quick tests of the shiftBoundaries function.@@ -307,10 +255,10 @@ canonization_tests = concatMap check_known_canon known_canons check_known_canon :: (Patch, Patch) -> [String] check_known_canon (p1,p2) =-    if (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1) == p2+    if (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1) == p2     then []     else ["Canonization failed:\n"++show p1++"canonized is\n"-          ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1 :: Patch)+          ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1 :: Patch)           ++"which is not\n"++show p2] known_canons :: [(Patch,Patch)] known_canons =@@ -383,7 +331,7 @@ Here we test to see if commuting patch A and patch B and then commuting the result gives us patch A and patch B again.  The set of patches (A,B) is chosen from the set of all pairs of test patches by selecting those which-commutex with one another.+commute with one another.  \begin{code} commute_recommute_tests :: [String]@@ -391,7 +339,7 @@   case take 200 [(p2:<p1)|                  p1<-test_patches,                  p2<-filter (\p->checkseq [p1,p]) test_patches,-                 commutex (p2:<p1) /= Nothing] of+                 commute (p1:>p2) /= Nothing] of   commute_pairs -> pair_unit_tester t_commute_recommute commute_pairs   where checkseq ps = check_a_patch $ join_patches ps primitive_commute_recommute_tests :: [String]@@ -400,15 +348,15 @@     [(p1:<p2)|      p1<-primitive_test_patches,      p2<-primitive_test_patches,-     commutex (p1:<p2) /= Nothing,+     commute (p2:>p1) /= Nothing,      check_a_patch $ join_patches [p2,p1]] t_commute_recommute   :: TwoPatchUnitTest t_commute_recommute p1 p2 =-    if (commutex (p1:<p2) >>= commutex) == Just (p1:<p2)+    if (commute (p2:>p1) >>= commute) == Just (p2:>p1)        then []-       else ["Failed to recommute:\n"++(show p1)++(show p2)++-            "we saw it as:\n"++show (commutex (p1:<p2))++-             "\nAnd recommute was:\n"++show (commutex (p1:<p2) >>= commutex)+       else ["Failed to recommute:\n"++(show p2)++(show p1)+++            "we saw it as:\n"++show (commute (p2:>p1))+++             "\nAnd recommute was:\n"++show (commute (p2:>p1) >>= commute)              ++ "\n"] \end{code} @@ -422,8 +370,8 @@     concatMap check_cant_commute known_cant_commute check_known_commute :: (Patch:< Patch, Patch:< Patch) -> [String] check_known_commute (p1:<p2,p2':<p1') =-   case commutex (p1:<p2) of-   Just (p2a:<p1a) ->+   case commute (p2:>p1) of+   Just (p1a:>p2a) ->        if (p2a:< p1a) == (p2':< p1')        then []        else ["Commute gave wrong value!\n"++show p1++"\n"++show p2@@ -431,8 +379,8 @@              ++"but is\n"++show p2a++"\n"++show p1a]    Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2]    ++-   case commutex (p2':<p1') of-   Just (p1a:<p2a) ->+   case commute (p1':>p2') of+   Just (p2a:>p1a) ->        if (p1a:< p2a) == (p1:< p2)        then []        else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a@@ -491,10 +439,10 @@  check_cant_commute :: (Patch:< Patch) -> [String] check_cant_commute (p1:<p2) =-    case commutex (p1:<p2) of+    case commute (p2:>p1) of     Nothing -> []     _ -> [show p1 ++ "\n\n" ++ show p2 ++-          "\nArgh, these guys shouldn't commutex!\n"]+          "\nArgh, these guys shouldn't commute!\n"] known_cant_commute :: [(Patch:< Patch)] known_cant_commute = [                       (testhunk 2 ["o"] ["n"]:<@@ -644,8 +592,8 @@     _ :/\: p2' ->         case merge (p1:\/:p2) of         _ :/\: p1' ->-            case commutex (p2':<p1) of-            Just (p1'b:<_) ->+            case commute (p1:>p2') of+            Just (_:>p1'b) ->                 if p1'b /= p1'                 then ["Merge swapping problem with...\np1 "++                       show p1++"merged with\np2 "++@@ -657,7 +605,7 @@             Nothing -> ["Merge commuting problem with...\np1 "++                         show p1++"merged with\np2 "++                         show p2++"gives\np2' "++-                        show p2'++"which doesn't commutex with p1.\n"+                        show p2'++"which doesn't commute with p1.\n"                        ] \end{code} @@ -731,15 +679,15 @@     take 50 [join_patches [p1,p2]|              p1<-primitive_test_patches,              p2<-filter (\p->checkseq [p1,p]) primitive_test_patches,-             commutex (p2:<p1) == Nothing]+             commute (p1:>p2) == Nothing]     where checkseq ps = check_a_patch $ join_patches ps  test_patches_composite =     take 100 [join_patches [p1,p2]|               p1<-primitive_test_patches,               p2<-filter (\p->checkseq [p1,p]) primitive_test_patches,-              commutex (p2:<p1) /= Nothing,-              commutex (p2:<p1) /= Just (p1:<p2)]+              commute (p1:>p2) /= Nothing,+              commute (p1:>p2) /= Just (p2:>p1)]     where checkseq ps = check_a_patch $ join_patches ps  test_patches_two_composite_hunks =@@ -773,7 +721,7 @@          ++take 10 test_patches_two_composite_hunks          ++take 2 test_patches_composite_four_hunks,      check_a_patch $ join_patches [invert p1, p2],-     commutex (p1:<p2) /= Just (p2:<p1)+     commute (p2:>p1) /= Just (p1:>p2)     ]  test_patches =  primitive_test_patches ++
src/win32/System/Posix.hs view
@@ -3,35 +3,31 @@  module System.Posix where -import Foreign.Ptr ( Ptr, castPtr, plusPtr )-import Foreign.Storable ( peek, poke, sizeOf )+import Foreign.Ptr ( Ptr )+import Foreign.Storable ( peek ) import Foreign.C.Types ( CInt, CUInt, CULong, CTime ) import Foreign.C.String ( CString, withCString )-import Foreign.Marshal.Alloc ( allocaBytes )+import Foreign.Marshal.Array ( withArray )+import Foreign.Marshal.Alloc ( alloca )  import System.Posix.Types ( EpochTime ) import System.IO ( Handle ) --foreign import ccall "sys/utime.h _utime" c_utime :: CString -> Ptr a -> IO CInt+foreign import ccall "sys/utime.h _utime" c_utime :: CString -> Ptr CTime -> IO CInt  setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO () setFileTimes path atime mtime = path `withCString` \s -> do-  allocaBytes 8 $ \p -> do-    poke (castPtr p :: Ptr CTime) (atime)-    poke (castPtr (plusPtr p 4) :: Ptr CTime) (mtime)-    c_utime s p-    return ()+  withArray [atime,mtime] $ \p -> do c_utime s p+                                     return ()   foreign import ccall "time" c_ctime :: Ptr CTime -> IO CInt  epochTime :: IO EpochTime epochTime = do-    allocaBytes (sizeOf (undefined :: CTime)) $ \p -> do-      c_ctime p-      t <- peek p :: IO CTime-      return t+  alloca $ \p -> do c_ctime p+                    t <- peek p :: IO CTime+                    return t  foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt
src/witnesses.hs view
@@ -1,3 +1,7 @@+import Context+-- import Preproc -- imports Darcs.Commands.Help+import ThisVersion+-- import Darcs.ArgumentDefaults -- imports Darcs.Commands.Help import Darcs.Patch.Real import Darcs.Patch.Properties import Darcs.Patch.Bundle@@ -6,16 +10,46 @@ import Darcs.Patch.Match import Darcs.Repository.HashedRepo import Darcs.Resolution-import Darcs.Patch.Check+import Darcs.Test.Patch.Check import Darcs.Repository.Pristine import Darcs.Repository.DarcsRepo import Darcs.Repository.Internal-import Darcs.Commands.Unrevert-import Darcs.Commands.WhatsNew-import Darcs.Commands.Show-import Darcs.Commands.Unrecord+-- import Darcs.Commands.Add+import Darcs.Commands.Annotate+-- import Darcs.Commands.AmendRecord -- depends on Darcs.Commands.Record+import Darcs.Commands.Apply+-- import Darcs.Commands.Changes -- does lots of nasty filtering of patch lists+-- import Darcs.Commands.Check+-- import Darcs.Commands.Convert+import Darcs.Commands.Diff import Darcs.Commands.Dist-import Darcs.Commands.TransferMode+-- import Darcs.Commands.Get import Darcs.Commands.GZCRCs+-- import Darcs.Commands.Help -- depends on Darcs.TheCommands+import Darcs.Commands.Init+-- import Darcs.Commands.MarkConflicts+-- import Darcs.Commands.Move+-- import Darcs.Commands.Optimize+import Darcs.Commands.Pull+import Darcs.Commands.Push+-- import Darcs.Commands.Put+-- import Darcs.Commands.Record+-- import Darcs.Commands.Remove -- depends on Darcs.Commands.Add+-- import Darcs.Commands.Repair+-- import Darcs.Commands.Replace+-- import Darcs.Commands.Revert+-- import Darcs.Commands.Rollback -- depends on Darcs.Commands.Rollback+import Darcs.Commands.Send+import Darcs.Commands.SetPref+import Darcs.Commands.Show+-- import Darcs.Commands.Tag -- depends on Darcs.Commands.Tag+import Darcs.Commands.TrackDown+import Darcs.Commands.TransferMode+import Darcs.Commands.Unrevert+import Darcs.Commands.Unrecord+import Darcs.Commands.WhatsNew++-- import Darcs.RunCommand -- imports Darcs.Commands.Help+-- import Darcs.TheCommands -- pulls in all other commands  main = return ()
tests/EXAMPLE.sh view
@@ -28,11 +28,16 @@ rm -rf R S                      # Another script may have left a mess. darcs init      --repo R        # Create our test repos. darcs init      --repo S-mkdir R/d/ R/e/                 # Change the working tree.-echo 'Example content.' >R/d/f-darcs record    --repo R -lam 'Add d/f and e.'-darcs mv        --repo R d/f e/-darcs record    --repo R -am 'Move d/f to e/f.'-darcs push      --repo R S -a   # Try to push patches between repos.-darcs push      --repo S R-rm -rf R/ S/                    # Clean up after ourselves.++cd R+mkdir d e                       # Change the working tree.+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'+darcs mv d/f e/+darcs record -am 'Move d/f to e/f.'+darcs push ../S -a	        # Try to push patches between repos.+cd ..++cd S+darcs push ../R -a+cd ..
tests/check.sh view
@@ -27,9 +27,16 @@ . lib                           # Load some portability helpers. rm -rf R                        # Another script may have left a mess. darcs init      --repo R-darcs setpref   --repo R test true-darcs record    --repo R -am 'true test'+darcs setpref   --repo R test 'grep hello f'+not darcs record    --repo R -am 'true test'+darcs record    --repo R -am 'true test' --no-test+ touch R/f-darcs record    --repo R -lam 'added foo'-darcs check     --repo R --test+darcs record    --repo R -lam 'added foo' --no-test+darcs tag       --repo R -m 'got f?'++echo hello > R/f+darcs record    --repo R -lam 'hellofoo'+darcs chec      --repo R --test+ rm -rf R                        # Clean up after ourselves.
tests/checkpoint.sh view
@@ -2,6 +2,9 @@  # A test for unrecording checkpoint tags, inspired by issue517 +exit 200 # checkpoint creation is not supported by current darcs+         # we would need a testdata tarball for this test+ set -ev  darcs --version
tests/diff.sh view
@@ -10,8 +10,8 @@ darcs add afile.txt darcs record --author me --all --no-test --patch-name init darcs diff-darcs diff -p . --store > diffinmem-darcs diff -p . > diffondisk+darcs diff -p . --store-in-mem > diffinmem+darcs diff -p . --no-store-in-mem > diffondisk diff diffinmem diffondisk cd ..
+ tests/dist-v.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash+set -ev++# tests for "darcs dist"++not () { "$@" && exit 1 || :; }++rm -rf temp1+mkdir temp1+cd temp1+darcs init+# needs fixed on FreeBSD+darcs dist -v 2> log+not grep error log+cd ..++rm -rf temp1+
+ tests/emailformat.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash++. ../tests/lib++set -ev+switch_to_latin9_locale+rm -rf temp1+rm -rf temp2+mkdir temp1+mkdir temp2+cd temp1++seventysevenaddy="<aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa@bbbbbbbbbb.cccccccccc.abrasoft.com>"++darcs init++echo "Have you seen the smørrebrød of René Çavésant?" > non_ascii_file+darcs add non_ascii_file+darcs record -am "non-ascii file add" -A test++cd ../temp2+darcs init+cd ../temp1++# long email adress: check that email adresses of <= 77 chars don't get split up+darcs send --from="Kjålt Überström $seventysevenaddy" \+           --subject "Un patch pour le répositoire" \+           --to="Un garçon français <garcon@francais.fr>" \+           --sendmail-command='tee mail_as_file %<' \+           -a ../temp2++cat mail_as_file+# The long mail address should be in there as a whole+grep $seventysevenaddy mail_as_file++# Check that there are no non-ASCII characters in the mail+ghc -e 'getContents >>= return . not . any (> Data.Char.chr 127)' < mail_as_file | grep '^True$'+++cd ..+rm -rf temp1+rm -rf temp2+
+ tests/external-resolution.sh view
@@ -0,0 +1,31 @@+#!/usr/bin/env bash+. lib++rm -rf temp1 temp2++mkdir temp1+cd temp1+darcs init+echo "Conflict, Base ." > child_of_conflict+darcs add child_of_conflict+darcs record -am 'Conflict Base'+cd ..+darcs get temp1 temp2++# Add and record differing lines to both repos+cd temp1+echo "Conflict, Part 1." > child_of_conflict+darcs record -A author -am 'Conflict Part 1'+cd ..+cd temp2+echo "Conflict, Part 2." > child_of_conflict+darcs record -A author -am 'Conflict Part 2'+cd ..++cd temp1+echo | darcs pull -a ../temp2 --external-merge 'cp %2 %o'+cd ..++diff -u temp1/child_of_conflict temp2/child_of_conflict++rm -rf temp1 temp2
+ tests/failed-amend-should-not-break-repo.sh view
@@ -0,0 +1,58 @@+#!/usr/bin/env bash+## Test for keeping the repository in consitent state in case+## of a test failure on amend-record. The bug was almost introduced+## when trying to fix issue 1406.+##+## Copyright (C) 2009 Kamil Dworakowski+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib+set -ev+rm -rf R+mkdir R+cd R+darcs init+# first patch: new file A+touch A+darcs add A+darcs record -a -m 'A'+# second patch: mv A to B+darcs mv A B+echo y | darcs record -a -m 'move'+# third patch: modify B+echo "content" > B+echo y | darcs record -a -m 'add content'++# amending 'move' results in commuting 'move' patch+# to the end for removal. The commute changes the "add content"+# patch to modify A instead of B. But the amend is interrupted+# because of test failure. Check the consitency after the operation.+darcs setpref test false+echo yy | not darcs amend -p move+darcs check++# Note: Amend-record in case of test failure is broken as described in issue1406,+# though when trying to fix it I almost managed to break darcs even more.+# This test is to guard against such regressions in the future.++cd ..+rm -rf R
+ tests/failing-add_permissions.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+## Darcs should refuse to add an unreadable file, because unreadable+## files aren't recordable.+##+## Copyright (C) 2005  Mark Stosberg+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++abort_windows                   # does not work on Windows.+rm -rf temp1                    # Another script may have left a mess.+darcs initialize --repodir temp1+touch temp1/unreadable+chmod a-r temp1/unreadable      # Make the file unreadable.+not darcs add --repodir temp1 no_perms.txt 2>temp1/log+fgrep -i 'permission denied' temp1/log+rm -rf temp1
+ tests/failing-issue1013_either_dependency.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+set -ev+export DARCS_EMAIL=test+rm -rf tmp_d1 tmp_d2 tmp_d+# Preparations:+# Set up two repos, each with a patch (d1 and d2 respectively) with both+# an individual change and a change that is identical in both repos,+# and thus auto-merge, i.e., they don't conflict in darcs2.  Pull them+# together and record a patch (problem) on top of the auto-merged change,+# so that it depends on EITHER of two patches.++mkdir tmp_d1; cd tmp_d1+darcs init --darcs-2+echo a > a+echo b > b+echo c > c+darcs rec -alm init+echo a-independent > a+echo c-common > c+darcs rec -am d1+cd ..+darcs get --to-patch init tmp_d1 tmp_d2+cd tmp_d2+echo b-independent > b+echo c-common > c+darcs rec -am d2+darcs pull -a ../tmp_d1+# no conflicts -- c-common is identical+echo c-problem > c+darcs rec -am problem+cd ..++# I want to pull the 'problem' patch, but expect darcs to get confused+# because it doesn't know how to select one of the two dependent patches.++darcs get --to-patch init tmp_d2 tmp_d+cd tmp_d+echo n/n/y |tr / \\012 |darcs pull ../tmp_d2+darcs cha++# This is weird, we got d2 though we said No.  I would have expected+# darcs to skip the 'problem' patch in this case.++# Try to pull d1 and unpull d2.++darcs pull -a ../tmp_d1+exit 1 # darcs hangs here (2.0.2+77)!+echo n/y/d |tr / \\012 |darcs obl -p d2++# The obliterate fails with: patches to commute_to_end does not commutex (1)++cd ..+rm -rf tmp_d1 tmp_d2 tmp_d
+ tests/failing-issue1014_identical_patches.sh view
@@ -0,0 +1,60 @@+#!/usr/bin/env bash+set -ev++# Set up a base repo. Our experiment will start from this point+mkdir base+cd base+darcs init --darcs-2+printf "Line1\nLine2\nLine3\n" > foo+darcs rec -alm Base+cd ..++# Now we want to record patch A, which will turn "Line2" into "Hello"+darcs get base a+cd a+printf "Line1\nHello\nLine3\n" > foo+darcs rec --ignore-times -am A+cd ..++# Make B the same as A+darcs get base b+cd b+printf "Line1\nHello\nLine3\n" > foo+darcs rec --ignore-times -am B+cd ..++# Now we make a patch C that depends on A+darcs get a ac+cd ac+printf "Line1\nWorld\nLine3\n" > foo+darcs rec --ignore-times -am C+cd ..++# Merge A and B+darcs get a ab+cd ab+darcs pull -a ../b+darcs revert -a+cd ..++# And merge in C too+darcs get ab abc+cd abc+darcs pull -a ../ac+darcs revert -a+cd ..++# Now we can pull just B and C into base+darcs get base bc+cd bc+darcs pull ../abc -ap 'B|C'+cd ..++# Now we have base, B and C in a repository.  At this point we're correct.++# Let's try merging AC with BC now, here we discover a bug.++darcs get ac abc2+cd abc2+darcs pull -a ../bc+
+ tests/failing-issue1190_unmarked_hunk_replace_conflict.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue1190 - conflicts between HUNK and REPLACE are not+## marked by --mark-conflicts.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++rm -rf d e                      # Another script may have left a mess.+darcs init    --repo d/+printf %s\\n foo bar baz >d/f+darcs record  --repo d/ -lam f1+darcs get d/ e/+darcs replace --repo e/ --force bar baz f+darcs record  --repo e/ -lam replacement+printf %s\\n foo bar quux >d/f  # replace baz with quux+darcs record  --repo d/ -am f2++## There ought to be a conflict here, and there is.+darcs pull    --repo e/ d/ -a --mark-conflicts+## The file ought to now have conflict markers in it.+grep 'v v v' e/f+rm -rf d/ e/                    # Clean up after ourselves.
+ tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+set -ev++not () { "$@" && exit 1 || :; }++rm -rf temp1+mkdir temp1+cd temp1++darcs init+touch aargh+darcs add aargh+echo utrecht > aargh++darcs wh foo foo/../foo/. > out+cat out+not grep utrecht out++cd ..+rm -rf temp1+
+ tests/failing-issue1266_init_inside_a_repo.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash+## Test for issue1266 - attempting to initialize a repository inside+## another repository should cause a warning, because while perfectly+## legitimate, it is likely to be accidental.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++rm -rf temp1 out                # Another script may have left a mess.+darcs init --repodir temp1+darcs init --repodir temp1/temp2 2>&1 | tee out+grep -i WARNING out             # A warning should be printed.
+ tests/failing-issue1317_list-options_subdir.sh view
@@ -0,0 +1,39 @@+#!/bin/sh++# Test for issue1317 - darcs mv --list-options returns results from root, and+# not from the current directory++# Copyright 2009 Marco Túlio Gontijo e Silva <marcot@riseup.net>++# Permission is hereby granted, free of charge, to any person obtaining a copy+# of this software and associated documentation files (the "Software"), to deal+# in the Software without restriction, including without limitation the rights+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+# copies of the Software, and to permit persons to whom the Software is+# furnished to do so, subject to the following conditions:++# The above copyright notice and this permission notice shall be included in+# all copies or substantial portions of the Software.++# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+# THE SOFTWARE.++. ../tests/lib+rm -rf R+mkdir R+cd R+darcs init+touch abcd+mkdir foo+darcs add foo+cd foo+touch abcc+mkdir bar+darcs mv --list-options | grep -x abcc+cd ../..+rm -rf R
+ tests/failing-issue1325_pending_minimisation.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+## Test for issue1325 - hunk patches interfere with pending patch+## minimisation+##+## Copyright (C) 2009 Marco Túlio Gontijo e Silva, Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init   --repo=R+darcs init   --repo=S++# this is expected to pass regardless of issue1325+# and is here to provide contrast+cd R+touch file+darcs add file+darcs record -am ' file'+mkdir b+darcs add b+darcs mv  file b+rm -r b+darcs whatsnew | not grep adddir+cd ..++# this is/was the failing part of issue1325+cd S+echo file > file                # we need a hunk to make this interesting+darcs add file+darcs record -am ' file'+mkdir b+darcs add b+darcs mv  file b+rm -r b+darcs whatsnew | not grep adddir+cd ..
+ tests/failing-issue1327.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash+set -ev++# See issue1327.+# results in the error:+# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452+++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo fileA version 1 > fileA+echo fileB version 1 > fileB+darcs add fileA fileB+darcs record --author foo@bar --ignore-times --all -m "Add fileA and fileB"+echo fileA version 2 > fileA+darcs record --author foo@bar --ignore-times --all -m "Modify fileA"+cd ..+darcs get temp1 temp2+cd temp2+darcs obliterate -p "Modify fileA" --all+darcs unrecord -p "Add fileA and fileB" --all+darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA"+cd ../temp1+darcs pull --all ../temp2+echo y | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"
+ tests/failing-issue1332_add_r_boring.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Test for issue1332 - add -r ignores --boring+##+## Copyright (C) 2009 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.++cd R+mkdir d+touch core f+# this is already known to work+darcs add --boring core f+darcs whatsnew > log+grep 'addfile ./f' log+grep 'addfile ./core' log+rm _darcs/patches/pending+# this fails for issue1332+darcs add -r --boring .+darcs whatsnew > log+grep 'addfile ./f' log+grep 'addfile ./core' log+rm _darcs/patches/pending+cd ..
+ tests/failing-issue1337_darcs_changes_false_positives.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue1337 - darcs changes shows unrelated patches+## Asking "darcs changes" about an unrecorded file d/f will list the+## patch that creates the parent directory d/ (instead of no patches).+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++rm -rf temp1+darcs init --repodir temp1+cd temp1+mkdir d+darcs record -lam d d+# We use --match 'touch d/f' instead of simply d/f because the latter+# prints "Changes to d/f:\n" before the count.+test 0 -eq "$(darcs changes --count --match 'touch d/f')"
+ tests/failing-issue1396_changepref-conflict.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash+set -ev++. ../tests/lib++rm -rf temp1 temp1a temp1b++mkdir temp1+cd temp1+darcs init+darcs setpref test 'echo nothing'+darcs record -am 'null pref'+cd ..++darcs get temp1 temp1a+cd temp1a+darcs setpref test 'echo a'+darcs record -am 'pref a'+cd ..++darcs get temp1 temp1b+cd temp1b+darcs setpref test 'echo b'+darcs record -am 'pref b'+cd ..++cd temp1+darcs pull -a ../temp1a --dont-allow-conflicts+not darcs pull -a ../temp1b --dont-allow-conflicts+cd ..++rm -rf temp1 temp1a temp1b
+ tests/failing-issue1401_bug_in_get_extra.sh view
@@ -0,0 +1,44 @@+#!/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.++. ../tests/lib++## This bug only affects darcs-2 repositories.+fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 0++rm -rf d e                      # Another script may have left a mess.+darcs initialize --repodir d/+darcs initialize --repodir e/+touch d/f d/g e/f+darcs record     --repodir d/ -lam 'Add f and g'+darcs record     --repodir e/ -lam 'Add f'+echo >d/f+darcs record     --repodir d/ -am 'Change f'+darcs pull       --repodir e/ -a d/+darcs obliterate --repodir e/ -ap 'Add f and g'+darcs pull       --repodir e/ -a d/+rm -rf d/ e/                    # Clean up after ourselves.
+ tests/failing-issue1406.sh view
@@ -0,0 +1,85 @@+#!/usr/bin/env bash+## Test for issue1406 - failed test on amend unrecords the+##                      original patch+##+## Copyright (C) 2009 Adam Vogt, Kamil Dworakowski+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.+darcs init      --repo S+mkdir R/d/ R/e/                 # Change the working tree.+echo 'Example content.' >R/d/f+darcs record    --repo R -lam 'Add d/f and e.'+darcs mv        --repo R d/f e/+darcs record    --repo R -am 'Move d/f to e/f.'+darcs push      --repo R S -a   # Try to push patches between repos.+darcs push      --repo S R+rm -rf R/ S/                    # Clean up after ourselves.+#!/bin/sh+set -ev++. ../tests/lib++rm -rf temp1+darcs init --repodir temp1++cd temp1++echo "test exit 1" > _darcs/prefs/prefs+echo "a" > a+darcs record --look-for-adds --no-test --all --patch-name=p1+echo "b" >> a+echo "y" | not darcs amend-record --all --patch=p1++# There should be one patch in the repo+test 1 -eq `darcs changes --count` || exit 1++# Another check: there should be nothing new after a is restored+echo "a" > a+not darcs whatsnew -l++cd ..+rm -rf test1++# the following section of the test does not create a new repo,+# it oprates on an existing old-fashioned repo; no need to run it 3 times+if grep 'old-fashioned' .darcs/defaults; then++    # check that we do the operations on checkpoints tentatively+    rm -rf old-with-checkpoint+    tar zxf ../tests/repos/old-with-checkpoint.tgz++    echo "test exit 1" > old-with-checkpoint/_darcs/prefs/prefs++    # this amend will fail+    echo 'y' | not darcs amend --repo old-with-checkpoint -m 'no longer a checkpoint :P' -p "checkpoint here"++    # check that the patch has not been removed from+    # the checkpoints inventory+    grep "checkpoint here" old-with-checkpoint/_darcs/checkpoints/inventory+    #NOTE: checking the file is a rather white box way of testing it, but+    #      I could not think of any other way at the time, please improve++    rm -rf old-with-checkpint+fi
+ tests/failing-issue1442_encoding_round-trip.sh view
@@ -0,0 +1,50 @@+#!/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.++. ../tests/lib++rm -rf R                        # Another script may have left a mess.++## Use the first UTF-8 locale we can find.+export LC_ALL=$(locale -a | egrep 'utf8|UTF-8' | head -1)+export DARCS_DONT_ESCAPE_ANYTHING=True++## If LC_ALL is the empty string, this system doesn't support UTF-8.+if test -z "$LC_ALL"+then exit 1+fi++darcs init      --repo R+echo '首頁 = א₀' >R/'首頁 = א₀'+darcs record    --repo R -lam '首頁 = א₀' '首頁 = א₀'+darcs changes   --repo R -v '首頁 = א₀' >R/log+#cat R/log                      # Show the humans what the output was.+grep -c '首頁 = א₀' R/log >R/count+echo 5 >R/expected-count+cmp R/count R/expected-count    # Both count files should contain "5\n".+rm -rf R                        # Clean up after ourselves.
+ tests/failing-issue1461_case_folding.sh view
@@ -0,0 +1,83 @@+#!/usr/bin/env bash+## Test for issue1461 - patches to files whose names only differ by+## case can be wrongly applied to the same file in the working directory.+##+## Copyright (C) 2009 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf lower upper joint        # Another script may have left a mess.+mkdir lower upper++cd lower+darcs init+cat > a << EOF+1+2+3+EOF+darcs add a+darcs record -am 'lower init a'+cd ..++cd upper+darcs init+cat > A << EOF+1+2+3+EOF+darcs add A+darcs record -am 'upper init A'+cd ..++darcs get lower joint+cd joint+darcs pull -a ../upper+cd ..++cd lower+cat > a << EOF+one lower+2+3+EOF+darcs record -am 'lower modify'+cd ..++cd upper+cat > A << EOF+1+2+three upper+EOF+darcs record -am 'upper modify'+cd ..++cd joint+darcs pull ../lower -a+darcs pull ../upper -a+grep one a && not grep three a+grep three A && not grep one A+cd ..+# clean up after ourselves+rm -rf lower upper joint
+ tests/failing-issue1473_annotate_repodir.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+set -ev++. ../tests/lib+rm -rf temp+mkdir temp+cd temp+darcs init+mkdir a b+touch a/a b/b+darcs add --rec .+darcs record -a -m ab -A test+darcs annotate a/a+# annotate --repodir=something '.' should work+cd ..+darcs annotate --repodir temp '.'+cd temp++cd ..+rm -rf temp+
+ tests/failing-issue1609_ot_convergence.sh view
@@ -0,0 +1,104 @@+#!/usr/bin/env bash+## Test for issue1609 - standard test for the TP2 property+## in the Operational Transformation literature.+##+## According to Wikipedia:+## For every three concurrent operations op1,op2 and op3 defined on the same+## document state, the transformation function T satisfies CP2/TP2 property+## if and only if:+## T(op_3, op_1 \circ T(op_2,op_1)) = T(op_3, op_2 \circ T(op_1,op_2)).+##+## Copyright (C) 2009 Eric Kow <kowey@darcs.net>+## Copyright (C) 2009 Pascal Molli <momo54@gmail.com>+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf S1  S2  S3               # Another script may have left a mess.+darcs init      --repo S1       # Create our test repos.++cd S1+cat > f << END+1+2+3+4+5+END+darcs add f+darcs record -am init+cd ..++darcs get S1 S2+darcs get S1 S3++cd S1+cat > f << END+1+2+X+3+4+5+END+darcs record -am 'insert X before line 3'+cd ..++cd S2+cat > f << END+1+2+4+5+END+darcs record -am 'delete line 3'+cd ..++cd S3+cat > f << END+1+2+3+Y+4+5+END+darcs record -am 'insert Y after line 3'+cd ..++darcs pull --allow-conflicts -a --repo S1 S2+darcs pull --allow-conflicts -a --repo S2 S1++darcs pull --allow-conflicts -a --repo S1 S3+darcs pull --allow-conflicts -a --repo S2 S3++darcs pull --allow-conflicts -a --repo S3 S1++# TP2 is just fine for conflict resolution itself...+diff S1/f S2/f # no difference+diff S2/f S3/f # no difference++# But what about the conflict marking?+darcs mark-conflicts --repo S1+darcs mark-conflicts --repo S2+darcs mark-conflicts --repo S3+diff S1/f S2/f # no difference+diff S2/f S3/f # no difference
+ tests/failing-issue1610_get_extra.sh view
@@ -0,0 +1,90 @@+#!/usr/bin/env bash+## Test for issue1610 - another bug in get_extra problem+## This is an offshoot of the issue1609 test+##+## Copyright (C) 2009 Eric Kow <kowey@darcs.net>+## Copyright (C) 2009 Pascal Molli <momo54@gmail.com>+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.++# this test is not relevant for darcs 2 repositories+(not grep darcs-2 $HOME/.darcs/defaults) || exit 200++rm -rf S1  S2  S3               # Another script may have left a mess.+darcs init      --repo S1       # Create our test repos.++cd S1+cat > f << END+1+2+3+4+5+END+darcs add f+darcs record -am init+cd ..++darcs get S1 S2+darcs get S1 S3++cd S1+cat > f << END+1+2+X+3+4+5+END+darcs record -am 'insert X before line 3'+cd ..++cd S2+cat > f << END+1+2+4+5+END+darcs record -am 'delete line 3'+cd ..++cd S3+cat > f << END+1+2+3+Y+4+5+END+darcs record -am 'insert Y after line 3'+cd ..++# please compare this with the issue1609 test+darcs pull -a --repo S1 S2+darcs pull -a --repo S1 S3++darcs pull -a --repo S2 S1+darcs pull -a --repo S2 S3
+ tests/failing-issue1632_changes_nonexisting.sh view
@@ -0,0 +1,40 @@+#!/usr/bin/env bash+## Test for issue1632 - 'darcs changes d/f' should not list any changes,+## where d is part of the repo and f is a non-existent file.+##+## Copyright (C) 2009   Ben Franksen+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.++cd R+mkdir d+darcs record -lam 'added directory d'+# darcs should not list any changes here:+darcs changes non-existent-file > log+not grep 'added directory d' log+# ...and neither here:+darcs changes d/non-existent-file > log+not grep 'added directory d' log+cd ..
+ tests/failing-issue1645-ignore-symlinks.sh view
@@ -0,0 +1,35 @@+#!/usr/bin/env bash+## Test for issue1645 - whatsnew -l should not consider symlinks to be+## "real" files in the working tree.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R f                      # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.++cd R+echo 'Example content.' > ../f  # a file outside the repo+ln -s ../f                      # a symlink to same inside the repo+darcs whatsnew -l >log+fgrep 'No changes!' log         # Darcs shouldn't report any changes.
@@ -0,0 +1,77 @@+#!/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.++. ../tests/lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.++## 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/failing-issue390_whatsnew.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++# For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory++set -ev++if ! test -x "$(which strace)"+then echo skipping test since strace was not found+     exit+fi++rm -rf temp+mkdir temp+cd temp+darcs init+date > file1+date > file2+darcs add file*+darcs record -am "test"++strace darcs whatsnew file1 &> out+# we should be accessing file1+grep file1 out+# but shouldn't be accessing file2+if grep file2 out+then+    echo A whatsnew for file1 should not involve a 'stat' call to file2+    exit 1+else+    echo Yay.  We pass.+fi++rm -rf temp
+ tests/failing-issue68_broken_pipe.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash++# For issue68, 'don't report "resource vanished" when stdout pipe is broken.'++set -ev++rm -rf temp1 # Another script may have left a mess.++darcs init --repodir temp1++cd temp1++date > f+darcs add f+darcs rec -am firstp+for (( i=0 ; i < 500; i=i+1 )); do+  echo $i >> f;+  darcs rec -am p$i+done++darcs changes 2> err | head++touch correcterr++diff correcterr err++cd ..
+ tests/failing-issue944_partial_inventory.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash++set -ev++test $DARCS || DARCS=$PWD/../darcs+ACTUAL_DARCS=`which $DARCS`+DARCSPATH=`dirname $ACTUAL_DARCS`+PATH="$DARCSPATH:$PATH"+export PATH++# create base repository+rm -rf temp1+mkdir temp1+cd temp1+darcs init++echo first > a+darcs add a+darcs record -am first+darcs tag --checkpoint 'Tag 1'++echo second > b+darcs add b+darcs record -am second+darcs tag --checkpoint 'Tag 2'++echo third > c+darcs add c+darcs record -am third+darcs tag --checkpoint 'Tag 3'++# create a partial copy of the base repository and modify it+cd ..+rm -rf temp2+darcs get --partial temp1 temp2+cd temp2++# instead of the following three commands one could also use darcs optimize+echo mistake > a+darcs record -am mistake+darcs unrecord -ap mistake++# now check the repository+darcs check+# => darcs: failed to read patch: ...+
+ tests/failing-merging_newlines.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+set -ev++# Note that this is fixed, the lines marked # BUG HERE+# should be moved back into merging_newlines.sh++# trick: requiring something to fail+not () { "$@" && exit 1 || :; }++rm -rf temp1 temp2++# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++cd temp1+echo "apply allow-conflicts" > _darcs/prefs/defaults+# note: to make this pass, change echo to echo -n+# is that right?+echo "from temp1" > one.txt+darcs add one.txt+darcs record -A bar -am "add one.txt"+echo >> one.txt+darcs wh -u+cd ..++darcs get temp1 temp2+cd temp2+# reality check+darcs show files | grep one.txt+echo "in tmp2" >> one.txt+darcs whatsnew -s | grep M+darcs record -A bar -am "add extra line"+darcs annotate -p . -u+darcs push -av > log+cat log+not grep -i conflicts log+# BUG HERE+# after a conflict, darcs resolve should report a conflict+darcs mark-conflicts > log 2>&1+cat log+not grep -i 'no conflicts' log+cd ..++rm -rf temp1 temp2
+ tests/failing-newlines.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2++# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++cd temp1+echo -n "from temp1" > one.txt+darcs add one.txt+darcs record -A bar -am "add one.txt"+echo >> one.txt+cd ..++darcs get temp1 temp2+cd temp2+echo "in tmp2" >> one.txt+darcs record -A bar -am "add extra line"+lines_added=`darcs changes -v --last=1 | grep '\+' | wc -l`+echo $lines_added+test $lines_added -eq 1+cd ..++rm -rf temp1 temp2
+ tests/failing-nice-resolutions.sh view
@@ -0,0 +1,52 @@+#!/bin/sh++set -ev++mkdir temp1+cd temp1+darcs init++echo a > foo+darcs add foo+darcs record -am addfoo++cd ..+darcs get temp1 temp2++cd temp2+echo B > foo+darcs record -am B++cd ../temp1+echo b > foo+darcs record -am b+echo c > foo+darcs record -am c+cd ../temp2+darcs pull -a++cat foo++grep b foo && exit 1+grep a foo && exit 1+grep B foo+grep c foo++echo C > foo+darcs record -am C++cd ../temp1+echo d > foo+darcs record -am d++cd ../temp2+darcs pull -a++cat foo++grep b foo && exit 1+grep a foo && exit 1+grep B foo && exit 1+grep c foo && exit 1+grep C foo+grep d foo
+ tests/failing-record-scaling.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issueN - darcs record shouldn't access old inventories!+##+## Copyright (C) 2008  David Roundy+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+which strace || exit 200        # This test requires strace(1).++rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repo.+touch R/a-unique-filename+strace -eopen -oR/trace \+  darcs record  --repo R -lam 'A unique commit message.'+grep a-unique-filename R/trace+grep _darcs/hashed_inventory R/trace+not grep _darcs/inventories/ R/trace+rm -rf R                        # Clean up after ourselves.
tests/haskell_policy.sh view
@@ -1,59 +1,41 @@ #!/usr/bin/env bash+## This is a pseudo-test that runs tweaked hlint on the source code.+##+## Copyright (C) 2009 Petr Rockai+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE. -RESULT=tmpfile-ROOT=..-ERRORSTATUS=0+. lib -# lookfor ( $1=what, $2=reason, $3=source module exception )-lookfor () {-    rm -f "$RESULT"-    darcs query manifest --repodir="$ROOT" | grep '\.l\?hs$' | while read f; do-        grep -Hnwe "$1" "$ROOT/$f" | grep -v "$3\.$1" | \-        grep -v ":[0-9]\+:import " | grep -Fv "ratify $1: " >> "$RESULT"-    done-    if [ -s "$RESULT" ]; then-        echo "Found the following unratified uses of $1:"-        # ugly sed expresion to fix relative paths; think pretty cat-        sed -e 's/[^:]*\/\.\///' "$RESULT"-        echo "$2"-        echo "Comment 'ratify $1: <why>' on the same line to allow it"-        echo-        ERRORSTATUS=1-    fi-    rm -f "$RESULT"+explain() {+    echo >&2+    echo "## It seems that hlint has found errors. This usually means that you" >&2+    echo "## have used a forbidden function. See contrib/darcs-errors.hlint for" >&2+    echo "## explanation. Please also disregard any possible parse errors." >&2 } -# On 2009-02-12 Petr Rockai explained this on darcs-users:-# The problem with Prelude readFile is that it's based on hGetContents, which-# is lazy by definition. This also means that unless you force consumption of-# the produced list, it will keep an fd open for the file, possibly-# indefinitely.  This is called a fd leak. Other than being annoying and if done-# often, leading to fd exhaustion and failure to open any new files (which is-# usually fatal), it also prevents the file to be unlinked (deleted) on win32.-#-# On the other hand, *strict* bytestring version of readFile will read the whole-# file into a contiguous buffer, *close the fd* and return. This is perfectly-# safe with regards to fd leaks. Btw., this is *not* the case with lazy-# bytestring variant of readFile, so that one is unsafe.-lookfor readFile \-        "Prelude.readFile doesn't ensure the file is closed before it is deleted!\nConsider import Data.ByteString.Char8 as B (readFile), B.readFile instead." \-        B # importing readFile from Data.ByteString as B, is allowed--lookfor hGetContents \-        "hGetContents doesn't ensure the file is closed before it is deleted!"+trap explain ERR -# look for tabs in haskell source-rm -f "$RESULT"-darcs query manifest --repodir="$ROOT" | grep '\.l\?hs$' | while read f; do-    grep -FHnwe "	" "$ROOT/$f" >> "$RESULT"-done-if [ -s "$RESULT" ]; then-    echo "Found the following lines with unwanted tabs:"-    # ugly sed expresion to fix relative paths; think pretty cat-    sed -e 's/[^:]*\/\.\///' "$RESULT"-    echo-    ERRORSTATUS=1-fi-rm -f "$RESULT"+hlint >& /dev/null || exit 200 # skip if there's no hlint -exit "$ERRORSTATUS"+wd="`pwd`"+cd ..+hlint --hint=contrib/darcs-errors.hlint src
tests/issue1139-diff-last.sh view
@@ -14,7 +14,7 @@ echo newtext > foo darcs record -am 'modify foo' -darcs diff --store --last=1 > out1+darcs diff --store-in-mem --last=1 > out1 cat out1 grep text out1 grep foo out1
+ tests/issue1224_convert-darcs2-repository.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue1224 - Attempting to darcs convert a repository+## which is already in darcs-2 format leads to inconsistent result+##+## Copyright (C) 2009 Tomas Caithaml+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++# this test is not relevant for other than darcs 2 repositories+grep darcs-2 $HOME/.darcs/defaults || exit 200++. ../tests/lib++rm -rf R +darcs init --repo R++echo File contents > R/file.txt+darcs add R/file.txt --repodir R+darcs record --patch-name=add_file.txt --author=me --no-test -a --repodir R++# This should fail with repository already in darcs-2 format.+echo "I understand the consequences of my action" > ack+not darcs convert temp/repo-2 temp/repo-2-converted < ack++rm -rf R
+ tests/issue1300_record_delete-file.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+## Test for issue1300 - record --delete-file should only delete+## after a successful record+##+## Copyright (C) 2009 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.+cd R+touch f+darcs add f+# no test+touch log+echo 'no test' > f+darcs record -am f --logfile log --delete-logfile+test ! -e log+# passing test+touch log+darcs setpref test 'exit 0'+echo 'test pass' > f+darcs record -am f --test --logfile log --delete-logfile+test ! -e log+# failing test+touch log+darcs setpref test 'exit 1'+echo 'test fail' > f+not darcs record -am g --test --logfile log --delete-logfile+test -e log # should *not* be deleted+cd ..
+ tests/issue1392_authorspelling.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue1392 - .authorspelling processing.+##+## Copyright (C) 2009 Tomas Caithaml+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R                       # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.+cd R++echo 'Bad\, Jr. <a@a.net>, Foo' > .authorspellings+echo 'Example content.' > f+darcs record -lam 'Add f.' -A 'Foo'+darcs show authors | grep -q 'Bad, Jr\. <a@a.net>' ++echo 'Bad\, Jr. <a@a.net>,  ^Foo\, Jr\..*$' > .authorspellings+echo 'Ex. cont.' > f+darcs record -lam 'Change f.' -A 'Foo, Jr. <a@b.net>'+darcs show authors | tee output.txt | grep -q 'Bad, Jr\. <a@a.net>'++cd ..++#--rm -rf R
+ tests/issue142_record-log.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash+## Test for issue142 - darcs record --logfile foo should not+## let you record a patch even when 'foo' is a missing file+##+## Copyright (C) 2009 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.+cd R+touch f g+touch log+darcs     record -alm f --logfile log     f+not darcs record -alm g --logfile missing g
tests/issue1465_ortryrunning.sh view
@@ -32,11 +32,12 @@ # Set the editor to a program that just fails (VISUAL), make Darcs use # it (--edit), and then make sure when it brokenly launches a fallback # editor, that editor will exit because stdin isn't a tty (/dev/null).-not env -u TERM VISUAL=false </dev/null &>R/log \+not env -u TERM DARCS_EDITOR=false VISUAL=false </dev/null &>R/log \ darcs record    --repo R -lam 'Initial commit.' --edit  # If Darcs did the right thing, the output won't make any mention of # the fallback editors.-not egrep -i 'not found|vi|emacs|nano|edit' R/log+# We skip ^\+ since the commandline is logged and matches "edit".+egrep -v '^\+' R/log | not egrep -i 'not found|vi|emacs|nano|edit'  rm -rf R/                       # Clean up after ourselves.
+ tests/issue1472_read_too_much.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue1472 - running "darcs record ./foo" shouldn't even+## TRY to read ./bar.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repo.+mkdir R/d/                      # Change the working tree.+echo 'Example content.' >R/f+echo 'Similar content.' >R/d/f+chmod 0 R/f                     # Make R/f unreadable, so that+                                # attempting to read it will result in+                                # an error.+darcs record    --repo R -lam 'Only changes to R/d/.' d+rm -rf R/                       # Clean up after ourselves.
+ tests/issue1488_whatsnew-l.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash+## Test for issue1488 - whatsnew in non-added directory crashes on fromJust+##+## Copyright (C) 2009  Marnix Klooster <marnix.klooster@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.++. ../tests/lib                  # Load some portability helpers.+rm -rf R++mkdir -p R/Foo/Bar		# 2 directory levels needed+cd R+darcs init+cd Foo/Bar+# and now the real problem causer:+darcs whatsnew -l .		# a "fromJust error" in Whatsnew.lhs
+ tests/issue1584_optimize_upgrade.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash+## Test for issue1584 - darcs optimize --upgrade+##+## Copyright (C) 2009 Eric Kow <kowey@darcs.net>+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R --old-fashioned # Create our test repos.+mkdir R/d/ R/e/                 # Change the working tree.+echo 'Example content.' >R/d/f+darcs record    --repo R -lam 'Add d/f and e.'+darcs mv        --repo R d/f e/  # Unrecorded change+darcs whatsnew  --repo R | grep 'move ./d/f'+darcs optimize  --repo R --upgrade+darcs check     --repo R+grep hashed R/_darcs/format+not grep darcs-2 R/_darcs/format+darcs whatsnew  --repo R | grep 'move ./d/f'
+ tests/issue1618-amend-preserve-logfile.sh view
@@ -0,0 +1,44 @@+#!/usr/bin/env bash+## Test for issue1618 - amend should preserve the logfile+##                      in case of failure+##+## Copyright (C) 2009 Kamil Dworakowski+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++set -ev+. ../tests/lib+rm -rf R; mkdir R; cd R++darcs init+darcs setpref test false+darcs record  -am foo --no-test+export DARCS_EDITOR="echo 'new log' > "+echo y | not darcs amend -p foo --edit-long-comment 2> out++# the msg has the format: "Logfile left in filenamehere."+LOGFILE=`grep "Logfile left in" out | sed "s/Logfile left in //" | sed s/.$//`++echo $LOGFILE+test -e "$LOGFILE"+grep 'new log' $LOGFILE++rm out; cd ..; rm -rf R/
+ tests/issue1620-record-lies-about-leaving-logfile.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+## Test for issue1620 - record does not really leave logfile+##                      after a failure+##+## Copyright (C) 2009 Kamil Dworakowski+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++set -ev+. ../tests/lib+rm -rf R; mkdir R; cd R+export DARCS_EDITOR="echo 'a log' > "+darcs init+darcs setpref test false+echo yy | not darcs record -m foo -a --edit-long-comment 2> out++# the msg has the format: "Logfile left in filenamehere."+LOGFILE=`grep "Logfile left in" out | sed "s/Logfile left in //" | sed s/.$//`+test -e "$LOGFILE"+grep 'a log' $LOGFILE++rm out+cd ..+rm -rf R/
+ tests/issue1636-match-hunk.sh view
@@ -0,0 +1,56 @@+#!/usr/bin/env bash+## Test for issue1636 - primitive match type: hunk+##+## Copyright (C) Kamil Dworakowski+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R+darcs init      --repo R        # Create our test repos.++cd R+echo 'first line' > f+darcs record -lam 'one'+echo 'second line' >> f+darcs record -am 'two'++darcs changes --match 'hunk first' > log+grep one log+not grep two log++darcs changes --match 'hunk line' > log+grep one log+grep two log++darcs changes --match 'hunk one' > log+not grep one log++# test searching for lines in the remove part of the hunk+echo 'first line' > f++darcs record -am 'three'+darcs changes --match 'hunk second' > log++grep three log+grep two log+not grep first log+
+ tests/issue27.sh view
@@ -0,0 +1,43 @@+#!/bin/sh++set -ev++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1+darcs init+echo first > a+darcs add a+darcs record --pipe --all --patch-name=first <<EOF+Thu Sep 18 22:37:06 MSD 2008+author+EOF++echo first > b+darcs add b+darcs record --pipe --all --patch-name=first <<EOF+Thu Sep 18 22:37:06 MSD 2008+author+EOF++cd ../temp2+darcs init+darcs pull --all --dont-allow-conflicts ../temp1+echo second >> a+darcs record --pipe --all --patch-name=second <<EOF+Thu Sep 18 22:37:07 MSD 2008+author+EOF++cd ../temp1+echo second >> b+darcs record --pipe --all --patch-name=second <<EOF+Thu Sep 18 22:37:07 MSD 2008+author+EOF++darcs pull --all --dont-allow-conflicts ../temp2+test `darcs changes --count` = "4"+cd ..++rm -rf temp1 temp2
+ tests/issue942_push_apply_prehook.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+## Test for issue942 - remote apply prehook not invoked on darcs push+## We also test for posthooks along the way even though that's not part+## of the issue.+##+## Copyright (C) 2009 Eric Kow <kowey@darcs.net>+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.+echo 'apply prehook touch g' >R/_darcs/prefs/defaults+echo 'apply posthook touch h' >>R/_darcs/prefs/defaults+darcs get R S+cd S+touch f+darcs add f+darcs record -lam 'Add f'+test ! -e ../R/g+test ! -e ../R/h+darcs push -a+test -e ../R/g+test -e ../R/h
tests/lib view
@@ -1,5 +1,5 @@ # This is a -*- sh -*- library.-set -ev+set -vex  ## I would use the builtin !, but that has the wrong semantics. not () { "$@" && exit 1 || :; }@@ -8,11 +8,30 @@ abort_windows () { if echo $OS | grep -i windows; then   echo This test does not work on Windows-  exit 0+  exit 200 fi }  pwd() {     ghc --make "$TESTS_WD/hspwd.hs"     "$TESTS_WD/hspwd"+}++# switch locale to latin9 if supported if there's a locale command, skip test+# otherwise+switch_to_latin9_locale () {+    if ! which locale ; then+        echo "no locale command"+        exit 200 # skip test+    fi++    latin9_locale=`locale -a | grep @euro | head -n 1`+    if [ -z "$latin9_locale" ]; then+            echo "no latin9 locale found"+            exit 200 # skip, we can't switch away from UTF-8+    fi++    echo "Using locale $latin9_locale"+    export LC_ALL=$latin9_locale+    echo "character encoding is now `locale charmap`" }
+ tests/nfs-failure.sh view
@@ -0,0 +1,35 @@+#!/bin/sh++set -ev++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo first > a+darcs add a+darcs record --pipe --all --patch-name=first <<EOF+Thu Sep 18 22:37:06 MSD 2008+author+EOF++echo first > b+darcs add b+darcs record --pipe --all --patch-name=first <<EOF+Thu Sep 18 22:37:06 MSD 2008+author+EOF++# it seems that somehow the following occasionally fails on an nfs+# filesystem when darcs is compiled with ghc 6.6.++darcs get . ../temp2++# it fails with something like:++# darcs: ./_darcs/patches/20080918223706-f64cd-6b512400a8108808b7ba7057f0eac2adf473b3ae.gz: copyFile: resource busy (file is locked)+++cd ..++rm -rf temp1 temp2
tests/partial.sh view
@@ -1,5 +1,8 @@ #!/usr/bin/env bash +exit 200 # checkpoint creation is not supported by current darcs+         # we would need a testdata tarball for this test+ # A partial get of a repo shall have the same _darcs/pristine as the original  set -ev
tests/pending_has_conflicts.sh view
@@ -22,8 +22,7 @@ write_buggy_pending  echo now watch the fireworks as all sorts of things fail-not darcs whatsnew &> out-cat out+not darcs whatsnew 2>&1 | tee out grep 'pending has conflicts' out  echo pending should now be fixed but there are no changes@@ -31,8 +30,7 @@  write_buggy_pending -darcs revert -a &> out-cat out+darcs revert -a 2>&1 | tee out grep 'pending has conflicts' out  echo pending should now be emptied@@ -40,22 +38,19 @@  write_buggy_pending -darcs record -a -m foo &> out-cat out+darcs record -a -m foo 2>&1 | tee out grep 'pending has conflicts' out  darcs record -a -m foo  darcs changes -v -darcs repair &> out-cat out+darcs repair 2>&1 | tee out grep 'The repository is already consistent' out  write_buggy_pending -darcs repair &> out-cat out+darcs repair 2>&1 | tee out grep 'The repository is already consistent' out  cd ..
+ tests/pull_conflicts.sh view
@@ -0,0 +1,57 @@+#!/usr/bin/env bash+## Test that pull --skip-conflicts filters the conflicts+## appropriately.+##+## Copyright (C) 2009 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.++mkdir R+cd R+darcs init+echo 'foo' > foo+echo 'bar' > bar+darcs rec -lam 'Add foo and bar'+cd ..++darcs get R S++cd R+echo 'foo2' > foo+darcs rec -lam 'Change foo (2)'+echo 'bar2' > bar+darcs rec -lam 'Change bar (2)'+cd ..++cd S+echo 'foo3' > foo+darcs rec -lam 'Change foo (3)'+darcs pull --skip-conflicts -a ../R+test `darcs changes --count` -eq 3+cd ..++cd S+darcs pull -a ../R+test `darcs changes --count` -eq 4+cd ..
tests/push-formerly-pl.sh view
@@ -4,6 +4,14 @@  . lib +slash() {+if echo $OS | grep -q -i windows; then+    echo -n \\+else+    echo -n /+fi+}+ DIR="`pwd`"  rm -rf temp1 temp2@@ -40,7 +48,7 @@ # Before trying to pull from self, defaultrepo does not exist test ! -e _darcs/prefs/defaultrepo # return special message when you try to push to yourself-not darcs push -a "$DIR/temp1" 2> log+not darcs push -a "$DIR`slash`temp1" 2> log grep -i "cannot push from repository to itself" log # and don't update the default repo to be the current dir test ! -e _darcs/prefs/defaultrepo
+ tests/push_conflicts.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash+## Test that apply --skip-conflicts filters the conflicts+## appropriately.+##+## Copyright (C) 2009 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.++mkdir R+cd R+darcs init+echo 'foo' > foo+echo 'bar' > bar+darcs rec -lam 'Add foo and bar'+cd ..++darcs get R S++cd R+echo 'foo2' > foo+darcs rec -lam 'Change foo (2)'+echo 'bar2' > bar+darcs rec -lam 'Change bar (2)'+cd ..++cd S+echo 'foo3' > foo+darcs rec -lam 'Change foo (3)'+cd ..++cd R+darcs send -a ../S -o ../S/applyme.dpatch+cd ..++cd S+darcs apply --skip-conflicts applyme.dpatch+test `darcs changes --count` -eq 3+cd ..
+ tests/remove.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+##+## Copyright (C) 2009  Roman Plasil+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.++cd R+mkdir d e                       # Change the working tree.+mkdir d/f d/f/g+echo 'Example content.' > d/f/1.txt+echo 'Example content.' > d/f/g/2.txt+echo 'Example content.' > e/3.txt++darcs add -r .+darcs wh -s > before.lst+grep -i d before.lst +grep -i e before.lst+grep -i d/f before.lst++darcs remove -r d+darcs wh -s > after.lst+not grep -i d after.lst +not grep -i d/f after.lst+not grep -i d/f/g after.lst+not grep -i d/f/g/2.txt after.lst+not grep -i d/f/1.txt after.lst++cd ..
tests/repair-corrupt.sh view
@@ -15,6 +15,7 @@  hashed=false test -e _darcs/hashed_inventory && hashed=true+cp -R _darcs _clean_darcs  # produce a corrupt patch echo 'rmfile foo' > _darcs/patches/pending@@ -22,6 +23,11 @@ darcs rec -a -m 'remove foo'  not darcs check # unapplicable patch!+cp -R _darcs/ _backup_darcs+darcs repair # repairs the patch+darcs check+rm -rf _darcs+mv _backup_darcs _darcs # get the bad patch back  # stash away contents of _darcs cp -R _darcs/ _backup_darcs@@ -30,15 +36,18 @@ darcs rec -a -m 'here'  # corrupt pristine content-$hashed && inv=`grep ^pristine _darcs/hashed_inventory`-cp _backup_darcs/patches/* _darcs/patches/-cp _backup_darcs/*inventory* _darcs/-$hashed && {-    cp _darcs/hashed_inventory hashed.tmp-    sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory-    rm hashed.tmp+corrupt_pristine() {+    $hashed && inv=`grep ^pristine _darcs/hashed_inventory`+    cp _backup_darcs/patches/* _darcs/patches/+    cp _backup_darcs/*inventory* _darcs/+    if $hashed; then+        cp _darcs/hashed_inventory hashed.tmp+        sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory+        rm hashed.tmp+    fi } +corrupt_pristine not darcs check # just a little paranoia  darcs repair # repair succeeds@@ -49,5 +58,11 @@ echo foo > foobar1 diff foobar foobar1 +rm -rf _backup_darcs+mv _clean_darcs _backup_darcs+corrupt_pristine # without the unapplicable patch+not darcs check+darcs repair+darcs check+ cd ..-rm -rf bad
+ tests/repos/old-with-checkpoint.tgz view

binary file changed (absent → 3053 bytes)

tests/show_contents.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. lib  rm -rf temp1 mkdir temp1@@ -21,6 +21,8 @@ darcs show contents foo -p third | grep third darcs show contents foo --match="author author1" first | grep first darcs show contents foo --tag t1 | grep second+not darcs show contents foo --match "hash bla" 2>&1 | tee out+grep "Couldn't match pattern" out cd ..  rm -rf temp1
+ tests/tentative_revert.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash+## Test for clearing tentative state after a failed transaction+##+## Copyright (C) 2009  Kamil Dworakowski+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++set -ev+. ../tests/lib+rm -rf R+darcs init      --repo R+touch R/foo+darcs record    --repo R -lam 'foo'+touch R/bar+darcs record    --repo R -lam 'bar'+echo "this change should stay uncommitted" >> R/foo+darcs setpref   --repo R test false+echo 'y' | not darcs amend --repo R -am 'change everything' R/foo+darcs setpref   --repo R test true++# if tentative state was not cleared, the previous changes+# from failed transaction would piggy back on the next+echo "xx" >> R/bar+echo 'y' | darcs amend     --repo R -am 'bar2' R/bar++# should have uncommitted changes+darcs wh      --repo R > changes+grep "this change should stay uncommitted" changes
+ tests/trailing-newlines.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+. lib++rm -rf temp && mkdir temp+cd temp+darcs init+echo -n > no_newline+echo -n > newline++darcs rec -lam "empty"++echo -n foo > no_newline+echo foo > newline++wc -l no_newline | grep 0+wc -l newline | grep 1++darcs wh > diff1+darcs rec -am "add bits"+darcs revert -a | grep "no changes"++echo -n > no_newline+echo -n > newline++darcs wh > diff2+darcs rec -lam "bar"++darcs revert -a | grep "no changes"+darcs check++cat > diff1.expected <<EOF+hunk ./newline 1++foo+hunk ./no_newline 1+-++foo+EOF++cat > diff2.expected <<EOF+hunk ./newline 1+-foo+hunk ./no_newline 1+-foo+++EOF++diff -u diff1.expected diff1+diff -u diff2.expected diff2++cd .. && rm -rf temp
tests/unrecord.sh view
@@ -2,6 +2,9 @@  set -ev +exit 200 # checkpoint creation is not supported by current darcs+         # we would need a testdata tarball for this test+ # Check that checkpoints are removed when tags are unrecorded  rm -rf temp1