darcs 2.4.4 → 2.5

raw patch · 221 files changed

+11541/−8840 lines, 221 filesdep +extensible-exceptionsdep +regex-posixdep +tardep −utf8-stringdep ~basedep ~hashed-storagedep ~haskelinesetup-changedbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: extensible-exceptions, regex-posix, tar, text

Dependencies removed: utf8-string

Dependency ranges changed: base, hashed-storage, haskeline, mmap

API changes (from Hackage documentation)

Files

• Distribution/ShellHarness.hs +15/−7
• NEWS +59/−0
• README +3/−14
• Setup.lhs +32/−20
• contrib/darcs-errors.hlint +2/−2
• contrib/update_roundup.pl +9/−4
• darcs.cabal +414/−346
• doc/darcs.css +4/−0
• release/distributed-context +1/−1
• src/ByteStringUtils.hs +89/−20
• src/CommandLine.hs +4/−4
• src/Darcs/ArgumentDefaults.lhs +26/−26
• src/Darcs/Arguments.lhs +330/−209
• src/Darcs/CheckFileSystem.hs +0/−59
• src/Darcs/ColorPrinter.hs +56/−58
• src/Darcs/Commands.lhs +8/−7
• src/Darcs/Commands/Add.lhs +84/−90
• src/Darcs/Commands/AmendRecord.lhs +60/−47
• src/Darcs/Commands/Annotate.lhs +39/−31
• src/Darcs/Commands/Apply.lhs +81/−75
• src/Darcs/Commands/Changes.lhs +73/−64
• src/Darcs/Commands/Check.lhs +9/−6
• src/Darcs/Commands/Convert.lhs +51/−47
• src/Darcs/Commands/Diff.lhs +22/−22
• src/Darcs/Commands/Dist.lhs +25/−27
• src/Darcs/Commands/Get.lhs +45/−43
• src/Darcs/Commands/MarkConflicts.lhs +19/−15
• src/Darcs/Commands/Move.lhs +55/−47
• src/Darcs/Commands/Optimize.lhs +94/−59
• src/Darcs/Commands/Pull.lhs +167/−57
• src/Darcs/Commands/Push.lhs +46/−36
• src/Darcs/Commands/Put.lhs +29/−26
• src/Darcs/Commands/Record.lhs +87/−87
• src/Darcs/Commands/Remove.lhs +53/−43
• src/Darcs/Commands/Repair.lhs +0/−1
• src/Darcs/Commands/Replace.lhs +14/−11
• src/Darcs/Commands/Revert.lhs +16/−11
• src/Darcs/Commands/Rollback.lhs +29/−28
• src/Darcs/Commands/Send.lhs +79/−87
• src/Darcs/Commands/SetPref.lhs +5/−2
• src/Darcs/Commands/ShowAuthors.lhs +5/−4
• src/Darcs/Commands/ShowContents.lhs +2/−2
• src/Darcs/Commands/ShowFiles.lhs +29/−27
• src/Darcs/Commands/ShowRepo.lhs +6/−5
• src/Darcs/Commands/ShowTags.lhs +7/−6
• src/Darcs/Commands/Tag.lhs +6/−6
• src/Darcs/Commands/TrackDown.lhs +107/−30
• src/Darcs/Commands/TransferMode.lhs +1/−1
• src/Darcs/Commands/Unrecord.lhs +75/−45
• src/Darcs/Commands/Unrevert.lhs +33/−33
• src/Darcs/Commands/WhatsNew.lhs +29/−22
• src/Darcs/CommandsAux.hs +19/−19
• src/Darcs/Compat.hs +16/−16
• src/Darcs/Diff.hs +51/−30
• src/Darcs/Email.hs +43/−41
• src/Darcs/External.hs +43/−29
• src/Darcs/FilePathMonad.hs +6/−6
• src/Darcs/Flags.hs +20/−10
• src/Darcs/Global.hs +10/−10
• src/Darcs/Hopefully.hs +33/−12
• src/Darcs/IO.hs +10/−10
• src/Darcs/Lock.hs +55/−50
• src/Darcs/Match.lhs +109/−202
• src/Darcs/Patch.lhs +13/−26
• src/Darcs/Patch/Apply.lhs +55/−62
• src/Darcs/Patch/Bundle.hs +96/−74
• src/Darcs/Patch/Choices.hs +237/−204
• src/Darcs/Patch/Commute.lhs +285/−299
• src/Darcs/Patch/Core.lhs +11/−11
• src/Darcs/Patch/Depends.hs +279/−457
• src/Darcs/Patch/FileName.hs +51/−54
• src/Darcs/Patch/Info.hs +192/−140
• src/Darcs/Patch/Match.lhs +42/−25
• src/Darcs/Patch/MatchData.hs +3/−3
• src/Darcs/Patch/Non.hs +13/−16
• src/Darcs/Patch/OldDate.hs +75/−75
• src/Darcs/Patch/Patchy.hs +22/−18
• src/Darcs/Patch/Permutations.hs +37/−32
• src/Darcs/Patch/Prim.lhs +212/−202
• src/Darcs/Patch/Properties.lhs +54/−54
• src/Darcs/Patch/Read.hs +76/−82
• src/Darcs/Patch/ReadMonads.hs +57/−48
• src/Darcs/Patch/Real.hs +112/−115
• src/Darcs/Patch/RegChars.hs +1/−1
• src/Darcs/Patch/Set.hs +37/−25
• src/Darcs/Patch/Show.lhs +3/−0
• src/Darcs/Patch/Split.hs +2/−2
• src/Darcs/Patch/TouchesFiles.hs +29/−21
• src/Darcs/Patch/Viewing.hs +2/−2
• src/Darcs/Population.hs +31/−28
• src/Darcs/PopulationData.hs +5/−5
• src/Darcs/ProgressPatches.hs +3/−3
• src/Darcs/RemoteApply.hs +30/−30
• src/Darcs/RepoPath.hs +14/−10
• src/Darcs/Repository.hs +191/−111
• src/Darcs/Repository/ApplyPatches.hs +9/−9
• src/Darcs/Repository/Cache.hs +73/−8
• src/Darcs/Repository/Checkpoint.hs +42/−64
• src/Darcs/Repository/DarcsRepo.lhs +163/−145
• src/Darcs/Repository/Format.hs +1/−1
• src/Darcs/Repository/HashedIO.hs +34/−120
• src/Darcs/Repository/HashedRepo.hs +259/−178
• src/Darcs/Repository/Internal.hs +208/−232
• src/Darcs/Repository/InternalTypes.hs +14/−2
• src/Darcs/Repository/LowLevel.hs +6/−6
• src/Darcs/Repository/Merge.hs +29/−27
• src/Darcs/Repository/Motd.lhs +6/−6
• src/Darcs/Repository/Prefs.lhs +34/−27
• src/Darcs/Repository/Pristine.hs +9/−19
• src/Darcs/Repository/Repair.hs +55/−46
• src/Darcs/Repository/State.hs +41/−38
• src/Darcs/Resolution.lhs +24/−25
• src/Darcs/RunCommand.hs +40/−38
• src/Darcs/SelectChanges.hs +834/−641
• src/Darcs/SignalHandler.hs +38/−30
• src/Darcs/SlurpDirectory.hs +0/−35
• src/Darcs/SlurpDirectory/Internal.hs +0/−661
• src/Darcs/Test.lhs +17/−17
• src/Darcs/Test/Email.hs +28/−28
• src/Darcs/Test/Patch/Check.hs +120/−120
• src/Darcs/Test/Patch/Info.hs +158/−0
• src/Darcs/Test/Patch/QuickCheck.hs +67/−81
• src/Darcs/Test/Patch/Test.hs +195/−190
• src/Darcs/Test/Patch/Unit.hs +98/−96
• src/Darcs/Test/Unit.lhs +766/−0
• src/Darcs/TheCommands.hs +2/−1
• src/Darcs/URL.hs +20/−20
• src/Darcs/Utils.hs +106/−66
• src/Darcs/Witnesses/Ordered.hs +75/−33
• src/Darcs/Witnesses/Sealed.hs +69/−23
• src/Darcs/Witnesses/Show.hs +34/−11
• src/Darcs/Witnesses/WZipper.hs +77/−0
• src/DateMatcher.hs +8/−5
• src/English.hs +4/−0
• src/Exec.hs +17/−14
• src/HTTP.hs +9/−8
• src/IsoDate.hs +109/−109
• src/Lcs.hs +4/−4
• src/Preproc.hs +29/−29
• src/Printer.lhs +23/−23
• src/Progress.hs +3/−3
• src/SHA1.hs +25/−25
• src/Ssh.hs +6/−5
• src/URL.hs +60/−59
• src/building_darcs.tex +2/−2
• src/darcs.hs +18/−19
• src/fpstring.c +2/−0
• src/fpstring.h +0/−1
• src/hscurl.c +20/−8
• src/hscurl.h +2/−0
• src/unit.hs +3/−0
• src/unit.lhs +0/−770
• src/witnesses.hs +23/−22
• tests/amend-record.sh +30/−1
• tests/check.sh +2/−2
• tests/dist.sh +23/−3
• tests/external-resolution.sh +11/−0
• tests/failed-amend-should-not-break-repo.sh +3/−3
• tests/failing-issue1014_identical_patches.sh +2/−0
• tests/failing-issue1337_darcs_changes_false_positives.sh +0/−37
• tests/failing-issue1363-mark-conflicts.sh +62/−0
• tests/failing-issue1461_case_folding.sh +4/−0
• tests/failing-issue1727_move_current_directory.sh +49/−0
• tests/failing-issue1737-move_args.sh +38/−0
• tests/failing-issue1740-mv-dir.sh +36/−0
• tests/failing-issue1845-paths-working-copy.sh +37/−0
• tests/failing-issue1848-rollback-p.sh +36/−0
• tests/failing-issue1909-unrecord-O-misses-tag.sh +20/−0
• tests/filepath.sh +1/−1
• tests/get.sh +2/−1
• tests/issue121.sh +45/−0
• tests/issue1210-no-global-cache-in-sources.sh +36/−0
• tests/issue1232_convert_forgets_prefs.sh +62/−0
• tests/issue1277-repo-format.sh +46/−0
• tests/issue1290-diff-index.sh +22/−0
• tests/issue1337_darcs_changes_false_positives.sh +37/−0
• tests/issue1427_apply_gz.sh +41/−0
• tests/issue1473.sh +42/−0
• tests/issue1618-amend-preserve-logfile.sh +1/−1
• tests/issue1620-record-lies-about-leaving-logfile.sh +1/−1
• tests/issue1726_darcs_always-boring.sh +73/−0
• tests/issue1739-escape-multibyte-chars-correctly.sh +71/−0
• tests/issue1749-rmdir.sh +42/−0
• tests/issue1756_moves_index.sh +50/−0
• tests/issue1763-pull-fails-on-non-ascii-filenames.sh +77/−0
• tests/issue1825-remove-pending.sh +43/−0
• tests/issue183_mv_order.sh +45/−0
• tests/issue1845-record-removed.sh +16/−0
• tests/issue1857-pristine-conversion.sh +37/−0
• tests/issue1860-incomplete-pristine.sh +45/−0
• tests/issue1865-get-context.sh +20/−0
• tests/issue1871-record-dot.sh +18/−0
• tests/issue1873-apply-failed-to-read-patch.sh +55/−0
• tests/issue1875-honor-no-set-default.sh +39/−0
• tests/issue1877_noisy_xml_output.sh +47/−0
• tests/issue1879-same-patchinfo-uncommon.sh +38/−0
• tests/issue1888-changes-context.sh +43/−0
• tests/issue1898-set-default-notification.sh +54/−0
• tests/issue1913-diffing.sh +39/−0
• tests/issue1951-add-outside-repo.sh +151/−0
• tests/issue538.sh +4/−4
• tests/lib +3/−6
• tests/match-date.sh +14/−1
• tests/mergeresolved.sh +0/−2
• tests/network/issue1503_prefer_local_caches_to_remote_one.sh +33/−0
• tests/output.sh +1/−1
• tests/posthook.sh +32/−2
• tests/printer.sh +9/−9
• tests/pull-dont-prompt-deps.sh +6/−4
• tests/pull.sh +2/−2
• tests/pull_binary.sh +1/−1
• tests/push-dont-prompt-deps.sh +6/−4
• tests/query_manifest.sh +6/−5
• tests/record.sh +4/−3
• tests/repos/minimal-darcs-2.4.tgz binary
• tests/send-dont-prompt-deps.sh +6/−4
• tests/tentative_revert.sh +2/−2
• tests/trackdown-bisect-helper.hs +38/−0
• tests/trackdown-bisect.sh +141/−0
• tests/utf8.sh +189/−0
• tests/whatsnew-pending.sh +15/−0

@@ -17,12 +17,20 @@ import Data.Maybe import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy, isSuffixOf ) import Control.Concurrent+import qualified Control.Exception as Exception+import Control.Monad++-- Handle exceptions migration. We could use extensible-exceptions+-- but Cabal can't handle package dependencies of Setup.lhs+-- automatically so it'd be disruptive for users.+-- Once we drop older GHCs we can clean up the use sites properly+-- and perhaps think about being more restrictive in which exceptions+-- are caught at each site. #if __GLASGOW_HASKELL__ >= 610-import Control.OldException+catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException)) #else-import Control.Exception+catchAny = Exception.catch #endif-import Control.Monad  runTests :: Maybe FilePath -> String -> [String] -> IO Bool runTests darcs_path cwd tests = do@@ -62,7 +70,7 @@                 ,("DARCS_DONT_ESCAPE_ANYTHING","1")]         shell = takeWhile (/= '\n') bash     putStrLn $ "Using bash shell in '"++shell++"'"-    catch (appendFile (".darcs/defaults") "\nALL --ignore-times\n")+    catchAny (appendFile (".darcs/defaults") "\nALL ignore-times\nsend no-edit-description\n")           (\e -> fail $ "Unable to set preferences: " ++ show e)     run_helper shell tests []  (set_env myenv env) @@ -102,8 +110,8 @@                  system $ "hpc sum --union --output=" ++ tixdir </> "sum.tix" ++ " " ++ unwords tixfiles                  forM tixfiles $ \f -> removeFile f                  return ()-             mapM_ (\x-> -                  setPermissions x (Permissions +             mapM_ (\x->+                  setPermissions x (Permissions                                    {readable = True                                    ,writable = True                                    ,executable = False@@ -146,7 +154,7 @@        let readWrite i = do x <- hGetLine i                             writeChan ch $ Just x                             readWrite i-                         `catch` \_ -> writeChan ch Nothing+                         `catchAny` \_ -> writeChan ch Nothing            readEO = do x <- readChan ch                        case x of                          Just l -> do y <- readEO

@@ -1,3 +1,62 @@+Darcs 2.5, 30 October 2010:++ * Important changes in Darcs 2.5++   * trackdown can now do binary search with the --bisect option+   * darcs always stores patch metadata encoded with UTF-8+   * diff now supports the --index option+   * amend-record now supports the --ask-deps option+   * apply now supports the --match option+   * amend-record has a new --keep-date option+   * inventory-changing commands (like record and pull) now operate in+     constant time with respect to the number of patches in the repository+   * the push, pull, send and fetch commands no longer set the default+     repository by default+   * the --edit-description option is now on by default for the send command++ * Issues resolved in Darcs 2.5++   * 64:   store metadata as UTF-8+   * 121:  add --ask-deps support to amend-record+   * 643:  darcs send -o outputs remote repo email address+   * 1159: avoid bogus repository cache entries+   * 1176: caches interfere with --remote-repo flag+   * 1208: add trackdown --bisect+   * 1210: global cache gets recorded in _darcs/prefs/sources+   * 1232: darcs convert copies _darcs/prefs/prefs+   * 1250: check for newlines in setpref values+   * 1277: percolate repository format errors correctly+   * 1288: the main darcs code now compiles and runs with witnesses+   * 1290: support diff --index+   * 1337: don't show unrelated patches in darcs changes on untracked path+   * 1389: change predist pref to point people to use 'cabal sdist'+   * 1427: accept gzipped patch bundles in darcs apply+   * 1456: make dist write more portable archives+   * 1473: make annotate accept '.' as argument+   * 1503: prefer local caches to remote ones+   * 1713: shorter interactive prompts+   * 1716: allow mail header lines of all whitespace in test+   * 1719: do not back up files when no conflict markers are inserted+   * 1726: don't consider all files with _darcs prefix boring+   * 1739: make ColorPrinter handle characters > 255+   * 1763: use correct filename encoding in conflictors+   * 1765: refuse to remove non-tracked directories recursively+   * 1769: add support for --match 'comment ...'+   * 1784: push and pull print remote address right away+   * 1815: work around Cabal sdist permissions issue+   * 1817: fix support for external merge tools+   * 1824: avoid PACKAGE_VERSION under Windows+   * 1825: do not omit important prims in unrecordedChanges w/ files+   * 1860: (un)applying move patches doesn't corrupt pristine+   * 1861: fix typo in --no-boring help+   * 1874: recognise network tests on cabal test command line+   * 1875: avoid accidentally setting default+   * 1879: notice unexpected commute failure on merge+   * 1887: add a missing newline to --list-options output+   * 1893: move fields of conditional builds within scope of condition+   * 1898: notify user when they can use set-default+   * 1913: sort changes in treeDiff+ Darcs 2.4.4, 9 May 2010   * Important changes in Darcs 2.4.4

@@ -11,20 +11,9 @@ Compilation and Installation ============================ -Building Darcs requires the cabal package, version 1.6 or higher.  The-cabal-install package is also recommended.--Using GHC 6.10.3 or newer is STRONGLY RECOMMENDED. You can compile darcs with-GHC 6.8, but there are several caveats. If you are using 6.8.2 or older, please-disable mmap support (pass -f-mmap to cabal install or runghc Setup configure-below). Note that the GHC 6.8.2 that ships with Debian Lenny is not affected-and it should be safe to keep mmap enabled. It is also recommended to disable-use of Hackage zlib when compiling with GHC 6.8.2 (including the Debian Lenny-version): pass -f-zlib to cabal. When using zlib, we have seen occasional-crashes with error messages like "openBinaryFile: file locked" -- this is a-known GHC 6.8.2 bug (and is fixed in GHC 6.8.3). Last, if you are using a-64-bit system, darcs may hang when you exit a pager when compiled with GHC-older than 6.10.3. Although this is harmless, it is quite inconvenient.+Building Darcs requires GHC, version 6.10.3 or higher. It also requires the+Cabal package, version 1.6 or higher.  The cabal-install package is also+recommended.  If you have the "cabal-install" package on your system (that is, there is a "cabal" executable in your path), you can use the following command to create

