diff -ruN darcs-2.4.4/debian/changelog darcs-2.5/debian/changelog --- darcs-2.4.4/debian/changelog 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/debian/changelog 2010-10-24 08:29:26.000000000 -0700 @@ -1,3 +1,9 @@ +darcs (2.5-0) unstable; urgency=low + + * Apply 2.4.4 -> 2.5 patch. + + -- David Fox Thu, 30 Dec 2010 06:38:05 -0800 + darcs (2.4.4-3) unstable; urgency=low [ Joachim Breitner ] diff -ruN darcs-2.4.4/contrib/darcs-errors.hlint darcs-2.5/contrib/darcs-errors.hlint --- darcs-2.4.4/contrib/darcs-errors.hlint 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/contrib/darcs-errors.hlint 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/contrib/update_roundup.pl darcs-2.5/contrib/update_roundup.pl --- darcs-2.4.4/contrib/update_roundup.pl 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/contrib/update_roundup.pl 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/darcs.cabal darcs-2.5/darcs.cabal --- darcs-2.4.4/darcs.cabal 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/darcs.cabal 2010-10-24 08:29:26.000000000 -0700 @@ -1,5 +1,5 @@ Name: darcs -version: 2.4.4 +version: 2.5 License: GPL License-file: COPYING Author: David Roundy , @@ -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. @@ -121,40 +121,77 @@ 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 - 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 + else + buildable: True + + 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 @@ -166,184 +203,190 @@ else buildable: False - hs-source-dirs: src - include-dirs: src - - 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 - - other-modules: Version - - 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 !flag(library) + 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 - build-depends: unix-compat >= 0.1.2 + hs-source-dirs: src + include-dirs: src - if os(solaris) - cc-options: -DHAVE_SIGINFO_H + 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 + + other-modules: Version + + 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(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(windows) - build-depends: unix >= 1.0 && < 2.5 + if os(solaris) + cc-options: -DHAVE_SIGINFO_H - build-depends: base >= 3, - bytestring >= 0.9.0 && < 0.10, - utf8-string == 0.3.*, + 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.* + + 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,70 +387,71 @@ 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 - - if flag(hpc) - ghc-prof-options: -fhpc - - 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-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 - cpp-options: -DHAVE_HTTP - x-have-http: - - if (!flag(curl) && !flag(http)) || flag(deps-only) - buildable: False - - if flag(mmap) && !os(windows) - build-depends: mmap >= 0.2 && < 0.5 - cpp-options: -DHAVE_MMAP - - 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 - - if flag(color) - x-use-color: - - extensions: - CPP, - ForeignFunctionInterface, - BangPatterns, - PatternGuards, - MagicHash, - UndecidableInstances, - DeriveDataTypeable, - GADTs, - ImpredicativeTypes, - TypeOperators, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - ScopedTypeVariables, - KindSignatures, - TypeSynonymInstances, - Rank2Types, - RankNTypes, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses + -- 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 impl(ghc>=6.12) + ghc-options: -fno-warn-unused-do-bind + + ghc-prof-options: -prof -auto-all + + if flag(hpc) + ghc-prof-options: -fhpc + + 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(http) + build-depends: network == 2.2.*, + HTTP >= 3000.0 && < 4000.1 + cpp-options: -DHAVE_HTTP + x-have-http: + + if (!flag(curl) && !flag(http)) || flag(deps-only) + buildable: False + + 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 + + -- 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: + + 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 - - 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 - - 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, + 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 + + -- 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 impl(ghc>=6.12) + ghc-options: -fno-warn-unused-do-bind + + ghc-prof-options: -prof -auto-all + if flag(threaded) + ghc-options: -threaded + + 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 - - 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 - - if flag(color) - x-use-color: - - extensions: - CPP, - ForeignFunctionInterface, - BangPatterns, - PatternGuards, - MagicHash, - UndecidableInstances, - DeriveDataTypeable, - GADTs, - TypeOperators, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - ScopedTypeVariables, - KindSignatures, - TypeSynonymInstances, - Rank2Types, - RankNTypes, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses - OverlappingInstances + 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 + + -- The terminfo package cannot be built on Windows. + if flag(terminfo) && !os(windows) + build-depends: terminfo == 0.3.* + cpp-options: -DHAVE_TERMINFO + + if flag(http) + build-depends: network == 2.2.*, + HTTP >= 3000.0 && < 4000.1 + + 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 diff -ruN darcs-2.4.4/Distribution/ShellHarness.hs darcs-2.5/Distribution/ShellHarness.hs --- darcs-2.4.4/Distribution/ShellHarness.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/Distribution/ShellHarness.hs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/doc/darcs.css darcs-2.5/doc/darcs.css --- darcs-2.4.4/doc/darcs.css 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/doc/darcs.css 2010-10-24 08:29:26.000000000 -0700 @@ -28,6 +28,10 @@ height: 50px; } +BLOCKQUOTE.testimonial { + font-style: italic; +} + PRE { background: #eeeeee; border: 1px solid #888888; diff -ruN darcs-2.4.4/NEWS darcs-2.5/NEWS --- darcs-2.4.4/NEWS 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/NEWS 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/README darcs-2.5/README --- darcs-2.4.4/README 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/README 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/release/distributed-context darcs-2.5/release/distributed-context --- darcs-2.4.4/release/distributed-context 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/release/distributed-context 2010-10-24 08:29:26.000000000 -0700 @@ -1 +1 @@ -Just "\nContext:\n\n[TAG 2.4.4\nEric Kow **20100515090819\n Ignore-this: 7d1a0e6a17c2be314f6ab1607bbcac13\n] \n" \ No newline at end of file +Just "\nContext:\n\n[TAG 2.5\nReinier Lamers **20101024151805\n Ignore-this: 1561ce30bfb1950a440c03371e0e2f20\n] \n" \ No newline at end of file diff -ruN darcs-2.4.4/Setup.lhs darcs-2.5/Setup.lhs --- darcs-2.4.4/Setup.lhs 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/Setup.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/src/building_darcs.tex darcs-2.5/src/building_darcs.tex --- darcs-2.4.4/src/building_darcs.tex 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/building_darcs.tex 2010-10-24 08:29:26.000000000 -0700 @@ -24,7 +24,7 @@ This will require the following build dependencies: \begin{itemize} -\item GHC 6.8 or higher; and +\item GHC 6.10 or higher; and \item Cabal 1.6 or higher. \end{itemize} @@ -70,7 +70,7 @@ \item http 3000 or 3001.1; \item network 2.2; \item terminfo 0.3. - \item utf8-string 0.3; and + \item text 0.3; and \item zlib 0.5. \end{itemize} \end{itemize} diff -ruN darcs-2.4.4/src/ByteStringUtils.hs darcs-2.5/src/ByteStringUtils.hs --- darcs-2.4.4/src/ByteStringUtils.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/ByteStringUtils.hs 2010-10-24 08:29:26.000000000 -0700 @@ -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 + diff -ruN darcs-2.4.4/src/CommandLine.hs darcs-2.5/src/CommandLine.hs --- darcs-2.4.4/src/CommandLine.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/CommandLine.hs 2010-10-24 08:29:26.000000000 -0700 @@ -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'] ++ "!'()*-.~" diff -ruN darcs-2.4.4/src/Darcs/ArgumentDefaults.lhs darcs-2.5/src/Darcs/ArgumentDefaults.lhs --- darcs-2.4.4/src/Darcs/ArgumentDefaults.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/ArgumentDefaults.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/src/Darcs/Arguments.lhs darcs-2.5/src/Darcs/Arguments.lhs --- darcs-2.4.4/src/Darcs/Arguments.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Arguments.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 )? " @@ -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 "" $$ - vcat (mapFL (to_xml . info) ps) $$ + vcat (mapFL (toXml . info) ps) $$ text "") 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]") - -remote_darcs :: DarcsOption -remote_darcs = DarcsArgOption [] ["remote-darcs"] RemoteDarcs "COMMAND" + [ 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 ] + +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" diff -ruN darcs-2.4.4/src/Darcs/CheckFileSystem.hs darcs-2.5/src/Darcs/CheckFileSystem.hs --- darcs-2.4.4/src/Darcs/CheckFileSystem.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/CheckFileSystem.hs 1969-12-31 16:00:00.000000000 -0800 @@ -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 - - diff -ruN darcs-2.4.4/src/Darcs/ColorPrinter.hs darcs-2.5/src/Darcs/ColorPrinter.hs --- darcs-2.4.4/src/Darcs/ColorPrinter.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/ColorPrinter.hs 2010-10-24 08:29:26.000000000 -0700 @@ -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 = "" -- 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 - -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 +-- memoized version of makeColor' +makeColor Blue = makeColor' Blue +makeColor Red = makeColor' Red +makeColor Green = makeColor' Green +makeColor Cyan = makeColor' Cyan +makeColor Magenta = makeColor' 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" diff -ruN darcs-2.4.4/src/Darcs/Commands/Add.lhs darcs-2.5/src/Darcs/Commands/Add.lhs --- darcs-2.4.4/src/Darcs/Commands/Add.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Add.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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} diff -ruN darcs-2.4.4/src/Darcs/Commands/AmendRecord.lhs darcs-2.5/src/Darcs/Commands/AmendRecord.lhs --- darcs-2.4.4/src/Darcs/Commands/AmendRecord.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/AmendRecord.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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,62 +115,78 @@ 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 - -addChangesToPatch :: forall t p . (RepoPatch p) => [DarcsFlag] -> Repository p -> PatchInfoAnd p - -> (FL Prim :> t) -> IO () -addChangesToPatch opts repository oldp (chs:>_) = + _ -> 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 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 - -updatePatchHeader :: forall p. (RepoPatch p) => [DarcsFlag] -> PatchInfoAnd p -> FL Prim - -> IO (Maybe String, PatchInfoAnd p) -updatePatchHeader opts oldp chs = do + finalizeRepositoryChanges repository'' `clarifyErrors` failmsg + maybe (return ()) removeFile mlogf + putStrLn "Finished amending patch:" + putDocLn $ description newp + +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 @@ -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} diff -ruN darcs-2.4.4/src/Darcs/Commands/Annotate.lhs darcs-2.5/src/Darcs/Commands/Annotate.lhs --- darcs-2.4.4/src/Darcs/Commands/Annotate.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Annotate.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 "" - $$ to_xml pinfo + $$ toXml pinfo $$ text "" --removed_by_xml :: PatchInfo -> String ---removed_by_xml pinfo = "\n"++to_xml pinfo++"\n" +--removed_by_xml pinfo = "\n"++toXml pinfo++"\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 "" $$ 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 "" @@ -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 "" $$ text "" - $$ to_xml wheni + $$ toXml wheni $$ text "" $$ escapeXML (BC.unpack l) $$ text "" @@ -350,7 +358,7 @@ $$ text "" | wheni `elem` old_pis = putDocLn $ text "" $$ text "" - $$ to_xml wheni + $$ toXml wheni $$ text "" $$ escapeXML (BC.unpack l) $$ text "" @@ -359,24 +367,24 @@ | whenadd == pinfo = putDocLn $ text "" $$ text "" - $$ to_xml whenrem + $$ toXml whenrem $$ text "" $$ escapeXML (BC.unpack l) $$ text "" | whenrem == pinfo = putDocLn $ text "" $$ text "" - $$ to_xml whenadd + $$ toXml whenadd $$ text "" $$ escapeXML (BC.unpack l) $$ text "" | whenadd `elem` old_pis && not (whenrem `elem` old_pis) = putDocLn $ text "" $$ text "" - $$ to_xml whenrem + $$ toXml whenrem $$ text "" $$ text "" - $$ to_xml whenadd + $$ toXml whenadd $$ text "" $$ escapeXML (BC.unpack l) $$ text "" @@ -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} diff -ruN darcs-2.4.4/src/Darcs/Commands/Apply.lhs darcs-2.5/src/Darcs/Commands/Apply.lhs --- darcs-2.4.4/src/Darcs/Commands/Apply.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Apply.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 @@ -350,9 +359,6 @@ 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 $ "The following patch was either unsigned, or signed by a non-allowed\n"++ diff -ruN darcs-2.4.4/src/Darcs/Commands/Changes.lhs darcs-2.5/src/Darcs/Commands/Changes.lhs --- darcs-2.4.4/src/Darcs/Commands/Changes.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Changes.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 "" @@ -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 diff -ruN darcs-2.4.4/src/Darcs/Commands/Check.lhs darcs-2.5/src/Darcs/Commands/Check.lhs --- darcs-2.4.4/src/Darcs/Commands/Check.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Check.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/src/Darcs/Commands/Convert.lhs darcs-2.5/src/Darcs/Commands/Convert.lhs --- darcs-2.4.4/src/Darcs/Commands/Convert.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Convert.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -34,40 +34,45 @@ 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} diff -ruN darcs-2.4.4/src/Darcs/Commands/Diff.lhs darcs-2.5/src/Darcs/Commands/Diff.lhs --- darcs-2.4.4/src/Darcs/Commands/Diff.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Diff.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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} diff -ruN darcs-2.4.4/src/Darcs/Commands/Dist.lhs darcs-2.5/src/Darcs/Commands/Dist.lhs --- darcs-2.4.4/src/Darcs/Commands/Dist.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Dist.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 (formerdirdistname++".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 diff -ruN darcs-2.4.4/src/Darcs/Commands/Get.lhs darcs-2.5/src/Darcs/Commands/Get.lhs --- darcs-2.4.4/src/Darcs/Commands/Get.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Get.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/src/Darcs/Commands/MarkConflicts.lhs darcs-2.5/src/Darcs/Commands/MarkConflicts.lhs --- darcs-2.4.4/src/Darcs/Commands/MarkConflicts.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/MarkConflicts.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/src/Darcs/Commands/Move.lhs darcs-2.5/src/Darcs/Commands/Move.lhs --- darcs-2.4.4/src/Darcs/Commands/Move.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Move.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/src/Darcs/Commands/Optimize.lhs darcs-2.5/src/Darcs/Commands/Optimize.lhs --- darcs-2.4.4/src/Darcs/Commands/Optimize.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Optimize.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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} diff -ruN darcs-2.4.4/src/Darcs/Commands/Pull.lhs darcs-2.5/src/Darcs/Commands/Pull.lhs --- darcs-2.4.4/src/Darcs/Commands/Pull.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Pull.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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} diff -ruN darcs-2.4.4/src/Darcs/Commands/Push.lhs darcs-2.5/src/Darcs/Commands/Push.lhs --- darcs-2.4.4/src/Darcs/Commands/Push.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Push.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 - -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 + 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) . (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) $ diff -ruN darcs-2.4.4/src/Darcs/Commands/Put.lhs darcs-2.5/src/Darcs/Commands/Put.lhs --- darcs-2.4.4/src/Darcs/Commands/Put.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Put.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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} diff -ruN darcs-2.4.4/src/Darcs/Commands/Record.lhs darcs-2.5/src/Darcs/Commands/Record.lhs --- darcs-2.4.4/src/Darcs/Commands/Record.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Record.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/src/Darcs/Commands/Remove.lhs darcs-2.5/src/Darcs/Commands/Remove.lhs --- darcs-2.4.4/src/Darcs/Commands/Remove.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Remove.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -22,8 +22,7 @@ module Darcs.Commands.Remove ( remove, rm, unadd ) where -import Control.Monad ( when ) -import Data.Maybe ( isJust ) +import Control.Monad ( when, foldM ) import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, commandStub, putWarning @@ -31,19 +30,19 @@ import Darcs.Arguments ( DarcsFlag (Recursive), fixSubPaths, listRegisteredFiles, workingRepoDir, umaskOption, - recursive + recursive ) import Darcs.RepoPath ( SubPath, sp2fn ) import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository, - add_to_pending, readRecordedAndPending, readUnrecorded ) + addToPending, readRecordedAndPending, readUnrecorded ) import Darcs.Diff( treeDiff ) import Darcs.Patch ( RepoPatch, Prim, adddir, rmdir, addfile, rmfile ) import Darcs.Patch.FileName( fn2fp ) import Darcs.Witnesses.Ordered ( FL(..), (+>+) ) -import Darcs.Witnesses.Sealed ( Sealed(..) ) -import Darcs.Repository.Prefs ( filetypeFunction ) -import Storage.Hashed.Tree( TreeItem(..), find, modifyTree, expand, list ) -import Storage.Hashed.AnchoredPath( anchorPath ) +import Darcs.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft ) +import Darcs.Repository.Prefs ( filetypeFunction, FileType ) +import Storage.Hashed.Tree( Tree, TreeItem(..), find, modifyTree, expand, list ) +import Storage.Hashed.AnchoredPath( anchorPath, AnchoredPath ) import Storage.Hashed( floatPath ) import Darcs.Commands.Add( expandDirs ) @@ -89,51 +88,62 @@ when (null args) $ putStrLn "Nothing specified, nothing removed." Sealed p <- makeRemovePatch opts repository args - add_to_pending repository p + addToPending repository p +-- | makeRemovePatch builds a list of patches to remove the given filepaths. +-- This function does not recursively process directories. The 'Recursive' +-- flag should be handled by the caller by adding all offspring of a directory +-- to the files list. makeRemovePatch :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> [SubPath] -> IO (Sealed (FL Prim C(u))) makeRemovePatch opts repository files = do recorded <- expand =<< readRecordedAndPending repository - unrecorded <- readUnrecorded repository + unrecorded <- readUnrecorded repository files ftf <- filetypeFunction - mrp ftf recorded unrecorded $ map (floatPath . fn2fp . sp2fn) files - where mrp ftf recorded unrecorded (f:fs) = do + result <- foldM removeOnePath (ftf,recorded,unrecorded, []) $ map (floatPath . fn2fp . sp2fn) files + case result of + (_, _, _, patches) -> return $ + unFreeLeft $ foldr (joinGap (+>+)) (emptyGap NilFL) $ reverse patches + where removeOnePath (ftf, recorded, unrecorded, patches) f = do let recorded' = modifyTree recorded f Nothing unrecorded' = modifyTree unrecorded f Nothing - f_fp = anchorPath "" f - skipAndWarn reason = - do putWarning opts . text $ "Can't remove " ++ f_fp - ++ " (" ++ reason ++ ")" - return $ Nothing - - local <- case (find recorded f, find unrecorded f) of - (Just (SubTree _), Just (SubTree unrecordedChildren)) -> do - if not $ null (list unrecordedChildren) - then skipAndWarn "it is not empty" - else return $ Just (rmdir f_fp :>: NilFL) - (Just (File _), Just (File _)) -> - Just `fmap` treeDiff ftf unrecorded unrecorded' - (Just (File _), _) -> - return $ Just (addfile f_fp :>: rmfile f_fp :>: NilFL) - (Just (SubTree _), _) -> - return $ Just (adddir f_fp :>: rmdir f_fp :>: NilFL) - (_, _) -> skipAndWarn "it is not tracked by darcs" - - -- we can tell if the remove succeeded by looking if local is - -- empty. If the remove succeeded, we should pass on updated - -- recorded and unrecorded that reflect the removal - let nextRecorded | isJust local = recorded' - | otherwise = recorded - nextUnrecorded | isJust local = unrecorded' - | otherwise = unrecorded - - Sealed rest <- mrp ftf nextRecorded nextUnrecorded fs - return . Sealed $ case local of - Just localFL -> (localFL +>+ rest) - Nothing -> rest + local <- makeRemoveGap opts ftf recorded unrecorded unrecorded' f + -- we can tell if the remove succeeded by looking if local is + -- empty. If the remove succeeded, we should pass on updated + -- recorded and unrecorded that reflect the removal + return $ case local of + Just gap -> (ftf, recorded', unrecorded', gap : patches) + _ -> (ftf, recorded, unrecorded, patches) + +-- | Takes a file path and returns the FL of patches to remove that, wrapped in +-- a 'Gap'. +-- Returns 'Nothing' in case the path cannot be removed (if it is not tracked, +-- or if it's a directory and it's not tracked). +-- The three 'Tree' arguments are the recorded state, the unrecorded state +-- excluding the removal of this file, and the unrecorded state including the +-- removal of this file. +makeRemoveGap :: [DarcsFlag] -> (FilePath -> FileType) + -> Tree IO -> Tree IO -> Tree IO -> AnchoredPath + -> IO (Maybe (FreeLeft (FL Prim))) +makeRemoveGap opts ftf recorded unrecorded unrecorded' f = + case (find recorded f, find unrecorded f) of + (Just (SubTree _), Just (SubTree unrecordedChildren)) -> do + if not $ null (list unrecordedChildren) + then skipAndWarn "it is not empty" + else return $ Just $ freeGap (rmdir f_fp :>: NilFL) + (Just (File _), Just (File _)) -> + Just `fmap` treeDiff ftf unrecorded unrecorded' + (Just (File _), _) -> + return $ Just $ freeGap (addfile f_fp :>: rmfile f_fp :>: NilFL) + (Just (SubTree _), _) -> + return $ Just $ freeGap (adddir f_fp :>: rmdir f_fp :>: NilFL) + (_, _) -> skipAndWarn "it is not tracked by darcs" + where f_fp = anchorPath "" f + skipAndWarn reason = + do putWarning opts . text $ "Can't remove " ++ f_fp + ++ " (" ++ reason ++ ")" + return $ Nothing - mrp _ _ _ [] = return (Sealed NilFL) rmDescription :: String rmDescription = "Help newbies find `darcs remove'." diff -ruN darcs-2.4.4/src/Darcs/Commands/Repair.lhs darcs-2.5/src/Darcs/Commands/Repair.lhs --- darcs-2.4.4/src/Darcs/Commands/Repair.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Repair.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -18,7 +18,6 @@ \darcsCommand{repair} \begin{code} module Darcs.Commands.Repair ( repair, repairCmd ) where -import System.IO import Control.Monad( unless ) import System.Directory( renameFile ) diff -ruN darcs-2.4.4/src/Darcs/Commands/Replace.lhs darcs-2.5/src/Darcs/Commands/Replace.lhs --- darcs-2.4.4/src/Darcs/Commands/Replace.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Replace.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -36,7 +36,7 @@ ignoretimes, umaskOption, tokens, forceReplace, workingRepoDir, fixSubPaths ) import Darcs.Repository ( withRepoLock, ($-), - add_to_pending, + addToPending, amInRepository, applyToWorking, readUnrecorded, readRecordedAndPending @@ -45,7 +45,8 @@ import Darcs.Patch.Apply ( forceTokReplace ) import Darcs.Patch.FileName( fn2fp ) import Darcs.Patch.Patchy ( Apply ) -import Darcs.Witnesses.Ordered ( FL(..), unsafeFL, (+>+), concatFL ) +import Darcs.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL ) +import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..) ) import Darcs.Patch.RegChars ( regChars ) import Data.Char ( isSpace ) import Darcs.RepoPath ( SubPath, toFilePath, sp2fn ) @@ -57,6 +58,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS #include "impossible.h" +#include "gadts.h" replaceDescription :: String replaceDescription = "Substitute one word for another." @@ -166,22 +168,23 @@ unless (isTok toks tok) $ fail $ "'"++tok++"' is not a valid token!" checkToken old checkToken new - work <- readUnrecorded repository + work <- readUnrecorded repository [] cur <- readRecordedAndPending repository files <- filterM (exists work) fs - pswork <- concatFL . unsafeFL <$> mapM (repl toks cur work) files - add_to_pending repository pswork + Sealed pswork <- mapSeal concatFL . toFL <$> mapM (repl toks cur work) files + addToPending repository pswork applyToWorking repository opts pswork `catch` \e -> fail $ "Can't do replace on working!\n" ++ "Perhaps one of the files already contains '"++ new++"'?\n" ++ show e + return () where ftf _ = TextFile skipmsg f = "Skipping file '" ++ toFilePath f ++ "' which isn't in the repository." exists tree file = if isJust $ findFile tree (floatSubPath file) then return True else do putStrLn $ skipmsg file return False - repl :: String -> Tree IO -> Tree IO -> SubPath -> IO (FL Prim) + repl :: String -> Tree IO -> Tree IO -> SubPath -> IO (FreeLeft (FL Prim)) repl toks cur work f = do work_replaced <- maybeApplyToTree replace_patch work cur_replaced <- maybeApplyToTree replace_patch cur @@ -191,11 +194,11 @@ putStrLn $ "Perhaps the recorded version of this " ++ "file already contains '" ++new++"'?" putStrLn $ "Use the --force option to override." - return NilFL + return (emptyGap NilFL) where f_fp = toFilePath f replace_patch = tokreplace f_fp toks old new - get_force_replace :: SubPath -> String -> Tree IO -> IO (FL Prim) + get_force_replace :: SubPath -> String -> Tree IO -> IO (FreeLeft (FL Prim)) get_force_replace f toks tree = do let path = floatSubPath f content <- readBlob $ fromJust $ findFile tree path @@ -204,7 +207,7 @@ case newcontent of Nothing -> bug "weird forcing bug in replace." Just _ -> do pfix <- treeDiff ftf tree tree' - return $ pfix +>+ (tokreplace f_fp toks old new :>: NilFL) + return $ joinGap (+>+) pfix (freeGap (tokreplace f_fp toks old new :>: NilFL)) where f_fp = toFilePath f replaceCmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]" @@ -212,7 +215,7 @@ floatSubPath :: SubPath -> AnchoredPath floatSubPath = floatPath . fn2fp . sp2fn -maybeApplyToTree :: Apply p => p -> Tree IO -> IO (Maybe (Tree IO)) +maybeApplyToTree :: Apply p => p C(x y) -> Tree IO -> IO (Maybe (Tree IO)) maybeApplyToTree patch tree = catch (Just `fmap` applyToTree patch tree) (\_ -> return Nothing) @@ -232,7 +235,7 @@ -- found, it validates the argument and returns it, without the -- surrounding square brackets. Otherwise, it returns either -- 'defaultToks' or 'filenameToks' as explained in 'replaceHelp'. --- +-- -- Note: Limitations in the current replace patch file format prevents -- tokens and token-char specifiers from containing any whitespace. chooseToks :: [DarcsFlag] -> String -> String -> IO String diff -ruN darcs-2.4.4/src/Darcs/Commands/Revert.lhs darcs-2.5/src/Darcs/Commands/Revert.lhs --- darcs-2.4.4/src/Darcs/Commands/Revert.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Revert.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -33,17 +33,19 @@ import Darcs.Utils ( askUser ) import Darcs.RepoPath ( toFilePath ) import Darcs.Repository ( withRepoLock, ($-), withGutsOf, - add_to_pending, + addToPending, applyToWorking, amInRepository, readRecorded, unrecordedChanges ) import Darcs.Patch ( invert, applyToFilepaths, commute ) import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) ) -import Darcs.SelectChanges ( with_selected_last_changes_to_files' ) -import Darcs.Patch.TouchesFiles ( choose_touching ) +import Darcs.SelectChanges ( selectChanges, WhichChanges(Last), selectionContextPrim, runSelection ) +import Darcs.Patch.TouchesFiles ( chooseTouching ) import Darcs.Commands.Unrevert ( writeUnrevert ) -import Darcs.Witnesses.Sealed ( unsafeUnseal ) +import Darcs.Witnesses.Sealed ( Sealed(..) ) + +#include "gadts.h" revertDescription :: String revertDescription = "Discard unrecorded changes." @@ -84,14 +86,16 @@ changes <- unrecordedChanges opts repository files let pre_changed_files = applyToFilepaths (invert changes) (map toFilePath files) rec <- readRecorded repository - case unsafeUnseal $ choose_touching pre_changed_files changes of + Sealed touching_changes <- return (chooseTouching pre_changed_files changes) + (case touching_changes of NilFL -> putStrLn "There are no changes to revert!" - _ -> with_selected_last_changes_to_files' "revert" opts Nothing - pre_changed_files changes $ \ (norevert:>p) -> - if nullFL p - then putStrLn $ "If you don't want to revert after all," ++ + _ -> do + let context = selectionContextPrim "revert" opts Nothing pre_changed_files + (norevert:>p) <- runSelection (selectChanges Last changes) context + if nullFL p + then putStrLn $ "If you don't want to revert after all," ++ " that's fine with me!" - else do + else do let theseChanges = englishNum (lengthFL p) . This . Noun $ "change" yorn <- if All `elem` opts then return "y" @@ -99,7 +103,7 @@ case yorn of ('y':_) -> return () _ -> exitWith $ ExitSuccess withGutsOf repository $ do - add_to_pending repository $ invert p + addToPending repository $ invert p when (Debug `elem` opts) $ putStrLn "About to write the unrevert file." case commute (norevert:>p) of Just (p':>_) -> writeUnrevert repository p' rec NilFL @@ -107,6 +111,7 @@ when (Debug `elem` opts) $ putStrLn "About to apply to the working directory." applyToWorking repository opts (invert p) `catch` \e -> fail ("Unable to apply inverse patch!" ++ show e) + return ()) :: IO () putStrLn "Finished reverting." \end{code} diff -ruN darcs-2.4.4/src/Darcs/Commands/Rollback.lhs darcs-2.5/src/Darcs/Commands/Rollback.lhs --- darcs-2.4.4/src/Darcs/Commands/Rollback.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Rollback.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -22,7 +22,7 @@ module Darcs.Commands.Rollback ( rollback ) where -import Control.Monad ( when, filterM ) +import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode(..) ) import Data.List ( sort ) import Data.Maybe ( isJust ) @@ -39,27 +39,32 @@ import Darcs.RepoPath ( toFilePath ) import Darcs.Repository ( Repository, amInRepository, withRepoLock, ($-), applyToWorking, - read_repo, slurp_recorded, + readRepo, tentativelyMergePatches, withGutsOf, finalizeRepositoryChanges, invalidateIndex ) import Darcs.Patch ( RepoPatch, summary, invert, namepatch, effect, fromPrims, sortCoalesceFL, canonize ) +import Darcs.Patch.Set ( newset2RL ) import Darcs.Patch.Prim ( Prim ) import Darcs.Witnesses.Ordered import Darcs.Hopefully ( PatchInfoAnd, n2pia ) -import Darcs.Lock ( world_readable_temp ) -import Darcs.SlurpDirectory ( empty_slurpy ) +import Darcs.Lock ( worldReadableTemp ) import Darcs.Match ( firstMatch ) -import Darcs.SelectChanges ( with_selected_last_changes_to_files_reversed, - with_selected_last_changes_to_files' ) -import Darcs.Commands.Record ( fileExists, getLog ) +import Darcs.SelectChanges ( selectChanges, + WhichChanges(..), + selectionContext, selectionContextPrim, + runSelection + ) +import Darcs.Commands.Record ( getLog ) import Darcs.Commands.Unrecord ( getLastPatches ) +import Darcs.Commands.WhatsNew ( announceFiles ) import Darcs.Utils ( clarifyErrors ) import Printer ( renderString ) import Progress ( debugMessage ) import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..) ) import IsoDate ( getIsoDateTime ) #include "impossible.h" +#include "gadts.h" rollbackDescription :: String rollbackDescription = @@ -92,37 +97,32 @@ rollbackCmd :: [DarcsFlag] -> [String] -> IO () rollbackCmd opts args = withRepoLock opts $- \repository -> do - rec <- if null args then return empty_slurpy - else slurp_recorded repository files <- sort `fmap` fixSubPaths opts args - existing_files <- map toFilePath `fmap` filterM (fileExists rec) files - non_existent_files <- map toFilePath `fmap` filterM (fmap not . fileExists rec) files - when (not $ null existing_files) $ - putStrLn $ "Recording changes in "++unwords existing_files++":\n" - when (not $ null non_existent_files) $ - putStrLn $ "Non existent files or directories: "++unwords non_existent_files++"\n" - when ((not $ null non_existent_files) && null existing_files) $ + let files_fp = map toFilePath files + existing_files <- announceFiles repository files "Recording changes in" + when (null existing_files && (not $ null files)) $ fail "None of the files you specified exist!" - allpatches <- read_repo repository + allpatches <- readRepo repository FlippedSeal patches <- return $ if firstMatch opts then getLastPatches opts allpatches - else FlippedSeal $ concatRL allpatches - with_selected_last_changes_to_files_reversed "rollback" opts Nothing existing_files - (reverseRL patches) $ \ (_ :> ps) -> - do when (nullFL ps) $ do putStrLn "No patches selected!" - exitWith ExitSuccess - definePatches ps - with_selected_last_changes_to_files' "rollback" opts Nothing - existing_files (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps) + else FlippedSeal $ newset2RL allpatches + let patches_context = selectionContext "rollback" opts Nothing files_fp + (_ :> ps) <- runSelection (selectChanges LastReversed (reverseRL patches)) patches_context + when (nullFL ps) $ do putStrLn "No patches selected!" + exitWith ExitSuccess + definePatches ps + let hunks_context = selectionContextPrim "rollback" opts Nothing files_fp + hunks = (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps) + runSelection (selectChanges Last hunks) hunks_context >>= (rollItBackNow opts repository ps) rollItBackNow :: (RepoPatch p1, RepoPatch p) => - [DarcsFlag] -> Repository p1 -> FL (PatchInfoAnd p) - -> (t :> FL Prim) -> IO () + [DarcsFlag] -> Repository p1 C(r u t) -> FL (PatchInfoAnd p) C(x y) + -> (q :> FL Prim) C(a t) -> IO () rollItBackNow opts repository ps (_ :> ps'') = do when (nullFL ps'') $ do putStrLn "No changes selected!" exitWith ExitSuccess - let make_log = world_readable_temp "darcs-rollback" + let make_log = worldReadableTemp "darcs-rollback" newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps )) --tentativelyRemovePatches repository opts (mapFL_FL hopefully ps) (name, my_log, logf) <- getLog opts newlog make_log $ invert ps'' @@ -139,6 +139,7 @@ finalizeRepositoryChanges repository debugMessage "About to apply rolled-back changes to working directory." revertable $ applyToWorking repository opts pw + return () when (isJust logf) $ removeFile (fromJust logf) putStrLn "Finished rolling back." where revertable x = x `clarifyErrors` unlines diff -ruN darcs-2.4.4/src/Darcs/Commands/Send.lhs darcs-2.5/src/Darcs/Commands/Send.lhs --- darcs-2.4.4/src/Darcs/Commands/Send.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Send.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -18,21 +18,21 @@ \darcsCommand{send} \begin{code} {-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TypeOperators #-} module Darcs.Commands.Send ( send ) where -import Data.Char ( isAlpha, isDigit, isSpace, toLower ) import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) import System.IO.Error ( ioeGetErrorString ) import System.IO ( hClose ) import Control.Monad ( when, unless, forM_ ) -import Data.Maybe ( isJust, isNothing ) +import Storage.Hashed.Tree ( Tree ) +import Data.Maybe ( isNothing ) import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose ) import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile, - Target, OutputAutoName, Output, Context, + Target, Context, DryRun, Quiet, Unified - ), + ), getOutput, fixUrl, definePatches, getCc, getAuthor, workingRepoDir, editDescription, logfile, rmlogfile, @@ -43,31 +43,34 @@ allInteractive, getSendmailCmd, printDryRunMessageAndExit, summary, allowUnrelatedRepos, - fromOpt, dryRun, sendToContext, + fromOpt, dryRun, sendToContext, getOutput, + changesReverse, ) -import Darcs.Flags ( willRemoveLogFile ) -import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) +import Darcs.Flags ( willRemoveLogFile, doReverse ) +import Darcs.Hopefully ( PatchInfoAnd, hopefully, patchDesc ) import Darcs.Repository ( PatchSet, Repository, amInRepository, identifyRepositoryFor, withRepoReadLock, ($-), - read_repo, readRecorded, prefsUrl, checkUnrelatedRepos ) + readRepo, readRecorded, prefsUrl, checkUnrelatedRepos ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif import Darcs.Patch ( RepoPatch, description, applyToTree, invert ) -import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..), - mapRL_RL, mapFL, mapRL, reverseRL, mapFL_FL, lengthFL, nullFL ) -import Darcs.Patch.Bundle ( make_bundle, scan_context ) -import Darcs.Patch.Info ( just_name ) +import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:>>)(..), + mapFL, mapFL_FL, lengthFL, nullFL, unsafeCoerceP ) +import Darcs.Patch.Bundle ( makeBundleN, scanContext, patchFilename ) import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist ) import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail ) import ByteStringUtils ( mmapFilePS ) import qualified Data.ByteString.Char8 as BC (unpack) -import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, world_readable_temp, removeFileMayNotExist ) -import Darcs.SelectChanges ( with_selected_changes ) -import Darcs.Patch.Depends ( get_common_and_uncommon ) -import Darcs.Utils ( askUser, catchall, edit_file, formatPath ) +import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, worldReadableTemp, removeFileMayNotExist ) +import Darcs.SelectChanges ( selectChanges, WhichChanges(..), selectionContext, runSelection ) +import Darcs.Patch.Depends ( findCommonWithThem ) +import Darcs.Utils ( askUser, catchall, editFile, formatPath ) import Progress ( debugMessage ) -import Darcs.Email ( make_email ) +import Darcs.Email ( makeEmail ) import Printer ( Doc, vsep, vcat, text, ($$), (<+>), (<>), putDoc ) import Darcs.RepoPath ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd, - getCurrentDirectory, makeAbsoluteOrStd, useAbsoluteOrStd ) + getCurrentDirectory, useAbsoluteOrStd ) import HTTP ( postUrl ) #include "impossible.h" @@ -123,7 +126,7 @@ commandArgdefaults = defaultrepo, commandAdvancedOptions = [logfile, rmlogfile, remoteRepo, - sendToContext] ++ + sendToContext, changesReverse] ++ networkOptions, commandBasicOptions = [matchSeveral, depsSel, allInteractive, @@ -132,7 +135,8 @@ output,outputAutoName,sign] ++dryRun++[summary, editDescription, - setDefault, workingRepoDir, + setDefault False, + workingRepoDir, sendmailCmd, allowUnrelatedRepos]} @@ -147,9 +151,9 @@ -- Test to make sure we aren't trying to push to the current repo here <- getCurrentDirectory when (repodir == toFilePath here) $ - fail ("Can't send to current repository! Did you mean send -"++"-context?") + fail ("Can't send to current repository! Did you mean send --context?") repo <- identifyRepositoryFor repository repodir - them <- read_repo repo + them <- readRepo repo old_default <- getPreflist "defaultrepo" setDefaultrepo repodir input_opts when (old_default == [repodir] && not (Quiet `elem` input_opts)) $ @@ -158,43 +162,47 @@ sendToThem repository input_opts wtds repodir them where the_context [] = return Nothing the_context (Context foo:_) - = (Just . scan_context )`fmap` mmapFilePS (toFilePath foo) + = (Just . scanContext )`fmap` mmapFilePS (toFilePath foo) the_context (_:fs) = the_context fs sendCmd _ _ = impossible -sendToThem :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p C(x) -> IO () +sendToThem :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p C(Origin x) -> IO () sendToThem repo opts wtds their_name them = do - us <- read_repo repo - case get_common_and_uncommon (us, them) of - (common, us' :\/: _) -> do - checkUnrelatedRepos opts common us them - (case us' of - NilRL -> do putInfo opts $ text "No recorded local changes to send!" - exitWith ExitSuccess - _ -> putVerbose opts $ text "We have the following patches to send:" - $$ (vcat $ mapRL description us')) :: IO () - pristine <- readRecorded repo - let our_ps = reverseRL us' - with_selected_changes "send" opts Nothing our_ps $ - \ (to_be_sent :> _) -> do - printDryRunMessageAndExit "send" opts to_be_sent - when (nullFL to_be_sent) $ do - putInfo opts $ text "You don't want to send any patches, and that's fine with me!" - exitWith ExitSuccess - definePatches to_be_sent - pristine' <- applyToTree (invert $ mapRL_RL hopefully us') pristine - unsig_bundle <- make_bundle (Unified:opts) pristine' common (mapFL_FL hopefully to_be_sent) - bundle <- signString opts unsig_bundle - let make_fname (tb:>:_) = patchFilename $ patchDesc tb - make_fname _ = impossible - fname = make_fname to_be_sent - outname = getOutput opts fname - case outname of - Just fname' -> writeBundleToFile opts to_be_sent bundle fname' their_name - Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name - -patchDesc :: forall p C(x y) . PatchInfoAnd p C(x y) -> String -patchDesc p = just_name $ info p + us <- readRepo repo + common :>> us' <- return $ findCommonWithThem us them + checkUnrelatedRepos opts us them + (case us' of + NilFL -> do putInfo opts $ text "No recorded local changes to send!" + exitWith ExitSuccess + _ -> putVerbose opts $ text "We have the following patches to send:" + $$ (vcat $ mapFL description us')) :: IO () + pristine <- readRecorded repo + let context = selectionContext "send" opts Nothing [] + selector = if doReverse opts + then selectChanges FirstReversed + else selectChanges First + (to_be_sent :> _) <- runSelection (selector us') context + printDryRunMessageAndExit "send" opts to_be_sent + when (nullFL to_be_sent) $ do + putInfo opts $ text "You don't want to send any patches, and that's fine with me!" + exitWith ExitSuccess + definePatches to_be_sent + bundle <- prepareBundle opts common pristine (us':\/:to_be_sent) + let make_fname (tb:>:_) = patchFilename $ patchDesc tb + make_fname _ = impossible + fname = make_fname to_be_sent + outname = getOutput opts fname + case outname of + Just fname' -> writeBundleToFile opts to_be_sent bundle fname' wtds their_name + Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name + +prepareBundle :: forall p C(x y z). RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin z) + -> Tree IO -> ((FL (PatchInfoAnd p)) :\/: (FL (PatchInfoAnd p))) C(x y) + -> IO Doc +prepareBundle opts common pristine (us' :\/: to_be_sent) = do + pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine + unsig_bundle <- makeBundleN (Just pristine') (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent) + signString opts unsig_bundle sendBundle :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> Doc -> String -> [WhatToDo] -> String -> IO () @@ -214,13 +222,13 @@ Nothing -> auto_subject to_be_sent Just subj -> subj (mailcontents, mailfile) <- getDescription opts their_name to_be_sent - let body = make_email their_name + let body = makeEmail their_name (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts) (Just mailcontents) bundle (Just fname) contentAndBundle = Just (mailcontents, bundle) - + sendmail = do sm_cmd <- getSendmailCmd opts (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (getCc opts) @@ -247,11 +255,13 @@ postUrl url (BC.unpack nbody) "message/rfc822") `catch` const sendmail cleanup opts mailfile - where - lt [t] = t - lt [t,""] = t - lt (t:ts) = t++" , "++lt ts - lt [] = "" + + +lt :: [String] -> String +lt [t] = t +lt [t,""] = t +lt (t:ts) = t++" , "++lt ts +lt [] = "" cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO () cleanup opts (Just mailfile) = when (isNothing (getFileopt opts) || (willRemoveLogFile opts)) $ @@ -259,24 +269,16 @@ cleanup _ Nothing = return () writeBundleToFile :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> Doc -> - AbsolutePathOrStd -> String -> IO () -writeBundleToFile opts to_be_sent bundle fname their_name = + AbsolutePathOrStd -> [WhatToDo] -> String -> IO () +writeBundleToFile opts to_be_sent bundle fname wtds their_name = do (d,f) <- getDescription opts their_name to_be_sent let putabs a = do writeDocBinFile a (d $$ bundle) putStrLn $ "Wrote patch to " ++ toFilePath a ++ "." putstd = putDoc (d $$ bundle) useAbsoluteOrStd putabs putstd fname + let mails = lt [ t | SendMail t <- wtds ] + unless (null mails) $ putInfo opts $ text $ "The usual recipent for this bundle is: " ++ mails cleanup opts f - -safeFileChar :: Char -> Char -safeFileChar c | isAlpha c = toLower c - | isDigit c = c - | isSpace c = '-' -safeFileChar _ = '_' - -patchFilename :: String -> String -patchFilename the_summary = name ++ ".dpatch" - where name = map safeFileChar the_summary \end{code} \begin{options} @@ -331,11 +333,7 @@ decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO [WhatToDo] decideOnBehavior opts the_remote_repo = case the_targets of - [] -> - if isJust $ getOutput opts "" - then return [] - else - do wtds <- check_post + [] -> do wtds <- check_post unless (null wtds) $ announce_recipients wtds return wtds ts -> do announce_recipients ts @@ -371,12 +369,6 @@ else when (null the_targets) $ putInfo opts . text $ "Patch bundle will be sent to: "++unwords (map pn emails) -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 - getTargets :: [WhatToDo] -> IO [WhatToDo] getTargets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? " getTargets wtds = return wtds @@ -434,7 +426,7 @@ when (isNothing $ getFileopt opts) $ writeDocBinFile file patchdesc debugMessage $ "About to edit file " ++ file - edit_file file + editFile file return () doc <- readDocBinFile file return (doc, Just file) @@ -450,7 +442,7 @@ Nothing -> if EditDescription `elem` opts then Just tempfile else Nothing - tempfile = world_readable_temp "darcs-temp-mail" + tempfile = worldReadableTemp "darcs-temp-mail" getFileopt :: [DarcsFlag] -> Maybe AbsolutePath getFileopt (LogFile f:_) = Just f diff -ruN darcs-2.4.4/src/Darcs/Commands/SetPref.lhs darcs-2.5/src/Darcs/Commands/SetPref.lhs --- darcs-2.4.4/src/Darcs/Commands/SetPref.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/SetPref.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -27,7 +27,7 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag, workingRepoDir, umaskOption ) -import Darcs.Repository ( amInRepository, add_to_pending, withRepoLock, ($-) ) +import Darcs.Repository ( amInRepository, addToPending, withRepoLock, ($-) ) import Darcs.Patch ( changepref ) import Darcs.Witnesses.Ordered ( FL(..) ) import Darcs.Repository.Prefs ( getPrefval, changePrefval, ) @@ -100,9 +100,12 @@ oval <- getPrefval pref old <- case oval of Just v -> return v Nothing -> return "" + when ('\n' `elem` val) $ do + putStrLn $ val ++ "is not a valid preference value: newlines forbidden!" + exitWith $ ExitFailure 1 changePrefval pref old val putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'" - add_to_pending repository (changepref pref old val :>: NilFL) + addToPending repository (changepref pref old val :>: NilFL) setprefCmd _ _ = impossible \end{code} diff -ruN darcs-2.4.4/src/Darcs/Commands/ShowAuthors.lhs darcs-2.5/src/Darcs/Commands/ShowAuthors.lhs --- darcs-2.4.4/src/Darcs/Commands/ShowAuthors.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/ShowAuthors.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -33,8 +33,9 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults, putWarning ) import Darcs.External ( viewDoc ) import Darcs.Hopefully ( info ) -import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) ) -import Darcs.Patch.Info ( pi_author ) +import Darcs.Repository ( amInRepository, readRepo, withRepository, ($-) ) +import Darcs.Patch.Info ( piAuthor ) +import Darcs.Patch.Set ( newset2RL ) import Darcs.Witnesses.Ordered ( mapRL, concatRL ) import Printer ( text ) import Data.Function (on) @@ -102,9 +103,9 @@ authorsCmd :: [DarcsFlag] -> [String] -> IO () authorsCmd opts _ = withRepository opts $- \repository -> do - patches <- read_repo repository + patches <- readRepo repository spellings <- compiledAuthorSpellings opts - let authors = mapRL (pi_author . info) $ concatRL patches + let authors = mapRL (piAuthor . info) $ newset2RL patches viewDoc $ text $ unlines $ if Verbose `elem` opts then authors diff -ruN darcs-2.4.4/src/Darcs/Commands/ShowContents.lhs darcs-2.5/src/Darcs/Commands/ShowContents.lhs --- darcs-2.4.4/src/Darcs/Commands/ShowContents.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/ShowContents.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -34,7 +34,7 @@ import Darcs.Patch.Match( Matcher ) import Darcs.Match ( haveNonrangeMatch, applyInvToMatcher, nonrangeMatcher , InclusiveOrExclusive(..), matchExists ) -import Darcs.Repository ( withRepository, ($-), findRepository, read_repo, readRecorded ) +import Darcs.Repository ( withRepository, ($-), findRepository, readRepo, readRecorded ) import Darcs.Patch( RepoPatch ) import Storage.Hashed.Monad( virtualTreeIO ) @@ -73,7 +73,7 @@ let matcher = getMatcher opts unapply_to_match = applyInvToMatcher Exclusive matcher matched <- if (haveNonrangeMatch opts) - then do patchset <- read_repo repository + then do patchset <- readRepo repository unless (matchExists matcher patchset) $ fail $ "Couldn't match pattern " ++ show matcher snd `fmap` virtualTreeIO (unapply_to_match patchset) pristine diff -ruN darcs-2.4.4/src/Darcs/Commands/ShowFiles.lhs darcs-2.5/src/Darcs/Commands/ShowFiles.lhs --- darcs-2.4.4/src/Darcs/Commands/ShowFiles.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/ShowFiles.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -26,14 +26,16 @@ import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, files, directories, pending, nullFlag, matchOne ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Repository ( Repository, amInRepository, slurp_pending, slurp_recorded, - withRepository ) +import Darcs.Repository ( Repository, amInRepository, withRepository ) import Darcs.Patch ( RepoPatch ) -import Darcs.SlurpDirectory ( Slurpy, list_slurpy, list_slurpy_files, list_slurpy_dirs, slurp ) +import Darcs.Repository.State ( readRecorded, readRecordedAndPending ) +import Storage.Hashed.Tree( Tree, TreeItem(..), list, expand ) +import Storage.Hashed.AnchoredPath( anchorPath ) +import Storage.Hashed.Plain( readPlainTree ) + import Data.List( isPrefixOf ) import Darcs.Match ( haveNonrangeMatch, getNonrangeMatch ) -import Workaround ( getCurrentDirectory ) import Darcs.Lock ( withDelayedDir ) showFilesDescription :: String showFilesDescription = "Show version-controlled files in the working copy." @@ -78,45 +80,45 @@ commandBasicOptions = [files, directories, pending, nullFlag, matchOne, workingRepoDir] } -toListFiles, toListManifest :: [DarcsFlag] -> Slurpy -> [FilePath] +toListFiles, toListManifest :: [DarcsFlag] -> Tree m -> [FilePath] toListFiles opts = filesDirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts) toListManifest opts = filesDirs (NoFiles `notElem` opts) (Directories `elem` opts) -filesDirs :: Bool -> Bool -> Slurpy -> [FilePath] -filesDirs False False = \_ -> [] -filesDirs False True = list_slurpy_dirs -filesDirs True False = list_slurpy_files -filesDirs True True = list_slurpy +filesDirs :: Bool -> Bool -> Tree m -> [FilePath] +filesDirs False False _ = [] +filesDirs False True t = "." : [ anchorPath "." p | (p, SubTree _) <- list t ] +filesDirs True False t = [ anchorPath "." p | (p, File _) <- list t ] +filesDirs True True t = "." : (map (anchorPath "." . fst) $ list t) -manifestCmd :: ([DarcsFlag] -> Slurpy -> [FilePath]) -> [DarcsFlag] -> [String] -> IO () +manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO () manifestCmd to_list opts argList = do list <- (to_list opts) `fmap` withRepository opts myslurp - case argList of + case argList of [] -> mapM_ output list prefixes -> mapM_ output (onlysubdirs prefixes list) - where myslurp :: RepoPatch p => Repository p C(r u r) -> IO Slurpy - myslurp = do let fRevisioned = haveNonrangeMatch opts - fPending = Pending `elem` opts - fNoPending = NoPending `elem` opts + where myslurp :: RepoPatch p => Repository p C(r u r) -> IO (Tree IO) + myslurp r = do let fRevisioned = haveNonrangeMatch opts + fPending = Pending `elem` opts + fNoPending = NoPending `elem` opts -- this covers all 8 options - case (fRevisioned,fPending,fNoPending) of - (True,False,_) -> slurp_revision opts + expand =<< case (fRevisioned,fPending,fNoPending) of + (True,False,_) -> slurpRevision opts r (True,True,_) -> error $ "can't mix revisioned and pending flags" - (False,False,True) -> slurp_recorded - (False,_,False) -> slurp_pending -- pending is default + (False,False,True) -> readRecorded r + (False,_,False) -> readRecordedAndPending r -- pending is default (False,True,True) -> error $ "can't mix pending and no-pending flags" output_null name = do { putStr name ; putChar '\0' } output = if NullFlag `elem` opts then output_null else putStrLn - isParentDir a b = a == b - || (a ++ "/") `isPrefixOf` b - || ("./" ++ a ++ "/") `isPrefixOf` b + isParentDir a b = a == b + || (a ++ "/") `isPrefixOf` b + || ("./" ++ a ++ "/") `isPrefixOf` b || "./" ++ a == b onlysubdirs suffixes = filter $ or . mapM isParentDir suffixes -slurp_revision :: RepoPatch p => [DarcsFlag] -> Repository p C(r u r) -> IO Slurpy -slurp_revision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do - getNonrangeMatch r opts - slurp =<< getCurrentDirectory +slurpRevision :: RepoPatch p => [DarcsFlag] -> Repository p C(r u r) -> IO (Tree IO) +slurpRevision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do + getNonrangeMatch r opts + expand =<< readPlainTree "." \end{code} diff -ruN darcs-2.4.4/src/Darcs/Commands/ShowRepo.lhs darcs-2.5/src/Darcs/Commands/ShowRepo.lhs --- darcs-2.4.4/src/Darcs/Commands/ShowRepo.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/ShowRepo.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -29,13 +29,14 @@ import Text.Html ( tag, stringToHtml ) import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, files, xmloutput ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Repository ( withRepository, ($-), amInRepository, read_repo ) +import Darcs.Repository ( withRepository, ($-), amInRepository, readRepo ) import Darcs.Repository.Internal ( Repository(..), RepoType(..) ) import Darcs.Repository.Format ( RepoFormat(..) ) import Darcs.Repository.Prefs ( getPreflist ) -import Darcs.Repository.Motd ( get_motd ) +import Darcs.Repository.Motd ( getMotd ) import Darcs.Patch ( RepoPatch ) -import Darcs.Witnesses.Ordered ( lengthRL, concatRL ) +import Darcs.Patch.Set ( newset2RL ) +import Darcs.Witnesses.Ordered ( lengthRL ) import qualified Data.ByteString.Char8 as BC (unpack) showRepoHelp :: String @@ -139,11 +140,11 @@ where prefOut = uncurry out . (\(p,v) -> (p++" Pref", (dropWhile isSpace v))) . break isSpace showRepoMOTD :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO () -showRepoMOTD out (Repo loc _ _ _) = get_motd loc >>= out "MOTD" . BC.unpack +showRepoMOTD out (Repo loc _ _ _) = getMotd loc >>= out "MOTD" . BC.unpack -- Support routines to provide information used by the PutInfo operations above. numPatches :: RepoPatch p => Repository p C(r u r) -> IO Int -numPatches r = read_repo r >>= (return . lengthRL . concatRL) +numPatches r = readRepo r >>= (return . lengthRL . newset2RL) \end{code} diff -ruN darcs-2.4.4/src/Darcs/Commands/ShowTags.lhs darcs-2.5/src/Darcs/Commands/ShowTags.lhs --- darcs-2.4.4/src/Darcs/Commands/ShowTags.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/ShowTags.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -21,9 +21,10 @@ import Darcs.Arguments ( DarcsFlag(..), workingRepoDir ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Hopefully ( info ) -import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) ) -import Darcs.Patch.Info ( pi_tag ) -import Darcs.Witnesses.Ordered ( mapRL, concatRL ) +import Darcs.Repository ( amInRepository, readRepo, withRepository, ($-) ) +import Darcs.Patch.Info ( piTag ) +import Darcs.Patch.Set ( newset2RL ) +import Darcs.Witnesses.Ordered ( mapRL ) import System.IO ( stderr, hPutStrLn ) -- import Printer ( renderPS ) @@ -55,10 +56,10 @@ tagsCmd :: [DarcsFlag] -> [String] -> IO () tagsCmd opts _ = withRepository opts $- \repository -> do - patches <- read_repo repository - sequence_ $ mapRL process $ concatRL patches + patches <- readRepo repository + sequence_ $ mapRL process $ newset2RL patches where process hp = - case pi_tag $ info hp of + case piTag $ info hp of Just t -> do t' <- normalize t t False putStrLn t' diff -ruN darcs-2.4.4/src/Darcs/Commands/Tag.lhs darcs-2.5/src/Darcs/Commands/Tag.lhs --- darcs-2.4.4/src/Darcs/Commands/Tag.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Tag.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -31,15 +31,15 @@ pipeInteractive, askLongComment, workingRepoDir, getAuthor ) import Darcs.Hopefully ( n2pia ) -import Darcs.Repository ( amInRepository, withRepoLock, ($-), read_repo, - tentativelyAddPatch, finalizeRepositoryChanges, +import Darcs.Repository ( amInRepository, withRepoLock, ($-), readRepo, + tentativelyAddPatch, finalizeRepositoryChanges, ) import Darcs.Patch ( infopatch, identity, adddeps ) import Darcs.Patch.Info ( patchinfo ) -import Darcs.Patch.Depends ( get_tags_right ) +import Darcs.Patch.Depends ( getTagsRight ) import Darcs.Commands.Record ( getDate, getLog ) import Darcs.Witnesses.Ordered ( FL(..) ) -import Darcs.Lock ( world_readable_temp ) +import Darcs.Lock ( worldReadableTemp ) import Darcs.Flags ( DarcsFlag(..) ) import System.IO ( hPutStr, stderr ) @@ -90,7 +90,7 @@ tagCmd opts args = withRepoLock opts $- \repository -> do date <- getDate opts the_author <- getAuthor opts - deps <- get_tags_right `fmap` read_repo repository + deps <- getTagsRight `fmap` readRepo repository (name, long_comment, mlogf) <- get_name_log opts args myinfo <- patchinfo date name the_author long_comment let mypatch = infopatch myinfo identity @@ -100,7 +100,7 @@ putStrLn $ "Finished tagging patch '"++name++"'" where get_name_log :: [DarcsFlag] -> [String] -> IO (String, [String], Maybe String) get_name_log o a = do let o2 = if null a then o else (add_patch_name o (unwords a)) - (name, comment, mlogf) <- getLog o2 Nothing (world_readable_temp "darcs-tag") NilFL + (name, comment, mlogf) <- getLog o2 Nothing (worldReadableTemp "darcs-tag") NilFL when (length name < 2) $ hPutStr stderr $ "Do you really want to tag '" ++name++"'? If not type: darcs obliterate --last=1\n" diff -ruN darcs-2.4.4/src/Darcs/Commands/TrackDown.lhs darcs-2.5/src/Darcs/Commands/TrackDown.lhs --- darcs-2.4.4/src/Darcs/Commands/TrackDown.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/TrackDown.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -25,15 +25,18 @@ import Control.Monad( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable), workingRepoDir, +import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable, Bisect), workingRepoDir, bisect, setScriptsExecutableOption ) import Darcs.Hopefully ( hopefully ) -import Darcs.Repository ( amInRepository, read_repo, withRepoReadLock, ($-), withRecorded, +import Darcs.Repository ( amInRepository, readRepo, withRepoReadLock, ($-), withRecorded, setScriptsExecutable ) -import Darcs.Witnesses.Ordered ( FL(..), mapRL_RL, concatRL ) -import Darcs.Patch ( RepoPatch, Named, description, apply, invert, invertRL ) +import Darcs.Witnesses.Ordered ( RL(..), (:<)(..), (+<+), + reverseRL, splitAtRL, lengthRL, mapRL, mapFL, mapRL_RL, concatRL ) +import Darcs.Patch.Patchy ( Invert, Apply, ShowPatch ) +import Darcs.Patch ( RepoPatch, Named, description, apply, invert ) +import Darcs.Patch.Set ( newset2RL ) import Printer ( putDocLn ) -import Darcs.Test ( get_test ) +import Darcs.Test ( getTest ) import Darcs.Lock ( withTempDir ) #include "gadts.h" @@ -47,7 +50,14 @@ "passes a test. Given no arguments, it uses the default repository test.\n"++ "Given one argument, it treats it as a test command. Given two arguments,\n"++ "the first is an initialization command with is run only once, and the\n"++ - "second is the test command.\n" + "second is the test command.\n\n"++ + "Without the --bisect option, trackdown does linear search starting from head,\n"++ + "and moving away from head. With the --bisect option, it does binary search.\n\n"++ + "Under the assumption that failure is monotonous, trackdown produces\n"++ + "the same result with and without --bisect. (Monotonous means that when\n"++ + "moving away from head, the test result changes only once from \"fail\" to \"ok\".)\n"++ + "If failure is not monotonous, any one of the patches that break the test is\n"++ + "found at random." trackdown :: DarcsCommand trackdown = DarcsCommand {commandName = "trackdown", @@ -61,14 +71,14 @@ commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, commandAdvancedOptions = [setScriptsExecutableOption], - commandBasicOptions = [workingRepoDir]} + commandBasicOptions = [workingRepoDir, bisect]} trackdownCmd :: [DarcsFlag] -> [String] -> IO () trackdownCmd opts args = withRepoReadLock opts $- \repository -> do - patches <- read_repo repository + patches <- readRepo repository (init,test) <- case args of [] -> - do t <- get_test opts + do t <- getTest opts return (return ExitSuccess, t) [cmd] -> do putStrLn $ "Tracking down command:\n"++cmd @@ -80,20 +90,96 @@ _ -> fail "Trackdown expects zero to two arguments." withRecorded repository (withTempDir "trackingdown") $ \_ -> do when (SetScriptsExecutable `elem` opts) setScriptsExecutable - init - trackNext opts test . invertRL . mapRL_RL hopefully . concatRL $ patches - -trackNext :: RepoPatch p => [DarcsFlag] -> (IO ExitCode) -> FL (Named p) C(x y) -> IO () -trackNext opts test (p:>:ps) = do + _ <- init + (if Bisect `elem` opts + then trackBisect + else trackNextLinear) opts test (mapRL_RL hopefully . newset2RL $ patches) + +-- | linear search (without --bisect) +trackNextLinear :: RepoPatch p => [DarcsFlag] -> IO ExitCode -> RL (Named p) C(x y) -> IO () +trackNextLinear opts test (p:<:ps) = do test_result <- test if test_result == ExitSuccess then putStrLn "Success!" - else do apply opts p `catch` \e -> fail ("Bad patch:\n" ++ show e) + else do apply opts (invert p) `catch` \e -> fail ("Bad patch:\n" ++ show e) putStrLn "Trying without the patch:" putDocLn $ description $ invert p hFlush stdout - trackNext opts test ps -trackNext _ _ NilFL = putStrLn "Noone passed the test!" + trackNextLinear opts test ps +trackNextLinear _opts test NilRL = do + test_result <- test + if test_result == ExitSuccess + then putStrLn "Success!" + else putStrLn "Noone passed the test!" + +-- | binary search (with --bisect) +trackBisect :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> IO ExitCode -> RL p C(x y) -> IO () +trackBisect opts test NilRL = do + test_result <- test + if test_result == ExitSuccess + then putStrLn "Success!" + else putStrLn "Noone passed the test!" +trackBisect opts test ps = do + test_result <- test + if test_result == ExitSuccess + then putStrLn ("Test does not fail on head.") + else trackNextBisect opts curr_prog test BisectRight (patchTreeFromRL ps) + where + curr_prog = (1, 1 + round ((logBase 2 $ fromIntegral $ lengthRL ps) :: Double)) :: (Int,Int) + +-- | Bisect Patch Tree +data PatchTree p C(x y) where + Leaf :: p C(x y) -> PatchTree p C(x y) + Fork :: PatchTree p C(y z) -> PatchTree p C(x y) -> PatchTree p C(x z) + +-- | Direction of Bisect trackdown +data BisectDir = BisectLeft | BisectRight deriving Show + +-- | Progress of Bisect +type BisectState = (Int, Int) + +-- | Create Bisect PatchTree from the RL +patchTreeFromRL :: (Invert p, ShowPatch p, Apply p) => RL p C(x y) -> PatchTree p C(x y) +patchTreeFromRL (l :<: NilRL) = Leaf l +patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of + (l :< r) -> Fork (patchTreeFromRL l) (patchTreeFromRL r) + +-- | Convert PatchTree back to RL +patchTree2RL :: (Invert p) => PatchTree p C(x y) -> RL p C(x y) +patchTree2RL (Leaf p) = p :<: NilRL +patchTree2RL (Fork l r) = (patchTree2RL l) +<+ (patchTree2RL r) + +-- | Iterate the Patch Tree +trackNextBisect :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> BisectState -> IO ExitCode -> BisectDir -> PatchTree p C(x y) -> IO () +trackNextBisect opts (dnow, dtotal) test dir (Fork l r) = do + putStr ("Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences...\n") + hFlush stdout + case dir of + BisectRight -> jumpHalfOnRight opts l -- move in temporary repo + BisectLeft -> jumpHalfOnLeft opts r -- within given direction + test_result <- test -- execute test on repo + case test_result of + ExitSuccess -> trackNextBisect opts (dnow+1, dtotal) test BisectLeft l -- continue left (to the present) + _ -> trackNextBisect opts (dnow+1, dtotal) test BisectRight r -- continue right (to the past) +trackNextBisect _ _ _ _ (Leaf p) = do + putStrLn ("Last recent patch that fails the test (assuming monotony in the given range):") + putDocLn (description p) + +jumpHalfOnRight :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> PatchTree p C(x y) -> IO () +jumpHalfOnRight opts l = unapplyRL opts (patchTree2RL l) + +jumpHalfOnLeft :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> PatchTree p C(x y) -> IO () +jumpHalfOnLeft opts r = applyRL opts (patchTree2RL r) + +applyRL :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> RL p C(x y) -> IO () +applyRL opts patches = sequence_ (mapFL (safeApply opts) (reverseRL $ patches)) + +unapplyRL :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> RL p C(x y) -> IO () +unapplyRL opts patches = sequence_ (mapRL ((safeApply opts) . invert) patches) + +safeApply :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> p C(x y) -> IO () +safeApply opts p = apply opts p `catch` (\msg -> fail ("Bad patch (during trackdown --bisect):\n" ++ show msg)) + \end{code} Trackdown is helpful for locating when something was broken. It creates @@ -113,20 +199,11 @@ finally succeeds, the name of the hunted down patch is found in the output before the last test run. -FIXME: It is -still rather primitive. Currently it just goes back over the history in -reverse order trying each version. I'd like for it to explore different -patch combinations, to try to find the minimum number of patches that you -would need to obliterate in order to make the test succeed. - -FIXME: I also would like to add an interface by which you can tell it which -patches it should consider not including. Without such a feature, the -following command: -\begin{verbatim} -% darcs trackdown 'make && false' -\end{verbatim} -would result in compiling every version in the repository--which is a -rather tedious prospect. +The \verb!--bisect! variant of trackdown can be useful when the sought after +patch is likely buried deep in the repository history; however, it currently +requires an potentially expensive process of applying or unapplying half the +repository's patches at a time. You may often find the straightforward linear +trackdown to be more efficient in practice. \subsubsection{Example usage} If you want to find the last version of darcs that had a FIXME note in the diff -ruN darcs-2.4.4/src/Darcs/Commands/TransferMode.lhs darcs-2.5/src/Darcs/Commands/TransferMode.lhs --- darcs-2.4.4/src/Darcs/Commands/TransferMode.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/TransferMode.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -24,7 +24,7 @@ module Darcs.Commands.TransferMode ( transferMode ) where import Prelude hiding ( catch ) -import Control.Exception ( catch ) +import Control.Exception.Extensible ( catch ) import System.IO ( stdout, hFlush ) import Darcs.Utils ( withCurrentDirectory, prettyException ) diff -ruN darcs-2.4.4/src/Darcs/Commands/Unrecord.lhs darcs-2.5/src/Darcs/Commands/Unrecord.lhs --- darcs-2.4.4/src/Darcs/Commands/Unrecord.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Unrecord.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -23,34 +23,47 @@ module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, getLastPatches ) where import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) +import Data.Maybe( isJust ) -import Printer ( text ) -import Darcs.Hopefully ( hopefully ) +import Printer ( text, putDoc ) +import English ( presentParticiple ) +import Darcs.Hopefully ( hopefully, info, patchDesc ) import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, putVerbose ) import Darcs.Arguments ( DarcsFlag, + output, outputAutoName, getOutput, workingRepoDir, nocompress, definePatches, matchSeveralOrLast, depsSel, ignoretimes, allInteractive, umaskOption, summary, dryRun, - printDryRunMessageAndExit + printDryRunMessageAndExit, changesReverse ) +import Darcs.Flags ( doReverse ) import Darcs.Match ( firstMatch, matchFirstPatchset, matchAPatchread ) -import Darcs.Repository ( PatchSet, PatchInfoAnd, withGutsOf, +import Darcs.Repository ( PatchInfoAnd, withGutsOf, withRepoLock, ($-), tentativelyRemovePatches, finalizeRepositoryChanges, tentativelyAddToPending, applyToWorking, - read_repo, amInRepository + readRepo, amInRepository , invalidateIndex, unrecordedChanges ) import Darcs.Patch ( Patchy, RepoPatch, invert, commute, effect ) -import Darcs.Witnesses.Ordered ( RL(..), (:>)(..), (:\/:)(..), (+<+), +import Darcs.Patch.Set ( PatchSet(..), Tagged(..) ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif +import Darcs.Witnesses.Ordered ( RL(..), (:>)(..), (+<+), (:>>)(..), reverseFL, mapFL_FL, nullFL, - reverseRL, mapRL ) -import Darcs.Patch.Depends ( get_common_and_uncommon ) -import Darcs.SelectChanges ( with_selected_last_changes_reversed ) + reverseRL, mapRL, FL(..), mapFL ) +import Darcs.Patch.Depends ( findCommonWithThem ) +import Darcs.SelectChanges ( selectChanges + , WhichChanges(..) + , selectionContext, runSelection ) +import Darcs.Patch.Bundle ( makeBundle, patchFilename, contextPatches ) import Progress ( debugMessage ) import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped ) +import Darcs.RepoPath( useAbsoluteOrStd ) +import Darcs.Lock( writeDocBinFile ) #include "gadts.h" unrecordDescription :: String @@ -143,7 +156,8 @@ commandPrereq = amInRepository, commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, - commandAdvancedOptions = [nocompress,umaskOption], + commandAdvancedOptions = + [nocompress,umaskOption,changesReverse], commandBasicOptions = [matchSeveralOrLast, depsSel, allInteractive, @@ -151,30 +165,30 @@ unrecordCmd :: [DarcsFlag] -> [String] -> IO () unrecordCmd opts _ = withRepoLock opts $- \repository -> do - allpatches <- read_repo repository + allpatches <- readRepo repository FlippedSeal patches <- return $ if firstMatch opts then getLastPatches opts allpatches else matchingHead opts allpatches - with_selected_last_changes_reversed "unrecord" opts Nothing - (reverseRL patches) $ - \ (_ :> to_unrecord) -> do - when (nullFL to_unrecord) $ do putStrLn "No patches selected!" - exitWith ExitSuccess - putVerbose opts $ text + let context = selectionContext "unrecord" opts Nothing [] + selector = if doReverse opts + then selectChanges Last + else selectChanges LastReversed + (_ :> to_unrecord) <- runSelection (selector (reverseRL patches)) context + when (nullFL to_unrecord) $ do putStrLn "No patches selected!" + exitWith ExitSuccess + putVerbose opts $ text "About to write out (potentially) modified patches..." - definePatches to_unrecord - invalidateIndex repository - withGutsOf repository $ do tentativelyRemovePatches repository opts $ - mapFL_FL hopefully to_unrecord - finalizeRepositoryChanges repository - putStrLn "Finished unrecording." + definePatches to_unrecord + invalidateIndex repository + withGutsOf repository $ do tentativelyRemovePatches repository opts to_unrecord + finalizeRepositoryChanges repository + putStrLn "Finished unrecording." -getLastPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(r) +getLastPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin r) -> FlippedSeal (RL (PatchInfoAnd p)) C(r) getLastPatches opts ps = case matchFirstPatchset opts ps of - Sealed p1s -> case get_common_and_uncommon (ps,p1s) of - (_,us :\/: _) -> FlippedSeal us + Sealed p1s -> case findCommonWithThem ps p1s of _ :>> us -> FlippedSeal (reverseFL us) unpullDescription :: String unpullDescription = @@ -267,7 +281,7 @@ commandPrereq = amInRepository, commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, - commandAdvancedOptions = [nocompress,ignoretimes,umaskOption], + commandAdvancedOptions = [nocompress,ignoretimes,umaskOption, changesReverse], commandBasicOptions = [matchSeveralOrLast, depsSel, allInteractive, @@ -285,38 +299,54 @@ -> IO () genericObliterateCmd cmdname opts _ = withRepoLock opts $- \repository -> do pend <- unrecordedChanges opts repository [] - allpatches <- read_repo repository + allpatches <- readRepo repository FlippedSeal patches <- return $ if firstMatch opts then getLastPatches opts allpatches else matchingHead opts allpatches - with_selected_last_changes_reversed cmdname opts Nothing - (reverseRL patches) $ - \ (_ :> ps) -> - case commute (effect ps :> pend) of + let + context = selectionContext cmdname opts Nothing [] + selector = if doReverse opts + then selectChanges Last + else selectChanges LastReversed + (kept :> removed) <- runSelection (selector (reverseRL patches)) context + case commute (effect removed :> pend) of Nothing -> fail $ "Can't "++ cmdname ++ " patch without reverting some unrecorded change." Just (_ :> p_after_pending) -> do - when (nullFL ps) $ do putStrLn "No patches selected!" - exitWith ExitSuccess - printDryRunMessageAndExit "obliterate" opts ps - definePatches ps + when (nullFL removed) $ do putStrLn "No patches selected!" + exitWith ExitSuccess + printDryRunMessageAndExit "obliterate" opts removed + definePatches removed + when (isJust $ getOutput opts "") $ + savetoBundle opts (reverseFL kept) removed invalidateIndex repository withGutsOf repository $ - do tentativelyRemovePatches repository opts (mapFL_FL hopefully ps) - tentativelyAddToPending repository opts $ invert $ effect ps + do tentativelyRemovePatches repository opts removed + tentativelyAddToPending repository opts $ invert $ effect removed finalizeRepositoryChanges repository debugMessage "Applying patches to working directory..." applyToWorking repository opts (invert p_after_pending) `catch` \e -> fail ("Couldn't undo patch in working dir.\n" ++ show e) + return () putStrLn $ "Finished " ++ presentParticiple cmdname ++ "." -matchingHead :: Patchy p => [DarcsFlag] -> PatchSet p C(r) -> FlippedSeal (RL (PatchInfoAnd p)) C(r) -matchingHead opts (x:<:_) | or (mapRL (matchAPatchread opts) x) = FlippedSeal x -matchingHead opts (x:<:xs) = (x +<+) `mapFlipped` matchingHead opts xs -matchingHead _ NilRL = FlippedSeal NilRL - -presentParticiple :: String -> String -presentParticiple v | last v == 'e' = init v ++ "ing" - | otherwise = v ++ "ing" +matchingHead :: RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin r) + -> FlippedSeal (RL (PatchInfoAnd p)) C(r) +matchingHead opts set@(PatchSet x _) + | or (mapRL (matchAPatchread opts) x) = contextPatches set +matchingHead opts (PatchSet x (Tagged t _ ps :<: ts)) + = (x +<+) `mapFlipped` matchingHead opts (PatchSet (t:<:ps) ts) +matchingHead _ (PatchSet _ NilRL) = FlippedSeal NilRL + +savetoBundle :: RepoPatch p => [DarcsFlag] + -> RL (PatchInfoAnd p) C(x z) -> FL (PatchInfoAnd p) C(z t) + -> IO () +savetoBundle opts kept removed@(x :>: _) = do + bundle <- makeBundle Nothing kept (mapFL_FL hopefully removed) + let filename = patchFilename $ patchDesc x + Just outname = getOutput opts filename + useAbsoluteOrStd writeDocBinFile putDoc outname $ bundle + +savetoBundle _ _ NilFL = return () \end{code} diff -ruN darcs-2.4.4/src/Darcs/Commands/Unrevert.lhs darcs-2.5/src/Darcs/Commands/Unrevert.lhs --- darcs-2.4.4/src/Darcs/Commands/Unrevert.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/Unrevert.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -34,18 +34,22 @@ import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, ($-), unrevertUrl, considerMergeToWorking, tentativelyAddToPending, finalizeRepositoryChanges, - read_repo, amInRepository, + readRepo, amInRepository, readRecorded, applyToWorking, unrecordedChanges ) import Darcs.Patch ( RepoPatch, Prim, commute, namepatch, fromPrims ) -import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), reverseRL, - (+>+) ) -import Darcs.SelectChanges ( with_selected_changes_to_files' ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif +import Darcs.Patch.Set ( PatchSet(..) ) +import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+) ) +import Darcs.SelectChanges ( selectChanges, WhichChanges(First), + runSelection, selectionContextPrim ) import qualified Data.ByteString as B import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist ) -import Darcs.Patch.Depends ( get_common_and_uncommon ) +import Darcs.Patch.Depends ( mergeThem ) import Darcs.Utils ( askUser, catchall ) -import Darcs.Patch.Bundle ( scan_bundle, make_bundle ) +import Darcs.Patch.Bundle ( scanBundle, makeBundleN ) import IsoDate ( getIsoDateTime ) import Darcs.SignalHandler ( withSignalsBlocked ) import Progress ( debugMessage ) @@ -83,25 +87,23 @@ unrevertCmd :: [DarcsFlag] -> [String] -> IO () unrevertCmd opts [] = withRepoLock opts $- \repository -> do - us <- read_repo repository + us <- readRepo repository Sealed them <- unrevertPatchBundle repository rec <- readRecorded repository unrec <- unrecordedChanges opts repository [] - case get_common_and_uncommon (us, them) of - (_, h_us :\/: h_them) -> do - Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts) - (reverseRL h_us) (reverseRL h_them) - with_selected_changes_to_files' "unrevert" opts Nothing [] pw $ - \ (p :> skipped) -> do - tentativelyAddToPending repository opts p - withSignalsBlocked $ - do finalizeRepositoryChanges repository - applyToWorking repository opts p `catch` \e -> - fail ("Error applying unrevert to working directory...\n" - ++ show e) - debugMessage "I'm about to writeUnrevert." - writeUnrevert repository skipped rec (unrec+>+p) - debugMessage "Finished unreverting." + Sealed h_them <- return $ mergeThem us them + Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts) NilFL h_them + let context = selectionContextPrim "unrevert" opts Nothing [] + (p :> skipped) <- runSelection (selectChanges First pw) context + tentativelyAddToPending repository opts p + withSignalsBlocked $ + do finalizeRepositoryChanges repository + applyToWorking repository opts p `catch` \e -> + fail ("Error applying unrevert to working directory...\n" + ++ show e) + debugMessage "I'm about to writeUnrevert." + writeUnrevert repository skipped rec (unrec+>+p) + debugMessage "Finished unreverting." unrevertCmd _ _ = impossible writeUnrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) @@ -114,21 +116,19 @@ _ -> exitWith $ ExitSuccess writeUnrevert repository NilFL rec pend Just (p' :> _) -> do - rep <- read_repo repository - case get_common_and_uncommon (rep,rep) of - (common,_ :\/: _) -> do - date <- getIsoDateTime - np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p') - bundle <- make_bundle [Unified] rec common (np :>: NilFL) - writeDocBinFile (unrevertUrl repository) bundle - where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y) - fromRepoPrims _ xs = fromPrims xs + rep <- readRepo repository + date <- getIsoDateTime + np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p') + bundle <- makeBundleN (Just rec) rep (np :>: NilFL) + writeDocBinFile (unrevertUrl repository) bundle + where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y) + fromRepoPrims _ xs = fromPrims xs -unrevertPatchBundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p) +unrevertPatchBundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p C(Origin)) unrevertPatchBundle repository = do pf <- B.readFile (unrevertUrl repository) `catchall` fail "There's nothing to unrevert!" - case scan_bundle pf of + case scanBundle pf of Right ps -> return ps Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err \end{code} diff -ruN darcs-2.4.4/src/Darcs/Commands/WhatsNew.lhs darcs-2.5/src/Darcs/Commands/WhatsNew.lhs --- darcs-2.4.4/src/Darcs/Commands/WhatsNew.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands/WhatsNew.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -22,7 +22,7 @@ #include "gadts.h" -module Darcs.Commands.WhatsNew ( whatsnew ) where +module Darcs.Commands.WhatsNew ( whatsnew, announceFiles ) where import System.Exit ( ExitCode(..), exitWith ) import Data.List ( sort, (\\) ) import Control.Monad ( when ) @@ -30,24 +30,26 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds, ignoretimes, noskipBoring, - unified, summary, noCache, + unified, summary, areFileArgs, fixSubPaths, listRegisteredFiles, ) import Darcs.Flags( isUnified ) import Darcs.RepoPath ( SubPath, sp2fn ) -import Darcs.Repository ( Repository, withRepository, ($-), - amInRepository +import Darcs.Repository ( Repository, withRepository, ($-) + , amInRepository, extractOptions , unrecordedChanges, readRecordedAndPending, readRecorded, readUnrecorded ) -import Darcs.Repository.State( restrictBoring ) +import Darcs.Repository.State( restrictBoring, applyTreeFilter ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Patch ( RepoPatch, Prim, plainSummary, primIsHunk, applyToTree ) +import Darcs.Patch.TouchesFiles( choosePreTouching ) import Darcs.Patch.Permutations ( partitionRL ) import Darcs.Patch.Real ( RealPatch, prim2real ) -import Darcs.Patch.FileName ( fn2fp ) +import Darcs.RepoPath( toFilePath ) import Darcs.PrintPatch ( printPatch, contextualPrintPatch ) import Darcs.Witnesses.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), nullFL ) +import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft ) import Darcs.Diff( treeDiff ) import Storage.Hashed.Monad( virtualTreeIO, exists ) @@ -98,42 +100,47 @@ commandPrereq = amInRepository, commandGetArgPossibilities = listRegisteredFiles, commandArgdefaults = nodefaults, - commandAdvancedOptions = [ignoretimes, noskipBoring, noCache], + commandAdvancedOptions = [ignoretimes, noskipBoring], commandBasicOptions = [summary, unified, lookforadds, workingRepoDir]} -announceFiles :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO () -announceFiles repo files = - when (areFileArgs files) $ do +filteredChanges opts repo files = + choosePreTouching (map toFilePath files) `fmap` unrecordedChanges opts repo files + +announceFiles :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> String -> IO [SubPath] +announceFiles repo files message = + if (areFileArgs files) then do pristine <- readRecordedAndPending repo -- TODO this is slightly inefficient, since we should really somehow -- extract the unrecorded state as a side-effect of unrecordedChanges - index <- readUnrecorded repo + index <- readUnrecorded repo files nonboring <- restrictBoring index - working <- nonboring `fmap` readPlainTree "." - let paths = map (fn2fp . sp2fn) files + working <- applyTreeFilter nonboring `fmap` readPlainTree "." + let paths = map toFilePath files check = virtualTreeIO (mapM exists $ map floatPath paths) (in_working, _) <- check working (in_pending, _) <- check pristine mapM_ maybe_warn $ zip3 paths in_working in_pending - putStrLn $ "What's new in "++unwords (map show files)++":\n" + putStrLn $ message ++ " " ++ unwords (map show files)++":\n" + return [ path | (path, True) <- zip files (zipWith (||) in_working in_pending) ] + else return files where maybe_warn (file, False, False) = putStrLn $ "WARNING: File '"++file++"' does not exist!" - maybe_warn (file, True, False) = + maybe_warn (file, True, False) | LookForAdds `notElem` extractOptions repo = putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!" maybe_warn _ = return () whatsnewCmd :: [DarcsFlag] -> [String] -> IO () -whatsnewCmd opts' args +whatsnewCmd opts' args | LookForAdds `elem` opts' && NoSummary `notElem` opts' = -- add Summary to the opts since 'darcs whatsnew --look-for-adds' -- implies summary withRepository (Summary:opts') $- \repository -> do files <- fixSubPaths opts' args - announceFiles repository files - all_changes <- unrecordedChanges opts' repository files - chold <- unrecordedChanges (opts' \\ [LookForAdds]) repository files + announceFiles repository files "What's new in" + Sealed all_changes <- filteredChanges opts' repository files + Sealed chold <- filteredChanges (opts' \\ [LookForAdds]) repository files pristine <- readRecorded repository ftf <- filetypeFunction cho_adds :> _ <- return $ partitionRL primIsHunk $ reverseFL chold @@ -141,7 +148,7 @@ cho_adds_t <- applyToTree (reverseRL cho_adds) pristine cha_t <- applyToTree (reverseRL cha) pristine - chn <- treeDiff ftf cho_adds_t cha_t + Sealed chn <- unFreeLeft `fmap` treeDiff ftf cho_adds_t cha_t exitOnNoChanges (chn, chold) putDocLn $ plainSummary chold @@ -161,8 +168,8 @@ | otherwise = withRepository opts $- \repository -> do files <- sort `fmap` fixSubPaths opts args - announceFiles repository files - changes <- unrecordedChanges opts repository files + announceFiles repository files "What's new in" + Sealed changes <- filteredChanges opts repository files when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ ExitFailure 1) printSummary repository $ mapFL_FL prim2real changes where printSummary :: RepoPatch p => Repository p C(r u t) -> FL RealPatch C(r y) -> IO () diff -ruN darcs-2.4.4/src/Darcs/CommandsAux.hs darcs-2.5/src/Darcs/CommandsAux.hs --- darcs-2.4.4/src/Darcs/CommandsAux.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/CommandsAux.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,7 +20,7 @@ #include "gadts.h" -module Darcs.CommandsAux ( check_paths, malicious_patches, has_malicious_path, +module Darcs.CommandsAux ( checkPaths, maliciousPatches, hasMaliciousPath, ) where import Darcs.Flags ( DarcsFlag( RestrictPaths, DontRestrictPaths ) ) import Darcs.Patch ( Patchy, listTouchedFiles ) @@ -49,11 +49,11 @@ applying any patches. It checks for malicious paths in patches, and prints an error message and fails if it finds one. -} -check_paths :: Patchy p => [DarcsFlag] -> FL p C(x y) -> IO () -check_paths opts patches - = if check_is_on && or (mapFL has_malicious_path patches) +checkPaths :: Patchy p => [DarcsFlag] -> FL p C(x y) -> IO () +checkPaths opts patches + = if check_is_on && or (mapFL hasMaliciousPath patches) then fail $ unlines $ ["Malicious path in patch:"] ++ - (map (\s -> " " ++ s) $ concat $ mapFL malicious_paths patches) ++ + (map (\s -> " " ++ s) $ concat $ mapFL maliciousPaths patches) ++ ["", "If you are sure this is ok then you can run again with the --dont-restrict-paths option."] -- TODO: print patch(es) -- NOTE: should use safe Doc printer, this can be evil chars @@ -63,19 +63,19 @@ RestrictPaths `elem` opts -- | Filter out patches that contains some malicious file path -malicious_patches :: Patchy p => [Sealed2 p] -> [Sealed2 p] -malicious_patches to_check = filter (unseal2 has_malicious_path) to_check +maliciousPatches :: Patchy p => [Sealed2 p] -> [Sealed2 p] +maliciousPatches to_check = filter (unseal2 hasMaliciousPath) to_check -has_malicious_path :: Patchy p => p C(x y) -> Bool -has_malicious_path patch = - case malicious_paths patch of +hasMaliciousPath :: Patchy p => p C(x y) -> Bool +hasMaliciousPath patch = + case maliciousPaths patch of [] -> False _ -> True -malicious_paths :: Patchy p => p C(x y) -> [String] -malicious_paths patch = +maliciousPaths :: Patchy p => p C(x y) -> [String] +maliciousPaths patch = let paths = listTouchedFiles patch in - filter is_malicious_path paths + filter isMaliciousPath paths {-| What is a malicious path? @@ -100,13 +100,13 @@ changes to certain preference files (_darcs\/prefs\/) in sub repositories'? -} -is_malicious_path :: String -> Bool -is_malicious_path fp = - not (is_explicitly_relative fp) || +isMaliciousPath :: String -> Bool +isMaliciousPath fp = + not (isExplicitlyRelative fp) || splitDirectories fp `contains_any` [ "..", darcsdir ] where contains_any a b = not . null $ intersect a b -is_explicitly_relative :: String -> Bool -is_explicitly_relative ('.':'/':_) = True -- begins with "./" -is_explicitly_relative _ = False +isExplicitlyRelative :: String -> Bool +isExplicitlyRelative ('.':'/':_) = True -- begins with "./" +isExplicitlyRelative _ = False diff -ruN darcs-2.4.4/src/Darcs/Commands.lhs darcs-2.5/src/Darcs/Commands.lhs --- darcs-2.4.4/src/Darcs/Commands.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Commands.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -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 diff -ruN darcs-2.4.4/src/Darcs/Compat.hs darcs-2.5/src/Darcs/Compat.hs --- darcs-2.4.4/src/Darcs/Compat.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Compat.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,7 +1,7 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} -module Darcs.Compat (stdout_is_a_pipe, mk_stdout_temp, canonFilename, - maybeRelink, atomic_create, sloppy_atomic_create) where +module Darcs.Compat (stdoutIsAPipe, mkStdoutTemp, canonFilename, + maybeRelink, atomicCreate, sloppyAtomicCreate) where import Prelude hiding ( catch ) @@ -23,12 +23,12 @@ BufferMode(NoBuffering) ) import System.IO.Error ( mkIOError, alreadyExistsErrorType ) import System.Posix.Files ( stdFileMode ) -import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, +import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, dupTo, defaultFileFlags, exclusive, OpenMode(WriteOnly) ) import System.Posix.Types ( Fd(..) ) -import Darcs.SignalHandler ( stdout_is_a_pipe ) +import Darcs.SignalHandler ( stdoutIsAPipe ) canonFilename :: FilePath -> IO FilePath canonFilename f@(_:':':_) = return f -- absolute windows paths @@ -44,16 +44,16 @@ simplefilename = reverse $ takeWhile (/='/') $ reverse f #ifdef WIN32 -mkstemp_core :: FilePath -> IO (Fd, String) -mkstemp_core fp +mkstempCore :: FilePath -> IO (Fd, String) +mkstempCore fp = do r <- randomIO let fp' = fp ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int)) fd <- openFd fp' WriteOnly (Just stdFileMode) flags return (fd, fp') where flags = defaultFileFlags { exclusive = True } #else -mkstemp_core :: String -> IO (Fd, String) -mkstemp_core str = withCString (str++"XXXXXX") $ +mkstempCore :: String -> IO (Fd, String) +mkstempCore str = withCString (str++"XXXXXX") $ \cstr -> do fd <- c_mkstemp cstr if fd < 0 then throwErrno $ "Failed to create temporary file "++str @@ -65,8 +65,8 @@ c_mkstemp :: CString -> IO CInt #endif -mk_stdout_temp :: String -> IO String -mk_stdout_temp str = do (fd, fn) <- mkstemp_core str +mkStdoutTemp :: String -> IO String +mkStdoutTemp str = do (fd, fn) <- mkstempCore str hFlush stdout hFlush stderr dupTo fd stdOutput @@ -101,23 +101,23 @@ return False _ -> fail ("Unexpected situation when relinking " ++ dst)) -sloppy_atomic_create :: FilePath -> IO () -sloppy_atomic_create fp +sloppyAtomicCreate :: FilePath -> IO () +sloppyAtomicCreate fp = do fd <- openFd fp WriteOnly (Just stdFileMode) flags closeFd fd where flags = defaultFileFlags { exclusive = True } -atomic_create :: FilePath -> IO () -atomic_create fp = withCString fp $ \cstr -> do +atomicCreate :: FilePath -> IO () +atomicCreate fp = withCString fp $ \cstr -> do rc <- c_atomic_create cstr unless (rc >= 0) $ do errno <- getErrno pwd <- getCurrentDirectory if errno == eEXIST then ioError $ mkIOError alreadyExistsErrorType - ("atomic_create in "++pwd) + ("atomicCreate in "++pwd) Nothing (Just fp) - else throwErrno $ "atomic_create "++fp++" in "++pwd + else throwErrno $ "atomicCreate "++fp++" in "++pwd foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create :: CString -> IO CInt diff -ruN darcs-2.4.4/src/Darcs/Diff.hs darcs-2.5/src/Darcs/Diff.hs --- darcs-2.4.4/src/Darcs/Diff.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Diff.hs 2010-10-24 08:29:26.000000000 -0700 @@ -22,6 +22,7 @@ module Darcs.Diff( treeDiff ) where import Darcs.Witnesses.Ordered ( FL(..), (+>+) ) +import Darcs.Witnesses.Sealed ( Gap(..) ) import Darcs.Repository.Prefs ( FileType(..) ) import Darcs.Patch ( Prim, hunk, canonize, binary , addfile, rmfile, adddir, rmdir, invert) @@ -33,32 +34,53 @@ import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -import ByteStringUtils( is_funky ) +import Data.List ( sortBy ) +import ByteStringUtils( isFunky ) #include "gadts.h" +#include "impossible.h" -treeDiff :: (FilePath -> FileType) -> Tree IO -> Tree IO -> IO (FL Prim C(x y)) -#ifdef GADT_WITNESSES -treeDiff = undefined -- Sigh. -#else +data Diff m = Added (TreeItem m) | Removed (TreeItem m) | Changed (TreeItem m) (TreeItem m) + +getDiff :: AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> (AnchoredPath, Diff m) +getDiff p Nothing (Just t) = (p, Added t) +getDiff p (Just from) (Just to) = (p, Changed from to) +getDiff p (Just t) Nothing = (p, Removed t) +getDiff p Nothing Nothing = impossible -- zipTrees should never return this + +treeDiff :: forall m w . (Functor m, Monad m, Gap w) => (FilePath -> FileType) -> Tree m -> Tree m -> m (w (FL Prim)) treeDiff ft t1 t2 = do (from, to) <- diffTrees t1 t2 - diffs <- sequence $ zipTrees diff from to - return $ foldr (+>+) NilFL diffs - where diff :: AnchoredPath -> Maybe (TreeItem IO) -> Maybe (TreeItem IO) - -> IO (FL Prim) - diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL - diff p (Just (SubTree _)) Nothing = - return $ rmdir (anchorPath "" p) :>: NilFL - diff p Nothing (Just (SubTree _)) = - return $ adddir (anchorPath "" p) :>: NilFL - diff p Nothing b'@(Just (File _)) = - do diff' <- diff p (Just (File emptyBlob)) b' - return $ addfile (anchorPath "" p) :>: diff' - diff p a'@(Just (File _)) Nothing = - do diff' <- diff p a' (Just (File emptyBlob)) - return $ diff' +>+ (rmfile (anchorPath "" p) :>: NilFL) - diff p (Just (File a')) (Just (File b')) = + diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to + return $ foldr (joinGap (+>+)) (emptyGap NilFL) diffs + where + -- sort into removes, changes, adds, with removes in reverse-path order + -- and everything else in forward order + organise :: (AnchoredPath, Diff m) -> (AnchoredPath, Diff m) -> Ordering + + organise (p1, Changed _ _ ) (p2, Changed _ _) = compare p1 p2 + organise (p1, Added _) (p2, Added _) = compare p1 p2 + organise (p1, Removed _) (p2, Removed _) = compare p2 p1 + + organise (p1, Removed _) _ = LT + organise _ (p1, Removed _) = GT + + organise (p1, Changed _ _) _ = LT + organise _ (p1, Changed _ _) = GT + + diff :: AnchoredPath -> Diff m -> m (w (FL Prim)) + diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL) + diff p (Removed (SubTree _)) = + return $ freeGap (rmdir (anchorPath "" p) :>: NilFL) + diff p (Added (SubTree _)) = + return $ freeGap (adddir (anchorPath "" p) :>: NilFL) + diff p (Added b'@(File _)) = + do diff' <- diff p (Changed (File emptyBlob) b') + return $ joinGap (:>:) (freeGap (addfile (anchorPath "" p))) diff' + diff p (Removed a'@(File _)) = + do diff' <- diff p (Changed a' (File emptyBlob)) + return $ joinGap (+>+) diff' (freeGap (rmfile (anchorPath "" p) :>: NilFL)) + diff p (Changed (File a') (File b')) = do a <- readBlob a' b <- readBlob b' let path = anchorPath "" p @@ -66,20 +88,19 @@ TextFile | no_bin a && no_bin b -> return $ text_diff path a b _ -> return $ if a /= b - then binary path (strict a) (strict b) :>: NilFL - else NilFL - diff p _ _ = fail $ "Missing case at path " ++ show p + then freeGap (binary path (strict a) (strict b) :>: NilFL) + else emptyGap NilFL + diff p _ = fail $ "Missing case at path " ++ show p text_diff p a b - | BL.null a && BL.null b = NilFL - | BL.null a = diff_from_empty p b - | BL.null b = diff_to_empty p a - | otherwise = line_diff p (linesB a) (linesB b) + | BL.null a && BL.null b = emptyGap NilFL + | BL.null a = freeGap (diff_from_empty p b) + | BL.null b = freeGap (diff_to_empty p a) + | otherwise = freeGap (line_diff p (linesB a) (linesB b)) line_diff p a b = canonize (hunk p 1 a b) diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) [] | otherwise = line_diff p (linesB x) [BS.empty] diff_from_empty p x = invert (diff_to_empty p x) - no_bin = not . is_funky . strict . BL.take 4096 + no_bin = not . isFunky . strict . BL.take 4096 linesB = map strict . BLC.split '\n' strict = BS.concat . BL.toChunks -#endif diff -ruN darcs-2.4.4/src/Darcs/Email.hs darcs-2.5/src/Darcs/Email.hs --- darcs-2.4.4/src/Darcs/Email.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Email.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,16 +1,15 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module Darcs.Email ( make_email, read_email, formatHeader ) where +module Darcs.Email ( makeEmail, readEmail, formatHeader ) where import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) import Data.List ( isInfixOf ) -import qualified Codec.Binary.UTF8.String as UTF8 ( encode ) import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS) -import ByteStringUtils (dropSpace, linesPS, betweenLinesPS ) +import ByteStringUtils ( packStringToUTF8, dropSpace, linesPS, betweenLinesPS ) import qualified Data.ByteString as B (ByteString, length, null, tail ,drop, head, concat, singleton - ,pack, append, empty + ,pack, append, empty, unpack ) import qualified Data.ByteString.Char8 as BC (index, head, pack) import Data.ByteString.Internal as B (c2w, createAndTrim) @@ -19,12 +18,12 @@ import Foreign.Storable ( poke ) import Data.Word ( Word8 ) --- line_max is maximum number of characters in an e-mail line excluding the CRLF --- at the end. qline_max is the number of characters in a q-encoded or +-- lineMax is maximum number of characters in an e-mail line excluding the CRLF +-- at the end. qlineMax is the number of characters in a q-encoded or -- quoted-printable-encoded line. -line_max, qline_max :: Int -line_max = 78 -qline_max = 75 +lineMax, qlineMax :: Int +lineMax = 78 +qlineMax = 75 -- | Formats an e-mail header by encoding any non-ascii characters using UTF-8 -- and Q-encoding, and folding lines at appropriate points. It doesn't do @@ -37,39 +36,39 @@ formatHeader headerName headerValue = B.append nameColon encodedValue where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding - encodedValue = fold_and_encode (' ':headerValue) + encodedValue = foldAndEncode (' ':headerValue) (B.length nameColon) False False -- run through a string and encode non-ascii words and fold where appropriate. -- the integer argument is the current position in the current line. -- the string in the first argument must begin with whitespace, or be empty. -fold_and_encode :: String -> Int -> Bool -> Bool -> B.ByteString -fold_and_encode [] _ _ _ = B.empty -fold_and_encode s p lastWordEncoded inMidWord = +foldAndEncode :: String -> Int -> Bool -> Bool -> B.ByteString +foldAndEncode [] _ _ _ = B.empty +foldAndEncode s p lastWordEncoded inMidWord = let newline = B.singleton 10 space = B.singleton 32 s2bs = B.pack . map B.c2w -- the twelve there is the max number of ASCII chars to encode a single -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte - safeEncChunkLength = (qline_max - B.length encoded_word_start - - B.length encoded_word_end) `div` 12 + safeEncChunkLength = (qlineMax - B.length encodedWordStart + - B.length encodedWordEnd) `div` 12 (curSpace, afterCurSpace) = span (== ' ') s (curWord, afterCurWord) = break (== ' ') afterCurSpace qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord) | otherwise = qEncode curWord mustEncode = inMidWord || any (\c -> not (isPrint c) || (ord c) > 127) curWord - || length curWord > line_max - 1 + || length curWord > lineMax - 1 || isInfixOf "=?" curWord mustFold | mustEncode && lastWordEncoded - = p + 1 + B.length qEncWord > line_max + = p + 1 + B.length qEncWord > lineMax | mustEncode - = p + length curSpace + B.length qEncWord > line_max + = p + length curSpace + B.length qEncWord > lineMax | otherwise - = p + length curSpace + length curWord > line_max - mustSplit = (B.length qEncWord > qline_max && mustEncode) - || length curWord > line_max - 1 + = p + length curSpace + length curWord > lineMax + mustSplit = (B.length qEncWord > qlineMax && mustEncode) + || length curWord > lineMax - 1 spaceToInsert | mustEncode && lastWordEncoded = space | otherwise = s2bs curSpace wordToInsert @@ -80,36 +79,39 @@ | otherwise = B.concat [spaceToInsert, wordToInsert] (rest, nextP) | mustSplit - = (drop safeEncChunkLength curWord ++ afterCurWord, qline_max + 1) - | mustEncode && mustFold + = (drop safeEncChunkLength curWord ++ afterCurWord, qlineMax + 1) + | mustEncode && mustFold = (afterCurWord, B.length spaceToInsert + B.length wordToInsert) | otherwise = (afterCurWord, p + B.length doneChunk) - in B.append doneChunk (fold_and_encode rest nextP mustEncode mustSplit) + in B.append doneChunk (foldAndEncode rest nextP mustEncode mustSplit) -- | Turns a piece of string into a q-encoded block -- Applies q-encoding, for use in e-mail header values, as defined in RFC 2047. -- It just takes a string and builds an encoded-word from it, it does not check -- length or necessity. qEncode :: String -> B.ByteString -qEncode s = B.concat [encoded_word_start, +qEncode s = B.concat [encodedWordStart, encodedString, - encoded_word_end] - where encodedString = B.concat (map q_encode_char s) + encodedWordEnd] + where encodedString = B.concat (map qEncodeChar s) -encoded_word_start, encoded_word_end :: B.ByteString -encoded_word_start = B.pack (map B.c2w "=?UTF-8?Q?") -encoded_word_end = B.pack (map B.c2w "?=") +encodedWordStart, encodedWordEnd :: B.ByteString +encodedWordStart = B.pack (map B.c2w "=?UTF-8?Q?") +encodedWordEnd = B.pack (map B.c2w "?=") -- turns a character into its q-encoded bytestring value. For most printable -- ASCII characters, that's just the singleton bytestring with that char. -q_encode_char :: Char -> B.ByteString -q_encode_char c +qEncodeChar :: Char -> B.ByteString +qEncodeChar c | c == ' ' = c2bs '_' | isPrint c && not (c `elem` ['?', '=', '_']) && ord c < 128 = c2bs c - | otherwise = B.concat (map qbyte (UTF8.encode [c])) + | otherwise = B.concat + (map qbyte + (B.unpack + (packStringToUTF8 [c]))) where c2bs = B.singleton . B.c2w -- qbyte turns a byte into its q-encoded "=hh" representation qbyte b = B.pack (map B.c2w ['=' @@ -123,24 +125,24 @@ qpencode :: B.ByteString -> B.ByteString qpencode s = unsafePerformIO -- Really only (3 + 2/75) * length or something in the worst case - $ B.createAndTrim (4 * B.length s) (\buf -> encode s qline_max buf 0) + $ B.createAndTrim (4 * B.length s) (\buf -> encode s qlineMax buf 0) encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int encode ps _ _ bufi | B.null ps = return bufi encode ps n buf bufi = case B.head ps of c | c == newline -> do poke (buf `plusPtr` bufi) newline - encode ps' qline_max buf (bufi+1) + encode ps' qlineMax buf (bufi+1) | n == 0 && B.length ps > 1 -> do poke (buf `plusPtr` bufi) equals poke (buf `plusPtr` (bufi+1)) newline - encode ps qline_max buf (bufi + 2) + encode ps qlineMax buf (bufi + 2) | (c == tab || c == space) -> if B.null ps' || B.head ps' == newline then do poke (buf `plusPtr` bufi) c poke (buf `plusPtr` (bufi+1)) equals poke (buf `plusPtr` (bufi+2)) newline - encode ps' qline_max buf (bufi + 3) + encode ps' qlineMax buf (bufi + 3) else do poke (buf `plusPtr` bufi) c encode ps' (n - 1) buf (bufi + 1) | (c >= bang && c /= equals && c <= tilde) -> @@ -193,8 +195,8 @@ toWord8 :: Int -> Word8 toWord8 = fromIntegral -make_email :: String -> [(String, String)] -> (Maybe Doc) -> Doc -> (Maybe String) -> Doc -make_email repodir headers mcontents bundle mfilename = +makeEmail :: String -> [(String, String)] -> (Maybe Doc) -> Doc -> (Maybe String) -> Doc +makeEmail repodir headers mcontents bundle mfilename = text "DarcsURL:" <+> text repodir $$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers $$ text "MIME-Version: 1.0" @@ -224,8 +226,8 @@ $$ text "" $$ text "" -read_email :: B.ByteString -> B.ByteString -read_email s = +readEmail :: B.ByteString -> B.ByteString +readEmail s = case betweenLinesPS (BC.pack "Content-Description: A darcs patch for your repository!") (BC.pack "--=_--") s of diff -ruN darcs-2.4.4/src/Darcs/External.hs darcs-2.5/src/Darcs/External.hs --- darcs-2.4.4/src/Darcs/External.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/External.hs 2010-10-24 08:29:26.000000000 -0700 @@ -4,7 +4,7 @@ backupByRenaming, backupByCopying, copyFileOrUrl, speculateFileOrUrl, copyFilesOrUrls, copyLocal, cloneFile, cloneTree, cloneTreeExcept, clonePartialsTree, clonePaths, - fetchFilePS, gzFetchFilePS, + fetchFilePS, fetchFileLazyPS, gzFetchFilePS, sendEmail, generateEmail, sendEmailDoc, resendEmail, signString, verifyPS, execDocPipe, execPipeIgnoreError, @@ -14,7 +14,7 @@ maybeURLCmd, Cachable(Cachable, Uncachable, MaxAge), viewDoc, viewDocWith, - sendmail_path, diff_program, darcs_program + sendmailPath, diffProgram, darcsProgram ) where import qualified Ratified @@ -34,7 +34,7 @@ findExecutable ) import System.Process ( runProcess, runInteractiveProcess, waitForProcess ) import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar ) -import Control.Exception ( bracket, try, finally ) +import Control.Exception.Extensible ( bracket, try, finally, SomeException ) import Data.Char ( toUpper ) #if defined (HAVE_MAPI) import Foreign.C ( CString, withCString ) @@ -53,7 +53,7 @@ import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL, NoLinks, Verify, VerifySSL, RemoteDarcs ) ) import Darcs.RepoPath ( AbsolutePath, toFilePath ) -import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, ) +import Darcs.Utils ( withCurrentDirectory, breakCommand, getViewer, ortryrunning, ) import Progress ( withoutProgress, progressList, debugMessage ) import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS) @@ -61,22 +61,23 @@ ,hGetContents, writeFile, hPut, length ,take, concat, drop, isPrefixOf, singleton, append) import qualified Data.ByteString.Char8 as BC (unpack, pack) +import qualified Data.ByteString.Lazy as BL -import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist ) +import Darcs.Lock ( withTemp, withOpenTemp, tempdirLoc, removeFileMayNotExist ) import CommandLine ( parseCmd, addUrlencoded ) import URL ( copyUrl, copyUrlFirst, waitUrl ) import Ssh ( getSSH, copySSH, copySSHs, SSHCmd(..) ) import URL ( Cachable(..) ) import Exec ( exec, Redirect(..), withoutNonBlock ) -import Darcs.URL ( is_file, is_url, is_ssh ) +import Darcs.URL ( isFile, isUrl, isSsh ) import Darcs.Utils ( catchall ) import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS, simplePrinters, text, empty, packedString, vcat, renderString ) import Darcs.Email ( formatHeader ) -sendmail_path :: IO String -sendmail_path = do +sendmailPath :: IO String +sendmailPath = do l <- filterM doesFileExist $ liftM2 () [ "/usr/sbin", "/sbin", "/usr/lib" ] [ "sendmail" ] @@ -84,15 +85,15 @@ when (isNothing ex && null l) $ fail "Cannot find the \"sendmail\" program." return $ head $ maybeToList ex ++ l -diff_program :: IO String -diff_program = do +diffProgram :: IO String +diffProgram = do l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ] when (null l) $ fail "Cannot find the \"diff\" program." return $ head l -- |Get the name of the darcs executable (as supplied by @getProgName@) -darcs_program :: IO String -darcs_program = getProgName +darcsProgram :: IO String +darcsProgram = getProgName -- Another option: getEnv "DARCS" `catch` \_ -> getProgName backupByRenaming :: FilePath -> IO () @@ -129,13 +130,23 @@ -- (either a file or an URL). If it has to download an url, then it -- will use a cache as required by its second argument. fetchFilePS :: String -> Cachable -> IO B.ByteString -fetchFilePS fou _ | is_file fou = B.readFile fou +fetchFilePS fou _ | isFile fou = B.readFile fou fetchFilePS fou cache = withTemp $ \t -> do let opts = [] -- FIXME: no network flags copyFileOrUrl opts fou t cache B.readFile t +-- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of +-- its argument (either a file or an URL). Warning: this function may +-- constitute a fd leak; make sure to force consumption of file contents +-- to avoid that. +fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString +fetchFileLazyPS fou _ | isFile fou = BL.readFile fou +fetchFileLazyPS fou cache = withTemp $ \t -> do let opts = [] -- FIXME: no network flags + copyFileOrUrl opts fou t cache + BL.readFile t + gzFetchFilePS :: String -> Cachable -> IO B.ByteString -gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou +gzFetchFilePS fou _ | isFile fou = gzReadFilePS fou gzFetchFilePS fou cache = withTemp $ \t-> do let opts = [] -- FIXME: no network flags copyFileOrUrl opts fou t cache gzReadFilePS t @@ -144,15 +155,18 @@ remoteDarcsCmd flags = head $ [ c | (RemoteDarcs c) <- flags ] ++ ["darcs"] copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO () -copyFileOrUrl opts fou out _ | is_file fou = copyLocal opts fou out -copyFileOrUrl _ fou out cache | is_url fou = copyRemote fou out cache -copyFileOrUrl opts fou out _ | is_ssh fou = copySSH (remoteDarcsCmd opts) fou out +copyFileOrUrl opts fou out _ | isFile fou = copyLocal opts fou out +copyFileOrUrl _ fou out cache | isUrl fou = copyRemote fou out cache +copyFileOrUrl opts fou out _ | isSsh fou = copySSH (remoteDarcsCmd opts) fou out copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou speculateFileOrUrl :: String -> FilePath -> IO () -speculateFileOrUrl fou out | is_url fou = speculateRemote fou out +speculateFileOrUrl fou out | isUrl fou = speculateRemote fou out | otherwise = return () +speculateFilesOrUrls :: FilePath -> [String] -> FilePath -> IO () +speculateFilesOrUrls _ _ _ = return () -- FIXME + copyLocal :: [DarcsFlag] -> String -> FilePath -> IO () copyLocal opts fou out | NoLinks `elem` opts = cloneFile fou out | otherwise = createLink fou out `catchall` cloneFile fou out @@ -249,9 +263,9 @@ copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO () -copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out -copyFilesOrUrls _ dou ns out c | is_url dou = copyRemotes dou ns out c -copyFilesOrUrls opts dou ns out _ | is_ssh dou = copySSHs (remoteDarcsCmd opts) dou ns out +copyFilesOrUrls opts dou ns out _ | isFile dou = copyLocals opts dou ns out +copyFilesOrUrls _ dou ns out c | isUrl dou = copyRemotes dou ns out c +copyFilesOrUrls opts dou ns out _ | isSsh dou = copySSHs (remoteDarcsCmd opts) dou ns out copyFilesOrUrls _ dou _ _ _ = fail $ "unknown transport protocol: "++dou @@ -364,8 +378,8 @@ = B.hPut h (B.append (formatHeader field value) newline) newline = B.singleton 10 -have_sendmail :: IO Bool -have_sendmail = (sendmail_path >> return True) `catch` (\_ -> return False) +haveSendmail :: IO Bool +haveSendmail = (sendmailPath >> return True) `catch` (\_ -> return False) -- | Send an email, optionally containing a patch bundle -- (more precisely, its description and the bundle itself) @@ -382,7 +396,7 @@ sendEmailDoc f "" s cc scmd mbundle body = sendEmailDoc f cc s "" scmd mbundle body sendEmailDoc f t s cc scmd mbundle body = do - use_sendmail <- have_sendmail + use_sendmail <- haveSendmail if use_sendmail || scmd /= "" then do withOpenTemp $ \(h,fn) -> do generateEmail h f t s cc body @@ -428,7 +442,7 @@ resendEmail :: String -> String -> B.ByteString -> IO () resendEmail "" _ _ = return () resendEmail t scmd body = do - use_sendmail <- have_sendmail + use_sendmail <- haveSendmail if use_sendmail || scmd /= "" then do withOpenTemp $ \(h,fn) -> do @@ -468,7 +482,7 @@ execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode execSendmail ftable scmd fn = if scmd == "" then do - cmd <- sendmail_path + cmd <- sendmailPath exec cmd ["-i", "-t"] (File fn, Null, AsIs) else case parseCmd (addUrlencoded ftable) scmd of Right (arg0:opts, wantstdin) -> @@ -633,7 +647,7 @@ viewDocWith pr msg = do isTerminal <- hIsTerminalDevice stdout if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg) - then do viewerPlusArgs <- get_viewer + then do viewerPlusArgs <- getViewer let (viewer:args) = words viewerPlusArgs pipeDocToPager viewer args pr msg `ortryrunning` pipeDocToPager "less" [] pr msg @@ -655,7 +669,7 @@ return ExitSuccess pipeDocToPager c args pr inp = withoutNonBlock $ withoutProgress $ do - tmp <- tempdir_loc + tmp <- tempdirLoc bracket (openBinaryTempFile tmp "darcs-pager") cleanup $ \(fn,fh) -> do hPutDocWith pr fh inp hClose fh @@ -666,5 +680,5 @@ putStrLn $ "Command not found:\n "++ show (c:args) return x where - cleanup (f,h) = do try $ hClose h + cleanup (f,h) = do try (hClose h) :: IO (Either SomeException ()) removeFileMayNotExist f diff -ruN darcs-2.4.4/src/Darcs/FilePathMonad.hs darcs-2.5/src/Darcs/FilePathMonad.hs --- darcs-2.4.4/src/Darcs/FilePathMonad.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/FilePathMonad.hs 2010-10-24 08:29:26.000000000 -0700 @@ -25,8 +25,8 @@ import Data.Maybe ( catMaybes ) import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) -import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, superName, break_on_dir, - norm_path, movedirfilename ) +import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, superName, breakOnDir, + normPath, movedirfilename ) #include "impossible.h" data FilePathMonad a = FPM ([FileName] -> ([FileName], a)) @@ -50,13 +50,13 @@ instance ReadableDirectory FilePathMonad where -- We can't check it actually is a directory here mDoesDirectoryExist d = - FPM $ \fs -> (fs, norm_path d `elem` map norm_path fs) + FPM $ \fs -> (fs, normPath d `elem` map normPath fs) -- We can't check it actually is a file here mDoesFileExist f = - FPM $ \fs -> (fs, norm_path f `elem` map norm_path fs) + FPM $ \fs -> (fs, normPath f `elem` map normPath fs) mInCurrentDirectory d (FPM j) = FPM $ \fs -> (fs, snd $ j $ catMaybes $ map indir fs) - where indir f = do (d',f') <- break_on_dir f + where indir f = do (d',f') <- breakOnDir f if d == d' then Just f' else Nothing mGetDirectoryContents = @@ -69,7 +69,7 @@ let splitfs = map splitf fs others = catMaybes $ map snd splitfs (myfs, a) = j $ catMaybes $ map fst splitfs - splitf f = case break_on_dir f of + splitf f = case breakOnDir f of Just (d', f') | d' == d -> (Just f', Nothing) _ -> (Nothing, Just f) in (others ++ myfs, a) diff -ruN darcs-2.4.4/src/Darcs/Flags.hs darcs-2.5/src/Darcs/Flags.hs --- darcs-2.4.4/src/Darcs/Flags.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Flags.hs 2010-10-24 08:29:26.000000000 -0700 @@ -15,12 +15,13 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Flags ( DarcsFlag( .. ), Compression( .. ), compression, - want_external_merge, isInteractive, +module Darcs.Flags ( DarcsFlag( .. ), Compression( .. ), compression, + wantExternalMerge, isInteractive, maxCount, willIgnoreTimes, willRemoveLogFile, isUnified, willStoreInMemory, doHappyForwarding, includeBoring, doAllowCaseOnly, doAllowWindowsReserved, doReverse, - showChangesOnlyToFiles + showChangesOnlyToFiles, + defaultFlag, ) where import Data.Maybe( fromMaybe ) import Darcs.Patch.MatchData ( PatchMatch ) @@ -59,6 +60,7 @@ | EditDescription | NoEditDescription | Toks String | EditLongComment | NoEditLongComment | PromptLongComment + | KeepDate | NoKeepDate | AllowConflicts | MarkConflicts | NoAllowConflicts | SkipConflicts | Boring | SkipBoring @@ -83,12 +85,12 @@ | NonApply | NonVerify | NonForce | DryRun | SetDefault | NoSetDefault | FancyMoveAdd | NoFancyMoveAdd - | Disable | SetScriptsExecutable | DontSetScriptsExecutable + | Disable | SetScriptsExecutable | DontSetScriptsExecutable | Bisect | UseHashedInventory | UseOldFashionedInventory | UseFormat2 | PristinePlain | PristineNone | NoUpdateWorking | Sibling AbsolutePath | Relink | RelinkPristine | NoLinks - | OptimizePristine + | OptimizePristine | OptimizeHTTP | UpgradeFormat | Files | NoFiles | Directories | NoDirectories | Pending | NoPending @@ -96,7 +98,7 @@ | PrehookCmd String | NoPrehook | AskPrehook | RunPrehook | UMask String | StoreInMemory | ApplyOnDisk - | HTTPPipelining | NoHTTPPipelining + | NoHTTPPipelining | NoCache | AllowUnrelatedRepos | Check | Repair | JustThisRepo @@ -108,10 +110,10 @@ compression f | NoCompress `elem` f = NoCompression | otherwise = GzipCompression -want_external_merge :: [DarcsFlag] -> Maybe String -want_external_merge [] = Nothing -want_external_merge (ExternalMerge c:_) = Just c -want_external_merge (_:fs) = want_external_merge fs +wantExternalMerge :: [DarcsFlag] -> Maybe String +wantExternalMerge [] = Nothing +wantExternalMerge (ExternalMerge c:_) = Just c +wantExternalMerge (_:fs) = wantExternalMerge fs isInteractive :: [DarcsFlag] -> Bool isInteractive = isInteractive_ True @@ -165,4 +167,12 @@ doReverse = getBoolFlag Reverse Forward showChangesOnlyToFiles :: [DarcsFlag] -> Bool -showChangesOnlyToFiles = getBoolFlag OnlyChangesToFiles ChangesToAllFiles \ No newline at end of file +showChangesOnlyToFiles = getBoolFlag OnlyChangesToFiles ChangesToAllFiles + +-- | Set flags to a default value, but only one has not already been provided +defaultFlag :: [DarcsFlag] -- ^ distractors + -> DarcsFlag -- ^ default + -> [DarcsFlag] -- ^ flags + -> [DarcsFlag] -- ^ updated flags +defaultFlag alts def flags = + if any (`elem` flags) alts then flags else def : flags diff -ruN darcs-2.4.4/src/Darcs/Global.hs darcs-2.5/src/Darcs/Global.hs --- darcs-2.4.4/src/Darcs/Global.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Global.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,7 +20,7 @@ -- to include global variables. Here, we attempt to cover broad, global -- features, such as exit handlers. These features slightly break the Haskellian -- purity of darcs, in favour of programming convenience. -module Darcs.Global ( atexit, with_atexit, +module Darcs.Global ( atexit, withAtexit, sshControlMasterDisabled, setSshControlMasterDisabled, verboseMode, setVerboseMode, timingsMode, setTimingsMode, @@ -32,7 +32,7 @@ import Control.Monad ( when ) import Control.Concurrent.MVar -import Control.Exception (bracket_, catch, block, unblock) +import Control.Exception.Extensible (bracket_, catch, block, unblock, SomeException) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Data.IORef ( modifyIORef ) import System.IO.Unsafe (unsafePerformIO) @@ -40,15 +40,15 @@ import System.Time ( calendarTimeToString, toCalendarTime, getClockTime ) import Prelude hiding (catch) -{-# NOINLINE atexit_actions #-} -atexit_actions :: MVar (Maybe [IO ()]) -atexit_actions = unsafePerformIO (newMVar (Just [])) +{-# NOINLINE atexitActions #-} +atexitActions :: MVar (Maybe [IO ()]) +atexitActions = unsafePerformIO (newMVar (Just [])) -- | Registers an IO action to run just before darcs exits. Useful -- for removing temporary files and directories, for example. atexit :: IO () -> IO () atexit action = do - modifyMVar_ atexit_actions $ \ml -> do + modifyMVar_ atexitActions $ \ml -> do case ml of Just l -> do return (Just (action : l)) @@ -56,19 +56,19 @@ hPutStrLn stderr "It's too late to use atexit" return Nothing -with_atexit :: IO a -> IO a -with_atexit prog = do +withAtexit :: IO a -> IO a +withAtexit prog = do bracket_ (return ()) exit prog where exit = block $ do - Just actions <- swapMVar atexit_actions Nothing + Just actions <- swapMVar atexitActions Nothing -- from now on atexit will not register new actions mapM_ runAction actions runAction action = do - catch (unblock action) $ \exn -> do + catch (unblock action) $ \(exn :: SomeException) -> do hPutStrLn stderr $ "Exception thrown by an atexit registered action:" hPutStrLn stderr $ show exn diff -ruN darcs-2.4.4/src/Darcs/Hopefully.hs darcs-2.5/src/Darcs/Hopefully.hs --- darcs-2.4.4/src/Darcs/Hopefully.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Hopefully.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,21 +21,22 @@ #include "gadts.h" module Darcs.Hopefully ( Hopefully, PatchInfoAnd, + WPatchInfo, unWPatchInfo, compareWPatchInfo, piap, n2pia, patchInfoAndPatch, - conscientiously, hopefully, info, + conscientiously, hopefully, info, winfo, hopefullyM, createHashed, extractHash, - actually, unavailable ) where + actually, unavailable, patchDesc ) where import System.IO.Unsafe ( unsafeInterleaveIO ) import Darcs.SignalHandler ( catchNonSignal ) import Printer ( Doc, renderString, errorDoc, text, ($$) ) -import Darcs.Patch.Info ( PatchInfo, human_friendly, idpatchinfo ) +import Darcs.Patch.Info ( PatchInfo, humanFriendly, idpatchinfo, justName ) import Darcs.Patch ( RepoPatch, Named, patch2patchinfo ) import Darcs.Patch.Prim ( Effect(..), Conflict(..) ) import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..), ShowPatch(..), Commute(..) ) -import Darcs.Witnesses.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) ) +import Darcs.Witnesses.Ordered ( MyEq, EqCheck(..), unsafeCoerceP, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) ) import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal ) import Darcs.Utils ( prettyException ) @@ -58,6 +59,19 @@ -- know its info. data PatchInfoAnd p C(a b) = PIAP !PatchInfo (Hopefully (Named p) C(a b)) +-- | @'WPatchInfo' C(a b)@ represents the info of a patch, marked with +-- the patch's witnesses. +newtype WPatchInfo C(a b) = WPatchInfo { unWPatchInfo :: PatchInfo } + +-- This is actually unsafe if we ever commute patches and then compare them +-- using this function. TODO: consider adding an extra existential to WPatchInfo +-- (as with TaggedPatch in Darcs.Patch.Choices) +compareWPatchInfo :: WPatchInfo C(a b) -> WPatchInfo C(c d) -> EqCheck C((a, b) (c, d)) +compareWPatchInfo (WPatchInfo x) (WPatchInfo y) = if x == y then unsafeCoerceP IsEq else NotEq + +instance MyEq WPatchInfo where + WPatchInfo x `unsafeCompare` WPatchInfo y = x == y + fmapH :: (a C(x y) -> b C(w z)) -> Hopefully a C(x y) -> Hopefully b C(w z) fmapH f (Hopefully sh) = Hopefully (ff sh) where ff (Actually a) = Actually (f a) @@ -69,6 +83,12 @@ info :: PatchInfoAnd p C(a b) -> PatchInfo info (PIAP i _) = i +patchDesc :: forall p C(x y) . PatchInfoAnd p C(x y) -> String +patchDesc p = justName $ info p + +winfo :: PatchInfoAnd p C(a b) -> WPatchInfo C(a b) +winfo (PIAP i _) = WPatchInfo i + -- | @'piap' i p@ creates a PatchInfoAnd containing p with info i. piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b) piap i p = PIAP i (Hopefully $ Actually p) @@ -95,14 +115,14 @@ conscientiously er (PIAP pinf hp) = case hopefully2either hp of Right p -> p - Left e -> errorDoc $ er (human_friendly pinf $$ text e) + Left e -> errorDoc $ er (humanFriendly pinf $$ text e) -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a -- monad instead of erroring. hopefullyM :: Monad m => PatchInfoAnd p C(a b) -> m (Named p C(a b)) hopefullyM (PIAP pinf hp) = case hopefully2either hp of Right p -> return p - Left e -> fail $ renderString (human_friendly pinf $$ text e) + Left e -> fail $ renderString (humanFriendly pinf $$ text e) -- Any recommendations for a nice adverb to name the below? hopefully2either :: Hopefully a C(x y) -> Either String (a C(x y)) @@ -139,17 +159,17 @@ instance (Conflict p, Effect p, ShowPatch p) => ShowPatch (PatchInfoAnd p) where showPatch (PIAP n p) = case hopefully2either p of Right x -> showPatch x - Left _ -> human_friendly n + Left _ -> humanFriendly n showContextPatch (PIAP n p) = case hopefully2either p of Right x -> showContextPatch x - Left _ -> return $ human_friendly n - description (PIAP n _) = human_friendly n + Left _ -> return $ humanFriendly n + description (PIAP n _) = humanFriendly n summary (PIAP n p) = case hopefully2either p of Right x -> summary x - Left _ -> human_friendly n + Left _ -> humanFriendly n showNicely (PIAP n p) = case hopefully2either p of Right x -> showNicely x - Left _ -> human_friendly n + Left _ -> humanFriendly n instance Commute p => Commute (PatchInfoAnd p) where commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y) @@ -179,8 +199,9 @@ instance Conflict p => Conflict (PatchInfoAnd p) where listConflictedFiles = listConflictedFiles . hopefully resolveConflicts = resolveConflicts . hopefully - commute_no_conflicts (x:>y) = do y':>x' <- commute_no_conflicts (hopefully x :> hopefully y) + commuteNoConflicts (x:>y) = do y':>x' <- commuteNoConflicts (hopefully x :> hopefully y) return (info y `piap` y' :> info x `piap` x') conflictedEffect = conflictedEffect . hopefully + isInconsistent = isInconsistent . hopefully instance RepoPatch p => Patchy (PatchInfoAnd p) diff -ruN darcs-2.4.4/src/Darcs/IO.hs darcs-2.5/src/Darcs/IO.hs --- darcs-2.4.4/src/Darcs/IO.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/IO.hs 2010-10-24 08:29:26.000000000 -0700 @@ -24,7 +24,7 @@ import Data.Char ( toLower ) import Data.List ( isSuffixOf ) import System.IO.Error ( isDoesNotExistError, isPermissionError ) -import Control.Exception ( catch, catchJust, ioErrors ) +import Control.Exception.Extensible ( catch, SomeException, IOException ) import Control.Monad.Error import System.Directory ( getDirectoryContents, createDirectory, removeDirectory, removeFile, @@ -108,7 +108,7 @@ fail $ "Cannot remove non-empty file "++fp removeFile fp mRemoveDirectory = removeDirectory . fn2fp - mRename a b = catchJust ioErrors + mRename a b = catch (renameDirectory x y `mplus` renameFile x y) -- We need to catch does not exist errors, since older -- versions of darcs allowed users to rename nonexistent @@ -132,7 +132,7 @@ newtype SilentIO a = SIO { runSilently :: IO a } instance TolerantMonad SilentIO where - warning io = SIO $ io `catch` \_ -> return () + warning io = SIO $ io `catch` \(_ :: SomeException) -> return () runIO (SIO io) = io runTM io = SIO io @@ -192,15 +192,15 @@ mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty mCreateDirectory d = warning $ backup d >> mCreateDirectory d mRemoveFile f = warning $ mRemoveFile f - mRemoveDirectory d = warning $ catchJust ioErrors + mRemoveDirectory d = warning $ catch (mRemoveDirectory d) - (\e -> + (\(e :: IOException) -> if "(Directory not empty)" `isSuffixOf` show e then ioError $ userError $ "Not deleting " ++ fn2fp d ++ " because it is not empty." else ioError $ userError $ "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e) - mRename a b = warning $ catchJust ioErrors + mRename a b = warning $ catch (let do_backup = if (map toLower x == map toLower y) then backupByCopying y -- avoid making the original vanish else backupByRenaming y @@ -224,15 +224,15 @@ mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty mCreateDirectory d = warning $ backup d >> mCreateDirectory d mRemoveFile f = warning $ mRemoveFile f - mRemoveDirectory d = warning $ catchJust ioErrors + mRemoveDirectory d = warning $ catch (mRemoveDirectory d) - (\e -> + (\(e :: SomeException) -> if "(Directory not empty)" `isSuffixOf` show e then ioError $ userError $ "Not deleting " ++ fn2fp d ++ " because it is not empty." else ioError $ userError $ "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e) - mRename a b = warning $ catchJust ioErrors + mRename a b = warning $ catch (let do_backup = if (map toLower x == map toLower y) then backupByCopying y -- avoid making the original vanish else backupByRenaming y @@ -255,7 +255,7 @@ floatFn :: FileName -> AnchoredPath floatFn = floatPath . fn2fp -instance (MonadPlus m, MonadError e m) => ReadableDirectory (HSM.TreeMonad m) where +instance (Functor m, MonadPlus m, MonadError e m) => ReadableDirectory (HSM.TreeMonad m) where mDoesDirectoryExist d = HSM.directoryExists (floatFn d) mDoesFileExist f = HSM.fileExists (floatFn f) mInCurrentDirectory d action = HSM.withDirectory (floatFn d) action diff -ruN darcs-2.4.4/src/Darcs/Lock.hs darcs-2.5/src/Darcs/Lock.hs --- darcs-2.4.4/src/Darcs/Lock.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Lock.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,13 +21,14 @@ withTemp, withOpenTemp, withStdoutTemp, withTempDir, withPermDir, withDelayedDir, withNamedTemp, writeToFile, appendToFile, - writeBinFile, writeDocBinFile, appendBinFile, appendDocBinFile, - readBinFile, readDocBinFile, + writeBinFile, writeLocaleFile, writeDocBinFile, + appendBinFile, appendDocBinFile, + readBinFile, readLocaleFile, readDocBinFile, writeAtomicFilePS, gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile, - rm_recursive, removeFileMayNotExist, + rmRecursive, removeFileMayNotExist, canonFilename, maybeRelink, - world_readable_temp, tempdir_loc, + worldReadableTemp, tempdirLoc, editText, environmentHelpTmpdir, environmentHelpKeepTmpdir ) where @@ -40,8 +41,8 @@ hClose, hPutStr, Handle, IOMode(WriteMode, AppendMode), hFlush, stdout ) import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError ) -import Control.Exception ( bracket, catchJust, ioErrors, throwIO, - Exception(IOException), catch, try ) +import Control.Exception.Extensible + ( bracket, throwIO, catch, try, SomeException ) import System.Directory ( removeFile, removeDirectory, doesFileExist, doesDirectoryExist, getDirectoryContents, createDirectory, @@ -49,23 +50,23 @@ ) import System.FilePath.Posix ( splitDirectories ) import Workaround ( renameFile ) -import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO, run_editor ) +import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO, runEditor ) import Control.Monad ( unless, when ) -import Darcs.URL ( is_relative ) -import Darcs.Utils ( catchall, add_to_error_loc ) +import Darcs.URL ( isRelative ) +import Darcs.Utils ( catchall, addToErrorLoc ) import Darcs.RepoPath ( AbsolutePath, FilePathLike, toFilePath, getCurrentDirectory, setCurrentDirectory ) -import ByteStringUtils ( gzWriteFilePSs) +import ByteStringUtils ( gzWriteFilePSs, decodeLocale, encodeLocale ) import qualified Data.ByteString as B (null, readFile, writeFile, hPut, ByteString) import qualified Data.ByteString.Char8 as BC (unpack) import Darcs.SignalHandler ( withSignalsBlocked ) import Printer ( Doc, hPutDoc, packedString, empty, renderPSs ) import Darcs.Global ( atexit, darcsdir ) -import Darcs.Compat ( mk_stdout_temp, canonFilename, maybeRelink, - atomic_create, sloppy_atomic_create ) +import Darcs.Compat ( mkStdoutTemp, canonFilename, maybeRelink, + atomicCreate, sloppyAtomicCreate ) import System.Posix.Files ( getSymbolicLinkStatus, isDirectory, fileMode, getFileStatus, setFileMode ) import System.Posix ( sleep ) @@ -103,7 +104,7 @@ catchNonExistence :: IO a -> a -> IO a catchNonExistence job nonexistval = - catchJust ioErrors job $ + catch job $ \e -> if isDoesNotExistError e then return nonexistval else ioError e @@ -111,27 +112,23 @@ takeLock :: FilePathLike p => p -> IO Bool takeLock fp = - do atomic_create $ toFilePath fp + do atomicCreate $ toFilePath fp return True - `catch` \e -> case e of - IOException e' - | isAlreadyExistsError e' -> - return False - _ -> do pwd <- getCurrentDirectory - throwIO $ add_to_error_loc e - ("takeLock "++toFilePath fp++" in "++toFilePath pwd) + `catch` \e -> if isAlreadyExistsError e + then return False + else do pwd <- getCurrentDirectory + throwIO $ addToErrorLoc e + ("takeLock "++toFilePath fp++" in "++toFilePath pwd) takeFile :: FilePath -> IO Bool takeFile fp = - do sloppy_atomic_create fp + do sloppyAtomicCreate fp return True - `catch` \e -> case e of - IOException e' - | isAlreadyExistsError e' -> - return False - _ -> do pwd <- getCurrentDirectory - throwIO $ add_to_error_loc e - ("takeFile "++fp++" in "++toFilePath pwd) + `catch` \e -> if isAlreadyExistsError e + then return False + else do pwd <- getCurrentDirectory + throwIO $ addToErrorLoc e + ("takeFile "++fp++" in "++toFilePath pwd) -- |'withTemp' safely creates an empty file (not open for writing) and -- returns its name. @@ -151,16 +148,16 @@ -- would reintroduce a race condition). withOpenTemp :: ((Handle, String) -> IO a) -> IO a withOpenTemp = bracket get_empty_file cleanup - where cleanup (h,f) = do try $ hClose h + where cleanup (h,f) = do try (hClose h) :: IO (Either SomeException ()) removeFileMayNotExist f get_empty_file = invert `fmap` openBinaryTempFile "." "darcs" invert (a,b) = (b,a) withStdoutTemp :: (String -> IO a) -> IO a -withStdoutTemp = bracket (mk_stdout_temp "stdout_") removeFileMayNotExist +withStdoutTemp = bracket (mkStdoutTemp "stdout_") removeFileMayNotExist -tempdir_loc :: IO FilePath -tempdir_loc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir, +tempdirLoc :: IO FilePath +tempdirLoc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir, maybeGetEnv "DARCS_TMPDIR" >>= chkdir, getTemporaryDirectory >>= chkdir . Just, getCurrentDirectorySansDarcs, @@ -190,8 +187,8 @@ withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a withDir _ "" _ = bug "withDir called with empty directory name" withDir kind abs_or_relative_name job = do - absolute_name <- if is_relative abs_or_relative_name - then fmap (++ abs_or_relative_name) tempdir_loc + absolute_name <- if isRelative abs_or_relative_name + then fmap (++ abs_or_relative_name) tempdirLoc else return abs_or_relative_name formerdir <- getCurrentDirectory bracket (create_directory absolute_name 0) @@ -199,8 +196,8 @@ k <- keep_tmpdir unless k $ do case kind of Perm -> return () - Temp -> rm_recursive (toFilePath dir) - Delayed -> atexit $ rm_recursive (toFilePath dir)) + Temp -> rmRecursive (toFilePath dir) + Delayed -> atexit $ rmRecursive (toFilePath dir)) job where newname name 0 = name newname name n = name ++ "-" ++ show n @@ -209,11 +206,9 @@ = do createDirectory $ newname name n setCurrentDirectory $ newname name n getCurrentDirectory - `catch` (\e -> case e of - IOException e' - | isAlreadyExistsError e' -> - create_directory name (n+1) - _ -> throwIO e) + `catch` (\e -> if isAlreadyExistsError e + then create_directory name (n+1) + else throwIO e) keep_tmpdir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR" environmentHelpKeepTmpdir :: ([String], [String]) @@ -254,21 +249,21 @@ doesDirectoryReallyExist f = catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False -rm_recursive :: FilePath -> IO () -rm_recursive d = +rmRecursive :: FilePath -> IO () +rmRecursive d = do isd <- doesDirectoryReallyExist d if not isd then removeFile d else when isd $ do conts <- actual_dir_contents withCurrentDirectory d $ - mapM_ rm_recursive conts + mapM_ rmRecursive conts removeDirectory d where actual_dir_contents = -- doesn't include . or .. do c <- getDirectoryContents d return $ filter (/=".") $ filter (/="..") c -world_readable_temp :: String -> IO String -world_readable_temp f = wrt 0 +worldReadableTemp :: String -> IO String +worldReadableTemp f = wrt 0 where wrt :: Int -> IO String wrt 100 = fail $ "Failure creating temp named "++f wrt n = let f_new = f++"-"++show n @@ -278,17 +273,22 @@ withNamedTemp :: String -> (String -> IO a) -> IO a withNamedTemp n = bracket get_empty_file removeFileMayNotExist - where get_empty_file = world_readable_temp n + where get_empty_file = worldReadableTemp n editText :: String -> B.ByteString -> IO B.ByteString editText desc txt = withNamedTemp desc $ \f -> do B.writeFile f txt - run_editor f + runEditor f B.readFile f readBinFile :: FilePathLike p => p -> IO String readBinFile = fmap BC.unpack . B.readFile . toFilePath +-- | Reads a file. Differs from readBinFile in that it interprets the file in +-- the current locale instead of as ISO-8859-1. +readLocaleFile :: FilePathLike p => p -> IO String +readLocaleFile f = decodeLocale `fmap` B.readFile (toFilePath f) + readDocBinFile :: FilePathLike p => p -> IO Doc readDocBinFile fp = do ps <- B.readFile $ toFilePath fp return $ if B.null ps then empty else packedString ps @@ -302,6 +302,11 @@ writeBinFile :: FilePathLike p => p -> String -> IO () writeBinFile f s = writeToFile f $ \h -> hPutStr h s +-- | Writes a file. Differs from writeBinFile in that it writes the string +-- encoded with the current locale instead of what GHC thinks is right. +writeLocaleFile :: FilePathLike p => p -> String -> IO () +writeLocaleFile f s = writeToFile f $ \h -> B.hPut h (encodeLocale s) + writeDocBinFile :: FilePathLike p => p -> Doc -> IO () writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d @@ -335,5 +340,5 @@ renameFile newf (toFilePath f) appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () -appendToFile f job = withSignalsBlocked $ +appendToFile f job = withSignalsBlocked $ bracket (openBinaryFile (toFilePath f) AppendMode) hClose job diff -ruN darcs-2.4.4/src/Darcs/Match.lhs darcs-2.5/src/Darcs/Match.lhs --- darcs-2.4.4/src/Darcs/Match.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Match.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -34,36 +34,38 @@ ) where import Text.Regex ( mkRegex, matchRegex ) -import Control.Monad ( when, unless ) +import Control.Monad ( when ) import Data.Maybe ( isJust ) +import Data.List ( isPrefixOf ) import Darcs.Hopefully ( PatchInfoAnd, info, piap, conscientiously, hopefully ) -import Darcs.Patch.Info ( just_name ) +import Darcs.Patch.Info ( justName ) import Darcs.Patch ( RepoPatch, Patch, Patchy, Named, invert, invertRL, patch2patchinfo, apply ) -import Darcs.Repository ( Repository, PatchSet, SealedPatchSet, read_repo, - slurp_recorded, createPristineDirectoryTree ) -import Darcs.Repository.ApplyPatches ( apply_patches ) -import Darcs.Patch.Depends ( get_patches_in_tag, get_patches_beyond_tag ) +import Darcs.Repository ( Repository, readRepo, createPristineDirectoryTree ) +import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif +import Darcs.Repository.ApplyPatches ( applyPatches ) +import Darcs.Patch.Depends ( getPatchesInTag, getPatchesBeyondTag ) import Darcs.Witnesses.Ordered ( RL(..), concatRL, consRLSealed ) import ByteStringUtils ( mmapFilePS ) -import qualified Data.ByteString as B (ByteString) import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context, AfterPatch, UpToPatch, LastN, PatchIndexRange, OneTag, AfterTag, UpToTag, OnePattern, SeveralPattern, - AfterPattern, UpToPattern ), willStoreInMemory ) -import Darcs.Patch.Bundle ( scan_context ) -import Darcs.Patch.Match ( Matcher, MatchFun, match_pattern, apply_matcher, make_matcher, parseMatch ) + AfterPattern, UpToPattern ) ) +import Darcs.Patch.Bundle ( scanContext ) +import Darcs.Patch.Match ( Matcher, MatchFun, matchPattern, applyMatcher, makeMatcher, parseMatch ) import Darcs.Patch.MatchData ( PatchMatch ) import Printer ( text, ($$) ) import Darcs.RepoPath ( toFilePath ) -import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) ) -import Darcs.SlurpDirectory ( SlurpMonad, writeSlurpy, withSlurpy ) -import Darcs.Patch.FileName ( FileName, superName, norm_path, (///) ) +import Darcs.IO ( WriteableDirectory(..) ) +import Darcs.Patch.FileName ( FileName ) import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..), seal, flipSeal, seal2, unsealFlipped, unseal2, unseal ) #include "impossible.h" @@ -126,15 +128,15 @@ hasC (_:xs) = hasC xs getNonrangeMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO () -getNonrangeMatch r fs = withRecordedMatchSmart fs r (getNonrangeMatchS fs) +getNonrangeMatch r fs = withRecordedMatch r (getNonrangeMatchS fs) getPartialNonrangeMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [FileName] -> IO () -getPartialNonrangeMatch r fs files = - withRecordedMatchOnlySomeSmart fs r files (getNonrangeMatchS fs) +getPartialNonrangeMatch r fs _ = + withRecordedMatch r (getNonrangeMatchS fs) -getNonrangeMatchS :: (MatchMonad m p, RepoPatch p) => - [DarcsFlag] -> PatchSet p C(x) -> m () +getNonrangeMatchS :: (RepoPatch p) => + [DarcsFlag] -> PatchSet p C(Origin x) -> IO () getNonrangeMatchS fs repo = case nonrangeMatcher fs of Just m -> if nonrangeMatcherIsTag fs @@ -151,25 +153,28 @@ || isJust (hasIndexRange fs) getFirstMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO () -getFirstMatch r fs = withRecordedMatchSmart fs r (getFirstMatchS fs) +getFirstMatch r fs = withRecordedMatch r (getFirstMatchS fs) getPartialFirstMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [FileName] -> IO () -getPartialFirstMatch r fs files = - withRecordedMatchOnlySomeSmart fs r files (getFirstMatchS fs) +getPartialFirstMatch r fs _ = + withRecordedMatch r (getFirstMatchS fs) -getFirstMatchS :: (MatchMonad m p, RepoPatch p) => - [DarcsFlag] -> PatchSet p C(x) -> m () +getFirstMatchS :: (RepoPatch p) => + [DarcsFlag] -> PatchSet p C(Origin x) -> IO () getFirstMatchS fs repo = case hasLastn fs of - Just n -> applyInvRL `unsealFlipped` (safetake n $ concatRL repo) - Nothing -> case firstMatcher fs of + Just n -> unpullLastN repo n + Nothing -> + case hasIndexRange fs of + Just (_,b) -> unpullLastN repo b -- b is chronologically earlier than a + Nothing -> + case firstMatcher fs of Nothing -> fail "Pattern not specified in getFirstMatch." Just m -> if firstMatcherIsTag fs then getTagS m repo else getMatcherS Inclusive m repo - -- | @secondMatch fs@ tells whether @fs@ implies a "second match", that -- is if we match against patches up to a point in the past on, rather -- than against all patches until now. @@ -178,14 +183,19 @@ getPartialSecondMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [FileName] -> IO () -getPartialSecondMatch r fs files = - withRecordedMatchOnlySomeSmart fs r files $ \repo -> +getPartialSecondMatch r fs _ = + withRecordedMatch r $ \repo -> case secondMatcher fs of - Nothing -> fail "Two patterns not specified in get_second_match." + Nothing -> case hasIndexRange fs of + Just (a,_) -> unpullLastN repo (a-1) + Nothing -> fail "Two patterns not specified in get_second_match." Just m -> if secondMatcherIsTag fs then getTagS m repo else getMatcherS Exclusive m repo +unpullLastN :: Patchy p => PatchSet p C(x y) -> Int -> IO () +unpullLastN repo n = applyInvRL `unsealFlipped` (safetake n $ newset2RL repo) + checkMatchSyntax :: [DarcsFlag] -> IO () checkMatchSyntax opts = do case getMatchPattern opts of @@ -199,14 +209,14 @@ getMatchPattern (_:fs) = getMatchPattern fs tagmatch :: String -> Matcher p -tagmatch r = make_matcher ("tag-name "++r) tm +tagmatch r = makeMatcher ("tag-name "++r) tm where tm (Sealed2 p) = - let n = just_name (info p) in - take 4 n == "TAG " && isJust (matchRegex (mkRegex r) $ drop 4 n) + let n = justName (info p) in + "TAG " `isPrefixOf` n && isJust (matchRegex (mkRegex r) $ drop 4 n) mymatch :: String -> Matcher p -mymatch r = make_matcher ("patch-name "++r) mm - where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . just_name . info $ p +mymatch r = makeMatcher ("patch-name "++r) mm + where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . justName . info $ p -- | strictJust is a strict version of the Just constructor, used to ensure @@ -232,10 +242,10 @@ -- @--tag@ options are passed (or their plural variants). nonrangeMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) nonrangeMatcher [] = Nothing -nonrangeMatcher (OnePattern m:_) = strictJust $ match_pattern m +nonrangeMatcher (OnePattern m:_) = strictJust $ matchPattern m nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t nonrangeMatcher (OnePatch p:_) = strictJust $ mymatch p -nonrangeMatcher (SeveralPattern m:_) = strictJust $ match_pattern m +nonrangeMatcher (SeveralPattern m:_) = strictJust $ matchPattern m nonrangeMatcher (SeveralPatch p:_) = strictJust $ mymatch p nonrangeMatcher (_:fs) = nonrangeMatcher fs @@ -252,8 +262,8 @@ -- returns @Nothing@. firstMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) firstMatcher [] = Nothing -firstMatcher (OnePattern m:_) = strictJust $ match_pattern m -firstMatcher (AfterPattern m:_) = strictJust $ match_pattern m +firstMatcher (OnePattern m:_) = strictJust $ matchPattern m +firstMatcher (AfterPattern m:_) = strictJust $ matchPattern m firstMatcher (AfterTag t:_) = strictJust $ tagmatch t firstMatcher (OnePatch p:_) = strictJust $ mymatch p firstMatcher (AfterPatch p:_) = strictJust $ mymatch p @@ -266,8 +276,8 @@ secondMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) secondMatcher [] = Nothing -secondMatcher (OnePattern m:_) = strictJust $ match_pattern m -secondMatcher (UpToPattern m:_) = strictJust $ match_pattern m +secondMatcher (OnePattern m:_) = strictJust $ matchPattern m +secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m secondMatcher (OnePatch p:_) = strictJust $ mymatch p secondMatcher (UpToPatch p:_) = strictJust $ mymatch p secondMatcher (UpToTag t:_) = strictJust $ tagmatch t @@ -283,7 +293,7 @@ matchAPatchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool matchAPatchread fs = case nonrangeMatcher fs of Nothing -> const True - Just m -> apply_matcher m + Just m -> applyMatcher m -- | @matchAPatch fs p@ tells whether @p@ matches the matchers in -- the flags @fs@ @@ -291,9 +301,9 @@ matchAPatch fs p = case nonrangeMatcher fs of Nothing -> True - Just m -> apply_matcher m (patch2patchinfo p `piap` p) + Just m -> applyMatcher m (patch2patchinfo p `piap` p) -matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p) +matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> Sealed2 (Named p) matchPatch fs ps = case hasIndexRange fs of Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of @@ -301,22 +311,23 @@ Nothing -> error "Patch out of range!" | otherwise -> bug ("Invalid index range match given to matchPatch: "++ show (PatchIndexRange a a')) - where myhead :: PatchSet p C(x) -> Maybe (Sealed2 (PatchInfoAnd p)) - myhead (NilRL:<:x) = myhead x - myhead ((x:<:_):<:_) = Just $ seal2 x - myhead NilRL = Nothing + where myhead :: PatchSet p C(start x) -> Maybe (Sealed2 (PatchInfoAnd p)) + myhead (PatchSet NilRL (Tagged t _ _ :<: _)) = Just $ seal2 t + myhead (PatchSet (x:<:_) _) = Just $ seal2 x + myhead _ = Nothing Nothing -> case nonrangeMatcher fs of Nothing -> bug "Couldn't matchPatch" Just m -> findAPatch m ps -getOnePatchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p) +getOnePatchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> + IO (SealedPatchSet p C(Origin)) getOnePatchset repository fs = case nonrangeMatcher fs of - Just m -> do ps <- read_repo repository + Just m -> do ps <- readRepo repository if nonrangeMatcherIsTag fs then return $ getMatchingTag m ps else return $ matchAPatchset m ps - Nothing -> (seal . scan_context) `fmap` mmapFilePS (toFilePath $ context_f fs) + Nothing -> (seal . scanContext) `fmap` mmapFilePS (toFilePath $ context_f fs) where context_f [] = bug "Couldn't match_nonrange_patchset" context_f (Context f:_) = f context_f (_:xs) = context_f xs @@ -338,7 +349,8 @@ -- patches in @matchFirstPatchset fs ps@ are the ones we don't want. -- -- Question: are they really? Florent -matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p +matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) + -> SealedPatchSet p C(start) matchFirstPatchset fs patchset = case hasLastn fs of Just n -> dropn n patchset @@ -353,15 +365,16 @@ else matchAPatchset m patchset -- | @dropn n ps@ drops the @n@ last patches from @ps@. -dropn :: Int -> PatchSet p C(x) -> SealedPatchSet p +dropn :: Int -> PatchSet p C(start x) -> SealedPatchSet p C(start) dropn n ps | n <= 0 = seal ps -dropn n (NilRL:<:ps) = dropn n ps -dropn _ NilRL = seal $ NilRL:<:NilRL -dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs +dropn n (PatchSet NilRL (Tagged t _ ps :<: ts)) = dropn n $ PatchSet (t:<:ps) ts +dropn _ (PatchSet NilRL NilRL) = seal $ PatchSet NilRL NilRL +dropn n (PatchSet (_:<:ps) ts) = dropn (n-1) $ PatchSet ps ts -- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its -- second matcher, ie the one that comes last dependencywise. -matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p +matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) + -> SealedPatchSet p C(start) matchSecondPatchset fs ps = case hasIndexRange fs of Just (a,_) -> dropn (a-1) ps @@ -374,82 +387,61 @@ -- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and -- calls 'error' if there is none. -findAPatch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p) -findAPatch m NilRL = error $ "Couldn't find patch matching " ++ show m -findAPatch m (NilRL:<:xs) = findAPatch m xs -findAPatch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p - | otherwise = findAPatch m (ps:<:xs) +findAPatch :: RepoPatch p => Matcher p -> PatchSet p C(start x) -> Sealed2 (Named p) +findAPatch m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m +findAPatch m (PatchSet NilRL (Tagged t _ ps :<: ts)) = findAPatch m (PatchSet (t:<:ps) ts) +findAPatch m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal2 $ hopefully p + | otherwise = findAPatch m (PatchSet ps ts) -- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@ -- ending in patch which matches @m@. Calls 'error' if there is none. -matchAPatchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p -matchAPatchset m NilRL = error $ "Couldn't find patch matching " ++ show m -matchAPatchset m (NilRL:<:xs) = matchAPatchset m xs -matchAPatchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs) - | otherwise = matchAPatchset m (ps:<:xs) +matchAPatchset :: RepoPatch p => Matcher p -> PatchSet p C(start x) + -> SealedPatchSet p C(start) +matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m +matchAPatchset m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchAPatchset m (PatchSet (t:<:ps) ts) +matchAPatchset m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal (PatchSet (p:<:ps) ts) + | otherwise = matchAPatchset m (PatchSet ps ts) -- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags -- returns a 'SealedPatchSet' containing all patches in the last tag which -- matches @m@. Last tag means the most recent tag in repository order, -- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls -- 'error' if there is no matching tag. -getMatchingTag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p -getMatchingTag m NilRL = error $ "Couldn't find a tag matching " ++ show m -getMatchingTag m (NilRL:<:xs) = getMatchingTag m xs -getMatchingTag m xxx@((p:<:ps):<:xs) - | apply_matcher m p = get_patches_in_tag (info p) xxx - | otherwise = getMatchingTag m (ps:<:xs) +getMatchingTag :: RepoPatch p => Matcher p -> PatchSet p C(start x) -> SealedPatchSet p C(start) +getMatchingTag m (PatchSet NilRL NilRL) = error $ "Couldn't find a tag matching " ++ show m +getMatchingTag m (PatchSet NilRL (Tagged t _ ps :<: ts)) = getMatchingTag m (PatchSet (t:<:ps) ts) +getMatchingTag m (PatchSet (p:<:ps) ts) + | applyMatcher m p = seal $ PatchSet (p:<:ps) ts + | otherwise = getMatchingTag m (PatchSet ps ts) -- | @matchExists m ps@ tells whether there is a patch matching -- @m@ in @ps@ -matchExists :: Matcher p -> PatchSet p C(x) -> Bool -matchExists _ NilRL = False -matchExists m (NilRL:<:xs) = matchExists m xs -matchExists m ((p:<:ps):<:xs) | apply_matcher m $ p = True - | otherwise = matchExists m (ps:<:xs) - -applyInvToMatcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m () -applyInvToMatcher _ _ NilRL = impossible -applyInvToMatcher ioe m (NilRL:<:xs) = applyInvToMatcher ioe m xs -applyInvToMatcher ioe m ((p:<:ps):<:xs) - | apply_matcher m p = when (ioe == Inclusive) (applyInvp p) - | otherwise = applyInvp p >> applyInvToMatcher ioe m (ps:<:xs) - --- | @maybeReadFile@ recursively gets the contents of all files --- in a directory, or just the contents of a file if called on a --- simple file. -maybeReadFile :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)]) -maybeReadFile file = do - d <- mDoesDirectoryExist file - if d - then do - children <- mInCurrentDirectory file mGetDirectoryContents - maybe_read_files [file /// ch | ch <- children] - else do - e <- mDoesFileExist file - if e - then do - contents <- mReadFilePS file - return [(norm_path file, contents)] - else return [] - where maybe_read_files [] = return [] - maybe_read_files (f:fs) = do - x <- maybeReadFile f - y <- maybe_read_files fs - return $ concat [x,y] +matchExists :: Matcher p -> PatchSet p C(start x) -> Bool +matchExists _ (PatchSet NilRL NilRL) = False +matchExists m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchExists m (PatchSet (t:<:ps) ts) +matchExists m (PatchSet (p:<:ps) ts) | applyMatcher m $ p = True + | otherwise = matchExists m (PatchSet ps ts) + +applyInvToMatcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(Origin x) -> m () +applyInvToMatcher _ _ (PatchSet NilRL NilRL) = impossible +applyInvToMatcher ioe m (PatchSet NilRL (Tagged t _ ps :<: ts)) = applyInvToMatcher ioe m + (PatchSet (t:<:ps) ts) +applyInvToMatcher ioe m (PatchSet (p:<:ps) xs) + | applyMatcher m p = when (ioe == Inclusive) (applyInvp p) + | otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet ps xs) -getMatcherS :: (MatchMonad m p, RepoPatch p) => - InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m () +getMatcherS :: (WriteableDirectory m, RepoPatch p) => + InclusiveOrExclusive -> Matcher p -> PatchSet p C(Origin x) -> m () getMatcherS ioe m repo = if matchExists m repo then applyInvToMatcher ioe m repo else fail $ "Couldn't match pattern "++ show m -getTagS :: (MatchMonad m p, RepoPatch p) => - Matcher p -> PatchSet p C(x) -> m () +getTagS :: (RepoPatch p) => + Matcher p -> PatchSet p C(Origin x) -> IO () getTagS match repo = do let pinfo = patch2patchinfo `unseal2` (findAPatch match repo) - case get_patches_beyond_tag pinfo repo of + case getPatchesBeyondTag pinfo repo of FlippedSeal extras -> applyInvRL extras -- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd @@ -471,96 +463,11 @@ safetake _ NilRL = error "There aren't that many patches..." safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as --- | A @MatchMonad p m@ is a monad in which we match patches from @p@ --- by playing with them in @m@, a 'WriteableDirectory' monad. How we --- play with the patches depends on the instance of @MatchMonad@ we're --- using. If we use @IO@, then we'll apply the patches directly in --- @m@, if we use @SlurpMonad@, then we'll apply the patches to a --- slurpy, and write to disk at the end. Note that both @IO@ and --- @SlurpMonad@ have an instance of 'WriteableDirectory' that --- implicitely writes in the current directory. -class (RepoPatch p, WriteableDirectory m) => MatchMonad m p where - withRecordedMatch :: Repository p C(r u t) - -> (PatchSet p C(r) -> m ()) -> IO () - -- ^ @withRecordedMatch@ is responsible for getting the recorded state - -- into the monad, and then applying the second argument, and - -- finally placing the resulting state into the current directory. - withRecordedMatchOnlySomeFiles - :: Repository p C(r u t) -> [FileName] - -> (PatchSet p C(r) -> m ()) -> IO () - -- ^ @withRecordedMatchOnlySomeFiles@ is a variant of - -- withRecordedMatch that may only return some of the files - -- (e.g. if we want to run diff on just a few files). - withRecordedMatchOnlySomeFiles r _ j = withRecordedMatch r j - applyInvRL :: RL (PatchInfoAnd p) C(x r) -> m () - applyInvRL NilRL = return () - applyInvRL (p:<:ps) = applyInvp p >> applyInvRL ps - -withRecordedMatchIO :: RepoPatch p => Repository p C(r u t) - -> (PatchSet p C(r) -> IO ()) -> IO () -withRecordedMatchIO = withRecordedMatch - --- | @withRecordedMatchSmart@ hides away the choice of the --- 'SlurpMonad' to use in order to apply 'withRecordedMatch'. --- If we have the @--store-in-memory@ flag, then use 'SlurpMonad', else --- use @IO@. In both case, the result is in the @IO@ monad. --- --- Suggestion: shouldn't we name @withRecordedMatchSmart@ --- @withRecordedMatch@, and give the monad function another name such --- as @withRecordedMatchRaw@? -withRecordedMatchSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) - -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ()) - -> IO () -withRecordedMatchSmart opts r j = - do if willStoreInMemory opts then withSM r j - else withRecordedMatchIO r j - where withSM :: RepoPatch p => Repository p C(r u t) - -> (PatchSet p C(r) -> SlurpMonad ()) -> IO () - withSM = withRecordedMatch - --- | @withRecordedMatchOnlySomeSmart@ is the smart version of --- 'withRecordedMatchOnlySome'. It runs 'withRecordedMatchOnlySome' --- either in the 'SlurpMonad' or in @IO@ according to the --- @--store-in-memory@ flag. -withRecordedMatchOnlySomeSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) - -> [FileName] - -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ()) - -> IO () -withRecordedMatchOnlySomeSmart opts r [] j = withRecordedMatchSmart opts r j -withRecordedMatchOnlySomeSmart opts r files j = - do if willStoreInMemory opts then withSM r files j - else withIO r files j - where withSM :: RepoPatch p => Repository p C(r u t) -> [FileName] - -> (PatchSet p C(r) -> SlurpMonad ()) -> IO () - withSM = withRecordedMatchOnlySomeFiles - withIO :: RepoPatch p => Repository p C(r u t) -> [FileName] - -> (PatchSet p C(r) -> IO ()) -> IO () - withIO = withRecordedMatchOnlySomeFiles - -instance RepoPatch p => MatchMonad IO p where - withRecordedMatch r job = do createPristineDirectoryTree r "." - read_repo r >>= job - applyInvRL = apply_patches [] . invertRL -- this gives nicer feedback - -instance RepoPatch p => MatchMonad SlurpMonad p where - withRecordedMatch r job = - do ps <- read_repo r - s <- slurp_recorded r - case withSlurpy s (job ps) of - Left err -> fail err - Right (s',_) -> writeSlurpy s' "." - withRecordedMatchOnlySomeFiles r fs job = - do ps <- read_repo r - s <- slurp_recorded r - case withSlurpy s (job ps >> mapM maybeReadFile fs) of - Left err -> fail err - Right (_,fcs) -> mapM_ createAFile $ concat fcs - where createAFile (p,c) = do ensureDirectories $ superName p - mWriteFilePS p c - ensureDirectories d = - do isPar <- mDoesDirectoryExist d - unless isPar $ do - ensureDirectories $ superName d - mCreateDirectory d +withRecordedMatch :: RepoPatch p => Repository p C(r u t) + -> (PatchSet p C(Origin r) -> IO ()) -> IO () +withRecordedMatch r job = do createPristineDirectoryTree r "." + readRepo r >>= job +applyInvRL :: (Patchy p) => RL (PatchInfoAnd p) C(x r) -> IO () +applyInvRL = applyPatches [] . invertRL -- this gives nicer feedback \end{code} diff -ruN darcs-2.4.4/src/Darcs/Patch/Apply.lhs darcs-2.5/src/Darcs/Patch/Apply.lhs --- darcs-2.4.4/src/Darcs/Patch/Apply.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Apply.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -22,14 +22,13 @@ #include "gadts.h" -module Darcs.Patch.Apply ( applyToFilepaths, applyToSlurpy, +module Darcs.Patch.Apply ( applyToFilepaths, forceTokReplace, markupFile, emptyMarkedupFile, patchChanges, applyToPop, applyToTree, - LineMark(..), MarkedUpFile, - forceReplaceSlurpy ) + LineMark(..), MarkedUpFile ) where import Prelude hiding ( catch, pi ) @@ -38,7 +37,7 @@ import qualified Data.ByteString.Char8 as BC (split, break, pack, singleton) import qualified Data.ByteString as B (ByteString, null, empty, concat, isPrefixOf) -import ByteStringUtils ( linesPS, unlinesPS, break_after_nth_newline, break_before_nth_newline, ) +import ByteStringUtils ( linesPS, unlinesPS, breakAfterNthNewline, breakBeforeNthNewline, ) import Darcs.Patch.FileName ( fn2ps, fn2fp, fp2fn, movedirfilename ) @@ -51,10 +50,9 @@ import Darcs.Patch.Core ( Patch(..), Named(..) ) import Darcs.Patch.Prim ( Prim(..), Effect(effect), DirPatchType(..), FilePatchType(..), - try_tok_internal ) + tryTokInternal, showHunk, FileNameFormat(..) ) import Darcs.Patch.Info ( PatchInfo ) import Control.Monad ( when ) -import Darcs.SlurpDirectory ( FileContents, Slurpy, withSlurpy, slurp_modfile ) import Darcs.Patch.RegChars ( regChars ) import Darcs.Repository.Prefs ( changePrefval ) import Darcs.Global ( darcsdir ) @@ -66,6 +64,9 @@ import Storage.Hashed.Tree( Tree ) import Storage.Hashed.Monad( virtualTreeIO ) +import Printer( renderString ) + +type FileContents = B.ByteString \end{code} @@ -114,11 +115,6 @@ applyToFilepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath] applyToFilepaths pa fs = withFilePaths fs (apply [] pa) -applyToSlurpy :: (Apply p, Monad m) => p C(x y) -> Slurpy -> m Slurpy -applyToSlurpy p s = case withSlurpy s (apply [] p) of - Left err -> fail err - Right (s', ()) -> return s' - instance Apply p => Apply (Named p) where apply opts (NamedP _ _ p) = apply opts p applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p @@ -131,11 +127,6 @@ applyAndTryToFix (ComP xs) = mapMaybeSnd ComP `fmap` applyAndTryToFix xs applyAndTryToFix x = do mapMaybeSnd ComP `fmap` applyAndTryToFixFL x -forceReplaceSlurpy :: Prim C(x y) -> Slurpy -> Maybe Slurpy -forceReplaceSlurpy (FP f (TokReplace tcs old new)) s = - slurp_modfile f (forceTokReplace tcs old new) s -forceReplaceSlurpy _ _ = bug "Can only forceReplaceSlurpy on a replace." - instance Apply Prim where apply opts (Split ps) = applyFL opts ps apply _ Identity = return () @@ -144,7 +135,7 @@ apply opts p@(FP _ (Hunk _ _ _)) = applyFL opts (p :>: NilFL) apply _ (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace where doreplace ls = - case mapM (try_tok_internal t (BC.pack o) (BC.pack n)) ls of + case mapM (tryTokInternal t (BC.pack o) (BC.pack n)) ls of Nothing -> fail $ "replace patch to " ++ fn2fp f ++ " couldn't apply." Just ls' -> return $ map B.concat ls' @@ -190,7 +181,9 @@ hunkmod (Hunk line old new:>:hs) ps = case applyHunkLines [(line,old,new)] ps of Just ps' -> hunkmod hs ps' - Nothing -> fail $ "Error applying hunk to file " ++ fn2fp f + Nothing -> fail $ "Error applying hunk " ++ + (renderString $ showHunk NewFormat f line old new) ++ + " to file " ++ fn2fp f ++ ": " ++ show ps hunkmod _ _ = impossible applyFL opts (p:>:ps) = do apply opts p applyFL opts ps @@ -206,14 +199,14 @@ -> B.ByteString -> Maybe [B.ByteString] applyHunks [] ps = Just [ps] applyHunks ((l, [], n):hs) ps - = case break_before_nth_newline (l - 2) ps of + = case breakBeforeNthNewline (l - 2) ps of (prfix, after_prefix) -> do rest <- applyHunks hs after_prefix return $ intersperse nl (prfix:n) ++ rest where nl = BC.singleton '\n' applyHunks ((l, o, n):hs) ps - = case break_before_nth_newline (l - 2) ps of + = case breakBeforeNthNewline (l - 2) ps of (prfix, after_prefix) -> - case break_before_nth_newline (length o) after_prefix of + case breakBeforeNthNewline (length o) after_prefix of (oo, _) | oo /= unlinesPS (B.empty:o) -> fail "applyHunks error" (_, suffix) -> do rest <- applyHunks hs suffix @@ -226,7 +219,7 @@ applyHunkLines [(1, [], n)] ps | B.null ps = Just $ unlinesPS (n++[B.empty]) applyHunkLines hs@((l, o, n):hs') ps = do pss <- case l of - 1 -> case break_after_nth_newline (length o) ps of + 1 -> case breakAfterNthNewline (length o) ps of Nothing -> if ps == unlinesPS o then return $ intersperse nl n else fail "applyHunkLines: Unexpected hunks" @@ -308,64 +301,64 @@ markupFile x p = mps (effect p) where mps :: FL Prim C(a b) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) mps NilFL = id - mps (pp:>:pps) = mps pps . markup_prim x pp + mps (pp:>:pps) = mps pps . markupPrim x pp -markup_prim :: PatchInfo -> Prim C(x y) +markupPrim :: PatchInfo -> Prim C(x y) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) -markup_prim _ (Split NilFL) (f, mk) = (f, mk) -markup_prim n (Split (p:>:ps)) (f, mk) = markup_prim n (Split ps) $ - markup_prim n p (f, mk) -markup_prim _ (FP _ AddFile) (f, mk) = (f, mk) -markup_prim _ (FP _ RmFile) (f, mk) = (f, mk) -markup_prim n (FP f' (Hunk line old new)) (f, mk) +markupPrim _ (Split NilFL) (f, mk) = (f, mk) +markupPrim n (Split (p:>:ps)) (f, mk) = markupPrim n (Split ps) $ + markupPrim n p (f, mk) +markupPrim _ (FP _ AddFile) (f, mk) = (f, mk) +markupPrim _ (FP _ RmFile) (f, mk) = (f, mk) +markupPrim n (FP f' (Hunk line old new)) (f, mk) | fn2fp f' /= f = (f, mk) - | otherwise = (f, markup_hunk n line old new mk) -markup_prim name (FP f' (TokReplace t o n)) (f, mk) + | otherwise = (f, markupHunk n line old new mk) +markupPrim name (FP f' (TokReplace t o n)) (f, mk) | fn2fp f' /= f = (f, mk) - | otherwise = (f, markup_tok name t o n mk) -markup_prim _ (DP _ _) (f, mk) = (f, mk) -markup_prim _ (Move d d') (f, mk) = (fn2fp $ movedirfilename d d' (fp2fn f), mk) -markup_prim _ (ChangePref _ _ _) (f,mk) = (f,mk) -markup_prim _ Identity (f,mk) = (f,mk) -markup_prim n (FP f' (Binary _ _)) (f,mk) + | otherwise = (f, markupTok name t o n mk) +markupPrim _ (DP _ _) (f, mk) = (f, mk) +markupPrim _ (Move d d') (f, mk) = (fn2fp $ movedirfilename d d' (fp2fn f), mk) +markupPrim _ (ChangePref _ _ _) (f,mk) = (f,mk) +markupPrim _ Identity (f,mk) = (f,mk) +markupPrim n (FP f' (Binary _ _)) (f,mk) | fn2fp f' == f = (f,(BC.pack "Binary file", AddedLine n):mk) | otherwise = (f,mk) -markup_hunk :: PatchInfo -> Int -> [B.ByteString] -> [B.ByteString] +markupHunk :: PatchInfo -> Int -> [B.ByteString] -> [B.ByteString] -> MarkedUpFile -> MarkedUpFile -markup_hunk n l old new ((sf, RemovedLine pi):mk) = - (sf, RemovedLine pi) : markup_hunk n l old new mk -markup_hunk n l old new ((sf, AddedRemovedLine po pn):mk) = - (sf, AddedRemovedLine po pn) : markup_hunk n l old new mk - -markup_hunk name 1 old (n:ns) mk = - (n, AddedLine name) : markup_hunk name 1 old ns mk -markup_hunk n 1 (o:os) [] ((sf, None):mk) - | o == sf = (sf, RemovedLine n) : markup_hunk n 1 os [] mk +markupHunk n l old new ((sf, RemovedLine pi):mk) = + (sf, RemovedLine pi) : markupHunk n l old new mk +markupHunk n l old new ((sf, AddedRemovedLine po pn):mk) = + (sf, AddedRemovedLine po pn) : markupHunk n l old new mk + +markupHunk name 1 old (n:ns) mk = + (n, AddedLine name) : markupHunk name 1 old ns mk +markupHunk n 1 (o:os) [] ((sf, None):mk) + | o == sf = (sf, RemovedLine n) : markupHunk n 1 os [] mk | otherwise = [(BC.pack "Error in patch application", AddedLine n)] -markup_hunk n 1 (o:os) [] ((sf, AddedLine nold):mk) - | o == sf = (sf, AddedRemovedLine nold n) : markup_hunk n 1 os [] mk +markupHunk n 1 (o:os) [] ((sf, AddedLine nold):mk) + | o == sf = (sf, AddedRemovedLine nold n) : markupHunk n 1 os [] mk | otherwise = [(BC.pack "Error in patch application", AddedLine n)] -markup_hunk _ 1 [] [] mk = mk +markupHunk _ 1 [] [] mk = mk -markup_hunk n l old new ((sf, AddedLine pi):mk) - | l > 1 = (sf, AddedLine pi) : markup_hunk n (l-1) old new mk - | l < 1 = (sf, AddedLine pi) : markup_hunk n (l-1) old new mk -markup_hunk n l old new ((sf, None):mk) - | l > 1 = (sf, None) : markup_hunk n (l-1) old new mk - | l < 1 = (sf, None) : markup_hunk n (l-1) old new mk +markupHunk n l old new ((sf, AddedLine pi):mk) + | l > 1 = (sf, AddedLine pi) : markupHunk n (l-1) old new mk + | l < 1 = (sf, AddedLine pi) : markupHunk n (l-1) old new mk +markupHunk n l old new ((sf, None):mk) + | l > 1 = (sf, None) : markupHunk n (l-1) old new mk + | l < 1 = (sf, None) : markupHunk n (l-1) old new mk -markup_hunk _ _ _ _ [] = [] +markupHunk _ _ _ _ [] = [] -markup_hunk _ _ _ _ mk = (BC.pack "Error: ",None) : mk +markupHunk _ _ _ _ mk = (BC.pack "Error: ",None) : mk -markup_tok :: PatchInfo -> String -> String -> String +markupTok :: PatchInfo -> String -> String -> String -> MarkedUpFile -> MarkedUpFile -markup_tok name t ostr nstr mk = concatMap mt mk +markupTok name t ostr nstr mk = concatMap mt mk where o = BC.pack ostr n = BC.pack nstr mt (sf, AddedLine pi) = - case B.concat `fmap` try_tok_internal t o n sf of + case B.concat `fmap` tryTokInternal t o n sf of Just sf' | sf' == sf -> [(sf, AddedLine pi)] | otherwise -> [(sf, AddedRemovedLine pi name), (sf', AddedLine name)] @@ -404,7 +397,7 @@ \begin{code} applyToPop :: PatchInfo -> FL Prim C(x y) -> Population -> Population applyToPop _ NilFL = id -applyToPop pinf (p:>:ps) = applyToPop pinf ps . applyToPop' pinf p +applyToPop pinf (p:>:ps) = applyToPop pinf ps . applyToPop' pinf p applyToPop' :: PatchInfo -> Prim C(x y) -> Population -> Population diff -ruN darcs-2.4.4/src/Darcs/Patch/Bundle.hs darcs-2.5/src/Darcs/Patch/Bundle.hs --- darcs-2.4.4/src/Darcs/Patch/Bundle.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Bundle.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,19 +20,25 @@ #include "gadts.h" -module Darcs.Patch.Bundle ( hash_bundle, make_bundle, make_bundle2, scan_bundle, - make_context, scan_context, +module Darcs.Patch.Bundle ( hashBundle, makeBundle, makeBundle2, makeBundleN, scanBundle, + contextPatches, scanContext, patchFilename ) where -import Darcs.Flags ( DarcsFlag, isUnified ) +import Data.Char ( isAlpha, toLower, isDigit, isSpace ) import Darcs.Hopefully ( PatchInfoAnd, piap, patchInfoAndPatch, unavailable, hopefully ) import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatch ) -import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly, is_tag ) -import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, humanFriendly, isTag ) +import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet ) +import Darcs.Patch.Depends ( slightlyOptimizePatchset ) +import Darcs.Hopefully( info ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif +import Darcs.Witnesses.Sealed ( flipSeal, FlippedSeal(..) ) import Darcs.Witnesses.Ordered ( RL(..), FL(..), unsafeCoerceP, - reverseFL, (+<+), mapFL, mapFL_FL ) + reverseFL, (+<+), mapFL, mapFL_FL, mapRL ) import Printer ( Doc, renderPS, newline, text, ($$), (<>), vcat, vsep, renderString ) @@ -46,24 +52,32 @@ import Storage.Hashed.Tree( Tree ) import Storage.Hashed.Monad( virtualTreeIO ) -hash_bundle :: RepoPatch p => [PatchInfo] -> FL (Named p) C(x y) -> String -hash_bundle _ to_be_sent = sha1PS $ renderPS +hashBundle :: RepoPatch p => [PatchInfo] -> FL (Named p) C(x y) -> String +hashBundle _ to_be_sent = sha1PS $ renderPS $ vcat (mapFL showPatch to_be_sent) <> newline -make_bundle :: RepoPatch p => [DarcsFlag] -> Tree IO -> [PatchInfo] -> FL (Named p) C(x y) -> IO Doc -make_bundle opts the_s common to_be_sent = make_bundle2 opts the_s common to_be_sent to_be_sent +makeBundleN :: RepoPatch p => Maybe (Tree IO) + -> PatchSet p C(start x) -> FL (Named p) C(x y) -> IO Doc +makeBundleN the_s (PatchSet ps (Tagged t _ _ :<: _)) to_be_sent = + makeBundle2 the_s (ps +<+ (t :<: NilRL)) to_be_sent to_be_sent +makeBundleN the_s (PatchSet ps NilRL) to_be_sent = + makeBundle2 the_s ps to_be_sent to_be_sent + +makeBundle :: RepoPatch p => Maybe (Tree IO) -> RL (PatchInfoAnd p) C(start x) + -> FL (Named p) C(x y) -> IO Doc +makeBundle the_s common to_be_sent = makeBundle2 the_s common to_be_sent to_be_sent --- | In make_bundle2, it is presumed that the two patch sequences are +-- | In makeBundle2, it is presumed that the two patch sequences are -- identical, but that they may be lazily generated. If two different -- patch sequences are passed, a bundle with a mismatched hash will be -- generated, which is not the end of the world, but isn't very useful -- either. -make_bundle2 :: RepoPatch p => [DarcsFlag] -> Tree IO -> [PatchInfo] +makeBundle2 :: RepoPatch p => Maybe (Tree IO) -> RL (PatchInfoAnd p) C(start x) -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> IO Doc -make_bundle2 opts the_s common to_be_sent to_be_sent2 = - do patches <- case (isUnified opts) of - True -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) the_s - False -> return (vsep $ mapFL showPatch to_be_sent) +makeBundle2 the_s common' to_be_sent to_be_sent2 = + do patches <- case the_s of + Just tree -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) tree + Nothing -> return (vsep $ mapFL showPatch to_be_sent) return $ format patches where format the_new = text "" $$ text "New patches:" @@ -74,26 +88,27 @@ $$ text "" $$ (vcat $ map showPatchInfo common) $$ text "Patch bundle hash:" - $$ text (hash_bundle common to_be_sent2) + $$ text (hashBundle common to_be_sent2) $$ text "" + common = mapRL info common' -scan_bundle :: RepoPatch p => B.ByteString -> Either String (SealedPatchSet p) -scan_bundle ps +scanBundle :: RepoPatch p => B.ByteString -> Either String (SealedPatchSet p C(Origin)) +scanBundle ps | B.null ps = Left "Bad patch bundle!" | otherwise = - case silly_lex ps of + case sillyLex ps of ("New patches:",rest) -> - case get_patches rest of + case getPatches rest of (Sealed patches, rest') -> - case silly_lex rest' of + case sillyLex rest' of ("Context:", rest'') -> case getContext rest'' of (cont,maybe_hash) -> case substrPS (BC.pack "Patch bundle hash:") maybe_hash of Just n -> - if hash_bundle cont (mapFL_FL hopefully patches) - == fst (silly_lex $ snd $ silly_lex $ + if hashBundle cont (mapFL_FL hopefully patches) + == fst (sillyLex $ snd $ sillyLex $ B.drop n maybe_hash) then seal_up_patches patches cont else Left $ @@ -107,37 +122,33 @@ ("Context:",rest) -> case getContext rest of (cont, rest') -> - case silly_lex rest' of + case sillyLex rest' of ("New patches:", rest'') -> - case parse_patches rest'' of + case parsePatches rest'' of Sealed ps'' -> seal_up_patches ps'' cont (a,_) -> Left $ "Malformed patch bundle: '" ++ a ++ "' is not 'New patches:'" ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> - scan_bundle $ filter_gpg_dashes rest - (_,rest) -> scan_bundle rest + scanBundle $ filterGpgDashes rest + (_,rest) -> scanBundle rest where seal_up_patches :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> [PatchInfo] - -> Either String (SealedPatchSet p) + -> Either String (SealedPatchSet p C(Origin)) seal_up_patches xxx yyy = case reverse yyy of - (x:_) | is_tag x -> - Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy) - :<: NilRL) - -- The above NilRL isn't quite - -- right, because ther *are* - -- earlier patches, but we - -- can't set this to undefined - -- because there are - -- situations where we look at - -- the rest. :{ - - -- bug "No more patches in patch bundle!") - _ -> Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy) - :<: NilRL) - --- filter_gpg_dashes is needed because clearsigned patches escape dashes: -filter_gpg_dashes :: B.ByteString -> B.ByteString -filter_gpg_dashes ps = + (x:ry) | isTag x -> + Right $ Sealed (PatchSet + (reverseFL xxx +<+ unavailablePatches (reverse ry)) + (Tagged (piUnavailable x) Nothing NilRL :<: NilRL)) + _ -> Right $ Sealed (PatchSet (reverseFL xxx +<+ unavailablePatches yyy) + NilRL) + -- The above NilRLs aren't quite right, because ther *are* + -- earlier patches, but we can't set this to undefined + -- because there are situations where we look at the rest. + -- :{ + +-- filterGpgDashes is needed because clearsigned patches escape dashes: +filterGpgDashes :: B.ByteString -> B.ByteString +filterGpgDashes ps = unlinesPS $ map drop_dashes $ takeWhile (/= BC.pack "-----END PGP SIGNED MESSAGE-----") $ dropWhile not_context_or_newpatches $ linesPS ps @@ -148,14 +159,14 @@ not_context_or_newpatches s = (s /= BC.pack "Context:") && (s /= BC.pack "New patches:") -unavailable_patches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) C(x y) -unavailable_patches [] = unsafeCoerceP NilRL -unavailable_patches (x:xs) = pi_unavailable x :<: unavailable_patches xs +unavailablePatches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) C(x y) +unavailablePatches [] = unsafeCoerceP NilRL +unavailablePatches (x:xs) = piUnavailable x :<: unavailablePatches xs -pi_unavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p C(x y) -pi_unavailable i = (i `patchInfoAndPatch` +piUnavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p C(x y) +piUnavailable i = (i `patchInfoAndPatch` unavailable ("Patch not stored in patch bundle:\n" ++ - renderString (human_friendly i))) + renderString (humanFriendly i))) getContext :: B.ByteString -> ([PatchInfo],B.ByteString) getContext ps = case readPatchInfo ps of @@ -165,50 +176,61 @@ Nothing -> ([],ps) (-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b) p -:- (Sealed ps, r) = (Sealed (p:>:ps), r) -get_patches :: RepoPatch p => B.ByteString -> (Sealed (FL (PatchInfoAnd p) C(x)), B.ByteString) -get_patches ps = +getPatches :: RepoPatch p => B.ByteString -> (Sealed (FL (PatchInfoAnd p) C(x)), B.ByteString) +getPatches ps = case readPatchInfo ps of Nothing -> (Sealed NilFL, ps) Just (pinfo,_) -> case readPatch ps of Nothing -> (Sealed NilFL, ps) - Just (Sealed p, r) -> (pinfo `piap` p) -:- get_patches r -parse_patches :: RepoPatch p => B.ByteString -> Sealed (FL (PatchInfoAnd p) C(x)) -parse_patches ps = + Just (Sealed p, r) -> (pinfo `piap` p) -:- getPatches r +parsePatches :: RepoPatch p => B.ByteString -> Sealed (FL (PatchInfoAnd p) C(x)) +parsePatches ps = case readPatchInfo ps of Nothing -> Sealed NilFL Just (pinfo,_) -> case readPatch ps of Nothing -> Sealed NilFL - Just (Sealed p, r) -> ((pinfo `piap` p) :>:) `mapSeal` parse_patches r + Just (Sealed p, r) -> ((pinfo `piap` p) :>:) `mapSeal` parsePatches r -silly_lex :: B.ByteString -> (String, B.ByteString) -silly_lex ps = (BC.unpack a, b) +sillyLex :: B.ByteString -> (String, B.ByteString) +sillyLex ps = (BC.unpack a, b) where (a, b) = BC.break (== '\n') (dropSpace ps) {- -silly_lex ps = (BC.unpack $ BC.takeWhile (/='\n') ps', BC.dropWhile (/='\n') ps') +sillyLex ps = (BC.unpack $ BC.takeWhile (/='\n') ps', BC.dropWhile (/='\n') ps') where ps' = dropSpace ps -} -make_context :: [PatchInfo] -> Doc -make_context common = - text "" - $$ text "Context:" - $$ text "" - $$ (vcat $ map showPatchInfo $ common) - $$ text "" -scan_context :: RepoPatch p => B.ByteString -> PatchSet p C(x) -scan_context ps +contextPatches :: RepoPatch p => PatchSet p C(Origin x) -> FlippedSeal (RL (PatchInfoAnd p)) C(x) +contextPatches set = case slightlyOptimizePatchset set of + PatchSet ps (Tagged t _ _ :<: _) -> flipSeal (ps +<+ (t :<: NilRL)) + PatchSet ps NilRL -> flipSeal ps + +-- are the type witnesses sensible? +scanContext :: RepoPatch p => B.ByteString -> PatchSet p C(Origin x) +scanContext ps | B.null ps = error "Bad context!" | otherwise = - case silly_lex ps of + case sillyLex ps of ("Context:",rest) -> case getContext rest of - (cont, _) -> unavailable_patches cont :<: NilRL + (cont@(_:_), _) | isTag (last cont) -> + PatchSet (unavailablePatches $ init cont) + (Tagged (piUnavailable $ last cont) Nothing NilRL :<: NilRL) + (cont, _) -> PatchSet (unavailablePatches cont) NilRL ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> - scan_context $ filter_gpg_dashes rest - (_,rest) -> scan_context rest + scanContext $ filterGpgDashes rest + (_,rest) -> scanContext rest + + +patchFilename :: String -> String +patchFilename the_summary = name ++ ".dpatch" + where name = map safeFileChar the_summary + safeFileChar c | isAlpha c = toLower c + | isDigit c = c + | isSpace c = '-' + safeFileChar _ = '_' diff -ruN darcs-2.4.4/src/Darcs/Patch/Choices.hs darcs-2.5/src/Darcs/Patch/Choices.hs --- darcs-2.4.4/src/Darcs/Patch/Choices.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Choices.hs 2010-10-24 08:29:26.000000000 -0700 @@ -33,40 +33,50 @@ -- the "last" group, which also means that any patches that depend on it -- must be in the "last" group. -- --- Internally, a PatchChoices doesn't actually reorder the patches until it is --- asked for the final output (e.g. by 'get_first_choice'). Instead, each --- patch is placed in a state of definitely first, definitely last and --- undecided; undecided leans towards "middle". In case you're wondering --- about the first-middle-last language, it's because in some cases the --- "yes" answers will be last (as is the case for the revert command), and --- in others first (as in record, pull and push). +-- Internally, a PatchChoices doesn't always reorder the patches until +-- it is asked for the final output (e.g. by 'get_first_choice'). +-- Instead, each patch is placed in a state of definitely first, +-- definitely last and undecided; undecided leans towards +-- "middle". The patches that are first are commuted to the head +-- immediately, but patches that are middle and last are mixed +-- together. In case you're wondering about the first-middle-last +-- language, it's because in some cases the "yes" answers will be last +-- (as is the case for the revert command), and in others first (as in +-- record, pull and push). +-- +-- Some patch marked "middle" may in fact be unselectable because of +-- dependencies: when a patch is marked "last", its dependencies are +-- not updated until patchSlot is called on them. module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps, patchChoicesTpsSub, - patchSlot, - getChoices, + patchSlot, patchSlot', + getChoices, refineChoices, separateFirstMiddleFromLast, separateFirstFromMiddleLast, forceFirst, forceFirsts, forceLast, forceLasts, forceMatchingFirst, forceMatchingLast, selectAllMiddles, - makeUncertain, makeEverythingLater, + makeUncertain, makeEverythingLater, makeEverythingSooner, TaggedPatch, Tag, tag, tpPatch, Slot(..), - substitute, + substitute ) where -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef ( newIORef, writeIORef, readIORef ) +import Control.Monad.State( State(..) ) + import Darcs.Patch -import Darcs.Patch.Permutations ( commuteWhatWeCanRL ) +import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL ) import Darcs.Patch.Patchy ( Invert, Commute ) import Darcs.Witnesses.Ordered ( FL(..), RL(..), MyEq, unsafeCompare, EqCheck(..), (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..), - zipWithFL, mapFL_FL, mapFL, concatFL, - (+>+), reverseRL, unsafeCoerceP ) + zipWithFL, mapFL_FL, concatFL, + (+>+), reverseRL, unsafeCoerceP, anyFL ) import Darcs.Witnesses.Sealed ( Sealed2(..) ) +#include "impossible.h" + + -- | 'TG' @mp i@ acts as a temporary identifier to help us keep track of patches -- during the selection process. These are useful for finding patches that -- may have moved around during patch selection (being pushed forwards or @@ -82,20 +92,18 @@ data Tag = TG (Maybe Tag) Integer deriving ( Eq, Ord ) data TaggedPatch p C(x y) = TP Tag (p C(x y)) -data PatchChoice p C(x y) = PC (TaggedPatch p C(x y)) Slot -newtype PatchChoices p C(x y) = PCs (FL (PatchChoice p) C(x y)) +-- | The @Bool@ parameter indicates whether the patch has been explicitely +-- selected (or rejected) by the user. +data PatchChoice p C(x y) = PC { pcPatch :: (TaggedPatch p C(x y)) + , choice :: Bool} + +data PatchChoices p C(x y) where + PCs { firsts :: FL (TaggedPatch p) C(x m) + , lasts :: FL (PatchChoice p) C(m y)} :: PatchChoices p C(x y) -- | See module documentation for 'Darcs.Patch.Choices' data Slot = InFirst | InMiddle | InLast -negTag :: Tag -> Tag -negTag (TG k n) = TG k (-n) - -invertTag :: Slot -> Slot -invertTag InFirst = InLast -invertTag InLast = InFirst -invertTag t = t - tag :: TaggedPatch p C(x y) -> Tag tag (TP tg _) = tg @@ -126,6 +134,14 @@ merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1' +instance Commute p => Commute (PatchChoice p) where + commute (PC p1 c1 :> PC p2 c2) = do p2' :> p1' <- commute (p1 :> p2) + return (PC p2' c2 :> PC p1' c1) + listTouchedFiles (PC p _) = listTouchedFiles p + hunkMatches f (PC p _) = hunkMatches f p + merge (PC tp1 c1 :\/: PC tp2 c2) = case merge (tp1 :\/: tp2) of + tp2' :/\: tp1' -> PC tp2' c2 :/\: PC tp1' c1 + patchChoices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y) patchChoices = fst . patchChoicesTps @@ -135,7 +151,7 @@ => Maybe Tag -> FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y)) patchChoicesTpsSub tg ps = let tps = zipWithFL TP (map (TG tg) [1..]) ps - in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps) + in (PCs NilFL (mapFL_FL (\tp -> PC tp False) tps), tps) -- |Tag a sequence of patches. patchChoicesTps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y)) @@ -144,203 +160,214 @@ instance MyEq p => MyEq (PatchChoice p) where unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2 -instance Invert p => Invert (PatchChoice p) where - invert (PC tp mf) = PC (invert tp) (invertTag mf) - identity = PC identity InMiddle - -instance Commute p => Commute (PatchChoice p) where - commute (PC t1 x1 :> PC t2 x2) - = do t2' :> t1' <- commute (t1 :> t2) - return (PC t2' x2 :> PC t1' x1) - merge (PC t1 x1 :\/: PC t2 x2) - = case merge (t1 :\/: t2) of - t2' :/\: t1' -> PC t2' x2 :/\: PC t1' x1 - listTouchedFiles (PC t _) = listTouchedFiles t - hunkMatches f (PC t _) = hunkMatches f t - -invertSeq :: (Invert p, Invert q) => (p :> q) C(x y) -> (q :> p) C(y x) -invertSeq (x :> y) = (invert y :> invert x) separateFirstFromMiddleLast :: Patchy p => PatchChoices p C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) -separateFirstFromMiddleLast (PCs e) = pull_only_firsts e +separateFirstFromMiddleLast (PCs f l) = f :> mapFL_FL (\ (PC tp _) -> tp) l separateFirstMiddleFromLast :: Patchy p => PatchChoices p C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) -separateFirstMiddleFromLast (PCs e) = pull_firsts_middles e +separateFirstMiddleFromLast (PCs f l) = + case pushLasts l of + (m :> l') -> f +>+ m :> l' +-- | @getChoices@ evaluates a @PatchChoices@ into the first, middle and last sequences +-- by doing the commutes that were needed. getChoices :: Patchy p => PatchChoices p C(x y) -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y) -getChoices (PCs e) = case pull_firsts e of - f :> ml -> case pull_firsts (invert ml) of - l :> m -> f :> mapFL_FL pc2tp (invert m) :> invert l - where pc2tp (PC tp _) = tp - -{- -This unsafePerformIO hack was reported by Igloo as being necessary for -constant space performance when working with a very large set of changes -(e.g. from an initial import) where the second element of the returned tuple -is expected to be small, and will only be accessed after the entire first -element has been forced. -On a quick scan on 20080729 it seemed like only revert/unrevert actually -make use of both elements of the tuple. -We should (a) add a test case that checks on constant space usage and -(b) clean up this interface and code, perhaps by replacing the FL :> FL -with a custom structure that forces traversal of the first element to -get at the second (but then how would we commute/pattern-match? messy...) --} - -pull_firsts_middles :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) -pull_firsts_middles easyPC = - let r = unsafePerformIO - $ newIORef (error "pull_firsts_middles called badly") - f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d) - f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL) - f acc (PC tp InLast:>:e) = f (tp:<:acc) e - f acc (PC tp _:>:e) = case commuteWhatWeCanRL (acc :> tp) of - more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e - xs = f NilRL easyPC - in (xs :> unsafePerformIO (readIORef r)) - -pull_only_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) -pull_only_firsts easyPC = - let r = unsafePerformIO - $ newIORef (error "pull_only_firsts called badly") - f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d) - f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL) - f acc (PC tp InFirst:>:e) = case commuteWhatWeCanRL (acc :> tp) of - more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e - f acc (PC tp _:>:e) = f (tp:<:acc) e - xs = f NilRL easyPC - in (xs :> unsafePerformIO (readIORef r)) - -{- -pull_middles_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p]) -pull_middles_lasts easyPC = - let r = unsafePerformIO - $ newIORef (error "pull_middles_lasts called badly") - f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` [] - f acc (PC tp (Just True):e) = f (tp:acc) e - f acc (PC (TP t p) _:e) = case commute_up_list p acc of - (acc', p') -> TP t p':f acc' e - xs = f [] easyPC - in (xs, unsafePerformIO (readIORef r)) --} - ---pull_only_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p]) ---pull_only_lasts easyPC = --- let r = unsafePerformIO --- $ newIORef (error "pull_only_lasts called badly") --- f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` [] --- f acc (PC (TP t p) (Just False):e) = case commute_up_list p acc of --- (acc', p') -> TP t p':f acc' e --- f acc (PC tp _:e) = f (tp:acc) e --- xs = f [] easyPC --- in (xs, unsafePerformIO (readIORef r)) - -pull_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (PatchChoice p)) C(x z) -pull_firsts e = case pull_first e of - Nothing -> (NilFL :> e) - Just (p:>e') -> case pull_firsts e' of - (ps:>e'') -> (p:>:ps :> e'') - -pull_lasts :: Patchy p => FL (PatchChoice p) C(x y) -> (FL (PatchChoice p) :> FL (TaggedPatch p)) C(x y) -pull_lasts e = invertSeq $ pull_firsts $ invert e - -pull_first :: Patchy p => FL (PatchChoice p) C(x z) -> Maybe ((TaggedPatch p :> FL (PatchChoice p)) C(x z)) -pull_first NilFL = Nothing -pull_first (PC tp InFirst:>:e) = Just (tp :> e) -pull_first (PC (TP t p) InLast:>:e) = - case pull_first e of - Just (TP t2 p2 :> e') -> - case commute (p:>p2) of - Just (p2':>p') -> Just (TP t2 p2' :> PC (TP t p') InLast:>:e') - Nothing -> error "Aaack fixme!" - Nothing -> Nothing -pull_first (PC tp@(TP t p) InMiddle:>:e) = - case pull_first e of - Just (TP t2 p2 :> e') -> - case commute (p:>p2) of - Just (p2':>p') -> Just (TP t2 p2' :> (PC (TP t p') InMiddle:>:e')) - Nothing -> Just (tp :> PC (TP (negTag t2) p2) InFirst:>:e') - Nothing -> Nothing - -patchSlot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot -patchSlot tp (PCs e) = ipf e - where ipf :: FL (PatchChoice p) C(u v) -> Slot - ipf (PC a mb:>:e') | tag a == tag tp = mb - | otherwise = ipf e' - -- actually, the following should be impossible, but this is a reasonable answer - ipf NilFL = InLast - --- | 'setSimplys' @ts s ps@ assigns all patches in @ps@ with a tag in @ts@ to slot @s@ --- (and any other patch to slot 'InMiddle') -setSimplys :: [Tag] -> Slot -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y) -setSimplys ts s e = mapFL_FL ch e - where ch (PC tp@(TP t _) _) - | t `elem` ts = PC tp s - | otherwise = PC tp InMiddle - - -m2ids :: (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> FL (PatchChoice p) C(a b) -> [Tag] -m2ids m (PC tp@(TP t _) _:>:e) - | m tp = t:m2ids m e - | otherwise = m2ids m e -m2ids _ NilFL = [] - -forceMatchingFirst :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool) - -> PatchChoices p C(a b) -> PatchChoices p C(a b) -forceMatchingFirst m (PCs e) = - let thd (PC (TP t _) _) = t - xs = m2ids m e - not_needed = case pull_firsts $ setSimplys xs InFirst e of - _ :> rest -> mapFL thd rest - ch pc@(PC tp@(TP t _) _) - | t `elem` not_needed = pc - | otherwise = PC tp InFirst - in PCs $ mapFL_FL ch e - -forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y) -forceFirsts ps pc = forceMatchingFirst ((`elem` ps) . tag) pc - -forceFirst :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) -forceFirst p pc = forceMatchingFirst ((== p) . tag) pc - -selectAllMiddles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y) -selectAllMiddles b (PCs e) = PCs (mapFL_FL f e) - where f (PC tp InMiddle) = PC tp (if b then InLast else InFirst) - f pc = pc - -reverse_pc :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(y x) -reverse_pc (PCs e) = PCs $ invert e +getChoices (PCs f l) = + case pushLasts l of + (m :> l') -> f :> m :> l' + +pushLasts :: Patchy p => FL (PatchChoice p) C(x y) + -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y) +pushLasts NilFL = NilFL :> NilFL +pushLasts (PC tp False :>: pcs) = + case pushLasts pcs of + (m :> l) -> (tp :>: m) :> l +pushLasts (PC tp True :>: pcs) = + case pushLasts pcs of + (m :> l) -> + case commuteWhatWeCanFL (tp :> m) of + (m' :> tp' :> deps) -> m' :> (tp' :>: deps +>+ l) + +-- | @refineChoices act@ performs @act@ on the middle part of a sequence +-- of choices, in order to hopefully get more patches into the @first@ and +-- @last@ parts of a @PatchChoices@. +refineChoices :: (Patchy p, Monad m, Functor m) => + (FORALL(u v) FL (TaggedPatch p) C(u v) -> + PatchChoices p C(u v) -> + m (PatchChoices p C(u v))) + -> PatchChoices p C(x y) -> m (PatchChoices p C(x y)) +refineChoices act ps = + case getChoices ps of + (f :> m :> l) -> do + let mchoices = PCs NilFL . mapFL_FL (flip PC False) $ m + (PCs f' l') <- act m mchoices + return . PCs (f +>+ f') $ l' +>+ mapFL_FL (flip PC True) l + +patchSlot :: forall p C(a b x y). Patchy p => TaggedPatch p C(a b) + -> PatchChoices p C(x y) -> (Slot, PatchChoices p C(x y)) +patchSlot (TP t _) pc@(PCs f l) = + if foundIn f + then (InFirst, pc) + else psLast f NilRL NilRL l + where + foundIn = anyFL ((== t) . tag) + psLast :: FORALL(m b l) + FL (TaggedPatch p) C(x m) -> + RL (TaggedPatch p) C(m b) -> + RL (TaggedPatch p) C(b l) -> + FL (PatchChoice p) C(l y) -> + (Slot, PatchChoices p C(x y)) + psLast firsts middles bubble (PC tp True :>: ls) + | tag tp == t = (InLast + , PCs { firsts = firsts + , lasts = settleM middles + +>+ settleB bubble + +>+ PC tp True :>: ls}) + psLast firsts middles bubble (PC tp False :>: ls) + | tag tp == t = + case commuteRL (bubble :> tp) of + Just (tp' :> bubble') -> (InMiddle, + PCs { firsts = firsts + , lasts = settleM middles + +>+ PC tp' False + :>: settleB bubble' + +>+ ls}) + Nothing -> (InLast, + PCs { firsts = firsts + , lasts = settleM middles + +>+ settleB bubble + +>+ PC tp True + :>: ls}) + psLast firsts middles bubble (PC tp True :>: ls) = + psLast firsts middles (tp :<: bubble) ls + psLast firsts middles bubble (PC tp False :>: ls) = + case commuteRL (bubble :> tp) of + Just (tp' :> bubble') -> psLast firsts (tp' :<: middles) bubble' ls + Nothing -> psLast firsts middles (tp :<: bubble) ls + psLast _ _ _ NilFL = impossible + settleM middles = mapFL_FL (\tp -> PC tp False) $ reverseRL middles + settleB bubble = mapFL_FL (\tp -> PC tp True) $ reverseRL bubble + +patchSlot' :: Patchy p => + TaggedPatch p C(a b) -> State (PatchChoices p C(x y)) Slot +patchSlot' = State . patchSlot + +forceMatchingFirst :: forall p C(a b). Patchy p => + ( FORALL(x y) TaggedPatch p C(x y) -> Bool) + -> PatchChoices p C(a b) + -> PatchChoices p C(a b) +forceMatchingFirst pred (PCs f l) = + fmfLasts f NilRL l + where + fmfLasts :: FL (TaggedPatch p) C(a m) + -> RL (PatchChoice p) C(m n) + -> FL (PatchChoice p) C(n b) + -> PatchChoices p C(a b) + fmfLasts f l1 (a :>: l2) + | pred_pc a = + case commuteWhatWeCanRL (l1 :> a) of + (deps :> a' :> l1') -> + let + f' = f +>+ mapFL_FL pcPatch (reverseRL deps) +>+ (pcPatch a' :>: NilFL) + in fmfLasts f' l1' l2 + fmfLasts f l1 (a :>: l2) = fmfLasts f (a :<: l1) l2 + fmfLasts f l1 NilFL = PCs { firsts = f + , lasts = reverseRL l1 } + pred_pc :: FORALL(x y) PatchChoice p C(x y) -> Bool + pred_pc (PC tp _) = pred tp + +forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(a b) + -> PatchChoices p C(a b) +forceFirsts ps = forceMatchingFirst ((`elem` ps) . tag) + +forceFirst :: Patchy p => Tag -> PatchChoices p C(a b) + -> PatchChoices p C(a b) +forceFirst p = forceMatchingFirst ((== p) . tag) +--TODO: stop after having seen the patch we want to force first + +selectAllMiddles :: forall p C(x y). Patchy p => Bool + -> PatchChoices p C(x y) -> PatchChoices p C(x y) +selectAllMiddles True (PCs f l) = PCs f (mapFL_FL g l) + where g (PC tp _) = PC tp True +selectAllMiddles False (PCs f l) = samf f NilRL NilRL l + where + samf :: FORALL(m1 m2 m3) + FL (TaggedPatch p) C(x m1) -> + RL (TaggedPatch p) C(m1 m2) -> + RL (PatchChoice p) C(m2 m3) -> + FL (PatchChoice p) C(m3 y) -> + PatchChoices p C(x y) + samf f1 f2 l1 (pc@(PC tp False) :>: l2) = + case commuteRL (l1 :> pc) of + Nothing -> samf f1 f2 (PC tp True :<: l1) l2 + Just ((PC tp' _) :> l1') -> samf f1 (tp' :<: f2) l1' l2 + samf f1 f2 l1 (PC tp True :>: l2) = samf f1 f2 (PC tp True :<: l1) l2 + samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1) forceMatchingLast :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool) + -> PatchChoices p C(a b) + -> PatchChoices p C(a b) +forceMatchingLast pred (PCs f l) = do + fmlFirst pred True NilRL f l + +fmlFirst :: forall p C(a b m1 m2) . Patchy p => + (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> Bool + -> RL (TaggedPatch p) C(a m1) + -> FL (TaggedPatch p) C(m1 m2) + -> FL (PatchChoice p) C(m2 b) + -> PatchChoices p C(a b) +fmlFirst pred b f1 (a :>: f2) l + | pred a = + case commuteWhatWeCanFL (a :> f2) of + (f2' :> a' :> deps) -> + let + l' = mapFL_FL (\tp -> PC tp b) (a' :>: deps) +>+ l + in + fmlFirst pred b f1 f2' l' +fmlFirst pred b f1 (a :>: f2) l = fmlFirst pred b (a :<: f1) f2 l +fmlFirst pred b f1 NilFL l = PCs { firsts = reverseRL f1 + , lasts = mapFL_FL ch l} + where ch (PC tp c) = (PC tp (if pred tp then b else c) ) + +forceLasts :: Patchy p => [Tag] + -> PatchChoices p C(a b) -> PatchChoices p C(a b) +forceLasts ps = forceMatchingLast ((`elem` ps) . tag) + +forceLast :: Patchy p => Tag -> PatchChoices p C(a b) -> PatchChoices p C(a b) -forceMatchingLast m (PCs e) = - let thd (PC (TP t _) _) = t - xs = m2ids m e - not_needed = case pull_lasts $ setSimplys xs InLast e of - rest :> _ -> mapFL thd rest - ch pc@(PC tp@(TP t _) _) - | t `elem` not_needed = pc - | otherwise = PC tp InLast - in PCs $ mapFL_FL ch e - -forceLast :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) -forceLast p pc = reverse_pc $ forceFirst p $ reverse_pc pc - -forceLasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y) -forceLasts ps pc = reverse_pc $ forceFirsts ps $ reverse_pc pc - -makeUncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) -makeUncertain t (PCs e) = PCs $ mapFL_FL ch e - where ch pc@(PC x _) = if t == tag x then PC x InMiddle else pc +forceLast p = forceMatchingLast ((== p) . tag) + +makeUncertain :: Patchy p => Tag -> PatchChoices p C(a b) -> PatchChoices p C(a b) +makeUncertain t (PCs f l) = fmlFirst ((== t) . tag) False NilRL f l makeEverythingLater :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y) -makeEverythingLater (PCs e) = PCs $ mapFL_FL ch e - where ch (PC tp InMiddle) = PC tp InLast - ch (PC tp InFirst) = PC tp InMiddle - ch x = x +makeEverythingLater (PCs f l) = + let m = mapFL_FL (\tp -> PC tp False) f + l' = mapFL_FL (\(PC tp _) -> PC tp True) l + in + PCs NilFL $ m +>+ l' + +makeEverythingSooner :: forall p C(x y). + Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y) +makeEverythingSooner (PCs f l) = + case mes NilRL NilRL l + of (m :> l) -> + PCs (f +>+ m) l + where + mes :: FORALL(m1 m2 m3) + RL (TaggedPatch p) C(m1 m2) -> + RL (TaggedPatch p) C(m2 m3) -> + FL (PatchChoice p) C(m3 y) -> + (FL (TaggedPatch p) :> FL (PatchChoice p)) C(m1 y) + mes middle bubble (PC tp True :>: ls) = mes middle (tp :<: bubble) ls + mes middle bubble (PC tp False :>: ls) = + case commuteRL (bubble :> tp) of + Nothing -> mes middle (tp :<: bubble) ls + Just (tp' :> bubble') -> mes (tp' :<: middle) bubble' ls + mes middle bubble NilFL = (reverseRL middle) :> mapFL_FL (\tp -> PC tp False) (reverseRL bubble) -- | 'substitute' @(a :||: bs)@ @pcs@ replaces @a@ with @bs@ in @pcs@ preserving the choice -- associated with @a@ @@ -349,8 +376,14 @@ => Sealed2 (TaggedPatch p :||: FL (TaggedPatch p)) -> PatchChoices p C(x y) -> PatchChoices p C(x y) -substitute (Sealed2 (tp :||: new_tps)) (PCs pcs) = PCs (concatFL (mapFL_FL translate pcs)) - where translate :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b) - translate (PC tp' c) - | IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps - | otherwise = PC tp' c :>: NilFL +substitute (Sealed2 (tp :||: new_tps)) (PCs f l) = + PCs (concatFL $ mapFL_FL substTp f) (concatFL $ mapFL_FL substPc l) + where + substTp :: TaggedPatch p C(a b) -> FL (TaggedPatch p) C(a b) + substTp tp' + | IsEq <- compareTags tp tp' = new_tps + | otherwise = tp' :>: NilFL + substPc :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b) + substPc (PC tp' c) + | IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps + | otherwise = PC tp' c :>: NilFL diff -ruN darcs-2.4.4/src/Darcs/Patch/Commute.lhs darcs-2.5/src/Darcs/Patch/Commute.lhs --- darcs-2.4.4/src/Darcs/Patch/Commute.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Commute.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -25,67 +25,56 @@ module Darcs.Patch.Commute ( fromPrims, modernizePatch, -#ifndef GADT_WITNESSES merge, elegantMerge, merger, unravel, -#endif - public_unravel, mangle_unravelled, + publicUnravel, mangleUnravelled, CommuteFunction, Perhaps(..), -- for other commutes: toMaybe, ) where -import Control.Monad ( MonadPlus, mplus, msum, mzero ) +import Control.Monad ( MonadPlus, mplus, msum, mzero, guard ) import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn ) -import Darcs.Patch.Info ( invert_name, idpatchinfo ) +import Darcs.Patch.Info ( invertName, idpatchinfo ) import Darcs.Patch.Patchy ( Commute(..), Invert(..), toFwdCommute, toRevCommute ) import Darcs.Patch.Core ( Patch(..), Named(..), -#ifndef GADT_WITNESSES flattenFL, isMerger, -#endif - merger_undo, - join_patchesFL ) + mergerUndo, + joinPatchesFL ) import Darcs.Patch.Prim ( Prim(..), FromPrims(..), Conflict(..), Effect(..), is_filepatch, sortCoalesceFL, -#ifndef GADT_WITNESSES FilePatchType(..), DirPatchType(..), -#else - FilePatchType(Hunk), -#endif primIsHunk, modernizePrim ) import qualified Data.ByteString.Char8 as BC (pack, last) import qualified Data.ByteString as B (null, ByteString) import Data.Maybe ( isJust ) import Data.List ( intersperse, sort ) -#ifndef GADT_WITNESSES -import Darcs.Patch.Permutations ( head_permutationsRL, head_permutationsFL ) +import Darcs.Patch.Permutations ( headPermutationsRL, simpleHeadPermutationsFL ) import Printer ( text, vcat, ($$) ) import Darcs.Patch.Patchy ( invertRL ) import Darcs.Patch.Show ( showPatch_ ) -import Data.List ( nubBy ) -import Darcs.Witnesses.Sealed ( unsafeUnseal ) -#endif +import Data.List ( nub, nubBy ) +import Darcs.Witnesses.Sealed ( unsafeUnseal, unsafeUnsealFlipped ) import Darcs.Utils ( nubsort ) #include "impossible.h" -import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal ) +import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, unseal, FlippedSeal(..), mapFlipped, unsealFlipped ) import Darcs.Witnesses.Ordered ( mapFL, mapFL_FL, unsafeCoerceP, + unsafeCoercePStart, unsafeCoercePEnd, FL(..), RL(..), (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..), -#ifndef GADT_WITNESSES lengthFL, mapRL, -#endif reverseFL, reverseRL, concatFL, - MyEq, unsafeCompare + MyEq, unsafeCompare, EqCheck(..), (=\/=) ) --import Darcs.ColorPrinter ( traceDoc ) --import Printer ( greenText ) \end{code} - + \section{Commuting patches} \subsection{Composite patches} @@ -167,9 +156,8 @@ toPerhaps (Just x) = Succeeded x toPerhaps Nothing = Failed -#ifndef GADT_WITNESSES -clever_commute :: CommuteFunction -> CommuteFunction -clever_commute c (p1: CommuteFunction +cleverCommute c (p1: Succeeded x Failed -> Failed @@ -177,15 +165,14 @@ Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1') Failed -> Failed Unknown -> Unknown -#endif -speedy_commute :: CommuteFunction -speedy_commute (p1 :< p2) -- Deal with common case quickly! +speedyCommute :: CommuteFunction +speedyCommute (p1 :< p2) -- Deal with common case quickly! | p1_modifies /= Nothing && p2_modifies /= Nothing && p1_modifies /= p2_modifies = Succeeded (unsafeCoerceP p2 :< unsafeCoerceP p1) | otherwise = Unknown - where p1_modifies = is_filepatch_merger p1 - p2_modifies = is_filepatch_merger p2 + where p1_modifies = isFilepatchMerger p1 + p2_modifies = isFilepatchMerger p2 instance Commute p => Commute (Named p) where commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) = @@ -202,9 +189,10 @@ instance Conflict p => Conflict (Named p) where listConflictedFiles (NamedP _ _ p) = listConflictedFiles p resolveConflicts (NamedP _ _ p) = resolveConflicts p + isInconsistent (NamedP _ _ p) = isInconsistent p -everything_else_commute :: MaybeCommute -> CommuteFunction -everything_else_commute c x = eec x +everythingElseCommute :: MaybeCommute -> CommuteFunction +everythingElseCommute c x = eec x where eec :: CommuteFunction eec (PP px :< PP py) = toPerhaps $ do x' :> y' <- commute (py :> px) @@ -225,10 +213,8 @@ return (p':<:ps' :< p2'') eec _xx = msum [ -#ifndef GADT_WITNESSES - clever_commute commute_recursive_merger _xx - ,clever_commute other_commute_recursive_merger _xx -#endif + cleverCommute commuteRecursiveMerger _xx + ,cleverCommute otherCommuteRecursiveMerger _xx ] {- @@ -242,42 +228,39 @@ then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1) -} -#ifndef GADT_WITNESSES -merger_commute :: (Patch :< Patch) -> Perhaps (Patch :< Patch) -merger_commute (Merger _ _ p1 p2 :< pA) - | unsafeCompare pA p1 = Succeeded (merger "0.0" p2 p1 :< p2) - | unsafeCompare pA (invert (merger "0.0" p2 p1)) = Failed -merger_commute (Merger _ _ +unsafeMerger :: String -> Patch C(x y) -> Patch C(x z) -> Patch C(a b) +unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2 + +mergerCommute :: (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) +mergerCommute (Merger _ _ p1 p2 :< pA) + | unsafeCompare pA p1 = Succeeded (unsafeMerger "0.0" p2 p1 :< unsafeCoercePStart p2) + | unsafeCompare pA (invert (unsafeMerger "0.0" p2 p1)) = Failed +mergerCommute (Merger _ _ (Merger _ _ c b) (Merger _ _ c' a) :< Merger _ _ b' c'') | unsafeCompare b' b && unsafeCompare c c' && unsafeCompare c c'' = - Succeeded (merger "0.0" (merger "0.0" b a) (merger "0.0" b c) :< - merger "0.0" b a) -merger_commute _ = Unknown -#endif + Succeeded (unsafeMerger "0.0" (unsafeMerger "0.0" b (unsafeCoercePStart a)) (unsafeMerger "0.0" b c) :< + unsafeMerger "0.0" b (unsafeCoercePStart a)) +mergerCommute _ = Unknown instance Commute Patch where merge (y :\/: z) = -#ifndef GADT_WITNESSES - case actual_merge (y:\/:z) of - y' -> case commute (z :> y') of + case actualMerge (y:\/:z) of + Sealed y' -> case commute (z :> y') of Nothing -> bugDoc $ text "merge_patches bug" $$ showPatch_ y $$ showPatch_ z $$ showPatch_ y' - Just (_ :> z') -> z' :/\: y' -#else - case elegantMerge (y:\/:z) of - Just (z' :/\: y') -> z' :/\: y' - Nothing -> undefined -#endif + Just (_ :> z') -> -- actualMerge returns one arm of a + -- merge result, so commuting then gives + -- us the other arm but we have to assert + -- that the starting context is correct + unsafeCoercePStart z' :/\: y' commute x = toMaybe $ msum - [toFwdCommute speedy_commute x, -#ifndef GADT_WITNESSES - toFwdCommute (clever_commute merger_commute) x, -#endif - toFwdCommute (everything_else_commute (toRevCommute commute)) x + [toFwdCommute speedyCommute x, + toFwdCommute (cleverCommute mergerCommute) x, + toFwdCommute (everythingElseCommute (toRevCommute commute)) x ] -- Recurse on everything, these are potentially spoofed patches listTouchedFiles (ComP ps) = nubsort $ concat $ mapFL listTouchedFiles ps @@ -291,70 +274,60 @@ hunkMatches f c@(Regrem _ _ _ _) = hunkMatches f $ invert c hunkMatches f (PP p) = hunkMatches f p -commute_no_merger :: MaybeCommute -commute_no_merger x = -#ifndef GADT_WITNESSES - toMaybe $ msum [speedy_commute x, - everything_else_commute commute_no_merger x] -#else - bug "commute_no_merger undefined when compiled with GADTs" x -#endif - -is_filepatch_merger :: Patch C(x y) -> Maybe FileName -is_filepatch_merger (PP p) = is_filepatch p -is_filepatch_merger (Merger _ _ p1 p2) = do - f1 <- is_filepatch_merger p1 - f2 <- is_filepatch_merger p2 +commuteNoMerger :: MaybeCommute +commuteNoMerger x = + toMaybe $ msum [speedyCommute x, + everythingElseCommute commuteNoMerger x] + +isFilepatchMerger :: Patch C(x y) -> Maybe FileName +isFilepatchMerger (PP p) = is_filepatch p +isFilepatchMerger (Merger _ _ p1 p2) = do + f1 <- isFilepatchMerger p1 + f2 <- isFilepatchMerger p2 if f1 == f2 then return f1 else Nothing -is_filepatch_merger (Regrem und unw p1 p2) - = is_filepatch_merger (Merger und unw p1 p2) -is_filepatch_merger (ComP _) = Nothing - -#ifndef GADT_WITNESSES -commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch) -commute_recursive_merger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ +isFilepatchMerger (Regrem und unw p1 p2) + = isFilepatchMerger (Merger und unw p1 p2) +isFilepatchMerger (ComP _) = Nothing + +commuteRecursiveMerger :: (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) +commuteRecursiveMerger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ do (_ :> pA') <- commute (pA :> undo) commute (pA' :> invert undo) - (_ :> pAmid) <- commute (pA :> invert p1) + (_ :> pAmid) <- commute (pA :> unsafeCoercePStart (invert p1)) (p1' :> pAx) <- commute (pAmid :> p1) - assert (pAx `unsafeCompare` pA) + guard (pAx `unsafeCompare` pA) (p2' :> _) <- commute (pAmid :> p2) (p2o :> _) <- commute (invert pAmid :> p2') - assert (p2o `unsafeCompare` p2) + guard (p2o `unsafeCompare` p2) let p' = if unsafeCompare p1' p1 && unsafeCompare p2' p2 - then p - else merger "0.0" p1' p2' - undo' = merger_undo p' + then unsafeCoerceP p + else unsafeMerger "0.0" p1' p2' + undo' = mergerUndo p' (pAo :> _) <- commute (undo' :> pA') - assert (pAo `unsafeCompare` pA) + guard (pAo `unsafeCompare` pA) return (pA' :< p') - where undo = merger_undo p -commute_recursive_merger _ = Unknown + where undo = mergerUndo p +commuteRecursiveMerger _ = Unknown -other_commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch) -other_commute_recursive_merger (pA':< p_old@(Merger _ _ p1' p2')) = +otherCommuteRecursiveMerger :: (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) +otherCommuteRecursiveMerger (pA':< p_old@(Merger _ _ p1' p2')) = toPerhaps $ - do (pA :> _) <- commute (merger_undo p_old :> pA') - (pAmid :> p1) <- commute (p1' :> pA) + do (pA :> _) <- commute (mergerUndo p_old :> pA') + (pAmid :> p1) <- commute (unsafeCoercePEnd p1' :> pA) (_ :> pAmido) <- commute (pA :> invert p1) - assert (pAmido `unsafeCompare` pAmid) + guard (pAmido `unsafeCompare` pAmid) (p2 :> _) <- commute (invert pAmid :> p2') (p2o' :> _) <- commute (pAmid :> p2) - assert (p2o' `unsafeCompare` p2') + guard (p2o' `unsafeCompare` p2') let p = if p1 `unsafeCompare` p1' && p2 `unsafeCompare` p2' - then p_old - else merger "0.0" p1 p2 - undo = merger_undo p - assert (not $ pA `unsafeCompare` p1) -- special case here... + then unsafeCoerceP p_old + else unsafeMerger "0.0" p1 p2 + undo = mergerUndo p + guard (not $ pA `unsafeCompare` p1) -- special case here... (_ :> pAo') <- commute (pA :> undo) - assert (pAo' `unsafeCompare` pA') + guard (pAo' `unsafeCompare` pA') return (p :< pA) -other_commute_recursive_merger _ = Unknown - -assert :: Bool -> Maybe () -assert False = Nothing -assert True = Just () -#endif +otherCommuteRecursiveMerger _ = Unknown type CommuteFunction = FORALL(x y) (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) type MaybeCommute = FORALL(x y) (Patch :< Patch) C(x y) -> Maybe ((Patch :< Patch) C(x y)) @@ -423,9 +396,8 @@ elegantMerge (p1 :\/: p2) = do p1' :> ip2' <- commute (invert p2 :> p1) p1o :> _ <- commute (p2 :> p1') - if unsafeCompare p1o p1 -- should be a redundant check - then return $ invert ip2' :/\: p1' - else Nothing + guard $ unsafeCompare p1o p1 -- should be a redundant check + return $ invert ip2' :/\: p1' \end{code} @@ -448,33 +420,58 @@ situation is considerably more complicated. \begin{code} -#ifndef GADT_WITNESSES -actual_merge :: (Patch :\/: Patch) -> Patch -actual_merge (ComP the_p1s :\/: ComP the_p2s) = - join_patchesFL $ mc the_p1s the_p2s - where mc :: FL Patch -> FL Patch -> FL Patch - mc NilFL (_:>:_) = NilFL - mc p1s NilFL = p1s - mc p1s (p2:>:p2s) = mc (merge_patches_after_patch p1s p2) p2s -actual_merge (ComP p1s :\/: p2) = seq p2 $ - join_patchesFL $ merge_patches_after_patch p1s p2 -actual_merge (p1 :\/: ComP p2s) = seq p1 $ merge_patch_after_patches p1 p2s - -actual_merge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of - Just (_ :/\: p1') -> p1' - Nothing -> merger "0.0" p2 p1 - -merge_patch_after_patches :: Patch -> FL Patch -> Patch -merge_patch_after_patches p (p1:>:p1s) = - merge_patch_after_patches (actual_merge (p:\/:p1)) p1s -merge_patch_after_patches p NilFL = p - -merge_patches_after_patch :: FL Patch -> Patch -> FL Patch -merge_patches_after_patch p2s p = - case commute (join_patchesFL p2s :> merge_patch_after_patches p p2s) of - Just (_ :> ComP p2s') -> p2s' - _ -> impossible -#endif +{- +A note about mergers and type witnesses +--------------------------------------- + +The merger code predates the introduction of type witnesses, and because +of its complexity has proved the hardest part of the codebase to retrofit. +Attempting to do this has exposed various places where the code behaves +oddly (e.g. 'putBefore' below); these are likely to be bugs but fixing +them would be potentially disruptive and dangerous as it might change +the existing merge behaviour and thus break existing repositories. + +As a result the addition of witnesses to this code has required the +liberal use of unsafe operators. In effect, witnesses bring no safety +in this area; the sole purpose of adding them here was to allow this +code to run as part of a codebase that uses witnesses everywhere else. + +A key problem point is the type of the 'Merger' and 'Regrem' constructors +of Patch, where the witnesses seem odd. It is likely that some or many +of the unsafe operations could be removed by finding a better type for +these constructors. +-} + + +actualMerge :: (Patch :\/: Patch) C(x y) -> Sealed (Patch C(y)) + +actualMerge (ComP the_p1s :\/: ComP the_p2s) = + mapSeal joinPatchesFL $ mc (the_p1s :\/: the_p2s) + where mc :: (FL Patch :\/: FL Patch) C(x y) -> Sealed (FL Patch C(y)) + mc (NilFL :\/: (_:>:_)) = Sealed NilFL + mc (p1s :\/: NilFL) = Sealed p1s + mc (p1s :\/: (p2:>:p2s)) = case mergePatchesAfterPatch (p1s:\/:p2) of + Sealed x -> mc (x:\/:p2s) +actualMerge (ComP p1s :\/: p2) = seq p2 $ + mapSeal joinPatchesFL $ mergePatchesAfterPatch (p1s:\/:p2) +actualMerge (p1 :\/: ComP p2s) = seq p1 $ mergePatchAfterPatches (p1:\/:p2s) + +actualMerge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of + Just (_ :/\: p1') -> Sealed p1' + Nothing -> merger "0.0" p2 p1 + +mergePatchAfterPatches :: (Patch :\/: FL Patch) C(x y) -> Sealed (Patch C(y)) +mergePatchAfterPatches (p :\/: (p1:>:p1s)) = + case actualMerge (p:\/:p1) of + Sealed x -> mergePatchAfterPatches (x :\/: p1s) +mergePatchAfterPatches (p :\/: NilFL) = Sealed p + +mergePatchesAfterPatch :: (FL Patch :\/: Patch) C(x y) -> Sealed (FL Patch C(y)) +mergePatchesAfterPatch (p2s :\/: p) = + case mergePatchAfterPatches (p :\/: p2s) of + Sealed x -> case commute (joinPatchesFL p2s :> x) of + Just (_ :> ComP p2s') -> Sealed (unsafeCoercePStart p2s') + _ -> impossible \end{code} Much of the merger code depends on a routine which recreates from a single @@ -568,52 +565,53 @@ discussion. \begin{code} -#ifndef GADT_WITNESSES -unwind :: Patch -> RL Patch -- Recreates a patch history in reverse. -unwind (Merger _ unwindings _ _) = unwindings -unwind p = p :<: NilRL; +unwind :: Patch C(x y) -> Sealed (RL Patch C(x)) -- Recreates a patch history in reverse. +unwind (Merger _ unwindings _ _) = Sealed unwindings +unwind p = Sealed (p :<: NilRL) -true_unwind :: Patch -> RL Patch -- Recreates a patch history in reverse. -true_unwind p@(Merger _ _ p1 p2) = +trueUnwind :: Patch C(x y) -> Sealed (RL Patch C(x)) -- Recreates a patch history in reverse. +trueUnwind p@(Merger _ _ p1 p2) = case (unwind p1, unwind p2) of - (_:<:p1s,_:<:p2s) -> p :<: p1 :<: reconcile_unwindings p p1s p2s + (Sealed (_:<:p1s),Sealed (_:<:p2s)) -> + Sealed (p :<: unsafeCoerceP p1 :<: unsafeUnsealFlipped (reconcileUnwindings p p1s (unsafeCoercePEnd p2s))) _ -> impossible -true_unwind _ = impossible +trueUnwind _ = impossible -reconcile_unwindings :: Patch -> RL Patch -> RL Patch -> RL Patch -reconcile_unwindings _ NilRL p2s = p2s -reconcile_unwindings _ p1s NilRL = p1s -reconcile_unwindings p (p1:<:p1s) p2s = +reconcileUnwindings :: Patch C(a b) -> RL Patch C(x z) -> RL Patch C(y z) -> FlippedSeal (RL Patch) C(z) +reconcileUnwindings _ NilRL p2s = FlippedSeal p2s +reconcileUnwindings _ p1s NilRL = FlippedSeal p1s +reconcileUnwindings p (p1:<:p1s) p2s@(p2:<:tp2s) = case [(p1s', p2s')| - p1s'@(hp1s':<:_) <- head_permutationsRL (p1:<:p1s), - p2s'@(hp2s':<:_) <- head_permutationsRL p2s, + p1s'@(hp1s':<:_) <- headPermutationsRL (p1:<:p1s), + p2s'@(hp2s':<:_) <- headPermutationsRL p2s, hp1s' `unsafeCompare` hp2s'] of ((p1':<:p1s', _:<:p2s'):_) -> - p1' :<: reconcile_unwindings p p1s' p2s' - [] -> case reverseFL `fmap` put_before p1 (reverseRL p2s) of - Just p2s' -> p1 :<: reconcile_unwindings p p1s p2s' + mapFlipped (p1' :<:) $ reconcileUnwindings p p1s' (unsafeCoercePEnd p2s') + [] -> case reverseFL `fmap` putBefore p1 (reverseRL p2s) of + Just p2s' -> mapFlipped (p1 :<:) $ reconcileUnwindings p p1s p2s' Nothing -> - case fmap reverseFL $ put_before (headRL p2s) $ + case fmap reverseFL $ putBefore p2 $ reverseRL (p1:<:p1s) of - Just p1s' -> case p2s of - hp2s:<:tp2s -> hp2s :<: - reconcile_unwindings p p1s' tp2s - NilRL -> impossible + Just p1s' -> mapFlipped (p2 :<:) $ + reconcileUnwindings p p1s' tp2s Nothing -> - bugDoc $ text "in function reconcile_unwindings" + bugDoc $ text "in function reconcileUnwindings" $$ text "Original patch:" $$ showPatch_ p - _ -> bug "in reconcile_unwindings" + _ -> bug "in reconcileUnwindings" -put_before :: Patch -> FL Patch -> Maybe (FL Patch) -put_before p1 (p2:>:p2s) = - do p1' :> p2' <- commute (p2 :> invert p1) +-- This code seems wrong, shouldn't the commute be invert p1 :> p2 ? And why isn't p1' re-inverted? +-- it seems to have been this way forever: +-- Fri May 23 10:27:04 BST 2003 droundy@abridgegame.org +-- * fix bug in unwind and add docs on unwind algorithm. +putBefore :: Patch C(y z) -> FL Patch C(x z) -> Maybe (FL Patch C(y w)) +putBefore p1 (p2:>:p2s) = + do p1' :> p2' <- commute (unsafeCoerceP p2 :> invert p1) commute (p2' :> p1) - (p2' :>:) `fmap` put_before p1' p2s -put_before _ NilFL = Just NilFL -#endif + (unsafeCoerceP p2' :>:) `fmap` putBefore p1' (unsafeCoerceP p2s) +putBefore _ NilFL = Just (unsafeCoerceP NilFL) \end{code} - + \section{Conflicts} There are a couple of simple constraints on the routine which determines @@ -638,149 +636,135 @@ \begin{code} instance Conflict Patch where - commute_no_conflicts (x:>y) = do x' :< y' <- commute_no_merger (y :< x) + commuteNoConflicts (x:>y) = do x' :< y' <- commuteNoMerger (y :< x) return (y':>x') -#ifndef GADT_WITNESSES resolveConflicts patch = rcs NilFL $ reverseFL $ flattenFL patch - where rcs :: FL Patch C(w y) -> RL Patch C(x y) -> [[Sealed (FL Prim C(w))]] + where rcs :: FL Patch C(y w) -> RL Patch C(x y) -> [[Sealed (FL Prim C(w))]] rcs _ NilRL = [] rcs passedby (p@(Merger _ _ _ _):<:ps) = - case commute_no_merger (join_patchesFL passedby: - (map Sealed $ nubBy unsafeCompare $ effect (glump09 p1 p2) : unravel p') + (map Sealed $ nubBy unsafeCompare $ + effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) : map (unsafeCoercePStart . unsafeUnseal) (unravel p')) : rcs (p :>: passedby) ps Nothing -> rcs (p :>: passedby) ps _ -> impossible rcs passedby (p:<:ps) = seq passedby $ rcs (p :>: passedby) ps -#else - resolveConflicts = bug "haven't defined resolveConflicts with type witnesses." -#endif - -public_unravel :: Patch C(x y) -> [Sealed (FL Prim C(y))] -#ifdef GADT_WITNESSES -public_unravel = bug "Haven't implemented public_unravel with type witnesses." -#else -public_unravel p = map Sealed $ unravel p -#endif - -#ifndef GADT_WITNESSES -unravel :: Patch -> [FL Prim] -unravel p = nubBy unsafeCompare $ - map (sortCoalesceFL . concatFL . mapFL_FL effect) $ - get_supers $ map reverseRL $ new_ur p $ unwind p - -get_supers :: [FL Patch] -> [FL Patch] -get_supers (x:xs) = - case filter (not.(x `is_superpatch_of`)) xs of - xs' -> if or $ map (`is_superpatch_of` x) xs' - then get_supers xs' - else x : get_supers xs' -get_supers [] = [] -is_superpatch_of :: FL Patch -> FL Patch -> Bool -x `is_superpatch_of` y | lengthFL y > lengthFL x = False -x `is_superpatch_of` y = x `iso` y - where iso :: FL Patch -> FL Patch -> Bool + +-- This type seems wrong - the most natural type for the result would seem to be +-- [Sealed (FL Prim C(x))], given the type of unwind. +-- However downstream code in darcs convert assumes the C(y) type, and I was unable +-- to figure out whether this could/should reasonably be changed -- Ganesh 13/4/10 +publicUnravel :: Patch C(x y) -> [Sealed (FL Prim C(y))] +publicUnravel = map (mapSeal unsafeCoercePStart) . unravel + +unravel :: Patch C(x y) -> [Sealed (FL Prim C(x))] +unravel p = nub $ map (mapSeal (sortCoalesceFL . concatFL . mapFL_FL effect)) $ + getSupers $ map (mapSeal reverseRL) $ unseal (newUr p) $ unwind p + +getSupers :: [Sealed (FL Patch C(x))] -> [Sealed (FL Patch C(x))] +getSupers (x:xs) = + case filter (not.(x `isSuperpatchOf`)) xs of + xs' -> if or $ map (`isSuperpatchOf` x) xs' + then getSupers xs' + else x : getSupers xs' +getSupers [] = [] + +isSuperpatchOf :: Sealed (FL Patch C(x)) -> Sealed (FL Patch C(x)) -> Bool +Sealed x `isSuperpatchOf` Sealed y | lengthFL y > lengthFL x = False -- should be just an optimisation +Sealed x `isSuperpatchOf` Sealed y = x `iso` y + where iso :: FL Patch C(x y) -> FL Patch C(x z) -> Bool _ `iso` NilFL = True NilFL `iso` _ = False a `iso` (b:>:bs) = - case filter ((`unsafeCompare` b) . headFL) $ - head_permutationsFL a of - ((_:>:as):_) -> as `iso` bs - [] -> False - _ -> bug "bug in is_superpatch_of" - -headFL :: FL a -> a -headFL (x:>:_) = x -headFL NilFL = bug "bad headFL" + head $ ([as `iso` bs | (ah :>: as) <- simpleHeadPermutationsFL a, IsEq <- [ah =\/= b]] :: [Bool]) ++ [False] -merger :: String -> Patch -> Patch -> Patch -merger "0.0" p1 p2 = Merger undoit unwindings p1 p2 +merger :: String -> Patch C(x y) -> Patch C(x z) -> Sealed (Patch C(y)) +merger "0.0" p1 p2 = Sealed $ Merger undoit unwindings p1 p2 where fake_p = Merger identity NilRL p1 p2 - unwindings = true_unwind fake_p + unwindings = unsafeUnseal (trueUnwind fake_p) p = Merger identity unwindings p1 p2 undoit = case (isMerger p1, isMerger p2) of - (True ,True ) -> join_patchesFL $ invertRL $ tailRL $ unwind p - where tailRL (_:<:t) = t - tailRL _ = impossible - (False,False) -> invert p1 - (True ,False) -> join_patchesFL NilFL - (False,True ) -> join_patchesFL (invert p1 :>: merger_undo p2 :>: NilFL) + (True ,True ) -> case unwind p of + Sealed (_:<:t) -> unsafeCoerceP $ joinPatchesFL $ invertRL t + _ -> impossible + (False,False) -> unsafeCoerceP $ invert p1 + (True ,False) -> unsafeCoerceP $ joinPatchesFL NilFL + (False,True ) -> unsafeCoerceP $ joinPatchesFL (invert p1 :>: mergerUndo p2 :>: NilFL) merger g _ _ = error $ "Cannot handle mergers other than version 0.0\n"++g ++ "\nPlease use darcs optimize --modernize with an older darcs." -glump09 :: Patch -> Patch -> Patch -glump09 p1 p2 = fromPrims $ unsafeUnseal $ mangle_unravelled $ map Sealed $ unravel $ merger "0.0" p1 p2 - -#endif +glump09 :: Patch C(x y) -> Patch C(x z) -> Sealed (Patch C(y)) +glump09 p1 p2 = mapSeal fromPrims $ mangleUnravelled $ unseal unravel $ merger "0.0" p1 p2 -mangle_unravelled :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) -mangle_unravelled pss = if only_hunks pss - then (:>: NilFL) `mapSeal` mangle_unravelled_hunks pss +mangleUnravelled :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) +mangleUnravelled pss = if onlyHunks pss + then (:>: NilFL) `mapSeal` mangleUnravelledHunks pss else head pss -only_hunks :: [Sealed (FL Prim C(x))] -> Bool -only_hunks [] = False -only_hunks pss = fn2fp f /= "" && all oh pss - where f = get_a_filename pss +onlyHunks :: [Sealed (FL Prim C(x))] -> Bool +onlyHunks [] = False +onlyHunks pss = fn2fp f /= "" && all oh pss + where f = getAFilename pss oh :: Sealed (FL Prim C(x)) -> Bool oh (Sealed (p:>:ps)) = primIsHunk p && [fn2fp f] == listTouchedFiles p && oh (Sealed ps) oh (Sealed NilFL) = True -apply_hunks :: [Maybe B.ByteString] -> FL Prim C(x y) -> [Maybe B.ByteString] -apply_hunks ms (FP _ (Hunk l o n):>:ps) = apply_hunks (rls l ms) ps +applyHunks :: [Maybe B.ByteString] -> FL Prim C(x y) -> [Maybe B.ByteString] +applyHunks ms (FP _ (Hunk l o n):>:ps) = applyHunks (rls l ms) ps where rls 1 mls = map Just n ++ drop (length o) mls rls i (ml:mls) = ml : rls (i-1) mls - rls _ [] = bug "rls in apply_hunks" -apply_hunks ms NilFL = ms -apply_hunks _ (_:>:_) = impossible - -get_old :: [Maybe B.ByteString] -> [Sealed (FL Prim C(x))] -> [Maybe B.ByteString] -get_old mls (ps:pss) = get_old (get_hunks_old mls ps) pss -get_old mls [] = mls - -get_a_filename :: [Sealed (FL Prim C(x))] -> FileName -get_a_filename ((Sealed (FP f _:>:_)):_) = f -get_a_filename _ = fp2fn "" + rls _ [] = bug "rls in applyHunks" +applyHunks ms NilFL = ms +applyHunks _ (_:>:_) = impossible + +getOld :: [Maybe B.ByteString] -> [Sealed (FL Prim C(x))] -> [Maybe B.ByteString] +getOld mls (ps:pss) = getOld (getHunksOld mls ps) pss +getOld mls [] = mls + +getAFilename :: [Sealed (FL Prim C(x))] -> FileName +getAFilename ((Sealed (FP f _:>:_)):_) = f +getAFilename _ = fp2fn "" -get_hunks_old :: [Maybe B.ByteString] -> Sealed (FL Prim C(x)) +getHunksOld :: [Maybe B.ByteString] -> Sealed (FL Prim C(x)) -> [Maybe B.ByteString] -get_hunks_old mls (Sealed ps) = - apply_hunks (apply_hunks mls ps) (invert ps) +getHunksOld mls (Sealed ps) = + applyHunks (applyHunks mls ps) (invert ps) -get_hunks_new :: [Maybe B.ByteString] -> Sealed (FL Prim C(x)) +getHunksNew :: [Maybe B.ByteString] -> Sealed (FL Prim C(x)) -> [Maybe B.ByteString] -get_hunks_new mls (Sealed ps) = apply_hunks mls ps +getHunksNew mls (Sealed ps) = applyHunks mls ps -get_hunkline :: [[Maybe B.ByteString]] -> Int -get_hunkline = ghl 1 +getHunkline :: [[Maybe B.ByteString]] -> Int +getHunkline = ghl 1 where ghl :: Int -> [[Maybe B.ByteString]] -> Int ghl n pps = if any (isJust . head) pps then n else ghl (n+1) $ map tail pps -make_chunk :: Int -> [Maybe B.ByteString] -> [B.ByteString] -make_chunk n mls = pull_chunk $ drop (n-1) mls +makeChunk :: Int -> [Maybe B.ByteString] -> [B.ByteString] +makeChunk n mls = pull_chunk $ drop (n-1) mls where pull_chunk (Just l:mls') = l : pull_chunk mls' pull_chunk (Nothing:_) = [] pull_chunk [] = bug "should this be [] in pull_chunk?" -mangle_unravelled_hunks :: [Sealed (FL Prim C(x))] -> Sealed (Prim C(x)) ---mangle_unravelled_hunks [[h1],[h2]] = Deal with simple cases handily? -mangle_unravelled_hunks pss = - if null nchs then bug "mangle_unravelled_hunks" +mangleUnravelledHunks :: [Sealed (FL Prim C(x))] -> Sealed (Prim C(x)) +--mangleUnravelledHunks [[h1],[h2]] = Deal with simple cases handily? +mangleUnravelledHunks pss = + if null nchs then bug "mangleUnravelledHunks" else Sealed (FP filename (Hunk l old new)) - where oldf = get_old (repeat Nothing) pss - newfs = map (get_hunks_new oldf) pss - l = get_hunkline $ oldf : newfs - nchs = sort $ map (make_chunk l) newfs - filename = get_a_filename pss - old = make_chunk l oldf + where oldf = getOld (repeat Nothing) pss + newfs = map (getHunksNew oldf) pss + l = getHunkline $ oldf : newfs + nchs = sort $ map (makeChunk l) newfs + filename = getAFilename pss + old = makeChunk l oldf new = [top] ++ concat (intersperse [middle] nchs) ++ [bottom] top = BC.pack $ "v v v v v v v" ++ eol_c middle = BC.pack $ "*************" ++ eol_c @@ -790,27 +774,35 @@ else "" instance Effect Patch where - effect p@(Merger _ _ _ _) = sortCoalesceFL $ effect $ merger_undo p + effect p@(Merger _ _ _ _) = sortCoalesceFL $ effect $ mergerUndo p effect p@(Regrem _ _ _ _) = invert $ effect $ invert p effect (ComP ps) = concatFL $ mapFL_FL effect ps effect (PP p) = effect p isHunk p = do PP p' <- return p isHunk p' +-- |@modernizePatch@ is used during conversion to Darcs 2 format. +-- It does the following: +-- +-- * removes mergers by linearising them, thus removing the ability +-- to commute them +-- +-- * drops mv a b ; add b which was introduced by an error in earlier +-- versions of darcs (TODO: check this; identify the versions) modernizePatch :: Patch C(x y) -> Patch C(x y) modernizePatch p@(Merger _ _ _ _) = fromPrims $ effect p modernizePatch p@(Regrem _ _ _ _) = fromPrims $ effect p modernizePatch (ComP ps) = ComP $ filtermv $ mapFL_FL modernizePatch ps where filtermv :: FL Patch C(x y) -> FL Patch C(x y) -#ifndef GADT_WITNESSES - filtermv (PP (Move _ b):>:xs) | hasadd xs = filtermv xs - where hasadd (PP (FP b' AddFile):>:_) | b' == b = True - hasadd (PP (DP b' AddDir):>:_) | b' == b = True - hasadd (PP (FP b' RmFile):>:_) | b' == b = False - hasadd (PP (DP b' RmDir):>:_) | b' == b = False + filtermv (PP (Move _ b :: Prim C(x z)):>:xs) + | IsEq <- hasadd xs = filtermv xs + where hasadd :: FL Patch C(a b) -> EqCheck C(x z) + hasadd (PP (FP b' AddFile):>:_) | b' == b = unsafeCoerceP IsEq + hasadd (PP (DP b' AddDir):>:_) | b' == b = unsafeCoerceP IsEq + hasadd (PP (FP b' RmFile):>:_) | b' == b = NotEq + hasadd (PP (DP b' RmDir):>:_) | b' == b = NotEq hasadd (_:>:z) = hasadd z - hasadd NilFL = False -#endif + hasadd NilFL = NotEq filtermv (x:>:xs) = x :>: filtermv xs filtermv NilFL = NilFL @@ -818,32 +810,26 @@ instance FromPrims Patch where fromPrims (p :>: NilFL) = PP p - fromPrims ps = join_patchesFL $ mapFL_FL PP ps - joinPatches = join_patchesFL + fromPrims ps = joinPatchesFL $ mapFL_FL PP ps + joinPatches = joinPatchesFL -#ifndef GADT_WITNESSES -new_ur :: Patch -> RL Patch -> [RL Patch] -new_ur p (Merger _ _ p1 p2 :<: ps) = - case filter ((`unsafeCompare` p1) . headRL) $ head_permutationsRL ps of - ((_:<:ps'):_) -> new_ur p (p1:<:ps') ++ new_ur p (p2:<:ps') - _ -> bugDoc $ text "in function new_ur" +newUr :: Patch C(a b) -> RL Patch C(x y) -> [Sealed (RL Patch C(x))] +newUr p (Merger _ _ p1 p2 :<: ps) = + case filter (\(pp:<:_) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of + ((_:<:ps'):_) -> newUr p (unsafeCoercePStart p1:<:ps') ++ newUr p (unsafeCoercePStart p2:<:ps') + _ -> bugDoc $ text "in function newUr" $$ text "Original patch:" $$ showPatch_ p $$ text "Unwound:" - $$ vcat (mapRL showPatch_ $ unwind p) + $$ vcat (unseal (mapRL showPatch_) $ unwind p) -new_ur op ps = - case filter (isMerger.headRL) $ head_permutationsRL ps of - [] -> [ps] - (ps':_) -> new_ur op ps' - -headRL :: RL a -> a -headRL (x:<:_) = x -headRL _ = bug "bad headRL" -#endif +newUr op ps = + case filter (\(p:<:_) -> isMerger p) $ headPermutationsRL ps of + [] -> [Sealed ps] + (ps':_) -> newUr op ps' instance Invert p => Invert (Named p) where - invert (NamedP n d p) = NamedP (invert_name n) (map invert_name d) (invert p) + invert (NamedP n d p) = NamedP (invertName n) (map invertName d) (invert p) identity = NamedP idpatchinfo [] identity instance Invert Patch where @@ -856,29 +842,29 @@ identity = ComP NilFL instance MyEq Patch where - unsafeCompare = eq_patches + unsafeCompare = eqPatches instance MyEq p => MyEq (Named p) where unsafeCompare (NamedP n1 d1 p1) (NamedP n2 d2 p2) = n1 == n2 && d1 == d2 && unsafeCompare p1 p2 -eq_patches :: Patch C(x y) -> Patch C(w z) -> Bool -eq_patches (PP p1) (PP p2) = unsafeCompare p1 p2 -eq_patches (ComP ps1) (ComP ps2) - = eq_FL eq_patches ps1 ps2 -eq_patches (ComP NilFL) (PP Identity) = True -eq_patches (PP Identity) (ComP NilFL) = True -eq_patches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) - = eq_patches p1a p2a && - eq_patches p1b p2b -eq_patches (Regrem _ _ p1a p1b) (Regrem _ _ p2a p2b) - = eq_patches p1a p2a && - eq_patches p1b p2b -eq_patches _ _ = False +eqPatches :: Patch C(x y) -> Patch C(w z) -> Bool +eqPatches (PP p1) (PP p2) = unsafeCompare p1 p2 +eqPatches (ComP ps1) (ComP ps2) + = eqFL eqPatches ps1 ps2 +eqPatches (ComP NilFL) (PP Identity) = True +eqPatches (PP Identity) (ComP NilFL) = True +eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) + = eqPatches p1a p2a && + eqPatches p1b p2b +eqPatches (Regrem _ _ p1a p1b) (Regrem _ _ p2a p2b) + = eqPatches p1a p2a && + eqPatches p1b p2b +eqPatches _ _ = False -eq_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool) +eqFL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool) -> FL a C(x y) -> FL a C(w z) -> Bool -eq_FL _ NilFL NilFL = True -eq_FL f (x:>:xs) (y:>:ys) = f x y && eq_FL f xs ys -eq_FL _ _ _ = False +eqFL _ NilFL NilFL = True +eqFL f (x:>:xs) (y:>:ys) = f x y && eqFL f xs ys +eqFL _ _ _ = False \end{code} diff -ruN darcs-2.4.4/src/Darcs/Patch/Core.lhs darcs-2.5/src/Darcs/Patch/Core.lhs --- darcs-2.4.4/src/Darcs/Patch/Core.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Core.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -27,21 +27,21 @@ module Darcs.Patch.Core ( Patch(..), Named(..), - join_patchesFL, concatFL, flattenFL, + joinPatchesFL, concatFL, flattenFL, nullP, isNullPatch, infopatch, - n_fn, + nFn, adddeps, namepatch, anonymous, - merger_undo, isMerger, + mergerUndo, isMerger, getdeps, patch2patchinfo, patchname, patchcontents, ) where import Prelude hiding ( pi ) -import Darcs.Patch.Info ( PatchInfo, patchinfo, make_filename ) +import Darcs.Patch.Info ( PatchInfo, patchinfo, makeFilename ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Witnesses.Ordered -import Darcs.Patch.Prim ( Prim(..), FromPrim(..), Effect(effect, effectRL), n_fn ) +import Darcs.Patch.Prim ( Prim(..), FromPrim(..), Effect(effect, effectRL), nFn ) #include "impossible.h" data Patch C(x y) where @@ -90,9 +90,9 @@ isMerger (Regrem _ _ _ _) = True isMerger _ = False -merger_undo :: Patch C(x y) -> Patch C(x y) -merger_undo (Merger undo _ _ _) = undo -merger_undo _ = impossible +mergerUndo :: Patch C(x y) -> Patch C(x y) +mergerUndo (Merger undo _ _ _) = undo +mergerUndo _ = impossible \end{code} %Another nice thing to be able to do with composite patches is to `flatten' @@ -106,8 +106,8 @@ flattenFL (PP Identity) = NilFL flattenFL p = p :>: NilFL -join_patchesFL :: FL Patch C(x y) -> Patch C(x y) -join_patchesFL ps = ComP $! ps +joinPatchesFL :: FL Patch C(x y) -> Patch C(x y) +joinPatchesFL ps = ComP $! ps infopatch :: Patchy p => PatchInfo -> p C(x y) -> Named p C(x y) adddeps :: Named p C(x y) -> [PatchInfo] -> Named p C(x y) @@ -130,7 +130,7 @@ patch2patchinfo (NamedP i _ _) = i patchname :: Named p C(x y) -> String -patchname (NamedP i _ _) = make_filename i +patchname (NamedP i _ _) = makeFilename i patchcontents :: Named p C(x y) -> p C(x y) patchcontents (NamedP _ _ p) = p diff -ruN darcs-2.4.4/src/Darcs/Patch/Depends.hs darcs-2.5/src/Darcs/Patch/Depends.hs --- darcs-2.4.4/src/Darcs/Patch/Depends.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Depends.hs 2010-10-24 08:29:26.000000000 -0700 @@ -16,59 +16,42 @@ -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -cpp -fglasgow-exts #-} -{-# LANGUAGE CPP #-} --- , ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE CPP , ScopedTypeVariables #-} +--, TypeOperators #-} #include "gadts.h" -module Darcs.Patch.Depends ( get_common_and_uncommon, get_tags_right, - get_common_and_uncommon_or_missing, - optimize_patchset, deep_optimize_patchset, - slightly_optimize_patchset, - get_patches_beyond_tag, get_patches_in_tag, - patchset_union, patchset_intersection, - commute_to_end, +module Darcs.Patch.Depends ( getTagsRight, + areUnrelatedRepos, + mergeThem, findCommonWithThem, + countUsThem, removeFromPatchSet, + optimizePatchset, deepOptimizePatchset, + slightlyOptimizePatchset, + getPatchesBeyondTag, getPatchesInTag, + splitOnTag, + newsetUnion, newsetIntersection, + commuteToEnd, findUncommon, merge2FL ) where -import Data.List ( delete, intersect ) -import Control.Monad ( liftM2 ) -import Control.Monad.Error ( Error(..) ) - -import Darcs.Patch ( RepoPatch, Named, getdeps, commute, - commuteFL, - patch2patchinfo, merge ) -import Darcs.Witnesses.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..), - RL(..), FL(..), - (+<+), - reverseFL, mapFL_FL, mapFL, concatReverseFL, - lengthRL, concatRL, reverseRL, mapRL, - unsafeCoerceP, EqCheck(..) ) -import Darcs.Patch.Permutations ( partitionRL ) -import Darcs.Patch.Info ( PatchInfo, human_friendly, is_tag ) -import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) -import Darcs.Patch.Patchy ( sloppyIdentity ) -import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia, - hopefully, conscientiously, hopefullyM ) +import Data.List ( delete, intersect, (\\) ) + +import Darcs.Patch ( RepoPatch, getdeps, commute, commuteFLorComplain, commuteRL ) +import Darcs.Patch.Info ( PatchInfo, isTag, humanFriendly ) +import Darcs.Patch.Patchy ( mergeFL ) +import Darcs.Patch.Permutations ( partitionFL, partitionRL, removeSubsequenceRL ) +import Darcs.Hopefully( PatchInfoAnd, hopefully, hopefullyM, info ) +import Darcs.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..), (:>)(..), (:>>)(..), + (=\/=), (=/\=), (+>+), EqCheck(..), mapFL, + RL(..), FL(..), isShorterThanRL, (+<+), + reverseFL, reverseRL, mapRL, unsafeCoerceP, unsafeCoercePStart ) +import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif import Darcs.ProgressPatches ( progressRL ) -import Darcs.Witnesses.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..) - , flipSeal, seal, unseal, mapFlipped ) -import Printer ( errorDoc, renderString, ($$), text ) +import Darcs.Witnesses.Sealed (Sealed(..), FlippedSeal(..), flipSeal, seal ) +import Printer ( renderString, vcat ) #include "impossible.h" -get_common_and_uncommon :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> - ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) -get_common_and_uncommon_or_missing :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> - Either PatchInfo ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) - -get_common_and_uncommon = - either missingPatchError id . get_common_and_uncommon_err - -get_common_and_uncommon_or_missing = - either (\(MissingPatch x _) -> Left x) Right . get_common_and_uncommon_err - -get_common_and_uncommon_err :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> - Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) -get_common_and_uncommon_err (ps1,ps2) = gcau (optimize_patchset ps1) ps2 - {-| with_partial_intersection takes two 'PatchSet's and splits them into a /common/ intersection portion and two sets of patches. The intersection, however, @@ -77,334 +60,85 @@ efficient function, because it makes use of the already-broken-up nature of 'PatchSet's. -'PatchSet's have the property that if -@ -(info $ last $ head a) == (info $ last $ head b) -@ -then @(tail a)@ and @(tail b)@ are identical repositories, and we want to take -advantage of this if possible, to avoid reading too many inventories. In -the case of --partial repositories or patch bundles, it is crucial that we -don't need to read the whole history, since it isn't available. - -TODO: - -The length equalising isn't necessarily right. We probably also be -thinking about not going past the end of a partial repository, or favour -local repository stuff over remote repository stuff. - -Also, when comparing l1 to l2, we should really be comparing the -newly discovered one to /all/ the lasts in the other patch set -that we've got so far. --} -with_partial_intersection :: forall a p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y) - -> (FORALL(z) PatchSet p C(z) -> RL (PatchInfoAnd p) C(z x) - -> RL (PatchInfoAnd p) C(z y) -> a) - -> a -with_partial_intersection NilRL ps2 j = j (NilRL:<:NilRL) NilRL (concatRL ps2) -with_partial_intersection ps1 NilRL j = j (NilRL:<:NilRL) (concatRL ps1) NilRL -with_partial_intersection (NilRL:<:ps1) ps2 j = - with_partial_intersection ps1 ps2 j -with_partial_intersection ps1 (NilRL:<:ps2) j = - with_partial_intersection ps1 ps2 j --- NOTE: symmetry is broken here, so we want the PatchSet with more history --- first! -with_partial_intersection ((pi1:<:NilRL):<:common) ((pi2:<:NilRL):<:_) j --- NOTE: Since the patchsets have the same starting but different ending --- we can coerce them. The type system is not aware of our invariant on tags, --- but both pi1 and pi2 should be tags, thus we check they are both identity --- patches. - | info pi1 == info pi2 - , IsEq <- sloppyIdentity pi1 - , IsEq <- sloppyIdentity pi2 = j common NilRL (unsafeCoerceP NilRL) -with_partial_intersection (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s) j - = f (lengthRL orig_ps1) (last $ mapRL info orig_ps1) (orig_ps1:>:NilFL) orig_ps1s - (lengthRL orig_ps2) (last $ mapRL info orig_ps2) (orig_ps2:>:NilFL) orig_ps2s - where {- Invariants: nx = length $ concatReverseFL psx - lx = last $ concatReverseFL psx -} - f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r) - -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u) - -> a - f _n1 l1 ps1 ps1s _n2 l2 ps2 _ps2s - | l1 == l2 = j ps1s (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2)) - f n1 l1 ps1 ps1s n2 l2 ps2 ps2s - = case compare n1 n2 of - GT -> case dropWhileNilRL ps2s of - ps2':<:ps2s' -> - f n1 l1 ps1 ps1s - (n2 + lengthRL ps2') (last $ mapRL info ps2') (ps2':>:ps2) ps2s' - NilRL -> -- We keep going round f so the l1 == l2 case - -- has a chance to kick in - case dropWhileNilRL ps1s of - ps1':<:ps1s' -> - f (n1 + lengthRL ps1') (last $ mapRL info ps1') - (ps1':>:ps1) ps1s' - n2 l2 ps2 ps2s - NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2) - _ -> case dropWhileNilRL ps1s of - ps1':<:ps1s' -> - f (n1 + lengthRL ps1') (last $ mapRL info ps1') (ps1':>:ps1) ps1s' - n2 l2 ps2 ps2s - NilRL -> -- We keep going round f so the l1 == l2 case - -- has a chance to kick in - case dropWhileNilRL ps2s of - ps2':<:ps2s' -> - f n1 l1 ps1 NilRL - (n2 + lengthRL ps2') (last $ mapRL info ps2') - (ps2':>:ps2) ps2s' - NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2) - -{-| -'gcau' determines a list of /common/ patches and patches unique to each of -the two 'PatchSet's. The list of /common/ patches only needs to include all -patches that are not interspersed with the /unique/ patches, but including -more patches in the list of /common/ patches doesn't really hurt, except -for efficiency considerations. Mostly, we want to access as few elements -as possible of the 'PatchSet' list, since those can be expensive (or -unavailable). In other words, the /common/ patches need not be minimal, -whereas the 'PatchSet's should be minimal for performance reasons. - -'PatchSet's have the property that if -@ -(info $ last $ head a) == (info $ last $ head b) -@ -then @(tail a)@ and @(tail b)@ are identical repositories, and we want to take -advantage of this if possible, to avoid reading too many inventories. In -the case of --partial repositories or patch bundles, it is crucial that we -don't need to read the whole history, since it isn't available. - -TODO: - -The length equalising isn't necessarily right. We probably also be -thinking about not going past the end of a partial repository, or favour -local repository stuff over remote repo stuff. - -Also, when comparing l1 to l2, we should really be comparing the -newly discovered one to /all/ the lasts in the other patch set -that we've got so far. +Note that the first argument to with_partial_intersection should be +the repository that is more cheaply accessed (i.e. local), as +with_partial_intersection does its best to reduce the number of +inventories that are accessed from its rightmost argument. -} -gcau :: forall p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y) - -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) -gcau NilRL ps2 = return ([], NilRL :\/: concatRL ps2) -gcau ps1 NilRL = return ([], concatRL ps1 :\/: NilRL) -gcau (NilRL:<:ps1) ps2 = gcau ps1 ps2 -gcau ps1 (NilRL:<:ps2) = gcau ps1 ps2 -gcau ((pi1:<:NilRL):<:_) ((pi2:<:NilRL):<:_) - | info pi1 == info pi2 - , IsEq <- sloppyIdentity pi1 - , IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL :\/: unsafeCoerceP NilRL) -gcau (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s) - = f (lengthRL orig_ps1) (unseal info $ lastRL orig_ps1) (orig_ps1:>:NilFL) orig_ps1s - (lengthRL orig_ps2) (unseal info $ lastRL orig_ps2) (orig_ps2:>:NilFL) orig_ps2s - where {- Invariants: nx = lengthRL $ concatReverseFL psx - lx = last $ concatReverseFL psx -} - f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r) - -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u) - -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) - f _n1 l1 ps1 _ps1s _n2 l2 ps2 _ps2s - | l1 == l2 = gcau_simple (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2)) - f n1 l1 ps1 ps1s n2 l2 ps2 ps2s - = case n1 `compare` n2 of - GT -> case dropWhileNilRL ps2s of - ps2':<:ps2s' -> - f n1 l1 ps1 ps1s - (n2 + lengthRL ps2') (unseal info $ lastRL ps2') (ps2':>:ps2) ps2s' - NilRL -> -- We keep going round f so the l1 == l2 case - -- has a chance to kick in - case dropWhileNilRL ps1s of - ps1':<:ps1s' -> - f (n1 + lengthRL ps1') (unseal info $ lastRL ps1') - (ps1':>:ps1) ps1s' - n2 l2 ps2 ps2s - NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2) - _ -> case dropWhileNilRL ps1s of - ps1':<:ps1s' -> - f (n1 + lengthRL ps1') (unseal info $ lastRL ps1') (ps1':>:ps1) ps1s' - n2 l2 ps2 ps2s - NilRL -> -- We keep going round f so the l1 == l2 case - -- has a chance to kick in - case dropWhileNilRL ps2s of - ps2':<:ps2s' -> - f n1 l1 ps1 NilRL - (n2 + lengthRL ps2') (unseal info $ lastRL ps2') - (ps2':>:ps2) ps2s' - NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2) - -lastRL :: RL a C(x y) -> Sealed (a C(x)) -lastRL (a:<:NilRL) = seal a -lastRL (_:<:as) = lastRL as -lastRL NilRL = bug "lastRL on empty list" - -dropWhileNilRL :: PatchSet p C(x) -> PatchSet p C(x) -dropWhileNilRL (NilRL:<:xs) = dropWhileNilRL xs -dropWhileNilRL xs = xs - --- | Filters the common elements from @ps1@ and @ps2@ and returns the simplified sequences. -gcau_simple :: RepoPatch p => RL (PatchInfoAnd p) C(x y) -- ^ @ps1@ - -> RL (PatchInfoAnd p) C(u v) -- ^ @ps2@ - -> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(y v)) -gcau_simple ps1 ps2 = do - FlippedSeal ex1 <- get_extra common ps1 - FlippedSeal ex2 <- get_extra common ps2 - let ps1' = filter (`elem` common) $ ps1_info - return (ps1', (unsafeCoerceP ex1 :\/: ex2)) - where common = ps1_info `intersect` mapRL info ps2 - ps1_info = mapRL info ps1 - -data MissingPatch = MissingPatch !PatchInfo !String - -instance Error MissingPatch where - -- we don't really need those methods - noMsg = bug "MissingPatch doesn't define noMsg." - --- | Returns a sub-sequence from @patches@, where all the elements of @common@ have --- been removed by commuting them back into the early part of the history. --- --- An informal illustration of this process as it traverses a mixed list of patches --- where C and x denote common patches and extra patches accordingly. Variants of --- patches obtained through commutation are indicated by letters following the --- patch name. --- --- > in: x6 < x5 < C4 < x3 < C2 < x1 skip: extra: --- > in: x5 < C4 < x3 < C2 < x1 skip: extra: x6 --- > in: C4 < x3 < C2 < x1 skip: extra: x5 > x6 --- > in: x3 < C2 < x1 skip: C4 extra: x5 > x6 --- > in: C2 < x1 skip: C4b extra: x3b > x5 > x6 --- > in: x1 skip: C2 > C4b extra: x3b > x5 > x6 --- > in: skip: C2b > C4c extra: x1b > x3b > x5 > x6 --- --- This function is undefined if for any reason we fail to commute an extra --- patch past one of the common ones. Such a failure would indicate that the --- common patch depends on the extra one, contradicting the claim that the --- \"common\" patch is shared with another repository lacking the extra patches. --- Unfortunately, such cases have crept up in practice. Some notable cases can --- be found on the bugtracker as: --- --- * issue27 - different patches with identical patch info; mistaken identity. --- Note how @common@ consists only of a list of 'PatchInfo' which --- we trust to uniquely identify such patches. --- --- * issue1014 - duplicate patches -get_extra :: RepoPatch p => [PatchInfo] -- ^ @common@ - -> RL (PatchInfoAnd p) C(u x) -- ^ @patches@ - -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y)) -get_extra = get_extra_aux (return $ unsafeCoerceP NilFL) - where - get_extra_aux :: RepoPatch p => Either MissingPatch (FL (Named p) C(x y)) - -> [PatchInfo] - -> RL (PatchInfoAnd p) C(u x) - -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y)) - get_extra_aux _ _ NilRL = return (flipSeal NilRL) - get_extra_aux skipped common (hp:<:pps) = - if info hp `elem` common && is_tag (info hp) - then case getdeps `fmap` hopefullyM hp of - Just ds -> get_extra_aux (liftM2 (:>:) ep skipped) (ds++delete (info hp) common) pps - Nothing -> get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps - else if info hp `elem` common - then get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps - else do - p <- ep - skpd <- skipped - case commuteFL (p :> skpd) of - Right (skipped_patch' :> p') -> do - FlippedSeal x <- get_extra_aux (return skipped_patch') common pps - return $ flipSeal (info hp `piap` p' :<: x) - -- Failure to commute indicates a bug because it means - -- that a patch was interspersed between the common - -- patches. This should only happen if that patch was - -- commuted there. This uses 2 properties: - -- 1) commute is its own inverse - -- 2) if patches commute in one adjacent context then - -- they commute in any context where they are - -- adjacent - Left (Sealed2 hpc) -> errorDoc $ text "bug in get_extra commuting patches:" - $$ text "First patch is:" - $$ human_friendly (info hp) - $$ text "Second patch is:" - $$ human_friendly (info $ n2pia hpc) - where ep = case hopefullyM hp of - Right p' -> return p' - Left e -> Left (MissingPatch (info hp) e) - -missingPatchError :: MissingPatch -> a -missingPatchError (MissingPatch pinfo e) = - errorDoc - ( text "failed to read patch in get_extra:" - $$ human_friendly pinfo $$ text e - $$ text "Perhaps this is a 'partial' repository?" ) - -get_extra_old :: RepoPatch p => [PatchInfo] - -> RL (PatchInfoAnd p) C(u x) - -> FlippedSeal (RL (PatchInfoAnd p)) C(y) -get_extra_old common pps = - either missingPatchError id (get_extra common pps) - -get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (PatchInfoAnd p)) C(x) -get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal NilRL -get_patches_beyond_tag t patchset@((hp:<:ps):<:pps) = +with_partial_intersection + :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) + -> (FORALL(a c) RL (Tagged p) C(start a) + -> RL (PatchInfoAnd p) C(a x) + -> RL (PatchInfoAnd p) C(a c) + -> ddd) + -> ddd +with_partial_intersection (PatchSet ps1 NilRL) s j = j NilRL ps1 (newset2RL s) +with_partial_intersection s (PatchSet ps2 NilRL) j = + j NilRL (newset2RL s) ps2 +with_partial_intersection bbb (PatchSet a (Tagged ta _ _ :<: _)) j + | Just (PatchSet b t) <- simpleTag (info ta) bbb = j t b (unsafeCoerceP a) +with_partial_intersection aaa (PatchSet b (Tagged tb _ pb :<: tbs)) j + = case hopefullyM tb of + Just _ -> with_partial_intersection aaa (PatchSet (b+<+tb:<:pb) tbs) j + Nothing -> case splitOnTag (info tb) aaa of + PatchSet NilRL com :>> us -> j com us (unsafeCoerceP b) + _ -> impossible + +getPatchesBeyondTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> FlippedSeal (RL (PatchInfoAnd p)) C(x) +getPatchesBeyondTag t (PatchSet ps (Tagged hp _ _ :<:_)) | info hp == t = flipSeal ps +getPatchesBeyondTag t patchset@(PatchSet (hp:<:ps) ts) = if info hp == t - then if get_tags_right patchset == [info hp] - then flipSeal NilRL -- special case to avoid looking at redundant patches - else get_extra_old [t] (concatRL patchset) - else mapFlipped (hp:<:) $ get_patches_beyond_tag t (ps:<:pps) -get_patches_beyond_tag t (NilRL:<:pps) = get_patches_beyond_tag t pps -get_patches_beyond_tag t NilRL = bug $ "tag\n" ++ - renderString (human_friendly t) ++ - "\nis not in the patchset in get_patches_beyond_tag." + then if getTagsRight patchset == [info hp] + then flipSeal $ NilRL -- special case to avoid looking at redundant patches + else case splitOnTag t patchset of _ :>> e -> flipSeal e + else case getPatchesBeyondTag t (PatchSet ps ts) of + FlippedSeal xxs -> FlippedSeal (hp :<: xxs) +getPatchesBeyondTag t (PatchSet NilRL NilRL) = bug $ "tag\n" ++ + renderString (humanFriendly t) ++ + "\nis not in the patchset in getPatchesBeyondTag." +getPatchesBeyondTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) = + getPatchesBeyondTag t0 (PatchSet (t:<:ps) ts) + +splitOnTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> (PatchSet p C(start) :>> RL (PatchInfoAnd p)) C(x) +splitOnTag t (PatchSet ps (Tagged hp x ps2 :<: ts)) + | info hp == t = (PatchSet NilRL (Tagged hp x ps2 :<: ts)) :>> ps +splitOnTag t patchset@(PatchSet (hp:<:ps) ts) + | info hp == t = if getTagsRight patchset == [info hp] + then PatchSet NilRL (Tagged hp Nothing ps :<: ts) :>> NilRL + else case partitionRL ((`notElem` (t:ds)) . info) (hp:<:ps) of + (x:<:a) :> b -> + if getTagsRight (PatchSet (x:<:a) ts) == [t] + then PatchSet NilRL (Tagged x Nothing a :<: ts) :>> b + else case splitOnTag t $ eatOne $ PatchSet (x:<:a) ts of + xx :>> yy -> xx :>> (b +<+ yy) + -- NilRL :> _ -> impossible + where ds = getdeps (hopefully hp) + eatOne :: PatchSet p C(start x) -> PatchSet p C(start x) + eatOne (PatchSet ps1 (Tagged x _ ps2 :<: ts')) = PatchSet (ps1+<+x:<:ps2) ts' + eatOne _ = bug "a stubborn case in splitOnTag (theoretically possible)" +splitOnTag t (PatchSet (p:<:ps) ts) = case splitOnTag t (PatchSet ps ts) of + ns :>> x -> ns :>> (p:<:x) +splitOnTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) = splitOnTag t0 (PatchSet (t:<:ps) ts) +splitOnTag t0 (PatchSet NilRL NilRL) = bug $ "tag\n" ++ + renderString (humanFriendly t0) ++ + "\nis not in the patchset in splitOnTag." --- | @get_patches_in_tag t ps@ returns a 'SealedPatchSet' of all +-- | @getPatchesInTag t ps@ returns a 'SealedPatchSet' of all -- patches in @ps@ which are contained in @t@. -get_patches_in_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> SealedPatchSet p -get_patches_in_tag t pps@((hp:<:NilRL):<:xs) - | info hp == t = seal pps - | otherwise = get_patches_in_tag t xs - -get_patches_in_tag t ((hp:<:ps):<:xs) - | info hp /= t = get_patches_in_tag t (ps:<:xs) - -get_patches_in_tag t ((pa:<:ps):<:xs) = gpit thepis (pa:>:NilFL) (ps:<:xs) - where thepis = getdeps $ conscientiously - (\e -> text "Couldn't read tag" - $$ human_friendly t - $$ text "" - $$ e) pa - gpit :: RepoPatch p => [PatchInfo] -> (FL (PatchInfoAnd p)) C(x y) -> PatchSet p C(x) -> SealedPatchSet p - gpit _ sofar NilRL = seal $ reverseFL sofar :<: NilRL - gpit deps sofar ((hp:<:NilRL):<:xs') - | info hp `elem` deps - , IsEq <- sloppyIdentity hp = seal $ (reverseFL $ hp :>: sofar) :<: xs' - | IsEq <- sloppyIdentity hp = gpit deps sofar xs' - gpit deps sofar (NilRL:<:xs') = gpit deps sofar xs' - gpit deps sofar ((hp:<:ps'):<:xs') - | info hp `elem` deps - = let odeps = filter (/=info hp) deps - alldeps = if is_tag $ info hp - then odeps ++ getdeps (hopefully hp) - else odeps - in gpit alldeps (hp:>:sofar) (ps':<:xs') - | otherwise - = gpit deps (commute_by sofar $ hopefully hp) (ps':<:xs') - commute_by :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> (Named p) C(w x) - -> FL (PatchInfoAnd p) C(w z) - commute_by NilFL _ = unsafeCoerceP NilFL - commute_by (hpa:>:xs') p = - case commute (p :> hopefully hpa) of - Nothing -> bug "Failure commuting patches in commute_by called by gpit!" - Just (a' :> p') -> (info hpa `piap` a') :>: commute_by xs' p' - -get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag" - $$ human_friendly t - -get_tags_right :: RL (RL (PatchInfoAnd p)) C(x y) -> [PatchInfo] -get_tags_right NilRL = [] -get_tags_right (ps:<:_) = get_tags_r (mapRL info_and_deps ps) +getPatchesInTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> SealedPatchSet p C(start) +getPatchesInTag t ns = case splitOnTag t ns of + ns' :>> _ -> seal ns' + +getTagsRight :: PatchSet p C(start x) -> [PatchInfo] +getTagsRight (PatchSet ps NilRL) = getTagsR (mapRL infoAndDeps ps) +getTagsRight (PatchSet ps (Tagged t _ _ :<: _)) = getTagsR (mapRL infoAndDeps (ps+<+t:<:NilRL)) + +getTagsR :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo] +getTagsR [] = [] +getTagsR ((i0,Nothing):pps0) = i0 : getTagsR pps0 +getTagsR ((i0,Just ds0):pps0) = i0 : getTagsR (drop_tags_r ds0 pps0) where - get_tags_r :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo] - get_tags_r [] = [] - get_tags_r (hp:pps) = case snd hp of - Just ds -> fst hp : get_tags_r (drop_tags_r ds pps) - Nothing -> fst hp : get_tags_r pps - drop_tags_r :: [PatchInfo] -> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])] drop_tags_r [] pps = pps @@ -414,105 +148,193 @@ Just ds' -> drop_tags_r (ds'++delete (fst hp) ds) pps Nothing -> drop_tags_r (delete (fst hp) ds) pps | otherwise = hp : drop_tags_r ds pps - - info_and_deps :: PatchInfoAnd p C(x y) -> (PatchInfo, Maybe [PatchInfo]) - info_and_deps p - | is_tag (info p) = (info p, getdeps `fmap` hopefullyM p) + +infoAndDeps :: PatchInfoAnd p C(x y) -> (PatchInfo, Maybe [PatchInfo]) +infoAndDeps p + | isTag (info p) = (info p, getdeps `fmap` hopefullyM p) | otherwise = (info p, Nothing) -deep_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x) -deep_optimize_patchset pss = optimize_patchset (concatRL pss :<: NilRL) +deepOptimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x) +deepOptimizePatchset ns = optimizePatchset (PatchSet (newset2RL ns) NilRL) -optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x) -optimize_patchset NilRL = NilRL -optimize_patchset (ps:<:pss) = opsp ps +<+ pss - where - opsp :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y) - opsp NilRL = NilRL - opsp (hp:<:pps) - | is_tag (info hp) && get_tags_right ((hp:<:pps):<:NilRL) == [info hp] - = (hp:<:NilRL) :<: opsp pps - | otherwise = hp -:- opsp pps - -(-:-) :: (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(a x) -> RL (RL (PatchInfoAnd p)) C(a y) -pp -:- NilRL = (pp:<:NilRL) :<: NilRL -pp -:- (p:<:ps) = ((pp:<:p) :<: ps) - -slightly_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x) -slightly_optimize_patchset NilRL = NilRL -slightly_optimize_patchset (ps:<:pss) = sops (progressRL "Optimizing inventory" ps) +<+ pss - where sops :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y) - sops NilRL = NilRL - sops (pinfomp :<: NilRL) = (pinfomp :<: NilRL) :<: NilRL - sops (hp:<:pps) | is_tag (info hp) = if get_tags_right ((hp:<:pps):<:NilRL) == [info hp] - then (hp:<:NilRL) :<: (pps:<: NilRL) - else hp -:- sops (progressRL "Optimizing inventory" pps) - | otherwise = hp -:- sops pps - -commute_to_end :: forall p C(x y). RepoPatch p => FL (Named p) C(x y) -> PatchSet p C(y) - -> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x) -commute_to_end select from = ctt (mapFL patch2patchinfo select) from NilFL - where --- In order to preserve the structure of the original PatchSet, we commute --- the patches we are going to throw away past the patches we plan to keep. --- This puts them at the end of the PatchSet where it is safe to discard them. --- We return all the patches in the PatchSet which have been commuted. - ctt :: [PatchInfo] -> PatchSet p C(v) -> FL (Named p) C(v u) - -> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x) - -- This unsafeCoerceP should be fine, because if we run out of - -- patches in the selection the ending context of the second param - -- should be x (because we have commute all of the selected sequence, - -- with context C(x y), past the elements of the second parameter. - -- Unfortunately this is hard to express in the type system while - -- using an accumulator to build up the return value. - ctt [] ps acc = (unsafeCoerceP acc) :< ps - ctt sel (NilRL:<:ps) acc = ctt sel ps acc - ctt sel ((hp:<:hps):<:ps) acc - | info hp `elem` sel - = case commuteFL (hopefully hp :> acc) of - Left _ -> bug "patches to commute_to_end does not commutex (1)" - Right (acc' :> _) -> ctt (delete (info hp) sel) (hps:<:ps) acc' - | otherwise - = ctt sel (hps:<:ps) (hopefully hp:>:acc) - ctt _ _ _ = bug "patches to commute_to_end does not commutex (2)" - -patchset_intersection :: RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p -patchset_intersection [] = seal (NilRL :<: NilRL) -patchset_intersection [x] = x -patchset_intersection (Sealed y:ys) = - case patchset_intersection ys of - Sealed ys' -> with_partial_intersection y ys' $ - \common a b -> - case mapRL info a `intersect` mapRL info b of - morecommon -> - case partitionRL (\e -> info e `notElem` morecommon) a of - commonps :> _ -> seal $ commonps :<: common - -patchset_union :: forall p. RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p -patchset_union [] = seal (NilRL :<: NilRL) -patchset_union [x] = x -patchset_union (Sealed y:ys) = - case patchset_union ys of - Sealed ys' -> with_partial_intersection y ys' f - where - f :: FORALL(z x y) PatchSet p C(z) -- ^ @common@ - -> RL (PatchInfoAnd p) C(z x) -- ^ @a@ - -> RL (PatchInfoAnd p) C(z y) -- ^ @b@ - -> SealedPatchSet p - f common a b = g_s $ gcau_simple a b - where - g_s :: Either MissingPatch - ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y)) - -> SealedPatchSet p - g_s (Left e) = missingPatchError e - g_s (Right (_, a' :\/: b')) = - case (merge_sets (a' :\/: b')) of - Sealed a'b' -> seal $ (a'b' +<+ b) :<: common - -merge_sets :: RepoPatch p => (RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y) -> Sealed (RL (PatchInfoAnd p) C(y)) -merge_sets (l :\/: r) = - let pl = mapFL_FL hopefully $ reverseRL l - pr = mapFL_FL hopefully $ reverseRL r - p2pimp p = patch2patchinfo p `piap` p - in case merge (pl:\/: pr) of - (_:/\:pl') -> seal $ reverseFL $ mapFL_FL p2pimp pl' +optimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x) +optimizePatchset (PatchSet NilRL ts) = PatchSet NilRL ts +optimizePatchset (PatchSet (p:<:ps) ts) + | isTag (info p) && getTagsRight (PatchSet (p:<:ps) ts) == [info p] + = case optimizePatchset (PatchSet ps ts) of + PatchSet ps' ts' -> PatchSet NilRL (Tagged p Nothing ps' :<: ts') + | otherwise = case optimizePatchset (PatchSet ps ts) of + PatchSet ps' ts' -> PatchSet (p:<:ps') ts' + +slightlyOptimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x) +slightlyOptimizePatchset (PatchSet ps0 ts0) = sops $ PatchSet (progressRL "Optimizing inventory" ps0) ts0 + where sops :: PatchSet p C(start y) -> PatchSet p C(start y) + sops (PatchSet NilRL ts) = PatchSet NilRL ts + sops (PatchSet (hp:<:ps) ts) + | isTag (info hp) = if getTagsRight (PatchSet (hp:<:ps) ts) == [info hp] + then PatchSet NilRL (Tagged hp Nothing ps :<: ts) + else case sops $ PatchSet (progressRL "Optimizing inventory" ps) ts of + PatchSet ps' ts' -> PatchSet (hp:<:ps') ts' + | otherwise = case sops $ PatchSet ps ts of + PatchSet ps' ts' -> PatchSet (hp:<:ps') ts' + +commuteToEnd :: forall p C(start x y). RepoPatch p => RL (PatchInfoAnd p) C(x y) + -> PatchSet p C(start y) -> (PatchSet p C(start) :>> RL (PatchInfoAnd p)) C(x) +commuteToEnd NilRL (PatchSet ps ts) = PatchSet NilRL ts :>> ps +commuteToEnd (p:<:ps) (PatchSet xs ts) + | info p `elem` mapRL info xs = case fastRemoveRL p xs of + Just xs' -> commuteToEnd ps (PatchSet xs' ts) + Nothing -> impossible -- "Nothing is impossible" +commuteToEnd ps (PatchSet xs (Tagged t _ ys :<: ts)) = + commuteToEnd ps (PatchSet (xs+<+t:<:ys) ts) +commuteToEnd _ _ = impossible + +removeFromPatchSet :: RepoPatch p => FL (PatchInfoAnd p) C(x y) + -> PatchSet p C(start y) -> Maybe (PatchSet p C(start x)) +removeFromPatchSet bad0 = rfns (reverseFL bad0) + where rfns :: RepoPatch p => RL (PatchInfoAnd p) C(x y) + -> PatchSet p C(start y) -> Maybe (PatchSet p C(start x)) + rfns bad (PatchSet ps ts) + | all (`elem` (mapRL info ps)) (mapRL info bad) = + do ps' <- removeSubsequenceRL bad ps + Just $ PatchSet ps' ts + rfns _ (PatchSet _ NilRL) = Nothing + rfns bad (PatchSet ps (Tagged t _ tps :<: ts)) = + rfns bad (PatchSet (ps+<+t:<:tps) ts) + +findCommonWithThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) + -> (PatchSet p C(start) :>> FL (PatchInfoAnd p)) C(x) +findCommonWithThem us them = + with_partial_intersection us them $ + \common us' them' -> + case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of + _ :> bad@(_:>:_) :> _ -> bug $ "Failed to commute common patches:\n" ++ + (renderString $ vcat $ mapRL (humanFriendly . info) $ reverseFL bad) + common2 :> _ :> only_ours -> PatchSet (reverseFL common2) common :>> unsafeCoerceP only_ours + +findUncommon :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) + -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(x y) +findUncommon us them = + case findCommonWithThem us them of + common :>> us' -> case findCommonWithThem them us of + _ :>> them' -> unsafeCoercePStart us' :\/: them' + +countUsThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) -> (Int, Int) +countUsThem us them = + with_partial_intersection us them $ + \_ us' them' -> let uu = mapRL info us' + tt = mapRL info them' + in (length $ uu \\ tt, length $ tt \\ uu) + +mergeThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) + -> Sealed (FL (PatchInfoAnd p) C(x)) +mergeThem us them = + with_partial_intersection us them $ + \_ us' them' -> merge2FL (reverseRL us') (reverseRL them') + +newsetIntersection :: RepoPatch p => [SealedPatchSet p C(start)] -> SealedPatchSet p C(start) +newsetIntersection [] = seal $ PatchSet NilRL NilRL +newsetIntersection [x] = x +newsetIntersection (Sealed y:ys) = + case newsetIntersection ys of + Sealed z -> with_partial_intersection y z $ + \common a b -> + case mapRL info a `intersect` mapRL info b of + morecommon -> + case partitionRL (\e -> info e `notElem` morecommon) a of + commonps :> _ -> seal $ PatchSet commonps common + +newsetUnion :: RepoPatch p => [SealedPatchSet p C(start)] -> SealedPatchSet p C(start) +newsetUnion [] = seal $ PatchSet NilRL NilRL +newsetUnion [x] = x +newsetUnion (Sealed y@(PatchSet psy tsy):Sealed y2:ys) = + case mergeThem y y2 of + Sealed p2 -> newsetUnion $ seal (PatchSet (reverseFL p2+<+psy) tsy) : ys + +-- | Merge two FLs (say L and R), starting in a common context. The result is a +-- FL starting in the original end context of L, going to a new context that is +-- the result of applying all patches from R on top of patches from L. +-- +-- While this function is similar to 'mergeFL', there are three important +-- differences to keep in mind: +-- +-- * 'mergeFL' does not correctly deal with duplicate patches whereas this one +-- does +-- (Question from Eric Kow: in what sense? Why not fix the mergeFL instance?) +-- +-- * 'mergeFL' returns both paths of the merge diamond, but this version only +-- returns one, so you'd better choose the order carefully, eg. +-- (@merge2FL l r@) +-- +-- * The conventional order we use in this function is reversed from +-- 'mergeFL' (so @mergeFL r l@ vs. @merge2FL l r@. This does not +-- matter so much for the former since you get both paths. +-- (Question from Eric Kow: should we flip merge2FL for more uniformity in +-- the code?) +merge2FL :: RepoPatch p => FL (PatchInfoAnd p) C(x y) + -> FL (PatchInfoAnd p) C(x z) + -> Sealed (FL (PatchInfoAnd p) C(y)) +merge2FL _ NilFL = seal NilFL +merge2FL NilFL ys = seal ys +merge2FL xs (y:>:ys) | Just xs' <- fastRemoveFL y xs = merge2FL xs' ys +merge2FL (x:>:xs) ys | Just ys' <- fastRemoveFL x ys = merge2FL xs ys' + | otherwise = case mergeFL (x :\/: ys) of + ys' :/\: _ -> merge2FL xs ys' + +simpleTag :: PatchInfo -> PatchSet p C(start x) -> Maybe (PatchSet p C(start x)) +simpleTag t0 (PatchSet ps (Tagged t h pst :<: ts)) + | t0 == info t = Just $ PatchSet ps (Tagged t h pst :<: ts) + | otherwise = do PatchSet ps' ts' <- simpleTag t0 (PatchSet (t:<:pst) ts) + Just $ PatchSet (ps +<+ ps') ts' +simpleTag _ _ = Nothing + +areUnrelatedRepos :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) -> Bool +areUnrelatedRepos us them = + with_partial_intersection us them checkit + where checkit (Tagged _ _ _ :<: _) _ _ = False + checkit _ u t | t `isShorterThanRL` 5 = False + | u `isShorterThanRL` 5 = False + | otherwise = null $ intersect (mapRL info u) (mapRL info t) + +-- | Remove a patch from FL, using PatchInfo equality. The result is Just +-- whenever the patch has been found and removed. If the patch is not present +-- in the sequence at all or any commutation fails, we get Nothing. First two +-- cases are optimisations for the common cases where the head of the list is +-- the patch to remove, or the patch is not there at all. +fastRemoveFL :: RepoPatch p => PatchInfoAnd p C(x y) -> FL (PatchInfoAnd p) C(x z) + -> Maybe (FL (PatchInfoAnd p) C(y z)) +fastRemoveFL _ NilFL = Nothing +fastRemoveFL a (b:>:bs) | IsEq <- a =\/= b = Just bs + | info a `notElem` mapFL info bs = Nothing +fastRemoveFL a (b:>:bs) = do a' :> bs' <- pullout NilRL bs + a'' :> b' <- commute (b :> a') + IsEq <- return (a'' =\/= a) + Just (b':>:bs') + where i = info a + pullout :: RepoPatch p => RL (PatchInfoAnd p) C(a0 a) + -> FL (PatchInfoAnd p) C(a b) + -> Maybe ((PatchInfoAnd p :> FL (PatchInfoAnd p)) C(a0 b)) + pullout _ NilFL = Nothing + pullout acc (x:>:xs) | info x == i = do x' :> acc' <- commuteRL (acc :> x) + Just (x' :> reverseRL acc' +>+ xs) + | otherwise = pullout (x:<:acc) xs + +fastRemoveRL :: RepoPatch p => PatchInfoAnd p C(y z) -> RL (PatchInfoAnd p) C(x z) + -> Maybe (RL (PatchInfoAnd p) C(x y)) +fastRemoveRL _ NilRL = Nothing +fastRemoveRL a (b:<:bs) | IsEq <- a =/\= b = Just bs + | info a `notElem` mapRL info bs = Nothing +fastRemoveRL a (b:<:bs) = do bs' :> a' <- pullout NilFL bs + b' :> a'' <- commute (a' :> b) + IsEq <- return (a'' =/\= a) + Just (b':<:bs') + where i = info a + pullout :: RepoPatch p => FL (PatchInfoAnd p) C(b c) + -> RL (PatchInfoAnd p) C(a b) + -> Maybe ((RL (PatchInfoAnd p) :> PatchInfoAnd p) C(a c)) + pullout _ NilRL = Nothing + pullout acc (x:<:xs) | info x == i = do acc' :> x' <- + either (const Nothing) + Just (commuteFLorComplain (x :> acc)) + Just (reverseFL acc' +<+ xs :> x') + | otherwise = pullout (x:>:acc) xs diff -ruN darcs-2.4.4/src/Darcs/Patch/FileName.hs darcs-2.5/src/Darcs/Patch/FileName.hs --- darcs-2.4.4/src/Darcs/Patch/FileName.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/FileName.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,28 +21,24 @@ fp2fn, fn2fp, fn2ps, ps2fn, niceps2fn, fn2niceps, - break_on_dir, norm_path, own_name, superName, + breakOnDir, normPath, ownName, superName, movedirfilename, - encode_white, decode_white, + encodeWhite, decodeWhite, (///), breakup ) where import System.IO import Data.Char ( isSpace, chr, ord ) -import qualified Codec.Binary.UTF8.String as UTF8 ( encode ) -import Codec.Binary.UTF8.Generic ( toString ) -import Data.Word ( Word8( ) ) +import ByteStringUtils ( packStringToUTF8, unpackPSFromUTF8 ) import qualified Data.ByteString.Char8 as BC (unpack, pack) -import qualified Data.ByteString as B (ByteString, pack) +import qualified Data.ByteString as B (ByteString) newtype FileName = FN FilePath deriving ( Eq, Ord ) -encode :: [Char] -> [Word8] -encode = UTF8.encode instance Show FileName where - showsPrec d (FN fp) = showParen (d > app_prec) $ showString "fp2fn " . showsPrec (app_prec + 1) fp - where app_prec = 10 + showsPrec d (FN fp) = showParen (d > appPrec) $ showString "fp2fn " . showsPrec (appPrec + 1) fp + where appPrec = 10 {-# INLINE fp2fn #-} fp2fn :: FilePath -> FileName @@ -54,77 +50,78 @@ {-# INLINE niceps2fn #-} niceps2fn :: B.ByteString -> FileName -niceps2fn = FN . decode_white . BC.unpack +niceps2fn = FN . decodeWhite . BC.unpack {-# INLINE fn2niceps #-} fn2niceps :: FileName -> B.ByteString -fn2niceps (FN fp) = BC.pack $ encode_white fp +fn2niceps (FN fp) = BC.pack $ encodeWhite fp {-# INLINE fn2ps #-} fn2ps :: FileName -> B.ByteString -fn2ps (FN fp) = B.pack $ encode $ encode_white fp +fn2ps (FN fp) = packStringToUTF8 $ encodeWhite fp {-# INLINE ps2fn #-} ps2fn :: B.ByteString -> FileName -ps2fn ps = FN $ decode_white $ toString ps +ps2fn ps = FN $ decodeWhite $ unpackPSFromUTF8 ps --- | 'encode_white' translates whitespace in filenames to a darcs-specific --- format (backslash followed by numerical representation according to 'ord'). --- Note that backslashes are also escaped since they are used in the encoding. +-- | 'encodeWhite' translates whitespace in filenames to a darcs-specific +-- format (numerical representation according to 'ord' surrounded by +-- backslashes). Note that backslashes are also escaped since they are used +-- in the encoding. -- --- > encode_white "hello there" == "hello\32there" --- > encode_white "hello\there" == "hello\\there" -encode_white :: FilePath -> String -encode_white (c:cs) | isSpace c || c == '\\' = - '\\' : (show $ ord c) ++ "\\" ++ encode_white cs -encode_white (c:cs) = c : encode_white cs -encode_white [] = [] +-- > encodeWhite "hello there" == "hello\32\there" +-- > encodeWhite "hello\there" == "hello\92\there" +encodeWhite :: FilePath -> String +encodeWhite (c:cs) | isSpace c || c == '\\' = + '\\' : (show $ ord c) ++ "\\" ++ encodeWhite cs +encodeWhite (c:cs) = c : encodeWhite cs +encodeWhite [] = [] --- | 'decode_white' interprets the Darcs-specific \"encoded\" filenames --- produced by 'encode_white' +-- | 'decodeWhite' interprets the Darcs-specific \"encoded\" filenames +-- produced by 'encodeWhite' -- --- > decode_white "hello\32there" == "hello there" --- > decode_white "hello\\there" == "hello\there" --- > decode_white "hello\there" == error "malformed filename" -decode_white :: String -> FilePath -decode_white ('\\':cs) = +-- > decodeWhite "hello\32\there" == "hello there" +-- > decodeWhite "hello\92\there" == "hello\there" +-- > decodeWhite "hello\there" == error "malformed filename" +decodeWhite :: String -> FilePath +decodeWhite ('\\':cs) = case break (=='\\') cs of (theord, '\\':rest) -> - chr (read theord) : decode_white rest + chr (read theord) : decodeWhite rest _ -> error "malformed filename" -decode_white (c:cs) = c: decode_white cs -decode_white "" = "" +decodeWhite (c:cs) = c: decodeWhite cs +decodeWhite "" = "" -own_name :: FileName -> FileName -own_name (FN f) = case breakLast '/' f of Nothing -> FN f +ownName :: FileName -> FileName +ownName (FN f) = case breakLast '/' f of Nothing -> FN f Just (_,f') -> FN f' superName :: FileName -> FileName -superName fn = case norm_path fn of +superName fn = case normPath fn of FN f -> case breakLast '/' f of Nothing -> FN "." Just (d,_) -> FN d -break_on_dir :: FileName -> Maybe (FileName,FileName) -break_on_dir (FN p) = case breakFirst '/' p of +breakOnDir :: FileName -> Maybe (FileName,FileName) +breakOnDir (FN p) = case breakFirst '/' p of Nothing -> Nothing - Just (d,f) | d == "." -> break_on_dir $ FN f + Just (d,f) | d == "." -> breakOnDir $ FN f | otherwise -> Just (FN d, FN f) -norm_path :: FileName -> FileName -- remove "./" -norm_path (FN p) = FN $ repath $ drop_dotdot $ breakup p +normPath :: FileName -> FileName -- remove "./" +normPath (FN p) = FN $ repath $ dropDotdot $ breakup p repath :: [String] -> String repath [] = "" repath [f] = f repath (d:p) = d ++ "/" ++ repath p -drop_dotdot :: [String] -> [String] -drop_dotdot ("":p) = drop_dotdot p -drop_dotdot (".":p) = drop_dotdot p -drop_dotdot ("..":p) = ".." : (drop_dotdot p) -drop_dotdot (_:"..":p) = drop_dotdot p -drop_dotdot (d:p) = case drop_dotdot p of +dropDotdot :: [String] -> [String] +dropDotdot ("":p) = dropDotdot p +dropDotdot (".":p) = dropDotdot p +dropDotdot ("..":p) = ".." : (dropDotdot p) +dropDotdot (_:"..":p) = dropDotdot p +dropDotdot (d:p) = case dropDotdot p of ("..":p') -> p' p' -> d : p' -drop_dotdot [] = [] +dropDotdot [] = [] -- | Split a file path at the slashes breakup :: String -> [String] @@ -143,8 +140,8 @@ Just (a,b) -> Just (reverse b, reverse a) (///) :: FileName -> FileName -> FileName -(FN "")///b = norm_path b -a///b = norm_path $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b +(FN "")///b = normPath b +a///b = normPath $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b movedirfilename :: FileName -> FileName -> FileName -> FileName movedirfilename old new name = @@ -153,6 +150,6 @@ take (length old'+1) name' == old'++"/" then fp2fn ("./"++new'++drop (length old') name') else name - where old' = fn2fp $ norm_path old - new' = fn2fp $ norm_path new - name' = fn2fp $ norm_path name + where old' = fn2fp $ normPath old + new' = fn2fp $ normPath new + name' = fn2fp $ normPath name diff -ruN darcs-2.4.4/src/Darcs/Patch/Info.hs darcs-2.5/src/Darcs/Patch/Info.hs --- darcs-2.4.4/src/Darcs/Patch/Info.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Info.hs 2010-10-24 08:29:26.000000000 -0700 @@ -15,22 +15,25 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Patch.Info ( PatchInfo, patchinfo, invert_name, is_inverted, - idpatchinfo, add_junk, - make_filename, make_alt_filename, readPatchInfo, - just_name, just_author, repopatchinfo, RepoPatchInfo, - human_friendly, to_xml, pi_date, set_pi_date, - pi_name, pi_rename, pi_author, pi_tag, pi_log, - showPatchInfo, is_tag +module Darcs.Patch.Info ( PatchInfo(..), patchinfo, invertName, + idpatchinfo, addJunk, + makeFilename, makeAltFilename, readPatchInfo, + justName, justAuthor, justLog, repopatchinfo, + RepoPatchInfo, humanFriendly, toXml, piDate, + setPiDate, piDateString, piDateBytestring, + piName, piRename, piAuthor, piTag, piLog, + showPatchInfo, isTag ) where import Text.Html hiding (name, text) import System.Random ( randomRIO ) import Numeric ( showHex ) import Control.Monad ( when ) -import ByteStringUtils +import ByteStringUtils import qualified Data.ByteString as B (length, splitAt, null, drop - ,isPrefixOf, tail, concat, ByteString ) + ,isPrefixOf, tail, concat + ,empty, head, cons, append + ,ByteString ) import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack, break) import Data.List( isPrefixOf ) @@ -49,11 +52,18 @@ repopatchinfo :: String -> PatchInfo -> RepoPatchInfo repopatchinfo r pi = RPI r pi -data PatchInfo = PatchInfo { _pi_date :: !B.ByteString - , _pi_name :: !B.ByteString - , _pi_author :: !B.ByteString - , _pi_log :: ![B.ByteString] - , is_inverted :: !Bool +-- | A PatchInfo value contains the metadata of a patch. The date, name, author +-- and log fields are UTF-8 encoded text in darcs 2.4 and later, and just +-- sequences of bytes (decoded with whatever is the locale when displayed) in +-- earlier darcs. +-- +-- The members with names that start with '_' are not supposed to be used +-- directly in code that does not care how the patch info is stored. +data PatchInfo = PatchInfo { _piDate :: !B.ByteString + , _piName :: !B.ByteString + , _piAuthor :: !B.ByteString + , _piLog :: ![B.ByteString] + , isInverted :: !Bool } deriving (Eq,Ord) @@ -63,65 +73,74 @@ patchinfo :: String -> String -> String -> [String] -> IO PatchInfo patchinfo date name author log = - add_junk $ PatchInfo { _pi_date = BC.pack date - , _pi_name = BC.pack name - , _pi_author = BC.pack author - , _pi_log = map BC.pack log - , is_inverted = False } - -add_junk :: PatchInfo -> IO PatchInfo -add_junk pinf = + addJunk $ PatchInfo { _piDate = BC.pack date + , _piName = packStringToUTF8 name + , _piAuthor = packStringToUTF8 author + , _piLog = map packStringToUTF8 log + , isInverted = False } + +-- | addJunk adds a line that contains a random number to make the patch +-- unique. +addJunk :: PatchInfo -> IO PatchInfo +addJunk pinf = do x <- randomRIO (0,2^(128 ::Integer) :: Integer) - when (_pi_log pinf /= ignore_junk (_pi_log pinf)) $ + when (_piLog pinf /= ignoreJunk (_piLog pinf)) $ do putStrLn "Lines beginning with 'Ignore-this: ' will be ignored." yorn <- promptYorn "Proceed? " when (yorn == 'n') $ fail "User cancelled because of Ignore-this." - return $ pinf { _pi_log = BC.pack (head ignored++showHex x ""): - _pi_log pinf } + return $ pinf { _piLog = BC.pack (head ignored++showHex x ""): + _piLog pinf } ignored :: [String] -- this is a [String] so we can change the junk header. ignored = ["Ignore-this: "] -ignore_junk :: [B.ByteString] -> [B.ByteString] -ignore_junk = filter isnt_ignored +ignoreJunk :: [B.ByteString] -> [B.ByteString] +ignoreJunk = filter isnt_ignored where isnt_ignored x = doesnt_start_with x (map BC.pack ignored) -- TODO doesnt_start_with x ys = not $ any (`B.isPrefixOf` x) ys -- * Patch info formatting -invert_name :: PatchInfo -> PatchInfo -invert_name pi = pi { is_inverted = not (is_inverted pi) } +invertName :: PatchInfo -> PatchInfo +invertName pi = pi { isInverted = not (isInverted pi) } -just_name :: PatchInfo -> String -just_name pinf = if is_inverted pinf then "UNDO: " ++ BC.unpack (_pi_name pinf) - else BC.unpack (_pi_name pinf) - -just_author :: PatchInfo -> String -just_author = BC.unpack . _pi_author - -human_friendly :: PatchInfo -> Doc -human_friendly pi = - text (friendly_d $ _pi_date pi) <> text " " <> packedString (_pi_author pi) - $$ hfn (_pi_name pi) - $$ vcat (map ((text " " <>) . packedString) (ignore_junk $ _pi_log pi)) - where hfn x = case pi_tag pi of - Nothing -> inverted <+> packedString x +-- | Get the name, including an "UNDO: " prefix if the patch is inverted. +justName :: PatchInfo -> String +justName pinf = if isInverted pinf then "UNDO: " ++ nameString + else nameString + where nameString = metadataToString (_piName pinf) + +-- | Returns the author of a patch. +justAuthor :: PatchInfo -> String +justAuthor = metadataToString . _piAuthor + +justLog :: PatchInfo -> String +justLog = unlines . map BC.unpack . _piLog + +humanFriendly :: PatchInfo -> Doc +humanFriendly pi = + text (friendlyD $ _piDate pi) <> text " " <> text (piAuthor pi) + $$ hfn (piName pi) + $$ vcat (map ((text " " <>) . text) (piLog pi)) + where hfn x = case piTag pi of + Nothing -> inverted <+> text x Just t -> text " tagged" <+> text t - inverted = if is_inverted pi then text " UNDO:" else text " *" - --- note the difference with just_name -pi_name :: PatchInfo -> String -pi_name = BC.unpack . _pi_name - -pi_rename :: PatchInfo -> String -> PatchInfo -pi_rename x n = x { _pi_name = BC.pack n } + inverted = if isInverted pi then text " UNDO:" else text " *" -pi_author :: PatchInfo -> String -pi_author = BC.unpack . _pi_author - -is_tag :: PatchInfo -> Bool -is_tag pinfo = "TAG " `isPrefixOf` just_name pinfo +-- | Returns the name of the patch. Unlike 'justName', it does not preprend +-- "UNDO: " to the name if the patch is inverted. +piName :: PatchInfo -> String +piName = metadataToString . _piName + +piRename :: PatchInfo -> String -> PatchInfo +piRename x n = x { _piName = packStringToUTF8 n } + +-- | Returns the author of a patch. +piAuthor :: PatchInfo -> String +piAuthor = metadataToString . _piAuthor +isTag :: PatchInfo -> Bool +isTag pinfo = "TAG " `isPrefixOf` justName pinfo -- | Note: we ignore timezone information in the date string, -- systematically treating a time as UTC. So if the patch @@ -134,46 +153,63 @@ readPatchDate = ignoreTz . readUTCDate . BC.unpack where ignoreTz ct = ct { ctTZ = 0 } -pi_date :: PatchInfo -> CalendarTime -pi_date = readPatchDate . _pi_date +piDate :: PatchInfo -> CalendarTime +piDate = readPatchDate . _piDate + +piDateString :: PatchInfo -> String +piDateString = BC.unpack . _piDate + +piDateBytestring :: PatchInfo -> B.ByteString +piDateBytestring = _piDate -set_pi_date :: String -> PatchInfo -> PatchInfo -set_pi_date date pi = pi { _pi_date = BC.pack date } +setPiDate :: String -> PatchInfo -> PatchInfo +setPiDate date pi = pi { _piDate = BC.pack date } -pi_log :: PatchInfo -> [String] -pi_log = map BC.unpack . ignore_junk . _pi_log +-- | Get the log message of a patch. +piLog :: PatchInfo -> [String] +piLog = map metadataToString . ignoreJunk . _piLog -pi_tag :: PatchInfo -> Maybe String -pi_tag pinf = +-- | Get the tag name, if the patch is a tag patch. +piTag :: PatchInfo -> Maybe String +piTag pinf = if l == t - then Just $ BC.unpack r + then Just $ metadataToString r else Nothing - where (l, r) = B.splitAt (B.length t) (_pi_name pinf) + where (l, r) = B.splitAt (B.length t) (_piName pinf) t = BC.pack "TAG " -friendly_d :: B.ByteString -> String ---friendly_d d = calendarTimeToString . readPatchDate . d -friendly_d d = unsafePerformIO $ do +-- | Convert a metadata ByteString to a string. It first tries to convert +-- using UTF-8, and if that fails, tries the locale encoding. +-- We try UTF-8 first because UTF-8 is clearly recognizable, widely used, +-- and people may have UTF-8 patches even when UTF-8 is not their locale. +metadataToString :: B.ByteString -> String +metadataToString bs | not ('\xfffd' `elem` bsUtf8) = bsUtf8 + | otherwise = decodeLocale bs + where bsUtf8 = unpackPSFromUTF8 bs + +friendlyD :: B.ByteString -> String +--friendlyD d = calendarTimeToString . readPatchDate . d +friendlyD d = unsafePerformIO $ do ct <- toCalendarTime $ toClockTime $ readPatchDate d return $ calendarTimeToString ct -to_xml :: PatchInfo -> Doc -to_xml pi = +toXml :: PatchInfo -> Doc +toXml pi = text " text "author='" <> escapeXML (just_author pi) <> text "'" - <+> text "date='" <> escapeXML (BC.unpack $ _pi_date pi) <> text "'" - <+> text "local_date='" <> escapeXML (friendly_d $ _pi_date pi) <> text "'" - <+> text "inverted='" <> text (show $ is_inverted pi) <> text "'" - <+> text "hash='" <> text (make_filename pi) <> text "'>" + <+> text "author='" <> escapeXMLByteString (_piAuthor pi) <> text "'" + <+> text "date='" <> escapeXMLByteString (_piDate pi) <> text "'" + <+> text "local_date='" <> escapeXML (friendlyD $ _piDate pi) <> text "'" + <+> text "inverted='" <> text (show $ isInverted pi) <> text "'" + <+> text "hash='" <> text (makeFilename pi) <> text "'>" $$ prefix "\t" ( - text "" <> escapeXML (pi_name pi) <> text "" - $$ comments_as_xml (_pi_log pi)) + text "" <> escapeXMLByteString (_piName pi) <> text "" + $$ commentsAsXml (_piLog pi)) $$ text "" -comments_as_xml :: [B.ByteString] -> Doc -comments_as_xml comments +commentsAsXml :: [B.ByteString] -> Doc +commentsAsXml comments | B.length comments' > 0 = text "" - <> escapeXML (BC.unpack comments') + <> escapeXMLByteString comments' <> text "" | otherwise = empty where comments' = unlinesPS comments @@ -184,6 +220,14 @@ escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" +-- Escape XML characters in a UTF-8 encoded ByteString, and turn it into a Doc. +-- The data will be in the Doc as a bytestring. +escapeXMLByteString :: B.ByteString -> Doc +escapeXMLByteString = packedString . bstrReplace '\'' "'" + . bstrReplace '"' """ + . bstrReplace '>' ">" + . bstrReplace '<' "<" + . bstrReplace '&' "&" strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] @@ -191,61 +235,69 @@ | x == z = y ++ (strReplace x y zs) | otherwise = z : (strReplace x y zs) -make_alt_filename :: PatchInfo -> String -make_alt_filename pi@(PatchInfo { is_inverted = False }) = - fix_up_fname (midtrunc (pi_name pi)++"-"++just_author pi++"-"++BC.unpack (_pi_date pi)) -make_alt_filename pi@(PatchInfo { is_inverted = True}) = - make_alt_filename (pi { is_inverted = False }) ++ "-inverted" +bstrReplace :: Char -> String -> B.ByteString -> B.ByteString +bstrReplace c s bs | B.null bs = B.empty + | otherwise = if BC.head bs == c + then B.append (BC.pack s) + (bstrReplace c s (B.tail bs)) + else B.cons (B.head bs) + (bstrReplace c s (B.tail bs)) + +makeAltFilename :: PatchInfo -> String +makeAltFilename pi@(PatchInfo { isInverted = False }) = + fixUpFname (midtrunc (piName pi)++"-"++justAuthor pi++"-"++BC.unpack (_piDate pi)) +makeAltFilename pi@(PatchInfo { isInverted = True}) = + makeAltFilename (pi { isInverted = False }) ++ "-inverted" -- This makes darcs-1 (non-hashed repos) filenames, and is also generally used in both in -- hashed and non-hashed repo code for making patch "hashes" -make_filename :: PatchInfo -> String -make_filename pi = +makeFilename :: PatchInfo -> String +makeFilename pi = showIsoDateTime d++"-"++sha1_a++"-"++sha1PS sha1_me++".gz" where b2ps True = BC.pack "t" b2ps False = BC.pack "f" - sha1_me = B.concat [_pi_name pi, - _pi_author pi, - _pi_date pi, - B.concat $ _pi_log pi, - b2ps $ is_inverted pi] - d = readPatchDate $ _pi_date pi - sha1_a = take 5 $ sha1PS $ _pi_author pi + sha1_me = B.concat [_piName pi, + _piAuthor pi, + _piDate pi, + B.concat $ _piLog pi, + b2ps $ isInverted pi] + d = readPatchDate $ _piDate pi + sha1_a = take 5 $ sha1PS $ _piAuthor pi midtrunc :: String -> String midtrunc s | length s < 73 = s | otherwise = (take 40 s)++"..."++(reverse $ take 30 $ reverse s) -fix_up_fname :: String -> String -fix_up_fname = map munge_char +fixUpFname :: String -> String +fixUpFname = map mungeChar -munge_char :: Char -> Char -munge_char '*' = '+' -munge_char '?' = '2' -munge_char '>' = '7' -munge_char '<' = '2' -munge_char ' ' = '_' -munge_char '"' = '~' -munge_char '`' = '.' -munge_char '\'' = '.' -munge_char '/' = '1' -munge_char '\\' = '1' -munge_char '!' = '1' -munge_char ':' = '.' -munge_char ';' = ',' -munge_char '{' = '~' -munge_char '}' = '~' -munge_char '(' = '~' -munge_char ')' = '~' -munge_char '[' = '~' -munge_char ']' = '~' -munge_char '=' = '+' -munge_char '#' = '+' -munge_char '%' = '8' -munge_char '&' = '6' -munge_char '@' = '9' -munge_char '|' = '1' -munge_char c = c +mungeChar :: Char -> Char +mungeChar '*' = '+' +mungeChar '?' = '2' +mungeChar '>' = '7' +mungeChar '<' = '2' +mungeChar ' ' = '_' +mungeChar '"' = '~' +mungeChar '`' = '.' +mungeChar '\'' = '.' +mungeChar '/' = '1' +mungeChar '\\' = '1' +mungeChar '!' = '1' +mungeChar ':' = '.' +mungeChar ';' = ',' +mungeChar '{' = '~' +mungeChar '}' = '~' +mungeChar '(' = '~' +mungeChar ')' = '~' +mungeChar '[' = '~' +mungeChar ']' = '~' +mungeChar '=' = '+' +mungeChar '#' = '+' +mungeChar '%' = '8' +mungeChar '&' = '6' +mungeChar '@' = '9' +mungeChar '|' = '1' +mungeChar c = c instance HTML RepoPatchInfo where toHtml = htmlPatchInfo @@ -265,10 +317,10 @@ -- note that below I assume the name has no newline in it. showPatchInfo :: PatchInfo -> Doc showPatchInfo pi = - blueText "[" <> packedString (_pi_name pi) - $$ packedString (_pi_author pi) <> text inverted <> packedString (_pi_date pi) - <> myunlines (_pi_log pi) <> blueText "] " - where inverted = if is_inverted pi then "*-" else "**" + blueText "[" <> packedString (_piName pi) + $$ packedString (_piAuthor pi) <> text inverted <> packedString (_piDate pi) + <> myunlines (_piLog pi) <> blueText "] " + where inverted = if isInverted pi then "*-" else "**" myunlines [] = empty myunlines xs = mul xs where mul [] = text "\n" @@ -290,18 +342,18 @@ (author,s2) -> case BC.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of (ct,s''') -> - do (log, s4) <- lines_starting_with_ending_with ' ' ']' $ dn s''' - return $ (PatchInfo { _pi_date = ct - , _pi_name = name - , _pi_author = author - , _pi_log = log - , is_inverted = BC.index s2 1 /= '*' + do (log, s4) <- linesStartingWithEndingWith ' ' ']' $ dn s''' + return $ (PatchInfo { _piDate = ct + , _piName = name + , _piAuthor = author + , _piLog = log + , isInverted = BC.index s2 1 /= '*' }, s4) where dn x = if B.null x || BC.head x /= '\n' then x else B.tail x -lines_starting_with_ending_with :: Char -> Char -> B.ByteString +linesStartingWithEndingWith :: Char -> Char -> B.ByteString -> Maybe ([B.ByteString],B.ByteString) -lines_starting_with_ending_with st en s = lswew s +linesStartingWithEndingWith st en s = lswew s where lswew x | B.null x = Nothing lswew x = @@ -320,14 +372,14 @@ htmlPatchInfo :: RepoPatchInfo -> Html htmlPatchInfo (RPI r pi) = - toHtml $ (td << patch_link r pi) `above` - ((td ! [align "right"] << mail_link (just_author pi)) `beside` - (td << (friendly_d $ _pi_date pi))) + toHtml $ (td << patchLink r pi) `above` + ((td ! [align "right"] << mailLink (justAuthor pi)) `beside` + (td << (friendlyD $ _piDate pi))) -patch_link :: String -> PatchInfo -> Html -patch_link r pi = +patchLink :: String -> PatchInfo -> Html +patchLink r pi = toHtml $ hotlink - ("darcs?"++r++"**"++make_filename pi) - [toHtml $ pi_name pi] -mail_link :: String -> Html -mail_link email = toHtml $ hotlink ("mailto:"++email) [toHtml email] + ("darcs?"++r++"**"++makeFilename pi) + [toHtml $ piName pi] +mailLink :: String -> Html +mailLink email = toHtml $ hotlink ("mailto:"++email) [toHtml email] diff -ruN darcs-2.4.4/src/Darcs/Patch/MatchData.hs darcs-2.5/src/Darcs/Patch/MatchData.hs --- darcs-2.4.4/src/Darcs/Patch/MatchData.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/MatchData.hs 2010-10-24 08:29:26.000000000 -0700 @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Patch.MatchData ( PatchMatch(..), patch_match, +module Darcs.Patch.MatchData ( PatchMatch(..), patchMatch, ) where data PatchMatch = PatternMatch String @@ -24,5 +24,5 @@ instance Show PatchMatch where show (PatternMatch m) = "pattern " ++ show m -patch_match :: String -> PatchMatch -patch_match s = PatternMatch s +patchMatch :: String -> PatchMatch +patchMatch s = PatternMatch s diff -ruN darcs-2.4.4/src/Darcs/Patch/Match.lhs darcs-2.5/src/Darcs/Patch/Match.lhs --- darcs-2.4.4/src/Darcs/Patch/Match.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Match.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -22,10 +22,10 @@ #include "gadts.h" module Darcs.Patch.Match ( PatchMatch, Matcher, MatchFun, - patch_match, match_pattern, - apply_matcher, make_matcher, + patchMatch, matchPattern, + applyMatcher, makeMatcher, parseMatch, - match_parser, helpOnMatchers, + matchParser, helpOnMatchers, ) where import Text.ParserCombinators.Parsec @@ -36,12 +36,12 @@ import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) import Darcs.Patch ( Patch, Patchy, hunkMatches, listTouchedFiles, patchcontents ) -import Darcs.Patch.Info ( just_name, just_author, make_filename, - pi_date ) +import Darcs.Patch.Info ( justName, justAuthor, justLog, makeFilename, + piDate ) import Darcs.Witnesses.Sealed ( Sealed2(..), seal2 ) import DateMatcher ( parseDateMatcher ) -import Darcs.Patch.MatchData ( PatchMatch(..), patch_match ) +import Darcs.Patch.MatchData ( PatchMatch(..), patchMatch ) import qualified Data.ByteString.Char8 as BC -- | A type for predicates over patches which do not care about @@ -55,25 +55,25 @@ instance Show (Matcher p) where show (MATCH s _) = '"':s ++ "\"" -make_matcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p -make_matcher s m = MATCH s m +makeMatcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p +makeMatcher s m = MATCH s m --- | @apply_matcher@ applies a matcher to a patch. -apply_matcher :: Matcher p -> PatchInfoAnd p C(x y) -> Bool -apply_matcher (MATCH _ m) = m . seal2 +-- | @applyMatcher@ applies a matcher to a patch. +applyMatcher :: Matcher p -> PatchInfoAnd p C(x y) -> Bool +applyMatcher (MATCH _ m) = m . seal2 parseMatch :: Patchy p => PatchMatch -> Either String (MatchFun p) parseMatch (PatternMatch s) = - case parse match_parser "match" s of + case parse matchParser "match" s of Left err -> Left $ "Invalid -"++"-match pattern '"++s++ "'.\n"++ unlines (map (" "++) $ lines $ show err) -- indent Right m -> Right m -match_pattern :: Patchy p => PatchMatch -> Matcher p -match_pattern p@(PatternMatch s) = +matchPattern :: Patchy p => PatchMatch -> Matcher p +matchPattern p@(PatternMatch s) = case parseMatch p of Left err -> error err - Right m -> make_matcher s m + Right m -> makeMatcher s m trivial :: Patchy p => MatchFun p trivial = const True @@ -81,7 +81,7 @@ \subsection{Match} -Currently \verb!--match! accepts six primitive match types, although +Currently \verb!--match! accepts eight primitive match types, although there are plans to expand it to match more patterns. Also, note that the syntax is still preliminary and subject to change. @@ -199,6 +199,18 @@ darcs annotate --summary --match 'touch foo/bar.c' \end{verbatim} +The seventh match type accepts a regular expression which is checked +against every hunk. The syntax is +\begin{verbatim} +darcs annotate --summary --match 'hunk "^instance .* Foo where$"' +\end{verbatim} + +The eight match type accepts a regular expression which is checked +against the long comment. The syntax is +\begin{verbatim} +darcs annotate --summary --match 'comment "remote repository"' +\end{verbatim} + The \verb!--match! pattern can include the logical operators \verb!&&!, \verb!||! and \verb!not!, as well as grouping of patterns with parentheses. For example @@ -207,8 +219,8 @@ \end{verbatim} \begin{code} -match_parser :: Patchy p => CharParser st (MatchFun p) -match_parser = do m <- option trivial submatch +matchParser :: Patchy p => CharParser st (MatchFun p) +matchParser = do m <- option trivial submatch eof return m @@ -266,7 +278,7 @@ "complement (not), conjunction (and) and disjunction (or) operators.", "The C notation for logic operators (!, && and ||) can also be used.", "", - " --patches=regex is a synonym for --matches='name regex'", + " --patches=regex is a synonym for --matches='name regex'", " --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...", " --from-patch and --to-match can be unproblematically combined:", " darcs changes --from-patch='html.*documentation' --to-match='date 20040212'", @@ -306,8 +318,11 @@ , ["\"David Roundy\"", "droundy", "droundy@darcs.net"] , authormatch ) , ("hunk", "check a regular expression against the contents of a hunk patch" - , ["foo = 2", "^instance .* Foo where$"] + , ["\"foo = 2\"", "\"^instance .* Foo where$\""] , hunkmatch ) + , ("comment", "check a regular expression against the log message" + , ["\"prevent deadlocks\""] + , logmatch ) , ("hash", "match the darcs hash for a patch" , ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"] , hashmatch ) @@ -333,22 +348,24 @@ mymatch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p -mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ just_name (info hp) +mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp) -exactmatch r (Sealed2 hp) = r == (just_name (info hp)) +exactmatch r (Sealed2 hp) = r == (justName (info hp)) -authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ just_author (info hp) +authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ justAuthor (info hp) +logmatch :: Patchy p => String -> MatchFun p +logmatch l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp) hunkmatch r (Sealed2 hp) = let patch = patchcontents $ hopefully hp regexMatcher = isJust . (matchRegex (mkRegex r) . BC.unpack) in hunkMatches regexMatcher patch -hashmatch h (Sealed2 hp) = let rh = make_filename (info hp) in +hashmatch h (Sealed2 hp) = let rh = makeFilename (info hp) in (rh == h) || (rh == h++".gz") datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d - in dm $ pi_date (info hp) + in dm $ piDate (info hp) touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp in or $ map (isJust . matchRegex (mkRegex r)) files diff -ruN darcs-2.4.4/src/Darcs/Patch/Non.hs darcs-2.5/src/Darcs/Patch/Non.hs --- darcs-2.4.4/src/Darcs/Patch/Non.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Non.hs 2010-10-24 08:29:26.000000000 -0700 @@ -24,11 +24,11 @@ -- |'NonPatch' and 'Non' patches are patches that store a context as a -- sequence of patches. See "Darcs.Patch.Real" for example usage. module Darcs.Patch.Non - ( NonPatch, Non(..), Nonable(..), unNon, + ( Non(..), Nonable(..), unNon, showNon, readNon, showNons, readNons, add, rem, addP, remP, addPs, remPs, remAddP, remAddPs, remNons, (*>), (>*), (*>>), (>>*), - prop_adjust_twice ) where + propAdjustTwice ) where import Prelude hiding ( rem ) import Data.List ( delete ) @@ -36,7 +36,7 @@ import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Effect(..), showPrim, FileNameFormat(..), sortCoalesceFL ) import Darcs.Patch.Patchy -import Darcs.Patch.ReadMonads ( ParserM, lex_char ) +import Darcs.Patch.ReadMonads ( ParserM, lexChar ) import Darcs.Witnesses.Ordered import Darcs.Patch.Read ( readPrim ) import Darcs.Patch.Viewing () @@ -61,13 +61,13 @@ readNons = peekfor "{{" rns (return []) where rns = peekfor "}}" (return []) $ do Just (Sealed ps) <- readPatch' False - lex_char ':' + lexChar ':' Just (Sealed p) <- readPrim NewFormat (Non ps p :) `liftM` rns readNon :: (ReadPatch p, ParserM m) => m (Maybe (Non p C(x))) readNon = do Just (Sealed ps) <- readPatch' False - peekfor ":" (do Just (Sealed p) <- readPatch' False + peekfor ":" (do Just (Sealed p) <- readPrim NewFormat return $ Just $ Non ps p) (return Nothing) @@ -80,9 +80,6 @@ data Non p C(x) where Non :: FL p C(a x) -> Prim C(x y) -> Non p C(a) --- | Convenience type for non primitive patches -type NonPatch C(x) = Non Prim C(x) - -- | Return as a list the context followed by the primitive patch. unNon :: FromPrim p => Non p C(x) -> Sealed (FL p C(x)) unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL) @@ -160,7 +157,7 @@ n *> p = invert p >* n (>*) :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe (Non p C(x)) -y >* (Non c x) = case commuteFL (y :> c) of +y >* (Non c x) = case commuteFLorComplain (y :> c) of Right (c' :> y') -> do px' :> _ <- commute (y' :> fromPrim x) x' <- toPrim px' @@ -176,8 +173,8 @@ adj NilRL n = Just n adj (x:<:xs) n = fromPrim x >* n >>= adj xs -prop_adjust_twice :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe Doc -prop_adjust_twice p n = +propAdjustTwice :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe Doc +propAdjustTwice p n = do n' <- p >* n case n' *> p of Nothing -> Just (redText "prop_adjust_inverse 1") @@ -189,17 +186,17 @@ Nothing -> Just (redText "prop_adjust_inverse 5") Just n'' | n'' /= n -> Just (redText "prop_adjust_inverse 6") _ -> Nothing - + instance Nonable Prim where non = Non NilFL instance Show2 p => Show (Non p C(x)) where - showsPrec = showsPrec1 + showsPrec d (Non cs p) = showParen (d > appPrec) $ showString "Non " . + showsPrec2 (appPrec + 1) cs . showString " " . + showsPrec (appPrec + 1) p instance Show2 p => Show1 (Non p) where - showsPrec1 d (Non cs p) = showParen (d > app_prec) $ showString "Non " . - showsPrec2 (app_prec + 1) cs . showString " " . - showsPrec (app_prec + 1) p + showDict1 = ShowDictClass instance Patchy Prim diff -ruN darcs-2.4.4/src/Darcs/Patch/OldDate.hs darcs-2.5/src/Darcs/Patch/OldDate.hs --- darcs-2.4.4/src/Darcs/Patch/OldDate.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/OldDate.hs 2010-10-24 08:29:26.000000000 -0700 @@ -52,7 +52,7 @@ (readI $ B.take 2 $ B.drop 12 bd) -- Second 0 Sunday 0 -- Picosecond, weekday and day of year unknown "GMT" 0 False - else let dt = do { x <- date_time tz; eof; return x } + else let dt = do { x <- dateTime tz; eof; return x } in case parse dt "" d of Left e -> Left $ "bad date: "++d++" - "++show e Right ct -> Right ct @@ -104,87 +104,87 @@ ----- Date/Time Parser ----------------------------------------------- -date_time :: Int -> CharParser a CalendarTime -date_time tz = - choice [try $ cvs_date_time tz, - try $ iso8601_date_time tz, - old_date_time] +dateTime :: Int -> CharParser a CalendarTime +dateTime tz = + choice [try $ cvsDateTime tz, + try $ iso8601DateTime tz, + oldDateTime] -cvs_date_time :: Int -> CharParser a CalendarTime -cvs_date_time tz = +cvsDateTime :: Int -> CharParser a CalendarTime +cvsDateTime tz = do y <- year char '/' - mon <- month_num + mon <- monthNum char '/' d <- day - my_spaces + mySpaces h <- hour char ':' m <- minute char ':' s <- second - z <- option tz $ my_spaces >> zone + z <- option tz $ mySpaces >> zone return (CalendarTime y mon d h m s 0 Monday 0 "" z False) -old_date_time :: CharParser a CalendarTime -old_date_time = do wd <- day_name - my_spaces - mon <- month_name - my_spaces +oldDateTime :: CharParser a CalendarTime +oldDateTime = do wd <- dayName + mySpaces + mon <- monthName + mySpaces d <- day - my_spaces + mySpaces h <- hour char ':' m <- minute char ':' s <- second - my_spaces + mySpaces z <- zone - my_spaces + mySpaces y <- year return (CalendarTime y mon d h m s 0 wd 0 "" z False) -{- FIXME: In case you ever want to use this outside of darcs, you should note - that this implementation of ISO 8601 is not complete. +{- FIXME: In case you ever want to use this outside of darcs, you should note + that this implementation of ISO 8601 is not complete. - reluctant to implement (ambiguous!): - * years > 9999 - * truncated representations with implied century (89 for 1989) - unimplemented: + reluctant to implement (ambiguous!): + * years > 9999 + * truncated representations with implied century (89 for 1989) + unimplemented: * repeated durations (not relevant) * lowest order component fractions in intervals - * negative dates (BC) + * negative dates (BC) unverified or too relaxed: * the difference between 24h and 0h - * allows stuff like 2005-1212; either you use the hyphen all the way + * allows stuff like 2005-1212; either you use the hyphen all the way (2005-12-12) or you don't use it at all (20051212), but you don't use - it halfway, likewise with time - * No bounds checking whatsoever on intervals! + it halfway, likewise with time + * No bounds checking whatsoever on intervals! (next action: read iso doc to see if bounds-checking required?) -} -iso8601_date_time :: Int -> CharParser a CalendarTime -iso8601_date_time localTz = try $ - do d <- iso8601_date - t <- option id $ try $ do optional $ oneOf " T" - iso8601_time +iso8601DateTime :: Int -> CharParser a CalendarTime +iso8601DateTime localTz = try $ + do d <- iso8601Date + t <- option id $ try $ do optional $ oneOf " T" + iso8601Time return $ t $ d { ctTZ = localTz } -iso8601_date :: CharParser a CalendarTime -iso8601_date = +iso8601Date :: CharParser a CalendarTime +iso8601Date = do d <- calendar_date <|> week_date <|> ordinal_date return $ foldr ($) nullCalendar d - where + where calendar_date = -- yyyy-mm-dd try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ] - -- allow other variants to be parsed correctly + -- allow other variants to be parsed correctly notFollowedBy (digit <|> char 'W') return d - week_date = --yyyy-Www-dd + week_date = --yyyy-Www-dd try $ do yfn <- year_ optional dash char 'W' -- offset human 'week 1' -> computer 'week 0' - w' <- (\x -> x-1) `liftM` two_digits - wd <- option 1 $ do { optional dash; n_digits 1 } + w' <- (\x -> x-1) `liftM` twoDigits + wd <- option 1 $ do { optional dash; nDigits 1 } let y = yfn nullCalendar firstDay = ctWDay y -- things that make this complicated @@ -199,32 +199,32 @@ ordinal_date = -- yyyy-ddd try $ optchain year_ [ (dash, yearDay_) ] -- - year_ = try $ do y <- four_digits "year (0000-9999)" + year_ = try $ do y <- fourDigits "year (0000-9999)" return $ \c -> c { ctYear = y } - month_ = try $ do m <- two_digits "month (1 to 12)" + month_ = try $ do m <- twoDigits "month (1 to 12)" -- we (artificially) use ctPicosec to indicate -- whether the month has been specified. return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 } - day_ = try $ do d <- two_digits "day in month (1 to 31)" + day_ = try $ do d <- twoDigits "day in month (1 to 31)" return $ \c -> c { ctDay = d } - yearDay_ = try $ do d <- n_digits 3 "day in year (1 to 366)" + yearDay_ = try $ do d <- nDigits 3 "day in year (1 to 366)" return $ \c -> c { ctYDay = d } dash = char '-' -- we return a function which sets the time on another calendar -iso8601_time :: CharParser a (CalendarTime -> CalendarTime) -iso8601_time = try $ +iso8601Time :: CharParser a (CalendarTime -> CalendarTime) +iso8601Time = try $ do ts <- optchain hour_ [ (colon , min_) , (colon , sec_) - , (oneOf ",.", pico_) ] + , (oneOf ",.", pico_) ] z <- option id $ choice [ zulu , offset ] return $ foldr (.) id (z:ts) - where - hour_ = do h <- two_digits + where + hour_ = do h <- twoDigits return $ \c -> c { ctHour = h } - min_ = do m <- two_digits + min_ = do m <- twoDigits return $ \c -> c { ctMin = m } - sec_ = do s <- two_digits + sec_ = do s <- twoDigits return $ \c -> c { ctSec = s } pico_ = do digs <- many digit let picoExp = 12 @@ -236,31 +236,31 @@ zulu = do { char 'Z'; return (\c -> c { ctTZ = 0 }) } offset = do sign <- choice [ do { char '+' >> return 1 } , do { char '-' >> return (-1) } ] - h <- two_digits - m <- option 0 $ do { optional colon; two_digits } + h <- twoDigits + m <- option 0 $ do { optional colon; twoDigits } return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) } colon = char ':' optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b] -optchain p next = try $ +optchain p next = try $ do r1 <- p - r2 <- case next of + r2 <- case next of [] -> return [] ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 } return (r1:r2) -n_digits :: Int -> CharParser a Int -n_digits n = read `liftM` count n digit +nDigits :: Int -> CharParser a Int +nDigits n = read `liftM` count n digit -two_digits, four_digits :: CharParser a Int -two_digits = n_digits 2 -four_digits = n_digits 4 +twoDigits, fourDigits :: CharParser a Int +twoDigits = nDigits 2 +fourDigits = nDigits 4 -my_spaces :: CharParser a String -my_spaces = manyN 1 $ char ' ' +mySpaces :: CharParser a String +mySpaces = manyN 1 $ char ' ' -day_name :: CharParser a Day -day_name = choice +dayName :: CharParser a Day +dayName = choice [ caseString "Mon" >> return Monday , try (caseString "Tue") >> return Tuesday , caseString "Wed" >> return Wednesday @@ -271,11 +271,11 @@ ] year :: CharParser a Int -year = four_digits +year = fourDigits -month_num :: CharParser a Month -month_num = do mn <- manyNtoM 1 2 digit - return $ intToMonth $ (read mn :: Int) +monthNum :: CharParser a Month +monthNum = do mn <- manyNtoM 1 2 digit + return $ intToMonth $ (read mn :: Int) intToMonth :: Int -> Month intToMonth 1 = January @@ -292,8 +292,8 @@ intToMonth 12 = December intToMonth _ = error "invalid month!" -month_name :: CharParser a Month -month_name = choice +monthName :: CharParser a Month +monthName = choice [ try (caseString "Jan") >> return January , caseString "Feb" >> return February , try (caseString "Mar") >> return March @@ -313,13 +313,13 @@ return (read d :: Int) hour :: CharParser a Int -hour = two_digits +hour = twoDigits minute :: CharParser a Int -minute = two_digits +minute = twoDigits second :: CharParser a Int -second = two_digits +second = twoDigits zone :: CharParser a Int zone = choice @@ -346,5 +346,5 @@ where mkZone n o = try $ do { caseString n; return (o*60*60) } space_digit = try $ do { char ' '; oneOf ['0'..'9'] } -nullCalendar :: CalendarTime +nullCalendar :: CalendarTime nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False diff -ruN darcs-2.4.4/src/Darcs/Patch/Patchy.hs darcs-2.5/src/Darcs/Patch/Patchy.hs --- darcs-2.4.4/src/Darcs/Patch/Patchy.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Patchy.hs 2010-10-24 08:29:26.000000000 -0700 @@ -24,7 +24,8 @@ module Darcs.Patch.Patchy ( Patchy, Apply, apply, applyAndTryToFix, applyAndTryToFixFL, mapMaybeSnd, - Commute(..), commuteFL, commuteRL, commuteRLFL, + Commute(..), commuteFLorComplain, commuteRL, + commuteFL, commuteRLFL, mergeFL, toFwdCommute, toRevCommute, ShowPatch(..), ReadPatch, readPatch', bracketedFL, peekfor, @@ -37,7 +38,7 @@ import Storage.Hashed.Monad( TreeIO ) import Darcs.Witnesses.Sealed ( Sealed(..), Sealed2(..), seal2 ) -import Darcs.Patch.ReadMonads ( ParserM, lex_eof, peek_input, my_lex, work, alter_input ) +import Darcs.Patch.ReadMonads ( ParserM, lexEof, peekInput, myLex, work, alterInput ) import Darcs.Witnesses.Ordered import Printer ( Doc, (<>), text ) import Darcs.Lock ( writeDocBinFile, gzWriteDocFile ) @@ -166,15 +167,18 @@ return (w'' :> z' :<: zs') commuteRL (NilRL :> w) = Just (w :> NilRL) -commuteFL :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y)) -commuteFL (p :> NilFL) = Right (NilFL :> p) -commuteFL (q :> p :>: ps) = case commute (q :> p) of +commuteFLorComplain :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y)) +commuteFLorComplain (p :> NilFL) = Right (NilFL :> p) +commuteFLorComplain (q :> p :>: ps) = case commute (q :> p) of Just (p' :> q') -> - case commuteFL (q' :> ps) of + case commuteFLorComplain (q' :> ps) of Right (ps' :> q'') -> Right (p' :>: ps' :> q'') Left l -> Left l Nothing -> Left $ seal2 p +commuteFL :: Commute p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y)) +commuteFL = either (const Nothing) Just . commuteFLorComplain + instance ReadPatch p => ReadPatch (FL p) where readPatch' want_eof = Just `liftM` read_patches where read_patches :: ParserM m => m (Sealed (FL p C(x ))) @@ -186,36 +190,36 @@ return $ Sealed (p:>:ps) Nothing -> if want_eof then do --tracePeek "no more patches" - unit' <- lex_eof + unit' <- lexEof case unit' of () -> return $ Sealed NilFL else do --tracePeek "no more patches" return $ Sealed NilFL --- tracePeek x = do y <- peek_input +-- tracePeek x = do y <- peekInput -- traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return () {-# INLINE bracketedFL #-} -bracketedFL :: (ReadPatch p, ParserM m) => - Word8 -> Word8 -> m (Maybe (Sealed (FL p C(x)))) -bracketedFL pre post = +bracketedFL :: forall p m C(x) . (ReadPatch p, ParserM m) => + (FORALL(y) m (Maybe (Sealed (p C(y))))) -> Word8 -> Word8 -> m (Maybe (Sealed (FL p C(x)))) +bracketedFL parser pre post = peekforw pre bfl (return Nothing) - where bfl :: (ReadPatch p, ParserM m) => m (Maybe (Sealed (FL p C(x)))) + where bfl :: FORALL(z) m (Maybe (Sealed (FL p C(z)))) bfl = peekforw post (return $ Just $ Sealed NilFL) - (do Just (Sealed p) <- readPatch' False + (do Just (Sealed p) <- parser Just (Sealed ps) <- bfl return $ Just $ Sealed (p:>:ps)) {-# INLINE peekforw #-} peekforw :: ParserM m => Word8 -> m a -> m a -> m a -peekforw w ifstr ifnot = do s <- peek_input +peekforw w ifstr ifnot = do s <- peekInput case ifHeadThenTail w $ dropSpace s of - Just s' -> alter_input (const s') >> ifstr + Just s' -> alterInput (const s') >> ifstr Nothing -> ifnot peekforPS :: ParserM m => BC.ByteString -> m a -> m a -> m a -peekforPS ps ifstr ifnot = do s <- peek_input - case ((ps ==) . fst) `fmap` my_lex s of - Just True -> work my_lex >> ifstr +peekforPS ps ifstr ifnot = do s <- peekInput + case ((ps ==) . fst) `fmap` myLex s of + Just True -> work myLex >> ifstr _ -> ifnot {-# INLINE peekfor #-} diff -ruN darcs-2.4.4/src/Darcs/Patch/Permutations.hs darcs-2.5/src/Darcs/Patch/Permutations.hs --- darcs-2.4.4/src/Darcs/Patch/Permutations.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Permutations.hs 2010-10-24 08:29:26.000000000 -0700 @@ -26,15 +26,15 @@ commuteWhatWeCanFL, commuteWhatWeCanRL, genCommuteWhatWeCanRL, partitionFL, partitionRL, - head_permutationsFL, head_permutationsRL, + simpleHeadPermutationsFL, headPermutationsRL, headPermutationsFL, - remove_subsequenceFL, remove_subsequenceRL, + removeSubsequenceFL, removeSubsequenceRL, partitionConflictingFL, CommuteFn, selfCommuter, commuterIdRL, ) where import Data.Maybe ( catMaybes ) -import Darcs.Patch.Patchy ( Commute, commute, commuteFL, commuteRL, Invert(..), invertFL, invertRL ) +import Darcs.Patch.Patchy ( Commute, commute, commuteFLorComplain, commuteRL, Invert(..), invertFL, invertRL ) import Darcs.Witnesses.Ordered #include "impossible.h" @@ -44,24 +44,29 @@ partitionFL :: Commute p => (FORALL(u v) p C(u v) -> Bool) -- ^predicate; if true we would like the patch in the "left" list -> FL p C(x y) -- ^input 'FL' - -> (FL p :> FL p) C(x y) -- ^"left" and "right" results + -> ((FL p :> FL p :> FL p) C(x y)) -- ^"left", "middle" and "right" -- optimise by using an accumulating parameter to track all the "right" patches that we've found so far partitionFL' :: Commute p => (FORALL(u v) p C(u v) -> Bool) - -> RL p C(x z) -- the "right" patches found so far - -> FL p C(z y) - -> (FL p :> FL p) C(x y) - -partitionFL keepleft ps = partitionFL' keepleft NilRL ps - -partitionFL' _ qs NilFL = NilFL :> reverseRL qs -partitionFL' keepleft qs (p :>: ps) - | keepleft p, - Just (p' :> qs') <- commuteRL (qs :> p) - = case partitionFL' keepleft qs' ps of - a :> b -> p' :>: a :> b - | otherwise = partitionFL' keepleft (p :<: qs) ps + -> RL p C(a b) -- the "middle" patches found so far + -> RL p C(b c) -- the "right" patches found so far + -> FL p C(c d) + -> ((FL p :> FL p :> FL p) C(a d)) + +partitionFL keepleft ps = partitionFL' keepleft NilRL NilRL ps + +partitionFL' _ middle right NilFL = (NilFL :> reverseRL middle :> reverseRL right) +partitionFL' keepleft middle right (p :>: ps) + | keepleft p = case commuteRL (right :> p) of + Just (p' :> right') -> case commuteRL (middle :> p') of + Just (p'' :> middle') -> case partitionFL' keepleft middle' right' ps of + (a :> b :> c) -> (p'' :>: a :> b :> c) + Nothing -> partitionFL' keepleft (p' :<: middle) right' ps + Nothing -> case commuteWhatWeCanRL (right :> p) of + (tomiddle :> p' :> right') -> partitionFL' keepleft (p' :<: tomiddle +<+ middle) right' ps + | otherwise = partitionFL' keepleft middle (p :<: right) ps + -- |split an 'RL' into "left" and "right" lists according to a predicate, using commutation as necessary. -- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy @@ -84,7 +89,7 @@ partitionRL' keepright (p :<: ps) qs | keepright p, - Right (qs' :> p') <- commuteFL (p :> qs) + Right (qs' :> p') <- commuteFLorComplain (p :> qs) = case partitionRL' keepright ps qs' of a :> b -> a :> p' :<: b | otherwise = partitionRL' keepright ps (p :>: qs) @@ -135,38 +140,38 @@ -- | 'removeRL' is like 'removeFL' except with 'RL' removeRL :: (MyEq p, Commute p) => p C(y z) -> RL p C(x z) -> Maybe (RL p C(x y)) -removeRL x xs = r x $ head_permutationsRL xs +removeRL x xs = r x $ headPermutationsRL xs where r :: (MyEq p, Commute p) => p C(y z) -> [RL p C(x z)] -> Maybe (RL p C(x y)) r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs | otherwise = r z zss r _ _ = Nothing --- | 'remove_subsequenceFL' @ab abc@ returns @Just c'@ where all the patches in +-- | 'removeSubsequenceFL' @ab abc@ returns @Just c'@ where all the patches in -- @ab@ have been commuted out of it, if possible. If this is not possible -- for any reason (the set of patches @ab@ is not actually a subset of @abc@, -- or they can't be commuted out) we return 'Nothing'. -remove_subsequenceFL :: (MyEq p, Commute p) => FL p C(a b) +removeSubsequenceFL :: (MyEq p, Commute p) => FL p C(a b) -> FL p C(a c) -> Maybe (FL p C(b c)) -remove_subsequenceFL a b | lengthFL a > lengthFL b = Nothing +removeSubsequenceFL a b | lengthFL a > lengthFL b = Nothing | otherwise = rsFL a b where rsFL :: (MyEq p, Commute p) => FL p C(a b) -> FL p C(a c) -> Maybe (FL p C(b c)) rsFL NilFL ys = Just ys - rsFL (x:>:xs) yys = removeFL x yys >>= remove_subsequenceFL xs + rsFL (x:>:xs) yys = removeFL x yys >>= removeSubsequenceFL xs --- | 'remove_subsequenceRL' is like @remove_subsequenceFL@ except that it works +-- | 'removeSubsequenceRL' is like @removeSubsequenceFL@ except that it works -- on 'RL' -remove_subsequenceRL :: (MyEq p, Commute p) => RL p C(ab abc) +removeSubsequenceRL :: (MyEq p, Commute p) => RL p C(ab abc) -> RL p C(a abc) -> Maybe (RL p C(a ab)) -remove_subsequenceRL a b | lengthRL a > lengthRL b = Nothing +removeSubsequenceRL a b | lengthRL a > lengthRL b = Nothing | otherwise = rsRL a b where rsRL :: (MyEq p, Commute p) => RL p C(ab abc) -> RL p C(a abc) -> Maybe (RL p C(a ab)) rsRL NilRL ys = Just ys - rsRL (x:<:xs) yys = removeRL x yys >>= remove_subsequenceRL xs + rsRL (x:<:xs) yys = removeRL x yys >>= removeSubsequenceRL xs -- | This is a minor variant of 'headPermutationsFL' with each permutation -- is simply returned as a 'FL' -head_permutationsFL :: Commute p => FL p C(x y) -> [FL p C(x y)] -head_permutationsFL ps = map (\ (x:>xs) -> x:>:xs) $ headPermutationsFL ps +simpleHeadPermutationsFL :: Commute p => FL p C(x y) -> [FL p C(x y)] +simpleHeadPermutationsFL ps = map (\ (x:>xs) -> x:>:xs) $ headPermutationsFL ps -- | 'headPermutationsFL' @p:>:ps@ returns all the permutations of the list -- in which one element of @ps@ is commuted past @p@ @@ -191,13 +196,13 @@ where swapfirstFL (p1:>p2:>xs) = do p2':>p1' <- commute (p1:>p2) Just $ p2':>p1':>:xs --- | 'head_permutationsRL' is like 'headPermutationsFL', except that we +-- | 'headPermutationsRL' is like 'headPermutationsFL', except that we -- operate on an 'RL' (in other words, we are pushing things to the end of a -- patch sequence instead of to the beginning). -head_permutationsRL :: Commute p => RL p C(x y) -> [RL p C(x y)] -head_permutationsRL NilRL = [] -head_permutationsRL (p:<:ps) = - (p:<:ps) : catMaybes (map (swapfirstRL.(p:<:)) $ head_permutationsRL ps) +headPermutationsRL :: Commute p => RL p C(x y) -> [RL p C(x y)] +headPermutationsRL NilRL = [] +headPermutationsRL (p:<:ps) = + (p:<:ps) : catMaybes (map (swapfirstRL.(p:<:)) $ headPermutationsRL ps) where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1) Just $ p2':<:p1':<:xs swapfirstRL _ = Nothing diff -ruN darcs-2.4.4/src/Darcs/Patch/Prim.lhs darcs-2.5/src/Darcs/Patch/Prim.lhs --- darcs-2.4.4/src/Darcs/Patch/Prim.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Prim.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -23,11 +23,11 @@ #include "gadts.h" module Darcs.Patch.Prim - ( Prim(..), IsConflictedPrim(IsC), ConflictState(..), showPrim, + ( Prim(..), IsConflictedPrim(IsC), ConflictState(..), showPrim, showPrimFL, showHunk, DirPatchType(..), FilePatchType(..), CommuteFunction, Perhaps(..), null_patch, nullP, isNullPatch, - is_identity, + isIdentity, formatFileName, FileNameFormat(..), adddir, addfile, binary, changepref, hunk, move, rmdir, rmfile, tokreplace, @@ -35,29 +35,27 @@ isSimilar, primIsAdddir, is_filepatch, canonize, tryToShrink, modernizePrim, subcommutes, sortCoalesceFL, join, canonizeFL, - try_tok_internal, - try_shrinking_inverse, - n_fn, + tryTokInternal, + tryShrinkingInverse, + nFn, FromPrim(..), FromPrims(..), ToFromPrim(..), - Conflict(..), Effect(..), commute_no_conflictsFL, commute_no_conflictsRL + Conflict(..), Effect(..), commuteNoConflictsFL, commuteNoConflictsRL ) where import Prelude hiding ( pi ) import Control.Monad ( MonadPlus, msum, mzero, mplus ) -import Data.Maybe ( isNothing ) -#ifndef GADT_WITNESSES +import Data.Maybe ( isNothing, listToMaybe, catMaybes ) import Data.Map ( elems, fromListWith, mapWithKey ) -#endif import ByteStringUtils ( substrPS, fromPS2Hex) import qualified Data.ByteString as B (ByteString, length, null, head, take, concat, drop) -import qualified Data.ByteString.Char8 as BC (break, pack) +import qualified Data.ByteString.Char8 as BC (break, pack, head) -import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, norm_path, - movedirfilename, encode_white ) +import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, normPath, + movedirfilename, encodeWhite ) import Darcs.Witnesses.Ordered -import Darcs.Witnesses.Sealed ( Sealed, unseal ) +import Darcs.Witnesses.Sealed ( Sealed, unseal, Sealed2(..), unsafeUnseal2 ) import Darcs.Patch.Patchy ( Invert(..), Commute(..), toFwdCommute, toRevCommute ) import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Witnesses.Show @@ -106,13 +104,13 @@ nullP :: Prim C(x y) -> EqCheck C(x y) nullP = sloppyIdentity -is_identity :: Prim C(x y) -> EqCheck C(x y) -is_identity (FP _ (Binary old new)) | old == new = unsafeCoerce# IsEq -is_identity (FP _ (Hunk _ old new)) | old == new = unsafeCoerce# IsEq -is_identity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerce# IsEq -is_identity (Move old new) | old == new = unsafeCoerce# IsEq -is_identity Identity = IsEq -is_identity _ = NotEq +isIdentity :: Prim C(x y) -> EqCheck C(x y) +isIdentity (FP _ (Binary old new)) | old == new = unsafeCoerce# IsEq +isIdentity (FP _ (Hunk _ old new)) | old == new = unsafeCoerce# IsEq +isIdentity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerce# IsEq +isIdentity (Move old new) | old == new = unsafeCoerce# IsEq +isIdentity Identity = IsEq +isIdentity _ = NotEq -- FIXME: The following code needs to be moved. @@ -157,19 +155,19 @@ evalargs :: (a -> b -> c) -> a -> b -> c evalargs f x y = (f $! x) $! y -addfile f = FP (fp2fn $ n_fn f) AddFile -rmfile f = FP (fp2fn $ n_fn f) RmFile -adddir d = DP (fp2fn $ n_fn d) AddDir -rmdir d = DP (fp2fn $ n_fn d) RmDir -move f f' = Move (fp2fn $ n_fn f) (fp2fn $ n_fn f') +addfile f = FP (fp2fn $ nFn f) AddFile +rmfile f = FP (fp2fn $ nFn f) RmFile +adddir d = DP (fp2fn $ nFn d) AddDir +rmdir d = DP (fp2fn $ nFn d) RmDir +move f f' = Move (fp2fn $ nFn f) (fp2fn $ nFn f') changepref p f t = ChangePref p f t -hunk f line old new = evalargs FP (fp2fn $ n_fn f) (Hunk line old new) +hunk f line old new = evalargs FP (fp2fn $ nFn f) (Hunk line old new) tokreplace f tokchars old new = - evalargs FP (fp2fn $ n_fn f) (TokReplace tokchars old new) -binary f old new = FP (fp2fn $! n_fn f) $ Binary old new + evalargs FP (fp2fn $ nFn f) (TokReplace tokchars old new) +binary f old new = FP (fp2fn $! nFn f) $ Binary old new -n_fn :: FilePath -> FilePath -n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f) +nFn :: FilePath -> FilePath +nFn f = "./"++(fn2fp $ normPath $ fp2fn f) instance Invert Prim where invert Identity = Identity @@ -188,48 +186,48 @@ sloppyIdentity _ = NotEq instance Show (Prim C(x y)) where - showsPrec d (Move fn1 fn2) = showParen (d > app_prec) $ showString "Move " . - showsPrec (app_prec + 1) fn1 . showString " " . - showsPrec (app_prec + 1) fn2 - showsPrec d (DP fn dp) = showParen (d > app_prec) $ showString "DP " . - showsPrec (app_prec + 1) fn . showString " " . - showsPrec (app_prec + 1) dp - showsPrec d (FP fn fp) = showParen (d > app_prec) $ showString "FP " . - showsPrec (app_prec + 1) fn . showString " " . - showsPrec (app_prec + 1) fp - showsPrec d (Split l) = showParen (d > app_prec) $ showString "Split " . - showsPrec (app_prec + 1) l + showsPrec d (Move fn1 fn2) = showParen (d > appPrec) $ showString "Move " . + showsPrec (appPrec + 1) fn1 . showString " " . + showsPrec (appPrec + 1) fn2 + showsPrec d (DP fn dp) = showParen (d > appPrec) $ showString "DP " . + showsPrec (appPrec + 1) fn . showString " " . + showsPrec (appPrec + 1) dp + showsPrec d (FP fn fp) = showParen (d > appPrec) $ showString "FP " . + showsPrec (appPrec + 1) fn . showString " " . + showsPrec (appPrec + 1) fp + showsPrec d (Split l) = showParen (d > appPrec) $ showString "Split " . + showsPrec (appPrec + 1) l showsPrec _ Identity = showString "Identity" - showsPrec d (ChangePref p f t) = showParen (d > app_prec) $ showString "ChangePref " . - showsPrec (app_prec + 1) p . showString " " . - showsPrec (app_prec + 1) f . showString " " . - showsPrec (app_prec + 1) t + showsPrec d (ChangePref p f t) = showParen (d > appPrec) $ showString "ChangePref " . + showsPrec (appPrec + 1) p . showString " " . + showsPrec (appPrec + 1) f . showString " " . + showsPrec (appPrec + 1) t instance Show2 Prim where - showsPrec2 = showsPrec + showDict2 = ShowDictClass instance Show (FilePatchType C(x y)) where showsPrec _ RmFile = showString "RmFile" showsPrec _ AddFile = showString "AddFile" showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new - = showParen (d > app_prec) $ showString "Hunk " . - showsPrec (app_prec + 1) line . showString " " . + = showParen (d > appPrec) $ showString "Hunk " . + showsPrec (appPrec + 1) line . showString " " . showsPrecC old . showString " " . showsPrecC new where showsPrecC [] = showString "[]" - showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (app_prec + 1) (map B.head ss) - showsPrec d (Hunk line old new) = showParen (d > app_prec) $ showString "Hunk " . - showsPrec (app_prec + 1) line . showString " " . - showsPrec (app_prec + 1) old . showString " " . - showsPrec (app_prec + 1) new - showsPrec d (TokReplace t old new) = showParen (d > app_prec) $ showString "TokReplace " . - showsPrec (app_prec + 1) t . showString " " . - showsPrec (app_prec + 1) old . showString " " . - showsPrec (app_prec + 1) new + showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (appPrec + 1) (map BC.head ss) + showsPrec d (Hunk line old new) = showParen (d > appPrec) $ showString "Hunk " . + showsPrec (appPrec + 1) line . showString " " . + showsPrec (appPrec + 1) old . showString " " . + showsPrec (appPrec + 1) new + showsPrec d (TokReplace t old new) = showParen (d > appPrec) $ showString "TokReplace " . + showsPrec (appPrec + 1) t . showString " " . + showsPrec (appPrec + 1) old . showString " " . + showsPrec (appPrec + 1) new -- this case may not work usefully - showsPrec d (Binary old new) = showParen (d > app_prec) $ showString "Binary " . - showsPrec (app_prec + 1) old . showString " " . - showsPrec (app_prec + 1) new + showsPrec d (Binary old new) = showParen (d > appPrec) $ showString "Binary " . + showsPrec (appPrec + 1) old . showString " " . + showsPrec (appPrec + 1) new instance Show (DirPatchType C(x y)) where showsPrec _ RmDir = showString "RmDir" @@ -243,7 +241,7 @@ data FileNameFormat = OldFormat | NewFormat formatFileName :: FileNameFormat -> FileName -> Doc formatFileName OldFormat = packedString . fn2ps -formatFileName NewFormat = text . encode_white . fn2fp +formatFileName NewFormat = text . encodeWhite . fn2fp showPrim :: FileNameFormat -> Prim C(a b) -> Doc showPrim x (FP f AddFile) = showAddFile x f @@ -258,6 +256,9 @@ showPrim x (Split ps) = showSplit x ps showPrim _ Identity = blueText "{}" +showPrimFL :: FileNameFormat -> FL Prim C(a b) -> Doc +showPrimFL f xs = vcat (mapFL (showPrim f) xs) + \end{code} @@ -375,14 +376,14 @@ showBinary x f o n = blueText "binary" <+> formatFileName x f $$ invisibleText "oldhex" - $$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex o) + $$ (vcat $ map makeprintable $ breakEvery 78 $ fromPS2Hex o) $$ invisibleText "newhex" - $$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex n) + $$ (vcat $ map makeprintable $ breakEvery 78 $ fromPS2Hex n) where makeprintable ps = invisibleText "*" <> invisiblePS ps -break_every :: Int -> B.ByteString -> [B.ByteString] -break_every n ps | B.length ps < n = [ps] - | otherwise = B.take n ps : break_every n (B.drop n ps) +breakEvery :: Int -> B.ByteString -> [B.ByteString] +breakEvery n ps | B.length ps < n = [ps] + | otherwise = B.take n ps : breakEvery n (B.drop n ps) \end{code} \paragraph{Split patch [OBSOLETE!]} @@ -401,8 +402,8 @@ $$ vcat (mapFL (showPrim x) ps) $$ blueText ")" -commute_split :: CommuteFunction -commute_split (Split patches :< patch) = +commuteSplit :: CommuteFunction +commuteSplit (Split patches :< patch) = toPerhaps $ cs (patches :< patch) >>= sc where cs :: ((FL Prim) :< Prim) C(x y) -> Maybe ((Prim :< (FL Prim)) C(x y)) cs (NilFL :< p1) = return (p1 :< NilFL) @@ -415,25 +416,31 @@ -> Maybe ((Prim :< Prim) C(x y)) scFL (p1' :< (p :>: NilFL)) = return (p1' :< p) scFL (p1' :< ps') = return (p1' :< Split ps') -commute_split _ = Unknown +commuteSplit _ = Unknown tryToShrink :: FL Prim C(x y) -> FL Prim C(x y) -tryToShrink = mapPrimFL try_harder_to_shrink +tryToShrink = mapPrimFL tryHarderToShrink mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y)) -> FL Prim C(w z) -> FL Prim C(w z) mapPrimFL f x = -#ifdef GADT_WITNESSES - f x -#else -- an optimisation; break the list up into independent sublists -- and apply f to each of them - case mapM toSimple $ mapFL id x of - Just sx -> foldr (+>+) NilFL $ elems $ - mapWithKey (\ k p -> f (fromSimples k (p NilFL))) $ + case mapM toSimpleSealed $ mapFL Sealed2 x of + Just sx -> concatFL $ unsealList $ elems $ + mapWithKey (\ k p -> Sealed2 (f (fromSimples k (unsealList (p []))))) $ fromListWith (flip (.)) $ - map (\ (a,b) -> (a,(b:>:))) sx + map (\ (a,b) -> (a,(b:))) sx Nothing -> f x + where + unsealList :: [Sealed2 p] -> FL p C(a b) + unsealList [] = unsafeCoerceP NilFL + unsealList (x:xs) = unsafeUnseal2 x :>: unsealList xs + + toSimpleSealed :: Sealed2 Prim -> Maybe (FileName, Sealed2 Simple) + toSimpleSealed (Sealed2 p) = fmap (\(fn, s) -> (fn, Sealed2 s)) (toSimple p) + + data Simple C(x y) = SFP !(FilePatchType C(x y)) | SDP !(DirPatchType C(x y)) | SCP String String String @@ -455,46 +462,45 @@ fromSimples :: FileName -> FL Simple C(x y) -> FL Prim C(x y) fromSimples a bs = mapFL_FL (fromSimple a) bs -#endif -try_harder_to_shrink :: FL Prim C(x y) -> FL Prim C(x y) -try_harder_to_shrink x = try_to_shrink2 $ maybe x id (try_shrinking_inverse x) +tryHarderToShrink :: FL Prim C(x y) -> FL Prim C(x y) +tryHarderToShrink x = tryToShrink2 $ maybe x id (tryShrinkingInverse x) -try_to_shrink2 :: FL Prim C(x y) -> FL Prim C(x y) -try_to_shrink2 psold = +tryToShrink2 :: FL Prim C(x y) -> FL Prim C(x y) +tryToShrink2 psold = let ps = sortCoalesceFL psold - ps_shrunk = shrink_a_bit ps + ps_shrunk = shrinkABit ps in if lengthFL ps_shrunk < lengthFL ps - then try_to_shrink2 ps_shrunk + then tryToShrink2 ps_shrunk else ps_shrunk -try_shrinking_inverse :: FL Prim C(x y) -> Maybe (FL Prim C(x y)) -try_shrinking_inverse (x:>:y:>:z) +tryShrinkingInverse :: FL Prim C(x y) -> Maybe (FL Prim C(x y)) +tryShrinkingInverse (x:>:y:>:z) | IsEq <- invert x =\/= y = Just z - | otherwise = case try_shrinking_inverse (y:>:z) of + | otherwise = case tryShrinkingInverse (y:>:z) of Nothing -> Nothing - Just yz' -> Just $ case try_shrinking_inverse (x:>:yz') of + Just yz' -> Just $ case tryShrinkingInverse (x:>:yz') of Nothing -> x:>:yz' Just xyz' -> xyz' -try_shrinking_inverse _ = Nothing +tryShrinkingInverse _ = Nothing -shrink_a_bit :: FL Prim C(x y) -> FL Prim C(x y) -shrink_a_bit NilFL = NilFL -shrink_a_bit (p:>:ps) = - case try_one NilRL p ps of - Nothing -> p :>: shrink_a_bit ps +shrinkABit :: FL Prim C(x y) -> FL Prim C(x y) +shrinkABit NilFL = NilFL +shrinkABit (p:>:ps) = + case tryOne NilRL p ps of + Nothing -> p :>: shrinkABit ps Just ps' -> ps' -try_one :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z) +tryOne :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z) -> Maybe (FL Prim C(w z)) -try_one _ _ NilFL = Nothing -try_one sofar p (p1:>:ps) = +tryOne _ _ NilFL = Nothing +tryOne sofar p (p1:>:ps) = case coalesce (p1 :< p) of Just p' -> Just (reverseRL sofar +>+ p':>:NilFL +>+ ps) Nothing -> case commute (p :> p1) of Nothing -> Nothing - Just (p1' :> p') -> try_one (p1':<:sofar) p' ps + Just (p1' :> p') -> tryOne (p1':<:sofar) p' ps -- | 'canonizeFL' @ps@ puts a sequence of primitive patches into -- canonical form. Even if the patches are just hunk patches, @@ -516,16 +522,16 @@ -- possible, sorting the results according to the scheme defined -- in 'comparePrim' sortCoalesceFL :: FL Prim C(x y) -> FL Prim C(x y) -sortCoalesceFL = mapPrimFL sort_coalesceFL2 +sortCoalesceFL = mapPrimFL sortCoalesceFL2 -- | The heart of "sortCoalesceFL" -sort_coalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y) -sort_coalesceFL2 NilFL = NilFL -sort_coalesceFL2 (x:>:xs) | IsEq <- nullP x = sort_coalesceFL2 xs -sort_coalesceFL2 (x:>:xs) | IsEq <- is_identity x = sort_coalesceFL2 xs -sort_coalesceFL2 (x:>:xs) = either id id $ push_coalesce_patch x $ sort_coalesceFL2 xs +sortCoalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y) +sortCoalesceFL2 NilFL = NilFL +sortCoalesceFL2 (x:>:xs) | IsEq <- nullP x = sortCoalesceFL2 xs +sortCoalesceFL2 (x:>:xs) | IsEq <- isIdentity x = sortCoalesceFL2 xs +sortCoalesceFL2 (x:>:xs) = either id id $ pushCoalescePatch x $ sortCoalesceFL2 xs --- | 'push_coalesce_patch' @new ps@ is almost like @new :>: ps@ except +-- | 'pushCoalescePatch' @new ps@ is almost like @new :>: ps@ except -- as an alternative to consing, we first try to coalesce @new@ with -- the head of @ps@. If this fails, we try again, using commutation -- to push @new@ down the list until we find a place where either @@ -534,33 +540,33 @@ -- (c) coalescing succeeds. -- The basic principle is to coalesce if we can and cons otherwise. -- --- As an additional optimization, push_coalesce_patch outputs a Left +-- As an additional optimization, pushCoalescePatch outputs a Left -- value if it wasn't able to shrink the patch sequence at all, and -- a Right value if it was indeed able to shrink the patch sequence. -- This avoids the O(N) calls to lengthFL that were in the older -- code. -- --- Also note that push_coalesce_patch is only ever used (and should +-- Also note that pushCoalescePatch is only ever used (and should -- only ever be used) as an internal function in in --- sort_coalesceFL2. -push_coalesce_patch :: Prim C(x y) -> FL Prim C(y z) +-- sortCoalesceFL2. +pushCoalescePatch :: Prim C(x y) -> FL Prim C(y z) -> Either (FL Prim C(x z)) (FL Prim C(x z)) -push_coalesce_patch new NilFL = Left (new:>:NilFL) -push_coalesce_patch new ps@(p:>:ps') +pushCoalescePatch new NilFL = Left (new:>:NilFL) +pushCoalescePatch new ps@(p:>:ps') = case coalesce (p :< new) of Just new' | IsEq <- nullP new' -> Right ps' - | otherwise -> Right $ either id id $ push_coalesce_patch new' ps' + | otherwise -> Right $ either id id $ pushCoalescePatch new' ps' Nothing -> if comparePrim new p == LT then Left (new:>:ps) else case commute (new :> p) of Just (p' :> new') -> - case push_coalesce_patch new' ps' of + case pushCoalescePatch new' ps' of Right r -> Right $ either id id $ - push_coalesce_patch p' r + pushCoalescePatch p' r Left r -> Left (p' :>: r) Nothing -> Left (new:>:ps) -is_in_directory :: FileName -> FileName -> Bool -is_in_directory d f = iid (fn2fp d) (fn2fp f) +isInDirectory :: FileName -> FileName -> Bool +isInDirectory d f = iid (fn2fp d) (fn2fp f) where iid (cd:cds) (cf:cfs) | cd /= cf = False | otherwise = iid cds cfs @@ -594,8 +600,8 @@ toPerhaps (Just x) = Succeeded x toPerhaps Nothing = Failed -clever_commute :: CommuteFunction -> CommuteFunction -clever_commute c (p1: CommuteFunction +cleverCommute c (p1: Succeeded x Failed -> Failed @@ -603,22 +609,22 @@ Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1') Failed -> Failed Unknown -> Unknown ---clever_commute c (p1,p2) = c (p1,p2) `mplus` +--cleverCommute c (p1,p2) = c (p1,p2) `mplus` -- (case c (invert p2,invert p1) of -- Succeeded (p1', p2') -> Succeeded (invert p2', invert p1') -- Failed -> Failed -- Unknown -> Unknown) -speedy_commute :: CommuteFunction -speedy_commute (p1 :< p2) -- Deal with common case quickly! +speedyCommute :: CommuteFunction +speedyCommute (p1 :< p2) -- Deal with common case quickly! | p1_modifies /= Nothing && p2_modifies /= Nothing && p1_modifies /= p2_modifies = Succeeded (unsafeCoerce# p2 :< unsafeCoerce# p1) | otherwise = Unknown where p1_modifies = is_filepatch p1 p2_modifies = is_filepatch p2 -everything_else_commute :: CommuteFunction -everything_else_commute x = eec x +everythingElseCommute :: CommuteFunction +everythingElseCommute x = eec x where eec :: CommuteFunction eec (ChangePref p f t : z' :/\: y' Nothing -> error "Commute Prim merge" - commute x = toMaybe $ msum [toFwdCommute speedy_commute x, - toFwdCommute everything_else_commute x + commute x = toMaybe $ msum [toFwdCommute speedyCommute x, + toFwdCommute everythingElseCommute x ] -- Recurse on everything, these are potentially spoofed patches listTouchedFiles (Move f1 f2) = map fn2fp [f1, f2] @@ -671,50 +677,50 @@ is_filepatch (FP f _) = Just f is_filepatch _ = Nothing -is_superdir :: FileName -> FileName -> Bool -is_superdir d1 d2 = isd (fn2fp d1) (fn2fp d2) +isSuperdir :: FileName -> FileName -> Bool +isSuperdir d1 d2 = isd (fn2fp d1) (fn2fp d2) where isd s1 s2 = length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/" -commute_filedir :: CommuteFunction -commute_filedir (FP f1 p1 :< FP f2 p2) = +commuteFiledir :: CommuteFunction +commuteFiledir (FP f1 p1 :< FP f2 p2) = if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerce# p2) :< FP f1 (unsafeCoerce# p1) ) else commuteFP f1 (p1 :< p2) -commute_filedir (DP d1 p1 :< DP d2 p2) = - if (not $ is_in_directory d1 d2) && (not $ is_in_directory d2 d1) && +commuteFiledir (DP d1 p1 :< DP d2 p2) = + if (not $ isInDirectory d1 d2) && (not $ isInDirectory d2 d1) && d1 /= d2 then Succeeded ( DP d2 (unsafeCoerce# p2) :< DP d1 (unsafeCoerce# p1) ) else Failed -commute_filedir (DP d dp :< FP f fp) = - if not $ is_in_directory d f +commuteFiledir (DP d dp :< FP f fp) = + if not $ isInDirectory d f then Succeeded (FP f (unsafeCoerce# fp) :< DP d (unsafeCoerce# dp)) else Failed -commute_filedir (Move d d' :< FP f2 p2) +commuteFiledir (Move d d' :< FP f2 p2) | f2 == d' = Failed | (p2 == AddFile || p2 == RmFile) && d == f2 = Failed | otherwise = Succeeded (FP (movedirfilename d d' f2) (unsafeCoerce# p2) :< Move d d') -commute_filedir (Move d d' :< DP d2 p2) - | is_superdir d2 d' || is_superdir d2 d = Failed +commuteFiledir (Move d d' :< DP d2 p2) + | isSuperdir d2 d' || isSuperdir d2 d = Failed | (p2 == AddDir || p2 == RmDir) && d == d2 = Failed | d2 == d' = Failed | otherwise = Succeeded (DP (movedirfilename d d' d2) (unsafeCoerce# p2) :< Move d d') -commute_filedir (Move d d' :< Move f f') +commuteFiledir (Move d d' :< Move f f') | f == d' || f' == d = Failed | f == d || f' == d' = Failed - | d `is_superdir` f && f' `is_superdir` d' = Failed + | d `isSuperdir` f && f' `isSuperdir` d' = Failed | otherwise = Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f') :< Move (movedirfilename f' f d) (movedirfilename f' f d')) -commute_filedir _ = Unknown +commuteFiledir _ = Unknown type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y)) -subcommutes :: [(String, CommuteFunction)] +subcommutes :: [(String, (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y)))] subcommutes = - [("speedy_commute", speedy_commute), - ("commute_filedir", clever_commute commute_filedir), - ("commute_filepatches", clever_commute commute_filepatches), + [("speedyCommute", speedyCommute), + ("commuteFiledir", cleverCommute commuteFiledir), + ("commuteFilepatches", cleverCommute commuteFilepatches), ("commutex", toPerhaps . toRevCommute commute) ] @@ -737,7 +743,7 @@ \begin{code} canonize :: Prim C(x y) -> FL Prim C(x y) canonize (Split ps) = sortCoalesceFL ps -canonize p | IsEq <- is_identity p = NilFL +canonize p | IsEq <- isIdentity p = NilFL canonize (FP f (Hunk line old new)) = canonizeHunk f line old new canonize p = p :>: NilFL \end{code} @@ -787,9 +793,9 @@ different files. If they happen to modify the same file, we'll have to check whether or not they commutex. \begin{code} -commute_filepatches :: CommuteFunction -commute_filepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2) -commute_filepatches _ = Unknown +commuteFilepatches :: CommuteFunction +commuteFilepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2) +commuteFilepatches _ = Unknown commuteFP :: FileName -> (FilePatchType :< FilePatchType) C(x y) -> Perhaps ((Prim :< Prim) C(x y)) @@ -800,10 +806,10 @@ commuteFP f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) = seq f $ toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) commuteFP f (TokReplace t o n :< Hunk line2 old2 new2) = seq f $ - case try_tok_replace t o n old2 of + case tryTokReplace t o n old2 of Nothing -> Failed Just old2' -> - case try_tok_replace t o n new2 of + case tryTokReplace t o n new2 of Nothing -> Failed Just new2' -> Succeeded (FP f (Hunk line2 old2' new2') :< FP f (TokReplace t o n)) @@ -910,29 +916,29 @@ canonizeHunk f line old new | null old || null new = FP f (Hunk line old new) :>: NilFL -canonizeHunk f line old new = make_holey f line $ getChanges old new +canonizeHunk f line old new = makeHoley f line $ getChanges old new -make_holey :: FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])] +makeHoley :: FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])] -> FL Prim C(x y) -make_holey f line changes = +makeHoley f line changes = unsafeMap_l2f (\ (l,o,n) -> FP f (Hunk (l+line) o n)) changes - -try_tok_replace :: String -> String -> String + +tryTokReplace :: String -> String -> String -> [B.ByteString] -> Maybe [B.ByteString] -try_tok_replace t o n mss = - mapM (fmap B.concat . try_tok_internal t (BC.pack o) (BC.pack n)) mss +tryTokReplace t o n mss = + mapM (fmap B.concat . tryTokInternal t (BC.pack o) (BC.pack n)) mss -try_tok_internal :: String -> B.ByteString -> B.ByteString +tryTokInternal :: String -> B.ByteString -> B.ByteString -> B.ByteString -> Maybe [B.ByteString] -try_tok_internal _ o n s | isNothing (substrPS o s) && +tryTokInternal _ o n s | isNothing (substrPS o s) && isNothing (substrPS n s) = Just [s] -try_tok_internal t o n s = +tryTokInternal t o n s = case BC.break (regChars t) s of (before,s') -> case BC.break (not . regChars t) s' of (tok,after) -> - case try_tok_internal t o n after of + case tryTokInternal t o n after of Nothing -> Nothing Just rest -> if tok == o @@ -948,20 +954,20 @@ instance MyEq Prim where unsafeCompare (Move a b) (Move c d) = a == c && b == d unsafeCompare (DP d1 p1) (DP d2 p2) - = d1 == d2 && p1 `unsafeCompare` p2 + = d1 == d2 && p1 `unsafeCompare` p2 unsafeCompare (FP f1 fp1) (FP f2 fp2) = f1 == f2 && fp1 `unsafeCompare` fp2 unsafeCompare (Split ps1) (Split ps2) - = eq_FL unsafeCompare ps1 ps2 + = eqFL unsafeCompare ps1 ps2 unsafeCompare (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) = c1 == c2 && b1 == b2 && a1 == a2 unsafeCompare Identity Identity = True unsafeCompare _ _ = False -merge_orders :: Ordering -> Ordering -> Ordering -merge_orders EQ x = x -merge_orders LT _ = LT -merge_orders GT _ = GT +mergeOrders :: Ordering -> Ordering -> Ordering +mergeOrders EQ x = x +mergeOrders LT _ = LT +mergeOrders GT _ = GT -- | 'comparePrim' @p1 p2@ is used to provide an arbitrary ordering between -- @p1@ and @p2@. Basically, identical patches are equal and @@ -977,7 +983,7 @@ comparePrim (FP f1 fp1) (FP f2 fp2) = compare (f1, fp1) $ unsafeCoerceP (f2, fp2) comparePrim (FP _ _) _ = LT comparePrim _ (FP _ _) = GT -comparePrim (Split ps1) (Split ps2) = compare_FL comparePrim ps1 $ unsafeCoerceP ps2 +comparePrim (Split ps1) (Split ps2) = compareFL comparePrim ps1 $ unsafeCoerceP ps2 comparePrim (Split _) _ = LT comparePrim _ (Split _) = GT comparePrim Identity Identity = EQ @@ -986,19 +992,19 @@ comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) = compare (c1, b1, a1) (c2, b2, a2) -eq_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool) +eqFL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool) -> FL a C(x y) -> FL a C(w z) -> Bool -eq_FL _ NilFL NilFL = True -eq_FL f (x:>:xs) (y:>:ys) = f x y && eq_FL f xs ys -eq_FL _ _ _ = False +eqFL _ NilFL NilFL = True +eqFL f (x:>:xs) (y:>:ys) = f x y && eqFL f xs ys +eqFL _ _ _ = False -compare_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Ordering) +compareFL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Ordering) -> FL a C(x y) -> FL a C(w z) -> Ordering -compare_FL _ NilFL NilFL = EQ -compare_FL _ NilFL _ = LT -compare_FL _ _ NilFL = GT -compare_FL f (x:>:xs) (y:>:ys) = f x y `merge_orders` compare_FL f xs ys - +compareFL _ NilFL NilFL = EQ +compareFL _ NilFL _ = LT +compareFL _ _ NilFL = GT +compareFL f (x:>:xs) (y:>:ys) = f x y `mergeOrders` compareFL f xs ys + class FromPrim p where fromPrim :: Prim C(x y) -> p C(x y) @@ -1028,7 +1034,7 @@ nubsort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p resolveConflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]] resolveConflicts _ = [] - -- | If 'commute_no_conflicts' @x :> y@ succeeds, we know that that @x@ commutes + -- | If 'commuteNoConflicts' @x :> y@ succeeds, we know that that @x@ commutes -- past @y@ without any conflicts. This function is useful for patch types -- for which 'commute' is defined to always succeed; so we need some way to -- pick out the specific cases where commutation succeeds without any conflicts. @@ -1062,8 +1068,8 @@ -- -- We check that commuting @X@ and @Y@ succeeds, as does commuting @-X@ and @Y'@. -- It also checks that @Y'' == Y@ and that @-(X')@ is the same as @(-X)'@ - commute_no_conflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y)) - commute_no_conflicts (x:>y) = + commuteNoConflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y)) + commuteNoConflicts (x:>y) = do y':>x' <- commute (x:>y) y'':>ix'' <- commute (invert x :> y') IsEq <- return $ y'' =\/= y @@ -1073,16 +1079,19 @@ conflictedEffect x = case listConflictedFiles x of [] -> mapFL (IsC Okay) $ effect x _ -> mapFL (IsC Conflicted) $ effect x + isInconsistent :: p C(x y) -> Maybe Doc + isInconsistent _ = Nothing instance Conflict p => Conflict (FL p) where listConflictedFiles = nubsort . concat . mapFL listConflictedFiles resolveConflicts NilFL = [] resolveConflicts x = resolveConflicts $ reverseFL x - commute_no_conflicts (NilFL :> x) = Just (x :> NilFL) - commute_no_conflicts (x :> NilFL) = Just (NilFL :> x) - commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (reverseFL xs :> ys) + commuteNoConflicts (NilFL :> x) = Just (x :> NilFL) + commuteNoConflicts (x :> NilFL) = Just (NilFL :> x) + commuteNoConflicts (xs :> ys) = do ys' :> rxs' <- commuteNoConflictsRLFL (reverseFL xs :> ys) return $ ys' :> reverseRL rxs' conflictedEffect = concat . mapFL conflictedEffect + isInconsistent = listToMaybe . catMaybes . mapFL isInconsistent instance Conflict p => Conflict (RL p) where listConflictedFiles = nubsort . concat . mapRL listConflictedFiles @@ -1090,15 +1099,16 @@ where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL Prim C(w))]] rcs NilRL _ = [] rcs (p:<:ps) passedby | (_:_) <- resolveConflicts p = - case commute_no_conflictsFL (p:>passedby) of + case commuteNoConflictsFL (p:>passedby) of Just (_:> p') -> resolveConflicts p' ++ rcs ps (p:>:passedby) Nothing -> rcs ps (p:>:passedby) rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby) - commute_no_conflicts (NilRL :> x) = Just (x :> NilRL) - commute_no_conflicts (x :> NilRL) = Just (NilRL :> x) - commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (xs :> reverseRL ys) + commuteNoConflicts (NilRL :> x) = Just (x :> NilRL) + commuteNoConflicts (x :> NilRL) = Just (NilRL :> x) + commuteNoConflicts (xs :> ys) = do ys' :> rxs' <- commuteNoConflictsRLFL (xs :> reverseRL ys) return $ reverseFL ys' :> rxs' conflictedEffect = concat . reverse . mapRL conflictedEffect + isInconsistent = listToMaybe . catMaybes . mapRL isInconsistent data IsConflictedPrim where IsC :: !ConflictState -> !(Prim C(x y)) -> IsConflictedPrim @@ -1133,23 +1143,23 @@ effect p = concatFL $ mapFL_FL effect $ reverseRL p effectRL p = concatRL $ mapRL_RL effectRL p -commute_no_conflictsFL :: Conflict p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y)) -commute_no_conflictsFL (p :> NilFL) = Just (NilFL :> p) -commute_no_conflictsFL (q :> p :>: ps) = do p' :> q' <- commute_no_conflicts (q :> p) - ps' :> q'' <- commute_no_conflictsFL (q' :> ps) +commuteNoConflictsFL :: Conflict p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y)) +commuteNoConflictsFL (p :> NilFL) = Just (NilFL :> p) +commuteNoConflictsFL (q :> p :>: ps) = do p' :> q' <- commuteNoConflicts (q :> p) + ps' :> q'' <- commuteNoConflictsFL (q' :> ps) return (p' :>: ps' :> q'') -commute_no_conflictsRL :: Conflict p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y)) -commute_no_conflictsRL (NilRL :> p) = Just (p :> NilRL) -commute_no_conflictsRL (p :<: ps :> q) = do q' :> p' <- commute_no_conflicts (p :> q) - q'' :> ps' <- commute_no_conflictsRL (ps :> q') +commuteNoConflictsRL :: Conflict p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y)) +commuteNoConflictsRL (NilRL :> p) = Just (p :> NilRL) +commuteNoConflictsRL (p :<: ps :> q) = do q' :> p' <- commuteNoConflicts (p :> q) + q'' :> ps' <- commuteNoConflictsRL (ps :> q') return (q'' :> p' :<: ps') -commute_no_conflictsRLFL :: Conflict p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y)) -commute_no_conflictsRLFL (NilRL :> ys) = Just (ys :> NilRL) -commute_no_conflictsRLFL (xs :> NilFL) = Just (NilFL :> xs) -commute_no_conflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commute_no_conflictsRL (xs :> y) - ys' :> xs'' <- commute_no_conflictsRLFL (xs' :> ys) +commuteNoConflictsRLFL :: Conflict p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y)) +commuteNoConflictsRLFL (NilRL :> ys) = Just (ys :> NilRL) +commuteNoConflictsRLFL (xs :> NilFL) = Just (NilFL :> xs) +commuteNoConflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteNoConflictsRL (xs :> y) + ys' :> xs'' <- commuteNoConflictsRLFL (xs' :> ys) return (y' :>: ys' :> xs'') \end{code} diff -ruN darcs-2.4.4/src/Darcs/Patch/Properties.lhs darcs-2.5/src/Darcs/Patch/Properties.lhs --- darcs-2.4.4/src/Darcs/Patch/Properties.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Properties.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -34,15 +34,15 @@ #include "gadts.h" -module Darcs.Patch.Properties ( recommute, commute_inverses, permutivity, partial_permutivity, - identity_commutes, inverse_doesnt_commute, - patch_and_inverse_commute, merge_either_way, +module Darcs.Patch.Properties ( recommute, commuteInverses, permutivity, partialPermutivity, + identityCommutes, inverseDoesntCommute, + patchAndInverseCommute, mergeEitherWay, show_read, - merge_commute, merge_consistent, merge_arguments_consistent, - join_inverses, join_commute ) where + mergeCommute, mergeConsistent, mergeArgumentsConsistent, + joinInverses, joinCommute ) where import Control.Monad ( msum, mplus ) -import Darcs.Witnesses.Show ( Show2(..) ) +import Darcs.Witnesses.Show ( Show2(..), show2 ) import Darcs.Patch.Patchy import Darcs.Patch.Prim import Darcs.Patch () @@ -69,18 +69,18 @@ \end{prp} \begin{code} -identity_commutes :: forall p C(x y). Patchy p => p C(x y) -> Maybe Doc -identity_commutes p = case commute (p :> identity) of - Nothing -> Just $ redText "identity_commutes failed:" $$ showPatch p +identityCommutes :: forall p C(x y). Patchy p => p C(x y) -> Maybe Doc +identityCommutes p = case commute (p :> identity) of + Nothing -> Just $ redText "identityCommutes failed:" $$ showPatch p Just (i :> p') | IsEq <- i =\/= identity, IsEq <- p' =\/= p -> checkRightIdentity $ commute $ identity :> p - Just _ -> Just $ greenText "identity_commutes" + Just _ -> Just $ greenText "identityCommutes" where checkRightIdentity :: Maybe ((p :> p) C(x y)) -> Maybe Doc - checkRightIdentity Nothing = Just $ redText "identity_commutes failed 2:" $$ showPatch p + checkRightIdentity Nothing = Just $ redText "identityCommutes failed 2:" $$ showPatch p checkRightIdentity (Just (p2 :> i2)) | IsEq <- i2 =\/= identity, IsEq <- p2 =\/= p = Nothing - checkRightIdentity (Just _) = Just $ greenText "identity_commutes 2" + checkRightIdentity (Just _) = Just $ greenText "identityCommutes 2" \end{code} \begin{prp}[Inverse doesn't commute] @@ -89,10 +89,10 @@ \end{prp} \begin{code} -inverse_doesnt_commute :: Patchy p => p C(a b) -> Maybe Doc -inverse_doesnt_commute p | IsEq <- sloppyIdentity p = Nothing +inverseDoesntCommute :: Patchy p => p C(a b) -> Maybe Doc +inverseDoesntCommute p | IsEq <- sloppyIdentity p = Nothing | otherwise = do p' :> _ <- commute (invert p :> p) - Just $ redText "inverse_doesnt_commute" $$ showPatch p' + Just $ redText "inverseDoesntCommute" $$ showPatch p' \end{code} \subsection{Commute properties} @@ -128,9 +128,9 @@ \end{prp} \begin{code} -commute_inverses :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) +commuteInverses :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) -> (p :> p) C(a b) -> Maybe Doc -commute_inverses c (x :> y) = +commuteInverses c (x :> y) = case c (x :> y) of Nothing -> Nothing Just (y' :> x') -> @@ -161,13 +161,13 @@ This property is only true of primitive patches. \begin{code} -patch_and_inverse_commute :: Patchy p => +patchAndInverseCommute :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) -> (p :> p) C(a b) -> Maybe Doc -patch_and_inverse_commute c (x :> y) = +patchAndInverseCommute c (x :> y) = do y' :> x' <- c (x :> y) case c (invert x :> y') of - Nothing -> Just (redText "failure in patch_and_inverse_commute") + Nothing -> Just (redText "failure in patchAndInverseCommute") Just (y'' :> ix') -> case y'' =\/= y of NotEq -> Just (redText "y'' /= y" $$ @@ -234,9 +234,9 @@ redText "z3" $$ showPatch z3 $$ redText "z3_" $$ showPatch z3_ -partial_permutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) +partialPermutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) -> (p :> p :> p) C(a b) -> Maybe Doc -partial_permutivity c (xx:>yy:>zz) = pp (xx:>yy:>zz) `mplus` pp (invert zz:>invert yy:>invert xx) +partialPermutivity c (xx:>yy:>zz) = pp (xx:>yy:>zz) `mplus` pp (invert zz:>invert yy:>invert xx) where pp (x:>y:>z) = do z1 :> y1 <- c (y :> z) _ :> x1 <- c (x :> z1) case c (x :> y) of @@ -244,45 +244,45 @@ Nothing -> case c (x1 :> y1) of Nothing -> Nothing - Just _ -> Just $ greenText "partial_permutivity error" $$ + Just _ -> Just $ greenText "partialPermutivity error" $$ greenText "x" $$ showPatch x $$ greenText "y" $$ showPatch y $$ greenText "z" $$ showPatch z -merge_arguments_consistent :: Patchy p => +mergeArgumentsConsistent :: Patchy p => (FORALL(x y) p C(x y) -> Maybe Doc) -> (p :\/: p) C(a b) -> Maybe Doc -merge_arguments_consistent is_consistent (x :\/: y) = - msum [(\z -> redText "merge_arguments_consistent x" $$ showPatch x $$ z) `fmap` is_consistent x, - (\z -> redText "merge_arguments_consistent y" $$ showPatch y $$ z) `fmap` is_consistent y] +mergeArgumentsConsistent isConsistent (x :\/: y) = + msum [(\z -> redText "mergeArgumentsConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x, + (\z -> redText "mergeArgumentsConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y] -merge_consistent :: Patchy p => +mergeConsistent :: Patchy p => (FORALL(x y) p C(x y) -> Maybe Doc) -> (p :\/: p) C(a b) -> Maybe Doc -merge_consistent is_consistent (x :\/: y) = +mergeConsistent isConsistent (x :\/: y) = case merge (x :\/: y) of y' :/\: x' -> - msum [(\z -> redText "merge_consistent x" $$ showPatch x $$ z) `fmap` is_consistent x, - (\z -> redText "merge_consistent y" $$ showPatch y $$ z) `fmap` is_consistent y, - (\z -> redText "merge_consistent x'" $$ showPatch x' $$ z $$ + msum [(\z -> redText "mergeConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x, + (\z -> redText "mergeConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y, + (\z -> redText "mergeConsistent x'" $$ showPatch x' $$ z $$ redText "where x' comes from x" $$ showPatch x $$ - redText "and y" $$ showPatch y) `fmap` is_consistent x', - (\z -> redText "merge_consistent y'" $$ showPatch y' $$ z) `fmap` is_consistent y'] + redText "and y" $$ showPatch y) `fmap` isConsistent x', + (\z -> redText "mergeConsistent y'" $$ showPatch y' $$ z) `fmap` isConsistent y'] -merge_either_way :: Patchy p => (p :\/: p) C(x y) -> Maybe Doc -merge_either_way (x :\/: y) = +mergeEitherWay :: Patchy p => (p :\/: p) C(x y) -> Maybe Doc +mergeEitherWay (x :\/: y) = case merge (x :\/: y) of y' :/\: x' -> case merge (y :\/: x) of x'' :/\: y'' | IsEq <- x'' =\/= x', IsEq <- y'' =\/= y' -> Nothing - | otherwise -> Just $ redText "merge_either_way bug" + | otherwise -> Just $ redText "mergeEitherWay bug" -merge_commute :: Patchy p => (p :\/: p) C(x y) -> Maybe Doc -merge_commute (x :\/: y) = +mergeCommute :: Patchy p => (p :\/: p) C(x y) -> Maybe Doc +mergeCommute (x :\/: y) = case merge (x :\/: y) of y' :/\: x' -> case commute (x :> y') of - Nothing -> Just $ redText "merge_commute 1" $$ + Nothing -> Just $ redText "mergeCommute 1" $$ redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$ redText "x'" $$ showPatch x' $$ @@ -291,7 +291,7 @@ | IsEq <- y_ =\/= y, IsEq <- x'_ =\/= x' -> case commute (y :> x') of - Nothing -> Just $ redText "merge_commute 2 failed" $$ + Nothing -> Just $ redText "mergeCommute 2 failed" $$ redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$ redText "x'" $$ showPatch x' $$ @@ -299,14 +299,14 @@ Just (x_ :> y'_) | IsEq <- x_ =\/= x, IsEq <- y'_ =\/= y' -> Nothing - | otherwise -> Just $ redText "merge_commute 3" $$ + | otherwise -> Just $ redText "mergeCommute 3" $$ redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$ redText "x'" $$ showPatch x' $$ redText "y'" $$ showPatch y' $$ redText "x_" $$ showPatch x_ $$ redText "y'_" $$ showPatch y'_ - | otherwise -> Just $ redText "merge_commute 4" $$ + | otherwise -> Just $ redText "mergeCommute 4" $$ redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$ redText "x'" $$ showPatch x' $$ @@ -314,28 +314,28 @@ redText "x'_" $$ showPatch x'_ $$ redText "y_" $$ showPatch y_ -join_inverses :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))) +joinInverses :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))) -> Prim C(a b) -> Maybe Doc -join_inverses j p = case j (invert p :> p) of +joinInverses j p = case j (invert p :> p) of Just Identity -> Nothing - Just p' -> Just $ redText "join_inverses gave just" $$ showPatch p' - Nothing -> Just $ redText "join_inverses failed" + Just p' -> Just $ redText "joinInverses gave just" $$ showPatch p' + Nothing -> Just $ redText "joinInverses failed" -join_commute :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))) +joinCommute :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))) -> (Prim :> Prim :> Prim) C(a b) -> Maybe Doc -join_commute j (a :> b :> c) = +joinCommute j (a :> b :> c) = do x <- j (b :> c) - case commuteFL (a :> b :>: c :>: NilFL) of + case commuteFLorComplain (a :> b :>: c :>: NilFL) of Right (b' :>: c' :>: NilFL :> a') -> case commute (a :> x) of - Nothing -> Just $ greenText "join_commute 1" + Nothing -> Just $ greenText "joinCommute 1" Just (x' :> a'') -> case a'' =/\= a' of - NotEq -> Just $ greenText "join_commute 3" + NotEq -> Just $ greenText "joinCommute 3" IsEq -> case j (b' :> c') of - Nothing -> Just $ greenText "join_commute 4" + Nothing -> Just $ greenText "joinCommute 4" Just x'' -> case x' =\/= x'' of - NotEq -> Just $ greenText "join_commute 5" + NotEq -> Just $ greenText "joinCommute 5" IsEq -> Nothing _ -> Nothing diff -ruN darcs-2.4.4/src/Darcs/Patch/Read.hs darcs-2.5/src/Darcs/Patch/Read.hs --- darcs-2.4.4/src/Darcs/Patch/Read.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Read.hs 2010-10-24 08:29:26.000000000 -0700 @@ -30,32 +30,30 @@ import qualified Data.ByteString.Char8 as BC (head, unpack, dropWhile, break) import qualified Data.ByteString as B (ByteString, null, init, tail, empty, concat) -import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, ps2fn, decode_white ) +import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, ps2fn, decodeWhite ) import Darcs.Patch.Core ( Patch(..), Named(..) ) import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..), DirPatchType(..), FilePatchType(..), hunk, binary ) -#ifndef GADT_WITNESSES import Darcs.Patch.Commute ( merger ) import Darcs.Patch.Patchy ( invert ) -#endif import Darcs.Patch.Info ( PatchInfo, readPatchInfo ) -import Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input, - parse_strictly, peek_input, lex_string, lex_eof, my_lex) +import Darcs.Patch.ReadMonads (ParserM, work, maybeWork, alterInput, + parseStrictly, peekInput, lexString, lexEof, myLex) #include "impossible.h" import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL ) -import Darcs.Witnesses.Ordered ( FL(..) ) +import Darcs.Witnesses.Ordered ( FL(..), unsafeCoerceP ) import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal ) readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString) -readPatch ps = case parse_strictly (readPatch' False) ps of +readPatch ps = case parseStrictly (readPatch' False) ps of Just (Just p, ps') -> Just (p, ps') _ -> Nothing instance ReadPatch p => ReadPatch (Named p) where readPatch' want_eof - = do s <- peek_input - case liftM (BC.unpack . fst) $ my_lex s of + = do s <- peekInput + case liftM (BC.unpack . fst) $ myLex s of Just ('[':_) -> liftM Just $ readNamed want_eof -- ] _ -> return Nothing @@ -64,9 +62,9 @@ readPrim :: ParserM m => FileNameFormat -> m (Maybe (Sealed (Prim C(x )))) readPrim x - = do s <- peek_input - case liftM (BC.unpack . fst) $ my_lex s of - Just "{}" -> do work my_lex + = do s <- peekInput + case liftM (BC.unpack . fst) $ myLex s of + Just "{}" -> do work myLex return $ Just $ seal Identity Just "(" -> liftM Just $ readSplit x -- ) Just "hunk" -> liftM (Just . seal) $ readHunk x @@ -82,69 +80,67 @@ instance ReadPatch Patch where readPatch' want_eof - = do mps <- bracketedFL (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}') + = do mps <- bracketedFL (readPatch' False) (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}') case mps of Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps - Nothing -> do s <- peek_input - case liftM (BC.unpack . fst) $ my_lex s of -#ifndef GADT_WITNESSES + Nothing -> do s <- peekInput + case liftM (BC.unpack . fst) $ myLex s of Just "merger" -> liftM (Just . seal) $ readMerger True Just "regrem" -> liftM (Just . seal) $ readMerger False -#endif _ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof -read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x ))) -read_patches x str want_eof +readPatches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x ))) +readPatches x str want_eof = do mp <- readPrim x case mp of - Nothing -> do unit <- lex_string str + Nothing -> do unit <- lexString str case unit of - () -> if want_eof then do unit' <- lex_eof + () -> if want_eof then do unit' <- lexEof case unit' of () -> return $ seal NilFL else return $ seal NilFL - Just (Sealed p) -> do Sealed ps <- read_patches x str want_eof + Just (Sealed p) -> do Sealed ps <- readPatches x str want_eof return $ seal (p:>:ps) readSplit :: ParserM m => FileNameFormat -> m (Sealed (Prim C(x ))) readSplit x = do - work my_lex - ps <- read_patches x ")" False + work myLex + ps <- readPatches x ")" False return $ Split `mapSeal` ps readFileName :: FileNameFormat -> B.ByteString -> FileName readFileName OldFormat = ps2fn -readFileName NewFormat = fp2fn . decode_white . BC.unpack +readFileName NewFormat = fp2fn . decodeWhite . BC.unpack readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y)) readHunk x = do - work my_lex - fi <- work my_lex + work myLex + fi <- work myLex l <- work readIntPS - have_nl <- skip_newline + have_nl <- skipNewline if have_nl - then do work $ lines_starting_with ' ' -- skipping context - old <- work $ lines_starting_with '-' - new <- work $ lines_starting_with '+' - work $ lines_starting_with ' ' -- skipping context + then do work $ linesStartingWith ' ' -- skipping context + old <- work $ linesStartingWith '-' + new <- work $ linesStartingWith '+' + work $ linesStartingWith ' ' -- skipping context return $ hunk (fn2fp $ readFileName x fi) l old new else return $ hunk (fn2fp $ readFileName x fi) l [] [] -skip_newline :: ParserM m => m Bool -skip_newline = do s <- peek_input +skipNewline :: ParserM m => m Bool +skipNewline = do s <- peekInput if B.null s then return False else if BC.head s /= '\n' then return False - else alter_input B.tail >> return True + else alterInput B.tail >> return True readTok :: ParserM m => FileNameFormat -> m (Prim C(x y)) readTok x = do - work my_lex - f <- work my_lex - regstr <- work my_lex - o <- work my_lex - n <- work my_lex + work myLex + f <- work myLex + regstr <- work myLex + o <- work myLex + n <- work myLex return $ FP (readFileName x f) $ TokReplace (BC.unpack (drop_brackets regstr)) (BC.unpack o) (BC.unpack n) where drop_brackets = B.init . B.tail @@ -163,90 +159,88 @@ -- > ... readBinary :: ParserM m => FileNameFormat -> m (Prim C(x y)) readBinary x = do - work my_lex - fi <- work my_lex - work my_lex - alter_input dropSpace - old <- work $ lines_starting_with '*' - work my_lex - alter_input dropSpace - new <- work $ lines_starting_with '*' + work myLex + fi <- work myLex + work myLex + alterInput dropSpace + old <- work $ linesStartingWith '*' + work myLex + alterInput dropSpace + new <- work $ linesStartingWith '*' return $ binary (fn2fp $ readFileName x fi) (fromHex2PS $ B.concat old) (fromHex2PS $ B.concat new) readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y)) -readAddFile x = do work my_lex - f <- work my_lex +readAddFile x = do work myLex + f <- work myLex return $ FP (readFileName x f) AddFile readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y)) -readRmFile x = do work my_lex - f <- work my_lex +readRmFile x = do work myLex + f <- work myLex return $ FP (readFileName x f) RmFile readMove :: ParserM m => FileNameFormat -> m (Prim C(x y)) -readMove x = do work my_lex - d <- work my_lex - d' <- work my_lex +readMove x = do work myLex + d <- work myLex + d' <- work myLex return $ Move (readFileName x d) (readFileName x d') readChangePref :: ParserM m => m (Prim C(x y)) readChangePref - = do work my_lex - p <- work my_lex + = do work myLex + p <- work myLex f <- work (Just . BC.break ((==)'\n') . B.tail . BC.dropWhile (== ' ')) t <- work (Just . BC.break ((==)'\n') . B.tail) return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t) readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y)) -readAddDir x = do work my_lex - f <- work my_lex +readAddDir x = do work myLex + f <- work myLex return $ DP (readFileName x f) AddDir readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y)) -readRmDir x = do work my_lex - f <- work my_lex +readRmDir x = do work myLex + f <- work myLex return $ DP (readFileName x f) RmDir -#ifndef GADT_WITNESSES readMerger :: ParserM m => Bool -> m (Patch C(x y)) -readMerger b = do work my_lex - g <- work my_lex - lex_string "(" +readMerger b = do work myLex + g <- work myLex + lexString "(" Just (Sealed p1) <- readPatch' False Just (Sealed p2) <- readPatch' False - lex_string ")" - let m = merger (BC.unpack g) p1 p2 - return $ if b then m else invert m -#endif + lexString ")" + Sealed m <- return $ merger (BC.unpack g) p1 p2 + return $ if b then unsafeCoerceP m else unsafeCoerceP (invert m) readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x ))) readNamed want_eof - = do mn <- maybe_work readPatchInfo + = do mn <- maybeWork readPatchInfo case mn of Nothing -> bug "readNamed 1" Just n -> - do d <- read_depends + do d <- readDepends Just p <- readPatch' want_eof return $ (NamedP n d) `mapSeal` p -read_depends :: ParserM m => m [PatchInfo] -read_depends = do s <- peek_input - case my_lex s of +readDepends :: ParserM m => m [PatchInfo] +readDepends = do s <- peekInput + case myLex s of Just (xs, _) | BC.unpack xs == "<" -> - do work my_lex - read_pis + do work myLex + readPis _ -> return [] -read_pis :: ParserM m => m [PatchInfo] -read_pis = do mpi <- maybe_work readPatchInfo +readPis :: ParserM m => m [PatchInfo] +readPis = do mpi <- maybeWork readPatchInfo case mpi of - Just pi -> do pis <- read_pis + Just pi -> do pis <- readPis return (pi:pis) - Nothing -> do alter_input (B.tail . BC.dropWhile (/= '>')) + Nothing -> do alterInput (B.tail . BC.dropWhile (/= '>')) return [] -lines_starting_with :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString) -lines_starting_with c thes = +linesStartingWith :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString) +linesStartingWith c thes = Just (lsw [] thes) where lsw acc s | B.null s || BC.head s /= c = (reverse acc, s) lsw acc s = let s' = B.tail s diff -ruN darcs-2.4.4/src/Darcs/Patch/ReadMonads.hs darcs-2.5/src/Darcs/Patch/ReadMonads.hs --- darcs-2.4.4/src/Darcs/Patch/ReadMonads.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/ReadMonads.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,56 +1,87 @@ - -module Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input, - parse_strictly, parse_lazily, - peek_input, - lex_char, lex_string, lex_strings, lex_eof, - my_lex) where +-- | This module defines our parsing monad. In the past there have been lazy +-- and strict parsers in this module. Currently we have only the strict +-- variant and it is used for parsing patch files. +module Darcs.Patch.ReadMonads (ParserM, work, maybeWork, alterInput, + parseStrictly, + peekInput, + lexChar, lexString, lexStrings, lexEof, + myLex) where import ByteStringUtils ( dropSpace, breakSpace ) import qualified Data.ByteString as B (null, empty, ByteString) import qualified Data.ByteString.Char8 as BC (unpack, pack) -lex_char :: ParserM m => Char -> m () -lex_char c = lex_string [c] - -lex_string :: ParserM m => String -> m () -lex_string str = work - $ \s -> case my_lex s of +-- | 'lexChar' checks if the next space delimited token from +-- the input stream matches a specific 'Char'. +-- Uses 'Maybe' inside 'ParserM' to handle failed matches, so +-- that it always returns () on success. +lexChar :: ParserM m => Char -> m () +lexChar c = lexString [c] + +-- | 'lexString' fetches the next whitespace delimited token from +-- from the input and checks if it matches the 'String' input. +-- Uses 'Maybe' inside 'ParserM' to handle failed matches, so +-- that it always returns () on success. +lexString :: ParserM m => String -> m () +lexString str = work + $ \s -> case myLex s of Just (xs, ys) | xs == BC.pack str -> Just ((), ys) _ -> Nothing -lex_eof :: ParserM m => m () -lex_eof = work +-- | 'lexEof' looks for optional spaces followed by the end of input. +-- Uses 'Maybe' inside 'ParserM' to handle failed matches, so +-- that it always returns () on success. +lexEof :: ParserM m => m () +lexEof = work $ \s -> if B.null (dropSpace s) then Just ((), B.empty) else Nothing -lex_strings :: ParserM m => [String] -> m String -lex_strings str = +-- | Checks if any of the input 'String's match the next +-- space delimited token in the input stream. +-- Uses 'Maybe' inside 'ParserM' to handle failed matches, +-- on success it returns the matching 'String'. +lexStrings :: ParserM m => [String] -> m String +lexStrings str = work $ \s -> - case my_lex s of + case myLex s of Just (xs, ys) | xs' `elem` str -> Just (xs', ys) where xs' = BC.unpack xs _ -> Nothing -my_lex :: B.ByteString -> Maybe (B.ByteString, B.ByteString) -my_lex s = let s' = dropSpace s +-- | 'myLex' drops leading spaces and then breaks the string at the +-- next space. Returns 'Nothing' when the string is empty after +-- dropping leading spaces, otherwise it returns the first sequence +-- of non-spaces and the remainder of the input. +myLex :: B.ByteString -> Maybe (B.ByteString, B.ByteString) +myLex s = let s' = dropSpace s in if B.null s' then Nothing else Just $ breakSpace s' -alter_input :: ParserM m +-- | Applies a function to the input stream and discards the +-- result of the function. +alterInput :: ParserM m => (B.ByteString -> B.ByteString) -> m () -alter_input f = work (\s -> Just ((), f s)) +alterInput f = work (\s -> Just ((), f s)) class Monad m => ParserM m where + -- | Applies a parsing function inside the 'ParserM' monad. work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m a - maybe_work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m (Maybe a) - peek_input :: m B.ByteString + -- | Applies a parsing function, that can return 'Nothing', + -- inside the 'ParserM' monad. + maybeWork :: (B.ByteString -> Maybe (a, B.ByteString)) -> m (Maybe a) + -- | Allows for the inspection of the input that is yet to be parsed. + peekInput :: m B.ByteString ----- Strict Monad ----- -parse_strictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString) -parse_strictly (SM f) s = f s +-- | 'parseStrictly' applies the parser functions to a string +-- and checks that each parser produced a result as it goes. +-- The strictness is in the 'ParserM' instance for 'SM'. +parseStrictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString) +parseStrictly (SM f) s = f s +-- | 'SM' is the Strict Monad for parsing. newtype SM a = SM (B.ByteString -> Maybe (a, B.ByteString)) instance Monad SM where SM m >>= k = SM $ \s -> case m s of @@ -63,29 +94,7 @@ instance ParserM SM where work f = SM f - maybe_work f = SM $ \s -> case f s of + maybeWork f = SM $ \s -> case f s of Just (x, s') -> Just (Just x, s') Nothing -> Just (Nothing, s) - peek_input = SM $ \s -> Just (s, s) - ------ Lazy Monad ----- -parse_lazily :: LM a -> B.ByteString -> (a, B.ByteString) -parse_lazily (LM f) s = f s - -newtype LM a = LM (B.ByteString -> (a, B.ByteString)) -instance Monad LM where - LM m >>= k = LM $ \s -> let (x, s') = m s - LM y = k x - in y s' - return x = LM (\s -> (x,s)) - fail s = error s - -instance ParserM LM where - work f = LM $ \s -> case f s of - Nothing -> error "parser error" - Just x -> x - maybe_work f = LM $ \s -> case f s of - Nothing -> (Nothing, s) - Just (x, s') -> (Just x, s') - peek_input = LM $ \s -> (s, s) - + peekInput = SM $ \s -> Just (s, s) diff -ruN darcs-2.4.4/src/Darcs/Patch/Real.hs darcs-2.5/src/Darcs/Patch/Real.hs --- darcs-2.4.4/src/Darcs/Patch/Real.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Real.hs 2010-10-24 08:29:26.000000000 -0700 @@ -23,13 +23,13 @@ -- | Conflictor patches module Darcs.Patch.Real - ( RealPatch(..), prim2real, is_consistent, is_forward, is_duplicate, + ( RealPatch(..), prim2real, isConsistent, isForward, isDuplicate, pullCommon, mergeUnravelled ) where import Control.Monad ( mplus, liftM ) import Data.List ( partition, nub ) import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Conflict(..), Effect(..), - showPrim, FileNameFormat(NewFormat), + showPrim, showPrimFL, FileNameFormat(NewFormat), IsConflictedPrim(..), ConflictState(..) ) import Darcs.Patch.Read ( readPrim ) import Darcs.Patch.Patchy @@ -37,16 +37,16 @@ --import Darcs.Patch.Read () --import Darcs.Patch.Viewing () --import Darcs.Patch.Apply () -import Darcs.Patch.Commute ( mangle_unravelled ) +import Darcs.Patch.Commute ( mangleUnravelled ) import Darcs.Patch.Non ( Non(..), Nonable(..), unNon, showNons, showNon, readNons, readNon, add, addP, addPs, remP, remPs, remNons, (*>), (>*), (*>>), (>>*) ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL, genCommuteWhatWeCanRL, - removeRL, removeFL, remove_subsequenceFL ) + removeRL, removeFL, removeSubsequenceFL ) import qualified Data.ByteString.Char8 as BC ( ByteString, unpack ) -import Darcs.Patch.ReadMonads ( work, peek_input, my_lex ) +import Darcs.Patch.ReadMonads ( work, peekInput, myLex ) import Darcs.Utils ( nubsort ) import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal ) import Darcs.Witnesses.Show @@ -85,19 +85,19 @@ Conflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(y x) InvConflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(x y) --- | 'is_duplicate' @p@ is ' @True@ if @p@ is either a 'Duplicate' or 'Etacilpud' patch -is_duplicate :: RealPatch C(s y) -> Bool -is_duplicate (Duplicate _) = True -is_duplicate (Etacilpud _) = True -is_duplicate _ = False +-- | 'isDuplicate' @p@ is ' @True@ if @p@ is either a 'Duplicate' or 'Etacilpud' patch +isDuplicate :: RealPatch C(s y) -> Bool +isDuplicate (Duplicate _) = True +isDuplicate (Etacilpud _) = True +isDuplicate _ = False -- | This is only used for unit testing -is_forward :: RealPatch C(s y) -> Maybe Doc -is_forward p@(InvConflictor _ _ _) = +isForward :: RealPatch C(s y) -> Maybe Doc +isForward p@(InvConflictor _ _ _) = Just $ redText "An inverse conflictor" $$ showPatch p -is_forward p@(Etacilpud _) = +isForward p@(Etacilpud _) = Just $ redText "An inverse duplicate" $$ showPatch p -is_forward _ = Nothing +isForward _ = Nothing mergeUnravelled :: [Sealed ((FL Prim) C(x))] -> Maybe (FlippedSeal RealPatch C(x)) mergeUnravelled [] = Nothing @@ -124,7 +124,7 @@ mergeConflictingNons ns = mcn $ map unNon ns where mcn :: [Sealed (FL RealPatch C(x))] -> Maybe (FL RealPatch C(x x)) mcn [] = Just NilFL - mcn [Sealed p] = case join_effects p of -- this is just a safety check, and could + mcn [Sealed p] = case joinEffects p of -- this is just a safety check, and could NilFL -> Just p -- be removed when we're sure of the code. _ -> Nothing mcn (Sealed p1:Sealed p2:zs) = case pullCommon p1 p2 of @@ -132,17 +132,17 @@ case merge (ps :\/: qs) of qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs) -join_effects :: Effect p => p C(x y) -> FL Prim C(x y) -join_effects = join_inverses . effect - where join_inverses :: FL Prim C(x y) -> FL Prim C(x y) - join_inverses NilFL = NilFL - join_inverses (p:>:ps) = case removeFL (invert p) ps' of +joinEffects :: Effect p => p C(x y) -> FL Prim C(x y) +joinEffects = joinInverses . effect + where joinInverses :: FL Prim C(x y) -> FL Prim C(x y) + joinInverses NilFL = NilFL + joinInverses (p:>:ps) = case removeFL (invert p) ps' of Just ps'' -> ps'' Nothing -> p :>: ps' - where ps' = join_inverses ps + where ps' = joinInverses ps assertConsistent :: RealPatch C(x y) -> RealPatch C(x y) -assertConsistent x = assertDoc (do e <- is_consistent x +assertConsistent x = assertDoc (do e <- isConsistent x Just (redText "Inconsistent patch:" $$ showPatch x $$ e)) x -- | @mergeAfterConflicting@ takes as input a sequence of conflicting @@ -168,7 +168,7 @@ mac (reverseFL xxx) yyy NilFL where mac :: RL RealPatch C(x y) -> FL Prim C(y z) -> FL RealPatch C(z a) -> Maybe (FL RealPatch C(x x), FL RealPatch C(x a)) - mac NilRL xs goneby = case join_effects goneby of + mac NilRL xs goneby = case joinEffects goneby of NilFL -> Just (NilFL, mapFL_FL Normal xs) _z -> --traceDoc (greenText "mac1 z" $$ showPatch _z) $ Nothing @@ -176,27 +176,27 @@ -- greenText "p" $$ showPatch p $$ -- greenText "xs" $$ showPatch xs $$ -- greenText "goneby" $$ showPatch goneby) $ - case commuteFL (p :> mapFL_FL Normal xs) of - Left _ -> case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of + case commuteFLorComplain (p :> mapFL_FL Normal xs) of + Left _ -> case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of a:>p':>b -> do (b',xs') <- mac b xs goneby - let pa = join_effects $ p':<:a + let pa = joinEffects $ p':<:a --traceDoc (greenText "foo1" $$ -- showPatch pa) $ Just () NilFL <- return pa return (reverseRL (p':<:a)+>+b', xs') `mplus` do NilFL <- return goneby - NilFL <- return $ join_effects (p:<:ps) + NilFL <- return $ joinEffects (p:<:ps) return (reverseRL (p:<:ps), mapFL_FL Normal xs) Right (l:>p'') -> case allNormal l of Just xs'' -> mac ps xs'' (p'':>:goneby) Nothing -> - case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of + case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of a:>p':>b -> do (b',xs') <- mac b xs goneby - let pa = join_effects $ p':<:a + let pa = joinEffects $ p':<:a --traceDoc (greenText "foo2" $$ -- showPatch pa) $ Just () NilFL <- return pa @@ -235,53 +235,49 @@ allNormal _ = Nothing -- | This is used for unit-testing and for internal sanity checks -is_consistent :: RealPatch C(x y) -> Maybe Doc -is_consistent (Normal _) = Nothing -is_consistent (Duplicate _) = Nothing -is_consistent (Etacilpud _) = Nothing -is_consistent (Conflictor im mm m@(Non deps _)) - | not $ everyone_conflicts im = Just $ redText "Someone doesn't conflict in im in is_consistent" - | Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in is_consistent" - | any (\x -> any (x `conflicts_with`) nmm) im - = Just $ redText "mm conflicts with im in is_consistent where nmm is" $$ +isConsistent :: RealPatch C(x y) -> Maybe Doc +isConsistent (Normal _) = Nothing +isConsistent (Duplicate _) = Nothing +isConsistent (Etacilpud _) = Nothing +isConsistent (Conflictor im mm m@(Non deps _)) + | not $ everyoneConflicts im = Just $ redText "Someone doesn't conflict in im in isConsistent" + | Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in isConsistent" + | any (\x -> any (x `conflictsWith`) nmm) im + = Just $ redText "mm conflicts with im in isConsistent where nmm is" $$ showNons nmm | Nothing <- (nmm ++ im) `minus` toNons deps = Just $ redText "dependencies not in conflict:" $$ showNons (toNons deps) $$ redText "compared with deps itself:" $$ showPatch deps - | otherwise = case all_conflicts_with m im of + | otherwise = case allConflictsWith m im of (im1,[]) | im1 `eqSet` im -> Nothing - (_,imnc) -> Just $ redText "m doesn't conflict with im in is_consistent. unconflicting:" + (_,imnc) -> Just $ redText "m doesn't conflict with im in isConsistent. unconflicting:" $$ showNons imnc where (nmm, rmm) = geteff im mm -is_consistent c@(InvConflictor _ _ _) = is_consistent (invert c) +isConsistent c@(InvConflictor _ _ _) = isConsistent (invert c) -everyone_conflicts :: [Non RealPatch C(x)] -> Bool -everyone_conflicts [] = True -everyone_conflicts (x:xs) = case all_conflicts_with x xs of +everyoneConflicts :: [Non RealPatch C(x)] -> Bool +everyoneConflicts [] = True +everyoneConflicts (x:xs) = case allConflictsWith x xs of ([],_) -> False - (_,xs') -> everyone_conflicts xs' + (_,xs') -> everyoneConflicts xs' prim2real :: Prim C(x y) -> RealPatch C(x y) prim2real = Normal instance Patchy RealPatch -instance MyEq p => Eq (Sealed (p C(x))) where - (Sealed x) == (Sealed y) | IsEq <- x =\/= y = True - | otherwise = False - -merge_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> Sealed (FL Prim C(x)) -merge_with p [] = effect `mapSeal` unNon p -merge_with p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $ - filter (\x -> not (p `depends_upon` x) && not (p `conflicts_with` x)) xs +mergeWith :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> Sealed (FL Prim C(x)) +mergeWith p [] = effect `mapSeal` unNon p +mergeWith p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $ + filter (\x -> not (p `dependsUpon` x) && not (p `conflictsWith` x)) xs where mergeall :: [Sealed (FL RealPatch C(x))] -> Sealed (FL Prim C(x)) mergeall [Sealed x] = Sealed $ effect x mergeall [] = Sealed NilFL mergeall (Sealed x:Sealed y:rest) = case merge (x :\/: y) of y' :/\: _ -> mergeall (Sealed (x+>+y'):rest) unconflicting_of [] = [] - unconflicting_of (q:qs) = case all_conflicts_with q qs of + unconflicting_of (q:qs) = case allConflictsWith q qs of ([],_) -> q:qs (_,nc) -> unconflicting_of nc @@ -291,8 +287,8 @@ conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x] conflictedEffect (InvConflictor _ _ _) = impossible conflictedEffect (Normal x) = [IsC Okay x] - resolveConflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled] - where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx) + resolveConflicts (Conflictor ix xx x) = [mangleUnravelled unravelled : unravelled] + where unravelled = nub $ filter isn $ map (`mergeWith` (x:ix++nonxx)) (x:ix++nonxx) nonxx = nonxx_ (nonxx_aux ix xx) nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y) nonxx_aux a b = reverseFL $ xx2patches a b @@ -306,65 +302,66 @@ resolveConflicts _ = [] -- cA - commute_no_conflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x) - commute_no_conflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x) - commute_no_conflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x) - commute_no_conflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x) + commuteNoConflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x) + commuteNoConflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x) + commuteNoConflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x) + commuteNoConflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x) -- cB - commute_no_conflicts (x :> Duplicate d) = if d == addP (invert x) (non x) + commuteNoConflicts (x :> Duplicate d) = if d == addP (invert x) (non x) then Just (x :> Duplicate d) else do d' <- remP (invert x) d return (Duplicate d' :> x) - commute_no_conflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d')) - commute_no_conflicts c@(Etacilpud _ :> _) = invertCommuteNC c - commute_no_conflicts c@(_ :> Etacilpud _) = invertCommuteNC c + commuteNoConflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d')) + commuteNoConflicts c@(Etacilpud _ :> _) = invertCommuteNC c + commuteNoConflicts c@(_ :> Etacilpud _) = invertCommuteNC c -- cE - commute_no_conflicts (Normal x :> Normal y) = do y' :> x' <- commute (x :> y) + commuteNoConflicts (Normal x :> Normal y) = do y' :> x' <- commute (x :> y) return (Normal y' :> Normal x') -- cF -- involves a conflict -- cG - commute_no_conflicts (Normal x :> Conflictor iy yy y) = - case commuteFL (x :> invert yy) of + commuteNoConflicts (Normal x :> Conflictor iy yy y) = + case commuteFLorComplain (x :> invert yy) of Right (iyy' :> x') -> do y':iy' <- mapM (Normal x' >*) (y:iy) return (Conflictor iy' (invert iyy') y' :> Normal x') _ -> Nothing -- cFi+cGi -- handle with previous two pattern matches - commute_no_conflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c + commuteNoConflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c -- icG FIXME: where is icF? - commute_no_conflicts (Conflictor iy' yy' y' :> Normal x') = + commuteNoConflicts (Conflictor iy' yy' y' :> Normal x') = do x :> iyy <- commuteRL (invertFL yy' :> x') y:iy <- mapM (*> Normal x') (y':iy') return (Normal x :> Conflictor iy (invertRL iyy) y) -- icGi -- handle with previous pattern match - commute_no_conflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c + commuteNoConflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c -- cH -- this involves a conflict commute -- cI - commute_no_conflicts (Conflictor ix xx x :> Conflictor iy yy y) = + commuteNoConflicts (Conflictor ix xx x :> Conflictor iy yy y) = do xx' :> yy' <- commute (yy :> xx) x':ix' <- mapM (yy >>*) (x:ix) y':iy' <- mapM (*>> xx') (y:iy) - False <- return $ any (conflicts_with y) (x':ix') - False <- return $ any (conflicts_with x') iy + False <- return $ any (conflictsWith y) (x':ix') + False <- return $ any (conflictsWith x') iy return (Conflictor iy' yy' y' :> Conflictor ix' xx' x') -- cHi+cIi uses previous two matches - commute_no_conflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c + commuteNoConflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c -- cJ - commute_no_conflicts (InvConflictor ix xx x :> Conflictor iy yy y) = + commuteNoConflicts (InvConflictor ix xx x :> Conflictor iy yy y) = do iyy' :> xx' <- commute (xx :> invert yy) y':iy' <- mapM (xx' >>*) (y:iy) x':ix' <- mapM (invertFL iyy' >>*) (x:ix) - False <- return $ any (conflicts_with y') (x':ix') - False <- return $ any (conflicts_with x') iy' + False <- return $ any (conflictsWith y') (x':ix') + False <- return $ any (conflictsWith x') iy' return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x') -- icJ - commute_no_conflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') = + commuteNoConflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') = do xx :> iyy <- commute (invert yy' :> xx') y:iy <- mapM (*>> xx') (y':iy') x:ix <- mapM (*>> yy') (x':ix') - False <- return $ any (conflicts_with y') (x':ix') - False <- return $ any (conflicts_with x') iy' + False <- return $ any (conflictsWith y') (x':ix') + False <- return $ any (conflictsWith x') iy' return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y) + isInconsistent = isConsistent instance FromPrim RealPatch where fromPrim = prim2real @@ -468,14 +465,14 @@ instance Commute RealPatch where -- commute (x :> y) | traceDoc (greenText "commuting x" $$ showPatch x $$ -- greenText "with y" $$ showPatch y) False = undefined - commute (x :> y) | Just (y' :> x') <- commute_no_conflicts (assertConsistent x :> assertConsistent y) = Just (y' :> x') + commute (x :> y) | Just (y' :> x') <- commuteNoConflicts (assertConsistent x :> assertConsistent y) = Just (y' :> x') -- cF commute (Normal x :> Conflictor a1'nop2 n1'x p1') -- these patches conflicted | Just rn1' <- removeRL x (reverseFL n1'x) = do let p2:n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (x:<:rn1') a2 = p1':a1'nop2++n1nons case (a1'nop2, reverseRL rn1', p1') of - ([], NilFL, Non c y) | NilFL <- join_effects c -> + ([], NilFL, Non c y) | NilFL <- joinEffects c -> Just (Normal y :> Conflictor a1'nop2 (y:>:NilFL) p2) (a1,n1,_) -> Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2) -- cFi -- handle with previous pattern match @@ -483,7 +480,7 @@ -- cH commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2) | Just a2_minus_p1 <- remove1 p1' a2, - not (p2 `depends_upon` p1') = + not (p2 `dependsUpon` p1') = do let n1nons = map (add n2) $ xx2nons a1 n1 n2nons = xx2nons a2 n2 Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons @@ -501,7 +498,7 @@ -- showPatch (assertConsistent $ Conflictor a2 n2 p2) $$ -- greenText "where n2'nons is" $$ showNons n2'nons $$ -- greenText "and others are" $$ - -- showNons (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) $$ + -- showNons (fst $ allConflictsWith p2 $ a2_minus_p1++n2nons) $$ -- greenText "These came from" $$ -- showNons (a2_minus_p1++n2nons) $$ -- greenText "n1'n2'nons" $$ showNons n1'n2'nons $$ @@ -511,14 +508,14 @@ -- greenText "p2 fixed" $$ showNon p2ooo $$ -- -- greenText "pren1" $$ showPatch pren1 $$ -- greenText "n1'" $$ showPatch n1' $$ - -- greenText "p2" $$ showNon p2 - -- ) - (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) `minus` n2'nons + -- greenText "p2" $$ showNon p2 + -- ) + (fst $ allConflictsWith p2 $ a2_minus_p1++n2nons) `minus` n2'nons Just a2' = mapM (remPs (xx2patches a1'nop2 n1')) $ a2'o Just p2' = remPs (xx2patches a1'nop2 n1') p2 case (a2', n2', p2') of - ([], NilFL, Non c x) | NilFL <- join_effects c -> + ([], NilFL, Non c x) | NilFL <- joinEffects c -> Just (Normal x :> Conflictor a1'nop2 (n1'+>+x:>:NilFL) p1') | otherwise -> impossible _ -> Just (Conflictor a2' n2' p2' :> Conflictor (p2:a1'nop2) n1' p1') @@ -610,42 +607,42 @@ hunkMatches f (InvConflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p] {- -all_conflicts_withFL :: FL Prim C(x y) -> [Non RealPatch C(x)] +allConflictsWithFL :: FL Prim C(x y) -> [Non RealPatch C(x)] -> ([Non RealPatch C(x)], [Non RealPatch C(x)]) -all_conflicts_withFL xx ns = case partition f ns of +allConflictsWithFL xx ns = case partition f ns of ([],nc) -> ([],nc) (c,nc) -> case acw c nc of (c',nc') -> (c++c',nc') - where acw (y:ys) zs = case all_conflicts_with y zs of + where acw (y:ys) zs = case allConflictsWith y zs of (c,nc) -> case acw ys nc of (c',nc') -> (c++c',nc') acw [] zs = ([],zs) f (Non c p) = case commuteRLFL (invertFL c :> mapFL_FL Normal xx) of Nothing -> True - Just (xx' :> _) -> case commuteFL (Normal (invert p) :> xx') of + Just (xx' :> _) -> case commuteFLorComplain (Normal (invert p) :> xx') of Nothing -> True Just _ -> False -} -all_conflicts_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] +allConflictsWith :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> ([Non RealPatch C(x)], [Non RealPatch C(x)]) -all_conflicts_with x ys = acw $ partition (conflicts_with x) ys +allConflictsWith x ys = acw $ partition (conflictsWith x) ys where acw ([],nc) = ([],nc) - acw (c:cs, nc) = case all_conflicts_with c nc of + acw (c:cs, nc) = case allConflictsWith c nc of (c1,nc1) -> case acw (cs, nc1) of (xs',nc') -> (c:c1++xs',nc') -conflicts_with :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool -conflicts_with x y | x `depends_upon` y || y `depends_upon` x = False -conflicts_with x (Non cy y) = +conflictsWith :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool +conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False +conflictsWith x (Non cy y) = case remPs cy x of - Just (Non cx' x') -> case commuteFL (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of + Just (Non cx' x') -> case commuteFLorComplain (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of Right _ -> False Left _ -> True Nothing -> True -depends_upon :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool -depends_upon (Non xs _) (Non ys y) = - case remove_subsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of +dependsUpon :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool +dependsUpon (Non xs _) (Non ys y) = + case removeSubsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of Just _ -> True Nothing -> False @@ -663,7 +660,7 @@ return (invert iy' :> invert ix') invertCommuteNC :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y)) -invertCommuteNC (x :> y) = do ix' :> iy' <- commute_no_conflicts (invert y :> invert x) +invertCommuteNC (x :> y) = do ix' :> iy' <- commuteNoConflicts (invert y :> invert x) return (invert iy' :> invert ix') -- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted @@ -713,14 +710,14 @@ blueText "conflictor" <+> showNons i <+> blueText "[]" $$ showNon p showPatch (Conflictor i cs p) = blueText "conflictor" <+> showNons i <+> blueText "[" $$ - showPatch cs $$ + showPrimFL NewFormat cs $$ blueText "]" $$ showNon p showPatch (InvConflictor i NilFL p) = blueText "rotcilfnoc" <+> showNons i <+> blueText "[]" $$ showNon p showPatch (InvConflictor i cs p) = blueText "rotcilfnoc" <+> showNons i <+> blueText "[" $$ - showPatch cs $$ + showPrimFL NewFormat cs $$ blueText "]" $$ showNon p showContextPatch (Normal p) = showContextPatch p @@ -728,29 +725,29 @@ instance ReadPatch RealPatch where readPatch' _ = - do s <- peek_input - case fmap (BC.unpack . fst) $ my_lex s of + do s <- peekInput + case fmap (BC.unpack . fst) $ myLex s of Just "duplicate" -> - do work my_lex + do work myLex p <- readNon return $ (Sealed . Duplicate) `fmap` p Just "etacilpud" -> - do work my_lex + do work myLex p <- readNon return $ (Sealed . Etacilpud) `fmap` p Just "conflictor" -> - do work my_lex - --let tracePeek x = do y <- peek_input + do work myLex + --let tracePeek x = do y <- peekInput -- traceDoc (greenText x $$ greenText (show $ BC.unpack y)) return () i <- readNons - Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') + Just (Sealed ps) <- bracketedFL (readPrim NewFormat) (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') Just p <- readNon return $ Just $ Sealed $ Conflictor i (unsafeCoerceP ps) p Just "rotcilfnoc" -> - do work my_lex + do work myLex i <- readNons - Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') + Just (Sealed ps) <- bracketedFL (readPrim NewFormat) (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') Just p <- readNon return $ Just $ Sealed $ InvConflictor i ps p _ -> do mp <- readPrim NewFormat @@ -762,7 +759,7 @@ show p = renderString $ showPatch p instance Show2 RealPatch where - show2 = show + showDict2 = ShowDictClass instance Nonable RealPatch where non (Duplicate d) = d diff -ruN darcs-2.4.4/src/Darcs/Patch/RegChars.hs darcs-2.5/src/Darcs/Patch/RegChars.hs --- darcs-2.4.4/src/Darcs/Patch/RegChars.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/RegChars.hs 2010-10-24 08:29:26.000000000 -0700 @@ -33,7 +33,7 @@ -- it can also be specified as a complement set by prefixing with '^' -- (caret). The dash and caret, as well as the backslash, can all be -- escaped with a backslash to suppress their special meaning. --- +-- -- NOTE: The '.' (dot) is allowed to be escaped. It has no special meaning -- if it is not escaped, but the default 'filename_toks' in -- Darcs.Commands.Replace uses an escaped dot (WHY?). diff -ruN darcs-2.4.4/src/Darcs/Patch/Set.hs darcs-2.5/src/Darcs/Patch/Set.hs --- darcs-2.4.4/src/Darcs/Patch/Set.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Set.hs 2010-10-24 08:29:26.000000000 -0700 @@ -16,35 +16,47 @@ -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, EmptyDataDecls #-} #include "gadts.h" -module Darcs.Patch.Set ( PatchSet, SealedPatchSet ) where - -import Darcs.Hopefully ( PatchInfoAnd ) -import Darcs.Witnesses.Ordered ( RL ) +module Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin, + progressPatchSet, tags, + newset2RL, newset2FL ) where + +import Progress ( progress ) +import Darcs.Patch.Info ( PatchInfo ) +import Darcs.Hopefully ( PatchInfoAnd, info ) +import Darcs.Witnesses.Ordered ( FL, RL(..), (+<+), + reverseRL, mapRL_RL, concatRL, mapRL ) import Darcs.Witnesses.Sealed ( Sealed ) --- | A PatchSet is in reverse order, plus has information about which --- tags are clean, meaning all patches applied prior to them are in --- the tag itself, so we can stop reading at that point. Just to --- clarify, the first patch in a PatchSet is the one most recently --- applied to the repo. --- --- 'PatchSet's have the property that if --- @ --- (info $ last $ head a) == (info $ last $ head b) --- @ --- then @(tail a)@ and @(tail b)@ are identical repositories --- --- Questions: --- --- Does this mean that in a patch set such as @[[a b t1 c d e t2][f g --- t3] [h i]]@, t1, t2 and t3 are tags, and t2 and t3 are clean? --- --- Can we have PatchSet with length at least 3? --- Florent -type PatchSet p C(x) = RL (RL (PatchInfoAnd p)) C(() x) +data Origin + +type SealedPatchSet p C(start) = Sealed ((PatchSet p) C(start)) + +data PatchSet p C(start x) where + PatchSet :: RL (PatchInfoAnd p) C(y x) -> RL (Tagged p) C(start y) -> PatchSet p C(start x) -type SealedPatchSet p = Sealed (RL (RL (PatchInfoAnd p)) C(())) +data Tagged p C(x2 z) where + Tagged :: PatchInfoAnd p C(y z) -> Maybe String + -> RL (PatchInfoAnd p) C(x3 y) -> Tagged p C(x3 z) + +newset2RL :: PatchSet p C(start x4) -> RL (PatchInfoAnd p) C(start x4) +newset2RL (PatchSet ps ts) = ps +<+ concatRL (mapRL_RL ts2rl ts) + where ts2rl :: Tagged p C(x5 y) -> RL (PatchInfoAnd p) C(x5 y) + ts2rl (Tagged t _ ps2) = t :<: ps2 + +newset2FL :: PatchSet p C(start x6) -> FL (PatchInfoAnd p) C(start x6) +newset2FL = reverseRL . newset2RL + +progressPatchSet :: String -> PatchSet p C(start x7) -> PatchSet p C(start x7) +progressPatchSet k (PatchSet ps0 ts0) = PatchSet (mapRL_RL prog ps0) $ mapRL_RL pts ts0 + where prog = progress k + pts :: Tagged p C(x8 y) -> Tagged p C(x8 y) + pts (Tagged t h ps) = Tagged (prog t) h (mapRL_RL prog ps) + +tags :: PatchSet p C(start x13) -> [PatchInfo] +tags (PatchSet _ ts) = mapRL f ts + where f :: Tagged p C(x14 y) -> PatchInfo + f (Tagged t _ _) = info t diff -ruN darcs-2.4.4/src/Darcs/Patch/Show.lhs darcs-2.5/src/Darcs/Patch/Show.lhs --- darcs-2.4.4/src/Darcs/Patch/Show.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Show.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -32,6 +32,7 @@ import Darcs.Patch.Prim ( showPrim, FileNameFormat(..) ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo ) import Darcs.Witnesses.Ordered ( FL(NilFL), mapFL ) +import Darcs.Witnesses.Show ( Show2(..), ShowDict(..) ) #include "gadts.h" \end{code} @@ -44,6 +45,8 @@ \begin{code} instance Show (Patch C(x y)) where show p = renderString (showPatch_ p) ++ "\n" +instance Show2 Patch where + showDict2 = ShowDictClass showPatch_ :: Patch C(a b) -> Doc showPatch_ (PP p) = showPrim OldFormat p diff -ruN darcs-2.4.4/src/Darcs/Patch/Split.hs darcs-2.5/src/Darcs/Patch/Split.hs --- darcs-2.4.4/src/Darcs/Patch/Split.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Split.hs 2010-10-24 08:29:26.000000000 -0700 @@ -31,7 +31,7 @@ import Darcs.Patch.Patchy ( ReadPatch(..), ShowPatch(..), Invert(..) ) import Darcs.Patch.Prim ( Prim(..), FilePatchType(..), canonize, canonizeFL ) -import Darcs.Patch.ReadMonads ( parse_strictly ) +import Darcs.Patch.ReadMonads ( parseStrictly ) import Darcs.Patch.Read () import Darcs.Patch.Viewing () @@ -94,7 +94,7 @@ rawSplitter = Splitter { applySplitter = \p -> Just (renderPS . showPatch $ p, - \str -> case parse_strictly (readPatch' False) str of + \str -> case parseStrictly (readPatch' False) str of Just (Just (Sealed res), _) -> Just (withEditedHead p res) _ -> Nothing ) diff -ruN darcs-2.4.4/src/Darcs/Patch/TouchesFiles.hs darcs-2.5/src/Darcs/Patch/TouchesFiles.hs --- darcs-2.4.4/src/Darcs/Patch/TouchesFiles.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/TouchesFiles.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,9 +20,9 @@ #include "gadts.h" -module Darcs.Patch.TouchesFiles ( look_touch, choose_touching, - select_touching, - deselect_not_touching, select_not_touching, +module Darcs.Patch.TouchesFiles ( lookTouch, chooseTouching, choosePreTouching, + selectTouching, + deselectNotTouching, selectNotTouching, ) where import Data.List ( sort, isSuffixOf ) @@ -30,38 +30,38 @@ patchChoices, tag, getChoices, forceFirsts, forceLasts, tpPatch, ) -import Darcs.Patch ( Patchy, applyToFilepaths, listTouchedFiles ) +import Darcs.Patch ( Patchy, applyToFilepaths, listTouchedFiles, invert ) import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) ) import Darcs.Witnesses.Sealed ( Sealed, seal ) -select_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) -select_touching [] pc = pc -select_touching files pc = forceFirsts xs pc +selectTouching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +selectTouching [] pc = pc +selectTouching files pc = forceFirsts xs pc where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] ct _ NilFL = [] - ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of + ct fs (tp:>:tps) = case lookTouch fs (tpPatch tp) of (True, fs') -> tag tp:ct fs' tps (False, fs') -> ct fs' tps xs = case getChoices pc of _ :> mc :> lc -> ct (map fix files) (mc +>+ lc) -deselect_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) -deselect_not_touching [] pc = pc -deselect_not_touching files pc = forceLasts xs pc +deselectNotTouching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +deselectNotTouching [] pc = pc +deselectNotTouching files pc = forceLasts xs pc where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] ct _ NilFL = [] - ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of + ct fs (tp:>:tps) = case lookTouch fs (tpPatch tp) of (True, fs') -> ct fs' tps (False, fs') -> tag tp:ct fs' tps xs = case getChoices pc of fc :> mc :> _ -> ct (map fix files) (fc +>+ mc) -select_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) -select_not_touching [] pc = pc -select_not_touching files pc = forceFirsts xs pc +selectNotTouching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +selectNotTouching [] pc = pc +selectNotTouching files pc = forceFirsts xs pc where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] ct _ NilFL = [] - ct fs (tp:>:tps) = case look_touch fs (tpPatch tp) of + ct fs (tp:>:tps) = case lookTouch fs (tpPatch tp) of (True, fs') -> ct fs' tps (False, fs') -> tag tp:ct fs' tps xs = case getChoices pc of @@ -73,13 +73,21 @@ fix "." = "." fix f = "./" ++ f -choose_touching :: Patchy p => [FilePath] -> FL p C(x y) -> Sealed (FL p C(x)) -choose_touching [] p = seal p -choose_touching files p = case getChoices $ select_touching files $ patchChoices p of +chooseTouching :: Patchy p => [FilePath] -> FL p C(x y) -> Sealed (FL p C(x)) +chooseTouching [] p = seal p +chooseTouching files p = case getChoices $ selectTouching files $ patchChoices p of fc :> _ :> _ -> seal $ mapFL_FL tpPatch fc -look_touch :: Patchy p => [FilePath] -> p C(x y) -> (Bool, [FilePath]) -look_touch fs p = (any (\tf -> any (affects tf) fs) (listTouchedFiles p) +choosePreTouching :: (Patchy p) => [FilePath] -> FL p C(x y) -> Sealed (FL p C(x)) +choosePreTouching files patch = do + let pre_files = applyToFilepaths (invert patch) files + relevant = case files of + [] -> seal patch + _ -> chooseTouching pre_files patch + in relevant + +lookTouch :: Patchy p => [FilePath] -> p C(x y) -> (Bool, [FilePath]) +lookTouch fs p = (any (\tf -> any (affects tf) fs) (listTouchedFiles p) || fs' /= fs, fs') where affects :: FilePath -> FilePath -> Bool affects touched f = touched == f diff -ruN darcs-2.4.4/src/Darcs/Patch/Viewing.hs darcs-2.5/src/Darcs/Patch/Viewing.hs --- darcs-2.4.4/src/Darcs/Patch/Viewing.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch/Viewing.hs 2010-10-24 08:29:26.000000000 -0700 @@ -44,7 +44,7 @@ DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Patchy ( Patchy, Apply, ShowPatch(..), identity ) import Darcs.Patch.Show ( showPatch_, showNamedPrefix ) -import Darcs.Patch.Info ( showPatchInfo, human_friendly ) +import Darcs.Patch.Info ( showPatchInfo, humanFriendly ) import Darcs.Patch.Apply ( applyToTree ) #include "impossible.h" #include "gadts.h" @@ -267,7 +267,7 @@ showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p showContextPatch (NamedP n [] p) = showContextPatch p >>= return . (showPatchInfo n <>) showContextPatch (NamedP n d p) = showContextPatch p >>= return . (showNamedPrefix n d <+>) - description (NamedP n _ _) = human_friendly n + description (NamedP n _ _) = humanFriendly n summary p = description p $$ text "" $$ prefix " " (plainSummary p) -- this isn't summary because summary does the -- wrong thing with (Named (FL p)) so that it can diff -ruN darcs-2.4.4/src/Darcs/Patch.lhs darcs-2.5/src/Darcs/Patch.lhs --- darcs-2.4.4/src/Darcs/Patch.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Patch.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -54,24 +54,20 @@ infopatch, changepref, thing, things, isSimilar, primIsAddfile, primIsHunk, primIsSetpref, -#ifndef GADT_WITNESSES - merger, isMerger, merge, + isMerger, merge, commute, listTouchedFiles, hunkMatches, -- for PatchTest - unravel, elegantMerge, -#else - Commute(..), -#endif + elegantMerge, resolveConflicts, Effect, effect, primIsBinary, gzWritePatch, writePatch, primIsAdddir, invert, invertFL, invertRL, identity, - commuteFL, commuteRL, + commuteFLorComplain, commuteRL, readPatch, canonize, sortCoalesceFL, tryToShrink, - applyToSlurpy, patchname, patchcontents, - applyToFilepaths, forceReplaceSlurpy, apply, + patchname, patchcontents, + applyToFilepaths, apply, applyToTree, patch2patchinfo, LineMark(AddedLine, RemovedLine, AddedRemovedLine, None), @@ -79,7 +75,7 @@ summary, plainSummary, xmlSummary, adddeps, getdeps, listConflictedFiles, - modernizePatch, + modernizePatch, isInconsistent, -- for Population DirMark(..), patchChanges, applyToPop, ) where @@ -88,9 +84,7 @@ flattenFL, adddeps, namepatch, anonymous, -#ifndef GADT_WITNESSES isMerger, -#endif getdeps, isNullPatch, nullP, infopatch, patch2patchinfo, patchname, patchcontents ) @@ -99,34 +93,27 @@ showPatch, showNicely, showContextPatch, invert, invertRL, invertFL, identity, thing, things, - commuteFL, commuteRL, apply, + commuteFLorComplain, commuteRL, apply, description, summary, -#ifndef GADT_WITNESSES - commute, listTouchedFiles, hunkMatches, -#else - Commute(..) -#endif + commute, listTouchedFiles, hunkMatches ) import Darcs.Patch.Viewing ( xmlSummary, plainSummary ) import Darcs.Patch.Apply ( applyToPop, patchChanges, emptyMarkedupFile, - markupFile, forceReplaceSlurpy, - applyToFilepaths, applyToSlurpy, + markupFile, + applyToFilepaths, LineMark(..), MarkedUpFile, applyToTree ) import Darcs.Patch.Commute ( modernizePatch, -#ifndef GADT_WITNESSES - unravel, - merger, merge, elegantMerge, -#endif + merge, elegantMerge, ) import Darcs.Patch.Prim ( FromPrims, fromPrims, joinPatches, FromPrim, fromPrim, Conflict, Effect(effect), listConflictedFiles, resolveConflicts, Prim, canonize, sortCoalesceFL, rmdir, rmfile, tokreplace, adddir, addfile, - binary, changepref, hunk, move, + binary, changepref, hunk, move, primIsAdddir, primIsAddfile, primIsHunk, primIsBinary, primIsSetpref, - isSimilar, + isSimilar, isInconsistent, tryToShrink ) import Darcs.Witnesses.Ordered ( FL ) import Darcs.Patch.Real ( RealPatch ) diff -ruN darcs-2.4.4/src/Darcs/PopulationData.hs darcs-2.5/src/Darcs/PopulationData.hs --- darcs-2.4.4/src/Darcs/PopulationData.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/PopulationData.hs 2010-10-24 08:29:26.000000000 -0700 @@ -103,7 +103,7 @@ then do fnames <- getDirectoryContents dirname sl <- withCurrentDirectory dirname - (mapM getPopFrom_helper $ filter not_hidden fnames) + (mapM getPopFrom_helper $ filter notHidden fnames) let i = Info {nameI = n, modifiedByI = pinfo, modifiedHowI = DullDir, @@ -117,7 +117,7 @@ creationNameI = Just n} return $ PopFile i -not_hidden :: FilePath -> Bool -not_hidden ('.':_) = False -not_hidden ('_':_) = False -not_hidden _ = True +notHidden :: FilePath -> Bool +notHidden ('.':_) = False +notHidden ('_':_) = False +notHidden _ = True diff -ruN darcs-2.4.4/src/Darcs/Population.hs darcs-2.5/src/Darcs/Population.hs --- darcs-2.4.4/src/Darcs/Population.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Population.hs 2010-10-24 08:29:26.000000000 -0700 @@ -25,8 +25,8 @@ setPopState, DirMark(..), getRepoPop, getRepoPopVersion, - modified_to_xml, - lookup_pop, lookup_creation_pop, + modifiedToXml, + lookupPop, lookupCreationPop, ) where import qualified Data.ByteString.Char8 as BC ( unpack, singleton, pack ) @@ -34,14 +34,17 @@ import Darcs.Utils ( withCurrentDirectory ) import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) -import Darcs.Patch.FileName ( fn2fp, fp2fn, fn2ps, norm_path ) +import Darcs.Patch.FileName ( fn2fp, fp2fn, fn2ps, normPath ) import Darcs.Patch ( RepoPatch, applyToPop, patchcontents, patchChanges, Effect, effect ) import Darcs.Witnesses.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL ) -import Darcs.Patch.Info ( PatchInfo, idpatchinfo, to_xml ) -import Darcs.Patch.Set ( PatchSet ) +import Darcs.Patch.Info ( PatchInfo, idpatchinfo, toXml ) +import Darcs.Patch.Set ( PatchSet(..), newset2FL, newset2RL ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal ) -import Darcs.Repository ( withRepositoryDirectory, ($-), read_repo ) +import Darcs.Repository ( withRepositoryDirectory, ($-), readRepo ) import Darcs.Repository.Pristine ( identifyPristine, getPristinePop ) import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..), setPopState, getPopFrom ) @@ -60,8 +63,8 @@ creationNameI = Just (BC.singleton '.')} -- | apply a patchset to a population -applyPatchSetPop :: RepoPatch p => PatchSet p C(x) -> Population -> Population -applyPatchSetPop ps pop = applyPatchesPop (reverseRL $ concatRL ps) pop +applyPatchSetPop :: RepoPatch p => PatchSet p C(Origin x) -> Population -> Population +applyPatchSetPop ps pop = applyPatchesPop (newset2FL ps) pop -- | apply Patches to a population applyPatchesPop :: Effect p => FL (PatchInfoAnd p) C(x y) -> Population -> Population @@ -72,7 +75,7 @@ getRepoPop :: FilePath -> IO Population getRepoPop repobasedir = withRepositoryDirectory [] repobasedir $- \repository -> do - pinfo <- (head . mapRL info . concatRL) `liftM` read_repo repository + pinfo <- (head . mapRL info . newset2RL) `liftM` readRepo repository -- pinfo is the latest patchinfo mp <- withCurrentDirectory repobasedir $ identifyPristine >>= getPristinePop pinfo @@ -82,9 +85,9 @@ getRepoPopVersion :: FilePath -> PatchInfo -> IO Population getRepoPopVersion repobasedir pinfo = withRepositoryDirectory [] repobasedir $- \repository -> - do pips <- concatRL `liftM` read_repo repository + do pips <- newset2RL `liftM` readRepo repository return $ (unseal applyPatchSetPop) (mkPatchSet $ dropWhileRL ((/=pinfo).info) pips) initPop - where mkPatchSet (Sealed xs) = seal $ xs :<: NilRL + where mkPatchSet (Sealed xs) = seal $ PatchSet xs NilRL dropWhileRL :: (FORALL(x y) a C(x y) -> Bool) -> RL a C(r v) -> Sealed (RL a C(r)) dropWhileRL _ NilRL = seal NilRL dropWhileRL p xs@(x:<:xs') @@ -93,23 +96,23 @@ -- Routines for pulling data conveniently out of a Population -lookup_pop :: FilePath -> Population -> Maybe Population -lookup_pop f p = lookup_pop' (BC.unpack $ fn2ps $ fp2fn f) p +lookupPop :: FilePath -> Population -> Maybe Population +lookupPop f p = lookupPop' (BC.unpack $ fn2ps $ fp2fn f) p -lookup_pop' :: String -> Population -> Maybe Population -lookup_pop' f p@(Pop _ (PopFile i)) +lookupPop' :: String -> Population -> Maybe Population +lookupPop' f p@(Pop _ (PopFile i)) | BC.unpack (nameI i) == f = Just p | otherwise = Nothing -lookup_pop' d p@(Pop pinfo (PopDir i c)) +lookupPop' d p@(Pop pinfo (PopDir i c)) | BC.unpack (nameI i) == "." = - case catMaybes $ map (lookup_pop' (dropDS d).(Pop pinfo)) c of + case catMaybes $ map (lookupPop' (dropDS d).(Pop pinfo)) c of [apop] -> Just apop [] -> Nothing _ -> impossible | BC.unpack (nameI i) == takeWhile (/='/') d = case dropWhile (=='/') $ dropWhile (/='/') d of "" -> Just p - d' -> case catMaybes $ map (lookup_pop' d'.(Pop pinfo)) c of + d' -> case catMaybes $ map (lookupPop' d'.(Pop pinfo)) c of [apop] -> Just apop [] -> Nothing _ -> impossible @@ -117,11 +120,11 @@ where dropDS ('.':'/':f) = dropDS f dropDS f = f -lookup_creation_pop :: PatchInfo -> FilePath -> Population -> Maybe Population -lookup_creation_pop pinfo f p = lookup_creation_pop' pinfo (BC.unpack $ fn2ps $ fp2fn f) p +lookupCreationPop :: PatchInfo -> FilePath -> Population -> Maybe Population +lookupCreationPop pinfo f p = lookupCreationPop' pinfo (BC.unpack $ fn2ps $ fp2fn f) p -lookup_creation_pop' :: PatchInfo -> String -> Population -> Maybe Population -lookup_creation_pop' b a (Pop pinfo pp) = (Pop pinfo) `fmap` lcp pp +lookupCreationPop' :: PatchInfo -> String -> Population -> Maybe Population +lookupCreationPop' b a (Pop pinfo pp) = (Pop pinfo) `fmap` lcp pp where lcp p@(PopFile i) | fixname `fmap` creationNameI i == f && createdByI i == who = Just p | otherwise = Nothing @@ -130,15 +133,15 @@ | otherwise = case catMaybes $ map lcp c of [apop] -> Just apop _ -> Nothing - fixname = BC.pack . fn2fp . norm_path . fp2fn . BC.unpack - f = Just $ BC.pack $ fn2fp $ norm_path $ fp2fn a + fixname = BC.pack . fn2fp . normPath . fp2fn . BC.unpack + f = Just $ BC.pack $ fn2fp $ normPath $ fp2fn a who = Just b -modified_to_xml :: Info -> Doc -modified_to_xml i | modifiedHowI i == DullDir = empty +modifiedToXml :: Info -> Doc +modifiedToXml i | modifiedHowI i == DullDir = empty | modifiedHowI i == DullFile = empty -modified_to_xml i = text "" +modifiedToXml i = text "" $$ text "" <> text (show (modifiedHowI i)) <> text "" - $$ to_xml (modifiedByI i) + $$ toXml (modifiedByI i) $$ text "" diff -ruN darcs-2.4.4/src/Darcs/ProgressPatches.hs darcs-2.5/src/Darcs/ProgressPatches.hs --- darcs-2.4.4/src/Darcs/ProgressPatches.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/ProgressPatches.hs 2010-10-24 08:29:26.000000000 -0700 @@ -9,7 +9,7 @@ import Progress (minlist, beginTedious, endTedious, progress, progressKeepLatest, tediousSize, finishedOne) -import Darcs.Patch.Info (just_name, is_tag) +import Darcs.Patch.Info (justName, isTag) -- | Evaluate an 'FL' list and report progress. @@ -58,8 +58,8 @@ pl (y:<:NilRL) = unsafePerformIO $ do endTedious k return (y:<:NilRL) pl (y:<:ys) = - if is_tag iy - then finishedOne k ("back to "++ just_name iy) y :<: pl ys + if isTag iy + then finishedOne k ("back to "++ justName iy) y :<: pl ys else progressKeepLatest k y :<: pl ys where iy = info y diff -ruN darcs-2.4.4/src/Darcs/RemoteApply.hs darcs-2.5/src/Darcs/RemoteApply.hs --- darcs-2.4.4/src/Darcs/RemoteApply.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/RemoteApply.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,58 +1,58 @@ -- | This module is used by the push and put commands to apply the a bundle to a -- remote repository. By remote I do not necessarily mean a repository on another -- machine, it is just not the repository we're located in. -module Darcs.RemoteApply ( remote_apply, apply_as ) where +module Darcs.RemoteApply ( remoteApply, applyAs ) where import System.Exit ( ExitCode ) import Darcs.Flags ( DarcsFlag( ApplyAs, Debug ) ) import Darcs.Utils ( breakCommand ) -import Darcs.URL ( is_url, is_ssh ) +import Darcs.URL ( isUrl, isSsh ) import Darcs.External import Printer -remote_apply :: [DarcsFlag] -> String -> Doc -> IO ExitCode -remote_apply opts repodir bundle - = case apply_as opts of - Nothing -> if is_ssh repodir - then apply_via_ssh opts repodir bundle - else if is_url repodir - then apply_via_url opts repodir bundle - else apply_via_local opts repodir bundle - Just un -> if is_ssh repodir - then apply_via_ssh_and_sudo opts repodir un bundle - else apply_via_sudo un repodir bundle - -apply_as :: [DarcsFlag] -> Maybe String -apply_as (ApplyAs user:_) = Just user -apply_as (_:fs) = apply_as fs -apply_as [] = Nothing -apply_via_sudo :: String -> String -> Doc -> IO ExitCode -apply_via_sudo user repo bundle = - darcs_program >>= \darcs -> +remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode +remoteApply opts repodir bundle + = case applyAs opts of + Nothing -> if isSsh repodir + then applyViaSsh opts repodir bundle + else if isUrl repodir + then applyViaUrl opts repodir bundle + else applyViaLocal opts repodir bundle + Just un -> if isSsh repodir + then applyViaSshAndSudo opts repodir un bundle + else applyViaSudo un repodir bundle + +applyAs :: [DarcsFlag] -> Maybe String +applyAs (ApplyAs user:_) = Just user +applyAs (_:fs) = applyAs fs +applyAs [] = Nothing +applyViaSudo :: String -> String -> Doc -> IO ExitCode +applyViaSudo user repo bundle = + darcsProgram >>= \darcs -> pipeDoc "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle -apply_via_local :: [DarcsFlag] -> String -> Doc -> IO ExitCode -apply_via_local opts repo bundle = - darcs_program >>= \darcs -> +applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode +applyViaLocal opts repo bundle = + darcsProgram >>= \darcs -> pipeDoc darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle -apply_via_url :: [DarcsFlag] -> String -> Doc -> IO ExitCode -apply_via_url opts repo bundle = +applyViaUrl :: [DarcsFlag] -> String -> Doc -> IO ExitCode +applyViaUrl opts repo bundle = do maybeapply <- maybeURLCmd "APPLY" repo case maybeapply of - Nothing -> apply_via_local opts repo bundle + Nothing -> applyViaLocal opts repo bundle Just apply -> do let (cmd, args) = breakCommand apply pipeDoc cmd (args ++ [repo]) bundle -apply_via_ssh :: [DarcsFlag] -> String -> Doc -> IO ExitCode -apply_via_ssh opts repo bundle = +applyViaSsh :: [DarcsFlag] -> String -> Doc -> IO ExitCode +applyViaSsh opts repo bundle = pipeDocSSH addr [remoteDarcsCmd opts++" apply --all "++unwords (applyopts opts)++ " --repodir '"++path++"'"] bundle where (addr,':':path) = break (==':') repo -apply_via_ssh_and_sudo :: [DarcsFlag] -> String -> String -> Doc -> IO ExitCode -apply_via_ssh_and_sudo opts repo username bundle = +applyViaSshAndSudo :: [DarcsFlag] -> String -> String -> Doc -> IO ExitCode +applyViaSshAndSudo opts repo username bundle = pipeDocSSH addr ["sudo -u "++username++" "++remoteDarcsCmd opts++ " apply --all --repodir '"++path++"'"] bundle where (addr,':':path) = break (==':') repo diff -ruN darcs-2.4.4/src/Darcs/RepoPath.hs darcs-2.5/src/Darcs/RepoPath.hs --- darcs-2.4.4/src/Darcs/RepoPath.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/RepoPath.hs 2010-10-24 08:29:26.000000000 -0700 @@ -30,6 +30,7 @@ makeAbsoluteOrStd, ioAbsoluteOrStd, useAbsoluteOrStd, + stdOut, -- * AbsoluteOrRemotePath AbsoluteOrRemotePath, ioAbsoluteOrRemote, @@ -49,7 +50,7 @@ import Data.List ( isPrefixOf, isSuffixOf ) import Control.Exception ( bracket ) -import Darcs.URL ( is_absolute, is_relative, is_ssh_nopath ) +import Darcs.URL ( isAbsolute, isRelative, isSshNopath ) import qualified Workaround ( getCurrentDirectory ) import qualified System.Directory ( setCurrentDirectory ) import System.Directory ( doesDirectoryExist ) @@ -119,7 +120,7 @@ simpleSubPath :: FilePath -> Maybe SubPath simpleSubPath x | null x = bug "simpleSubPath called with empty path" - | is_relative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x + | isRelative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x | otherwise = Nothing -- | Interpret a possibly relative path wrt the current working directory. @@ -151,8 +152,8 @@ -- Regarding the last point, someone more familiar with how these functions -- are used should verify that this is indeed necessary or at least useful. makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath -makeAbsolute a dir = if not (null dir) && is_absolute dir - then AbsolutePath (norm_slashes dir') +makeAbsolute a dir = if not (null dir) && isAbsolute dir + then AbsolutePath (normSlashes dir') else ma a dir' where dir' = FilePath.normalise $ pathToPosix dir @@ -172,7 +173,7 @@ -- | Convert to posix, remove trailing slashes, and (under Posix) -- reduce multiple leading slashes to one. simpleClean :: String -> String -simpleClean = norm_slashes . reverse . dropWhile (=='/') . reverse . pathToPosix +simpleClean = normSlashes . reverse . dropWhile (=='/') . reverse . pathToPosix -- | The root directory as an absolute path. rootDirectory :: AbsolutePath @@ -182,13 +183,16 @@ makeAbsoluteOrStd _ "-" = APStd makeAbsoluteOrStd a p = AP $ makeAbsolute a p +stdOut :: AbsolutePathOrStd +stdOut = APStd + ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd ioAbsoluteOrStd "-" = return APStd ioAbsoluteOrStd p = AP `fmap` ioAbsolute p -- | Execute either the first or the second argument action, depending on -- whether the given path is an 'AbsolutePath' or stdin/stdout. -useAbsoluteOrStd :: (AbsolutePath -> IO a) -> IO a -> AbsolutePathOrStd -> IO a +useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a useAbsoluteOrStd _ f APStd = f useAbsoluteOrStd f _ (AP x) = f x @@ -197,7 +201,7 @@ isdir <- doesDirectoryExist p if not isdir then return $ RmtP $ - case () of _ | is_ssh_nopath p -> p++"." + case () of _ | isSshNopath p -> p++"." | "/" `isSuffixOf` p -> init p | otherwise -> p else AbsP `fmap` ioAbsolute p @@ -233,12 +237,12 @@ convert c = c -- | Reduce multiple leading slashes to one. This only affects Posix systems. -norm_slashes :: FilePath -> FilePath +normSlashes :: FilePath -> FilePath #ifndef WIN32 -- multiple slashes in front are ignored under Posix -norm_slashes ('/':p) = '/' : dropWhile (== '/') p +normSlashes ('/':p) = '/' : dropWhile (== '/') p #endif -norm_slashes p = p +normSlashes p = p getCurrentDirectory :: IO AbsolutePath getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory diff -ruN darcs-2.4.4/src/Darcs/Repository/ApplyPatches.hs darcs-2.5/src/Darcs/Repository/ApplyPatches.hs --- darcs-2.4.4/src/Darcs/Repository/ApplyPatches.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/ApplyPatches.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,31 +20,31 @@ #include "gadts.h" -module Darcs.Repository.ApplyPatches ( apply_patches, apply_patches_with_feedback ) where +module Darcs.Repository.ApplyPatches ( applyPatches, applyPatchesWithFeedback ) where import Darcs.Patch ( Patchy, apply ) import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) -import Darcs.Patch.Info ( human_friendly ) +import Darcs.Patch.Info ( humanFriendly ) import Darcs.Witnesses.Ordered ( FL(..), lengthFL, mapFL ) import Darcs.Flags ( DarcsFlag ) import Darcs.Utils ( putDocLnError ) import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) import Printer ( text ) -apply_patches_with_feedback :: Patchy p => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO () -apply_patches_with_feedback _ _ NilFL = return () -apply_patches_with_feedback opts k patches = +applyPatchesWithFeedback :: Patchy p => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO () +applyPatchesWithFeedback _ _ NilFL = return () +applyPatchesWithFeedback opts k patches = do beginTedious k tediousSize k (lengthFL patches) sequence_ $ mapFL apply_cautiously patches endTedious k where apply_cautiously :: Patchy p => PatchInfoAnd p C(a b) -> IO () apply_cautiously hp = - do finishedOneIO k (show $ human_friendly $ info hp) + do finishedOneIO k (show $ humanFriendly $ info hp) apply opts (hopefully hp) `catch` \e -> do putDocLnError $ text "Unapplicable patch:" - putDocLnError $ human_friendly (info hp) + putDocLnError $ humanFriendly (info hp) ioError e -apply_patches :: Patchy p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () -apply_patches opts ps = apply_patches_with_feedback opts "Applying patch" ps +applyPatches :: Patchy p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () +applyPatches opts ps = applyPatchesWithFeedback opts "Applying patch" ps diff -ruN darcs-2.4.4/src/Darcs/Repository/Cache.hs darcs-2.5/src/Darcs/Repository/Cache.hs --- darcs-2.4.4/src/Darcs/Repository/Cache.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Cache.hs 2010-10-24 08:29:26.000000000 -0700 @@ -7,17 +7,20 @@ cacheHash, okayHash, takeHash, Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..), HashedDir(..), hashedDir, - unionCaches, cleanCaches, cleanCachesWithHint, - fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache, + unionCaches, unionRemoteCaches, cleanCaches, cleanCachesWithHint, + fetchFileUsingCache, speculateFileUsingCache, speculateFilesUsingCache, + writeFileUsingCache, peekInCache, repo2cache, - writable, isthisrepo, hashedFilePath, allHashedDirs + writable, isthisrepo, hashedFilePath, allHashedDirs, compareByLocality ) where -import Control.Monad ( liftM, when, guard ) +import Control.Monad ( liftM, when, guard, unless, filterM, forM_ ) import Data.List ( nub ) -import Data.Maybe ( listToMaybe ) -import System.Directory ( removeFile, doesFileExist, getDirectoryContents ) +import Data.Maybe ( catMaybes, listToMaybe ) +import System.Directory ( removeFile, doesFileExist, doesDirectoryExist, + getDirectoryContents, getPermissions ) +import qualified System.Directory as SD ( writable ) import System.Posix.Files ( linkCount, getSymbolicLinkStatus ) import System.IO ( hPutStrLn, stderr ) @@ -37,7 +40,7 @@ import Darcs.Global ( darcsdir ) import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS ) import Progress ( progressList, debugMessage, debugFail ) -import Darcs.URL ( is_file ) +import Darcs.URL ( isFile, isUrl, isSsh ) import Darcs.Utils ( withCurrentDirectory, catchall ) data HashedDir = HashedPristineDir | HashedPatchesDir | HashedInventoriesDir @@ -69,6 +72,54 @@ unionCaches :: Cache -> Cache -> Cache unionCaches (Ca a) (Ca b) = Ca (nub (a++b)) +-- | unionRemoteCaches merges caches. It tries to do better than just blindly +-- copying remote cache entries: +-- +-- * If remote repository is accessed through network, do not copy any cache +-- entries from it. Taking local entries does not make sense and using +-- network entries can lead to darcs hang when it tries to get to +-- unaccessible host. +-- +-- * If remote repositoty is local, copy all network cache entries. For local +-- cache entries if the cache directory exists and is writable it is added +-- as writable cache, if it exists but is not writable it is added as +-- read-only cache. +-- +-- This approach should save us from bogus cache entries. One case it does not +-- work very well is when you fetch from partial repository over network. +-- Hopefully this is not a common case. +unionRemoteCaches :: Cache -> Cache -> String -> IO (Cache) +unionRemoteCaches local (Ca remote) repourl + | isFile repourl = do f <- filtered + return $ local `unionCaches` Ca f + | otherwise = return local + where filtered = mapM (\x -> fn x `catchall` return Nothing) remote >>= + return . catMaybes + fn :: CacheLoc -> IO (Maybe CacheLoc) + fn (Cache Repo Writable _) = return Nothing + fn c@(Cache t _ url) + | isFile url = do + ex <- doesDirectoryExist url + if ex then do p <- getPermissions url + return $ Just $ + if writable c && SD.writable p + then c else Cache t NotWritable url + else return Nothing + | otherwise = return $ Just c + +-- | Compares two caches, a remote cache is greater than a local one. +-- The order of the comparison is given by: local < http < ssh +compareByLocality :: CacheLoc -> CacheLoc -> Ordering +compareByLocality (Cache _ _ x) (Cache _ _ y) + | isLocal x && isRemote y = LT + | isRemote x && isLocal y = GT + | isUrl x && isSsh y = LT + | isSsh x && isUrl y = GT + | otherwise = EQ + where + isRemote r= isUrl r || isSsh r + isLocal = isFile + repo2cache :: String -> Cache repo2cache r = Ca [Cache Repo NotWritable r] @@ -132,6 +183,16 @@ speculateFileUsingCache c sd h = do debugMessage $ "Speculating on "++h copyFileUsingCache OnlySpeculate c sd h +-- | Note that the files are likely to be useful soon: pipelined downloads will +-- add them to the (low-priority) queue, for the rest it is a noop. +speculateFilesUsingCache :: Cache -> HashedDir -> [String] -> IO () +speculateFilesUsingCache _ _ [] = return () +speculateFilesUsingCache cache sd hs = + do --debugMessage $ "Thinking about speculating on "++unwords hs + hs' <- filterM (fmap not . peekInCache cache sd) hs + unless (null hs') $ do debugMessage $ "Speculating on "++unwords hs' + copyFilesUsingCache OnlySpeculate cache sd hs' + data OrOnlySpeculate = ActuallyCopy | OnlySpeculate deriving ( Eq ) copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO () @@ -157,6 +218,10 @@ | otherwise = sfuc cs out fn c = hashedFilePath c subdir f +copyFilesUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> [String] -> IO () +copyFilesUsingCache oos cache subdir hs = + do forM_ hs $ copyFileUsingCache oos cache subdir + data FromWhere = LocalOnly | Anywhere deriving ( Eq ) @@ -167,7 +232,7 @@ `catchall` debugFail ("Couldn't fetch `"++f++"'\nin subdir "++(hashedDir subdir)++ " from sources:\n\n"++show (Ca cache)) where ffuc (c:cs) - | not (writable c) && (Anywhere == fromWhere || is_file (fn c)) = + | not (writable c) && (Anywhere == fromWhere || isFile (fn c)) = do debugMessage $ "In fetchFileUsingCachePrivate I'm going manually" debugMessage $ " getting "++f debugMessage $ " from " ++ fn c diff -ruN darcs-2.4.4/src/Darcs/Repository/Checkpoint.hs darcs-2.5/src/Darcs/Repository/Checkpoint.hs --- darcs-2.4.4/src/Darcs/Repository/Checkpoint.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Checkpoint.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,102 +20,80 @@ #include "gadts.h" -module Darcs.Repository.Checkpoint ( get_checkpoint, get_checkpoint_by_default, - identify_checkpoint, - write_checkpoint_patch, +module Darcs.Repository.Checkpoint ( getCheckpoint, getCheckpointByDefault, + identifyCheckpoint, + writeCheckpointPatch, ) where import System.Directory ( createDirectoryIfMissing ) -import System.IO.Unsafe ( unsafeInterleaveIO ) -import Data.Maybe ( listToMaybe, catMaybes ) +import Data.Maybe ( listToMaybe ) import Darcs.Hopefully ( PatchInfoAnd, info ) import qualified Data.ByteString as B ( null, empty, ByteString ) import Darcs.Lock ( writeDocBinFile ) -import Darcs.SlurpDirectory ( Slurpy, empty_slurpy ) -import Darcs.Patch ( RepoPatch, Patch, Named, patch2patchinfo, - applyToSlurpy, readPatch, gzWritePatch ) -import Darcs.Witnesses.Ordered ( RL(..), FL(..), mapRL, reverseRL ) -import Darcs.Repository.Internal ( Repository(..), read_repo ) -import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo, - showPatchInfo - ) +import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, + readPatch, gzWritePatch ) +import Darcs.Witnesses.Ordered ( mapRL ) +import Darcs.Repository.Internal ( Repository(..), readRepo ) +import Darcs.Repository.DarcsRepo ( readCheckpoints ) +import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfo, + showPatchInfo ) +import Darcs.Patch.Set( PatchSet(..), Tagged(..) ) import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) ) import Darcs.Flags ( DarcsFlag( Partial, Complete ) ) import Darcs.Utils ( catchall ) -import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import Darcs.Global ( darcsdir ) import Printer ( Doc, ($$), empty ) -import Darcs.Witnesses.Sealed ( Sealed(Sealed), Sealed2(Sealed2), seal, seal2 ) +import Darcs.Witnesses.Sealed ( Sealed, Sealed2(Sealed2), seal2 ) import Control.Monad ( liftM ) -read_patch_ids :: B.ByteString -> [PatchInfo] -read_patch_ids inv | B.null inv = [] -read_patch_ids inv = case readPatchInfo inv of - Just (pinfo,r) -> pinfo : read_patch_ids r +readPatchIds :: B.ByteString -> [PatchInfo] +readPatchIds inv | B.null inv = [] +readPatchIds inv = case readPatchInfo inv of + Just (pinfo,r) -> pinfo : readPatchIds r Nothing -> [] -read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)] -read_checkpoints d = do - realdir <- toPath `fmap` ioAbsoluteOrRemote d - pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable - `catchall` return B.empty - pis <- return $ reverse $ read_patch_ids pistr - slurpies <- sequence $ map (fetch_checkpoint realdir) pis - return $ zip pis slurpies - where fetch_checkpoint r pinfo = - unsafeInterleaveIO $ do - pstr <- gzFetchFilePS - (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable - case fst `fmap` (readPatch pstr :: Maybe (Sealed (Named Patch C(x)), B.ByteString)) of - Nothing -> return Nothing - Just (Sealed p) -> return $ applyToSlurpy p empty_slurpy - -get_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) -get_checkpoint repository@(Repo _ opts _ _) = if Partial `elem` opts - then get_check_internal repository +getCheckpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) +getCheckpoint repository@(Repo _ opts _ _) = if Partial `elem` opts + then getCheckInternal repository else return Nothing -get_checkpoint_by_default :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) -get_checkpoint_by_default repository@(Repo _ opts _ _) = if Complete `elem` opts +getCheckpointByDefault :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) +getCheckpointByDefault repository@(Repo _ opts _ _) = if Complete `elem` opts then return Nothing - else get_check_internal repository + else getCheckInternal repository -identify_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe PatchInfo) -identify_checkpoint repository@(Repo r _ _ _) = do - pis <- (map sp2i . catMaybes . mapRL lastRL) `liftM` read_repo repository +identifyCheckpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe PatchInfo) +identifyCheckpoint repository@(Repo r _ _ _) = do + pis <- (map sp2i . extractTags) `liftM` readRepo repository pistr <- fetchFilePS (r++"/"++darcsdir++"/checkpoints/inventory") Uncachable `catchall` return B.empty - return $ listToMaybe $ filter (`elem` pis) $ reverse $ read_patch_ids pistr - where lastRL :: RL a C(x y) -> Maybe (Sealed2 a) - lastRL as = do Sealed ps <- headFL (reverseRL as) - return $ seal2 ps - headFL :: FL a C(x y) -> Maybe (Sealed (a C(x))) - headFL (x:>:_) = Just $ seal x - headFL NilFL = Nothing + return $ listToMaybe $ filter (`elem` pis) $ reverse $ readPatchIds pistr + where extractTags :: PatchSet p C(start end) -> [Sealed2 (PatchInfoAnd p)] + extractTags (PatchSet _ ts) = mapRL (\(Tagged t _ _) -> seal2 t) ts sp2i :: Sealed2 (PatchInfoAnd p) -> PatchInfo sp2i (Sealed2 p) = info p -get_check_internal :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) -get_check_internal repository@(Repo r _ _ _) = do - mc <- identify_checkpoint repository +getCheckInternal :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) +getCheckInternal repository@(Repo r _ _ _) = do + mc <- identifyCheckpoint repository case mc of Nothing -> return Nothing Just pinfo -> do ps <- gzFetchFilePS - (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable + (r++"/"++darcsdir++"/checkpoints/"++makeFilename pinfo) Cachable return $ case readPatch ps of Just (p, _) -> Just p Nothing -> Nothing -format_inv :: [PatchInfo] -> Doc -format_inv [] = empty -format_inv (pinfo:ps) = showPatchInfo pinfo - $$ format_inv ps +formatInv :: [PatchInfo] -> Doc +formatInv [] = empty +formatInv (pinfo:ps) = showPatchInfo pinfo + $$ formatInv ps -write_checkpoint_patch :: RepoPatch p => Named p C(x y) -> IO () -write_checkpoint_patch p = +writeCheckpointPatch :: RepoPatch p => Named p C(x y) -> IO () +writeCheckpointPatch p = do createDirectoryIfMissing False (darcsdir++"/checkpoints") - gzWritePatch (darcsdir++"/checkpoints/"++make_filename (patch2patchinfo p)) p - cpi <- (map fst) `fmap` read_checkpoints "." + gzWritePatch (darcsdir++"/checkpoints/"++makeFilename (patch2patchinfo p)) p + cpi <- readCheckpoints "." writeDocBinFile (darcsdir++"/checkpoints/inventory") - $ format_inv $ reverse $ patch2patchinfo p:cpi + $ formatInv $ reverse $ patch2patchinfo p:cpi diff -ruN darcs-2.4.4/src/Darcs/Repository/DarcsRepo.lhs darcs-2.5/src/Darcs/Repository/DarcsRepo.lhs --- darcs-2.4.4/src/Darcs/Repository/DarcsRepo.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/DarcsRepo.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -50,23 +50,24 @@ #include "gadts.h" -module Darcs.Repository.DarcsRepo ( write_inventory, write_inventory_and_patches, - add_to_inventory, add_to_tentative_pristine, - add_to_tentative_inventory, remove_from_tentative_inventory, - finalize_tentative_changes, finalize_pristine_changes, - revert_tentative_changes, - read_repo, read_tentative_repo, write_and_read_patch, - copy_patches +module Darcs.Repository.DarcsRepo ( writeInventory, writeInventoryAndPatches, + addToInventory, addToTentativePristine, + addToTentativeInventory, removeFromTentativeInventory, + finalizeTentativeChanges, finalizePristineChanges, + revertTentativeChanges, + readRepo, readTentativeRepo, writeAndReadPatch, + copyPatches, readCheckpoints ) where -import System.Directory ( doesDirectoryExist, createDirectoryIfMissing ) +import System.Directory ( createDirectoryIfMissing ) import Workaround ( renameFile ) import Darcs.Utils ( clarifyErrors ) import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr ) import System.IO.Unsafe ( unsafeInterleaveIO ) -import Control.Monad ( liftM, when, unless ) +import System.FilePath.Posix ( () ) +import Control.Monad ( when ) import Darcs.Hopefully ( Hopefully, PatchInfoAnd, patchInfoAndPatch, info, actually, hopefully, unavailable, n2pia ) @@ -76,31 +77,36 @@ import qualified Data.ByteString as B (ByteString, null, readFile, empty) import qualified Data.ByteString.Char8 as BC (break, pack) -import Darcs.SlurpDirectory ( Slurpy, empty_slurpy ) -import Darcs.Patch ( RepoPatch, Effect, Prim, Named, Patch, invert, +import Darcs.Patch ( RepoPatch, Effect, Prim, Named, invert, effect, patch2patchinfo, - applyToSlurpy, readPatch, - writePatch, gzWritePatch, showPatch ) -import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:<)(..), + showPatch ) +import qualified Darcs.Patch as Patch + +import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>>)(..), (+<+), reverseFL, mapFL, unsafeCoerceP, - reverseRL, concatRL, mapRL, mapRL_RL ) -import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo, - showPatchInfo, is_tag + reverseRL, mapRL ) +import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfo, + showPatchInfo, isTag ) -import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif import Darcs.External ( gzFetchFilePS, fetchFilePS, copyFilesOrUrls, Cachable(..), cloneFile ) import Darcs.Lock ( writeBinFile, writeDocBinFile, appendDocBinFile, appendBinFile ) import Darcs.Flags ( DarcsFlag( NoCompress ) ) -import Darcs.Patch.Depends ( slightly_optimize_patchset, commute_to_end, deep_optimize_patchset ) +import Darcs.Patch.Depends ( slightlyOptimizePatchset, commuteToEnd, deepOptimizePatchset ) import Darcs.Repository.Pristine ( identifyPristine, applyPristine ) import Darcs.Global ( darcsdir ) import Darcs.Utils ( catchall ) import Darcs.ProgressPatches ( progressFL ) import Printer ( text, (<>), Doc, ($$), empty ) -import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal ) + +#include "impossible.h" \end{code} There is a very special patch which may be stored in \verb!patches! which @@ -110,19 +116,20 @@ Similarly, token replaces are stored in pending until they are recorded. \begin{code} -write_patch :: RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath -write_patch opts p = +writePatch :: RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath +writePatch opts p = do let writeFun = if NoCompress `elem` opts - then writePatch - else gzWritePatch - pname = darcsdir++"/patches/"++make_filename (patch2patchinfo p) + then Patch.writePatch + else Patch.gzWritePatch + pname = darcsdir++"/patches/"++makeFilename (patch2patchinfo p) writeFun pname p return pname -write_and_read_patch :: RepoPatch p => [DarcsFlag] -> PatchInfoAnd p C(x y) +writeAndReadPatch :: RepoPatch p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y)) -write_and_read_patch opts p = do fn <- write_patch opts $ hopefully p - unsafeInterleaveIO $ parse fn +writeAndReadPatch opts p = + do fn <- writePatch opts $ hopefully p + unsafeInterleaveIO $ parse fn where parse fn = do debugMessage ("Reading patch file: "++ fn) ps <- gzReadFilePS fn Sealed pp <- case readPatch ps of @@ -130,90 +137,101 @@ Nothing -> fail ("Couldn't parse patch file "++fn) return $ n2pia $ unsafeCoerceP pp ---format_inventory is not exported for use outside of the DarcsRepo module +--formatInventory is not exported for use outside of the DarcsRepo module --itself. -format_inventory :: [PatchInfo] -> Doc -format_inventory [] = empty -format_inventory (pinfo:ps) = showPatchInfo pinfo $$ format_inventory ps +formatInventory :: [PatchInfo] -> Doc +formatInventory [] = empty +formatInventory (pinfo:ps) = showPatchInfo pinfo $$ formatInventory ps -write_inventory :: RepoPatch p => FilePath -> PatchSet p C(x) -> IO () --- Note that write_inventory optimizes the inventory it writes out by +writeInventory :: RepoPatch p => FilePath -> PatchSet p C(Origin x) -> IO () +-- Note that writeInventory optimizes the inventory it writes out by -- checking on tag dependencies. --- FIXME: There is also a problem that write_inventory always writes +-- FIXME: There is also a problem that writeInventory always writes -- out the entire inventory, including the parts that you haven't -- changed... -write_inventory dir ps = withSignalsBlocked $ do +writeInventory dir ps = withSignalsBlocked $ do createDirectoryIfMissing False (dir++"/"++darcsdir++"/inventories") - simply_write_inventory "inventory" dir $ slightly_optimize_patchset ps + simplyWriteInventory "inventory" dir $ slightlyOptimizePatchset ps -simply_write_inventory :: RepoPatch p => String -> FilePath -> PatchSet p C(x) -> IO () -simply_write_inventory name dir NilRL = +simplyWriteInventory :: RepoPatch p => String -> FilePath -> PatchSet p C(Origin x) -> IO () +simplyWriteInventory name dir (PatchSet NilRL NilRL) = writeBinFile (dir++"/"++darcsdir++"/"++name) "" -simply_write_inventory name dir (ps:<:NilRL) = do - writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ format_inventory $ mapFL info $ reverseRL ps -simply_write_inventory _ _ (NilRL:<:_) = - fail $ "Bug in simply_write_inventory, please report!" -simply_write_inventory name dir (ps:<:pss) = do - tagname <- return $ make_filename $ last $ mapRL info ps - simply_write_inventory ("inventories/"++tagname) dir pss +simplyWriteInventory name dir (PatchSet ps NilRL) = do + writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ formatInventory $ mapFL info $ reverseRL ps +simplyWriteInventory name dir (PatchSet ps ts@(Tagged t _ _ :<: _)) = do -- nonempty Tagged + simplyWriteTaggedInventory dir ts writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ text "Starting with tag:" - $$ format_inventory (mapFL info $ reverseRL ps) + $$ formatInventory (mapFL info $ t :>: reverseRL ps) -write_inventory_and_patches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> IO () -write_inventory_and_patches opts ps = do write_inventory "." ps - sequence_ $ mapRL (write_patch opts . hopefully) $ concatRL ps +simplyWriteTaggedInventory :: RepoPatch p => FilePath -> RL (Tagged p) C(Origin x) -> IO () +simplyWriteTaggedInventory _ NilRL = return () +simplyWriteTaggedInventory dir (Tagged t _ ps :<: NilRL) = do + writeDocBinFile (dir "_darcs/inventories" makeFilename (info t)) $ + formatInventory (mapFL info $ reverseRL ps) +simplyWriteTaggedInventory dir (Tagged t _ ps :<: ts@(Tagged t2 _ _ :<: _)) = + do simplyWriteTaggedInventory dir ts + writeDocBinFile (dir "_darcs/inventories" makeFilename (info t)) $ + text "Starting with tag:" $$ + formatInventory (mapFL info $ t2 :>: reverseRL ps) + +writeInventoryAndPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin x) -> IO () +writeInventoryAndPatches opts ps = do writeInventory "." ps + sequence_ $ mapRL (writePatch opts . hopefully) $ newset2RL ps -add_to_inventory :: FilePath -> [PatchInfo] -> IO () -add_to_inventory dir pinfos = +addToInventory :: FilePath -> [PatchInfo] -> IO () +addToInventory dir pinfos = appendDocBinFile (dir++"/"++darcsdir++"/inventory") $ text "\n" <> pidocs pinfos where pidocs [] = text "" pidocs (p:ps) = showPatchInfo p $$ pidocs ps -add_to_tentative_inventory :: forall p C(x y). RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath -add_to_tentative_inventory opts p = +addToTentativeInventory :: forall p C(x y). RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath +addToTentativeInventory opts p = do appendDocBinFile (darcsdir++"/tentative_inventory") $ text "\n" <> showPatchInfo (patch2patchinfo p) - when (is_tag $ patch2patchinfo p) $ + res <- writePatch opts p + when (isTag $ patch2patchinfo p) $ do debugMessage "Optimizing the tentative inventory, since we're adding a tag." realdir <- toPath `fmap` ioAbsoluteOrRemote "." let k = "Reading tentative inventory" beginTedious k - Sealed ps <- read_repo_private k opts realdir "tentative_inventory" - :: IO (SealedPatchSet p) - simply_write_inventory "tentative_inventory" "." $ slightly_optimize_patchset ps - write_patch opts p + Sealed ps <- readRepoPrivate k realdir "tentative_inventory" + :: IO (SealedPatchSet p C(Origin) ) + simplyWriteInventory "tentative_inventory" "." $ slightlyOptimizePatchset ps + return res -add_to_tentative_pristine :: Effect p => p C(x y) -> IO () -add_to_tentative_pristine p = +addToTentativePristine :: Effect p => p C(x y) -> IO () +addToTentativePristine p = do -- Sealed p <- (fst . fromJust . readPatchCarefully) `fmap` gzReadFilePS fp appendDocBinFile (darcsdir++"/tentative_pristine") $ showPatch (effect p) -- FIXME: this is inefficient! appendBinFile (darcsdir++"/tentative_pristine") "\n" -remove_from_tentative_inventory :: RepoPatch p => Bool -> [DarcsFlag] -> FL (Named p) C(x y) -> IO () -remove_from_tentative_inventory update_pristine opts to_remove = - do finalize_tentative_changes - Sealed allpatches <- read_repo opts "." - skipped :< unmodified <- return $ commute_to_end (unsafeCoerceP to_remove) allpatches - sequence_ $ mapFL (write_patch opts) skipped - write_inventory "." $ deep_optimize_patchset - $ mapRL_RL n2pia (reverseFL skipped) :<: unmodified - remove_from_checkpoint_inventory to_remove +removeFromTentativeInventory :: RepoPatch p => Bool -> [DarcsFlag] + -> FL (PatchInfoAnd p) C(x y) -> IO () +removeFromTentativeInventory update_pristine opts to_remove = + do finalizeTentativeChanges + Sealed allpatches <- readRepo opts "." + unmodified :>> skipped <- return $ commuteToEnd + (reverseFL $ unsafeCoerceP to_remove) allpatches + sequence_ $ mapRL (writePatch opts . hopefully) skipped + let newpatches = case unmodified of + PatchSet ps ts -> PatchSet (skipped+<+ps) ts + writeInventory "." $ deepOptimizePatchset newpatches when update_pristine $ do pris <- identifyPristine repairable $ applyPristine pris $ progressFL "Applying inverse to pristine" $ invert to_remove - revert_tentative_changes + revertTentativeChanges -finalize_tentative_changes :: IO () -finalize_tentative_changes = renameFile (darcsdir++"/tentative_inventory") (darcsdir++"/inventory") +finalizeTentativeChanges :: IO () +finalizeTentativeChanges = renameFile (darcsdir++"/tentative_inventory") (darcsdir++"/inventory") -finalize_pristine_changes :: IO () -finalize_pristine_changes = +finalizePristineChanges :: IO () +finalizePristineChanges = do Sealed ps <- read_patches $ darcsdir++"/tentative_pristine" pris <- identifyPristine repairable $ applyPristine pris ps - where + where read_patches :: String -> IO (Sealed (FL Prim C(x))) read_patches f = do ps <- B.readFile f return $ case readPatch ps of @@ -225,109 +243,109 @@ ["Your repository is now in an inconsistent state.", "This must be fixed by running darcs repair."] -revert_tentative_changes :: IO () -revert_tentative_changes = +revertTentativeChanges :: IO () +revertTentativeChanges = do cloneFile (darcsdir++"/inventory") (darcsdir++"/tentative_inventory") writeBinFile (darcsdir++"/tentative_pristine") "" -copy_patches :: [DarcsFlag] -> FilePath -> FilePath -> [PatchInfo] -> IO () -copy_patches opts dir out patches = do +copyPatches :: [DarcsFlag] -> FilePath -> FilePath -> [PatchInfo] -> IO () +copyPatches opts dir out patches = do realdir <- toPath `fmap` ioAbsoluteOrRemote dir - copyFilesOrUrls opts (realdir++"/"++darcsdir++"/patches") (map make_filename patches) + copyFilesOrUrls opts (realdir++"/"++darcsdir++"/patches") (map makeFilename patches) (out++"/"++darcsdir++"/patches") Cachable -read_repo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p) -read_repo opts d = do +readRepo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p C(Origin)) +readRepo _ d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d let k = "Reading inventory of repository "++d beginTedious k - read_repo_private k opts realdir "inventory" `catch` + readRepoPrivate k realdir "inventory" `catch` (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e) -read_tentative_repo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p) -read_tentative_repo opts d = do +readTentativeRepo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p C(Origin)) +readTentativeRepo _ d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d let k = "Reading tentative inventory of repository "++d beginTedious k - read_repo_private k opts realdir "tentative_inventory" `catch` + readRepoPrivate k realdir "tentative_inventory" `catch` (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e) -read_repo_private :: RepoPatch p => String -> [DarcsFlag] -> FilePath -> FilePath -> IO (SealedPatchSet p) -read_repo_private k opts d iname = do - i <- gzFetchFilePS (d++"/"++darcsdir++"/"++iname) Uncachable +readRepoPrivate :: RepoPatch p => String -> FilePath -> FilePath -> IO (SealedPatchSet p C(Origin)) +readRepoPrivate k d iname = do + i <- gzFetchFilePS (d "_darcs" iname) Uncachable finishedOneIO k iname - (rest,str) <- case BC.break ((==) '\n') i of - (swt,pistr) | swt == BC.pack "Starting with tag:" -> - do r <- rr $ head $ read_patch_ids pistr - return (r,pistr) - _ -> do endTedious k - return (seal NilRL,i) - pis <- return $ reverse $ read_patch_ids str - isdir <- doesDirectoryExist d - let parse f = let fn = d ++ "/"++darcsdir++"/patches/" ++ make_filename f - in if isdir then parse_local fn - else parse_remote fn - lift2Sealed (:<:) (return rest) (read_patches parse pis) - where rr pinfo = unsafeInterleaveIO $ read_repo_private k opts d $ - "inventories/"++make_filename pinfo - -- parse_remote should really download to a temporary file removed - -- at exit - parse_remote, parse_local :: RepoPatch p => String -> IO (Sealed (Hopefully (Named p) C(x))) - parse_remote fn = do ps <- gzFetchFilePS fn Cachable - return $ hopefullyNoParseError fn (readPatch ps) - parse_local fn = do ps <- gzReadFilePS fn - return $ hopefullyNoParseError fn (readPatch ps) - hopefullyNoParseError :: String -> Maybe (Sealed (a C(x)), b) -> Sealed (Hopefully a C(x)) + let parse inf = parse2 inf $ d "_darcs/patches" makeFilename inf + (mt, is) = case BC.break ((==) '\n') i of + (swt,pistr) | swt == BC.pack "Starting with tag:" -> + case readPatchIds pistr of + (t:ids) -> (Just t,reverse ids) + [] -> bug "bad inventory in readRepoPrivate" + _ -> (Nothing, reverse $ readPatchIds i) + Sealed ts <- unseal seal `fmap` unsafeInterleaveIO (read_ts parse mt) + Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is) + return $ seal (PatchSet ps ts) + where read_ts :: RepoPatch p => + (FORALL(b) PatchInfo -> IO (Sealed (PatchInfoAnd p C(b)))) + -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) C(Origin))) + read_ts _ Nothing = do endTedious k + return $ seal NilRL + read_ts parse (Just tag0) = + do debugMessage $ "Looking for inventory for:\n"++ show tag0 + i <- unsafeInterleaveIO $ + do x <- gzFetchFilePS (d"_darcs/inventories"makeFilename tag0) Uncachable + finishedOneIO k (show tag0) + return x + let (mt, is) = case BC.break ((==) '\n') i of + (swt,pistr) | swt == BC.pack "Starting with tag:" -> + case readPatchIds pistr of + (t:ids) -> (Just t,reverse ids) + [] -> bug "bad inventory in readRepoPrivate" + _ -> (Nothing, reverse $ readPatchIds i) + Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $ read_ts parse mt + Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is) + Sealed tag00 <- parse tag0 `catch` + \e -> return $ seal $ + patchInfoAndPatch tag0 $ unavailable $ show e + return $ seal $ Tagged tag00 Nothing ps :<: ts + parse2 :: RepoPatch p => PatchInfo -> FilePath + -> IO (Sealed (PatchInfoAnd p C(x))) + parse2 i fn = do ps <- unsafeInterleaveIO $ gzFetchFilePS fn Cachable + return $ patchInfoAndPatch i + `mapSeal` hopefullyNoParseError (toPath fn) (readPatch ps) + hopefullyNoParseError :: String -> Maybe (Sealed (Named a1dr C(x)), b) + -> Sealed (Hopefully (Named a1dr) C(x)) hopefullyNoParseError _ (Just (Sealed x, _)) = seal $ actually x hopefullyNoParseError s Nothing = seal $ unavailable $ "Couldn't parse file "++s - read_patches :: RepoPatch p => (FORALL(b) PatchInfo -> IO (Sealed (Hopefully (Named p) C(b)))) + read_patches :: RepoPatch p => + (FORALL(b) PatchInfo -> IO (Sealed (PatchInfoAnd p C(b)))) -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) C(x))) read_patches _ [] = return $ seal NilRL read_patches parse (i:is) = - lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) + lift2Sealed (:<:) (read_patches parse is) - (parse i `catch` \e -> return $ seal $ unavailable $ show e) - lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z)) - -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed (r C(x))) + (parse i `catch` \e -> + return $ seal $ patchInfoAndPatch i $ unavailable $ show e) + lift2Sealed :: (FORALL(y z) q C(y z) -> pp C(y) -> r C(z)) + -> IO (Sealed pp) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed r) lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy return $ seal $ f y x -read_patch_ids :: B.ByteString -> [PatchInfo] -read_patch_ids inv | B.null inv = [] -read_patch_ids inv = case readPatchInfo inv of - Just (pinfo,r) -> pinfo : read_patch_ids r +readPatchIds :: B.ByteString -> [PatchInfo] +readPatchIds inv | B.null inv = [] +readPatchIds inv = case readPatchInfo inv of + Just (pinfo,r) -> pinfo : readPatchIds r Nothing -> [] -read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)] -read_checkpoints d = do +readCheckpoints :: String -> IO [PatchInfo] +readCheckpoints d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable `catchall` return B.empty - pis <- return $ reverse $ read_patch_ids pistr - slurpies <- sequence $ map (fetch_checkpoint realdir) pis - return $ zip pis slurpies - where fetch_checkpoint r pinfo = - unsafeInterleaveIO $ do - pstr <- gzFetchFilePS - (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable - case fst `liftM` readPatch_ pstr of - Nothing -> return Nothing - Just (Sealed p) -> return $ applyToSlurpy p empty_slurpy - readPatch_ :: B.ByteString -> Maybe (Sealed (Named Patch C(x)), B.ByteString) - readPatch_ = readPatch - -remove_from_checkpoint_inventory :: RepoPatch p => FL (Named p) C(x y) -> IO () -remove_from_checkpoint_inventory ps = do - -- only tags can be checkpoints - let pinfos = filter is_tag $ mapFL patch2patchinfo ps - unless (null pinfos) $ do - createDirectoryIfMissing False (darcsdir++"/checkpoints") - cpi <- (map fst) `liftM` read_checkpoints "." - writeDocBinFile (darcsdir++"/checkpoints/inventory") $ - format_inventory $ reverse $ filter (`notElem` pinfos) cpi + pis <- return $ reverse $ readPatchIds pistr + return pis \end{code} The \verb!_darcs! directory also contains a directory called diff -ruN darcs-2.4.4/src/Darcs/Repository/Format.hs darcs-2.5/src/Darcs/Repository/Format.hs --- darcs-2.4.4/src/Darcs/Repository/Format.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Format.hs 2010-10-24 08:29:26.000000000 -0700 @@ -107,7 +107,7 @@ readfromAndWritetoProblem :: RepoFormat -> RepoFormat -> Maybe String readfromAndWritetoProblem inrf outrf | formatHas Darcs2 inrf /= formatHas Darcs2 outrf - = Just "Cannot mix darcs-2 repositories with older formats" + = Just "Cannot mix darcs-2 repositories with older formats" | otherwise = msum [readProblem inrf, writeProblem outrf] diff -ruN darcs-2.4.4/src/Darcs/Repository/HashedIO.hs darcs-2.5/src/Darcs/Repository/HashedIO.hs --- darcs-2.4.4/src/Darcs/Repository/HashedIO.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/HashedIO.hs 2010-10-24 08:29:26.000000000 -0700 @@ -19,41 +19,42 @@ #include "gadts.h" -module Darcs.Repository.HashedIO ( HashedIO, applyHashed, - copyHashed, copyPartialsHashed, listHashedContents, - slurpHashedPristine, writeHashedPristine, - clean_hashdir ) where +module Darcs.Repository.HashedIO ( HashedIO, + copyHashed, copyPartialsHashed, + cleanHashdir ) where import Darcs.Global ( darcsdir ) import qualified Data.Set as Set -import qualified Data.Map as Map import System.Directory ( getDirectoryContents, createDirectoryIfMissing ) import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift ) import Control.Monad ( when ) import Control.Applicative ( (<$>) ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO ( hPutStrLn, stderr ) -import Darcs.SlurpDirectory.Internal ( Slurpy(..), SlurpyContents(..), map_to_slurpies, slurpies_to_map ) -import Darcs.SlurpDirectory ( withSlurpy, undefined_size ) -import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache, +import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, writeFileUsingCache, peekInCache, speculateFileUsingCache, okayHash, cleanCachesWithHint, HashedDir(..), hashedDir ) import Darcs.Patch ( Patchy, apply ) import Darcs.RepoPath ( FilePathLike, toFilePath ) import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) -import Darcs.Flags ( DarcsFlag, Compression( .. ), compression ) +import Darcs.Flags ( DarcsFlag, Compression( .. ) ) import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist ) import Darcs.Utils ( withCurrentDirectory ) -import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress ) -import Darcs.Patch.FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn, - break_on_dir, own_name, superName ) +import Progress ( debugMessage, tediousSize, finishedOneIO ) +import Darcs.Patch.FileName ( FileName, normPath, fp2fn, fn2fp, fn2niceps, niceps2fn, + breakOnDir, ownName, superName ) import ByteStringUtils ( linesPS, unlinesPS ) import qualified Data.ByteString as B (ByteString, length, empty) import qualified Data.ByteString.Char8 as BC (unpack, pack) -import SHA1 ( sha1PS ) +import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize, readDarcsHashed, + writeDarcsHashed, readDarcsHashedDir, darcsLocation, + decodeDarcsHash, decodeDarcsSize ) +import Storage.Hashed.Tree( treeHash, ItemType(..) ) +import Storage.Hashed.Hash( encodeBase16, Hash(..) ) -- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir, -- fetching it from 'Cache' @c@ if needed. @@ -62,19 +63,6 @@ do debugMessage $ "Reading hash file "++hash++" from "++(hashedDir subdir)++"/" fetchFileUsingCache c subdir hash -applyHashed :: Patchy q => Cache -> [DarcsFlag] -> String -> q C(x y) -> IO String -applyHashed c fs h p = do s <- slurpHashedPristine c (compression fs) h - let ms = withSlurpy s $ apply fs p - case ms of - Left e -> fail e - Right (s', ()) -> writeHashedPristine c (compression fs) s' -{- -applyHashed c fs h p = do (_,hd) <- runStateT (apply fs p) $ - HashDir { permissions = RW, cache = c, - options = fs, rootHash = h } - return $ rootHash hd --} - data HashDir r p = HashDir { permissions :: !r, cache :: !Cache, compress :: !Compression, rootHash :: !String } type HashedIO r p = StateT (HashDir r p) IO @@ -99,7 +87,7 @@ _ -> return False mInCurrentDirectory fn j | fn' == fp2fn "" = j | otherwise = - case break_on_dir fn' of + case breakOnDir fn' of Nothing -> do c <- readroot case geta D fn' c of Nothing -> fail "dir doesn't exist mInCurrentDirectory..." @@ -108,11 +96,11 @@ case geta D d c of Nothing -> fail "dir doesn't exist..." Just h -> inh h $ mInCurrentDirectory fn'' j - where fn' = norm_path fn + where fn' = normPath fn mGetDirectoryContents = map (\ (_,f,_) -> f) `fmap` readroot mReadFilePS fn = mInCurrentDirectory (superName fn) $ do c <- readroot - case geta F (own_name fn) c of + case geta F (ownName fn) c of Nothing -> fail $ " file don't exist... "++ fn2fp fn Just h -> readhash h @@ -120,7 +108,7 @@ mWithCurrentDirectory fn j | fn' == fp2fn "" = j | otherwise = - case break_on_dir fn' of + case breakOnDir fn' of Nothing -> do c <- readroot case geta D fn' c of Nothing -> fail "dir doesn't exist in mWithCurrentDirectory..." @@ -133,7 +121,7 @@ Just h -> do (h',x) <- withh h $ mWithCurrentDirectory fn'' j writeroot $ seta D d h' c return x - where fn' = norm_path fn + where fn' = normPath fn mSetFileExecutable _ _ = return () mWriteFilePS fn ps = do mexists <- identifyThing fn case mexists of @@ -160,22 +148,22 @@ identifyThing :: FileName -> HashedIO r p (Maybe (ObjType,String)) identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash return $ Just (D, h) - | otherwise = case break_on_dir fn' of + | otherwise = case breakOnDir fn' of Nothing -> getany fn' `fmap` readroot Just (d,fn'') -> do c <- readroot case geta D d c of Nothing -> return Nothing Just h -> inh h $ identifyThing fn'' - where fn' = norm_path fn + where fn' = normPath fn makeThing :: FileName -> (ObjType,String) -> HashedIO RW p () -makeThing fn (o,h) = mWithCurrentDirectory (superName $ norm_path fn) $ - seta o (own_name $ norm_path fn) h `fmap` readroot >>= writeroot +makeThing fn (o,h) = mWithCurrentDirectory (superName $ normPath fn) $ + seta o (ownName $ normPath fn) h `fmap` readroot >>= writeroot rmThing :: FileName -> HashedIO RW p () -rmThing fn = mWithCurrentDirectory (superName $ norm_path fn) $ +rmThing fn = mWithCurrentDirectory (superName $ normPath fn) $ do c <- readroot - let c' = filter (\(_,x,_)->x/= own_name (norm_path fn)) c + let c' = filter (\(_,x,_)->x/= ownName (normPath fn)) c if length c' == length c - 1 then writeroot c' else fail "obj doesn't exist in rmThing" @@ -186,10 +174,6 @@ let (_,out) = z return out -readTediousHash :: String -> String -> HashedIO r p B.ByteString -readTediousHash k h = do lift $ finishedOneIO k h - readhash h - withh :: String -> HashedIO RW p a -> HashedIO RW p (String,a) withh h j = do hd <- get put $ hd { rootHash = h } @@ -205,13 +189,6 @@ put hd return x -safeInterleave :: HashedIO RO p a -> HashedIO r p a -safeInterleave job = do HashDir _ c compr h <- get - z <- lift $ unsafeInterleaveIO $ runStateT job - (HashDir { permissions = RO, cache = c, compress = compr, rootHash = h }) - let (x,_) = z - return x - readroot :: HashedIO r p [(ObjType, FileName, String)] readroot = do haveitalready <- peekroot cc <- gets rootHash >>= readdir @@ -268,59 +245,6 @@ compr <- gets compress lift $ writeFileUsingCache c compr HashedPristineDir ps --- |Create a Slurpy representing the pristine content determined by the --- supplied root hash (which uniquely determines the pristine tree) -slurpHashedPristine :: Cache -> Compression -> String -> IO Slurpy -slurpHashedPristine c compr h = fst `fmap` runStateT slh - (HashDir { permissions = RO, cache = c, - compress = compr, rootHash = h }) - -slh :: HashedIO r p Slurpy -slh = do c <- readroot - hroot <- gets rootHash - lift $ beginTedious k - safeInterleave $ (Slurpy rootdir . SlurpDir (Just hroot) . slurpies_to_map) `fmap` mapM sl c - where sl (F,n,h) = do ps <- safeInterleave $ readTediousHash k h - let len = if length h == 75 then read (take 10 h) - else undefined_size - return $ Slurpy n $ SlurpFile (Just h, 0, len) ps - sl (D,n,h) = inh h $ do c <- readroot - lift $ tediousSize k (length c) - lift $ finishedOneIO k h - (Slurpy n . SlurpDir (Just h) . slurpies_to_map) `fmap` mapM sl c - k = "Reading pristine" - -rootdir :: FileName -rootdir = fp2fn "." - --- |Write contents of a Slurpy into hashed pristine. Only files that have not --- not yet been hashed (that is, the hash corresponding to their content is --- already present in hashed pristine) will be written out, so it is efficient --- to use this function to update existing pristine cache. Note that the --- pristine root hash will *not* be updated. You need to do that manually. -writeHashedPristine :: Cache -> Compression -> Slurpy -> IO String -writeHashedPristine c compr sl = - do beginTedious k - h <- fst `fmap` runStateT (hsl sl) - (HashDir { permissions = RW, cache = c, - compress = compr, rootHash = sha1PS B.empty }) - endTedious k - return h - where hsl (Slurpy _ (SlurpDir (Just h) _)) = return h - hsl (Slurpy _ (SlurpDir Nothing ss)) = do lift $ tediousSize k (Map.size ss) - mapM hs (map_to_slurpies ss) >>= writedir - hsl (Slurpy _ (SlurpFile (Just h,_,_) _)) = return h - hsl (Slurpy _ (SlurpFile _ x)) = writeHashFile x - hs (Slurpy d (SlurpDir (Just h) _)) = progress k $ return (D, d, h) - hs s@(Slurpy d (SlurpDir Nothing _)) = do h <- hsl s - lift $ finishedOneIO k h - return (D, d, h) - hs (Slurpy f (SlurpFile (Just h,_,_) _)) = progress k $ return (F, f, h) - hs s@(Slurpy f (SlurpFile _ _)) = do h <- hsl s - lift $ finishedOneIO k h - return (F, f, h) - k = "Writing pristine" - copyHashed :: String -> Cache -> Compression -> String -> IO () copyHashed k c compr z = do runStateT cph $ HashDir { permissions = RO, cache = c, compress = compr, rootHash = z } @@ -355,28 +279,18 @@ lift $ writeAtomicFilePS (fn2fp f) ps Nothing -> return () --- | Seems to list all hashes reachable from "root". -listHashedContents :: String -> Cache -> String -> IO [String] -listHashedContents k c root = - do beginTedious k - tediousSize k 1 - x <- fst `fmap` runStateT (lhc (D,fp2fn ".",root)) (HashDir RO c NoCompression root) - endTedious k - return x - where lhc :: (ObjType, FileName, String) -> HashedIO r a [String] - lhc (D,dname,d) = do xs <- inh d $ readroot - lift $ finishedOneIO k (fn2fp dname) - lift $ tediousSize k (length $ filter (\(x,_,_) -> x == D) xs) - hcxs <- mapM lhc xs - return (d:concat hcxs) - lhc (F,_,h) = return [h] - -clean_hashdir :: Cache -> HashedDir -> [String] -> IO () -clean_hashdir c dir_ hashroots = +cleanHashdir :: Cache -> HashedDir -> [String] -> IO () +cleanHashdir c dir_ hashroots = do -- we'll remove obsolete bits of "dir" debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..." let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/" - hs <- set . concat <$> mapM (listHashedContents "cleaning up..." c) hashroots + listone h = do let size = decodeDarcsSize $ BC.pack h + hash = decodeDarcsHash $ BC.pack h + x <- readDarcsHashedDir hashdir (size, hash) + let subs = [ fst $ darcsLocation "" (s, h) | (TreeType, _, s, h) <- x ] + hashes = h : [ fst $ darcsLocation "" (s, h) | (_, _, s, h) <- x ] + (hashes++) . concat <$> mapM listone subs + hs <- set . concat <$> mapM listone hashroots fs <- set . filter okayHash <$> getDirectoryContents hashdir mapM_ (removeFileMayNotExist . (hashdir++)) (unset $ fs `Set.difference` hs) -- and also clean out any global caches. diff -ruN darcs-2.4.4/src/Darcs/Repository/HashedRepo.hs darcs-2.5/src/Darcs/Repository/HashedRepo.hs --- darcs-2.4.4/src/Darcs/Repository/HashedRepo.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/HashedRepo.hs 2010-10-24 08:29:26.000000000 -0700 @@ -19,42 +19,46 @@ #include "gadts.h" -module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes, - slurp_pristine, clean_pristine, - copy_pristine, copy_partials_pristine, - apply_to_tentative_pristine, - add_to_tentative_inventory, remove_from_tentative_inventory, - read_repo, read_tentative_repo, write_and_read_patch, - write_tentative_inventory, copy_repo, slurp_all_but_darcs, - readHashedPristineRoot, pris2inv +module Darcs.Repository.HashedRepo ( revertTentativeChanges, finalizeTentativeChanges, + cleanPristine, + copyPristine, copyPartialsPristine, + applyToTentativePristine, + addToTentativeInventory, removeFromTentativeInventory, + readRepo, readTentativeRepo, writeAndReadPatch, + writeTentativeInventory, copyRepo, + readHashedPristineRoot, pris2inv, copySources ) where -import System.Directory ( doesFileExist, createDirectoryIfMissing ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath.Posix( () ) import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO ( stderr, hPutStrLn ) -import Data.List ( delete ) +import Data.List ( delete, filter ) import Control.Monad ( unless ) import Workaround ( renameFile ) import Darcs.Flags ( DarcsFlag, Compression ) -import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif import Darcs.RepoPath ( FilePathLike, ioAbsoluteOrRemote, toPath ) -import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, speculateFileUsingCache, - writeFileUsingCache, +import Darcs.Repository.Cache ( Cache(..), CacheLoc(..), fetchFileUsingCache, + speculateFilesUsingCache, writeFileUsingCache, unionCaches, repo2cache, okayHash, takeHash, - HashedDir(..), hashedDir ) -import Darcs.Repository.HashedIO ( applyHashed, slurpHashedPristine, - copyHashed, copyPartialsHashed, - clean_hashdir ) -import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) -import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, n2pia, info, + HashedDir(..),WritableOrNot(..), hashedDir, + peekInCache ) +import qualified Darcs.Repository.Cache as DarcsCache +import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed, + cleanHashdir ) +import Darcs.Repository.InternalTypes ( Repository(..), extractCache, modifyCache ) +import Darcs.Repository.Prefs ( globalCacheDir ) +import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, info, extractHash, createHashed ) -import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, slurp_remove, slurp ) -import Darcs.Patch ( RepoPatch, Patchy, Named, showPatch, patch2patchinfo, readPatch ) -import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset ) -import Darcs.Patch.Info ( PatchInfo, showPatchInfo, human_friendly, readPatchInfo ) -import Darcs.Witnesses.Ordered ( unsafeCoerceP, (:<)(..) ) -import Darcs.Patch.FileName ( fp2fn ) +import Darcs.Patch ( RepoPatch, Patchy, showPatch, readPatch, apply ) +import Darcs.Patch.Depends ( commuteToEnd, slightlyOptimizePatchset ) +import Darcs.Patch.Info ( PatchInfo, showPatchInfo, humanFriendly, readPatchInfo ) +import Darcs.Witnesses.Ordered ( unsafeCoerceP, reverseRL, reverseFL, (+<+) ) import ByteStringUtils ( gzReadFilePS, dropSpace ) import qualified Data.ByteString as B (null, length, empty @@ -62,30 +66,62 @@ import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack) import Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS ) -import SHA1 ( sha1PS ) +import Crypt.SHA256 ( sha256sum ) import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, Cachable( Uncachable ) ) import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile ) import Darcs.Utils ( withCurrentDirectory ) -import Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO ) +import Progress ( beginTedious, endTedious, debugMessage, finishedOneIO ) #include "impossible.h" -import Darcs.Witnesses.Ordered ( FL(..), RL(..), - mapRL, mapFL, lengthRL ) -import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>>)(..), mapRL, mapFL ) +import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal ) import Darcs.Global ( darcsdir ) -revert_tentative_changes :: IO () -revert_tentative_changes = +import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize, readDarcsHashed, + writeDarcsHashed, readDarcsHashedDir, darcsLocation, + decodeDarcsHash, decodeDarcsSize ) +import Storage.Hashed.Tree( treeHash, ItemType(..) ) +import Storage.Hashed.Hash( encodeBase16, Hash(..) ) + + +applyHashed' fs root p = do case root of + (SHA256 _) -> return () + _ -> fail $ "Cannot handle hash: " ++ show root + s <- readDarcsHashedNosize "_darcs/pristine.hashed" root + (_, t) <- (hashedTreeIO (apply fs p) s "_darcs/pristine.hashed") + return $ BC.unpack . encodeBase16 $ treeHash t + +applyHashed :: Patchy q => [DarcsFlag] -> String -> q C(x y) -> IO String +applyHashed fs h p = applyHashed' fs hash p `catch` \_ -> do + hPutStrLn stderr warn + inv <- gzReadFilePS invpath + let oldroot = BC.pack $ inv2pris inv + oldroot_hash = decodeDarcsHash oldroot + oldroot_size = decodeDarcsSize oldroot + old <- readDarcsHashed "_darcs/pristine.hashed" (oldroot_size, oldroot_hash) + root <- writeDarcsHashed old "_darcs/pristine.hashed" + let newroot = BC.unpack $ encodeBase16 root + writeDocBinFile invpath $ pris2inv newroot inv + cleanHashdir (Ca []) HashedPristineDir [newroot] + hPutStrLn stderr "Pristine conversion done..." + applyHashed' fs root p + where invpath = darcsdir ++ "/hashed_inventory" + hash = decodeDarcsHash $ BC.pack h + warn = "WARNING: Doing a one-time conversion of pristine format.\n" ++ + "This may take a while. The new format is backwards-compatible." + +revertTentativeChanges :: IO () +revertTentativeChanges = do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory") i <- gzReadFilePS (darcsdir++"/hashed_inventory") writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i -finalize_tentative_changes :: RepoPatch p => Repository p C(r u t) -> Compression -> IO () -finalize_tentative_changes r compr = +finalizeTentativeChanges :: RepoPatch p => Repository p C(r u t) -> Compression -> IO () +finalizeTentativeChanges r compr = do let t = darcsdir++"/tentative_hashed_inventory" -- first let's optimize it... debugMessage "Optimizing the inventory..." - ps <- read_tentative_repo r "." - write_tentative_inventory (extractCache r) compr ps + ps <- readTentativeRepo r "." + writeTentativeInventory (extractCache r) compr ps -- then we'll add in the pristine cache, i <- gzReadFilePS t p <- gzReadFilePS $ darcsdir++"/tentative_pristine" @@ -101,80 +137,84 @@ i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\_ -> return Nothing) return $ inv2pris `fmap` i -clean_pristine :: Repository p C(r u t) -> IO () -clean_pristine r@(Repo d _ _ _) = withCurrentDirectory d $ +cleanPristine :: Repository p C(r u t) -> IO () +cleanPristine r@(Repo d _ _ _) = withCurrentDirectory d $ do -- we'll remove obsolete bits of our pristine cache debugMessage "Cleaning out the pristine cache..." i <- gzReadFilePS (darcsdir++"/hashed_inventory") - clean_hashdir (extractCache r) HashedPristineDir [inv2pris i] + cleanHashdir (extractCache r) HashedPristineDir [inv2pris i] -add_to_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) -> IO FilePath -add_to_tentative_inventory c compr p = - do hash <- snd `fmap` write_patch_if_necesary c compr p +addToTentativeInventory :: RepoPatch p => Cache -> Compression + -> PatchInfoAnd p C(x y) -> IO FilePath +addToTentativeInventory c compr p = + do hash <- snd `fmap` writePatchIfNecesary c compr p appendDocBinFile (darcsdir++"/tentative_hashed_inventory") $ showPatchInfo $ info p appendBinFile (darcsdir++"/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n" return $ darcsdir++"/patches/" ++ hash -remove_from_tentative_inventory :: RepoPatch p => Repository p C(r u t) -> Compression - -> FL (Named p) C(x t) -> IO () -remove_from_tentative_inventory repo compr to_remove = +removeFromTentativeInventory :: RepoPatch p => Repository p C(r u t) -> Compression + -> FL (PatchInfoAnd p) C(x t) -> IO () +removeFromTentativeInventory repo compr to_remove = -- FIXME: This algorithm should be *far* simpler. All we need do is -- to to remove the patches from a patchset and then write that -- patchset. The commutation behavior of PatchInfoAnd should track -- which patches need to be rewritten for us. - do allpatches <- read_tentative_repo repo "." - skipped :< _ <- return $ commute_to_end to_remove allpatches - okay <- simple_remove_from_tentative_inventory repo compr - (mapFL patch2patchinfo to_remove ++ mapFL patch2patchinfo skipped) - unless okay $ bug "bug in HashedRepo.remove_from_tentative_inventory" - sequence_ $ mapFL (add_to_tentative_inventory (extractCache repo) compr . n2pia) skipped + do allpatches <- readTentativeRepo repo "." + _ :>> skipped <- return $ commuteToEnd (reverseFL to_remove) allpatches + okay <- simpleRemoveFromTentativeInventory repo compr + (mapFL info to_remove ++ mapRL info skipped) + unless okay $ bug "bug in HashedRepo.removeFromTentativeInventory" + sequence_ $ mapFL (addToTentativeInventory (extractCache repo) compr) (reverseRL skipped) -simple_remove_from_tentative_inventory :: forall p C(r u t). RepoPatch p => +simpleRemoveFromTentativeInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> Compression -> [PatchInfo] -> IO Bool -simple_remove_from_tentative_inventory repo compr pis = do - inv <- read_tentative_repo repo "." +simpleRemoveFromTentativeInventory repo compr pis = do + inv <- readTentativeRepo repo "." case cut_inv pis inv of Nothing -> return False - Just (Sealed inv') -> do write_tentative_inventory (extractCache repo) compr inv' + Just (Sealed inv') -> do writeTentativeInventory (extractCache repo) compr inv' return True - where cut_inv :: [PatchInfo] -> PatchSet p C(x) -> Maybe (SealedPatchSet p) + where cut_inv :: [PatchInfo] -> PatchSet p C(start x) -> Maybe (SealedPatchSet p C(start)) cut_inv [] x = Just $ seal x - cut_inv x (NilRL:<:rs) = cut_inv x rs - cut_inv xs ((hp:<:r):<:rs) | info hp `elem` xs = cut_inv (info hp `delete` xs) (r:<:rs) + cut_inv x (PatchSet NilRL (Tagged t _ ps :<: ts)) + = cut_inv x (PatchSet (t :<: ps) ts) + cut_inv xs (PatchSet (hp:<:r) ts) + | info hp `elem` xs = cut_inv (info hp `delete` xs) (PatchSet r ts) cut_inv _ _ = Nothing writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String writeHashFile c compr subdir d = do debugMessage $ "Writing hash file to "++(hashedDir subdir) writeFileUsingCache c compr subdir $ renderPS d -read_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(r)) -read_repo repo d = do +readRepo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(Origin r)) +readRepo repo d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d - Sealed ps <- read_repo_private repo realdir "hashed_inventory" `catch` + Sealed ps <- readRepoPrivate (extractCache repo) realdir "hashed_inventory" `catch` (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e) return $ unsafeCoerceP ps -read_tentative_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(t)) -read_tentative_repo repo d = do +readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(Origin t)) +readTentativeRepo repo d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d - Sealed ps <- read_repo_private repo realdir "tentative_hashed_inventory" `catch` + Sealed ps <- readRepoPrivate (extractCache repo) realdir "tentative_hashed_inventory" `catch` (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e) return $ unsafeCoerceP ps -read_repo_private :: RepoPatch p => Repository p C(r u t) - -> FilePath -> FilePath -> IO (SealedPatchSet p) -read_repo_private repo d iname = - do inventories <- read_inventory_private repo (d++"/"++darcsdir) iname - parseinvs inventories - where read_patches :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x))) +readRepoPrivate :: RepoPatch p => Cache -> FilePath -> FilePath -> IO (SealedPatchSet p C(Origin)) +readRepoPrivate cache d iname = + do inventory <- readInventoryPrivate cache (d "_darcs") iname + parseinvs inventory + where read_patches :: RepoPatch p => [(PatchInfo, String)] + -> IO (Sealed (RL (PatchInfoAnd p) C(x))) read_patches [] = return $ seal NilRL read_patches allis@((i1,h1):is1) = lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest) (rp is1) (createHashed h1 (const $ speculate h1 allis >> parse i1 h1)) - where rp :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x))) + where rp :: RepoPatch p => [(PatchInfo, String)] + -> IO (Sealed (RL (PatchInfoAnd p) C(x))) rp [] = return $ seal NilRL rp [(i,h),(il,hl)] = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) @@ -183,85 +223,145 @@ rp ((i,h):is) = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) (rp is) (createHashed h (parse i)) + read_tag :: RepoPatch p => (PatchInfo, String) -> IO (Sealed (PatchInfoAnd p C(x))) + read_tag (i,h) = mapSeal (patchInfoAndPatch i) `fmap` createHashed h (parse i) speculate :: String -> [(PatchInfo, String)] -> IO () - speculate h is = do already_got_one <- doesFileExist (d++"/"++darcsdir++"/patches/"++h) - unless already_got_one $ - mapM_ (speculateFileUsingCache (extractCache repo) HashedPatchesDir . snd) is + speculate h is = + do already_got_one <- peekInCache cache HashedPatchesDir h + unless already_got_one $ + speculateFilesUsingCache cache HashedPatchesDir (map snd is) parse :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x))) - parse i h = do debugMessage ("Reading patch file: "++ show (human_friendly i)) - (fn,ps) <- fetchFileUsingCache (extractCache repo) HashedPatchesDir h + parse i h = do debugMessage ("Reading patch file: "++ show (humanFriendly i)) + (fn,ps) <- fetchFileUsingCache cache HashedPatchesDir h case readPatch ps of Just (p,_) -> return p Nothing -> fail $ unlines ["Couldn't parse file "++fn, "which is patch", - renderString $ human_friendly i] - parseinvs :: RepoPatch p => [[(PatchInfo, String)]] -> IO (SealedPatchSet p) - parseinvs [] = return $ seal NilRL - parseinvs (i:is) = lift2Sealed (:<:) (parseinvs is) (read_patches i) + renderString $ humanFriendly i] + parseinvs :: RepoPatch p => (Maybe String, [(PatchInfo, String)]) + -> IO (SealedPatchSet p C(Origin)) + parseinvs (Nothing, ris) = mapSeal (\ps -> PatchSet ps NilRL) + `fmap` (read_patches $ reverse ris) + parseinvs (Just h, []) = bug $ "bad inventory "++h++" (no tag) in parseinvs!" + parseinvs (Just h, t:ris) = do Sealed ts <- unseal seal `fmap` + unsafeInterleaveIO (read_ts t h) + Sealed ps <- unseal seal `fmap` + unsafeInterleaveIO (read_patches $ + reverse ris) + return $ seal $ PatchSet ps ts + read_ts :: RepoPatch p => (PatchInfo, String) -> String -> IO (Sealed (RL (Tagged p) C(Origin))) + read_ts tag0 h0 = + do contents <- unsafeInterleaveIO $ readTaggedInventory cache h0 + let is = reverse $ case contents of (Just _, _:ris0) -> ris0 + (Nothing, ris0) -> ris0 + (Just _, []) -> bug "inventory without tag!!!!" + Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $ + case contents of + (Just h', t':_) -> read_ts t' h' + (Just _, []) -> bug "inventory without tag!!!!" + (Nothing, _) -> return $ seal NilRL + Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches is) + Sealed tag00 <- read_tag tag0 + return $ seal $ Tagged tag00 (Just h0) ps :<: ts lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z)) - -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed (r C(x))) - lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox - Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy + -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) + -> IO (Sealed (r C(x))) + lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` + unsafeInterleaveIO iox + Sealed y <- unseal seal `fmap` + unsafeInterleaveIO ioy return $ seal $ f y x -write_and_read_patch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) +readTaggedInventory :: Cache -> String -> IO (Maybe String, [(PatchInfo, String)]) +readTaggedInventory cache ihash = do + (fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash + let i = skipPristine i_and_p + (rest,str) <- case BC.break ((==)'\n') i of + (swt,pistr) | swt == BC.pack "Starting with inventory:" -> + case BC.break ((==)'\n') $ B.tail pistr of + (h,thisinv) | okayHash hash -> return (Just hash, thisinv) + where hash = BC.unpack h + _ -> fail $ "Bad hash in file " ++ fn + _ -> return (Nothing,i) + return (rest, readPatchIds str) + +copyRepo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO () +copyRepo repo@(Repo outr _ _ _) opts inr = do + createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories") + copyFileOrUrl opts (inr++"/"++darcsdir++"/hashed_inventory") (outr++"/"++darcsdir++"/hashed_inventory") + Uncachable -- no need to copy anything but hashed_inventory! + copySources repo inr + debugMessage "Done copying hashed inventory." + +copySources :: RepoPatch p => Repository p C(r u t) -> String -> IO () +copySources repo@(Repo outr _ _ _) inr = do + let repoCache = extractCache $ modifyCache repo dropGlobalCaches + appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` repoCache ) + where + dropGlobalCaches (Ca cache) = Ca $ filter notGlobalCache cache + notGlobalCache xs = case xs of + Cache DarcsCache.Directory _ _ -> False + _ -> True + +writeAndReadPatch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y)) -write_and_read_patch c compr p = do (i,h) <- write_patch_if_necesary c compr p +writeAndReadPatch c compr p = do (i,h) <- writePatchIfNecesary c compr p unsafeInterleaveIO $ readp h i - where parse i h = do debugMessage ("Rereading patch file: "++ show (human_friendly i)) + where parse i h = do debugMessage ("Rereading patch file: "++ show (humanFriendly i)) (fn,ps) <- fetchFileUsingCache c HashedPatchesDir h case readPatch ps of Just (x,_) -> return x Nothing -> fail $ unlines ["Couldn't parse patch file "++fn, "which is", - renderString $ human_friendly i] + renderString $ humanFriendly i] readp h i = do Sealed x <- createHashed h (parse i) return $ patchInfoAndPatch i $ unsafeCoerceP x -write_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(x) -> IO () -write_tentative_inventory c compr = write_either_inventory c compr "tentative_hashed_inventory" - -copy_repo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO () -copy_repo repo@(Repo outr _ _ _) opts inr = do - createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories") - copyFileOrUrl opts (inr++"/"++darcsdir++"/hashed_inventory") (outr++"/"++darcsdir++"/hashed_inventory") - Uncachable -- no need to copy anything but hashed_inventory! - appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` extractCache repo) - debugMessage "Done copying hashed inventory." +writeTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(Origin x) -> IO () +writeTentativeInventory cache compr = writeEitherInventory cache compr "tentative_hashed_inventory" -write_either_inventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(x) -> IO () -write_either_inventory c compr iname x = - do createDirectoryIfMissing False $ darcsdir++"/inventories" +writeEitherInventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(Origin x) -> IO () +writeEitherInventory cache compr iname x = + do debugMessage "in writeEitherInventory..." + createDirectoryIfMissing False $ "_darcs/inventories" let k = "Writing inventory" beginTedious k - tediousSize k (lengthRL x) - hsh <- write_inventory_private k c compr $ slightly_optimize_patchset x + hsh <- writeInventoryPrivate cache k compr $ slightlyOptimizePatchset x endTedious k + debugMessage "still in writeEitherInventory..." case hsh of - Nothing -> writeBinFile (darcsdir++"/"++iname) "" - Just h -> gzReadFilePS (darcsdir++"/inventories/"++h) >>= writeAtomicFilePS (darcsdir++"/"++iname) - -write_inventory_private :: RepoPatch p => String -> Cache -> Compression - -> PatchSet p C(x) -> IO (Maybe String) -write_inventory_private _ _ _ NilRL = return Nothing -write_inventory_private _ _ _ (NilRL:<:NilRL) = return Nothing -write_inventory_private _ _ _ (NilRL:<:_) = -- This shouldn't be possible, so best to check... - bug "malformed PatchSet in HashedRepo.write_inventory_private" -write_inventory_private k c compr (x:<:xs) = - do resthash <- write_inventory_private k c compr xs - finishedOneIO k (case resthash of Nothing -> ""; Just h -> h) - inventory <- sequence $ mapRL (write_patch_if_necesary c compr) x + Nothing -> writeBinFile ("_darcs" iname) "" + Just h -> fmap snd (fetchFileUsingCache cache HashedInventoriesDir h) + >>= writeAtomicFilePS ("_darcs" iname) + +writeInventoryPrivate :: RepoPatch p => Cache -> String -> Compression + -> PatchSet p C(Origin x) -> IO (Maybe String) +writeInventoryPrivate _ _ _ (PatchSet NilRL NilRL) = return Nothing +writeInventoryPrivate cache _ compr (PatchSet x NilRL) = + do inventory <- sequence $ mapRL (writePatchIfNecesary cache compr) x + let inventorylist = hcat (map pihash $ reverse inventory) + hash <- writeHashFile cache compr HashedInventoriesDir inventorylist + return $ Just hash +writeInventoryPrivate cache k compr (PatchSet x xs@(Tagged t _ _ :<: _)) = + do resthash <- write_ts xs + finishedOneIO k $ maybe "" id resthash + inventory <- sequence $ mapRL (writePatchIfNecesary cache compr) (x+<+t:<:NilRL) let inventorylist = hcat (map pihash $ reverse inventory) - inventorycontents = case resthash of - Just lasthash -> text ("Starting with inventory:\n"++lasthash) $$ - inventorylist - _ -> inventorylist - hash <- writeHashFile c compr HashedInventoriesDir inventorycontents + inventorycontents = + case resthash of + Just h -> text ("Starting with inventory:\n"++h) $$ inventorylist + Nothing -> inventorylist + hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents return $ Just hash + where write_ts :: RepoPatch p => RL (Tagged p) C(Origin x) -> IO (Maybe String) + write_ts (Tagged _ (Just h) _ :<: _) = return (Just h) -- already written! + write_ts (Tagged _ Nothing pps :<: tts) = + writeInventoryPrivate cache k compr $ PatchSet pps tts + write_ts NilRL = return Nothing -write_patch_if_necesary :: RepoPatch p => Cache -> Compression +writePatchIfNecesary :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) -> IO (PatchInfo, String) -write_patch_if_necesary c compr hp = +writePatchIfNecesary c compr hp = seq infohp $ case extractHash hp of Right h -> return (infohp, h) Left p -> (\h -> (infohp, h)) `fmap` @@ -271,44 +371,41 @@ pihash :: (PatchInfo,String) -> Doc pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n") -read_inventory_private :: Repository p C(r u t) -> String -> String - -> IO [[(PatchInfo, String)]] -read_inventory_private repo d iname = do - i <- skip_pristine `fmap` fetchFilePS (d++"/"++iname) Uncachable +readInventoryPrivate :: Cache -> String -> String -> IO (Maybe String, [(PatchInfo, String)]) +readInventoryPrivate _ d iname = do + i <- skipPristine `fmap` fetchFilePS (d iname) Uncachable (rest,str) <- case BC.break ((==)'\n') i of (swt,pistr) | swt == BC.pack "Starting with inventory:" -> case BC.break ((==)'\n') $ B.tail pistr of - (h,thisinv) | okayHash $ BC.unpack h -> - do r <- unsafeInterleaveIO $ read_inventories - (extractCache repo) (BC.unpack h) -- don't unpack twice! - return (r,thisinv) - _ -> fail $ "Bad hash in " ++ d ++ "/"++darcsdir++"/" ++ iname - _ -> return ([],i) - return $ reverse (read_patch_ids str) : rest + (h,thisinv) | okayHash hash -> return (Just hash, thisinv) + where hash = BC.unpack h + _ -> fail $ "Bad hash in " ++ toPath d ++ "/_darcs/" ++ iname + _ -> return (Nothing, i) + return (rest, readPatchIds str) -read_inventories :: Cache -> String -> IO [[(PatchInfo, String)]] -read_inventories cache ihash = do +readInventories :: Cache -> String -> IO [[(PatchInfo, String)]] +readInventories cache ihash = do (fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash - let i = skip_pristine i_and_p + let i = skipPristine i_and_p (rest,str) <- case BC.break ((==)'\n') i of (swt,pistr) | swt == BC.pack "Starting with inventory:" -> case BC.break ((==)'\n') $ B.tail pistr of (h,thisinv) | okayHash $ BC.unpack h -> do r <- unsafeInterleaveIO $ - read_inventories cache (BC.unpack h) -- again. no. + readInventories cache (BC.unpack h) -- again. no. return (r,thisinv) _ -> fail $ "Bad hash in file " ++ fn _ -> return ([],i) - return $ reverse (read_patch_ids str) : rest + return $ reverse (readPatchIds str) : rest -read_patch_ids :: B.ByteString -> [(PatchInfo, String)] -read_patch_ids inv | B.null inv = [] -read_patch_ids inv = case readPatchInfo inv of +readPatchIds :: B.ByteString -> [(PatchInfo, String)] +readPatchIds inv | B.null inv = [] +readPatchIds inv = case readPatchInfo inv of Nothing -> [] Just (pinfo,r) -> case readHash r of Nothing -> [] - Just (h,r') -> (pinfo,h) : read_patch_ids r' + Just (h,r') -> (pinfo,h) : readPatchIds r' readHash :: B.ByteString -> Maybe (String, B.ByteString) readHash s = let s' = dropSpace s @@ -318,27 +415,17 @@ then Nothing else Just (BC.unpack $ B.tail h,r) -apply_pristine :: Patchy q => Cache -> [DarcsFlag] -> String -> String -> q C(x y) -> IO () -apply_pristine c opts d iname p = +applyPristine :: Patchy q => [DarcsFlag] -> String -> String -> q C(x y) -> IO () +applyPristine opts d iname p = do i <- gzReadFilePS (d++"/"++iname) - h <- applyHashed c opts (inv2pris i) p + h <- applyHashed opts (inv2pris i) p writeDocBinFile (d++"/"++iname) $ pris2inv h i -apply_to_tentative_pristine :: Patchy q => Cache -> [DarcsFlag] -> q C(x y) -> IO () -apply_to_tentative_pristine c opts p = apply_pristine c opts "." (darcsdir++"/tentative_pristine") p +applyToTentativePristine :: Patchy q => [DarcsFlag] -> q C(x y) -> IO () +applyToTentativePristine opts p = applyPristine opts "." (darcsdir++"/tentative_pristine") p -slurp_pristine :: Cache -> Compression -> String -> String -> IO Slurpy -slurp_pristine c compr d iname = do - i <- fetchFilePS (d++"/"++iname) Uncachable - slurp_pristine_private c compr i - -slurp_pristine_private :: Cache -> Compression -> B.ByteString -> IO Slurpy -slurp_pristine_private c compr inv = case inv2pris inv of - h | h == sha1PS B.empty -> return empty_slurpy - | otherwise -> slurpHashedPristine c compr h - -copy_pristine :: Cache -> Compression -> String -> String -> IO () -copy_pristine c compr d iname = do +copyPristine :: Cache -> Compression -> String -> String -> IO () +copyPristine c compr d iname = do i <- fetchFilePS (d++"/"++iname) Uncachable debugMessage $ "Copying hashed pristine tree: "++inv2pris i let k = "Copying pristine" @@ -346,36 +433,30 @@ copyHashed k c compr $ inv2pris i endTedious k -copy_partials_pristine :: FilePathLike fp => +copyPartialsPristine :: FilePathLike fp => Cache -> Compression -> String -> String -> [fp] -> IO () -copy_partials_pristine c compr d iname fps = +copyPartialsPristine c compr d iname fps = do i <- fetchFilePS (d++"/"++iname) Uncachable copyPartialsHashed c compr (inv2pris i) fps inv2pris :: B.ByteString -> String -inv2pris inv | B.take pristine_name_length inv == pristine_name = - case takeHash $ B.drop pristine_name_length inv of +inv2pris inv | B.take pristineNameLength inv == pristineName = + case takeHash $ B.drop pristineNameLength inv of Just (h,_) -> h Nothing -> error "Bad hash in inventory!" - | otherwise = sha1PS B.empty + | otherwise = sha256sum B.empty pris2inv :: String -> B.ByteString -> Doc -pris2inv h inv = invisiblePS pristine_name <> text h $$ invisiblePS (skip_pristine inv) +pris2inv h inv = invisiblePS pristineName <> text h $$ invisiblePS (skipPristine inv) -pristine_name :: B.ByteString -pristine_name = BC.pack "pristine:" +pristineName :: B.ByteString +pristineName = BC.pack "pristine:" -skip_pristine :: B.ByteString -> B.ByteString -skip_pristine ps - | B.take pristine_name_length ps == pristine_name = B.drop 1 $ BC.dropWhile (/= '\n') $ - B.drop pristine_name_length ps +skipPristine :: B.ByteString -> B.ByteString +skipPristine ps + | B.take pristineNameLength ps == pristineName = B.drop 1 $ BC.dropWhile (/= '\n') $ + B.drop pristineNameLength ps | otherwise = ps -pristine_name_length :: Int -pristine_name_length = B.length pristine_name - -slurp_all_but_darcs :: FilePath -> IO Slurpy -slurp_all_but_darcs d = do s <- slurp d - case slurp_remove (fp2fn $ "./"++darcsdir) s of - Nothing -> return s - Just s' -> return s' +pristineNameLength :: Int +pristineNameLength = B.length pristineName diff -ruN darcs-2.4.4/src/Darcs/Repository/Internal.hs darcs-2.5/src/Darcs/Repository/Internal.hs --- darcs-2.4.4/src/Darcs/Repository/Internal.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Internal.hs 2010-10-24 08:29:26.000000000 -0700 @@ -23,13 +23,13 @@ module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-), maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor, + IdentifyRepo(..), findRepository, amInRepository, amNotInRepository, - slurp_pending, revertRepositoryChanges, - slurp_recorded, slurp_recorded_and_unrecorded, - announce_merge_conflicts, setTentativePending, - check_unrecorded_conflicts, + revertRepositoryChanges, + announceMergeConflicts, setTentativePending, + checkUnrecordedConflicts, withRecorded, - read_repo, + readRepo, readTentativeRepo, prefsUrl, makePatchLazy, withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf, @@ -47,29 +47,27 @@ getRepository, rIO, testTentative, testRecorded, UpdatePristine(..), MakeChanges(..), applyToTentativePristine, - make_new_pending + makeNewPending ) where import Printer ( putDocLn, (<+>), text, ($$) ) -import Data.Maybe ( isJust, isNothing ) import Darcs.Repository.Prefs ( getPrefval ) -import Darcs.Repository.State ( readRecorded ) -import Darcs.Repository.LowLevel ( read_pending, pendingName, readPrims, read_pendingfile ) +import Darcs.Repository.State ( readRecorded, readWorking ) +import Darcs.Repository.LowLevel ( readPending, pendingName, readPrims, readPendingfile ) import System.Exit ( ExitCode(..), exitWith ) import System.Cmd ( system ) import Darcs.External ( clonePartialsTree ) import Darcs.IO ( runTolerantly, runSilently ) import Darcs.Repository.Pristine ( identifyPristine, nopristine, - easyCreatePristineDirectoryTree, slurpPristine, + easyCreatePristineDirectoryTree, easyCreatePartialsPristineDirectoryTree ) -import Data.List ( (\\) ) import Darcs.SignalHandler ( withSignalsBlocked ) import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ), identifyRepoFormat, formatHas, writeProblem, readProblem, readfromAndWritetoProblem ) -import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile, +import System.Directory ( doesDirectoryExist, setCurrentDirectory, createDirectoryIfMissing ) import Control.Monad ( liftM, when, unless ) import Workaround ( getCurrentDirectory, renameFile, setExecutable ) @@ -80,66 +78,69 @@ import Darcs.Patch ( Patch, RealPatch, Effect, primIsHunk, primIsBinary, description, - tryToShrink, commuteFL, commute ) -import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict ) -import Darcs.Patch.Bundle ( scan_bundle, make_bundle ) -import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, list_slurpy_files ) -import Darcs.Hopefully ( PatchInfoAnd, info, n2pia, + tryToShrink, commuteFLorComplain, commute ) +import Darcs.Patch.Prim ( tryShrinkingInverse ) +import Darcs.Patch.Bundle ( scanBundle, makeBundleN ) +import Darcs.Hopefully ( PatchInfoAnd, info, hopefully, hopefullyM ) -import Darcs.Repository.ApplyPatches ( apply_patches ) +import Darcs.Repository.ApplyPatches ( applyPatches ) import qualified Darcs.Repository.HashedRepo as HashedRepo - ( revert_tentative_changes, finalize_tentative_changes, - remove_from_tentative_inventory, - copy_pristine, copy_partials_pristine, slurp_pristine, - apply_to_tentative_pristine, - write_tentative_inventory, write_and_read_patch, - add_to_tentative_inventory, - read_repo, read_tentative_repo, clean_pristine, - slurp_all_but_darcs ) + ( revertTentativeChanges, finalizeTentativeChanges, + removeFromTentativeInventory, + copyPristine, copyPartialsPristine, + applyToTentativePristine, + writeTentativeInventory, writeAndReadPatch, + addToTentativeInventory, + readRepo, readTentativeRepo, cleanPristine ) import qualified Darcs.Repository.DarcsRepo as DarcsRepo import Darcs.Flags ( DarcsFlag(Verbose, Quiet, MarkConflicts, AllowConflicts, NoUpdateWorking, WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir, SetScriptsExecutable, DryRun ), - want_external_merge, compression ) + wantExternalMerge, compression ) import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP, (:\/:)(..), (:/\:)(..), (:>)(..), (+>+), lengthFL, - allFL, filterFL, - reverseRL, reverseFL, concatRL, mapFL, - mapFL_FL, concatFL ) + allFL, filterFLFL, + reverseFL, mapFL_FL, concatFL ) import Darcs.Patch ( RepoPatch, Patchy, Prim, merge, joinPatches, listConflictedFiles, listTouchedFiles, Named, patchcontents, commuteRL, fromPrims, - patch2patchinfo, readPatch, + readPatch, writePatch, effect, invert, primIsAddfile, primIsAdddir, primIsSetpref, - apply, applyToSlurpy, + apply, applyToTree, emptyMarkedupFile, MarkedUpFile ) -import Darcs.Patch.Patchy ( Invert(..) ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL ) import Darcs.Patch.Info ( PatchInfo ) -import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2FL ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif import Darcs.Patch.Apply ( markupFile, LineMark(None) ) -import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset ) +import Darcs.Patch.Depends ( deepOptimizePatchset, removeFromPatchSet, mergeThem ) import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath, ioAbsoluteOrRemote, toPath ) import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort ) import Progress ( debugMessage ) import Darcs.ProgressPatches (progressFL) -import Darcs.URL ( is_file ) +import Darcs.URL ( isFile ) import Darcs.Repository.Prefs ( getCaches ) -import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist, +import Darcs.Lock ( withLock, writeDocBinFile, removeFileMayNotExist, withTempDir, withPermDir ) import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal ) import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) ) import Darcs.Global ( darcsdir ) + import System.Mem( performGC ) +import qualified Storage.Hashed.Tree as Tree +import Storage.Hashed.AnchoredPath( anchorPath ) + #include "impossible.h" -- | Repository IO monad. This monad-like datatype is responsible for @@ -189,36 +190,42 @@ getRepository :: RIO p C(r u t t) (Repository p C(r u t)) getRepository = RIO return -maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (Either String (Repository p C(r u t))) +-- | The status of a given directory: is it a darcs repository? +data IdentifyRepo p C(r u t) = BadRepository String -- ^ looks like a repository with some error + | NonRepository String -- ^ safest guess + | GoodRepository (Repository p C(r u t)) + +maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p C(r u t)) maybeIdentifyRepository opts "." = do darcs <- doesDirectoryExist darcsdir rf_or_e <- identifyRepoFormat "." here <- toPath `fmap` ioAbsoluteOrRemote "." case rf_or_e of - Left err -> return $ Left err + Left err -> return $ NonRepository err Right rf -> case readProblem rf of - Just err -> return $ Left err + Just err -> return $ BadRepository err Nothing -> if darcs then do pris <- identifyPristine cs <- getCaches opts here - return $ Right $ Repo here opts rf (DarcsRepository pris cs) - else return (Left "Not a repository") + return $ GoodRepository $ Repo here opts rf (DarcsRepository pris cs) + else return (NonRepository "Not a repository") maybeIdentifyRepository opts url' = do url <- toPath `fmap` ioAbsoluteOrRemote url' rf_or_e <- identifyRepoFormat url case rf_or_e of - Left e -> return $ Left e + Left e -> return $ NonRepository e Right rf -> case readProblem rf of - Just err -> return $ Left err + Just err -> return $ BadRepository err Nothing -> do cs <- getCaches opts url - return $ Right $ Repo url opts rf (DarcsRepository nopristine cs) + return $ GoodRepository $ Repo url opts rf (DarcsRepository nopristine cs) identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t)) identifyDarcs1Repository opts url = do er <- maybeIdentifyRepository opts url case er of - Left s -> fail s - Right r -> return r + BadRepository s -> fail s + NonRepository s -> fail s + GoodRepository r -> return r identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t)) identifyRepositoryFor (Repo _ opts rf _) url = @@ -228,20 +235,14 @@ Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e Nothing -> return $ Repo absurl opts rf_ t' -isRight :: Either a b -> Bool -isRight (Right _) = True -isRight _ = False - -currentDirIsRepository :: IO Bool -currentDirIsRepository = isRight `liftM` maybeIdentifyRepository [] "." - amInRepository :: [DarcsFlag] -> IO (Either String ()) amInRepository (WorkRepoDir d:_) = do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) - air <- currentDirIsRepository - if air - then return (Right ()) - else return (Left "You need to be in a repository directory to run this command.") + status <- maybeIdentifyRepository [] "." + case status of + GoodRepository _ -> return (Right ()) + BadRepository e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e) + NonRepository _ -> return (Left "You need to be in a repository directory to run this command.") amInRepository (_:fs) = amInRepository fs amInRepository [] = seekRepo (Left "You need to be in a repository directory to run this command.") @@ -255,10 +256,12 @@ -> IO (Either String ()) seekRepo onFail = getCurrentDirectory >>= helper where helper startpwd = do - air <- currentDirIsRepository - if air - then return (Right ()) - else do cd <- toFilePath `fmap` getCurrentDirectory + status <- maybeIdentifyRepository [] "." + case status of + GoodRepository _ -> return (Right ()) + BadRepository e -> return (Left e) + NonRepository _ -> + do cd <- toFilePath `fmap` getCurrentDirectory setCurrentDirectory ".." cd' <- toFilePath `fmap` getCurrentDirectory if cd' /= cd @@ -277,12 +280,14 @@ amNotInRepository [] amNotInRepository (_:f) = amNotInRepository f amNotInRepository [] = - do air <- currentDirIsRepository - if air then return (Left $ "You may not run this command in a repository.") - else return $ Right () + do status <- maybeIdentifyRepository [] "." + case status of + GoodRepository _ -> return (Left $ "You may not run this command in a repository.") + BadRepository e -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e) + NonRepository _ -> return (Right ()) findRepository :: [DarcsFlag] -> IO (Either String ()) -findRepository (WorkRepoUrl d:_) | is_file d = +findRepository (WorkRepoUrl d:_) | isFile d = do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) findRepository [] findRepository (WorkRepoDir d:_) = @@ -291,52 +296,21 @@ findRepository (_:fs) = findRepository fs findRepository [] = seekRepo (Right ()) -slurp_pending :: RepoPatch p => Repository p C(r u t) -> IO Slurpy -slurp_pending repo@(Repo _ _ _ rt) = do - cur <- slurp_recorded repo - Sealed pend <- read_pending repo - case applyToSlurpy pend cur of - Just pendcur -> return pendcur - Nothing -> do putStrLn "Yikes, pending has conflicts. Renaming file as_darcs/patches/pending_buggy" - renameFile (pendingName rt) (pendingName rt++"_buggy") - return cur - -slurp_recorded :: RepoPatch p => Repository p C(r u t) -> IO Slurpy -slurp_recorded (Repo dir opts rf (DarcsRepository _ c)) - | formatHas HashedInventory rf = - HashedRepo.slurp_pristine c (compression opts) dir $ darcsdir++"/hashed_inventory" -slurp_recorded repository@(Repo dir _ _ (DarcsRepository p _)) = do - mc <- withCurrentDirectory dir $ slurpPristine p - case mc of (Just slurpy) -> return slurpy - Nothing -> withDelayedDir "pristine.temp" $ \abscd -> - do let cd = toFilePath abscd - createPristineDirectoryTree repository cd - mmap_slurp cd - -slurp_recorded_and_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (Slurpy, Slurpy) -slurp_recorded_and_unrecorded repo@(Repo r _ _ _) = do - cur <- slurp_recorded repo - Sealed pend <- read_pending repo - withCurrentDirectory r $ - case applyToSlurpy pend cur of - Nothing -> fail "Yikes, pending has conflicts!" - Just pendslurp -> do unrec <- co_slurp pendslurp "." - return (cur, unrec) - -make_new_pending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> IO () -make_new_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () -make_new_pending repo@(Repo r _ _ tp) origp = +makeNewPending :: forall p C(r u t y). RepoPatch p + => Repository p C(r u t) -> FL Prim C(t y) -> IO () +makeNewPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +makeNewPending repo@(Repo r _ _ tp) origp = withCurrentDirectory r $ do let newname = pendingName tp ++ ".new" debugMessage $ "Writing new pending: " ++ newname - Sealed sfp <- return $ sift_for_pending origp + Sealed sfp <- return $ siftForPending origp writeSealedPatch newname $ seal $ fromPrims $ sfp - cur <- slurp_recorded repo - Sealed p <- read_pendingfile newname - when (isNothing $ applyToSlurpy p cur) $ do + cur <- readRecorded repo + Sealed p <- readPendingfile newname + catch (applyToTree p cur) $ \err -> do let buggyname = pendingName tp ++ "_buggy" renameFile newname buggyname - bugDoc $ text "There was an attempt to write an invalid pending!" + bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err) $$ text "If possible, please send the contents of" <+> text buggyname $$ text "along with a bug report." @@ -345,21 +319,21 @@ where writeSealedPatch :: FilePath -> Sealed (Patch C(x)) -> IO () writeSealedPatch fp (Sealed p) = writePatch fp p -sift_for_pending :: FL Prim C(x y) -> Sealed (FL Prim C(x)) -sift_for_pending simple_ps = - let oldps = maybe simple_ps id $ try_shrinking_inverse $ crude_sift simple_ps +siftForPending :: FL Prim C(x y) -> Sealed (FL Prim C(x)) +siftForPending simple_ps = + let oldps = maybe simple_ps id $ tryShrinkingInverse $ crudeSift simple_ps in if allFL (\p -> primIsAddfile p || primIsAdddir p) $ oldps then seal oldps else fromJust $ do Sealed x <- return $ sfp NilFL $ reverseFL oldps return (case tryToShrink x of - ps | lengthFL ps < lengthFL oldps -> sift_for_pending ps + ps | lengthFL ps < lengthFL oldps -> siftForPending ps | otherwise -> seal ps) where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c)) sfp sofar NilRL = seal sofar sfp sofar (p:<:ps) | primIsHunk p || primIsBinary p - = case commuteFL (p :> sofar) of + = case commuteFLorComplain (p :> sofar) of Right (sofar' :> _) -> sfp sofar' ps Left _ -> sfp (p:>:sofar) ps sfp sofar (p:<:ps) = sfp (p:>:sofar) ps @@ -368,24 +342,24 @@ -- seal it. Instead, update this function to work with type witnesses -- by fixing DarcsRepo to match HashedRepo in the handling of -- Repository state. -read_repo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(r)) -read_repo repo@(Repo r opts rf _) - | formatHas HashedInventory rf = do ps <- HashedRepo.read_repo repo r +readRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(Origin r)) +readRepo repo@(Repo r opts rf _) + | formatHas HashedInventory rf = do ps <- HashedRepo.readRepo repo r return ps - | otherwise = do Sealed ps <- DarcsRepo.read_repo opts r + | otherwise = do Sealed ps <- DarcsRepo.readRepo opts r return $ unsafeCoerceP ps -readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(t)) +readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(Origin t)) readTentativeRepo repo@(Repo r opts rf _) - | formatHas HashedInventory rf = do ps <- HashedRepo.read_tentative_repo repo r + | formatHas HashedInventory rf = do ps <- HashedRepo.readTentativeRepo repo r return ps - | otherwise = do Sealed ps <- DarcsRepo.read_tentative_repo opts r + | otherwise = do Sealed ps <- DarcsRepo.readTentativeRepo opts r return $ unsafeCoerceP ps makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y)) makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p - | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p - | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p + | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.writeAndReadPatch c (compression opts) p + | otherwise = withCurrentDirectory r $ DarcsRepo.writeAndReadPatch opts p prefsUrl :: Repository p C(r u t) -> String prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs" @@ -393,19 +367,20 @@ unrevertUrl :: Repository p C(r u t) -> String unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert" -applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO () -applyToWorking (Repo r _ _ (DarcsRepository _ _)) opts patch = - withCurrentDirectory r $ if Quiet `elem` opts - then runSilently $ apply opts patch - else runTolerantly $ apply opts patch +applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO (Repository p1 C(r y t)) +applyToWorking (Repo r ropts rf (DarcsRepository t c)) opts patch = + do withCurrentDirectory r $ if Quiet `elem` opts + then runSilently $ apply opts patch + else runTolerantly $ apply opts patch + return (Repo r ropts rf (DarcsRepository t c)) -handle_pend_for_add :: forall p q C(r u t x y). (RepoPatch p, Effect q) +handlePendForAdd :: forall p q C(r u t x y). (RepoPatch p, Effect q) => Repository p C(r u t) -> q C(x y) -> IO () -handle_pend_for_add (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () -handle_pend_for_add (Repo _ _ _ rt) p = +handlePendForAdd (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +handlePendForAdd (Repo _ _ _ rt) p = do let pn = pendingName rt ++ ".tentative" Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL) - let effectp = if allFL is_simple pend then crude_sift $ effect p + let effectp = if allFL isSimple pend then crudeSift $ effect p else effect p Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) pend writePatch pn $ fromPrims_ newpend @@ -427,11 +402,11 @@ fromPrims_ :: FL Prim C(a b) -> Patch C(a b) fromPrims_ = fromPrims -is_simple :: Prim C(x y) -> Bool -is_simple x = primIsHunk x || primIsBinary x || primIsSetpref x +isSimple :: Prim C(x y) -> Bool +isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x -crude_sift :: FL Prim C(x y) -> FL Prim C(x y) -crude_sift xs = if allFL is_simple xs then filterFL ishunkbinary xs else xs +crudeSift :: FL Prim C(x y) -> FL Prim C(x y) +crudeSift xs = if allFL isSimple xs then filterFLFL ishunkbinary xs else xs where ishunkbinary :: Prim C(x y) -> EqCheck C(x y) ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq | otherwise = NotEq @@ -445,12 +420,12 @@ data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) -announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool -announce_merge_conflicts cmd opts resolved_pw = +announceMergeConflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool +announceMergeConflicts cmd opts resolved_pw = case nubsort $ listTouchedFiles $ resolved_pw of [] -> return False cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts - || want_external_merge opts /= Nothing + || wantExternalMerge opts /= Nothing then do putStrLn "We have conflicts in the following files:" putStrLn $ unwords cfs return True @@ -463,13 +438,13 @@ " "++cmd++" mark-conflicts\n"++ "to "++darcsdir++"/prefs/defaults in the target repo. " -check_unrecorded_conflicts :: forall p C(r y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(r y) -> IO Bool -check_unrecorded_conflicts opts _ | NoUpdateWorking `elem` opts = return False -check_unrecorded_conflicts opts pc = +checkUnrecordedConflicts :: forall p C(t y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(t y) -> IO Bool +checkUnrecordedConflicts opts _ | NoUpdateWorking `elem` opts = return False +checkUnrecordedConflicts opts pc = do repository <- identifyDarcs1Repository opts "." cuc repository where cuc :: Repository Patch C(r u t) -> IO Bool - cuc r = do Sealed mpend <- read_pending r :: IO (Sealed (FL Prim C(r))) + cuc r = do Sealed mpend <- readPending r :: IO (Sealed (FL Prim C(t))) case mpend of NilFL -> return False pend -> @@ -488,32 +463,33 @@ fromPrims_ = fromPrims tentativelyAddPatch :: RepoPatch p - => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(r y) -> IO () + => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y)) tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq tentativelyAddPatch_ :: RepoPatch p => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag] - -> PatchInfoAnd p C(r y) -> IO () + -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y)) tentativelyAddPatch_ _ _ opts _ | DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified" -tentativelyAddPatch_ up r@(Repo dir _ rf (DarcsRepository _ c)) opts p = +tentativelyAddPatch_ up r@(Repo dir ropts rf (DarcsRepository t c)) opts p = withCurrentDirectory dir $ do decideHashedOrNormal rf $ HvsO { - hashed = HashedRepo.add_to_tentative_inventory c (compression opts) p, - old = DarcsRepo.add_to_tentative_inventory opts (hopefully p) } + hashed = HashedRepo.addToTentativeInventory c (compression opts) p, + old = DarcsRepo.addToTentativeInventory opts (hopefully p) } when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..." applyToTentativePristine r p debugMessage "Updating pending..." - handle_pend_for_add r p + handlePendForAdd r p + return (Repo dir ropts rf (DarcsRepository t c)) -applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(r y) -> IO () +applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(t y) -> IO () applyToTentativePristine (Repo dir opts rf (DarcsRepository _ c)) p = withCurrentDirectory dir $ do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p - decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.apply_to_tentative_pristine c opts p, - old = DarcsRepo.add_to_tentative_pristine p} + decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.applyToTentativePristine opts p, + old = DarcsRepo.addToTentativePristine p} -- | This fuction is unsafe because it accepts a patch that works on the tentative -- pending and we don't currently track the state of the tentative pending. @@ -540,7 +516,7 @@ setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO () setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () setTentativePending (Repo dir _ _ rt) patch = do - Sealed prims <- return $ sift_for_pending patch + Sealed prims <- return $ siftForPending patch withCurrentDirectory dir $ writePatch (pendingName rt ++ ".tentative") $ fromPrims_ prims where fromPrims_ :: FL Prim C(a b) -> Patch C(a b) @@ -555,7 +531,7 @@ do let pn = pendingName rt ++ ".tentative" Sealed pend <- readPrims `liftM` (gzReadFilePS pn `catchall` (return B.empty)) Sealed newpend_ <- return $ newpend pend patch - writePatch pn $ fromPrims_ (crude_sift newpend_) + writePatch pn $ fromPrims_ (crudeSift newpend_) where newpend :: FL Prim C(b c) -> FL Prim C(a b) -> Sealed (FL Prim C(a)) newpend NilFL patch_ = seal patch_ newpend p patch_ = seal $ patch_ +>+ p @@ -563,50 +539,48 @@ fromPrims_ = fromPrims tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] - -> FL (Named p) C(x t) -> IO () + -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x)) tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag] - -> FL (Named p) C(x t) -> IO () -tentativelyRemovePatches_ up repository@(Repo dir _ rf (DarcsRepository _ c)) opts ps = + -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x)) +tentativelyRemovePatches_ up repository@(Repo dir ropts rf (DarcsRepository t c)) opts ps = withCurrentDirectory dir $ do when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..." prepend repository $ effect ps - remove_from_unrevert_context repository ps + removeFromUnrevertContext repository ps debugMessage "Removing changes from tentative inventory..." if formatHas HashedInventory rf - then do HashedRepo.remove_from_tentative_inventory repository (compression opts) ps + then do HashedRepo.removeFromTentativeInventory repository (compression opts) ps when (up == UpdatePristine) $ - HashedRepo.apply_to_tentative_pristine c opts $ + HashedRepo.applyToTentativePristine opts $ progressFL "Applying inverse to pristine" $ invert ps - else DarcsRepo.remove_from_tentative_inventory (up==UpdatePristine) opts ps + else DarcsRepo.removeFromTentativeInventory (up==UpdatePristine) opts ps + return (Repo dir ropts rf (DarcsRepository t c)) tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag] - -> FL (Named p) C(x t) -> IO () -tentativelyReplacePatches repository@(Repo x y z w) opts ps = - -- tentativelyRemovePatches_ leaves the repository in state C(x u t) - do tentativelyRemovePatches_ DontUpdatePristine repository opts ps - -- Now we add the patches back so that the repo again has state C(r u t) - sequence_ $ mapAdd ((Repo x y z w) :: Repository p C(x u t)) ps - where mapAdd :: Repository p C(i l m) -> FL (Named p) C(i j) -> [IO ()] - mapAdd _ NilFL = [] - mapAdd r@(Repo dir df rf dr) (a:>:as) = - -- we construct a new Repository object on the recursive case so that the - -- recordedstate of the repository can match the fact that we just wrote a patch - tentativelyAddPatch_ DontUpdatePristine r opts (n2pia a) : mapAdd (Repo dir df rf dr) as + -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u t)) +tentativelyReplacePatches repository opts ps = + do repository' <- tentativelyRemovePatches_ DontUpdatePristine repository opts ps + mapAdd repository' ps + where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j)) + mapAdd r NilFL = return r + mapAdd r (a:>:as) = + do r' <- tentativelyAddPatch_ DontUpdatePristine r opts a + mapAdd r' as -finalize_pending :: RepoPatch p => Repository p C(r u t) -> IO () -finalize_pending (Repo dir opts _ rt) +finalizePending :: RepoPatch p => Repository p C(r u t) -> IO () +finalizePending (Repo dir opts _ rt) | NoUpdateWorking `elem` opts = withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt) -finalize_pending repository@(Repo dir _ _ rt) = do +finalizePending repository@(Repo dir _ _ rt) = do withCurrentDirectory dir $ do let pn = pendingName rt tpn = pn ++ ".tentative" tpfile <- gzReadFilePS tpn `catchall` (return B.empty) Sealed tpend <- return $ readPrims tpfile - Sealed new_pending <- return $ sift_for_pending tpend - make_new_pending repository new_pending + Sealed new_pending <- return $ siftForPending tpend + makeNewPending repository new_pending finalizeRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO () finalizeRepositoryChanges (Repo _ opts _ _) @@ -616,16 +590,16 @@ withCurrentDirectory dir $ do debugMessage "Considering whether to test..." testTentative repository debugMessage "Finalizing changes..." - withSignalsBlocked $ do HashedRepo.finalize_tentative_changes repository (compression opts) - finalize_pending repository + withSignalsBlocked $ do HashedRepo.finalizeTentativeChanges repository (compression opts) + finalizePending repository debugMessage "Done finalizing changes..." finalizeRepositoryChanges repository@(Repo dir _ _ (DarcsRepository _ _)) = withCurrentDirectory dir $ do debugMessage "Considering whether to test..." testTentative repository debugMessage "Finalizing changes..." - withSignalsBlocked $ do DarcsRepo.finalize_pristine_changes - DarcsRepo.finalize_tentative_changes - finalize_pending repository + withSignalsBlocked $ do DarcsRepo.finalizePristineChanges + DarcsRepo.finalizeTentativeChanges + finalizePending repository testTentative :: RepoPatch p => Repository p C(r u t) -> IO () testTentative = testAny withTentative @@ -661,14 +635,14 @@ revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) = withCurrentDirectory dir $ do removeFileMayNotExist (pendingName dr ++ ".tentative") - Sealed x <- read_pending r + Sealed x <- readPending r setTentativePending r $ effect x when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr - decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revert_tentative_changes, - old = DarcsRepo.revert_tentative_changes } + decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revertTentativeChanges, + old = DarcsRepo.revertTentativeChanges } -patchSetToPatches :: RepoPatch p => RL (RL (PatchInfoAnd p)) C(x y) -> FL (Named p) C(x y) -patchSetToPatches patchSet = mapFL_FL hopefully $ reverseRL $ concatRL patchSet +patchSetToPatches :: RepoPatch p => PatchSet p C(x y) -> FL (Named p) C(x y) +patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet getUMask :: [DarcsFlag] -> Maybe String getUMask [] = Nothing @@ -731,43 +705,44 @@ then job repository else withLock name (revertRepositoryChanges repository >> job repository) -remove_from_unrevert_context :: forall p C(r u t x). RepoPatch p - => Repository p C(r u t) -> FL (Named p) C(x t) -> IO () -remove_from_unrevert_context repository ps = do - Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (NilRL:<:NilRL)) +removeFromUnrevertContext :: forall p C(r u t x). RepoPatch p + => Repository p C(r u t) -> FL (PatchInfoAnd p) C(x t) -> IO () +removeFromUnrevertContext repository ps = do + Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (PatchSet NilRL NilRL)) remove_from_unrevert_context_ bundle - where unrevert_impossible unrevert_loc = - do putStrLn "This operation will make unrevert impossible!" - yorn <- promptYorn "Proceed?" + where unrevert_impossible = + do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?" case yorn of 'n' -> fail "Cancelled." - 'y' -> removeFile unrevert_loc `catchall` return () + 'y' -> removeFileMayNotExist (unrevertUrl repository) _ -> impossible - pis = mapFL patch2patchinfo ps - unrevert_patch_bundle :: IO (SealedPatchSet p) + unrevert_patch_bundle :: IO (SealedPatchSet p C(Origin)) unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository) - case scan_bundle pf of + case scanBundle pf of Right foo -> return foo Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err - remove_from_unrevert_context_ :: PatchSet p C(z) -> IO () - remove_from_unrevert_context_ (NilRL :<: NilRL) = return () - remove_from_unrevert_context_ bundle = do - let unrevert_loc = unrevertUrl repository - debugMessage "Adjusting the context of the unrevert changes..." + remove_from_unrevert_context_ :: PatchSet p C(Origin z) -> IO () + remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return () + remove_from_unrevert_context_ bundle = + do debugMessage "Adjusting the context of the unrevert changes..." + debugMessage $ "Removing "++ show (lengthFL ps) ++ + " patches in removeFromUnrevertContext!" ref <- readTentativeRepo repository - case get_common_and_uncommon (bundle, ref) of - (common,(h_us:<:NilRL) :\/: NilRL) -> - case commuteRL (reverseFL ps :> hopefully h_us) of - Nothing -> unrevert_impossible unrevert_loc - Just (us' :> _) -> do - s <- readRecorded repository - bundle' <- make_bundle [] s (common \\ pis) (us' :>: NilFL) - writeDocBinFile unrevert_loc bundle' - (common,(x:<:NilRL):\/:_) - | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc - | isr -> return () - where isr = isJust $ hopefullyM x - _ -> unrevert_impossible unrevert_loc + let withSinglet :: Sealed (FL ppp C(xxx)) + -> (FORALL(yyy) ppp C(xxx yyy) -> IO ()) -> IO () + withSinglet (Sealed (x :>: NilFL)) j = j x + withSinglet _ _ = return () + withSinglet (mergeThem ref bundle) $ \h_us -> + case commuteRL (reverseFL ps :> h_us) of + Nothing -> unrevert_impossible + Just (us' :> _) -> + case removeFromPatchSet ps ref of + Nothing -> unrevert_impossible + Just common -> + do debugMessage "Have now found the new context..." + bundle <- makeBundleN Nothing common (hopefully us':>:NilFL) + writeDocBinFile (unrevertUrl repository) bundle + debugMessage "Done adjusting the context of the unrevert changes!" -- | Writes out a fresh copy of the inventory that minimizes the -- amount of inventory that need be downloaded when people pull from @@ -782,31 +757,31 @@ -- important in large repositories. optimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO () optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) = - do ps <- read_repo repository + do ps <- readRepo repository decideHashedOrNormal rf $ HvsO { hashed = do revertRepositoryChanges repository - HashedRepo.write_tentative_inventory c (compression opts) $ deep_optimize_patchset ps + HashedRepo.writeTentativeInventory c (compression opts) $ deepOptimizePatchset ps finalizeRepositoryChanges repository, - old = DarcsRepo.write_inventory r $ deep_optimize_patchset ps + old = DarcsRepo.writeInventory r $ deepOptimizePatchset ps } cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO () cleanRepository repository@(Repo _ _ rf _) = decideHashedOrNormal rf $ - HvsO { hashed = HashedRepo.clean_pristine repository, + HvsO { hashed = HashedRepo.cleanPristine repository, old = return () } createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO () createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir | formatHas HashedInventory rf = do createDirectoryIfMissing True reldir - withCurrentDirectory reldir $ HashedRepo.copy_pristine c (compression opts) r (darcsdir++"/hashed_inventory") + withCurrentDirectory reldir $ HashedRepo.copyPristine c (compression opts) r (darcsdir++"/hashed_inventory") | otherwise = do dir <- toPath `fmap` ioAbsoluteOrRemote reldir done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir - unless done $ do Sealed patches <- (seal . reverseRL . concatRL) `liftM` read_repo repo + unless done $ do Sealed patches <- (seal . newset2FL) `liftM` readRepo repo createDirectoryIfMissing True dir - withCurrentDirectory dir $ apply_patches [] patches + withCurrentDirectory dir $ applyPatches [] patches -- fp below really should be FileName createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO () @@ -814,7 +789,7 @@ | formatHas HashedInventory rf = do createDirectoryIfMissing True dir withCurrentDirectory dir $ - HashedRepo.copy_partials_pristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs + HashedRepo.copyPartialsPristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs createPartialsPristineDirectoryTree r@(Repo rdir _ _ (DarcsRepository pris _)) prefs dir = withCurrentDirectory rdir $ do done <- easyCreatePartialsPristineDirectoryTree prefs pris dir @@ -832,7 +807,7 @@ -> (AbsolutePath -> IO a) -> IO a withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f | formatHas HashedInventory rf = - mk_dir $ \d -> do HashedRepo.copy_pristine c (compression opts) dir (darcsdir++"/tentative_pristine") + mk_dir $ \d -> do HashedRepo.copyPristine c (compression opts) dir (darcsdir++"/tentative_pristine") f d withTentative repository@(Repo dir opts _ _) mk_dir f = withRecorded repository mk_dir $ \d -> @@ -848,20 +823,20 @@ getMarkedupFile :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> FilePath -> IO MarkedUpFile getMarkedupFile repository pinfo f = do Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info) - . reverseRL . concatRL) `liftM` read_repo repository - return $ snd $ do_mark_all patches (f, emptyMarkedupFile) + . newset2FL) `liftM` readRepo repository + return $ snd $ doMarkAll patches (f, emptyMarkedupFile) where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v) dropWhileFL _ NilFL = flipSeal NilFL dropWhileFL p xs@(x:>:xs') | p x = dropWhileFL p xs' | otherwise = flipSeal xs -do_mark_all :: RepoPatch p => FL (PatchInfoAnd p) C(x y) +doMarkAll :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) -do_mark_all (hp:>:pps) (f, mk) = +doMarkAll (hp:>:pps) (f, mk) = case hopefullyM hp of - Just p -> do_mark_all pps $ markupFile (info hp) (patchcontents p) (f, mk) + Just p -> doMarkAll pps $ markupFile (info hp) (patchcontents p) (f, mk) Nothing -> (f, [(BC.pack "Error reading a patch!",None)]) -do_mark_all NilFL (f, mk) = (f, mk) +doMarkAll NilFL (f, mk) = (f, mk) -- | Sets scripts in or below the current directory executable. A script is any file that starts -- with the bytes '#!'. This is used sometimes for --set-scripts-executable, but at other times @@ -870,10 +845,11 @@ setScriptsExecutable = do debugMessage "Making scripts executable" myname <- getCurrentDirectory - c <- list_slurpy_files `fmap` (HashedRepo.slurp_all_but_darcs myname) - let setExecutableIfScript f = + tree <- readWorking + let paths = [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ] + setExecutableIfScript f = do contents <- B.readFile f when (BC.pack "#!" `B.isPrefixOf` contents) $ do debugMessage ("Making executable: " ++ f) setExecutable f True - mapM_ setExecutableIfScript c + mapM_ setExecutableIfScript paths diff -ruN darcs-2.4.4/src/Darcs/Repository/InternalTypes.hs darcs-2.5/src/Darcs/Repository/InternalTypes.hs --- darcs-2.4.4/src/Darcs/Repository/InternalTypes.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/InternalTypes.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,12 +21,14 @@ #include "gadts.h" module Darcs.Repository.InternalTypes ( Repository(..), RepoType(..), Pristine(..) - , extractCache + , extractCache, extractOptions, modifyCache ) where -import Darcs.Repository.Cache ( Cache ) +import Data.List ( nub, sortBy ) +import Darcs.Repository.Cache ( Cache (..) , compareByLocality ) import Darcs.Flags ( DarcsFlag ) import Darcs.Repository.Format ( RepoFormat ) +import Darcs.Patch ( RepoPatch ) data Pristine = NoPristine !String @@ -40,3 +42,13 @@ extractCache :: Repository p C(r u t) -> Cache extractCache (Repo _ _ _ (DarcsRepository _ c)) = c + +extractOptions :: Repository p C(r u t) -> [DarcsFlag] +extractOptions (Repo _ opts _ _) = opts + +-- | 'modifyCache' @repository function@ modifies the cache of +-- @repository@ with @function@, remove duplicates and sort the results with 'compareByLocality'. +modifyCache :: FORALL(p r u t) (RepoPatch p) => Repository p C(r u t) -> (Cache -> Cache) -> Repository p C(r u t) +modifyCache (Repo dir opts rf (DarcsRepository pristine cache)) f = Repo dir opts rf dr + where dr = DarcsRepository pristine . cmap ( sortBy compareByLocality . nub ) $ f cache + cmap f (Ca c) = Ca (f c) diff -ruN darcs-2.4.4/src/Darcs/Repository/LowLevel.hs darcs-2.5/src/Darcs/Repository/LowLevel.hs --- darcs-2.4.4/src/Darcs/Repository/LowLevel.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/LowLevel.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,7 +21,7 @@ #include "gadts.h" -module Darcs.Repository.LowLevel ( read_pending, read_pendingfile, pendingName, readPrims ) where +module Darcs.Repository.LowLevel ( readPending, readPendingfile, pendingName, readPrims ) where import Darcs.Repository.InternalTypes ( RepoType(..), Repository(..) ) import Darcs.Patch ( readPatch, Prim, Patch, RepoPatch, effect ) @@ -35,12 +35,12 @@ pendingName :: RepoType p -> String pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending" -read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r))) -read_pending (Repo r _ _ tp) = - withCurrentDirectory r (read_pendingfile (pendingName tp)) +readPending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(t))) +readPending (Repo r _ _ tp) = + withCurrentDirectory r (readPendingfile (pendingName tp)) -read_pendingfile :: String -> IO (Sealed (FL Prim C(x))) -read_pendingfile name = do +readPendingfile :: String -> IO (Sealed (FL Prim C(x))) +readPendingfile name = do pend <- gzReadFilePS name `catchall` return BS.empty return $ readPrims pend diff -ruN darcs-2.4.4/src/Darcs/Repository/Merge.hs darcs-2.5/src/Darcs/Repository/Merge.hs --- darcs-2.4.4/src/Darcs/Repository/Merge.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Merge.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,19 +21,20 @@ module Darcs.Repository.Merge where -import Darcs.Resolution ( standard_resolution, external_resolution ) +import Darcs.Resolution ( standardResolution, externalResolution ) import Darcs.External ( backupByCopying ) -import Control.Monad ( when ) +import Control.Monad ( when, unless ) import Darcs.Patch ( Effect ) import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully ) import Darcs.Flags - ( DarcsFlag( AllowConflicts ), want_external_merge ) + ( DarcsFlag( AllowConflicts, NoAllowConflicts ), wantExternalMerge ) import Darcs.Witnesses.Ordered ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL ) import Darcs.Patch ( RepoPatch, Prim, merge, joinPatches, listTouchedFiles , patchcontents, anonymous, fromPrims, effect ) +import Darcs.Patch.Depends( merge2FL ) import Progress( debugMessage ) import Darcs.ProgressPatches( progressFL ) import Darcs.Witnesses.Sealed( Sealed(Sealed), seal ) @@ -42,72 +43,73 @@ import Darcs.Repository.State( unrecordedChanges, readUnrecorded ) import Darcs.Repository.Internal - ( announce_merge_conflicts, check_unrecorded_conflicts + ( announceMergeConflicts, checkUnrecordedConflicts , MakeChanges(..), setTentativePending , tentativelyAddPatch_, applyToTentativePristine, UpdatePristine(..) ) tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p => MakeChanges -> Repository p C(r u t) -> String -> [DarcsFlag] - -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y) -> IO (Sealed (FL Prim C(u))) tentativelyMergePatches_ mc r cmd opts usi themi = do let us = mapFL_FL hopefully usi them = mapFL_FL hopefully themi - _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us) + Sealed pc <- return $ merge2FL (progressFL "Merging us" usi) (progressFL "Merging them" themi) pend <- unrecordedChanges opts r [] - anonpend <- anonymous (fromPrims pend) + anonpend <- n2pia `fmap` anonymous (fromPrims pend) pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL) - let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw - Sealed standard_resolved_pw <- return $ standard_resolution pwprim + let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ + mapFL_FL (patchcontents . hopefully) pw + Sealed standard_resolved_pw <- return $ standardResolution pwprim debugMessage "Checking for conflicts..." - mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw + unless (AllowConflicts `elem` opts || NoAllowConflicts `elem` opts) $ + mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw debugMessage "Announcing conflicts..." - have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw + have_conflicts <- announceMergeConflicts cmd opts standard_resolved_pw debugMessage "Checking for unrecorded conflicts..." - have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc + have_unrecorded_conflicts <- checkUnrecordedConflicts opts $ mapFL_FL hopefully pc debugMessage "Reading working directory..." - working <- readUnrecorded r + working <- readUnrecorded r [] debugMessage "Working out conflicts in actual working directory..." Sealed pw_resolution <- - case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of + case (wantExternalMerge opts, have_conflicts || have_unrecorded_conflicts) of (Nothing,_) -> return $ if AllowConflicts `elem` opts then seal NilFL else seal standard_resolved_pw (_,False) -> return $ seal standard_resolved_pw - (Just c, True) -> external_resolution working c + (Just c, True) -> externalResolution working c (effect us +>+ pend) (effect them) pwprim debugMessage "Applying patches to the local directories..." when (mc == MakeChanges) $ - do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO () + do let doChanges :: FL (PatchInfoAnd p) C(x t) -> IO () doChanges NilFL = applyps r themi - doChanges _ = applyps r (mapFL_FL n2pia pc) + doChanges _ = applyps r pc doChanges usi setTentativePending r (effect pend' +>+ pw_resolution) return $ seal (effect pwprim +>+ pw_resolution) - where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()] - mapAdd _ NilFL = [] - mapAdd r'@(Repo dir df rf dr) (a:>:as) = - -- we construct a new Repository object on the recursive case so that the - -- recordedstate of the repository can match the fact that we just wrote a patch - tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as - applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO () + where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j)) + mapAdd repo NilFL = return repo + mapAdd repo (a:>:as) = + do repo' <- tentativelyAddPatch_ DontUpdatePristine repo opts a + mapAdd repo' as + applyps :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO () applyps repo ps = do debugMessage "Adding patches to inventory..." - sequence_ $ mapAdd repo ps + mapAdd repo ps debugMessage "Applying patches to pristine..." applyToTentativePristine repo ps tentativelyMergePatches :: RepoPatch p => Repository p C(r u t) -> String -> [DarcsFlag] - -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y) -> IO (Sealed (FL Prim C(u))) tentativelyMergePatches = tentativelyMergePatches_ MakeChanges considerMergeToWorking :: RepoPatch p => Repository p C(r u t) -> String -> [DarcsFlag] - -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y) -> IO (Sealed (FL Prim C(u))) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges diff -ruN darcs-2.4.4/src/Darcs/Repository/Motd.lhs darcs-2.5/src/Darcs/Repository/Motd.lhs --- darcs-2.4.4/src/Darcs/Repository/Motd.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Motd.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -17,7 +17,7 @@ \begin{code} -module Darcs.Repository.Motd (get_motd, show_motd) where +module Darcs.Repository.Motd (getMotd, showMotd) where import Control.Monad ( unless ) import Darcs.Flags ( DarcsFlag( Quiet, XMLOutput ) ) import Darcs.External ( fetchFilePS, Cachable(..) ) @@ -34,15 +34,15 @@ \begin{code} -- | Fetch and return the message of the day for a given repository. -get_motd :: String -> IO B.ByteString -get_motd repo = fetchFilePS (repo++"/"++darcsdir++"/prefs/motd") (MaxAge 600) +getMotd :: String -> IO B.ByteString +getMotd repo = fetchFilePS (repo++"/"++darcsdir++"/prefs/motd") (MaxAge 600) `catchall` return B.empty -- | Display the message of the day for a given repository, -- unless either the 'XMLOutput' or the 'Quiet' flags are passed in -show_motd :: [DarcsFlag] -> String -> IO () -show_motd opts repo = unless (Quiet `elem` opts || XMLOutput `elem` opts) $ do - motd <- get_motd repo +showMotd :: [DarcsFlag] -> String -> IO () +showMotd opts repo = unless (Quiet `elem` opts || XMLOutput `elem` opts) $ do + motd <- getMotd repo unless (B.null motd) $ do B.hPut stdout motd putStrLn "**********************" diff -ruN darcs-2.4.4/src/Darcs/Repository/Prefs.lhs darcs-2.5/src/Darcs/Repository/Prefs.lhs --- darcs-2.4.4/src/Darcs/Repository/Prefs.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Prefs.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -31,7 +31,8 @@ boringRegexps, boringFileFilter, darcsdirFilter, FileType(..), filetypeFunction, getCaches, - binariesFileHelp + binariesFileHelp, + globalCacheDir ) where import System.IO.Error ( isDoesNotExistError ) @@ -39,7 +40,7 @@ import Text.Regex ( Regex, mkRegex, matchRegex, ) import Data.Char ( toUpper ) import Data.Maybe ( isJust, catMaybes ) -import Data.List ( nub, isPrefixOf, union ) +import Data.List ( nub, isPrefixOf, union, sortBy ) import System.Directory ( getAppUserDataDirectory ) import System.FilePath ( () ) import System.Environment ( getEnvironment ) @@ -54,8 +55,8 @@ import qualified Data.ByteString as B ( empty ) import Darcs.Global ( darcsdir ) import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..), - WritableOrNot(..) ) -import Darcs.URL ( is_file ) + WritableOrNot(..), compareByLocality ) +import Darcs.URL ( isFile ) \end{code} \section{prefs} @@ -116,7 +117,7 @@ \verb!_darcs/prefs/boring!, so be sure to copy that file to the boringfile. You can also set up a ``boring'' regexps -file in your home directory, named \verb!~/.darcs/boring!, +file in your home directory, named \verb!~/.darcs/boring!, on MS Windows~\ref{ms_win}, which will be used with all of your darcs repositories. @@ -237,7 +238,8 @@ isDarcsdir "" = True isDarcsdir ".." = True isDarcsdir "../" = True -isDarcsdir fp = darcsdir `isPrefixOf` fp +isDarcsdir "_darcs" = True +isDarcsdir fp = "_darcs/" `isPrefixOf` fp -- | The path of the global preference directory; @~/.darcs@ on Unix, -- and @%APPDATA%/darcs@ on Windows. @@ -433,7 +435,7 @@ defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] defaultrepo opts _ [] = - do let fixR r | not (is_file r) = return r + do let fixR r | not (isFile r) = return r | otherwise = do absr <- ioAbsolute r return $ toFilePath absr case [r | RemoteRepo r <- opts] of @@ -445,17 +447,26 @@ defaultrepo _ _ r = return r setDefaultrepo :: String -> [DarcsFlag] -> IO () -setDefaultrepo r opts = do doit <- if (NoSetDefault `notElem` opts && DryRun `notElem` opts && r_is_not_tmp) - then return True - else do olddef <- - getPreflist "defaultrepo" - return (olddef == []) - when doit - (setPreflist "defaultrepo" [r]) +setDefaultrepo r opts = do olddef <- getPreflist "defaultrepo" + let doit = NoSetDefault `notElem` opts && greenLight + greenLight = wetRun + && not rIsTmp + && (olddef /= [r] || olddef == []) + if doit + then setPreflist "defaultrepo" [r] + else when greenLight $ putStr . unlines $ + -- the nuance here is that we should only notify when the + -- reason we're not setting default is the --no-set-default + -- flag, not the various automatic show stoppers + [ "Note: if you want to change the default remote repository to" + , r ++ "," + , "quit now and issue the same command with the --set-default flag." + ] addToPreflist "repos" r `catchall` return () -- we don't care if this fails! where - r_is_not_tmp = not $ r `elem` [x | RemoteRepo x <- opts] + wetRun = DryRun `notElem` opts + rIsTmp = r `elem` [x | RemoteRepo x <- opts] \end{code} \paragraph{email} @@ -485,21 +496,16 @@ downloading patches multiple times when you pull from a remote repository to more than one local repository. -We strongly advise that you enable a global cache directory, which will -allow darcs to avoid re-downloading patches (for example, when doing a +A global cache is enabled by default in your home directory. The cache +allows darcs to avoid re-downloading patches (for example, when doing a second darcs get of the same repository), and also allows darcs to use hard -links to reduce disk usage. To do this, simply -\begin{verbatim} -mkdir -p $HOME/.darcs/cache -echo cache:$HOME/.darcs/cache > $HOME/.darcs/sources -\end{verbatim} +links to reduce disk usage. + Note that the cache directory should reside on the same filesystem as your repositories, so you may need to vary this. You can also use multiple cache directories on different filesystems, if you have several filesystems on which you use darcs. -On MS Windows~\ref{ms_win}) - \begin{code} getCaches :: [DarcsFlag] -> String -> IO Cache getCaches opts repodir = @@ -517,9 +523,10 @@ let thisrepo = if Ephemeral `elem` opts then [Cache Repo NotWritable $ toFilePath thisdir] else [Cache Repo Writable $ toFilePath thisdir] - return $ Ca $ nub $ thisrepo ++ globalcache ++ globalsources ++ + let tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++ here ++ [Cache Repo NotWritable repodir] ++ there - where + return $ Ca $ sortBy compareByLocality tempCache + where parsehs = catMaybes . map readln . noncomments readln l | take 5 l == "repo:" = Just (Cache Repo NotWritable (drop 5 l)) | take 9 l == "thisrepo:" = Just (Cache Repo Writable (drop 9 l)) @@ -528,6 +535,6 @@ | take 9 l == "readonly:" = Just (Cache Directory NotWritable (drop 9 l)) | otherwise = Nothing nocache = NoCache `elem` opts - + \end{code} diff -ruN darcs-2.4.4/src/Darcs/Repository/Pristine.hs darcs-2.5/src/Darcs/Repository/Pristine.hs --- darcs-2.4.4/src/Darcs/Repository/Pristine.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Pristine.hs 2010-10-24 08:29:26.000000000 -0700 @@ -23,7 +23,6 @@ module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine, createPristine, removePristine, identifyPristine, - slurpPristine, applyPristine, createPristineFromWorking, getPristinePop, pristineDirectory, pristineToFlagString, @@ -34,9 +33,7 @@ import Data.Maybe ( isJust ) import Control.Monad ( when, liftM ) import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, removeFile ) -import Darcs.Lock ( rm_recursive, writeBinFile ) -import Workaround ( getCurrentDirectory ) -import Darcs.SlurpDirectory ( Slurpy, mmap_slurp ) +import Darcs.Lock ( rmRecursive, writeBinFile ) import Darcs.PopulationData ( Population, getPopFrom ) import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) ) @@ -46,12 +43,12 @@ import Darcs.Patch ( Patchy, apply ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.FileName ( fp2fn ) -import qualified Data.ByteString as B (empty) import Darcs.RepoPath ( FilePathLike, toFilePath ) -import SHA1 ( sha1PS ) import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree ) import Darcs.Repository.InternalTypes ( Pristine(..) ) import Darcs.Global ( darcsdir ) +import Storage.Hashed.Darcs( writeDarcsHashed ) +import Storage.Hashed.Tree( emptyTree ) #include "impossible.h" nopristine :: Pristine @@ -67,7 +64,7 @@ Just pristine -> return pristine reallyIdentifyPristine :: IO (Maybe Pristine) -reallyIdentifyPristine = +reallyIdentifyPristine = do dir <- findpristine doesDirectoryExist "" none <- findpristine doesFileExist ".none" hashinv <- doesFileExist $ darcsdir++"/hashed_inventory" @@ -100,14 +97,15 @@ flagsToPristine [] rf = flagsToPristine [PristinePlain] rf createPristine :: Pristine -> IO Pristine -createPristine p = +createPristine p = do oldpristine <- reallyIdentifyPristine when (isJust oldpristine) $ fail "Pristine tree already exists." case p of NoPristine n -> writeBinFile n "Do not delete this file.\n" PlainPristine n -> createDirectory n HashedPristine -> do createDirectory hashedPristineDirectory - writeFile (hashedPristineDirectory++"/"++sha1PS B.empty) "" + writeDarcsHashed emptyTree "_darcs/pristine.hashed" + return () return p hashedPristineDirectory :: String @@ -115,16 +113,8 @@ removePristine :: Pristine -> IO () removePristine (NoPristine n) = removeFile n -removePristine (PlainPristine n) = rm_recursive n -removePristine HashedPristine = rm_recursive hashedPristineDirectory - -slurpPristine :: Pristine -> IO (Maybe Slurpy) -slurpPristine (PlainPristine n) = do cwd <- getCurrentDirectory - slurpy <- mmap_slurp (cwd ++ "/" ++ n) - return (Just slurpy) -slurpPristine (NoPristine _) = return Nothing -slurpPristine HashedPristine = - bug "HashedPristine is not implemented yet." +removePristine (PlainPristine n) = rmRecursive n +removePristine HashedPristine = rmRecursive hashedPristineDirectory applyPristine :: Patchy p => Pristine -> p C(x y) -> IO () applyPristine (NoPristine _) _ = return () diff -ruN darcs-2.4.4/src/Darcs/Repository/Repair.hs darcs-2.5/src/Darcs/Repository/Repair.hs --- darcs-2.4.4/src/Darcs/Repository/Repair.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/Repair.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,10 +1,10 @@ {-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, PatternGuards #-} module Darcs.Repository.Repair ( replayRepository, checkIndex , RepositoryConsistency(..) ) where - + import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO ) import Control.Applicative( (<$>) ) @@ -13,24 +13,30 @@ import Data.List ( sort, (\\) ) import System.Directory ( createDirectoryIfMissing ) -import Darcs.Lock( rm_recursive ) -import Darcs.Hopefully ( PatchInfoAnd, info ) +import Darcs.Lock( rmRecursive ) +import Darcs.Hopefully ( PatchInfoAnd, info, winfo, WPatchInfo, unWPatchInfo, compareWPatchInfo ) -import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL, - mapRL ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, reverseFL, + mapRL, nullFL, (:||:)(..), EqCheck(..) ) +import Darcs.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft ) import Darcs.Patch.Patchy ( applyAndTryToFix ) -import Darcs.Patch.Info ( PatchInfo( .. ), human_friendly ) -import Darcs.Patch.Set ( PatchSet ) -import Darcs.Patch ( RepoPatch ) +import Darcs.Hopefully( hopefully ) +import Darcs.Patch.Info ( humanFriendly ) +import Darcs.Patch.Set ( PatchSet(..), newset2FL, newset2RL ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif +import Darcs.Patch ( RepoPatch, isInconsistent ) +import Darcs.Patch.Core ( patchcontents ) -import Darcs.Repository.Format ( identifyRepoFormat, +import Darcs.Repository.Format ( identifyRepoFormat, RepoProperty ( HashedInventory ), formatHas ) import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) -import Darcs.Repository.HashedIO ( clean_hashdir ) +import Darcs.Repository.HashedIO ( cleanHashdir ) import Darcs.Repository.HashedRepo ( readHashedPristineRoot ) import Darcs.Repository.InternalTypes ( extractCache ) import Darcs.Repository.Prefs ( filetypeFunction ) -import Darcs.Repository ( Repository, read_repo, makePatchLazy +import Darcs.Repository ( Repository, readRepo, makePatchLazy , readRecorded, readIndex, readRecordedAndPending ) import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) @@ -53,83 +59,86 @@ import qualified Data.ByteString.Char8 as BS #include "impossible.h" +#include "gadts.h" -replaceInFL :: FL (PatchInfoAnd a) - -> [(PatchInfo, PatchInfoAnd a)] - -> FL (PatchInfoAnd a) +replaceInFL :: FL (PatchInfoAnd a) C(x y) + -> [Sealed2 (WPatchInfo :||: PatchInfoAnd a)] + -> FL (PatchInfoAnd a) C(x y) replaceInFL orig [] = orig replaceInFL NilFL _ = impossible -replaceInFL (o:>:orig) ch@((o',c):ch_rest) - | info o == o' = c:>:replaceInFL orig ch_rest +replaceInFL (o:>:orig) ch@(Sealed2 (o':||:c):ch_rest) + | IsEq <- winfo o `compareWPatchInfo` o' = c:>:replaceInFL orig ch_rest | otherwise = o:>:replaceInFL orig ch -applyAndFix :: forall p. RepoPatch p => Repository p -> FL (PatchInfoAnd p) -> TreeIO (FL (PatchInfoAnd p), Bool) +applyAndFix :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL (PatchInfoAnd p) C(Origin r) -> TreeIO (FL (PatchInfoAnd p) C(Origin r), Bool) applyAndFix _ NilFL = return (NilFL, True) applyAndFix r psin = do liftIO $ beginTedious k liftIO $ tediousSize k $ lengthFL psin (repaired, ok) <- aaf psin liftIO $ endTedious k - orig <- liftIO $ (reverseRL . concatRL) `fmap` read_repo r + orig <- liftIO $ newset2FL `fmap` readRepo r return (replaceInFL orig repaired, ok) where k = "Replaying patch" - aaf :: FL (PatchInfoAnd p) -> TreeIO ([(PatchInfo, PatchInfoAnd p)], Bool) + aaf :: FL (PatchInfoAnd p) C(w z) -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd p)], Bool) aaf NilFL = return ([], True) aaf (p:>:ps) = do mp' <- applyAndTryToFix p - let !infp = info p -- assure that 'p' can be garbage collected. - liftIO $ finishedOneIO k $ show $ human_friendly $ infp + case isInconsistent . patchcontents . hopefully $ p of + Just err -> liftIO $ putDocLn err + Nothing -> return () + let !winfp = winfo p -- assure that 'p' can be garbage collected. + liftIO $ finishedOneIO k $ show $ humanFriendly $ unWPatchInfo winfp (ps', restok) <- aaf ps case mp' of Nothing -> return (ps', restok) Just (e,pp) -> do liftIO $ putStrLn e p' <- liftIO $ makePatchLazy r pp - return ((infp, p'):ps', False) + return (Sealed2 (winfp :||: p'):ps', False) -data RepositoryConsistency p = +data RepositoryConsistency p C(x) = RepositoryConsistent | BrokenPristine (Tree IO) - | BrokenPatches (Tree IO) (PatchSet p) + | BrokenPatches (Tree IO) (PatchSet p C(Origin x)) -check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO () -check_uniqueness putVerbose putInfo repository = +checkUniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p C(r u t) -> IO () +checkUniqueness putVerbose putInfo repository = do putVerbose $ text "Checking that patch names are unique..." - r <- read_repo repository - case has_duplicate $ mapRL info $ concatRL r of + r <- readRepo repository + case hasDuplicate $ mapRL info $ newset2RL r of Nothing -> return () Just pinf -> do putInfo $ text "Error! Duplicate patch name:" - putInfo $ human_friendly pinf + putInfo $ humanFriendly pinf fail "Duplicate patches found." -has_duplicate :: Ord a => [a] -> Maybe a -has_duplicate li = hd $ sort li +hasDuplicate :: Ord a => [a] -> Maybe a +hasDuplicate li = hd $ sort li where hd [_] = Nothing hd [] = Nothing hd (x1:x2:xs) | x1 == x2 = Just x1 | otherwise = hd (x2:xs) -replayRepository' :: (RepoPatch p) => Repository p -> [DarcsFlag] -> IO (RepositoryConsistency p) +replayRepository' :: (RepoPatch p) + => Repository p C(r u t) -> [DarcsFlag] -> IO (RepositoryConsistency p C(r)) replayRepository' repo opts = do let putVerbose s = when (Verbose `elem` opts) $ putDocLn s putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s - check_uniqueness putVerbose putInfo repo + checkUniqueness putVerbose putInfo repo createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed" putVerbose $ text "Reading recorded state..." pris <- readRecorded repo `catch` \_ -> return emptyTree putVerbose $ text "Applying patches..." - patches <- read_repo repo + patches <- readRepo repo debugMessage "Fixing any broken patches..." - let psin = reverseRL $ concatRL patches + let psin = newset2FL patches repair = applyAndFix repo psin ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree "_darcs/pristine.hashed" debugMessage "Done fixing broken patches..." - let newpatches = reverseFL ps :<: NilRL + let newpatches = PatchSet (reverseFL ps) NilRL debugMessage "Checking pristine against slurpy" ftf <- filetypeFunction - is_same <- do diff <- treeDiff ftf pris newpris - return $ case diff of - NilFL -> True - _ -> False + is_same <- do Sealed diff <- unFreeLeft `fmap` treeDiff ftf pris newpris + return $ nullFL diff `catchall` return False -- TODO is the latter condition needed? Does a broken patch imply pristine -- difference? Why, or why not? @@ -139,25 +148,25 @@ then BrokenPristine newpris else BrokenPatches newpris newpatches) -cleanupRepositoryReplay :: Repository p -> IO () +cleanupRepositoryReplay :: Repository p C(r u t) -> IO () cleanupRepositoryReplay r = do let c = extractCache r rf_or_e <- identifyRepoFormat "." rf <- case rf_or_e of Left e -> fail e Right x -> return x unless (formatHas HashedInventory rf) $ - rm_recursive $ darcsdir ++ "/pristine.hashed" + rmRecursive $ darcsdir ++ "/pristine.hashed" when (formatHas HashedInventory rf) $ do current <- readHashedPristineRoot r - clean_hashdir c HashedPristineDir $ catMaybes [current] + cleanHashdir c HashedPristineDir $ catMaybes [current] -replayRepository :: (RepoPatch p) => Repository p -> [DarcsFlag] -> (RepositoryConsistency p -> IO a) -> IO a +replayRepository :: (RepoPatch p) => Repository p C(r u t) -> [DarcsFlag] -> (RepositoryConsistency p C(r) -> IO a) -> IO a replayRepository r opt f = run `finally` cleanupRepositoryReplay r where run = do st <- replayRepository' r opt f st -checkIndex :: (RepoPatch p) => Repository p -> Bool -> IO Bool +checkIndex :: (RepoPatch p) => Repository p C(r u t) -> Bool -> IO Bool checkIndex repo quiet = do index <- updateIndex =<< readIndex repo pristine <- expand =<< readRecordedAndPending repo diff -ruN darcs-2.4.4/src/Darcs/Repository/State.hs darcs-2.5/src/Darcs/Repository/State.hs --- darcs-2.4.4/src/Darcs/Repository/State.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository/State.hs 2010-10-24 08:29:26.000000000 -0700 @@ -24,9 +24,9 @@ -- SOFTWARE. module Darcs.Repository.State - ( restrictSubpaths, restrictBoring + ( restrictSubpaths, restrictBoring, TreeFilter(..) -- * Diffs. - , unrecordedChanges, readPending, pendingChanges + , unrecordedChanges, readPending -- * Trees. , readRecorded, readUnrecorded, readRecordedAndPending, readWorking -- * Index. @@ -46,16 +46,17 @@ import Darcs.Patch ( RepoPatch, Prim, invert, applyToTree, applyToFilepaths , sortCoalesceFL ) -import Darcs.Patch.TouchesFiles ( choose_touching ) +import Darcs.Patch.TouchesFiles ( chooseTouching ) import Darcs.Witnesses.Ordered ( FL(..), (+>+) ) -import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal ) +import Darcs.Witnesses.Ordered ( unsafeCoerceP, EqCheck(IsEq) ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft ) import Darcs.Diff ( treeDiff ) import Darcs.Flags ( DarcsFlag( LookForAdds ), willIgnoreTimes ) import Darcs.Global ( darcsdir ) import Darcs.Utils ( filterPaths ) import Darcs.Repository.InternalTypes ( Repository ) -import Darcs.Repository.LowLevel( read_pending ) +import qualified Darcs.Repository.LowLevel as LowLevel import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps ) import Darcs.Patch.FileName ( fn2fp ) @@ -71,6 +72,8 @@ #include "gadts.h" +newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m } + -- | From a repository and a list of SubPath's, construct a filter that can be -- used on a Tree (recorded or unrecorded state) of this repository. This -- constructed filter will take pending into account, so the subpaths will be @@ -78,15 +81,15 @@ -- convenience, if the subpath list is empty, the filter constructed is an -- identity. restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] - -> IO (forall t m. FilterTree t m => t m -> t m) + -> IO (TreeFilter m) restrictSubpaths repo subpaths = do - Sealed pending <- read_pending repo + Sealed pending <- LowLevel.readPending repo let paths = map (fn2fp . sp2fn) subpaths paths' = paths `union` applyToFilepaths pending paths anchored = map floatPath paths' restrictPaths :: FilterTree t m => t m -> t m restrictPaths = if null subpaths then id else filter (filterPaths anchored) - return restrictPaths + return (TreeFilter restrictPaths) -- | Construct a Tree filter that removes any boring files the Tree might have -- contained. Additionally, you should (in most cases) pass an (expanded) Tree @@ -99,7 +102,7 @@ -- full working copy of the repository, including untracked -- files. Cf. whatsnew, record --look-for-adds. NB. Assumes that our CWD is -- the repository root. -restrictBoring :: forall t m. Tree m -> IO (FilterTree t m => t m -> t m) +restrictBoring :: forall m . Tree m -> IO (TreeFilter m) restrictBoring guide = do boring <- boringRegexps let boring' (AnchoredPath (Name x:_)) | x == BSC.pack darcsdir = False @@ -109,14 +112,17 @@ restrictTree = filter $ \p _ -> case find guide p of Nothing -> boring' p _ -> True - return restrictTree + return (TreeFilter restrictTree) -- | For a repository and a list of paths (when empty, take everything) compute -- a (forward) list of prims (i.e. a patch) going from the recorded state of -- the repository (pristine) to the unrecorded state of the repository (the --- working copy + pending). When a non-empty list of paths is given, exactly +-- working copy + pending). When a non-empty list of paths is given, at least -- the files that live under any of these paths in either recorded or --- unrecorded will be included in the resulting patch. +-- unrecorded will be included in the resulting patch. NB. More patches may be +-- included in this list, eg. the full contents of the pending patch. This is +-- usually not a problem, since selectChanges will properly filter the results +-- anyway. -- -- This also depends on the options given: with LookForAdds, we will include -- any non-boring files (i.e. also those that do not exist in the "recorded" @@ -128,29 +134,30 @@ -- is very inefficient, although in extremely rare cases, the index could go -- out of sync (file is modified, index is updated and file is modified again -- within a single second). -unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) - -> [SubPath] -> IO (FL Prim C(r y)) +unrecordedChanges :: FORALL(p r u t) (RepoPatch p) + => [DarcsFlag] -> Repository p C(r u t) + -> [SubPath] -> IO (FL Prim C(t u)) unrecordedChanges opts repo paths = do - (all_current, _) <- readPending repo - Sealed pending <- pendingChanges repo paths + (all_current, Sealed (pending :: FL Prim C(t x))) <- readPending repo relevant <- restrictSubpaths repo paths - let getIndex = I.updateIndex =<< (relevant <$> readIndex repo) - current = relevant all_current + let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) + current = applyTreeFilter relevant all_current working <- case (LookForAdds `elem` opts, willIgnoreTimes opts) of (False, False) -> getIndex (False, True) -> do guide <- expand current - relevant <$> restrict guide <$> readPlainTree "." + applyTreeFilter relevant <$> restrict guide <$> readPlainTree "." (True, ignoretimes) -> do index <- getIndex nonboring <- restrictBoring index - plain <- relevant <$> nonboring <$> readPlainTree "." + plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "." return $ if ignoretimes then plain else plain `overlay` index ft <- filetypeFunction - diff <- treeDiff ft current working + Sealed (diff :: FL Prim C(x y)) <- (unFreeLeft `fmap` treeDiff ft current working) :: IO (Sealed (FL Prim C(x))) + IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck C(y u)) return $ sortCoalesceFL (pending +>+ diff) -- | Obtains a Tree corresponding to the "recorded" state of the repository: @@ -183,9 +190,16 @@ (_, _) -> fail "No pristine tree is available!" -- | Obtains a Tree corresponding to the "unrecorded" state of the repository: --- the working tree plus the "pending" patch. -readUnrecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO) -readUnrecorded repo = readIndex repo >>= I.updateIndex +-- the working tree plus the "pending" patch. The optional list of paths (it is +-- ignored if empty) allows to restrict the query to a subtree. +-- +-- Limiting the query may be more efficient, since hashes on the uninteresting +-- parts of the index do not need to go through an up-to-date check (which +-- involves a relatively expensive lstat(2) per file. +readUnrecorded :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO (Tree IO) +readUnrecorded repo paths = do + relevant <- restrictSubpaths repo paths + readIndex repo >>= I.updateIndex . applyTreeFilter relevant -- | Obtains a Tree corresponding to the working copy of the -- repository. NB. Almost always, using readUnrecorded is the right @@ -198,12 +212,12 @@ readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO) readRecordedAndPending repo = do pristine <- readRecorded repo - Sealed pending <- pendingChanges repo [] + Sealed pending <- snd `fmap` readPending repo applyToTree pending pristine -readPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO, Sealed (FL Prim C(r))) +readPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO, Sealed (FL Prim C(t))) readPending repo = - do Sealed pending <- read_pending repo + do Sealed pending <- LowLevel.readPending repo pristine <- readRecorded repo catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ err -> do putStrLn $ "Yikes, pending has conflicts! " ++ show err @@ -212,17 +226,6 @@ "_darcs/patches/pending_buggy" return (pristine, seal NilFL) -pendingChanges :: (RepoPatch p) => Repository p C(r u t) - -> [SubPath] -> IO (Sealed (FL Prim C(r))) -pendingChanges repo paths = do - Sealed pending <- snd `fmap` readPending repo - let files = map (fn2fp . sp2fn) paths - pre_files = applyToFilepaths (invert pending) files - relevant = case paths of - [] -> seal pending - _ -> choose_touching pre_files pending - return relevant - -- | Mark the existing index as invalid. This has to be called whenever the -- listing of pristine changes and will cause darcs to update the index next -- time it tries to read it. (NB. This is about files added and removed from diff -ruN darcs-2.4.4/src/Darcs/Repository.hs darcs-2.5/src/Darcs/Repository.hs --- darcs-2.4.4/src/Darcs/Repository.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Repository.hs 2010-10-24 08:29:26.000000000 -0700 @@ -22,42 +22,43 @@ #include "gadts.h" module Darcs.Repository - ( Repository, ($-), maybeIdentifyRepository, identifyRepositoryFor + ( Repository, HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..), ($-), maybeIdentifyRepository, identifyRepositoryFor , withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory , withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository - , amNotInRepository, slurp_pending, replacePristine, slurp_recorded - , slurp_recorded_and_unrecorded, withRecorded, read_repo, prefsUrl - , add_to_pending, tentativelyAddPatch, tentativelyRemovePatches - , tentativelyAddToPending, tentativelyReplacePatches + , amNotInRepository, replacePristine + , withRecorded, readRepo, prefsUrl + , addToPending, tentativelyAddPatch, tentativelyRemovePatches + , tentativelyAddToPending, tentativelyReplacePatches, readTentativeRepo , tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges , finalizeRepositoryChanges, createRepository, copyRepository - , copy_oldrepo_patches, patchSetToRepository, unrevertUrl, applyToWorking + , copyOldrepoPatches, patchSetToRepository, unrevertUrl, applyToWorking , patchSetToPatches, createPristineDirectoryTree , createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository , getMarkedupFile, PatchSet, SealedPatchSet, PatchInfoAnd , setScriptsExecutable, checkUnrelatedRepos, testTentative, testRecorded + , extractOptions, modifyCache -- * Recorded and unrecorded and pending. - , readRecorded, readUnrecorded, unrecordedChanges, readPending, pendingChanges + , readRecorded, readUnrecorded, unrecordedChanges, readPending , readRecordedAndPending -- * Index. , readIndex, invalidateIndex ) where import System.Exit ( ExitCode(..), exitWith ) +import Data.List ( isSuffixOf ) +import Data.Maybe( catMaybes ) import Darcs.Repository.State( readRecorded, readUnrecorded, readWorking, unrecordedChanges - , readPending, pendingChanges, readIndex, invalidateIndex + , readPending, readIndex, invalidateIndex , readRecordedAndPending ) import Darcs.Repository.Internal (Repository(..), RepoType(..), ($-), - maybeIdentifyRepository, identifyRepositoryFor, + maybeIdentifyRepository, identifyRepositoryFor, IdentifyRepo(..), findRepository, amInRepository, amNotInRepository, makePatchLazy, - slurp_pending, - slurp_recorded, slurp_recorded_and_unrecorded, withRecorded, - read_repo, + readRepo, readTentativeRepo, prefsUrl, withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf, tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, @@ -70,46 +71,54 @@ getMarkedupFile, setScriptsExecutable, testTentative, testRecorded, - make_new_pending + makeNewPending ) import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking ) -import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) ) -import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.Repository.Cache ( unionRemoteCaches, fetchFileUsingCache, + speculateFileUsingCache, HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..)) +import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2RL, newset2FL, progressPatchSet ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif +import URL ( maxPipelineLength ) +import Control.Applicative ( (<$>) ) import Control.Monad ( unless, when ) -import Data.Either(Either(..)) -import System.Directory ( createDirectory, renameDirectory ) +import System.Directory ( createDirectory, renameDirectory, + createDirectoryIfMissing, renameFile ) import System.IO.Error ( isAlreadyExistsError ) import qualified Darcs.Repository.DarcsRepo as DarcsRepo import qualified Darcs.Repository.HashedRepo as HashedRepo import Darcs.Hopefully ( PatchInfoAnd, info, extractHash ) -import Darcs.Repository.Checkpoint ( identify_checkpoint, write_checkpoint_patch, get_checkpoint ) -import Darcs.Repository.ApplyPatches ( apply_patches ) -import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine, pris2inv ) -import Darcs.Repository.InternalTypes ( Pristine(..) ) +import Darcs.Repository.Checkpoint ( identifyCheckpoint, writeCheckpointPatch, getCheckpoint ) +import Darcs.Repository.ApplyPatches ( applyPatches ) +import Darcs.Repository.HashedRepo ( applyToTentativePristine, pris2inv, revertTentativeChanges, + copySources ) +import Darcs.Repository.InternalTypes ( Pristine(..), extractOptions, modifyCache ) import Darcs.Patch ( RepoPatch, Named, Prim, Patch, patch2patchinfo, apply ) -import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL - , reverseRL ,concatRL, lengthRL, isShorterThanRL, (+>+) ) +import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL + , reverseRL ,lengthRL, (+>+), (:\/:)(..) ) import Darcs.Patch.Info ( PatchInfo ) -import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), +import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), RepoFormat, createRepoFormat, formatHas, writeRepoFormat ) import Darcs.Repository.Prefs ( writeDefaultPrefs ) import Darcs.Repository.Pristine ( createPristine, flagsToPristine, createPristineFromWorking ) -import Darcs.Patch.Depends ( get_patches_beyond_tag ) +import Darcs.Patch.Depends ( getPatchesBeyondTag, areUnrelatedRepos, findUncommon ) + import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError ) -import Darcs.External ( copyFileOrUrl, Cachable(..) ) -import Progress ( debugMessage, tediousSize, - beginTedious, endTedious, progress ) +import Darcs.External ( copyFileOrUrl, Cachable(..), fetchFileLazyPS ) +import Progress ( debugMessage, tediousSize, beginTedious, endTedious ) import Darcs.ProgressPatches (progressRLShowTags, progressFL) -import Darcs.Lock ( writeBinFile, writeDocBinFile, rm_recursive ) +import Darcs.Lock ( writeBinFile, writeDocBinFile, rmRecursive, withTemp ) import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped ) import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral, Complete, AllowUnrelatedRepos, NoUpdateWorking ) , compression ) import Darcs.Global ( darcsdir ) +import Darcs.URL ( isFile ) import Storage.Hashed.Tree( Tree, emptyTree ) import Storage.Hashed.Hash( encodeBase16 ) @@ -118,8 +127,10 @@ import ByteStringUtils( gzReadFilePS ) import System.FilePath( () ) - +import qualified Codec.Archive.Tar as Tar +import Codec.Compression.GZip ( compress, decompress ) import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL #include "impossible.h" @@ -137,7 +148,7 @@ writeRepoFormat rf (darcsdir++"/format") if formatHas HashedInventory rf then writeBinFile (darcsdir++"/hashed_inventory") "" - else DarcsRepo.write_inventory "." ((NilRL:<:NilRL) :: PatchSet Patch C(())) -- YUCK! + else DarcsRepo.writeInventory "." (PatchSet NilRL NilRL :: PatchSet Patch C(Origin Origin)) -- YUCK! copyRepository :: RepoPatch p => Repository p C(r u t) -> IO () copyRepository fromrepository@(Repo _ opts rf _) @@ -151,44 +162,48 @@ data RepoSort = Hashed | Old +repoSort :: RepoFormat -> RepoSort +repoSort f + | formatHas HashedInventory f = Hashed + | otherwise = Old + copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO () -copyInventory fromrepo@(Repo fromdir opts rf (DarcsRepository _ cremote)) = do - repo@(Repo todir xx rf2 (DarcsRepository yy c)) <- identifyRepositoryFor fromrepo "." - let newrepo :: Repository p C(r u t) - newrepo = Repo todir xx rf2 (DarcsRepository yy (c `unionCaches` cremote)) - copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir - copyAnythingToOld r = withCurrentDirectory todir $ read_repo r >>= - DarcsRepo.write_inventory_and_patches opts - repoSort rfx | formatHas HashedInventory rfx = Hashed - | otherwise = Old - case repoSort rf2 of - Hashed -> - if formatHas HashedInventory rf - then copyHashedHashed - else withCurrentDirectory todir $ - do HashedRepo.revert_tentative_changes - patches <- read_repo fromrepo +copyInventory fromRepo@(Repo fromDir opts fromFormat (DarcsRepository _ fromCache)) = do + toRepo@(Repo toDir opts' toFormat (DarcsRepository toPristine toCache)) <- + identifyRepositoryFor fromRepo "." + toCache2 <- unionRemoteCaches toCache fromCache fromDir + let toRepo2 :: Repository p C(r u t) + toRepo2 = Repo toDir opts' toFormat $ DarcsRepository toPristine toCache2 + copyHashedHashed = HashedRepo.copyRepo toRepo2 opts fromDir + copyAnyToOld r = withCurrentDirectory toDir $ readRepo r >>= + DarcsRepo.writeInventoryAndPatches opts + case repoSort fromFormat of + Hashed -> case repoSort toFormat of + Hashed -> copyHashedHashed + Old -> copyAnyToOld fromRepo + Old -> case repoSort toFormat of + Hashed -> withCurrentDirectory toDir $ do + HashedRepo.revertTentativeChanges + patches <- readRepo fromRepo let k = "Copying patch" beginTedious k - tediousSize k (lengthRL $ concatRL patches) - let patches' = mapRL_RL (mapRL_RL (progress k)) patches - HashedRepo.write_tentative_inventory c (compression opts) patches' + tediousSize k (lengthRL $ newset2RL patches) + let patches' = progressPatchSet k patches + HashedRepo.writeTentativeInventory toCache (compression opts) patches' endTedious k - HashedRepo.finalize_tentative_changes repo (compression opts) - Old -> case repoSort rf of - Hashed -> copyAnythingToOld fromrepo - _ -> copy_oldrepo_patches opts fromrepo todir - -copy_oldrepo_patches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO () -copy_oldrepo_patches opts repository@(Repo dir _ _ _) out = do - Sealed patches <- DarcsRepo.read_repo opts "." :: IO (SealedPatchSet Patch) + HashedRepo.finalizeTentativeChanges toRepo $ compression opts + Old -> copyOldrepoPatches opts fromRepo toDir + +copyOldrepoPatches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO () +copyOldrepoPatches opts repository@(Repo dir _ _ _) out = do + Sealed patches <- DarcsRepo.readRepo opts "." :: IO (SealedPatchSet Patch C(Origin)) mpi <- if Partial `elem` opts -- FIXME this should get last pinfo *before* -- desired tag... - then identify_checkpoint repository + then identifyCheckpoint repository else return Nothing - FlippedSeal scp <- return $ since_checkpoint mpi $ concatRL patches - DarcsRepo.copy_patches opts dir out $ mapRL info $ scp + FlippedSeal scp <- return $ since_checkpoint mpi $ newset2RL patches + DarcsRepo.copyPatches opts dir out $ mapRL info $ scp where since_checkpoint :: Maybe PatchInfo -> RL (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (PatchInfoAnd p)) C(y) since_checkpoint Nothing ps = flipSeal ps @@ -199,118 +214,184 @@ copyPartialRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO PorNP copyPartialRepository fromrepository@(Repo _ opts _ _) = do - mch <- get_checkpoint fromrepository :: IO (Maybe (Sealed (Named p C(x)))) + mch <- getCheckpoint fromrepository :: IO (Maybe (Sealed (Named p C(x)))) case mch of Nothing -> do putStrLn "No checkpoint." return NotPartial Just (Sealed ch) -> do copyInventory fromrepository withRepoLock opts $- \torepository -> do - write_checkpoint_patch ch - local_patches <- read_repo torepository + writeCheckpointPatch ch + local_patches <- readRepo torepository let pi_ch = patch2patchinfo ch - FlippedSeal ps <- return $ get_patches_beyond_tag pi_ch local_patches + FlippedSeal ps <- return $ getPatchesBeyondTag pi_ch local_patches let needed_patches = reverseRL ps apply opts ch `catch` \e -> fail ("Bad checkpoint!\n" ++ prettyError e) - apply_patches opts needed_patches + applyPatches opts needed_patches debugMessage "Writing the pristine" pristineFromWorking torepository return IsPartial copyFullRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO () -copyFullRepository fromrepository@(Repo fromdir opts rffrom _) = do - copyInventory fromrepository +copyFullRepository fromRepo@(Repo fromDir opts _ _) = do debugMessage "Copying prefs" - copyFileOrUrl opts (fromdir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600) - `catchall` return () + copyFileOrUrl opts (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs") + (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return () + if True -- isFile fromDir -- packs disabled for darcs 2.5 + then copyNotPackedRepository fromRepo + else do + b <- (Just <$> fetchFileLazyPS (fromDir ++ "/" ++ darcsdir ++ + "/packs/basic.tar.gz") Uncachable) `catchall` return Nothing + case b of + Nothing -> copyNotPackedRepository fromRepo + Just b' -> copyPackedRepository fromRepo b' + +copyNotPackedRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO () +copyNotPackedRepository fromrepository@(Repo _ opts rffrom _) = do + copyInventory fromrepository debugMessage "Grabbing lock in new repository..." - withRepoLock opts $- \torepository@(Repo _ _ rfto (DarcsRepository _ c)) -> + withRepoLock opts $- \torepository@(Repo _ _ rfto _) -> if formatHas HashedInventory rffrom && formatHas HashedInventory rfto then do debugMessage "Writing working directory contents..." createPristineDirectoryTree torepository "." - fetch_patches_if_necessary opts torepository + fetchPatchesIfNecessary opts torepository when (Partial `elem` opts) $ putStrLn $ "--partial: hashed or darcs-2 repository detected, using --lazy instead" else if formatHas HashedInventory rfto - then do local_patches <- read_repo torepository + then do local_patches <- readRepo torepository replacePristine torepository emptyTree - let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $ - mapRL_RL reverseRL local_patches - sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply + let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches + sequence_ $ mapFL (applyToTentativePristine opts) $ bunchFL 100 patchesToApply finalizeRepositoryChanges torepository debugMessage "Writing working directory contents..." createPristineDirectoryTree torepository "." - else do read_repo torepository >>= (apply_patches opts . reverseRL . concatRL) + else do readRepo torepository >>= (applyPatches opts . newset2FL) debugMessage "Writing the pristine" pristineFromWorking torepository +copyPackedRepository :: forall p C(r u t). RepoPatch p => + Repository p C(r u t) -> BL.ByteString -> IO () +copyPackedRepository fromRepo@(Repo fromDir opts _ (DarcsRepository _ fromCache)) b = do + Repo toDir _ toFormat (DarcsRepository toPristine toCache) <- + identifyRepositoryFor fromRepo "." + toCache2 <- unionRemoteCaches toCache fromCache fromDir + let toRepo :: Repository p C(r u r) -- In empty repo, t(entative) = r(ecorded) + toRepo = Repo toDir opts toFormat $ DarcsRepository toPristine toCache2 + fromPacksDir = fromDir ++ "/" ++ darcsdir ++ "/packs/" + createDirectoryIfMissing False $ toDir darcsdir "inventories" + createDirectoryIfMissing False $ toDir darcsdir "pristine.hashed" + createDirectoryIfMissing False $ toDir darcsdir "patches" + copySources toRepo fromDir + -- unpack inventory & pristine cache + writeCompressed . Tar.read $ decompress b + createPristineDirectoryTree toRepo "." + -- pull new patches + us <- readRepo toRepo + them <- readRepo fromRepo + us' :\/: them' <- return $ findUncommon us them + revertTentativeChanges + Sealed pw <- tentativelyMergePatches toRepo "get" opts us' them' + invalidateIndex toRepo + withGutsOf toRepo $ do + finalizeRepositoryChanges toRepo + applyToWorking toRepo opts pw + return () + -- get old patches + unless (any (`elem` opts) [Partial, Lazy, Ephemeral]) $ do + putInfo "Copying patches, to get lazy repository hit ctrl-C..." + writeCompressed . Tar.read . decompress =<< fetchFileLazyPS (fromPacksDir ++ + "patches.tar.gz") Uncachable + where + writeCompressed Tar.Done = return () + writeCompressed (Tar.Next x xs) = case Tar.entryContent x of + Tar.NormalFile x' _ -> do + let p = Tar.entryPath x + withTemp $ \p' -> do + BL.writeFile p' $ if "hashed_inventory" `isSuffixOf` p + then x' + else compress x' + renameFile p' p + writeCompressed xs + _ -> fail "Unexpected non-file tar entry" + writeCompressed (Tar.Fail e) = fail e + putInfo = when (not $ Quiet `elem` opts) . putStrLn + -- | writePatchSet is like patchSetToRepository, except that it doesn't -- touch the working directory or pristine cache. -writePatchSet :: RepoPatch p => PatchSet p C(x) -> [DarcsFlag] -> IO (Repository p C(r u t)) +writePatchSet :: RepoPatch p => PatchSet p C(Origin x) -> [DarcsFlag] -> IO (Repository p C(r u t)) writePatchSet patchset opts = do maybeRepo <- maybeIdentifyRepository opts "." - let repo@(Repo _ _ rf2 (DarcsRepository _ c)) = + let repo@(Repo _ _ rf2 (DarcsRepository _ c)) = case maybeRepo of - Right r -> r - Left e -> bug ("Current directory not repository in writePatchSet: " ++ e) + GoodRepository r -> r + BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e) + NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e) debugMessage "Writing inventory" if formatHas HashedInventory rf2 - then do HashedRepo.write_tentative_inventory c (compression opts) patchset - HashedRepo.finalize_tentative_changes repo (compression opts) - else DarcsRepo.write_inventory_and_patches opts patchset + then do HashedRepo.writeTentativeInventory c (compression opts) patchset + HashedRepo.finalizeTentativeChanges repo (compression opts) + else DarcsRepo.writeInventoryAndPatches opts patchset return repo -- | patchSetToRepository takes a patch set, and writes a new repository in the current directory -- that contains all the patches in the patch set. This function is used when 'darcs get'ing a -- repository with the --to-match flag and the new repository is not in hashed format. --- This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell +-- This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell -- darcs to create a hashed repository, this function will call @error@. -patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(x) +patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(Origin x) -> [DarcsFlag] -> IO (Repository p C(r u t)) patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do when (formatHas HashedInventory rf) $ -- set up sources and all that do writeFile "_darcs/tentative_pristine" "" -- this is hokey repox <- writePatchSet patchset opts - HashedRepo.copy_repo repox opts fromrepo + HashedRepo.copyRepo repox opts fromrepo repo <- writePatchSet patchset opts - read_repo repo >>= (apply_patches opts . reverseRL . concatRL) + readRepo repo >>= (applyPatches opts . newset2FL) debugMessage "Writing the pristine" pristineFromWorking repo return repo -checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(y) -> IO () -checkUnrelatedRepos opts common us them - | AllowUnrelatedRepos `elem` opts || not (null common) - || concatRL us `isShorterThanRL` 5 || concatRL them `isShorterThanRL` 5 - = return () - | otherwise - = do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?") - when (yorn /= 'y') $ do putStrLn "Cancelled." - exitWith ExitSuccess +checkUnrelatedRepos :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> PatchSet p C(start y) + -> IO () +checkUnrelatedRepos opts _ _ | AllowUnrelatedRepos `elem` opts = return () +checkUnrelatedRepos _ us them = + if areUnrelatedRepos us them + then do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?") + when (yorn /= 'y') $ do putStrLn "Cancelled." + exitWith ExitSuccess + else return () -- | Unless a flag has been given in the first argument that tells darcs not to do so (--lazy, --- --partial or --ephemeral), this function fetches all patches that the given repository has +-- --partial or --ephemeral), this function fetches all patches that the given repository has -- with fetchFileUsingCache. This is used as a helper in copyFullRepository. -fetch_patches_if_necessary :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO () -fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) = +fetchPatchesIfNecessary :: forall p C(r u t). RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO () +fetchPatchesIfNecessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) = unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $ do unless (Complete `elem` opts) $ putInfo "Copying patches, to get lazy repository hit ctrl-C..." - r <- read_repo torepository - let peekaboo :: PatchInfoAnd p C(x y) -> IO () - peekaboo x = case extractHash x of - Left _ -> return () - Right h -> fetchFileUsingCache c HashedPatchesDir h >> return () - sequence_ $ mapRL peekaboo $ progressRLShowTags "Copying patches" $ concatRL r + r <- readRepo torepository + pipelineLength <- maxPipelineLength + let patches = newset2RL r + ppatches = progressRLShowTags "Copying patches" patches + (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches + speculate | pipelineLength > 1 = [] : first : map (:[]) other + | otherwise = [] + mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat []) where putInfo = when (not $ Quiet `elem` opts) . putStrLn - -add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO () -add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () -add_to_pending repo@(Repo _ opts _ _) p = + hashes :: FORALL(x y) RL (PatchInfoAnd p) C(x y) -> [String] + hashes = catMaybes . mapRL ((either (const Nothing) Just) . extractHash) + fetchAndSpeculate :: (String, [String]) -> IO () + fetchAndSpeculate (f, ss) = do + fetchFileUsingCache c HashedPatchesDir f + mapM_ (speculateFileUsingCache c HashedPatchesDir) ss + +addToPending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO () +addToPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +addToPending repo@(Repo _ opts _ _) p = do pend <- unrecordedChanges opts repo [] invalidateIndex repo - make_new_pending repo (pend +>+ p) + makeNewPending repo (pend +>+ p) -- | Replace the existing pristine with a new one (loaded up in a Tree object). replacePristine :: Repository p C(r u t) -> Tree IO -> IO () @@ -323,7 +404,7 @@ root <- writeDarcsHashed tree' $ darcsdir "pristine.hashed" writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i replace (PlainPristine n) = - do rm_recursive nold `catchall` return () + do rmRecursive nold `catchall` return () writePlainTree tree ntmp renameDirectory n nold renameDirectory ntmp n @@ -338,4 +419,3 @@ withCurrentDirectory dir $ readWorking >>= replacePristine repo pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) = withCurrentDirectory dir $ createPristineFromWorking p - diff -ruN darcs-2.4.4/src/Darcs/Resolution.lhs darcs-2.5/src/Darcs/Resolution.lhs --- darcs-2.4.4/src/Darcs/Resolution.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Resolution.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -21,9 +21,9 @@ #include "gadts.h" -module Darcs.Resolution ( standard_resolution, - external_resolution, - patchset_conflict_resolutions, +module Darcs.Resolution ( standardResolution, + externalResolution, + patchsetConflictResolutions, ) where import System.FilePath.Posix ( () ) @@ -44,9 +44,11 @@ import CommandLine ( parseCmd ) import Darcs.Hopefully ( hopefully ) import Darcs.Utils ( askUser, filterFilePaths ) -import Darcs.Patch.Set ( PatchSet ) -import Darcs.Witnesses.Sealed ( seal ) -import Darcs.Witnesses.Sealed ( Sealed(..) ) +import Darcs.Patch.Set ( PatchSet(..) ) +#ifdef GADT_WITNESSES +import Darcs.Patch.Set ( Origin ) +#endif +import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft ) import Darcs.Repository.Prefs ( filetypeFunction ) import Exec ( exec, Redirect(..) ) import Darcs.Lock ( withTempDir ) @@ -59,11 +61,11 @@ --import Printer ( greenText, ($$), Doc ) --import Darcs.Patch ( showPatch ) -standard_resolution :: RepoPatch p => p C(x y) -> Sealed (FL Prim C(y)) -standard_resolution p = merge_list $ map head $ resolveConflicts p +standardResolution :: RepoPatch p => p C(x y) -> Sealed (FL Prim C(y)) +standardResolution p = mergeList $ map head $ resolveConflicts p -merge_list :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) -merge_list patches = doml NilFL patches +mergeList :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) +mergeList patches = doml NilFL patches where doml :: FL Prim C(x y) -> [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) doml mp (Sealed p:ps) = case commute (invert p :> mp) of @@ -103,7 +105,7 @@ Note that the command is split into space-separated words and the first one is \verb!exec!ed with the rest as arguments---it is not a shell command. In particular, on Windows this means that the first command path should not contain spaces and -you should make sure the command is in your \verb!PATH!. +you should make sure the command is in your \verb!PATH!. The substitution of the \verb!%! escapes is done everywhere. If you need to prevent substitution you can use a double percentage sign, i.e. \verb!%%a! is substituted with @@ -144,7 +146,7 @@ Note that if you do use an external merge tool, most likely you will want to add to your defaults file -(\verb!_darcs/prefs/defaults! or \verb!~/.darcs/prefs!, see \ref{defaults}, +(\verb!_darcs/prefs/defaults! or \verb!~/.darcs/prefs!, see \ref{defaults}, on MS Windows~\ref{ms_win}) a line such as \begin{verbatim} @@ -158,10 +160,10 @@ Note that the defaults file does not want quotes around the command. \begin{code} -external_resolution :: RepoPatch p => Tree.Tree IO -> String -> FL Prim C(x y) -> FL Prim C(x z) +externalResolution :: RepoPatch p => Tree.Tree IO -> String -> FL Prim C(x y) -> FL Prim C(x z) -> p C(y a) -> IO (Sealed (FL Prim C(a))) -external_resolution s1 c p1 p2 pmerged = do +externalResolution s1 c p1 p2 pmerged = do sa <- applyToTree (invert p1) s1 sm <- applyToTree pmerged s1 s2 <- applyToTree p2 sa @@ -192,16 +194,16 @@ withTempDir "version2" $ \absd2 -> do let d2 = toFilePath absd2 write_files s2 n2s - mapM_ (externally_resolve_file c da d1 d2 dm) ns + mapM_ (externallyResolveFile c da d1 d2 dm) ns sc <- readPlainTree dc sfixed <- readPlainTree dm ftf <- filetypeFunction - seal `fmap` treeDiff ftf sc sfixed + unFreeLeft `fmap` treeDiff ftf sc sfixed -externally_resolve_file :: String -> String -> String -> String -> String +externallyResolveFile :: String -> String -> String -> String -> String -> (FilePath, FilePath, FilePath, FilePath) -> IO () -externally_resolve_file c da d1 d2 dm (fa, f1, f2, fm) = do +externallyResolveFile c da d1 d2 dm (fa, f1, f2, fm) = do putStrLn $ "Merging file "++fm++" by hand." ec <- run c [('1', d1f1), ('2', d2f2), ('a', dafa), ('o', dmfm), ('%', "%")] when (ec /= ExitSuccess) $ @@ -219,16 +221,13 @@ exec command args (Null,Null,Null) rr [] = return ExitSuccess -patchset_conflict_resolutions :: RepoPatch p => PatchSet p C(x) -> Sealed (FL Prim C(x)) -patchset_conflict_resolutions (NilRL:<:_) = --traceDoc (greenText "no conflicts A") $ - Sealed NilFL -patchset_conflict_resolutions NilRL = --traceDoc (greenText "no conflicts B") $ - Sealed NilFL -patchset_conflict_resolutions (xs:<:_) +patchsetConflictResolutions :: RepoPatch p => PatchSet p C(Origin x) -> Sealed (FL Prim C(x)) +patchsetConflictResolutions (PatchSet NilRL _) = Sealed NilFL +patchsetConflictResolutions (PatchSet xs _) = --traceDoc (greenText "looking at resolutions" $$ -- (sh $ resolveConflicts $ joinPatches $ -- mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $ - merge_list $ map head $ resolveConflicts $ joinPatches $ + mergeList $ map head $ resolveConflicts $ joinPatches $ mapFL_FL (patchcontents . hopefully) $ reverseRL xs --where sh :: [[Sealed (FL Prim)]] -> Doc -- sh [] = greenText "no more conflicts" diff -ruN darcs-2.4.4/src/Darcs/RunCommand.hs darcs-2.5/src/Darcs/RunCommand.hs --- darcs-2.4.4/src/Darcs/RunCommand.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/RunCommand.hs 2010-10-24 08:29:26.000000000 -0700 @@ -16,7 +16,7 @@ -- Boston, MA 02110-1301, USA. {-# LANGUAGE CPP #-} -module Darcs.RunCommand ( run_the_command ) where +module Darcs.RunCommand ( runTheCommand ) where import Control.Monad ( unless, when ) import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ), @@ -26,10 +26,12 @@ import Darcs.Arguments ( DarcsFlag(..), help, - optionFromDarcsoption, - listOptions ) -import Darcs.ArgumentDefaults ( get_default_flags ) + fixUrlFlag, + optionFromDarcsOption, + listOptions, nubOptions ) +import Darcs.ArgumentDefaults ( getDefaultFlags ) import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ), + CommandControl, DarcsCommand, commandName, commandCommand, @@ -47,56 +49,55 @@ subusage, chompNewline ) import Darcs.Commands.GZCRCs ( doCRCWarnings ) import Darcs.Global ( atexit ) -import Darcs.Commands.Help ( commandControlList ) import Darcs.External ( viewDoc ) import Darcs.Global ( setDebugMode, setSshControlMasterDisabled, setTimingsMode, setVerboseMode ) import Darcs.Match ( checkMatchSyntax ) import Progress ( setProgressMode ) import Darcs.RepoPath ( getCurrentDirectory ) -import Darcs.Test ( run_posthook, run_prehook ) +import Darcs.Test ( runPosthook, runPrehook ) import Darcs.Utils ( formatPath ) import Data.List ( intersperse ) import Printer ( text ) -import URL ( setDebugHTTP, setHTTPPipelining ) +import URL ( setDebugHTTP, disableHTTPPipelining ) -run_the_command :: String -> [String] -> IO () -run_the_command cmd args = +runTheCommand :: [CommandControl] -> String -> [String] -> IO () +runTheCommand commandControlList cmd args = either fail rtc $ disambiguateCommands commandControlList cmd args where - rtc (CommandOnly c, as) = run_command Nothing c as - rtc (SuperCommandOnly c, as) = run_raw_supercommand c as - rtc (SuperCommandSub c s, as) = run_command (Just c) s as + rtc (CommandOnly c, as) = runCommand Nothing c as + rtc (SuperCommandOnly c, as) = runRawSupercommand c as + rtc (SuperCommandSub c s, as) = runCommand (Just c) s as -- This is the actual heavy lifter code, which is responsible for parsing the -- arguments and then running the command itself. -run_command :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO () +runCommand :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO () -run_command _ _ args -- Check for "dangerous" typoes... +runCommand _ _ args -- Check for "dangerous" typoes... | "-all" `elem` args = -- -all indicates --all --look-for-adds! - fail $ "Are you sure you didn't mean -" ++ "-all rather than -all?" -run_command msuper cmd args = do + fail "Are you sure you didn't mean --all rather than -all?" +runCommand msuper cmd args = do cwd <- getCurrentDirectory let options = opts1 ++ opts2 (opts1, opts2) = commandOptions cwd cmd case getOpt Permute - (optionFromDarcsoption cwd listOptions++options) args of + (optionFromDarcsOption cwd listOptions++options) args of (opts,extra,[]) | Help `elem` opts -> viewDoc $ text $ getCommandHelp msuper cmd | ListOptions `elem` opts -> do setProgressMode False commandPrereq cmd opts file_args <- commandGetArgPossibilities cmd - putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args - | otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra + putStrLn $ unlines $ getOptionsOptions (opts1++opts2) : file_args + | otherwise -> considerRunning msuper cmd (addVerboseIfDebug opts) extra (_,_,ermsgs) -> do fail $ chompNewline(unlines ermsgs) where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts | otherwise = opts -consider_running :: Maybe DarcsCommand -> DarcsCommand +considerRunning :: Maybe DarcsCommand -> DarcsCommand -> [DarcsFlag] -> [String] -> IO () -consider_running msuper cmd opts old_extra = do +considerRunning msuper cmd opts old_extra = do cwd <- getCurrentDirectory location <- commandPrereq cmd opts case location of @@ -104,7 +105,7 @@ formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++ " here.\n\n" ++ complaint Right () -> do - specops <- add_command_defaults cmd opts + specops <- nubopts `fmap` addCommandDefaults cmd opts extra <- (commandArgdefaults cmd) specops cwd old_extra when (Disable `elem` specops) $ fail $ "Command "++commandName cmd++" disabled with --disable option!" @@ -118,7 +119,8 @@ nth_arg (length extra + 1) ++ "\n" ++ getCommandMiniHelp msuper cmd else runWithHooks specops extra - where nth_arg n = nth_of n (commandExtraArgHelp cmd) + where nubopts = nubOptions (uncurry (++) $ commandAlloptions cmd) + nth_arg n = nth_of n (commandExtraArgHelp cmd) nth_of 1 (h:_) = h nth_of n (_:hs) = nth_of (n-1) hs nth_of _ [] = "UNDOCUMENTED" @@ -131,39 +133,39 @@ when (DebugHTTP `elem` os) setDebugHTTP when (Verbose `elem` os) setVerboseMode when (Quiet `elem` os) $ setProgressMode False - when (HTTPPipelining `elem` os) $ setHTTPPipelining True - when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False + when (NoHTTPPipelining `elem` os) $ disableHTTPPipelining unless (SSHControlMaster `elem` os) setSshControlMasterDisabled unless (Quiet `elem` os) $ atexit $ doCRCWarnings (Verbose `elem` os) -- actually run the command and its hooks - preHookExitCode <- run_prehook os here + preHookExitCode <- runPrehook os here if preHookExitCode /= ExitSuccess then exitWith preHookExitCode else do let fixFlag = FixFilePath here cwd - (commandCommand cmd) (fixFlag : os) ex - postHookExitCode <- run_posthook os here + fixedOs <- mapM (fixUrlFlag [fixFlag]) os + (commandCommand cmd) (fixFlag : fixedOs) ex + postHookExitCode <- runPosthook os here exitWith postHookExitCode -add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag] -add_command_defaults cmd already = do +addCommandDefaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag] +addCommandDefaults cmd already = do let (opts1, opts2) = commandAlloptions cmd - defaults <- get_default_flags (commandName cmd) (opts1 ++ opts2) already + defaults <- getDefaultFlags (commandName cmd) (opts1 ++ opts2) already return $ already ++ defaults -get_options_options :: [OptDescr DarcsFlag] -> String -get_options_options = concat . intersperse "\n" . concatMap goo +getOptionsOptions :: [OptDescr DarcsFlag] -> String +getOptionsOptions = concat . intersperse "\n" . concatMap goo where goo (Option _ os _ _) = map ("--"++) os -run_raw_supercommand :: DarcsCommand -> [String] -> IO () -run_raw_supercommand super [] = +runRawSupercommand :: DarcsCommand -> [String] -> IO () +runRawSupercommand super [] = fail $ "Command '"++ commandName super ++"' requires subcommand!\n\n" ++ subusage super -run_raw_supercommand super args = do +runRawSupercommand super args = do cwd <- getCurrentDirectory case getOpt RequireOrder - (optionFromDarcsoption cwd help++ - optionFromDarcsoption cwd listOptions) args of + (optionFromDarcsOption cwd help++ + optionFromDarcsOption cwd listOptions) args of (opts,_,[]) | Help `elem` opts -> viewDoc $ text $ getCommandHelp Nothing super diff -ruN darcs-2.4.4/src/Darcs/SelectChanges.hs darcs-2.5/src/Darcs/SelectChanges.hs --- darcs-2.4.4/src/Darcs/SelectChanges.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/SelectChanges.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,178 +21,231 @@ #include "gadts.h" -module Darcs.SelectChanges ( with_selected_changes', - with_selected_changes_to_files', - with_selected_last_changes_to_files', - with_selected_last_changes_reversed', - with_selected_changes, - with_selected_changes_to_files, - with_selected_changes_reversed, - with_selected_last_changes_to_files, - with_selected_last_changes_to_files_reversed, - with_selected_last_changes_reversed, - view_changes, - with_selected_patch_from_repo, - filterOutConflicts, +module Darcs.SelectChanges (selectChanges, WhichChanges(..), viewChanges, withSelectedPatchFromRepo, + filterOutConflicts, runSelection, selectionContextPrim, + selectionContext ) where import System.IO import Data.List ( intersperse ) -import Data.Maybe ( catMaybes, isJust ) +import Data.Maybe ( catMaybes, isJust, fromJust ) import Data.Char ( toUpper ) -import Control.Monad ( when ) +import Control.Monad ( when, (>=>) ) +import Control.Monad.Trans ( liftIO ) +import Control.Monad.Reader ( ReaderT, Reader, asks, runReader, runReaderT ) +import Control.Monad.State ( State(..), StateT, modify, gets, execStateT ) import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import English ( Noun(..), englishNum ) import Darcs.Arguments ( showFriendly ) import Darcs.Hopefully ( PatchInfoAnd, hopefully, n2pia ) -import Darcs.Repository ( Repository, read_repo, unrecordedChanges ) +import Darcs.Repository ( Repository, readRepo, unrecordedChanges ) import Darcs.Patch ( RepoPatch, Patchy, Prim, summary, invert, listTouchedFiles, - commuteFL, fromPrims, anonymous ) + commuteFLorComplain, fromPrims, anonymous ) +import Darcs.Patch.Set ( newset2RL ) import qualified Darcs.Patch ( thing, things ) import Darcs.Patch.Split ( Splitter(..) ) import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:||:)(..), - (+>+), lengthFL, lengthRL, concatRL, mapFL_FL, - spanFL, reverseFL, (+<+), mapFL, - unsafeCoerceP ) -import Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps, + (+>+), lengthFL, concatRL, mapFL_FL, + spanFL, spanFL_M, reverseFL, (+<+), mapFL, filterFL ) +import Darcs.Witnesses.WZipper( FZipper(..), left, right + , rightmost, lengthFZ, focus + , toEnd) +import Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTpsSub, forceFirst, forceLast, makeUncertain, tag, - getChoices, - separateFirstMiddleFromLast, + getChoices, refineChoices, separateFirstFromMiddleLast, - patchSlot, + patchSlot', selectAllMiddles, forceMatchingLast, forceMatchingFirst, makeEverythingLater, - TaggedPatch, tpPatch, Slot(..), - substitute, + makeEverythingSooner, + TaggedPatch, tpPatch, Slot(..), + substitute ) import Darcs.Patch.Permutations ( partitionConflictingFL, selfCommuter, commuterIdRL ) -import Darcs.Patch.TouchesFiles ( deselect_not_touching, select_not_touching ) +import qualified Darcs.Patch.TouchesFiles as TouchesFiles import Darcs.PrintPatch ( printFriendly, printPatch, printPatchPager ) import Darcs.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread ) import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies, SkipConflicts), isInteractive ) -import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2, Sealed(..) ) -import Darcs.Utils ( askUser, promptCharFancy ) +import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2, Sealed(..), Sealed2(..) ) +import Darcs.Utils ( askUser, promptChar, PromptConfig(..) ) import Darcs.Lock ( editText ) import Printer ( prefix, putDocLn ) -#include "impossible.h" +-- | When asking about patches, we either ask about them in +-- oldest-first or newest first (with respect to the current ordering +-- of the repository), and we either want an initial segment or a +-- final segment of the poset of patches. +-- +-- @First@: ask for an initial +-- segment, first patches first (default for all pull-like commands) +-- +-- @FirstReversed@: ask for an initial segment, last patches first +-- (used to ask about dependencies in record, and for pull-like +-- commands with the @--reverse@ flag). +-- +-- @LastReversed@: ask for a final segment, last patches first. (default +-- for unpull-like commands, except for selecting *primitive* patches in +-- rollback) +-- +-- @Last@: ask for a final segment, first patches first. (used for selecting +-- primitive patches in rollback, and for unpull-like commands with the +-- @--reverse@ flag data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show) -type MatchCriterion p = FORALL(u v) WhichChanges -> [DarcsFlag] -> (p C(u v)) -> Bool +-- | A @WhichChanges@ is backwards if the order in which patches are presented +-- is the opposite of the order of dependencies for that operation. +backward :: WhichChanges -> Bool +backward w = w == Last || w == FirstReversed + +-- | The type of the function we use to filter patches when @--match@ is +-- given. +type MatchCriterion p = WhichChanges -> [DarcsFlag] -> Sealed2 p -> Bool + +-- | A @PatchSelectionContext@ contains all the static settings for selecting +-- patches. See "PatchSelectionM" +data PatchSelectionContext p = PSC { opts :: [DarcsFlag] + , splitter :: Maybe (Splitter p) + , files :: [FilePath] + , matchCriterion :: MatchCriterion p + , jobname :: String } + +-- | A 'PatchSelectionContext' for selecting 'Prim' patches. +selectionContextPrim :: String -> [DarcsFlag] -> Maybe (Splitter Prim) + -> [FilePath] -> PatchSelectionContext Prim +selectionContextPrim jn o spl fs = + PSC { opts = o + , splitter = spl + , files = fs + , matchCriterion = triv + , jobname = jn } + +-- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches) +selectionContext :: (RepoPatch p) => String -> [DarcsFlag] -> Maybe (Splitter (PatchInfoAnd p)) + -> [FilePath] -> PatchSelectionContext (PatchInfoAnd p) +selectionContext jn o spl fs = + PSC { opts = o + , splitter = spl + , files = fs + , matchCriterion = iswanted + , jobname = jn } + +-- | The dynamic parameters for interactive selection of patches. +data InteractiveSelectionContext p C(x y) = ISC { total :: Int + -- ^ total number of patches + , current :: Int + -- ^ number of already-seen patches + , tps :: FZipper (TaggedPatch p) C(x y) + -- ^ the patches we offer + , choices :: PatchChoices p C(x y) + -- ^ the user's choices + } + +type PatchSelectionM p a = ReaderT (PatchSelectionContext p) a + +type InteractiveSelectionM p C(x y) a = + StateT (InteractiveSelectionContext p C(x y)) + (PatchSelectionM p IO) a -type WithPatches p a C(x y) = - String -- jobname - -> [DarcsFlag] -- opts - -> Maybe (Splitter p) -- for interactive editing - -> FL p C(x y) -- patches to select among - -> ((FL p :> FL p) C(x y) -> IO a) -- job - -> IO a -- result of running job - --- | The only difference with 'WithPatches' is the [FilePath] argument -type WithPatchesToFiles p a C(x y) = - String -- jobname - -> [DarcsFlag] -- opts - -> Maybe (Splitter p) -- for interactive editing - -> [FilePath] -- files - -> FL p C(x y) -- patches to select among - -> ((FL p :> FL p) C(x y) -> IO a) -- job - -> IO a -- result of running job - -with_selected_changes' - :: WithPatches Prim a C(x y) -with_selected_changes_to_files' - :: WithPatchesToFiles Prim a C(x y) -with_selected_last_changes_to_files' - :: WithPatchesToFiles Prim a C(x y) -with_selected_last_changes_reversed' - :: WithPatches Prim a C(x y) +type PatchSelection p C(x y) = + PatchSelectionM p IO ((FL p :> FL p) C(x y)) -- Common match criteria + +-- | For commands without @--match@, 'triv' matches all patches triv :: MatchCriterion p -triv _ _ _ = True +triv = \ _ _ _ -> True +-- | 'iswanted' selects patches according to the @--match@ flag in +-- opts' iswanted :: Patchy p => MatchCriterion (PatchInfoAnd p) -iswanted First opts p = matchAPatch opts . hopefully $ p -iswanted LastReversed opts p = matchAPatch opts . hopefully . invert $ p -iswanted Last _ _ = bug "don't support patch matching with Last in wasp" -iswanted FirstReversed _ _ = bug "don't support patch matching with FirstReversed in wasp" - -with_selected_changes' = wasc First triv -with_selected_changes_to_files' = wasc_ First triv -with_selected_last_changes_to_files' = wasc_ Last triv -with_selected_last_changes_reversed' = wasc LastReversed triv - -with_selected_changes :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y) -with_selected_changes_to_files :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y) -with_selected_changes_reversed :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y) -with_selected_last_changes_to_files :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y) -with_selected_last_changes_to_files_reversed :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y) -with_selected_last_changes_reversed :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y) - -with_selected_changes = wasc First iswanted -with_selected_changes_to_files = wasc_ First iswanted -with_selected_changes_reversed = wasc FirstReversed iswanted -with_selected_last_changes_to_files = wasc_ Last iswanted -with_selected_last_changes_to_files_reversed = wasc_ LastReversed iswanted -with_selected_last_changes_reversed = wasc LastReversed iswanted - --- | wasc and wasc_ are just shorthand for with_any_selected_changes -wasc :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatches p a C(x y) -wasc mwch crit j o spl = wasc_ mwch crit j o spl [] -wasc_ :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y) -wasc_ = with_any_selected_changes - -with_any_selected_changes :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y) -with_any_selected_changes Last crit jn opts splitter fs = - with_any_selected_changes_last - (patches_to_consider_last' fs opts crit) - crit jn opts splitter fs -with_any_selected_changes First crit jn opts splitter fs = - with_any_selected_changes_first - (patches_to_consider_first' fs opts crit) - crit jn opts splitter fs -with_any_selected_changes FirstReversed crit jn opts splitter fs = - with_any_selected_changes_first_reversed - (patches_to_consider_first_reversed' fs opts crit) - crit jn opts splitter fs -with_any_selected_changes LastReversed crit jn opts splitter fs = - with_any_selected_changes_last_reversed - (patches_to_consider_last_reversed' fs opts crit) - crit jn opts splitter fs - - -view_changes :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () -view_changes opts ps = do - text_view opts Nothing 0 NilRL init_tps init_pc - return () - where (init_pc, init_tps) = patchChoicesTps ps - -data KeyPress a = KeyPress { kp :: Char +iswanted whch opts' = + unseal2 (iw whch opts') + where + iw First o = matchAPatch o . hopefully + iw Last o = matchAPatch o . hopefully + iw LastReversed o = matchAPatch o . hopefully . invert + iw FirstReversed o = matchAPatch o . hopefully . invert + +liftR :: Monad m => Reader r a -> ReaderT r m a +liftR = asks . runReader + +-- | runs a 'PatchSelection' action in the given 'PatchSelectionContext'. +runSelection :: (Patchy p) => PatchSelection p C(x y) -> PatchSelectionContext p + -> IO ((FL p :> FL p) C(x y)) +runSelection = runReaderT + +-- | Select patches from a @FL@. +selectChanges :: forall p C(x y) . Patchy p => + WhichChanges -> FL p C(x y) + -> PatchSelection p C(x y) +selectChanges First = sc1 First +selectChanges Last = sc1 Last +selectChanges FirstReversed = return . invert + >=> sc1 FirstReversed + >=> return . invertC + +selectChanges LastReversed = return . invert + >=> sc1 LastReversed + >=> return . invertC + +sc1 :: forall p C(x y) . Patchy p => + WhichChanges -> FL p C(x y) + -> PatchSelection p C(x y) +sc1 whch = + ((liftR . patchesToConsider whch) + >=> realSelectChanges whch + >=> return . selectedPatches whch + >=> (liftR . canonizeAfterSplitter)) + +-- | inverses the choices that have been made +invertC :: (Patchy p) => (FL p :> FL p) C(x y) -> (FL p :> FL p) C(y x) +invertC (a :> b) = (invert b) :> (invert a) + +-- | Shows the patch that is actually being selected the way the user +-- should see it. +repr :: (Patchy p) => WhichChanges -> Sealed2 p -> Sealed2 p +repr First (Sealed2 p) = Sealed2 p +repr LastReversed (Sealed2 p) = Sealed2 (invert p) +repr Last (Sealed2 p) = Sealed2 p +repr FirstReversed (Sealed2 p) = Sealed2 (invert p) + +-- | The equivalent of 'selectChanges' for the @darcs changes@ command +viewChanges :: Patchy p => [DarcsFlag] -> [Sealed2 p] -> IO () +viewChanges opts ps = textView opts Nothing 0 [] ps + +-- | The type of the answers to a "shall I [wiggle] that [foo]?" question +-- They are found in a [[KeyPress]] bunch, each list representing a set of +-- answers which belong together +data KeyPress = KeyPress { kp :: Char , kpHelp :: String } -helpFor :: String -> [[KeyPress a]] -> String -helpFor jobname options = - unlines $ [ "How to use "++jobname++":" ] - ++ (concat $ intersperse [""] $ map (map help) options) +-- | Generates the help for a set of basic and advanced 'KeyPress' groups. +helpFor :: String -> [[KeyPress]] -> [[KeyPress]] -> String +helpFor jn basicKeypresses advancedKeyPresses = + unlines $ [ "How to use "++jn++":" ] + ++ (concat $ intersperse [""] $ map (map help) keypresses) ++ [ "" , "?: show this help" , "" , ": accept the current default (which is capitalized)" ] where help i = kp i:(": "++kpHelp i) + keypresses = basicKeypresses ++ advancedKeyPresses -keysFor :: [[KeyPress a]] -> [Char] +-- | The keys used by a list of 'keyPress' groups. +keysFor :: [[KeyPress]] -> [Char] keysFor = concatMap (map kp) -with_selected_patch_from_repo :: forall p C(r u t). RepoPatch p => String -> Repository p C(r u t) -> [DarcsFlag] +-- | The function for selecting a patch to amend record. Read at your own risks. +withSelectedPatchFromRepo :: forall p C(r u t). RepoPatch p => String -> Repository p C(r u t) -> [DarcsFlag] -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ()) -> IO () -with_selected_patch_from_repo jn repository opts job = do - p_s <- read_repo repository - sp <- wspfr jn (matchAPatchread opts) - (concatRL p_s) NilFL +withSelectedPatchFromRepo jn repository o job = do + p_s <- readRepo repository + sp <- wspfr jn (matchAPatchread o) + (newset2RL p_s) NilFL case sp of Just (FlippedSeal (skipped :> selected)) -> job (skipped :> selected) Nothing -> do putStrLn $ "Cancelling "++jn++" since no patch was selected." @@ -207,22 +260,29 @@ wspfr jn matches (p:<:pps) skipped | not $ matches p = wspfr jn matches pps (p:>:skipped) | otherwise = - case commuteFL (p :> skipped) of + case commuteFLorComplain (p :> skipped) of Left _ -> do putStrLn "\nSkipping depended-upon patch:" printFriendly [] p wspfr jn matches pps (p:>:skipped) Right (skipped' :> p') -> do printFriendly [] p let repeat_this = wspfr jn matches (p:<:pps) skipped - options = [[ KeyPress 'y' (jn++" this patch") + basic_options = + [[ KeyPress 'y' (jn++" this patch") , KeyPress 'n' ("don't "++jn++" it") - , KeyPress 'v' "view this patch in full" + ]] + advanced_options = + [[ KeyPress 'v' "view this patch in full" , KeyPress 'p' "view this patch in full with pager" , KeyPress 'x' "view a summary of this patch" , KeyPress 'q' ("cancel "++jn) ]] let prompt = "Shall I "++jn++" this patch?" - yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h" + yorn <- promptChar $ PromptConfig { pPrompt = prompt + , pBasicCharacters = keysFor basic_options + , pAdvancedCharacters = keysFor advanced_options + , pDefault = Just 'n' + , pHelp = "?h" } case yorn of 'y' -> return $ Just $ flipSeal $ skipped' :> p' 'n' -> wspfr jn matches pps (p:>:skipped) @@ -232,436 +292,569 @@ repeat_this 'q' -> do putStrLn $ jn_cap++" cancelled." exitWith $ ExitSuccess - _ -> do putStrLn $ helpFor jn options + _ -> do putStrLn $ helpFor jn basic_options advanced_options repeat_this where jn_cap = (toUpper $ head jn) : tail jn -- After selecting with a splitter, the results may not be canonical -canonizeWith :: Maybe (Splitter p) -> (FL p :> FL p) C(x y) -> (FL p :> FL p) C(x y) -canonizeWith Nothing xy = xy -canonizeWith (Just spl) (x :> y) = canonizeSplit spl x :> canonizeSplit spl y - -with_any_selected_changes_last :: forall p a C(x y). Patchy p - => (FL p C(x y) -> (FL p :> FL p) C(x y)) - -> MatchCriterion p - -> WithPatchesToFiles p a C(x y) -with_any_selected_changes_last p2c crit jobname opts splitter _ ps job = - case p2c ps of - ps_to_consider :> other_ps -> - if not $ isInteractive opts - then job $ ps_to_consider :> other_ps - else do pc <- tentatively_text_select splitter "" jobname (Noun "patch") Last crit - opts ps_len 0 NilRL init_tps init_pc - job $ canonizeWith splitter $ selected_patches_last rejected_ps pc - where rejected_ps = ps_to_consider - ps_len = lengthFL init_tps - (init_pc, init_tps) = patchChoicesTps $ other_ps - -with_any_selected_changes_first :: forall p a C(x y). Patchy p - => (FL p C(x y) -> (FL p :> FL p) C(x y)) - -> MatchCriterion p - -> WithPatchesToFiles p a C(x y) -with_any_selected_changes_first p2c crit jobname opts splitter _ ps job = - case p2c ps of - ps_to_consider :> other_ps -> - if not $ isInteractive opts - then job $ ps_to_consider :> other_ps - else do pc <- tentatively_text_select splitter "" jobname (Noun "patch") First crit - opts ps_len 0 NilRL init_tps init_pc - job $ canonizeWith splitter $ selected_patches_first rejected_ps pc - where rejected_ps = other_ps - ps_len = lengthFL init_tps - (init_pc, init_tps) = patchChoicesTps $ ps_to_consider - -with_any_selected_changes_first_reversed :: forall p a C(x y). Patchy p - => (FL p C(x y) -> (FL p :> FL p) C(y x)) - -> MatchCriterion p - -> WithPatchesToFiles p a C(x y) -with_any_selected_changes_first_reversed p2c crit jobname opts splitter _ ps job = - case p2c ps of - ps_to_consider :> other_ps -> - if not $ isInteractive opts - then job $ invert other_ps :> invert ps_to_consider - else do pc <- tentatively_text_select splitter - "" jobname (Noun "patch") FirstReversed crit - opts ps_len 0 NilRL init_tps init_pc - job $ canonizeWith splitter $ selected_patches_first_reversed rejected_ps pc - where rejected_ps = ps_to_consider - ps_len = lengthFL init_tps - (init_pc, init_tps) = patchChoicesTps other_ps - -with_any_selected_changes_last_reversed :: forall p a C(x y). Patchy p - => (FL p C(x y) -> (FL p :> FL p) C(y x)) - -> MatchCriterion p - -> WithPatchesToFiles p a C(x y) -with_any_selected_changes_last_reversed p2c crit jobname opts splitter _ ps job = - case p2c ps of - ps_to_consider :> other_ps -> - if not $ isInteractive opts - then job $ invert other_ps :> invert ps_to_consider - else do pc <- tentatively_text_select splitter - "" jobname (Noun "patch") LastReversed crit - opts ps_len 0 NilRL init_tps init_pc - job $ canonizeWith splitter $ selected_patches_last_reversed rejected_ps pc - where rejected_ps = other_ps - ps_len = lengthFL init_tps - (init_pc, init_tps) = patchChoicesTps ps_to_consider - - -patches_to_consider_first' :: Patchy p - => [FilePath] -- ^ files - -> [DarcsFlag] -- ^ opts - -> MatchCriterion p - -> FL p C(x y) -- ^ patches - -> (FL p :> FL p) C(x y) -patches_to_consider_first' fs opts crit ps = - let deselect_unwanted pc = - if haveNonrangeMatch opts - then if DontGrabDeps `elem` opts - then forceMatchingLast (not.iswanted_) pc - else makeEverythingLater $ forceMatchingFirst iswanted_ pc - else pc - iswanted_ = crit First opts . tpPatch - in if null fs && not (haveNonrangeMatch opts) - then ps :> NilFL - else tp_patches $ separateFirstMiddleFromLast $ deselect_not_touching fs - $ deselect_unwanted $ patchChoices ps - -patches_to_consider_last' :: Patchy p - => [FilePath] -- ^ files - -> [DarcsFlag] -- ^ opts - -> MatchCriterion p - -> FL p C(x y) -- ^ patches - -> (FL p :> FL p) C(x y) -patches_to_consider_last' fs opts crit ps = - let deselect_unwanted pc = - if haveNonrangeMatch opts - then if DontGrabDeps `elem` opts - then forceMatchingLast (not.iswanted_) pc - else makeEverythingLater $ forceMatchingFirst iswanted_ pc - else pc - iswanted_ = crit Last opts . tpPatch - in if null fs && not (haveNonrangeMatch opts) - then NilFL :> ps - else case getChoices $ select_not_touching fs $ deselect_unwanted $ patchChoices ps of - fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc - -patches_to_consider_first_reversed' :: Patchy p - => [FilePath] -- ^ files - -> [DarcsFlag] -- ^ opts - -> MatchCriterion p - -> FL p C(x y) -- ^ patches - -> (FL p :> FL p) C(y x) -patches_to_consider_first_reversed' fs opts crit ps = - let deselect_unwanted pc = - if haveNonrangeMatch opts - then if DontGrabDeps `elem` opts - then forceMatchingLast (not.iswanted_) pc - else makeEverythingLater $ forceMatchingFirst iswanted_ pc - else pc - iswanted_ = crit FirstReversed opts . tpPatch - in if null fs && not (haveNonrangeMatch opts) - then NilFL :> (invert ps) - else case getChoices $ select_not_touching fs $ deselect_unwanted $ patchChoices $ invert ps of - fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc - -patches_to_consider_last_reversed' :: Patchy p - => [FilePath] -- ^ files - -> [DarcsFlag] -- ^ opts - -> MatchCriterion p - -> FL p C(x y) -- ^ patches - -> (FL p :> FL p) C(y x) -patches_to_consider_last_reversed' fs opts crit ps = - let deselect_unwanted pc = - if haveNonrangeMatch opts - then if DontGrabDeps `elem` opts - then forceMatchingLast (not.iswanted_) pc - else makeEverythingLater $ forceMatchingFirst iswanted_ pc - else pc - iswanted_ = crit LastReversed opts . tpPatch - in - if null fs && not (haveNonrangeMatch opts) - then (invert ps) :> NilFL - else tp_patches $ separateFirstMiddleFromLast $ deselect_not_touching fs - $ deselect_unwanted $ patchChoices $ invert ps +canonizeAfterSplitter :: (FL p :> FL p) C(x y) -> Reader (PatchSelectionContext p) ((FL p :> FL p) C(x y)) +canonizeAfterSplitter (x :> y) = + do spl' <- asks splitter + case spl' of + Nothing -> return (x:>y) + Just spl -> return $ canonizeSplit spl x :> canonizeSplit spl y + +realSelectChanges :: forall p C(x y). Patchy p + => WhichChanges + -> PatchChoices p C(x y) + -> PatchSelectionM p IO (PatchChoices p C(x y)) +realSelectChanges whch autoChoices = + do + o <- asks opts + if not $ isInteractive o + then return $ promote autoChoices + else flip refineChoices autoChoices $ textSelect whch + where forward = not $ backward whch + promote = if forward + then makeEverythingSooner + else makeEverythingLater + +-- | When using @--match@, remove unmatched patches not depended upon by matched +-- patches. +deselectUnwanted :: forall p C(x y) . Patchy p => WhichChanges -> + PatchChoices p C(x y) -> + Reader (PatchSelectionContext p) (PatchChoices p C(x y)) +deselectUnwanted whichch pc = + do + o <- asks opts + c <- (asks matchCriterion) + let iswanted_ = c whichch o . seal2 . tpPatch + select = if forward + then forceMatchingFirst iswanted_ + else forceMatchingLast iswanted_ + deselect = if forward + then forceMatchingLast (not . iswanted_) + else forceMatchingFirst (not . iswanted_) + if haveNonrangeMatch o + then if DontGrabDeps `elem` o + then return $ deselect pc + else do + return . demote $ select pc + else return pc + where + forward = not $ backward whichch + demote = if forward + then makeEverythingLater + else makeEverythingSooner + +-- | Selects the patches matching the match criterion, and puts them first or last +-- according to whch, while respecting any dependencies. +patchesToConsider :: Patchy p + => WhichChanges + -> FL p C(x y) + -> Reader (PatchSelectionContext p) (PatchChoices p C(x y)) +patchesToConsider whch ps = + do + fs <- asks files + o <- asks opts + let deselectNotTouching = + case whch of + First -> TouchesFiles.deselectNotTouching + Last -> TouchesFiles.selectNotTouching + FirstReversed -> TouchesFiles.selectNotTouching + LastReversed -> TouchesFiles.deselectNotTouching + everything = patchChoices ps + if null fs && not (haveNonrangeMatch o) + then return everything + else do notUnwanted <- deselectUnwanted whch everything + return $ deselectNotTouching fs notUnwanted -- | Returns the results of a patch selection user interaction -selected_patches_last :: Patchy p => FL p C(x y) -> PatchChoices p C(y z) - -> (FL p :> FL p) C(x z) -selected_patches_last other_ps pc = +selectedPatches :: Patchy p => WhichChanges -> PatchChoices p C(y z) + -> (FL p :> FL p) C(y z) +selectedPatches Last pc = case getChoices pc of - fc :> mc :> lc -> other_ps +>+ mapFL_FL tpPatch (fc +>+ mc) :> mapFL_FL tpPatch lc + fc :> mc :> lc -> mapFL_FL tpPatch (fc +>+ mc) :> mapFL_FL tpPatch lc -selected_patches_first :: Patchy p => FL p C(y z) -> PatchChoices p C(x y) - -> (FL p :> FL p) C(x z) -selected_patches_first other_ps pc = +selectedPatches First pc = case separateFirstFromMiddleLast pc of - xs :> ys -> mapFL_FL tpPatch xs :> mapFL_FL tpPatch ys +>+ other_ps + xs :> ys -> mapFL_FL tpPatch xs :> mapFL_FL tpPatch ys -selected_patches_last_reversed :: Patchy p => FL p C(y x) -> PatchChoices p C(z y) - -> (FL p :> FL p) C(x z) -selected_patches_last_reversed other_ps pc = +selectedPatches LastReversed pc = case separateFirstFromMiddleLast pc of - xs :> ys -> invert (mapFL_FL tpPatch ys +>+ other_ps) :> invert (mapFL_FL tpPatch xs) + xs :> ys -> mapFL_FL tpPatch (xs) :> (mapFL_FL tpPatch (ys)) -selected_patches_first_reversed :: Patchy p => FL p C(z y) -> PatchChoices p C(y x) - -> (FL p :> FL p) C(x z) -selected_patches_first_reversed other_ps pc = +selectedPatches FirstReversed pc = case getChoices pc of - fc :> mc :> lc -> invert (mapFL_FL tpPatch lc) :> invert (other_ps +>+ mapFL_FL tpPatch (fc +>+ mc)) + fc :> mc :> lc -> (mapFL_FL tpPatch (fc +>+ mc)) :> (mapFL_FL tpPatch lc) -text_select :: forall p C(x y z). Patchy p => Maybe (Splitter p) -> String -> WhichChanges - -> MatchCriterion p -> [DarcsFlag] -> Int -> Int - -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z) -> PatchChoices p C(x z) - -> IO ((PatchChoices p) C(x z)) - -text_select _ _ _ _ _ _ _ _ NilFL pc = return pc -text_select splitter jn whichch crit opts n_max n - tps_done tps_todo@(tp:>:tps_todo') pc = do - (printFriendly opts) `unseal2` viewp - repeat_this -- prompt the user - where - do_next_action ja je = tentatively_text_select splitter ja jn je whichch crit opts - n_max - (n+1) (tp:<:tps_done) tps_todo' - do_next = do_next_action "" (Noun "patch") - helper :: PatchChoices p C(a b) -> p C(a b) - helper = undefined - thing = Darcs.Patch.thing (helper pc) - things = Darcs.Patch.things (helper pc) - split = splitter >>= flip applySplitter (tpPatch tp) - options_basic = - [ KeyPress 'y' (jn++" this "++thing) - , KeyPress 'n' ("don't "++jn++" it") - , KeyPress 'w' ("wait and decide later, defaulting to no") ] - options_file = - [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file") - , KeyPress 'f' (jn++" the rest of the changes to this file") ] - options_view = - [ KeyPress 'v' ("view this "++thing++" in full") - , KeyPress 'p' ("view this "++thing++" in full with pager") - , KeyPress 'l' ("list all selected "++things) ] - options_summary = - [ KeyPress 'x' ("view a summary of this "++thing) ] - options_quit = - [ KeyPress 'd' (jn++" selected "++things++", skipping all the remaining "++things) - , KeyPress 'a' (jn++" all the remaining "++things) - , KeyPress 'q' ("cancel "++jn) ] - options_nav = - [ KeyPress 'j' ("skip to next "++thing) - , KeyPress 'k' ("back up to previous "++thing) ] - options_split - | Just _ <- split - = [ KeyPress 'e' ("interactively edit this "++thing) ] - | otherwise = [] - options = [options_basic] - ++ [options_split] - ++ (if is_single_file_patch then [options_file] else []) - ++ [options_view ++ - if Summary `elem` opts then [] else options_summary] - ++ [options_quit] - ++ [options_nav ] - prompt = "Shall I "++jn++" this "++thing++"? " - ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") " - repeat_this :: IO ((PatchChoices p) C(x z)) - repeat_this = do - yorn <- promptCharFancy prompt (keysFor options) (Just the_default) "?h" - case yorn of - 'y' -> do_next $ force_yes (tag tp) pc - 'n' -> do_next $ force_no (tag tp) pc - 'w' -> do_next $ makeUncertain (tag tp) pc - 'e' | Just (text, parse) <- split - -> do newText <- editText "darcs-patch-edit" text - case parse newText of - Nothing -> repeat_this - Just ps -> do let tps_new = snd $ patchChoicesTpsSub (Just (tag tp)) ps - text_select splitter - jn whichch crit opts (n_max + lengthFL tps_new - 1) n - tps_done (tps_new+>+tps_todo') - (substitute (seal2 (tp :||: tps_new)) pc) - - 's' -> do_next_action "Skipped" (Noun "change") $ skip_file - 'f' -> do_next_action "Included" (Noun "change") $ do_file - 'v' -> printPatch `unseal2` viewp >> repeat_this - 'p' -> printPatchPager `unseal2` viewp >> repeat_this - 'l' -> do let selected = case getChoices pc of - (first_chs:>_:>last_chs) -> - if whichch == Last || whichch == FirstReversed - then map_patches last_chs - else map_patches first_chs - map_patches = mapFL (\a -> - (showFriendly opts) `unseal2` (seal2 $ tpPatch a)) - putStrLn $ "---- Already selected "++things++" ----" - mapM_ putDocLn $ selected - putStrLn $ "---- end of already selected "++things++" ----" - (printFriendly opts) `unseal2` viewp - repeat_this - 'x' -> do (putDocLn . prefix " " . summary) `unseal2` viewp - repeat_this - 'd' -> return pc - 'a' -> do ask_confirmation - return $ selectAllMiddles (whichch == Last || whichch == FirstReversed) pc - 'q' -> do putStrLn $ jn_cap++" cancelled." - exitWith $ ExitSuccess - 'j' -> case tps_todo' of - NilFL -> -- May as well work out the length now we have all - -- the patches in memory - text_select splitter jn whichch crit opts - n_max n tps_done tps_todo pc - _ -> text_select splitter jn whichch crit opts - n_max (n+1) (tp:<:tps_done) tps_todo' pc - 'k' -> case tps_done of - NilRL -> repeat_this - (tp':<:tps_done') -> - text_select splitter jn whichch crit opts - n_max (n-1) tps_done' (tp':>:tps_todo) pc - 'c' -> text_select splitter jn whichch crit opts - n_max n tps_done tps_todo pc - _ -> do putStrLn $ helpFor jn options - repeat_this - force_yes = if whichch == Last || whichch == FirstReversed then forceLast else forceFirst - force_no = if whichch == Last || whichch == FirstReversed then forceFirst else forceLast - patches_to_skip = (tag tp:) $ catMaybes - $ mapFL (\tp' -> if listTouchedFiles tp' == touched_files - then Just (tag tp') - else Nothing) tps_todo' - skip_file = foldr force_no pc patches_to_skip - do_file = foldr force_yes pc patches_to_skip - the_default = get_default (whichch == Last || whichch == FirstReversed) $ patchSlot tp pc - jn_cap = (toUpper $ head jn) : tail jn - touched_files = listTouchedFiles $ tpPatch tp - is_single_file_patch = length touched_files == 1 - viewp = if whichch == LastReversed || whichch == FirstReversed then seal2 $ invert (tpPatch tp) else seal2 $ tpPatch tp - ask_confirmation = - if jn `elem` ["unpull", "unrecord", "obliterate"] - then do yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? " - case yorn of - ('y':_) -> return () - _ -> exitWith $ ExitSuccess - else return () - -text_view :: forall p C(x y u r s). Patchy p => [DarcsFlag] -> Maybe Int -> Int - -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y u) -> PatchChoices p C(r s) - -> IO ((PatchChoices p) C(r s)) -text_view _ _ _ _ NilFL _ = return $ patchChoices $ unsafeCoerceP NilFL --return pc -text_view opts n_max n - tps_done tps_todo@(tp:>:tps_todo') pc = do - printFriendly opts (tpPatch tp) - putStr "\n" +-- | Runs a function on the underlying @PatchChoices@ object +liftChoices :: forall p a C(x y) . Patchy p => + State (PatchChoices p C(x y)) a + -> InteractiveSelectionM p C(x y) a +liftChoices act = do + ch <- gets choices + let (result, ch') = runState act ch + modify $ \isc -> isc {choices = ch} + return result + +-- | @justDone n@ notes that @n@ patches have just been processed +justDone :: Patchy p => Int -> InteractiveSelectionM p C(x y) () +justDone n = modify $ \isc -> isc{ current = current isc + n} + +-- | The actual interactive selection process. +textSelect :: forall p C(x y) . Patchy p => WhichChanges -> + FL (TaggedPatch p) C(x y) -> PatchChoices p C(x y) + -> PatchSelectionM p IO (PatchChoices p C(x y)) +textSelect whch tps pcs = do + userSelection <- execStateT (skipMundane whch >> + showCur whch >> + textSelect' whch) $ + ISC { total = lengthFL tps + , current = 0 + , tps = FZipper NilRL tps + , choices = pcs } + return $ choices userSelection + +textSelect' :: Patchy p => WhichChanges -> + InteractiveSelectionM p C(x y) () +textSelect' whch = do + z <- gets tps + when (not $ rightmost z) $ + do + textSelectOne whch + textSelect' whch + +optionsBasic :: [Char] -> [Char] -> [KeyPress] +optionsBasic jn aThing = + [ KeyPress 'y' (jn++" this "++aThing) + , KeyPress 'n' ("don't "++jn++" it") + , KeyPress 'w' ("wait and decide later, defaulting to no") ] + +optionsFile :: [Char] -> [KeyPress] +optionsFile jn = + [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file") + , KeyPress 'f' (jn++" the rest of the changes to this file") ] + +optionsView :: String -> String -> [KeyPress] +optionsView aThing someThings = + [ KeyPress 'v' ("view this "++aThing++" in full") + , KeyPress 'p' ("view this "++aThing++" in full with pager") + , KeyPress 'l' ("list all selected "++someThings) ] + +optionsSummary :: String -> [KeyPress] +optionsSummary aThing = + [ KeyPress 'x' ("view a summary of this "++aThing) ] + +optionsQuit :: String -> String -> [KeyPress] +optionsQuit jn someThings = + [ KeyPress 'd' (jn++" selected "++someThings++", skipping all the remaining "++someThings) + , KeyPress 'a' (jn++" all the remaining "++someThings) + , KeyPress 'q' ("cancel "++jn) ] + +optionsNav :: String -> [KeyPress] +optionsNav aThing = + [ KeyPress 'j' ("skip to next "++ aThing) + , KeyPress 'k' ("back up to previous "++ aThing) ] + +optionsSplit :: Maybe (Splitter a) -> String -> [KeyPress] +optionsSplit split aThing + | Just _ <- split + = [ KeyPress 'e' ("interactively edit this "++ aThing) ] + | otherwise = [] + +options :: forall p C(x y) . (Patchy p) => Bool -> + InteractiveSelectionM p C(x y) ([[KeyPress]],[[KeyPress]]) +options single = do + split <- asks splitter + jn <- asks jobname + aThing <- thing + someThings <- things + o <- asks opts + return $ + ([optionsBasic jn aThing] + ,[optionsSplit split aThing] + ++ (if single then + [optionsFile jn ] else []) + ++ [optionsView aThing someThings ++ + if Summary `elem` o then [] + else optionsSummary aThing] + ++ [optionsQuit jn someThings] + ++ [optionsNav aThing] + ) + +-- | Returns a @Sealed2@ version of the patch we are asking the user +-- about. +currentPatch :: forall p C(x y) . Patchy p => + InteractiveSelectionM p C(x y) + (Maybe (Sealed2 (TaggedPatch p))) +currentPatch = do + (FZipper _ tps_todo) :: FZipper (TaggedPatch p) C(x y) <- gets tps + case tps_todo of + NilFL -> return Nothing + (tp:>:_) -> return $ Just (Sealed2 tp) + +-- | Returns the patches we have yet to ask the user about. +todo :: forall p C(x y) . Patchy p + => InteractiveSelectionM p C(x y) + (FlippedSeal (FL (TaggedPatch p)) C(y)) +todo = do + (FZipper _ tps_todo) <- gets tps + return (FlippedSeal tps_todo) + +-- | Modify the underlying @PatchChoices@ by some function +modChoices :: forall p C(x y) . Patchy p => + (PatchChoices p C(x y) -> PatchChoices p C(x y)) + -> InteractiveSelectionM p C(x y) () +modChoices f = modify $ \isc -> isc{choices = f $ choices isc} + +-- | returns @Just f@ if the 'currentPatch' only modifies @f@, +-- @Nothing@ otherwise. +currentFile :: forall p C(x y) . Patchy p + => InteractiveSelectionM p C(x y) (Maybe FilePath) +currentFile = do + c <- currentPatch + return $ case c of + Nothing -> Nothing + Just (Sealed2 tp) -> + case listTouchedFiles tp of + [f] -> Just f + _ -> Nothing + +-- | @decide True@ selects the current patch, and @decide False@ deselects +-- it. +decide :: forall p C(x y t u) . Patchy p => WhichChanges -> Bool + -> TaggedPatch p C(t u) + -> InteractiveSelectionM p C(x y) () +decide whch takeOrDrop tp = + if backward whch == takeOrDrop -- we go backward xor we are dropping + then modChoices $ forceLast (tag tp) + else modChoices $ forceFirst (tag tp) + +-- | like 'decide', but for all patches touching @file@ +decideWholeFile :: forall p C(x y). Patchy p => WhichChanges -> + FilePath -> Bool -> InteractiveSelectionM p C(x y) () +decideWholeFile whch file takeOrDrop = + do + FlippedSeal tps_todo <- todo + let patches_to_skip = + filterFL (\tp' -> listTouchedFiles tp' == [file]) tps_todo + mapM_ (unseal2 $ decide whch takeOrDrop) patches_to_skip + +-- | Undecide the current patch. +postponeNext :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) () +postponeNext = + do + Just (Sealed2 tp) <- currentPatch + modChoices $ makeUncertain (tag tp) + +-- | Focus the next patch. +skipOne :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) () +skipOne = modify so + where so x = x{tps = right (tps x), current = current x +1} + +-- | Focus the previous patch. +backOne :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) () +backOne = modify so + where so isc = isc{tps = left (tps isc), current = max (current isc-1) 0} + +-- | Split the current patch (presumably a hunk), and add the replace it +-- with its parts. +splitCurrent :: forall p C(x y) . Patchy p => Splitter p + -> InteractiveSelectionM p C(x y) () +splitCurrent s = do + FZipper tps_done (tp:>:tps_todo) <- gets tps + case (applySplitter s (tpPatch tp)) of + Nothing -> return () + Just (text, parse) -> + do + newText <- liftIO $ editText "darcs-patch-edit" text + case parse newText of + Nothing -> return () + Just ps -> do + tps_new <- liftIO . return . snd + $ patchChoicesTpsSub (Just (tag tp)) ps + modify $ \isc -> isc { total = ( total isc + + lengthFL tps_new - 1 ) + , tps = (FZipper tps_done + (tps_new +>+ tps_todo)) + , choices = (substitute + (seal2 (tp :||: tps_new)) + (choices isc)) + } + +-- | Returns a list of the currently selected patches, in +-- their original context, i.e., not commuted past unselected +-- patches. +selected :: forall p C(x y). Patchy p => WhichChanges -> + InteractiveSelectionM p C(x y) [Sealed2 p] +selected whichch = do + c <- gets choices + (first_chs :> _ :> last_chs) <- return $ getChoices c + return $ if backward whichch + then + mapFL (repr whichch . Sealed2 . tpPatch) $ last_chs + else + mapFL (repr whichch . Sealed2 . tpPatch) $ first_chs + +-- | Prints the list of the selected patches. See 'selected'. +printSelected :: Patchy p => WhichChanges -> + InteractiveSelectionM p C(x y) () +printSelected whichch = do + someThings <- things + o <- asks opts + s <- selected whichch + liftIO $ do + putStrLn $ "---- Already selected "++someThings++" ----" + mapM_ (putDocLn . unseal2 (showFriendly o)) s + putStrLn $ "---- end of already selected "++someThings++" ----" + +printSummary :: forall p C(x y) . Patchy p => p C(x y) -> IO () +printSummary = + putDocLn . prefix " " . summary + +-- | Skips all remaining patches. +skipAll :: forall p C(x y) . Patchy p => + InteractiveSelectionM p C(x y) () +skipAll = do + modify $ \isc -> isc {tps = toEnd $ tps isc} + +isSingleFile :: Patchy p => p C(x y) -> Bool +isSingleFile p = length (listTouchedFiles p) == 1 + +askConfirmation :: forall p C(x y) . Patchy p => + InteractiveSelectionM p C(x y) () +askConfirmation = do + jn <- asks jobname + liftIO $ if jn `elem` ["unpull", "unrecord", "obliterate"] + then do + yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? " + case yorn of + ('y':_) -> return () + _ -> exitWith $ ExitSuccess + else return () + +-- | The singular form of the noun for items of type @p@. +thing :: Patchy p => InteractiveSelectionM p C(x y) String +thing = gets choices >>= return . Darcs.Patch.thing . helper + where + helper :: PatchChoices p C(a b) -> p C(a b) + helper = undefined + +-- | The plural form of the noun for items of type @p@. +things :: Patchy p => InteractiveSelectionM p C(x y) String +things = gets choices >>= return . Darcs.Patch.things . helper + where + helper :: PatchChoices p C(a b) -> p C(a b) + helper = undefined + +-- | The question to ask about one patch. +prompt :: Patchy p => InteractiveSelectionM p C(x y) String +prompt = do + jn <- asks jobname + aThing <- thing + n <- gets current + n_max <- gets total + return $ "Shall I "++jn++" this "++aThing++"? " + ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") " + +-- | Asks the user about one patch, returns their answer. +promptUser :: forall p C(x y) . Patchy p => Bool -> Char + -> InteractiveSelectionM p C(x y) Char +promptUser single def = do + thePrompt <- prompt + (basicOptions,advancedOptions) <- options single + liftIO $ promptChar $ PromptConfig { pPrompt = thePrompt + , pBasicCharacters = keysFor basicOptions + , pAdvancedCharacters = keysFor advancedOptions + , pDefault = Just def + , pHelp = "?h" + } + +-- | Ask the user what to do with the next patch. +textSelectOne :: forall p C(x y). Patchy p => WhichChanges + -> InteractiveSelectionM p C(x y) () +textSelectOne whichch = do + c <- currentPatch + case c of + Nothing -> return () + Just (Sealed2 tp) -> + do + jn <- asks jobname + spl <- asks splitter + o <- asks opts + let singleFile = isSingleFile (tpPatch tp) + reprCur = repr whichch (Sealed2 (tpPatch tp)) + (basicOptions,advancedOptions) <- options singleFile + theSlot <- liftChoices $ patchSlot' tp + let + the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot + jn_cap = (toUpper $ head jn) : tail jn + yorn <- promptUser singleFile the_default + let nextPatch = skipMundane whichch >> showCur whichch + case yorn of + 'y' -> decide whichch True tp >> skipOne >> nextPatch + 'n' -> decide whichch False tp >> skipOne >> nextPatch + 'w' -> postponeNext >> skipOne >> nextPatch + 'e' | (Just s) <- spl -> splitCurrent s >> showCur whichch + 's' -> currentFile >>= maybe + (return ()) + (\f -> decideWholeFile whichch f False) >> nextPatch + 'f' -> currentFile >>= maybe + (return ()) + (\f -> decideWholeFile whichch f True) >> nextPatch + 'v' -> liftIO $ unseal2 printPatch reprCur + 'p' -> liftIO $ unseal2 printPatchPager reprCur + 'l' -> printSelected whichch >> showCur whichch + 'x' -> liftIO $ unseal2 printSummary reprCur + 'd' -> skipAll + 'a' -> + do + askConfirmation + modChoices $ selectAllMiddles (whichch == Last || whichch == FirstReversed) + skipAll + 'q' -> liftIO $ + do putStrLn $ jn_cap++" cancelled." + exitWith $ ExitSuccess + 'j' -> skipOne >> showCur whichch + 'k' -> backOne >> showCur whichch + _ -> do liftIO . putStrLn $ helpFor jn basicOptions advancedOptions + +-- | Shows the current patch as it should be seen by the user. +showCur :: forall p C(x y) . Patchy p => WhichChanges + -> InteractiveSelectionM p C(x y) () +showCur whichch = do + o <- asks opts + c <- currentPatch + case c of + Nothing -> return () + Just (Sealed2 tp) -> do + let reprCur = repr whichch (Sealed2 (tpPatch tp)) + liftIO . (unseal2 (printFriendly o)) $ reprCur + +-- | The interactive part of @darcs changes@ +textView :: forall p C(x y u r s). Patchy p => [DarcsFlag] -> Maybe Int -> Int + -> [Sealed2 p] -> [Sealed2 p] + -> IO () +textView _ _ _ _ [] = return () +textView o n_max n + ps_done ps_todo@(p:ps_todo') = do + unseal2 (printFriendly o) p repeat_this -- prompt the user where - prev_patch :: IO ((PatchChoices p) C(r s)) - prev_patch = case tps_done of - NilRL -> repeat_this - (tp':<:tps_done') -> - text_view opts - n_max (n-1) tps_done' (tp':>:tps_todo) pc - next_patch :: IO ((PatchChoices p) C(r s)) - next_patch = case tps_todo' of - NilFL -> -- May as well work out the length now we have all + prev_patch :: IO () + prev_patch = case ps_done of + [] -> repeat_this + (p':ps_done') -> + textView o + n_max (n-1) ps_done' (p':ps_todo) + next_patch :: IO () + next_patch = case ps_todo' of + [] -> -- May as well work out the length now we have all -- the patches in memory - text_view opts n_max - n tps_done NilFL pc - _ -> text_view opts n_max - (n+1) (tp:<:tps_done) tps_todo' pc + textView o n_max + n ps_done [] + _ -> textView o n_max + (n+1) (p:ps_done) ps_todo' options_yn = [ KeyPress 'y' "view this patch and go to the next" , KeyPress 'n' "skip to the next patch" ] - options_view = + optionsView = [ KeyPress 'v' "view this patch in full" , KeyPress 'p' "view this patch in full with pager" ] - options_summary = + optionsSummary = [ KeyPress 'x' "view a summary of this patch" ] - options_nav = - [ KeyPress 'q' ("quit view changes") + optionsNav = + [ KeyPress 'q' "quit view changes" , KeyPress 'k' "back up to previous patch" , KeyPress 'j' "skip to next patch" , KeyPress 'c' "count total patch number" ] - options = [ options_yn ] - ++ [ options_view ++ - if Summary `elem` opts then [] else options_summary ] - ++ [ options_nav ] + basicOptions = [ options_yn ] + advancedOptions = + [ optionsView ++ + if Summary `elem` o then [] else optionsSummary ] + ++ [ optionsNav ] prompt = "Shall I view this patch? " ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")" - repeat_this :: IO ((PatchChoices p) C(r s)) + repeat_this :: IO () repeat_this = do - yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h" + yorn <- promptChar (PromptConfig prompt (keysFor basicOptions) (keysFor advancedOptions) (Just 'n') "?h") case yorn of - 'y' -> printPatch (tpPatch tp) >> next_patch + 'y' -> unseal2 printPatch p >> next_patch 'n' -> next_patch - 'v' -> printPatch (tpPatch tp) >> repeat_this - 'p' -> printPatchPager (tpPatch tp) >> repeat_this - 'x' -> do putDocLn $ prefix " " $ summary (tpPatch tp) + 'v' -> unseal2 printPatch p >> repeat_this + 'p' -> unseal2 printPatchPager p >> repeat_this + 'x' -> do putDocLn $ prefix " " $ unseal2 summary p repeat_this 'q' -> exitWith ExitSuccess 'k' -> prev_patch 'j' -> next_patch - 'c' -> text_view opts - count_n_max n tps_done tps_todo pc - _ -> do putStrLn $ helpFor "view changes" options + 'c' -> textView o + count_n_max n ps_done ps_todo + _ -> do putStrLn $ helpFor "view changes" basicOptions advancedOptions repeat_this count_n_max | isJust n_max = n_max - | otherwise = Just $ lengthFL tps_todo + lengthRL tps_done -tentatively_text_select :: Patchy p => Maybe (Splitter p) -> String -> String -> Noun -> WhichChanges - -> MatchCriterion p -> [DarcsFlag] - -> Int -> Int -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z) - -> PatchChoices p C(x z) - -> IO ((PatchChoices p) C(x z)) -tentatively_text_select _ _ _ _ _ _ _ _ _ _ NilFL pc = return pc -tentatively_text_select splitter jobaction jobname jobelement whichch crit - opts n_max n ps_done ps_todo pc = - case spanFL (\p -> decided $ patchSlot p pc) ps_todo of - skipped :> unskipped -> do - when (numSkipped > 0) show_skipped - let (boringThenInteresting) = - if DontPromptForDependencies `elem` opts - then spanFL (not.(crit whichch opts).tpPatch) unskipped - else NilFL :> unskipped - case boringThenInteresting of - boring :> interesting -> do - let numNotConsidered = lengthFL boring + numSkipped - text_select splitter jobname whichch crit opts n_max (n + numNotConsidered) - (reverseFL boring +<+ reverseFL skipped +<+ ps_done) interesting pc - where - numSkipped = lengthFL skipped - show_skipped = do putStrLn $ _doing_ ++ _with_ ++ "." - when (Verbose `elem` opts) $ showskippedpatch skipped + | otherwise = Just $ length ps_done + length ps_todo + +-- | Skips patches we should not ask the user about +skipMundane :: Patchy p => WhichChanges -> + InteractiveSelectionM p C(x y) () +skipMundane whichch = do + (FZipper tps_done tps_todo) <- gets tps + o <- asks opts + crit <- asks matchCriterion + jn <- asks jobname + (skipped :> unskipped) <- liftChoices $ spanFL_M + (patchSlot' >=> return . decided) + tps_todo + let numSkipped = lengthFL skipped + when (numSkipped > 0) . liftIO $ show_skipped o jn numSkipped skipped + let boringThenInteresting = + if DontPromptForDependencies `elem` o + then spanFL (not.(crit whichch o) . seal2 . tpPatch) $ + unskipped + else NilFL :> unskipped + case boringThenInteresting of + boring :> interesting -> + do + justDone $ lengthFL boring + numSkipped + modify $ \isc -> isc {tps = (FZipper (reverseFL boring +<+ reverseFL skipped +<+ tps_done) interesting)} where - _doing_ = _action_ ++ " " ++ jobname - _with_ = " of " ++ show numSkipped ++ " " ++ _elem_ "" - _action_ = if (length jobaction) == 0 then "Skipped" else jobaction - _elem_ = englishNum numSkipped jobelement + show_skipped o jn n ps = do putStrLn $ _nevermind_ jn ++ _these_ n ++ "." + when (Verbose `elem` o) $ + showskippedpatch ps + _nevermind_ jn = "Will not ask whether to " ++ jn ++ " " + _these_ n = show n ++ " already decided " ++ _elem_ n "" + _elem_ n = englishNum n (Noun "patch") showskippedpatch :: Patchy p => FL (TaggedPatch p) C(y t) -> IO () - showskippedpatch (tp:>:tps) = (putDocLn $ prefix " " $ summary (tpPatch tp)) >> showskippedpatch tps - showskippedpatch NilFL = return () + showskippedpatch = + sequence_ . mapFL (printSummary . tpPatch) decided :: Slot -> Bool decided InMiddle = False decided _ = True -get_default :: Bool -> Slot -> Char -get_default _ InMiddle = 'w' -get_default True InFirst = 'n' -get_default True InLast = 'y' -get_default False InFirst = 'y' -get_default False InLast = 'n' - -tp_patches :: (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y) - -> (FL p :> FL p) C(x y) -tp_patches (x:>y) = mapFL_FL tpPatch x :> mapFL_FL tpPatch y +-- | The action bound to space, depending on the current status of the +-- patch. +getDefault :: Bool -> Slot -> Char +getDefault _ InMiddle = 'w' +getDefault True InFirst = 'n' +getDefault True InLast = 'y' +getDefault False InFirst = 'y' +getDefault False InLast = 'n' -- |Optionally remove any patches (+dependencies) from a sequence that -- conflict with the recorded or unrecorded changes in a repo filterOutConflicts :: RepoPatch p => [DarcsFlag] -- ^Command-line options. Only 'SkipConflicts' is -- significant; filtering will happen iff it is present - -> RL (PatchInfoAnd p) C(x r) -- ^Recorded patches from repository, starting from + -> RL (PatchInfoAnd p) C(x t) -- ^Recorded patches from repository, starting from -- same context as the patches to filter -> Repository p C(r u t) -- ^Repository itself, used for grabbing unrecorded changes -> FL (PatchInfoAnd p) C(x z) -- ^Patches to filter -> IO (Bool, Sealed (FL (PatchInfoAnd p) C(x))) -- ^(True iff any patches were removed, possibly filtered patches) -filterOutConflicts opts us repository them - | SkipConflicts `elem` opts +filterOutConflicts o us repository them + | SkipConflicts `elem` o = do let commuter = commuterIdRL selfCommuter unrec <- fmap n2pia . (anonymous . fromPrims) =<< unrecordedChanges [] repository [] them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us) diff -ruN darcs-2.4.4/src/Darcs/SignalHandler.hs darcs-2.5/src/Darcs/SignalHandler.hs --- darcs-2.4.4/src/Darcs/SignalHandler.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/SignalHandler.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,16 +21,20 @@ module Darcs.SignalHandler ( withSignalsHandled, withSignalsBlocked, catchInterrupt, catchNonSignal, - tryNonSignal, stdout_is_a_pipe ) where + tryNonSignal, stdoutIsAPipe ) where + +import Prelude hiding ( catch ) import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName ) -import Control.Exception ( dynExceptions, ioErrors, catchJust, Exception ( IOException ) ) import System.Exit ( exitWith, ExitCode ( ExitFailure ) ) import Control.Concurrent ( ThreadId, myThreadId ) -import Control.Exception ( catchDyn, throwDyn, throwDynTo, block ) +import Control.Exception.Extensible + ( catch, throw, throwTo, block, + Exception(..), SomeException(..), IOException ) import System.Posix.Files ( getFdStatus, isNamedPipe ) import System.Posix.IO ( stdOutput ) -import Data.Dynamic ( Typeable, fromDynamic ) +import Data.Typeable ( Typeable, cast ) +import Data.List ( isPrefixOf ) import System.IO ( hPutStrLn, stderr ) import Control.Monad ( when ) @@ -40,21 +44,25 @@ import CtrlC ( withCtrlCHandler ) #endif -stdout_is_a_pipe :: IO Bool -stdout_is_a_pipe - = catchJust ioErrors +stdoutIsAPipe :: IO Bool +stdoutIsAPipe + = catch (do stat <- getFdStatus stdOutput return (isNamedPipe stat)) - (\_ -> return False) + (\(_ :: IOException) -> return False) withSignalsHandled :: IO a -> IO a -newtype SignalException = SignalException Signal deriving (Typeable) +newtype SignalException = SignalException Signal deriving (Show, Typeable) + +instance Exception SignalException where + toException e = SomeException e + fromException (SomeException e) = cast e withSignalsHandled job = do thid <- myThreadId mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE] - catchJust just_usererrors (job' thid `catchSignal` defaults) - die_with_string + catchUserErrors (job' thid `catchSignal` defaults) + die_with_string where defaults s | s == sigINT = ew s "Interrupted!" | s == sigHUP = ew s "HUP" | s == sigABRT = ew s "ABRT" @@ -65,8 +73,8 @@ resethandler sig raiseSignal sig -- ensure that our caller knows how we died exitWith $ ExitFailure $ 1 - die_with_string e | take 6 e == "STDOUT" = - do is_pipe <- stdout_is_a_pipe + die_with_string e | "STDOUT" `isPrefixOf` e = + do is_pipe <- stdoutIsAPipe when (not is_pipe) $ hPutStrLn stderr $ "\ndarcs failed: "++drop 6 e exitWith $ ExitFailure $ 2 @@ -74,7 +82,7 @@ exitWith $ ExitFailure $ 2 #ifdef WIN32 job' thid = - withCtrlCHandler (throwDynTo thid $ SignalException sigINT) job + withCtrlCHandler (throwTo thid $ SignalException sigINT) job #else job' _ = job #endif @@ -85,39 +93,39 @@ ih :: ThreadId -> Signal -> IO () ih thid s = - do installHandler s (Catch $ throwDynTo thid $ SignalException s) Nothing + do installHandler s (Catch $ throwTo thid $ SignalException s) Nothing return () catchSignal :: IO a -> (Signal -> IO a) -> IO a catchSignal job handler = - job `Control.Exception.catchDyn` (\(SignalException sig) -> handler sig) + job `catch` (\(SignalException sig) -> handler sig) -- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows -- us to catch anything but a signal. Useful for situations where we want -- don't want to inhibit ctrl-C. -catchNonSignal :: IO a -> (Control.Exception.Exception -> IO a) -> IO a -catchNonSignal = Control.Exception.catchJust notSig - where notSig x = case dynExceptions x of - Nothing -> Just x - Just d -> case fromDynamic d :: Maybe SignalException of - Just _ -> Nothing - Nothing -> Just x +catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a +catchNonSignal comp handler = catch comp handler' + where handler' se = + case fromException se :: Maybe SignalException of + Nothing -> handler se + Just _ -> throw se catchInterrupt :: IO a -> IO a -> IO a catchInterrupt job handler = job `catchSignal` h where h s | s == sigINT = handler - | otherwise = throwDyn (SignalException s) + | otherwise = throw (SignalException s) -tryNonSignal :: IO a -> IO (Either Control.Exception.Exception a) +tryNonSignal :: IO a -> IO (Either SomeException a) tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e) -just_usererrors :: Control.Exception.Exception -> Maybe String -just_usererrors (IOException e) | isUserError e = Just $ ioeGetErrorString e -just_usererrors (IOException e) | ioeGetFileName e == Just "" - = Just $ "STDOUT"++ioeGetErrorString e -just_usererrors _ = Nothing +catchUserErrors :: IO a -> (String -> IO a) -> IO a +catchUserErrors comp handler = catch comp handler' + where handler' ioe + | isUserError ioe = handler (ioeGetErrorString ioe) + | ioeGetFileName ioe == Just "" = handler ("STDOUT" ++ ioeGetErrorString ioe) + | otherwise = throw ioe withSignalsBlocked :: IO () -> IO () withSignalsBlocked job = (block job) `catchSignal` couldnt_do diff -ruN darcs-2.4.4/src/Darcs/SlurpDirectory/Internal.hs darcs-2.5/src/Darcs/SlurpDirectory/Internal.hs --- darcs-2.4.4/src/Darcs/SlurpDirectory/Internal.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/SlurpDirectory/Internal.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,661 +0,0 @@ --- Copyright (C) 2002-2004 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -{-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE CPP #-} - --- | SlurpDirectory is intended to give a nice lazy way of traversing directory --- trees. -module Darcs.SlurpDirectory.Internal - ( Slurpy(..), SlurpyContents(..), slurpies_to_map, map_to_slurpies, - FileContents, empty_slurpy, - slurp, mmap_slurp, slurp_unboring, co_slurp, - slurp_name, is_file, is_dir, - get_filecontents, get_dircontents, get_mtime, - get_length, get_slurp, - slurp_removefile, slurp_removedir, - slurp_remove, - slurp_modfile, slurp_hasfile, slurp_hasdir, - slurp_has_anycase, undefined_time, - undefined_size, - slurp_has, list_slurpy, list_slurpy_files, - get_path_list, - list_slurpy_dirs, - isFileReallySymlink, - doesFileReallyExist, doesDirectoryReallyExist, - SlurpMonad, withSlurpy, write_files, - writeSlurpy, syncSlurpy - ) where - -import System.IO -import System.Directory hiding ( getCurrentDirectory, renameFile ) -import Workaround ( getCurrentDirectory ) -import Darcs.Utils ( withCurrentDirectory, formatPath ) -import Darcs.RepoPath ( FilePathLike, toPath ) -import System.IO.Unsafe ( unsafeInterleaveIO ) -import Data.List ( isPrefixOf ) -import Control.Monad ( MonadPlus(..), when ) -import Data.Char ( toLower ) -import System.Posix.Types ( EpochTime ) -import System.Posix.Files - ( getSymbolicLinkStatus, modificationTime, - fileSize, - isRegularFile, isDirectory, isSymbolicLink - ) -import Data.Maybe ( catMaybes, isJust, maybeToList ) -import Data.Map (Map) -import qualified Data.Map as Map - -import Darcs.SignalHandler ( tryNonSignal ) -import Darcs.CheckFileSystem ( can_I_use_mmap ) -import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) - -import ByteStringUtils -import qualified Data.ByteString as B - -import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, norm_path, break_on_dir, - own_name, superName ) -import System.Posix.Types ( FileOffset ) - -#include "impossible.h" - -data Slurpy = Slurpy !FileName !SlurpyContents - -slurpy_to_pair :: Slurpy -> (FileName, SlurpyContents) -slurpy_to_pair (Slurpy fn sc) = (fn, sc) - -pair_to_slurpy :: (FileName, SlurpyContents) -> Slurpy -pair_to_slurpy = uncurry Slurpy - -type SlurpyMap = Map FileName SlurpyContents - -slurpies_to_map :: [Slurpy] -> SlurpyMap -slurpies_to_map = Map.fromList . map slurpy_to_pair - -map_to_slurpies :: SlurpyMap -> [Slurpy] -map_to_slurpies = map pair_to_slurpy . Map.toList - -data SlurpyContents = SlurpDir (Maybe String) SlurpyMap - | SlurpFile (Maybe String,EpochTime,FileOffset) FileContents -type FileContents = B.ByteString - -instance Show Slurpy where - show (Slurpy fn (SlurpDir _ l)) = - "Dir " ++ (fn2fp fn) ++ "\n" ++ - concat (map show $ map_to_slurpies l) ++ "End Dir " ++ (fn2fp fn) ++ "\n" - show (Slurpy fn (SlurpFile _ _)) = "File " ++ (fn2fp fn) ++ "\n" - -mapSlurpyNames :: (FileName -> FileName) -> Slurpy -> Slurpy -mapSlurpyNames f = onSlurpy - where onSlurpy (Slurpy fn sc) = Slurpy (f fn) (onSlurpyContents sc) - onSlurpyContents sf@(SlurpFile _ _) = sf - onSlurpyContents (SlurpDir x sm) = SlurpDir x . slurpies_to_map . map onSlurpy . map_to_slurpies $ sm - -slurp :: FilePathLike p => p -> IO Slurpy -mmap_slurp :: FilePath -> IO Slurpy -slurp_unboring :: (FilePath->Bool) -> FilePath -> IO Slurpy -empty_slurpy :: Slurpy -empty_slurpy = Slurpy (fp2fn ".") (SlurpDir Nothing Map.empty) -slurp_name :: Slurpy -> FilePath -is_file :: Slurpy -> Bool -is_dir :: Slurpy -> Bool - -get_filecontents :: Slurpy -> FileContents -get_dircontents :: Slurpy -> [Slurpy] -get_mtime :: Slurpy -> EpochTime -get_length :: Slurpy -> FileOffset - -instance Eq Slurpy where - s1 == s2 = (slurp_name s1) == (slurp_name s2) -instance Ord Slurpy where - s1 <= s2 = (slurp_name s1) <= (slurp_name s2) - -data SlurpMonad a = SM ((Either String Slurpy) - -> Either String (Slurpy, a)) -mksm :: (Slurpy -> Either String (Slurpy, a)) -> SlurpMonad a -mksm x = SM sm where sm (Left e) = Left e - sm (Right s) = x s - -instance Functor SlurpMonad where - fmap f m = m >>= return . f - -instance Monad SlurpMonad where - (SM p) >>= k = SM sm - where sm e = case p e of - Left er -> Left er - Right (s, a) -> case k a of - (SM q) -> q (Right s) - return a = SM ( \s -> case s of - Left e -> Left e - Right x -> Right (x, a) ) - fail e = SM ( \s -> case s of - Left x -> Left x - _ -> Left e ) - -instance MonadPlus SlurpMonad where - mzero = fail "SlurpMonad mzero" - (SM p) `mplus` (SM q) = SM sm - where sm e = case p e of - Left _ -> q e - okay -> okay - -instance ReadableDirectory SlurpMonad where - mDoesDirectoryExist d = smDoesDirectoryExist d - mDoesFileExist f = smDoesFileExist f - mInCurrentDirectory = smInSlurpy - mGetDirectoryContents = smGetDirContents - mReadFilePS = smReadFilePS - mReadFilePSs = smReadFilePSs - -instance WriteableDirectory SlurpMonad where - mWithCurrentDirectory = modifySubSlurpy - mSetFileExecutable _ _ = return () - mWriteFilePS = smWriteFilePS - mCreateDirectory = smCreateDirectory - mRename = smRename - mRemoveDirectory = smRemoveDirectory - mRemoveFile = smRemoveFile - -write_file :: Slurpy -> FileName -> IO () -write_file s fn = case withSlurpy s $ smReadFilePS fn of - Left err -> fail err - Right (_, c) -> do - ensureDirectories (superName fn) - mWriteFilePS fn c - -try_write_file :: Slurpy -> FilePath -> IO () -try_write_file s fp = let fn = fp2fn fp in - if slurp_hasfile fn s - then write_file s fn - else if slurp_hasdir fn s - then ensureDirectories fn - else return () - -ensureDirectories :: WriteableDirectory m => FileName -> m () -ensureDirectories d = do - isPar <- mDoesDirectoryExist d - if isPar - then return () - else ensureDirectories (superName d) >> (mCreateDirectory d) - -write_files :: Slurpy -> [FilePath] -> IO () -write_files s fps = mapM_ (try_write_file s) fps - --- don't overwrite non-empty directories unless explicitly asked by --- being passed "." (which always exists) -writeSlurpy :: Slurpy -> FilePath -> IO () -writeSlurpy s d = do - when (d /= ".") $ createDirectory d - withCurrentDirectory d $ write_files s (list_slurpy s) - -withSlurpy :: Slurpy -> SlurpMonad a -> Either String (Slurpy, a) -withSlurpy s (SM f) = f (Right s) - -smDoesDirectoryExist :: FileName -> SlurpMonad Bool -smDoesDirectoryExist d = mksm $ \s -> (Right (s, slurp_hasdir d s)) - -smDoesFileExist :: FileName -> SlurpMonad Bool -smDoesFileExist f = mksm $ \s -> (Right (s, slurp_hasfile f s)) - --- smInSlurpy doesn't make any changes to the subdirectory. -smInSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a -smInSlurpy d job = mksm sm - where sm s = case get_slurp d s of - Just s' | is_dir s' -> case withSlurpy s' job of - Left e -> Left e - Right (_,a) -> Right (s, a) - _ -> Left $ "smInSlurpy: Couldn't find directory " ++ - formatPath (fn2fp d) - -fromSlurpFile :: FileName -> (Slurpy -> a) -> SlurpMonad a -fromSlurpFile f job = mksm sm - where sm s = case get_slurp f s of - Just s' | is_file s' -> Right (s, job s') - _ -> Left $ "fromSlurpFile: Couldn't find file " ++ - formatPath (fn2fp f) - -modifySubSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a -modifySubSlurpy d job = mksm sm - where sm s = case get_slurp_context d s of - Just (ctx, sub@(Slurpy _ (SlurpDir _ _))) -> - case withSlurpy sub job of - Left e -> Left e - Right (sub',a) -> Right (ctx sub', a) - _ -> Left $ "modifySubSlurpy: Couldn't find directory " ++ - formatPath (fn2fp d) - -modifyFileSlurpy :: FileName -> (Slurpy -> Slurpy) -> SlurpMonad () -modifyFileSlurpy f job = mksm sm - where sm s = case get_slurp_context f s of - Just (ctx, sf@(Slurpy _ (SlurpFile _ _))) -> Right (ctx $ job sf, ()) - _ -> Left $ "modifyFileSlurpy: Couldn't find file " ++ - formatPath (fn2fp f) - -insertSlurpy :: FileName -> Slurpy -> SlurpMonad () -insertSlurpy f news = mksm $ \s -> - if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (superName f) s) - then Left $ "Error creating file "++fn2fp f - else Right (addslurp f news s, ()) - -smReadFilePS :: FileName -> SlurpMonad B.ByteString -smReadFilePS f = fromSlurpFile f get_filecontents - -smReadFilePSs :: FileName -> SlurpMonad [B.ByteString] -smReadFilePSs f = fromSlurpFile f (linesPS . get_filecontents) - -smGetDirContents :: SlurpMonad [FileName] -smGetDirContents = mksm $ \s -> Right (s, map slurp_fn $ get_dircontents s) - -smWriteFilePS :: FileName -> B.ByteString -> SlurpMonad () -smWriteFilePS f ps = -- this implementation could be made rather more direct - -- and limited to a single pass down the Slurpy - modifyFileSlurpy f (\_ -> sl) - `mplus` insertSlurpy f sl - where sl = Slurpy (own_name f) (SlurpFile undef_time_size ps) - -smCreateDirectory :: FileName -> SlurpMonad () -smCreateDirectory a = mksm sm - where sm s = case slurp_adddir a s of - Just s' -> Right (s', ()) - Nothing -> Left $ "Error creating directory "++fn2fp a - -smRename :: FileName -> FileName -> SlurpMonad () -smRename a b = mksm sm - where sm s = case slurp_move a b s of - Just s' -> Right (s', ()) - Nothing -> - -- Workaround for some old patches having moves when the source file doesn't exist. - if (slurp_has (fn2fp a) s) - then Left $ "Error moving "++fn2fp a++" to "++fn2fp b - else Right (s, ()) - -smRemove :: FileName -> SlurpMonad () -smRemove f = mksm sm - where sm s = case slurp_remove f s of - Nothing -> Left $ fn2fp f++" does not exist." - Just s' -> Right (s', ()) - -smRemoveFile :: FileName -> SlurpMonad () -smRemoveFile f = - do exists <- mDoesFileExist f - if exists then smRemove f - else fail $ "File "++fn2fp f++" does not exist." - -smRemoveDirectory :: FileName -> SlurpMonad () -smRemoveDirectory f = - do exists <- mDoesDirectoryExist f - if exists then smRemove f - else fail $ "Directory "++fn2fp f++" does not exist." - --- | Here are a few access functions. -slurp_name (Slurpy n _) = fn2fp n -slurp_fn :: Slurpy -> FileName -slurp_fn (Slurpy n _) = n -slurp_setname :: FileName -> Slurpy -> Slurpy -slurp_setname f (Slurpy _ s) = Slurpy f s - -is_file (Slurpy _ (SlurpDir _ _)) = False -is_file (Slurpy _ (SlurpFile _ _)) = True - -is_dir (Slurpy _ (SlurpDir _ _)) = True -is_dir (Slurpy _ (SlurpFile _ _)) = False - -get_filecontents (Slurpy _ (SlurpFile _ c)) = c -get_filecontents _ = bug "Can't get_filecontents on SlurpDir." - -get_dircontents (Slurpy _ (SlurpDir _ c)) = map_to_slurpies c -get_dircontents _ = bug "Can't get_dircontents on SlurpFile." - -get_mtime (Slurpy _ (SlurpFile (_,t,_) _)) = t -get_mtime _ = bug "can't get_mtime on SlurpDir." -get_length (Slurpy _ (SlurpFile (_,_,l) _)) = l -get_length _ = bug "can't get_length on SlurpDir." - -undefined_time :: EpochTime -undefined_time = -1 -undefined_size :: FileOffset -undefined_size = -1 -undef_time_size :: (Maybe String, EpochTime, FileOffset) -undef_time_size = (Nothing, undefined_time, undefined_size) - -isFileReallySymlink :: FilePath -> IO Bool -isFileReallySymlink f = do fs <- getSymbolicLinkStatus f - return (isSymbolicLink fs) - -doesFileReallyExist :: FilePath -> IO Bool -doesFileReallyExist f = do fs <- getSymbolicLinkStatus f - return (isRegularFile fs) - -doesDirectoryReallyExist :: FilePath -> IO Bool -doesDirectoryReallyExist f = do fs <- getSymbolicLinkStatus f - return (isDirectory fs) - --- |slurp is how we get a slurpy in the first place\ldots -slurp = slurp_unboring (\_->True) . toPath -mmap_slurp d = do canmmap <- can_I_use_mmap - if canmmap then genslurp True (\_->True) d - else genslurp False (\_->True) d -slurp_unboring = genslurp False -genslurp :: Bool -> (FilePath -> Bool) - -> FilePath -> IO Slurpy -genslurp usemm nb dirname = do - isdir <- doesDirectoryExist dirname - ms <- if isdir - then withCurrentDirectory dirname $ - do actualname <- getCurrentDirectory - genslurp_helper usemm nb (reverse actualname) "" "." - else do former_dir <- getCurrentDirectory - genslurp_helper usemm nb (reverse former_dir) "" dirname - case ms of - Just s -> return s - Nothing -> fail $ "Unable to read directory " ++ dirname ++ - " (it appears to be neither file nor directory)" - -unsafeInterleaveMapIO :: (a -> IO b) -> [a] -> IO [b] -unsafeInterleaveMapIO _ [] = return [] -unsafeInterleaveMapIO f (x:xs) - = do x' <- f x - xs' <- unsafeInterleaveIO $ unsafeInterleaveMapIO f xs - return (x':xs') - -genslurp_helper :: Bool -> (FilePath -> Bool) - -> FilePath -> String -> String -> IO (Maybe Slurpy) -genslurp_helper usemm nb formerdir fullpath dirname = do - fs <- getSymbolicLinkStatus fulldirname - if isRegularFile fs - then do let mtime = (Nothing, modificationTime fs, fileSize fs) - ls <- unsafeInterleaveIO $ myReadFileLinesPSetc fulldirname - return $ Just $ Slurpy (fp2fn dirname) $ SlurpFile mtime ls - else if isDirectory fs || (isSymbolicLink fs && dirname == ".") - then do sl <- unsafeInterleaveIO $ - do fnames <- getDirectoryContents fulldirname - unsafeInterleaveMapIO - (\f -> genslurp_helper usemm nb fulldirname' - (fullpath///f) f) - $ filter (nb . (fullpath///)) $ filter not_hidden fnames - return $ Just $ Slurpy (fp2fn dirname) $ SlurpDir Nothing $ slurpies_to_map $ catMaybes sl - else return Nothing - where fulldirname' = formerdir\\\dirname - fulldirname = reverse fulldirname' - myReadFileLinesPSetc = if usemm then mmapFilePS - else B.readFile - -not_hidden :: FilePath -> Bool -not_hidden "." = False -not_hidden ".." = False -not_hidden _ = True - -(\\\) :: FilePath -> FilePath -> FilePath -(\\\) "" d = d -(\\\) d "." = d -(\\\) d subdir = reverse subdir ++ "/" ++ d - -(///) :: FilePath -> FilePath -> FilePath -(///) "" d = d -(///) d "." = d -(///) d subdir = d ++ "/" ++ subdir - -co_slurp :: Slurpy -> FilePath -> IO Slurpy -co_slurp guide dirname = do - isdir <- doesDirectoryExist dirname - if isdir - then withCurrentDirectory dirname $ do - actualname <- getCurrentDirectory - Just slurpy <- co_slurp_helper (reverse actualname) guide - return slurpy - else error "Error coslurping!!! Please report this." - -co_slurp_helper :: FilePath -> Slurpy -> IO (Maybe Slurpy) -co_slurp_helper former_dir (Slurpy d (SlurpDir _ c)) = unsafeInterleaveIO $ do - let d' = fn2fp d - fn' = former_dir\\\d' - fn = reverse fn' - efs <- tryNonSignal $ getSymbolicLinkStatus fn - case efs of - Right fs - | isDirectory fs || (isSymbolicLink fs && d' == ".") -> - do sl <- unsafeInterleaveIO - $ unsafeInterleaveMapIO (co_slurp_helper fn') (map_to_slurpies c) - return $ Just $ Slurpy d $ SlurpDir Nothing $ slurpies_to_map $ catMaybes sl - _ -> return Nothing -co_slurp_helper former_dir (Slurpy f (SlurpFile _ _)) = unsafeInterleaveIO $ do - let fn' = former_dir\\\fn2fp f - fn = reverse fn' - efs <- tryNonSignal $ getSymbolicLinkStatus fn - case efs of - Right fs - | isRegularFile fs -> - do let mtime = (Nothing, modificationTime fs, fileSize fs) - ls <- unsafeInterleaveIO $ B.readFile fn - return $ Just $ Slurpy f $ SlurpFile mtime ls - _ -> return Nothing - -get_slurp_context_generic :: (Slurpy -> a) -> (a -> [Slurpy]) -> FileName -> Slurpy -> Maybe (a -> a, Slurpy) -get_slurp_context_generic h1 h2 fn0 s0 = - let norm_fn0 = norm_path fn0 in - if norm_fn0 == empty - then Just (id, s0) - else slurp_context_private norm_fn0 id s0 - where - slurp_context_private f ctx s@(Slurpy f' (SlurpFile _ _)) = - if f == f' then Just (ctx, s) - else Nothing - slurp_context_private f ctx s@(Slurpy d (SlurpDir _ c)) - | f == d = Just (ctx, s) - | d == dot = - case break_on_dir f of - Just (dn,fn) | dn == dot -> - descend fn - _ -> - descend f - | otherwise = - case break_on_dir f of - Just (dn,fn) -> - if dn == d - then descend fn - else Nothing - _ -> Nothing - where - descend fname = - case findSubSlurpy fname c of - Nothing -> Nothing - Just this -> slurp_context_private - fname - (ctx . h1 . Slurpy d . SlurpDir Nothing . foldr (uncurry Map.insert) (Map.delete (slurp_fn this) c) . map slurpy_to_pair . h2) - this - - dot = fp2fn "." - empty = fp2fn "" - --- |get_slurp_context navigates to a specified filename in the given slurpy, --- and returns the child slurpy at that point together with a update function that can be used --- to reconstruct the original slurpy from a replacement value for the child slurpy. -get_slurp_context :: FileName -> Slurpy -> Maybe (Slurpy -> Slurpy, Slurpy) -get_slurp_context = get_slurp_context_generic id return - --- |A variant of 'get_slurp_context' that allows for removing the child slurpy --- altogether by passing in 'Nothing' to the update function. --- If the child slurpy happened to be at the top level and 'Nothing' was passed in, --- then the result of the update function will also be 'Nothing', otherwise it will always --- be a 'Just' value. -get_slurp_context_maybe :: FileName -> Slurpy -> Maybe (Maybe Slurpy -> Maybe Slurpy, Slurpy) -get_slurp_context_maybe = get_slurp_context_generic Just maybeToList - --- |A variant of 'get_slurp_context' that allows for replacing the child slurpy by --- a list of slurpies. The result of the update function will always be a singleton --- list unless the child slurpy was at the top level. --- Currently unused. --- get_slurp_context_list :: FileName -> Slurpy -> Maybe ([Slurpy] -> [Slurpy], Slurpy) --- get_slurp_context_list = get_slurp_context_generic return id - --- | It is important to be able to readily modify a slurpy. -slurp_remove :: FileName -> Slurpy -> Maybe Slurpy -slurp_remove fname s@(Slurpy _ (SlurpDir _ _)) = - case get_slurp_context_maybe fname s of - Just (ctx, _) -> ctx Nothing - Nothing -> Nothing -slurp_remove _ _ = bug "slurp_remove only acts on SlurpDirs" - -slurp_removefile :: FileName -> Slurpy -> Maybe Slurpy -slurp_removefile f s = - if slurp_hasfile f s - then case slurp_remove f s of - s'@(Just (Slurpy _ (SlurpDir _ _))) -> s' - _ -> impossible - else Nothing - -slurp_move :: FileName -> FileName -> Slurpy -> Maybe Slurpy -slurp_move f f' s = - if not (slurp_has (fn2fp f') s) && slurp_hasdir (superName f') s - then case get_slurp f s of - Nothing -> Nothing - Just sf -> - case slurp_remove f s of - Nothing -> Nothing - Just (s'@(Slurpy _ (SlurpDir _ _))) -> - Just $ addslurp f' (slurp_setname (own_name f') sf) s' - _ -> impossible - else Nothing - -addslurp :: FileName -> Slurpy -> Slurpy -> Slurpy -addslurp fname s s' = - case get_slurp_context (superName fname) s' of - Just (ctx, Slurpy d (SlurpDir _ c)) -> ctx (Slurpy d (SlurpDir Nothing (uncurry Map.insert (slurpy_to_pair s) c))) - _ -> s' - -get_slurp :: FileName -> Slurpy -> Maybe Slurpy -get_slurp f s = fmap snd (get_slurp_context f s) - -slurp_removedir :: FileName -> Slurpy -> Maybe Slurpy -slurp_removedir f s = - case get_slurp f s of - Just (Slurpy _ (SlurpDir _ l)) | Map.null l -> - case slurp_remove f s of - s'@(Just (Slurpy _ (SlurpDir _ _))) -> s' - _ -> impossible - _ -> Nothing - -slurp_adddir :: FileName -> Slurpy -> Maybe Slurpy -slurp_adddir f s = - if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (superName f) s) - then Nothing - else Just $ addslurp f (Slurpy (own_name f) (SlurpDir Nothing Map.empty)) s - --- |Code to modify a given file in a slurpy. -slurp_modfile :: FileName -> (FileContents -> Maybe FileContents) - -> Slurpy -> Maybe Slurpy -slurp_modfile fname modify sl = - case get_slurp_context fname sl of - Just (ctx, Slurpy ff (SlurpFile _ c)) -> - case modify c of - Nothing -> Nothing - Just c' -> Just (ctx (Slurpy ff (SlurpFile undef_time_size c'))) - _ -> - Nothing - -slurp_hasfile :: FileName -> Slurpy -> Bool -slurp_hasfile f s = - case get_slurp f s of - Just s' | is_file s' -> True - _ -> False - -slurp_has :: FilePath -> Slurpy -> Bool -slurp_has f s = isJust (get_slurp (fp2fn f) s) - -slurp_has_anycase :: FilePath -> Slurpy -> Bool -slurp_has_anycase fname s = - seq normed_name $ isJust $ get_slurp normed_name $ mapSlurpyNames tolower s - where normed_name = norm_path $ fp2fn $ map toLower fname - -tolower :: FileName -> FileName -tolower = fp2fn . (map toLower) . fn2fp - -findSubSlurpy :: FileName -> SlurpyMap -> Maybe Slurpy -findSubSlurpy fn sm = - let topname = case break_on_dir fn of - Just (dn, _) -> dn - Nothing -> fn - in fmap (Slurpy topname) (Map.lookup topname sm) - -slurp_hasdir :: FileName -> Slurpy -> Bool -slurp_hasdir d _ | norm_path d == fp2fn "" = True -slurp_hasdir f (Slurpy _ (SlurpDir _ c)) = - seq f $ let f' = norm_path f - in case findSubSlurpy f' c of - Just s -> slurp_hasdir_private f' s - Nothing -> False -slurp_hasdir _ _ = False - -slurp_hasdir_private :: FileName -> Slurpy -> Bool -slurp_hasdir_private _ (Slurpy _ (SlurpFile _ _)) = False -slurp_hasdir_private f (Slurpy d (SlurpDir _ c)) - | f == d = True - | otherwise = - case break_on_dir f of - Just (dn,fn) -> - if dn == d - then case findSubSlurpy fn c of - Just s -> slurp_hasdir_private fn s - Nothing -> False - else False - _ -> False - -get_path_list :: Slurpy -> FilePath -> [FilePath] -get_path_list s fp = get_path_list' s ("./" ++ fp) - -get_path_list' :: Slurpy -> FilePath -> [FilePath] -get_path_list' s "" = list_slurpy s -get_path_list' (Slurpy f (SlurpFile _ _)) fp - | f' == fp = [f'] - where f' = fn2fp f -get_path_list' (Slurpy d (SlurpDir _ ss)) fp - | (d' ++ "/") `isPrefixOf` (fp ++ "/") - = let fp' = drop (length d' + 1) fp - in map (d' ///) $ concatMap (\s -> get_path_list' s fp') $ map_to_slurpies ss - where d' = fn2fp d -get_path_list' _ _ = [] - -list_slurpy :: Slurpy -> [FilePath] -list_slurpy (Slurpy f (SlurpFile _ _)) = [fn2fp f] -list_slurpy (Slurpy dd (SlurpDir _ ss)) = d : map (d ///) (concatMap list_slurpy (map_to_slurpies ss)) - where d = fn2fp dd - -list_slurpy_files :: Slurpy -> [FilePath] -list_slurpy_files (Slurpy f (SlurpFile _ _)) = [fn2fp f] -list_slurpy_files (Slurpy dd (SlurpDir _ ss)) = - map ((fn2fp dd) ///) (concatMap list_slurpy_files (map_to_slurpies ss)) - -list_slurpy_dirs :: Slurpy -> [FilePath] -list_slurpy_dirs (Slurpy _ (SlurpFile _ _)) = [] -list_slurpy_dirs (Slurpy dd (SlurpDir _ ss)) = - d : map (d ///) (concatMap list_slurpy_dirs (map_to_slurpies ss)) - where d = fn2fp dd - -unsyncedSlurpySize :: Slurpy -> Int -unsyncedSlurpySize (Slurpy _ (SlurpFile (_,_,size) ps)) - | size == undefined_size = B.length ps - | otherwise = 0 -unsyncedSlurpySize (Slurpy _ (SlurpDir _ ss)) = - sum $ map unsyncedSlurpySize (map_to_slurpies ss) - -slurp_sync_size :: Int -slurp_sync_size = 100 * 1000000 - -syncSlurpy :: (Slurpy -> IO Slurpy) -> Slurpy -> IO Slurpy -syncSlurpy put s = if unsyncedSlurpySize s > slurp_sync_size - then put s - else return s diff -ruN darcs-2.4.4/src/Darcs/SlurpDirectory.hs darcs-2.5/src/Darcs/SlurpDirectory.hs --- darcs-2.4.4/src/Darcs/SlurpDirectory.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/SlurpDirectory.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,35 +0,0 @@ --- Copyright (C) 2002-2004 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -module Darcs.SlurpDirectory - (Slurpy, empty_slurpy, slurp, - mmap_slurp, co_slurp, slurp_unboring, - FileContents, - undefined_time, undefined_size, - doesFileReallyExist, doesDirectoryReallyExist, isFileReallySymlink, - is_dir, is_file, - get_slurp, slurp_name, - slurp_has, slurp_has_anycase, slurp_hasfile, slurp_hasdir, - list_slurpy, list_slurpy_files, list_slurpy_dirs, get_path_list, - get_filecontents, get_dircontents, get_mtime, get_length, - slurp_modfile, slurp_remove, slurp_removefile, slurp_removedir, - write_files, - SlurpMonad, withSlurpy, writeSlurpy, syncSlurpy - ) - where - -import Darcs.SlurpDirectory.Internal diff -ruN darcs-2.4.4/src/Darcs/Test/Email.hs darcs-2.5/src/Darcs/Test/Email.hs --- darcs-2.4.4/src/Darcs/Test/Email.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Test/Email.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,9 +21,9 @@ -- These tests check whether the emails generated by darcs meet a few criteria. -- We check for line length and non-ASCII characters. We apparently do not have -- to check for CR-LF newlines because that's handled by sendmail. -module Darcs.Test.Email ( email_parsing, email_header_no_long_lines, - email_header_ascii_chars, email_header_lines_start, - email_header_no_empty_lines +module Darcs.Test.Email ( emailParsing, emailHeaderNoLongLines, + emailHeaderAsciiChars, emailHeaderLinesStart, + emailHeaderNoEmptyLines ) where import Data.Char ( isPrint ) import qualified Data.ByteString as B ( length, unpack, null, head, filter, @@ -32,55 +32,55 @@ import Test.Framework ( Test ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Printer ( text, renderPS ) -import Darcs.Email ( make_email, read_email, formatHeader ) +import Darcs.Email ( makeEmail, readEmail, formatHeader ) -- | Checks that darcs can read the emails it generates -email_parsing :: Test -email_parsing = testProperty "Checking that email can be parsed" $ \s -> +emailParsing :: Test +emailParsing = testProperty "Checking that email can be parsed" $ \s -> unlines ("":s++["", ""]) == - BC.unpack (read_email (renderPS - $ make_email "reponame" [] (Just (text "contents\n")) + BC.unpack (readEmail (renderPS + $ makeEmail "reponame" [] (Just (text "contents\n")) (text $ unlines s) (Just "filename"))) -- | Check that formatHeader never creates lines longer than 78 characters -- (excluding the carriage return and line feed) -email_header_no_long_lines :: Test -email_header_no_long_lines = +emailHeaderNoLongLines :: Test +emailHeaderNoLongLines = testProperty "Checking email header line length" $ \field value -> - let cleanField = clean_field_string field - in not $ any (>78) $ map B.length $ bs_lines $ formatHeader cleanField value + let cleanField = cleanFieldString field + in not $ any (>78) $ map B.length $ bsLines $ formatHeader cleanField value -- Check that an email header does not contain non-ASCII characters -- formatHeader doesn't escape field names, there is no such thing as non-ascii -- field names afaik -email_header_ascii_chars :: Test -email_header_ascii_chars = +emailHeaderAsciiChars :: Test +emailHeaderAsciiChars = testProperty "Checking email for illegal characters" $ \field value -> - let cleanField = clean_field_string field + let cleanField = cleanFieldString field in not (any (>127) (B.unpack (formatHeader cleanField value))) -- Check that header the second and later lines of a header start with a space -email_header_lines_start :: Test -email_header_lines_start = +emailHeaderLinesStart :: Test +emailHeaderLinesStart = testProperty "Checking for spaces at start of folded email header lines" $ \field value -> - let headerLines = bs_lines (formatHeader cleanField value) - cleanField = clean_field_string field + let headerLines = bsLines (formatHeader cleanField value) + cleanField = cleanFieldString field in all (\l -> B.null l || B.head l == 32) (tail headerLines) -- Checks that there are no lines in email headers with only whitespace -email_header_no_empty_lines :: Test -email_header_no_empty_lines = +emailHeaderNoEmptyLines :: Test +emailHeaderNoEmptyLines = testProperty "Checking that there are no empty lines in email headers" $ \field value -> - let headerLines = bs_lines (formatHeader cleanField value) - cleanField = clean_field_string field - in all (not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines + let headerLines = bsLines (formatHeader cleanField value) + cleanField = cleanFieldString field + in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines -bs_lines :: B.ByteString -> [B.ByteString] -bs_lines = finalizeFold . B.foldr splitAtLines (B.empty, []) +bsLines :: B.ByteString -> [B.ByteString] +bsLines = finalizeFold . B.foldr splitAtLines (B.empty, []) where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines) splitAtLines c (thisLine, prevLines) = (B.cons c thisLine, prevLines) finalizeFold (lastLine, otherLines) = lastLine : otherLines -clean_field_string :: String -> String -clean_field_string = filter (\c -> isPrint c && c < '\x80' && c /= ':') +cleanFieldString :: String -> String +cleanFieldString = filter (\c -> isPrint c && c < '\x80' && c /= ':') diff -ruN darcs-2.4.4/src/Darcs/Test/Patch/Check.hs darcs-2.5/src/Darcs/Test/Patch/Check.hs --- darcs-2.4.4/src/Darcs/Test/Patch/Check.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Test/Patch/Check.hs 2010-10-24 08:29:26.000000000 -0700 @@ -15,11 +15,11 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Test.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists, - remove_file, remove_dir, create_file, create_dir, - insert_line, delete_line, is_valid, do_verbose_check, - file_empty, - check_move, modify_file, FileContents(..) +module Darcs.Test.Patch.Check ( PatchCheck(), doCheck, fileExists, dirExists, + removeFile, removeDir, createFile, createDir, + insertLine, deleteLine, isValid, doVerboseCheck, + fileEmpty, + checkMove, modifyFile, FileContents(..) ) where import System.IO.Unsafe ( unsafePerformIO ) @@ -38,8 +38,8 @@ -- We must also store the greatest line number that is known to exist in a -- file, to be able to exclude the possibility of it being empty without -- knowing its contents. -data FileContents = FC { fc_lines :: Map Int B.ByteString - , fc_maxline :: Int +data FileContents = FC { fcLines :: Map Int B.ByteString + , fcMaxline :: Int } deriving (Eq, Show) data Prop = FileEx String | DirEx String | NotEx String | FileLines String FileContents @@ -62,115 +62,115 @@ type PatchCheck = State KnownState -- | The @FileContents@ structure for an empty file -empty_filecontents :: FileContents -empty_filecontents = FC M.empty 0 +emptyFilecontents :: FileContents +emptyFilecontents = FC M.empty 0 -- | Returns a given value if the repository state is inconsistent, and performs -- a given action otherwise. -handle_inconsistent :: a -- ^ The value to return if the state is inconsistent +handleInconsistent :: a -- ^ The value to return if the state is inconsistent -> PatchCheck a -- ^ The action to perform otherwise -> PatchCheck a -handle_inconsistent v a = do state <- get +handleInconsistent v a = do state <- get case state of Inconsistent -> return v _ -> a -do_check :: PatchCheck a -> a -do_check p = evalState p (P [] []) +doCheck :: PatchCheck a -> a +doCheck p = evalState p (P [] []) -- | Run a check, and print the final repository state -do_verbose_check :: PatchCheck a -> a -do_verbose_check p = +doVerboseCheck :: PatchCheck a -> a +doVerboseCheck p = case runState p (P [] []) of (b, pc) -> unsafePerformIO $ do putStrLn $ show pc return b -- | Returns true if the current repository state is not inconsistent -is_valid :: PatchCheck Bool -is_valid = handle_inconsistent False (return True) +isValid :: PatchCheck Bool +isValid = handleInconsistent False (return True) has :: Prop -> [Prop] -> Bool has _ [] = False has k (k':ks) = k == k' || has k ks -modify_file :: String +modifyFile :: String -> (Maybe FileContents -> Maybe FileContents) -> PatchCheck Bool -modify_file f change = do - file_exists f - c <- file_contents f +modifyFile f change = do + fileExists f + c <- fileContents f case change c of - Nothing -> assert_not $ FileEx f -- shorthand for "FAIL" - Just c' -> do set_contents f c' - is_valid - -insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool -insert_line f n l = do - c <- file_contents f + Nothing -> assertNot $ FileEx f -- shorthand for "FAIL" + Just c' -> do setContents f c' + isValid + +insertLine :: String -> Int -> B.ByteString -> PatchCheck Bool +insertLine f n l = do + c <- fileContents f case c of - Nothing -> assert_not $ FileEx f -- in this case, the repo is inconsistent + Nothing -> assertNot $ FileEx f -- in this case, the repo is inconsistent Just c' -> do - let lines' = M.mapKeys (\k -> if k >= n then k+1 else k) (fc_lines c') + let lines' = M.mapKeys (\k -> if k >= n then k+1 else k) (fcLines c') lines'' = M.insert n l lines' - maxline' = max n (fc_maxline c') - set_contents f (FC lines'' maxline') + maxline' = max n (fcMaxline c') + setContents f (FC lines'' maxline') return True -- deletes a line from a hunk patch (third argument) in the given file (first -- argument) at the given line number (second argument) -delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool -delete_line f n l = do - c <- file_contents f +deleteLine :: String -> Int -> B.ByteString -> PatchCheck Bool +deleteLine f n l = do + c <- fileContents f case c of - Nothing -> assert_not $ FileEx f + Nothing -> assertNot $ FileEx f Just c' -> - let flines = fc_lines c' + let flines = fcLines c' flines' = M.mapKeys (\k -> if k > n then k-1 else k) (M.delete n flines) - maxlinenum' | n <= fc_maxline c' = fc_maxline c' - 1 + maxlinenum' | n <= fcMaxline c' = fcMaxline c' - 1 | otherwise = n - 1 c'' = FC flines' maxlinenum' do_delete = do - set_contents f c'' - is_valid + setContents f c'' + isValid in case M.lookup n flines of Nothing -> do_delete Just l' -> if l == l' then do_delete - else assert_not $ FileEx f + else assertNot $ FileEx f -set_contents :: String -> FileContents -> PatchCheck () -set_contents f c = handle_inconsistent () $ do +setContents :: String -> FileContents -> PatchCheck () +setContents f c = handleInconsistent () $ do P ks nots <- get let ks' = FileLines f c : filter (not . is_file_lines_for f) ks put (P ks' nots) - where is_file_lines_for file prop = case prop of + where is_file_lines_for file prop = case prop of FileLines f' _ -> file == f' _ -> False -- | Get (as much as we know about) the contents of a file in the current state. -- Returns Nothing if the state is inconsistent. -file_contents :: String -> PatchCheck (Maybe FileContents) -file_contents f = handle_inconsistent Nothing $ do +fileContents :: String -> PatchCheck (Maybe FileContents) +fileContents f = handleInconsistent Nothing $ do P ks _ <- get return (fic ks) where fic (FileLines f' c:_) | f == f' = Just c fic (_:ks) = fic ks - fic [] = Just empty_filecontents + fic [] = Just emptyFilecontents -- | Checks if a file is empty -file_empty :: String -- ^ Name of the file to check +fileEmpty :: String -- ^ Name of the file to check -> PatchCheck Bool -file_empty f = do - c <- file_contents f +fileEmpty f = do + c <- fileContents f let empty = case c of - Just c' -> fc_maxline c' == 0 && M.null (fc_lines c') + Just c' -> fcMaxline c' == 0 && M.null (fcLines c') Nothing -> True if empty - then do set_contents f empty_filecontents - is_valid + then do setContents f emptyFilecontents + isValid -- Crude way to make it inconsistent and return false: - else assert_not $ FileEx f + else assertNot $ FileEx f return empty movedirfilename :: String -> String -> String -> String @@ -181,8 +181,8 @@ -- | Replaces a filename by another in all paths. Returns True if the repository -- is consistent, False if it is not. -do_swap :: String -> String -> PatchCheck Bool -do_swap f f' = handle_inconsistent False $ do +doSwap :: String -> String -> PatchCheck Bool +doSwap f f' = handleInconsistent False $ do modify (\(P ks nots) -> P (map sw ks) (map sw nots)) return True where sw (FileEx a) | f `is_soe` a = FileEx $ movedirfilename f f' a @@ -203,7 +203,7 @@ -- the property is already in the list of properties that do not hold for the -- repo, the state becomes inconsistent, and the function returns false. assert :: Prop -> PatchCheck Bool -assert p = handle_inconsistent False $ do +assert p = handleInconsistent False $ do P ks nots <- get if has p nots then do @@ -217,8 +217,8 @@ -- | Like @assert@, but negatively: state that some property must not hold for -- the current repo. -assert_not :: Prop -> PatchCheck Bool -assert_not p = handle_inconsistent False $ do +assertNot :: Prop -> PatchCheck Bool +assertNot p = handleInconsistent False $ do P ks nots <- get if has p ks then do @@ -233,76 +233,76 @@ -- | Remove a property from the list of properties that do not hold for this -- repo (if it's there), and add it to the list of properties that hold. -- Returns False if the repo is inconsistent, True otherwise. -change_to_true :: Prop -> PatchCheck Bool -change_to_true p = handle_inconsistent False $ do +changeToTrue :: Prop -> PatchCheck Bool +changeToTrue p = handleInconsistent False $ do modify (\(P ks nots) -> P (p:ks) (filter (p /=) nots)) return True -- | Remove a property from the list of properties that hold for this repo (if -- it's in there), and add it to the list of properties that do not hold. -- Returns False if the repo is inconsistent, True otherwise. -change_to_false :: Prop -> PatchCheck Bool -change_to_false p = handle_inconsistent False $ do +changeToFalse :: Prop -> PatchCheck Bool +changeToFalse p = handleInconsistent False $ do modify (\(P ks nots) -> P (filter (p /=) ks) (p:nots)) return True -assert_file_exists :: String -> PatchCheck Bool -assert_file_exists f = do assert_not $ NotEx f - assert_not $ DirEx f +assertFileExists :: String -> PatchCheck Bool +assertFileExists f = do assertNot $ NotEx f + assertNot $ DirEx f assert $ FileEx f -assert_dir_exists :: String -> PatchCheck Bool -assert_dir_exists d = do assert_not $ NotEx d - assert_not $ FileEx d +assertDirExists :: String -> PatchCheck Bool +assertDirExists d = do assertNot $ NotEx d + assertNot $ FileEx d assert $ DirEx d -assert_exists :: String -> PatchCheck Bool -assert_exists f = assert_not $ NotEx f +assertExists :: String -> PatchCheck Bool +assertExists f = assertNot $ NotEx f -assert_no_such :: String -> PatchCheck Bool -assert_no_such f = do assert_not $ FileEx f - assert_not $ DirEx f +assertNoSuch :: String -> PatchCheck Bool +assertNoSuch f = do assertNot $ FileEx f + assertNot $ DirEx f assert $ NotEx f -create_file :: String -> PatchCheck Bool -create_file fn = do - superdirs_exist fn - assert_no_such fn - change_to_true (FileEx fn) - change_to_false (NotEx fn) - -create_dir :: String -> PatchCheck Bool -create_dir fn = do - substuff_dont_exist fn - superdirs_exist fn - assert_no_such fn - change_to_true (DirEx fn) - change_to_false (NotEx fn) - -remove_file :: String -> PatchCheck Bool -remove_file fn = do - superdirs_exist fn - assert_file_exists fn - file_empty fn - change_to_false (FileEx fn) - change_to_true (NotEx fn) - -remove_dir :: String -> PatchCheck Bool -remove_dir fn = do - substuff_dont_exist fn - superdirs_exist fn - assert_dir_exists fn - change_to_false (DirEx fn) - change_to_true (NotEx fn) - -check_move :: String -> String -> PatchCheck Bool -check_move f f' = do - superdirs_exist f - superdirs_exist f' - assert_exists f - assert_no_such f' - do_swap f f' +createFile :: String -> PatchCheck Bool +createFile fn = do + superdirsExist fn + assertNoSuch fn + changeToTrue (FileEx fn) + changeToFalse (NotEx fn) + +createDir :: String -> PatchCheck Bool +createDir fn = do + substuffDontExist fn + superdirsExist fn + assertNoSuch fn + changeToTrue (DirEx fn) + changeToFalse (NotEx fn) + +removeFile :: String -> PatchCheck Bool +removeFile fn = do + superdirsExist fn + assertFileExists fn + fileEmpty fn + changeToFalse (FileEx fn) + changeToTrue (NotEx fn) + +removeDir :: String -> PatchCheck Bool +removeDir fn = do + substuffDontExist fn + superdirsExist fn + assertDirExists fn + changeToFalse (DirEx fn) + changeToTrue (NotEx fn) + +checkMove :: String -> String -> PatchCheck Bool +checkMove f f' = do + superdirsExist f + superdirsExist f' + assertExists f + assertNoSuch f' + doSwap f f' -substuff_dont_exist :: String -> PatchCheck Bool -substuff_dont_exist d = handle_inconsistent False $ do +substuffDontExist :: String -> PatchCheck Bool +substuffDontExist d = handleInconsistent False $ do P ks _ <- get if all noss ks then return True @@ -317,17 +317,17 @@ -- the init and tail calls dump the final init (which is just the path itself -- again), the first init (which is empty), and the initial "." from -- splitDirectories -superdirs_exist :: String -> PatchCheck Bool -superdirs_exist fn = and `fmap` mapM assert_dir_exists superdirs - where superdirs = map (("./"++) . joinPath) +superdirsExist :: String -> PatchCheck Bool +superdirsExist fn = and `fmap` mapM assertDirExists superdirs + where superdirs = map (("./"++) . joinPath) (init (tail (inits (tail (splitDirectories fn))))) -file_exists :: String -> PatchCheck Bool -file_exists fn = do - superdirs_exist fn - assert_file_exists fn - -dir_exists :: String -> PatchCheck Bool -dir_exists fn = do - superdirs_exist fn - assert_dir_exists fn +fileExists :: String -> PatchCheck Bool +fileExists fn = do + superdirsExist fn + assertFileExists fn + +dirExists :: String -> PatchCheck Bool +dirExists fn = do + superdirsExist fn + assertDirExists fn diff -ruN darcs-2.4.4/src/Darcs/Test/Patch/Info.hs darcs-2.5/src/Darcs/Test/Patch/Info.hs --- darcs-2.4.4/src/Darcs/Test/Patch/Info.hs 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/src/Darcs/Test/Patch/Info.hs 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,158 @@ +-- Copyright (C) 2009 Reinier Lamers +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +-- | This module contains tests for the code in Darcs.Patch.Info. Most of them +-- are about the UTF-8-encoding of patch metadata. +module Darcs.Test.Patch.Info ( metadataDecodingTest, metadataEncodingTest, + packUnpackTest + ) where + +import Prelude hiding ( pi ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B ( split, pack ) +import qualified Data.ByteString.Char8 as BC ( unpack ) +import Data.List ( sort ) +import Data.Maybe ( isNothing ) +import Data.Text as T ( findBy, any ) +import Data.Text.Encoding ( decodeUtf8With ) +import Data.Text.Encoding.Error ( lenientDecode ) +import Foreign ( unsafePerformIO ) +import Test.QuickCheck ( Arbitrary(arbitrary), oneof, listOf, choose, shrink + , Gen ) +import Test.Framework.Providers.QuickCheck2 ( testProperty ) +import Test.Framework (Test) +import Data.List ( isPrefixOf ) + +import Darcs.Patch.Info ( PatchInfo(..), patchinfo, + piLog, piAuthor, piName ) +import ByteStringUtils ( decodeLocale, packStringToUTF8, unpackPSFromUTF8 ) + +-- | A newtype wrapping String so we can make our own random generator for it. +newtype UnicodeString = UnicodeString { asString :: String } + deriving (Show, Eq, Ord) + +-- | A newtype wrapping PatchInfo that has a random generator that generates +-- both UTF-8-encoded and non-encoded PatchInfo's. +newtype UTF8OrNotPatchInfo = UTF8OrNotPatchInfo PatchInfo deriving (Eq, Ord) + +-- | A newtype wrapping PatchInfo, which has a random generator that generates +-- only UTF-8-encoded PatchInfo's. +newtype UTF8PatchInfo = UTF8PatchInfo PatchInfo deriving (Eq, Ord) + +instance Arbitrary UnicodeString where + -- 0x10ffff is the highest Unicode code point ; 0xd800 - 0xdfff are + -- surrogates. '\xfffd' is excluded because it is used as a marker + -- for UTF-8 test failure. + arbitrary = UnicodeString `fmap` listOf (oneof [choose ('\0', '\xd799') + ,choose ('\xe000', '\xfffc') + ,choose ('\xfffe', '\x10ffff')]) + +instance Show UTF8PatchInfo where + showsPrec _ = withUTF8PatchInfo rawPatchInfoShow +instance Show UTF8OrNotPatchInfo where + showsPrec _ = withUTF8OrNotPatchInfo rawPatchInfoShow + +-- | Shows a PatchInfo, outputting every byte and clearly marking what is what +rawPatchInfoShow :: PatchInfo -> String -> String +rawPatchInfoShow pi = ("PatchInfo: \n"++) + . ("date: "++) . shows (_piDate pi) . ('\n':) + . ("author: "++) . shows (_piAuthor pi) . ('\n':) + . ("name: "++) . shows (_piName pi) . ('\n':) + . ("log: "++) . shows (_piLog pi) . ('\n':) + +instance Arbitrary UTF8PatchInfo where + arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8Patch + shrink upi = flip withUTF8PatchInfo upi $ \pi -> do + sn <- shrink (piName pi) + sa <- shrink (piAuthor pi) + sl <- shrink (filter (not . isPrefixOf "Ignore-this:") (piLog pi)) + return (UTF8PatchInfo + (unsafePerformIO $ patchinfo sn + (BC.unpack (_piDate pi)) sa sl)) + +instance Arbitrary UTF8OrNotPatchInfo where + arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8Patch, + arbitraryUnencodedPatch]) + +-- | Generate arbitrary patch metadata that uses the metadata creation function +-- 'patchinfo' from Darcs.Patch.Info. +arbitraryUTF8Patch :: Gen PatchInfo +arbitraryUTF8Patch = + do n <- asString `fmap` arbitrary + d <- arbitrary + a <- asString `fmap` arbitrary + l <- (lines . asString) `fmap` arbitrary + return $ unsafePerformIO $ patchinfo n d a l + +-- | Generate arbitrary patch metadata that has totally arbitrary byte strings +-- as its name, date, author and log. +arbitraryUnencodedPatch :: Gen PatchInfo +arbitraryUnencodedPatch = do + n <- arbitraryByteString + d <- arbitraryByteString + a <- arbitraryByteString + -- split 10 is the ByteString equivalent of 'lines' + l <- B.split 10 `fmap` arbitraryByteString + i <- arbitrary + return (PatchInfo d n a l i) + +arbitraryByteString :: Gen ByteString +arbitraryByteString = (B.pack . map fromIntegral) + `fmap` listOf (choose (0, 255) :: Gen Int) + +-- | Test that anything produced by the 'patchinfo' function is valid UTF-8 +metadataEncodingTest :: Test +metadataEncodingTest = testProperty "Testing patch metadata encoding" $ + withUTF8PatchInfo $ + \patchInfo -> encodingOK (_piAuthor patchInfo) + && encodingOK (_piName patchInfo) + && all encodingOK (_piLog patchInfo) + where encodingOK = isNothing . T.findBy (=='\xfffd') . decodeUtf8With lenientDecode + +-- | Test that metadata in patches are decoded as UTF-8 or locale depending on +-- whether they're valid UTF-8. +metadataDecodingTest :: Test +metadataDecodingTest = testProperty "Testing patch metadata decoding" $ + withUTF8OrNotPatchInfo $ + \patchInfo -> utf8OrLocale (_piAuthor patchInfo) == piAuthor patchInfo + && utf8OrLocale (_piName patchInfo) == piName patchInfo + && map utf8OrLocale (_piLog patchInfo) `superset` piLog patchInfo + where utf8OrLocale bs = if isValidUTF8 bs + then unpackPSFromUTF8 bs + else decodeLocale bs + +isValidUTF8 :: ByteString -> Bool +isValidUTF8 = not . T.any (=='\xfffd') . decodeUtf8With lenientDecode + +packUnpackTest :: Test +packUnpackTest = testProperty "Testing UTF-8 packing and unpacking" $ + \uString -> asString uString == (unpackPSFromUTF8 . packStringToUTF8) (asString uString) + +superset :: (Eq a, Ord a) => [a] -> [a] -> Bool +superset a b = sorted_superset (sort a) (sort b) + where sorted_superset (x:xs) (y:ys) | x == y = sorted_superset xs ys + | x < y = sorted_superset xs (y:ys) + | y < x = False + sorted_superset [] (_:_) = False + sorted_superset _ [] = True + +withUTF8PatchInfo :: (PatchInfo -> a) -> UTF8PatchInfo -> a +withUTF8PatchInfo f mpi = case mpi of + UTF8PatchInfo pinf -> f pinf +withUTF8OrNotPatchInfo :: (PatchInfo -> a) -> UTF8OrNotPatchInfo -> a +withUTF8OrNotPatchInfo f mpi = case mpi of + UTF8OrNotPatchInfo pinf -> f pinf diff -ruN darcs-2.4.4/src/Darcs/Test/Patch/QuickCheck.hs darcs-2.5/src/Darcs/Test/Patch/QuickCheck.hs --- darcs-2.4.4/src/Darcs/Test/Patch/QuickCheck.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Test/Patch/QuickCheck.hs 2010-10-24 08:29:26.000000000 -0700 @@ -3,23 +3,21 @@ #include "gadts.h" module Darcs.Test.Patch.QuickCheck ( WithStartState, RepoModel, Tree, -#ifndef GADT_WITNESSES - merge_examples, commute_examples, triple_examples, -#endif - prop_consistent_tree_flattenings, prop_fail, - prop_is_mergeable, + mergeExamples, commuteExamples, tripleExamples, + propConsistentTreeFlattenings, propFail, + propIsMergeable, flattenOne, testConditional, commutePairFromTree, mergePairFromTree, commuteTripleFromTree, commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples, patchFromTree, - quickCheck, real_patch_loop_examples, shrink + quickCheck, realPatchLoopExamples, shrink ) where import Control.Arrow ( (***) ) import Control.Monad ( liftM, replicateM, mplus, mzero ) -import qualified Data.ByteString.Char8 as BC (pack) -import qualified Data.ByteString as B (ByteString) +import qualified Data.ByteString.Char8 as BC (pack, head) +import qualified Data.ByteString as B (ByteString, length) import Test.QuickCheck import Test.Framework ( Test ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) @@ -28,8 +26,9 @@ import Darcs.Witnesses.Ordered import Darcs.Patch.Patchy (--showPatch, Invert(..), Commute(..)) -import Darcs.Patch.Prim (Prim(..), Effect(..), FilePatchType(..), FromPrim(..), is_identity ) +import Darcs.Patch.Prim (Prim(..), Effect(..), FilePatchType(..), FromPrim(..), isIdentity ) import Darcs.Patch.Real ( RealPatch, prim2real ) +import Darcs.Patch.Set ( Origin ) --import Darcs.ColorPrinter ( errorDoc ) --import Darcs.ColorPrinter ( traceDoc ) import Darcs.Witnesses.Show @@ -38,25 +37,15 @@ #include "impossible.h" - -#ifndef GADT_WITNESSES -instance Eq (a C(x y)) => Eq (Sealed2 a) where - (Sealed2 x) == (Sealed2 y) = x == y -#endif - -instance Show2 Patch where - show2 = show - -#ifndef GADT_WITNESSES -triple_examples :: (FromPrim p, Commute p, Invert p) => [p :> p :> p] -triple_examples = [commuteTripleFromTree id $ +tripleExamples :: (FromPrim p, Commute p, Invert p) => [Sealed2 (p :> p :> p)] +tripleExamples = [commuteTripleFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "g"])) (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j"])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "s"])) NilTree))) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "e"])) NilTree)) - ,commuteTripleFromTree id $ + ,commuteTripleFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [BC.pack "j"] }) (ParTree @@ -68,12 +57,12 @@ ] -merge_examples :: (FromPrim p, Commute p, Invert p) => [p :\/: p] -merge_examples = map (mergePairFromCommutePair id) commute_examples +mergeExamples :: (FromPrim p, Commute p, Invert p) => [Sealed2 (p :\/: p)] +mergeExamples = map (unseal2 (mergePairFromCommutePair seal2)) commuteExamples -commute_examples :: (FromPrim p, Commute p) => [p :> p] -commute_examples = [ - commutePairFromTWFP id $ +commuteExamples :: (FromPrim p, Commute p) => [Sealed2 (p :> p)] +commuteExamples = [ + commutePairFromTWFP seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (TWFP 3 (ParTree @@ -82,7 +71,7 @@ (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) NilTree)))))), - commutePairFromTWFP id $ + commutePairFromTWFP seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [BC.pack "f",BC.pack "s",BC.pack "d"] }) @@ -94,7 +83,7 @@ (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "s",BC.pack "d"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)))))), -{- commutePairFromTWFP id $ +{- commutePairFromTWFP seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [BC.pack "f",BC.pack "u", @@ -109,7 +98,7 @@ (SeqTree (FP(fp2fn "./file") (Hunk 0 [BC.pack "u",BC.pack "s",BC.pack "d"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "a"])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "a"] [])) NilTree))))))),-} - commutePairFromTree id $ + commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [BC.pack "n",BC.pack "t",BC.pack "h"] }) (ParTree @@ -118,13 +107,13 @@ (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "h"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "n"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t"] [])) NilTree)))), - commutePairFromTree id $ + commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "n"])) NilTree) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "i"])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "i"])) NilTree))), - commutePairFromTree id $ + commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "c"])) @@ -133,7 +122,7 @@ (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "d"])) NilTree)))) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree)), - commutePairFromTWFP id $ + commutePairFromTWFP seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (TWFP 1 (ParTree @@ -141,7 +130,7 @@ (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "t"])) NilTree) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "t"])) NilTree)) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree))), - commutePairFromTWFP id $ + commutePairFromTWFP seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [BC.pack "f",BC.pack " r", BC.pack "c",BC.pack "v"] }) @@ -154,7 +143,7 @@ (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f",BC.pack "r"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "y"])) NilTree)))) (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "v"] [])) NilTree))), - commutePairFromTree id $ + commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "z"])) NilTree) @@ -163,7 +152,7 @@ (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "r"])) NilTree) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "d"])) NilTree)))) - , commutePairFromTree id $ + , commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [BC.pack "t",BC.pack "r", BC.pack "h"] }) @@ -174,7 +163,7 @@ (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "o"])) NilTree)) (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "h"] [])) NilTree))) - , commutePairFromTWFP id $ + , commutePairFromTWFP seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) $ TWFP 2 (ParTree @@ -182,26 +171,26 @@ (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "y"])) (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "m"])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)))) - , commutePairFromTree id $ + , commutePairFromTree seal2 $ WithStartState (RepoModel {rmFileName = fp2fn "./file",rmFileContents = [] }) (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "p"])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "p"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "c"])) NilTree))) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "z"])) NilTree)) - , commutePairFromTree id $ + , commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j" ])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree)) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)) - , commutePairFromTree id $ + , commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j" ])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree))) - , commutePairFromTree id $ + , commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [BC.pack "x",BC.pack "c"] }) (ParTree @@ -211,7 +200,7 @@ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "x"] [])) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j"])) NilTree)))) (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "l"])) NilTree)) - , commutePairFromTree id $ + , commutePairFromTree seal2 $ WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) (ParTree (SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "s"))) NilTree) @@ -220,7 +209,6 @@ (SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "m"))) (SeqTree (FP (fp2fn "./file") (Hunk 0 (packStringLetters "m") [])) NilTree))))) ] -#endif -- | Turns a condition and a test function into a conditional quickcheck -- property that can be run by test-framework. @@ -240,23 +228,21 @@ } deriving (Eq) instance Show (RepoModel C(x)) where - showsPrec d rm = showParen (d > app_prec) $ + showsPrec d rm = showParen (d > appPrec) $ showString "RepoModel { rmFileName = " . showsPrec 0 (rmFileName rm) . - showString ", rmFileContents = " . showsPrec 0 (rmFileContents rm) . + showString ", rmFileContents = " . showsPrec' 0 (rmFileContents rm) . showString " }" + where showsPrec' n lines | all ((==1) . B.length) lines = showsPrecC n lines + | otherwise = showsPrec n lines + showsPrecC _ [] = showString "[]" + showsPrecC n ss = showParen (n > 0) $ showString "packStringLetters " . showsPrec (appPrec + 1) (map BC.head ss) instance Show1 RepoModel where - showsPrec1 = showsPrec - -#ifdef GADT_WITNESSES --- | The initial repository state, to be used as an argument to the @RepoModel@ --- data type. -data InitRepoModel -- this ought to be defined somewhere central as the unique starting state -#endif + showDict1 = ShowDictClass -- | The initial repository model. The repository contains a single file named -- @./file@, which is empty. -initRepoModel :: RepoModel C(InitRepoModel) +initRepoModel :: RepoModel C(Origin) initRepoModel = RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] } rebuildRepoModel :: RepoModel C(x) -> RepoModel C(y) rebuildRepoModel rm = RepoModel { rmFileName = rmFileName rm, rmFileContents = rmFileContents rm } @@ -285,41 +271,41 @@ arbitrary = do Sealed2 ps1 <- liftM (unseal (seal2 . wesPatch)) $ arbitraryState initRepoModel return $ Sealed2 $ mapFL_FL make_identity_identity ps1 where make_identity_identity :: Prim C(x y) -> Prim C(x y) - make_identity_identity p | IsEq <- is_identity p = identity + make_identity_identity p | IsEq <- isIdentity p = identity | otherwise = p instance Arbitrary (Sealed2 (FL (WithState RepoModel Prim))) where arbitrary = liftM (unseal (seal2 . wesPatch)) $ arbitraryState initRepoModel -prop_consistent_tree_flattenings :: Sealed (WithStartState RepoModel (Tree Prim)) -> Bool -prop_consistent_tree_flattenings (Sealed (WithStartState start t)) +propConsistentTreeFlattenings :: Sealed (WithStartState RepoModel (Tree Prim)) -> Bool +propConsistentTreeFlattenings (Sealed (WithStartState start t)) = fromJust $ do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2real t rms <- return $ map (applyPatch start) flat - return $ and $ zipWith assert_equal_fst (zip rms flat) (tail $ zip rms flat) + return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat) -assert_equal_fst :: (Eq a, Show a, Show b, Show c) => (a, b) -> (a, c) -> Bool -assert_equal_fst (x,bx) (y,by) +assertEqualFst :: (Eq a, Show a, Show b, Show c) => (a, b) -> (a, c) -> Bool +assertEqualFst (x,bx) (y,by) | x == y = True | otherwise = error ("Not really equal:\n" ++ show x ++ "\nand\n" ++ show y ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by) --- WithState and prop_fail are handy for debugging arbitrary code +-- WithState and propFail are handy for debugging arbitrary code data WithState s p C(x y) = WithState (s C(x)) (p C(x y)) (s C(y)) deriving Show data WithStartState s p C(x) = WithStartState (s C(x)) (p C(x)) instance (Show1 s, Show1 p) => Show (WithStartState s p C(x)) where - showsPrec d (WithStartState s p) = showParen (d > app_prec) $ showString "WithStartState " . - showsPrec1 (app_prec + 1) s . showString " " . - showsPrec1 (app_prec + 1) p + showsPrec d (WithStartState s p) = showParen (d > appPrec) $ showString "WithStartState " . + showsPrec1 (appPrec + 1) s . showString " " . + showsPrec1 (appPrec + 1) p instance (Show1 s, Show1 p) => Show1 (WithStartState s p) where - showsPrec1 = showsPrec + showDict1 = ShowDictClass -prop_fail :: Int -> Tree Prim C(x) -> Bool -prop_fail n xs = sizeTree xs < n +propFail :: Int -> Tree Prim C(x) -> Bool +propFail n xs = sizeTree xs < n instance ArbitraryState s p => ArbitraryState s (WithState s p) where arbitraryState rm = do xandrm' <- arbitraryState rm @@ -348,15 +334,15 @@ instance Show2 p => Show (Tree p C(x)) where showsPrec _ NilTree = showString "NilTree" - showsPrec d (SeqTree a t) = showParen (d > app_prec) $ showString "SeqTree " . - showsPrec2 (app_prec + 1) a . showString " " . - showsPrec (app_prec + 1) t - showsPrec d (ParTree t1 t2) = showParen (d > app_prec) $ showString "ParTree " . - showsPrec (app_prec + 1) t1 . showString " " . - showsPrec (app_prec + 1) t2 + showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " . + showsPrec2 (appPrec + 1) a . showString " " . + showsPrec (appPrec + 1) t + showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " . + showsPrec (appPrec + 1) t1 . showString " " . + showsPrec (appPrec + 1) t2 instance Show2 p => Show1 (Tree p) where - showsPrec1 = showsPrec + showDict1 = ShowDictClass sizeTree :: Tree p C(x) -> Int sizeTree NilTree = 0 @@ -511,10 +497,10 @@ return $ Sealed $ WithStartState rm (canonizeTree tree) shrink = shrinkWSSTree -prop_is_mergeable :: forall p C(x) . (FromPrim p, Commute p) +propIsMergeable :: forall p C(x) . (FromPrim p, Commute p) => Sealed (WithStartState RepoModel (Tree Prim)) -> Maybe (Tree p C(x)) -prop_is_mergeable (Sealed (WithStartState _ t)) +propIsMergeable (Sealed (WithStartState _ t)) = case flattenOne t of Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p) in case lengthFL ps of @@ -630,12 +616,12 @@ instance Show2 p => Show (TreeWithFlattenPos p C(x)) where - showsPrec d (TWFP n t) = showParen (d > app_prec) $ showString "TWFP " . - showsPrec (app_prec + 1) n . showString " " . - showsPrec1 (app_prec + 1) t + showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " . + showsPrec (appPrec + 1) n . showString " " . + showsPrec1 (appPrec + 1) t instance Show1 (TreeWithFlattenPos Prim) where - show1 = show + showDict1 = ShowDictClass instance Arbitrary (Sealed (WithStartState RepoModel (TreeWithFlattenPos Prim))) where arbitrary = do Sealed (WithStartState rm t) <- arbitrary @@ -718,8 +704,8 @@ packStringLetters :: String -> [B.ByteString] packStringLetters = map (BC.pack . (:[])) -real_patch_loop_examples :: [Sealed (WithStartState RepoModel (Tree Prim))] -real_patch_loop_examples = +realPatchLoopExamples :: [Sealed (WithStartState RepoModel (Tree Prim))] +realPatchLoopExamples = [Sealed (WithStartState (RepoModel { rmFileName = fx, rmFileContents = [] }) $ canonizeTree (ParTree diff -ruN darcs-2.4.4/src/Darcs/Test/Patch/Test.hs darcs-2.5/src/Darcs/Test/Patch/Test.hs --- darcs-2.4.4/src/Darcs/Test/Patch/Test.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Test/Patch/Test.hs 2010-10-24 08:29:26.000000000 -0700 @@ -21,22 +21,22 @@ #include "gadts.h" module Darcs.Test.Patch.Test - ( prop_read_show, - prop_inverse_composition, prop_commute_twice, - prop_inverse_valid, prop_other_inverse_valid, - prop_commute_equivalency, prop_commute_either_order, - prop_commute_either_way, prop_merge_is_commutable_and_correct, - prop_merge_is_swapable, prop_merge_valid, - prop_unravel_three_merge, prop_unravel_seq_merge, - prop_unravel_order_independent, - prop_simple_smart_merge_good_enough, - prop_elegant_merge_good_enough, - prop_patch_and_inverse_is_identity, - quickmerge, check_patch, check_a_patch, verbose_check_a_patch, - prop_resolve_conflicts_valid, - test_patch, prop_commute_inverse, - subcommutes_inverse, subcommutes_nontrivial_inverse, - subcommutes_failure, + ( propReadShow, + propInverseComposition, propCommuteTwice, + propInverseValid, propOtherInverseValid, + propCommuteEquivalency, propCommuteEitherOrder, + propCommuteEitherWay, propMergeIsCommutableAndCorrect, + propMergeIsSwapable, propMergeValid, + propUnravelThreeMerge, propUnravelSeqMerge, + propUnravelOrderIndependent, + propSimpleSmartMergeGoodEnough, + propElegantMergeGoodEnough, + propPatchAndInverseIsIdentity, + quickmerge, checkPatch, checkAPatch, verboseCheckAPatch, + propResolveConflictsValid, + testPatch, propCommuteInverse, + subcommutesInverse, subcommutesNontrivialInverse, + subcommutesFailure, join_patches ) where @@ -47,10 +47,10 @@ import Darcs.Patch.Info ( PatchInfo, patchinfo ) import Darcs.Test.Patch.Check ( PatchCheck, - check_move, remove_dir, create_dir, - is_valid, insert_line, file_empty, file_exists, - delete_line, modify_file, create_file, remove_file, - do_check, do_verbose_check, FileContents(..) + checkMove, removeDir, createDir, + isValid, insertLine, fileEmpty, fileExists, + deleteLine, modifyFile, createFile, removeFile, + doCheck, doVerboseCheck, FileContents(..) ) import Darcs.Patch.RegChars ( regChars ) import ByteStringUtils ( linesPS ) @@ -65,8 +65,9 @@ changepref, isMerger, invert, commute, merge, readPatch, resolveConflicts, effect, fromPrims, - unravel, merger, elegantMerge ) + elegantMerge ) import Darcs.Patch.Core ( Patch(..) ) +import Darcs.Patch.Commute ( unravel, merger ) import Darcs.Patch.Prim ( Prim(..), DirPatchType(..), FilePatchType(..), CommuteFunction, Perhaps(..), subcommutes ) @@ -117,7 +118,7 @@ twofilegen p = do n1 <- filepathgen n2 <- filepathgen - if n1 /= n2 && (check_a_patch $ fromPrims $ (p n1 n2 :>: NilFL)) + if n1 /= n2 && (checkAPatch $ fromPrims $ (p n1 n2 :>: NilFL)) then return $ p n1 n2 else twofilegen p @@ -151,40 +152,44 @@ arbpatch n = frequency [(3,PP `fmap` onepatchgen), -- (1,compgen n), (2,flatcompgen n), - (0,raw_merge_gen n), + (0,rawMergeGen n), (0,mergegen n), (1,PP `fmap` onepatchgen) ] +-- | Generate an arbitrary list of at least one element unempty :: Arbitrary a => Gen [a] unempty = do + a <- arbitrary as <- arbitrary - case as of - [] -> unempty - _ -> return as + return (a:as) join_patches :: [Patch] -> Patch join_patches = joinPatches . unsafeFL + where + unsafeFL :: [a] -> FL a + unsafeFL [] = NilFL + unsafeFL (a:as) = a :>: unsafeFL as -raw_merge_gen :: Int -> Gen Patch -raw_merge_gen n = do p1 <- arbpatch len +rawMergeGen :: Int -> Gen Patch +rawMergeGen n = do p1 <- arbpatch len p2 <- arbpatch len - if (check_a_patch $ join_patches [invert p1,p2]) && - (check_a_patch $ join_patches [invert p2,p1]) + if (checkAPatch $ join_patches [invert p1,p2]) && + (checkAPatch $ join_patches [invert p2,p1]) then case merge (p2 :\/: p1) of _ :/\: p2' -> return p2' - else raw_merge_gen n + else rawMergeGen n where len = if n < 15 then n`div`3 else 3 mergegen :: Int -> Gen Patch mergegen n = do p1 <- norecursgen len p2 <- norecursgen len - if (check_a_patch $ join_patches [invert p1,p2]) && - (check_a_patch $ join_patches [invert p2,p1]) + if (checkAPatch $ join_patches [invert p1,p2]) && + (checkAPatch $ join_patches [invert p2,p1]) then case merge (p2:\/:p1) of p1' :/\: p2' -> - if check_a_patch $ join_patches [p1,p2'] + if checkAPatch $ join_patches [p1,p2'] then return $ join_patches [p1,p2'] else return $ join_patches [PP $ addfile "Error_in_mergegen", PP $ addfile "Error_in_mergegen", @@ -221,7 +226,7 @@ size <- choose (0,n) myp <- liftM join_patches $ plistgen size ((n+1) `div` (size+1)) -- here I assume we only want to consider valid patches... - if check_a_patch myp + if checkAPatch myp then return myp else compgen n -} @@ -231,8 +236,8 @@ flatcompgen :: Int -> Gen Patch flatcompgen n = do - myp <- liftM (join_patches . regularize_patches) $ flatlistgen n - if check_a_patch myp + myp <- liftM (join_patches . regularizePatches) $ flatlistgen n + if checkAPatch myp then return myp else flatcompgen n @@ -286,88 +291,88 @@ -} -- coarbitrary c = coarbitrary (ord c) -check_patch :: Patch -> PatchCheck Bool -check_a_patch :: Patch -> Bool -check_a_patch p = do_check $ do check_patch p - check_patch $ invert p -verbose_check_a_patch :: Patch -> Bool -verbose_check_a_patch p = do_verbose_check $ do check_patch p - check_patch $ invert p - -check_patch p | isMerger p = do - check_patch $ fromPrims $ effect p -check_patch (Merger _ _ _ _) = impossible -check_patch (Regrem _ _ _ _) = impossible -check_patch (ComP NilFL) = is_valid -check_patch (ComP (p:>:ps)) = - check_patch p >> check_patch (ComP ps) -check_patch (PP Identity) = is_valid -check_patch (PP (Split NilFL)) = is_valid -check_patch (PP (Split (p:>:ps))) = - check_patch (PP p) >> check_patch (PP (Split ps)) - -check_patch (PP (FP f RmFile)) = remove_file $ fn2fp f -check_patch (PP (FP f AddFile)) = create_file $ fn2fp f -check_patch (PP (FP f (Hunk line old new))) = do - file_exists $ fn2fp f - mapM_ (delete_line (fn2fp f) line) old - mapM_ (insert_line (fn2fp f) line) (reverse new) - is_valid -check_patch (PP (FP f (TokReplace t old new))) = - modify_file (fn2fp f) (try_tok_possibly t old new) +checkPatch :: Patch -> PatchCheck Bool +checkAPatch :: Patch -> Bool +checkAPatch p = doCheck $ do checkPatch p + checkPatch $ invert p +verboseCheckAPatch :: Patch -> Bool +verboseCheckAPatch p = doVerboseCheck $ do checkPatch p + checkPatch $ invert p + +checkPatch p | isMerger p = do + checkPatch $ fromPrims $ effect p +checkPatch (Merger _ _ _ _) = impossible +checkPatch (Regrem _ _ _ _) = impossible +checkPatch (ComP NilFL) = isValid +checkPatch (ComP (p:>:ps)) = + checkPatch p >> checkPatch (ComP ps) +checkPatch (PP Identity) = isValid +checkPatch (PP (Split NilFL)) = isValid +checkPatch (PP (Split (p:>:ps))) = + checkPatch (PP p) >> checkPatch (PP (Split ps)) + +checkPatch (PP (FP f RmFile)) = removeFile $ fn2fp f +checkPatch (PP (FP f AddFile)) = createFile $ fn2fp f +checkPatch (PP (FP f (Hunk line old new))) = do + fileExists $ fn2fp f + mapM_ (deleteLine (fn2fp f) line) old + mapM_ (insertLine (fn2fp f) line) (reverse new) + isValid +checkPatch (PP (FP f (TokReplace t old new))) = + modifyFile (fn2fp f) (tryTokPossibly t old new) -- note that the above isn't really a sure check, as it leaves PSomethings -- and PNothings which may have contained new... -check_patch (PP (FP f (Binary o n))) = do - file_exists $ fn2fp f - mapM_ (delete_line (fn2fp f) 1) (linesPS o) - file_empty $ fn2fp f - mapM_ (insert_line (fn2fp f) 1) (reverse $ linesPS n) - is_valid +checkPatch (PP (FP f (Binary o n))) = do + fileExists $ fn2fp f + mapM_ (deleteLine (fn2fp f) 1) (linesPS o) + fileEmpty $ fn2fp f + mapM_ (insertLine (fn2fp f) 1) (reverse $ linesPS n) + isValid -check_patch (PP (DP d AddDir)) = create_dir $ fn2fp d -check_patch (PP (DP d RmDir)) = remove_dir $ fn2fp d +checkPatch (PP (DP d AddDir)) = createDir $ fn2fp d +checkPatch (PP (DP d RmDir)) = removeDir $ fn2fp d -check_patch (PP (Move f f')) = check_move (fn2fp f) (fn2fp f') -check_patch (PP (ChangePref _ _ _)) = return True +checkPatch (PP (Move f f')) = checkMove (fn2fp f) (fn2fp f') +checkPatch (PP (ChangePref _ _ _)) = return True -regularize_patches :: [Patch] -> [Patch] -regularize_patches patches = rpint [] patches +regularizePatches :: [Patch] -> [Patch] +regularizePatches patches = rpint [] patches where rpint ok_ps [] = ok_ps rpint ok_ps (p:ps) = - if check_a_patch (join_patches $ p:ok_ps) + if checkAPatch (join_patches $ p:ok_ps) then rpint (p:ok_ps) ps else rpint ok_ps ps -prop_inverse_composition :: Patch -> Patch -> Bool -prop_inverse_composition p1 p2 = +propInverseComposition :: Patch -> Patch -> Bool +propInverseComposition p1 p2 = invert (join_patches [p1,p2]) == join_patches [invert p2, invert p1] -prop_inverse_valid :: Patch -> Bool -prop_inverse_valid p1 = check_a_patch $ join_patches [invert p1,p1] -prop_other_inverse_valid :: Patch -> Bool -prop_other_inverse_valid p1 = check_a_patch $ join_patches [p1,invert p1] - -prop_commute_twice :: Patch -> Patch -> Property -prop_commute_twice p1 p2 = - (does_commute p1 p2) ==> (Just (p1:>p2) == (commute (p1:>p2) >>= commute)) -does_commute :: Patch -> Patch -> Bool -does_commute p1 p2 = - commute (p1:>p2) /= Nothing && (check_a_patch $ join_patches [p1,p2]) -prop_commute_equivalency :: Patch -> Patch -> Property -prop_commute_equivalency p1 p2 = - (does_commute p1 p2) ==> +propInverseValid :: Patch -> Bool +propInverseValid p1 = checkAPatch $ join_patches [invert p1,p1] +propOtherInverseValid :: Patch -> Bool +propOtherInverseValid p1 = checkAPatch $ join_patches [p1,invert p1] + +propCommuteTwice :: Patch -> Patch -> Property +propCommuteTwice p1 p2 = + (doesCommute p1 p2) ==> (Just (p1:>p2) == (commute (p1:>p2) >>= commute)) +doesCommute :: Patch -> Patch -> Bool +doesCommute p1 p2 = + commute (p1:>p2) /= Nothing && (checkAPatch $ join_patches [p1,p2]) +propCommuteEquivalency :: Patch -> Patch -> Property +propCommuteEquivalency p1 p2 = + (doesCommute p1 p2) ==> case commute (p1:>p2) of - Just (p2':>p1') -> check_a_patch $ join_patches [p1,p2,invert p1',invert p2'] + Just (p2':>p1') -> checkAPatch $ join_patches [p1,p2,invert p1',invert p2'] _ -> impossible -prop_commute_either_way :: Patch -> Patch -> Property -prop_commute_either_way p1 p2 = - does_commute p1 p2 ==> does_commute (invert p2) (invert p1) - -prop_commute_either_order :: Patch -> Patch -> Patch -> Property -prop_commute_either_order p1 p2 p3 = - check_a_patch (join_patches [p1,p2,p3]) && - does_commute p1 (join_patches [p2,p3]) && - does_commute p2 p3 ==> +propCommuteEitherWay :: Patch -> Patch -> Property +propCommuteEitherWay p1 p2 = + doesCommute p1 p2 ==> doesCommute (invert p2) (invert p1) + +propCommuteEitherOrder :: Patch -> Patch -> Patch -> Property +propCommuteEitherOrder p1 p2 p3 = + checkAPatch (join_patches [p1,p2,p3]) && + doesCommute p1 (join_patches [p2,p3]) && + doesCommute p2 p3 ==> case commute (p1:>p2) of Nothing -> False Just (p2':>p1') -> @@ -384,9 +389,9 @@ Just (p3''a:>_) -> p3''a == p3'' Nothing -> False -prop_patch_and_inverse_is_identity :: Patch -> Patch -> Property -prop_patch_and_inverse_is_identity p1 p2 = - (check_a_patch $ join_patches [p1,p2]) && (commute (p1:>p2) /= Nothing) ==> +propPatchAndInverseIsIdentity :: Patch -> Patch -> Property +propPatchAndInverseIsIdentity p1 p2 = + (checkAPatch $ join_patches [p1,p2]) && (commute (p1:>p2) /= Nothing) ==> case commute (p1:>p2) of Just (p2':>_) -> case commute (invert p1:>p2') of Nothing -> True -- This is a subtle distinction. @@ -397,40 +402,40 @@ quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of _ :/\: p1' -> p1' -prop_merge_is_commutable_and_correct :: Patch -> Patch -> Property -prop_merge_is_commutable_and_correct p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> +propMergeIsCommutableAndCorrect :: Patch -> Patch -> Property +propMergeIsCommutableAndCorrect p1 p2 = + (checkAPatch $ join_patches [invert p1,p2]) ==> case merge (p2:\/:p1) of p1' :/\: p2' -> case commute (p1:>p2') of Nothing -> False Just (p2'':>p1'') -> p2'' == p2 && p1' == p1'' -prop_merge_is_swapable :: Patch -> Patch -> Property -prop_merge_is_swapable p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> +propMergeIsSwapable :: Patch -> Patch -> Property +propMergeIsSwapable p1 p2 = + (checkAPatch $ join_patches [invert p1,p2]) ==> case merge (p2:\/:p1) of p1' :/\: p2' -> case merge (p1:\/:p2) of p2''' :/\: p1''' -> p1' == p1''' && p2' == p2''' -prop_merge_valid :: Patch -> Patch -> Property -prop_merge_valid p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> +propMergeValid :: Patch -> Patch -> Property +propMergeValid p1 p2 = + (checkAPatch $ join_patches [invert p1,p2]) ==> case merge (p2:\/:p1) of _ :/\: p2' -> - check_a_patch $ join_patches [invert p1,p2,invert p2,p1,p2'] + checkAPatch $ join_patches [invert p1,p2,invert p2,p1,p2'] -prop_simple_smart_merge_good_enough :: Patch -> Patch -> Property -prop_simple_smart_merge_good_enough p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - smart_merge (p2:\/:p1) == simple_smart_merge (p2:\/:p1) - -smart_merge :: (Patch :\/: Patch) -> Maybe (Patch :< Patch) -smart_merge (p1 :\/: p2) = - case simple_smart_merge (p1:\/:p2) of +propSimpleSmartMergeGoodEnough :: Patch -> Patch -> Property +propSimpleSmartMergeGoodEnough p1 p2 = + (checkAPatch $ join_patches [invert p1,p2]) ==> + smartMerge (p2:\/:p1) == simpleSmartMerge (p2:\/:p1) + +smartMerge :: (Patch :\/: Patch) -> Maybe (Patch :< Patch) +smartMerge (p1 :\/: p2) = + case simpleSmartMerge (p1:\/:p2) of Nothing -> Nothing Just (p1'a: - case simple_smart_merge (p2 :\/: p1) of + case simpleSmartMerge (p2 :\/: p1) of Nothing -> Nothing Just (x: case commute (y:>x) of @@ -439,8 +444,8 @@ if p1'a == p1'b && p2a == p2b && p2a == p2 then Just (p1'a :< p2) else Nothing -simple_smart_merge :: (Patch :\/: Patch) -> Maybe (Patch :< Patch) -simple_smart_merge (p1 :\/: p2) = +simpleSmartMerge :: (Patch :\/: Patch) -> Maybe (Patch :< Patch) +simpleSmartMerge (p1 :\/: p2) = case commute (invert p2 :> p1) of Just (p1':>_) -> case commute (p2:>p1') of @@ -450,10 +455,10 @@ Nothing -> Nothing Nothing -> Nothing -prop_elegant_merge_good_enough :: Patch -> Patch -> Property -prop_elegant_merge_good_enough p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - (fst' `fmap` smart_merge (p2:\/:p1)) == +propElegantMergeGoodEnough :: Patch -> Patch -> Property +propElegantMergeGoodEnough p1 p2 = + (checkAPatch $ join_patches [invert p1,p2]) ==> + (fst' `fmap` smartMerge (p2:\/:p1)) == (snd'' `fmap` elegantMerge (p2:\/:p1)) fst' :: p :< p -> p @@ -474,42 +479,42 @@ instance Show p => Show (p :> p) where show (x :> y) = show x ++ " :> " ++ show y -test_patch :: String -test_patch = test_str ++ test_note +testPatch :: String +testPatch = testStr ++ testNote tp1, tp2 :: Patch tp1 = unsafeUnseal . fst . fromJust . readPatch $ BC.pack "\nmove ./test/test ./hello\n" tp2 = unsafeUnseal . fst . fromJust . readPatch $ BC.pack "\nmove ./test ./hello\n" tp1', tp2' :: Patch tp2' = quickmerge (tp2:\/:tp1) tp1' = quickmerge (tp1:\/:tp2) -test_note :: String -test_note = (if commute (tp1:>tp2') == Just (tp2:>tp1') +testNote :: String +testNote = (if commute (tp1:>tp2') == Just (tp2:>tp1') then "At least they commutex right.\n" else "Argh! they don't even commutex right.\n") - ++(if check_a_patch $ tp2 + ++(if checkAPatch $ tp2 then "tp2 itself is valid!\n" else "Oh my! tp2 isn't even valid!\n") - ++(if check_a_patch $ tp2' + ++(if checkAPatch $ tp2' then "tp2' itself is valid!\n" else "Aaack! tp2' itself is invalid!\n") - ++(if check_a_patch $ join_patches [tp1, tp2'] + ++(if checkAPatch $ join_patches [tp1, tp2'] then "Valid merge tp2'!\n" else "Bad merge tp2'!\n") - ++ (if check_a_patch $ join_patches [tp2, tp1'] + ++ (if checkAPatch $ join_patches [tp2, tp1'] then "Valid merge tp1'!\n" else "Bad merge tp1'!\n") - ++ (if check_a_patch $ join_patches [tp2,tp1',invert tp2',invert tp1] + ++ (if checkAPatch $ join_patches [tp2,tp1',invert tp2',invert tp1] then "Both agree!\n" else "The two merges don't agree!\n") - ++ (if check_a_patch $ join_patches [invert tp2, tp1] + ++ (if checkAPatch $ join_patches [invert tp2, tp1] then "They should be mergable!\n" else "Wait a minute, these guys can't be merged!\n") tp :: Patch tp = tp1' -test_str :: String -test_str = "Patches are:\n"++(show tp) - ++(if check_a_patch tp +testStr :: String +testStr = "Patches are:\n"++(show tp) + ++(if checkAPatch tp then "At least the patch itself is valid.\n" else "The patch itself is bad!\n") ++"commute of tp2 and tp1' is "++show (commute (tp2:>tp1'))++"\n" @@ -518,13 +523,13 @@ ++ (show $ mapFL (joinPatches.flattenFL.merger_equivalent) $ flattenFL tp) ++ "\n\nUnravelled, it gives:\n" ++ (show $ map unravel $ flatten tp) ++ "\n\nUnwound, it gives:\n" ++ (show $ mapFL unwind $ flattenFL tp) - ++(if check_a_patch (join_patches$ reverse $ unwind tp) + ++(if checkAPatch (join_patches$ reverse $ unwind tp) then "Unwinding is valid.\n" else "Bad unwinding!\n") - ++(if check_a_patch $ join_patches [tp,invert tp] + ++(if checkAPatch $ join_patches [tp,invert tp] then "Inverse is valid.\n" else "Bad inverse!\n") - ++(if check_a_patch $ join_patches [invert tp, tp] + ++(if checkAPatch $ join_patches [invert tp, tp] then "Other inverse is valid.\n" else "Bad other inverse!\n")-} @@ -538,56 +543,56 @@ -- unravel the merger, almost any function of the unravelled merger satisfies -- the two constraints mentioned above that the conflict resolution code must -- satisfy. -prop_unravel_three_merge :: Patch -> Patch -> Patch -> Property -prop_unravel_three_merge p1 p2 p3 = - (check_a_patch $ join_patches [invert p1,p2,invert p2,p3]) ==> - (unravel $ merger "0.0" (merger "0.0" p2 p3) (merger "0.0" p2 p1)) == - (unravel $ merger "0.0" (merger "0.0" p1 p3) (merger "0.0" p1 p2)) - -prop_unravel_seq_merge :: Patch -> Patch -> Patch -> Property -prop_unravel_seq_merge p1 p2 p3 = - (check_a_patch $ join_patches [invert p1,p2,p3]) ==> - (unravel $ merger "0.0" p3 $ merger "0.0" p2 p1) == - (unravel $ merger "0.0" (merger "0.0" p2 p1) p3) - -prop_unravel_order_independent :: Patch -> Patch -> Property -prop_unravel_order_independent p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - (unravel $ merger "0.0" p2 p1) == (unravel $ merger "0.0" p1 p2) - -prop_resolve_conflicts_valid :: Patch -> Patch -> Property -prop_resolve_conflicts_valid p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - and $ map (check_a_patch.(\l-> join_patches [p,merge_list l])) +propUnravelThreeMerge :: Patch -> Patch -> Patch -> Property +propUnravelThreeMerge p1 p2 p3 = + (checkAPatch $ join_patches [invert p1,p2,invert p2,p3]) ==> + (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p2 p3)) (unsafeUnseal (merger "0.0" p2 p1))) == + (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p1 p3)) (unsafeUnseal (merger "0.0" p1 p2))) + +propUnravelSeqMerge :: Patch -> Patch -> Patch -> Property +propUnravelSeqMerge p1 p2 p3 = + (checkAPatch $ join_patches [invert p1,p2,p3]) ==> + (unravel $ unsafeUnseal $ merger "0.0" p3 $ unsafeUnseal $ merger "0.0" p2 p1) == + (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal $ merger "0.0" p2 p1) p3) + +propUnravelOrderIndependent :: Patch -> Patch -> Property +propUnravelOrderIndependent p1 p2 = + (checkAPatch $ join_patches [invert p1,p2]) ==> + (unravel $ unsafeUnseal $ merger "0.0" p2 p1) == (unravel $ unsafeUnseal $ merger "0.0" p1 p2) + +propResolveConflictsValid :: Patch -> Patch -> Property +propResolveConflictsValid p1 p2 = + (checkAPatch $ join_patches [invert p1,p2]) ==> + and $ map (checkAPatch.(\l-> join_patches [p,mergeList l])) $ resolveConflicts p where p = case merge (p1:\/:p2) of _ :/\: p1' -> join_patches [p2,p1'] -merge_list :: [Sealed (FL Prim C(x))] -> Patch -merge_list patches = fromPrims `unseal` doml NilFL patches +mergeList :: [Sealed (FL Prim C(x))] -> Patch +mergeList patches = fromPrims `unseal` doml NilFL patches where doml mp (Sealed p:ps) = case commute (invert p :> mp) of Just (mp' :> _) -> doml (effect p +>+ effect mp') ps Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions. doml mp [] = Sealed mp -try_tok_possibly :: String -> String -> String +tryTokPossibly :: String -> String -> String -> (Maybe FileContents) -> (Maybe FileContents) -try_tok_possibly t o n = liftM $ \contents -> +tryTokPossibly t o n = liftM $ \contents -> let lines' = M.mapMaybe (liftM B.concat - . try_tok_internal t (BC.pack o) (BC.pack n)) - (fc_lines contents) - in contents { fc_lines = lines' } + . tryTokInternal t (BC.pack o) (BC.pack n)) + (fcLines contents) + in contents { fcLines = lines' } -try_tok_internal :: String -> B.ByteString -> B.ByteString +tryTokInternal :: String -> B.ByteString -> B.ByteString -> B.ByteString -> Maybe [B.ByteString] -try_tok_internal _ _ _ s | B.null s = Just [] -try_tok_internal t o n s = +tryTokInternal _ _ _ s | B.null s = Just [] +tryTokInternal t o n s = case BC.break (regChars t) s of (before,s') -> case BC.break (not . regChars t) s' of (tok,after) -> - case try_tok_internal t o n after of + case tryTokInternal t o n after of Nothing -> Nothing Just rest -> if tok == o @@ -596,25 +601,25 @@ then Nothing else Just $ before : tok : rest -prop_read_show :: Patch -> Bool -prop_read_show p = case readPatch $ renderPS $ showPatch p of +propReadShow :: Patch -> Bool +propReadShow p = case readPatch $ renderPS $ showPatch p of Just (Sealed p',_) -> p' == p Nothing -> False -- |In order for merges to work right with commuted patches, inverting a patch -- past a patch and its inverse had golly well better give you the same patch -- back again. -prop_commute_inverse :: Patch -> Patch -> Property -prop_commute_inverse p1 p2 = - does_commute p1 p2 ==> case commute (p1 :> p2) of +propCommuteInverse :: Patch -> Patch -> Property +propCommuteInverse p1 p2 = + doesCommute p1 p2 ==> case commute (p1 :> p2) of Nothing -> impossible Just (_ :> p1') -> case commute (p1' :> invert p2) of Nothing -> False Just (_ :> p1'') -> p1'' == p1 -subcommutes_inverse :: [(String, Prim -> Prim -> Property)] -subcommutes_inverse = zip names (map prop_subcommute cs) +subcommutesInverse :: [(String, Prim -> Prim -> Property)] +subcommutesInverse = zip names (map prop_subcommute cs) where (names, cs) = unzip subcommutes prop_subcommute c p1 p2 = does c p1 p2 ==> @@ -634,8 +639,8 @@ _ -> False _ -> False -subcommutes_nontrivial_inverse :: [(String, Prim -> Prim -> Property)] -subcommutes_nontrivial_inverse = zip names (map prop_subcommute cs) +subcommutesNontrivialInverse :: [(String, Prim -> Prim -> Property)] +subcommutesNontrivialInverse = zip names (map prop_subcommute cs) where (names, cs) = unzip subcommutes prop_subcommute c p1 p2 = nontrivial c p1 p2 ==> @@ -655,28 +660,28 @@ _ -> False _ -> False -subcommutes_failure :: [(String, Prim -> Prim -> Property)] -subcommutes_failure = zip names (map prop cs) +subcommutesFailure :: [(String, Prim -> Prim -> Property)] +subcommutesFailure = zip names (map prop cs) where (names, cs) = unzip subcommutes prop c p1 p2 = - does_fail c p1 p2 ==> case c (invert p1 :< invert p2) of + doesFail c p1 p2 ==> case c (invert p1 :< invert p2) of Failed -> True _ -> False -does_fail :: CommuteFunction -> Prim -> Prim -> Bool -does_fail c p1 p2 = - fails (c (p2: Prim -> Prim -> Bool +doesFail c p1 p2 = + fails (c (p2:: p2 :>: NilFL)) where fails Failed = True fails _ = False does :: CommuteFunction -> Prim -> Prim -> Bool does c p1 p2 = - succeeds (c (p2:: p2 :>: NilFL)) where succeeds (Succeeded _) = True succeeds _ = False nontrivial :: CommuteFunction -> Prim -> Prim -> Bool nontrivial c p1 p2 = - succeeds (c (p2:: p2 :>: NilFL)) where succeeds (Succeeded (p1' :< p2')) = p1' /= p1 || p2' /= p2 succeeds _ = False diff -ruN darcs-2.4.4/src/Darcs/Test/Patch/Unit.hs darcs-2.5/src/Darcs/Test/Patch/Unit.hs --- darcs-2.4.4/src/Darcs/Test/Patch/Unit.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Test/Patch/Unit.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,21 +20,21 @@ #include "gadts.h" -module Darcs.Test.Patch.Unit ( patch_unit_tests ) where +module Darcs.Test.Patch.Unit ( patchUnitTests ) where import Data.Maybe ( catMaybes, isNothing ) import qualified Data.ByteString.Char8 as BC ( pack ) import Darcs.Witnesses.Sealed import Darcs.Patch import Darcs.Patch.Patchy ( mergeFL, Invert ) -import Darcs.Patch.Real ( RealPatch, prim2real, is_consistent, is_forward, is_duplicate ) +import Darcs.Patch.Real ( RealPatch, prim2real, isConsistent, isForward, isDuplicate ) import Darcs.Test.Patch.Test () -- for instance Eq Patch import Darcs.Witnesses.Ordered -import Darcs.Patch.Properties ( recommute, commute_inverses, permutivity, partial_permutivity, - inverse_doesnt_commute, patch_and_inverse_commute, - merge_commute, merge_consistent, merge_arguments_consistent, - merge_either_way, show_read, - join_inverses, join_commute ) +import Darcs.Patch.Properties ( recommute, commuteInverses, permutivity, partialPermutivity, + inverseDoesntCommute, patchAndInverseCommute, + mergeCommute, mergeConsistent, mergeArgumentsConsistent, + mergeEitherWay, show_read, + joinInverses, joinCommute ) import Darcs.Patch.Prim ( join ) import Darcs.Test.Patch.QuickCheck import Printer ( Doc, redText, ($$) ) @@ -51,56 +51,56 @@ -- #include "impossible.h" -- | The unit tests defined about patches -patch_unit_tests :: [Test] -patch_unit_tests = [--do putStr "Checking with quickcheck that real patches have consistent flattenings... " - -- quickCheck (not . isBottomTimeOut (Just 10) . prop_consistent_tree_flattenings) >> return 0 - run_primitive_tests "prim join inverses" (\ (a:\/:_) -> join_inverses join a) mergeables, - testProperty "Checking prim join inverses using QuickCheck... " (isNothing . join_inverses join), - run_primitive_tests "prim inverse doesn't commute" (\ (a:\/:_) -> inverse_doesnt_commute a) mergeables, +patchUnitTests :: [Test] +patchUnitTests = [--do putStr "Checking with quickcheck that real patches have consistent flattenings... " + -- quickCheck (not . isBottomTimeOut (Just 10) . propConsistentTreeFlattenings) >> return 0 + runPrimitiveTests "prim join inverses" (\ (a:\/:_) -> joinInverses join a) mergeables, + testProperty "Checking prim join inverses using QuickCheck... " (isNothing . joinInverses join), + runPrimitiveTests "prim inverse doesn't commute" (\ (a:\/:_) -> inverseDoesntCommute a) mergeables, -- The following fails because of setpref patches... --,do putStr "Checking prim inverse doesn't commute using QuickCheck... " - -- simpleCheck (inverse_doesnt_commute :: Prim -> Maybe Doc) - run_primitive_tests "join commute" (join_commute join) prim_permutables, - testProperty "Checking prim join commute using QuickCheck... " (unseal2 (isNothing . join_commute join)), - run_primitive_tests "prim recommute" (recommute commute) $ map mergeable2commutable mergeables, - run_primitive_tests "prim patch and inverse commute" (patch_and_inverse_commute commute) $ map mergeable2commutable mergeables, - run_primitive_tests "prim inverses commute" (commute_inverses commute) $ map mergeable2commutable mergeables, + -- simpleCheck (inverseDoesntCommute :: Prim -> Maybe Doc) + runPrimitiveTests "join commute" (joinCommute join) primPermutables, + testProperty "Checking prim join commute using QuickCheck... " (unseal2 (isNothing . joinCommute join)), + runPrimitiveTests "prim recommute" (recommute commute) $ map mergeable2commutable mergeables, + runPrimitiveTests "prim patch and inverse commute" (patchAndInverseCommute commute) $ map mergeable2commutable mergeables, + runPrimitiveTests "prim inverses commute" (commuteInverses commute) $ map mergeable2commutable mergeables, --,do putStr "Checking prim recommute using QuickCheck... " -- simpleCheck (recommute -- (commute :: Prim :> Prim -- -> Maybe (Prim :> Prim))) - run_primitive_tests "FL prim recommute" (recommute commute) $ map mergeable2commutable mergeablesFL, - run_primitive_tests "FL prim patch and inverse commute" (patch_and_inverse_commute commute) $ map mergeable2commutable mergeablesFL, - run_primitive_tests "FL prim inverses commute" (commute_inverses commute) $ map mergeable2commutable mergeablesFL, - run_primitive_tests "fails" (commute_fails commute) ([] :: [Prim :> Prim]), - run_primitive_tests "read and show work on Prim" show_read prim_patches, - run_primitive_tests "read and show work on RealPatch" show_read real_patches, + runPrimitiveTests "FL prim recommute" (recommute commute) $ map mergeable2commutable mergeablesFL, + runPrimitiveTests "FL prim patch and inverse commute" (patchAndInverseCommute commute) $ map mergeable2commutable mergeablesFL, + runPrimitiveTests "FL prim inverses commute" (commuteInverses commute) $ map mergeable2commutable mergeablesFL, + runPrimitiveTests "fails" (commuteFails commute) ([] :: [Prim :> Prim]), + runPrimitiveTests "read and show work on Prim" show_read primPatches, + runPrimitiveTests "read and show work on RealPatch" show_read realPatches, testProperty "Checking that readPatch and showPatch work on RealPatch... " (isNothing . (unseal $ patchFromTree $ (show_read :: RealPatch -> Maybe Doc))), testProperty "Checking that readPatch and showPatch work on FL RealPatch... " (isNothing . (unseal2 $ (show_read :: FL RealPatch -> Maybe Doc))), - run_primitive_tests "example flattenings work" - (\x -> if prop_consistent_tree_flattenings x + runPrimitiveTests "example flattenings work" + (\x -> if propConsistentTreeFlattenings x then Nothing else Just $ redText "oops") - real_patch_loop_examples, - testProperty "Checking that tree flattenings are consistent... " prop_consistent_tree_flattenings, + realPatchLoopExamples, + testProperty "Checking that tree flattenings are consistent... " propConsistentTreeFlattenings, testProperty "Checking with quickcheck that real patches are consistent... " - (isNothing . (unseal $ patchFromTree $ is_consistent)), - run_primitive_tests "real merge input consistent" (merge_arguments_consistent is_consistent) real_mergeables, - run_primitive_tests "real merge input is forward" (merge_arguments_consistent is_forward) real_mergeables, - run_primitive_tests "real merge output is forward" (merge_consistent is_forward) real_mergeables, - run_primitive_tests "real merge output consistent" (merge_consistent is_consistent) real_mergeables, - run_primitive_tests "real merge either way" merge_either_way real_mergeables, - run_primitive_tests "real merge and commute" merge_commute real_mergeables, - - run_primitive_tests "real recommute" (recommute commute) real_commutables, - run_primitive_tests "real inverses commute" (commute_inverses commute) real_commutables, - run_primitive_tests "real permutivity" (permutivity commute) $ filter (not_duplicatestriple) real_triples, - run_primitive_tests "real partial permutivity" (partial_permutivity commute) $ filter (not_duplicatestriple) real_triples, + (isNothing . (unseal $ patchFromTree $ isConsistent)), + runPrimitiveTests "real merge input consistent" (mergeArgumentsConsistent isConsistent) realMergeables, + runPrimitiveTests "real merge input is forward" (mergeArgumentsConsistent isForward) realMergeables, + runPrimitiveTests "real merge output is forward" (mergeConsistent isForward) realMergeables, + runPrimitiveTests "real merge output consistent" (mergeConsistent isConsistent) realMergeables, + runPrimitiveTests "real merge either way" mergeEitherWay realMergeables, + runPrimitiveTests "real merge and commute" mergeCommute realMergeables, + + runPrimitiveTests "real recommute" (recommute commute) realCommutables, + runPrimitiveTests "real inverses commute" (commuteInverses commute) realCommutables, + runPrimitiveTests "real permutivity" (permutivity commute) $ filter (notDuplicatestriple) realTriples, + runPrimitiveTests "real partial permutivity" (partialPermutivity commute) $ filter (notDuplicatestriple) realTriples, testProperty "Checking we can do merges using QuickCheck" - (isNothing . (prop_is_mergeable :: + (isNothing . (propIsMergeable :: Sealed (WithStartState RepoModel (Tree Prim)) -> Maybe (Tree RealPatch C(x)))), testProperty "Checking recommute using QuickCheck Tree generator" @@ -114,13 +114,13 @@ (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))))), testConditional "Checking nontrivial recommute" - (unseal $ commutePairFromTree $ nontrivial_reals) + (unseal $ commutePairFromTree $ nontrivialReals) (unseal $ commutePairFromTree $ (recommute (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))), testConditional "Checking nontrivial recommute using TWFP" - (unseal $ commutePairFromTWFP $ nontrivial_reals) + (unseal $ commutePairFromTWFP $ nontrivialReals) (unseal $ commutePairFromTWFP $ (recommute (commute :: RealPatch :> RealPatch @@ -128,67 +128,67 @@ testProperty "Checking inverses commute using QuickCheck Tree generator" (isNothing . (unseal $ commutePairFromTree $ - (commute_inverses + (commuteInverses (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))))), testProperty "Checking inverses commute using QuickCheck TWFP generator" (isNothing . (unseal $ commutePairFromTWFP $ - (commute_inverses + (commuteInverses (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))))), testConditional "Checking nontrivial inverses commute" - (unseal $ commutePairFromTree $ nontrivial_reals) + (unseal $ commutePairFromTree $ nontrivialReals) (unseal $ commutePairFromTree $ - (commute_inverses + (commuteInverses (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))), testConditional "Checking nontrivial inverses commute using TWFP" - (unseal $ commutePairFromTWFP $ nontrivial_reals) + (unseal $ commutePairFromTWFP $ nontrivialReals) (unseal $ commutePairFromTWFP $ - (commute_inverses + (commuteInverses (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))), testProperty "Checking merge either way using QuickCheck TWFP generator" (isNothing . (unseal $ mergePairFromTWFP $ - (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))), + (mergeEitherWay :: RealPatch :\/: RealPatch -> Maybe Doc))), testProperty "Checking merge either way using QuickCheck Tree generator" (isNothing . (unseal $ mergePairFromTree $ - (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))), + (mergeEitherWay :: RealPatch :\/: RealPatch -> Maybe Doc))), testConditional "Checking nontrivial merge either way" - (unseal $ mergePairFromTree $ nontrivial_merge_reals) + (unseal $ mergePairFromTree $ nontrivialMergeReals) (unseal $ mergePairFromTree $ - (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)), + (mergeEitherWay :: RealPatch :\/: RealPatch -> Maybe Doc)), testConditional "Checking nontrivial merge either way using TWFP" - (unseal $ mergePairFromTWFP $ nontrivial_merge_reals) + (unseal $ mergePairFromTWFP $ nontrivialMergeReals) (unseal $ mergePairFromTWFP $ - (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)), + (mergeEitherWay :: RealPatch :\/: RealPatch -> Maybe Doc)), testConditional "Checking permutivity" - (unseal $ commuteTripleFromTree not_duplicatestriple) + (unseal $ commuteTripleFromTree notDuplicatestriple) (unseal $ commuteTripleFromTree $ permutivity (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))), testConditional "Checking partial permutivity" - (unseal $ commuteTripleFromTree not_duplicatestriple) - (unseal $ commuteTripleFromTree $ partial_permutivity + (unseal $ commuteTripleFromTree notDuplicatestriple) + (unseal $ commuteTripleFromTree $ partialPermutivity (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))), testConditional "Checking nontrivial permutivity" (unseal $ commuteTripleFromTree - (\t -> nontrivial_triple t && not_duplicatestriple t)) + (\t -> nontrivialTriple t && notDuplicatestriple t)) (unseal $ commuteTripleFromTree $ (permutivity (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))) ] -not_duplicatestriple :: RealPatch :> RealPatch :> RealPatch -> Bool -not_duplicatestriple (a :> b :> c) = not $ any is_duplicate [a,b,c] +notDuplicatestriple :: RealPatch :> RealPatch :> RealPatch -> Bool +notDuplicatestriple (a :> b :> c) = not $ any isDuplicate [a,b,c] --not_duplicates_pair :: RealPatch :> RealPatch -> Bool ---not_duplicates_pair (a :> b) = not $ any is_duplicate [a,b] +--not_duplicates_pair (a :> b) = not $ any isDuplicate [a,b] -nontrivial_triple :: RealPatch :> RealPatch :> RealPatch -> Bool -nontrivial_triple (a :> b :> c) = +nontrivialTriple :: RealPatch :> RealPatch :> RealPatch -> Bool +nontrivialTriple (a :> b :> c) = case commute (a :> b) of Nothing -> False Just (b' :> a') -> @@ -201,30 +201,30 @@ (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) && (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a')) -nontrivial_reals :: RealPatch :> RealPatch -> Bool -nontrivial_reals = nontrivial_commute +nontrivialReals :: RealPatch :> RealPatch -> Bool +nontrivialReals = nontrivialCommute -nontrivial_commute :: Patchy p => p :> p -> Bool -nontrivial_commute (x :> y) = case commute (x :> y) of +nontrivialCommute :: Patchy p => p :> p -> Bool +nontrivialCommute (x :> y) = case commute (x :> y) of Just (y' :> x') -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x) Nothing -> False -nontrivial_merge_reals :: RealPatch :\/: RealPatch -> Bool -nontrivial_merge_reals = nontrivial_merge +nontrivialMergeReals :: RealPatch :\/: RealPatch -> Bool +nontrivialMergeReals = nontrivialMerge -nontrivial_merge :: Patchy p => p :\/: p -> Bool -nontrivial_merge (x :\/: y) = case merge (x :\/: y) of +nontrivialMerge :: Patchy p => p :\/: p -> Bool +nontrivialMerge (x :\/: y) = case merge (x :\/: y) of y' :/\: x' -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x) -- | Run a test function on a set of data, using HUnit. The test function should -- return @Nothing@ upon success and a @Just x@ upon failure. -run_primitive_tests :: (Show a, Show b) => String -- ^ The test name +runPrimitiveTests :: (Show a, Show b) => String -- ^ The test name -> (a -> Maybe b) -- ^ The test function -> [a] -- ^ The test data -> Test -run_primitive_tests name test datas = testCase name (assertBool assertName res) +runPrimitiveTests name test datas = testCase name (assertBool assertName res) where assertName = "Boolean assertion for \"" ++ name ++ "\"" res = and $ map (isNothing . test) datas @@ -232,8 +232,8 @@ quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o) (map (\c -> BC.pack [c]) n) -prim_permutables :: [Prim :> Prim :> Prim] -prim_permutables = +primPermutables :: [Prim :> Prim :> Prim] +primPermutables = [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"] mergeables :: [Prim :\/: Prim] @@ -255,17 +255,18 @@ mergeable2commutable :: Invert p => p :\/: p -> p :> p mergeable2commutable (x :\/: y) = invert x :> y -prim_patches :: [Prim] -prim_patches = concatMap mergeable2patches mergeables +primPatches :: [Prim] +primPatches = concatMap mergeable2patches mergeables where mergeable2patches (x:\/:y) = [x,y] -real_patches :: [RealPatch] -real_patches = concatMap commutable2patches real_commutables +realPatches :: [RealPatch] +realPatches = concatMap commutable2patches realCommutables where commutable2patches (x:>y) = [x,y] -real_triples :: [RealPatch :> RealPatch :> RealPatch] -real_triples = [ob' :> oa2 :> a2'', - oa' :> oa2 :> a2''] ++ triple_examples +realTriples :: [RealPatch :> RealPatch :> RealPatch] +realTriples = [ob' :> oa2 :> a2'', + oa' :> oa2 :> a2''] + ++ map unsafeUnseal2 tripleExamples ++ map unsafeUnseal2 (concatMap getTriples realFLs) where oa = prim2real $ quickhunk 1 "o" "aa" oa2 = oa @@ -280,18 +281,19 @@ where oa = prim2real $ quickhunk 1 "o" "a" ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL) -real_commutables :: [RealPatch :> RealPatch] -real_commutables = commute_examples ++ map mergeable2commutable real_mergeables++ +realCommutables :: [RealPatch :> RealPatch] +realCommutables = map unsafeUnseal2 commuteExamples++ + map mergeable2commutable realMergeables++ [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs) where oa = prim2real $ quickhunk 1 "o" "a" ob = prim2real $ quickhunk 1 "o" "b" _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL) -real_mergeables :: [RealPatch :\/: RealPatch] -real_mergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables - ++ real_igloo_mergeables - ++ real_quickcheck_mergeables - ++ merge_examples +realMergeables :: [RealPatch :\/: RealPatch] +realMergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables + ++ realIglooMergeables + ++ realQuickcheckMergeables + ++ map unsafeUnseal2 mergeExamples ++ catMaybes (map pair2m (concatMap getPairs realFLs)) ++ [(oa :\/: od), (oa :\/: a2'), @@ -335,8 +337,8 @@ pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y) return (xx :\/: y') -real_igloo_mergeables :: [RealPatch :\/: RealPatch] -real_igloo_mergeables = [(a :\/: b), +realIglooMergeables :: [RealPatch :\/: RealPatch] +realIglooMergeables = [(a :\/: b), (b :\/: c), (a :\/: c), (x :\/: a), @@ -356,8 +358,8 @@ y' :/\: _ = merge (b :\/: y) z' :/\: _ = merge (c :\/: z) -real_quickcheck_mergeables :: [RealPatch :\/: RealPatch] -real_quickcheck_mergeables = [-- invert k1 :\/: n1 +realQuickcheckMergeables :: [RealPatch :\/: RealPatch] +realQuickcheckMergeables = [-- invert k1 :\/: n1 --, invert k2 :\/: n2 hb :\/: k , b' :\/: b' @@ -388,9 +390,9 @@ d3 :/\: _ = merge (xi :\/: d) _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL) -commute_fails :: (MyEq p, Patchy p) => (p :> p -> Maybe (p :> p)) -> p :> p +commuteFails :: (MyEq p, Patchy p) => (p :> p -> Maybe (p :> p)) -> p :> p -> Maybe Doc -commute_fails c (x :> y) = do y' :> x' <- c (x :> y) +commuteFails c (x :> y) = do y' :> x' <- c (x :> y) return $ redText "x" $$ showPatch x $$ redText ":> y" $$ showPatch y $$ redText "y'" $$ showPatch y' $$ diff -ruN darcs-2.4.4/src/Darcs/Test/Unit.lhs darcs-2.5/src/Darcs/Test/Unit.lhs --- darcs-2.4.4/src/Darcs/Test/Unit.lhs 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/src/Darcs/Test/Unit.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,766 @@ +% Copyright (C) 2002-2005,2007 David Roundy +% +% This program is free software; you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation; either version 2, or (at your option) +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; see the file COPYING. If not, write to +% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +% Boston, MA 02110-1301, USA. + +\documentclass{report} +\usepackage{color} + +\usepackage{verbatim} +\newenvironment{code}{\color{blue}\verbatim}{\endverbatim} + +\begin{document} + +% Definition of title page: +\title{ + Unit Testing for darcs in Haskell +} +\author{ + David Roundy % insert author(s) here +} + +\maketitle + +\tableofcontents % Table of Contents + +\chapter{Introduction} + +This is a unit testing program, which is intended to make sure that all the +functions of my darcs code work properly. + +\begin{code} +{-# OPTIONS_GHC -cpp -fno-warn-orphans -fno-warn-deprecations -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +module Darcs.Test.Unit (main) where + +import System.IO.Unsafe ( unsafePerformIO ) +import ByteStringUtils hiding ( intercalate ) +import qualified Data.ByteString.Char8 as BC ( unpack, pack ) +import qualified Data.ByteString as B ( concat, empty ) +import Darcs.Patch +import Darcs.Test.Patch.Test +import Darcs.Test.Patch.Unit ( patchUnitTests ) +import Darcs.Test.Email ( emailParsing, emailHeaderNoLongLines, + emailHeaderAsciiChars, emailHeaderLinesStart, + emailHeaderNoEmptyLines ) +import Darcs.Test.Patch.Info ( metadataDecodingTest, metadataEncodingTest, + packUnpackTest ) +import Lcs ( shiftBoundaries ) +import Test.QuickCheck +import Printer ( renderPS ) +import Darcs.Patch.Commute +import Data.Array.Base +import Data.Array.Unboxed +import Control.Monad.ST +import Darcs.Witnesses.Ordered +import Darcs.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal ) +import Test.HUnit ( assertBool, assertFailure ) +import Test.Framework.Providers.QuickCheck2 ( testProperty ) +import Test.Framework.Providers.HUnit ( testCase ) +import Test.Framework.Runners.Console ( defaultMain ) +import Test.Framework ( Test ) + +#include "impossible.h" +\end{code} + +\chapter{Main body of code} + +\begin{code} +main :: IO () +main = do + putStr ("There are a total of "++(show (length primitiveTestPatches)) + ++" primitive patches.\n") + putStr ("There are a total of "++ + (show (length testPatches))++" patches.\n") + defaultMain tests + +-- | Utility function to run bools with test-framework +testBool :: String -> Bool -> Test +testBool name test = testCase name (assertBool assertName test) + where assertName = "boolean test \"" ++ name ++ "\" should return True" + +-- | Utility function to run old tests that return a list of error messages, +-- with the empty list meaning success. +testStringList :: String -> [String] -> Test +testStringList name test = testCase name $ mapM_ assertFailure test + +-- | This is the big list of tests that will be run using testrunner. +tests :: [Test] +tests = patchUnitTests ++ + [testBool "Checking that UTF-8 packing and unpacking preserves 'hello world'" + (unpackPSFromUTF8 (BC.pack "hello world") == "hello world"), + testBool "Checking that hex packing and unpacking preserves 'hello world'" + (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world") + == "hello world"), + emailParsing, + emailHeaderNoLongLines, + emailHeaderAsciiChars, + emailHeaderLinesStart, + emailHeaderNoEmptyLines, + testProperty "Checking that B.concat works" propConcatPS, + testProperty "Checking that hex conversion works" propHexConversion, + testProperty "Checking that show and read work right" propReadShow, + testStringList "Checking known commutes" commuteTests, + testStringList "Checking known merges" mergeTests, + testStringList "Checking known canons" canonizationTests] + ++ checkSubcommutes subcommutesInverse "patch and inverse both commute" + ++ checkSubcommutes subcommutesNontrivialInverse "nontrivial commutes are correct" + ++ checkSubcommutes subcommutesFailure "inverses fail" + ++ + [testProperty "Checking that commuting by patch and its inverse is ok" propCommuteInverse, + --putStr "Checking that conflict resolution is valid... " + --runQuickCheckTest returnval propResolveConflictsValid + testProperty "Checking that a patch followed by its inverse is identity" propPatchAndInverseIsIdentity, + -- The following tests are "wrong" with the Conflictor code. + --putStr "Checking that a simple smart_merge is sufficient... " + --runQuickCheckTest returnval propSimpleSmartMergeGoodEnough + --putStr "Checking that an elegant merge is sufficient... " + --runQuickCheckTest returnval propElegantMergeGoodEnough + testProperty "Checking that commutes are equivalent" propCommuteEquivalency, + testProperty "Checking that merges are valid" propMergeValid, + testProperty "Checking inverses being valid" propInverseValid, + testProperty "Checking other inverse being valid" propOtherInverseValid, + testStringList "Checking merge swaps" mergeSwapTests, + -- The patch generator isn't smart enough to generate correct test + -- cases for the following: (which will be obsoleted soon, anyhow) + --putStr "Checking the order dependence of unravel... " + --runQuickCheckTest returnval propUnravelOrderIndependent + --putStr "Checking the unravelling of three merges... " + --runQuickCheckTest returnval propUnravelThreeMerge + --putStr "Checking the unravelling of a merge of a sequence... " + --runQuickCheckTest returnval propUnravelSeqMerge + testProperty "Checking inverse of inverse" propInverseComposition, + testProperty "Checking the order of commutes" propCommuteEitherOrder, + testProperty "Checking commute either way" propCommuteEitherWay, + testProperty "Checking the double commute" propCommuteTwice, + testProperty "Checking that merges commute and are well behaved" propMergeIsCommutableAndCorrect, + testProperty "Checking that merges can be swapped" propMergeIsSwapable, + testProperty "Checking again that merges can be swapped (I'm paranoid) " propMergeIsSwapable, + testStringList "Checking that the patch validation works" testCheck, + testStringList "Checking commute/recommute" commuteRecommuteTests, + testStringList "Checking merge properties" genericMergeTests, + testStringList "Testing the lcs code" showLcsTests, + testStringList "Checking primitive patch IO functions" primitiveShowReadTests, + testStringList "Checking IO functions" showReadTests, + testStringList "Checking primitive commute/recommute" primitiveCommuteRecommuteTests, + metadataDecodingTest, + metadataEncodingTest, + packUnpackTest + ] +\end{code} + +\chapter{Unit Tester} + +The unit tester function is really just a glorified map for functions that +return lists, in which the lists get concatenated (where map would end up +with a list of lists). + +\begin{code} +type PatchUnitTest p = p -> [String] +type TwoPatchUnitTest = Patch -> Patch -> [String] + +parallelPairUnitTester :: TwoPatchUnitTest -> [(Patch:\/:Patch)] -> [String] +parallelPairUnitTester _ [] = [] +parallelPairUnitTester thetest ((p1:\/:p2):ps) + = (thetest p1 p2)++(parallelPairUnitTester thetest ps) + +pairUnitTester :: TwoPatchUnitTest -> [(Patch: [String] +pairUnitTester _ [] = [] +pairUnitTester thetest ((p1: [String] +checkKnownShifts (ca, cb, sa, sb, ca', cb') = runST ( + do ca_arr <- newListArray (0, length ca) $ toBool (0:ca) + cb_arr <- newListArray (0, length cb) $ toBool (0:cb) + let p_a = listArray (0, length sa) $ B.empty:(toPS sa) + p_b = listArray (0, length sb) $ B.empty:(toPS sb) + shiftBoundaries ca_arr cb_arr p_a 1 1 + shiftBoundaries cb_arr ca_arr p_b 1 1 + ca_res <- fmap (fromBool . tail) $ getElems ca_arr + cb_res <- fmap (fromBool . tail) $ getElems cb_arr + return $ if ca_res == ca' && cb_res == cb' then [] + else ["shiftBoundaries failed on "++sa++" and "++sb++" with " + ++(show (ca,cb))++" expected "++(show (ca', cb')) + ++" got "++(show (ca_res, cb_res))++"\n"]) + where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c]) + toBool = map (>0) + fromBool = map (\b -> if b then 1 else 0) + +knownShifts :: [([Int],[Int],String,String,[Int],[Int])] +knownShifts = + [([0,0,0],[0,1,0,1,0],"aaa","aaaaa", + [0,0,0],[0,0,0,1,1]), + ([0,1,0],[0,1,1,0],"cd ","c a ", + [0,1,0],[0,1,1,0]), + ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}", + [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end + ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}", + [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end + ([],[1,1],"","aa",[],[1,1]), + ([1,1],[],"aa","",[1,1],[])] + + +\end{code} + +\chapter{Show/Read tests} + +This test involves calling ``show'' to print a string describing a patch, +and then using readPatch to read it back in, and making sure the patch we +read in is the same as the original. Useful for making sure that I don't +have any stupid IO bugs. + +\begin{code} +showReadTests :: [String] +showReadTests = concatMap tShowRead testPatches ++ + concatMap tShowRead testPatchesNamed +primitiveShowReadTests :: [String] +primitiveShowReadTests = concatMap tShowRead primitiveTestPatches +tShowRead :: (Eq p, Show p, Patchy p) => PatchUnitTest p +tShowRead p = + case readPatch $ renderPS $ showPatch p of + Just (Sealed p',_) -> if p' == p then [] + else ["Failed to read shown: "++(show p)++"\n"] + Nothing -> ["Failed to read at all: "++(show p)++"\n"] + +instance MyEq p => Eq (Named p) where + (==) = unsafeCompare +\end{code} + +\chapter{Canonization tests} + +This is a set of known correct canonizations, to make sure that I'm +canonizing as I ought. + +\begin{code} +canonizationTests :: [String] +canonizationTests = concatMap checkKnownCanon knownCanons +checkKnownCanon :: (Patch, Patch) -> [String] +checkKnownCanon (p1,p2) = + if (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1) == p2 + then [] + else ["Canonization failed:\n"++show p1++"canonized is\n" + ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1 :: Patch) + ++"which is not\n"++show p2] +knownCanons :: [(Patch,Patch)] +knownCanons = + [(quickhunk 1 "abcde" "ab", quickhunk 3 "cde" ""), + (quickhunk 1 "abcde" "bd", join_patches [quickhunk 1 "a" "", + quickhunk 2 "c" "", + quickhunk 3 "e" ""]), + (join_patches [quickhunk 4 "a" "b", + quickhunk 1 "c" "d"], + join_patches [quickhunk 1 "c" "d", + quickhunk 4 "a" "b"]), + (join_patches [quickhunk 1 "a" "", + quickhunk 1 "" "b"], + quickhunk 1 "a" "b"), + (join_patches [quickhunk 1 "ab" "c", + quickhunk 1 "cd" "e"], + quickhunk 1 "abd" "e"), + (quickhunk 1 "abcde" "cde", quickhunk 1 "ab" ""), + (quickhunk 1 "abcde" "acde", quickhunk 2 "b" "")] +quickhunk :: Int -> String -> String -> Patch +quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o) + (map (\c -> BC.pack [c]) n) +\end{code} + +\chapter{Merge/unmgerge tests} + +It should always be true that if two patches can be unmerged, then merging +the resulting patches should give them back again. +\begin{code} +genericMergeTests :: [String] +genericMergeTests = + case take 400 [(p1:\/:p2)| + i <- [0..(length testPatches)-1], + p1<-[testPatches!!i], + p2<-drop i testPatches, + checkAPatch $ join_patches [invert p2,p1]] of + merge_pairs -> (parallelPairUnitTester tMergeEitherWayValid merge_pairs) ++ + (parallelPairUnitTester tMergeSwapMerge merge_pairs) +tMergeEitherWayValid :: TwoPatchUnitTest +tMergeEitherWayValid p1 p2 = + case join_patches [p2, quickmerge (p1:\/: p2)] of + combo2 -> + case join_patches [p1, quickmerge (p2:\/: p1)] of + combo1 -> + if not $ checkAPatch $ join_patches [combo1] + then ["oh my combo1 invalid:\n"++show p1++"and...\n"++show p2++show combo1] + else + if checkAPatch $ join_patches [invert combo1, combo2] + then [] + else ["merge both ways invalid:\n"++show p1++"and...\n"++show p2++ + show combo1++ + show combo2] +tMergeSwapMerge :: TwoPatchUnitTest +tMergeSwapMerge p1 p2 = + if (swapp $ merge (p2:\/: p1)) == merge (p1:\/:p2) + then [] + else ["Failed to swap merges:\n"++show p1++"and...\n"++show p2 + ++"merged:\n"++show (merge (p1:\/:p2))++"\n" + ++"merged and swapped:\n"++show (swapp $ merge (p2:\/: p1))++"\n"] + where swapp (x :/\: y) = y :/\: x + +instance Show p => Show (p :/\: p) where + show (x :/\: y) = show x ++ " :/\\: " ++ show y +instance Eq p => Eq (p :/\: p) where + (x :/\: y) == (x' :/\: y') = x == x' && y == y' +\end{code} + +\chapter{Commute/recommute tests} + +Here we test to see if commuting patch A and patch B and then commuting the +result gives us patch A and patch B again. The set of patches (A,B) is +chosen from the set of all pairs of test patches by selecting those which +commute with one another. + +\begin{code} +commuteRecommuteTests :: [String] +commuteRecommuteTests = + case take 200 [(p2:checkseq [p1,p]) testPatches, + commute (p1:>p2) /= Nothing] of + commute_pairs -> pairUnitTester tCommuteRecommute commute_pairs + where checkseq ps = checkAPatch $ join_patches ps +primitiveCommuteRecommuteTests :: [String] +primitiveCommuteRecommuteTests = + pairUnitTester tCommuteRecommute + [(p1:p1) /= Nothing, + checkAPatch $ join_patches [p2,p1]] +tCommuteRecommute :: TwoPatchUnitTest +tCommuteRecommute p1 p2 = + if (commute (p2:>p1) >>= commute) == Just (p2:>p1) + then [] + else ["Failed to recommute:\n"++(show p2)++(show p1)++ + "we saw it as:\n"++show (commute (p2:>p1))++ + "\nAnd recommute was:\n"++show (commute (p2:>p1) >>= commute) + ++ "\n"] +\end{code} + +\chapter{Commute tests} + +Here we provide a set of known interesting commutes. +\begin{code} +commuteTests :: [String] +commuteTests = + concatMap checkKnownCommute knownCommutes++ + concatMap checkCantCommute knownCantCommute +checkKnownCommute :: (Patch:< Patch, Patch:< Patch) -> [String] +checkKnownCommute (p1:p1) of + Just (p1a:>p2a) -> + if (p2a:< p1a) == (p2':< p1') + then [] + else ["Commute gave wrong value!\n"++show p1++"\n"++show p2 + ++"should be\n"++show p2'++"\n"++show p1' + ++"but is\n"++show p2a++"\n"++show p1a] + Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2] + ++ + case commute (p1':>p2') of + Just (p2a:>p1a) -> + if (p1a:< p2a) == (p1:< p2) + then [] + else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a + ++"should have been\n"++show p2'++"\n"++show p1'] + Nothing -> ["Commute failed!\n"++show p2'++"\n"++show p1'] +knownCommutes :: [(Patch: [String] +checkCantCommute (p1:p1) of + Nothing -> [] + _ -> [show p1 ++ "\n\n" ++ show p2 ++ + "\nArgh, these guys shouldn't commute!\n"] +knownCantCommute :: [(Patch:< Patch)] +knownCantCommute = [ + (testhunk 2 ["o"] ["n"]:< + testhunk 1 [] ["A"]), + (testhunk 1 [] ["A"]:< + testhunk 1 ["o"] ["n"]), + (quickmerge (testhunk 2 ["o"] ["n"]:\/: + testhunk 2 ["o"] ["v"]):< + testhunk 1 [] ["a"]), + (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):< + fromPrim (addfile "test"))] + where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n) +\end{code} + +\chapter{Merge tests} + +Here we provide a set of known interesting merges. +\begin{code} +mergeTests :: [String] +mergeTests = + concatMap checkKnownMergeEquiv knownMergeEquivs++ + concatMap checkKnownMerge knownMerges +checkKnownMerge :: (Patch:\/: Patch, Patch) -> [String] +checkKnownMerge (p1:\/:p2,p1') = + case merge (p1:\/:p2) of + _ :/\: p1a -> + if p1a == p1' + then [] + else ["Merge gave wrong value!\n"++show p1++show p2 + ++"I expected\n"++show p1' + ++"but found instead\n"++show p1a] +knownMerges :: [(Patch:\/:Patch,Patch)] +knownMerges = [ + (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/: + testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"], + testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]), + (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/: + testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"], + testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]), + (testhunk 3 [BC.pack "A"] []:\/: + testhunk 1 [BC.pack "B"] [], + testhunk 2 [BC.pack "A"] []), + (fromPrim (rmdir "./test/world"):\/: + fromPrim (hunk "./world" 3 [BC.pack "A"] []), + fromPrim (rmdir "./test/world")), + + (join_patches [quickhunk 1 "a" "bc", + quickhunk 6 "d" "ef"]:\/: + join_patches [quickhunk 3 "a" "bc", + quickhunk 8 "d" "ef"], + join_patches [quickhunk 1 "a" "bc", + quickhunk 7 "d" "ef"]), + + (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/: + testhunk 2 [BC.pack "B"] [BC.pack "C"], + testhunk 1 [BC.pack "A"] [BC.pack "B"]), + + (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/: + testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"], + testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"])] + where testhunk l o n = fromPrim $ hunk "test" l o n +checkKnownMergeEquiv :: (Patch:\/:Patch,Patch) -> [String] +checkKnownMergeEquiv (p1:\/: p2, pe) = + case quickmerge (p1:\/:p2) of + p1' -> if checkAPatch $ join_patches [invert p1, p2, p1', invert pe] + then [] + else ["Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2 + ++"in other words\n" ++ show (p1 :\/: p2) + ++"merges as\n" ++ show (merge $ p1 :\/: p2) + ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2) + ++"which is equivalent to\n" ++ show (effect p1') + ++ "should all work out to\n" + ++ show pe] +knownMergeEquivs :: [(Patch:\/: Patch, Patch)] +knownMergeEquivs = [ + + -- The following tests are going to be failed by the + -- Conflictor code as a cleanup. + + --(addfile "test":\/: + -- adddir "test", + -- join_patches [adddir "test", + -- addfile "test-conflict"]), + --(move "silly" "test":\/: + -- adddir "test", + -- join_patches [adddir "test", + -- move "silly" "test-conflict"]), + --(addfile "test":\/: + -- move "old" "test", + -- join_patches [addfile "test", + -- move "old" "test-conflict"]), + --(move "a" "test":\/: + -- move "old" "test", + -- join_patches [move "a" "test", + -- move "old" "test-conflict"]), + (fromPrim (hunk "test" 1 [] [BC.pack "A"]):\/: + fromPrim (hunk "test" 1 [] [BC.pack "B"]), + fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])), + (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/: + fromPrim (hunk "test" 1 [BC.pack "b"] []), + identity), + --hunk "test" 1 [] [BC.pack "v v v v v v v", + -- BC.pack "*************", + -- BC.pack "a", + -- BC.pack "b", + -- BC.pack "^ ^ ^ ^ ^ ^ ^"]), + (quickhunk 4 "a" "":\/: + quickhunk 3 "a" "", + quickhunk 3 "aa" ""), + (join_patches [quickhunk 1 "a" "bc", + quickhunk 6 "d" "ef"]:\/: + join_patches [quickhunk 3 "a" "bc", + quickhunk 8 "d" "ef"], + join_patches [quickhunk 3 "a" "bc", + quickhunk 8 "d" "ef", + quickhunk 1 "a" "bc", + quickhunk 7 "d" "ef"]), + (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a"):\/: + quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"), + quickhunk 2 "" "abdc") + ] +\end{code} + +It also is useful to verify that it doesn't matter which order we specify +the patches when we merge. + +\begin{code} +mergeSwapTests :: [String] +mergeSwapTests = + concat + [checkMergeSwap p1 p2 | + p1<-primitiveTestPatches, + p2<-primitiveTestPatches, + checkAPatch $ join_patches [invert p1,p2] + ] +checkMergeSwap :: Patch -> Patch -> [String] +checkMergeSwap p1 p2 = + case merge (p2:\/:p1) of + _ :/\: p2' -> + case merge (p1:\/:p2) of + _ :/\: p1' -> + case commute (p1:>p2') of + Just (_:>p1'b) -> + if p1'b /= p1' + then ["Merge swapping problem with...\np1 "++ + show p1++"merged with\np2 "++ + show p2++"p1' is\np1' "++ + show p1'++"p1'b is\np1'b "++ + show p1'b + ] + else [] + Nothing -> ["Merge commuting problem with...\np1 "++ + show p1++"merged with\np2 "++ + show p2++"gives\np2' "++ + show p2'++"which doesn't commute with p1.\n" + ] +\end{code} + +\chapter{Patch test data} + +This is where we define the set of patches which we run our tests on. This +should be kept up to date with as many interesting permutations of patch +types as possible. + +\begin{code} +testPatches :: [Patch] +testPatchesNamed :: [Named Patch] +testPatchesAddfile :: [Patch] +testPatchesRmfile :: [Patch] +testPatchesHunk :: [Patch] +primitiveTestPatches :: [Patch] +testPatchesBinary :: [Patch] +testPatchesCompositeNocom :: [Patch] +testPatchesComposite :: [Patch] +testPatchesTwoCompositeHunks :: [Patch] +testPatchesCompositeHunks :: [Patch] +testPatchesCompositeFourHunks :: [Patch] +testPatchesMerged :: [Patch] +validPatches :: [Patch] + +testPatchesNamed = [unsafePerformIO $ + namepatch "date is" "patch name" "David Roundy" [] + (fromPrim $ addfile "test"), + unsafePerformIO $ + namepatch "Sat Oct 19 08:31:13 EDT 2002" + "This is another patch" "David Roundy" + ["This log file has","two lines in it"] + (fromPrim $ rmfile "test")] +testPatchesAddfile = map fromPrim + [addfile "test",adddir "test",addfile "test/test"] +testPatchesRmfile = map invert testPatchesAddfile +testPatchesHunk = + [fromPrim $ hunk file line old new | + file <- ["test"], + line <- [1,2], + old <- map (map BC.pack) partials, + new <- map (map BC.pack) partials, + old /= new + ] + where partials = [["A"],["B"],[],["B","B2"]] + +primitiveTestPatches = testPatchesAddfile ++ + testPatchesRmfile ++ + testPatchesHunk ++ + [unsafeUnseal.fst.fromJust.readPatch $ + BC.pack "move ./test/test ./hello", + unsafeUnseal.fst.fromJust.readPatch $ + BC.pack "move ./test ./hello"] ++ + testPatchesBinary + +testPatchesBinary = + [fromPrim $ binary "./hello" + (BC.pack $ "agadshhdhdsa75745457574asdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg") + (BC.pack $ "adafjttkykrehhtrththrthrthre" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaagg"), + fromPrim $ binary "./hello" + B.empty + (BC.pack "adafjttkykrere")] + +testPatchesCompositeNocom = + take 50 [join_patches [p1,p2]| + p1<-primitiveTestPatches, + p2<-filter (\p->checkseq [p1,p]) primitiveTestPatches, + commute (p1:>p2) == Nothing] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesComposite = + take 100 [join_patches [p1,p2]| + p1<-primitiveTestPatches, + p2<-filter (\p->checkseq [p1,p]) primitiveTestPatches, + commute (p1:>p2) /= Nothing, + commute (p1:>p2) /= Just (p2:>p1)] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesTwoCompositeHunks = + take 100 [join_patches [p1,p2]| + p1<-testPatchesHunk, + p2<-filter (\p->checkseq [p1,p]) testPatchesHunk] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesCompositeHunks = + take 100 [join_patches [p1,p2,p3]| + p1<-testPatchesHunk, + p2<-filter (\p->checkseq [p1,p]) testPatchesHunk, + p3<-filter (\p->checkseq [p1,p2,p]) testPatchesHunk] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesCompositeFourHunks = + take 100 [join_patches [p1,p2,p3,p4]| + p1<-testPatchesHunk, + p2<-filter (\p->checkseq [p1,p]) testPatchesHunk, + p3<-filter (\p->checkseq [p1,p2,p]) testPatchesHunk, + p4<-filter (\p->checkseq [p1,p2,p3,p]) testPatchesHunk] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesMerged = + take 200 + [joinPatches $ flattenFL p2+>+flattenFL (quickmerge (p1:\/:p2)) | + p1<-take 10 (drop 15 testPatchesCompositeHunks)++primitiveTestPatches + ++take 10 (drop 15 testPatchesTwoCompositeHunks) + ++ take 2 (drop 4 testPatchesCompositeFourHunks), + p2<-take 10 testPatchesCompositeHunks++primitiveTestPatches + ++take 10 testPatchesTwoCompositeHunks + ++take 2 testPatchesCompositeFourHunks, + checkAPatch $ join_patches [invert p1, p2], + commute (p2:>p1) /= Just (p1:>p2) + ] + +testPatches = primitiveTestPatches ++ + testPatchesComposite ++ + testPatchesCompositeNocom ++ + testPatchesMerged +\end{code} + +\chapter{Check patch test} +Check patch is supposed to verify that a patch is valid. + +\begin{code} +validPatches = [(join_patches [quickhunk 4 "a" "b", + quickhunk 1 "c" "d"]), + (join_patches [quickhunk 1 "a" "bc", + quickhunk 1 "b" "d"]), + (join_patches [quickhunk 1 "a" "b", + quickhunk 1 "b" "d"])]++testPatches + +testCheck :: [String] +testCheck = concatMap tTestCheck validPatches +tTestCheck :: PatchUnitTest Patch +tTestCheck p = if checkAPatch p + then [] + else ["Failed the check: "++show p++"\n"] + +propHexConversion :: String -> Bool +propHexConversion s = + fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s +propConcatPS :: [String] -> Bool +propConcatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss) + +-- | Groups a set of tests by giving them the same prefix in their description. +-- When this is called as @checkSubcommutes subcoms expl@, the prefix for a +-- test becomes @"Checking " ++ expl ++ " for subcommute "@. +checkSubcommutes :: Testable a => [(String, a)] -> String + -> [Test] +checkSubcommutes subcoms expl = map check_subcommute subcoms + where check_subcommute (name, test) = + let testName = "Checking" ++ expl ++ " for subcommute " ++ name + in testProperty testName test +\end{code} + +\end{document} + + diff -ruN darcs-2.4.4/src/Darcs/Test.lhs darcs-2.5/src/Darcs/Test.lhs --- darcs-2.4.4/src/Darcs/Test.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Test.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -16,8 +16,8 @@ % Boston, MA 02110-1301, USA. \begin{code} -module Darcs.Test ( get_test, - run_posthook, run_prehook ) +module Darcs.Test ( getTest, + runPosthook, runPrehook ) where import Darcs.RepoPath ( AbsolutePath ) import Darcs.Utils ( withCurrentDirectory ) @@ -57,8 +57,8 @@ section~\ref{defaults}). \begin{code} -get_test :: [DarcsFlag] -> IO (IO ExitCode) -get_test opts = +getTest :: [DarcsFlag] -> IO (IO ExitCode) +getTest opts = let putInfo s = when (not $ Quiet `elem` opts) $ putStr s in do testline <- getPrefval "test" @@ -73,12 +73,12 @@ else putInfo "Test failed!\n" return ec -run_posthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode -run_posthook opts repodir = do ph <- get_posthook opts - withCurrentDirectory repodir $ run_hook opts "Posthook" ph +runPosthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode +runPosthook opts repodir = do ph <- getPosthook opts + withCurrentDirectory repodir $ runHook opts "Posthook" ph -get_posthook :: [DarcsFlag] -> IO (Maybe String) -get_posthook opts = case getPosthookCmd opts of +getPosthook :: [DarcsFlag] -> IO (Maybe String) +getPosthook opts = case getPosthookCmd opts of Nothing -> return Nothing Just command -> if AskPosthook `elem` opts @@ -91,12 +91,12 @@ return Nothing else return $ Just command -run_prehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode -run_prehook opts repodir = do ph <- get_prehook opts - withCurrentDirectory repodir $ run_hook opts "Prehook" ph +runPrehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode +runPrehook opts repodir = do ph <- getPrehook opts + withCurrentDirectory repodir $ runHook opts "Prehook" ph -get_prehook :: [DarcsFlag] -> IO (Maybe String) -get_prehook opts = case getPrehookCmd opts of +getPrehook :: [DarcsFlag] -> IO (Maybe String) +getPrehook opts = case getPrehookCmd opts of Nothing -> return Nothing Just command -> if AskPrehook `elem` opts @@ -109,9 +109,9 @@ return Nothing else return $ Just command -run_hook :: [DarcsFlag] -> String -> Maybe String -> IO ExitCode -run_hook _ _ Nothing = return ExitSuccess -run_hook opts cname (Just command) = +runHook :: [DarcsFlag] -> String -> Maybe String -> IO ExitCode +runHook _ _ Nothing = return ExitSuccess +runHook opts cname (Just command) = do ec <- system command when (Quiet `notElem` opts) $ if ec == ExitSuccess diff -ruN darcs-2.4.4/src/Darcs/TheCommands.hs darcs-2.5/src/Darcs/TheCommands.hs --- darcs-2.4.4/src/Darcs/TheCommands.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/TheCommands.hs 2010-10-24 08:29:26.000000000 -0700 @@ -35,7 +35,7 @@ import Darcs.Commands.MarkConflicts ( markconflicts, resolve ) import Darcs.Commands.Move ( move, mv ) import Darcs.Commands.Optimize ( optimize ) -import Darcs.Commands.Pull ( pull ) +import Darcs.Commands.Pull ( pull, fetch ) import Darcs.Commands.Push ( push ) import Darcs.Commands.Put ( put ) import Darcs.Commands.Record ( record, commit ) @@ -84,6 +84,7 @@ HiddenCommand transferMode, GroupName "Copying patches between repositories with working copy update:", CommandData pull, + CommandData fetch, CommandData obliterate, HiddenCommand unpull, CommandData rollback, CommandData push, diff -ruN darcs-2.4.4/src/Darcs/URL.hs darcs-2.5/src/Darcs/URL.hs --- darcs-2.4.4/src/Darcs/URL.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/URL.hs 2010-10-24 08:29:26.000000000 -0700 @@ -48,34 +48,34 @@ -} module Darcs.URL ( - is_file, is_url, is_ssh, is_relative, is_absolute, - is_ssh_nopath + isFile, isUrl, isSsh, isRelative, isAbsolute, + isSshNopath ) where #include "impossible.h" -is_relative :: String -> Bool -is_relative (_:':':_) = False -is_relative f@(c:_) = is_file f && c /= '/' && c /= '~' -is_relative "" = bug "Empty filename in is_relative" - -is_absolute :: String -> Bool -is_absolute "" = bug "is_absolute called with empty filename" -is_absolute f = is_file f && (not $ is_relative f) - -is_file :: String -> Bool -is_file (_:_:fou) = ':' `notElem` fou -is_file _ = True - -is_url :: String -> Bool -is_url (':':'/':'/':_:_) = True -is_url (_:x) = is_url x -is_url "" = False +isRelative :: String -> Bool +isRelative (_:':':_) = False +isRelative f@(c:_) = isFile f && c /= '/' && c /= '~' +isRelative "" = bug "Empty filename in isRelative" + +isAbsolute :: String -> Bool +isAbsolute "" = bug "isAbsolute called with empty filename" +isAbsolute f = isFile f && (not $ isRelative f) + +isFile :: String -> Bool +isFile (_:_:fou) = ':' `notElem` fou +isFile _ = True + +isUrl :: String -> Bool +isUrl (':':'/':'/':_:_) = True +isUrl (_:x) = isUrl x +isUrl "" = False -is_ssh :: String -> Bool -is_ssh s = not (is_file s || is_url s) +isSsh :: String -> Bool +isSsh s = not (isFile s || isUrl s) -is_ssh_nopath :: String -> Bool -is_ssh_nopath s = case reverse s of +isSshNopath :: String -> Bool +isSshNopath s = case reverse s of ':':x@(_:_:_) -> ':' `notElem` x _ -> False diff -ruN darcs-2.4.4/src/Darcs/Utils.hs darcs-2.5/src/Darcs/Utils.hs --- darcs-2.4.4/src/Darcs/Utils.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Utils.hs 2010-10-24 08:29:26.000000000 -0700 @@ -7,22 +7,25 @@ putStrLnError, putDocLnError, withCurrentDirectory, withUMask, askUser, stripCr, - showHexLen, add_to_error_loc, + showHexLen, addToErrorLoc, maybeGetEnv, firstNotBlank, firstJustM, firstJustIO, - isUnsupportedOperationError, isHardwareFaultError, - get_viewer, edit_file, run_editor, - promptYorn, promptCharFancy, + getViewer, editFile, runEditor, + PromptConfig(..), promptYorn, promptChar, environmentHelpEditor, environmentHelpPager, - formatPath + formatPath, + isFileReallySymlink, doesDirectoryReallyExist, doesFileReallyExist + -- * Tree filtering. , filterFilePaths, filterPaths + -- * Tree lookup. + , treeHas, treeHasDir, treeHasFile, treeHasAnycase ) where import Prelude hiding ( catch ) -import Control.Exception ( bracket, bracket_, catch, Exception(IOException), try ) -import GHC.IOBase ( IOException(ioe_location), - IOErrorType(UnsupportedOperation, HardwareFault) ) -import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString ) +import Control.Exception.Extensible + ( bracket, bracket_, catch, try, + IOException, SomeException, Exception(fromException) ) +import System.IO.Error ( annotateIOError, isUserError, ioeGetErrorString ) import Darcs.SignalHandler ( catchNonSignal ) import Numeric ( showHex ) @@ -30,49 +33,41 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getEnv ) import System.IO ( hPutStrLn, stderr ) -import Data.Char ( toUpper ) +import Data.Char ( toUpper, toLower ) import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath ) import Data.Maybe ( listToMaybe, isJust ) import Data.List ( group, sort ) -import Control.Monad ( when ) -import Exec ( exec_interactive ) +import Control.Monad ( when, forM ) +import Control.Monad.Error( catchError, MonadError ) +import Exec ( execInteractive ) import Printer ( Doc, hPutDocLn ) import Foreign.C.String ( CString, withCString ) import Foreign.C.Error ( throwErrno ) import Foreign.C.Types ( CInt ) -import Progress ( withoutProgress ) +import qualified Data.ByteString.Char8 as BSC -import Storage.Hashed.AnchoredPath( AnchoredPath, isPrefix, floatPath ) +import System.Posix.Files( getSymbolicLinkStatus, isRegularFile, isDirectory, isSymbolicLink ) + +import Progress ( withoutProgress ) import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine, getInputChar, outputStrLn ) -import System.Console.Haskeline.Encoding ( encode ) import qualified Data.ByteString as B ( readFile ) -import qualified Data.ByteString.Char8 as B ( unpack ) + +import Control.Monad.State.Strict( gets ) +import Storage.Hashed.AnchoredPath( AnchoredPath(..), Name(..), isPrefix, floatPath ) +import Storage.Hashed.Monad( withDirectory, fileExists, exists, directoryExists + , virtualTreeMonad, currentDirectory + , TreeMonad, tree ) +import Storage.Hashed.Tree( Tree, listImmediate, findTree ) showHexLen :: (Integral a) => Int -> a -> String showHexLen n x = let s = showHex x "" in replicate (n - length s) ' ' ++ s -add_to_error_loc :: Exception -> String -> Exception -add_to_error_loc (IOException ioe) s - = IOException $ ioe { ioe_location = s ++ ": " ++ ioe_location ioe } -add_to_error_loc e _ = e - -isUnsupportedOperationError :: IOError -> Bool -isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType - -isUnsupportedOperationErrorType :: IOErrorType -> Bool -isUnsupportedOperationErrorType UnsupportedOperation = True -isUnsupportedOperationErrorType _ = False - -isHardwareFaultError :: IOError -> Bool -isHardwareFaultError = isHardwareFaultErrorType . ioeGetErrorType - -isHardwareFaultErrorType :: IOErrorType -> Bool -isHardwareFaultErrorType HardwareFault = True -isHardwareFaultErrorType _ = False +addToErrorLoc :: IOException -> String -> IOException +addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing catchall :: IO a -> IO a -> IO a a `catchall` b = a `catchNonSignal` (\_ -> b) @@ -100,8 +95,8 @@ clarifyErrors :: IO a -> String -> IO a clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e]) -prettyException :: Control.Exception.Exception -> String -prettyException (IOException e) | isUserError e = ioeGetErrorString e +prettyException :: SomeException -> String +prettyException e | Just ioe <- fromException e, isUserError ioe = ioeGetErrorString ioe prettyException e = show e prettyError :: IOError -> String @@ -120,7 +115,7 @@ (Right (ExitFailure 126)) -> b -- command not executable (Right (ExitFailure 127)) -> b -- command not found (Right x) -> return x -- legitimate success/failure - (Left _) -> b -- an exception + (Left (_ :: SomeException)) -> b -- an exception putStrLnError :: String -> IO () putStrLnError = hPutStrLn stderr @@ -151,13 +146,12 @@ (reset_umask rc) job -askUser :: String -> IO String +-- | Ask the user for a line of input. +askUser :: String -- ^ The prompt to display + -> IO String -- ^ The string the user entered. askUser prompt = withoutProgress $ runInputT defaultSettings $ getInputLine prompt >>= maybe (error "askUser: unexpected end of input") return - -- Return the input as encoded, 8-bit Chars (same as the - -- non-Haskeline backend). - >>= fmap B.unpack . encode stripCr :: String -> String stripCr "" = "" @@ -188,10 +182,10 @@ nubsort = map head . group . sort -edit_file :: FilePathLike p => p -> IO ExitCode -edit_file ff = do +editFile :: FilePathLike p => p -> IO ExitCode +editFile ff = do old_content <- file_content - ec <- run_editor f + ec <- runEditor f new_content <- file_content when (new_content == old_content) $ do yorn <- promptYorn "File content did not change. Continue anyway?" @@ -205,13 +205,13 @@ return $ Just content else return Nothing -run_editor :: FilePath -> IO ExitCode -run_editor f = do - ed <- get_editor +runEditor :: FilePath -> IO ExitCode +runEditor f = do + ed <- getEditor exec_interactive ed f -get_editor :: IO String -get_editor = getEnv "DARCS_EDITOR" `catchall` +getEditor :: IO String +getEditor = getEnv "DARCS_EDITOR" `catchall` getEnv "DARCSEDITOR" `catchall` getEnv "VISUAL" `catchall` getEnv "EDITOR" `catchall` return "editor" @@ -225,8 +225,8 @@ "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are", "each tried in turn."]) -get_viewer :: IO String -get_viewer = getEnv "DARCS_PAGER" `catchall` +getViewer :: IO String +getViewer = getEnv "DARCS_PAGER" `catchall` getEnv "PAGER" `catchall` return "pager" environmentHelpPager :: ([String], [String]) @@ -241,26 +235,36 @@ "to fit onscreen. Darcs will use the pager specified by $DARCS_PAGER", "or $PAGER. If neither are set, `less' will be used."]) +data PromptConfig = PromptConfig { pPrompt :: String + , pBasicCharacters :: [Char] + , pAdvancedCharacters :: [Char] -- ^ only shown on help + , pDefault :: Maybe Char + , pHelp :: [Char] + } + promptYorn :: [Char] -> IO Char -promptYorn p = promptCharFancy p "yn" Nothing [] +promptYorn p = promptChar (PromptConfig p "yn" [] Nothing []) -promptCharFancy :: String -> [Char] -> Maybe Char -> [Char] -> IO Char -promptCharFancy p chs md help_chs = withoutProgress $ runInputT defaultSettings $ - loopChar +promptChar :: PromptConfig -> IO Char +promptChar (PromptConfig p basic_chs adv_chs md help_chs) = + withoutProgress $ runInputT defaultSettings $ loopChar where + chs = basic_chs ++ adv_chs loopChar = do - let prompt = p ++ " [" ++ setDefault chs ++ "]" ++ helpStr - a <- getInputChar prompt >>= maybe (error "promptCharFancy: unexpected end of input") + let chars = setDefault (basic_chs ++ (if null adv_chs then "" else "...")) + prompt = p ++ " [" ++ chars ++ "]" ++ helpStr + a <- getInputChar prompt >>= maybe (error "promptChar: unexpected end of input") return - case () of + case () of _ | a `elem` chs -> return a - | a == ' ' -> case md of Nothing -> tryAgain + | a == ' ' -> case md of Nothing -> tryAgain Just d -> return d | a `elem` help_chs -> return a | otherwise -> tryAgain helpStr = case help_chs of - [] -> "" - (h:_) -> ", or " ++ (h:" for help: ") + [] -> "" + (h:_) | null adv_chs -> ", or " ++ (h:" for help: ") + | otherwise -> ", or " ++ (h:" for more options: ") tryAgain = do outputStrLn "Invalid response, try again!" loopChar setDefault s = case md of Nothing -> s @@ -279,3 +283,39 @@ filterFilePaths :: [FilePath] -> AnchoredPath -> t -> Bool filterFilePaths = filterPaths . map floatPath +-- Huh? +isFileReallySymlink :: FilePath -> IO Bool +isFileReallySymlink f = do fs <- getSymbolicLinkStatus f + return (isSymbolicLink fs) + +doesFileReallyExist :: FilePath -> IO Bool +doesFileReallyExist f = do fs <- getSymbolicLinkStatus f + return (isRegularFile fs) + +doesDirectoryReallyExist :: FilePath -> IO Bool +doesDirectoryReallyExist f = do fs <- getSymbolicLinkStatus f + return (isDirectory fs) + +treeHasAnycase :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool +treeHasAnycase tree path = fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree + +existsAnycase :: (MonadError e m, Functor m, Monad m) => AnchoredPath -> TreeMonad m Bool +existsAnycase (AnchoredPath []) = return True +existsAnycase (AnchoredPath (Name x:xs)) = + do wd <- currentDirectory + Just tree <- gets (flip findTree wd . tree) + let subs = [ AnchoredPath [Name n] | (Name n, _) <- listImmediate tree, + BSC.map toLower n == BSC.map toLower x ] + or `fmap` forM subs (\path -> do + file <- fileExists path + if file then return True + else withDirectory path (existsAnycase $ AnchoredPath xs)) + +treeHas :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool +treeHas tree path = fst `fmap` virtualTreeMonad (exists $ floatPath path) tree + +treeHasDir :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool +treeHasDir tree path = fst `fmap` virtualTreeMonad (directoryExists $ floatPath path) tree + +treeHasFile :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool +treeHasFile tree path = fst `fmap` virtualTreeMonad (fileExists $ floatPath path) tree diff -ruN darcs-2.4.4/src/Darcs/Witnesses/Ordered.hs darcs-2.5/src/Darcs/Witnesses/Ordered.hs --- darcs-2.4.4/src/Darcs/Witnesses/Ordered.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Witnesses/Ordered.hs 2010-10-24 08:29:26.000000000 -0700 @@ -23,24 +23,25 @@ module Darcs.Witnesses.Ordered ( EqCheck(..), isEq, (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..), (:||:)(..), FL(..), RL(..),Proof(..), -#ifndef GADT_WITNESSES - unsafeUnFL, unsafeFL, unsafeRL, unsafeUnRL, -#endif - lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL, - splitAtFL, bunchFL, foldlRL, + lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL, anyFL, + filterFL, + splitAtFL, splitAtRL, bunchFL, foldlRL, lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL, - unsafeMap_l2f, filterE, filterFL, + unsafeMap_l2f, filterE, filterFLFL, + filterRL, reverseFL, reverseRL, (+>+), (+<+), nullFL, concatFL, concatRL, concatReverseFL, headRL, MyEq, unsafeCompare, (=\/=), (=/\=), - consRLSealed, nullRL, - unsafeCoerceP, unsafeCoerceP2 + consRLSealed, nullRL, toFL, + (:>>)(..), + unsafeCoercePStart, unsafeCoercePEnd, + unsafeCoerceP, unsafeCoerceP2, spanFL_M ) where #include "impossible.h" import GHC.Base (unsafeCoerce#) import Darcs.Witnesses.Show -import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal ) +import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, Sealed(..), FreeLeft, unFreeLeft, Sealed2(..) ) data EqCheck C(a b) where IsEq :: EqCheck C(a a) @@ -70,6 +71,10 @@ data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y)) data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z)) data (a1 :||: a2) C(x y) = (a1 C(x y)) :||: (a2 C(x y)) + +data (a1 :>> a2) C(y) = FORALL(z) (a1 C(z)) :>> (a2 C(z y)) +infixr 1 :>> + class MyEq p where -- Minimal definition defines any one of unsafeCompare, =\/= and =/\=. unsafeCompare :: p C(a b) -> p C(c d) -> Bool @@ -86,20 +91,38 @@ unsafeCoerceP :: a C(x y) -> a C(b c) unsafeCoerceP = unsafeCoerce# +unsafeCoercePStart :: a C(x1 y) -> a C(x2 y) +unsafeCoercePStart = unsafeCoerce# + +unsafeCoercePEnd :: a C(x y1) -> a C(x y2) +unsafeCoercePEnd = unsafeCoerce# + unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d) unsafeCoerceP2 = unsafeCoerce# instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where showsPrec d (x :> y) = showOp2 1 ":>" d x y +instance (MyEq a, MyEq b) => MyEq (a :> b) where + (a1 :> b1) =\/= (a2 :> b2) | IsEq <- a1 =\/= a2 = b1 =\/= b2 + | otherwise = NotEq + +instance (MyEq a, MyEq b) => MyEq (a :< b) where + (a1 :< b1) =\/= (a2 :< b2) | IsEq <- b1 =\/= b2 = a1 =\/= a2 + | otherwise = NotEq + instance (Show2 a, Show2 b) => Show2 (a :> b) where - showsPrec2 = showsPrec + showDict2 = ShowDictClass instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y instance (Show2 a, Show2 b) => Show2 (a :\/: b) where - showsPrec2 = showsPrec + showDict2 = ShowDictClass + +instance MyEq a => Eq (Sealed (a C(x))) where + Sealed x == Sealed y | IsEq <- x =\/= y = True + | otherwise = False infixr 5 :>:, :<:, +>+, +<+ @@ -115,7 +138,7 @@ where prec = 5 instance Show2 a => Show2 (FL a) where - showsPrec2 = showsPrec + showDict2 = ShowDictClass -- reverse list data RL a C(x z) where @@ -130,10 +153,15 @@ nullRL NilRL = True nullRL _ = False -filterFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z) -filterFL _ NilFL = NilFL -filterFL f (x:>:xs) | IsEq <- f x = filterFL f xs - | otherwise = x :>: filterFL f xs +filterFLFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z) +filterFLFL _ NilFL = NilFL +filterFLFL f (x:>:xs) | IsEq <- f x = filterFLFL f xs + | otherwise = x :>: filterFLFL f xs + +filterRL :: (FORALL(x y) p C(x y) -> Bool) -> RL p C(x y) -> [Sealed2 p] +filterRL _ NilRL = [] +filterRL f (x :<: xs) | f x = Sealed2 x : (filterRL f xs) + | otherwise = filterRL f xs filterE :: (a -> EqCheck C(x y)) -> [a] -> [Proof a C(x y)] filterE _ [] = [] @@ -174,12 +202,31 @@ ys :> zs -> (x:>:ys) :> zs spanFL _ xs = NilFL :> xs +spanFL_M :: forall a m C(x z). Monad m => + (FORALL(w y) a C(w y) -> m Bool) -> FL a C(x z) + -> m ((FL a :> FL a) C(x z)) +spanFL_M f (x:>:xs) = + do + continue <- f x + if continue + then do (ys :> zs) <- spanFL_M f xs + return $ (x :>: ys) :> zs + else return $ NilFL :> (x :>: xs) + +spanFL_M _ (NilFL) = return $ NilFL :> NilFL + splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z) splitAtFL 0 xs = NilFL :> xs splitAtFL _ NilFL = NilFL :> NilFL splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of (xs':>xs'') -> (x:>:xs' :> xs'') +splitAtRL :: Int -> RL a C(x z) -> (RL a :< RL a) C(x z) +splitAtRL 0 xs = NilRL :< xs +splitAtRL _ NilRL = NilRL :< NilRL +splitAtRL n (x:<:xs) = case splitAtRL (n-1) xs of + (xs': (x:<:xs' :< xs'') + -- 'bunchFL n' groups patches into batches of n, except that it always puts -- the first patch in its own group, this being a recognition that the -- first patch is often *very* large. @@ -196,6 +243,9 @@ allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool allFL f xs = and $ mapFL f xs +anyFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool +anyFL f xs = or $ mapFL f xs + foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a foldlFL _ x NilFL = x foldlFL f x (y:>:ys) = foldlFL f (f x y) ys @@ -222,6 +272,12 @@ mapFL _ NilFL = [] mapFL f (a :>: b) = f a : mapFL f b +filterFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(x y) -> [Sealed2 a] +filterFL _ NilFL = [] +filterFL f (a :>: b) = if f a + then (Sealed2 a):(filterFL f b) + else filterFL f b + mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b] mapRL _ NilRL = [] mapRL f (a :<: b) = f a : mapRL f b @@ -257,21 +313,7 @@ consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z) consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as -#ifndef GADT_WITNESSES --- These are useful for interfacing with modules which do not yet use type witnesses -unsafeUnFL :: FL a -> [a] -unsafeUnFL NilFL = [] -unsafeUnFL (a:>:as) = a : unsafeUnFL as - -unsafeUnRL :: RL a -> [a] -unsafeUnRL NilRL = [] -unsafeUnRL (a:<:as) = a : unsafeUnRL as - -unsafeFL :: [a] -> FL a -unsafeFL [] = NilFL -unsafeFL (a:as) = a :>: unsafeFL as - -unsafeRL :: [a] -> RL a -unsafeRL [] = NilRL -unsafeRL (a:as) = a :<: unsafeRL as -#endif +toFL :: [FreeLeft a] -> Sealed (FL a C(x)) +toFL [] = Sealed NilFL +toFL (x:xs) = case unFreeLeft x of Sealed y -> case toFL xs of Sealed ys -> Sealed (y :>: ys) + diff -ruN darcs-2.4.4/src/Darcs/Witnesses/Sealed.hs darcs-2.5/src/Darcs/Witnesses/Sealed.hs --- darcs-2.4.4/src/Darcs/Witnesses/Sealed.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Witnesses/Sealed.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,4 +1,4 @@ --- Copyright (C) 2007 David Roundy +-- Copyright (C) 2007 David Roundy, 2009 Ganesh Sittampalam -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -22,12 +22,11 @@ #include "gadts.h" module Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal, -#ifndef GADT_WITNESSES - unsafeUnseal, unsafeUnflippedseal, unsafeUnseal2, -#endif + unsafeUnseal, unsafeUnsealFlipped, unsafeUnseal2, Sealed2(..), seal2, unseal2, mapSeal2, FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped, - unsealM, liftSM + unsealM, liftSM, + Gap(..), FreeLeft, unFreeLeft, FreeRight, unFreeRight ) where import GHC.Base ( unsafeCoerce# ) @@ -51,22 +50,17 @@ flipSeal :: a C(x y) -> FlippedSeal a C(y) flipSeal = FlippedSeal -#ifndef GADT_WITNESSES -unsafeUnseal :: Sealed a -> a -unsafeUnseal (Sealed a) = a - -unsafeUnflippedseal :: FlippedSeal a -> a -unsafeUnflippedseal (FlippedSeal a) = a - -unsafeUnseal2 :: Sealed2 a -> a -unsafeUnseal2 (Sealed2 a) = a -#endif +unsafeUnseal :: Sealed a -> a C(x) +unsafeUnseal (Sealed a) = unsafeCoerce# a -seriouslyUnsafeUnseal :: Sealed a -> a C(()) -seriouslyUnsafeUnseal (Sealed a) = unsafeCoerce# a +unsafeUnsealFlipped :: FlippedSeal a C(y) -> a C(x y) +unsafeUnsealFlipped (FlippedSeal a) = unsafeCoerce# a + +unsafeUnseal2 :: Sealed2 a -> a C(x y) +unsafeUnseal2 (Sealed2 a) = unsafeCoerce# a unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b -unseal f x = f (seriouslyUnsafeUnseal x) +unseal f x = f (unsafeUnseal x) -- laziness property: -- unseal (const True) undefined == True @@ -85,11 +79,8 @@ mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z) mapFlipped f (FlippedSeal x) = FlippedSeal (f x) -seriouslyUnsafeUnseal2 :: Sealed2 a -> a C(() ()) -seriouslyUnsafeUnseal2 (Sealed2 a) = unsafeCoerce# a - unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b -unseal2 f a = f (seriouslyUnsafeUnseal2 a) +unseal2 f a = f (unsafeUnseal2 a) mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b mapSeal2 f = unseal2 (seal2 . f) @@ -98,6 +89,61 @@ unsealFlipped f (FlippedSeal a) = f a instance Show1 a => Show (Sealed a) where - showsPrec d (Sealed x) = showParen (d > app_prec) $ showString "Sealed " . showsPrec1 (app_prec + 1) x + showsPrec d (Sealed x) = showParen (d > appPrec) $ showString "Sealed " . showsPrec1 (appPrec + 1) x instance Show2 a => Show (Sealed2 a) where - showsPrec d (Sealed2 x) = showParen (d > app_prec) $ showString "Sealed2 " . showsPrec2 (app_prec + 1) x + showsPrec d (Sealed2 x) = showParen (d > appPrec) $ showString "Sealed2 " . showsPrec2 (appPrec + 1) x + +-- |'Poly' is similar to 'Sealed', but the type argument is +-- universally quantified instead of being existentially quantified. +newtype Poly a = Poly { unPoly :: FORALL(x) a C(x) } + +-- |'Stepped' is a type level composition operator. +-- For example, 'Stepped Sealed p' is equivalent to 'lambda x . Sealed (p x)' +newtype Stepped f a C(x) = Stepped { unStepped :: f (a C(x)) } + +-- |'FreeLeft p' is '\forall x . \exists y . p x y' +-- In other words the caller is free to specify the left witness, +-- and then the right witness is an existential. +-- Note that the order of the type constructors is important for ensuring +-- that 'y' is dependent on the 'x' that is supplied. +-- This is why 'Stepped' is needed, rather than writing the more obvious +-- 'Sealed (Poly p)' which would notionally have the same quantification +-- of the type witnesses. +newtype FreeLeft p = FLInternal (Poly (Stepped Sealed p)) + +-- |'FreeLeft p' is '\forall y . \exists x . p x y' +-- In other words the caller is free to specify the right witness, +-- and then the left witness is an existential. +-- Note that the order of the type constructors is important for ensuring +-- that 'x' is dependent on the 'y' that is supplied. +newtype FreeRight p = FRInternal (Poly (FlippedSeal p)) + +-- |Unwrap a 'FreeLeft' value +unFreeLeft :: FreeLeft p -> Sealed (p C(x)) +unFreeLeft (FLInternal x) = unStepped (unPoly x) + +-- |Unwrap a 'FreeRight' value +unFreeRight :: FreeRight p -> FlippedSeal p C(x) +unFreeRight (FRInternal x) = unPoly x + +-- |'Gap' abstracts over 'FreeLeft' and 'FreeRight' for code constructing these values +class Gap w where + -- |An empty 'Gap', e.g. 'NilFL' or 'NilRL' + emptyGap :: (FORALL(x) p C(x x)) -> w p + -- |A 'Gap' constructed from a completely polymorphic value, for example the constructors + -- for primitive patches + freeGap :: (FORALL(x y) p C(x y)) -> w p + -- |Compose two 'Gap' values together, e.g. 'joinGap (+>+)' or 'joinGap (:>:)' + joinGap :: (FORALL(x y z) p C(x y) -> q C(y z) -> r C(x z)) -> w p -> w q -> w r + +instance Gap FreeLeft where + emptyGap e = FLInternal (Poly (Stepped (Sealed e))) + freeGap e = FLInternal (Poly (Stepped (Sealed e))) + joinGap op (FLInternal p) (FLInternal q) + = FLInternal (Poly (case unPoly p of Stepped (Sealed p') -> case unPoly q of Stepped (Sealed q') -> Stepped (Sealed (p' `op` q')))) + +instance Gap FreeRight where + emptyGap e = FRInternal (Poly (FlippedSeal e)) + freeGap e = FRInternal (Poly (FlippedSeal e)) + joinGap op (FRInternal p) (FRInternal q) + = FRInternal (Poly (case unPoly q of FlippedSeal q' -> case unPoly p of FlippedSeal p' -> FlippedSeal (p' `op` q'))) \ No newline at end of file diff -ruN darcs-2.4.4/src/Darcs/Witnesses/Show.hs darcs-2.5/src/Darcs/Witnesses/Show.hs --- darcs-2.4.4/src/Darcs/Witnesses/Show.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Darcs/Witnesses/Show.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,25 +1,48 @@ {-# OPTIONS_GHC -cpp -fglasgow-exts #-} {-# LANGUAGE CPP #-} -module Darcs.Witnesses.Show(Show1(..), Show2(..), showOp2, app_prec) where +module Darcs.Witnesses.Show(ShowDict(..), showD, showListD, showsPrecD, + Show1(..), Show2(..), show1, showsPrec1, show2, showsPrec2, showOp2, appPrec) where #include "gadts.h" +data ShowDict a where + ShowDictClass :: Show a => ShowDict a + ShowDictRecord :: (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowDict a + +showsPrecD :: ShowDict a -> Int -> a -> ShowS +showsPrecD ShowDictClass = showsPrec +showsPrecD (ShowDictRecord showsPrecR _ _) = showsPrecR + +showD :: ShowDict a -> a -> String +showD ShowDictClass = show +showD (ShowDictRecord _ showR _) = showR + +showListD :: ShowDict a -> [a] -> ShowS +showListD ShowDictClass = showList +showListD (ShowDictRecord _ _ showListR) = showListR + class Show1 a where - show1 :: a C(x) -> String - show1 x = showsPrec1 0 x "" - showsPrec1 :: Int -> a C(x) -> ShowS - showsPrec1 _ x s = show1 x ++ s + showDict1 :: ShowDict (a C(x)) + +showsPrec1 :: Show1 a => Int -> a C(x) -> ShowS +showsPrec1 = showsPrecD showDict1 + +show1 :: Show1 a => a C(x) -> String +show1 = showD showDict1 class Show2 a where - show2 :: a C(x y) -> String - show2 x = showsPrec2 0 x "" - showsPrec2 :: Int -> a C(x y) -> ShowS - showsPrec2 _ x s = show2 x ++ s + showDict2 :: ShowDict (a C(x y)) + +showsPrec2 :: Show2 a => Int -> a C(x y) -> ShowS +showsPrec2 = showsPrecD showDict2 + +show2 :: Show2 a => a C(x y) -> String +show2 = showD showDict2 showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x . showString opstr . showsPrec2 (prec + 1) y -app_prec :: Int -app_prec = 10 +appPrec :: Int +appPrec = 10 diff -ruN darcs-2.4.4/src/Darcs/Witnesses/WZipper.hs darcs-2.5/src/Darcs/Witnesses/WZipper.hs --- darcs-2.4.4/src/Darcs/Witnesses/WZipper.hs 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/src/Darcs/Witnesses/WZipper.hs 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,77 @@ +-- Copyright (C) 2009 Florent Becker +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" +module Darcs.Witnesses.WZipper ( FZipper(..), focus, leftmost, left + , rightmost, right, jokers, clowns + , flToZipper, lengthFZ, nullFZ + , toEnd + ) +where +import Darcs.Witnesses.Ordered ( FL(..), RL(..), nullFL, nullRL + , lengthFL, lengthRL, (+<+) + , reverseFL + ) +import Darcs.Witnesses.Sealed(Sealed2(..), Sealed(..), FlippedSeal(..)) + +-- forward zipper +data FZipper a C(x z) where + FZipper :: RL a C(x y) -> FL a C(y z) -> FZipper a C(x z) + +-- Constructors +flToZipper :: FL a C(x y) -> FZipper a C(x y) +flToZipper l = FZipper NilRL l + +--destructors +nullFZ :: FZipper a C(x y) -> Bool +nullFZ (FZipper l r) = nullRL l && nullFL r + +lengthFZ :: FZipper a C(x y) -> Int +lengthFZ (FZipper l r) = lengthRL l + lengthFL r + +focus :: FZipper a C(x y) -> Maybe (Sealed2 a) +focus (FZipper _ (x :>: _)) = Just $ Sealed2 x +focus _ = Nothing + +clowns :: FZipper a C(x y) -> Sealed ((RL a) C(x)) +clowns (FZipper l _) = Sealed l + +jokers :: FZipper a C(x y) -> FlippedSeal (FL a) C(y) +jokers (FZipper _ r) = FlippedSeal r + +rightmost :: FZipper p C(x y) -> Bool +rightmost (FZipper _ NilFL) = True +rightmost _ = False + +right :: FZipper p C(x y) -> FZipper p C(x y) +right (FZipper l (b:>:r)) = FZipper (b :<: l) r +right x@(FZipper _ NilFL) = x + +leftmost :: FZipper p C(x y) -> Bool +leftmost (FZipper NilRL _) = True +leftmost _ = False + +left :: FZipper p C(x y) -> FZipper p C(x y) +left (FZipper (b :<: l) r) = FZipper l (b :>: r) +left x@(FZipper NilRL _) = x + +toEnd :: FZipper p C(x y) -> FZipper p C(x y) +toEnd (FZipper l r) = FZipper (reverseFL r +<+ l) NilFL + diff -ruN darcs-2.4.4/src/darcs.hs darcs-2.5/src/darcs.hs --- darcs-2.4.4/src/darcs.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/darcs.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,26 +20,24 @@ module Main (main) where -import System.IO ( hSetBinaryMode) -import System.IO ( stdin, stdout ) +import Prelude hiding ( catch ) + +import System.IO ( stdin, stdout, stderr, hSetBinaryMode ) +import Control.Monad ( forM_ ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs ) -import Control.Exception ( Exception( AssertionFailed ), handleJust, catchDyn ) +import Control.Exception.Extensible ( AssertionFailed(..), handle, catch ) -import Darcs.RunCommand ( run_the_command ) +import Darcs.RunCommand ( runTheCommand ) import Darcs.Flags ( DarcsFlag(Verbose) ) -import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion ) +import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion, commandControlList ) import Darcs.SignalHandler ( withSignalsHandled ) -import Version ( version, context ) -import Darcs.Global ( with_atexit ) -import Preproc( preproc_main ) +import Version ( version, context, builddeps ) +import Darcs.Global ( withAtexit ) +import Preproc( preprocMain ) import Exec ( ExecException(..) ) #include "impossible.h" -assertions :: Control.Exception.Exception -> Maybe String -assertions (AssertionFailed s) = Just s -assertions _ = Nothing - execExceptionHandler :: ExecException -> IO a execExceptionHandler (ExecException cmd args redirects reason) = do putStrLn $ "Failed to execute external command: " ++ unwords (cmd:args) ++ "\n" @@ -48,9 +46,9 @@ exitWith $ ExitFailure 3 main :: IO () -main = with_atexit $ withSignalsHandled $ - flip catchDyn execExceptionHandler $ - handleJust assertions bug $ do +main = withAtexit $ withSignalsHandled $ + flip catch execExceptionHandler $ + handle (\(AssertionFailed e) -> bug e) $ do argv <- getArgs case argv of -- User called "darcs" without arguments. @@ -65,9 +63,10 @@ ["--exact-version"] -> do putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__ putStrLn context - ("--preprocess-manual":rest) -> preproc_main rest + putStrLn $ "Compiled with:\n" + putStr builddeps + ("--preprocess-manual":rest) -> preprocMain rest -- User called a normal darcs command, "darcs foo [args]". _ -> do - hSetBinaryMode stdin True - hSetBinaryMode stdout True - run_the_command (head argv) (tail argv) + forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True + runTheCommand commandControlList (head argv) (tail argv) diff -ruN darcs-2.4.4/src/DateMatcher.hs darcs-2.5/src/DateMatcher.hs --- darcs-2.4.4/src/DateMatcher.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/DateMatcher.hs 2010-10-24 08:29:26.000000000 -0700 @@ -23,10 +23,12 @@ -- for debugging only , DateMatcher(..), getMatchers ) where -import Control.Exception ( catchJust, userErrors ) +import Prelude hiding ( catch ) +import Control.Exception.Extensible ( catch, throw ) +import System.IO.Error ( isUserError, ioeGetErrorString ) import Data.Maybe ( isJust ) import System.Time -import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast, iso8601_interval, +import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast, iso8601Interval, resetCalendar, subtractFromMCal, getLocalTz, MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime, unsetTime, @@ -107,7 +109,7 @@ -- | 'parseDateMatcher' @s@ return the first matcher in -- 'getMatchers' that can parse 's' parseDateMatcher :: String -> IO (CalendarTime -> Bool) -parseDateMatcher d = +parseDateMatcher d = do matcher <- tryMatchers `fmap` getMatchers d -- Hack: test the matcher against the current date and discard the results. -- We just want to make sure it won't throw any exceptions when we use it for real. @@ -119,7 +121,8 @@ then error "Can't handle dates that far back!" else error e where - catchUserError = catchJust userErrors + catchUserError comp handler + = catch comp (\e -> if isUserError e then handler (ioeGetErrorString e) else throw e) -- | 'getMatchers' @d@ returns the list of matchers that will be -- applied on @d@. If you wish to extend the date parsing code, @@ -144,7 +147,7 @@ (parseDateWith $ englishInterval rightNow) (uncurry cDateRange) , DM "ISO 8601 interval" - (parseDateWith $ iso8601_interval tzNow) + (parseDateWith $ iso8601Interval tzNow) matchIsoInterval , DM "CVS, ISO 8601, or old style date" (parseDate tzNow d) diff -ruN darcs-2.4.4/src/English.hs darcs-2.5/src/English.hs --- darcs-2.4.4/src/English.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/English.hs 2010-10-24 08:29:26.000000000 -0700 @@ -74,3 +74,7 @@ intersperseLast _ _ [clause] = clause intersperseLast sep sepLast clauses = concat (intersperse sep $ init clauses) ++ sepLast ++ last clauses + +presentParticiple :: String -> String +presentParticiple v | last v == 'e' = init v ++ "ing" + | otherwise = v ++ "ing" diff -ruN darcs-2.4.4/src/Exec.hs darcs-2.5/src/Exec.hs --- darcs-2.4.4/src/Exec.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Exec.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,21 +20,21 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} -- , DeriveDataTypeable #-} -module Exec ( exec, exec_interactive, +module Exec ( exec, execInteractive, withoutNonBlock, Redirects, Redirect(..), ExecException(..) ) where -import Data.Typeable ( Typeable ) +import Data.Typeable ( Typeable, cast ) #ifndef WIN32 -import Control.Exception ( bracket ) +import Control.Exception.Extensible ( bracket ) import System.Posix.Env ( setEnv, getEnv, unsetEnv ) import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput ) import System.IO ( stdin ) #else -import Control.Exception ( catchJust, Exception(IOException) ) +import Control.Exception.Extensible ( catchJust, IOException ) import Data.List ( isInfixOf ) #endif @@ -44,7 +44,7 @@ import System.Process ( runProcess, terminateProcess, waitForProcess ) import GHC.Handle ( hDuplicate ) -- urgh. hDuplicate isn't available from a standard place. -import Control.Exception ( bracketOnError ) +import Control.Exception.Extensible ( bracketOnError, Exception(..), SomeException(..) ) import Darcs.Global ( whenDebugMode ) import Progress ( withoutProgress ) @@ -81,12 +81,15 @@ data ExecException = ExecException String [String] Redirects String deriving (Typeable,Show) +instance Exception ExecException where + toException e = SomeException e + fromException (SomeException e) = cast e -_dev_null :: FilePath +_devNull :: FilePath #ifdef WIN32 -_dev_null = "NUL" +_devNull = "NUL" #else -_dev_null = "/dev/null" +_devNull = "/dev/null" #endif {- @@ -107,14 +110,14 @@ (waitForProcess) where redirect AsIs _ = return Nothing - redirect Null mode = Just `fmap` openBinaryFile _dev_null mode + redirect Null mode = Just `fmap` openBinaryFile _devNull mode redirect (File "/dev/null") mode = redirect Null mode redirect (File f) mode = Just `fmap` openBinaryFile f mode redirect Stdout _ = Just `fmap` hDuplicate stdout -- hDuplicate stdout rather than passing stdout itself, -- because runProcess closes the Handles we pass it. -exec_interactive :: String -> String -> IO ExitCode +execInteractive :: String -> String -> IO ExitCode #ifndef WIN32 {- @@ -123,7 +126,7 @@ the argument in any way, so we set an environment variable and call cmd "$DARCS_ARGUMENT" -} -exec_interactive cmd arg = withoutProgress $ do +execInteractive cmd arg = withoutProgress $ do let var = "DARCS_ARGUMENT" stdin `seq` return () withoutNonBlock $ bracket @@ -138,7 +141,7 @@ #else -exec_interactive cmd arg = withoutProgress $ do +execInteractive cmd arg = withoutProgress $ do system $ cmd ++ " " ++ arg #endif @@ -172,8 +175,8 @@ #ifdef WIN32 withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127) -notFoundError :: Exception -> Maybe () -notFoundError (IOException e) | "runProcess: does not exist" `isInfixOf` show e = Just () +notFoundError :: IOException -> Maybe () +notFoundError e | "runProcess: does not exist" `isInfixOf` show e = Just () notFoundError _ = Nothing #else withExit127 = id diff -ruN darcs-2.4.4/src/fpstring.c darcs-2.5/src/fpstring.c --- darcs-2.4.4/src/fpstring.c 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/fpstring.c 2010-10-24 08:29:26.000000000 -0700 @@ -20,6 +20,7 @@ #include #include + #ifdef _WIN32 #include #else @@ -65,3 +66,4 @@ return; } + diff -ruN darcs-2.4.4/src/fpstring.h darcs-2.5/src/fpstring.h --- darcs-2.4.4/src/fpstring.h 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/fpstring.h 2010-10-24 08:29:26.000000000 -0700 @@ -5,4 +5,3 @@ void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars); void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars); - diff -ruN darcs-2.4.4/src/hscurl.c darcs-2.5/src/hscurl.c --- darcs-2.4.4/src/hscurl.c 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/hscurl.c 2010-10-24 08:29:26.000000000 -0700 @@ -1,5 +1,3 @@ -#ifdef HAVE_CURL - #include "hscurl.h" #include @@ -8,6 +6,11 @@ #include #include +#if LIBCURL_VERSION_NUM >= 0x071301 +/* enable pipelining for libcurl >= 7.19.1 */ +#define ENABLE_PIPELINING +#endif + enum RESULT_CODES { RESULT_OK = 0, @@ -44,8 +45,14 @@ }; static int debug = 0; +#ifndef _WIN32 static const char user_agent[] = "darcs/" PACKAGE_VERSION " libcurl/" LIBCURL_VERSION; +#else +static const char user_agent[] = + "darcs/unknown libcurl/" LIBCURL_VERSION; +#endif + static const char *proxypass; static int init_done = 0; static CURLM *multi = NULL; @@ -133,7 +138,7 @@ multi = curl_multi_init(); if (multi == NULL) return error_strings[RESULT_MULTI_INIT_FAIL]; -#ifdef CURL_PIPELINING +#ifdef ENABLE_PIPELINING error = curl_multi_setopt(multi, CURLMOPT_PIPELINING, 1); if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM) return curl_multi_strerror(error); @@ -302,4 +307,11 @@ debug = 1; } +int curl_pipelining_enabled() +{ +#ifdef ENABLE_PIPELINING + return 1; +#else + return 0; #endif +} diff -ruN darcs-2.4.4/src/hscurl.h darcs-2.5/src/hscurl.h --- darcs-2.4.4/src/hscurl.h 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/hscurl.h 2010-10-24 08:29:26.000000000 -0700 @@ -7,3 +7,5 @@ const char *curl_last_url(); void curl_enable_debug(); + +int curl_pipelining_enabled(); diff -ruN darcs-2.4.4/src/HTTP.hs darcs-2.5/src/HTTP.hs --- darcs-2.4.4/src/HTTP.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/HTTP.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,9 +1,10 @@ {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} -module HTTP( fetchUrl, postUrl, request_url, wait_next_url ) where +module HTTP( fetchUrl, postUrl, requestUrl, waitNextUrl ) where import Darcs.Global ( debugFail ) +import Version ( version ) #ifdef HAVE_HTTP import Control.Monad ( when ) @@ -25,13 +26,13 @@ -> String -- ^ mime type -> IO () -- ^ result -request_url :: String -> FilePath -> a -> IO String -wait_next_url :: IO (String, String) +requestUrl :: String -> FilePath -> a -> IO String +waitNextUrl :: IO (String, String) #ifdef HAVE_HTTP headers :: [Header] -headers = [Header HdrUserAgent $ "darcs-HTTP/" ++ PACKAGE_VERSION] +headers = [Header HdrUserAgent $ "darcs-HTTP/" ++ version] fetchUrl url = case parseURI url of Nothing -> fail $ "Invalid URI: " ++ url @@ -75,14 +76,14 @@ requestedUrl :: IORef (String, FilePath) requestedUrl = unsafePerformIO $ newIORef ("", "") -request_url u f _ = do +requestUrl u f _ = do (u', _) <- readIORef requestedUrl if null u' then do writeIORef requestedUrl (u, f) return "" else return "URL already requested" -wait_next_url = do +waitNextUrl = do (u, f) <- readIORef requestedUrl if null u then return ("", "No URL requested") @@ -101,7 +102,7 @@ fetchUrl _ = debugFail "Network.HTTP does not exist" postUrl _ _ _ = debugFail "Cannot use http POST because darcs was not compiled with Network.HTTP." -request_url _ _ _ = debugFail "Network.HTTP does not exist" -wait_next_url = debugFail "Network.HTTP does not exist" +requestUrl _ _ _ = debugFail "Network.HTTP does not exist" +waitNextUrl = debugFail "Network.HTTP does not exist" #endif diff -ruN darcs-2.4.4/src/IsoDate.hs darcs-2.5/src/IsoDate.hs --- darcs-2.4.4/src/IsoDate.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/IsoDate.hs 2010-10-24 08:29:26.000000000 -0700 @@ -20,7 +20,7 @@ module IsoDate ( getIsoDateTime, readLocalDate, readUTCDate, parseDate, getLocalTz, englishDateTime, englishInterval, englishLast, - iso8601_interval, iso8601_duration, + iso8601Interval, iso8601Duration, cleanLocalDate, resetCalendar, MCalendarTime(..), subtractFromMCal, addToMCal, toMCalendarTime, unsafeToCalendarTime, @@ -71,7 +71,7 @@ -- | Parse a date string, assuming a default timezone if -- the date string does not specify one. The date formats --- understood are those of 'showIsoDateTime' and 'date_time' +-- understood are those of 'showIsoDateTime' and 'dateTime' parseDate :: Int -> String -> Either ParseError MCalendarTime parseDate tz d = if length d >= 14 && B.all isDigit bd @@ -84,7 +84,7 @@ (readI $ B.take 2 $ B.drop 12 bd) -- Second 0 Sunday 0 -- Picosecond, weekday and day of year unknown "GMT" 0 False - else let dt = do { x <- date_time tz; eof; return x } + else let dt = do { x <- dateTime tz; eof; return x } in parse dt "" d where bd = B.pack (take 14 d) readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s) @@ -138,54 +138,54 @@ -- | Try each of these date parsers in the following order -- --- (1) 'cvs_date_time' +-- (1) 'cvsDateTime' -- --- (2) 'iso8601_date_time' +-- (2) 'iso8601DateTime' -- --- (3) 'old_date_time -date_time :: Int -> CharParser a MCalendarTime -date_time tz = - choice [try $ toMCalendarTime `fmap` cvs_date_time tz, - try $ iso8601_date_time tz, - toMCalendarTime `fmap` old_date_time] +-- (3) 'oldDateTime +dateTime :: Int -> CharParser a MCalendarTime +dateTime tz = + choice [try $ toMCalendarTime `fmap` cvsDateTime tz, + try $ iso8601DateTime tz, + toMCalendarTime `fmap` oldDateTime] -- | CVS-style date/times, e.g. -- 2007/08/25 14:25:39 GMT -- Note that time-zones are optional here. -cvs_date_time :: Int -> CharParser a CalendarTime -cvs_date_time tz = +cvsDateTime :: Int -> CharParser a CalendarTime +cvsDateTime tz = do y <- year char '/' - mon <- month_num + mon <- monthNum char '/' d <- day - my_spaces + mySpaces h <- hour char ':' m <- minute char ':' s <- second - z <- option tz $ my_spaces >> zone + z <- option tz $ mySpaces >> zone return (CalendarTime y mon d h m s 0 Monday 0 "" z False) -- | \"Old\"-style dates, e.g. -- Tue Jan 3 14:08:07 EST 1999 -- darcs-doc: Question (what does the "old" stand for really?) -old_date_time :: CharParser a CalendarTime -old_date_time = do wd <- day_name - my_spaces - mon <- month_name - my_spaces +oldDateTime :: CharParser a CalendarTime +oldDateTime = do wd <- dayName + mySpaces + mon <- monthName + mySpaces d <- day - my_spaces + mySpaces h <- hour char ':' m <- minute char ':' s <- second - my_spaces + mySpaces z <- zone - my_spaces + mySpaces y <- year return (CalendarTime y mon d h m s 0 wd 0 "" z False) @@ -195,7 +195,7 @@ -- -- * years > 9999 -- --- * truncated representations with implied century (89 for 1989) +-- * truncated representations with implied century (89 for 1989) -- -- I have not implemented: -- @@ -209,17 +209,17 @@ -- -- * the difference between 24h and 0h -- --- * allows stuff like 2005-1212; either you use the hyphen all the way +-- * allows stuff like 2005-1212; either you use the hyphen all the way -- (2005-12-12) or you don't use it at all (20051212), but you don't use -- it halfway, likewise with time -- -- * No bounds checking whatsoever on intervals! -- (next action: read iso doc to see if bounds-checking required?) -} -iso8601_date_time :: Int -> CharParser a MCalendarTime -iso8601_date_time localTz = try $ - do d <- iso8601_date - t <- option id $ try $ do optional $ oneOf " T" - iso8601_time +iso8601DateTime :: Int -> CharParser a MCalendarTime +iso8601DateTime localTz = try $ + do d <- iso8601Date + t <- option id $ try $ do optional $ oneOf " T" + iso8601Time return $ t $ d { mctTZ = Just localTz } -- | Three types of ISO 8601 date: @@ -229,14 +229,14 @@ -- * week+day in year, e.g., 1997-W32-4 -- -- * day in year, e.g, 1997-273 -iso8601_date :: CharParser a MCalendarTime -iso8601_date = +iso8601Date :: CharParser a MCalendarTime +iso8601Date = do d <- calendar_date <|> week_date <|> ordinal_date return $ foldr ($) nullMCalendar d - where + where calendar_date = -- yyyy-mm-dd try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ] - -- allow other variants to be parsed correctly + -- allow other variants to be parsed correctly notFollowedBy (digit <|> char 'W') return d week_date = --yyyy-Www-d @@ -244,8 +244,8 @@ optional dash char 'W' -- offset human 'week 1' -> computer 'week 0' - w' <- (\x -> x-1) `liftM` two_digits - mwd <- option Nothing $ do { optional dash; Just `fmap` n_digits 1 } + w' <- (\x -> x-1) `liftM` twoDigits + mwd <- option Nothing $ do { optional dash; Just `fmap` nDigits 1 } let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 } firstDay = ctWDay y -- things that make this complicated @@ -263,33 +263,33 @@ ordinal_date = -- yyyy-ddd try $ optchain year_ [ (dash, yearDay_) ] -- - year_ = try $ do y <- four_digits "year (0000-9999)" + year_ = try $ do y <- fourDigits "year (0000-9999)" return $ \c -> c { mctYear = Just y } - month_ = try $ do m <- two_digits "month (1 to 12)" + month_ = try $ do m <- twoDigits "month (1 to 12)" return $ \c -> c { mctMonth = Just $ intToMonth m } - day_ = try $ do d <- two_digits "day in month (1 to 31)" + day_ = try $ do d <- twoDigits "day in month (1 to 31)" return $ \c -> c { mctDay = Just d } - yearDay_ = try $ do d <- n_digits 3 "day in year (001 to 366)" + yearDay_ = try $ do d <- nDigits 3 "day in year (001 to 366)" return $ \c -> c { mctDay = Just d , mctYDay = Just (d - 1) } dash = char '-' -- | Note that this returns a function which sets the time on --- another calendar (see 'iso8601_date_time' for a list of +-- another calendar (see 'iso8601DateTime' for a list of -- flaws -iso8601_time :: CharParser a (MCalendarTime -> MCalendarTime) -iso8601_time = try $ +iso8601Time :: CharParser a (MCalendarTime -> MCalendarTime) +iso8601Time = try $ do ts <- optchain hour_ [ (colon , min_) , (colon , sec_) - , (oneOf ",.", pico_) ] + , (oneOf ",.", pico_) ] z <- option id $ choice [ zulu , offset ] return $ foldr (.) id (z:ts) - where - hour_ = do h <- two_digits + where + hour_ = do h <- twoDigits return $ \c -> c { mctHour = Just h } - min_ = do m <- two_digits + min_ = do m <- twoDigits return $ \c -> c { mctMin = Just m } - sec_ = do s <- two_digits + sec_ = do s <- twoDigits return $ \c -> c { mctSec = Just s } pico_ = do digs <- many digit let picoExp = 12 @@ -301,8 +301,8 @@ zulu = do { char 'Z'; return (\c -> c { mctTZ = Just 0 }) } offset = do sign <- choice [ do { char '+' >> return 1 } , do { char '-' >> return (-1) } ] - h <- two_digits - m <- option 0 $ do { optional colon; two_digits } + h <- twoDigits + m <- option 0 $ do { optional colon; twoDigits } return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) } colon = char ':' @@ -314,24 +314,24 @@ -- -- * P2Y11MT16H30M/2012-08-17T16:30 -- --- See 'iso8601_duration' -iso8601_interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime)) -iso8601_interval localTz = leftDur <|> rightDur where - leftDur = - do dur <- iso8601_duration +-- See 'iso8601Duration' +iso8601Interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime)) +iso8601Interval localTz = leftDur <|> rightDur where + leftDur = + do dur <- iso8601Duration end <- option Nothing $ do { char '/'; Just `liftM` isoDt } - return $ case end of + return $ case end of Nothing -> Left dur Just e -> Right (dur `subtractFromMCal` e, e) rightDur = do start <- isoDt char '/' - durOrEnd <- Left `liftM` iso8601_duration <|> Right `liftM` isoDt + durOrEnd <- Left `liftM` iso8601Duration <|> Right `liftM` isoDt return $ case durOrEnd of Left dur -> Right (start, dur `addToMCal` start) Right end -> Right (start, end) - isoDt = iso8601_date_time localTz - + isoDt = iso8601DateTime localTz + -- | Durations in ISO 8601, e.g., -- -- * P4Y (four years) @@ -341,19 +341,19 @@ -- * P4Y5M (four years and five months) -- -- * P4YT3H6S (four years, three hours and six seconds) -iso8601_duration :: CharParser a TimeDiff -iso8601_duration = +iso8601Duration :: CharParser a TimeDiff +iso8601Duration = do char 'P' y <- block 0 'Y' mon <- block 0 'M' d <- block 0 'D' - (h,m,s) <- option (0,0,0) $ + (h,m,s) <- option (0,0,0) $ do char 'T' h' <- block (-1) 'H' m' <- block (-1) 'M' s' <- block (-1) 'S' let unset = (== (-1)) - if all unset [h',m',s'] + if all unset [h',m',s'] then fail "T should be omitted if time is unspecified" else let clear x = if (unset x) then 0 else x in return (clear h', clear m', clear s') @@ -361,7 +361,7 @@ return $ TimeDiff y mon d h m s 0 where block d c = option d $ try $ do n <- many1 digit - char c + char c return $ read n -- | 'optchain' @p xs@ parses a string with the obligatory @@ -378,29 +378,29 @@ -- the year and month), 200707 (only the year and month -- with no separator), 2007-07-19 (year, month and day). optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b] -optchain p next = try $ +optchain p next = try $ do r1 <- p - r2 <- case next of + r2 <- case next of [] -> return [] ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 } return (r1:r2) -n_digits :: Int -> CharParser a Int -n_digits n = read `liftM` count n digit +nDigits :: Int -> CharParser a Int +nDigits n = read `liftM` count n digit -two_digits, four_digits :: CharParser a Int -two_digits = n_digits 2 -four_digits = n_digits 4 +twoDigits, fourDigits :: CharParser a Int +twoDigits = nDigits 2 +fourDigits = nDigits 4 -- | One or more space. -- WARNING! This only matches on the space character, not on -- whitespace in general -my_spaces :: CharParser a String -my_spaces = manyN 1 $ char ' ' +mySpaces :: CharParser a String +mySpaces = manyN 1 $ char ' ' -- | English three-letter day abbreviations (e.g. Mon, Tue, Wed) -day_name :: CharParser a Day -day_name = choice +dayName :: CharParser a Day +dayName = choice [ caseString "Mon" >> return Monday , try (caseString "Tue") >> return Tuesday , caseString "Wed" >> return Wednesday @@ -412,11 +412,11 @@ -- | Four-digit year year :: CharParser a Int -year = four_digits +year = fourDigits -- | One or two digit month (e.g. 3 for March, 11 for November) -month_num :: CharParser a Month -month_num = do mn <- manyNtoM 1 2 digit +monthNum :: CharParser a Month +monthNum = do mn <- manyNtoM 1 2 digit return $ intToMonth $ (read mn :: Int) -- | January is 1, February is 2, etc @@ -436,8 +436,8 @@ intToMonth _ = error "invalid month!" -- | English three-letter month abbreviations (e.g. Jan, Feb, Mar) -month_name :: CharParser a Month -month_name = choice +monthName :: CharParser a Month +monthName = choice [ try (caseString "Jan") >> return January , caseString "Feb" >> return February , try (caseString "Mar") >> return March @@ -459,15 +459,15 @@ -- | hour in two-digit notation hour :: CharParser a Int -hour = two_digits +hour = twoDigits -- | minute in two-digit notation minute :: CharParser a Int -minute = two_digits +minute = twoDigits -- | second in two-digit notation second :: CharParser a Int -second = two_digits +second = twoDigits -- | limited timezone support -- @@ -552,18 +552,18 @@ -- Uses its first argument as "now", i.e. the time relative to which -- "yesterday", "today" etc are to be interpreted englishDateTime :: CalendarTime -> CharParser a CalendarTime -englishDateTime now = - try $ dateMaybeAtTime <|> timeThenDate - where +englishDateTime now = + try $ dateMaybeAtTime <|> timeThenDate + where -- yesterday (at) noon - dateMaybeAtTime = try $ + dateMaybeAtTime = try $ do ed <- englishDate now t <- option Nothing $ try $ do { space; optional $ caseString "at "; Just `liftM` englishTime } return $ fromMaybe id t $ ed -- tea time 2005-12-04 timeThenDate = try $ - do t <- englishTime + do t <- englishTime optional $ char ',' space ed <- englishDate now @@ -581,7 +581,7 @@ -- -- The first argument is "now". englishDate :: CalendarTime -> CharParser a CalendarTime -englishDate now = try $ +englishDate now = try $ (caseString "today" >> (return $ resetCalendar now)) <|> (caseString "yesterday" >> (return $ oneDay `subtractFromCal` now) ) <|> fst `fmap` englishLast now @@ -606,7 +606,7 @@ space d <- englishDate now <|> fst `fmap` englishLast now - <|> unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now) + <|> unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now) return (m,d) return $ multiplyDiff m p `addToCal` ref where @@ -626,27 +626,27 @@ -- * 4 months ago (i.e. till now; see 'englishAgo') englishInterval :: CalendarTime -> CharParser a TimeInterval englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc - where - englishDT = (unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now) + where + englishDT = (unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now) <|> englishDateTime now) before = try $ do caseString "before" space - end <- englishDT + end <- englishDT return (Just theBeginning, Just end) after = try $ do caseString "after" space start <- englishDT return (Just start, Nothing) - twixt = try $ + twixt = try $ do caseString "between" space start <- englishDT space - caseString "and" + caseString "and" space - end <- englishDT + end <- englishDT return (Just start, Just end) inTheLast = try $ do caseString "in the last" @@ -668,17 +668,17 @@ d <- englishDuration return (d `subtractFromCal` now, now) --- | Either an 'iso8601_time' or one of several common +-- | Either an 'iso8601Time' or one of several common -- English time expressions like 'noon' or 'tea time' englishTime :: CharParser a (CalendarTime->CalendarTime) -englishTime = try $ - choice [ wrapM `fmap` iso8601_time - , namedTime "noon" 12 0 +englishTime = try $ + choice [ wrapM `fmap` iso8601Time + , namedTime "noon" 12 0 , namedTime "midnight" 0 0 , namedTime "tea time" 16 30 - , namedTime "bed time" 2 30 + , namedTime "bed time" 2 30 , namedTime "proper bed time" 21 30 ] - where namedTime name h m = try $ + where namedTime name h m = try $ do caseString name return $ \c -> c { ctHour = h, ctMin = m } wrapM f = unsafeToCalendarTime . f . toMCalendarTime @@ -702,11 +702,11 @@ b <- base optional (caseString "es" <|> caseString "s") let current = multiplyDiff n b - next <- option noTimeDiff $ try $ do + next <- option noTimeDiff $ try $ do { optional space; char ',' ; optional space ; englishDuration } - return $ addDiff current next - where - base = choice + return $ addDiff current next + where + base = choice [ try $ caseString "score" >> (return $ TimeDiff 20 0 0 0 0 0 0) -- why not? , caseString "year" >> (return $ TimeDiff 1 0 0 0 0 0 0) , try $ caseString "month" >> (return $ TimeDiff 0 1 0 0 0 0 0) @@ -714,9 +714,9 @@ , caseString "week" >> (return $ TimeDiff 0 0 7 0 0 0 0) , caseString "day" >> (return $ TimeDiff 0 0 1 0 0 0 0) , caseString "hour" >> (return $ TimeDiff 0 0 0 1 0 0 0) - , caseString "minute" >> (return $ TimeDiff 0 0 0 0 1 0 0) + , caseString "minute" >> (return $ TimeDiff 0 0 0 0 1 0 0) , caseString "second" >> (return $ TimeDiff 0 0 0 0 0 1 0) ] - + ----- Calendar and TimeDiff manipulation --------------------------------------------- -- | The very beginning of time, i.e. 1970-01-01 diff -ruN darcs-2.4.4/src/Lcs.hs darcs-2.5/src/Lcs.hs --- darcs-2.4.4/src/Lcs.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Lcs.hs 2010-10-24 08:29:26.000000000 -0700 @@ -196,7 +196,7 @@ (xmid, ymid, _) <- findDiag 1 h_a h_b p_a p_b m_a m_b v vrev off_a' off_b' l_a' l_b' del dodd when ((xmid == 0 && ymid == 0) || (xmid == l_a' && ymid == l_b') - || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b')) + || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b')) impossible c1 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b off_a' off_b' xmid ymid @@ -246,7 +246,7 @@ -- | find position on diag d with one more insert/delete going forward findOne :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray - -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int + -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b = do x0 <- do xbelow <- readArray v (d - 1) xover <- readArray v (d + 1) @@ -268,7 +268,7 @@ -- | find position on diag d with one more insert/delete going backward findOneRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray - -> VSTArray s -> Int -> Int -> Int -> Int -> ST s Int + -> VSTArray s -> Int -> Int -> Int -> Int -> ST s Int findOneRev h_a h_b p_a p_b m_a m_b v d del off_a off_b = do x0 <- do xbelow <- readArray v (d - 1) xover <- readArray v (d + 1) @@ -359,7 +359,7 @@ when ((not b1) || b2) impossible when (p_a!(i-1) /= p_a!(start-1)) impossible writeArray c_a (i-1) False - writeArray c_a (start-1) True + writeArray c_a (start-1) True j' <- prevUnchanged c_b (j-1) moveCorr (start-1) (i-1) j' corr diff -ruN darcs-2.4.4/src/Preproc.hs darcs-2.5/src/Preproc.hs --- darcs-2.4.4/src/Preproc.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Preproc.hs 2010-10-24 08:29:26.000000000 -0700 @@ -12,7 +12,7 @@ -- * Some nonstandard pseudo-LaTeX commands are expanded into actual -- LaTeX text. In particular, \\darcsCommand{foo} is replaced by -- LaTeX markup describing the command @foo@. -module Preproc ( preproc_main ) where +module Preproc ( preprocMain ) where import qualified Ratified( readFile ) import System.FilePath ( () ) import System.Environment ( getArgs ) @@ -29,15 +29,15 @@ import English ( andClauses ) import Version ( version ) -the_commands :: [DarcsCommand] -the_commands = extractCommands commandControlList +theCommands :: [DarcsCommand] +theCommands = extractCommands commandControlList -- | The entry point for this program. The path to the TeX master -- file is supplied as the first argument. Bootstrapping into -- 'preproc' then happens by passing it a pseudo-document that -- contains a single input (include) line. -preproc_main :: [String] -> IO () -preproc_main args = do +preprocMain :: [String] -> IO () +preprocMain args = do if length args < 1 then exitWith $ ExitFailure 1 else return () @@ -48,9 +48,9 @@ -- | Depending on whether pdflatex or htlatex is to be used, the LaTeX -- output of this program must vary subtly. This procedure returns -- true iff the command-line arguments contain @--html@. -am_html :: IO Bool -am_html = do args <- getArgs - return $ elem "--html" args +amHtml :: IO Bool +amHtml = do args <- getArgs + return $ elem "--html" args -- | Given a list of input lines in pseudo-LaTeX, return the same -- document in LaTeX. The pseudo-LaTeX lines are replaced, other @@ -59,7 +59,7 @@ preproc [] = return [] -- Empty input, empty output. preproc ("\\usepackage{html}":ss) = -- only use html package with latex2html do rest <- preproc ss - ah <- am_html + ah <- amHtml if ah then return $ "\\usepackage{html}" : rest else return $ "\\usepackage{hyperref}" : rest preproc ("\\begin{code}":ss) = ignore ss @@ -69,13 +69,13 @@ ignore [] = return [] preproc ("\\begin{options}":ss) = do rest <- preproc ss - ah <- am_html + ah <- amHtml if ah then return $ "\\begin{rawhtml}" : "
" : rest else return $ ("\\begin{Verbatim}[frame=lines,xleftmargin=1cm," ++ "xrightmargin=1cm]") : rest preproc ("\\end{options}":ss) = do rest <- preproc ss - ah <- am_html + ah <- amHtml if ah then return $ "
" : "\\end{rawhtml}" : rest else return $ "\\end{Verbatim}" : rest preproc ("\\darcsVersion":ss) = do @@ -101,36 +101,36 @@ latexCommandHelp :: String -> String latexCommandHelp command = section ++ "{darcs " ++ command ++ "}\n" ++ "\\label{" ++ command ++ "}\n" ++ - gh ++ get_options command ++ gd + gh ++ getOptions command ++ gd where section = if ' ' `elem` command then "\\subsubsection" else "\\subsection" -- | Given a Darcs command name as a string, return that command's (multi-line) help string. gh :: String - gh = escape_latex_specials $ command_property commandHelp the_commands command + gh = escapeLatexSpecials $ commandProperty commandHelp theCommands command -- | Given a Darcs command name as a string, return that command's (one-line) description string. gd :: String - gd = command_property commandDescription the_commands command + gd = commandProperty commandDescription theCommands command -get_options :: String -> String -get_options comm = get_com_options $ get_c names the_commands +getOptions :: String -> String +getOptions comm = getComOptions $ getC names theCommands where names = words comm -get_c :: [String] -> [DarcsCommand] -> [DarcsCommand] -get_c (name:ns) commands = +getC :: [String] -> [DarcsCommand] -> [DarcsCommand] +getC (name:ns) commands = case ns of [] -> [get name commands] _ -> case get name commands of c@SuperCommand { } -> - c:(get_c ns $ extractCommands $ commandSubCommands c) + c:(getC ns $ extractCommands $ commandSubCommands c) _ -> error $ "Not a supercommand: " ++ name where get n (c:cs) | commandName c == n = c | otherwise = get n cs get n [] = error $ "No such command: "++n -get_c [] _ = error "no command specified" +getC [] _ = error "no command specified" -get_com_options :: [DarcsCommand] -> String -get_com_options c = +getComOptions :: [DarcsCommand] -> String +getComOptions c = "\\par\\verb!Usage: darcs " ++ cmd ++ " [OPTION]... " ++ args ++ "!\n\n" ++ "Options:\n\n" ++ optionsLatex opts1 ++ (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ optionsLatex opts2) @@ -139,21 +139,21 @@ opts1 = commandBasicOptions $ last c opts2 = commandAdvancedOptions $ last c -command_property :: (DarcsCommand -> String) -> [DarcsCommand] -> String +commandProperty :: (DarcsCommand -> String) -> [DarcsCommand] -> String -> String -command_property property commands name = +commandProperty property commands name = property $ last c where names = words name - c = get_c names commands + c = getC names commands envHelp :: String -> String envHelp var = unlines $ render $ entry environmentHelp where render (ks, ds) = - ("\\paragraph{" ++ escape_latex_specials (andClauses ks) ++ "}") : + ("\\paragraph{" ++ escapeLatexSpecials (andClauses ks) ++ "}") : ("\\label{env:" ++ var ++ "}") : - map escape_latex_specials ds + map escapeLatexSpecials ds entry [] = undefined entry (x:xs) | elem var $ fst x = x | otherwise = entry xs @@ -161,9 +161,9 @@ -- | LaTeX treats a number of characters or sequences specially. -- Therefore when including ordinary help text in a LaTeX document, it -- is necessary to escape these characters in the way LaTeX expects. -escape_latex_specials :: String -> String +escapeLatexSpecials :: String -> String -- Order is important -escape_latex_specials = +escapeLatexSpecials = (bs2 . amp . percent . carrot . dollar . underscore . rbrace . lbrace . bs1) where amp = replace "&" "\\&" diff -ruN darcs-2.4.4/src/Printer.lhs darcs-2.5/src/Printer.lhs --- darcs-2.4.4/src/Printer.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Printer.lhs 2010-10-24 08:29:26.000000000 -0700 @@ -43,9 +43,9 @@ hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith, renderString, renderStringWith, renderPS, renderPSWith, renderPSs, renderPSsWith, lineColor, - prefix, insert_before_lastline, colorText, invisibleText, + prefix, insertBeforeLastline, colorText, invisibleText, hiddenText, hiddenPrefix, userchunk, text, - printable, wrap_text, + printable, wrapText, blueText, redText, greenText, magentaText, cyanText, unsafeText, unsafeBoth, unsafeBothText, unsafeChar, invisiblePS, packedString, unsafePackedString, userchunkPS, @@ -68,13 +68,13 @@ | PS !B.ByteString | Both !String !B.ByteString --- | 'space_p' is the 'Printable' representation of a space. -space_p :: Printable -space_p = Both " " (BC.singleton ' ') - --- | 'newline_p' is the 'Printable' representation of a newline. -newline_p :: Printable -newline_p = S "\n" +-- | 'spaceP' is the 'Printable' representation of a space. +spaceP :: Printable +spaceP = Both " " (BC.singleton ' ') + +-- | 'newlineP' is the 'Printable' representation of a newline. +newlineP :: Printable +newlineP = S "\n" -- | Minimal 'Doc's representing the common characters 'space', 'newline' -- 'minus', 'plus', and 'backslash'. @@ -154,7 +154,7 @@ -- | The State associated with a doc. Contains a set of printers for each -- hanlde, and the current prefix of the document. data St = St { printers :: !Printers', - current_prefix :: !([Printable] -> [Printable]) } + currentPrefix :: !([Printable] -> [Printable]) } type Printers = Handle -> Printers' -- | A set of printers to print different types of text to a handle. @@ -214,24 +214,24 @@ -- printers. Each item of the list corresponds to a string that was -- added to the doc. renderWith :: Printers' -> Doc -> [Printable] -renderWith ps (Doc d) = case d (init_state ps) of +renderWith ps (Doc d) = case d (initState ps) of Empty -> [] Document f -> f [] -init_state :: Printers' -> St -init_state prs = St { printers = prs, current_prefix = id } +initState :: Printers' -> St +initState prs = St { printers = prs, currentPrefix = id } prefix :: String -> Doc -> Doc prefix s (Doc d) = Doc $ \st -> let p = S s - st' = st { current_prefix = current_prefix st . (p:) } in + st' = st { currentPrefix = currentPrefix st . (p:) } in case d st' of Document d'' -> Document $ (p:) . d'' Empty -> Empty - -insert_before_lastline :: Doc -> Doc -> Doc -insert_before_lastline a b = + +insertBeforeLastline :: Doc -> Doc -> Doc +insertBeforeLastline a b = case reverse $ map packedString $ linesPS $ renderPS a of (ll:ls) -> vcat (reverse ls) $$ b $$ ll [] -> error "empty Doc given as first argument of Printer.insert_before_last_line" @@ -245,7 +245,7 @@ hiddenPrefix s (Doc d) = Doc $ \st -> let pr = printers st p = S (renderStringWith pr $ hiddenText s) - st' = st { current_prefix = current_prefix st . (p:) } + st' = st { currentPrefix = currentPrefix st . (p:) } in case d st' of Document d'' -> Document $ (p:) . d'' Empty -> Empty @@ -304,9 +304,9 @@ colorText :: Color -> String -> Doc colorText c = mkColorPrintable c . S --- | @'wrap_text' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters -wrap_text :: Int -> String -> Doc -wrap_text n s = +-- | @'wrapText' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters +wrapText :: Int -> String -> Doc +wrapText n s = vcat $ map text $ reverse $ "": (foldl add_to_line [] $ words s) where add_to_line [] a = [a] add_to_line ("":d) a = (a:d) @@ -393,7 +393,7 @@ Document af -> Document (\s -> af $ case b st of Empty -> s Document bf -> - space_p:bf s) + spaceP:bf s) -- a above b Doc a $$ Doc b = @@ -402,8 +402,8 @@ Document af -> Document (\s -> af $ case b st of Empty -> s - Document bf -> sf (newline_p:pf (bf s))) - where pf = current_prefix st + Document bf -> sf (newlineP:pf (bf s))) + where pf = currentPrefix st sf = lineColorS $ printers st -- | 'vcat' piles vertically a list of 'Doc's. diff -ruN darcs-2.4.4/src/Progress.hs darcs-2.5/src/Progress.hs --- darcs-2.4.4/src/Progress.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Progress.hs 2010-10-24 08:29:26.000000000 -0700 @@ -11,9 +11,9 @@ finishedOneIO, progressList, minlist, setProgressMode) where -import Prelude hiding (lookup, catch) +import Prelude hiding (lookup) -import Control.Exception ( catch, throw ) +import Control.Exception.Extensible ( onException ) import Control.Monad ( when ) import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn, hSetBuffering, hIsTerminalDevice, @@ -172,7 +172,7 @@ withoutProgress :: IO a -> IO a withoutProgress j = withProgressMode $ \m -> do debugMessage "Disabling progress reports..." setProgressMode False - a <- j `catch` \e -> setProgressMode m >> throw e + a <- j `onException` setProgressMode m if m then debugMessage "Reenabling progress reports." else debugMessage "Leaving progress reports off." setProgressMode m diff -ruN darcs-2.4.4/src/SHA1.hs darcs-2.5/src/SHA1.hs --- darcs-2.4.4/src/SHA1.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/SHA1.hs 2010-10-24 08:29:26.000000000 -0700 @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-name-shadowing -cpp #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE CPP #-} @@ -40,52 +40,52 @@ sha1PS :: B.ByteString -> String sha1PS s = s5 - where s1_2 = sha1_step_1_2_pad_length s - abcde = sha1_step_3_init + where s1_2 = sha1Step12PadLength s + abcde = sha1Step3Init abcde' = unsafePerformIO $ unsafeWithInternals s1_2 (\ptr len -> do let ptr' = castPtr ptr #ifndef BIGENDIAN - fiddle_endianness ptr' len + fiddleEndianness ptr' len #endif - sha1_step_4_main abcde ptr' len) - s5 = sha1_step_5_display abcde' + sha1Step4Main abcde ptr' len) + s5 = sha1Step5Display abcde' -fiddle_endianness :: Ptr Word32 -> Int -> IO () -fiddle_endianness p 0 = p `seq` return () -fiddle_endianness p n +fiddleEndianness :: Ptr Word32 -> Int -> IO () +fiddleEndianness p 0 = p `seq` return () +fiddleEndianness p n = do x <- peek p poke p $ shiftL x 24 .|. shiftL (x .&. 0xff00) 8 .|. (shiftR x 8 .&. 0xff00) .|. shiftR x 24 - fiddle_endianness (p `advancePtr` 1) (n - 4) + fiddleEndianness (p `advancePtr` 1) (n - 4) --- sha1_step_1_2_pad_length assumes the length is at most 2^61. +-- sha1Step12PadLength assumes the length is at most 2^61. -- This seems reasonable as the Int used to represent it is normally 32bit, -- but obviously could go wrong with large inputs on 64bit machines. -- The B.ByteString library should probably move to Word64s if this is an -- issue, though. -sha1_step_1_2_pad_length :: B.ByteString -> B.ByteString -sha1_step_1_2_pad_length s +sha1Step12PadLength :: B.ByteString -> B.ByteString +sha1Step12PadLength s = let len = B.length s num_nuls = (55 - len) `mod` 64 padding = 128:replicate num_nuls 0 - len_w8s = reverse $ size_split 8 (fromIntegral len*8) + len_w8s = reverse $ sizeSplit 8 (fromIntegral len*8) in B.concat [s, B.pack padding, B.pack len_w8s] -size_split :: Int -> Integer -> [Word8] -size_split 0 _ = [] -size_split p n = fromIntegral d:size_split (p-1) n' +sizeSplit :: Int -> Integer -> [Word8] +sizeSplit 0 _ = [] +sizeSplit p n = fromIntegral d:sizeSplit (p-1) n' where (n', d) = divMod n 256 -sha1_step_3_init :: ABCDE -sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 +sha1Step3Init :: ABCDE +sha1Step3Init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 -sha1_step_4_main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE -sha1_step_4_main abcde _ 0 = return $! abcde -sha1_step_4_main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len +sha1Step4Main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE +sha1Step4Main abcde _ 0 = return $! abcde +sha1Step4Main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len = do (e, b) <- doit f1 0x5a827999 (x 0) a b c d e (d, a) <- doit f1 0x5a827999 (x 1) e a b c d @@ -168,7 +168,7 @@ (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e) - sha1_step_4_main abcde' (s `advancePtr` 16) (len - 64) + sha1Step4Main abcde' (s `advancePtr` 16) (len - 64) where {-# INLINE f1 #-} f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z) {-# INLINE f2 #-} @@ -192,8 +192,8 @@ return (rotateL a 5 + f (XYZ b c d) + e + i' + k, rotateL b 30) -sha1_step_5_display :: ABCDE -> String -sha1_step_5_display (ABCDE a b c d e) +sha1Step5Display :: ABCDE -> String +sha1Step5Display (ABCDE a b c d e) = concatMap showAsHex [a, b, c, d, e] showAsHex :: Word32 -> String diff -ruN darcs-2.4.4/src/Ssh.hs darcs-2.5/src/Ssh.hs --- darcs-2.4.4/src/Ssh.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/Ssh.hs 2010-10-24 08:29:26.000000000 -0700 @@ -22,13 +22,14 @@ import Control.Monad ( when ) import System.Process ( runInteractiveProcess ) +import Data.List ( isPrefixOf ) import Data.Map ( Map, empty, insert, lookup ) import Data.IORef ( IORef, newIORef, readIORef, modifyIORef ) import Darcs.SignalHandler ( catchNonSignal ) import Darcs.Utils ( withCurrentDirectory, breakCommand, prettyException, catchall ) import Darcs.Global ( atexit, sshControlMasterDisabled, darcsdir, withDebugMode ) -import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist ) +import Darcs.Lock ( withTemp, withOpenTemp, tempdirLoc, removeFileMayNotExist ) import Exec ( exec, Redirects, Redirect(..), ) import Progress ( withoutProgress, debugMessage, debugFail, progressList ) @@ -85,7 +86,7 @@ modifyIORef sshConnections (insert (cleanrepourl x) Nothing) cleanrepourl :: String -> String -cleanrepourl zzz | take (length dd) zzz == dd = "" +cleanrepourl zzz | dd `isPrefixOf` zzz = "" where dd = darcsdir++"/" cleanrepourl (z:zs) = z : cleanrepourl zs cleanrepourl "" = "" @@ -97,7 +98,7 @@ grabSSH x c = do let dir = drop 1 $ dropWhile (/= ':') x dd = darcsdir++"/" - clean zzz | take (length dd) zzz == dd = drop (length dd) zzz + clean zzz | dd `isPrefixOf` zzz = drop (length dd) zzz clean (_:zs) = clean zs clean "" = bug $ "Buggy path in grabSSH: "++x file = clean dir @@ -159,7 +160,7 @@ then (take 5 ns) ++ ["and " ++ (show (length ns - 5)) ++ " more"] else ns - hint = if take 1 path == "~" + hint = if "~" `isPrefixOf` path then ["sftp doesn't expand ~, use path/ instead of ~/path/"] else [] when (r /= ExitSuccess) $ do @@ -310,7 +311,7 @@ -> IO FilePath controlMasterPath rawAddr = do let addr = takeWhile (/= ':') rawAddr - tmp <- (fmap (/// ".darcs") $ getEnv "HOME") `catchall` tempdir_loc + tmp <- (fmap (/// ".darcs") $ getEnv "HOME") `catchall` tempdirLoc #ifdef WIN32 r <- randomIO let suffix = (showHexLen 6 (r .&. 0xFFFFFF :: Int)) diff -ruN darcs-2.4.4/src/unit.hs darcs-2.5/src/unit.hs --- darcs-2.4.4/src/unit.hs 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/src/unit.hs 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,3 @@ +module Main ( main ) where + +import Darcs.Test.Unit ( main ) diff -ruN darcs-2.4.4/src/unit.lhs darcs-2.5/src/unit.lhs --- darcs-2.4.4/src/unit.lhs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/unit.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,770 +0,0 @@ -% Copyright (C) 2002-2005,2007 David Roundy -% -% This program is free software; you can redistribute it and/or modify -% it under the terms of the GNU General Public License as published by -% the Free Software Foundation; either version 2, or (at your option) -% any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; see the file COPYING. If not, write to -% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -% Boston, MA 02110-1301, USA. - -\documentclass{report} -\usepackage{color} - -\usepackage{verbatim} -\newenvironment{code}{\color{blue}\verbatim}{\endverbatim} - -\begin{document} - -% Definition of title page: -\title{ - Unit Testing for darcs in Haskell -} -\author{ - David Roundy % insert author(s) here -} - -\maketitle - -\tableofcontents % Table of Contents - -\chapter{Introduction} - -This is a unit testing program, which is intended to make sure that all the -functions of my darcs code work properly. - -\begin{code} -{-# OPTIONS_GHC -cpp -fno-warn-orphans -fno-warn-deprecations -fglasgow-exts #-} -{-# LANGUAGE CPP #-} - -module Main (main) where - -import System.IO.Unsafe ( unsafePerformIO ) -import ByteStringUtils hiding ( intercalate ) -import Codec.Binary.UTF8.Generic ( toString ) -import qualified Data.ByteString.Char8 as BC ( unpack, pack ) -import qualified Data.ByteString as B ( concat, empty ) -import Darcs.Patch -import Darcs.Test.Patch.Test -import Darcs.Test.Patch.Unit ( patch_unit_tests ) -import Darcs.Test.Email ( email_parsing, email_header_no_long_lines, - email_header_ascii_chars, email_header_lines_start, - email_header_no_empty_lines ) -import Lcs ( shiftBoundaries ) -import Test.QuickCheck -import Printer ( renderPS ) -import Darcs.Patch.Commute -import Data.Array.Base -import Data.Array.Unboxed -import Control.Monad.ST -import Darcs.Witnesses.Ordered -import Darcs.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal ) -import Test.HUnit ( assertBool, assertFailure ) -import Test.Framework.Providers.QuickCheck2 ( testProperty ) -import Test.Framework.Providers.HUnit ( testCase ) -import Test.Framework.Runners.Console ( defaultMain ) -import Test.Framework ( Test ) - -#include "impossible.h" -\end{code} - -\chapter{Main body of code} - -\begin{code} -main :: IO () -main = do - putStr ("There are a total of "++(show (length primitive_test_patches)) - ++" primitive patches.\n") - putStr ("There are a total of "++ - (show (length test_patches))++" patches.\n") - defaultMain tests - --- | Utility function to run bools with test-framework -testBool :: String -> Bool -> Test -testBool name test = testCase name (assertBool assertName test) - where assertName = "boolean test \"" ++ name ++ "\" should return True" - --- | Utility function to run old tests that return a list of error messages, --- with the empty list meaning success. -testStringList :: String -> [String] -> Test -testStringList name test = testCase name $ mapM_ assertFailure test - --- | This is the big list of tests that will be run using testrunner. -tests :: [Test] -tests = patch_unit_tests ++ - [testBool "Checking that UTF-8 packing and unpacking preserves 'hello world'" - (toString (BC.pack "hello world") == "hello world"), - testBool "Checking that hex packing and unpacking preserves 'hello world'" - (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world") - == "hello world"), - email_parsing, - email_header_no_long_lines, - email_header_ascii_chars, - email_header_lines_start, - email_header_no_empty_lines, - testProperty "Checking that B.concat works" prop_concatPS, - testProperty "Checking that hex conversion works" prop_hex_conversion, - testProperty "Checking that show and read work right" prop_read_show, - testStringList "Checking known commutes" commute_tests, - testStringList "Checking known merges" merge_tests, - testStringList "Checking known canons" canonization_tests] - ++ check_subcommutes subcommutes_inverse "patch and inverse both commute" - ++ check_subcommutes subcommutes_nontrivial_inverse "nontrivial commutes are correct" - ++ check_subcommutes subcommutes_failure "inverses fail" - ++ - [testProperty "Checking that commuting by patch and its inverse is ok" prop_commute_inverse, - --putStr "Checking that conflict resolution is valid... " - --runQuickCheckTest returnval prop_resolve_conflicts_valid - testProperty "Checking that a patch followed by its inverse is identity" prop_patch_and_inverse_is_identity, - -- The following tests are "wrong" with the Conflictor code. - --putStr "Checking that a simple smart_merge is sufficient... " - --runQuickCheckTest returnval prop_simple_smart_merge_good_enough - --putStr "Checking that an elegant merge is sufficient... " - --runQuickCheckTest returnval prop_elegant_merge_good_enough - testProperty "Checking that commutes are equivalent" prop_commute_equivalency, - testProperty "Checking that merges are valid" prop_merge_valid, - testProperty "Checking inverses being valid" prop_inverse_valid, - testProperty "Checking other inverse being valid" prop_other_inverse_valid, - testStringList "Checking merge swaps" merge_swap_tests, - -- The patch generator isn't smart enough to generate correct test - -- cases for the following: (which will be obsoleted soon, anyhow) - --putStr "Checking the order dependence of unravel... " - --runQuickCheckTest returnval prop_unravel_order_independent - --putStr "Checking the unravelling of three merges... " - --runQuickCheckTest returnval prop_unravel_three_merge - --putStr "Checking the unravelling of a merge of a sequence... " - --runQuickCheckTest returnval prop_unravel_seq_merge - testProperty "Checking inverse of inverse" prop_inverse_composition, - testProperty "Checking the order of commutes" prop_commute_either_order, - testProperty "Checking commute either way" prop_commute_either_way, - testProperty "Checking the double commute" prop_commute_twice, - testProperty "Checking that merges commute and are well behaved" prop_merge_is_commutable_and_correct, - testProperty "Checking that merges can be swapped" prop_merge_is_swapable, - testProperty "Checking again that merges can be swapped (I'm paranoid) " prop_merge_is_swapable, - testStringList "Checking that the patch validation works" test_check, - testStringList "Checking commute/recommute" commute_recommute_tests, - testStringList "Checking merge properties" generic_merge_tests, - testStringList "Testing the lcs code" show_lcs_tests, - testStringList "Checking primitive patch IO functions" primitive_show_read_tests, - testStringList "Checking IO functions" show_read_tests, - testStringList "Checking primitive commute/recommute" primitive_commute_recommute_tests - ] -\end{code} - -\chapter{Unit Tester} - -The unit tester function is really just a glorified map for functions that -return lists, in which the lists get concatenated (where map would end up -with a list of lists). - -\begin{code} -type PatchUnitTest p = p -> [String] -type TwoPatchUnitTest = Patch -> Patch -> [String] - -parallel_pair_unit_tester :: TwoPatchUnitTest -> [(Patch:\/:Patch)] -> [String] -parallel_pair_unit_tester _ [] = [] -parallel_pair_unit_tester thetest ((p1:\/:p2):ps) - = (thetest p1 p2)++(parallel_pair_unit_tester thetest ps) - -pair_unit_tester :: TwoPatchUnitTest -> [(Patch: [String] -pair_unit_tester _ [] = [] -pair_unit_tester thetest ((p1: [String] -check_known_shifts (ca, cb, sa, sb, ca', cb') = runST ( - do ca_arr <- newListArray (0, length ca) $ toBool (0:ca) - cb_arr <- newListArray (0, length cb) $ toBool (0:cb) - let p_a = listArray (0, length sa) $ B.empty:(toPS sa) - p_b = listArray (0, length sb) $ B.empty:(toPS sb) - shiftBoundaries ca_arr cb_arr p_a 1 1 - shiftBoundaries cb_arr ca_arr p_b 1 1 - ca_res <- fmap (fromBool . tail) $ getElems ca_arr - cb_res <- fmap (fromBool . tail) $ getElems cb_arr - return $ if ca_res == ca' && cb_res == cb' then [] - else ["shiftBoundaries failed on "++sa++" and "++sb++" with " - ++(show (ca,cb))++" expected "++(show (ca', cb')) - ++" got "++(show (ca_res, cb_res))++"\n"]) - where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c]) - toBool = map (>0) - fromBool = map (\b -> if b then 1 else 0) - -known_shifts :: [([Int],[Int],String,String,[Int],[Int])] -known_shifts = - [([0,0,0],[0,1,0,1,0],"aaa","aaaaa", - [0,0,0],[0,0,0,1,1]), - ([0,1,0],[0,1,1,0],"cd ","c a ", - [0,1,0],[0,1,1,0]), - ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}", - [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end - ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}", - [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end - ([],[1,1],"","aa",[],[1,1]), - ([1,1],[],"aa","",[1,1],[])] - - -\end{code} - -\chapter{Show/Read tests} - -This test involves calling ``show'' to print a string describing a patch, -and then using readPatch to read it back in, and making sure the patch we -read in is the same as the original. Useful for making sure that I don't -have any stupid IO bugs. - -\begin{code} -show_read_tests :: [String] -show_read_tests = concatMap t_show_read test_patches ++ - concatMap t_show_read test_patches_named -primitive_show_read_tests :: [String] -primitive_show_read_tests = concatMap t_show_read primitive_test_patches -t_show_read :: (Eq p, Show p, Patchy p) => PatchUnitTest p -t_show_read p = - case readPatch $ renderPS $ showPatch p of - Just (Sealed p',_) -> if p' == p then [] - else ["Failed to read shown: "++(show p)++"\n"] - Nothing -> ["Failed to read at all: "++(show p)++"\n"] - -instance MyEq p => Eq (Named p) where - (==) = unsafeCompare -\end{code} - -\chapter{Canonization tests} - -This is a set of known correct canonizations, to make sure that I'm -canonizing as I ought. - -\begin{code} -canonization_tests :: [String] -canonization_tests = concatMap check_known_canon known_canons -check_known_canon :: (Patch, Patch) -> [String] -check_known_canon (p1,p2) = - if (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1) == p2 - then [] - else ["Canonization failed:\n"++show p1++"canonized is\n" - ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1 :: Patch) - ++"which is not\n"++show p2] -known_canons :: [(Patch,Patch)] -known_canons = - [(quickhunk 1 "abcde" "ab", quickhunk 3 "cde" ""), - (quickhunk 1 "abcde" "bd", join_patches [quickhunk 1 "a" "", - quickhunk 2 "c" "", - quickhunk 3 "e" ""]), - (join_patches [quickhunk 4 "a" "b", - quickhunk 1 "c" "d"], - join_patches [quickhunk 1 "c" "d", - quickhunk 4 "a" "b"]), - (join_patches [quickhunk 1 "a" "", - quickhunk 1 "" "b"], - quickhunk 1 "a" "b"), - (join_patches [quickhunk 1 "ab" "c", - quickhunk 1 "cd" "e"], - quickhunk 1 "abd" "e"), - (quickhunk 1 "abcde" "cde", quickhunk 1 "ab" ""), - (quickhunk 1 "abcde" "acde", quickhunk 2 "b" "")] -quickhunk :: Int -> String -> String -> Patch -quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o) - (map (\c -> BC.pack [c]) n) -\end{code} - -\chapter{Merge/unmgerge tests} - -It should always be true that if two patches can be unmerged, then merging -the resulting patches should give them back again. -\begin{code} -generic_merge_tests :: [String] -generic_merge_tests = - case take 400 [(p1:\/:p2)| - i <- [0..(length test_patches)-1], - p1<-[test_patches!!i], - p2<-drop i test_patches, - check_a_patch $ join_patches [invert p2,p1]] of - merge_pairs -> (parallel_pair_unit_tester t_merge_either_way_valid merge_pairs) ++ - (parallel_pair_unit_tester t_merge_swap_merge merge_pairs) -t_merge_either_way_valid :: TwoPatchUnitTest -t_merge_either_way_valid p1 p2 = - case join_patches [p2, quickmerge (p1:\/: p2)] of - combo2 -> - case join_patches [p1, quickmerge (p2:\/: p1)] of - combo1 -> - if not $ check_a_patch $ join_patches [combo1] - then ["oh my combo1 invalid:\n"++show p1++"and...\n"++show p2++show combo1] - else - if check_a_patch $ join_patches [invert combo1, combo2] - then [] - else ["merge both ways invalid:\n"++show p1++"and...\n"++show p2++ - show combo1++ - show combo2] -t_merge_swap_merge :: TwoPatchUnitTest -t_merge_swap_merge p1 p2 = - if (swapp $ merge (p2:\/: p1)) == merge (p1:\/:p2) - then [] - else ["Failed to swap merges:\n"++show p1++"and...\n"++show p2 - ++"merged:\n"++show (merge (p1:\/:p2))++"\n" - ++"merged and swapped:\n"++show (swapp $ merge (p2:\/: p1))++"\n"] - where swapp (x :/\: y) = y :/\: x - -instance Show p => Show (p :/\: p) where - show (x :/\: y) = show x ++ " :/\\: " ++ show y -instance Eq p => Eq (p :/\: p) where - (x :/\: y) == (x' :/\: y') = x == x' && y == y' -\end{code} - -\chapter{Commute/recommute tests} - -Here we test to see if commuting patch A and patch B and then commuting the -result gives us patch A and patch B again. The set of patches (A,B) is -chosen from the set of all pairs of test patches by selecting those which -commute with one another. - -\begin{code} -commute_recommute_tests :: [String] -commute_recommute_tests = - case take 200 [(p2:checkseq [p1,p]) test_patches, - commute (p1:>p2) /= Nothing] of - commute_pairs -> pair_unit_tester t_commute_recommute commute_pairs - where checkseq ps = check_a_patch $ join_patches ps -primitive_commute_recommute_tests :: [String] -primitive_commute_recommute_tests = - pair_unit_tester t_commute_recommute - [(p1:p1) /= Nothing, - check_a_patch $ join_patches [p2,p1]] -t_commute_recommute :: TwoPatchUnitTest -t_commute_recommute p1 p2 = - if (commute (p2:>p1) >>= commute) == Just (p2:>p1) - then [] - else ["Failed to recommute:\n"++(show p2)++(show p1)++ - "we saw it as:\n"++show (commute (p2:>p1))++ - "\nAnd recommute was:\n"++show (commute (p2:>p1) >>= commute) - ++ "\n"] -\end{code} - -\chapter{Commute tests} - -Here we provide a set of known interesting commutes. -\begin{code} -commute_tests :: [String] -commute_tests = - concatMap check_known_commute known_commutes++ - concatMap check_cant_commute known_cant_commute -check_known_commute :: (Patch:< Patch, Patch:< Patch) -> [String] -check_known_commute (p1:p1) of - Just (p1a:>p2a) -> - if (p2a:< p1a) == (p2':< p1') - then [] - else ["Commute gave wrong value!\n"++show p1++"\n"++show p2 - ++"should be\n"++show p2'++"\n"++show p1' - ++"but is\n"++show p2a++"\n"++show p1a] - Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2] - ++ - case commute (p1':>p2') of - Just (p2a:>p1a) -> - if (p1a:< p2a) == (p1:< p2) - then [] - else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a - ++"should have been\n"++show p2'++"\n"++show p1'] - Nothing -> ["Commute failed!\n"++show p2'++"\n"++show p1'] -known_commutes :: [(Patch: [String] -check_cant_commute (p1:p1) of - Nothing -> [] - _ -> [show p1 ++ "\n\n" ++ show p2 ++ - "\nArgh, these guys shouldn't commute!\n"] -known_cant_commute :: [(Patch:< Patch)] -known_cant_commute = [ - (testhunk 2 ["o"] ["n"]:< - testhunk 1 [] ["A"]), - (testhunk 1 [] ["A"]:< - testhunk 1 ["o"] ["n"]), - (quickmerge (testhunk 2 ["o"] ["n"]:\/: - testhunk 2 ["o"] ["v"]):< - testhunk 1 [] ["a"]), - (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):< - fromPrim (addfile "test"))] - where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n) -\end{code} - -\chapter{Merge tests} - -Here we provide a set of known interesting merges. -\begin{code} -merge_tests :: [String] -merge_tests = - concatMap check_known_merge_equiv known_merge_equivs++ - concatMap check_known_merge known_merges -check_known_merge :: (Patch:\/: Patch, Patch:< Patch) -> [String] -check_known_merge (p1:\/:p2,p1': - if (p1a:< p2) == (p1':< p2') - then [] - else ["Merge gave wrong value!\n"++show p1++show p2 - ++"I expected\n"++show p1'++show p2' - ++"but found instead\n"++show p1a] -known_merges :: [(Patch:\/:Patch,Patch: [String] -check_known_merge_equiv (p1:\/: p2, pe) = - case quickmerge (p1:\/:p2) of - p1' -> if check_a_patch $ join_patches [invert p1, p2, p1', invert pe] - then [] - else ["Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2 - ++"in other words\n" ++ show (p1 :\/: p2) - ++"merges as\n" ++ show (merge $ p1 :\/: p2) - ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2) - ++"which is equivalent to\n" ++ show (effect p1') - ++ "should all work out to\n" - ++ show pe] -known_merge_equivs :: [(Patch:\/: Patch, Patch)] -known_merge_equivs = [ - - -- The following tests are going to be failed by the - -- Conflictor code as a cleanup. - - --(addfile "test":\/: - -- adddir "test", - -- join_patches [adddir "test", - -- addfile "test-conflict"]), - --(move "silly" "test":\/: - -- adddir "test", - -- join_patches [adddir "test", - -- move "silly" "test-conflict"]), - --(addfile "test":\/: - -- move "old" "test", - -- join_patches [addfile "test", - -- move "old" "test-conflict"]), - --(move "a" "test":\/: - -- move "old" "test", - -- join_patches [move "a" "test", - -- move "old" "test-conflict"]), - (fromPrim (hunk "test" 1 [] [BC.pack "A"]):\/: - fromPrim (hunk "test" 1 [] [BC.pack "B"]), - fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])), - (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/: - fromPrim (hunk "test" 1 [BC.pack "b"] []), - identity), - --hunk "test" 1 [] [BC.pack "v v v v v v v", - -- BC.pack "*************", - -- BC.pack "a", - -- BC.pack "b", - -- BC.pack "^ ^ ^ ^ ^ ^ ^"]), - (quickhunk 4 "a" "":\/: - quickhunk 3 "a" "", - quickhunk 3 "aa" ""), - (join_patches [quickhunk 1 "a" "bc", - quickhunk 6 "d" "ef"]:\/: - join_patches [quickhunk 3 "a" "bc", - quickhunk 8 "d" "ef"], - join_patches [quickhunk 3 "a" "bc", - quickhunk 8 "d" "ef", - quickhunk 1 "a" "bc", - quickhunk 7 "d" "ef"]), - (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a"):\/: - quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"), - quickhunk 2 "" "abdc") - ] -\end{code} - -It also is useful to verify that it doesn't matter which order we specify -the patches when we merge. - -\begin{code} -merge_swap_tests :: [String] -merge_swap_tests = - concat - [check_merge_swap p1 p2 | - p1<-primitive_test_patches, - p2<-primitive_test_patches, - check_a_patch $ join_patches [invert p1,p2] - ] -check_merge_swap :: Patch -> Patch -> [String] -check_merge_swap p1 p2 = - case merge (p2:\/:p1) of - _ :/\: p2' -> - case merge (p1:\/:p2) of - _ :/\: p1' -> - case commute (p1:>p2') of - Just (_:>p1'b) -> - if p1'b /= p1' - then ["Merge swapping problem with...\np1 "++ - show p1++"merged with\np2 "++ - show p2++"p1' is\np1' "++ - show p1'++"p1'b is\np1'b "++ - show p1'b - ] - else [] - Nothing -> ["Merge commuting problem with...\np1 "++ - show p1++"merged with\np2 "++ - show p2++"gives\np2' "++ - show p2'++"which doesn't commute with p1.\n" - ] -\end{code} - -\chapter{Patch test data} - -This is where we define the set of patches which we run our tests on. This -should be kept up to date with as many interesting permutations of patch -types as possible. - -\begin{code} -test_patches :: [Patch] -test_patches_named :: [Named Patch] -test_patches_addfile :: [Patch] -test_patches_rmfile :: [Patch] -test_patches_hunk :: [Patch] -primitive_test_patches :: [Patch] -test_patches_binary :: [Patch] -test_patches_composite_nocom :: [Patch] -test_patches_composite :: [Patch] -test_patches_two_composite_hunks :: [Patch] -test_patches_composite_hunks :: [Patch] -test_patches_composite_four_hunks :: [Patch] -test_patches_merged :: [Patch] -valid_patches :: [Patch] - -test_patches_named = [unsafePerformIO $ - namepatch "date is" "patch name" "David Roundy" [] - (fromPrim $ addfile "test"), - unsafePerformIO $ - namepatch "Sat Oct 19 08:31:13 EDT 2002" - "This is another patch" "David Roundy" - ["This log file has","two lines in it"] - (fromPrim $ rmfile "test")] -test_patches_addfile = map fromPrim - [addfile "test",adddir "test",addfile "test/test"] -test_patches_rmfile = map invert test_patches_addfile -test_patches_hunk = - [fromPrim $ hunk file line old new | - file <- ["test"], - line <- [1,2], - old <- map (map BC.pack) partials, - new <- map (map BC.pack) partials, - old /= new - ] - where partials = [["A"],["B"],[],["B","B2"]] - -primitive_test_patches = test_patches_addfile ++ - test_patches_rmfile ++ - test_patches_hunk ++ - [unsafeUnseal.fst.fromJust.readPatch $ - BC.pack "move ./test/test ./hello", - unsafeUnseal.fst.fromJust.readPatch $ - BC.pack "move ./test ./hello"] ++ - test_patches_binary - -test_patches_binary = - [fromPrim $ binary "./hello" - (BC.pack $ "agadshhdhdsa75745457574asdgg" ++ - "a326424677373735753246463gadshhdhdsaasdgg" ++ - "a326424677373735753246463gadshhdhdsaasdgg" ++ - "a326424677373735753246463gadshhdhdsaasdgg") - (BC.pack $ "adafjttkykrehhtrththrthrthre" ++ - "a326424677373735753246463gadshhdhdsaasdgg" ++ - "a326424677373735753246463gadshhdhdsaasdgg" ++ - "a326424677373735753246463gadshhdhdsaagg"), - fromPrim $ binary "./hello" - B.empty - (BC.pack "adafjttkykrere")] - -test_patches_composite_nocom = - take 50 [join_patches [p1,p2]| - p1<-primitive_test_patches, - p2<-filter (\p->checkseq [p1,p]) primitive_test_patches, - commute (p1:>p2) == Nothing] - where checkseq ps = check_a_patch $ join_patches ps - -test_patches_composite = - take 100 [join_patches [p1,p2]| - p1<-primitive_test_patches, - p2<-filter (\p->checkseq [p1,p]) primitive_test_patches, - commute (p1:>p2) /= Nothing, - commute (p1:>p2) /= Just (p2:>p1)] - where checkseq ps = check_a_patch $ join_patches ps - -test_patches_two_composite_hunks = - take 100 [join_patches [p1,p2]| - p1<-test_patches_hunk, - p2<-filter (\p->checkseq [p1,p]) test_patches_hunk] - where checkseq ps = check_a_patch $ join_patches ps - -test_patches_composite_hunks = - take 100 [join_patches [p1,p2,p3]| - p1<-test_patches_hunk, - p2<-filter (\p->checkseq [p1,p]) test_patches_hunk, - p3<-filter (\p->checkseq [p1,p2,p]) test_patches_hunk] - where checkseq ps = check_a_patch $ join_patches ps - -test_patches_composite_four_hunks = - take 100 [join_patches [p1,p2,p3,p4]| - p1<-test_patches_hunk, - p2<-filter (\p->checkseq [p1,p]) test_patches_hunk, - p3<-filter (\p->checkseq [p1,p2,p]) test_patches_hunk, - p4<-filter (\p->checkseq [p1,p2,p3,p]) test_patches_hunk] - where checkseq ps = check_a_patch $ join_patches ps - -test_patches_merged = - take 200 - [joinPatches $ flattenFL p2+>+flattenFL (quickmerge (p1:\/:p2)) | - p1<-take 10 (drop 15 test_patches_composite_hunks)++primitive_test_patches - ++take 10 (drop 15 test_patches_two_composite_hunks) - ++ take 2 (drop 4 test_patches_composite_four_hunks), - p2<-take 10 test_patches_composite_hunks++primitive_test_patches - ++take 10 test_patches_two_composite_hunks - ++take 2 test_patches_composite_four_hunks, - check_a_patch $ join_patches [invert p1, p2], - commute (p2:>p1) /= Just (p1:>p2) - ] - -test_patches = primitive_test_patches ++ - test_patches_composite ++ - test_patches_composite_nocom ++ - test_patches_merged -\end{code} - -\chapter{Check patch test} -Check patch is supposed to verify that a patch is valid. - -\begin{code} -valid_patches = [(join_patches [quickhunk 4 "a" "b", - quickhunk 1 "c" "d"]), - (join_patches [quickhunk 1 "a" "bc", - quickhunk 1 "b" "d"]), - (join_patches [quickhunk 1 "a" "b", - quickhunk 1 "b" "d"])]++test_patches - -test_check :: [String] -test_check = concatMap t_test_check valid_patches -t_test_check :: PatchUnitTest Patch -t_test_check p = if check_a_patch p - then [] - else ["Failed the check: "++show p++"\n"] - -prop_hex_conversion :: String -> Bool -prop_hex_conversion s = - fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s -prop_concatPS :: [String] -> Bool -prop_concatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss) - --- | Groups a set of tests by giving them the same prefix in their description. --- When this is called as @check_subcommutes subcoms expl@, the prefix for a --- test becomes @"Checking " ++ expl ++ " for subcommute "@. -check_subcommutes :: Testable a => [(String, a)] -> String - -> [Test] -check_subcommutes subcoms expl = map check_subcommute subcoms - where check_subcommute (name, test) = - let testName = "Checking" ++ expl ++ " for subcommute " ++ name - in testProperty testName test -\end{code} - -\end{document} - - diff -ruN darcs-2.4.4/src/URL.hs darcs-2.5/src/URL.hs --- darcs-2.4.4/src/URL.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/URL.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,8 +1,8 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} -module URL ( copyUrl, copyUrlFirst, pipeliningEnabledByDefault, - setDebugHTTP, setHTTPPipelining, waitUrl, - Cachable(Cachable, Uncachable, MaxAge), +module URL ( copyUrl, copyUrlFirst, setDebugHTTP, + disableHTTPPipelining, maxPipelineLength, + waitUrl, Cachable(Cachable, Uncachable, MaxAge), environmentHelpProxy, environmentHelpProxyPassword ) where @@ -31,23 +31,21 @@ #ifdef HAVE_CURL import Foreign.C.String ( withCString, peekCString, CString ) #else -import qualified HTTP ( request_url, wait_next_url ) +import qualified HTTP ( requestUrl, waitNextUrl ) #endif #include "impossible.h" data UrlRequest = UrlRequest { url :: String , file :: FilePath , cachable :: Cachable - , priority :: Priority - , notifyVar :: MVar String } + , priority :: Priority } data Cachable = Cachable | Uncachable | MaxAge !CInt deriving (Show, Eq) data UrlState = UrlState { inProgress :: Map String ( FilePath , [FilePath] - , Cachable - , (MVar String) ) + , Cachable ) , waitToStart :: Q String , pipeLength :: Int , randomJunk :: String } @@ -80,26 +78,19 @@ data Priority = High | Low deriving Eq -#if defined(CURL_PIPELINING) || defined(CURL_PIPELINING_DEFAULT) -pipeliningLimit :: Int -pipeliningLimit = 100 -#endif - -pipeliningEnabledByDefault :: Bool -#ifdef CURL_PIPELINING_DEFAULT -pipeliningEnabledByDefault = True -#else -pipeliningEnabledByDefault = False +{-# NOINLINE maxPipelineLengthRef #-} +maxPipelineLengthRef :: IORef Int +maxPipelineLengthRef = unsafePerformIO $ do + enabled <- pipeliningEnabled +#ifdef HAVE_CURL + when (not enabled) (debugMessage $ + "Warning: pipelining is disabled, because libcurl "++ + "version darcs was compiled with is too old (< 7.19.1)") #endif + newIORef $ if enabled then 100 else 1 -{-# NOINLINE maxPipeLength #-} -maxPipeLength :: IORef Int -maxPipeLength = unsafePerformIO $ newIORef $ -#ifdef CURL_PIPELINING_DEFAULT - pipeliningLimit -#else - 1 -#endif +maxPipelineLength :: IO Int +maxPipelineLength = readIORef maxPipelineLengthRef {-# NOINLINE urlNotifications #-} urlNotifications :: MVar (Map String (MVar String)) @@ -148,23 +139,23 @@ st <- get let p = inProgress st w = waitToStart st - e = (f, [], c, notifyVar r) + e = (f, [], c) new_w = case priority r of High -> pushQ u w Low -> insertQ u w new_st = st { inProgress = Map.insert u e p , waitToStart = new_w } case Map.lookup u p of - Just (f', fs', c', v) -> do + Just (f', fs', c') -> do let new_c = minCachable c c' - when (c /= c') $ let new_p = Map.insert u (f', fs', new_c, v) p + when (c /= c') $ let new_p = Map.insert u (f', fs', new_c) p in do modify (\s -> s { inProgress = new_p }) dbg $ "Changing "++u++" request cachability from "++show c++" to "++show new_c when (u `elemQ` w && priority r == High) $ do modify (\s -> s { waitToStart = pushQ u (deleteQ u w) }) dbg $ "Moving "++u++" to head of download queue." if f `notElem` (f':fs') - then let new_p = Map.insert u (f', f:fs', new_c, v) p + then let new_p = Map.insert u (f', f:fs', new_c) p in do modify (\s -> s { inProgress = new_p }) dbg "Adding new file to existing UrlRequest." else dbg "Ignoring UrlRequest of file that's already queued." @@ -179,25 +170,25 @@ checkWaitToStart = do st <- get let l = pipeLength st - mpl <- liftIO $ readIORef maxPipeLength + mpl <- liftIO maxPipelineLength when (l < mpl) $ do let w = waitToStart st case readQ w of Just (u,rest) -> do case Map.lookup u (inProgress st) of - Just (f, _, c, v) -> do - dbg ("URL.request_url ("++u++"\n"++ + Just (f, _, c) -> do + dbg ("URL.requestUrl ("++u++"\n"++ " -> "++f++")") let f_new = f++"-new_"++randomJunk st - err <- liftIO $ request_url u f_new c + err <- liftIO $ requestUrl u f_new c if null err - then do dbg "URL.request_url succeeded" + then do dbg "URL.requestUrl succeeded" liftIO $ atexit (removeFileMayNotExist f_new) put $ st { waitToStart = rest , pipeLength = l + 1 } else do dbg $ "Failed to start download URL "++u++": "++err liftIO $ do removeFileMayNotExist f_new - putMVar v err + downloadComplete u err put $ st { waitToStart = rest } _ -> bug $ "Possible bug in URL.checkWaitToStart "++u checkWaitToStart @@ -216,7 +207,7 @@ v <- newEmptyMVar let fn _ old_val = old_val modifyMVar_ urlNotifications (return . (Map.insertWith fn u v)) - let r = UrlRequest u f c p v + let r = UrlRequest u f c p writeChan urlChan r waitNextUrl :: StateT UrlState IO () @@ -225,22 +216,22 @@ let l = pipeLength st when (l > 0) $ do dbg "URL.waitNextUrl start" - (u, e) <- liftIO $ wait_next_url + (u, e) <- liftIO $ waitNextUrl' let p = inProgress st new_st = st { inProgress = Map.delete u p , pipeLength = l - 1 } liftIO $ if null e then case Map.lookup u p of - Just (f, fs, _, v) -> do + Just (f, fs, _) -> do renameFile (f++"-new_"++randomJunk st) f mapM_ (safeCopyFile st f) fs - putMVar v e + downloadComplete u e debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u else case Map.lookup u p of - Just (f, _, _, v) -> do + Just (f, _, _) -> do removeFileMayNotExist (f++"-new_"++randomJunk st) - putMVar v e + downloadComplete u e debugMessage $ "URL.waitNextUrl failed: "++ u++" "++f++" "++e Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++u++" "++e @@ -249,6 +240,13 @@ in do copyFile f new_t renameFile new_t t +downloadComplete :: String -> String -> IO () +downloadComplete u e = do + r <- withMVar urlNotifications (return . (Map.lookup u)) + case r of + Just notifyVar -> putMVar notifyVar e + Nothing -> debugMessage $ "downloadComplete URL '"++u++"' downloaded several times" + waitUrl :: String -> IO () waitUrl u = do debugMessage $ "URL.waitUrl "++u r <- withMVar urlNotifications (return . (Map.lookup u)) @@ -277,35 +275,33 @@ cachableToInt (MaxAge n) = n #endif -setHTTPPipelining :: Bool -> IO () -setHTTPPipelining False = writeIORef maxPipeLength 1 -setHTTPPipelining True = writeIORef maxPipeLength -#ifdef CURL_PIPELINING - pipeliningLimit -#else - 1 >> (putStrLn $ "Warning: darcs is compiled without HTTP pipelining "++ - "support, '--http-pipelining' argument is ignored.") -#endif +disableHTTPPipelining :: IO () +disableHTTPPipelining = writeIORef maxPipelineLengthRef 1 setDebugHTTP :: IO () -request_url :: String -> FilePath -> Cachable -> IO String -wait_next_url :: IO (String, String) +requestUrl :: String -> FilePath -> Cachable -> IO String +waitNextUrl' :: IO (String, String) +pipeliningEnabled :: IO Bool #ifdef HAVE_CURL setDebugHTTP = curl_enable_debug -request_url u f cache = +requestUrl u f cache = withCString u $ \ustr -> withCString f $ \fstr -> do err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString return err -wait_next_url = do +waitNextUrl' = do e <- curl_wait_next_url >>= peekCString u <- curl_last_url >>= peekCString return (u, e) +pipeliningEnabled = do + r <- curl_pipelining_enabled + return $ r /= 0 + foreign import ccall "hscurl.h curl_request_url" curl_request_url :: CString -> CString -> CInt -> IO CString @@ -318,17 +314,22 @@ foreign import ccall "hscurl.h curl_enable_debug" curl_enable_debug :: IO () +foreign import ccall "hscurl.h curl_pipelining_enabled" + curl_pipelining_enabled :: IO CInt + #elif defined(HAVE_HTTP) setDebugHTTP = return () -request_url = HTTP.request_url -wait_next_url = HTTP.wait_next_url +requestUrl = HTTP.requestUrl +waitNextUrl' = HTTP.waitNextUrl +pipeliningEnabled = return False #else setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl" -request_url _ _ _ = debugFail "URL.request_url: there is no libcurl!" -wait_next_url = debugFail "URL.wait_next_url: there is no libcurl!" +requestUrl _ _ _ = debugFail "URL.requestUrl: there is no libcurl!" +waitNextUrl' = debugFail "URL.waitNextUrl': there is no libcurl!" +pipeliningEnabled = return False #endif diff -ruN darcs-2.4.4/src/witnesses.hs darcs-2.5/src/witnesses.hs --- darcs-2.4.4/src/witnesses.hs 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/src/witnesses.hs 2010-10-24 08:29:26.000000000 -0700 @@ -1,6 +1,6 @@ import Version --- import Preproc -- imports Darcs.Commands.Help --- import Darcs.ArgumentDefaults -- imports Darcs.Commands.Help +import Preproc +import Darcs.ArgumentDefaults import Darcs.Patch.Real import Darcs.Patch.Properties import Darcs.Patch.Bundle @@ -10,45 +10,46 @@ import Darcs.Repository.HashedRepo import Darcs.Resolution import Darcs.Test.Patch.Check +import Darcs.Test.Patch.QuickCheck import Darcs.Repository.Pristine import Darcs.Repository.DarcsRepo import Darcs.Repository.Internal --- import Darcs.Commands.Add +import Darcs.Commands.Add import Darcs.Commands.Annotate --- import Darcs.Commands.AmendRecord -- depends on Darcs.Commands.Record +import Darcs.Commands.AmendRecord import Darcs.Commands.Apply --- import Darcs.Commands.Changes -- does lots of nasty filtering of patch lists --- import Darcs.Commands.Check --- import Darcs.Commands.Convert +import Darcs.Commands.Changes +import Darcs.Commands.Check +import Darcs.Commands.Convert import Darcs.Commands.Diff import Darcs.Commands.Dist --- import Darcs.Commands.Get +import Darcs.Commands.Get import Darcs.Commands.GZCRCs --- import Darcs.Commands.Help -- depends on Darcs.TheCommands +import Darcs.Commands.Help import Darcs.Commands.Init --- import Darcs.Commands.MarkConflicts --- import Darcs.Commands.Move --- import Darcs.Commands.Optimize +import Darcs.Commands.MarkConflicts +import Darcs.Commands.Move +import Darcs.Commands.Optimize import Darcs.Commands.Pull import Darcs.Commands.Push --- import Darcs.Commands.Put --- import Darcs.Commands.Record --- import Darcs.Commands.Remove -- depends on Darcs.Commands.Add --- import Darcs.Commands.Repair --- import Darcs.Commands.Replace --- import Darcs.Commands.Revert --- import Darcs.Commands.Rollback -- depends on Darcs.Commands.Rollback +import Darcs.Commands.Put +import Darcs.Commands.Record +import Darcs.Commands.Remove +import Darcs.Commands.Repair +import Darcs.Commands.Replace +import Darcs.Commands.Revert +import Darcs.Commands.Rollback import Darcs.Commands.Send import Darcs.Commands.SetPref import Darcs.Commands.Show --- import Darcs.Commands.Tag -- depends on Darcs.Commands.Tag +import Darcs.Commands.Tag import Darcs.Commands.TrackDown import Darcs.Commands.TransferMode import Darcs.Commands.Unrevert import Darcs.Commands.Unrecord import Darcs.Commands.WhatsNew --- import Darcs.RunCommand -- imports Darcs.Commands.Help --- import Darcs.TheCommands -- pulls in all other commands +import Darcs.RunCommand +import Darcs.TheCommands main = return () diff -ruN darcs-2.4.4/tests/amend-record.sh darcs-2.5/tests/amend-record.sh --- darcs-2.4.4/tests/amend-record.sh 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/tests/amend-record.sh 2010-10-24 08:29:26.000000000 -0700 @@ -44,6 +44,35 @@ echo "another line" >> foo echo y | darcs amend -a -m new_name -A new_author foo | grep -i 'amending changes' darcs changes --last=1 | grep new_author + +# check that normally the date changes when we amend +echo "another line" >> foo +darcs changes --last=1 | head -n 1 > old_date +sleep 1 +echo y | darcs amend -a foo -A new_author | grep -i 'amending changes' +darcs changes --last=1 | head -n 1 > new_date +not cmp old_date new_date + +# check that --keep-date works +echo "another line" >> foo +darcs changes --last=1 | head -n 1 > old_date +sleep 1 +echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes' +darcs changes --last=1 | head -n 1 > new_date +cmp old_date new_date + cd .. -rm -rf temp1 +# check that the identity changes with --keep-date +darcs get temp1 temp2 +cd temp2 + +echo "another line" >> foo +darcs changes --last=1 | head -n 1 > old_date +echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes' +darcs pull ../temp1 -a --skip-conflicts | grep -i "Skipping some" + +cd .. + + +rm -rf temp1 temp2 diff -ruN darcs-2.4.4/tests/check.sh darcs-2.5/tests/check.sh --- darcs-2.4.4/tests/check.sh 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/tests/check.sh 2010-10-24 08:29:26.000000000 -0700 @@ -28,7 +28,7 @@ rm -rf R # Another script may have left a mess. darcs init --repo R darcs setpref --repo R test 'grep hello f' -not darcs record --repo R -am 'true test' +not darcs record --repo R -am 'true test' --test darcs record --repo R -am 'true test' --no-test touch R/f @@ -36,7 +36,7 @@ darcs tag --repo R -m 'got f?' echo hello > R/f -darcs record --repo R -lam 'hellofoo' +darcs record --repo R -lam 'hellofoo' --test darcs chec --repo R --test rm -rf R # Clean up after ourselves. diff -ruN darcs-2.4.4/tests/dist.sh darcs-2.5/tests/dist.sh --- darcs-2.4.4/tests/dist.sh 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/tests/dist.sh 2010-10-24 08:29:26.000000000 -0700 @@ -1,15 +1,35 @@ #!/usr/bin/env bash +# run darcs dist, then extract the resulting archive +# and compare it to the original repository content + . lib rm -rf temp1 mkdir temp1 cd temp1 darcs init -touch foo -darcs add foo + +for (( i=0 ; i < 5; i=i+1 )); do + echo $i >> file-$i; + mkdir dir-$i; + echo $i >> dir-$i/file-$i; + darcs add file-$i; + darcs add dir-$i/file-$i +done + darcs record -a -m add_foo | grep -i "finished recording" darcs dist + +mv temp1.tar.gz .. + cd .. -rm -rf temp1 +rm -rf temp1/_darcs +mv temp1 temp_orig + +tar xzf temp1.tar.gz + +diff -r temp_orig temp1 + +rm -rf temp_orig temp1 diff -ruN darcs-2.4.4/tests/external-resolution.sh darcs-2.5/tests/external-resolution.sh --- darcs-2.4.4/tests/external-resolution.sh 2010-05-23 01:58:07.000000000 -0700 +++ darcs-2.5/tests/external-resolution.sh 2010-10-24 08:29:26.000000000 -0700 @@ -26,6 +26,17 @@ echo | darcs pull -a ../temp2 --external-merge 'cp %2 %o' cd .. +grep "Part 2" temp1/child_of_conflict diff -u temp1/child_of_conflict temp2/child_of_conflict +cd temp1 +darcs wh +darcs rev -a +echo y | darcs unpull --last 1 -a +echo | darcs pull -a ../temp2 --external-merge 'cp %1 %o' +cd .. + +cat temp1/child_of_conflict +grep "Part 1" temp1/child_of_conflict + rm -rf temp1 temp2 diff -ruN darcs-2.4.4/tests/failed-amend-should-not-break-repo.sh darcs-2.5/tests/failed-amend-should-not-break-repo.sh --- darcs-2.4.4/tests/failed-amend-should-not-break-repo.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/failed-amend-should-not-break-repo.sh 2010-10-24 08:29:26.000000000 -0700 @@ -37,17 +37,17 @@ darcs record -a -m 'A' # second patch: mv A to B darcs mv A B -echo y | darcs record -a -m 'move' +darcs record -a -m 'move' # third patch: modify B echo "content" > B -echo y | darcs record -a -m 'add content' +darcs record -a -m 'add content' # amending 'move' results in commuting 'move' patch # to the end for removal. The commute changes the "add content" # patch to modify A instead of B. But the amend is interrupted # because of test failure. Check the consitency after the operation. darcs setpref test false -echo yy | not darcs amend -p move +echo yy | not darcs amend -p move --test darcs check # Note: Amend-record in case of test failure is broken as described in issue1406, diff -ruN darcs-2.4.4/tests/failing-issue1014_identical_patches.sh darcs-2.5/tests/failing-issue1014_identical_patches.sh --- darcs-2.4.4/tests/failing-issue1014_identical_patches.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/failing-issue1014_identical_patches.sh 2010-10-24 08:29:26.000000000 -0700 @@ -57,4 +57,6 @@ darcs get ac abc2 cd abc2 darcs pull -a ../bc +darcs changes +test `darcs changes | fgrep -c '* C'` -eq 1 diff -ruN darcs-2.4.4/tests/failing-issue1337_darcs_changes_false_positives.sh darcs-2.5/tests/failing-issue1337_darcs_changes_false_positives.sh --- darcs-2.4.4/tests/failing-issue1337_darcs_changes_false_positives.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/failing-issue1337_darcs_changes_false_positives.sh 1969-12-31 16:00:00.000000000 -0800 @@ -1,37 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1337 - darcs changes shows unrelated patches -## Asking "darcs changes" about an unrecorded file d/f will list the -## patch that creates the parent directory d/ (instead of no patches). -## -## Copyright (C) 2009 Trent W. Buck -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ../tests/lib - -rm -rf temp1 -darcs init --repodir temp1 -cd temp1 -mkdir d -darcs record -lam d d -# We use --match 'touch d/f' instead of simply d/f because the latter -# prints "Changes to d/f:\n" before the count. -test 0 -eq "$(darcs changes --count --match 'touch d/f')" diff -ruN darcs-2.4.4/tests/failing-issue1363-mark-conflicts.sh darcs-2.5/tests/failing-issue1363-mark-conflicts.sh --- darcs-2.4.4/tests/failing-issue1363-mark-conflicts.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/failing-issue1363-mark-conflicts.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,62 @@ +#!/usr/bin/env bash +## Test for issue1363 - mark-conflicts should report that there is a +## conflict to mark if apply/push say there are +## +## Copyright (C) 2010 Eric Kow +## Copyright (C) 2009 Thorkil Naur +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S T # Another script may have left a mess. +darcs init --repo R # Create our test repos. +darcs init --repo S +darcs init --repo T + +cd R + touch f.txt + darcs add f.txt + darcs record -am "Empty f.txt" + echo f.txt contents >> f.txt + darcs record -am "Contents of f.txt" +cd .. + +cd S + echo yn | darcs pull ../R + rm f.txt + darcs record -am 'Remove f.txt in S' +cd .. + +cd T + echo ynn | darcs pull ../R + rm f.txt + darcs record -am 'Remove f.txt in T' + not darcs push -a ../R > log # should fail because of conflict + grep "There are conflicts" log +cd .. + +cd R + darcs pull -a ../S + darcs revert -a + darcs pull -a ../T + echo y | darcs mark-conflicts > log + not grep "No conflicts" log +cd .. diff -ruN darcs-2.4.4/tests/failing-issue1461_case_folding.sh darcs-2.5/tests/failing-issue1461_case_folding.sh --- darcs-2.4.4/tests/failing-issue1461_case_folding.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/failing-issue1461_case_folding.sh 2010-10-24 08:29:26.000000000 -0700 @@ -25,6 +25,10 @@ ## SOFTWARE. . ../tests/lib # Load some portability helpers. + +touch casetest +test -e CASETEST || exit 200 + rm -rf lower upper joint # Another script may have left a mess. mkdir lower upper diff -ruN darcs-2.4.4/tests/failing-issue1727_move_current_directory.sh darcs-2.5/tests/failing-issue1727_move_current_directory.sh --- darcs-2.4.4/tests/failing-issue1727_move_current_directory.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/failing-issue1727_move_current_directory.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,49 @@ +#!/usr/bin/env bash +## Test for issue1727 - darcs move . target' fails as an attempt to +## write an 'invalid pending. +## +## Copyright (C) 2009 Sean Erle Johnson +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. + +# Create repository R +darcs init --repo R # Create the test repo. +cd R + +mkdir d # Change the working tree. + +# darcs move empty current directory to existing directory d +darcs move . d + +# darcs move empty current directory to non-existing directory e +darcs move . e + +# Make file to be copied +echo 'main = putStrLn "Hello World"' > hello.hs + +# darcs move non-empty current directory to existing directory d +darcs move . d + +# darcs move non-empty current directory to non-existing directory e +darcs move . e diff -ruN darcs-2.4.4/tests/failing-issue1737-move_args.sh darcs-2.5/tests/failing-issue1737-move_args.sh --- darcs-2.4.4/tests/failing-issue1737-move_args.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/failing-issue1737-move_args.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,38 @@ +#!/usr/bin/env bash +## Test for issue1737 - command line filtering on darcs move +## yields suprising results with shell globs +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d +touch d.txt +darcs record -lam 'Add d and d.txt' +darcs move d d.txt d 2> log || : # this can happen if eg. you darcs move d* d +# d.txt isn't a directory; we should probably just say that you +# can't move a directory on to itself +not grep "target directory d.txt" log diff -ruN darcs-2.4.4/tests/failing-issue1740-mv-dir.sh darcs-2.5/tests/failing-issue1740-mv-dir.sh --- darcs-2.4.4/tests/failing-issue1740-mv-dir.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/failing-issue1740-mv-dir.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,36 @@ +#!/usr/bin/env bash +## Test for issue1740 - darcs mv on directories should work after the fact +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d +echo 'Example content.' > d/f +darcs record -lam 'Add d/f' +mv d d2 +darcs mv d d2 # oops, I meant to darcs mv that +darcs what | grep move ./d ./d2 diff -ruN darcs-2.4.4/tests/failing-issue1845-paths-working-copy.sh darcs-2.5/tests/failing-issue1845-paths-working-copy.sh --- darcs-2.4.4/tests/failing-issue1845-paths-working-copy.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/failing-issue1845-paths-working-copy.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +## Test for issue1845 - darcs wants file paths from root of working copy +## +## Copyright (C) 2010 Guillaume Hoffmann +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. +cd R +mkdir subdir +touch subdir/subfile +darcs add subdir subdir/subfile +darcs record -am"add subdir and subfile" +cd subdir +rm subfile +darcs record subfile -am"delete file in subdirectory" # fails because darcs wants subdir/subfile + diff -ruN darcs-2.4.4/tests/failing-issue1848-rollback-p.sh darcs-2.5/tests/failing-issue1848-rollback-p.sh --- darcs-2.4.4/tests/failing-issue1848-rollback-p.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/failing-issue1848-rollback-p.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,36 @@ +#!/usr/bin/env bash +## Test for issue1848 - interactive selection of primitive patches +## should still work with rollback -p +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +echo 'f' > f +echo 'g' > g +darcs record -lam 'Add f and g' +echo ynq | darcs rollback -p 'f and g' +cd .. diff -ruN darcs-2.4.4/tests/failing-issue1909-unrecord-O-misses-tag.sh darcs-2.5/tests/failing-issue1909-unrecord-O-misses-tag.sh --- darcs-2.4.4/tests/failing-issue1909-unrecord-O-misses-tag.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/failing-issue1909-unrecord-O-misses-tag.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,20 @@ +#!/usr/bin/env bash +## issue1909: unrecord -O in tagged repo makes a busted bundle + +. lib + +rm -rf R +mkdir R +darcs init --repo R +echo a > R/a +darcs rec -lam a --repo R --ignore-times +darcs tag -m T --repo R +echo b > R/a +darcs rec -lam b --repo R --ignore-times +echo c > R/a +darcs rec -lam c --repo R --ignore-times + +darcs unpull -p c -a --repo R -O +cat c.dpatch +grep '^\[b' c.dpatch +grep TAG c.dpatch diff -ruN darcs-2.4.4/tests/filepath.sh darcs-2.5/tests/filepath.sh --- darcs-2.4.4/tests/filepath.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/filepath.sh 2010-10-24 08:29:26.000000000 -0700 @@ -103,7 +103,7 @@ # can handle .. path cd temp3 -darcs pull ../temp2 -p1 --all | grep -i 'Finished pulling' +darcs pull ../temp2 --set-default -p1 --all | grep -i 'Finished pulling' darcs pull --dry-run | grep hello2 cd a/b #[issue268] repodir with subdir diff -ruN darcs-2.4.4/tests/get.sh darcs-2.5/tests/get.sh --- darcs-2.4.4/tests/get.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/get.sh 2010-10-24 08:29:26.000000000 -0700 @@ -15,4 +15,5 @@ cd .. rm -rf temp2 darcs get temp1 --context="${abs_to_context}" temp2 -rm -rf temp1 temp2 +darcs changes --context --repo temp2 > repo2_context +diff -u "${abs_to_context}" repo2_context diff -ruN darcs-2.4.4/tests/issue1210-no-global-cache-in-sources.sh darcs-2.5/tests/issue1210-no-global-cache-in-sources.sh --- darcs-2.4.4/tests/issue1210-no-global-cache-in-sources.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1210-no-global-cache-in-sources.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,36 @@ +#!/usr/bin/env bash +## Test for issue1210 - 'global cache gets recorded in _darcs/prefs/sources' +## +## Copyright (C) 2010 Adolfo Builes +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +set -ev + +. lib + +cacheDir=$HOME/.darcs/cache + +rm -rf R S +darcs init --repo R +darcs get R S +not grep "$cacheDir" S/_darcs/prefs/sources +not grep "cache:" S/_darcs/prefs/sources \ No newline at end of file diff -ruN darcs-2.4.4/tests/issue121.sh darcs-2.5/tests/issue121.sh --- darcs-2.4.4/tests/issue121.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue121.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +## Test for issue121 - amend-record --ask-deps +## +## Copyright (C) 2009 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R +darcs init --repo R # Create our test repos. + +cd R +touch a +darcs add a +darcs rec --ignore-times -am 'add a' +(echo '1' ; echo '1' ; echo '1') > a +darcs rec --ignore-times -am 'patch X' +(echo '2' ; echo '1' ; echo '1') > a +darcs rec --ignore-times -am 'patch Y' +(echo '2' ; echo '1' ; echo '2') > a +darcs rec --ignore-times -am 'patch Z' + +darcs obliterate --dry-run --patch 'patch Y' | not grep 'patch Z' + +echo 'yy' | darcs amend-rec --ask-deps + +darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z' diff -ruN darcs-2.4.4/tests/issue1232_convert_forgets_prefs.sh darcs-2.5/tests/issue1232_convert_forgets_prefs.sh --- darcs-2.4.4/tests/issue1232_convert_forgets_prefs.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1232_convert_forgets_prefs.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,62 @@ +#!/usr/bin/env bash +## Test for issue1232 - When converting a repo to darcs2 format, +## the prefs file isn't copied. +## +## Copyright (C) 2010 Dino Morelli +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + + +# Test set-up where src repo DOES NOT already have a +# _darcs/prefs/prefs file + +# Another script may have left a mess +rm -rf R S + +# Create source repo +darcs init --old-fashioned-inventory --repo R + +# Perform the d1 to d2 conversion +echo "I understand the consequences of my action" | darcs convert R S + +# Check that the new repo is d2 +test -f S/_darcs/hashed_inventory + + +# Test set-up where src repo DOES have a _darcs/prefs/prefs file + +# Another script may have left a mess +rm -rf R S + +# Create source repo +darcs init --old-fashioned-inventory --repo R + +# Do something easy that will create a prefs file +darcs setpref test 'true' --repo R + +# Perform the d1 to d2 conversion +echo "I understand the consequences of my action" | darcs convert R S + +# Check that the prefs file was copied over +prefsPath="_darcs/prefs/prefs" +diff R/$prefsPath S/$prefsPath diff -ruN darcs-2.4.4/tests/issue1277-repo-format.sh darcs-2.5/tests/issue1277-repo-format.sh --- darcs-2.4.4/tests/issue1277-repo-format.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1277-repo-format.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,46 @@ +#!/usr/bin/env bash +## Test for issue1277 - repository format errors should be reported +## correctly (ie. not as some totally unrelated error) +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. +cd R + darcs init --repo R2 # Protect the darcs darcs repo with R + cd R2 + echo impossible >> _darcs/format + echo 'Example content.' > f + not darcs add f > log 2>&1 + grep "Can't understand repository format" log + not darcs whatsnew > log 2>&1 + grep "Can't understand repository format" log + not darcs init > log 2>&1 + grep "You may not run this command in a repository" log + grep "Can't understand repository format" log + cd .. + not darcs whatsnew --repodir R2 > log 2>&1 + grep "R2 looks like a repository directory," log + grep "Can't understand repository format" log +cd .. diff -ruN darcs-2.4.4/tests/issue1290-diff-index.sh darcs-2.5/tests/issue1290-diff-index.sh --- darcs-2.4.4/tests/issue1290-diff-index.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1290-diff-index.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,22 @@ +#!/usr/bin/env bash +## Test for issue1290 - darcs diff --index +## +## Public domain - 2010 Eric Kow + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R + echo '1' > f + darcs record -lam 'one' + echo '2' > f + darcs record -lam 'two' + echo '3' > f + darcs record -lam 'three' + echo '4' > f + darcs record -lam 'four' + darcs diff --from-patch one --to-patch two > d1 + darcs diff --index=3-4 > d2 # the numbers go backwards + diff -q d1 d2 +cd .. diff -ruN darcs-2.4.4/tests/issue1337_darcs_changes_false_positives.sh darcs-2.5/tests/issue1337_darcs_changes_false_positives.sh --- darcs-2.4.4/tests/issue1337_darcs_changes_false_positives.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1337_darcs_changes_false_positives.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +## Test for issue1337 - darcs changes shows unrelated patches +## Asking "darcs changes" about an unrecorded file d/f will list the +## patch that creates the parent directory d/ (instead of no patches). +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf temp1 +darcs init --repodir temp1 +cd temp1 +mkdir d +darcs record -lam d d +# We use --match 'touch d/f' instead of simply d/f because the latter +# prints "Changes to d/f:\n" before the count. +test 0 -eq "$(darcs changes --count --match 'touch d/f')" diff -ruN darcs-2.4.4/tests/issue1427_apply_gz.sh darcs-2.5/tests/issue1427_apply_gz.sh --- darcs-2.4.4/tests/issue1427_apply_gz.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1427_apply_gz.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,41 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp2 +darcs init + +cd ../temp1 +darcs init +touch foo bar +darcs add foo bar +darcs record -a -m add_foo_bar -A x +darcs mv foo zig +darcs mv bar foo +darcs mv zig bar +darcs record -a -m swap_foo_bar -A x +darcs send --author=me --output=funpatch --dont-sign -a ../temp2 + +gzip funpatch + +cd ../temp2 +darcs apply ../temp1/funpatch.gz +cd .. +cmp temp1/bar temp2/bar +rm -rf temp2 + +mkdir temp2 +cd temp2 +darcs init +darcs apply ../temp1/funpatch.gz +## Also test that "darcs apply" can accept a patch on stdin. +darcs obl -a +darcs apply < ../temp1/funpatch.gz +cd .. +cmp temp1/bar temp2/bar + + +rm -rf temp1 temp2 + diff -ruN darcs-2.4.4/tests/issue1473.sh darcs-2.5/tests/issue1473.sh --- darcs-2.4.4/tests/issue1473.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1473.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,42 @@ +#!/usr/bin/env bash +## Test for issue1473 - check that darcs annotate works with and without +## repodir and with "." argument. It should fail with the empty string as +## a single argument and without any arguments. +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. +. lib # Load some portability helpers. + +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +echo 'Example content.' > f +darcs record -lam 'Added f.' +darcs annotate . +darcs annotate f +not darcs annotate +not darcs annotate '' + +cd .. +darcs annotate --repodir=R . +darcs annotate --repodir=R f +not darcs annotate --repodir=R +not darcs annotate --repodir=R '' diff -ruN darcs-2.4.4/tests/issue1618-amend-preserve-logfile.sh darcs-2.5/tests/issue1618-amend-preserve-logfile.sh --- darcs-2.4.4/tests/issue1618-amend-preserve-logfile.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/issue1618-amend-preserve-logfile.sh 2010-10-24 08:29:26.000000000 -0700 @@ -32,7 +32,7 @@ darcs setpref test false darcs record -am foo --no-test export DARCS_EDITOR="echo 'new log' > " -echo y | not darcs amend -p foo --edit-long-comment 2> out +echo y | not darcs amend -p foo --edit-long-comment --test 2> out # the msg has the format: "Logfile left in filenamehere." LOGFILE=`grep "Logfile left in" out | sed "s/Logfile left in //" | sed s/.$//` diff -ruN darcs-2.4.4/tests/issue1620-record-lies-about-leaving-logfile.sh darcs-2.5/tests/issue1620-record-lies-about-leaving-logfile.sh --- darcs-2.4.4/tests/issue1620-record-lies-about-leaving-logfile.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/issue1620-record-lies-about-leaving-logfile.sh 2010-10-24 08:29:26.000000000 -0700 @@ -30,7 +30,7 @@ export DARCS_EDITOR="echo 'a log' > " darcs init darcs setpref test false -echo yy | not darcs record -m foo -a --edit-long-comment 2> out +echo yy | not darcs record -m foo -a --edit-long-comment --test 2> out # the msg has the format: "Logfile left in filenamehere." LOGFILE=`grep "Logfile left in" out | sed "s/Logfile left in //" | sed s/.$//` diff -ruN darcs-2.4.4/tests/issue1726_darcs_always-boring.sh darcs-2.5/tests/issue1726_darcs_always-boring.sh --- darcs-2.4.4/tests/issue1726_darcs_always-boring.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1726_darcs_always-boring.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,73 @@ +#!/usr/bin/env bash +## Test for issue1726 - Files whose names start with "_darcs" are considered +## boring, even if they don't match anything in the boring file, and even if +## you pass --boring to the command. +## +## Copyright (C) 2009 Daniel Dickison +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R + + +## First test expected failures with actual _darcs files/directories + +function bad_add { + filename="$1" + touch "$filename" + not darcs whatsnew -ls --boring + not darcs whatsnew -ls + not darcs add --boring "$filename" +} + +touch _darcs/foo +bad_add _darcs +bad_add _darcs/ +bad_add _darcs/foo +bad_add ./_darcs +bad_add ./_darcs/ +bad_add ./_darcs/foo +bad_add "$PWD/_darcs" +bad_add "$PWD/_darcs/" +bad_add "$PWD/_darcs/foo" +bad_add "../${PWD##*/}/_darcs" +bad_add "../${PWD##*/}/_darcs/" +bad_add "../${PWD##*/}/_darcs/foo" + + + +## Then test expected successes with files that aren't in _darcs + +# Passing --boring should definitely succeed. +touch _darcsfoo +darcs whatsnew -ls --boring +darcs add --boring _darcsfoo +darcs record -am 'add _darcsfoo' _darcsfoo + +# Without --boring, this tests the default boring file. +touch _darcsbar +darcs whatsnew -ls +darcs add _darcsbar +darcs record -am 'add _darcsbar' _darcsbar diff -ruN darcs-2.4.4/tests/issue1739-escape-multibyte-chars-correctly.sh darcs-2.5/tests/issue1739-escape-multibyte-chars-correctly.sh --- darcs-2.4.4/tests/issue1739-escape-multibyte-chars-correctly.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1739-escape-multibyte-chars-correctly.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,71 @@ +#!/usr/bin/env bash +## Test for issue1739 - "Char.intToDigit: not a digit" in darcs changes +## +## Copyright (C) 2010 Reinier Lamers +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +# First, try to see if character set is UTF-8. If we can't find out or if it +# isn't, we skip this test. +if ! which locale ; then + echo "no locale command" + exit 200 # skip test +fi + +charmap=`locale charmap` +if [ $? -ne 0 ]; then + echo "couldn't determine locale character set" + exit 200 # skip test +fi + +if [ "$charmap" != "UTF-8" ]; then + echo "locale character set is not UTF-8, skipping" + exit 200 +fi + +# we want escaping, otherwise output of non-ASCII characters is unreliable +export DARCS_DONT_ESCAPE_ANYTHING=0 + +rm -rf R +mkdir R +cd R +darcs init + +echo garbelbolf > aargh +darcs add aargh +echo -e '\xe2\x80\x9e\x54\x61\x20\x4d\xc3\xa8\x72\x65\xe2\x80\x9d' > message.txt +darcs record --logfile=message.txt -A 'Petra Testa van der Test ' -a > rec.txt +darcs changes > log.txt +cat log.txt +grep '' log.txt +grep '' log.txt +grep '' log.txt + +# locale should not matter +LC_ALL=C darcs changes > log.txt +grep '' log.txt +grep '' log.txt +grep '' log.txt + +cd .. + diff -ruN darcs-2.4.4/tests/issue1749-rmdir.sh darcs-2.5/tests/issue1749-rmdir.sh --- darcs-2.4.4/tests/issue1749-rmdir.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1749-rmdir.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,42 @@ +#!/usr/bin/env bash +## Test for issueXXX - darcs remove corrupts the patch sequence +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R +cd R + +mkdir dir +touch dir/file + +darcs add dir/file # adds dir too (which is fine) +darcs rec -a -m"add dir and file" + +darcs remove dir +darcs rec -a -m"remove dir" # removed dir but didn't remove file + +darcs obliterate -a --patch "remove dir" +darcs check + diff -ruN darcs-2.4.4/tests/issue1756_moves_index.sh darcs-2.5/tests/issue1756_moves_index.sh --- darcs-2.4.4/tests/issue1756_moves_index.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1756_moves_index.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +## Test for issue1756 - moving files between directories breaks index +## +## Copyright (C) 2010 Petr Rockai +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d e # Change the working tree. +echo 'a' > d/a +echo 'b' > d/b +echo 'c' > e/c +darcs record -lam '.' +darcs mv d/a e/ +darcs check --no-ignore-times +cd .. +rm -rf R + +darcs init --repo R +cd R +mkdir d e # Change the working tree. +echo 'a' > d/a +echo 'b' > e/b +darcs record -lam '.' +darcs mv d/a e/ +darcs check --no-ignore-times +cd .. +rm -rf R diff -ruN darcs-2.4.4/tests/issue1763-pull-fails-on-non-ascii-filenames.sh darcs-2.5/tests/issue1763-pull-fails-on-non-ascii-filenames.sh --- darcs-2.4.4/tests/issue1763-pull-fails-on-non-ascii-filenames.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1763-pull-fails-on-non-ascii-filenames.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,77 @@ +#!/usr/bin/env bash +## Test for issue1763 - When you pull in a conflicting hunk +## patch to a file with a non-ASCII name, and then pull from the same +## repo again, darcs crashes. +## +## Copyright (C) 2010 Reinier Lamers +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +abort_windows # FIXME! We should figure out what's going on here + +rm -rf R S +darcs init --repo R + +export LC_ALL=C + +function check_consistent_filename { + count=`darcs changes -v | grep 'hunk .*\.lisp' | sed -e 's/.*hunk //' -e 's/.lisp.*//' | sort | uniq | wc -l` + test $count -eq 1 +} + +# Set up a repo with 3 patches to a non-ASCII-named file +cd R +touch kitöltés.lisp +darcs rec -l -a -m "Add" +echo hi >> kitöltés.lisp +darcs record -a -m "First edit" +cd .. + +rm -rf S S2 S3 +darcs get R S +darcs get R S2 +darcs get R S3 + +cd R +echo hi >> kitöltés.lisp +darcs record -a -m "Second edit" +cd .. + +# From another repo, pull the first two, edit, pull the third to get a +# conflict, pull again to get the crash +cd S +echo hello >> kitöltés.lisp +darcs record -a -m "My edit" +darcs pull -a ../R +darcs pull -a ../R +check_consistent_filename +cd .. + +# duplicates +cd S2 +echo hi >> kitöltés.lisp +darcs record -a -m "My duplicate edit" +darcs pull -a ../R +darcs pull -a ../R +check_consistent_filename +cd .. diff -ruN darcs-2.4.4/tests/issue1825-remove-pending.sh darcs-2.5/tests/issue1825-remove-pending.sh --- darcs-2.4.4/tests/issue1825-remove-pending.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1825-remove-pending.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,43 @@ +#!/usr/bin/env bash +## Test for issue1825 - buggy pending when reverting a removed +## directory and file. +## +## Copyright (C) 2010 Ferenc Wagner +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir -p a +echo foo >a/b +darcs add -r a +darcs rec -am "add a/b" +rm -r a +darcs add # NB. not darcs add per se, but any operation which + # causes the pending patch to be detected (eg. remove, + # record + unrecord) + +# We have a legitimate pending patch so far. Now what? +darcs revert -a a/b diff -ruN darcs-2.4.4/tests/issue183_mv_order.sh darcs-2.5/tests/issue183_mv_order.sh --- darcs-2.4.4/tests/issue183_mv_order.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue183_mv_order.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +## Test for issue183 - mv and other patches should be in replayable +## order +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +touch f +darcs add f +darcs record -am 'Create f' +mkdir d +darcs add d +darcs mv f d +darcs record -am 'Create d and mv f in it' +cat > expected << EOF + A ./d/ + ./f -> ./d/f +EOF +darcs changes -s -p 'Create d' | grep "d/" > log +diff -q expected log +cd .. diff -ruN darcs-2.4.4/tests/issue1845-record-removed.sh darcs-2.5/tests/issue1845-record-removed.sh --- darcs-2.4.4/tests/issue1845-record-removed.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1845-record-removed.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,16 @@ +#!/usr/bin/env bash +## Test for issue1871 - darcs record f, for f a removed file should work +## +## Public domain - 2010 Petr Rockai + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +echo 'Example content.' > f +darcs rec -lam "first" +rm -f f +echo n | darcs record f 2>&1 | tee log +not grep "None of the files" log +cd .. diff -ruN darcs-2.4.4/tests/issue1857-pristine-conversion.sh darcs-2.5/tests/issue1857-pristine-conversion.sh --- darcs-2.4.4/tests/issue1857-pristine-conversion.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1857-pristine-conversion.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +## Test for issue1857 - upgrading the pristine format should either +## work or have no effect) even it happens before a failing operation +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf minimal-darcs-2.4 +tar zxf ../tests/repos/minimal-darcs-2.4.tgz + +cd minimal-darcs-2.4 +darcs check +darcs setpref test false +echo 'hi' > README +not darcs record -a -m argh --test +darcs check +cd .. diff -ruN darcs-2.4.4/tests/issue1860-incomplete-pristine.sh darcs-2.5/tests/issue1860-incomplete-pristine.sh --- darcs-2.4.4/tests/issue1860-incomplete-pristine.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1860-incomplete-pristine.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +## Copyright (C) 2010 Petr Rockai +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir tools +darcs rec -lam "add tools" +mkdir tools/cgi +echo bar > tools/cgi/README +darcs rec -lam "add cgi" +darcs move tools contrib +darcs rec -lam "rename tools/ to contrib/" +rm -rf contrib/cgi +darcs rec -lam "drop cgi" +cd .. + +darcs get R S +cd S +darcs show pristine +darcs unpull --last 2 -a +darcs show pristine +cd .. diff -ruN darcs-2.4.4/tests/issue1865-get-context.sh darcs-2.5/tests/issue1865-get-context.sh --- darcs-2.4.4/tests/issue1865-get-context.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1865-get-context.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,20 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +touch t.t +darcs add t.t +darcs record -am "initial add" +darcs tag -m tt +echo x > x +darcs rec -lam "x" x +darcs changes --context > my_context +abs_to_context="$(pwd)/my_context" +cd .. +darcs get temp1 --context="${abs_to_context}" temp2 +darcs changes --context --repo temp2 > repo2_context +diff -u "${abs_to_context}" repo2_context diff -ruN darcs-2.4.4/tests/issue1871-record-dot.sh darcs-2.5/tests/issue1871-record-dot.sh --- darcs-2.4.4/tests/issue1871-record-dot.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1871-record-dot.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +## Test for issue1871 - darcs record . should work for tracked changes +## in a subdirectory even if the subdirectory itself is not known yet. +## +## Public domain - 2010 Eric Kow + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d # Change the working tree. +echo 'Example content.' > d/f +darcs add d/f +echo n | darcs record +echo n | darcs record . > log +not grep "None of the files" log +cd .. diff -ruN darcs-2.4.4/tests/issue1873-apply-failed-to-read-patch.sh darcs-2.5/tests/issue1873-apply-failed-to-read-patch.sh --- darcs-2.4.4/tests/issue1873-apply-failed-to-read-patch.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1873-apply-failed-to-read-patch.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,55 @@ +#!/usr/bin/env bash +## Test for issue1873 - apply should complain about the right +## patches if it says some are missing +## +## Copyright (C) 2010 Petr Rockai +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf R S +mkdir R +darcs init --repo R + +cd R +echo a > a +darcs rec -lam a +echo b > a +darcs rec -lam b +echo x > x +darcs rec -lam x +echo c > a +darcs rec -lam c +echo y > y +darcs rec -lam y +echo d > a +darcs rec -lam d +cd .. + +darcs get R S +darcs unpull -p x -a --repo R +darcs send -p x -a --repo S -o R/x.dpatch +darcs unpull -p y -a --repo R +not darcs apply --repo R R/x.dpatch 2>&1 | tee log + +not grep '^ \* d' log # does not complain about an unrelated patch + grep '^ \* y' log # complains about the offending one instead diff -ruN darcs-2.4.4/tests/issue1875-honor-no-set-default.sh darcs-2.5/tests/issue1875-honor-no-set-default.sh --- darcs-2.4.4/tests/issue1875-honor-no-set-default.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1875-honor-no-set-default.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,39 @@ +#!/usr/bin/env bash +## Test for issue1875 - corner cases in which darcs may accidentally +## set default even though it's not supposed to +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. +darcs get R S --no-set-default +not find S/_darcs/prefs/defaultrepo +rm -rf S + +darcs init --repo S +cd S +darcs push ../R --dry-run +not grep '/R$' _darcs/prefs/defaultrepo +darcs push ../R +cd .. diff -ruN darcs-2.4.4/tests/issue1877_noisy_xml_output.sh darcs-2.5/tests/issue1877_noisy_xml_output.sh --- darcs-2.4.4/tests/issue1877_noisy_xml_output.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1877_noisy_xml_output.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +## Test for issue1877 - pull --dry-run --xml-output is noisy +## +## Copyright (C) 2010 Lele Gaifax +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. +darcs init --repo S + +cd R +echo 'Example content.' > foo +darcs record -lam 'Add foo.' +cd .. + +cd S + +# This does the right thing... at least until the second command is executed +darcs pull --dry-run --xml-output 2>&1 ../R | not grep "Would pull" + +# This does not, never +darcs pull --summary --dry-run --xml-output 2>&1 ../R | not grep "Would pull" + +# From now on, this fails too! +darcs pull --dry-run --xml-output 2>&1 ../R | not grep "Would pull" + +cd .. diff -ruN darcs-2.4.4/tests/issue1879-same-patchinfo-uncommon.sh darcs-2.5/tests/issue1879-same-patchinfo-uncommon.sh --- darcs-2.4.4/tests/issue1879-same-patchinfo-uncommon.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1879-same-patchinfo-uncommon.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,38 @@ +#!/usr/bin/env bash +## Test for issue1879 - we should at least notice that when a patch claims +## to have the same identity (patchinfo) as one of ours, then it should not +## depend on anything we don't have. +## +## Public domain - 2010 Eric Kow + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. +darcs init --repo S + +cd R +touch x1 +darcs add x1 +darcs record -am 'x1' +darcs changes --context > ctx +echo hello > f +echo world > x1 +darcs add f +darcs record -am 'hello world' +darcs send -a --context ctx -o foo.dpatch ../S +cd .. + +cd S +touch x2 +darcs add x2 +darcs record -am 'x2' +darcs changes --context > ctx +# create an evil wrong patch +sed -e '/Context:/,$d' -e 's/x1/x2/g' ../R/foo.dpatch > foo.dpatch +cat ctx >> foo.dpatch +darcs apply foo.dpatch +cd .. + +cd R +not darcs pull -a ../S > log 2>&1 +cd .. diff -ruN darcs-2.4.4/tests/issue1888-changes-context.sh darcs-2.5/tests/issue1888-changes-context.sh --- darcs-2.4.4/tests/issue1888-changes-context.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1888-changes-context.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,43 @@ +#!/usr/bin/env bash +## Test for issue1888 - changes --context is broken when topmost patch is a +## clean tag. + +## Copyright (C) 2010 Petr Rockai +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R + +echo a > a ; darcs rec -lam "patch_a" +darcs changes --context | grep patch_a + +darcs tag -m "tag_a" +darcs changes --context | not grep patch_a +darcs changes --context | grep tag_a + +echo b > a; darcs rec -lam "patch_b" +darcs changes --context | not grep patch_a +darcs changes --context | grep tag_a +darcs changes --context | grep patch_b diff -ruN darcs-2.4.4/tests/issue1898-set-default-notification.sh darcs-2.5/tests/issue1898-set-default-notification.sh --- darcs-2.4.4/tests/issue1898-set-default-notification.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1898-set-default-notification.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,54 @@ +#!/usr/bin/env bash +## Test for issue1898 - set-default mechanism +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R0 R1 R2 S # Another script may have left a mess. +darcs init --repo R0 # Create our test repos. + +darcs get R0 R1 +darcs get R0 R2 +darcs get R0 S + +cd S +# default to no-set-default +darcs push ../R1 > log +grep '/R0$' _darcs/prefs/defaultrepo +# notification when using no-set-default +grep "set-default" log +# set-default works +darcs push ../R1 --set-default > log +grep '/R1$' _darcs/prefs/defaultrepo +# no notification when already using --set-default +not grep "set-default" log +# no notification when already pushing to the default repo +darcs push > log +not grep "set-default" log +# no notification when it's just the --remote-repo +darcs push --remote-repo ../R1 > log +not grep "set-default" log +# but... notification still works in presence of remote-repo +darcs push --remote-repo ../R1 ../R2 > log +grep "set-default" log +cd .. diff -ruN darcs-2.4.4/tests/issue1913-diffing.sh darcs-2.5/tests/issue1913-diffing.sh --- darcs-2.4.4/tests/issue1913-diffing.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1913-diffing.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,39 @@ +#!/usr/bin/env bash +## Test for issue1913 - test for directory diffing +## +## Copyright (C) 2010 Ian Lynagh +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir foo +touch foo/foofile +darcs rec -l -a -m "foo patch" +mkdir bar +touch bar/barfile +rm -r foo +darcs rec -l -a -m "bar patch" +not darcs whatsnew -l +cd .. diff -ruN darcs-2.4.4/tests/issue1951-add-outside-repo.sh darcs-2.5/tests/issue1951-add-outside-repo.sh --- darcs-2.4.4/tests/issue1951-add-outside-repo.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/issue1951-add-outside-repo.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,151 @@ +#!/usr/bin/env bash +## Test for issue1951 - darcs should refuse adds from outside the +## current repository +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. + +rm -rf R R2 R3 R4 R5 R6 R7 R8 R9 R10 +darcs init --repo R # Create our test repos. +darcs init --repo R2 +darcs init --repo R3 +darcs init --repo R4 +darcs init --repo R5 +darcs init --repo R6 +darcs init --repo R7 +darcs init --repo R8 +darcs init --repo R9 +darcs init --repo R10 + +# test if adding files outside the repository fails + +OUTSIDE=`pwd` + +cd R +echo 'Example content.' > f +echo 'Bad' > ../junk-for-issue1951 +darcs add f +not darcs add ../junk-for-issue1951 +not darcs add $OUTSIDE/junk-for-issue1951 +darcs whatsnew > log +not grep junk-for-issue1951 log +cd .. + +# test adding a file that: +# * is in a subdirectory of the repository root +# * is referred to with a path relative to the cwd, when the cwd is the +# directory that the file is in +cd R2 +mkdir subdir +cd subdir +touch f +darcs add f +darcs whatsnew > log +grep 'subdir/f' log +cd ../.. + +# same as above, but now the relative path is valid both from the cwd and from +# the repository root. Darcs should add the file in the cwd, not the one in the +# repository root +cd R3 +touch f +mkdir subdir +cd subdir +touch f +darcs add f +darcs whatsnew > log +grep 'subdir/f' log +cd ../.. + +# now test that adding fails on a file that +# * is in the repository root +# * is referred to with a path relative to the repository root, when the cwd is +# not the repository root +cd R4 +touch myfilename +mkdir subdir +cd subdir +not darcs add myfilename +cd ../.. + +# test adding a file by relative path from the repo root, when the cwd is +# outside the repo +# It may seem counterintuitive that this succeeds and the cases above and below +# do not, but that's the way it is. We use this feature ourselves in our test +# suite. + +touch R5/myfilename +darcs add --repo R5 myfilename +darcs whatsnew --repo R5 > log +grep 'myfilename' log +not grep '\.\./myfilename' log + +# The case below makes the R4 case (of using a repo-root-relative path in a +# subdir of the repo) look even more like the R5 case (of using a +# repo-root-relative path outside the repo) by usign the --repo flag. It still +# failed on darcs 2.4. + +cd R6 +touch myfilename +mkdir subdir +cd subdir +not darcs add --repo .. myfilename +cd ../.. + +# Test adding a file by relative path from the repo root, when the cwd is +# outside the repo, and the relative path also exists from the cwd + +touch myfilename +touch R7/myfilename +darcs add --repo R7 myfilename +darcs whatsnew --repo R7 > log +grep 'myfilename' log +not grep '\.\.myfilename' log + +# Like the R4 case: try to use a path relative to the repo root from a cwd that +# is a subdir of the repo root. In this case the path relative to the repo root +# also includes a directory however. + +cd R8 +mkdir subdir1 +mkdir subdir2 +touch subdir2/myfilename +cd subdir1 +not darcs add subdir2/myfilename +cd ../.. + +# Try adding a non-repository file using a non-existent repo subdirectory name +# followed by two ..'s +touch myfilename +cd R9 +not darcs add nonexistentsubdir/../../myfilename +cd .. + +# Try adding a non-repository file using an existing repo subdirectory name +# followed by two ..'s +touch myfilename +cd R10 +mkdir subdir +not darcs add subdir/../../myfilename +cd .. diff -ruN darcs-2.4.4/tests/issue538.sh darcs-2.5/tests/issue538.sh --- darcs-2.4.4/tests/issue538.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/issue538.sh 2010-10-24 08:29:26.000000000 -0700 @@ -23,7 +23,7 @@ make_repo_with_test touch blaat darcs add blaat -if darcs record --set-scripts-executable -A test@test -am blaat ; then +if darcs record --set-scripts-executable -A test@test -am blaat --test; then echo "ok 1" else echo "not ok 1 recording second patch failed (because test failed?)" @@ -36,7 +36,7 @@ make_repo_with_test touch blaat darcs add blaat -if darcs record --dont-set-scripts-executable -A test@test -am blaat ; then +if darcs record --dont-set-scripts-executable -A test@test -am blaat --test; then echo "not ok 2 recording second patch succeeded though test script should not be executable" exit 1 else @@ -49,7 +49,7 @@ make_repo_with_test touch blaat darcs add blaat -if echo y | darcs amend-record --set-scripts-executable -A test@test -a ; then +if echo y | darcs amend-record --set-scripts-executable -A test@test -a --test; then echo "ok 3" else echo "not ok 3 amending patch failed (because test failed?)" @@ -62,7 +62,7 @@ make_repo_with_test touch blaat darcs add blaat -if echo y | darcs amend-record --dont-set-scripts-executable -A test@test -a /dev/null ; then +if echo y | darcs amend-record --dont-set-scripts-executable -A test@test -a /dev/null --test; then echo "not ok 4 amending patch succeeded even though --dont-set-scripts-executable specified" exit 1 else diff -ruN darcs-2.4.4/tests/lib darcs-2.5/tests/lib --- darcs-2.4.4/tests/lib 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/lib 2010-10-24 08:29:26.000000000 -0700 @@ -1,5 +1,5 @@ # This is a -*- sh -*- library. -set -vex +set -vex -o pipefail ## I would use the builtin !, but that has the wrong semantics. not () { "$@" && exit 1 || :; } @@ -25,11 +25,8 @@ exit 200 # skip test fi - latin9_locale=`locale -a | grep @euro | head -n 1` - if [ -z "$latin9_locale" ]; then - echo "no latin9 locale found" - exit 200 # skip, we can't switch away from UTF-8 - fi + latin9_locale=`locale -a | grep @euro | head -n 1` || exit 200 + test -n "$latin9_locale" || exit 200 echo "Using locale $latin9_locale" export LC_ALL=$latin9_locale diff -ruN darcs-2.4.4/tests/match-date.sh darcs-2.5/tests/match-date.sh --- darcs-2.4.4/tests/match-date.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/match-date.sh 2010-10-24 08:29:26.000000000 -0700 @@ -5,6 +5,17 @@ rm -rf temp1 # Some tests for the '--match' flag, specifically the date-matching +fmt_offset() { + if date -d "now${1}days" >& /dev/null; then + date -d "now${1}days" +"%Y%m%d" + elif date -v ${1}d >& /dev/null; then + date -v ${1}d +"%Y%m%d" + else + echo "Can't do date arithmetic on this system :(" >&2 + return 1 + fi +} + reset_repo () { cd .. rm -rf temp1 @@ -122,8 +133,10 @@ match_date 'last week' match_date 'last month' +fmt_offset -1 || exit 200 + reset_repo -create_entry "$(($year-1))-$mm-$dd" +create_entry "$(fmt_offset -350)" # english dates - new possibilities nomatch_date 'yesterday at 14:00:00' match_date 'last 3 years' diff -ruN darcs-2.4.4/tests/mergeresolved.sh darcs-2.5/tests/mergeresolved.sh --- darcs-2.4.4/tests/mergeresolved.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/mergeresolved.sh 2010-10-24 08:29:26.000000000 -0700 @@ -53,5 +53,3 @@ # At this point, tempB and tempA should agree since we have pulled both ways. cmp tempB/foo tempA/foo -rm -rf fooOld tempA tempB - diff -ruN darcs-2.4.4/tests/network/issue1503_prefer_local_caches_to_remote_one.sh darcs-2.5/tests/network/issue1503_prefer_local_caches_to_remote_one.sh --- darcs-2.4.4/tests/network/issue1503_prefer_local_caches_to_remote_one.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/network/issue1503_prefer_local_caches_to_remote_one.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,33 @@ +#!/usr/bin/env bash +## Test for issue1503 - 'Prefer local caches to remote ones' +## +## Copyright (C) 2010 Adolfo Builes +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf S T +darcs get --lazy http://darcs.net/testing/repo1 S +darcs tag --repo S -m 2 +darcs get --lazy http://darcs.net/testing/repo1 T +darcs pull --repo T S -a --debug --verbose 2>&1 | tee log +not grep repo1 log diff -ruN darcs-2.4.4/tests/output.sh darcs-2.5/tests/output.sh --- darcs-2.4.4/tests/output.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/output.sh 2010-10-24 08:29:26.000000000 -0700 @@ -30,7 +30,7 @@ diff -u ../patchfile ../correct rm ../patchfile -darcs send -a --dont-edit-description -o - ../../temp2 > ../patchfile +darcs send -a --set-default --dont-edit-description -o - ../../temp2 > ../patchfile grep -v Creating ../patchfile | diff -u ../correct - darcs apply --repodir=../../temp2 --dry-run ../patchfile > out diff -ruN darcs-2.4.4/tests/posthook.sh darcs-2.5/tests/posthook.sh --- darcs-2.4.4/tests/posthook.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/posthook.sh 2010-10-24 08:29:26.000000000 -0700 @@ -2,6 +2,8 @@ set -ev +. lib + rm -rf temp1 mkdir temp1 cd temp1 @@ -20,7 +22,35 @@ test -f posthook-ran rm posthook-ran -echo Successful. - cd .. rm -rf temp1 + +# POSIX-only section +# ---------------------------------------------------------------------- +# Things below this section do not appear to work on Windows. +# Pending further investigation at http://bugs.darcs.net/issue1813 + +if echo $OS | grep -i windows; then + exit 0 +fi + +# Check that DARCS_PATCHES_XML works +rm -rf R S # another script may have left a mess +darcs init --repo R # Create our test repos. +darcs init --repo S # Create our test repos. + +cd R +echo 'echo $DARCS_PATCHES_XML' > hook +darcs record -lam 'hook' +chmod u+x hook +cat > _darcs/prefs/defaults << END +apply run-posthook +apply posthook ./hook +END +cd .. + +cd S +echo 'Example content.' > f +darcs record -lam 'Add f' +darcs push -a ../R | grep 'patch author' +cd .. diff -ruN darcs-2.4.4/tests/printer.sh darcs-2.5/tests/printer.sh --- darcs-2.4.4/tests/printer.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/printer.sh 2010-10-24 08:29:26.000000000 -0700 @@ -63,21 +63,21 @@ test_line $(printf '\x1E') '[_^^_]' test_line $(printf '\x1F') '[_^__]' test_line $(printf '\x7F') '[_^?_]' -# other chars are escaped with \xXX +# other chars are escaped with test_line $(printf '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F')\ - '[_\80_][_\81_][_\82_][_\83_][_\84_][_\85_][_\86_][_\87_][_\88_][_\89_][_\8a_][_\8b_][_\8c_][_\8d_][_\8e_][_\8f_]' + '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F')\ - '[_\90_][_\91_][_\92_][_\93_][_\94_][_\95_][_\96_][_\97_][_\98_][_\99_][_\9a_][_\9b_][_\9c_][_\9d_][_\9e_][_\9f_]' + '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF')\ - '[_\a0_][_\a1_][_\a2_][_\a3_][_\a4_][_\a5_][_\a6_][_\a7_][_\a8_][_\a9_][_\aa_][_\ab_][_\ac_][_\ad_][_\ae_][_\af_]' + '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF')\ - '[_\b0_][_\b1_][_\b2_][_\b3_][_\b4_][_\b5_][_\b6_][_\b7_][_\b8_][_\b9_][_\ba_][_\bb_][_\bc_][_\bd_][_\be_][_\bf_]' + '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF')\ - '[_\c0_][_\c1_][_\c2_][_\c3_][_\c4_][_\c5_][_\c6_][_\c7_][_\c8_][_\c9_][_\ca_][_\cb_][_\cc_][_\cd_][_\ce_][_\cf_]' + '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF')\ - '[_\d0_][_\d1_][_\d2_][_\d3_][_\d4_][_\d5_][_\d6_][_\d7_][_\d8_][_\d9_][_\da_][_\db_][_\dc_][_\dd_][_\de_][_\df_]' + '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF')\ - '[_\e0_][_\e1_][_\e2_][_\e3_][_\e4_][_\e5_][_\e6_][_\e7_][_\e8_][_\e9_][_\ea_][_\eb_][_\ec_][_\ed_][_\ee_][_\ef_]' + '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' test_line $(printf '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF')\ - '[_\f0_][_\f1_][_\f2_][_\f3_][_\f4_][_\f5_][_\f6_][_\f7_][_\f8_][_\f9_][_\fa_][_\fb_][_\fc_][_\fd_][_\fe_][_\ff_]' + '[__][__][__][__][__][__][__][__][__][__][__][__][__][__][__][__]' rm -rf temp1 diff -ruN darcs-2.4.4/tests/pull_binary.sh darcs-2.5/tests/pull_binary.sh --- darcs-2.4.4/tests/pull_binary.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/pull_binary.sh 2010-10-24 08:29:26.000000000 -0700 @@ -19,7 +19,7 @@ mkdir temp2 cd temp2 darcs init -echo yn | darcs pull ../temp1 +echo yn | darcs pull --set-default ../temp1 rm foo darcs pull -a cd .. diff -ruN darcs-2.4.4/tests/pull-dont-prompt-deps.sh darcs-2.5/tests/pull-dont-prompt-deps.sh --- darcs-2.4.4/tests/pull-dont-prompt-deps.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/pull-dont-prompt-deps.sh 2010-10-24 08:29:26.000000000 -0700 @@ -22,10 +22,12 @@ echo bar2 > b darcs record -Ax -alm bar2 cd ../temp2 -echo y | darcs pull ../temp1 --dont-prompt-for-dependencies -p foo2 --dry-run > toto -#on the previous line, we don't get asked about foo1. -grep foo toto | wc -l | grep 2 -#but we send it anyway. +echo y | darcs pull ../temp1 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto +#on the previous line, we get asked about foo2, and we take it +grep foo2 toto | wc -l | grep 2 +#we don't get asked about foo1, but we take it anyway, so +grep foo1 toto | wc -l | grep 1 +#and we don't send bar grep bar toto | wc -l | grep 0 cd .. rm -rf temp1 temp2 diff -ruN darcs-2.4.4/tests/pull.sh darcs-2.5/tests/pull.sh --- darcs-2.4.4/tests/pull.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/pull.sh 2010-10-24 08:29:26.000000000 -0700 @@ -25,7 +25,7 @@ darcs add one; darcs record --patch-name uno --all cd .. # now outside of any repo -darcs pull --repodir temp1 --all temp2 | grep -i 'Finished pulling.' # temp2 is not relative to temp1 +darcs pull --set-default --repodir temp1 --all temp2 | grep -i 'Finished pulling.' # temp2 is not relative to temp1 # set up server repo date > temp2/one/date.t @@ -119,7 +119,7 @@ darcs record -am newdir cd ../temp2 mkdir newdir -darcs pull -a ../temp1 &> out2 +darcs pull -a --set-default ../temp1 &> out2 cat out grep Backing out2 grep 'Finished pulling' out2 diff -ruN darcs-2.4.4/tests/push-dont-prompt-deps.sh darcs-2.5/tests/push-dont-prompt-deps.sh --- darcs-2.4.4/tests/push-dont-prompt-deps.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/push-dont-prompt-deps.sh 2010-10-24 08:29:26.000000000 -0700 @@ -21,10 +21,12 @@ darcs record -Ax -alm foo2 echo bar2 > b darcs record -Ax -alm bar2 -echo y | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run > toto -#on the previous line, we don't get asked about foo1. -grep foo toto | wc -l | grep 2 -#but we send it anyway. +echo y | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run -i > toto +#on the previous line, we get asked about foo2, and we take it +grep foo2 toto | wc -l | grep 2 +#we don't get asked about foo1, but we take it anyway, so +grep foo1 toto | wc -l | grep 1 +#and we don't send bar grep bar toto | wc -l | grep 0 cd .. rm -rf temp1 temp2 diff -ruN darcs-2.4.4/tests/query_manifest.sh darcs-2.5/tests/query_manifest.sh --- darcs-2.4.4/tests/query_manifest.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/query_manifest.sh 2010-10-24 08:29:26.000000000 -0700 @@ -13,12 +13,13 @@ echo "./$x" >> dirs.tmp echo "./$x" >> files-dirs.tmp done - darcs query manifest $3 --files --no-directories | sort > darcs-files.tmp - darcs query manifest $3 --no-files --directories | sort > darcs-dirs.tmp - darcs query manifest $3 --files --directories | sort > darcs-files-dirs.tmp + darcs query manifest $3 --files --no-directories > darcsraw-files.tmp + darcs query manifest $3 --no-files --directories > darcsraw-dirs.tmp + darcs query manifest $3 --files --directories > darcsraw-files-dirs.tmp for x in files dirs files-dirs ; do - sort $x.tmp >sorted-$x.tmp - diff sorted-$x.tmp darcs-$x.tmp + sort $x.tmp | sed -e 's,\\,/,' > expected-$x.tmp + sort darcsraw-$x.tmp | sed -e 's,\\,/,' > darcs-$x.tmp + diff -u expected-$x.tmp darcs-$x.tmp done } rm -rf temp diff -ruN darcs-2.4.4/tests/record.sh darcs-2.5/tests/record.sh --- darcs-2.4.4/tests/record.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/record.sh 2010-10-24 08:29:26.000000000 -0700 @@ -24,12 +24,13 @@ # RT#231 - special message is given for nonexistent directories not darcs record -am foo not_there.txt > log -grep -i 'non existent' log +grep -i 'not exist' log # RT#231 - a nonexistent file before an existing file is handled correctly touch b.t -darcs record -am foo a.t b.t > log -grep -i 'non existent files or directories: "a.t"' log +darcs record -lam foo a.t b.t > log +grep -i 'WARNING:.*a.t' log +grep -iv 'WARNING:.*b.t' log DIR="`pwd`" touch date.t Binary files darcs-2.4.4/tests/repos/minimal-darcs-2.4.tgz and darcs-2.5/tests/repos/minimal-darcs-2.4.tgz differ diff -ruN darcs-2.4.4/tests/send-dont-prompt-deps.sh darcs-2.5/tests/send-dont-prompt-deps.sh --- darcs-2.4.4/tests/send-dont-prompt-deps.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/send-dont-prompt-deps.sh 2010-10-24 08:29:26.000000000 -0700 @@ -21,10 +21,12 @@ darcs record -Ax -alm foo2 echo bar2 > b darcs record -Ax -alm bar2 -echo y | darcs send ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run > toto -#on the previous line, we don't get asked about foo1. -grep foo toto | wc -l | grep 2 -#but we send it anyway. +echo y | darcs send ../temp2 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto +#on the previous line, we get asked about foo2, and we take it +grep foo2 toto | wc -l | grep 2 +#we don't get asked about foo1, but we take it anyway, so +grep foo1 toto | wc -l | grep 1 +#and we don't send bar grep bar toto | wc -l | grep 0 cd .. rm -rf temp1 temp2 diff -ruN darcs-2.4.4/tests/tentative_revert.sh darcs-2.5/tests/tentative_revert.sh --- darcs-2.4.4/tests/tentative_revert.sh 2010-05-23 01:58:08.000000000 -0700 +++ darcs-2.5/tests/tentative_revert.sh 2010-10-24 08:29:26.000000000 -0700 @@ -33,13 +33,13 @@ darcs record --repo R -lam 'bar' echo "this change should stay uncommitted" >> R/foo darcs setpref --repo R test false -echo 'y' | not darcs amend --repo R -am 'change everything' R/foo +echo 'y' | not darcs amend --repo R -am 'change everything' R/foo --test darcs setpref --repo R test true # if tentative state was not cleared, the previous changes # from failed transaction would piggy back on the next echo "xx" >> R/bar -echo 'y' | darcs amend --repo R -am 'bar2' R/bar +echo 'y' | darcs amend --repo R -am 'bar2' R/bar --test # should have uncommitted changes darcs wh --repo R > changes diff -ruN darcs-2.4.4/tests/trackdown-bisect-helper.hs darcs-2.5/tests/trackdown-bisect-helper.hs --- darcs-2.4.4/tests/trackdown-bisect-helper.hs 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/trackdown-bisect-helper.hs 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,38 @@ +{- + +Tool for construction of testing repository for trackdown testing +with bisect option. Written by Matthias Fischmann. + +Usage: + +./trackdown-bisect-helper '[0,1,1,1,0,0,0]' + +This will generate a repository in which `grep -q 1 j` will first fail +three times, then succeed three times, then fail once if you unapply +patches with the linear implementation. + +-} + + +import Control.Monad +import System.IO +import System +import System.Random +import Data.List +import Control.Exception + + +stamp i j = system ("echo " ++ show i ++ " > ./i") >> + system ("echo " ++ show j ++ " > ./j") >> + -- system ("sleep 1") >> + hFlush stdout >> + system ("darcs record --ignore-times -am '" ++ show i ++ "'") + +generate :: [Int] -> IO () +generate = mapM_ (uncurry stamp) . zip [1..] + +main :: IO () +main = do + args <- getArgs + let js = (read (head args)) :: [Int] + generate js diff -ruN darcs-2.4.4/tests/trackdown-bisect.sh darcs-2.5/tests/trackdown-bisect.sh --- darcs-2.4.4/tests/trackdown-bisect.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/trackdown-bisect.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,141 @@ +#!/bin/env bash +# A test for trackdown --bisect option. +# In general it construct various repositories and try +# to find the last recent failing patch and match it with +# expected position. +# +# It runs the same tests also for the trackdown without +# the --bisect. +################################################################ + +set -ev + +if echo $OS | grep -i windows; then + echo I do not know how to run a test program under windows + exit 0 +fi + +ghc -o trackdown-bisect-helper trackdown-bisect-helper.hs + +function make_repo_with_test { + rm -fr temp1 + mkdir temp1 ; cd temp1 ; darcs init + touch ./i + touch ./j + darcs add ./i + darcs add ./j + ../trackdown-bisect-helper $1 +} + +function cleanup_repo_after { + cd .. + rm -fr temp1 +} + +# You can remove --bisect for compare with linear trackdown +trackdown_args='--bisect' + +# Function return true if given patch was found. +# It expects that last line has finish with +# For the linear it is second last from the end, and last line +# is sentence if trackdown failed or succeed. +function is_found_good_patch { + if [ -z "$trackdown_args" ]; then + tail -n 2 | grep " $1\$" + else + tail -n 1 | grep " $1\$" + fi +} + +# Test command - Success condition is that file 'j' have one inside (1) +# That means if it has zero (0) it is failing test. +test_cmd='grep -q 1 j' + +############################################################################# +# Section with test-cases +############################################################################# + +# TEST01: Repo with success in the half +testTrackdown() { +make_repo_with_test $1 +if darcs trackdown $trackdown_args "$test_cmd" | is_found_good_patch $2; then + echo "ok 1" +else + echo "not ok 1. the trackdown should find last failing patch = $2." + exit 1 +fi +cleanup_repo_after +} + +# TEST01: Repo with success in the half +test01() { +testTrackdown '[1,1,0,0,0]' 3 +} + +# TEST02: Repo with without success condition +test02() { +testTrackdown '[0,0,0,0,0]' 1 +} + +# TEST03: Repo with with success condition at before last patch +test03() { +testTrackdown '[1,1,1,1,0]' 5 +} + +# TEST04: Repo with with success condition as first patch ever +test04() { +testTrackdown '[1,0,0,0,0]' 2 +} + +# TEST05: Long repo with with success condition as first patch ever +test05() { +testTrackdown '[1,0,0,0,0,0,0,0,0,0,0]' 2 +} + +# TEST06: Long repo with with success condition as sixth patch +test06() { +testTrackdown '[1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0]' 7 +} + +# TEST07: Long repo with with success condition very nead the head +test07() { +testTrackdown '[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0]' 54 +} + +# TEST08: Long repo with with success condition very nead the head +test08() { +testTrackdown '[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0]' 55 +} + +# TEST09: Long repo with non-monotone errors / success distribution +# This test only tests that it will not crash... +test09() { +testTrackdown '[1,1,1,1,1,1,0,0,0,0,1,0,0,1,0,0,0,0,0,0]' 7 +} + +############################################# +# call test-cases for trackdown linear +############################################# +trackdown_args='' +test01 +test02 +test03 +test04 +test05 +test06 +test07 +test08 +############################################# +# Call test-cases for trackdown bisect +############################################# +trackdown_args='--bisect' +test01 +test02 +test03 +test04 +test05 +test06 +test07 +test08 +test09 # only for --bisect + diff -ruN darcs-2.4.4/tests/utf8.sh darcs-2.5/tests/utf8.sh --- darcs-2.4.4/tests/utf8.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/utf8.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,189 @@ +#!/usr/bin/env bash +## Test for issue64 - Should store patch metadata in UTF-8 +## +## Copyright (C) 2009 Reinier Lamers +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +# Helper function: do a darcs changes --xml and grep the result for the first +# argument. If it is not found, exit with status 1. Otherwise, continue. The +# second argument is a text that describes what we're grepping for. +# If a third argument is given, it is used as the value for a --last option for +# darcs changes. +grep_changes () { + if [ -z "$3" ]; then + last="" + else + last="--last $3" + fi + + darcs changes $last --xml > changes.xml + if grep "$1" changes.xml ; then + echo "$2 OK" + else + echo "$2 not UTF-8-encoded!" + exit 1 + fi +} + + +# This file is encoded in ISO-8859-15 aka latin9. It was crafted with a hex editor. +# Please leave it this way :-) +switch_to_latin9_locale + +rm -rf temp1 +mkdir temp1 +cd temp1 + +darcs init + +# Test recording non-UTF-8-encoded non-latin1 ("funny") metadata from +# interactive input + +echo 'Selbstverständlich überraschend' > something.txt +darcs add something.txt + +echo 'l33tking¸0r@example.org' > interaction_script.txt +echo y >> interaction_script.txt +echo y >> interaction_script.txt +echo '¤uroh4xx0rz' >> interaction_script.txt +echo n >> interaction_script.txt + +unset DARCSEMAIL +unset DARCS_TESTING_PREFS_DIR +unset EMAIL +set +darcs record -i < interaction_script.txt +grep_changes 'l33tkingž0r@example.org' 'patch author from interactive prompt' +grep_changes '€uroh4xx0rz' 'patch name from interactive prompt' + +# Test recording funny metadata from command line + +echo 'Sogar überraschender' >> something.txt + +darcs record -a -A 'Jérôme Leb½uf' -m 'that will be ¤ 15, sir' + +grep_changes 'that will be € 15, sir' 'patch name from command line' +grep_changes 'Jérôme LebÅ“uf' 'patch author from command line' + +# Test recording funny metadata from a log file + +echo 'Am allerüberraschendsten' >> something.txt + +echo 'darcs is soms wat naïef aangaande tekstcodering' > log.txt +echo 'en zulke naïviteit is tegenwoordig passé, aldus ´i¸ek' >> log.txt +darcs record -a -A 'Jérôme Leb½uf' --logfile=log.txt + +grep_changes 'darcs is soms wat naïef aangaande tekstcodering' 'patch name from log file' +grep_changes 'en zulke naïviteit is tegenwoordig passé, aldus Žižek' 'patch log from log file' + +# Test recording funny metadata from environment, +export EMAIL='Slavoj ´i¸ek ' +rm _darcs/prefs/author +echo 'La la la, the more lines the better!' >> something.txt +darcs record -a -m 'Patch names are overrated' + +grep_changes 'Slavoj Žižek' 'author name from environment' + +# Test recording funny metadata from prefs files +echo '´ed is dead' > _darcs/prefs/author +echo '483 bottles of beer on the wall' >> something.txt +darcs record -a -m 'Patch by ´ed' + +grep_changes 'Žed is dead' 'author name from prefs file' + +# Test amend-recording funny metadata +echo 'No, it is really 484' >> something.txt +echo y | darcs amend-record -p 'Patch by ' -A '´ed is even deader' -a +grep_changes 'Žed is even deader' 'author name from amend-record command line flag' + +echo '#!/usr/bin/env bash' > editor +echo 'echo All my ¤s are gone > $1' >> editor # create an 'editor' that writes latin9 +chmod +x editor +export EDITOR="`pwd`/editor" +printf "y\ny\n" | darcs amend --edit -p 'Patch by ' +grep_changes 'All my €s are gone' 'description edited from amend-record' +grep_changes 'Žed is even deader' 'author name taken from draft in amend' + +# Test rollback recording funny metadata +printf "y\ny\n" | darcs rollback -p 's are gone' -A '´ee´ee' -m "No patch¤s by ´ed!" +grep_changes 'ŽeeŽee' 'Author name from rollback command line' +grep_changes 'No patch€s by Žed' 'Patch name from rollback command line' +grep_changes 'All my €s are gone' 'Patch name of rolled back patch' 1 +grep_changes 'Žed is even deader' 'Author name of rolled back patch' 1 + +# Test tag recording funny metadata +rm _darcs/prefs/author # Make tag be taken from EMAIL env variable +darcs tag -m '´ is my favorite letter' +grep_changes 'Slavoj Žižek' 'author name from environment with tag command' 1 +grep_changes 'Ž is my favorite letter' 'Tag name from command line' + +unset EMAIL +printf "´ors\ninitialcomment\n" | darcs tag --edit-long-comment +grep_changes Žors 'Author name from interactive prompt from tag command' +grep_changes 'All my €s are gone' 'Tag name from editor from tag command' 1 + +if grep ´ors _darcs/prefs/author ; then + echo 'Author name stored locale-encoded in prefs file after tag command, OK' +else + echo 'No locale-encoded author in prefs file after tag command!' + exit 1 +fi + +darcs tag -A Ad¸e -m 'La¸t call' +grep_changes Adže 'Author name from tag command line' 1 +grep_changes 'Lažt call' 'Tag name from tag command line (take 2)' 1 + +cd .. + +# test that UTF-8 metadata doesn't get mangled on get +rm -rf temp2 +darcs get temp1 temp2 +darcs changes --repodir temp1 --xml > temp1/changes.xml +darcs changes --repodir temp2 --xml > temp2/changes.xml +diff temp1/changes.xml temp2/changes.xml + +# and that it doesn't get mangled on push +rm -rf temp2 +mkdir temp2; darcs init --repodir temp2 +darcs push --repodir temp1 -a temp2 --set-default +darcs changes --repodir temp1 --xml > temp1/changes.xml +darcs changes --repodir temp2 --xml > temp2/changes.xml +diff temp1/changes.xml temp2/changes.xml + +# and that it doesn't get mangled on pull +rm -rf temp2 +mkdir temp2; darcs init --repodir temp2 +darcs pull --repodir temp2 -a temp1 +darcs changes --repodir temp1 --xml > temp1/changes.xml +darcs changes --repodir temp2 --xml > temp2/changes.xml +diff temp1/changes.xml temp2/changes.xml + +# and that it doesn't get mangled on send +rm -rf temp2 +mkdir temp2; darcs init --repodir temp2 +darcs send --repodir temp1 -a -o temp2/patch.dpatch +darcs apply --repodir temp2 -a temp2/patch.dpatch +darcs changes --repodir temp1 --xml > temp1/changes.xml +darcs changes --repodir temp2 --xml > temp2/changes.xml +diff temp1/changes.xml temp2/changes.xml diff -ruN darcs-2.4.4/tests/whatsnew-pending.sh darcs-2.5/tests/whatsnew-pending.sh --- darcs-2.4.4/tests/whatsnew-pending.sh 1969-12-31 16:00:00.000000000 -0800 +++ darcs-2.5/tests/whatsnew-pending.sh 2010-10-24 08:29:26.000000000 -0700 @@ -0,0 +1,15 @@ +#!/usr/bin/env bash +## Ensure that darcs whatsnew only lists relevant bits. +## Public Domain, 2010, Petr Rockai + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d e # Change the working tree. +echo 'Example content.' > d/f +darcs record -lam 'Add d/f and e.' +darcs remove d/f +not darcs wh e # | not grep f +cd ..