darcs-beta 2.4.98.1 → 2.4.98.2
raw patch · 26 files changed
+1471/−1350 lines, 26 filesdep ~basesetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
- Darcs.Arguments: optionFromDarcsoption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]
+ Darcs.Arguments: DarcsMutuallyExclusive :: [DarcsAtomicOption] -> ([DarcsFlag] -> [DarcsFlag]) -> DarcsOption
+ Darcs.Arguments: DarcsSingleOption :: DarcsAtomicOption -> DarcsOption
+ Darcs.Arguments: applyDefaults :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]
+ Darcs.Arguments: atomicOptions :: DarcsOption -> [DarcsAtomicOption]
+ Darcs.Arguments: data DarcsAtomicOption
+ Darcs.Arguments: nubOptions :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]
+ Darcs.Arguments: optionFromDarcsOption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]
+ Darcs.Flags: defaultFlag :: [DarcsFlag] -> DarcsFlag -> [DarcsFlag] -> [DarcsFlag]
- Darcs.Arguments: DarcsAbsPathOption :: [Char] -> [String] -> (AbsolutePath -> DarcsFlag) -> String -> String -> DarcsOption
+ Darcs.Arguments: DarcsAbsPathOption :: [Char] -> [String] -> (AbsolutePath -> DarcsFlag) -> String -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsAbsPathOrStdOption :: [Char] -> [String] -> (AbsolutePathOrStd -> DarcsFlag) -> String -> String -> DarcsOption
+ Darcs.Arguments: DarcsAbsPathOrStdOption :: [Char] -> [String] -> (AbsolutePathOrStd -> DarcsFlag) -> String -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsArgOption :: [Char] -> [String] -> (String -> DarcsFlag) -> String -> String -> DarcsOption
+ Darcs.Arguments: DarcsArgOption :: [Char] -> [String] -> (String -> DarcsFlag) -> String -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsMultipleChoiceOption :: [DarcsOption] -> DarcsOption
+ Darcs.Arguments: DarcsMultipleChoiceOption :: [DarcsAtomicOption] -> DarcsOption
- Darcs.Arguments: DarcsNoArgOption :: [Char] -> [String] -> DarcsFlag -> String -> DarcsOption
+ Darcs.Arguments: DarcsNoArgOption :: [Char] -> [String] -> DarcsFlag -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsOptAbsPathOption :: [Char] -> [String] -> String -> (AbsolutePath -> DarcsFlag) -> String -> String -> DarcsOption
+ Darcs.Arguments: DarcsOptAbsPathOption :: [Char] -> [String] -> String -> (AbsolutePath -> DarcsFlag) -> String -> String -> DarcsAtomicOption
- Darcs.Arguments: arein :: [DarcsOption] -> [DarcsFlag] -> Bool
+ Darcs.Arguments: arein :: DarcsOption -> [DarcsFlag] -> Bool
- Darcs.Arguments: isin :: (String -> DarcsFlag) -> [DarcsFlag] -> Bool
+ Darcs.Arguments: isin :: DarcsAtomicOption -> [DarcsFlag] -> Bool
- Darcs.Arguments: setDefault :: DarcsOption
+ Darcs.Arguments: setDefault :: Bool -> DarcsOption
Files
- Distribution/ShellHarness.hs +13/−5
- Setup.lhs +20/−9
- darcs-beta.cabal +377/−366
- release/distributed-context +1/−1
- src/Darcs/ArgumentDefaults.lhs +10/−10
- src/Darcs/Arguments.lhs +235/−159
- src/Darcs/Commands.lhs +6/−5
- src/Darcs/Commands/Get.lhs +1/−1
- src/Darcs/Commands/Optimize.lhs +3/−3
- src/Darcs/Commands/Pull.lhs +2/−2
- src/Darcs/Commands/Push.lhs +1/−1
- src/Darcs/Commands/Put.lhs +1/−1
- src/Darcs/Commands/Send.lhs +2/−1
- src/Darcs/Commands/WhatsNew.lhs +2/−2
- src/Darcs/Flags.hs +10/−1
- src/Darcs/Patch/Commute.lhs +4/−2
- src/Darcs/Patch/Match.lhs +1/−0
- src/Darcs/Repository.hs +1/−1
- src/Darcs/RunCommand.hs +9/−8
- src/Darcs/Test/Email.hs +1/−1
- src/Darcs/Test/Unit.lhs +766/−0
- src/Darcs/Witnesses/Show.hs +0/−3
- src/unit.hs +3/−0
- src/unit.lhs +0/−766
- tests/filepath.sh +1/−1
- tests/issue1865-get-context.sh +1/−1
Distribution/ShellHarness.hs view
@@ -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) @@ -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
Setup.lhs view
@@ -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 )@@ -55,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 ()@@ -201,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@@ -241,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@@ -340,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 ()@@ -357,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 =@@ -373,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
darcs-beta.cabal view
@@ -1,5 +1,5 @@ Name: darcs-beta-version: 2.4.98.1+version: 2.4.98.2 License: GPL License-file: COPYING Author: David Roundy <droundy@darcs.net>, <darcs-users@darcs.net>@@ -118,261 +118,265 @@ 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- PatternGuards- UndecidableInstances- ScopedTypeVariables- PatternSignatures- RankNTypes- GADTs- TypeOperators- if !flag(type-witnesses) buildable: False+ else+ buildable: True - if os(windows)- hs-source-dirs: src/win32- include-dirs: src/win32- other-modules: CtrlC- System.Posix- System.Posix.Files- System.Posix.IO- cpp-options: -DWIN32- c-sources: src/win32/send_email.c- build-depends: unix-compat >= 0.1.2+ hs-source-dirs: src+ include-dirs: src+ cpp-options: -DGADT_WITNESSES=1+ -- FIXME...+ c-sources: src/atomic_create.c+ src/fpstring.c+ src/maybe_relink.c+ src/umask.c+ src/Crypt/sha2.c+ -- this module isn't exported by libdarcs, so not included in the tarball+ -- if not mentioned+ other-modules: Darcs.Test.Patch.Check - 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,- 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+ 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 + 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,+ base >= 3,+ bytestring >= 0.9.0 && < 0.10,+ text >= 0.3,+ old-time == 1.0.*,+ directory == 1.0.*,+ process == 1.0.*,+ containers >= 0.1 && < 0.4,+ array >= 0.1 && < 0.4,+ random == 1.0.*,+ tar == 0.3.*,+ zlib >= 0.5.1.0 && < 0.6.0.0,+ QuickCheck >= 2.1.0.0,+ test-framework >= 0.2.2,+ test-framework-quickcheck2 >= 0.2.2+ if !os(windows)+ build-depends: unix >= 1.0 && < 2.5+ if flag(http)+ build-depends: network == 2.2.*,+ HTTP >= 3000.0 && < 4000.1++ -- ---------------------------------------------------------------------- -- darcs library -- ---------------------------------------------------------------------- Library- if flag(library)- buildable: True- else+ if !flag(library) buildable: False+ else+ buildable: True - hs-source-dirs: src- include-dirs: src+ hs-source-dirs: src+ include-dirs: src - 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+ 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+ 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+ 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+ 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 - if os(solaris)- cc-options: -DHAVE_SIGINFO_H+ if os(solaris)+ cc-options: -DHAVE_SIGINFO_H - 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,- tar == 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,+ tar == 0.3.* - if !os(windows)- build-depends: unix >= 1.0 && < 2.5+ if !os(windows)+ build-depends: unix >= 1.0 && < 2.5 - build-depends: base >= 3,- bytestring >= 0.9.0 && < 0.10,- text >= 0.3,+ build-depends: base >= 3,+ bytestring >= 0.9.0 && < 0.10,+ text >= 0.3, old-time == 1.0.*, directory == 1.0.*, process == 1.0.*,@@ -381,70 +385,71 @@ random == 1.0.* - -- 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+ -- 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+ if impl(ghc>=6.12)+ ghc-options: -fno-warn-unused-do-bind - ghc-prof-options: -prof -auto-all+ ghc-prof-options: -prof -auto-all - if flag(hpc)- ghc-prof-options: -fhpc+ 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)+ 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(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(curl) && !flag(http)) || flag(deps-only)+ buildable: False - if flag(mmap) && !os(windows)- build-depends: mmap >= 0.5 && < 0.6- cpp-options: -DHAVE_MMAP+ if flag(mmap) && !os(windows)+ build-depends: mmap >= 0.5 && < 0.6+ cpp-options: -DHAVE_MMAP - build-depends: zlib >= 0.5.1.0 && < 0.6.0.0+ build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 - -- The terminfo package cannot be built on Windows.- if flag(terminfo) && !os(windows)- build-depends: terminfo == 0.3.*- cpp-options: -DHAVE_TERMINFO+ -- The terminfo package cannot be built on Windows.+ if flag(terminfo) && !os(windows)+ build-depends: terminfo == 0.3.*+ cpp-options: -DHAVE_TERMINFO - if flag(color)- x-use-color:+ if flag(color)+ x-use-color: - extensions:- CPP,- ForeignFunctionInterface,- BangPatterns,- PatternGuards,- MagicHash,- UndecidableInstances,- DeriveDataTypeable,- GADTs,- TypeOperators,- ExistentialQuantification,- FlexibleContexts,- FlexibleInstances,- ScopedTypeVariables,- PatternSignatures,- KindSignatures,- TypeSynonymInstances,- Rank2Types,- RankNTypes,- GeneralizedNewtypeDeriving,- MultiParamTypeClasses+ 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@@ -463,7 +468,7 @@ -- 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+ ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs if impl(ghc>=6.12) ghc-options: -fno-warn-unused-do-bind@@ -563,6 +568,7 @@ FlexibleContexts, FlexibleInstances, ScopedTypeVariables,+ -- PatternSignatures is needed for GHC 6.8 PatternSignatures, KindSignatures, TypeSynonymInstances,@@ -576,32 +582,7 @@ -- ---------------------------------------------------------------------- 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.Info- 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-- if impl(ghc>=6.12)- ghc-options: -fno-warn-unused-do-bind-- ghc-prof-options: -prof -auto-all- if flag(threaded)- ghc-options: -threaded+ main-is: unit.hs if !flag(test) buildable: False@@ -621,27 +602,56 @@ test-framework-quickcheck2 >= 0.2.2 - cc-options: -D_REENTRANT+ hs-source-dirs: src+ include-dirs: src+ c-sources: src/atomic_create.c+ src/fpstring.c+ src/maybe_relink.c+ src/umask.c+ src/Crypt/sha2.c+ -- list all unit test modules not exported by libdarcs; otherwise Cabal won't+ -- include them in the tarball+ other-modules: Darcs.Test.Email+ Darcs.Test.Patch.Check+ Darcs.Test.Patch.Info+ Darcs.Test.Patch.QuickCheck+ Darcs.Test.Patch.Test+ Darcs.Test.Patch.Unit+ Darcs.Test.Unit - if os(windows)- hs-source-dirs: src/win32- include-dirs: src/win32- other-modules: CtrlC- System.Posix- System.Posix.Files- System.Posix.IO- cpp-options: -DWIN32- c-sources: src/win32/send_email.c- build-depends: unix-compat >= 0.1.2+ -- We need optimizations, regardless of what Hackage says+ -- Note: "if true" works around a cabal bug with order of flag composition+ if true+ ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs - if os(solaris)- cc-options: -DHAVE_SIGINFO_H+ if impl(ghc>=6.12)+ ghc-options: -fno-warn-unused-do-bind - if !os(windows)- build-depends: unix >= 1.0 && < 2.5+ ghc-prof-options: -prof -auto-all+ if flag(threaded)+ ghc-options: -threaded - build-depends: base >= 3,- bytestring >= 0.9.0 && < 0.10,+ cc-options: -D_REENTRANT++ if os(windows)+ hs-source-dirs: src/win32+ include-dirs: src/win32+ other-modules: CtrlC+ System.Posix+ System.Posix.Files+ System.Posix.IO+ cpp-options: -DWIN32+ c-sources: src/win32/send_email.c+ build-depends: unix-compat >= 0.1.2++ 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.*,@@ -652,43 +662,44 @@ hashed-storage == 0.5.2, random == 1.0.* - if flag(mmap) && !os(windows)- build-depends: mmap >= 0.5 && < 0.6- cpp-options: -DHAVE_MMAP+ if flag(mmap) && !os(windows)+ build-depends: mmap >= 0.5 && < 0.6+ cpp-options: -DHAVE_MMAP - build-depends: zlib >= 0.5.1.0 && < 0.6.0.0+ build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 - -- The terminfo package cannot be built on Windows.- if flag(terminfo) && !os(windows)- build-depends: terminfo == 0.3.*- cpp-options: -DHAVE_TERMINFO+ -- The terminfo package cannot be built on Windows.+ if flag(terminfo) && !os(windows)+ build-depends: terminfo == 0.3.*+ cpp-options: -DHAVE_TERMINFO - if flag(http)- build-depends: network == 2.2.*,- HTTP >= 3000.0 && < 4000.1+ if flag(http)+ build-depends: network == 2.2.*,+ HTTP >= 3000.0 && < 4000.1 - if flag(color)- x-use-color:+ if flag(color)+ x-use-color: - extensions:- CPP,- ForeignFunctionInterface,- BangPatterns,- PatternGuards,- MagicHash,- UndecidableInstances,- DeriveDataTypeable,- GADTs,- TypeOperators,- ExistentialQuantification,- FlexibleContexts,- FlexibleInstances,- ScopedTypeVariables,- PatternSignatures,- KindSignatures,- TypeSynonymInstances,- Rank2Types,- RankNTypes,- GeneralizedNewtypeDeriving,- MultiParamTypeClasses- OverlappingInstances+ 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
release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n"+Just "\nContext:\n\n[TAG 2.4.98.2\nReinier Lamers <tux_rocker@reinier.de>**20100726184946\n Ignore-this: 43a9f17e811c2172be76fb1b19aa1497\n] \n"
src/Darcs/ArgumentDefaults.lhs view
@@ -20,7 +20,8 @@ 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 )@@ -123,7 +124,8 @@ 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 getFlagsFrom :: String -> [DarcsOption] -> [DarcsFlag] -> [(String,String,String)] -> [DarcsFlag] getFlagsFrom com com_opts already defs =@@ -142,24 +144,22 @@ 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 defaultContent :: IO [String] -> IO [(String,String,String)] defaultContent = fmap (catMaybes . map (doline.words))
src/Darcs/Arguments.lhs view
@@ -21,13 +21,14 @@ #include "gadts.h" -module Darcs.Arguments ( DarcsFlag( .. ), flagToString,+module Darcs.Arguments ( DarcsFlag( .. ), flagToString, applyDefaults, nubOptions, maxCount, isin, arein, definePatches, defineChanges, fixFilePathOrStd, fixUrl, fixSubPaths, areFileArgs,- DarcsOption( .. ), optionFromDarcsoption,+ DarcsAtomicOption( .. ), atomicOptions,+ DarcsOption( .. ), optionFromDarcsOption, help, listOptions, listFiles, anyVerbosity, disable, restrictPaths, notest, test, workingRepoDir,@@ -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 )@@ -123,7 +123,7 @@ ioAbsolute, ioAbsoluteOrStd, makeAbsolute, makeAbsoluteOrStd, rootDirectory ) import Darcs.Patch.MatchData ( patchMatch )-import Darcs.Flags ( DarcsFlag(..), maxCount )+import Darcs.Flags ( DarcsFlag(..), maxCount, defaultFlag ) import Darcs.Repository ( withRepository ) import Darcs.Global ( darcsdir ) import Darcs.Lock ( writeLocaleFile )@@ -347,23 +347,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@@ -373,7 +365,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@@ -399,25 +391,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@@ -467,32 +505,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, allPatches, interactive, pipe,+pipeInteractive, allPipeInteractive, allInteractive, humanReadable, diffflags, allowProblematicFilenames, noskipBoring, askLongComment, matchOneNontag, changesReverse, creatorhash, changesFormat, matchOneContext, happyForwarding, sendToContext,@@ -505,12 +531,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} @@ -529,7 +553,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} @@ -541,7 +565,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} @@ -577,7 +602,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}@@ -592,9 +618,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@@ -623,7 +652,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} @@ -631,10 +660,10 @@ \input{Darcs/Patch/Match.lhs} \begin{code}-patchnameOption = DarcsArgOption ['m'] ["patch-name"]+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 =@@ -649,13 +678,15 @@ ] 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]+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@@ -675,7 +706,7 @@ "select changes starting with a tag matching REGEXP"] 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"@@ -714,7 +745,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 @@ -790,6 +821,7 @@ DarcsNoArgOption [] ["prompt-long-comment"] PromptLongComment "prompt for whether to edit the long comment"] +keepDate :: DarcsOption keepDate = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["keep-date"] KeepDate@@ -806,7 +838,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@@ -815,10 +847,10 @@ DarcsNoArgOption [] ["no-delete-logfile"] DontRmLogFile "keep the logfile when done [DEFAULT]"] -author = DarcsArgOption ['A'] ["author"] (Author . decodeString) "EMAIL"- "specify author id"-fromOpt = DarcsArgOption [] ["from"] (Author . decodeString) "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 = [@@ -888,10 +920,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@@ -914,8 +946,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@@ -923,16 +955,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@@ -940,7 +975,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@@ -951,16 +986,17 @@ 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" getOutput :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd@@ -969,16 +1005,19 @@ getOutput (_:flags) f = getOutput flags f getOutput [] _ = Nothing -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"]+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 = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME"- "name of version"+distnameOption = DarcsSingleOption $+ DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME" "name of version" +recursive :: String -> DarcsOption recursive h = DarcsMultipleChoiceOption [DarcsNoArgOption ['r'] ["recursive"] Recursive h,@@ -1003,15 +1042,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@@ -1034,11 +1073,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"@@ -1048,9 +1091,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",@@ -1058,13 +1104,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@@ -1080,7 +1131,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"]@@ -1105,8 +1157,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}@@ -1157,8 +1210,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]@@ -1225,16 +1278,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@@ -1250,15 +1306,22 @@ "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"-allPatches = DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches" +allPatches :: DarcsAtomicOption+allPatches =+ DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches"+ allInteractive = DarcsMultipleChoiceOption [allPatches, interactive] allPipeInteractive@@ -1298,14 +1361,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) =@@ -1320,8 +1388,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 [] = "&"@@ -1342,17 +1408,19 @@ "don't make scripts executable"] bisect :: DarcsOption-bisect = DarcsNoArgOption [] ["bisect"] Bisect+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.@@ -1362,11 +1430,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}@@ -1375,7 +1443,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"], [@@ -1427,7 +1496,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} @@ -1583,30 +1652,36 @@ \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]"],- DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining- "disable HTTP pipelining",- noCache, remoteDarcs- ]+ [ 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 = DarcsArgOption [] ["remote-darcs"] RemoteDarcs "COMMAND"+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 = DarcsNoArgOption [] ["http"] OptimizeHTTP+optimizeHTTP = DarcsSingleOption $+ DarcsNoArgOption [] ["http"] OptimizeHTTP "optimize repository for getting over network" \end{code} \begin{options}@@ -1618,7 +1693,7 @@ \begin{code} umaskOption :: DarcsOption-umaskOption =+umaskOption = DarcsSingleOption $ DarcsArgOption [] ["umask"] UMask "UMASK" "specify umask to use when writing" \end{code}@@ -1643,6 +1718,7 @@ the command line, when pulling or applying unknown patches. \begin{code}+restrictPaths :: DarcsOption restrictPaths = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["restrict-paths"] RestrictPaths@@ -1658,7 +1734,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}@@ -1674,7 +1750,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}@@ -1689,7 +1765,7 @@ This option specifies checking mode. \begin{code}-check =+check = DarcsSingleOption $ DarcsNoArgOption [] ["check"] Check "Specify checking mode" \end{code}@@ -1700,7 +1776,7 @@ This option specifies repair mode. \begin{code}-repair =+repair = DarcsSingleOption $ DarcsNoArgOption [] ["repair"] Repair "Specify repair mode"
src/Darcs/Commands.lhs view
@@ -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
src/Darcs/Commands/Get.lhs view
@@ -131,7 +131,7 @@ commandBasicOptions = [reponame, partial, matchOneContext,- setDefault,+ setDefault True, setScriptsExecutableOption, nolinks, getInventoryChoices]}
src/Darcs/Commands/Optimize.lhs view
@@ -45,7 +45,7 @@ flagsToSiblings, upgradeFormat, workingRepoDir, umaskOption, optimizePristine,- optimizeHTTP+ -- optimizeHTTP -- disabled for darcs-2.5 ) import Darcs.Repository.Prefs ( getPreflist ) import Darcs.Repository ( Repository,@@ -137,8 +137,8 @@ sibling, relink, relinkPristine, upgradeFormat,- optimizePristine,- optimizeHTTP]}+ optimizePristine+ ]} --optimizeHTTP]} -- disabled for 2.5 optimizeCmd :: [DarcsFlag] -> [String] -> IO () optimizeCmd origopts _ = do
src/Darcs/Commands/Pull.lhs view
@@ -128,7 +128,7 @@ ++dryRun++ [summary, depsSel,- setDefault,+ setDefault False, workingRepoDir, output, allowUnrelatedRepos]}@@ -159,7 +159,7 @@ useExternalMerge, test]++dryRun++[summary, depsSel,- setDefault,+ setDefault False, workingRepoDir, allowUnrelatedRepos]}
src/Darcs/Commands/Push.lhs view
@@ -93,7 +93,7 @@ allInteractive, sign]++dryRun++[summary, workingRepoDir,- setDefault,+ setDefault False, allowUnrelatedRepos]} pushCmd :: [DarcsFlag] -> [String] -> IO ()
src/Darcs/Commands/Put.lhs view
@@ -67,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."
src/Darcs/Commands/Send.lhs view
@@ -135,7 +135,8 @@ output,outputAutoName,sign] ++dryRun++[summary, editDescription,- setDefault, workingRepoDir,+ setDefault False,+ workingRepoDir, sendmailCmd, allowUnrelatedRepos]}
src/Darcs/Commands/WhatsNew.lhs view
@@ -30,7 +30,7 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds, ignoretimes, noskipBoring,- unified, summary, noCache,+ unified, summary, areFileArgs, fixSubPaths, listRegisteredFiles, )@@ -100,7 +100,7 @@ commandPrereq = amInRepository, commandGetArgPossibilities = listRegisteredFiles, commandArgdefaults = nodefaults,- commandAdvancedOptions = [ignoretimes, noskipBoring, noCache],+ commandAdvancedOptions = [ignoretimes, noskipBoring], commandBasicOptions = [summary, unified, lookforadds, workingRepoDir]}
src/Darcs/Flags.hs view
@@ -20,7 +20,8 @@ maxCount, willIgnoreTimes, willRemoveLogFile, isUnified, willStoreInMemory, doHappyForwarding, includeBoring, doAllowCaseOnly, doAllowWindowsReserved, doReverse,- showChangesOnlyToFiles+ showChangesOnlyToFiles,+ defaultFlag, ) where import Data.Maybe( fromMaybe ) import Darcs.Patch.MatchData ( PatchMatch )@@ -167,3 +168,11 @@ showChangesOnlyToFiles :: [DarcsFlag] -> Bool 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
src/Darcs/Patch/Commute.lhs view
@@ -783,9 +783,11 @@ -- |@modernizePatch@ is used during conversion to Darcs 2 format. -- It does the following:--- - removes mergers by linearising them, thus removing the ability+--+-- * removes mergers by linearising them, thus removing the ability -- to commute them--- - drops mv a b ; add b which was introduced by a bug in earlier+--+-- * 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
src/Darcs/Patch/Match.lhs view
@@ -354,6 +354,7 @@ 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
src/Darcs/Repository.hs view
@@ -238,7 +238,7 @@ debugMessage "Copying prefs" copyFileOrUrl opts (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs") (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return ()- if isFile fromDir+ if True -- isFile fromDir -- packs disabled for darcs 2.5 then copyNotPackedRepository fromRepo else do b <- (Just <$> fetchFileLazyPS (fromDir ++ "/" ++ darcsdir ++
src/Darcs/RunCommand.hs view
@@ -26,8 +26,8 @@ import Darcs.Arguments ( DarcsFlag(..), help,- optionFromDarcsoption,- listOptions )+ optionFromDarcsOption,+ listOptions, nubOptions ) import Darcs.ArgumentDefaults ( getDefaultFlags ) import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ), DarcsCommand,@@ -81,14 +81,14 @@ 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 $ getOptionsOptions (opts1++opts2) ++ unlines file_args+ 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@@ -104,7 +104,7 @@ formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++ " here.\n\n" ++ complaint Right () -> do- specops <- addCommandDefaults 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 +118,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"@@ -161,8 +162,8 @@ 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
src/Darcs/Test/Email.hs view
@@ -73,7 +73,7 @@ testProperty "Checking that there are no empty lines in email headers" $ \field value -> let headerLines = bsLines (formatHeader cleanField value) cleanField = cleanFieldString field- in all (not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines+ in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines bsLines :: B.ByteString -> [B.ByteString] bsLines = finalizeFold . B.foldr splitAtLines (B.empty, [])
+ src/Darcs/Test/Unit.lhs view
@@ -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:<Patch)] -> [String]+pairUnitTester _ [] = []+pairUnitTester thetest ((p1:<p2):ps)+ = (thetest p1 p2)++(pairUnitTester thetest ps)+\end{code}++\chapter{LCS}++Here are a few quick tests of the shiftBoundaries function.++\begin{code}+showLcsTests :: [String]+showLcsTests = concatMap checkKnownShifts knownShifts+checkKnownShifts :: ([Int],[Int],String,String,[Int],[Int])+ -> [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:<p1)|+ p1<-testPatches,+ p2<-filter (\p->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:<p2)|+ p1<-primitiveTestPatches,+ p2<-primitiveTestPatches,+ commute (p2:>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:<p2,p2':<p1') =+ case commute (p2:>p1) of+ Just (p1a:>p2a) ->+ if (p2a:< p1a) == (p2':< p1')+ then []+ else ["Commute gave wrong value!\n"++show p1++"\n"++show p2+ ++"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:<Patch,Patch:<Patch)]+knownCommutes = [+ (testhunk 1 [] ["A"]:<+ testhunk 2 [] ["B"],+ testhunk 3 [] ["B"]:<+ testhunk 1 [] ["A"]),+ (fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):<+ testhunk 2+ ["hello world all that is old is good old_"]+ ["I don't like old things"],+ testhunk 2+ ["hello world all that is new is good old_"]+ ["I don't like new things"]:<+ fromPrim (tokreplace "test" "A-Za-z_" "old" "new")),+ (testhunk 1 ["A"] ["B"]:<+ testhunk 2 ["C"] ["D"],+ testhunk 2 ["C"] ["D"]:<+ testhunk 1 ["A"] ["B"]),+ (fromPrim (rmfile "NwNSO"):<+ (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))),+ (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):<+ fromPrim (rmfile "NwNSO")),++ (quickmerge (testhunk 3 ["o"] ["n"]:\/:+ testhunk 3 ["o"] ["v"]):<+ testhunk 1 [] ["a"],+ testhunk 1 [] ["a"]:<+ quickmerge (testhunk 2 ["o"] ["n"]:\/:+ testhunk 2 ["o"] ["v"])),++ (testhunk 1 ["A"] []:<+ testhunk 3 ["B"] [],+ testhunk 2 ["B"] []:<+ testhunk 1 ["A"] []),++ (testhunk 1 ["A"] ["B"]:<+ testhunk 2 ["B"] ["C"],+ testhunk 2 ["B"] ["C"]:<+ testhunk 1 ["A"] ["B"]),++ (testhunk 1 ["A"] ["B"]:<+ testhunk 3 ["B"] ["C"],+ testhunk 3 ["B"] ["C"]:<+ testhunk 1 ["A"] ["B"]),++ (testhunk 1 ["A"] ["B","C"]:<+ testhunk 2 ["B"] ["C","D"],+ testhunk 3 ["B"] ["C","D"]:<+ testhunk 1 ["A"] ["B","C"])]+ where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)++checkCantCommute :: (Patch:< Patch) -> [String]+checkCantCommute (p1:<p2) =+ case commute (p2:>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}++
src/Darcs/Witnesses/Show.hs view
@@ -10,9 +10,6 @@ ShowDictClass :: Show a => ShowDict a ShowDictRecord :: (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowDict a -showsPrecR :: ShowDict a -> Int -> a -> ShowS-showsPrecR (ShowDictRecord x _ _) = x- showsPrecD :: ShowDict a -> Int -> a -> ShowS showsPrecD ShowDictClass = showsPrec showsPrecD (ShowDictRecord showsPrecR _ _) = showsPrecR
+ src/unit.hs view
@@ -0,0 +1,3 @@+module Main ( main ) where++import Darcs.Test.Unit ( main )
− src/unit.lhs
@@ -1,766 +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 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:<Patch)] -> [String]-pairUnitTester _ [] = []-pairUnitTester thetest ((p1:<p2):ps)- = (thetest p1 p2)++(pairUnitTester thetest ps)-\end{code}--\chapter{LCS}--Here are a few quick tests of the shiftBoundaries function.--\begin{code}-showLcsTests :: [String]-showLcsTests = concatMap checkKnownShifts knownShifts-checkKnownShifts :: ([Int],[Int],String,String,[Int],[Int])- -> [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:<p1)|- p1<-testPatches,- p2<-filter (\p->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:<p2)|- p1<-primitiveTestPatches,- p2<-primitiveTestPatches,- commute (p2:>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:<p2,p2':<p1') =- case commute (p2:>p1) of- Just (p1a:>p2a) ->- if (p2a:< p1a) == (p2':< p1')- then []- else ["Commute gave wrong value!\n"++show p1++"\n"++show p2- ++"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:<Patch,Patch:<Patch)]-knownCommutes = [- (testhunk 1 [] ["A"]:<- testhunk 2 [] ["B"],- testhunk 3 [] ["B"]:<- testhunk 1 [] ["A"]),- (fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):<- testhunk 2- ["hello world all that is old is good old_"]- ["I don't like old things"],- testhunk 2- ["hello world all that is new is good old_"]- ["I don't like new things"]:<- fromPrim (tokreplace "test" "A-Za-z_" "old" "new")),- (testhunk 1 ["A"] ["B"]:<- testhunk 2 ["C"] ["D"],- testhunk 2 ["C"] ["D"]:<- testhunk 1 ["A"] ["B"]),- (fromPrim (rmfile "NwNSO"):<- (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))),- (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):<- fromPrim (rmfile "NwNSO")),-- (quickmerge (testhunk 3 ["o"] ["n"]:\/:- testhunk 3 ["o"] ["v"]):<- testhunk 1 [] ["a"],- testhunk 1 [] ["a"]:<- quickmerge (testhunk 2 ["o"] ["n"]:\/:- testhunk 2 ["o"] ["v"])),-- (testhunk 1 ["A"] []:<- testhunk 3 ["B"] [],- testhunk 2 ["B"] []:<- testhunk 1 ["A"] []),-- (testhunk 1 ["A"] ["B"]:<- testhunk 2 ["B"] ["C"],- testhunk 2 ["B"] ["C"]:<- testhunk 1 ["A"] ["B"]),-- (testhunk 1 ["A"] ["B"]:<- testhunk 3 ["B"] ["C"],- testhunk 3 ["B"] ["C"]:<- testhunk 1 ["A"] ["B"]),-- (testhunk 1 ["A"] ["B","C"]:<- testhunk 2 ["B"] ["C","D"],- testhunk 3 ["B"] ["C","D"]:<- testhunk 1 ["A"] ["B","C"])]- where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)--checkCantCommute :: (Patch:< Patch) -> [String]-checkCantCommute (p1:<p2) =- case commute (p2:>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}--
tests/filepath.sh view
@@ -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
tests/issue1865-get-context.sh view
@@ -17,4 +17,4 @@ cd .. darcs get temp1 --context="${abs_to_context}" temp2 darcs changes --context --repo temp2 > repo2_context-diff -u ${abs_to_context} repo2_context+diff -u "${abs_to_context}" repo2_context