@@ -3,6 +3,9 @@ -- copyright (c) 2008 Duncan Coutts -- portions copyright (c) 2008 David Roundy +import Prelude hiding ( catch )+import qualified Prelude+ import Distribution.Simple          ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.ModuleName( toFilePath )@@ -12,11 +15,12 @@          , updatePackageDescription, cppOptions, ccOptions          , library, libBuildInfo, otherModules ) import Distribution.Package-         ( packageVersion )+         ( packageVersion, packageName, PackageName(..) ) import Distribution.Version          ( Version(versionBranch) )+import Data.Version( showVersion ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), absoluteInstallDirs )+         ( LocalBuildInfo(..), absoluteInstallDirs, externalPackageDeps ) import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest)) import Distribution.Simple.Setup     (buildVerbosity, copyDest, copyVerbosity, fromFlag,@@ -54,10 +58,18 @@  import qualified Distribution.ShellHarness as Harness ( runTests ) +import qualified Control.Exception as Exception++-- Handle exceptions migration. We could use extensible-exceptions+-- but Cabal can't handle package dependencies of Setup.lhs+-- automatically so it'd be disruptive for users.+-- Once we drop older GHCs we can clean up the use sites properly+-- and perhaps think about being more restrictive in which exceptions+-- are caught at each site. #if __GLASGOW_HASKELL__ >= 610-import qualified Control.OldException as Exception+catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException)) #else-import qualified Control.Exception as Exception+catchAny = Exception.catch #endif  main :: IO ()@@ -200,7 +212,7 @@       case reads (out) of         ((n,_):_) -> return $ Just ((n :: Int) - 1)         _         -> return Nothing-    `Exception.catch` \_ -> return Nothing+    `catchAny` \_ -> return Nothing    numPatchesDist <- parseFile versionFile   return $ case (numPatchesDarcs, numPatchesDist) of@@ -219,12 +231,15 @@   ctx <- context verbosity (packageVersion pkg)   rewriteFile (dir </> "Version.hs") $ unlines     ["module Version where"-    ,"version, context :: String"+    ,"builddeps, version, context :: String"     ,"version = \"" ++ version ++ " (" ++ state ++ ")\""+    ,"builddeps = " ++ (show $ formatdeps (externalPackageDeps lbi))     ,"context = " ++ case ctx of                        Just x -> show x                        Nothing -> show "context not available"     ]+  where formatdeps = unlines . map (formatone . snd)+        formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p)  context :: Verbosity -> Version -> IO (Maybe String) context verbosity version = do@@ -237,7 +252,7 @@                           ["changes", "--from-tag", display version ]       out <- rawSystemStdout verbosity "darcs" ["changes", "--context"]       return $ Just out-   `Exception.catch` \_ -> return Nothing+   `catchAny` \_ -> return Nothing    contextDist <- parseFile contextFile   return $ case (contextDarcs, contextDist) of@@ -312,14 +327,11 @@               run <- map kindify `fmap` filterM doesFileExist c               return $ take 1 run             kindify test = case splitDirectories test of-                             [p, y] -> (parse_kind p y, y)-                             _ -> error $ "Bad format in " ++ test ++-                                          ": expected type/test"-            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-+                             ["tests", y] -> (parse_kind y, y)+                             ["tests","network",y] -> (Network, y)+                             xs -> error $ "Bad format in " ++ test +++                                          ": expected type/test" ++ " but got " ++ show xs+            parse_kind y = if isTest Bug y then Bug else Test  allTests :: FilePath -> TestKind -> [String] -> IO () allTests darcs_path k s =@@ -339,7 +351,7 @@         (do cwd <- getCurrentDirectory             when (name /= "") (setCurrentDirectory name)             return cwd)-        (\oldwd -> setCurrentDirectory oldwd `catch` (\_ -> return ()))+        (\oldwd -> setCurrentDirectory oldwd `catchAny` (\_ -> return ()))         (const m)  cloneTree :: FilePath -> FilePath -> IO ()@@ -356,7 +368,7 @@             mk_dest   fp = dest   ++ "/" ++ fp         zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')      else fail ("cloneTreeExcept: Bad source " ++ source)-   `catch` fail ("cloneTreeExcept: Bad source " ++ source)+   `catchAny` fail ("cloneTreeExcept: Bad source " ++ source)  cloneSubTree :: FilePath -> FilePath -> IO () cloneSubTree source dest =@@ -372,9 +384,9 @@      else if isfile then do         cloneFile source dest      else fail ("cloneSubTree: Bad source "++ source)-    `catch` (\e -> if isDoesNotExistError e-                   then return ()-                   else ioError e)+    `Prelude.catch` (\e -> if isDoesNotExistError e+                           then return ()+                           else ioError e)  cloneFile :: FilePath -> FilePath -> IO () cloneFile = copyFile

@@ -41,5 +41,5 @@                               ==> Data.ByteString.hGetContents error "Avoid BL.hGetContents" = Data.ByteString.Lazy.Char8.hGetContents                               ==> Data.ByteString.hGetContents-error "Avoid BL.readFile" = Data.ByteString.Lazy.Char8.readFile ==> Data.ByteString.readFile-error "Avoid BL.readFile" = Data.ByteString.Lazy.readFile ==> Data.ByteString.readFile+-- error "Avoid BL.readFile" = Data.ByteString.Lazy.Char8.readFile ==> Data.ByteString.readFile+-- error "Avoid BL.readFile" = Data.ByteString.Lazy.readFile ==> Data.ByteString.readFile

@@ -16,12 +16,17 @@ use MIME::Lite; use XML::Simple; +my $UPDATE_STRING="status=resolved";+if (scalar(@ARGV) == 1) {+  $UPDATE_STRING=$ARGV[0];+}+ unless ($ENV{DARCS_PATCHES_XML}) {     die "DARCS_PATCHES_XML was expected to be set in the environment, but was not found.            Are you running this from a Darcs 2.0 or newer posthook?" } -my $xml = eval { XMLin($ENV{DARCS_PATCHES_XML}); };+my $xml = eval { XMLin($ENV{DARCS_PATCHES_XML}, forcearray=>['patch']); }; die "hmmm.. we couldn't parse your XML. The error was: $@"  if $@;  # $xml structure returned looks like this: @@ -59,11 +64,11 @@      # Each patches can potentially update the status of a different issue, so generates a different e-mail     my $msg = MIME::Lite->new(          From     => $email, -         To      =>'bugs@darcs.net',+         To      =>'bugs@lists.osuosl.org',          #To       =>'mark@stosberg.com',-         Subject  =>"[$issue] [status=resolved]",+         Subject  =>"[$issue] [$UPDATE_STRING]",          Type     =>'text/plain',-         Data     => qq!The following patch updated the status of $issue to be resolved:+         Data     => qq!The following patch updated issue $issue with $UPDATE_STRING  * $patch_name $comment 

@@ -1,5 +1,5 @@ Name:           darcs-version:        2.4.4+version:        2.5 License:        GPL License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-users@darcs.net>@@ -33,7 +33,7 @@ Homepage:       http://darcs.net/  Build-Type:     Custom-Cabal-Version:  >= 1.6+Cabal-Version:  >= 1.8 Tested-with:    GHC==6.8.2  extra-source-files:@@ -59,7 +59,9 @@   -- testsuite   Distribution/ShellHarness.hs   tests/repos/*.tgz tests/repos/README+  tests/repos/minimal-darcs-2.4.tgz   tests/*.sh+  tests/trackdown-bisect-helper.hs   tests/hspwd.hs   tests/network/*.sh   tests/lib@@ -75,12 +77,6 @@ flag curl   description: Use libcurl for HTTP support. -flag curl-pipelining-  description: Use libcurl's HTTP pipelining.-  default:     False-  --TODO: needs Cabal ticket #342 to allow default True-  --      and decide on this automatically- flag http   description: Use the pure Haskell HTTP package for HTTP support. @@ -99,6 +95,10 @@   description: Use GADT type witnesses.   default:     False +flag library+  description: Build darcs library+  default:     True+ flag color   description: Use ansi color escapes. @@ -118,224 +118,267 @@  Executable          witnesses   main-is:          witnesses.hs-  hs-source-dirs:   src-  include-dirs:     src-  cpp-options:      -DGADT_WITNESSES=1-  -- FIXME...-  c-sources:        src/atomic_create.c-                    src/fpstring.c-                    src/maybe_relink.c-                    src/umask.c-                    src/Crypt/sha2.c-  -- this module isn't exported by libdarcs, so not included in the tarball-  -- if not mentioned-  other-modules:    Darcs.Test.Patch.Check -  extensions:-    CPP-    UndecidableInstances-    ScopedTypeVariables-    RankNTypes-    GADTs-    ImpredicativeTypes-   if !flag(type-witnesses)     buildable: False+  else+    buildable: True -  if os(windows)-    hs-source-dirs: src/win32-    include-dirs:   src/win32-    other-modules:  CtrlC-                    System.Posix-                    System.Posix.Files-                    System.Posix.IO-    cpp-options:    -DWIN32-    c-sources:      src/win32/send_email.c-    build-depends:  unix-compat >= 0.1.2+    hs-source-dirs:   src+    include-dirs:     src+    cpp-options:      -DGADT_WITNESSES=1+    -- FIXME...+    c-sources:        src/atomic_create.c+                      src/fpstring.c+                      src/maybe_relink.c+                      src/umask.c+                      src/Crypt/sha2.c+    -- this module isn't exported by libdarcs, so not included in the tarball+    -- if not mentioned+    other-modules:    Darcs.Test.Patch.Check +    extensions:+      CPP+      PatternGuards+      UndecidableInstances+      ScopedTypeVariables+      -- PatternSignatures is needed for GHC 6.8+      PatternSignatures+      RankNTypes+      GADTs+      TypeOperators++    if os(windows)+      hs-source-dirs: src/win32+      include-dirs:   src/win32+      other-modules:  CtrlC+                      System.Posix+                      System.Posix.Files+                      System.Posix.IO+      cpp-options:    -DWIN32+      c-sources:      src/win32/send_email.c+      build-depends:  unix-compat >= 0.1.2,+                      regex-posix >= 0.94.4 && < 0.95++    build-depends:   base          < 5,+                     extensible-exceptions >= 0.1 && < 0.2,+                     regex-compat >= 0.71 && < 0.94,+                     mtl          >= 1.0 && < 1.2,+                     parsec       >= 2.0 && < 3.1,+                     html         == 1.0.*,+                     filepath     == 1.1.*,+                     haskeline    >= 0.6.2.2 && < 0.7,+                     hashed-storage >= 0.5.2 && < 0.6,+                     base >= 3,+                     bytestring >= 0.9.0 && < 0.10,+                     text >= 0.3,+                     old-time   == 1.0.*,+                     directory  == 1.0.*,+                     process    == 1.0.*,+                     containers >= 0.1 && < 0.4,+                     array      >= 0.1 && < 0.4,+                     random     == 1.0.*,+                     tar          == 0.3.*,+                     zlib >= 0.5.1.0 && < 0.6.0.0,+                     QuickCheck   >= 2.1.0.0,+                     test-framework             >= 0.2.2,+                     test-framework-quickcheck2 >= 0.2.2+    if !os(windows)+      build-depends: unix >= 1.0 && < 2.5+    if flag(http)+        build-depends:    network == 2.2.*,+                          HTTP    >= 3000.0 && < 4000.1++ -- ---------------------------------------------------------------------- -- darcs library -- ----------------------------------------------------------------------  Library-  hs-source-dirs:   src-  include-dirs:     src+  if !flag(library)+    buildable: False+  else+    buildable: True -  exposed-modules:  CommandLine-                    Crypt.SHA256-                    Darcs.ArgumentDefaults-                    Darcs.Arguments-                    Darcs.Bug-                    Darcs.CheckFileSystem-                    Darcs.ColorPrinter-                    Darcs.Commands-                    Darcs.Commands.Add-                    Darcs.Commands.AmendRecord-                    Darcs.Commands.Annotate-                    Darcs.Commands.Apply-                    Darcs.CommandsAux-                    Darcs.Commands.Changes-                    Darcs.Commands.Check-                    Darcs.Commands.Convert-                    Darcs.Commands.Diff-                    Darcs.Commands.Dist-                    Darcs.Commands.Get-                    Darcs.Commands.GZCRCs-                    Darcs.Commands.Help-                    Darcs.Commands.Init-                    Darcs.Commands.MarkConflicts-                    Darcs.Commands.Move-                    Darcs.Commands.Optimize-                    Darcs.Commands.Pull-                    Darcs.Commands.Push-                    Darcs.Commands.Put-                    Darcs.Commands.Record-                    Darcs.Commands.Remove-                    Darcs.Commands.Repair-                    Darcs.Commands.Replace-                    Darcs.Commands.Revert-                    Darcs.Commands.Rollback-                    Darcs.Commands.Send-                    Darcs.Commands.SetPref-                    Darcs.Commands.Show-                    Darcs.Commands.ShowAuthors-                    Darcs.Commands.ShowBug-                    Darcs.Commands.ShowContents-                    Darcs.Commands.ShowFiles-                    Darcs.Commands.ShowIndex-                    Darcs.Commands.ShowRepo-                    Darcs.Commands.ShowTags-                    Darcs.Commands.Tag-                    Darcs.Commands.TrackDown-                    Darcs.Commands.TransferMode-                    Darcs.Commands.Unrecord-                    Darcs.Commands.Unrevert-                    Darcs.Commands.WhatsNew-                    Darcs.Compat-                    Darcs.Diff-                    Darcs.Email-                    Darcs.External-                    Darcs.FilePathMonad-                    Darcs.Flags-                    Darcs.Global-                    Darcs.Hopefully-                    Darcs.IO-                    Darcs.Lock-                    Darcs.Match-                    Darcs.Witnesses.Ordered-                    Darcs.Patch-                    Darcs.Patch.Apply-                    Darcs.Patch.Bundle-                    Darcs.Patch.Choices-                    Darcs.Patch.Commute-                    Darcs.Patch.Core-                    Darcs.Patch.Depends-                    Darcs.Patch.FileName-                    Darcs.Patch.Info-                    Darcs.Patch.Match-                    Darcs.Patch.MatchData-                    Darcs.Patch.Non-                    Darcs.Patch.OldDate-                    Darcs.Patch.Patchy-                    Darcs.Patch.Permutations-                    Darcs.Patch.Prim-                    Darcs.Patch.Properties-                    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-                    Darcs.PopulationData-                    Darcs.PrintPatch-                    Darcs.ProgressPatches-                    Darcs.RemoteApply-                    Darcs.RepoPath-                    Darcs.Repository-                    Darcs.Repository.ApplyPatches-                    Darcs.Repository.Cache-                    Darcs.Repository.Checkpoint-                    Darcs.Repository.DarcsRepo-                    Darcs.Repository.Format-                    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.Witnesses.Sealed-                    Darcs.SelectChanges-                    Darcs.Witnesses.Show-                    Darcs.SignalHandler-                    Darcs.SlurpDirectory-                    Darcs.SlurpDirectory.Internal-                    Darcs.Test-                    Darcs.TheCommands-                    Darcs.URL-                    Darcs.Utils-                    DateMatcher-                    English-                    Exec-                    ByteStringUtils-                    HTTP-                    IsoDate-                    Lcs-                    Printer-                    Progress-                    Ratified-                    SHA1-                    Ssh-                    URL-                    Workaround+    hs-source-dirs:   src+    include-dirs:     src -  other-modules:    Version+    exposed-modules:  CommandLine+                      Crypt.SHA256+                      Darcs.ArgumentDefaults+                      Darcs.Arguments+                      Darcs.Bug+                      Darcs.ColorPrinter+                      Darcs.Commands+                      Darcs.Commands.Add+                      Darcs.Commands.AmendRecord+                      Darcs.Commands.Annotate+                      Darcs.Commands.Apply+                      Darcs.CommandsAux+                      Darcs.Commands.Changes+                      Darcs.Commands.Check+                      Darcs.Commands.Convert+                      Darcs.Commands.Diff+                      Darcs.Commands.Dist+                      Darcs.Commands.Get+                      Darcs.Commands.GZCRCs+                      Darcs.Commands.Help+                      Darcs.Commands.Init+                      Darcs.Commands.MarkConflicts+                      Darcs.Commands.Move+                      Darcs.Commands.Optimize+                      Darcs.Commands.Pull+                      Darcs.Commands.Push+                      Darcs.Commands.Put+                      Darcs.Commands.Record+                      Darcs.Commands.Remove+                      Darcs.Commands.Repair+                      Darcs.Commands.Replace+                      Darcs.Commands.Revert+                      Darcs.Commands.Rollback+                      Darcs.Commands.Send+                      Darcs.Commands.SetPref+                      Darcs.Commands.Show+                      Darcs.Commands.ShowAuthors+                      Darcs.Commands.ShowBug+                      Darcs.Commands.ShowContents+                      Darcs.Commands.ShowFiles+                      Darcs.Commands.ShowIndex+                      Darcs.Commands.ShowRepo+                      Darcs.Commands.ShowTags+                      Darcs.Commands.Tag+                      Darcs.Commands.TrackDown+                      Darcs.Commands.TransferMode+                      Darcs.Commands.Unrecord+                      Darcs.Commands.Unrevert+                      Darcs.Commands.WhatsNew+                      Darcs.Compat+                      Darcs.Diff+                      Darcs.Email+                      Darcs.External+                      Darcs.FilePathMonad+                      Darcs.Flags+                      Darcs.Global+                      Darcs.Hopefully+                      Darcs.IO+                      Darcs.Lock+                      Darcs.Match+                      Darcs.Witnesses.Ordered+                      Darcs.Witnesses.WZipper+                      Darcs.Patch+                      Darcs.Patch.Apply+                      Darcs.Patch.Bundle+                      Darcs.Patch.Choices+                      Darcs.Patch.Commute+                      Darcs.Patch.Core+                      Darcs.Patch.Depends+                      Darcs.Patch.FileName+                      Darcs.Patch.Info+                      Darcs.Patch.Match+                      Darcs.Patch.MatchData+                      Darcs.Patch.Non+                      Darcs.Patch.OldDate+                      Darcs.Patch.Patchy+                      Darcs.Patch.Permutations+                      Darcs.Patch.Prim+                      Darcs.Patch.Properties+                      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+                      Darcs.PopulationData+                      Darcs.PrintPatch+                      Darcs.ProgressPatches+                      Darcs.RemoteApply+                      Darcs.RepoPath+                      Darcs.Repository+                      Darcs.Repository.ApplyPatches+                      Darcs.Repository.Cache+                      Darcs.Repository.Checkpoint+                      Darcs.Repository.DarcsRepo+                      Darcs.Repository.Format+                      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.Witnesses.Sealed+                      Darcs.SelectChanges+                      Darcs.Witnesses.Show+                      Darcs.SignalHandler+                      Darcs.Test+                      Darcs.TheCommands+                      Darcs.URL+                      Darcs.Utils+                      DateMatcher+                      English+                      Exec+                      ByteStringUtils+                      HTTP+                      IsoDate+                      Lcs+                      Printer+                      Progress+                      Ratified+                      SHA1+                      Ssh+                      URL+                      Workaround -  c-sources:        src/atomic_create.c-                    src/fpstring.c-                    src/maybe_relink.c-                    src/umask.c-                    src/Crypt/sha2.c-  cc-options:       -D_REENTRANT+    other-modules:    Version -  if os(windows)-    hs-source-dirs: src/win32-    include-dirs:   src/win32-    other-modules:  CtrlC-                    System.Posix-                    System.Posix.Files-                    System.Posix.IO-    cpp-options:    -DWIN32-    build-depends:  unix-compat >= 0.1.2+    c-sources:        src/atomic_create.c+                      src/fpstring.c+                      src/maybe_relink.c+                      src/umask.c+                      src/Crypt/sha2.c+    cc-options:       -D_REENTRANT -  if os(solaris)-    cc-options:     -DHAVE_SIGINFO_H+    if os(windows)+      hs-source-dirs: src/win32+      include-dirs:   src/win32+      other-modules:  CtrlC+                      System.Posix+                      System.Posix.Files+                      System.Posix.IO+      cpp-options:    -DWIN32+      build-depends:  unix-compat >= 0.1.2,+                      regex-posix >= 0.94.4 && < 0.95 -  build-depends:   base          < 4,-                   regex-compat >= 0.71 && < 0.94,-                   mtl          >= 1.0 && < 1.2,-                   parsec       >= 2.0 && < 3.1,-                   html         == 1.0.*,-                   filepath     == 1.1.*,-                   haskeline    >= 0.6.1 && < 0.7,-                   hashed-storage == 0.4.13+    if os(solaris)+      cc-options:     -DHAVE_SIGINFO_H -  if !os(windows)-    build-depends: unix >= 1.0 && < 2.5+    build-depends:   base          < 5,+                     extensible-exceptions >= 0.1 && < 0.2,+                     regex-compat >= 0.71 && < 0.94,+                     mtl          >= 1.0 && < 1.2,+                     parsec       >= 2.0 && < 3.1,+                     html         == 1.0.*,+                     filepath     == 1.1.*,+                     haskeline    >= 0.6.2.2 && < 0.7,+                     hashed-storage >= 0.5.2 && < 0.6,+                     tar          == 0.3.* -  build-depends: base >= 3,-                 bytestring >= 0.9.0 && < 0.10,-                 utf8-string == 0.3.*,+    if !os(windows)+      build-depends: unix >= 1.0 && < 2.5++    build-depends: base >= 3,+                   bytestring >= 0.9.0 && < 0.10,+                   text >= 0.3,                    old-time   == 1.0.*,                    directory  == 1.0.*,                    process    == 1.0.*,@@ -344,71 +387,72 @@                    random     == 1.0.*  -  -- We need optimizations, regardless of what Hackage says-  ghc-options:      -Wall -O2 -funbox-strict-fields -fwarn-tabs-  ghc-prof-options: -prof -auto-all+    -- We need optimizations, regardless of what Hackage says+    -- Note: "if true" works around a cabal bug with order of flag composition+    if true+      ghc-options:      -Wall -O2 -funbox-strict-fields -fwarn-tabs -  if flag(hpc)-    ghc-prof-options: -fhpc+    if impl(ghc>=6.12)+      ghc-options: -fno-warn-unused-do-bind -  if flag(curl)-    extra-libraries:   curl-    includes:          curl/curl.h-    cpp-options:       -DHAVE_CURL-    c-sources:         src/hscurl.c-    cc-options:        -DHAVE_CURL+    ghc-prof-options: -prof -auto-all -    if flag(curl-pipelining)-      -- curl 7.19.1 has bug-free pipelining-      if !os(windows)-        pkgconfig-depends: libcurl >= 7.19.1-      cpp-options:       -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT+    if flag(hpc)+      ghc-prof-options: -fhpc -  if flag(http)-      build-depends:    network == 2.2.*,-                        HTTP    >= 3000.0 && < 4000.1-      cpp-options:      -DHAVE_HTTP-      x-have-http:+    if flag(curl)+      extra-libraries:   curl+      includes:          curl/curl.h+      cpp-options:       -DHAVE_CURL+      c-sources:         src/hscurl.c+      cc-options:        -DHAVE_CURL -  if (!flag(curl) && !flag(http)) || flag(deps-only)-      buildable: False+    if flag(http)+        build-depends:    network == 2.2.*,+                          HTTP    >= 3000.0 && < 4000.1+        cpp-options:      -DHAVE_HTTP+        x-have-http: -  if flag(mmap) && !os(windows)-    build-depends:    mmap >= 0.2 && < 0.5-    cpp-options:      -DHAVE_MMAP+    if (!flag(curl) && !flag(http)) || flag(deps-only)+        buildable: False -  build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0+    if flag(mmap) && !os(windows)+      build-depends:    mmap >= 0.5 && < 0.6+      cpp-options:      -DHAVE_MMAP -  -- The terminfo package cannot be built on Windows.-  if flag(terminfo) && !os(windows)-    build-depends:    terminfo == 0.3.*-    cpp-options:      -DHAVE_TERMINFO+    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0 -  if flag(color)-    x-use-color:+    -- The terminfo package cannot be built on Windows.+    if flag(terminfo) && !os(windows)+      build-depends:    terminfo == 0.3.*+      cpp-options:      -DHAVE_TERMINFO -  extensions:-    CPP,-    ForeignFunctionInterface,-    BangPatterns,-    PatternGuards,-    MagicHash,-    UndecidableInstances,-    DeriveDataTypeable,-    GADTs,-    ImpredicativeTypes,-    TypeOperators,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    ScopedTypeVariables,-    KindSignatures,-    TypeSynonymInstances,-    Rank2Types,-    RankNTypes,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses+    if flag(color)+      x-use-color: +    extensions:+      CPP,+      ForeignFunctionInterface,+      BangPatterns,+      PatternGuards,+      MagicHash,+      UndecidableInstances,+      DeriveDataTypeable,+      GADTs,+      TypeOperators,+      ExistentialQuantification,+      FlexibleContexts,+      FlexibleInstances,+      ScopedTypeVariables,+      -- PatternSignatures is needed for GHC 6.8+      PatternSignatures,+      KindSignatures,+      TypeSynonymInstances,+      Rank2Types,+      RankNTypes,+      GeneralizedNewtypeDeriving,+      MultiParamTypeClasses+ -- ---------------------------------------------------------------------- -- darcs itself -- ----------------------------------------------------------------------@@ -424,7 +468,13 @@                     src/Crypt/sha2.c    -- We need optimizations, regardless of what Hackage says-  ghc-options:      -Wall -O2 -funbox-strict-fields+  -- Note: "if true" works around a cabal bug with order of flag composition+  if true+    ghc-options:      -Wall -O2 -funbox-strict-fields -fwarn-tabs++  if impl(ghc>=6.12)+    ghc-options: -fno-warn-unused-do-bind+   ghc-prof-options: -prof -auto-all   if flag(threaded)     ghc-options:    -threaded@@ -447,26 +497,29 @@                     Preproc     cpp-options:    -DWIN32     c-sources:      src/win32/send_email.c-    build-depends:  unix-compat >= 0.1.2+    build-depends:  unix-compat >= 0.1.2,+                    regex-posix >= 0.94.4 && < 0.95    if os(solaris)     cc-options:     -DHAVE_SIGINFO_H -  build-depends:   base          < 4,+  build-depends:   base          < 5,+                   extensible-exceptions >= 0.1 && < 0.2,                    regex-compat >= 0.71 && < 0.94,                    mtl          >= 1.0 && < 1.2,                    parsec       >= 2.0 && < 3.1,                    html         == 1.0.*,                    filepath     == 1.1.*,-                   haskeline    >= 0.6.1 && < 0.7,-                   hashed-storage == 0.4.13+                   haskeline    >= 0.6.2.2 && < 0.7,+                   hashed-storage >= 0.5.2 && < 0.6,+                   tar          == 0.3.*    if !os(windows)     build-depends: unix >= 1.0 && < 2.5    build-depends: base >= 3,                  bytestring >= 0.9.0 && < 0.10,-                 utf8-string == 0.3.*,+                 text >= 0.3,                    old-time   == 1.0.*,                    directory  == 1.0.*,                    process    == 1.0.*,@@ -481,12 +534,6 @@     c-sources:         src/hscurl.c     cc-options:        -DHAVE_CURL -    if flag(curl-pipelining)-      -- curl 7.19.1 has bug-free pipelining-      if !os(windows)-        pkgconfig-depends: libcurl >= 7.19.1-      cpp-options:       -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT-   if flag(http)       build-depends:    network == 2.2.*,                         HTTP    >= 3000.0 && < 4000.1@@ -497,7 +544,7 @@       buildable: False    if flag(mmap) && !os(windows)-    build-depends:    mmap >= 0.2 && < 0.5+    build-depends:    mmap >= 0.5 && < 0.6     cpp-options:      -DHAVE_MMAP    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0@@ -519,12 +566,13 @@     UndecidableInstances,     DeriveDataTypeable,     GADTs,-    ImpredicativeTypes,     TypeOperators,     ExistentialQuantification,     FlexibleContexts,     FlexibleInstances,     ScopedTypeVariables,+    -- PatternSignatures is needed for GHC 6.8+    PatternSignatures,     KindSignatures,     TypeSynonymInstances,     Rank2Types,@@ -537,33 +585,14 @@ -- ----------------------------------------------------------------------  Executable          unit-  main-is:          unit.lhs-  hs-source-dirs:   src-  include-dirs:     src-  c-sources:        src/atomic_create.c-                    src/fpstring.c-                    src/maybe_relink.c-                    src/umask.c-                    src/Crypt/sha2.c-  -- list all unit test modules not exported by libdarcs; otherwise Cabal won't-  -- include them in the tarball-  other-modules:    Darcs.Test.Email-                    Darcs.Test.Patch.Check-                    Darcs.Test.Patch.QuickCheck-                    Darcs.Test.Patch.Test-                    Darcs.Test.Patch.Unit--  -- We need optimizations, regardless of what Hackage says-  ghc-options:      -Wall -O2 -funbox-strict-fields-  ghc-prof-options: -prof -auto-all-  if flag(threaded)-    ghc-options:    -threaded+  main-is:          unit.hs    if !flag(test)     buildable: False   else     buildable: True-    build-depends:   base          < 4,+    build-depends:   base          < 5,+                     extensible-exceptions >= 0.1 && < 0.2,                      regex-compat >= 0.71 && < 0.94,                      mtl          >= 1.0 && < 1.2,                      parsec       >= 2.0 && < 3.1,@@ -576,66 +605,105 @@                      test-framework-quickcheck2 >= 0.2.2  -  cc-options:       -D_REENTRANT+    hs-source-dirs:   src+    include-dirs:     src+    c-sources:        src/atomic_create.c+                      src/fpstring.c+                      src/maybe_relink.c+                      src/umask.c+                      src/Crypt/sha2.c+    -- list all unit test modules not exported by libdarcs; otherwise Cabal won't+    -- include them in the tarball+    other-modules:    Darcs.Test.Email+                      Darcs.Test.Patch.Check+                      Darcs.Test.Patch.Info+                      Darcs.Test.Patch.QuickCheck+                      Darcs.Test.Patch.Test+                      Darcs.Test.Patch.Unit+                      Darcs.Test.Unit -  if os(windows)-    hs-source-dirs: src/win32-    include-dirs:   src/win32-    other-modules:  CtrlC-                    System.Posix-                    System.Posix.Files-                    System.Posix.IO-    cpp-options:    -DWIN32-    c-sources:      src/win32/send_email.c-    build-depends:  unix-compat >= 0.1.2+    -- We need optimizations, regardless of what Hackage says+    -- Note: "if true" works around a cabal bug with order of flag composition+    if true+      ghc-options:      -Wall -O2 -funbox-strict-fields -fwarn-tabs -  if os(solaris)-    cc-options:     -DHAVE_SIGINFO_H+    if impl(ghc>=6.12)+      ghc-options: -fno-warn-unused-do-bind -  if !os(windows)-    build-depends: unix >= 1.0 && < 2.5+    ghc-prof-options: -prof -auto-all+    if flag(threaded)+      ghc-options:    -threaded -  build-depends: base >= 3,-                 bytestring >= 0.9.0 && < 0.10,+    cc-options:       -D_REENTRANT++    if os(windows)+      hs-source-dirs: src/win32+      include-dirs:   src/win32+      other-modules:  CtrlC+                      System.Posix+                      System.Posix.Files+                      System.Posix.IO+      cpp-options:    -DWIN32+      c-sources:      src/win32/send_email.c+      build-depends:  unix-compat >= 0.1.2,+                      regex-posix >= 0.94.4 && < 0.95++    if os(solaris)+      cc-options:     -DHAVE_SIGINFO_H++    if !os(windows)+      build-depends: unix >= 1.0 && < 2.5++    build-depends: base >= 3,+                   bytestring >= 0.9.0 && < 0.10,+                   haskeline    >= 0.6.2.2 && < 0.7,+                   text >= 0.3,                    old-time   == 1.0.*,                    directory  == 1.0.*,                    process    == 1.0.*,                    containers >= 0.1 && < 0.4,                    array      >= 0.1 && < 0.4,+                   hashed-storage >= 0.5.2 && < 0.6,                    random     == 1.0.* -  if flag(mmap) && !os(windows)-    build-depends:    mmap >= 0.2 && < 0.5-    cpp-options:      -DHAVE_MMAP+    if flag(mmap) && !os(windows)+      build-depends:    mmap >= 0.5 && < 0.6+      cpp-options:      -DHAVE_MMAP -  build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0+    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0 -  -- The terminfo package cannot be built on Windows.-  if flag(terminfo) && !os(windows)-    build-depends:    terminfo == 0.3.*-    cpp-options:      -DHAVE_TERMINFO+    -- The terminfo package cannot be built on Windows.+    if flag(terminfo) && !os(windows)+      build-depends:    terminfo == 0.3.*+      cpp-options:      -DHAVE_TERMINFO -  if flag(color)-    x-use-color:+    if flag(http)+        build-depends:    network == 2.2.*,+                          HTTP    >= 3000.0 && < 4000.1 -  extensions:-    CPP,-    ForeignFunctionInterface,-    BangPatterns,-    PatternGuards,-    MagicHash,-    UndecidableInstances,-    DeriveDataTypeable,-    GADTs,-    TypeOperators,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    ScopedTypeVariables,-    KindSignatures,-    TypeSynonymInstances,-    Rank2Types,-    RankNTypes,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses-    OverlappingInstances+    if flag(color)+      x-use-color:++    extensions:+      CPP,+      ForeignFunctionInterface,+      BangPatterns,+      PatternGuards,+      MagicHash,+      UndecidableInstances,+      DeriveDataTypeable,+      GADTs,+      TypeOperators,+      ExistentialQuantification,+      FlexibleContexts,+      FlexibleInstances,+      ScopedTypeVariables,+      -- PatternSignatures is needed for GHC 6.8+      PatternSignatures,+      KindSignatures,+      TypeSynonymInstances,+      Rank2Types,+      RankNTypes,+      GeneralizedNewtypeDeriving,+      MultiParamTypeClasses+      OverlappingInstances

@@ -28,6 +28,10 @@   height: 50px; } +BLOCKQUOTE.testimonial {+  font-style: italic;+}+ PRE     {   background: #eeeeee;   border: 1px solid #888888;

@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.4.4\nEric Kow <kowey@darcs.net>**20100515090819\n Ignore-this: 7d1a0e6a17c2be314f6ab1607bbcac13\n] \n"+Just "\nContext:\n\n[TAG 2.5\nReinier Lamers <tux_rocker@reinier.de>**20101024151805\n Ignore-this: 1561ce30bfb1950a440c03371e0e2f20\n] \n"

@@ -12,18 +12,22 @@ -- Stability   :  experimental -- Portability :  portable ----- GZIp and MMap IO for ByteStrings, and miscellaneous functions for Data.ByteString+-- GZIp and MMap IO for ByteStrings, encoding utilities, and miscellaneous+-- functions for Data.ByteString --  module ByteStringUtils (          unsafeWithInternals,+        unpackPSFromUTF8,+        packStringToUTF8,          -- IO with mmap or gzip         gzReadFilePS,         mmapFilePS,         gzWriteFilePS,         gzWriteFilePSs,+        gzReadStdin,          -- gzip handling         isGZFile,@@ -40,13 +44,20 @@         breakLastPS,         substrPS,         readIntPS,-        is_funky,+        isFunky,         fromHex2PS,         fromPS2Hex,         betweenLinesPS,-        break_after_nth_newline,-        break_before_nth_newline,-        intercalate+        breakAfterNthNewline,+        breakBeforeNthNewline,+        intercalate,++        -- encoding and unicode utilities+        decodeLocale,+        encodeLocale,+        encodeLatin1,+        decodeString,+        utf8ToLocale     ) where  import Prelude hiding ( catch )@@ -57,10 +68,12 @@ import Data.ByteString.Internal (fromForeignPtr)  #if defined (HAVE_MMAP)-import Control.Exception        ( catch )+import Control.Exception.Extensible ( catch, SomeException ) #endif import System.IO import System.IO.Unsafe         ( unsafePerformIO )+import System.Console.Haskeline ( runInputT, defaultSettings )+import System.Console.Haskeline.Encoding ( decode, encode )  import Foreign.Storable         ( peekElemOff, peek ) import Foreign.Marshal.Array    ( advancePtr )@@ -70,6 +83,9 @@ import Data.Char                ( ord, isSpace ) import Data.Word                ( Word8 ) import Data.Int                 ( Int32 )+import qualified Data.Text as T ( pack, unpack )+import Data.Text.Encoding       ( encodeUtf8, decodeUtf8With )+import Data.Text.Encoding.Error ( lenientDecode ) import Control.Monad            ( when )  import Foreign.Ptr              ( plusPtr, Ptr )@@ -114,6 +130,17 @@ readIntPS = BC.readInt . BC.dropWhile isSpace  -- -----------------------------------------------------------------------------+-- Destructor functions (taking PackedStrings apart)++-- | Decodes a 'ByteString' containing UTF-8 to a 'String'. Decoding errors are+--   flagged with the U+FFFD character.+unpackPSFromUTF8 :: B.ByteString -> String+unpackPSFromUTF8  = T.unpack . decodeUtf8With lenientDecode++packStringToUTF8 :: String -> B.ByteString+packStringToUTF8 = encodeUtf8 . T.pack++-- ----------------------------------------------------------------------------- -- List-mimicking functions for PackedStrings  {-# INLINE ifHeadThenTail #-}@@ -154,7 +181,7 @@ -- | 'dropSpace' efficiently returns the 'ByteString' argument with -- white space Chars removed from the front. It is more efficient than -- calling dropWhile for removing whitespace. I.e.--- +-- -- > dropWhile isSpace == dropSpace -- dropSpace :: B.ByteString -> B.ByteString@@ -165,7 +192,7 @@  -- | 'breakSpace' returns the pair of ByteStrings when the argument is -- broken at the first whitespace byte. I.e.--- +-- -- > break isSpace == breakSpace -- breakSpace :: B.ByteString -> (B.ByteString,B.ByteString)@@ -180,9 +207,9 @@  ------------------------------------------------------------------------ -{-# INLINE is_funky #-}-is_funky :: B.ByteString -> Bool-is_funky ps = case BI.toForeignPtr ps of+{-# INLINE isFunky #-}+isFunky :: B.ByteString -> Bool+isFunky ps = case BI.toForeignPtr ps of    (x,s,l) ->     unsafePerformIO $ withForeignPtr x $ \p->     (/=0) `fmap` has_funky_char (p `plusPtr` s) (fromIntegral l)@@ -372,6 +399,20 @@ gzWriteFilePSs f pss  =     BL.writeFile f $ GZ.compress $ BL.fromChunks pss +-- | Read standard input, which may or may not be gzip compressed, directly+-- into a 'B.ByteString'.+gzReadStdin :: IO B.ByteString+gzReadStdin = do header <- B.hGet stdin 2+                 rest   <- B.hGetContents stdin+                 let allStdin = B.concat [header,rest]+                 return $+                  if header /= BC.pack "\31\139"+                   then allStdin+                   else let decompress = fst . gzDecompress Nothing+                            compressed = BL.fromChunks [allStdin]+                        in+                        B.concat $ decompress compressed+ -- ----------------------------------------------------------------------------- -- mmapFilePS @@ -390,7 +431,7 @@ #ifdef HAVE_MMAP mmapFilePS f = do   x <- mmapFileByteString f Nothing-   `catch` (\_ -> do+   `catch` (\(_ :: SomeException) -> do                      size <- fileSize `fmap` getSymbolicLinkStatus f                      if size == 0                         then return B.empty@@ -443,12 +484,12 @@        _ -> Nothing  -- ---------------------------------------------------------------------------- break_after_nth_newline+-- breakAfterNthNewline -break_after_nth_newline :: Int -> B.ByteString+breakAfterNthNewline :: Int -> B.ByteString                         -> Maybe (B.ByteString, B.ByteString)-break_after_nth_newline 0 the_ps | B.null the_ps = Just (B.empty, B.empty)-break_after_nth_newline n the_ps =+breakAfterNthNewline 0 the_ps | B.null the_ps = Just (B.empty, B.empty)+breakAfterNthNewline n the_ps =   case BI.toForeignPtr the_ps of   (fp,the_s,l) ->    unsafePerformIO $ withForeignPtr fp $ \p ->@@ -465,12 +506,12 @@       findit n the_s  -- ---------------------------------------------------------------------------- break_before_nth_newline+-- breakBeforeNthNewline -break_before_nth_newline :: Int -> B.ByteString -> (B.ByteString, B.ByteString)-break_before_nth_newline 0 the_ps+breakBeforeNthNewline :: Int -> B.ByteString -> (B.ByteString, B.ByteString)+breakBeforeNthNewline 0 the_ps  | B.null the_ps = (B.empty, B.empty)-break_before_nth_newline n the_ps =+breakBeforeNthNewline n the_ps =  case BI.toForeignPtr the_ps of  (fp,the_s,l) ->    unsafePerformIO $ withForeignPtr fp $ \p ->@@ -486,3 +527,31 @@           nl = BI.c2w '\n'           end = the_s + l       findit n the_s++-- | Decode a ByteString to a String according to the current locale+-- unsafePerformIO in the locale function is ratified by the fact that GHC 6.12+-- and above also supply locale conversion with functions with a pure type.+-- Unrecognized byte sequences in the input are skipped.+decodeLocale :: B.ByteString -> String+decodeLocale = unsafePerformIO . runInputT defaultSettings . decode++-- | Encode a String to a ByteString with latin1 (i.e., the values of the+-- characters become the values of the bytes; if a character value is greater+-- than 255, its byte becomes the character value modulo 256)+encodeLatin1 :: String -> B.ByteString+encodeLatin1 = B.pack . (map (fromIntegral . ord))++-- | Encode a String to a ByteString according to the current locale+encodeLocale :: String -> B.ByteString+encodeLocale = unsafePerformIO . runInputT defaultSettings . encode++-- | Take a @String@ that represents byte values and re-decode it acording to+-- the current locale.+decodeString :: String -> String+decodeString = decodeLocale . encodeLatin1++-- | Convert a bytestring representing a text from UTF-8 to the current locale+utf8ToLocale :: B.ByteString -> B.ByteString+utf8ToLocale bs = encodeLocale string+  where string = unpackPSFromUTF8 bs+

