diff --git a/Distribution/ShellHarness.hs b/Distribution/ShellHarness.hs --- a/Distribution/ShellHarness.hs +++ b/Distribution/ShellHarness.hs @@ -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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/darcs-beta.cabal b/darcs-beta.cabal --- a/darcs-beta.cabal +++ b/darcs-beta.cabal @@ -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 , @@ -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 diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -Just "\nContext:\n\n" +Just "\nContext:\n\n[TAG 2.4.98.2\nReinier Lamers **20100726184946\n Ignore-this: 43a9f17e811c2172be76fb1b19aa1497\n] \n" diff --git a/src/Darcs/ArgumentDefaults.lhs b/src/Darcs/ArgumentDefaults.lhs --- a/src/Darcs/ArgumentDefaults.lhs +++ b/src/Darcs/ArgumentDefaults.lhs @@ -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)) diff --git a/src/Darcs/Arguments.lhs b/src/Darcs/Arguments.lhs --- a/src/Darcs/Arguments.lhs +++ b/src/Darcs/Arguments.lhs @@ -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" diff --git a/src/Darcs/Commands.lhs b/src/Darcs/Commands.lhs --- a/src/Darcs/Commands.lhs +++ b/src/Darcs/Commands.lhs @@ -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 diff --git a/src/Darcs/Commands/Get.lhs b/src/Darcs/Commands/Get.lhs --- a/src/Darcs/Commands/Get.lhs +++ b/src/Darcs/Commands/Get.lhs @@ -131,7 +131,7 @@ commandBasicOptions = [reponame, partial, matchOneContext, - setDefault, + setDefault True, setScriptsExecutableOption, nolinks, getInventoryChoices]} diff --git a/src/Darcs/Commands/Optimize.lhs b/src/Darcs/Commands/Optimize.lhs --- a/src/Darcs/Commands/Optimize.lhs +++ b/src/Darcs/Commands/Optimize.lhs @@ -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 diff --git a/src/Darcs/Commands/Pull.lhs b/src/Darcs/Commands/Pull.lhs --- a/src/Darcs/Commands/Pull.lhs +++ b/src/Darcs/Commands/Pull.lhs @@ -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]} diff --git a/src/Darcs/Commands/Push.lhs b/src/Darcs/Commands/Push.lhs --- a/src/Darcs/Commands/Push.lhs +++ b/src/Darcs/Commands/Push.lhs @@ -93,7 +93,7 @@ allInteractive, sign]++dryRun++[summary, workingRepoDir, - setDefault, + setDefault False, allowUnrelatedRepos]} pushCmd :: [DarcsFlag] -> [String] -> IO () diff --git a/src/Darcs/Commands/Put.lhs b/src/Darcs/Commands/Put.lhs --- a/src/Darcs/Commands/Put.lhs +++ b/src/Darcs/Commands/Put.lhs @@ -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." diff --git a/src/Darcs/Commands/Send.lhs b/src/Darcs/Commands/Send.lhs --- a/src/Darcs/Commands/Send.lhs +++ b/src/Darcs/Commands/Send.lhs @@ -135,7 +135,8 @@ output,outputAutoName,sign] ++dryRun++[summary, editDescription, - setDefault, workingRepoDir, + setDefault False, + workingRepoDir, sendmailCmd, allowUnrelatedRepos]} diff --git a/src/Darcs/Commands/WhatsNew.lhs b/src/Darcs/Commands/WhatsNew.lhs --- a/src/Darcs/Commands/WhatsNew.lhs +++ b/src/Darcs/Commands/WhatsNew.lhs @@ -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]} diff --git a/src/Darcs/Flags.hs b/src/Darcs/Flags.hs --- a/src/Darcs/Flags.hs +++ b/src/Darcs/Flags.hs @@ -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 diff --git a/src/Darcs/Patch/Commute.lhs b/src/Darcs/Patch/Commute.lhs --- a/src/Darcs/Patch/Commute.lhs +++ b/src/Darcs/Patch/Commute.lhs @@ -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 diff --git a/src/Darcs/Patch/Match.lhs b/src/Darcs/Patch/Match.lhs --- a/src/Darcs/Patch/Match.lhs +++ b/src/Darcs/Patch/Match.lhs @@ -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 diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -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 ++ diff --git a/src/Darcs/RunCommand.hs b/src/Darcs/RunCommand.hs --- a/src/Darcs/RunCommand.hs +++ b/src/Darcs/RunCommand.hs @@ -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 diff --git a/src/Darcs/Test/Email.hs b/src/Darcs/Test/Email.hs --- a/src/Darcs/Test/Email.hs +++ b/src/Darcs/Test/Email.hs @@ -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, []) diff --git a/src/Darcs/Test/Unit.lhs b/src/Darcs/Test/Unit.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Test/Unit.lhs @@ -0,0 +1,766 @@ +% Copyright (C) 2002-2005,2007 David Roundy +% +% This program is free software; you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation; either version 2, or (at your option) +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; see the file COPYING. If not, write to +% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +% Boston, MA 02110-1301, USA. + +\documentclass{report} +\usepackage{color} + +\usepackage{verbatim} +\newenvironment{code}{\color{blue}\verbatim}{\endverbatim} + +\begin{document} + +% Definition of title page: +\title{ + Unit Testing for darcs in Haskell +} +\author{ + David Roundy % insert author(s) here +} + +\maketitle + +\tableofcontents % Table of Contents + +\chapter{Introduction} + +This is a unit testing program, which is intended to make sure that all the +functions of my darcs code work properly. + +\begin{code} +{-# OPTIONS_GHC -cpp -fno-warn-orphans -fno-warn-deprecations -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +module Darcs.Test.Unit (main) where + +import System.IO.Unsafe ( unsafePerformIO ) +import ByteStringUtils hiding ( intercalate ) +import qualified Data.ByteString.Char8 as BC ( unpack, pack ) +import qualified Data.ByteString as B ( concat, empty ) +import Darcs.Patch +import Darcs.Test.Patch.Test +import Darcs.Test.Patch.Unit ( patchUnitTests ) +import Darcs.Test.Email ( emailParsing, emailHeaderNoLongLines, + emailHeaderAsciiChars, emailHeaderLinesStart, + emailHeaderNoEmptyLines ) +import Darcs.Test.Patch.Info ( metadataDecodingTest, metadataEncodingTest, + packUnpackTest ) +import Lcs ( shiftBoundaries ) +import Test.QuickCheck +import Printer ( renderPS ) +import Darcs.Patch.Commute +import Data.Array.Base +import Data.Array.Unboxed +import Control.Monad.ST +import Darcs.Witnesses.Ordered +import Darcs.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal ) +import Test.HUnit ( assertBool, assertFailure ) +import Test.Framework.Providers.QuickCheck2 ( testProperty ) +import Test.Framework.Providers.HUnit ( testCase ) +import Test.Framework.Runners.Console ( defaultMain ) +import Test.Framework ( Test ) + +#include "impossible.h" +\end{code} + +\chapter{Main body of code} + +\begin{code} +main :: IO () +main = do + putStr ("There are a total of "++(show (length primitiveTestPatches)) + ++" primitive patches.\n") + putStr ("There are a total of "++ + (show (length testPatches))++" patches.\n") + defaultMain tests + +-- | Utility function to run bools with test-framework +testBool :: String -> Bool -> Test +testBool name test = testCase name (assertBool assertName test) + where assertName = "boolean test \"" ++ name ++ "\" should return True" + +-- | Utility function to run old tests that return a list of error messages, +-- with the empty list meaning success. +testStringList :: String -> [String] -> Test +testStringList name test = testCase name $ mapM_ assertFailure test + +-- | This is the big list of tests that will be run using testrunner. +tests :: [Test] +tests = patchUnitTests ++ + [testBool "Checking that UTF-8 packing and unpacking preserves 'hello world'" + (unpackPSFromUTF8 (BC.pack "hello world") == "hello world"), + testBool "Checking that hex packing and unpacking preserves 'hello world'" + (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world") + == "hello world"), + emailParsing, + emailHeaderNoLongLines, + emailHeaderAsciiChars, + emailHeaderLinesStart, + emailHeaderNoEmptyLines, + testProperty "Checking that B.concat works" propConcatPS, + testProperty "Checking that hex conversion works" propHexConversion, + testProperty "Checking that show and read work right" propReadShow, + testStringList "Checking known commutes" commuteTests, + testStringList "Checking known merges" mergeTests, + testStringList "Checking known canons" canonizationTests] + ++ checkSubcommutes subcommutesInverse "patch and inverse both commute" + ++ checkSubcommutes subcommutesNontrivialInverse "nontrivial commutes are correct" + ++ checkSubcommutes subcommutesFailure "inverses fail" + ++ + [testProperty "Checking that commuting by patch and its inverse is ok" propCommuteInverse, + --putStr "Checking that conflict resolution is valid... " + --runQuickCheckTest returnval propResolveConflictsValid + testProperty "Checking that a patch followed by its inverse is identity" propPatchAndInverseIsIdentity, + -- The following tests are "wrong" with the Conflictor code. + --putStr "Checking that a simple smart_merge is sufficient... " + --runQuickCheckTest returnval propSimpleSmartMergeGoodEnough + --putStr "Checking that an elegant merge is sufficient... " + --runQuickCheckTest returnval propElegantMergeGoodEnough + testProperty "Checking that commutes are equivalent" propCommuteEquivalency, + testProperty "Checking that merges are valid" propMergeValid, + testProperty "Checking inverses being valid" propInverseValid, + testProperty "Checking other inverse being valid" propOtherInverseValid, + testStringList "Checking merge swaps" mergeSwapTests, + -- The patch generator isn't smart enough to generate correct test + -- cases for the following: (which will be obsoleted soon, anyhow) + --putStr "Checking the order dependence of unravel... " + --runQuickCheckTest returnval propUnravelOrderIndependent + --putStr "Checking the unravelling of three merges... " + --runQuickCheckTest returnval propUnravelThreeMerge + --putStr "Checking the unravelling of a merge of a sequence... " + --runQuickCheckTest returnval propUnravelSeqMerge + testProperty "Checking inverse of inverse" propInverseComposition, + testProperty "Checking the order of commutes" propCommuteEitherOrder, + testProperty "Checking commute either way" propCommuteEitherWay, + testProperty "Checking the double commute" propCommuteTwice, + testProperty "Checking that merges commute and are well behaved" propMergeIsCommutableAndCorrect, + testProperty "Checking that merges can be swapped" propMergeIsSwapable, + testProperty "Checking again that merges can be swapped (I'm paranoid) " propMergeIsSwapable, + testStringList "Checking that the patch validation works" testCheck, + testStringList "Checking commute/recommute" commuteRecommuteTests, + testStringList "Checking merge properties" genericMergeTests, + testStringList "Testing the lcs code" showLcsTests, + testStringList "Checking primitive patch IO functions" primitiveShowReadTests, + testStringList "Checking IO functions" showReadTests, + testStringList "Checking primitive commute/recommute" primitiveCommuteRecommuteTests, + metadataDecodingTest, + metadataEncodingTest, + packUnpackTest + ] +\end{code} + +\chapter{Unit Tester} + +The unit tester function is really just a glorified map for functions that +return lists, in which the lists get concatenated (where map would end up +with a list of lists). + +\begin{code} +type PatchUnitTest p = p -> [String] +type TwoPatchUnitTest = Patch -> Patch -> [String] + +parallelPairUnitTester :: TwoPatchUnitTest -> [(Patch:\/:Patch)] -> [String] +parallelPairUnitTester _ [] = [] +parallelPairUnitTester thetest ((p1:\/:p2):ps) + = (thetest p1 p2)++(parallelPairUnitTester thetest ps) + +pairUnitTester :: TwoPatchUnitTest -> [(Patch: [String] +pairUnitTester _ [] = [] +pairUnitTester thetest ((p1: [String] +checkKnownShifts (ca, cb, sa, sb, ca', cb') = runST ( + do ca_arr <- newListArray (0, length ca) $ toBool (0:ca) + cb_arr <- newListArray (0, length cb) $ toBool (0:cb) + let p_a = listArray (0, length sa) $ B.empty:(toPS sa) + p_b = listArray (0, length sb) $ B.empty:(toPS sb) + shiftBoundaries ca_arr cb_arr p_a 1 1 + shiftBoundaries cb_arr ca_arr p_b 1 1 + ca_res <- fmap (fromBool . tail) $ getElems ca_arr + cb_res <- fmap (fromBool . tail) $ getElems cb_arr + return $ if ca_res == ca' && cb_res == cb' then [] + else ["shiftBoundaries failed on "++sa++" and "++sb++" with " + ++(show (ca,cb))++" expected "++(show (ca', cb')) + ++" got "++(show (ca_res, cb_res))++"\n"]) + where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c]) + toBool = map (>0) + fromBool = map (\b -> if b then 1 else 0) + +knownShifts :: [([Int],[Int],String,String,[Int],[Int])] +knownShifts = + [([0,0,0],[0,1,0,1,0],"aaa","aaaaa", + [0,0,0],[0,0,0,1,1]), + ([0,1,0],[0,1,1,0],"cd ","c a ", + [0,1,0],[0,1,1,0]), + ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}", + [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end + ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}", + [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end + ([],[1,1],"","aa",[],[1,1]), + ([1,1],[],"aa","",[1,1],[])] + + +\end{code} + +\chapter{Show/Read tests} + +This test involves calling ``show'' to print a string describing a patch, +and then using readPatch to read it back in, and making sure the patch we +read in is the same as the original. Useful for making sure that I don't +have any stupid IO bugs. + +\begin{code} +showReadTests :: [String] +showReadTests = concatMap tShowRead testPatches ++ + concatMap tShowRead testPatchesNamed +primitiveShowReadTests :: [String] +primitiveShowReadTests = concatMap tShowRead primitiveTestPatches +tShowRead :: (Eq p, Show p, Patchy p) => PatchUnitTest p +tShowRead p = + case readPatch $ renderPS $ showPatch p of + Just (Sealed p',_) -> if p' == p then [] + else ["Failed to read shown: "++(show p)++"\n"] + Nothing -> ["Failed to read at all: "++(show p)++"\n"] + +instance MyEq p => Eq (Named p) where + (==) = unsafeCompare +\end{code} + +\chapter{Canonization tests} + +This is a set of known correct canonizations, to make sure that I'm +canonizing as I ought. + +\begin{code} +canonizationTests :: [String] +canonizationTests = concatMap checkKnownCanon knownCanons +checkKnownCanon :: (Patch, Patch) -> [String] +checkKnownCanon (p1,p2) = + if (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1) == p2 + then [] + else ["Canonization failed:\n"++show p1++"canonized is\n" + ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1 :: Patch) + ++"which is not\n"++show p2] +knownCanons :: [(Patch,Patch)] +knownCanons = + [(quickhunk 1 "abcde" "ab", quickhunk 3 "cde" ""), + (quickhunk 1 "abcde" "bd", join_patches [quickhunk 1 "a" "", + quickhunk 2 "c" "", + quickhunk 3 "e" ""]), + (join_patches [quickhunk 4 "a" "b", + quickhunk 1 "c" "d"], + join_patches [quickhunk 1 "c" "d", + quickhunk 4 "a" "b"]), + (join_patches [quickhunk 1 "a" "", + quickhunk 1 "" "b"], + quickhunk 1 "a" "b"), + (join_patches [quickhunk 1 "ab" "c", + quickhunk 1 "cd" "e"], + quickhunk 1 "abd" "e"), + (quickhunk 1 "abcde" "cde", quickhunk 1 "ab" ""), + (quickhunk 1 "abcde" "acde", quickhunk 2 "b" "")] +quickhunk :: Int -> String -> String -> Patch +quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o) + (map (\c -> BC.pack [c]) n) +\end{code} + +\chapter{Merge/unmgerge tests} + +It should always be true that if two patches can be unmerged, then merging +the resulting patches should give them back again. +\begin{code} +genericMergeTests :: [String] +genericMergeTests = + case take 400 [(p1:\/:p2)| + i <- [0..(length testPatches)-1], + p1<-[testPatches!!i], + p2<-drop i testPatches, + checkAPatch $ join_patches [invert p2,p1]] of + merge_pairs -> (parallelPairUnitTester tMergeEitherWayValid merge_pairs) ++ + (parallelPairUnitTester tMergeSwapMerge merge_pairs) +tMergeEitherWayValid :: TwoPatchUnitTest +tMergeEitherWayValid p1 p2 = + case join_patches [p2, quickmerge (p1:\/: p2)] of + combo2 -> + case join_patches [p1, quickmerge (p2:\/: p1)] of + combo1 -> + if not $ checkAPatch $ join_patches [combo1] + then ["oh my combo1 invalid:\n"++show p1++"and...\n"++show p2++show combo1] + else + if checkAPatch $ join_patches [invert combo1, combo2] + then [] + else ["merge both ways invalid:\n"++show p1++"and...\n"++show p2++ + show combo1++ + show combo2] +tMergeSwapMerge :: TwoPatchUnitTest +tMergeSwapMerge p1 p2 = + if (swapp $ merge (p2:\/: p1)) == merge (p1:\/:p2) + then [] + else ["Failed to swap merges:\n"++show p1++"and...\n"++show p2 + ++"merged:\n"++show (merge (p1:\/:p2))++"\n" + ++"merged and swapped:\n"++show (swapp $ merge (p2:\/: p1))++"\n"] + where swapp (x :/\: y) = y :/\: x + +instance Show p => Show (p :/\: p) where + show (x :/\: y) = show x ++ " :/\\: " ++ show y +instance Eq p => Eq (p :/\: p) where + (x :/\: y) == (x' :/\: y') = x == x' && y == y' +\end{code} + +\chapter{Commute/recommute tests} + +Here we test to see if commuting patch A and patch B and then commuting the +result gives us patch A and patch B again. The set of patches (A,B) is +chosen from the set of all pairs of test patches by selecting those which +commute with one another. + +\begin{code} +commuteRecommuteTests :: [String] +commuteRecommuteTests = + case take 200 [(p2:checkseq [p1,p]) testPatches, + commute (p1:>p2) /= Nothing] of + commute_pairs -> pairUnitTester tCommuteRecommute commute_pairs + where checkseq ps = checkAPatch $ join_patches ps +primitiveCommuteRecommuteTests :: [String] +primitiveCommuteRecommuteTests = + pairUnitTester tCommuteRecommute + [(p1:p1) /= Nothing, + checkAPatch $ join_patches [p2,p1]] +tCommuteRecommute :: TwoPatchUnitTest +tCommuteRecommute p1 p2 = + if (commute (p2:>p1) >>= commute) == Just (p2:>p1) + then [] + else ["Failed to recommute:\n"++(show p2)++(show p1)++ + "we saw it as:\n"++show (commute (p2:>p1))++ + "\nAnd recommute was:\n"++show (commute (p2:>p1) >>= commute) + ++ "\n"] +\end{code} + +\chapter{Commute tests} + +Here we provide a set of known interesting commutes. +\begin{code} +commuteTests :: [String] +commuteTests = + concatMap checkKnownCommute knownCommutes++ + concatMap checkCantCommute knownCantCommute +checkKnownCommute :: (Patch:< Patch, Patch:< Patch) -> [String] +checkKnownCommute (p1:p1) of + Just (p1a:>p2a) -> + if (p2a:< p1a) == (p2':< p1') + then [] + else ["Commute gave wrong value!\n"++show p1++"\n"++show p2 + ++"should be\n"++show p2'++"\n"++show p1' + ++"but is\n"++show p2a++"\n"++show p1a] + Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2] + ++ + case commute (p1':>p2') of + Just (p2a:>p1a) -> + if (p1a:< p2a) == (p1:< p2) + then [] + else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a + ++"should have been\n"++show p2'++"\n"++show p1'] + Nothing -> ["Commute failed!\n"++show p2'++"\n"++show p1'] +knownCommutes :: [(Patch: [String] +checkCantCommute (p1:p1) of + Nothing -> [] + _ -> [show p1 ++ "\n\n" ++ show p2 ++ + "\nArgh, these guys shouldn't commute!\n"] +knownCantCommute :: [(Patch:< Patch)] +knownCantCommute = [ + (testhunk 2 ["o"] ["n"]:< + testhunk 1 [] ["A"]), + (testhunk 1 [] ["A"]:< + testhunk 1 ["o"] ["n"]), + (quickmerge (testhunk 2 ["o"] ["n"]:\/: + testhunk 2 ["o"] ["v"]):< + testhunk 1 [] ["a"]), + (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):< + fromPrim (addfile "test"))] + where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n) +\end{code} + +\chapter{Merge tests} + +Here we provide a set of known interesting merges. +\begin{code} +mergeTests :: [String] +mergeTests = + concatMap checkKnownMergeEquiv knownMergeEquivs++ + concatMap checkKnownMerge knownMerges +checkKnownMerge :: (Patch:\/: Patch, Patch) -> [String] +checkKnownMerge (p1:\/:p2,p1') = + case merge (p1:\/:p2) of + _ :/\: p1a -> + if p1a == p1' + then [] + else ["Merge gave wrong value!\n"++show p1++show p2 + ++"I expected\n"++show p1' + ++"but found instead\n"++show p1a] +knownMerges :: [(Patch:\/:Patch,Patch)] +knownMerges = [ + (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/: + testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"], + testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]), + (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/: + testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"], + testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]), + (testhunk 3 [BC.pack "A"] []:\/: + testhunk 1 [BC.pack "B"] [], + testhunk 2 [BC.pack "A"] []), + (fromPrim (rmdir "./test/world"):\/: + fromPrim (hunk "./world" 3 [BC.pack "A"] []), + fromPrim (rmdir "./test/world")), + + (join_patches [quickhunk 1 "a" "bc", + quickhunk 6 "d" "ef"]:\/: + join_patches [quickhunk 3 "a" "bc", + quickhunk 8 "d" "ef"], + join_patches [quickhunk 1 "a" "bc", + quickhunk 7 "d" "ef"]), + + (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/: + testhunk 2 [BC.pack "B"] [BC.pack "C"], + testhunk 1 [BC.pack "A"] [BC.pack "B"]), + + (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/: + testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"], + testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"])] + where testhunk l o n = fromPrim $ hunk "test" l o n +checkKnownMergeEquiv :: (Patch:\/:Patch,Patch) -> [String] +checkKnownMergeEquiv (p1:\/: p2, pe) = + case quickmerge (p1:\/:p2) of + p1' -> if checkAPatch $ join_patches [invert p1, p2, p1', invert pe] + then [] + else ["Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2 + ++"in other words\n" ++ show (p1 :\/: p2) + ++"merges as\n" ++ show (merge $ p1 :\/: p2) + ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2) + ++"which is equivalent to\n" ++ show (effect p1') + ++ "should all work out to\n" + ++ show pe] +knownMergeEquivs :: [(Patch:\/: Patch, Patch)] +knownMergeEquivs = [ + + -- The following tests are going to be failed by the + -- Conflictor code as a cleanup. + + --(addfile "test":\/: + -- adddir "test", + -- join_patches [adddir "test", + -- addfile "test-conflict"]), + --(move "silly" "test":\/: + -- adddir "test", + -- join_patches [adddir "test", + -- move "silly" "test-conflict"]), + --(addfile "test":\/: + -- move "old" "test", + -- join_patches [addfile "test", + -- move "old" "test-conflict"]), + --(move "a" "test":\/: + -- move "old" "test", + -- join_patches [move "a" "test", + -- move "old" "test-conflict"]), + (fromPrim (hunk "test" 1 [] [BC.pack "A"]):\/: + fromPrim (hunk "test" 1 [] [BC.pack "B"]), + fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])), + (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/: + fromPrim (hunk "test" 1 [BC.pack "b"] []), + identity), + --hunk "test" 1 [] [BC.pack "v v v v v v v", + -- BC.pack "*************", + -- BC.pack "a", + -- BC.pack "b", + -- BC.pack "^ ^ ^ ^ ^ ^ ^"]), + (quickhunk 4 "a" "":\/: + quickhunk 3 "a" "", + quickhunk 3 "aa" ""), + (join_patches [quickhunk 1 "a" "bc", + quickhunk 6 "d" "ef"]:\/: + join_patches [quickhunk 3 "a" "bc", + quickhunk 8 "d" "ef"], + join_patches [quickhunk 3 "a" "bc", + quickhunk 8 "d" "ef", + quickhunk 1 "a" "bc", + quickhunk 7 "d" "ef"]), + (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a"):\/: + quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"), + quickhunk 2 "" "abdc") + ] +\end{code} + +It also is useful to verify that it doesn't matter which order we specify +the patches when we merge. + +\begin{code} +mergeSwapTests :: [String] +mergeSwapTests = + concat + [checkMergeSwap p1 p2 | + p1<-primitiveTestPatches, + p2<-primitiveTestPatches, + checkAPatch $ join_patches [invert p1,p2] + ] +checkMergeSwap :: Patch -> Patch -> [String] +checkMergeSwap p1 p2 = + case merge (p2:\/:p1) of + _ :/\: p2' -> + case merge (p1:\/:p2) of + _ :/\: p1' -> + case commute (p1:>p2') of + Just (_:>p1'b) -> + if p1'b /= p1' + then ["Merge swapping problem with...\np1 "++ + show p1++"merged with\np2 "++ + show p2++"p1' is\np1' "++ + show p1'++"p1'b is\np1'b "++ + show p1'b + ] + else [] + Nothing -> ["Merge commuting problem with...\np1 "++ + show p1++"merged with\np2 "++ + show p2++"gives\np2' "++ + show p2'++"which doesn't commute with p1.\n" + ] +\end{code} + +\chapter{Patch test data} + +This is where we define the set of patches which we run our tests on. This +should be kept up to date with as many interesting permutations of patch +types as possible. + +\begin{code} +testPatches :: [Patch] +testPatchesNamed :: [Named Patch] +testPatchesAddfile :: [Patch] +testPatchesRmfile :: [Patch] +testPatchesHunk :: [Patch] +primitiveTestPatches :: [Patch] +testPatchesBinary :: [Patch] +testPatchesCompositeNocom :: [Patch] +testPatchesComposite :: [Patch] +testPatchesTwoCompositeHunks :: [Patch] +testPatchesCompositeHunks :: [Patch] +testPatchesCompositeFourHunks :: [Patch] +testPatchesMerged :: [Patch] +validPatches :: [Patch] + +testPatchesNamed = [unsafePerformIO $ + namepatch "date is" "patch name" "David Roundy" [] + (fromPrim $ addfile "test"), + unsafePerformIO $ + namepatch "Sat Oct 19 08:31:13 EDT 2002" + "This is another patch" "David Roundy" + ["This log file has","two lines in it"] + (fromPrim $ rmfile "test")] +testPatchesAddfile = map fromPrim + [addfile "test",adddir "test",addfile "test/test"] +testPatchesRmfile = map invert testPatchesAddfile +testPatchesHunk = + [fromPrim $ hunk file line old new | + file <- ["test"], + line <- [1,2], + old <- map (map BC.pack) partials, + new <- map (map BC.pack) partials, + old /= new + ] + where partials = [["A"],["B"],[],["B","B2"]] + +primitiveTestPatches = testPatchesAddfile ++ + testPatchesRmfile ++ + testPatchesHunk ++ + [unsafeUnseal.fst.fromJust.readPatch $ + BC.pack "move ./test/test ./hello", + unsafeUnseal.fst.fromJust.readPatch $ + BC.pack "move ./test ./hello"] ++ + testPatchesBinary + +testPatchesBinary = + [fromPrim $ binary "./hello" + (BC.pack $ "agadshhdhdsa75745457574asdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg") + (BC.pack $ "adafjttkykrehhtrththrthrthre" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaagg"), + fromPrim $ binary "./hello" + B.empty + (BC.pack "adafjttkykrere")] + +testPatchesCompositeNocom = + take 50 [join_patches [p1,p2]| + p1<-primitiveTestPatches, + p2<-filter (\p->checkseq [p1,p]) primitiveTestPatches, + commute (p1:>p2) == Nothing] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesComposite = + take 100 [join_patches [p1,p2]| + p1<-primitiveTestPatches, + p2<-filter (\p->checkseq [p1,p]) primitiveTestPatches, + commute (p1:>p2) /= Nothing, + commute (p1:>p2) /= Just (p2:>p1)] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesTwoCompositeHunks = + take 100 [join_patches [p1,p2]| + p1<-testPatchesHunk, + p2<-filter (\p->checkseq [p1,p]) testPatchesHunk] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesCompositeHunks = + take 100 [join_patches [p1,p2,p3]| + p1<-testPatchesHunk, + p2<-filter (\p->checkseq [p1,p]) testPatchesHunk, + p3<-filter (\p->checkseq [p1,p2,p]) testPatchesHunk] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesCompositeFourHunks = + take 100 [join_patches [p1,p2,p3,p4]| + p1<-testPatchesHunk, + p2<-filter (\p->checkseq [p1,p]) testPatchesHunk, + p3<-filter (\p->checkseq [p1,p2,p]) testPatchesHunk, + p4<-filter (\p->checkseq [p1,p2,p3,p]) testPatchesHunk] + where checkseq ps = checkAPatch $ join_patches ps + +testPatchesMerged = + take 200 + [joinPatches $ flattenFL p2+>+flattenFL (quickmerge (p1:\/:p2)) | + p1<-take 10 (drop 15 testPatchesCompositeHunks)++primitiveTestPatches + ++take 10 (drop 15 testPatchesTwoCompositeHunks) + ++ take 2 (drop 4 testPatchesCompositeFourHunks), + p2<-take 10 testPatchesCompositeHunks++primitiveTestPatches + ++take 10 testPatchesTwoCompositeHunks + ++take 2 testPatchesCompositeFourHunks, + checkAPatch $ join_patches [invert p1, p2], + commute (p2:>p1) /= Just (p1:>p2) + ] + +testPatches = primitiveTestPatches ++ + testPatchesComposite ++ + testPatchesCompositeNocom ++ + testPatchesMerged +\end{code} + +\chapter{Check patch test} +Check patch is supposed to verify that a patch is valid. + +\begin{code} +validPatches = [(join_patches [quickhunk 4 "a" "b", + quickhunk 1 "c" "d"]), + (join_patches [quickhunk 1 "a" "bc", + quickhunk 1 "b" "d"]), + (join_patches [quickhunk 1 "a" "b", + quickhunk 1 "b" "d"])]++testPatches + +testCheck :: [String] +testCheck = concatMap tTestCheck validPatches +tTestCheck :: PatchUnitTest Patch +tTestCheck p = if checkAPatch p + then [] + else ["Failed the check: "++show p++"\n"] + +propHexConversion :: String -> Bool +propHexConversion s = + fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s +propConcatPS :: [String] -> Bool +propConcatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss) + +-- | Groups a set of tests by giving them the same prefix in their description. +-- When this is called as @checkSubcommutes subcoms expl@, the prefix for a +-- test becomes @"Checking " ++ expl ++ " for subcommute "@. +checkSubcommutes :: Testable a => [(String, a)] -> String + -> [Test] +checkSubcommutes subcoms expl = map check_subcommute subcoms + where check_subcommute (name, test) = + let testName = "Checking" ++ expl ++ " for subcommute " ++ name + in testProperty testName test +\end{code} + +\end{document} + + diff --git a/src/Darcs/Witnesses/Show.hs b/src/Darcs/Witnesses/Show.hs --- a/src/Darcs/Witnesses/Show.hs +++ b/src/Darcs/Witnesses/Show.hs @@ -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 diff --git a/src/unit.hs b/src/unit.hs new file mode 100644 --- /dev/null +++ b/src/unit.hs @@ -0,0 +1,3 @@ +module Main ( main ) where + +import Darcs.Test.Unit ( main ) diff --git a/src/unit.lhs b/src/unit.lhs deleted file mode 100644 --- a/src/unit.lhs +++ /dev/null @@ -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: [String] -pairUnitTester _ [] = [] -pairUnitTester thetest ((p1: [String] -checkKnownShifts (ca, cb, sa, sb, ca', cb') = runST ( - do ca_arr <- newListArray (0, length ca) $ toBool (0:ca) - cb_arr <- newListArray (0, length cb) $ toBool (0:cb) - let p_a = listArray (0, length sa) $ B.empty:(toPS sa) - p_b = listArray (0, length sb) $ B.empty:(toPS sb) - shiftBoundaries ca_arr cb_arr p_a 1 1 - shiftBoundaries cb_arr ca_arr p_b 1 1 - ca_res <- fmap (fromBool . tail) $ getElems ca_arr - cb_res <- fmap (fromBool . tail) $ getElems cb_arr - return $ if ca_res == ca' && cb_res == cb' then [] - else ["shiftBoundaries failed on "++sa++" and "++sb++" with " - ++(show (ca,cb))++" expected "++(show (ca', cb')) - ++" got "++(show (ca_res, cb_res))++"\n"]) - where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c]) - toBool = map (>0) - fromBool = map (\b -> if b then 1 else 0) - -knownShifts :: [([Int],[Int],String,String,[Int],[Int])] -knownShifts = - [([0,0,0],[0,1,0,1,0],"aaa","aaaaa", - [0,0,0],[0,0,0,1,1]), - ([0,1,0],[0,1,1,0],"cd ","c a ", - [0,1,0],[0,1,1,0]), - ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}", - [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end - ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}", - [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end - ([],[1,1],"","aa",[],[1,1]), - ([1,1],[],"aa","",[1,1],[])] - - -\end{code} - -\chapter{Show/Read tests} - -This test involves calling ``show'' to print a string describing a patch, -and then using readPatch to read it back in, and making sure the patch we -read in is the same as the original. Useful for making sure that I don't -have any stupid IO bugs. - -\begin{code} -showReadTests :: [String] -showReadTests = concatMap tShowRead testPatches ++ - concatMap tShowRead testPatchesNamed -primitiveShowReadTests :: [String] -primitiveShowReadTests = concatMap tShowRead primitiveTestPatches -tShowRead :: (Eq p, Show p, Patchy p) => PatchUnitTest p -tShowRead p = - case readPatch $ renderPS $ showPatch p of - Just (Sealed p',_) -> if p' == p then [] - else ["Failed to read shown: "++(show p)++"\n"] - Nothing -> ["Failed to read at all: "++(show p)++"\n"] - -instance MyEq p => Eq (Named p) where - (==) = unsafeCompare -\end{code} - -\chapter{Canonization tests} - -This is a set of known correct canonizations, to make sure that I'm -canonizing as I ought. - -\begin{code} -canonizationTests :: [String] -canonizationTests = concatMap checkKnownCanon knownCanons -checkKnownCanon :: (Patch, Patch) -> [String] -checkKnownCanon (p1,p2) = - if (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1) == p2 - then [] - else ["Canonization failed:\n"++show p1++"canonized is\n" - ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1 :: Patch) - ++"which is not\n"++show p2] -knownCanons :: [(Patch,Patch)] -knownCanons = - [(quickhunk 1 "abcde" "ab", quickhunk 3 "cde" ""), - (quickhunk 1 "abcde" "bd", join_patches [quickhunk 1 "a" "", - quickhunk 2 "c" "", - quickhunk 3 "e" ""]), - (join_patches [quickhunk 4 "a" "b", - quickhunk 1 "c" "d"], - join_patches [quickhunk 1 "c" "d", - quickhunk 4 "a" "b"]), - (join_patches [quickhunk 1 "a" "", - quickhunk 1 "" "b"], - quickhunk 1 "a" "b"), - (join_patches [quickhunk 1 "ab" "c", - quickhunk 1 "cd" "e"], - quickhunk 1 "abd" "e"), - (quickhunk 1 "abcde" "cde", quickhunk 1 "ab" ""), - (quickhunk 1 "abcde" "acde", quickhunk 2 "b" "")] -quickhunk :: Int -> String -> String -> Patch -quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o) - (map (\c -> BC.pack [c]) n) -\end{code} - -\chapter{Merge/unmgerge tests} - -It should always be true that if two patches can be unmerged, then merging -the resulting patches should give them back again. -\begin{code} -genericMergeTests :: [String] -genericMergeTests = - case take 400 [(p1:\/:p2)| - i <- [0..(length testPatches)-1], - p1<-[testPatches!!i], - p2<-drop i testPatches, - checkAPatch $ join_patches [invert p2,p1]] of - merge_pairs -> (parallelPairUnitTester tMergeEitherWayValid merge_pairs) ++ - (parallelPairUnitTester tMergeSwapMerge merge_pairs) -tMergeEitherWayValid :: TwoPatchUnitTest -tMergeEitherWayValid p1 p2 = - case join_patches [p2, quickmerge (p1:\/: p2)] of - combo2 -> - case join_patches [p1, quickmerge (p2:\/: p1)] of - combo1 -> - if not $ checkAPatch $ join_patches [combo1] - then ["oh my combo1 invalid:\n"++show p1++"and...\n"++show p2++show combo1] - else - if checkAPatch $ join_patches [invert combo1, combo2] - then [] - else ["merge both ways invalid:\n"++show p1++"and...\n"++show p2++ - show combo1++ - show combo2] -tMergeSwapMerge :: TwoPatchUnitTest -tMergeSwapMerge p1 p2 = - if (swapp $ merge (p2:\/: p1)) == merge (p1:\/:p2) - then [] - else ["Failed to swap merges:\n"++show p1++"and...\n"++show p2 - ++"merged:\n"++show (merge (p1:\/:p2))++"\n" - ++"merged and swapped:\n"++show (swapp $ merge (p2:\/: p1))++"\n"] - where swapp (x :/\: y) = y :/\: x - -instance Show p => Show (p :/\: p) where - show (x :/\: y) = show x ++ " :/\\: " ++ show y -instance Eq p => Eq (p :/\: p) where - (x :/\: y) == (x' :/\: y') = x == x' && y == y' -\end{code} - -\chapter{Commute/recommute tests} - -Here we test to see if commuting patch A and patch B and then commuting the -result gives us patch A and patch B again. The set of patches (A,B) is -chosen from the set of all pairs of test patches by selecting those which -commute with one another. - -\begin{code} -commuteRecommuteTests :: [String] -commuteRecommuteTests = - case take 200 [(p2:checkseq [p1,p]) testPatches, - commute (p1:>p2) /= Nothing] of - commute_pairs -> pairUnitTester tCommuteRecommute commute_pairs - where checkseq ps = checkAPatch $ join_patches ps -primitiveCommuteRecommuteTests :: [String] -primitiveCommuteRecommuteTests = - pairUnitTester tCommuteRecommute - [(p1:p1) /= Nothing, - checkAPatch $ join_patches [p2,p1]] -tCommuteRecommute :: TwoPatchUnitTest -tCommuteRecommute p1 p2 = - if (commute (p2:>p1) >>= commute) == Just (p2:>p1) - then [] - else ["Failed to recommute:\n"++(show p2)++(show p1)++ - "we saw it as:\n"++show (commute (p2:>p1))++ - "\nAnd recommute was:\n"++show (commute (p2:>p1) >>= commute) - ++ "\n"] -\end{code} - -\chapter{Commute tests} - -Here we provide a set of known interesting commutes. -\begin{code} -commuteTests :: [String] -commuteTests = - concatMap checkKnownCommute knownCommutes++ - concatMap checkCantCommute knownCantCommute -checkKnownCommute :: (Patch:< Patch, Patch:< Patch) -> [String] -checkKnownCommute (p1:p1) of - Just (p1a:>p2a) -> - if (p2a:< p1a) == (p2':< p1') - then [] - else ["Commute gave wrong value!\n"++show p1++"\n"++show p2 - ++"should be\n"++show p2'++"\n"++show p1' - ++"but is\n"++show p2a++"\n"++show p1a] - Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2] - ++ - case commute (p1':>p2') of - Just (p2a:>p1a) -> - if (p1a:< p2a) == (p1:< p2) - then [] - else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a - ++"should have been\n"++show p2'++"\n"++show p1'] - Nothing -> ["Commute failed!\n"++show p2'++"\n"++show p1'] -knownCommutes :: [(Patch: [String] -checkCantCommute (p1:p1) of - Nothing -> [] - _ -> [show p1 ++ "\n\n" ++ show p2 ++ - "\nArgh, these guys shouldn't commute!\n"] -knownCantCommute :: [(Patch:< Patch)] -knownCantCommute = [ - (testhunk 2 ["o"] ["n"]:< - testhunk 1 [] ["A"]), - (testhunk 1 [] ["A"]:< - testhunk 1 ["o"] ["n"]), - (quickmerge (testhunk 2 ["o"] ["n"]:\/: - testhunk 2 ["o"] ["v"]):< - testhunk 1 [] ["a"]), - (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):< - fromPrim (addfile "test"))] - where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n) -\end{code} - -\chapter{Merge tests} - -Here we provide a set of known interesting merges. -\begin{code} -mergeTests :: [String] -mergeTests = - concatMap checkKnownMergeEquiv knownMergeEquivs++ - concatMap checkKnownMerge knownMerges -checkKnownMerge :: (Patch:\/: Patch, Patch) -> [String] -checkKnownMerge (p1:\/:p2,p1') = - case merge (p1:\/:p2) of - _ :/\: p1a -> - if p1a == p1' - then [] - else ["Merge gave wrong value!\n"++show p1++show p2 - ++"I expected\n"++show p1' - ++"but found instead\n"++show p1a] -knownMerges :: [(Patch:\/:Patch,Patch)] -knownMerges = [ - (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/: - testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"], - testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]), - (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/: - testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"], - testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]), - (testhunk 3 [BC.pack "A"] []:\/: - testhunk 1 [BC.pack "B"] [], - testhunk 2 [BC.pack "A"] []), - (fromPrim (rmdir "./test/world"):\/: - fromPrim (hunk "./world" 3 [BC.pack "A"] []), - fromPrim (rmdir "./test/world")), - - (join_patches [quickhunk 1 "a" "bc", - quickhunk 6 "d" "ef"]:\/: - join_patches [quickhunk 3 "a" "bc", - quickhunk 8 "d" "ef"], - join_patches [quickhunk 1 "a" "bc", - quickhunk 7 "d" "ef"]), - - (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/: - testhunk 2 [BC.pack "B"] [BC.pack "C"], - testhunk 1 [BC.pack "A"] [BC.pack "B"]), - - (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/: - testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"], - testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"])] - where testhunk l o n = fromPrim $ hunk "test" l o n -checkKnownMergeEquiv :: (Patch:\/:Patch,Patch) -> [String] -checkKnownMergeEquiv (p1:\/: p2, pe) = - case quickmerge (p1:\/:p2) of - p1' -> if checkAPatch $ join_patches [invert p1, p2, p1', invert pe] - then [] - else ["Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2 - ++"in other words\n" ++ show (p1 :\/: p2) - ++"merges as\n" ++ show (merge $ p1 :\/: p2) - ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2) - ++"which is equivalent to\n" ++ show (effect p1') - ++ "should all work out to\n" - ++ show pe] -knownMergeEquivs :: [(Patch:\/: Patch, Patch)] -knownMergeEquivs = [ - - -- The following tests are going to be failed by the - -- Conflictor code as a cleanup. - - --(addfile "test":\/: - -- adddir "test", - -- join_patches [adddir "test", - -- addfile "test-conflict"]), - --(move "silly" "test":\/: - -- adddir "test", - -- join_patches [adddir "test", - -- move "silly" "test-conflict"]), - --(addfile "test":\/: - -- move "old" "test", - -- join_patches [addfile "test", - -- move "old" "test-conflict"]), - --(move "a" "test":\/: - -- move "old" "test", - -- join_patches [move "a" "test", - -- move "old" "test-conflict"]), - (fromPrim (hunk "test" 1 [] [BC.pack "A"]):\/: - fromPrim (hunk "test" 1 [] [BC.pack "B"]), - fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])), - (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/: - fromPrim (hunk "test" 1 [BC.pack "b"] []), - identity), - --hunk "test" 1 [] [BC.pack "v v v v v v v", - -- BC.pack "*************", - -- BC.pack "a", - -- BC.pack "b", - -- BC.pack "^ ^ ^ ^ ^ ^ ^"]), - (quickhunk 4 "a" "":\/: - quickhunk 3 "a" "", - quickhunk 3 "aa" ""), - (join_patches [quickhunk 1 "a" "bc", - quickhunk 6 "d" "ef"]:\/: - join_patches [quickhunk 3 "a" "bc", - quickhunk 8 "d" "ef"], - join_patches [quickhunk 3 "a" "bc", - quickhunk 8 "d" "ef", - quickhunk 1 "a" "bc", - quickhunk 7 "d" "ef"]), - (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a"):\/: - quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"), - quickhunk 2 "" "abdc") - ] -\end{code} - -It also is useful to verify that it doesn't matter which order we specify -the patches when we merge. - -\begin{code} -mergeSwapTests :: [String] -mergeSwapTests = - concat - [checkMergeSwap p1 p2 | - p1<-primitiveTestPatches, - p2<-primitiveTestPatches, - checkAPatch $ join_patches [invert p1,p2] - ] -checkMergeSwap :: Patch -> Patch -> [String] -checkMergeSwap p1 p2 = - case merge (p2:\/:p1) of - _ :/\: p2' -> - case merge (p1:\/:p2) of - _ :/\: p1' -> - case commute (p1:>p2') of - Just (_:>p1'b) -> - if p1'b /= p1' - then ["Merge swapping problem with...\np1 "++ - show p1++"merged with\np2 "++ - show p2++"p1' is\np1' "++ - show p1'++"p1'b is\np1'b "++ - show p1'b - ] - else [] - Nothing -> ["Merge commuting problem with...\np1 "++ - show p1++"merged with\np2 "++ - show p2++"gives\np2' "++ - show p2'++"which doesn't commute with p1.\n" - ] -\end{code} - -\chapter{Patch test data} - -This is where we define the set of patches which we run our tests on. This -should be kept up to date with as many interesting permutations of patch -types as possible. - -\begin{code} -testPatches :: [Patch] -testPatchesNamed :: [Named Patch] -testPatchesAddfile :: [Patch] -testPatchesRmfile :: [Patch] -testPatchesHunk :: [Patch] -primitiveTestPatches :: [Patch] -testPatchesBinary :: [Patch] -testPatchesCompositeNocom :: [Patch] -testPatchesComposite :: [Patch] -testPatchesTwoCompositeHunks :: [Patch] -testPatchesCompositeHunks :: [Patch] -testPatchesCompositeFourHunks :: [Patch] -testPatchesMerged :: [Patch] -validPatches :: [Patch] - -testPatchesNamed = [unsafePerformIO $ - namepatch "date is" "patch name" "David Roundy" [] - (fromPrim $ addfile "test"), - unsafePerformIO $ - namepatch "Sat Oct 19 08:31:13 EDT 2002" - "This is another patch" "David Roundy" - ["This log file has","two lines in it"] - (fromPrim $ rmfile "test")] -testPatchesAddfile = map fromPrim - [addfile "test",adddir "test",addfile "test/test"] -testPatchesRmfile = map invert testPatchesAddfile -testPatchesHunk = - [fromPrim $ hunk file line old new | - file <- ["test"], - line <- [1,2], - old <- map (map BC.pack) partials, - new <- map (map BC.pack) partials, - old /= new - ] - where partials = [["A"],["B"],[],["B","B2"]] - -primitiveTestPatches = testPatchesAddfile ++ - testPatchesRmfile ++ - testPatchesHunk ++ - [unsafeUnseal.fst.fromJust.readPatch $ - BC.pack "move ./test/test ./hello", - unsafeUnseal.fst.fromJust.readPatch $ - BC.pack "move ./test ./hello"] ++ - testPatchesBinary - -testPatchesBinary = - [fromPrim $ binary "./hello" - (BC.pack $ "agadshhdhdsa75745457574asdgg" ++ - "a326424677373735753246463gadshhdhdsaasdgg" ++ - "a326424677373735753246463gadshhdhdsaasdgg" ++ - "a326424677373735753246463gadshhdhdsaasdgg") - (BC.pack $ "adafjttkykrehhtrththrthrthre" ++ - "a326424677373735753246463gadshhdhdsaasdgg" ++ - "a326424677373735753246463gadshhdhdsaasdgg" ++ - "a326424677373735753246463gadshhdhdsaagg"), - fromPrim $ binary "./hello" - B.empty - (BC.pack "adafjttkykrere")] - -testPatchesCompositeNocom = - take 50 [join_patches [p1,p2]| - p1<-primitiveTestPatches, - p2<-filter (\p->checkseq [p1,p]) primitiveTestPatches, - commute (p1:>p2) == Nothing] - where checkseq ps = checkAPatch $ join_patches ps - -testPatchesComposite = - take 100 [join_patches [p1,p2]| - p1<-primitiveTestPatches, - p2<-filter (\p->checkseq [p1,p]) primitiveTestPatches, - commute (p1:>p2) /= Nothing, - commute (p1:>p2) /= Just (p2:>p1)] - where checkseq ps = checkAPatch $ join_patches ps - -testPatchesTwoCompositeHunks = - take 100 [join_patches [p1,p2]| - p1<-testPatchesHunk, - p2<-filter (\p->checkseq [p1,p]) testPatchesHunk] - where checkseq ps = checkAPatch $ join_patches ps - -testPatchesCompositeHunks = - take 100 [join_patches [p1,p2,p3]| - p1<-testPatchesHunk, - p2<-filter (\p->checkseq [p1,p]) testPatchesHunk, - p3<-filter (\p->checkseq [p1,p2,p]) testPatchesHunk] - where checkseq ps = checkAPatch $ join_patches ps - -testPatchesCompositeFourHunks = - take 100 [join_patches [p1,p2,p3,p4]| - p1<-testPatchesHunk, - p2<-filter (\p->checkseq [p1,p]) testPatchesHunk, - p3<-filter (\p->checkseq [p1,p2,p]) testPatchesHunk, - p4<-filter (\p->checkseq [p1,p2,p3,p]) testPatchesHunk] - where checkseq ps = checkAPatch $ join_patches ps - -testPatchesMerged = - take 200 - [joinPatches $ flattenFL p2+>+flattenFL (quickmerge (p1:\/:p2)) | - p1<-take 10 (drop 15 testPatchesCompositeHunks)++primitiveTestPatches - ++take 10 (drop 15 testPatchesTwoCompositeHunks) - ++ take 2 (drop 4 testPatchesCompositeFourHunks), - p2<-take 10 testPatchesCompositeHunks++primitiveTestPatches - ++take 10 testPatchesTwoCompositeHunks - ++take 2 testPatchesCompositeFourHunks, - checkAPatch $ join_patches [invert p1, p2], - commute (p2:>p1) /= Just (p1:>p2) - ] - -testPatches = primitiveTestPatches ++ - testPatchesComposite ++ - testPatchesCompositeNocom ++ - testPatchesMerged -\end{code} - -\chapter{Check patch test} -Check patch is supposed to verify that a patch is valid. - -\begin{code} -validPatches = [(join_patches [quickhunk 4 "a" "b", - quickhunk 1 "c" "d"]), - (join_patches [quickhunk 1 "a" "bc", - quickhunk 1 "b" "d"]), - (join_patches [quickhunk 1 "a" "b", - quickhunk 1 "b" "d"])]++testPatches - -testCheck :: [String] -testCheck = concatMap tTestCheck validPatches -tTestCheck :: PatchUnitTest Patch -tTestCheck p = if checkAPatch p - then [] - else ["Failed the check: "++show p++"\n"] - -propHexConversion :: String -> Bool -propHexConversion s = - fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s -propConcatPS :: [String] -> Bool -propConcatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss) - --- | Groups a set of tests by giving them the same prefix in their description. --- When this is called as @checkSubcommutes subcoms expl@, the prefix for a --- test becomes @"Checking " ++ expl ++ " for subcommute "@. -checkSubcommutes :: Testable a => [(String, a)] -> String - -> [Test] -checkSubcommutes subcoms expl = map check_subcommute subcoms - where check_subcommute (name, test) = - let testName = "Checking" ++ expl ++ " for subcommute " ++ name - in testProperty testName test -\end{code} - -\end{document} - - diff --git a/tests/filepath.sh b/tests/filepath.sh --- a/tests/filepath.sh +++ b/tests/filepath.sh @@ -103,7 +103,7 @@ # can handle .. path cd temp3 -darcs pull ../temp2 -p1 --all | grep -i 'Finished pulling' +darcs pull ../temp2 --set-default -p1 --all | grep -i 'Finished pulling' darcs pull --dry-run | grep hello2 cd a/b #[issue268] repodir with subdir diff --git a/tests/issue1865-get-context.sh b/tests/issue1865-get-context.sh --- a/tests/issue1865-get-context.sh +++ b/tests/issue1865-get-context.sh @@ -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