packages feed

darcs 2.3.1 → 2.4

raw patch · 251 files changed

+12183/−10399 lines, 251 filesdep ~arraydep ~containersdep ~hashed-storagesetup-changedbinary-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++DARCS = dist/build/darcs/darcs+PREPROC=./dist/build/darcs/darcs --preprocess-manual+PREPROCHTML=--html+TEXSOURCES = src/darcs.tex $(wildcard src/*.tex) $(filter %.lhs,$(DARCS_FILES))+doc/manual/darcs.tex: $(TEXSOURCES) $(DARCS)+	$(PREPROC) darcs.tex $(PREPROCHTML) >$@+doc/manual/darcs_print.tex: $(TEXSOURCES) $(DARCS)+	$(PREPROC) darcs.tex >$@+doc/manual/patch-theory.tex: $(TEXSOURCES) $(UNIT_FILES) $(DARCS)+	$(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
README view
@@ -31,6 +31,7 @@ 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"@@ -55,11 +56,11 @@ 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
@@ -5,10 +5,12 @@  import Distribution.Simple          ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.ModuleName( toFilePath ) import Distribution.PackageDescription          ( PackageDescription(executables), Executable(buildInfo, exeName)          , BuildInfo(customFieldsBI), emptyBuildInfo-         , updatePackageDescription, cppOptions, ccOptions )+         , updatePackageDescription, cppOptions, ccOptions+         , library, libBuildInfo, otherModules ) import Distribution.Package          ( packageVersion ) import Distribution.Version@@ -42,7 +44,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 +101,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@@ -108,8 +110,13 @@     y <- context verb pkgVer     rewriteFile "release/distributed-version" $ show x     rewriteFile "release/distributed-context" $ show y+    putStrLn "about to hand over"+    let pkg' = pkg { library = sanity (library pkg) }+        sanity (Just lib) = Just $ lib { libBuildInfo = sanity' $ libBuildInfo lib }+        sanity _ = error "eh"+        sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] } -    sDistHook simpleUserHooks pkg lbi hooks flags+    sDistHook simpleUserHooks pkg' lbi hooks flags }  -- | For @./Setup build@ and @./Setup haddock@, do some unusual@@ -117,17 +124,13 @@ commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a)                 -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a commonBuildHook runHook pkg lbi hooks verbosity = do-  -- Autoconf may have generated a context file.  Remove it before-  -- building, as its existence inexplicably breaks Cabal.-  removeFile "src/Context.hs"-    `catch` (\e -> unless (isDoesNotExistError e) (ioError e))+  (version, state) <- determineVersion verbosity pkg    -- Create our own context file.-  writeGeneratedModules verbosity pkg lbi+  generateVersionModule verbosity pkg lbi version state    -- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c)   -- invocations, doing a dance to make the base hook aware of them.-  (version, state) <- determineVersion verbosity pkg   littleEndian <- testEndianness   let args = ("-DPACKAGE_VERSION=" ++ show' version) :              ("-DPACKAGE_VERSION_STATE=" ++ show' state) :@@ -168,14 +171,6 @@               (mandir (absoluteInstallDirs pkg lbi copy) </> "man1")               [(buildDir lbi </> "darcs", "darcs.1")] -writeGeneratedModules :: Verbosity-                      -> PackageDescription -> LocalBuildInfo -> IO ()-writeGeneratedModules verbosity pkg lbi = do-  createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)--  let contextModulePath = autogenModulesDir lbi </> "Context.hs"-  generateContextModule verbosity contextModulePath pkg- determineVersion :: Verbosity -> PackageDescription -> IO (String, String) determineVersion verbosity pkg = do   let darcsVersion  =  packageVersion pkg@@ -216,12 +211,16 @@  where   versionFile = "release/distributed-version" -generateContextModule :: (Package pkg) => Verbosity -> FilePath -> pkg -> IO ()-generateContextModule verbosity targetFile pkg = do+generateVersionModule :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> String -> String -> IO ()+generateVersionModule verbosity pkg lbi version state = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir   ctx <- context verbosity (packageVersion pkg)-  rewriteFile targetFile $ unlines-    ["module Context where"-    ,"context :: String"+  rewriteFile (dir </> "Version.hs") $ unlines+    ["module Version where"+    ,"version, context :: String"+    ,"version = \"" ++ version ++ " (" ++ state ++ ")\""     ,"context = " ++ case ctx of                        Just x -> show x                        Nothing -> show "context not available"@@ -263,36 +262,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 +307,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.cabal view
@@ -1,5 +1,5 @@ Name:           darcs-version:        2.3.1+version:        2.4 License:        GPL License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-users@darcs.net>@@ -44,13 +44,12 @@   -- 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/images.tex, doc/manual/bigimages.tex, doc/manual/patch-theory.tex,+  doc/darcs.css    README, NEWS @@ -65,8 +64,9 @@   tests/network/*.sh   tests/lib   tests/example_binary.png-  bugs/*.sh +  GNUmakefile+ source-repository head   type:     darcs   location: http://darcs.net/@@ -83,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@@ -112,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@@ -120,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@@ -205,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@@ -224,6 +230,7 @@                     Darcs.Patch.Match                     Darcs.Patch.MatchData                     Darcs.Patch.Non+                    Darcs.Patch.OldDate                     Darcs.Patch.Patchy                     Darcs.Patch.Permutations                     Darcs.Patch.Prim@@ -231,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@@ -250,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@@ -274,21 +287,18 @@                     HTTP                     IsoDate                     Lcs-                    OldDate                     Printer                     Progress-                    RegChars+                    Ratified                     SHA1                     Ssh                     URL-                    UTF8                     Workaround -  other-modules:    ThisVersion+  other-modules:    Version    c-sources:        src/atomic_create.c                     src/fpstring.c-                    src/c_compat.c                     src/maybe_relink.c                     src/umask.c                     src/Crypt/sha2.c@@ -313,23 +323,29 @@                    html         == 1.0.*,                    filepath     == 1.1.*,                    haskeline    >= 0.6.1 && < 0.7,-                   hashed-storage >= 0.3.8 && < 0.4+                   hashed-storage >= 0.4.7 && < 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@@ -349,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)@@ -387,6 +391,7 @@     UndecidableInstances,     DeriveDataTypeable,     GADTs,+    ImpredicativeTypes,     TypeOperators,     ExistentialQuantification,     FlexibleContexts,@@ -409,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)@@ -444,17 +453,19 @@                    html         == 1.0.*,                    filepath     == 1.1.*,                    haskeline    >= 0.6.1 && < 0.7,-                   hashed-storage >= 0.3.8 && < 0.4+                   hashed-storage >= 0.4.4 && < 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)@@ -476,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)@@ -514,6 +513,7 @@     UndecidableInstances,     DeriveDataTypeable,     GADTs,+    ImpredicativeTypes,     TypeOperators,     ExistentialQuantification,     FlexibleContexts,@@ -536,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@@ -562,9 +563,6 @@                      test-framework-quickcheck2 >= 0.2.2  -  if !flag(zlib)-    extra-libraries:  z-   cc-options:       -D_REENTRANT    if os(windows)@@ -581,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/bigimages.tex view
@@ -0,0 +1,605 @@+\batchmode+++\documentclass{book}+\RequirePackage{ifthen}+++++\usepackage{verbatim}+\usepackage{html}+\usepackage{fancyvrb}++%+\newenvironment{code}{\comment}{\endcomment} +++++\usepackage[dvips]{color}+++\pagecolor[gray]{.7}++\usepackage[latin1]{inputenc}++++\makeatletter++\makeatletter+\count@=\the\catcode`\_ \catcode`\_=8 +\newenvironment{tex2html_wrap}{}{}%+\catcode`\<=12\catcode`\_=\count@+\newcommand{\providedcommand}[1]{\expandafter\providecommand\csname #1\endcsname}%+\newcommand{\renewedcommand}[1]{\expandafter\providecommand\csname #1\endcsname{}%+  \expandafter\renewcommand\csname #1\endcsname}%+\newcommand{\newedenvironment}[1]{\newenvironment{#1}{}{}\renewenvironment{#1}}%+\let\newedcommand\renewedcommand+\let\renewedenvironment\newedenvironment+\makeatother+\let\mathon=$+\let\mathoff=$+\ifx\AtBeginDocument\undefined \newcommand{\AtBeginDocument}[1]{}\fi+\newbox\sizebox+\setlength{\hoffset}{0pt}\setlength{\voffset}{0pt}+\addtolength{\textheight}{\footskip}\setlength{\footskip}{0pt}+\addtolength{\textheight}{\topmargin}\setlength{\topmargin}{0pt}+\addtolength{\textheight}{\headheight}\setlength{\headheight}{0pt}+\addtolength{\textheight}{\headsep}\setlength{\headsep}{0pt}+\setlength{\textwidth}{349pt}+\newwrite\lthtmlwrite+\makeatletter+\let\realnormalsize=\normalsize+\global\topskip=2sp+\def\preveqno{}\let\real@float=\@float \let\realend@float=\end@float+\def\@float{\let\@savefreelist\@freelist\real@float}+\def\liih@math{\ifmmode$\else\bad@math\fi}+\def\end@float{\realend@float\global\let\@freelist\@savefreelist}+\let\real@dbflt=\@dbflt \let\end@dblfloat=\end@float+\let\@largefloatcheck=\relax+\let\if@boxedmulticols=\iftrue+\def\@dbflt{\let\@savefreelist\@freelist\real@dbflt}+\def\adjustnormalsize{\def\normalsize{\mathsurround=0pt \realnormalsize+ \parindent=0pt\abovedisplayskip=0pt\belowdisplayskip=0pt}%+ \def\phantompar{\csname par\endcsname}\normalsize}%+\def\lthtmltypeout#1{{\let\protect\string \immediate\write\lthtmlwrite{#1}}}%+\newcommand\lthtmlhboxmathA{\adjustnormalsize\setbox\sizebox=\hbox\bgroup\kern.05em }%+\newcommand\lthtmlhboxmathB{\adjustnormalsize\setbox\sizebox=\hbox to\hsize\bgroup\hfill }%+\newcommand\lthtmlvboxmathA{\adjustnormalsize\setbox\sizebox=\vbox\bgroup %+ \let\ifinner=\iffalse \let\)\liih@math }%+\newcommand\lthtmlboxmathZ{\@next\next\@currlist{}{\def\next{\voidb@x}}%+ \expandafter\box\next\egroup}%+\newcommand\lthtmlmathtype[1]{\gdef\lthtmlmathenv{#1}}%+\newcommand\lthtmllogmath{\dimen0\ht\sizebox \advance\dimen0\dp\sizebox+  \ifdim\dimen0>.95\vsize+   \lthtmltypeout{%+*** image for \lthtmlmathenv\space is too tall at \the\dimen0, reducing to .95 vsize ***}%+   \ht\sizebox.95\vsize \dp\sizebox\z@ \fi+  \lthtmltypeout{l2hSize %+:\lthtmlmathenv:\the\ht\sizebox::\the\dp\sizebox::\the\wd\sizebox.\preveqno}}%+\newcommand\lthtmlfigureA[1]{\let\@savefreelist\@freelist+       \lthtmlmathtype{#1}\lthtmlvboxmathA}%+\newcommand\lthtmlpictureA{\bgroup\catcode`\_=8 \lthtmlpictureB}%+\newcommand\lthtmlpictureB[1]{\lthtmlmathtype{#1}\egroup+       \let\@savefreelist\@freelist \lthtmlhboxmathB}%+\newcommand\lthtmlpictureZ[1]{\hfill\lthtmlfigureZ}%+\newcommand\lthtmlfigureZ{\lthtmlboxmathZ\lthtmllogmath\copy\sizebox+       \global\let\@freelist\@savefreelist}%+\newcommand\lthtmldisplayA{\bgroup\catcode`\_=8 \lthtmldisplayAi}%+\newcommand\lthtmldisplayAi[1]{\lthtmlmathtype{#1}\egroup\lthtmlvboxmathA}%+\newcommand\lthtmldisplayB[1]{\edef\preveqno{(\theequation)}%+  \lthtmldisplayA{#1}\let\@eqnnum\relax}%+\newcommand\lthtmldisplayZ{\lthtmlboxmathZ\lthtmllogmath\lthtmlsetmath}%+\newcommand\lthtmlinlinemathA{\bgroup\catcode`\_=8 \lthtmlinlinemathB}+\newcommand\lthtmlinlinemathB[1]{\lthtmlmathtype{#1}\egroup\lthtmlhboxmathA+  \vrule height1.5ex width0pt }%+\newcommand\lthtmlinlineA{\bgroup\catcode`\_=8 \lthtmlinlineB}%+\newcommand\lthtmlinlineB[1]{\lthtmlmathtype{#1}\egroup\lthtmlhboxmathA}%+\newcommand\lthtmlinlineZ{\egroup\expandafter\ifdim\dp\sizebox>0pt %+  \expandafter\centerinlinemath\fi\lthtmllogmath\lthtmlsetinline}+\newcommand\lthtmlinlinemathZ{\egroup\expandafter\ifdim\dp\sizebox>0pt %+  \expandafter\centerinlinemath\fi\lthtmllogmath\lthtmlsetmath}+\newcommand\lthtmlindisplaymathZ{\egroup %+  \centerinlinemath\lthtmllogmath\lthtmlsetmath}+\def\lthtmlsetinline{\hbox{\vrule width.1em \vtop{\vbox{%+  \kern.1em\copy\sizebox}\ifdim\dp\sizebox>0pt\kern.1em\else\kern.3pt\fi+  \ifdim\hsize>\wd\sizebox \hrule depth1pt\fi}}}+\def\lthtmlsetmath{\hbox{\vrule width.1em\kern-.05em\vtop{\vbox{%+  \kern.1em\kern0.8 pt\hbox{\hglue.17em\copy\sizebox\hglue0.8 pt}}\kern.3pt%+  \ifdim\dp\sizebox>0pt\kern.1em\fi \kern0.8 pt%+  \ifdim\hsize>\wd\sizebox \hrule depth1pt\fi}}}+\def\centerinlinemath{%+  \dimen1=\ifdim\ht\sizebox<\dp\sizebox \dp\sizebox\else\ht\sizebox\fi+  \advance\dimen1by.5pt \vrule width0pt height\dimen1 depth\dimen1 + \dp\sizebox=\dimen1\ht\sizebox=\dimen1\relax}++\def\lthtmlcheckvsize{\ifdim\ht\sizebox<\vsize +  \ifdim\wd\sizebox<\hsize\expandafter\hfill\fi \expandafter\vfill+  \else\expandafter\vss\fi}%+\providecommand{\selectlanguage}[1]{}%+\makeatletter \tracingstats = 1 +++\begin{document}+\pagestyle{empty}\thispagestyle{empty}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength hsize=\the\hsize}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength vsize=\the\vsize}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength hoffset=\the\hoffset}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength voffset=\the\voffset}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength topmargin=\the\topmargin}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength topskip=\the\topskip}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength headheight=\the\headheight}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength headsep=\the\headsep}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength parskip=\the\parskip}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength oddsidemargin=\the\oddsidemargin}\lthtmltypeout{}%+\makeatletter+\if@twoside\lthtmltypeout{latex2htmlLength evensidemargin=\the\evensidemargin}%+\else\lthtmltypeout{latex2htmlLength evensidemargin=\the\oddsidemargin}\fi%+\lthtmltypeout{}%+\makeatother+\setcounter{page}{1}+\onecolumn++% !!! IMAGES START HERE !!!++\stepcounter{chapter}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{chapter}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2771}%+$<$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2773}%+$>$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{paragraph}+\stepcounter{chapter}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{section}+\stepcounter{chapter}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2775}%+$+$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2777}%+$R_{c}$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2779}%+$f_1$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2781}%+$R_c$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2783}%+$R_1$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2787}%+$f_2$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2795}%+$R_2$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2835}%+$R_p$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2839}%+$R_l$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{chapter}+\stepcounter{chapter}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{subsection}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2841}%+$\backslash$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2847}%+$ R_1 \bigcup R_2+\bigcup R_3 \ldots$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2849}%+$ R_1 \bigcap R_2 \bigcap R_3 \ldots$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2851}%+$ S+\backslash S \rightarrow \emptyset $%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2853}%+$ R_1+\backslash (R_2 \bigcup R_3 \bigcup \ldots$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}++%+\providecommand{\pullwarning}[1]{+\textbf{WARNING:} #1 should not be run when there is a possibility+that another user may be pulling from the same repository.  Attempting to do so+may cause repository corruption.}%++\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsubsection}+\stepcounter{subsection}+\appendix+\stepcounter{section}+\stepcounter{paragraph}+++\addtolength{\itemsep}{-0.5\baselineskip}%++\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+++\addtolength{\itemsep}{-0.5\baselineskip}%++\stepcounter{paragraph}+\stepcounter{chapter}+\stepcounter{section}+\stepcounter{section}+\stepcounter{chapter}+++\newtheorem{thm}{Theorem}%++++\newtheorem{dfn}{Definition}%++\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2863}%+$P_1$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2865}%+$P_2$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2867}%+$P_2P_1$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2873}%+$P_1\parallel P_2$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2875}%+$P^{ -1}$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2877}%+$P$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2759}%+\( P^{ -1} P \)%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmldisplayA{displaymath2763}%+\begin{displaymath} (P_2 P_1)^{ -1} = P_1^{ -1} P_2^{ -1}. \end{displaymath}%+\lthtmldisplayZ+\lthtmlcheckvsize\clearpage}++\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{subsection}+\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2881}%+$O(n)$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{section}+\stepcounter{subsection}++%+\providecommand{\commutex}{\longleftrightarrow}%+++%+\providecommand{\commutes}{\longleftrightarrow}%++{\newpage\clearpage+\lthtmldisplayA{displaymath2764}%+\begin{displaymath} P_2 P_1 \longleftrightarrow {P_1}' {P_2}'. \end{displaymath}%+\lthtmldisplayZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2887}%+$P_1'$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2893}%+$P_2'$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2897}%+$\longleftrightarrow $%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2899}%+$==$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2901}%+$\ddot\frown$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{paragraph}++%+\providecommand{\merge}{\Longrightarrow}%++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2760}%+\( \Longrightarrow \)%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmldisplayA{displaymath2765}%+\begin{displaymath}  P_2 \parallel P_1 \Longrightarrow {P_2}' P_1 \longleftrightarrow {P_1}' P_2. \end{displaymath}%+\lthtmldisplayZ+\lthtmlcheckvsize\clearpage}++\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2911}%+$ P_2' P_1 \longleftrightarrow P_1' P_2 $%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2913}%+$ P_1'^{ -1}+P_2' \longleftrightarrow P_2 P_1^{ -1} $%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2915}%+$P_1'^{ -1}$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2917}%+$P_1^{ -1}$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmldisplayA{displaymath2766}%+\begin{displaymath}+A^{ -1} C \longleftrightarrow C' A'^{ -1}+\end{displaymath}%+\lthtmldisplayZ+\lthtmlcheckvsize\clearpage}++\stepcounter{section}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{chapter}+\stepcounter{chapter}+\addtocounter{enumi}{-1}+\stepcounter{section}++\end{document}
+ doc/manual/images.tex view
@@ -0,0 +1,605 @@+\batchmode+++\documentclass{book}+\RequirePackage{ifthen}+++++\usepackage{verbatim}+\usepackage{html}+\usepackage{fancyvrb}++%+\newenvironment{code}{\comment}{\endcomment} +++++\usepackage[dvips]{color}+++\pagecolor[gray]{.7}++\usepackage[latin1]{inputenc}++++\makeatletter++\makeatletter+\count@=\the\catcode`\_ \catcode`\_=8 +\newenvironment{tex2html_wrap}{}{}%+\catcode`\<=12\catcode`\_=\count@+\newcommand{\providedcommand}[1]{\expandafter\providecommand\csname #1\endcsname}%+\newcommand{\renewedcommand}[1]{\expandafter\providecommand\csname #1\endcsname{}%+  \expandafter\renewcommand\csname #1\endcsname}%+\newcommand{\newedenvironment}[1]{\newenvironment{#1}{}{}\renewenvironment{#1}}%+\let\newedcommand\renewedcommand+\let\renewedenvironment\newedenvironment+\makeatother+\let\mathon=$+\let\mathoff=$+\ifx\AtBeginDocument\undefined \newcommand{\AtBeginDocument}[1]{}\fi+\newbox\sizebox+\setlength{\hoffset}{0pt}\setlength{\voffset}{0pt}+\addtolength{\textheight}{\footskip}\setlength{\footskip}{0pt}+\addtolength{\textheight}{\topmargin}\setlength{\topmargin}{0pt}+\addtolength{\textheight}{\headheight}\setlength{\headheight}{0pt}+\addtolength{\textheight}{\headsep}\setlength{\headsep}{0pt}+\setlength{\textwidth}{349pt}+\newwrite\lthtmlwrite+\makeatletter+\let\realnormalsize=\normalsize+\global\topskip=2sp+\def\preveqno{}\let\real@float=\@float \let\realend@float=\end@float+\def\@float{\let\@savefreelist\@freelist\real@float}+\def\liih@math{\ifmmode$\else\bad@math\fi}+\def\end@float{\realend@float\global\let\@freelist\@savefreelist}+\let\real@dbflt=\@dbflt \let\end@dblfloat=\end@float+\let\@largefloatcheck=\relax+\let\if@boxedmulticols=\iftrue+\def\@dbflt{\let\@savefreelist\@freelist\real@dbflt}+\def\adjustnormalsize{\def\normalsize{\mathsurround=0pt \realnormalsize+ \parindent=0pt\abovedisplayskip=0pt\belowdisplayskip=0pt}%+ \def\phantompar{\csname par\endcsname}\normalsize}%+\def\lthtmltypeout#1{{\let\protect\string \immediate\write\lthtmlwrite{#1}}}%+\newcommand\lthtmlhboxmathA{\adjustnormalsize\setbox\sizebox=\hbox\bgroup\kern.05em }%+\newcommand\lthtmlhboxmathB{\adjustnormalsize\setbox\sizebox=\hbox to\hsize\bgroup\hfill }%+\newcommand\lthtmlvboxmathA{\adjustnormalsize\setbox\sizebox=\vbox\bgroup %+ \let\ifinner=\iffalse \let\)\liih@math }%+\newcommand\lthtmlboxmathZ{\@next\next\@currlist{}{\def\next{\voidb@x}}%+ \expandafter\box\next\egroup}%+\newcommand\lthtmlmathtype[1]{\gdef\lthtmlmathenv{#1}}%+\newcommand\lthtmllogmath{\dimen0\ht\sizebox \advance\dimen0\dp\sizebox+  \ifdim\dimen0>.95\vsize+   \lthtmltypeout{%+*** image for \lthtmlmathenv\space is too tall at \the\dimen0, reducing to .95 vsize ***}%+   \ht\sizebox.95\vsize \dp\sizebox\z@ \fi+  \lthtmltypeout{l2hSize %+:\lthtmlmathenv:\the\ht\sizebox::\the\dp\sizebox::\the\wd\sizebox.\preveqno}}%+\newcommand\lthtmlfigureA[1]{\let\@savefreelist\@freelist+       \lthtmlmathtype{#1}\lthtmlvboxmathA}%+\newcommand\lthtmlpictureA{\bgroup\catcode`\_=8 \lthtmlpictureB}%+\newcommand\lthtmlpictureB[1]{\lthtmlmathtype{#1}\egroup+       \let\@savefreelist\@freelist \lthtmlhboxmathB}%+\newcommand\lthtmlpictureZ[1]{\hfill\lthtmlfigureZ}%+\newcommand\lthtmlfigureZ{\lthtmlboxmathZ\lthtmllogmath\copy\sizebox+       \global\let\@freelist\@savefreelist}%+\newcommand\lthtmldisplayA{\bgroup\catcode`\_=8 \lthtmldisplayAi}%+\newcommand\lthtmldisplayAi[1]{\lthtmlmathtype{#1}\egroup\lthtmlvboxmathA}%+\newcommand\lthtmldisplayB[1]{\edef\preveqno{(\theequation)}%+  \lthtmldisplayA{#1}\let\@eqnnum\relax}%+\newcommand\lthtmldisplayZ{\lthtmlboxmathZ\lthtmllogmath\lthtmlsetmath}%+\newcommand\lthtmlinlinemathA{\bgroup\catcode`\_=8 \lthtmlinlinemathB}+\newcommand\lthtmlinlinemathB[1]{\lthtmlmathtype{#1}\egroup\lthtmlhboxmathA+  \vrule height1.5ex width0pt }%+\newcommand\lthtmlinlineA{\bgroup\catcode`\_=8 \lthtmlinlineB}%+\newcommand\lthtmlinlineB[1]{\lthtmlmathtype{#1}\egroup\lthtmlhboxmathA}%+\newcommand\lthtmlinlineZ{\egroup\expandafter\ifdim\dp\sizebox>0pt %+  \expandafter\centerinlinemath\fi\lthtmllogmath\lthtmlsetinline}+\newcommand\lthtmlinlinemathZ{\egroup\expandafter\ifdim\dp\sizebox>0pt %+  \expandafter\centerinlinemath\fi\lthtmllogmath\lthtmlsetmath}+\newcommand\lthtmlindisplaymathZ{\egroup %+  \centerinlinemath\lthtmllogmath\lthtmlsetmath}+\def\lthtmlsetinline{\hbox{\vrule width.1em \vtop{\vbox{%+  \kern.1em\copy\sizebox}\ifdim\dp\sizebox>0pt\kern.1em\else\kern.3pt\fi+  \ifdim\hsize>\wd\sizebox \hrule depth1pt\fi}}}+\def\lthtmlsetmath{\hbox{\vrule width.1em\kern-.05em\vtop{\vbox{%+  \kern.1em\kern0.8 pt\hbox{\hglue.17em\copy\sizebox\hglue0.8 pt}}\kern.3pt%+  \ifdim\dp\sizebox>0pt\kern.1em\fi \kern0.8 pt%+  \ifdim\hsize>\wd\sizebox \hrule depth1pt\fi}}}+\def\centerinlinemath{%+  \dimen1=\ifdim\ht\sizebox<\dp\sizebox \dp\sizebox\else\ht\sizebox\fi+  \advance\dimen1by.5pt \vrule width0pt height\dimen1 depth\dimen1 + \dp\sizebox=\dimen1\ht\sizebox=\dimen1\relax}++\def\lthtmlcheckvsize{\ifdim\ht\sizebox<\vsize +  \ifdim\wd\sizebox<\hsize\expandafter\hfill\fi \expandafter\vfill+  \else\expandafter\vss\fi}%+\providecommand{\selectlanguage}[1]{}%+\makeatletter \tracingstats = 1 +++\begin{document}+\pagestyle{empty}\thispagestyle{empty}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength hsize=\the\hsize}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength vsize=\the\vsize}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength hoffset=\the\hoffset}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength voffset=\the\voffset}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength topmargin=\the\topmargin}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength topskip=\the\topskip}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength headheight=\the\headheight}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength headsep=\the\headsep}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength parskip=\the\parskip}\lthtmltypeout{}%+\lthtmltypeout{latex2htmlLength oddsidemargin=\the\oddsidemargin}\lthtmltypeout{}%+\makeatletter+\if@twoside\lthtmltypeout{latex2htmlLength evensidemargin=\the\evensidemargin}%+\else\lthtmltypeout{latex2htmlLength evensidemargin=\the\oddsidemargin}\fi%+\lthtmltypeout{}%+\makeatother+\setcounter{page}{1}+\onecolumn++% !!! IMAGES START HERE !!!++\stepcounter{chapter}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{chapter}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2771}%+$<$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2773}%+$>$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{paragraph}+\stepcounter{chapter}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{section}+\stepcounter{chapter}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2775}%+$+$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2777}%+$R_{c}$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2779}%+$f_1$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2781}%+$R_c$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2783}%+$R_1$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2787}%+$f_2$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2795}%+$R_2$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2835}%+$R_p$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2839}%+$R_l$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{chapter}+\stepcounter{chapter}+\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{subsection}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2841}%+$\backslash$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2847}%+$ R_1 \bigcup R_2+\bigcup R_3 \ldots$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2849}%+$ R_1 \bigcap R_2 \bigcap R_3 \ldots$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2851}%+$ S+\backslash S \rightarrow \emptyset $%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2853}%+$ R_1+\backslash (R_2 \bigcup R_3 \bigcup \ldots$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}++%+\providecommand{\pullwarning}[1]{+\textbf{WARNING:} #1 should not be run when there is a possibility+that another user may be pulling from the same repository.  Attempting to do so+may cause repository corruption.}%++\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{subsubsection}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{subsubsection}+\stepcounter{subsection}+\appendix+\stepcounter{section}+\stepcounter{paragraph}+++\addtolength{\itemsep}{-0.5\baselineskip}%++\stepcounter{paragraph}+\stepcounter{section}+\stepcounter{paragraph}+++\addtolength{\itemsep}{-0.5\baselineskip}%++\stepcounter{paragraph}+\stepcounter{chapter}+\stepcounter{section}+\stepcounter{section}+\stepcounter{chapter}+++\newtheorem{thm}{Theorem}%++++\newtheorem{dfn}{Definition}%++\stepcounter{section}+\stepcounter{section}+\stepcounter{section}+\stepcounter{subsection}+\stepcounter{subsection}+\stepcounter{section}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2863}%+$P_1$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2865}%+$P_2$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2867}%+$P_2P_1$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2873}%+$P_1\parallel P_2$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2875}%+$P^{ -1}$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2877}%+$P$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2759}%+\( P^{ -1} P \)%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmldisplayA{displaymath2763}%+\begin{displaymath} (P_2 P_1)^{ -1} = P_1^{ -1} P_2^{ -1}. \end{displaymath}%+\lthtmldisplayZ+\lthtmlcheckvsize\clearpage}++\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{subsection}+\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2881}%+$O(n)$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{section}+\stepcounter{subsection}++%+\providecommand{\commutex}{\longleftrightarrow}%+++%+\providecommand{\commutes}{\longleftrightarrow}%++{\newpage\clearpage+\lthtmldisplayA{displaymath2764}%+\begin{displaymath} P_2 P_1 \longleftrightarrow {P_1}' {P_2}'. \end{displaymath}%+\lthtmldisplayZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2887}%+$P_1'$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2893}%+$P_2'$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2897}%+$\longleftrightarrow $%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2899}%+$==$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2901}%+$\ddot\frown$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++\stepcounter{paragraph}++%+\providecommand{\merge}{\Longrightarrow}%++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2760}%+\( \Longrightarrow \)%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmldisplayA{displaymath2765}%+\begin{displaymath}  P_2 \parallel P_1 \Longrightarrow {P_2}' P_1 \longleftrightarrow {P_1}' P_2. \end{displaymath}%+\lthtmldisplayZ+\lthtmlcheckvsize\clearpage}++\stepcounter{subsection}+{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2911}%+$ P_2' P_1 \longleftrightarrow P_1' P_2 $%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2913}%+$ P_1'^{ -1}+P_2' \longleftrightarrow P_2 P_1^{ -1} $%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2915}%+$P_1'^{ -1}$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmlinlinemathA{tex2html_wrap_inline2917}%+$P_1^{ -1}$%+\lthtmlinlinemathZ+\lthtmlcheckvsize\clearpage}++{\newpage\clearpage+\lthtmldisplayA{displaymath2766}%+\begin{displaymath}+A^{ -1} C \longleftrightarrow C' A'^{ -1}+\end{displaymath}%+\lthtmldisplayZ+\lthtmlcheckvsize\clearpage}++\stepcounter{section}+\stepcounter{section}+\stepcounter{paragraph}+\stepcounter{paragraph}+\stepcounter{chapter}+\stepcounter{chapter}+\addtocounter{enumi}{-1}+\stepcounter{section}++\end{document}
+ 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.3.1\nReinier Lamers <tux_rocker@reinier.de>**20090920174331\n Ignore-this: a5da37b9925e1dfe3e81f0b67183ef1f\n] \n"+Just "\nContext:\n\n[TAG 2.4\nReinier Lamers <tux_rocker@reinier.de>**20100226180900\n Ignore-this: 36ce0456c214345f55a7bc5fc142e985\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,96 +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 = "List patches in the repository."+changesDescription :: String+changesDescription = "List patches in the repository." -changes_help :: String-changes_help =+changesHelp :: String+changesHelp =  "The `darcs changes' command lists the patches that constitute the\n" ++- "current repository.  Without options or arguments, ALL patches will be\n" ++- "listed.\n" ++- "\n" ++ changes_help' ++- "\n" ++ changes_help''+ "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."@@ -132,15 +133,15 @@             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)   -- FIXME: this prose is unreadable. --twb, 2009-08-changes_help' :: String-changes_help' =- "When given one or more files or directories as an argument, only\n" +++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" ++@@ -156,18 +157,18 @@  "whereas `darcs changes --last 3 foo.c' will, of the last three\n" ++  "patches, print only those that affect foo.c.\n" -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@@ -178,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) @@ -224,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@@ -260,8 +261,8 @@           description' = description . fst  -- FIXME: this prose is unreadable. --twb, 2009-08-changes_help'' :: String-changes_help'' =+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" ++@@ -277,17 +278,20 @@  "WILL be output for a knowledgeable human to recreate the current state\n" ++  "of the repository.\n" -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 )@@ -38,59 +38,59 @@ import Printer ( text ) import Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) import System.Exit ( ExitCode(..), exitWith )-import ThisVersion ( darcs_version )+import Version ( version ) import URL (environmentHelpProxy, environmentHelpProxyPassword) 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 " ++ 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,@@ -144,7 +148,7 @@ -- | The lines of the manpage to be printed. manpageLines :: [String] manpageLines = [- ".TH DARCS 1 \"" ++ darcs_version ++ "\"",+ ".TH DARCS 1 \"" ++ version ++ "\"",  ".SH NAME",  "darcs \\- an advanced revision control system",  ".SH SYNOPSIS",@@ -190,7 +194,7 @@  unlines environment,  ".SH FILES",  ".SS \"_darcs/prefs/binaries\"",- escape $ 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", escape $ 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
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,38 @@  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, list )+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 )+import Debug.Trace -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 +66,70 @@  "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+                skipAndWarn reason =+                    do putWarning opts . text $ "Can't remove " ++ f_fp+                                                ++ " (" ++ reason ++ ")"+                       return $ Sealed rest -rm_description :: String-rm_description = "Help newbies find `darcs remove'."+            case (find recorded f, find unrecorded f) of+              (Just (SubTree _), Just (SubTree unrecordedChildren)) -> do+                  if not $ null (list unrecordedChildren)+                    then skipAndWarn "it is not empty"+                    else 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+              (_, _) -> skipAndWarn "it is not tracked by darcs"+                             -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 +137,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" ++@@ -135,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"@@ -225,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" ++@@ -89,26 +89,29 @@  "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@@ -121,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@@ -150,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,147 @@+{-# 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") $ concat+           [ helptext+           , [mkSep " BEFORE (reference) =========================="]+           , before+           , [mkSep "=== AFTER (edit) ============================="]+           , after+           , [mkSep "=== (edit above) ============================="]+           ],+         \bs -> do let ls = BC.split '\n' bs+                   (_, ls2) <- breakSep ls        -- before+                   (before', ls3) <- breakSep ls2 -- after 1+                   (after', _) <- breakSep ls3    -- after 2+                   return (hunk before before' +>+ hunk before' after' +>+ hunk after' after))+    where sep = BC.pack "=========================="+          helptext = map BC.pack [ "Interactive hunk edit:"+                                 , " - Edit the section marked 'AFTER'"+                                 , " - Arbitrary editing is supported"+                                 , " - This will only affect the patch, not your working copy"+                                 , " - Hints:"+                                 , "   - To split added text, delete the part you want to postpone"+                                 , "   - To split removed text, copy back the part you want to retain"+                                 , ""+                                 ]+          hunk b a = canonize (FP fn (Hunk n b a))+          mkSep s = BC.append sep (BC.pack s)+          breakSep xs = case break (sep `BC.isPrefixOf`) xs of+                           (_, []) -> Nothing+                           (ys, _:zs) -> Just (ys, zs)+doPrimSplit _ = Nothing++-- |Split a primitive hunk patch up+-- by allowing the user to edit both the before and after lines, then insert fixup patches+-- to clean up the mess.+primSplitter :: 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}@@ -124,7 +124,7 @@ as \verb!manual/index.html!) matches any of the boring regular expressions is considered boring.  The boring file is used to filter the files provided to darcs add, to allow you to use a-simple \verb-darcs add newdir newdir/*-+simple \verb-darcs add newdir newdir/-\verb-*- % cabal haddock barfs on adjacent / * without accidentally adding a bunch of object files.  It is also used when the \verb!--look-for-adds! flag is given to whatsnew or record.@@ -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 ]+      working_paths = [ p | (p, _) <- list working ]+      index_extra = index_paths \\ working_paths+      working_extra = working_paths \\ index_paths+      gethashes p (Just i1) (Just i2) = (p, itemHash i1, itemHash i2)+      gethashes p (Just i1) Nothing   = (p, itemHash i1, NoHash)+      gethashes p   Nothing (Just i2) = (p,      NoHash, itemHash i2)+      gethashes p   Nothing Nothing   = error $ "Bad case at " ++ show p+      mismatches = [ miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2 ]++      format paths = unlines $ (map $ (("  " ++) . anchorPath "")) paths+      mismatches_disp = unlines [ anchorPath "" p +++                                    "\n    index: " ++ BS.unpack (encodeBase16 h1) +++                                    "\n  working: " ++ BS.unpack (encodeBase16 h2)+                                  | (p, h1, h2) <- mismatches ]+  unless (quiet || null index_extra) $+         putStrLn $ "Extra items in index!\n" ++ format index_extra+  unless (quiet || null working_extra) $+         putStrLn $ "Missing items in index!\n" ++ format working_extra+  unless (quiet || null mismatches) $+         putStrLn $ "Hash mismatch(es)!\n" ++ mismatches_disp+  return $ null index_extra && null working_extra && null mismatches+
+ 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 )@@ -58,12 +56,13 @@ import Darcs.RepoPath ( getCurrentDirectory ) import Darcs.Test ( run_posthook, run_prehook ) import Darcs.Utils ( formatPath )+import Data.List ( intersperse ) import Printer ( text ) import URL ( setDebugHTTP, setHTTPPipelining )  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 +79,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 +98,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,52 +134,45 @@                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-get_options_options [] = ""-get_options_options (o:os) =-    get_long_option o ++"\n"++ get_options_options os--get_long_option :: OptDescr DarcsFlag -> String-get_long_option (Option _ [] _ _) = ""-get_long_option (Option a (o:os) b c) = "--"++o++-                 get_long_option (Option a os b c)+get_options_options = concat . intersperse "\n" . concatMap goo+ where+  goo (Option _ os _ _) = map ("--"++) os  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
@@ -13,23 +13,24 @@ --     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,-                        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 )+                        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 )+import Version ( version )  the_commands :: [DarcsCommand]-the_commands = extract_commands command_control_list+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@@ -79,17 +80,17 @@              else return $ "\\end{Verbatim}" : rest preproc ("\\darcsVersion":ss) = do   rest <- preproc ss-  return $ darcs_version:rest+  return $ 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+        do cs <- Ratified.readFile $ "src" </> path -- not part of normal darcs operation            this <- preproc $ lines cs            return $ this ++ rest     Just ["darcsCommand", _, command] ->-        return $ commandHelp command : rest+        return $ latexCommandHelp command : rest     Just ["darcsEnv", _, variable] ->         return $ envHelp variable : rest     -- The base case for the whole preproc function.  Nothing to@@ -97,18 +98,18 @@     -- the result unmodified.     _ -> return $ s : rest -commandHelp :: String -> String-commandHelp command = section ++ "{darcs " ++ command ++ "}\n" +++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 command_help the_commands command+      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 command_description the_commands command+      gd = command_property commandDescription the_commands command  get_options :: String -> String get_options comm = get_com_options $ get_c names the_commands@@ -120,10 +121,10 @@     [] -> [get name commands]     _ -> case get name commands of          c@SuperCommand { } ->-             c:(get_c ns $ extract_commands $ command_sub_commands c)+             c:(get_c ns $ extractCommands $ commandSubCommands c)          _ ->              error $ "Not a supercommand: " ++ name-    where get n (c:cs) | command_name c == n = c+    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"@@ -131,12 +132,12 @@ 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+    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
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/ThisVersion.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS -cpp #-}--module ThisVersion ( darcs_version ) where--#ifndef PACKAGE_VERSION-#define PACKAGE_VERSION "0"-#define PACKAGE_VERSION_STATE "no version info"-#endif--{-# NOINLINE darcs_version #-}-darcs_version :: String-darcs_version = PACKAGE_VERSION ++ " (" ++ PACKAGE_VERSION_STATE ++ ")"
− 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/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,10 +28,9 @@  import Darcs.RunCommand ( run_the_command ) import Darcs.Flags ( DarcsFlag(Verbose) )-import Darcs.Commands.Help ( help_cmd, list_available_commands, print_version )-import ThisVersion ( darcs_version )+import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion ) import Darcs.SignalHandler ( withSignalsHandled )-import Context ( context )+import Version ( version, context ) import Darcs.Global ( with_atexit ) import Preproc( preproc_main ) import Exec ( ExecException(..) )@@ -55,14 +54,14 @@   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-    ["-v"]              -> putStrLn darcs_version-    ["--version"]       -> putStrLn darcs_version+    ["-h"]              -> helpCmd [] []+    ["--help"]          -> helpCmd [] []+    ["--overview"]      -> helpCmd [Verbose] []+    ["--commands"]      -> listAvailableCommands+    ["-v"]              -> putStrLn version+    ["--version"]       -> putStrLn version     ["--exact-version"] -> do               putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__               putStrLn context
+ 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/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,6 @@+import Version+-- import Preproc -- imports Darcs.Commands.Help+-- import Darcs.ArgumentDefaults -- imports Darcs.Commands.Help import Darcs.Patch.Real import Darcs.Patch.Properties import Darcs.Patch.Bundle@@ -6,16 +9,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