@@ -51,7 +51,7 @@ -- eg (c,s) means that %c is replaced by s type FTable = [(Char,String)] commandline :: FTable -> Parser ([String], Bool)-commandline ftable = consumeAll (do l <- sepEndBy1 (arg ftable) +commandline ftable = consumeAll (do l <- sepEndBy1 (arg ftable)                                                    (try separator)                                     redir <- formatRedir                                     spaces@@ -90,7 +90,7 @@ consumeAll p = do r <- p                   eof                   return r-                + separator :: Parser () separator = do skipMany1 space @@ -99,7 +99,7 @@                           Just (_,s) -> s                           Nothing -> error "impossible" --- | parse a commandline returning a list of strings +-- | parse a commandline returning a list of strings -- (intended to be used as argv) and a bool value which -- specifies if the command expects input on stdin -- format specifiers with a mapping in ftable are accepted@@ -111,7 +111,7 @@ urlEncode :: String -> String 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]    +          intToHex i = map intToDigit [i `div` 16, i `mod` 16]           allowed x = x `elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']                       ++ "!'()*-.~" 

@@ -16,11 +16,12 @@ %  Boston, MA 02110-1301, USA.  \begin{code}-module Darcs.ArgumentDefaults ( get_default_flags ) where+module Darcs.ArgumentDefaults ( getDefaultFlags ) where import Data.Maybe ( catMaybes, listToMaybe, mapMaybe )  import Darcs.Arguments ( DarcsFlag,-                         DarcsOption( DarcsArgOption, DarcsNoArgOption, DarcsMultipleChoiceOption ),+                         atomicOptions, DarcsAtomicOption( .. ), DarcsOption ( .. ),+                         applyDefaults,                          arein, isin ) import Darcs.Commands ( CommandControl( CommandData ),                         commandAlloptions )@@ -42,7 +43,7 @@ option without the ``\verb!--!'', i.e.\ \verb!verbose! rather than \verb!--verbose!.  Finally, the \verb!VALUE! option can be omitted if the flag is one such as \verb!verbose! that doesn't involve a value.-If the value has spaces in it, use single quotes, not double quotes, to surround it. +If the value has spaces in it, use single quotes, not double quotes, to surround it. Each line only takes one flag.  To set multiple defaults for the same command (or for \verb!ALL! commands), use multiple lines. @@ -110,59 +111,58 @@ \end{verbatim}  Also, a global preferences file can be created with the name-\verb!.darcs/defaults! in your home directory, on MS Windows~\ref{ms_win}. +\verb!.darcs/defaults! in your home directory, on MS Windows~\ref{ms_win}. Options present there will be added to the repository-specific preferences. If they conflict with repository-specific options, the repository-specific ones will take precedence.  \begin{code}-get_default_flags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag]-get_default_flags com com_opts already = do-    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+getDefaultFlags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag]+getDefaultFlags com com_opts already = do+    repo_defs   <- defaultContent $ getPreflist "defaults"+    global_defs <- defaultContent $ getGlobal   "defaults"+    let repo_flags = getFlagsFrom com com_opts already repo_defs+        global_flags = getFlagsFrom com com_opts                                           (already++repo_flags) global_defs-    return $ repo_flags ++ global_flags+    return $ applyDefaults com_opts     -- hard-coded defaults (respects user preferences)+           $ repo_flags ++ global_flags -- user preferences -get_flags_from :: String -> [DarcsOption] -> [DarcsFlag] -> [(String,String,String)] -> [DarcsFlag]-get_flags_from com com_opts already defs =+getFlagsFrom :: String -> [DarcsOption] -> [DarcsFlag] -> [(String,String,String)] -> [DarcsFlag]+getFlagsFrom com com_opts already defs =     options_for com_defs com_opts com_opts ++     options_for all_defs com_opts all_opts     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+          options_for d o ao = concatMap (findOption o ao already) d           all_opts = concatMap get_opts commandControlList           get_opts (CommandData c) = let (o1, o2) = commandAlloptions c                                       in o1 ++ o2           get_opts _                = [] -find_option :: [DarcsOption] -> [DarcsOption] -> [DarcsFlag] -> (String,String,String) -> [DarcsFlag]-find_option opts all_opts already (c, f, d) =+findOption :: [DarcsOption] -> [DarcsOption] -> [DarcsFlag] -> (String,String,String) -> [DarcsFlag]+findOption opts all_opts already (c, f, d) =     if null $ mapMaybe choose_option all_opts     then error $ "Bad default option: command '"++c++"' has no option '"++f++"'."     else concat $ mapMaybe choose_option opts-    where choose_option (DarcsNoArgOption _ fls o _)-              | o `elem` already = Just []+    where choose_atomic_option (DarcsNoArgOption _ fls o _)               | f `elem` fls = if null d                                then Just [o]                                else error $ "Bad default option: '"++f                                         ++"' takes no argument, but '"++d                                         ++"' argument given."-          choose_option (DarcsArgOption _ fls o _ _)-              | o `isin` already = Just []+          choose_atomic_option ao@(DarcsArgOption _ fls o _ _)               | f `elem` fls = if null d                                then error $ "Bad default option: '"++f                                         ++"' requires an argument, but no "                                         ++"argument given."                                else Just [o d]-          choose_option (DarcsMultipleChoiceOption os)-              | os `arein` already = Just []-              | otherwise = listToMaybe $ mapMaybe choose_option os-          choose_option _ = Nothing+          choose_atomic_option _ = Nothing+          choose_option o+              | o `arein` already = Just []+              | otherwise = listToMaybe $ mapMaybe choose_atomic_option $ atomicOptions o -default_content :: IO [String] -> IO [(String,String,String)]-default_content = fmap (catMaybes . map (doline.words))+defaultContent :: IO [String] -> IO [(String,String,String)]+defaultContent = fmap (catMaybes . map (doline.words))     where doline (c:a:r) = Just (c, drop_dashdash a, unwords r)           doline _ = Nothing           drop_dashdash ('-':'-':a) = a

@@ -21,17 +21,17 @@  #include "gadts.h" -module Darcs.Arguments ( DarcsFlag( .. ), flagToString,+module Darcs.Arguments ( DarcsFlag( .. ), flagToString, applyDefaults, nubOptions,                          maxCount,                          isin, arein,                          definePatches, defineChanges,-                         fixFilePathOrStd, fixUrl,+                         fixFilePathOrStd, fixUrl, fixUrlFlag,                          fixSubPaths, areFileArgs,-                         DarcsOption( .. ), optionFromDarcsoption,+                         DarcsAtomicOption( .. ), atomicOptions,+                         DarcsOption( .. ), optionFromDarcsOption,                          help, listOptions, listFiles,                          anyVerbosity, disable, restrictPaths,                          notest, test, workingRepoDir,-                         testByDefault,                          remoteRepo,                          leaveTestDir,                          possiblyRemoteRepoDir, getRepourl,@@ -45,7 +45,7 @@                          recursive, inventoryChoices, getInventoryChoices,                          upgradeFormat,                          askdeps, ignoretimes, lookforadds,-                         askLongComment, sendmailCmd,+                         askLongComment, keepDate, sendmailCmd,                          environmentHelpSendmail,                          sign, verify, editDescription,                          reponame, creatorhash,@@ -73,7 +73,7 @@                          matchSeveralOrLast,                          setDefault,                          fancyMoveAdd,-                         setScriptsExecutableOption,+                         setScriptsExecutableOption, bisect,                          sibling, flagsToSiblings, relink, relinkPristine, nolinks,                          files, directories, pending,                          posthookCmd, posthookPrompt,@@ -85,7 +85,8 @@                          patchSelectFlag,                          networkOptions, noCache,                          allowUnrelatedRepos,-                         checkOrRepair, justThisRepo, optimizePristine+                         checkOrRepair, justThisRepo, optimizePristine,+                         optimizeHTTP, getOutput                       ) where import System.Console.GetOpt import System.Directory ( doesDirectoryExist )@@ -95,9 +96,8 @@ import Storage.Hashed.Tree( list, expand, emptyTree )  import Data.List ( (\\), nub )-import Data.Maybe ( fromMaybe, listToMaybe )+import Data.Maybe ( fromMaybe, listToMaybe, mapMaybe ) import System.Exit ( ExitCode(ExitSuccess), exitWith )-import Data.Maybe ( catMaybes ) import Control.Monad ( when, unless ) import Control.Applicative( (<$>) ) import Data.Char ( isDigit )@@ -110,25 +110,25 @@  import Darcs.Hopefully ( PatchInfoAnd, info, hopefullyM ) import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xmlSummary )-import Darcs.Patch.Info ( to_xml )+import Darcs.Patch.Info ( toXml ) import Darcs.Witnesses.Ordered ( FL, mapFL ) import qualified Darcs.Patch ( summary ) import Darcs.Utils ( askUser, maybeGetEnv, firstNotBlank, firstJustIO,                      withCurrentDirectory ) import Darcs.Repository.Prefs ( getPreflist, getGlobal )-import Darcs.Repository.State ( restrictBoring, readRecordedAndPending )-import Darcs.URL ( is_file )+import Darcs.Repository.State ( restrictBoring, applyTreeFilter, readRecordedAndPending )+import Darcs.URL ( isFile ) import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd, SubPath, toFilePath,-                        makeSubPathOf, simpleSubPath,-                        ioAbsolute, ioAbsoluteOrStd,+                        makeSubPathOf, ioAbsolute, ioAbsoluteOrStd,                         makeAbsolute, makeAbsoluteOrStd, rootDirectory )-import Darcs.Patch.MatchData ( patch_match )-import Darcs.Flags ( DarcsFlag(..), maxCount )+import Darcs.Patch.MatchData ( patchMatch )+import Darcs.Flags ( DarcsFlag(..), maxCount, defaultFlag ) import Darcs.Repository ( withRepository ) import Darcs.Global ( darcsdir )-import Printer ( Doc, putDocLn, text, vsep, ($$), vcat, insert_before_lastline,+import Darcs.Lock ( writeLocaleFile )+import Printer ( Doc, putDocLn, text, vsep, ($$), vcat, insertBeforeLastline,                  prefix )-import URL ( pipeliningEnabledByDefault )+import ByteStringUtils ( decodeString ) #include "impossible.h"  data FlagContent = NoContent | AbsoluteContent AbsolutePath | AbsoluteOrStdContent AbsolutePathOrStd | StringContent String@@ -226,6 +226,8 @@ getContent EditLongComment = NoContent getContent NoEditLongComment = NoContent getContent PromptLongComment = NoContent+getContent KeepDate = NoContent+getContent NoKeepDate = NoContent getContent AllowConflicts = NoContent getContent MarkConflicts = NoContent getContent NoAllowConflicts = NoContent@@ -276,6 +278,7 @@ getContent Disable = NoContent getContent SetScriptsExecutable = NoContent getContent DontSetScriptsExecutable = NoContent+getContent Bisect = NoContent getContent UseHashedInventory = NoContent getContent UseOldFashionedInventory = NoContent getContent UseFormat2 = NoContent@@ -302,7 +305,6 @@ getContent AskPrehook = NoContent getContent StoreInMemory = NoContent getContent ApplyOnDisk = NoContent-getContent HTTPPipelining = NoContent getContent NoHTTPPipelining = NoContent getContent NoCache = NoContent getContent NullFlag = NoContent@@ -313,6 +315,7 @@ getContent Repair = NoContent getContent JustThisRepo = NoContent getContent OptimizePristine = NoContent+getContent OptimizeHTTP = NoContent  getContentString :: DarcsFlag -> Maybe String getContentString f =@@ -343,23 +346,15 @@                           AbsoluteOrStdContent s -> f == x s                           _ -> False -isin :: (String->DarcsFlag) -> [DarcsFlag] -> Bool-f `isin` fs = any (`isa` f) fs+isin :: DarcsAtomicOption -> [DarcsFlag] -> Bool+(DarcsNoArgOption _ _ f _)          `isin` fs = f `elem` fs+(DarcsArgOption _ _ f _ _)          `isin` fs = any (`isa` f) fs+(DarcsAbsPathOption _ _ f _ _)      `isin` fs = any (`isAnAbsolute` f) fs+(DarcsAbsPathOrStdOption _ _ f _ _) `isin` fs = any (`isAnAbsoluteOrStd` f) fs+(DarcsOptAbsPathOption _ _ _ f _ _) `isin` fs = any (`isAnAbsolute` f) fs -arein :: [DarcsOption] -> [DarcsFlag] -> Bool-(DarcsNoArgOption _ _ f _ : dos') `arein` fs-    = f `elem` fs || dos' `arein` fs-(DarcsArgOption _ _ f _ _ : dos') `arein` fs-    = f `isin` fs || dos' `arein` fs-(DarcsAbsPathOption _ _ f _ _ : dos') `arein` fs-    = any (`isAnAbsolute` f) fs || dos' `arein` fs-(DarcsAbsPathOrStdOption _ _ f _ _ : dos') `arein` fs-    = any (`isAnAbsoluteOrStd` f) fs || dos' `arein` fs-(DarcsOptAbsPathOption _ _ _ f _ _ : dos') `arein` fs-    = any (`isAnAbsolute` f) fs || dos' `arein` fs-(DarcsMultipleChoiceOption os: dos') `arein` fs-    = os `arein` fs || dos' `arein` fs-[] `arein` _ = False+arein :: DarcsOption -> [DarcsFlag] -> Bool+o `arein` fs = any (`isin` fs) (atomicOptions o)  -- | A type for darcs' options. The value contains the command line -- switch(es) for the option, a help string, and a function to build a@@ -369,7 +364,7 @@ -- switches, optDescr the description of the option, and argDescr the description -- of its argument, if any. mkFlag is a function which makes a @DarcsFlag@ from -- the arguments of the option.-data DarcsOption+data DarcsAtomicOption     = DarcsArgOption [Char] [String] (String->DarcsFlag) String String     -- ^ @DarcsArgOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@     -- The constructor for options with a string argument, such as@@ -395,25 +390,71 @@     -- ^ @DarcsNoArgOption shortSwitches longSwitches mkFlag optDescr@     -- The constructon fon options with no arguments. -    | DarcsMultipleChoiceOption [DarcsOption]+data DarcsOption+    = DarcsSingleOption DarcsAtomicOption+    | DarcsMultipleChoiceOption [DarcsAtomicOption]     -- ^ A constructor for grouping related options together, such as     -- @--hashed@, @--darcs-2@ and @--old-fashioned-inventory@. -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]+    | DarcsMutuallyExclusive [DarcsAtomicOption]          -- choices+                             ([DarcsFlag] -> [DarcsFlag]) -- setter +type NoArgPieces = (DarcsFlag -> String -> DarcsAtomicOption, DarcsFlag , String)++mkMutuallyExclusive :: [NoArgPieces] -- ^ before+                    -> NoArgPieces   -- ^ default+                    -> [NoArgPieces] -- ^ after+                    -> DarcsOption+mkMutuallyExclusive os1 od_ os2 =+  DarcsMutuallyExclusive (map option (os1 ++ (od : os2)))+                         (defaultFlag (map flag (os1 ++ os2)) (flag od))+ where+  od = third (++ " [DEFAULT]") od_+  flag (_,f,_) = f+  option (x,y,z) = x y z+  third f (x,y,z) = (x,y,f z)++nubOptions [] opts = opts+nubOptions (DarcsMutuallyExclusive ch _:options) opts = nubOptions options $ collapse opts+  where collapse (x:xs) | x `elem` flags ch = x : clear xs+                        | otherwise = x : collapse xs+        collapse [] = []+        clear (x:xs) | x `elem` flags ch = clear xs+                     | otherwise = x : clear xs+        clear [] = []+        flags (DarcsNoArgOption _ _ fl _:xs) = fl : flags xs+        flags (_:xs) = flags xs+        flags [] = []+nubOptions (_:options) opts = nubOptions options opts++applyDefaults :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]+applyDefaults opts = foldr (.) id (mapMaybe getSetter opts)+ where+  getSetter (DarcsMutuallyExclusive _ f) = Just f+  getSetter _ = Nothing++optionFromDarcsAtomicOption :: AbsolutePath -> DarcsAtomicOption -> OptDescr DarcsFlag+optionFromDarcsAtomicOption _ (DarcsNoArgOption a b c h) = Option a b (NoArg c) h+optionFromDarcsAtomicOption _ (DarcsArgOption a b c n h) = Option a b (ReqArg c n) h+optionFromDarcsAtomicOption wd (DarcsAbsPathOrStdOption a b c n h) =+  Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h+optionFromDarcsAtomicOption wd (DarcsAbsPathOption a b c n h) =+  Option a b (ReqArg (c . makeAbsolute wd) n) h+optionFromDarcsAtomicOption wd (DarcsOptAbsPathOption a b d c n h) =+  Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h++atomicOptions :: DarcsOption -> [DarcsAtomicOption]+atomicOptions (DarcsSingleOption x) = [x]+atomicOptions (DarcsMultipleChoiceOption xs) = xs+atomicOptions (DarcsMutuallyExclusive xs _) = xs++optionFromDarcsOption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]+optionFromDarcsOption wd = map (optionFromDarcsAtomicOption wd) . atomicOptions+ -- | 'concat_option' creates a DarcsMultipleChoiceOption from a list of -- option, flattening any DarcsMultipleChoiceOption in the list. concatOptions :: [DarcsOption] -> DarcsOption-concatOptions os = DarcsMultipleChoiceOption $ concatMap from_option os- where-  from_option (DarcsMultipleChoiceOption xs) = xs-  from_option x = [x]+concatOptions = DarcsMultipleChoiceOption . concatMap atomicOptions  extractFixPath :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath) extractFixPath [] = Nothing@@ -431,11 +472,25 @@       Nothing -> bug "Can't fix path in fixFilePathOrStd"       Just (_,o) -> withCurrentDirectory o $ ioAbsoluteOrStd f +fixUrlFlag :: [DarcsFlag] -> DarcsFlag -> IO DarcsFlag+fixUrlFlag opts (RemoteRepo f) = RemoteRepo `fmap` fixUrl opts f+fixUrlFlag _ f = return f+ fixUrl :: [DarcsFlag] -> String -> IO String-fixUrl opts f = if is_file f+fixUrl opts f = if isFile f                 then toFilePath `fmap` fixFilePath opts f                 else return f +-- | @fixSubPaths files@ returns the @SubPath@s for the paths in @files@ that+-- are inside the repository, preserving their order. Paths in @files@ that are+-- outside the repository directory are not in the result.+--+-- When converting a relative path to an absolute one, this function first tries+-- to interpret the relative path with respect to the current working directory.+-- If that fails, it tries to interpret it with respect to the repository+-- directory. Only when that fails does it omit the path from the result.+--+-- It is intended for validating file arguments to darcs commands. fixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [SubPath] fixSubPaths flags fs =     withCurrentDirectory o $@@ -451,7 +506,11 @@     fixit p = do ap <- ioAbsolute p                  case makeSubPathOf r ap of                    Just sp -> return $ Right sp-                   Nothing -> return $ maybe (Left p) Right $ simpleSubPath p+                   Nothing -> withCurrentDirectory r $ do+                     absolutePathByRepodir <- ioAbsolute p+                     return $ case makeSubPathOf r absolutePathByRepodir of+                                Just sp -> Right sp+                                Nothing -> Left p  partitionEither :: [Either a b] -> ([b],[a]) partitionEither es = ( [b | Right b <- es]@@ -463,32 +522,20 @@  -- | 'list_option' is an option which lists the command's arguments listOptions :: DarcsOption-listOptions = DarcsNoArgOption [] ["list-options"] ListOptions+listOptions = DarcsSingleOption $ 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 <- getContentString f-                                                  if c arg == f-                                                      then return $ unwords [('-':'-':s), arg]-                                                      else Nothing+flagToString x f = listToMaybe $ mapMaybe f2o $ concatMap atomicOptions x+    where f2o (DarcsArgOption _ (s:_) c _ _) =+            do arg <- getContentString f+               if c arg == f+                  then return $ unwords [('-':'-':s), arg]+                  else Nothing           f2o (DarcsNoArgOption _ (s:_) f' _) | f == f' = Just ('-':'-':s)-          f2o (DarcsMultipleChoiceOption xs) = maybeHead $ catMaybes $ map f2o xs           f2o _ = Nothing-          maybeHead (a:_) = Just a-          maybeHead [] = Nothing -reponame :: DarcsOption-depsSel :: DarcsOption-partial :: DarcsOption-partialCheck :: DarcsOption-tokens :: DarcsOption-workingRepoDir :: DarcsOption-possiblyRemoteRepoDir :: DarcsOption-disable :: DarcsOption-restrictPaths :: DarcsOption--pipeInteractive, allPipeInteractive, allInteractive, all_patches, interactive, pipe,+pipeInteractive, allPipeInteractive, allInteractive,   humanReadable, diffflags, allowProblematicFilenames, noskipBoring,   askLongComment, matchOneNontag, changesReverse, creatorhash,   changesFormat, matchOneContext, happyForwarding, sendToContext,@@ -501,12 +548,10 @@   author, askdeps, lookforadds, ignoretimes, test, notest, help, forceReplace,   allowUnrelatedRepos,   matchOne, matchRange, matchSeveral, fancyMoveAdd, sendmailCmd,-  logfile, rmlogfile, leaveTestDir, fromOpt, setDefault+  logfile, rmlogfile, leaveTestDir, fromOpt        :: DarcsOption -recursive :: String -> DarcsOption- sign, applyas, verify :: DarcsOption \end{code} @@ -525,7 +570,7 @@ % darcs COMMAND --help \end{verbatim} \begin{code}-help = DarcsNoArgOption ['h'] ["help"] Help+help = DarcsSingleOption $ DarcsNoArgOption ['h'] ["help"] Help        "shows brief description of command and its arguments" \end{code} @@ -537,7 +582,8 @@ can be helpful if you want to protect the repository from accidental use of advanced commands like obliterate, unpull, unrecord or amend-record. \begin{code}-disable = DarcsNoArgOption [] ["disable"] Disable+disable :: DarcsOption+disable = DarcsSingleOption $ DarcsNoArgOption [] ["disable"] Disable         "disable this command" \end{code} @@ -573,7 +619,8 @@                  "suppress informational output",                  DarcsNoArgOption [] ["standard-verbosity"] NormalVerbosity                  "neither verbose nor quiet output"],-                 DarcsNoArgOption [] ["timings"] Timings "provide debugging timings information"]+               DarcsSingleOption+                (DarcsNoArgOption [] ["timings"] Timings "provide debugging timings information")] \end{code}  \begin{options}@@ -588,9 +635,12 @@ when running \verb'apply' from a mailer.  \begin{code}-workingRepoDir = DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY"+workingRepoDir :: DarcsOption+workingRepoDir = DarcsSingleOption $ DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY"              "specify the repository directory in which to run"-possiblyRemoteRepoDir = DarcsArgOption [] ["repo"] WorkRepoUrl "URL"++possiblyRemoteRepoDir :: DarcsOption+possiblyRemoteRepoDir = DarcsSingleOption $ DarcsArgOption [] ["repo"] WorkRepoUrl "URL"              "specify the repository URL"  -- | 'getRepourl' takes a list of flags and returns the url of the@@ -598,7 +648,7 @@ -- This flag is present if darcs was invoked with @--repodir=DIRECTORY@ getRepourl :: [DarcsFlag] -> Maybe String getRepourl [] = Nothing-getRepourl (WorkRepoUrl d:_) | not (is_file d) = Just d+getRepourl (WorkRepoUrl d:_) | not (isFile d) = Just d getRepourl (_:fs) = getRepourl fs \end{code} @@ -619,7 +669,7 @@ -- | 'remoteRepo' is the option used to specify the URL of the remote -- repository to work with remoteRepo :: DarcsOption-remoteRepo = DarcsArgOption [] ["remote-repo"] RemoteRepo "URL"+remoteRepo = DarcsSingleOption $ DarcsArgOption [] ["remote-repo"] RemoteRepo "URL"              "specify the remote repository URL to work with" \end{code} @@ -627,10 +677,10 @@ \input{Darcs/Patch/Match.lhs}  \begin{code}-patchnameOption = DarcsArgOption ['m'] ["patch-name"] PatchName "PATCHNAME"-                   "name of patch"+patchnameOption = DarcsSingleOption $ DarcsArgOption ['m'] ["patch-name"]+                   (PatchName . decodeString) "PATCHNAME" "name of patch" -sendToContext = DarcsAbsPathOption [] ["context"] Context "FILENAME"+sendToContext = DarcsSingleOption $ DarcsAbsPathOption [] ["context"] Context "FILENAME"                   "send to context stored in FILENAME"  matchOneContext =@@ -643,15 +693,23 @@      DarcsAbsPathOption [] ["context"] Context "FILENAME"      "version specified by the context in FILENAME"     ]-    where mp s = OnePattern (patch_match s)+    where mp s = OnePattern (patchMatch s) -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]-matchSeveralOrLast  = concatOptions [matchFrom, __last, __matches, __patches, __tags]+matchOne = DarcsMultipleChoiceOption [__match, __patch, __tag, __index]+                                            -- [NOTE --index removed from matchOneNontag because issue1926]+                                            -- The --index option was removed for 2.5 release because it isn't handled+                                            -- by amend-record (see issue1926).+                                            --+                                            -- At this moment, amend-record is the only command that uses 'matchOneNontag',+                                            -- so there is no other command affected.+matchOneNontag  = DarcsMultipleChoiceOption [__match, __patch {- , __index -} ]+matchSeveral    = DarcsMultipleChoiceOption [__matches, __patches, __tags]+matchRange      = concatOptions $ [ matchTo, matchFrom+                                  , DarcsMultipleChoiceOption [__match, __patch, __last, __indexes] ]+matchSeveralOrRange = concatOptions [ matchTo, matchFrom+                                    , DarcsMultipleChoiceOption [ __last, __indexes, __matches, __patches, __tags] ]+matchSeveralOrLast  = concatOptions [ matchFrom+                                    , DarcsMultipleChoiceOption [ __last, __matches, __patches, __tags] ]  matchTo, matchFrom :: DarcsOption matchTo = DarcsMultipleChoiceOption@@ -661,7 +719,7 @@              "select changes up to a patch matching REGEXP",              DarcsArgOption [] ["to-tag"] UpToTag "REGEXP"              "select changes up to a tag matching REGEXP"]-    where uptop s = UpToPattern (patch_match s)+    where uptop s = UpToPattern (patchMatch s) matchFrom = DarcsMultipleChoiceOption               [DarcsArgOption [] ["from-match"] fromp "PATTERN"                "select changes starting with a patch matching PATTERN",@@ -669,9 +727,9 @@                "select changes starting with a patch matching REGEXP",                DarcsArgOption [] ["from-tag"] AfterTag "REGEXP"                "select changes starting with a tag matching REGEXP"]-    where fromp s = AfterPattern (patch_match s)+    where fromp s = AfterPattern (patchMatch s) -__tag, __tags, __patch, __patches, __match, __matches, __last, __index, __indexes :: DarcsOption+__tag, __tags, __patch, __patches, __match, __matches, __last, __index, __indexes :: DarcsAtomicOption  __tag = DarcsArgOption ['t'] ["tag"] OneTag "REGEXP"        "select tag matching REGEXP"@@ -685,10 +743,10 @@  __match = DarcsArgOption [] ["match"] mp "PATTERN"          "select a single patch matching PATTERN"-  where mp s = OnePattern (patch_match s)+  where mp s = OnePattern (patchMatch s) __matches = DarcsArgOption [] ["matches"] mp "PATTERN"            "select patches matching PATTERN"-  where mp s = SeveralPattern (patch_match s)+  where mp s = SeveralPattern (patchMatch s)  __last = DarcsArgOption [] ["last"] lastn "NUMBER"          "select the last NUMBER patches"@@ -710,7 +768,7 @@           isokay c = isDigit c || c == '-'  matchMaxcount :: DarcsOption-matchMaxcount = DarcsArgOption [] ["max-count"] mc "NUMBER"+matchMaxcount = DarcsSingleOption $ DarcsArgOption [] ["max-count"] mc "NUMBER"          "return only NUMBER results"     where mc = MaxCount . numberString @@ -732,9 +790,6 @@                   LeaveTestDir "don't remove the test directory",                   DarcsNoArgOption [] ["remove-test-directory"]                   NoLeaveTestDir "remove the test directory"]--testByDefault :: [DarcsFlag] -> [DarcsFlag]-testByDefault o = if NoTest `elem` o then o else Test:o \end{code}  \begin{options}@@ -751,7 +806,7 @@ \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 = +ignoretimes =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["ignore-times"] IgnoreTimes                          "don't trust the file modification times"@@ -788,6 +843,16 @@      "don't give a long comment",      DarcsNoArgOption [] ["prompt-long-comment"] PromptLongComment      "prompt for whether to edit the long comment"]++keepDate :: DarcsOption+keepDate =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["keep-date"] KeepDate+     "keep the date of the original patch",+     DarcsNoArgOption [] ["no-keep-date"] NoKeepDate+     "use the current date for the amended patch"+    ]+ \end{code}  \begin{options}@@ -796,7 +861,7 @@ \darcsEnv{DARCS_EMAIL}  \begin{code}-logfile = DarcsAbsPathOption [] ["logfile"] LogFile "FILE"+logfile = DarcsSingleOption $ DarcsAbsPathOption [] ["logfile"] LogFile "FILE"           "give patch name and comment in file"  rmlogfile = DarcsMultipleChoiceOption@@ -805,8 +870,10 @@              DarcsNoArgOption [] ["no-delete-logfile"] DontRmLogFile             "keep the logfile when done [DEFAULT]"] -author = DarcsArgOption ['A'] ["author"] Author "EMAIL" "specify author id"-fromOpt = DarcsArgOption [] ["from"] Author "EMAIL" "specify email address"+author = DarcsSingleOption $+  DarcsArgOption ['A'] ["author"] (Author . decodeString) "EMAIL" "specify author id"+fromOpt = DarcsSingleOption $+  DarcsArgOption [] ["from"] (Author . decodeString) "EMAIL" "specify email address"  fileHelpAuthor :: [String] fileHelpAuthor = [@@ -847,8 +914,8 @@             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") $-                    unlines ["# " ++ line | line <- fileHelpAuthor] ++ "\n" ++ add+          writeLocaleFile (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>)? " @@ -856,10 +923,15 @@ -- then from global preferences, then from environment variables. Returns 'Nothing' if it -- could not get it. getEasyAuthor :: IO (Maybe String)-getEasyAuthor = firstJustIO [ firstNotBlank `fmap` getPreflist "author",-                                firstNotBlank `fmap` getGlobal "author",-                                maybeGetEnv "DARCS_EMAIL",-                                maybeGetEnv "EMAIL" ]+getEasyAuthor = do+    undecodedAuthor <-+      firstJustIO [ firstNotBlank `fmap` getPreflist "author",+                    firstNotBlank `fmap` getGlobal "author",+                    maybeGetEnv "DARCS_EMAIL",+                    maybeGetEnv "EMAIL" ]+    case undecodedAuthor of+        Just a  -> return (Just (decodeString a))+        Nothing -> return Nothing \end{code}  \begin{options}@@ -871,10 +943,10 @@ file.  \begin{code}-nocompress = concatOptions [__compress, __dontCompress]-uncompressNocompress = concatOptions [__compress, __dontCompress, __uncompress]+nocompress = DarcsMultipleChoiceOption [__compress, __dontCompress]+uncompressNocompress = DarcsMultipleChoiceOption [__compress, __dontCompress, __uncompress] -__compress, __dontCompress, __uncompress :: DarcsOption+__compress, __dontCompress, __uncompress :: DarcsAtomicOption __compress = DarcsNoArgOption [] ["compress"] Compress             "create compressed patches" __dontCompress = DarcsNoArgOption [] ["dont-compress","no-compress"] NoCompress@@ -897,8 +969,8 @@            DarcsNoArgOption  [] ["no-unified"] NonUnified           "output patch in diff's dumb format"] -diffCmdFlag = DarcsArgOption [] ["diff-command"]-       DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)"+diffCmdFlag = DarcsSingleOption $+  DarcsArgOption [] ["diff-command"] DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)"  storeInMemory = DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["store-in-memory"] StoreInMemory@@ -906,16 +978,19 @@      DarcsNoArgOption [] ["no-store-in-memory"] ApplyOnDisk      "do patch application on disk [DEFAULT]"] -target = DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email"-ccSend = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s)"-ccApply = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply"+target = DarcsSingleOption $+  DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email"+ccSend = DarcsSingleOption $+  DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s)"+ccApply = DarcsSingleOption $+  DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply"  -- |'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. getCc :: [DarcsFlag] -> String-getCc fs = lt $ catMaybes $ map whatcc fs+getCc fs = lt $ mapMaybe whatcc fs             where whatcc (Cc t) = Just t                   whatcc _ = Nothing                   lt [t] = t@@ -923,7 +998,7 @@                   lt (t:ts) = t++" , "++lt ts                   lt [] = "" -subject = DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject"+subject = DarcsSingleOption $ DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject"  -- |'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@@ -934,28 +1009,38 @@ getSubject (_:fs) = getSubject fs getSubject [] = Nothing -inReplyTo = DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header"+inReplyTo = DarcsSingleOption $ 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"+output = DarcsSingleOption $ DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE"          "specify output filename" -outputAutoName = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY"+outputAutoName = DarcsSingleOption $+                   DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY"                    "output to automatically named file in DIRECTORY, default: current directory" -editDescription =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["edit-description"] EditDescription-                          "edit the patch bundle description",-     DarcsNoArgOption [] ["dont-edit-description","no-edit-description"] NoEditDescription-                      "don't edit the patch bundle description"]+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 -distnameOption = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME"-                  "name of version"+editDescription = mkMutuallyExclusive [] yes [no]+ where+  yes = ( DarcsNoArgOption [] ["edit-description"]+        , EditDescription+        , "edit the patch bundle description" )+  no  = ( DarcsNoArgOption [] ["dont-edit-description","no-edit-description"]+        , NoEditDescription+        , "don't edit the patch bundle description" ) +distnameOption = DarcsSingleOption $+  DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME" "name of version"++recursive :: String -> DarcsOption recursive h     = DarcsMultipleChoiceOption       [DarcsNoArgOption ['r'] ["recursive"] Recursive h,@@ -980,15 +1065,15 @@                           "Convert from hashed to darcs-1 format"]  upgradeFormat :: DarcsOption-upgradeFormat =+upgradeFormat = DarcsSingleOption $     DarcsNoArgOption [] ["upgrade"] UpgradeFormat          "upgrade repository to latest compatible format" -xmloutput = DarcsNoArgOption [] ["xml-output"] XMLOutput-        "generate XML formatted output"+xmloutput = DarcsSingleOption $+  DarcsNoArgOption [] ["xml-output"] XMLOutput "generate XML formatted output" -creatorhash = DarcsArgOption [] ["creator-hash"] CreatorHash "HASH"-              "specify hash of creator patch (see docs)"+creatorhash = DarcsSingleOption $+  DarcsArgOption [] ["creator-hash"] CreatorHash "HASH" "specify hash of creator patch (see docs)"  sign = DarcsMultipleChoiceOption        [DarcsNoArgOption [] ["sign"] Sign@@ -1011,11 +1096,15 @@                     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-               "don't set default repository"]+setDefault :: Bool -> DarcsOption+setDefault wantYes+  | wantYes   = mkMutuallyExclusive [] yes [no]+  | otherwise = mkMutuallyExclusive [yes] no []+ where+  yes = ( DarcsNoArgOption [] ["set-default"], SetDefault+        , "set default repository" )+  no  = ( DarcsNoArgOption [] ["no-set-default"], NoSetDefault+        , "don't set default repository" )  verify = DarcsMultipleChoiceOption          [DarcsAbsPathOption [] ["verify"] Verify "PUBRING"@@ -1025,9 +1114,12 @@           DarcsNoArgOption [] ["no-verify"] NonVerify           "don't verify patch signature"] -reponame = DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY"+reponame :: DarcsOption+reponame = DarcsSingleOption $+           DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY"            "path of output directory" --repodir is there for compatibility                                       --should be removed eventually+depsSel :: DarcsOption depsSel = DarcsMultipleChoiceOption        [DarcsNoArgOption [] ["no-deps"] DontGrabDeps         "don't automatically fulfill dependencies",@@ -1035,13 +1127,18 @@         "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]"]-tokens = DarcsArgOption [] ["token-chars"] Toks "\"[CHARS]\""++tokens :: DarcsOption+tokens = DarcsSingleOption $+         DarcsArgOption [] ["token-chars"] Toks "\"[CHARS]\""          "define token to contain these characters" -partial       = concatOptions [__partial, __lazy, __ephemeral, __complete]-partialCheck = concatOptions [__complete, __partial]+partial :: DarcsOption+partial       = DarcsMultipleChoiceOption [__partial, __lazy, __ephemeral, __complete]+partialCheck :: DarcsOption+partialCheck = DarcsMultipleChoiceOption [__complete, __partial] -__partial, __lazy, __ephemeral, __complete :: DarcsOption+__partial, __lazy, __ephemeral, __complete :: DarcsAtomicOption __partial = DarcsNoArgOption [] ["partial"] Partial             "get partial repository using checkpoint (old-fashioned format only)" __lazy = DarcsNoArgOption [] ["lazy"] Lazy@@ -1057,7 +1154,8 @@                  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"+reply = DarcsSingleOption $+  DarcsArgOption [] ["reply"] Reply "FROM" "reply to email-based patch using FROM address" applyConflictOptions     = DarcsMultipleChoiceOption       [DarcsNoArgOption [] ["mark-conflicts"]@@ -1082,8 +1180,9 @@        DarcsNoArgOption [] ["skip-conflicts"]        SkipConflicts "filter out any patches that would create conflicts"       ]-useExternalMerge = DarcsArgOption [] ["external-merge"]-                     ExternalMerge "COMMAND" "use external tool to merge conflicts"+useExternalMerge = DarcsSingleOption $+  DarcsArgOption [] ["external-merge"] ExternalMerge "COMMAND"+    "use external tool to merge conflicts" \end{code}  \begin{options}@@ -1134,8 +1233,8 @@ -- --dry-run is a possibility, automated users can examine the results more -- easily with --xml. dryRunNoxml :: DarcsOption-dryRunNoxml = DarcsNoArgOption [] ["dry-run"] DryRun-                "don't actually take the action"+dryRunNoxml = DarcsSingleOption $+  DarcsNoArgOption [] ["dry-run"] DryRun "don't actually take the action"  dryRun :: [DarcsOption] dryRun = [dryRunNoxml, xmloutput]@@ -1172,12 +1271,12 @@            putInfo = if XMLOutput `elem` opts then \_ -> return () else putDocLn            xml_info pl               | Summary `elem` opts = xml_with_summary pl-              | otherwise = (to_xml . info) pl-            +              | otherwise = (toXml . info) pl+            xml_with_summary hp-               | Just p <- hopefullyM hp = insert_before_lastline-                                            (to_xml $ info hp) (indent $ xmlSummary p)-           xml_with_summary hp = to_xml (info hp)+               | Just p <- hopefullyM hp = insertBeforeLastline+                                            (toXml $ info hp) (indent $ xmlSummary p)+           xml_with_summary hp = toXml (info hp)            indent = prefix "    "  @@ -1190,7 +1289,7 @@                 [DarcsNoArgOption [] ["boring"]                  Boring "don't skip boring files",                  DarcsNoArgOption [] ["no-boring"]-                 SkipBoring "skip borign files [DEFAULT]"]+                 SkipBoring "skip boring files [DEFAULT]"]  allowProblematicFilenames = DarcsMultipleChoiceOption                 [DarcsNoArgOption [] ["case-ok"] AllowCaseOnly@@ -1202,16 +1301,19 @@                 ,DarcsNoArgOption [] ["no-reserved-ok"] DontAllowWindowsReserved                  "refuse to add files with Windows-reserved names [DEFAULT]"] -diffflags = DarcsArgOption [] ["diff-opts"]+diffflags = DarcsSingleOption $+            DarcsArgOption [] ["diff-opts"]             DiffFlags "OPTIONS" "options to pass to diff" -changesFormat = DarcsMultipleChoiceOption-                 [DarcsNoArgOption [] ["context"]-                  (Context rootDirectory) "give output suitable for get --context",+changesFormat = concatOptions $+                 [DarcsMultipleChoiceOption [+                   DarcsNoArgOption [] ["context"]+                    (Context rootDirectory) "give output suitable for get --context" ],                   xmloutput,                   humanReadable,+                  DarcsMultipleChoiceOption [                   DarcsNoArgOption [] ["number"] NumberPatches "number the changes",-                  DarcsNoArgOption [] ["count"] Count "output count of changes"+                  DarcsNoArgOption [] ["count"] Count "output count of changes" ]                  ] changesReverse = DarcsMultipleChoiceOption                   [DarcsNoArgOption [] ["reverse"] Reverse@@ -1227,19 +1329,26 @@      "show changes to all files [DEFAULT]"]  -humanReadable = DarcsNoArgOption [] ["human-readable"]-                 HumanReadable "give human-readable output"-pipe = DarcsNoArgOption [] ["pipe"] Pipe "ask user interactively for the patch metadata"+humanReadable = DarcsSingleOption $+  DarcsNoArgOption [] ["human-readable"] HumanReadable "give human-readable output" +pipe :: DarcsAtomicOption+pipe =+  DarcsNoArgOption [] ["pipe"] Pipe "ask user interactively for the patch metadata"++interactive :: DarcsAtomicOption interactive =     DarcsNoArgOption ['i'] ["interactive"] Interactive                          "prompt user interactively"-all_patches = DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches" -allInteractive = DarcsMultipleChoiceOption [all_patches, interactive]+allPatches :: DarcsAtomicOption+allPatches =+  DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches" +allInteractive = DarcsMultipleChoiceOption [allPatches, interactive]+ allPipeInteractive-    = DarcsMultipleChoiceOption [all_patches,pipe,interactive]+    = DarcsMultipleChoiceOption [allPatches,pipe,interactive]  pipeInteractive =     DarcsMultipleChoiceOption [pipe, interactive]@@ -1256,7 +1365,7 @@ -- | 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 "."+                working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "."                 return $ map (anchorPath "" . fst) $ list working  -- | 'listUnregisteredFiles' returns the list of all non-boring unregistered@@ -1275,14 +1384,19 @@  optionsLatex :: [DarcsOption] -> String optionsLatex opts = "\\begin{tabular}{lll}\n"++-                     unlines (map optionLatex opts)+++                     unlines (map optionListLatex opts)++                      "\\end{tabular}\n"  latexHelp :: String -> String latexHelp h     = "\\begin{minipage}{7cm}\n\\raggedright\n" ++ h ++ "\\end{minipage}\n" -optionLatex :: DarcsOption -> String+optionListLatex :: DarcsOption -> String+optionListLatex (DarcsSingleOption o) = optionLatex o+optionListLatex (DarcsMultipleChoiceOption os) = unlines (map optionLatex os)+optionListLatex (DarcsMutuallyExclusive os _) = unlines (map optionLatex os)++optionLatex :: DarcsAtomicOption -> String optionLatex (DarcsNoArgOption a b _ h) =     showShortOptions a ++ showLongOptions b ++ latexHelp h ++ "\\\\" optionLatex (DarcsArgOption a b _ arg h) =@@ -1297,8 +1411,6 @@ optionLatex (DarcsOptAbsPathOption a b _ _ arg h) =     showShortOptions a ++     showLongOptions (map (++("[="++arg++"]")) b) ++ latexHelp h ++ "\\\\"-optionLatex (DarcsMultipleChoiceOption os) =-    unlines (map optionLatex os)  showShortOptions :: [Char] -> String showShortOptions [] = "&"@@ -1318,14 +1430,20 @@                                DarcsNoArgOption [] ["dont-set-scripts-executable","no-set-scripts-executable"] DontSetScriptsExecutable                                "don't make scripts executable"] +bisect :: DarcsOption+bisect = DarcsSingleOption $ DarcsNoArgOption [] ["bisect"] Bisect+         "binary instead of linear search"+ relink, relinkPristine, sibling :: DarcsOption-relink = DarcsNoArgOption [] ["relink"] Relink+relink = DarcsSingleOption $ DarcsNoArgOption [] ["relink"] Relink          "relink random internal data to a sibling" -relinkPristine = DarcsNoArgOption [] ["relink-pristine"] RelinkPristine+relinkPristine = DarcsSingleOption $+  DarcsNoArgOption [] ["relink-pristine"] RelinkPristine                   "relink pristine tree (not recommended)" -sibling = DarcsAbsPathOption [] ["sibling"] Sibling "URL"+sibling = DarcsSingleOption $+  DarcsAbsPathOption [] ["sibling"] Sibling "URL"           "specify a sibling directory"  -- | 'flagsToSiblings' collects the contents of all @Sibling@ flags in a list of flags.@@ -1335,11 +1453,11 @@ flagsToSiblings [] = []  nolinks :: DarcsOption-nolinks = DarcsNoArgOption [] ["nolinks"] NoLinks+nolinks = DarcsSingleOption $ DarcsNoArgOption [] ["nolinks"] NoLinks           "do not link repository or pristine to sibling"  reorderPatches :: DarcsOption-reorderPatches = DarcsNoArgOption [] ["reorder-patches"] Reorder+reorderPatches = DarcsSingleOption $ DarcsNoArgOption [] ["reorder-patches"] Reorder                   "reorder the patches in the repository" \end{code} \begin{options}@@ -1348,7 +1466,8 @@ \darcsEnv{SENDMAIL}  \begin{code}-sendmailCmd = DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command"+sendmailCmd = DarcsSingleOption $+  DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command"  environmentHelpSendmail :: ([String], [String]) environmentHelpSendmail = (["SENDMAIL"], [@@ -1370,7 +1489,7 @@ -- @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.-getSendmailCmd :: [DarcsFlag] -> IO String +getSendmailCmd :: [DarcsFlag] -> IO String getSendmailCmd (SendmailCmd a:_) = return a getSendmailCmd (_:flags) = getSendmailCmd flags getSendmailCmd [] =   do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ]@@ -1400,7 +1519,7 @@                "only included recorded patches in output"]  nullFlag :: DarcsOption        -- "null" is already taken-nullFlag = DarcsNoArgOption ['0'] ["null"] NullFlag+nullFlag = DarcsSingleOption $ DarcsNoArgOption ['0'] ["null"] NullFlag        "separate file names by NUL characters" \end{code} @@ -1444,7 +1563,7 @@                       finishedOneIO k "DARCS_PATCHES_XML"                       setEnvCautiously "DARCS_PATCHES_XML"                                  (renderString $ text "<patches>" $$-                                                 vcat (mapFL (to_xml . info) ps) $$+                                                 vcat (mapFL (toXml . info) ps) $$                                                  text "</patches>")                       finishedOneIO k "DARCS_FILES"                       setEnvCautiously "DARCS_FILES" (unlines$ listTouchedFiles ps)@@ -1556,36 +1675,37 @@ \begin{code} networkOptions :: [DarcsOption] networkOptions =-    [DarcsMultipleChoiceOption-     [DarcsNoArgOption [] ["ssh-cm"] SSHControlMaster-                           "use SSH ControlMaster feature",-      DarcsNoArgOption [] ["no-ssh-cm"] NoSSHControlMaster-                           "don't use SSH ControlMaster feature [DEFAULT]"],-     DarcsMultipleChoiceOption-     [DarcsNoArgOption [] ["http-pipelining"] HTTPPipelining-                           pipelining_description,-      DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining-                           no_pipelining_description],-      noCache, remote_darcs-     ]-    where pipelining_description =-              "enable HTTP pipelining"++-              (if pipeliningEnabledByDefault then " [DEFAULT]" else "")-          no_pipelining_description =-              "disable HTTP pipelining"++-              (if pipeliningEnabledByDefault then "" else " [DEFAULT]")+   [ DarcsMultipleChoiceOption+       [ DarcsNoArgOption [] ["ssh-cm"] SSHControlMaster+                           "use SSH ControlMaster feature"+       , DarcsNoArgOption [] ["no-ssh-cm"] NoSSHControlMaster+                           "don't use SSH ControlMaster feature [DEFAULT]"+       ]+   , DarcsMultipleChoiceOption+       [ DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining+                          "disable HTTP pipelining"+       ]+   , remoteDarcs ] -remote_darcs :: DarcsOption-remote_darcs =  DarcsArgOption [] ["remote-darcs"] RemoteDarcs "COMMAND"+remoteDarcs :: DarcsOption+remoteDarcs = DarcsSingleOption $+  DarcsArgOption [] ["remote-darcs"] RemoteDarcs "COMMAND"                 "name of the darcs executable on the remote server"  noCache :: DarcsOption-noCache = DarcsNoArgOption [] ["no-cache"] NoCache+noCache = DarcsSingleOption $+  DarcsNoArgOption [] ["no-cache"] NoCache                           "don't use patch caches"  optimizePristine :: DarcsOption-optimizePristine = DarcsNoArgOption [] ["pristine"] OptimizePristine+optimizePristine = DarcsSingleOption $+  DarcsNoArgOption [] ["pristine"] OptimizePristine                           "optimize hashed pristine layout"++optimizeHTTP :: DarcsOption+optimizeHTTP = DarcsSingleOption $+  DarcsNoArgOption [] ["http"] OptimizeHTTP+                          "optimize repository for getting over network" \end{code} \begin{options} --umask@@ -1596,7 +1716,7 @@  \begin{code} umaskOption :: DarcsOption-umaskOption =+umaskOption = DarcsSingleOption $     DarcsArgOption [] ["umask"] UMask "UMASK"         "specify umask to use when writing" \end{code}@@ -1621,6 +1741,7 @@ the command line, when pulling or applying unknown patches.  \begin{code}+restrictPaths :: DarcsOption restrictPaths =     DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["restrict-paths"] RestrictPaths@@ -1636,7 +1757,7 @@ doing pull, push and send. This option makes darcs skip this check.  \begin{code}-allowUnrelatedRepos =+allowUnrelatedRepos = DarcsSingleOption $     DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos                          "do not check if repositories are unrelated" \end{code}@@ -1652,7 +1773,7 @@ omits any caches or other repos listed as a source of patches.  \begin{code}-justThisRepo =+justThisRepo = DarcsSingleOption $     DarcsNoArgOption [] ["just-this-repo"] JustThisRepo                         "Limit the check or repair to the current repo" \end{code}@@ -1667,7 +1788,7 @@ This option specifies checking mode.  \begin{code}-check =+check = DarcsSingleOption $     DarcsNoArgOption [] ["check"] Check                         "Specify checking mode" \end{code}@@ -1678,7 +1799,7 @@ This option specifies repair mode.  \begin{code}-repair =+repair = DarcsSingleOption $     DarcsNoArgOption [] ["repair"] Repair                         "Specify repair mode" 

@@ -1,59 +0,0 @@--- Copyright (C) 2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.CheckFileSystem ( can_I_use_mmap ) where--import System.Directory ( removeFile, removeDirectory, setCurrentDirectory,-                          createDirectory,-                        )-import Control.Exception ( block )--import Darcs.Utils ( withCurrentDirectory )-import Darcs.Lock ( withOpenTemp )---- Beware that the below test will return true in any directory where we--- don't have write permission.  This is risky, but means we'll do the--- right thing in the common case where we're dealing with posix--- filesystems and directories in which we don't have permission to write.--can_I_remove_open_files :: IO Bool-can_I_remove_open_files = block $ -   (withOpenTemp $ \ (_,f) ->-       (do { removeFile f; return True}) `catch` \_ -> return False)-   `catch` \_ -> return True--can_I_remove_directories_holding_open_files :: IO Bool-can_I_remove_directories_holding_open_files = block $-   (do createDirectory "darcs_testing_for_nfs"-       okay <- (withCurrentDirectory "darcs_testing_for_nfs" $-                do withOpenTemp $ \ (_,f) -> -                       (do removeFile f-                           setCurrentDirectory ".."-                           removeDirectory "darcs_testing_for_nfs"-                           return True-                       ) `catch` \_ -> return False-               ) `catch` \_ -> return True-       removeDirectory "darcs_testing_for_nfs" `catch` \_ -> return ()-       return okay-   ) `catch` \_ -> return True--can_I_use_mmap :: IO Bool-can_I_use_mmap = do a <- can_I_remove_open_files-                    if a then can_I_remove_directories_holding_open_files-                         else return False--

@@ -8,13 +8,14 @@                 invisiblePrinter, (<>), (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat,                 unsafeText, unsafeChar, space, unsafePackedString,                 renderStringWith, prefix )-import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr, intToDigit )+import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr ) import Data.Bits ( bit, xor ) import System.Environment ( getEnv ) import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd) import qualified Data.ByteString       as B (null, init) import System.IO.Unsafe ( unsafePerformIO ) import System.IO ( hIsTerminalDevice, Handle )+import Text.Printf ( printf )  dollar, cr :: Doc dollar = unsafeBothText "$"@@ -101,7 +102,7 @@ -- | @'fancyPrinters' h@ returns a set of printers suitable for outputting -- to @h@ fancyPrinters :: Printers-fancyPrinters h = let policy = getPolicy h in +fancyPrinters h = let policy = getPolicy h in                       Printers { colorP = colorPrinter policy,                              invisibleP = invisiblePrinter,                              hiddenP = colorPrinter policy Green,@@ -115,11 +116,11 @@ -- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise -- does nothing. lineColorTrans :: Policy -> Color -> Doc -> Doc-lineColorTrans po | poLineColor po = \c d -> prefix (set_color c) d <?> unsafeBothText reset_color+lineColorTrans po | poLineColor po = \c d -> prefix (setColor c) d <?> unsafeBothText resetColor                   | otherwise      = const id  lineColorSuffix :: Policy -> [Printable] -> [Printable]-lineColorSuffix po | poLineColor po = \d -> S reset_color : d+lineColorSuffix po | poLineColor po = \d -> S resetColor : d                    | otherwise      = id  colorPrinter :: Policy -> Color -> Printer@@ -141,7 +142,7 @@                 then Doc $ escapePrinter po p                 else Doc (escapePrinter po (PS leadPS))                   <> Doc (escapePrinter po{poSpace=True} (PS trailPS))-                  <> mark_escape po dollar+                  <> markEscape po dollar    prString s = let (trail',lead') = span isSpace (reverse s)                    lead = reverse lead'@@ -149,7 +150,7 @@                in if (not.null) trail                    then Doc (escapePrinter po (S lead))                      <> Doc (escapePrinter po{poSpace=True} (S trail))-                     <> mark_escape po dollar+                     <> markEscape po dollar                    else Doc (escapePrinter po p)  escapePrinter :: Policy -> Printer@@ -161,7 +162,7 @@           | otherwise            = epr p    epr (S s)      = escape po s-  epr (PS ps)    = if BC.any (not.no_escape po) ps+  epr (PS ps)    = if BC.any (not.noEscape po) ps                    then escape po (BC.unpack ps)                    else unsafePackedString ps   epr (Both s _) = escape po s@@ -175,28 +176,26 @@   initPR (Both s ps) = Both (init s) (B.init ps)  --- escape assumes the input is in ['\0'..'\255']- -- | @'escape' policy string@ escapes @string@ according to the rules -- defined in 'policy', turning it into a 'Doc'. escape :: Policy -> String -> Doc escape _ "" = unsafeText "" escape po s = hcat (map escapeChar s)  where-  escapeChar c | no_escape po c = unsafeChar c+  escapeChar c | noEscape po c = unsafeChar c   escapeChar ' ' = space   escapeChar c = (emph.unsafeText.quoteChar) c-  emph = mark_escape po+  emph = markEscape po --- | @'no_escape' policy c@ tells wether @c@ will be left as-is+-- | @'noEscape' policy c@ tells wether @c@ will be left as-is -- when escaping according to @policy@-no_escape :: Policy -> Char -> Bool-no_escape po c | poSpace po && isSpace c = False-no_escape po c | c `elem` poEscX po = False-no_escape po c | c `elem` poNoEscX po = True-no_escape _ '\t' = True  -- tabs will likely be converted to spaces-no_escape _ '\n' = True-no_escape po c = if (poIsprint po) then isPrint c+noEscape :: Policy -> Char -> Bool+noEscape po c | poSpace po && isSpace c = False+noEscape po c | c `elem` poEscX po = False+noEscape po c | c `elem` poNoEscX po = True+noEscape _ '\t' = True  -- tabs will likely be converted to spaces+noEscape _ '\n' = True+noEscape po c = if (poIsprint po) then isPrint c                                    else isPrintableAscii c                  ||  c >= '\x80' && po8bit po @@ -216,66 +215,65 @@  | otherwise = sHex  where   cHat = chr $ (bit 6 `xor`) $ ord c-  sHex = let (q, r) = quotRem (ord c) 16-         in ['\\', intToDigit q, intToDigit r]+  sHex = "<U+" ++ printf "%04X" c ++ ">"   -- make colors and highlightings --- | @'mark_escape' policy doc@ marks @doc@ with the appropriate+-- | @'markEscape' policy doc@ marks @doc@ with the appropriate -- marking for escaped characters according to @policy@-mark_escape :: Policy -> Doc -> Doc-mark_escape po | poAltColor po  = make_invert-               | poColor po     = make_color Red-               | otherwise      = make_asciiart+markEscape :: Policy -> Doc -> Doc+markEscape po  | poAltColor po  = makeInvert+               | poColor po     = makeColor Red+               | otherwise      = makeAsciiart  -- | @'color' policy color doc@ colors @doc@ with color @color@ if -- @policy@ is not set to use an alternative to color. In that case, -- it makes the text bold instead. color :: Policy -> Color -> Doc -> Doc-color po | poAltColor po = \_ -> make_bold-         | otherwise     = make_color+color po | poAltColor po = \_ -> makeBold+         | otherwise     = makeColor -make_color, make_color' :: Color -> Doc -> Doc+makeColor, makeColor' :: Color -> Doc -> Doc -make_color' = with_color . set_color+makeColor' = withColor . setColor --- memoized version of make_color'-make_color Blue    = make_color' Blue-make_color Red     = make_color' Red-make_color Green   = make_color' Green-make_color Cyan    = make_color' Cyan-make_color Magenta = make_color' Magenta+-- memoized version of makeColor'+makeColor Blue    = makeColor' Blue+makeColor Red     = makeColor' Red+makeColor Green   = makeColor' Green+makeColor Cyan    = makeColor' Cyan+makeColor Magenta = makeColor' Magenta -set_color :: Color -> String-set_color Blue    = "\x1B[01;34m" -- bold blue-set_color Red     = "\x1B[01;31m" -- bold red-set_color Green   = "\x1B[01;32m" -- bold green-set_color Cyan    = "\x1B[36m"    -- light cyan-set_color Magenta = "\x1B[35m"    -- light magenta+setColor :: Color -> String+setColor Blue    = "\x1B[01;34m" -- bold blue+setColor Red     = "\x1B[01;31m" -- bold red+setColor Green   = "\x1B[01;32m" -- bold green+setColor Cyan    = "\x1B[36m"    -- light cyan+setColor Magenta = "\x1B[35m"    -- light magenta --- | @'make_asciiart' doc@ tries to make @doc@ (usually a+-- | @'makeAsciiart' doc@ tries to make @doc@ (usually a -- single escaped char) stand out with the help of only plain -- ascii, i.e., no color or font style.-make_asciiart :: Doc -> Doc-make_asciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]"+makeAsciiart :: Doc -> Doc+makeAsciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]"  -- | the string to reset the terminal's color.-reset_color :: String-reset_color = "\x1B[00m"+resetColor :: String+resetColor = "\x1B[00m" --- | @'with_color' color doc@ returns a colorized version of @doc@.--- @color@ is a string that represents a color, given by 'set_color'-with_color :: String -> Doc -> Doc-with_color c =+-- | @'withColor' color doc@ returns a colorized version of @doc@.+-- @color@ is a string that represents a color, given by 'setColor'+withColor :: String -> Doc -> Doc+withColor c =    let c' = unsafeBothText c-       r' = unsafeBothText reset_color+       r' = unsafeBothText resetColor    in \x -> c' <> x <> r'  --- | 'make_bold' boldens a doc.-make_bold :: Doc -> Doc--- | 'make_invert' returns an invert video version of a doc.-make_invert :: Doc -> Doc-make_bold   = with_color "\x1B[01m"-make_invert = with_color "\x1B[07m"+-- | 'makeBold' boldens a doc.+makeBold :: Doc -> Doc+-- | 'makeInvert' returns an invert video version of a doc.+makeInvert :: Doc -> Doc+makeBold   = withColor "\x1B[01m"+makeInvert = withColor "\x1B[07m"

@@ -33,7 +33,7 @@                        disambiguateCommands, CommandArgs(..),                        getCommandHelp, getCommandMiniHelp,                        getSubcommands,-                       usage, subusage, chompNewline,+                       usage, usageHelper, subusage, chompNewline,                        extractCommands,                        superName,                        nodefaults,@@ -45,8 +45,8 @@  import Data.List ( sort, isPrefixOf ) import Darcs.Arguments ( DarcsFlag(Quiet,Verbose, DryRun), DarcsOption, disable, help,-                         anyVerbosity, posthookCmd, posthookPrompt,-                         prehookCmd, prehookPrompt, optionFromDarcsoption )+                         anyVerbosity, noCache, posthookCmd, posthookPrompt,+                         prehookCmd, prehookPrompt, optionFromDarcsOption ) import Darcs.RepoPath ( AbsolutePath, rootDirectory ) import Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc ) import System.IO ( stderr )@@ -146,7 +146,8 @@                                 , commandAdvancedOptions = opts2 }     = (opts1 ++ [disable, help],        anyVerbosity ++ opts2 ++-                [posthookCmd, posthookPrompt+                [noCache+                ,posthookCmd, posthookPrompt                 ,prehookCmd, prehookPrompt])  --  Supercommands cannot be disabled.@@ -158,7 +159,7 @@ commandOptions :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag]) commandOptions cwd c = (convert basic, convert advanced)  where (basic, advanced) = commandAlloptions c-       convert = concatMap (optionFromDarcsoption cwd)+       convert = concatMap (optionFromDarcsOption cwd)  nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] nodefaults _ _ xs = return xs@@ -203,7 +204,7 @@      ("Usage: darcs "++commandName super++" SUBCOMMAND ... " ++       "\n\n"++ commandDescription super++       "\n\nSubcommands:\n" ++ usageHelper (getSubcommands super) ++ "\nOptions:")-     (optionFromDarcsoption rootDirectory help))+     (optionFromDarcsOption rootDirectory help))     ++ "\n" ++ commandHelp super  usageHelper :: [CommandControl] -> String@@ -297,7 +298,7 @@  putVerbose :: [DarcsFlag] -> Doc -> IO () putVerbose opts = when (amVerbose opts) . putDocLn-     + putInfo :: [DarcsFlag] -> Doc -> IO () putInfo opts = unless (amQuiet opts) . putDocLn 

@@ -20,6 +20,10 @@ module Darcs.Commands.Add ( add, expandDirs ) where  import Data.List ( (\\), nub)+import Data.Maybe( isNothing )+import Control.Monad ( when, unless, liftM )+import Storage.Hashed.Tree( Tree, findTree, expand )+import Storage.Hashed.AnchoredPath( floatPath, anchorPath, parents )  import Darcs.Commands(DarcsCommand(..), putVerbose, putWarning, nodefaults) import Darcs.Arguments (noskipBoring, allowProblematicFilenames,@@ -32,23 +36,22 @@ 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, 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.Repository.State( readRecordedAndPending )+import Darcs.Repository ( amInRepository, withRepoLock, ($-), addToPending )+import Darcs.Patch ( Prim, applyToTree, addfile, adddir, move )+import Darcs.Witnesses.Ordered ( FL(..), (+>+), nullFL )+import Darcs.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )+import Darcs.Utils ( isFileReallySymlink, doesDirectoryReallyExist+                   , doesFileReallyExist, treeHas, treeHasDir, treeHasAnycase ) 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 qualified System.FilePath.Windows as WindowsFilePath import Printer( text ) +#include "gadts.h"+ addDescription :: String addDescription = "Add one or more new files or directories." @@ -96,12 +99,14 @@  addCmd :: [DarcsFlag] -> [String] -> IO () addCmd opts args = withRepoLock opts $- \repository ->- do cur <- slurp_pending repository-    origfiles <- fixSubPaths opts args-    when (null origfiles) $+ do -- TODO do not expand here, and use findM/findIO or such later+    -- (needs adding to hashed-storage first though)+    cur <- expand =<< readRecordedAndPending repository+    when (null args) $        putStrLn "Nothing specified, nothing added." >>        putStrLn "Maybe you wanted to say `darcs add --recursive .'?"-    parlist <- getParents cur (map toFilePath origfiles)+    origfiles <- fixSubPaths opts args+    let parlist = getParents cur (map toFilePath origfiles)     flist' <- if Recursive `elem` opts               then expandDirs origfiles               else return origfiles@@ -111,19 +116,19 @@                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 ")++)) $+    mapM_ (putWarning fixedOpts . text . ((msgSkipping msgs ++ " boring file ")++)) $       flist \\ nboring flist     date <- getIsoDateTime-    ps <- addp msgs fixedOpts date cur $ nboring flist+    Sealed ps <- fmap unFreeLeft $ 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+    unless gotDryRun $ addToPending repository ps   where     gotDryRun = DryRun `elem` opts     msgs | gotDryRun = dryRunMessages          | otherwise = normalMessages -addp :: AddMessages -> [DarcsFlag] -> String -> Slurpy -> [FilePath] -> IO (FL Prim)+addp :: AddMessages -> [DarcsFlag] -> String -> Tree IO -> [FilePath] -> IO (FreeLeft (FL Prim)) addp msgs opts date cur0 files = do     (ps, dups) <-         foldr@@ -146,99 +151,95 @@            isDir <- doesDirectoryReallyExist f            if isDir                then return $-                 "The following directory "++msg_is msgs++" already in the repository"+                 "The following directory "++msgIs msgs++" already in the repository"                else return $-                 "The following file "++msg_is msgs++" already in the repository"+                 "The following file "++msgIs msgs++" already in the repository"          fs   ->            do            areDirs <- mapM doesDirectoryReallyExist fs            if and areDirs                then return $-                 "The following directories "++msg_are msgs++" already in the repository"+                 "The following directories "++msgAre msgs++" already in the repository"                else                  (if or areDirs                       then return $                         "The following files and directories " ++-                        msg_are msgs ++ " already in the repository"+                        msgAre msgs ++ " already in the repository"                       else return $-                        "The following files " ++ msg_are msgs ++ " already in the repository")+                        "The following files " ++ msgAre msgs ++ " already in the repository")        putWarning opts . text $ dupMsg ++ caseMsg        mapM_ (putWarning opts . text) uniq_dups-    return $ concatFL $ unsafeFL ps+    return $ foldr (joinGap (+>+)) (emptyGap NilFL) ps  where-  addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath)-  addp' cur f =-    if already_has-    then return (cur, Nothing, Just f)-    else-    if is_badfilename-       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-      if isdir-         then trypatch $ myadddir f-         else do isfile <- doesFileReallyExist f-                 if isfile-                    then trypatch $ myaddfile f-                    else do islink <- isFileReallySymlink f-                            if islink then-                               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-                          else slurp_has_anycase f cur-            is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)+  addp' :: Tree IO -> FilePath -> IO (Tree IO, Maybe (FreeLeft (FL Prim)), Maybe FilePath)+  addp' cur f = do+    already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f+    isdir <- doesDirectoryReallyExist f+    isfile <- doesFileReallyExist f+    islink <- isFileReallySymlink f+    case (already_has, is_badfilename, isdir, isfile, islink) of+      (True, _, _, _, _) -> return (cur, Nothing, Just f)+      (_, True, _, _, _) ->+        do putWarning opts . text $+             "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it."+           return add_failure+      (_, _, True, _, _) -> trypatch $ myadddir f+      (_, _, _, True, _) -> trypatch $ myaddfile f+      (_, _, _, _, True) -> do putWarning opts . text $ "Sorry, file " ++ f +++                                  " is a symbolic link, which is unsupported by darcs."+                               return add_failure+      _ -> do putWarning opts . text $ "File "++ f ++" does not exist!"+              return add_failure+      where is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)             add_failure = (cur, Nothing, Nothing)-            trypatch p =-                case applyToSlurpy p cur of-                Nothing -> do putWarning opts . text $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error-                              return (cur, Nothing, Nothing)-                Just s' -> do putVerbose opts . text $ msg_adding msgs++" '"++f++"'"-                              return (s', Just p, Nothing)+            trypatch :: FreeLeft (FL Prim) -> IO (Tree IO, Maybe (FreeLeft (FL Prim)), Maybe FilePath)+            trypatch p = do Sealed p' <- return $ unFreeLeft p+                            tree <- applyToTree p' cur+                            putVerbose opts . text $ msgAdding msgs++" '"++f++"'"+                            return (tree, Just p, Nothing)+                          `catch` \_ -> do+                            err <- parent_error+                            putWarning opts . text $ msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ err+                            return (cur, Nothing, Nothing)             parentdir = takeDirectory f-            have_parentdir = slurp_hasdir (fp2fn parentdir) cur-            parent_error = if have_parentdir-                           then ""-                           else "couldn't add parent directory '"++parentdir++-                                "' to repository."+            have_parentdir = treeHasDir cur parentdir+            parent_error = have_parentdir >>= \x -> return $+                             if x then ""+                                  else "couldn't add parent directory '"++parentdir++"' to repository."             myadddir d = if gotFancyMoveAdd-                         then adddir (d++"-"++date) :>:-                              move (d++"-"++date) d :>: NilFL-                         else adddir d :>: NilFL+                         then freeGap (adddir (d++"-"++date) :>:+                                       move (d++"-"++date) d :>: NilFL)+                         else freeGap (adddir d :>: NilFL)             myaddfile d = if gotFancyMoveAdd-                          then addfile (d++"-"++date) :>:-                               move (d++"-"++date) d :>: NilFL-                          else addfile d :>: NilFL+                          then freeGap (addfile (d++"-"++date) :>:+                                        move (d++"-"++date) d :>: NilFL)+                          else freeGap (addfile d :>: NilFL)   gotFancyMoveAdd = FancyMoveAdd `elem` opts   gotAllowCaseOnly = doAllowCaseOnly opts   gotAllowWindowsReserved = doAllowWindowsReserved opts  data AddMessages =     AddMessages-    { msg_skipping  :: String-    , msg_adding    :: String-    , msg_is        :: String-    , msg_are       :: String+    { msgSkipping  :: String+    , msgAdding    :: String+    , msgIs        :: String+    , msgAre       :: String     }  normalMessages, dryRunMessages :: AddMessages normalMessages =     AddMessages-    { msg_skipping  = "Skipping"-    , msg_adding    = "Adding"-    , msg_is        = "is"-    , msg_are       = "are"+    { msgSkipping  = "Skipping"+    , msgAdding    = "Adding"+    , msgIs        = "is"+    , msgAre       = "are"     } dryRunMessages =     AddMessages-    { msg_skipping  = "Would skip"-    , msg_adding    = "Would add"-    , msg_is        = "would be"-    , msg_are       = "would be"+    { msgSkipping  = "Would skip"+    , msgAdding    = "Would add"+    , msgIs        = "would be"+    , msgAre       = "would be"     }  -- |FIXME: this documentation makes *no* sense to me, and the@@ -261,15 +262,8 @@      else do fs <- withCurrentDirectory f listFiles              return $ f: map (f </>) fs -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 <- getParent cur parentdir-          return (grandparents ++ [parentdir])-    where parentdir = takeDirectory f-\end{code}+getParents :: Tree IO -> [FilePath] -> [FilePath]+getParents cur = map (anchorPath "") . go . map floatPath+  where go fs = filter (isNothing . findTree cur) $ concatMap parents fs +\end{code}

@@ -24,9 +24,9 @@ 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.Flags ( DarcsFlag(Author, LogFile, PatchName, AskDeps,+                               EditLongComment, PromptLongComment, KeepDate) )+import Darcs.Lock ( worldReadableTemp ) import Darcs.RepoPath ( toFilePath ) import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully, info ) import Darcs.Repository ( Repository, withRepoLock, ($-), withGutsOf,@@ -38,27 +38,30 @@                      infopatch, getdeps, adddeps, effect,                    ) import Darcs.Patch.Prim ( canonizeFL )-import Darcs.Patch.Info ( pi_author, pi_name, pi_log,-                          PatchInfo, patchinfo, is_inverted, invert_name,+import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString,+                          PatchInfo, patchinfo, isInverted, invertName,                         ) 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.SelectChanges ( selectChanges, WhichChanges(..),+                             selectionContextPrim,+                             runSelection,+                             withSelectedPatchFromRepo ) import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Commands.Record ( getDate, getLog )+import Darcs.Commands.Record ( getDate, getLog, askAboutDepends ) import Darcs.Arguments ( DarcsFlag ( All ),                          areFileArgs, fixSubPaths, defineChanges,                         allInteractive, ignoretimes,-                        askLongComment, author, patchnameOption,+                        askLongComment, askdeps, keepDate, author, patchnameOption,                         leaveTestDir, nocompress, lookforadds,                          workingRepoDir,                         matchOneNontag, umaskOption,-                        notest, testByDefault, listRegisteredFiles,+                         test, listRegisteredFiles,                         getEasyAuthor, setScriptsExecutableOption                       ) import Darcs.Utils ( askUser, clarifyErrors ) import Printer ( putDocLn )+#include "gadts.h"  amendrecordDescription :: String amendrecordDescription =@@ -96,7 +99,7 @@  "It is usually a bad idea to amend another developer's patch.  To make\n" ++  "amend-record only ask about your own patches by default, you can add\n" ++  "something like `amend-record match David Roundy' to ~/.darcs/defaults, \n" ++- "where `David Roundy' is your name. " ++ + "where `David Roundy' is your name. " ++  "On Windows use C:/Documents And Settings/user/Application Data/darcs/defaults\n"  amendrecord :: DarcsCommand@@ -112,63 +115,79 @@                             commandAdvancedOptions = [nocompress, ignoretimes, umaskOption,                                                         setScriptsExecutableOption],                             commandBasicOptions = [matchOneNontag,-                                                     notest,+                                                   test,                                                     leaveTestDir,                                                     allInteractive,-                                                    author, patchnameOption, askLongComment,+                                                    author, patchnameOption, askdeps, askLongComment, keepDate,                                                     lookforadds,                                                     workingRepoDir]}  amendrecordCmd :: [DarcsFlag] -> [String] -> IO () amendrecordCmd opts args =-    withRepoLock (testByDefault opts) $- \repository -> do+    withRepoLock opts $- \(repository :: Repository p C(r u r)) -> 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+    withSelectedPatchFromRepo "amend" repository opts $ \ (_ :> oldp) -> do         ch <- unrecordedChanges opts repository files         case ch of           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+          _ -> do+            let context = selectionContextPrim  "add" (filter (==All) opts) (Just primSplitter)+                                                                            (map toFilePath files)+            chosenPatches <- runSelection (selectChanges First ch) context+            addChangesToPatch opts repository oldp chosenPatches -addChangesToPatch :: forall t p . (RepoPatch p) => [DarcsFlag] -> Repository p -> PatchInfoAnd p-                  -> (FL Prim :> t) -> IO ()-addChangesToPatch opts repository oldp (chs:>_) =    +addChangesToPatch :: forall p C(r u t x y) . (RepoPatch p)+                  => [DarcsFlag] -> Repository p C(r u t) -> PatchInfoAnd p C(x t)+                  -> (FL Prim :> FL Prim) C(t y) -> 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+                         repository' <- tentativelyRemovePatches repository opts (oldp :>: NilFL)+                         (mlogf, newp) <- updatePatchHeader opts repository' oldp chs+                         defineChanges newp+                         repository'' <- 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+                         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+updatePatchHeader :: forall p C(x y r u t) . (RepoPatch p)+                  => [DarcsFlag] -> Repository p C(r u t)+                  -> PatchInfoAnd p C(t x) -> FL Prim C(x y)+                  -> IO (Maybe String, PatchInfoAnd p C(t y))+updatePatchHeader opts repository oldp chs = do++                       let newchs = canonizeFL (effect oldp +>+ chs)++                       let old_pdeps = getdeps $ hopefully oldp+                       newdeps <- if AskDeps `elem` opts+                                  then askAboutDepends repository newchs opts old_pdeps+                                  else return old_pdeps+                        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-                       date <- getDate opts+                           prior    = (piName old_pinf, piLog old_pinf)+                           make_log = worldReadableTemp "darcs-amend-record"+                           old_author = piAuthor old_pinf+                       date <- if KeepDate `elem` opts then return (piDateString old_pinf) else 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+                                        Nothing -> piAuthor old_pinf+                           maybe_invert = if isInverted old_pinf then invertName else id                        new_pinf <- maybe_invert `fmap` patchinfo date new_name                                                                  new_author new_log-                       return $ (mlogf, fixp oldp chs new_pinf) +                       let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps)++                       return (mlogf, newp)+ warnIfHijacking :: [DarcsFlag] -> String -> IO () warnIfHijacking opts old_author = do   author_here <- getEasyAuthor@@ -177,7 +196,7 @@     Just ah -> let edit_author = isJust (getAuthor opts)               in if (edit_author || ah == old_author)                  then return ()-                 else do yorn <- askUser $ +                 else do yorn <- askUser $                                 "You're not "++old_author ++"! Amend anyway? "                          case yorn of ('y':_) -> return ()                                       _ -> exitWith $ ExitSuccess@@ -188,6 +207,7 @@ hasEditMetadata (PatchName _:_) = True hasEditMetadata (EditLongComment:_) = True hasEditMetadata (PromptLongComment:_) = True+hasEditMetadata (AskDeps:_) = True hasEditMetadata (_:fs) = hasEditMetadata fs hasEditMetadata [] = False @@ -196,11 +216,4 @@ 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 $ canonizeFL-             $ oldchs +>+ chs \end{code}

@@ -37,21 +37,25 @@                       ) import Darcs.Flags ( isUnified ) import Storage.Hashed.Plain( readPlainTree )-import Darcs.Repository ( Repository, PatchSet, amInRepository, withRepository, ($-), read_repo,+import Darcs.Repository ( Repository, amInRepository, withRepository, ($-), readRepo,                           getMarkedupFile )+import Darcs.Patch.Set ( PatchSet, newset2RL )+#ifdef GADT_WITNESSES+import Darcs.Patch.Set ( Origin )+#endif import Darcs.Patch ( RepoPatch, Named, LineMark(..), patch2patchinfo, xmlSummary ) import qualified Darcs.Patch ( summary ) 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,+import Darcs.Patch.Info ( PatchInfo, humanFriendly, toXml, makeFilename,                    showPatchInfo ) import Darcs.PopulationData ( Population(..), PopTree(..), DirMark(..),                         nameI, modifiedByI, modifiedHowI,                         createdByI, creationNameI,                       )-import Darcs.Population ( getRepoPopVersion, lookup_pop, lookup_creation_pop,-                    modified_to_xml,+import Darcs.Population ( getRepoPopVersion, lookupPop, lookupCreationPop,+                    modifiedToXml,                   ) import Darcs.Hopefully ( info ) import Darcs.RepoPath ( SubPath, toFilePath )@@ -107,7 +111,7 @@   when (not $ haveNonrangeMatch opts) $       fail $ "Annotate requires either a patch pattern or a " ++                "file or directory argument."-  Sealed2 p <- matchPatch opts `fmap` read_repo repository+  Sealed2 p <- matchPatch opts `fmap` readRepo repository   if Summary `elem` opts      then do putDocLn $ showpi $ patch2patchinfo p              putDocLn $ show_summary p@@ -118,12 +122,14 @@                   contextualPrintPatch c p           else printPatch p     where showpi | MachineReadable `elem` opts = showPatchInfo-                 | XMLOutput `elem` opts       = to_xml-                 | otherwise                   = human_friendly+                 | XMLOutput `elem` opts       = toXml+                 | otherwise                   = humanFriendly           show_summary :: RepoPatch p => Named p C(x y) -> Doc           show_summary = if XMLOutput `elem` opts                          then xmlSummary                          else Darcs.Patch.summary++annotateCmd opts [""] = annotateCmd opts [] \end{code}  If a directory name is given, annotate will output details of the last@@ -140,13 +146,16 @@ 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}-annotateCmd opts args@[_] = withRepository opts $- \repository -> do-  r <- read_repo repository-  (rel_file_or_directory:_) <- fixSubPaths opts args+annotateCmd opts [file] = withRepository opts $- \repository -> do+  r <- readRepo repository+  fixed_args <- fixSubPaths opts [file]+  (rel_file_or_directory:_) <- case fixed_args of+                                 [] -> fail ("The supplied path " ++ file ++ " is not usable")+                                 fs -> return fs   let file_or_directory = rel_file_or_directory   pinfo <- if haveNonrangeMatch opts            then return $ patch2patchinfo `unseal2` (matchPatch opts r)-           else case mapRL info $ concatRL r of+           else case mapRL info $ newset2RL r of                 [] -> fail "Annotate does not currently work correctly on empty repositories."                 (x:_) -> return x   pop <- getRepoPopVersion "." pinfo@@ -154,10 +163,9 @@   -- deal with --creator-hash option   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 == ""+                     Nothing -> lookupPop+                     Just cp -> lookupCreationPop cp+  if toFilePath file_or_directory == "." || toFilePath file_or_directory == ""     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 '"++@@ -166,13 +174,13 @@           | modifiedHowI i == RemovedDir && modifiedByI i /= pinfo ->               errorDoc $ text ("The directory '" ++ toFilePath rel_file_or_directory ++                                "' was removed by")-                      $$ human_friendly (modifiedByI i)+                      $$ humanFriendly (modifiedByI i)           | 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)+                      $$ humanFriendly (modifiedByI i)           | otherwise -> annotateFile repository opts pinfo file_or_directory pt  annotateCmd _ _ = fail "annotate accepts at most one argument"@@ -235,10 +243,10 @@ createdAsXml pinfo as = text "<created_as original_name='"                        <> escapeXML as                        <> text "'>"-                    $$    to_xml pinfo+                    $$    toXml pinfo                     $$    text "</created_as>" --removed_by_xml :: PatchInfo -> String---removed_by_xml pinfo = "<removed_by>\n"++to_xml pinfo++"</removed_by>\n"+--removed_by_xml pinfo = "<removed_by>\n"++toXml pinfo++"</removed_by>\n"  p2xmlOpen :: PatchInfo -> PopTree -> Doc p2xmlOpen _ (PopFile inf) =@@ -250,7 +258,7 @@                     Nothing -> empty                     Just ci -> createdAsXml ci                                (BC.unpack $ fromJust $ creationNameI inf)-          modified = modified_to_xml inf+          modified = modifiedToXml inf p2xmlOpen _ (PopDir inf _) =     text "<directory name='" <> escapeXML f <> text "'>"  $$ created@@ -260,7 +268,7 @@                     Nothing -> empty                     Just ci -> createdAsXml ci                                (BC.unpack $ fromJust $ creationNameI inf)-          modified = modified_to_xml inf+          modified = modifiedToXml inf  p2xmlClose :: PatchInfo -> PopTree -> Doc p2xmlClose _(PopFile _) = text "</file>"@@ -289,7 +297,7 @@                      <> 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+  old_pis <- (dropWhile (/= pinfo).mapRL info.newset2RL) `fmap` readRepo repository   mapM_ (annotateMarkedup opts pinfo old_pis) mk   when (XMLOutput `elem` opts) $  putDocLn $ p2xmlClose pinfo (PopFile inf)   where ci = fromJust $ createdByI inf@@ -340,7 +348,7 @@     | wheni `elem` old_pis = return ()     | otherwise            = putDocLn $ text "<normal_line>"                              $$ text "<removed_by>"-                             $$ to_xml wheni+                             $$ toXml wheni                              $$ text "</removed_by>"                              $$ escapeXML (BC.unpack l)                              $$ text "</normal_line>"@@ -350,7 +358,7 @@                              $$ text "</added_line>"     | wheni `elem` old_pis = putDocLn $ text "<normal_line>"                              $$ text "<added_by>"-                             $$ to_xml wheni+                             $$ toXml wheni                              $$ text "</added_by>"                              $$ escapeXML (BC.unpack l)                              $$ text "</normal_line>"@@ -359,24 +367,24 @@     | whenadd == pinfo =         putDocLn $ text "<added_line>"                 $$ text "<removed_by>"-                $$ to_xml whenrem+                $$ toXml whenrem                 $$ text "</removed_by>"                 $$ escapeXML (BC.unpack l)                 $$ text "</added_line>"     | whenrem == pinfo =         putDocLn $ text "<removed_line>"                 $$ text "<added_by>"-                $$ to_xml whenadd+                $$ toXml whenadd                 $$ text "</added_by>"                 $$ escapeXML (BC.unpack l)                 $$ text "</removed_line>"     | whenadd `elem` old_pis && not (whenrem `elem` old_pis) =         putDocLn $ text "<normal_line>"                 $$ text "<removed_by>"-                $$ to_xml whenrem+                $$ toXml whenrem                 $$ text "</removed_by>"                 $$ text "<added_by>"-                $$ to_xml whenadd+                $$ toXml whenadd                 $$ text "</added_by>"                 $$ escapeXML (BC.unpack l)                 $$ text "</normal_line>"@@ -395,14 +403,14 @@ examine a file even if it has been renamed multiple times.  \begin{code}-findCreationPatchinfo :: [DarcsFlag] -> PatchSet p C(x) -> Maybe PatchInfo+findCreationPatchinfo :: [DarcsFlag] -> PatchSet p C(Origin x) -> Maybe PatchInfo findCreationPatchinfo [] _ = Nothing-findCreationPatchinfo (CreatorHash h:_) r = findHash h $ mapRL info $ concatRL r+findCreationPatchinfo (CreatorHash h:_) r = findHash h $ mapRL info $ newset2RL r findCreationPatchinfo (_:fs) r = findCreationPatchinfo fs r  findHash :: String -> [PatchInfo] -> Maybe PatchInfo findHash _ [] = Nothing findHash h (pinf:pinfs)-    | take (length h) (make_filename pinf) == h = Just pinf+    | take (length h) (makeFilename pinf) == h = Just pinf     | otherwise = findHash h pinfs \end{code}

@@ -18,20 +18,22 @@ \darcsCommand{apply} \begin{code} {-# OPTIONS_GHC -cpp #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, PatternGuards #-}  module Darcs.Commands.Apply ( apply ) where import System.Exit ( ExitCode(..), exitWith ) import Prelude hiding ( catch )-import System.IO ( hClose, stdin, stdout, stderr )-import Control.Exception ( catch, throw, Exception( ExitException ) )+import System.IO ( hClose, stdout, stderr )+import Control.Exception.Extensible+                 ( catch, fromException, SomeException, throwIO ) import Control.Monad ( when ) -import Darcs.Hopefully ( PatchInfoAnd, n2pia, conscientiously, info )+import Darcs.Hopefully ( PatchInfoAnd, n2pia, conscientiously, hopefullyM, info ) import Darcs.SignalHandler ( withSignalsBlocked ) import Darcs.Commands ( DarcsCommand(..), putVerbose )-import Darcs.CommandsAux ( check_paths )-import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All ),+import Darcs.CommandsAux ( checkPaths )+import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All),+                         matchSeveral,                          definePatches,                          getCc, workingRepoDir,                         notest, nocompress, applyConflictOptions,@@ -40,37 +42,45 @@                         reply, verify, listFiles,                         fixFilePathOrStd, umaskOption,                         allInteractive, sendmailCmd,-                        leaveTestDir, happyForwarding, +                        leaveTestDir, happyForwarding,                         dryRun, printDryRunMessageAndExit,-                        setScriptsExecutableOption, restrictPaths+                        setScriptsExecutableOption, restrictPaths,+                        changesReverse                       )-import Darcs.Flags(doHappyForwarding)+import Darcs.Flags(doHappyForwarding, doReverse)  import qualified Darcs.Arguments as DarcsArguments ( ccApply ) import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd ) import Darcs.Repository ( Repository, SealedPatchSet, withRepoLock, ($-), amInRepository,                           tentativelyMergePatches,-                    read_repo,+                    readRepo,                     finalizeRepositoryChanges,                     applyToWorking, invalidateIndex                   )+#ifdef GADT_WITNESSES+import Darcs.Patch.Set ( Origin )+#endif+import Darcs.Patch.Set ( newset2RL ) import Darcs.Patch ( RepoPatch, description )-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 Darcs.Patch.Info ( PatchInfo, humanFriendly )+import Darcs.Witnesses.Ordered ( FL, RL(..), (:\/:)(..), (:>)(..), (:>>)(..),+                       mapFL, mapRL, nullFL, mapFL_FL, reverseFL )+import ByteStringUtils ( linesPS, unlinesPS, gzReadFilePS, gzReadStdin )+import Data.List( (\\) )+import qualified Data.ByteString as B (ByteString, null, init, take, drop) import qualified Data.ByteString.Char8 as BC (unpack, last, pack)  import Darcs.External ( sendEmail, sendEmailDoc, resendEmail,                   verifyPS )-import Darcs.Email ( read_email )+import Darcs.Email ( readEmail ) import Darcs.Lock ( withStdoutTemp, readBinFile )-import Darcs.Patch.Depends ( get_common_and_uncommon_or_missing )-import Darcs.SelectChanges ( with_selected_changes, filterOutConflicts )-import Darcs.Patch.Bundle ( scan_bundle )+import Darcs.Patch.Depends ( findUncommon, findCommonWithThem )+import Darcs.SelectChanges ( selectChanges, WhichChanges(..),+                             runSelection, selectionContext,+                             filterOutConflicts )+import Darcs.Patch.Bundle ( scanBundle ) import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Printer ( packedString, vcat, text, ($$), errorDoc, empty )+import Printer ( packedString, vcat, text, ($$), empty, renderString )  #include "impossible.h" @@ -126,22 +136,23 @@                                                   sendmailCmd,                                                   ignoretimes, nocompress,                                                   setScriptsExecutableOption, umaskOption,-                                                  restrictPaths],+                                                  restrictPaths, changesReverse],                       commandBasicOptions = [verify,                                               allInteractive]++dryRun++-                                              [applyConflictOptions,-                                              useExternalMerge,-                                              notest,-                                              leaveTestDir,-                                              workingRepoDir]}+                                              [matchSeveral,+                                               applyConflictOptions,+                                               useExternalMerge,+                                               notest,+                                               leaveTestDir,+                                               workingRepoDir]}  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+  ps <- useAbsoluteOrStd (gzReadFilePS . toFilePath) gzReadStdin patchesfile   let from_whom = getFrom ps-  us <- read_repo repository+  us <- readRepo repository   either_them <- getPatchBundle opts ps   Sealed them      <- case either_them of@@ -150,24 +161,35 @@                         if forwarded                           then exitWith ExitSuccess                           else fail er-  (_, us':\/:them') <- case get_common_and_uncommon_or_missing (us, them) of-                         Left pinfo ->-                            if pinfo `elem` mapRL info (concatRL us)-                                then cannotApplyPartialRepo pinfo ""-                                else cannotApplyMissing pinfo-                         Right x -> return x-  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+  common :>> ours <- return $ findCommonWithThem us them++  -- all patches that are in "them" and not in "common" need to be available; check that+  let common_i = mapRL info $ newset2RL common+      them_i = mapRL info $ newset2RL them+      required = them_i \\ common_i -- FIXME quadratic?+      check :: RL (PatchInfoAnd p) C(x y) -> [PatchInfo] -> IO ()+      check (p :<: ps) bad = case hopefullyM p of+        Nothing | info p `elem` required -> check ps (info p : bad)+        _ -> check ps bad+      check NilRL [] = return ()+      check NilRL bad = fail . renderString $ vcat $ map humanFriendly bad +++                        [ text "\nFATAL: Cannot apply this bundle. We are missing the above patches." ]++  check (newset2RL them) []++  (us':\/:them') <- return $ findUncommon us them+  (hadConflicts, Sealed their_ps) <- filterOutConflicts opts (reverseFL us') repository them'   when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."-  when (nullFL their_ps_filtered) $+  when (nullFL their_ps) $        do putStr $ "All these patches have already been applied.  " ++                      "Nothing to do.\n"           exitWith ExitSuccess-  with_selected_changes "apply" fixed_opts Nothing their_ps_filtered $-                            \ (to_be_applied:>_) ->-                                applyItNow opts from_whom repository us' to_be_applied+  let context = selectionContext "apply" fixed_opts Nothing []+      selector = if doReverse opts+                 then selectChanges FirstReversed+                 else selectChanges First+  (to_be_applied :> _) <- runSelection (selector their_ps) context+  applyItNow opts from_whom repository us' to_be_applied     where fixed_opts = if Interactive `elem` opts                          then opts                          else All : opts@@ -175,38 +197,24 @@  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 ()+           -> FL (PatchInfoAnd p) C(x t) -> 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+   checkPaths opts 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 us') to_be_applied+    Sealed pw <- tentativelyMergePatches repository "apply" opts us' to_be_applied     invalidateIndex repository     withSignalsBlocked $ do finalizeRepositoryChanges repository-                            applyToWorking repository opts pw `catch` \e ->+                            applyToWorking repository opts pw `catch` \(e :: SomeException) ->                                 fail ("Error applying patch to working dir:\n" ++ show e)+                            return ()     putStrLn "Finished applying..."--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@@ -222,15 +230,15 @@ \begin{code}  getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString-                 -> IO (Either String (SealedPatchSet p))+                 -> IO (Either String (SealedPatchSet p C(Origin))) getPatchBundle opts fps = do-    mps <- verifyPS opts $ read_email fps+    mps <- verifyPS opts $ readEmail fps     mops <- verifyPS opts fps     case (mps, mops) of       (Nothing, Nothing) ->           return $ Left "Patch bundle not properly signed, or gpg failed."-      (Just ps, Nothing) -> return $ scan_bundle ps-      (Nothing, Just ps) -> return $ scan_bundle ps+      (Just ps, Nothing) -> return $ scanBundle ps+      (Nothing, Just ps) -> return $ scanBundle ps       -- We use careful_scan_bundle only below because in either of the two       -- above case we know the patch was signed, so it really shouldn't       -- need stripping of CRs.@@ -238,8 +246,8 @@                               Left _ -> return $ careful_scan_bundle ps2                               Right x -> return $ Right x           where careful_scan_bundle ps =-                    case scan_bundle ps of-                    Left e -> case scan_bundle $ stripCrPS ps of+                    case scanBundle ps of+                    Left e -> case scanBundle $ stripCrPS ps of                               Right x -> Right x                               _ -> Left e                     x -> x@@ -302,7 +310,7 @@            | B.take 5 x == fromStart = BC.unpack $ B.drop 5 x            | otherwise = readFrom xs -redirectOutput :: [DarcsFlag] -> String -> IO a -> IO a+redirectOutput :: forall a . [DarcsFlag] -> String -> IO a -> IO a redirectOutput opts to doit = ro opts     where   cc = getCc opts@@ -313,17 +321,18 @@                                   hClose stderr;                                   return a;                                  } `catch` (sendit tempf)-        where sendit tempf e@(ExitException ExitSuccess) =+        where sendit :: FilePath -> SomeException -> IO a+              sendit tempf e | Just ExitSuccess <- fromException e =                 do sendSanitizedEmail opts f to "Patch applied" cc tempf                    throwIO e-              sendit tempf (ExitException _) =+              sendit tempf e | Just (_ :: ExitCode) <- fromException e =                 do sendSanitizedEmail opts f to "Patch failed!" cc tempf-                   throwIO $ ExitException ExitSuccess+                   throwIO ExitSuccess               sendit tempf e =                 do sendSanitizedEmail opts f to "Darcs error applying patch!" cc $                              tempf ++ "\n\nCaught exception:\n"++                              show e++"\n"-                   throwIO $ ExitException ExitSuccess+                   throwIO ExitSuccess   ro (_:fs) = ro fs  -- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd@@ -349,9 +358,6 @@           remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s           remove_backspaces "" ('\008':s) = remove_backspaces "" s           remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss--throwIO :: Exception -> IO a-throwIO e = return $ throw e  forwardingMessage :: B.ByteString forwardingMessage = BC.pack $

@@ -20,15 +20,17 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts #-} {-# LANGUAGE CPP, PatternGuards #-} +#include "gadts.h"+ module Darcs.Commands.Changes ( changes, log ) where import Prelude hiding ( log )+import Unsafe.Coerce (unsafeCoerce)  import Data.List ( intersect, sort ) import Data.Maybe ( fromMaybe ) import Control.Monad ( when, unless )  import Darcs.Hopefully ( hopefullyM, info )-import Darcs.Patch.Depends ( slightly_optimize_patchset ) import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) import Darcs.Arguments ( DarcsFlag(Context, HumanReadable, MachineReadable,                                    Interactive, Count,@@ -45,30 +47,31 @@                       ) import Darcs.Flags ( doReverse, showChangesOnlyToFiles ) import Darcs.RepoPath ( toFilePath, rootDirectory )-import Darcs.Patch.FileName ( fp2fn, fn2fp, norm_path )-import Darcs.Repository ( Repository, PatchSet, PatchInfoAnd,+import Darcs.Patch.FileName ( fp2fn, fn2fp, normPath )+import Darcs.Repository ( Repository, PatchInfoAnd,                           withRepositoryDirectory, ($-), findRepository,-                          read_repo, unrecordedChanges )-import Darcs.Patch.Info ( to_xml, showPatchInfo )-import Darcs.Patch.Depends ( get_common_and_uncommon )-import Darcs.Patch.TouchesFiles ( look_touch )+                          readRepo, unrecordedChanges )+import Darcs.Patch.Set ( PatchSet(..), newset2RL )+import Darcs.Patch.Info ( toXml, showPatchInfo )+import Darcs.Patch.Depends ( findCommonWithThem )+import Darcs.Patch.Bundle( contextPatches )+import Darcs.Patch.TouchesFiles ( lookTouch ) import Darcs.Patch ( RepoPatch, invert, xmlSummary, description, applyToFilepaths,                      listTouchedFiles, effect, identity )-import Darcs.Witnesses.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL,-                             EqCheck(..), filterFL )+import Darcs.Witnesses.Ordered ( RL(..), EqCheck(..), filterFLFL, filterRL,+                                 reverseFL, (:>>)(..), mapRL ) import Darcs.Match ( firstMatch, secondMatch,                matchAPatchread, haveNonrangeMatch,                matchFirstPatchset, matchSecondPatchset,              ) import Darcs.Commands.Annotate ( createdAsXml ) import Printer ( Doc, putDocLnWith, simplePrinters, (<+>),-                 renderString, prefix, text, vcat, vsep, -                 ($$), empty, errorDoc, insert_before_lastline )+                 renderString, prefix, text, vcat, vsep,+                 ($$), empty, errorDoc, insertBeforeLastline ) import Darcs.ColorPrinter ( fancyPrinters ) import Progress ( setProgressMode, debugMessage )-import Darcs.SelectChanges ( view_changes )-import Darcs.Witnesses.Sealed ( unsafeUnseal )-#include "impossible.h"+import Darcs.SelectChanges ( viewChanges )+import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..), FlippedSeal(..), seal2 )  changesDescription :: String changesDescription = "List patches in the repository."@@ -114,23 +117,23 @@   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 unrecordedChanges opts repository files-           `catch` \_ -> return identity -- this is triggered when repository is remote-  let filez = map (fn2fp . norm_path . fp2fn) $ applyToFilepaths (invert unrec) $ map toFilePath files+  Sealed unrec <- if null files then return (Sealed identity)+                  else Sealed `fmap` unrecordedChanges opts repository files+                  `catch` \_ -> return (Sealed identity) -- this is triggered when repository is remote+  let filez = map (fn2fp . normPath . 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+  patches <- readRepo repository   debugMessage "Done reading the repository."   if Interactive `elem` opts     then do let (fp_and_fs, _, _) = filtered_changes patches                 fp = map fst fp_and_fs-            view_changes opts (unsafeFL fp)+            viewChanges opts fp     else do when (not (null files) && not (XMLOutput `elem` opts)) $                  putStrLn $ "Changes to "++unwords filez++":\n"             debugMessage "About to print the changes..."             let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters-            ps <- read_repo repository -- read repo again to prevent holding onto+            ps <- readRepo 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 doReverse opts@@ -157,16 +160,21 @@  "whereas `darcs changes --last 3 foo.c' will, of the last three\n" ++  "patches, print only those that affect foo.c.\n" -getChangesInfo :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p-                 -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)+getChangesInfo :: RepoPatch p => [DarcsFlag] -> [FilePath]+               -> PatchSet p C(x y)+               -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [FilePath], Doc) getChangesInfo opts plain_fs ps =-  case get_common_and_uncommon (p2s,p1s) of-  (_,us:\/:_) -> filterPatchesByNames (maxCount opts) fs $ filter pf $ unsafeUnRL us+    case (sp1s, sp2s) of+      (Sealed p1s, Sealed p2s) ->+          case findCommonWithThem p2s p1s of+            _ :>> us -> filterPatchesByNames (maxCount opts) fs $ filterRL pf $ reverseFL us   where fs = map (\x -> "./" ++ x) $ plain_fs-        p1s = if firstMatch opts then unsafeUnseal $ matchFirstPatchset opts ps-                                  else NilRL:<:NilRL-        p2s = if secondMatch opts then unsafeUnseal $ matchSecondPatchset opts ps-                                   else ps+        sp1s = if firstMatch opts+               then matchFirstPatchset opts ps+               else Sealed $ PatchSet NilRL NilRL+        sp2s = if secondMatch opts+               then matchSecondPatchset opts ps+               else Sealed $ ps         pf = if haveNonrangeMatch opts              then matchAPatchread opts              else \_ -> True@@ -182,20 +190,20 @@ filterPatchesByNames :: RepoPatch p =>                            Maybe Int -- ^ maxcount                         -> [FilePath] -- ^ filenames-                        -> [PatchInfoAnd p] -- ^ patchlist-                        -> ([(PatchInfoAnd p,[FilePath])], [FilePath], Doc)+                        -> [Sealed2 (PatchInfoAnd p)] -- ^ patchlist+                        -> ([(Sealed2 (PatchInfoAnd p),[FilePath])], [FilePath], Doc) filterPatchesByNames (Just 0) _ _ = ([], [], empty) filterPatchesByNames _ _ [] = ([], [], empty) filterPatchesByNames maxcount [] (hp:ps) =     (hp, []) -:- filterPatchesByNames (subtract 1 `fmap` maxcount) [] ps-filterPatchesByNames maxcount fs (hp:ps)+filterPatchesByNames maxcount fs ((Sealed2 hp):ps)     | Just p <- hopefullyM hp =-    case look_touch fs (invert p) of-    (True, []) -> ([(hp, fs)], fs, empty)-    (True, fs') -> (hp, fs) -:- filterPatchesByNames-                                (subtract 1 `fmap` maxcount) fs' ps+    case lookTouch fs (invert p) of+    (True, []) -> ([(Sealed2 hp, fs)], fs, empty)+    (True, fs') -> (Sealed2 hp, fs) -:- filterPatchesByNames+                                         (subtract 1 `fmap` maxcount) fs' ps     (False, fs') -> filterPatchesByNames maxcount fs' ps-filterPatchesByNames _ _ (hp:_) =+filterPatchesByNames _ _ ((Sealed2 hp):_) =     ([], [], text "Can't find changes prior to:" $$ description hp)  -- | Note, lazy pattern matching is required to make functions like@@ -206,13 +214,14 @@ (-:-) :: a -> ([a],b,c) -> ([a],b,c) x -:- ~(xs,y,z) = (x:xs,y,z) -changelog :: RepoPatch p => [DarcsFlag] -> PatchSet p -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)+changelog :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) ->+            ([(Sealed2 (PatchInfoAnd p), [FilePath])], [FilePath], Doc)           -> Doc changelog opts patchset (pis_and_fs, orig_fs, errstring)     | Count `elem` opts = text $ show $ length pis_and_fs     | MachineReadable `elem` opts =         if renderString errstring == ""-        then vsep $ map (showPatchInfo.info) pis+        then vsep $ map (unseal2 (showPatchInfo.info)) pis         else errorDoc errstring     | XMLOutput `elem` opts =          text "<changelog>"@@ -224,41 +233,45 @@         $$ errstring     | otherwise = vsep (map (number_patch description') pis_and_fs)                $$ errstring-    where change_with_summary (hp, fs)+    where change_with_summary (Sealed2 hp, fs)               | Just p <- hopefullyM hp = if showChangesOnlyToFiles opts                                           then description hp $$ text "" $$-                                               indent (showFriendly opts (filterFL xx $ effect p))+                                               indent (showFriendly opts (filterFLFL xx $ effect p))                                           else showFriendly opts p               | otherwise = description hp                             $$ indent (text "[this patch is unavailable]")               where xx x = case listTouchedFiles x of-                             ys | null $ ys `intersect` fs -> IsEq+                             ys | null $ ys `intersect` fs -> unsafeCoerce IsEq+                             -- in that case, the change does not affect the patches we are+                             -- looking at, so we ignore the difference between the two states.+                             -- It's all read-only anyway.                              _ -> NotEq-          xml_with_summary hp-              | Just p <- hopefullyM hp = insert_before_lastline-                                           (to_xml $ info hp) (indent $ xmlSummary p)-          xml_with_summary hp = to_xml (info hp)+          xml_with_summary (Sealed2 hp)+              | Just p <- hopefullyM hp = insertBeforeLastline+                                           (toXml $ info hp) (indent $ xmlSummary p)+          xml_with_summary (Sealed2 hp) = toXml (info hp)           indent = prefix "    "           actual_xml_changes = if Summary `elem` opts                                then map xml_with_summary pis-                               else map (to_xml.info) pis+                               else map (toXml . (unseal2 info)) pis           xml_file_names = map (createdAsXml first_change) orig_fs           first_change = if doReverse opts-                         then info $ head pis-                         else info $ last pis+                         then unseal2 info $ head pis+                         else unseal2 info $ last pis           number_patch f x = if NumberPatches `elem` opts                              then case get_number (fst x) of                                   Just n -> text (show n++":") <+> f x                                   Nothing -> f x                              else f x-          get_number :: PatchInfoAnd p -> Maybe Int-          get_number y = gn 1 (concatRL patchset)+          get_number :: Sealed2 (PatchInfoAnd p) -> Maybe Int+          get_number (Sealed2 y) = gn 1 (newset2RL patchset)               where iy = info y+                    gn :: Int -> RL (PatchInfoAnd p) C(start x) -> Maybe Int                     gn n (b:<:bs) | seq n (info b) == iy = Just n                                   | otherwise = gn (n+1) bs                     gn _ NilRL = Nothing           pis = map fst pis_and_fs-          description' = description . fst+          description' = unseal2 description . fst  -- FIXME: this prose is unreadable. --twb, 2009-08 changesHelp'' :: String@@ -278,19 +291,15 @@  "WILL be output for a knowledgeable human to recreate the current state\n" ++  "of the repository.\n" -changesContext :: RepoPatch p => Repository p -> [DarcsFlag] -> IO ()+changesContext :: RepoPatch p => Repository p C(r u t) -> [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 $-                 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+  FlippedSeal ps' <- contextPatches `fmap` readRepo repository+  let ps = mapRL (\p -> (seal2 p, [])) ps'+  unless fancy $ putStrLn "\nContext:\n"+  putDocLnWith simplePrinters $ changelog opts' emptyset (ps, [], empty)+    where opts' = if fancy then opts else MachineReadable : opts+          fancy = HumanReadable `elem` opts || XMLOutput `elem` opts+          emptyset = PatchSet NilRL NilRL  log :: DarcsCommand log = commandAlias "log" Nothing changes

@@ -26,7 +26,7 @@  import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo ) import Darcs.Arguments ( DarcsFlag(Quiet),-                        partialCheck, notest, testByDefault,+                         partialCheck, test,                         leaveTestDir, workingRepoDir, ignoretimes                       ) import Darcs.Flags(willIgnoreTimes)@@ -34,12 +34,14 @@                               , RepositoryConsistency(..) ) import Darcs.Repository ( Repository, amInRepository, withRepository,                           testRecorded, readRecorded )-import Darcs.Patch ( RepoPatch, showPatch )+import Darcs.Patch ( RepoPatch, showPatch, Prim ) import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Diff( treeDiff ) import Printer ( text, ($$), (<+>) ) +#include "gadts.h"  checkDescription :: String checkDescription = "Check the repository for consistency."@@ -71,7 +73,7 @@                       commandArgdefaults = nodefaults,                       commandAdvancedOptions = [],                       commandBasicOptions = [partialCheck,-                                              notest,+                                             test,                                               leaveTestDir,                                               workingRepoDir,                                                ignoretimes@@ -80,9 +82,10 @@ checkCmd :: [DarcsFlag] -> [String] -> IO () checkCmd opts _ = withRepository opts (check' opts) -check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()+check'+  :: forall p C(r u t) . (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) -> IO () check' opts repository = do-    failed <- replayRepository repository (testByDefault opts) $ \ state -> do+    failed <- replayRepository repository opts $ \ state -> do       case state of         RepositoryConsistent -> do           putInfo opts $ text "The repository is consistent!"@@ -105,7 +108,7 @@          putInfo opts $ text "Looks like we have a difference..."          mc <- readRecorded repository          ftf <- filetypeFunction-         diff <- treeDiff ftf newpris mc+         Sealed (diff :: FL Prim C(r r2)) <- unFreeLeft `fmap` treeDiff ftf newpris mc :: IO (Sealed (FL Prim C(r)))          putInfo opts $ case diff of                         NilFL -> text "Nothing"                         patch -> text "Difference: " <+> showPatch patch

@@ -34,41 +34,46 @@  import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully ) import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo, putVerbose )-import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo,-                                    SetScriptsExecutable, UseFormat2, NoUpdateWorking),-                        reponame,-                        setScriptsExecutableOption,-                        networkOptions )-import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo,+import Darcs.Arguments+   ( DarcsFlag+      ( AllowConflicts, NewRepo, SetScriptsExecutable, UseFormat2+      , NoUpdateWorking, NoLinks+      )+   , reponame+   , setScriptsExecutableOption+   , networkOptions+   )+import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, readRepo,                           createRepository, invalidateIndex,-                          slurp_recorded, optimizeInventory,+                          optimizeInventory,                           tentativelyMergePatches, patchSetToPatches,                           createPristineDirectoryTree,                           revertRepositoryChanges, finalizeRepositoryChanges,-                          applyToWorking )+                          applyToWorking, setScriptsExecutable ) import Darcs.Global ( darcsdir ) import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch,                      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 )+                                 concatFL, mapRL )+import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo )+import Darcs.Patch.Commute ( publicUnravel ) import Darcs.Patch.Real ( mergeUnravelled )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2))-import Darcs.Repository.Motd ( show_motd )-import Darcs.Utils ( clarifyErrors, askUser )+import Darcs.Repository.Motd ( showMotd )+import Darcs.Utils ( clarifyErrors, askUser, catchall ) import Darcs.ProgressPatches ( progressFL ) import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(..) ) 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.External+import System.FilePath.Posix +#include "gadts.h"+ convertDescription :: String convertDescription = "Convert a repository from a legacy format." @@ -126,22 +131,22 @@ 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 +  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-  show_motd opts repodir+  showMotd opts repodir   mysimplename <- makeRepoName opts repodir   createDirectory mysimplename   setCurrentDirectory mysimplename@@ -160,24 +165,25 @@       -- "universal" functions to do the conversion, but that's also       -- unsatisfying. -      let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch)-          themrepo = unsafeCoerce# themrepobar :: Repository Patch-      theirstuff <- read_repo themrepo+      let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch) C(r u t)+          themrepo = unsafeCoerce# themrepobar :: Repository Patch C(r u t)+      theirstuff <- readRepo themrepo       let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff           inOrderTags = iot theirstuff-              where iot ((t:<:NilRL):<:r) = info t : iot r-                    iot (NilRL:<:r) = iot r-                    iot NilRL = []-                    iot ((_:<:x):<:y) = iot (x:<:y)-          outOfOrderTags = catMaybes $ mapRL oot $ concatRL theirstuff-              where oot t = if is_tag (info t) && not (info t `elem` inOrderTags)+              where iot :: PatchSet p C(s x) -> [PatchInfo]+                    iot (PatchSet _ ts) = iot_ ts+                    iot_ :: RL(Tagged t1) C(t y) -> [PatchInfo]+                    iot_ (Tagged t _ _ :<: ts) = info t : iot_ ts+                    iot_ NilRL = []+          outOfOrderTags = catMaybes $ mapRL oot $ newset2RL theirstuff+              where oot t = if isTag (info t) && not (info t `elem` inOrderTags)                             then Just (info t, getdeps $ hopefully t)                             else Nothing           fixDep p = case lookup p outOfOrderTags of                      Just d -> p : concatMap fixDep d                      Nothing -> [p]-          convertOne :: Patch -> FL RealPatch-          convertOne x | isMerger x = case mergeUnravelled $ public_unravel $ modernizePatch x of+          convertOne :: Patch C(x y) -> FL RealPatch C(x y)+          convertOne x | isMerger x = case mergeUnravelled $ publicUnravel $ modernizePatch x of                                        Just (FlippedSeal y) ->                                            case effect y =/\= effect x of                                            IsEq -> y :>: NilFL@@ -193,13 +199,13 @@                                      NilFL -> NilFL                                      (x':>:NilFL) -> fromPrims $ effect x'                                      xs -> concatFL $ mapFL_FL convertOne xs-          convertNamed :: Named Patch -> PatchInfoAnd (FL RealPatch)+          convertNamed :: Named Patch C(x y) -> PatchInfoAnd (FL RealPatch) C(x y)           convertNamed n = n2pia $                            adddeps (infopatch (convertInfo $ patch2patchinfo n) $                                               convertOne $ patchcontents n)                                    (map convertInfo $ concatMap fixDep $ getdeps n)           convertInfo n | n `elem` inOrderTags = n-                        | otherwise = maybe n (\t -> pi_rename n ("old tag: "++t)) $ pi_tag n+                        | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n           applySome xs = do Sealed pw <- tentativelyMergePatches repository "convert" (AllowConflicts:opts) NilFL xs                             finalizeRepositoryChanges repository -- this is to clean out pristine.hashed                             revertRepositoryChanges repository@@ -208,15 +214,13 @@       sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches       invalidateIndex repository       revertable $ createPristineDirectoryTree repository "."-      when (SetScriptsExecutable `elem` opts) $-               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 opts $ text ("Making executable: " ++ f)-                                 setExecutable f True-                  mapM_ setExecutableIfScript c+      when (SetScriptsExecutable `elem` opts) $ setScriptsExecutable++      -- Copy over the prefs file+      let prefsRelPath = darcsdir </> "prefs" </> "prefs"+      copyFileOrUrl [NoLinks] (repodir </> prefsRelPath)+         prefsRelPath Uncachable `catchall` return ()+       optimizeInventory repository       putInfo opts $ text "Finished converting."       where revertable x = x `clarifyErrors` unlines@@ -260,5 +264,5 @@                return thename        else mrn n $ i+1     where thename = if i == -1 then n else n++"_"++show i-                        -\end{code}                        ++\end{code}

@@ -29,12 +29,14 @@ import Control.Monad ( when ) import Data.List ( (\\) ) -import Darcs.External( diff_program )+import Storage.Hashed.Plain( writePlainTree )++import Darcs.External( diffProgram ) import CommandLine ( parseCmd ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag(DiffFlags, DiffCmd,                                    LastN, AfterPatch),-                        matchRange, storeInMemory, +                        matchRange, storeInMemory,                         diffCmdFlag, diffflags, unidiff,                          workingRepoDir, fixSubPaths,                       )@@ -44,15 +46,16 @@ import Darcs.Match ( getPartialFirstMatch, getPartialSecondMatch,                      firstMatch, secondMatch,                      matchFirstPatchset, matchSecondPatchset )-import Darcs.Repository ( PatchSet, withRepository, ($-), read_repo,-                          amInRepository, slurp_recorded_and_unrecorded,+import Darcs.Repository ( withRepository, ($-), readRepo,+                          amInRepository,                           createPristineDirectoryTree,                           createPartialsPristineDirectoryTree )-import Darcs.SlurpDirectory ( get_path_list, writeSlurpy )+import Darcs.Patch.Set ( PatchSet, newset2RL )+import Darcs.Repository.State ( readUnrecorded, restrictSubpaths ) import Darcs.Patch ( RepoPatch )-import Darcs.Witnesses.Ordered ( mapRL, concatRL )-import Darcs.Patch.Info ( PatchInfo, human_friendly )-import Darcs.External ( execPipeIgnoreError, clonePaths )+import Darcs.Witnesses.Ordered ( mapRL )+import Darcs.Patch.Info ( PatchInfo, humanFriendly )+import Darcs.External ( execPipeIgnoreError ) import Darcs.Lock ( withTempDir ) import Darcs.Witnesses.Sealed ( unseal ) import Printer ( Doc, putDoc, vcat, empty, ($$) )@@ -127,7 +130,7 @@  -- | 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+-- default 'diffProgram'.  Note that this potentially involves parsing the -- user's diff-command, hence the possibility for failure with an exception. getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String                       -> Either String (String, [String])@@ -187,9 +190,9 @@          ++ " patch to the present, or use just '--patch' to view this specific"          ++ " patch.")   formerdir <- getCurrentDirectory-  path_list <- if null args-               then return []-               else map sp2fn `fmap` fixSubPaths opts args+  subpaths <- if null args then return []+                           else fixSubPaths opts args+  let path_list = map sp2fn subpaths   thename <- return $ takeFileName formerdir   withTempDir ("old-"++thename) $ \odir -> do     setCurrentDirectory formerdir@@ -203,11 +206,8 @@     if secondMatch opts        then withCurrentDirectory ndir $             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-                  then withCurrentDirectory ndir $ writeSlurpy s "."-                  else clonePaths formerdir (toFilePath ndir) ps+       else withCurrentDirectory formerdir $ do+               readUnrecorded repository subpaths >>= (flip writePlainTree (toFilePath ndir))     thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $                    case path_list of                    [] -> rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir)@@ -215,12 +215,12 @@                          mapM (\f -> rundiff                                (takeFileName (toFilePath odir) ++ "/" ++ toFilePath f)                                (takeFileName (toFilePath ndir) ++ "/" ++ toFilePath f)) fs-    morepatches <- read_repo repository+    morepatches <- readRepo repository     putDoc $ changelog (getDiffInfo opts morepatches)             $$ thediff     where rundiff :: String -> String -> IO Doc           rundiff f1 f2 = do-            cmd <- diff_program+            cmd <- diffProgram             case getDiffCmdAndArgs cmd opts f1 f2 of              Left err -> fail err              Right (d_cmd, d_args) ->@@ -233,9 +233,9 @@                     return ()                  return output -getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> [PatchInfo]+getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> [PatchInfo] getDiffInfo opts ps =-    let infos = mapRL info . concatRL+    let infos = mapRL info . newset2RL         handle (match_cond, do_match)           | match_cond opts = unseal infos (do_match opts ps)           | otherwise = infos ps@@ -243,6 +243,6 @@          \\ handle (firstMatch, matchFirstPatchset)  changelog :: [PatchInfo] -> Doc-changelog pis = vcat $ map human_friendly pis+changelog pis = vcat $ map humanFriendly pis \end{code} 

@@ -25,6 +25,11 @@ import System.FilePath.Posix ( takeFileName, (</>) ) import Data.Char ( isAlphaNum ) import Control.Monad ( when )+import Codec.Archive.Tar ( pack, write )+import Codec.Archive.Tar.Entry ( entryPath )+import Codec.Compression.GZip ( compress )+import Prelude hiding ( writeFile )+import Data.ByteString.Lazy ( writeFile )  import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp,                         commandDescription, commandExtraArgs,@@ -40,10 +45,9 @@ import Darcs.Repository ( amInRepository, withRepoReadLock, ($-), --withRecorded,                           createPartialsPristineDirectoryTree ) import Darcs.Repository.Prefs ( getPrefval )-import Darcs.Lock ( withTemp, withTempDir, readBinFile )+import Darcs.Lock ( withTempDir ) import Darcs.RepoPath ( AbsolutePath, toFilePath ) import Darcs.Utils ( withCurrentDirectory )-import Exec ( exec, Redirect(..) )  distDescription :: String distDescription = "Create a distribution tarball."@@ -106,36 +110,30 @@                then return [""]                else map toFilePath `fmap` fixSubPaths opts args   resultfile <- return (formerdir</>distname++".tar.gz")-  withTemp $ \tarfile ->-    withTempDir "darcsdist" $ \tempdir -> do-      setCurrentDirectory (formerdir)-      withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do-        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 doDist verb tarfile tempdir ddir resultfile-            else-                do-                putStrLn "Dist aborted due to predist failure"-                exitWith ec+  withTempDir "darcsdist" $ \tempdir -> do+    setCurrentDirectory (formerdir)+    withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do+      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 doDist verb tempdir ddir resultfile+          else+              do+              putStrLn "Dist aborted due to predist failure"+              exitWith ec  -- | This function performs the actual distribution action itself. -- NB - it does /not/ perform the pre-dist, that should already -- have completed successfully before this is invoked.-doDist :: Bool -> FilePath -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()-doDist verb tarfile tempdir ddir resultfile = do+doDist :: Bool -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()+doDist verb tempdir ddir resultfile = do   setCurrentDirectory (toFilePath tempdir)-  exec "tar" ["-cf", "-", safename $ takeFileName $ toFilePath ddir]-             (Null, File tarfile, AsIs)-  when verb $ withTemp $ \tar_listing -> do-                exec "tar" ["-tf", "-"]-                     (File tarfile, File tar_listing, Stdout)-                to <- readBinFile tar_listing-                putStr to-  exec "gzip" ["-c"]-       (File tarfile, File resultfile, AsIs)+  let safeddir = safename $ takeFileName $ toFilePath ddir+  entries <- pack "." [safeddir]+  when verb $ putStr $ unlines $ map entryPath entries+  writeFile resultfile $ compress $ write entries   putStrLn $ "Created dist as "++resultfile   where     safename n@(c:_) | isAlphaNum c  = n

@@ -36,27 +36,31 @@                         partial, reponame,                         matchOneContext, setDefault, setScriptsExecutableOption, nolinks,                         networkOptions )-import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo,+import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, readRepo,                           createPristineDirectoryTree,-                          tentativelyRemovePatches, patchSetToPatches, patchSetToRepository,+                          tentativelyRemovePatches, patchSetToRepository,                           copyRepository, tentativelyAddToPending,                           finalizeRepositoryChanges, setScriptsExecutable                         , invalidateIndex ) import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat,                                  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,+import Darcs.Repository.DarcsRepo ( writeInventory )+import qualified Darcs.Repository.DarcsRepo as DR ( readRepo )+import Darcs.Repository ( SealedPatchSet, copyOldrepoPatches,                         createRepository)-import Darcs.Repository.ApplyPatches ( apply_patches )-import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint )-import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert,-                     effect, description )-import Darcs.Witnesses.Ordered ( (:\/:)(..), RL(..), mapRL, concatRL, reverseRL, lengthFL )+import Darcs.Patch.Set ( PatchSet(..),  newset2RL )+#ifdef GADT_WITNESSES+import Darcs.Patch.Set ( Origin )+#endif+import Darcs.Repository.ApplyPatches ( applyPatches )+import Darcs.Repository.Checkpoint ( writeCheckpointPatch, getCheckpoint )+import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert, effect )+import Darcs.Witnesses.Ordered ( RL(..), reverseRL, lengthFL, mapFL_FL, (:>>)(..) ) import Darcs.External ( copyFileOrUrl, Cachable(..) )-import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag )+import Darcs.Hopefully ( hopefully )+import Darcs.Patch.Depends ( findCommonWithThem, countUsThem, getPatchesBeyondTag ) import Darcs.Repository.Prefs ( setDefaultrepo )-import Darcs.Repository.Motd ( show_motd )+import Darcs.Repository.Motd ( showMotd ) import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, ) import Darcs.SignalHandler ( catchInterrupt ) import Darcs.Commands.Init ( initialize )@@ -66,10 +70,11 @@ import Printer ( text, vcat, errorDoc, ($$) ) import Darcs.Lock ( writeBinFile ) import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote)-import Darcs.Witnesses.Sealed ( Sealed(..), unsafeUnflippedseal )+import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..) ) import Darcs.Global ( darcsdir ) import English ( englishNum, Noun(..) ) #include "impossible.h"+#include "gadts.h"  getDescription :: String getDescription = "Create a local copy of a repository."@@ -126,7 +131,7 @@                     commandBasicOptions = [reponame,                                             partial,                                             matchOneContext,-                                            setDefault,+                                            setDefault True,                                             setScriptsExecutableOption,                                              nolinks,                                              getInventoryChoices]}@@ -140,7 +145,7 @@   debugMessage "Starting work on get..."   typed_repodir <- ioAbsoluteOrRemote inrepodir   let repodir = toPath typed_repodir-  show_motd opts repodir+  showMotd opts repodir   when (Partial `elem` opts) $ debugMessage "Reading checkpoint..."   rfsource_or_e <- identifyRepoFormat repodir   rfsource <- case rfsource_or_e of Left e -> fail e@@ -165,7 +170,7 @@                         Right x -> return x   if formatHas HashedInventory rf -- refactor this into repository     then writeBinFile (darcsdir++"/hashed_inventory") ""-    else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch)+    else writeInventory "." (PatchSet NilRL NilRL :: PatchSet Patch C(Origin Origin))    if not (null [p | OnePattern p <- opts]) -- --to-match given      && not (Partial `elem` opts) && not (Lazy `elem` opts)@@ -183,11 +188,11 @@ -- right format has already been created. copyRepoAndGoToChosenVersion :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> IO () copyRepoAndGoToChosenVersion opts repodir rfsource rf = do-  copy_repo `catchInterrupt` (when (formatHas HashedInventory rfsource)+  copyRepo `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 =+      where copyRepo =                 withRepository opts $- \repository -> do                   let hashUs   = formatHas HashedInventory rf                       hashThem = formatHas HashedInventory rfsource@@ -273,25 +278,23 @@                       then return $ Right ()                       else return . Left $ "Context file "++toFilePath f++" does not exist" -goToChosenVersion :: RepoPatch p => Repository p+goToChosenVersion :: RepoPatch p => Repository p C(r u r)                      -> [DarcsFlag] -> IO () goToChosenVersion repository opts =     when (havePatchsetMatch opts) $ do        debugMessage "Going to specified version..."-       patches <- read_repo repository+       patches <- readRepo repository        Sealed context <- getOnePatchset repository opts-       let (_,us':\/:them') = get_common_and_uncommon (patches, context)-       case them' of-           NilRL -> return ()-           _ -> errorDoc $ text "Missing these patches from context:"-                        $$ (vcat $ mapRL description them')-       let ps = patchSetToPatches (us':<:NilRL)+       when (snd (countUsThem patches context) > 0) $+            errorDoc $ text "Missing patches from context!" -- FIXME : - (+       _ :>> us' <- return $ findCommonWithThem patches context+       let ps = mapFL_FL hopefully us'        putInfo opts $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++                    (englishNum (lengthFL ps) (Noun "patch") "")        invalidateIndex repository        withRepoLock opts $- \_ ->-           do tentativelyRemovePatches repository opts ps-              tentativelyAddToPending repository opts $ invert $ effect ps+           do tentativelyRemovePatches repository opts us'+              tentativelyAddToPending repository opts $ invert $ effect us'               finalizeRepositoryChanges repository               apply opts (invert $ effect ps) `catch` \e ->                   fail ("Couldn't undo patch in working dir.\n" ++ show e)@@ -306,18 +309,18 @@  "For modern darcs-2 repositories, --partial is a deprecated alias for\n" ++  "the --lazy option.\n" -copyRepoOldFashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO ()+copyRepoOldFashioned :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO () copyRepoOldFashioned repository opts repodir = do   myname <- getCurrentDirectory   fromrepo <- identifyRepositoryFor repository repodir-  mch <- get_checkpoint fromrepo-  patches <- read_repo fromrepo+  mch <- getCheckpoint fromrepo+  patches <- readRepo fromrepo   debugMessage "Getting the inventory..."-  write_inventory "." patches+  writeInventory "." patches   debugMessage "Copying patches..."-  copy_oldrepo_patches opts fromrepo "."+  copyOldrepoPatches opts fromrepo "."   debugMessage "Patches copied"-  Sealed local_patches <- DR.read_repo opts "." :: IO (SealedPatchSet Patch)+  Sealed local_patches <- DR.readRepo opts "." :: IO (SealedPatchSet Patch C(Origin))   debugMessage "Repo read"   repo_is_local <- doesDirectoryExist repodir   debugMessage $ "Repo local: " ++ formatPath (show repo_is_local)@@ -338,15 +341,14 @@      else do        setCurrentDirectory myname        if Partial `elem` opts && isJust mch-          then let Sealed p_ch = fromJust mch-                   pi_ch = patch2patchinfo p_ch-                   needed_patches = reverseRL $ unsafeUnflippedseal $-                                    get_patches_beyond_tag pi_ch local_patches-                   in do write_checkpoint_patch p_ch-                         apply opts p_ch `catch`-                             \e -> fail ("Bad checkpoint!!!\n" ++ prettyError e)-                         apply_patches opts needed_patches-          else apply_patches opts $ reverseRL $ concatRL local_patches+          then do Sealed p_ch <- return (fromJust mch)+                  let pi_ch = patch2patchinfo p_ch+                  FlippedSeal needed_patches <- return (getPatchesBeyondTag pi_ch local_patches)+                  writeCheckpointPatch p_ch+                  apply opts p_ch `catch`+                      \e -> fail ("Bad checkpoint!!!\n" ++ prettyError e)+                  applyPatches opts (reverseRL needed_patches)+          else applyPatches opts $ reverseRL $ newset2RL local_patches   debugMessage "Writing the pristine"   pristine <- identifyPristine   createPristineFromWorking pristine

@@ -27,16 +27,17 @@  import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) import Darcs.Arguments ( DarcsFlag, ignoretimes, workingRepoDir, umaskOption )-import Darcs.Repository ( withRepoLock, ($-), amInRepository, add_to_pending,+import Darcs.Repository ( withRepoLock, ($-), amInRepository, addToPending,                     applyToWorking,-                    read_repo, unrecordedChanges+                    readRepo, unrecordedChanges, Repository                     )-import Darcs.Patch ( invert )+import Darcs.Patch ( invert, Prim ) import Darcs.Witnesses.Ordered ( FL(..) ) import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Darcs.Resolution ( patchset_conflict_resolutions )+import Darcs.Resolution ( patchsetConflictResolutions ) import Darcs.Utils ( promptYorn ) #include "impossible.h"+#include "gadts.h"  markconflictsDescription :: String markconflictsDescription =@@ -77,25 +78,28 @@                                                       workingRepoDir]}  markconflictsCmd :: [DarcsFlag] -> [String] -> IO ()-markconflictsCmd opts [] = withRepoLock opts $- \repository -> do+markconflictsCmd opts [] = withRepoLock opts $- \(repository :: Repository p C(r u r)) -> 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."-                          exitWith ExitSuccess-              _ -> return ()-  case pend of-    NilFL -> return ()-    _ ->      do putStrLn ("This will trash any unrecorded changes"+++  r <- readRepo repository+  Sealed res <- return $ patchsetConflictResolutions r+  (case res of NilFL -> do putStrLn "No conflicts to mark."+                           exitWith ExitSuccess+               _ -> return ()) :: IO ()+  let undoUnrec :: FL Prim C(r u) -> IO (Repository p C(r r r))+      undoUnrec NilFL = return repository+      undoUnrec pend =+              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)+  repository' <- undoUnrec pend   withSignalsBlocked $-    do add_to_pending repository res-       applyToWorking repository opts res `catch` \e ->+    do addToPending repository' res+       applyToWorking repository' opts res `catch` \e ->            bug ("Problem marking conflicts in mark-conflicts!" ++ show e)+       return ()   putStrLn "Finished marking conflicts." markconflictsCmd _ _ = impossible 

@@ -21,6 +21,7 @@ {-# LANGUAGE CPP #-}  module Darcs.Commands.Move ( move, mv ) where+import Control.Applicative ( (<$>) ) import Control.Monad ( when, unless, zipWithM_ ) import Data.Maybe ( catMaybes ) import Darcs.SignalHandler ( withSignalsBlocked )@@ -31,23 +32,27 @@                         listFiles, allowProblematicFilenames, umaskOption,                       ) import Darcs.Flags ( doAllowCaseOnly, doAllowWindowsReserved )-import Darcs.RepoPath ( toFilePath, sp2fn )+import Darcs.RepoPath ( toFilePath ) import System.FilePath.Posix ( (</>), takeFileName ) import System.Directory ( renameDirectory ) import Workaround ( renameFile )-import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository,-                    slurp_pending, add_to_pending,-                  )-import Darcs.Witnesses.Ordered ( FL(..), unsafeFL )+import Darcs.Repository.State ( readRecordedAndPending )+import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository, addToPending )+import Darcs.Witnesses.Ordered ( FL(..), toFL )+import Darcs.Witnesses.Sealed ( Sealed(..), unseal, freeGap, FreeLeft, unFreeLeft ) 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, superName ) import qualified System.FilePath.Windows as WindowsFilePath +import Darcs.Utils( treeHas, treeHasDir, treeHasAnycase, treeHasFile )+import Storage.Hashed.Tree( Tree, modifyTree )+import Storage.Hashed.Plain( readPlainTree )+import Storage.Hashed.AnchoredPath( floatPath )+ #include "impossible.h"+#include "gadts.h"  moveDescription :: String moveDescription = "Move or rename files."@@ -90,18 +95,20 @@                         [_,_] -> two_files                         [_] -> error "Cannot rename a file or directory onto itself!"                         xs -> bug $ "Problem in moveCmd: " ++ show xs-  work <- slurp "."+  work <- readPlainTree "."   let old_fp = toFilePath old       new_fp = toFilePath new-  if slurp_hasdir (sp2fn new) work && slurp_has old_fp work+  has_new <- treeHasDir work new_fp+  has_old <- treeHas work old_fp+  if has_new && has_old    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)+    cur <- readRecordedAndPending repository+    addpatch <- checkNewAndOldFilenames opts cur work (old_fp,new_fp)     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)+      case unFreeLeft <$> addpatch of+        Nothing -> addToPending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)+        Just (Sealed p) -> addToPending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)       moveFileOrDir work old_fp new_fp  moveCmd opts args =@@ -111,50 +118,52 @@          finaldir = last relpaths      moveToDir repository opts moved finaldir -moveToDir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()+moveToDir :: RepoPatch p => Repository p C(r u t) -> [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+      movepatches = zipWith (\a b -> freeGap (Darcs.Patch.move a b)) moved movetargets   in do-    cur <- slurp_pending repository-    work <- slurp "."-    addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets+    cur <- readRecordedAndPending repository+    work <- readPlainTree "."+    addpatches <- mapM (checkNewAndOldFilenames opts cur work) $ zip moved movetargets     withSignalsBlocked $ do-      add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches+      unseal (addToPending repository) $ toFL $ catMaybes addpatches ++ movepatches       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+checkNewAndOldFilenames+    :: [DarcsFlag] -> Tree IO -> Tree IO -> (FilePath, FilePath) -> IO (Maybe (FreeLeft Prim))+checkNewAndOldFilenames opts cur work (old,new) = do   unless (doAllowWindowsReserved opts || WindowsFilePath.isValid new) $      fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++             "Use --reserved-ok to allow such filenames."+  has_work <- treeHas work old+  has_cur <- treeHas cur old   maybe_add_file_thats_been_moved <--     if slurp_has old work -- We need to move the object-     then do unless (slurp_hasdir (superName $ fp2fn new) work) $+     if has_work -- We need to move the object+     then do has_target <- treeHasDir work (fn2fp $ superName $ fp2fn new)+             unless has_target $                     fail $ "The target directory " ++                              (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"+             has_new <- it_has work+             when has_new $ 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 (superName $ fp2fn new) cur) $+     else do has_new <- treeHas work new+             unless has_new $ fail $ doesnt_exist "working directory"+             return (Just (freeGap (Darcs.Patch.addfile old)))+  if has_cur+     then do has_target <- treeHasDir cur (fn2fp $ superName $ fp2fn new)+             unless has_target $                     fail $ "The target directory " ++                              (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"+             has_new <- it_has cur+             when has_new $ fail $ already_exists "repository"      else fail $ doesnt_exist "repository"   return maybe_add_file_thats_been_moved-    where it_has f s = -            let ms2 = slurp_remove (fp2fn old) s-            in case ms2 of-               Nothing -> False-               Just s2 -> if doAllowCaseOnly opts-                          then slurp_has f s2-                          else slurp_has_anycase f s2+    where it_has s = treeHas_case (modifyTree s (floatPath old) Nothing) new+          treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase           already_exists what_slurpy =               if doAllowCaseOnly opts               then "A file or dir named "++new++" already exists in "@@ -167,15 +176,14 @@               "There is no file or dir named " ++ old ++               " in the "++ what_slurpy ++ "." -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 ()+moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()+moveFileOrDir work old new = do+  has_file <- treeHasFile work old+  has_dir <- treeHasDir work old+  when has_file $ do debugMessage $ unwords ["renameFile",old,new]+                     renameFile old new+  when has_dir $ do debugMessage $ unwords ["renameDirectory",old,new]+                    renameDirectory old new  mv :: DarcsCommand mv = commandAlias "mv" Nothing move

@@ -21,57 +21,59 @@ {-# LANGUAGE CPP #-}  module Darcs.Commands.Optimize ( optimize ) where+import Control.Applicative ( (<$>) ) import Control.Monad ( when, unless ) import Data.Maybe ( isJust )-import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist )+import System.Directory ( getDirectoryContents, doesDirectoryExist,+                          doesFileExist, renameFile )+import System.IO.Unsafe ( unsafeInterleaveIO ) import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BL  import Storage.Hashed.Darcs( decodeDarcsSize ) -import Darcs.Hopefully ( hopefully, info )+import Darcs.Hopefully ( info ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag( UpgradeFormat, UseHashedInventory,                                     Compress, UnCompress,                                     NoCompress, Reorder,-                                    Relink, RelinkPristine, OptimizePristine ),+                                    Relink, RelinkPristine, OptimizePristine,+                                    OptimizeHTTP ),                         reorderPatches,                         uncompressNocompress,                         relink, relinkPristine, sibling,                         flagsToSiblings,                         upgradeFormat,-                        workingRepoDir, umaskOption, optimizePristine+                        workingRepoDir, umaskOption, optimizePristine,+                        -- optimizeHTTP -- disabled for darcs-2.5                       ) import Darcs.Repository.Prefs ( getPreflist )-import Darcs.Repository ( Repository, PatchSet, withRepoLock, ($-), withGutsOf,-                          read_repo, optimizeInventory, slurp_recorded,+import Darcs.Repository ( Repository,+                          withRepoLock, ($-), withGutsOf,+                          readRepo, optimizeInventory,                           tentativelyReplacePatches, cleanRepository,                           amInRepository, finalizeRepositoryChanges, replacePristine )-import Darcs.Witnesses.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL )-import Darcs.Patch.Info ( PatchInfo, just_name )+import Darcs.Witnesses.Ordered ( (+<+), reverseRL, mapRL, (:>>)(..)+                               , mapFL, bunchFL, lengthRL )+import Darcs.Patch.Info ( isTag ) import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Set ( PatchSet(..), newset2RL, newset2FL, progressPatchSet ) import ByteStringUtils ( gzReadFilePS )-import Darcs.Patch.Depends ( slightly_optimize_patchset,-                 get_patches_beyond_tag, get_patches_in_tag,-               )+import Darcs.Patch.Depends ( splitOnTag ) import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS ) import Darcs.RepoPath ( toFilePath ) import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage )-import Darcs.SlurpDirectory ( slurp, list_slurpy_files ) import Darcs.Repository.Pristine ( identifyPristine, pristineDirectory )-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, (</>) )+import System.FilePath.Posix ( takeExtension, (</>), (<.>) ) -import Progress ( beginTedious, endTedious, tediousSize, progress )-import SHA1 ( sha1PS )+import Progress ( beginTedious, endTedious, tediousSize ) import Darcs.Flags ( compression )-import Darcs.Lock ( rm_recursive )-import Darcs.Witnesses.Ordered ( mapFL, mapRL_RL, bunchFL, lengthRL )+import Darcs.Lock ( rmRecursive ) import Darcs.ProgressPatches ( progressFL ) import Darcs.Repository.Cache ( hashedDir, HashedDir(HashedPristineDir) ) import Darcs.Repository.Format ( identifyRepoFormat,@@ -82,6 +84,16 @@ import Darcs.Repository.Repair ( replayRepository, RepositoryConsistency(..) ) import Darcs.Repository.State ( readRecorded ) import Darcs.Utils ( catchall )++import Storage.Hashed.Tree( TreeItem(..), list, expand, emptyTree )+import Storage.Hashed.AnchoredPath( anchorPath )+import Storage.Hashed.Plain( readPlainTree )+import Storage.Hashed.Darcs( writeDarcsHashed )++import Codec.Archive.Tar ( write )+import Codec.Archive.Tar.Entry ( fileEntry, toTarPath )+import Codec.Compression.GZip ( compress )+ #include "gadts.h"  optimizeDescription :: String@@ -125,12 +137,14 @@                                                  sibling, relink,                                                  relinkPristine,                                                   upgradeFormat,-                                                 optimizePristine]}+                                                 optimizePristine+                                                 ]} --optimizeHTTP]} -- disabled for 2.5  optimizeCmd :: [DarcsFlag] -> [String] -> IO () optimizeCmd origopts _ = do     when (UpgradeFormat `elem` origopts) optimizeUpgradeFormat     withRepoLock opts $- \repository -> do+    when (OptimizeHTTP `elem` origopts) doOptimizeHTTP     if (OptimizePristine `elem` opts)        then doOptimizePristine repository        else do cleanRepository repository@@ -142,8 +156,6 @@                     doRelink opts repository     putStrLn "Done optimizing!"   where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts-isTag :: PatchInfo -> Bool-isTag pinfo = take 4 (just_name pinfo) == "TAG "  optimizeHelpInventory :: String optimizeHelpInventory =@@ -152,7 +164,7 @@  "remote command needs to download.  It should also reduce the CPU time\n" ++  "needed for some operations.\n" -doOptimizeInventory :: RepoPatch p => Repository p -> IO ()+doOptimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO () doOptimizeInventory repository = do     debugMessage "Writing out a nice copy of the inventory."     optimizeInventory repository@@ -204,7 +216,7 @@  "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" -doOptimizePristine :: RepoPatch p => Repository p -> IO ()+doOptimizePristine :: RepoPatch p => Repository p C(r u t) -> IO () doOptimizePristine repo = do   hashed <- doesFileExist $ darcsdir </> "hashed_inventory"   when hashed $ do@@ -218,33 +230,33 @@                                       readRecorded repo >>= replacePristine repo                                       cleanRepository repo -doRelink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()+doRelink :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO () doRelink opts repository =     do some_siblings <- return (flagsToSiblings opts)        defrepolist <- getPreflist "defaultrepo"        siblings <- return (map toFilePath some_siblings ++ defrepolist)-       if (siblings == []) +       if (siblings == [])           then putStrLn "No siblings -- no relinking done."           else do when (Relink `elem` opts) $                       do debugMessage "Relinking patches..."-                         patches <--                           (fmap list_slurpy_files) (slurp $ darcsdir++"/patches")-                         maybeRelinkFiles siblings patches (darcsdir++"/patches")+                         patch_tree <- expand =<< readPlainTree "_darcs/patches"+                         let patches = [ anchorPath "" p | (p, File _) <- list patch_tree ]+                         maybeRelinkFiles siblings patches "_darcs/patches"                   when (RelinkPristine `elem` opts) $                       do pristine <- identifyPristine                          case (pristineDirectory pristine) of                              (Just d) -> do                                  debugMessage "Relinking pristine tree..."-                                 c <- slurp_recorded repository+                                 c <- readRecorded repository                                  maybeRelinkFiles-                                     siblings (list_slurpy_files c) d+                                     siblings [ anchorPath "" p | (p, File _) <- list c ] d                              Nothing -> return ()                   debugMessage "Done relinking."                   return ()        return ()  maybeRelinkFiles :: [String] -> [String] -> String -> IO ()-maybeRelinkFiles src dst dir = +maybeRelinkFiles src dst dir =     mapM_ (maybeRelinkFile src) (map ((dir ++ "/") ++) dst)  maybeRelinkFile :: [String] -> String -> IO ()@@ -278,31 +290,24 @@ --  "of the default optimization.  It reorders patches with respect to ALL\n" ++ --  "tags, rather than just the latest tag.\n" -doReorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()+doReorder :: RepoPatch p => [DarcsFlag] -> Repository p C(r u r) -> IO () doReorder opts _ | not (Reorder `elem` opts) = return () doReorder opts repository = do     debugMessage "Reordering the inventory."-    psnew <- chooseOrder `fmap` read_repo repository-    let ps = mapFL_FL hopefully $ reverseRL $ head $ unsafeUnRL psnew-    withGutsOf repository $ do tentativelyReplacePatches repository opts ps+    PatchSet ps _ <- chooseOrder `fmap` readRepo repository+    withGutsOf repository $ do tentativelyReplacePatches repository opts $ reverseRL ps                                finalizeRepositoryChanges repository     debugMessage "Done reordering the inventory." -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 -> (p+<+(t:<:NilRL)) :<: pps-    _ -> impossible             -    where last_tag = case filter isTag $ mapRL info $ concatRL ps of-                     (t:_) -> Just t-                     _ -> Nothing-          lt = fromJust last_tag-chooseOrder ps = ps+chooseOrder :: forall p C(s x) . RepoPatch p => PatchSet p C(s x) -> PatchSet p C(s x)+chooseOrder ps = case filter isTag $ mapRL info $ newset2RL ps of+                  [] -> ps+                  (lt:_) -> case splitOnTag lt ps of+                            PatchSet xs ts :>> r -> PatchSet (r+<+xs) ts \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+upgrade of your repository to the latest \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!).@@ -328,38 +333,68 @@ actuallyUpgradeFormat :: RepoPatch p => Repository p C(r u t) -> IO () actuallyUpgradeFormat repository = do   -- convert patches/inventory-  patches <- read_repo repository+  patches <- readRepo repository   let k = "Hashing patch"   beginTedious k-  tediousSize k (lengthRL $ concatRL patches)-  let patches' = mapRL_RL (mapRL_RL (progress k)) patches+  tediousSize k (lengthRL $ newset2RL patches)+  let patches' = progressPatchSet k patches   cache <- getCaches [] "."   let compr = compression [] -- default compression-  HashedRepo.write_tentative_inventory cache compr patches'+  HashedRepo.writeTentativeInventory 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'+  let patchesToApply = progressFL "Applying patch" $ newset2FL $ patches'   createDirectoryIfMissing False $ darcsdir </> hashedDir HashedPristineDir-  writeFile (darcsdir </> hashedDir HashedPristineDir </> sha1PS B.empty) ""-  sequence_ $ mapFL (HashedRepo.apply_to_tentative_pristine cache []) $ bunchFL 100 patchesToApply+  writeDarcsHashed emptyTree "_darcs/pristine.hashed"+  sequence_ $ mapFL (HashedRepo.applyToTentativePristine []) $ bunchFL 100 patchesToApply   -- now make it official-  HashedRepo.finalize_tentative_changes repository compr+  HashedRepo.finalizeTentativeChanges 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")+  rmRecursive (darcsdir </> "pristine") `catchall` rmRecursive (darcsdir </> "current")   rmGzsIn (darcsdir </> "patches")   rmGzsIn (darcsdir </> "inventories")   let checkpointDir = darcsdir </> "checkpoints"   hasCheckPoints <- doesDirectoryExist checkpointDir-  when hasCheckPoints $ rm_recursive checkpointDir+  when hasCheckPoints $ rmRecursive checkpointDir   putStrLn "Done upgrading!"  where   rmGzsIn dir =     withCurrentDirectory dir $ do       gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "."       mapM_ removeFile gzs++doOptimizeHTTP :: IO ()+doOptimizeHTTP = do+  rf <- either fail return =<< identifyRepoFormat "."+  unless (formatHas HashedInventory rf) . fail $+    "Unsupported repository format:\n" +++    "  only hashed repositories can be optimized for HTTP"+  createDirectoryIfMissing False packsDir+  ps <- dirContents' "patches" $ \x -> all (x /=) ["unrevert", "pending",+    "pending.tentative"]+  BL.writeFile (patchesTar <.> "part") . compress . write =<<+    mapM fileEntry' ps+  renameFile (patchesTar <.> "part") patchesTar+  let i = darcsdir </> "hashed_inventory"+  is <- dirContents "inventories"+  pr <- dirContents "pristine.hashed"+  BL.writeFile (basicTar <.> "part") . compress . write =<<+    mapM fileEntry' (i : (is ++ pr))+  renameFile (basicTar <.> "part") basicTar+ where+  packsDir = darcsdir </> "packs"+  basicTar = packsDir </> "basic.tar.gz"+  patchesTar = packsDir </> "patches.tar.gz"+  fileEntry' x = unsafeInterleaveIO $ do+    content <- BL.fromChunks . return <$> gzReadFilePS x+    tp <- either fail return $ toTarPath False x+    return $ fileEntry tp content+  dirContents d = dirContents' d $ const True+  dirContents' d f = map ((darcsdir </> d) </>) . filter (\x ->+    head x /= '.' && f x) <$> getDirectoryContents (darcsdir </> d) \end{code}

@@ -18,19 +18,19 @@ \darcsCommand{pull} \begin{code} {-# OPTIONS_GHC -cpp #-}-{-# LANGUAGE CPP #-} -module Darcs.Commands.Pull ( pull ) where+module Darcs.Commands.Pull ( pull, fetch ) where import System.Exit ( ExitCode(..), exitWith ) import Workaround ( getCurrentDirectory ) import Control.Monad ( when ) import Data.List ( nub )+import Data.Maybe ( fromMaybe )  import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo )-import Darcs.CommandsAux ( check_paths )+import Darcs.CommandsAux ( checkPaths ) import Darcs.Arguments ( DarcsFlag( Verbose, DryRun, MarkConflicts,                                    Intersection, Complement, AllowConflicts,-                                   NoAllowConflicts ),+                                   NoAllowConflicts, XMLOutput ),                          nocompress, ignoretimes, definePatches,                          depsSel, pullConflictOptions, useExternalMerge,                          matchSeveral, fixUrl,@@ -39,25 +39,41 @@                          test, dryRun,                          setDefault, summary, workingRepoDir, remoteRepo,                          setScriptsExecutableOption, nolinks,-                         networkOptions, umaskOption, allowUnrelatedRepos, restrictPaths+                         networkOptions, umaskOption, allowUnrelatedRepos, restrictPaths, changesReverse,+                         getOutput, output                       )-import Darcs.Repository ( Repository, SealedPatchSet, identifyRepositoryFor, withGutsOf,+import Darcs.Flags( doReverse )+import Darcs.Repository ( Repository, identifyRepositoryFor, withGutsOf,                           amInRepository, withRepoLock, ($-), tentativelyMergePatches,                           finalizeRepositoryChanges, applyToWorking,-                          read_repo, checkUnrelatedRepos, invalidateIndex )-import Darcs.Hopefully ( info )+                          readRepo, checkUnrelatedRepos, invalidateIndex, modifyCache, modifyCache,  HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..))+import qualified Darcs.Repository.Cache as DarcsCache+import Darcs.Repository.Merge+import Darcs.Hopefully ( info, hopefully, patchDesc ) import Darcs.Patch ( RepoPatch, description )-import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), RL(..),-                             mapFL, nullFL, reverseRL, mapRL )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Bundle( makeBundleN, patchFilename )+import Darcs.Hopefully ( PatchInfoAnd )+#ifdef GADT_WITNESSES+import Darcs.Patch.Set ( Origin )+#endif+import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2FL )+import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), FL(..), RL(..), (:>>)(..)+                               , mapFL, nullFL, reverseFL, mapFL_FL, unsafeCoercePEnd ) import Darcs.Patch.Permutations ( partitionFL ) 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, filterOutConflicts )+import Darcs.Repository.Motd (showMotd )+import Darcs.Patch.Depends ( findUncommon, findCommonWithThem,+                             newsetIntersection, newsetUnion )+import Darcs.SelectChanges ( selectChanges,+                             WhichChanges(..),+                             filterOutConflicts,+                             runSelection, selectionContext) import Darcs.Utils ( clarifyErrors, formatPath ) import Darcs.Witnesses.Sealed ( Sealed(..), seal )-import Printer ( putDocLn, vcat, ($$), text )+import Printer ( putDocLn, vcat, ($$), text, putDoc )+import Darcs.Lock ( writeDocBinFile )+import Darcs.RepoPath ( useAbsoluteOrStd, stdOut ) #include "impossible.h"  #include "gadts.h"@@ -66,6 +82,10 @@ pullDescription =  "Copy and apply patches from another repository to this one." +fetchDescription :: String+fetchDescription =+ "Fetch patches from another repository, but don't apply them."+ pullHelp :: String pullHelp =  "Pull is used to bring changes made in another repository into the current\n"++@@ -76,6 +96,43 @@  "without an argument, pull will use the repository from which you have most\n"++  "recently either pushed or pulled.\n" +fetchHelp :: String+fetchHelp =+ "fetch is used to bring changes made in another repository\n" +++ "into the current repository without actually applying\n"+++ "them. Fetch allows you to bring over all or\n"+++ "some of the patches that are in that repository but not in this one. Fetch\n"+++ "accepts arguments, which are URLs from which to fetch, and when called\n"+++ "without an argument, fetch will use the repository from which you have most\n"+++ "recently either pushed or pulled.\n"+++ "The fetched patches are stored into a patch bundle, to be later\n" +++ "applied using \"darcs apply\"."+++fetch :: DarcsCommand+fetch = DarcsCommand {+         commandName = "fetch",+         commandHelp = fetchHelp,+         commandDescription = fetchDescription,+         commandExtraArgs = -1,+         commandExtraArgHelp = ["[REPOSITORY]..."],+         commandCommand = fetchCmd,+         commandPrereq = amInRepository,+         commandGetArgPossibilities = getPreflist "repos",+         commandArgdefaults = defaultrepo,+         commandAdvancedOptions = [repoCombinator,+                                     remoteRepo] +++                                    networkOptions,+         commandBasicOptions = [matchSeveral,+                                  allInteractive]+                                 ++dryRun+++                                 [summary,+                                  depsSel,+                                  setDefault False,+                                  workingRepoDir,+                                  output,+                                  allowUnrelatedRepos]}+ pull :: DarcsCommand pull = DarcsCommand {commandName = "pull",                      commandHelp = pullHelp,@@ -92,7 +149,9 @@                                                  remoteRepo,                                                  setScriptsExecutableOption,                                                  umaskOption,-                                                 restrictPaths] +++                                                 restrictPaths,+                                                 changesReverse+                                                ] ++                                                 networkOptions,                      commandBasicOptions = [matchSeveral,                                               allInteractive,@@ -100,66 +159,116 @@                                               useExternalMerge,                                               test]++dryRun++[summary,                                               depsSel,-                                              setDefault,+                                              setDefault False,                                               workingRepoDir,                                               allowUnrelatedRepos]} +mergeOpts :: [DarcsFlag] -> [DarcsFlag]+mergeOpts opts | NoAllowConflicts `elem` opts = opts+                | AllowConflicts   `elem` opts = opts+                | otherwise                    = MarkConflicts : opts+ pullCmd :: [DarcsFlag] -> [String] -> IO ()-pullCmd opts unfixedrepodirs@(_:_) = withRepoLock opts $- \repository -> do+pullCmd opts repos =+  do+    pullingFrom <- mapM (fixUrl opts) repos+    withRepoLock opts $- \ initRepo -> do+      let repository = modifyCache initRepo $ addReposToCache pullingFrom+      r <- fetchPatches opts' repos "pull" repository+      applyPatches opts' repository r+    where+      opts' = mergeOpts opts+      addReposToCache repos (Ca cache) = Ca $ [ toReadOnlyCache r | r <- repos ] ++  cache+      toReadOnlyCache = Cache DarcsCache.Repo NotWritable+++fetchCmd :: [DarcsFlag] -> [String] -> IO ()+fetchCmd opts repos =+    withRepoLock opts $- \ repository ->+        fetchPatches opts repos "fetch" repository+                         >>= makeBundle opts++fetchPatches :: FORALL(p r u t) (RepoPatch p) => [DarcsFlag] -> [String] -> String ->+               Repository p C(r u r) ->+                   IO ( SealedPatchSet p C(Origin), Sealed ((FL (PatchInfoAnd p)  :\/: FL (PatchInfoAnd p)) C(r)))+fetchPatches opts unfixedrepodirs@(_:_) jobname 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) <- readRepos repository opts repodirs   old_default <- getPreflist "defaultrepo"-  setDefaultrepo (head repodirs) opts-  mapM_ (addToPreflist "repos") repodirs-  when (old_default == repodirs) $+  when (old_default == repodirs && not (XMLOutput `elem` opts)) $       let pulling = if DryRun `elem` opts then "Would pull" else "Pulling"       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 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)-               _ -> return ()-             when (not $ nullFL ps) $ putDocLn $ text "They have the following patches to pull:"-                      $$ (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 Nothing psFiltered $-      \ (to_be_pulled:>_) ->+  (Sealed them, Sealed compl) <- readRepos repository opts repodirs+  setDefaultrepo (head repodirs) opts+  mapM_ (addToPreflist "repos") repodirs+  mapM_ (showMotd opts) repodirs+  us <- readRepo repository+  checkUnrelatedRepos opts us them++  common :>> _ <- return $ findCommonWithThem us them+  us' :\/: them' <- return $ findUncommon us them+  _   :\/: compl' <- return $ findUncommon us compl++  let avoided = mapFL info compl'+  ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) them'+  when (Verbose `elem` opts) $+       do case us' of+            (x@(_:>:_)) -> putDocLn $ text "We have the following new (to them) patches:"+                                                             $$ (vcat $ mapFL description x)+            _ -> return ()+          when (not $ nullFL ps) $ putDocLn $ text "They have the following patches to pull:"+                                                             $$ (vcat $ mapFL description ps)+  (hadConflicts, Sealed psFiltered) <- filterOutConflicts opts (reverseFL 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+  let context = selectionContext jobname opts Nothing []+      selector = if doReverse opts+                 then selectChanges FirstReversed+                 else selectChanges First+  (to_be_pulled :> _) <- runSelection (selector psFiltered) $ context+  return (seal common, seal $ us' :\/: to_be_pulled)++fetchPatches _ [] jobname _ = fail $ "No default repository to " ++ jobname +++                                " from, please specify one"++applyPatches ::+    forall p C(r u t a). (RepoPatch p) => [DarcsFlag] -> Repository p C(r u r) ->+    (SealedPatchSet p C(Origin), Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(r)))+    -> IO ()+applyPatches opts repository (_, Sealed (us' :\/: 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+           checkPaths 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+           Sealed pw <- tentativelyMergePatches repository "pull" opts us' to_be_pulled            invalidateIndex repository            withGutsOf repository $ do finalizeRepositoryChanges repository                                       revertable $ applyToWorking repository opts pw+                                      return ()            putInfo opts $ text "Finished pulling and applying." -pullCmd _ [] = fail "No default repository to pull from, please specify one"+makeBundle ::+    forall p C(r u t x) . (RepoPatch p) => [DarcsFlag] ->+    (SealedPatchSet p C(Origin), Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(r)))+    -> IO ()+makeBundle opts (Sealed common, Sealed (_ :\/: to_be_fetched)) =+    do+      bundle <- makeBundleN Nothing (unsafeCoercePEnd common) $+                 mapFL_FL hopefully to_be_fetched+      let fname = case to_be_fetched of+                    (x:>:_)-> patchFilename $ patchDesc x+          o = fromMaybe stdOut (getOutput opts fname)+      useAbsoluteOrStd writeDocBinFile putDoc o $ bundle  revertable :: IO a -> IO a revertable x =@@ -188,17 +297,18 @@ the second patchset(s) to be complemented against Rc. -} -readRepos :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [String] -> IO (SealedPatchSet p,SealedPatchSet p)+readRepos :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [String]+          -> IO (SealedPatchSet p C(Origin),SealedPatchSet p C(Origin)) readRepos _ _ [] = impossible readRepos to_repo opts us =     do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo u-                            ps <- read_repo r+                            ps <- readRepo r                             return $ seal ps) us        return $ if Intersection `elem` opts-                then (patchset_intersection rs, seal NilRL)+                then (newsetIntersection rs, seal (PatchSet NilRL NilRL))                 else if Complement `elem` opts-                     then (head rs, patchset_union $ tail rs)-                     else (patchset_union rs, seal NilRL)+                     then (head rs, newsetUnion $ tail rs)+                     else (newsetUnion rs, seal (PatchSet NilRL NilRL))  \end{code} @@ -208,7 +318,7 @@  If you provide more than one repository as an argument to pull, darcs' behavior is determined by the presence of the \verb!--complement!,-\verb!--intersection!, and \verb!--union!  flags.  +\verb!--intersection!, and \verb!--union!  flags.  \begin{itemize} 

@@ -33,27 +33,33 @@                          applyas, matchSeveral, fixUrl, depsSel,                          allInteractive, dryRun, nolinks,                          remoteRepo, networkOptions,-                         setDefault, sign, allowUnrelatedRepos+                         setDefault, sign, allowUnrelatedRepos,+                         changesReverse                       )++import Darcs.Flags(doReverse) import Darcs.Hopefully ( PatchInfoAnd, hopefully ) import Darcs.Repository ( Repository, withRepoReadLock, ($-), identifyRepositoryFor,-                          read_repo, amInRepository, checkUnrelatedRepos )+                          readRepo, amInRepository, checkUnrelatedRepos ) import Darcs.Patch ( RepoPatch, description )-import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), RL, FL, nullRL,-                             nullFL, reverseRL, mapFL_FL, mapRL, lengthRL )+import Darcs.Witnesses.Ordered ( (:>)(..), RL, FL, nullRL,+                             nullFL, reverseFL, mapFL_FL, mapRL, (:>>)(..) ) 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.URL ( isUrl, isFile )+import Darcs.SelectChanges ( selectChanges, WhichChanges(..),+                             selectionContext, runSelection ) import Darcs.Utils ( formatPath )-import Darcs.Patch.Depends ( get_common_and_uncommon )-import Darcs.Patch.Bundle ( make_bundle )+import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )+import Darcs.Patch.Bundle ( makeBundleN ) import Darcs.Patch.Patchy( ShowPatch )-import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Set ( PatchSet )+#ifdef GADT_WITNESSES+import Darcs.Patch.Set ( Origin )+#endif import Printer ( Doc, vcat, empty, text, ($$) )-import Darcs.RemoteApply ( remote_apply, apply_as )-import Darcs.Email ( make_email )+import Darcs.RemoteApply ( remoteApply, applyAs )+import Darcs.Email ( makeEmail ) import English (englishNum, Noun(..)) #include "impossible.h" @@ -80,13 +86,14 @@                      commandArgdefaults = defaultrepo,                      commandAdvancedOptions = [applyas,                                                  nolinks,-                                                 remoteRepo] +++                                                 remoteRepo,+                                                 changesReverse] ++                                                 networkOptions,                      commandBasicOptions = [matchSeveral, depsSel,                                               allInteractive,                                               sign]++dryRun++[summary,                                               workingRepoDir,-                                              setDefault,+                                              setDefault False,                                               allowUnrelatedRepos]}  pushCmd :: [DarcsFlag] -> [String] -> IO ()@@ -103,10 +110,10 @@  (bundle) <- withRepoReadLock opts $-                           prepareBundle opts repodir  sbundle <- signString opts bundle- let body = if is_file repodir+ let body = if isFile repodir             then sbundle-            else make_email repodir [] Nothing sbundle Nothing- rval <- remote_apply opts repodir body+            else makeEmail repodir [] Nothing sbundle Nothing+ rval <- remoteApply opts repodir body  case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"                                    exitWith (ExitFailure ec)               ExitSuccess -> putInfo opts $ text "Push successful."@@ -115,26 +122,30 @@ 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 <- getPreflist "defaultrepo"-  setDefaultrepo repodir opts   when (old_default == [repodir]) $        let pushing = if DryRun `elem` opts then "Would push" else "Pushing"        in  putInfo opts $ text $ pushing++" to "++formatPath repodir++"..."-  us <- read_repo repository-  case get_common_and_uncommon (us, them) of-    (common, us' :\/: them') -> do-      prePushChatter opts common us us' them them'-      with_selected_changes "push" opts Nothing (reverseRL us') $ bundlePatches opts common+  them <- identifyRepositoryFor repository repodir >>= readRepo+  setDefaultrepo repodir opts+  us <- readRepo repository+  common :>> us' <- return $ findCommonWithThem us them+  prePushChatter opts us (reverseFL us') them+  let context = selectionContext "push" opts Nothing []+      selector = if doReverse opts+                 then selectChanges FirstReversed+                 else selectChanges First+  runSelection (selector us') context+                   >>= 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 +prePushChatter :: forall p a C(x y t) . (RepoPatch p, ShowPatch a) =>+                 [DarcsFlag] -> PatchSet p C(Origin x) ->+                 RL a C(t x) -> PatchSet p C(Origin y) -> IO ()+prePushChatter opts us us' them = do+  checkUnrelatedRepos opts us them+  let num_to_pull = snd $ countUsThem us them+      pull_reminder = if num_to_pull > 0+                      then text $ "The remote repository has " ++ show num_to_pull                       ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull."                       else empty   putVerbose opts $ text "We have the following patches to push:" $$ (vcat $ mapRL description us')@@ -142,7 +153,7 @@   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]+bundlePatches :: forall t p C(x y z w a). RepoPatch p => [DarcsFlag] -> PatchSet p C(a z)                                           -> (FL (PatchInfoAnd p) :> t) C(z w)                                           -> IO (Doc) bundlePatches opts common (to_be_pushed :> _) =@@ -153,8 +164,7 @@           putInfo opts $             text "You don't want to push any patches, and that's fine with me!"           exitWith ExitSuccess-      bundle <- make_bundle []-                     (bug "using slurpy in make_bundle called from Push")+      bundle <- makeBundleN Nothing                      common (mapFL_FL hopefully to_be_pushed)       return (bundle) @@ -170,8 +180,8 @@  checkOptionsSanity :: [DarcsFlag] -> String -> IO () checkOptionsSanity opts repodir =-  if is_url repodir then do-       when (apply_as opts /= Nothing) $+  if isUrl repodir then do+       when (applyAs opts /= Nothing) $            abortRun opts $ text "Cannot --apply-as when pushing to URLs"        maybeapply <- maybeURLCmd "APPLY" repodir        when (maybeapply == Nothing) $

@@ -15,26 +15,31 @@                         networkOptions, flagToString, getInventoryChoices,                         setScriptsExecutableOption, workingRepoDir, setDefault                       )-import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, read_repo, amInRepository )+import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, readRepo, amInRepository ) import Darcs.Repository.Format ( identifyRepoFormat,                                  RepoProperty ( Darcs2, HashedInventory ), formatHas )-import Darcs.Patch.Bundle ( make_bundle2 )-import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Patch.Bundle ( makeBundle2 )+import Darcs.Patch.Set ( PatchSet )+#ifdef GADT_WITNESSES+import Darcs.Patch.Set ( Origin )+#endif+import Darcs.Witnesses.Ordered ( FL(..), RL(..), nullFL, EqCheck(..), unsafeCoerceP ) import Darcs.Match ( havePatchsetMatch, getOnePatchset ) import Darcs.Repository.Prefs ( getPreflist, setDefaultrepo )-import Darcs.URL ( is_url, is_file )+import Darcs.URL ( isUrl, isFile ) import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import Darcs.External ( execSSH )-import Darcs.RemoteApply ( remote_apply )+import Darcs.RemoteApply ( remoteApply ) import Darcs.Commands.Init ( initialize )-import Darcs.Email ( make_email )+import Darcs.Email ( makeEmail ) import Darcs.Witnesses.Sealed ( Sealed(..), seal ) import Printer ( text ) #include "impossible.h"+#include "gadts.h" -putDescription :: String +putDescription :: String putDescription =  "Makes a copy of the repository" @@ -62,7 +67,7 @@                     commandAdvancedOptions = [applyas] ++ networkOptions,                     commandBasicOptions = [matchOneContext, setScriptsExecutableOption,                                              getInventoryChoices,-                                             setDefault, workingRepoDir]}+                                             setDefault True, workingRepoDir]}  putCmd :: [DarcsFlag] -> [String] -> IO () putCmd _ [""] = fail "Empty repository argument given to put."@@ -76,7 +81,7 @@      req_absolute_repo_dir = toPath t_req_absolute_repo_dir  when (cur_absolute_repo_dir == req_absolute_repo_dir) $        fail "Can't put to current repository!"- when (is_url req_absolute_repo_dir) $ error "Can't put to a URL!"+ when (isUrl req_absolute_repo_dir) $ error "Can't put to a URL!"   debugMessage "Creating repository"  putVerbose opts $ text "Creating repository"@@ -89,37 +94,35 @@                         not (UseOldFashionedInventory `elem` opts)                      then UseHashedInventory:filter (/= UseFormat2) opts                      else UseOldFashionedInventory:filter (/= UseFormat2) opts- if is_file req_absolute_repo_dir+ if isFile req_absolute_repo_dir      then do createDirectory req_absolute_repo_dir              withCurrentDirectory req_absolute_repo_dir $ (commandCommand initialize) initopts []-     else do -- is_ssh req_absolute_repo_dir+     else do -- isSsh req_absolute_repo_dir              remoteInit req_absolute_repo_dir initopts   withCurrentDirectory cur_absolute_repo_dir $-                      withRepoReadLock opts $- \repository -> do+                      withRepoReadLock opts $- \repository -> (do   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 havePatchsetMatch opts-                      then getOnePatchset repository opts  -- todo: make sure getOnePatchset has the right type-                      else read_repo repository >>= (return . seal)+  let doRead = if havePatchsetMatch opts+               then getOnePatchset repository opts  -- todo: make sure getOnePatchset has the right type+               else readRepo repository >>= (return . seal)+  Sealed (patchset :: PatchSet p C(Origin x1)) <- doRead+  Sealed (patchset2 :: PatchSet p C(Origin x2)) <- doRead+  IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck C(x1 x2))   let patches = patchSetToPatches patchset       patches2 = patchSetToPatches patchset2-      nullFL NilFL = True-      nullFL _ = False   when (nullFL patches) $ do           putInfo opts $ text "No patches were selected to put. Nothing to be done."           exitWith ExitSuccess-  bundle <- make_bundle2 opts emptyTree [] patches patches2-  let message = if is_file req_absolute_repo_dir+  bundle <- makeBundle2 Nothing NilRL patches patches2+  let message = if isFile req_absolute_repo_dir                 then bundle-                else make_email req_absolute_repo_dir [] Nothing bundle Nothing+                else makeEmail req_absolute_repo_dir [] Nothing bundle Nothing   putVerbose opts $ text "Applying patches in new repository..."-  rval <- remote_apply opts req_absolute_repo_dir message+  rval <- remoteApply opts req_absolute_repo_dir message   case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"                                     exitWith (ExitFailure ec)-               ExitSuccess -> putInfo opts $ text "Put successful."+               ExitSuccess -> putInfo opts $ text "Put successful.") :: IO () putCmd _ _ = impossible  remoteInit :: FilePath -> [DarcsFlag] -> IO ()@@ -127,7 +130,7 @@     let args = catMaybes $ map (flagToString $ commandBasicOptions initialize) opts         command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords args     exitCode <- execSSH addr command-    when (exitCode /= ExitSuccess) $ +    when (exitCode /= ExitSuccess) $          fail "Couldn't initialize remote repository."   where (addr,':':path) = break (==':') repo \end{code}

@@ -19,58 +19,65 @@ \begin{code} {-# LANGUAGE CPP, PatternGuards #-} -module Darcs.Commands.Record ( record, commit, getDate, getLog, fileExists ) where+module Darcs.Commands.Record ( record, commit, getDate, getLog,+                               askAboutDepends+                             ) where import qualified Ratified( hGetContents )-import Control.Exception ( handleJust, Exception( ExitException ) )-import Control.Monad ( filterM, when )+import Control.Exception.Extensible ( handleJust )+import Control.Monad ( when ) import System.IO ( stdin )-import Data.List ( sort, isPrefixOf )+import Data.List ( sort, isPrefixOf, union )+import Data.Char ( ord ) import System.Exit ( exitWith, exitFailure, ExitCode(..) )-import System.IO ( hPutStrLn )-import System.Directory ( doesFileExist, doesDirectoryExist, removeFile )-import Data.Maybe ( isJust )+import System.Directory ( removeFile )+import Data.Maybe ( isJust, catMaybes )+import qualified Data.ByteString as B ( hPut ) -import Darcs.Lock ( readBinFile, writeBinFile, world_readable_temp, appendToFile )-import Darcs.Hopefully ( info, n2pia )+import Darcs.Lock ( readLocaleFile, writeLocaleFile, worldReadableTemp, appendToFile )+import Darcs.Hopefully ( info, n2pia, PatchInfoAnd ) import Darcs.Repository ( Repository, amInRepository, withRepoLock, ($-),                           withGutsOf,-                    read_repo,-                    slurp_recorded,+                    readTentativeRepo,                     tentativelyAddPatch, finalizeRepositoryChanges                         , invalidateIndex, unrecordedChanges ) import Darcs.Patch ( RepoPatch, Patch, Prim, namepatch, summary, anonymous,                      adddeps, fromPrims )+import Darcs.Patch.Set ( PatchSet(..) ) import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+),-                             unsafeUnFL, unsafeCompare,+                             unsafeCompare,                              reverseRL, mapFL, mapFL_FL, nullFL )+import Darcs.Witnesses.Sealed import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Split ( primSplitter )-import Darcs.SlurpDirectory ( slurp_hasfile, slurp_hasdir ) 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 )+                             forceFirsts, getChoices, tag )+import Darcs.SelectChanges ( selectChanges, WhichChanges(..),+                             selectionContext, selectionContextPrim,+                             runSelection+                           )+import Darcs.RepoPath ( FilePathLike, SubPath, toFilePath ) import Darcs.Commands ( DarcsCommand(..), nodefaults, commandStub )+import Darcs.Commands.WhatsNew ( announceFiles ) import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment,                                     EditLongComment, LogFile, Pipe,                                     PatchName, AskDeps, All ),                          fileHelpAuthor,                          getAuthor, workingRepoDir, lookforadds,-                         fixSubPaths, defineChanges, testByDefault,+                         fixSubPaths, defineChanges,                          askLongComment, askdeps, patchSelectFlag,-                         allPipeInteractive, leaveTestDir, notest,+                         allPipeInteractive, leaveTestDir, test,                          author, patchnameOption, umaskOption, ignoretimes,                          nocompress, rmlogfile, logfile, listRegisteredFiles,                          setScriptsExecutableOption ) import Darcs.Flags (willRemoveLogFile)-import Darcs.Utils ( askUser, promptYorn, edit_file, clarifyErrors )+import Darcs.Utils ( askUser, promptYorn, editFile, clarifyErrors ) import Progress ( debugMessage) import Darcs.ProgressPatches( progressFL) import IsoDate ( getIsoDateTime, cleanLocalDate )-import Printer ( hPutDocLn, text, wrap_text, ($$) )+import Printer ( hPutDocLn, text, wrapText, ($$) )+import ByteStringUtils ( encodeLocale ) #include "impossible.h"+#include "gadts.h"  recordDescription :: String recordDescription = "Create a patch from unrecorded changes."@@ -98,7 +105,7 @@                                                    umaskOption,                                                    setScriptsExecutableOption],                        commandBasicOptions = [patchnameOption, author,-                                               notest,+                                               test,                                                leaveTestDir,                                                allPipeInteractive,                                                askdeps,@@ -119,41 +126,24 @@ commit :: DarcsCommand commit = commandStub "commit" commitHelp commitDescription record -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- 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+    withRepoLock opts $- \repository -> do     files <- sort `fmap` fixSubPaths opts args-    let non_repo_files = if null files && (not $ null args) then args else []-    existing_files <- filterM (fileExists rec) files-    non_existent_files <- filterM (fmap not . fileExists rec) files-    when (not $ null existing_files) $-         putStrLn $ "Recording changes in "++unwords (map show existing_files)++":\n"-    when (not $ null non_existent_files) $-         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!"+    existing_files <- announceFiles repository files "Recording changes in"+    when (null existing_files && (not $ null files)) $+       fail "None of the files you specified exist!"     debugMessage "About to get the unrecorded changes."     changes <- unrecordedChanges opts repository files     debugMessage "I've gotten unrecorded."     case allow_empty_with_askdeps changes of       Nothing -> do when (Pipe `elem` opts) $ do getDate opts                                                  return ()-                    if ((not $ null existing_files) || (not $ null non_existent_files))-                       then putStrLn "No changes in selected files or directories!"-                       else putStrLn "No changes!"+                    putStrLn "No changes!"       Just ch -> doRecord repository opts existing_files ch-    where allow_empty_with_askdeps NilFL+    where allow_empty_with_askdeps :: FL p C(x y) -> Maybe (FL p C(x y))+          allow_empty_with_askdeps NilFL               | AskDeps `elem` opts = Just NilFL               | otherwise = Nothing           allow_empty_with_askdeps p = Just p@@ -170,7 +160,7 @@             then do                 let keepAsking = do                     yorn <- promptYorn ("You specified " ++ show n ++ " as the patch name. Is that really what you want?")-                    case yorn of +                    case yorn of                         'y' -> return ()                         'n' -> do                                    putStrLn "Okay, aborting the record."@@ -180,27 +170,29 @@             else return ()  -doRecord :: RepoPatch p => Repository p -> [DarcsFlag] -> [SubPath] -> FL Prim -> IO ()+doRecord :: RepoPatch p => Repository p C(r u r) -> [DarcsFlag] -> [SubPath] -> FL Prim C(r x) -> IO () doRecord repository opts files ps = do-    let make_log = world_readable_temp "darcs-record"+    let make_log = worldReadableTemp "darcs-record"     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 (Just primSplitter)-      (map toFilePath files) ps $ \ (chs:>_) ->-      do when (is_empty_but_not_askdeps chs) $+    (chs :> _ ) <- runSelection (selectChanges First ps) $+                  selectionContextPrim "record" opts (Just primSplitter)+                                       (map toFilePath files)+    when (is_empty_but_not_askdeps chs) $               do putStrLn "Ok, if you don't want to record anything, that's fine!"                  exitWith ExitSuccess-         handleJust onlySuccessfulExits (\_ -> return ()) $+    handleJust onlySuccessfulExits (\_ -> return ()) $              do deps <- if AskDeps `elem` opts-                        then askAboutDepends 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) <- getLog opts Nothing make_log chs+                          debugMessage ("Patch name as received from getLog: " ++ show (map ord name))                           doActualRecord repository opts name date                                  my_author my_log logf deps chs     where is_empty_but_not_askdeps l@@ -208,9 +200,9 @@                                       -- a "partial tag" patch; see below.               | otherwise = nullFL l -doActualRecord :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> String -> String+doActualRecord :: RepoPatch p => Repository p C(r u r) -> [DarcsFlag] -> String -> String -> String                  -> [String] -> Maybe String-                 -> [PatchInfo] -> FL Prim -> IO ()+                 -> [PatchInfo] -> FL Prim C(r x) -> IO () 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 $@@ -257,12 +249,12 @@  data PName = FlagPatchName String | PriorPatchName String | NoPatchName -getLog :: [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL Prim ->+getLog :: FORALL(x y) [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL Prim C(x y) ->            IO (String, [String], Maybe String) 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+          patchname_helper (PatchName n:_) | "TAG " `isPrefixOf` n = FlagPatchName $ '.':n+                                           | otherwise             = FlagPatchName n           patchname_helper (_:fs) = patchname_helper fs           patchname_helper [] = case m_old of Just (p,_) -> PriorPatchName p                                               Nothing    -> NoPatchName@@ -278,7 +270,7 @@                            return (p, thelog, Nothing)           gl (LogFile f:fs) =               do -- round 1 (patchname)-                 mlp <- lines `fmap` readBinFile f `catch` (\_ -> return [])+                 mlp <- lines `fmap` readLocaleFile f `catch` (\_ -> return [])                  firstname <- case (patchname_specified, mlp) of                                 (FlagPatchName  p, []) -> return p                                 (_, p:_)               -> return p -- logfile trumps prior!@@ -286,7 +278,7 @@                                 (NoPatchName, [])      -> prompt_patchname True                  -- round 2                  append_info f firstname-                 when (EditLongComment `elem` fs) $ do edit_file f+                 when (EditLongComment `elem` fs) $ do editFile f                                                        return ()                  (name, thelog, _) <- read_long_comment f firstname                  let toRemove = if willRemoveLogFile opts@@ -319,7 +311,7 @@                     NoPatchName -> prompt_patchname True >>= prompt_long_comment           prompt_patchname retry =             do n <- askUser "What is the patch name? "-               if n == "" || take 4 n == "TAG "+               if n == "" || "TAG " `isPrefixOf` n                   then if retry then prompt_patchname retry                                 else fail "Bad patch name!"                   else return n@@ -328,27 +320,29 @@                if yorn == 'y' then actually_get_log oldname                               else return (oldname, [], Nothing)           actually_get_log p = do logf <- make_log-                                  writeBinFile logf $ unlines $ p : default_log+                                  -- TODO: make sure encoding used for logf is the same everywhere+                                  -- probably should be locale because the editor will assume it+                                  writeLocaleFile logf $ unlines $ p : default_log                                   append_info logf p-                                  edit_file logf+                                  editFile logf                                   read_long_comment logf p           read_long_comment :: FilePathLike p => p -> String -> IO (String, [String], Maybe p)           read_long_comment f oldname =-              do t <- (lines.filter (/='\r')) `fmap` readBinFile f+              do t <- (lines.filter (/='\r')) `fmap` readLocaleFile f                  case t of [] -> return (oldname, [], Just f)                            (n:ls) -> return (n, takeWhile                                              (not.(eod `isPrefixOf`)) ls,                                              Just f)           append_info f oldname =-              do fc <- readBinFile f+              do fc <- readLocaleFile f                  appendToFile f $ \h ->                      do case fc of-                          _ | null (lines fc) -> hPutStrLn h oldname-                            | last fc /= '\n' -> hPutStrLn h ""+                          _ | null (lines fc) -> B.hPut h (encodeLocale (oldname ++ "\n"))+                            | last fc /= '\n' -> B.hPut h (encodeLocale "\n")                             | otherwise       -> return ()                         hPutDocLn h $ text eod                             $$ text ""-                            $$ wrap_text 75+                            $$ wrapText 75                                ("Place the long patch description above the "++                                 eod++                                 " marker.  The first line of this file "++@@ -356,7 +350,7 @@                             $$ text ""                             $$ text "This patch contains the following changes:"                             $$ text ""-                            $$ summary (fromPrims chs :: Patch)+                            $$ summary (fromPrims chs :: Patch C(x y))  eod :: String eod = "***END OF DESCRIPTION***"@@ -388,27 +382,33 @@ depended-upon patches.  \begin{code}-askAboutDepends :: RepoPatch p => Repository p -> FL Prim -> [DarcsFlag] -> IO [PatchInfo]-askAboutDepends repository pa' opts = do-  pps <- read_repo repository+askAboutDepends :: forall p C(r u t x y) . RepoPatch p => Repository p C(r u t) -> FL Prim C(t y) -> [DarcsFlag] -> [PatchInfo] -> IO [PatchInfo]+askAboutDepends repository pa' opts olddeps = do+  -- ideally we'd just default the olddeps to yes but still ask about them.+  -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would+  -- have to have this support added first.+  pps <- readTentativeRepo repository   pa <- n2pia `fmap` anonymous (fromPrims pa')-  let ps = (reverseRL $ headRL pps)+>+(pa:>:NilFL)-      (pc, tps) = patchChoicesTps ps-      ta = case filter ((pa `unsafeCompare`) . tpPatch) $ unsafeUnFL tps of-                [tp] -> tag tp+  FlippedSeal ps <- return+                      ((case pps of+                          PatchSet x _ -> FlippedSeal ((reverseRL x)+>+(pa:>:NilFL))+                          PatchSet NilRL NilRL -> impossible) :: FlippedSeal (FL (PatchInfoAnd p)) C(y))+  let (pc, tps) = patchChoicesTps ps+      tas = case catMaybes (mapFL (\tp -> if pa `unsafeCompare` (tpPatch tp) || info (tpPatch tp) `elem` olddeps+                                          then Just (tag tp) else Nothing) tps) of+                 [] -> 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+                tgs -> tgs+  Sealed2 ps' <- return $ case getChoices (forceFirsts tas pc) of _ :> mc :> _ -> Sealed2 $ mapFL_FL tpPatch mc+  (deps:>_) <- runSelection (selectChanges FirstReversed ps') $+                                        selectionContext "depend on" (filter askdep_allowed opts) Nothing []+  return $ olddeps `union` mapFL info deps+ where        askdep_allowed = not . patchSelectFlag-       middle_choice p = mc where (_ :> mc :> _) = getChoices p  -onlySuccessfulExits :: Exception -> Maybe ()-onlySuccessfulExits (ExitException ExitSuccess) = Just ()+onlySuccessfulExits :: ExitCode -> Maybe ()+onlySuccessfulExits ExitSuccess = Just () onlySuccessfulExits _ = Nothing  recordHelp'' :: String