diff --git a/Distribution/ShellHarness.hs b/Distribution/ShellHarness.hs --- a/Distribution/ShellHarness.hs +++ b/Distribution/ShellHarness.hs @@ -65,7 +65,7 @@ Nothing -> return (cwd ++ "/..") Just d -> return $ takeDirectory d set_prefs = do - finally (catch (appendFile ".darcs/defaults" "ALL --ignore-times") + finally (catch (appendFile ".darcs/defaults" "\nALL --ignore-times\n") (\e -> fail $ "Unable to set preferences: " ++ show e)) (createDirectoryIfMissing False ".darcs") diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,87 @@ +Darcs +===== +This is the source tree for darcs, a distributed version control system +written in Haskell. + +For more information, visit the darcs web site: + + http://www.darcs.net + + +Compilation and Installation +============================ + +Darcs currently supports two build systems: a traditional autotools- +based system, and an experimental cabal-based system. Currently +AUTOTOOLS IS RECOMMENDED; in later releases it will be deprecated and +eventually removed (in favour of cabal). + +If a "configure" file is present, autotools is supported. If a +"Setup.lhs" file is present, cabal is supported. Currently there is a +separate source tarball for each build system; either can be used in +unstable checkouts. + + +Using Autotools +--------------- + +If you have the normal, autotools-based tarball, this sequence should work +for you (if you are in doubt, this is likely the case): + + $ ./configure + $ make + # make install + +You first need to run `autoconf` if you obtained the source tree from the +darcs repository (but this is not needed for release tarballs). + +For more information, please see the manual: + + * http://www.darcs.net/manual + * doc/manual/darcs.ps + + +Using Cabal +----------- + +This method requires the cabal package, version 1.6 or higher. The +cabal-install package is also recommended. + +If you have the "cabal-install" package on your system (that is, there +is a "cabal" executable in your path), you can use the following +commands to create an executable in ~/.cabal/bin/darcs. + + $ cabal configure + $ cabal build + $ cabal install + +Otherwise, if you have the "cabal" package but not the "cabal-install" +package, run the following: + + $ runghc Setup configure + $ runghc Setup build + $ sudo runghc Setup install + +You may also omit the last step and copy the darcs executable (found in +dist/build/darcs/darcs) to a location of your choosing. + +More detailed instructions can be found at + +including instructions on obtaining a copy of cabal-install. + + +Hacking +======= +For more information about darcs hacking and best practices please check +the darcs wiki at http://darcs.net/DarcsWiki + +Of particular interest are the following documents: + * http://wiki.darcs.net/index.html/DeveloperFAQ + * http://wiki.darcs.net/index.html/DeveloperTips + +Testing +======= +For more information about the test suite, including how to run specific +tests please read tests/README.test_maintainers.txt. + +Happy hacking! diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -207,7 +207,7 @@ out <- rawSystemStdout verbosity "darcs" ["changes", "--from-tag", display darcsVersion, "--count"] case reads (out) of - ((n,_):_) -> return $ Just (n :: Int) + ((n,_):_) -> return $ Just ((n :: Int) - 1) _ -> return Nothing `Exception.catch` \_ -> return Nothing @@ -225,10 +225,12 @@ rewriteFile targetFile $ unlines ["module Context where" ,"context :: String" - ,"context = " ++ show ctx + ,"context = " ++ case ctx of + Just x -> show x + Nothing -> "context not available" ] -context :: Verbosity -> Version -> IO String +context :: Verbosity -> Version -> IO (Maybe String) context verbosity version = do contextDarcs <- do -- FIXME currently we run changes --from-tag to at least assert that the @@ -243,9 +245,9 @@ contextDist <- parseFile contextFile return $ case (contextDarcs, contextDist) of - (Just x, _) -> x - (Nothing, Just x) -> x - (Nothing, Nothing) -> "context not available" + (Just x, _) -> Just x + (Nothing, Just x) -> Just x + (Nothing, Nothing) -> Nothing where contextFile = "release/distributed-context" parseFile :: (Read a) => String -> IO (Maybe a) diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,5 +1,5 @@ Name: darcs -version: 2.1.2.2 +version: 2.1.98.2 License: GPL License-file: COPYING Author: David Roundy , @@ -58,6 +58,8 @@ src/features.tex, src/gpl.tex, src/switching.tex, tools/cgi/README.in + README + -- release data release/distributed-version, release/distributed-context @@ -66,6 +68,8 @@ tests/repos/*.tgz tests/repos/README tests/*.sh tests/network/*.sh + tests/lib + tests/example_binary.png bugs/*.sh bugs/bin/darcs @@ -93,6 +97,7 @@ flag external-zlib description: Use the external zlib binding package. + default: False flag haskeline description: Use the haskeline package for command line editing support. @@ -114,12 +119,11 @@ flag base3 -Executable darcs - main-is: darcs.hs +Library hs-source-dirs: src include-dirs: src - other-modules: CommandLine + exposed-modules: CommandLine Crypt.SHA256 Darcs.ArgumentDefaults Darcs.Arguments @@ -196,20 +200,17 @@ Darcs.Patch.Permutations Darcs.Patch.Prim Darcs.Patch.Properties - Darcs.Patch.QuickCheck Darcs.Patch.Read Darcs.Patch.ReadMonads Darcs.Patch.Real Darcs.Patch.Set Darcs.Patch.Show - Darcs.Patch.Test Darcs.Patch.TouchesFiles - Darcs.Patch.Unit Darcs.Patch.Viewing Darcs.Population Darcs.PopulationData Darcs.PrintPatch - Darcs.Progress + Darcs.ProgressPatches Darcs.RemoteApply Darcs.RepoPath Darcs.Repository @@ -247,6 +248,7 @@ Lcs OldDate Printer + Progress RegChars SHA1 Ssh @@ -304,25 +306,26 @@ extra-libraries: curl cpp-options: -DHAVE_CURL c-sources: src/hscurl.c - cc-options: -DHAVE_CURL -DPACKAGE_VERSION="2.1.2" + cc-options: -DHAVE_CURL -DPACKAGE_VERSION="2.1.98.2" if flag(curl-pipelining) -- curl 7.19.1 has bug-free pipelining - pkgconfig-depends: libcurl >= 7.19.1 + if !os(windows) + pkgconfig-depends: libcurl >= 7.19.1 cpp-options: -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT else if flag(libwww) build-tools: libwww-config >= 5.0 c-sources: src/hslibwww.c - cc-options: -DHAVE_LIBWWW -DPACKAGE_VERSION="2.1.2" + cc-options: -DHAVE_LIBWWW -DPACKAGE_VERSION="2.1.98.2" cpp-options: -DHAVE_LIBWWW x-have-libwww: else if flag(http) build-depends: network == 2.2.*, HTTP >= 3000.0 && < 3001.1 - cpp-options: -DHAVE_HTTP -DPACKAGE_VERSION="2.1.2" + cpp-options: -DHAVE_HTTP -DPACKAGE_VERSION="2.1.98.2" x-have-http: if flag(external-bytestring) @@ -335,7 +338,8 @@ else extra-libraries: z - if flag(terminfo) + -- The terminfo package cannot be built on Windows. + if flag(terminfo) && !os(windows) build-depends: terminfo == 0.2.* && >= 0.2.2 cpp-options: -DHAVE_TERMINFO @@ -344,6 +348,146 @@ cpp-options: -DHAVE_CURSES if flag(haskeline) + build-depends: haskeline == 0.3.* && >= 0.3.1 + cpp-options: -DHAVE_HASKELINE + + if flag(color) + x-use-color: + + extensions: + CPP, + ForeignFunctionInterface, + BangPatterns, + PatternGuards, + MagicHash, + UndecidableInstances, + DeriveDataTypeable, + GADTs, + TypeOperators, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables, + KindSignatures, + TypeSynonymInstances, + Rank2Types, + RankNTypes, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses + +Executable darcs + main-is: darcs.hs + hs-source-dirs: src + include-dirs: src + c-sources: src/atomic_create.c + src/fpstring.c + src/c_compat.c + src/maybe_relink.c + src/umask.c + src/Crypt/sha2.c + + -- We need optimizations, regardless of what Hackage says + ghc-options: -Wall -O2 -funbox-strict-fields -threaded + ghc-prof-options: -prof -auto-all + + if !flag(external-zlib) + extra-libraries: z + + 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 + 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 + + if os(solaris) + cc-options: -DHAVE_SIGINFO_H + + build-depends: base < 4, + regex-compat >= 0.71 && <= 0.92, + mtl == 1.1.*, + parsec == 2.1.*, + html == 1.0.*, + filepath == 1.1.* + + if !os(windows) + build-depends: unix == 2.3.* + cpp-options: -DHAVE_SIGNALS + + if flag(base3) + build-depends: base >= 3, + old-time == 1.0.*, + directory == 1.0.*, + process == 1.0.*, + containers >= 0.1 && < 0.3, + array >= 0.1 && < 0.3, + random == 1.0.* + else + build-depends: base < 3 + + -- We need optimizations, regardless of what Hackage says + ghc-options: -Wall -O2 -funbox-strict-fields -threaded + ghc-prof-options: -prof -auto-all + + if flag(curl) + extra-libraries: curl + cpp-options: -DHAVE_CURL + c-sources: src/hscurl.c + cc-options: -DHAVE_CURL -DPACKAGE_VERSION="2.1.98.2" + + if flag(curl-pipelining) + -- curl 7.19.1 has bug-free pipelining + if !os(windows) + pkgconfig-depends: libcurl >= 7.19.1 + cpp-options: -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT + + else + if flag(libwww) + build-tools: libwww-config >= 5.0 + c-sources: src/hslibwww.c + cc-options: -DHAVE_LIBWWW -DPACKAGE_VERSION="2.1.98.2" + cpp-options: -DHAVE_LIBWWW + x-have-libwww: + else + if flag(http) + build-depends: network == 2.2.*, + HTTP >= 3000.0 && < 3001.1 + cpp-options: -DHAVE_HTTP -DPACKAGE_VERSION="2.1.98.2" + x-have-http: + + if flag(external-bytestring) + build-depends: bytestring >= 0.9.0 && < 0.10 + cpp-options: -DHAVE_BYTESTRING + + if flag(external-zlib) + build-depends: zlib == 0.5.* + cpp-options: -DHAVE_HASKELL_ZLIB + else + extra-libraries: z + + -- The terminfo package cannot be built on Windows. + if flag(terminfo) && !os(windows) + build-depends: terminfo == 0.2.* && >= 0.2.2 + cpp-options: -DHAVE_TERMINFO + + if flag(curses) + extra-libraries: curses + cpp-options: -DHAVE_CURSES + + -- Haskeline has some bugs on Windows with international keyboards. + if flag(haskeline) && !os(windows) build-depends: haskeline == 0.3.* && >= 0.3.1 cpp-options: -DHAVE_HASKELINE diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -"context not available" +Just "\nContext:\n\n[TAG 2.1.98.2\nPetr Rockai **20090104102526] \n" diff --git a/release/distributed-version b/release/distributed-version --- a/release/distributed-version +++ b/release/distributed-version @@ -1,1 +1,1 @@ -Nothing +Just 0 diff --git a/src/ByteStringUtils.hs b/src/ByteStringUtils.hs --- a/src/ByteStringUtils.hs +++ b/src/ByteStringUtils.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fbang-patterns -fffi -cpp #-} {-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP #-} ----------------------------------------------------------------------------- diff --git a/src/Crypt/SHA256.hs b/src/Crypt/SHA256.hs --- a/src/Crypt/SHA256.hs +++ b/src/Crypt/SHA256.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fffi -cpp #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} -- | diff --git a/src/Darcs/Arguments.lhs b/src/Darcs/Arguments.lhs --- a/src/Darcs/Arguments.lhs +++ b/src/Darcs/Arguments.lhs @@ -31,6 +31,7 @@ help_on_match, any_verbosity, disable, notest, test, working_repo_dir, + testByDefault, remote_repo, leave_test_dir, possibly_remote_repo_dir, get_repourl, @@ -67,7 +68,7 @@ match_several_or_range, happy_forwarding, match_several_or_last, set_default, - fancy_move_add, pristine_tree, + fancy_move_add, set_scripts_executable, sibling, flagsToSiblings, relink, relink_pristine, nolinks, files, directories, pending, @@ -93,7 +94,7 @@ import Printer ( renderString ) import System.Posix.Env ( setEnv ) import Darcs.Patch ( list_touched_files ) -import Darcs.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) +import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) #endif import Darcs.Hopefully ( PatchInfoAnd, info ) @@ -118,9 +119,7 @@ import Printer ( Doc, putDocLn, text, vsep, ($$), vcat ) import URL ( pipeliningEnabledByDefault ) #include "impossible.h" -\end{code} -\begin{code} data FlagContent = NoContent | AbsoluteContent AbsolutePath | AbsoluteOrStdContent AbsolutePathOrStd | StringContent String deriving (Eq, Show, Ord) @@ -200,9 +199,10 @@ getContent SSHControlMaster = NoContent getContent NoSSHControlMaster = NoContent getContent (Toks s) = StringContent s -getContent (WorkDir s) = StringContent s -getContent (RepoDir s) = StringContent s +getContent (WorkRepoDir s) = StringContent s +getContent (WorkRepoUrl s) = StringContent s getContent (RemoteRepo s) = StringContent s +getContent (NewRepo s) = StringContent s getContent (Reply s) = StringContent s getContent EditDescription = NoContent getContent NoEditDescription = NoContent @@ -386,9 +386,7 @@ where from_option (DarcsMultipleChoiceOption xs) = xs from_option x = [x] -\end{code} -\begin{code} extract_fix_path :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath) extract_fix_path [] = Nothing extract_fix_path ((FixFilePath repo orig):_) = Just (repo, orig) @@ -434,9 +432,7 @@ -- as opposed to just '.' areFileArgs :: [SubPath] -> Bool areFileArgs rps = concatMap toFilePath rps /= "" -\end{code} -\begin{code} -- | 'list_option' is an option which lists the command's arguments list_options :: DarcsOption list_options = DarcsNoArgOption [] ["list-options"] ListOptions @@ -478,7 +474,7 @@ author, askdeps, lookforadds, ignoretimes, test, notest, help, force_replace, help_on_match, allow_unrelated_repos, match_one, match_range, match_several, fancy_move_add, sendmail_cmd, - logfile, rmlogfile, leave_test_dir, from_opt, set_default, pristine_tree + logfile, rmlogfile, leave_test_dir, from_opt, set_default :: DarcsOption @@ -568,9 +564,9 @@ when running \verb'apply' from a mailer. \begin{code} -working_repo_dir = DarcsArgOption [] ["repodir"] WorkDir "DIRECTORY" +working_repo_dir = DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY" "specify the repository directory in which to run" -possibly_remote_repo_dir = DarcsArgOption [] ["repo"] RepoDir "URL" +possibly_remote_repo_dir = DarcsArgOption [] ["repo"] WorkRepoUrl "URL" "specify the repository URL" -- | 'get_repourl' takes a list of flags and returns the url of the @@ -578,7 +574,7 @@ -- This flag is present if darcs was invoked with @--repodir=DIRECTORY@ get_repourl :: [DarcsFlag] -> Maybe String get_repourl [] = Nothing -get_repourl (RepoDir d:_) | not (is_file d) = Just d +get_repourl (WorkRepoUrl d:_) | not (is_file d) = Just d get_repourl (_:fs) = get_repourl fs \end{code} @@ -696,9 +692,7 @@ -- This flag is present if darcs was invoked with @--context=FILE@ get_context :: [DarcsFlag] -> Maybe AbsolutePath get_context xs = listToMaybe [ c | Context c <- xs ] -\end{code} -\begin{code} notest = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script", DarcsNoArgOption [] ["test"] Test "run the test script"] @@ -710,6 +704,9 @@ LeaveTestDir "don't remove the test directory", DarcsNoArgOption [] ["remove-test-directory"] NoLeaveTestDir "remove the test directory"] + +testByDefault :: [DarcsFlag] -> [DarcsFlag] +testByDefault o = if NoTest `elem` o then o else Test:o \end{code} \begin{options} @@ -742,16 +739,6 @@ DarcsNoArgOption [] ["no-date-trick"] NoFancyMoveAdd "don't use experimental date appending trick [DEFAULT]"] -pristine_tree = - DarcsMultipleChoiceOption - [DarcsNoArgOption [] ["plain-pristine-tree"] PristinePlain - "use a plain pristine tree [DEFAULT]", - DarcsNoArgOption [] ["no-pristine-tree"] PristineNone - "use no pristine tree"] - -\end{code} - -\begin{code} askdeps = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["ask-deps"] AskDeps @@ -856,9 +843,7 @@ "don't create compressed patches" __uncompress = DarcsNoArgOption [] ["uncompress"] UnCompress "uncompress patches" -\end{code} -\begin{code} summary = DarcsMultipleChoiceOption [DarcsNoArgOption ['s'] ["summary"] Summary "summarize changes", DarcsNoArgOption [] ["no-summary"] NoSummary "don't summarize changes"] @@ -870,9 +855,7 @@ DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)" store_in_memory = DarcsNoArgOption [] ["store-in-memory"] StoreInMemory "do patch application in memory rather than on disk" -\end{code} -\begin{code} target = DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email" cc = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply" @@ -888,9 +871,7 @@ lt [t,""] = t lt (t:ts) = t++" , "++lt ts lt [] = "" -\end{code} -\begin{code} subject = DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject" -- |'get_subject' takes a list of flags and returns the subject of the mail @@ -901,48 +882,34 @@ get_subject (Subject s:_) = Just s get_subject (_:fs) = get_subject fs get_subject [] = Nothing -\end{code} -\begin{code} in_reply_to = DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header" get_in_reply_to :: [DarcsFlag] -> Maybe String get_in_reply_to (InReplyTo s:_) = Just s get_in_reply_to (_:fs) = get_in_reply_to fs get_in_reply_to [] = Nothing -\end{code} -\begin{code} output = DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE" "specify output filename" -\end{code} -\begin{code} output_auto_name = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY" "output to automatically named file in DIRECTORY, default: current directory" -\end{code} -\begin{code} edit_description = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["edit-description"] EditDescription "edit the patch bundle description", DarcsNoArgOption [] ["dont-edit-description"] NoEditDescription "don't edit the patch bundle description"] -\end{code} -\begin{code} distname_option = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME" "name of version" -\end{code} -\begin{code} recursive h = DarcsMultipleChoiceOption [DarcsNoArgOption ['r'] ["recursive"] Recursive h, DarcsNoArgOption [] ["not-recursive"] NoRecursive ("don't "++h)] -\end{code} -\begin{code} inventory_choices :: DarcsOption inventory_choices = DarcsMultipleChoiceOption @@ -960,19 +927,13 @@ "Convert darcs-1 format to hashed format", DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory "Convert from hashed to darcs-1 format"] -\end{code} -\begin{code} xmloutput = DarcsNoArgOption [] ["xml-output"] XMLOutput "generate XML formatted output" -\end{code} -\begin{code} creatorhash = DarcsArgOption [] ["creator-hash"] CreatorHash "HASH" "specify hash of creator patch (see docs)" -\end{code} -\begin{code} sign = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["sign"] Sign "sign the patch with your gpg key", @@ -994,9 +955,7 @@ "set default repository [DEFAULT]", DarcsNoArgOption [] ["no-set-default"] NoSetDefault "don't set default repository"] -\end{code} -\begin{code} verify = DarcsMultipleChoiceOption [DarcsAbsPathOption [] ["verify"] Verify "PUBRING" "verify that the patch was signed by a key in PUBRING", @@ -1004,11 +963,10 @@ "verify using openSSL with authorized keys from file KEYS", DarcsNoArgOption [] ["no-verify"] NonVerify "don't verify patch signature"] -\end{code} -\begin{code} -reponame = DarcsArgOption [] ["repo-name"] WorkDir "DIRECTORY" - "path of output directory" +reponame = DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY" + "path of output directory" --repodir is there for compatibility + --should be removed eventually tagname = DarcsArgOption ['t'] ["tag"] TagName "TAGNAME" "name of version to checkpoint" deps_sel = DarcsMultipleChoiceOption @@ -1035,17 +993,13 @@ "don't save patch files in the repository" __complete = DarcsNoArgOption [] ["complete"] Complete "get a complete copy of the repository" -\end{code} -\begin{code} force_replace = DarcsMultipleChoiceOption [DarcsNoArgOption ['f'] ["force"] ForceReplace "proceed with replace even if 'new' token already exists", DarcsNoArgOption [] ["no-force"] NonForce "don't force the replace if it looks scary"] -\end{code} -\begin{code} reply = DarcsArgOption [] ["reply"] Reply "FROM" "reply to email-based patch using FROM address" apply_conflict_options = DarcsMultipleChoiceOption @@ -1171,9 +1125,7 @@ ] diffflags = DarcsArgOption [] ["diff-opts"] DiffFlags "OPTIONS" "options to pass to diff" -\end{code} -\begin{code} changes_format = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["context"] (Context rootDirectory) "give output suitable for get --context", @@ -1214,9 +1166,7 @@ "take union of all repositories [DEFAULT]", DarcsNoArgOption [] ["complement"] Complement "take complement of repositories (in order listed)"] -\end{code} -\begin{code} -- | 'list_files' returns the list of all non-boring files in the repository list_files :: IO [String] list_files = do s <- slurp_all_but_darcs "." @@ -1240,9 +1190,7 @@ list_registered_files :: IO [String] list_registered_files = (map drop_dotslash . list_slurpy) `fmap` (withRepository [] slurp_pending) -\end{code} -\begin{code} options_latex :: [DarcsOption] -> String options_latex opts = "\\begin{tabular}{lll}\n"++ unlines (map option_latex opts)++ @@ -1288,9 +1236,6 @@ DarcsNoArgOption [] ["dont-set-scripts-executable"] DontSetScriptsExecutable "don't make scripts executable"] -\end{code} - -\begin{code} relink, relink_pristine, sibling :: DarcsOption relink = DarcsNoArgOption [] ["relink"] Relink "relink random internal data to a sibling" @@ -1306,15 +1251,11 @@ flagsToSiblings ((Sibling s) : l) = s : (flagsToSiblings l) flagsToSiblings (_ : l) = flagsToSiblings l flagsToSiblings [] = [] -\end{code} -\begin{code} nolinks :: DarcsOption nolinks = DarcsNoArgOption [] ["nolinks"] NoLinks "do not link repository or pristine to sibling" -\end{code} -\begin{code} reorder_patches :: DarcsOption reorder_patches = DarcsNoArgOption [] ["reorder-patches"] Reorder "reorder the patches in the repository" @@ -1346,9 +1287,7 @@ case easy_sendmail of Just a -> return a Nothing -> return "" -\end{code} -\begin{code} files :: DarcsOption files = DarcsMultipleChoiceOption [DarcsNoArgOption [] ["files"] Files @@ -1564,9 +1503,7 @@ allow_unrelated_repos = DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos "do not check if repositories are unrelated" -\end{code} -\begin{code} -- | @'patch_select_flag' f@ holds whenever @f@ is a way of selecting -- patches such as @PatchName n@. patch_select_flag :: DarcsFlag -> Bool diff --git a/src/Darcs/Commands.lhs b/src/Darcs/Commands.lhs --- a/src/Darcs/Commands.lhs +++ b/src/Darcs/Commands.lhs @@ -181,9 +181,7 @@ , command_description = d , command_command = \_ _ -> putStr h } -\end{code} -\begin{code} usage :: [CommandControl] -> String usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++ usage_helper cs ++ "\n" ++ @@ -257,9 +255,7 @@ (DarcsCommand _ _ _ _ _ _ _ _ _ _ _) -> command_extra_arg_help cmd _ -> [] -\end{code} -\begin{code} data CommandArgs = CommandOnly DarcsCommand | SuperCommandOnly DarcsCommand | SuperCommandSub DarcsCommand DarcsCommand @@ -285,9 +281,7 @@ cs' -> Left $ "Ambiguous command...\n\n" ++ "The command '"++cmd++"' could mean one of:\n" ++ unwords (sort $ map command_name cs') -\end{code} -\begin{code} -- | Output functions equivalent to (putStrLn, hPutStrLn stderr, putDocLn) loggers :: [DarcsFlag] -> ( String -> IO () , String -> IO () diff --git a/src/Darcs/Commands/Add.lhs b/src/Darcs/Commands/Add.lhs --- a/src/Darcs/Commands/Add.lhs +++ b/src/Darcs/Commands/Add.lhs @@ -48,12 +48,9 @@ import System.FilePath.Posix ( takeDirectory, () ) import System.IO ( hPutStrLn, stderr ) import qualified System.FilePath.Windows as WindowsFilePath -\end{code} -\begin{code} add_description :: String -add_description = - "Add one or more new files or directories." +add_description = "Add one or more new files or directories." \end{code} \options{add} @@ -63,15 +60,20 @@ \begin{code} add_help :: String add_help = - "Add needs to be called whenever you add a new file or directory to your\n"++ - "project. Of course, it also needs to be called when you first create the\n"++ - "project, to let darcs know which files should be kept track of.\n" -\end{code} + "Generally a repository contains both files that should be version\n" ++ + "controlled (such as source code) and files that Darcs should ignore\n" ++ + "(such as executables compiled from the source code). The `darcs add'\n" ++ + "command is used to tell Darcs which files to version control.\n" ++ + "\n" ++ + "When an existing project is first imported into a Darcs repository, it\n" ++ + "is common to run `darcs add -r *' or `darcs record -l' to add all\n" ++ + "initial source files into darcs.\n"++ + "\n" ++ + "Adding symbolic links (symlinks) is not supported.\n\n" -\begin{code} add :: DarcsCommand add = DarcsCommand {command_name = "add", - command_help = add_help, + command_help = add_help ++ add_help' ++ add_help'', command_description = add_description, command_extra_args = -1, command_extra_arg_help = [" ..."], @@ -85,24 +87,19 @@ recursive "add contents of subdirectories", fancy_move_add, working_repo_dir, dry_run_noxml]} -\end{code} -Darcs will refuse to add a file or directory that differs from an existing -one only in case. This is because the HFS+ file system used on MacOS -treats such files as being one and the same. - -You can not add symbolic links to darcs. -If you try to do that, darcs will refuse and print an error message. -Perhaps you want to make symbolic links \emph{to} the files in darcs instead? - -\begin{options} ---boring -\end{options} - -By default darcs will ignore all files that match any of the boring patterns. -If you want to add such a file anyway you must use the \verb!--boring! option. +add_help' :: String +add_help' = + "Darcs will ignore all files and folders that look `boring'. The\n" ++ + "--boring option overrides this behaviour.\n" ++ + "\n" ++ + "Darcs will not add file if another file in the same folder has the\n" ++ + "same name, except for case. The --case-ok option overrides this\n" ++ + "behaviour. Windows and OS X usually use filesystems that do not allow\n" ++ + "files a folder to have the same name except for case (for example,\n" ++ + "`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++ + "unusable on those systems!\n\n" -\begin{code} add_cmd :: [DarcsFlag] -> [String] -> IO () add_cmd opts args = withRepoLock opts $- \repository -> do cur <- slurp_pending repository @@ -248,18 +245,16 @@ , msg_is = "would be" , msg_are = "would be" } -\end{code} -\begin{options} ---date-trick -\end{options} - -The \verb!--date-trick! option allows you to enable an experimental trick -to make add conflicts, in which two users each add a file or directory with -the same name, less problematic. While this trick is completely safe, it -is not clear to what extent it is beneficial. +-- |FIXME: this documentation makes *no* sense to me, and the +-- ramifications of using this option are not clear. --twb, 2008 +add_help'' :: String +add_help'' = + "The --date-trick option allows you to enable an experimental trick to\n" ++ + "make add conflicts, in which two users each add a file or directory\n" ++ + "with the same name, less problematic. While this trick is completely\n" ++ + "safe, it is not clear to what extent it is beneficial.\n" -\begin{code} expand_dirs :: [FilePath] -> IO [FilePath] expand_dirs fs = concat `fmap` mapM expand_one fs expand_one :: FilePath -> IO [FilePath] diff --git a/src/Darcs/Commands/AmendRecord.lhs b/src/Darcs/Commands/AmendRecord.lhs --- a/src/Darcs/Commands/AmendRecord.lhs +++ b/src/Darcs/Commands/AmendRecord.lhs @@ -46,20 +46,19 @@ with_selected_patch_from_repo ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Commands.Record ( get_date, get_log ) -import Darcs.Arguments ( DarcsFlag ( Test, NoTest, All ), +import Darcs.Arguments ( DarcsFlag ( All ), areFileArgs, fixSubPaths, defineChanges, all_interactive, ignoretimes, ask_long_comment, author, patchname_option, leave_test_dir, nocompress, lookforadds, working_repo_dir, match_one_nontag, umask_option, - notest, list_registered_files, + notest, testByDefault, list_registered_files, get_easy_author, set_scripts_executable ) import Darcs.Utils ( askUser ) import Printer ( putDocLn ) -\end{code} -\begin{code} + amendrecord_description :: String amendrecord_description = "Replace a patch with a better version before it leaves your repository." @@ -68,26 +67,40 @@ \options{amend-record} \haskell{amend-record_help} -If you provide one or more files or directories as additional arguments to -amend-record, you will only be prompted to changes in those files or -directories. - -The old version of the patch is lost and the new patch will include both the -old and the new changes. This is mostly the same as unrecording the old patch, -fixing the changes and recording a new patch with the same name and -description. - -\verb!amend-record! will modify the date of the recorded patch. \begin{code} amendrecord_help :: String amendrecord_help = - "Amend-record is used to replace a patch with a newer version with additional\n"++ - "changes.\n\n"++ - "WARNINGS: You should ONLY use amend-record on patches which only exist in a\n"++ - "single repository! Also, running amend-record while another user is pulling\n"++ - "from the same repository may cause repository corruption.\n" -\end{code} -\begin{code} + "Amend-record updates a `draft' patch with additions or improvements,\n" ++ + "resulting in a single `finished' patch. This is better than recording\n" ++ + "the additions and improvements as separate patches, because then\n" ++ + "whenever the `draft' patch is copied between repositories, you would\n" ++ + "need to make sure all the extra patches are copied, too.\n" ++ + "\n" ++ + "Do not copy draft patches between repositories, because a finished\n" ++ + "patch cannot be copied into a repository that contains a draft of the\n" ++ + "same patch. If this has already happened, `darcs obliterate' can be\n" ++ + "used to remove the draft patch.\n" ++ + "\n" ++ + -- FIXME: is the following still true in Darcs 2.1? --twb + "Do not run amend-record in repository that other developers can pull\n" ++ + "from, because if they pull while an amend-record is in progress, their\n" ++ + "repository may be corrupted.\n" ++ + "\n" ++ + "When recording a draft patch, it is a good idea to start the name with\n" ++ + "`DRAFT:' so that other developers know it is not finished. When\n" ++ + "finished, remove it with `darcs amend-record --edit-description'.\n" ++ + "\n" ++ + "Like `darcs record', if you call amend-record with files as arguments,\n" ++ + "you will only be asked about changes to those files. So to amend a\n" ++ + "patch to foo.c with improvements in bar.c, you would run:\n" ++ + "\n" ++ + " darcs amend-record --match 'touch foo.c' bar.c\n" ++ + "\n" ++ + "It is usually a bad idea to amend another developer's patch. To make\n" ++ + "amend-record only ask about your own patches by default, you can add\n" ++ + "something like `amend-record match David Roundy' to ~/.darcs/defaults,\n" ++ + "where `David Roundy' is your name.\n" + amendrecord :: DarcsCommand amendrecord = DarcsCommand {command_name = "amend-record", command_help = amendrecord_help, @@ -107,13 +120,11 @@ author, patchname_option, ask_long_comment, lookforadds, working_repo_dir]} -\end{code} -\begin{code} + amendrecord_cmd :: [DarcsFlag] -> [String] -> IO () -amendrecord_cmd origopts args = - let opts = if NoTest `elem` origopts then origopts else Test:origopts - edit_metadata = has_edit_metadata opts in - withRepoLock opts $- \repository -> do +amendrecord_cmd opts args = + let edit_metadata = has_edit_metadata opts in + withRepoLock (testByDefault opts) $- \repository -> do files <- sort `fmap` fixSubPaths opts args when (areFileArgs files) $ putStrLn $ "Amending changes in "++unwords (map show files)++":\n" @@ -175,16 +186,7 @@ get_author (Author a:_) = Just a get_author (_:as) = get_author as get_author [] = Nothing -\end{code} -If you configure darcs to run a test suite, darcs will run this test on the -amended repository to make sure it is valid. Darcs first creates a pristine -copy of the source tree (in a temporary directory), then it runs the test, -using its return value to decide if the amended change is valid. If the -\verb!--set-scripts-executable! flag is passed to amend-record, darcs will set -scripts executable in the temporary test directory before running the test. - -\begin{code} fixp :: RepoPatch p => PatchInfoAnd p -> FL Prim -> PatchInfo -> PatchInfoAnd p fixp oldp chs new_pinf = let pdeps = getdeps $ hopefully oldp diff --git a/src/Darcs/Commands/Annotate.lhs b/src/Darcs/Commands/Annotate.lhs --- a/src/Darcs/Commands/Annotate.lhs +++ b/src/Darcs/Commands/Annotate.lhs @@ -78,9 +78,7 @@ "Annotate displays which patches created or last modified a directory\n"++ "file or line. It can also display the contents of a particular patch\n"++ "in darcs format.\n" -\end{code} -\begin{code} annotate :: DarcsCommand annotate = DarcsCommand {command_name = "annotate", command_help = annotate_help, @@ -190,21 +188,15 @@ "' was removed by") $$ human_friendly (modifiedByI i) | otherwise -> annotate_file repository opts pinfo file_or_directory pt -\end{code} -\begin{code} annotate_cmd _ _ = fail "annotate accepts at most one argument" -\end{code} -\begin{code} annotate_pop :: [DarcsFlag] -> PatchInfo -> PopTree -> IO () annotate_pop opts pinfo pt = putDocLn $ p2format pinfo pt where p2format = if XMLOutput `elem` opts then p2xml else p2s -\end{code} -\begin{code} indent :: Doc -> [Doc] -- This is a bit nasty: indent = map (text . i) . lines . renderString @@ -242,9 +234,7 @@ dir_change = if modifiedByI inf == pinfo then text $ show (modifiedHowI inf) else empty -\end{code} -\begin{code} escapeXML :: String -> Doc escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" diff --git a/src/Darcs/Commands/Apply.lhs b/src/Darcs/Commands/Apply.lhs --- a/src/Darcs/Commands/Apply.lhs +++ b/src/Darcs/Commands/Apply.lhs @@ -73,8 +73,7 @@ import Darcs.Sealed ( Sealed(Sealed) ) import Printer ( packedString, putDocLn, vcat, text, ($$), errorDoc, empty ) #include "impossible.h" -\end{code} -\begin{code} + apply_description :: String apply_description = "Apply patches (from an email bundle) to the repository." @@ -88,8 +87,7 @@ apply_help = "Apply is used to apply a bundle of patches to this repository.\n"++ "Such a bundle may be created using send.\n" -\end{code} -\begin{code} + stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] stdindefault _ x = return x @@ -115,8 +113,7 @@ notest, leave_test_dir, working_repo_dir]} -\end{code} -\begin{code} + apply_cmd :: [DarcsFlag] -> [String] -> IO () apply_cmd _ [""] = fail "Empty filename argument given to apply!" apply_cmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do @@ -390,9 +387,7 @@ throwIO :: Exception -> IO a throwIO e = return $ throw e -\end{code} -\begin{code} forwarding_message :: B.ByteString forwarding_message = BC.pack $ "The following patch was either unsigned, or signed by a non-allowed\n"++ diff --git a/src/Darcs/Commands/Changes.lhs b/src/Darcs/Commands/Changes.lhs --- a/src/Darcs/Commands/Changes.lhs +++ b/src/Darcs/Commands/Changes.lhs @@ -63,7 +63,7 @@ renderString, prefix, packedString, text, vcat, vsep, ($$), empty, errorDoc ) import Darcs.ColorPrinter ( fancyPrinters ) -import Darcs.Progress ( setProgressMode, debugMessage ) +import Progress ( setProgressMode, debugMessage ) import Darcs.SelectChanges ( view_changes ) import Darcs.Sealed ( unsafeUnseal ) #include "impossible.h" @@ -100,10 +100,7 @@ possibly_remote_repo_dir, working_repo_dir, all_interactive]} -\end{code} - -\begin{code} changes_cmd :: [DarcsFlag] -> [String] -> IO () changes_cmd [Context _] [] = return () changes_cmd opts args | Context rootDirectory `elem` opts = diff --git a/src/Darcs/Commands/Check.lhs b/src/Darcs/Commands/Check.lhs --- a/src/Darcs/Commands/Check.lhs +++ b/src/Darcs/Commands/Check.lhs @@ -18,18 +18,18 @@ \subsection{darcs check} \begin{code} module Darcs.Commands.Check ( check ) where -import Control.Monad ( when, unless ) +import Control.Monad ( when ) import System.Exit ( ExitCode(..), exitWith ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag( Quiet, NoTest ), - partial_check, notest, +import Darcs.Arguments ( DarcsFlag( Quiet ), + partial_check, notest, testByDefault, leave_test_dir, working_repo_dir, ) import Darcs.Repository.Repair( replayRepository, RepositoryConsistency(..) ) -import Darcs.Repository ( Repository, amInRepository, withRepository, ($-), slurp_recorded, - testTentative ) +import Darcs.Repository ( Repository, amInRepository, withRepository, slurp_recorded, + testRecorded ) import Darcs.Patch ( RepoPatch, showPatch ) import Darcs.Ordered ( FL(..) ) import Darcs.Diff ( unsafeDiff ) @@ -43,28 +43,22 @@ \begin{code} check_description :: String check_description = "Check the repository for consistency." -\end{code} -Check verifies that the patches stored in the repository, when successively -applied to an empty tree, properly recreate the stored pristine tree. -\begin{options} ---complete, --partial -\end{options} - -If you have a checkpoint of the repository (as is the case if you got the -repository originally using \verb!darcs get --partial!), by default -\verb'darcs check' -will only verify the contents since the most recent checkpoint. You can -change this behavior using the \verb!--complete! flag. - -\begin{code} check_help :: String check_help = - "Check verifies that the patches stored in the repository, when successively\n"++ - "applied to an empty tree, properly recreate the stored pristine tree.\n" -\end{code} + "This command verifies that the patches in the repository, when applied\n" ++ + "successively to an empty tree, result in the pristine tree. If not,\n" ++ + "the differences are printed and Darcs exits unsucessfully (with a\n" ++ + "non-zero exit status).\n" ++ + "\n" ++ + "If the repository is in darcs-1 format and has a checkpoint, you can\n" ++ + "use the --partial option to start checking from the latest checkpoint.\n" ++ + "This is the default for partial darcs-1 repositories; the --complete\n" ++ + "option to forces a full check.\n" ++ + "\n" ++ + "If a regression test is defined (see `darcs setpref') it will be run\n" ++ + "by `darcs check'. Use the --no-test option to disable this.\n" -\begin{code} check :: DarcsCommand check = DarcsCommand {command_name = "check", command_help = check_help, @@ -81,28 +75,25 @@ leave_test_dir, working_repo_dir ]} -\end{code} -\begin{code} check_cmd :: [DarcsFlag] -> [String] -> IO () -check_cmd opts _ = withRepository opts $- \repo -> check' repo opts +check_cmd opts _ = withRepository opts (check' opts) -check' :: (RepoPatch p) => Repository p -> [DarcsFlag] -> IO () -check' repository opts = do - res <- replayRepository repository opts $ \ state -> do +check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO () +check' opts repository = do + replayRepository repository (testByDefault opts) $ \ state -> do case state of RepositoryConsistent -> do putInfo $ text "The repository is consistent!" - unless (NoTest `elem` opts) $ testTentative repository - return ExitSuccess + testRecorded repository + exitWith ExitSuccess BrokenPristine newpris -> do brokenPristine newpris - return $ ExitFailure 1 + exitWith $ ExitFailure 1 BrokenPatches newpris _ -> do brokenPristine newpris putInfo $ text "Found broken patches." - return $ ExitFailure 1 - exitWith res + exitWith $ ExitFailure 1 where brokenPristine newpris = do putInfo $ text "Looks like we have a difference..." @@ -114,15 +105,8 @@ putInfo $ text "" $$ text "Inconsistent repository!" putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s -\end{code} +\end{code} +%% FIXME: this should go in "common options" or something, since +%% commands like record and amend-record also run the test command. \input{Darcs/Test.lhs} - -\begin{options} ---no-test -\end{options} - -If you just want to check the consistency of your repository without -running the test, you can call darcs check with the \verb!--no-test! -option. - diff --git a/src/Darcs/Commands/Convert.lhs b/src/Darcs/Commands/Convert.lhs --- a/src/Darcs/Commands/Convert.lhs +++ b/src/Darcs/Commands/Convert.lhs @@ -34,14 +34,14 @@ import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Commands.Init ( initialize ) -import Darcs.Arguments ( DarcsFlag( AllowConflicts, WorkDir, +import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo, SetScriptsExecutable, UseFormat2, NoUpdateWorking, Verbose, Quiet ), reponame, set_scripts_executable, network_options ) import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo, + createRepository, slurp_recorded, optimizeInventory, tentativelyMergePatches, patchSetToPatches, createPristineDirectoryTree, @@ -52,14 +52,13 @@ adddeps, getdeps, effect, flattenFL, is_merger, patchcontents ) import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL, concatFL, concatRL, mapRL ) -import Darcs.Patch.Depends ( is_tag ) -import Darcs.Patch.Info ( pi_rename, pi_tag ) +import Darcs.Patch.Info ( pi_rename, pi_tag, is_tag ) import Darcs.Patch.Commute ( public_unravel ) import Darcs.Patch.Real ( mergeUnravelled ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import Darcs.Repository.Motd ( show_motd ) import Darcs.Utils ( clarify_errors, askUser ) -import Darcs.Progress ( progressFL ) +import Darcs.ProgressPatches ( progressFL ) import Darcs.Sealed ( FlippedSeal(..) ) import Printer ( text, putDocLn, ($$) ) import Darcs.ColorPrinter ( traceDoc ) @@ -88,8 +87,7 @@ "repository, re-create each branch by using `darcs get' on the\n" ++ "converted repository, then using `darcs obliterate' to delete patches\n" ++ "of branches.\n" -\end{code} -\begin{code} + convert :: DarcsCommand convert = DarcsCommand {command_name = "convert", command_help = convert_help, @@ -102,10 +100,9 @@ command_argdefaults = nodefaults, command_advanced_options = network_options, command_basic_options = [reponame,set_scripts_executable]} -\end{code} -\begin{code} + convert_cmd :: [DarcsFlag] -> [String] -> IO () -convert_cmd opts [inrepodir, outname] = convert_cmd (WorkDir outname:opts) [inrepodir] +convert_cmd opts [inrepodir, outname] = convert_cmd (NewRepo outname:opts) [inrepodir] convert_cmd orig_opts [inrepodir] = do putDocLn $ text "WARNING: the repository produced by this command is not understood by" $$ text "the darcs 1 program, and patches cannot be exchanged between" $$ @@ -129,7 +126,7 @@ mysimplename <- make_repo_name opts repodir createDirectory mysimplename setCurrentDirectory mysimplename - (command_command initialize) opts [] + createRepository opts writeBinFile (darcsdir++"/hashed_inventory") "" withRepoLock (NoUpdateWorking:opts) $- \repositoryfoo -> withRepositoryDirectory opts repodir $- \themrepobar -> do @@ -211,11 +208,9 @@ "repository consistent again by running darcs revert -a."] convert_cmd _ _ = fail "You must provide 'convert' with either one or two arguments." -\end{code} -\begin{code} make_repo_name :: [DarcsFlag] -> FilePath -> IO String -make_repo_name (WorkDir n:_) _ = +make_repo_name (NewRepo n:_) _ = do exists <- doesDirectoryExist n file_exists <- doesFileExist n if exists || file_exists diff --git a/src/Darcs/Commands/Diff.lhs b/src/Darcs/Commands/Diff.lhs --- a/src/Darcs/Commands/Diff.lhs +++ b/src/Darcs/Commands/Diff.lhs @@ -232,9 +232,7 @@ askUser "Hit return to move on..." return () return output -\end{code} -\begin{code} get_diff_info :: RepoPatch p => [DarcsFlag] -> PatchSet p -> [PatchInfo] get_diff_info opts ps = let pi1s = mapRL info $ concatRL $ if first_match opts diff --git a/src/Darcs/Commands/Dist.lhs b/src/Darcs/Commands/Dist.lhs --- a/src/Darcs/Commands/Dist.lhs +++ b/src/Darcs/Commands/Dist.lhs @@ -46,41 +46,47 @@ import Exec ( exec, Redirect(..) ) \end{code} - \options{dist} - -\haskell{dist_description} - +\haskell{dist_help} \begin{code} -dist_description :: String -dist_description = - "Create a distribution tarball." -\end{code} -\haskell{dist_help} Basically, you will typically use it in a makefile -rule such as -\begin{verbatim} -dist: - darcs dist --dist-name darcs-`./darcs --version` -\end{verbatim} -\verb!darcs dist! then simply creates a clean copy of the source tree, -which it then tars and gzips. If you use programs such as autoconf or -automake, you really should run them on the clean tree before tarring it up -and distributing it. You can do this using the pref value ``predist'', -which is a shell command that is run prior to tarring up the distribution: -\begin{verbatim} -% darcs setpref predist "autoconf && automake" -\end{verbatim} +dist_description :: String +dist_description = "Create a distribution tarball." -\begin{code} dist_help :: String dist_help = - "Dist creates a tarball from a clean copy of the recorded edition of\n"++ - "your tree, eventually augmented by running the shell command specified\n"++ - "with the \"predist\" preference.\n" -\end{code} + "The `darcs dist' command creates a compressed archive (a `tarball') in\n" ++ + "the repository's root directory, containing the recorded state of the\n" ++ + -- FIXME: _ is escaped to appease TeX while we wait for reST. + "working tree (unrecorded changes and the \\_darcs directory are\n" ++ + "excluded).\n" ++ + "\n" ++ + "If a predist command is set (see `darcs setpref'), that command will\n" ++ + "be run on the tarball contents prior to archiving. For example,\n" ++ + -- FIXME: &s are escaped to appease TeX while we wait for reST. + "autotools projects would set it to `autoconf \\&\\& automake'.\n" ++ + "\n" ++ + "By default, the tarball (and the top-level directory within the\n" ++ + "tarball) has the same name as the repository, but this can be\n" ++ + "overridden with the --dist-name option.\n" -\begin{code} + -- FIXME: this is tedious and ugly. + {- + ++ "\n" ++ + "Suppose you use a version numbering scheme `major.minor.patch', and\n" ++ + "you tag each release `major.minor'. You can then calculate the\n" ++ + "version number by taking the newest tag and appending a dot and the\n" ++ + "number of patches since that tag. If you use the directory name as\n" ++ + "the project name, you can make tarballs of the form name-version.tgz\n" ++ + "using the following shell script:\n" ++ + "\n" ++ + " major_minor=$(darcs show tags | head -1) &&\n" ++ + " patch_level=$(($(darcs changes --count --from-tag .) - 1)) &&\n" ++ + " version=$major_minor.$patch_level &&\n" ++ + " project=${PWD##*/} &&\n" ++ + " darcs dist --dist-name \"$project\"-\"$version\".tar.gz\n" + -} + dist :: DarcsCommand dist = DarcsCommand {command_name = "dist", command_help = dist_help, @@ -96,9 +102,7 @@ working_repo_dir, match_one, store_in_memory]} -\end{code} -\begin{code} dist_cmd :: [DarcsFlag] -> [String] -> IO () dist_cmd opts args = withRepoReadLock opts $- \repository -> do distname <- get_dist_name opts 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 @@ -29,10 +29,10 @@ import Control.Monad ( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag( WorkDir, Partial, Lazy, +import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy, UseFormat2, UseOldFashionedInventory, UseHashedInventory, SetScriptsExecutable, Quiet, OnePattern ), - get_context, pristine_tree, get_inventory_choices, working_repo_dir, + get_context, get_inventory_choices, partial, reponame, match_one_context, set_default, set_scripts_executable, nolinks, network_options ) @@ -45,7 +45,8 @@ RepoProperty ( Darcs2, HashedInventory ), format_has ) import Darcs.Repository.DarcsRepo ( write_inventory ) import qualified Darcs.Repository.DarcsRepo as DR ( read_repo ) -import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches ) +import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches, + createRepository) import Darcs.Repository.ApplyPatches ( apply_patches ) import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint ) import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert, @@ -60,15 +61,14 @@ import Darcs.Commands.Init ( initialize ) import Darcs.Match ( have_patchset_match, get_one_patchset ) import Darcs.Utils ( catchall, formatPath, withCurrentDirectory ) -import Darcs.Progress ( debugMessage ) +import Progress ( debugMessage ) import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, ) import Darcs.Lock ( writeBinFile ) import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote) import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) import Darcs.Global ( darcsdir ) #include "impossible.h" -\end{code} -\begin{code} + get_description :: String get_description = "Create a local copy of another repository." @@ -94,8 +94,7 @@ get_help :: String get_help = "Get is used to get a local copy of a repository.\n" -\end{code} -\begin{code} + get :: DarcsCommand get = DarcsCommand {command_name = "get", command_help = get_help, @@ -113,13 +112,11 @@ match_one_context, set_default, set_scripts_executable, - nolinks, pristine_tree, - get_inventory_choices, - working_repo_dir]} -\end{code} -\begin{code} + nolinks, + get_inventory_choices]} + get_cmd :: [DarcsFlag] -> [String] -> IO () -get_cmd opts [inrepodir, outname] = get_cmd (WorkDir outname:opts) [inrepodir] +get_cmd opts [inrepodir, outname] = get_cmd (NewRepo outname:opts) [inrepodir] get_cmd opts [inrepodir] = do debugMessage "Starting work on get..." typed_repodir <- ioAbsoluteOrRemote inrepodir @@ -141,7 +138,7 @@ not (UseOldFashionedInventory `elem` opts) then UseHashedInventory:filter (/= UseFormat2) opts else UseOldFashionedInventory:filter (/= UseFormat2) opts - (command_command initialize) opts' [] + createRepository opts' debugMessage "Finished initializing new directory." set_defaultrepo repodir opts @@ -182,11 +179,8 @@ when (SetScriptsExecutable `elem` opts) setScriptsExecutable else copy_repo_old_fashioned repository opts repodir -\end{code} - -\begin{code} make_repo_name :: [DarcsFlag] -> FilePath -> IO String -make_repo_name (WorkDir n:_) _ = +make_repo_name (NewRepo n:_) _ = do exists <- doesDirectoryExist n file_exists <- doesFileExist n if exists || file_exists @@ -284,14 +278,6 @@ Only get the patches since the last checkpoint. This will save time, bandwidth and disk space, at the expense of losing the history before the checkpoint. - -\begin{options} ---no-pristine-tree -\end{options} -In order to save disk space, you can use {\tt get} with the -\verb|--no-pristine-tree| flag to create a repository with no pristine -tree. Please see Section~\ref{disk-usage} for more information. - \begin{code} diff --git a/src/Darcs/Commands/Help.lhs b/src/Darcs/Commands/Help.lhs --- a/src/Darcs/Commands/Help.lhs +++ b/src/Darcs/Commands/Help.lhs @@ -18,11 +18,6 @@ \subsection{darcs help} \label{help} -You could also call \verb|help| as a command. This is equivalent to calling -darcs --help. -the \verb|--help| to that command. For example, \verb|darcs help query manifest| -is equivalent to \verb|darcs query manifest --help|. - \begin{code} module Darcs.Commands.Help ( help_cmd, command_control_list, print_version, list_available_commands @@ -49,18 +44,17 @@ \haskell{help_description} \begin{code} help_description :: String -help_description = "Display help for darcs or a single command." +help_description = "Display help about darcs and darcs commands." \end{code} \haskell{help_help} \begin{code} help_help :: String help_help = - "help displays usage information for darcs in general or for a single\n" ++ - "command (for example, darcs help query manifest).\n\n" -\end{code} + "Without arguments, `darcs help' prints a categorized list of darcs\n" ++ + "commands and a short description of each one. With an extra argument,\n" ++ + "`darcs help foo' prints detailed help about the darcs command foo.\n" -\begin{code} help :: DarcsCommand help = DarcsCommand {command_name = "help", command_help = help_help, @@ -73,9 +67,7 @@ command_argdefaults = nodefaults, command_advanced_options = [], command_basic_options = [help_on_match]} -\end{code} -\begin{code} help_cmd :: [DarcsFlag] -> [String] -> IO () help_cmd opts [] = do viewDoc $ text $ @@ -110,14 +102,10 @@ putStrLn "--overview" where isRight (Right _) = True isRight _ = False -\end{code} -\begin{code} print_version :: IO () print_version = putStrLn $ "darcs version " ++ darcs_version -\end{code} -\begin{code} -- avoiding a module import cycle between Help and TheCommands command_control_list :: [CommandControl] command_control_list = diff --git a/src/Darcs/Commands/Init.lhs b/src/Darcs/Commands/Init.lhs --- a/src/Darcs/Commands/Init.lhs +++ b/src/Darcs/Commands/Init.lhs @@ -19,7 +19,7 @@ \begin{code} module Darcs.Commands.Init ( initialize, initialize_cmd ) where import Darcs.Commands ( DarcsCommand(..), nodefaults ) -import Darcs.Arguments ( DarcsFlag, pristine_tree, working_repo_dir, +import Darcs.Arguments ( DarcsFlag, working_repo_dir, inventory_choices ) import Darcs.Repository ( amNotInRepository, createRepository ) \end{code} @@ -44,9 +44,7 @@ "level directory of the project, with the project files already there.\n"++ "Initialize will set up all the directories and files darcs needs in order to\n"++ "start keeping track of revisions for your project.\n" -\end{code} -\begin{code} initialize :: DarcsCommand initialize = DarcsCommand {command_name = "initialize", command_help = initialize_help, @@ -58,7 +56,7 @@ command_get_arg_possibilities = return [], command_argdefaults = nodefaults, command_advanced_options = [], - command_basic_options = [pristine_tree, inventory_choices, + command_basic_options = [inventory_choices, working_repo_dir]} \end{code} @@ -75,54 +73,7 @@ --darcs-2 \end{options} -These options describe possible repository formats to use. - -\verb'old-fashioned-inventory' is now deprecated and should be avoided if at -all possible. - -\verb'hashed' Offers several features while still being compatible with old-fashioned repositories. The specific features are: - -\begin{itemize} - -\item The hashed format allows for greater atomicity of operations. This makes for greater safety and simultaneously greater efficiency. These benefits, however, have not been fully realized in this release. For instance, with a hashed repository, there is no need for darcs push to require a repository lock, so you could record patches while waiting for a push to finish (for instance, if it's waiting on the test suite). - -\item The \verb!_darcs/pristine! directory no longer holds the pristine -cache. This disallows certain hackish short-cuts, but also dramatically -reduces the danger of third-party programs (e.g. DreamWeaver) recursing -into the pristine cache and corrupting darcs repositories. - -\item Darcs get can optionally operate in a much faster ``lazy'' -fashion, meaning that patches are downloaded only when they are -needed. This gives us much of the benefits of --partial repositories, -without most of their disadvantages. This approach, however, does have -several new dangers. First, some operations may unexpectedly require the -download of large numbers of patches, which could be slow (but you could -always interrupt with \verb!^C!). Secondly, if the source repository disappears, -or you lose network connectivity, some operations may fail. - -\item Darcs now supports caching of patches and file contents to reduce bandwidth and save disk space. It greatly speeds up a number of operations, and is essentially transparent. The only reason we don't enable it by default is because it creates a large directory in ~/.darcs/cache without the user's explicit consent. - -\end{itemize} - -\verb'darcs-2' Is the default. It enables all available features, and -requiring that all repos for a project use the same format. In addition to the -features of the \verb'hashed' format described above, the \verb'darcs-2' format -also enables the following: - -\begin{itemize} - -\item It should no longer be possible to confuse darcs or freeze it indefinitely by merging conflicting changes. - -\item Identical primitive changes no longer conflict. This is a long-requested feature, and has far-reaching implications. - -\end{itemize} - -\begin{options} ---no-pristine-tree -\end{options} -In order to save disk space, you can use \verb|initialize| with the -\verb|--no-pristine-tree| flag to create a repository with no pristine -tree. Please see Section~\ref{disk-usage} for more information. +These options force a particular repository format to be used. \begin{code} initialize_cmd :: [DarcsFlag] -> [String] -> IO () diff --git a/src/Darcs/Commands/MarkConflicts.lhs b/src/Darcs/Commands/MarkConflicts.lhs --- a/src/Darcs/Commands/MarkConflicts.lhs +++ b/src/Darcs/Commands/MarkConflicts.lhs @@ -37,11 +37,10 @@ import Darcs.Resolution ( patchset_conflict_resolutions ) import Darcs.Utils ( promptYorn ) #include "impossible.h" -\end{code} -\begin{code} + markconflicts_description :: String markconflicts_description = - "Mark any conflicts to the working copy for manual resolution." + "Mark any unresolved conflicts in working copy, for manual resolution." \end{code} \options{mark-conflicts} @@ -51,11 +50,25 @@ \begin{code} markconflicts_help :: String markconflicts_help = - "Mark-conflicts is used to mark and resolve any conflicts that may exist in a\n"++ - "repository. Note that this trashes any unrecorded changes in the working\n"++ - "copy.\n" -\end{code} -\begin{code} + "Darcs requires human guidance to unify changes to the same part of a\n" ++ + "source file. When a conflict first occurs, darcs will add both\n" ++ + "choices to the working tree, delimited by markers.\n" ++ + -- Removing this part of the sentence for now, because ^ ^ ^ upsets TeX. + -- the markers `v v v', `* * *' and `^ ^ ^'.\n" + "\n" ++ + "However, you might revert or manually delete these markers without\n" ++ + "actually resolving the conflict. In this case, `darcs mark-conflicts'\n" ++ + "is useful to show where any unresolved conflicts. It is also useful\n" ++ + "if `darcs apply' is called with --apply-conflicts, where conflicts\n" ++ + "aren't marked initially.\n" ++ + "\n" ++ + "Any unrecorded changes to the working tree *will* be lost forever when\n" ++ + "you run this command! You will be prompted for confirmation before\n" ++ + "this takes place.\n" ++ + "\n" ++ + "This command was historically called `resolve', and this deprecated\n" ++ + "alias still exists for backwards-compatibility.\n" + markconflicts :: DarcsCommand markconflicts = DarcsCommand {command_name = "mark-conflicts", command_help = markconflicts_help, @@ -69,9 +82,7 @@ command_advanced_options = [umask_option], command_basic_options = [ignoretimes, working_repo_dir]} -\end{code} -\begin{code} markconflicts_cmd :: [DarcsFlag] -> [String] -> IO () markconflicts_cmd opts [] = withRepoLock opts $- \repository -> do pend <- get_unrecorded_unsorted repository @@ -95,11 +106,8 @@ bug ("Problem marking conflicts in mark-conflicts!" ++ show e) putStrLn "Finished marking conflicts." markconflicts_cmd _ _ = impossible -\end{code} -% resolve - not documented because hidden - -\begin{code} +-- |resolve is an alias for mark-conflicts. resolve :: DarcsCommand resolve = command_alias "resolve" markconflicts \end{code} diff --git a/src/Darcs/Commands/Mv.lhs b/src/Darcs/Commands/Mv.lhs --- a/src/Darcs/Commands/Mv.lhs +++ b/src/Darcs/Commands/Mv.lhs @@ -46,9 +46,7 @@ import Darcs.Patch.FileName ( fp2fn, fn2fp, super_name ) import qualified System.FilePath.Windows as WindowsFilePath #include "impossible.h" -\end{code} -\begin{code} mv_description :: String mv_description = "Move/rename one or more files or directories." @@ -75,9 +73,7 @@ "Darcs mv needs to be called whenever you want to move files or\n"++ "directories. Unlike remove, mv actually performs the move itself in your\n"++ "working copy.\n" -\end{code} -\begin{code} mv :: DarcsCommand mv = DarcsCommand {command_name = "mv", command_help = mv_help, @@ -93,9 +89,7 @@ mv_cmd :: [DarcsFlag] -> [String] -> IO () mv_cmd _ [] = fail "You must specify at least two arguments for mv" mv_cmd _ [_] = fail "You must specify at least two arguments for mv" -\end{code} -\begin{code} mv_cmd opts args@[_,_] = withRepoLock opts $- \repository -> do two_files <- fixSubPaths opts args [old,new] <- return $ case two_files of @@ -115,9 +109,7 @@ Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL) Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL) move_file_or_dir work old_fp new_fp -\end{code} -\begin{code} mv_cmd opts args = withRepoLock opts $- \repository -> do relpaths <- map toFilePath `fmap` fixSubPaths opts args 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 @@ -54,15 +54,14 @@ import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS ) import Darcs.RepoPath ( toFilePath ) import Darcs.Utils ( withCurrentDirectory ) -import Darcs.Progress ( debugMessage ) +import Progress ( debugMessage ) import Printer ( putDocLn, text, ($$) ) import Darcs.SlurpDirectory ( slurp, list_slurpy_files ) import Darcs.Repository.Pristine ( identifyPristine, pristineDirectory ) import Darcs.Sealed ( FlippedSeal(..), unsafeUnseal ) import Darcs.Global ( darcsdir ) #include "impossible.h" -\end{code} -\begin{code} + optimize_description :: String optimize_description = "Optimize the repository." @@ -76,8 +75,7 @@ optimize_help :: String optimize_help = "Optimize can help to improve the performance of your repository in a number of cases.\n" -\end{code} -\begin{code} + optimize :: DarcsCommand optimize = DarcsCommand {command_name = "optimize", command_help = optimize_help, @@ -95,8 +93,7 @@ reorder_patches, sibling, relink, relink_pristine]} -\end{code} -\begin{code} + optimize_cmd :: [DarcsFlag] -> [String] -> IO () optimize_cmd origopts _ = withRepoLock opts $- \repository -> do cleanRepository repository @@ -182,9 +179,7 @@ lasts [] = [] lasts (x@(_:_):ls) = last x : lasts ls lasts ([]:ls) = lasts ls -\end{code} -\begin{code} mymatch :: String -> PatchInfo -> Bool mymatch r = match_name $ matchRegex (mkRegex r) match_name :: (String -> Maybe a) -> PatchInfo -> Bool 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 @@ -59,8 +59,7 @@ import Darcs.Sealed ( Sealed(..), seal ) import Printer ( putDocLn, vcat, ($$), text ) #include "impossible.h" -\end{code} -\begin{code} + pull_description :: String pull_description = "Copy and apply patches from another repository to this one." @@ -79,8 +78,7 @@ "accepts arguments, which are URLs from which to pull, and when called\n"++ "without an argument, pull will use the repository from which you have most\n"++ "recently either pushed or pulled.\n" -\end{code} -\begin{code} + pull :: DarcsCommand pull = DarcsCommand {command_name = "pull", command_help = pull_help, @@ -107,8 +105,7 @@ set_default, working_repo_dir, allow_unrelated_repos]} -\end{code} -\begin{code} + pull_cmd :: [DarcsFlag] -> [String] -> IO () pull_cmd opts unfixedrepodirs@(_:_) = @@ -174,9 +171,6 @@ "by using 'darcs revert' you should be able to make your", "working directory consistent again."] pull_cmd _ [] = fail "No default repository to pull from, please specify one" -\end{code} - -\begin{code} {- Read in the specified pull-from repositories. Perform Intersection, Union, or Complement read. In patch-theory terms 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 @@ -53,8 +53,7 @@ import Darcs.Email ( make_email ) import English (englishNum, Noun(..)) #include "impossible.h" -\end{code} -\begin{code} + push_description :: String push_description = "Copy and apply patches from this repository to another one." @@ -67,8 +66,7 @@ push_help = "Push is the opposite of pull. Push allows you to copy changes from the\n"++ "current repository into another repository.\n" -\end{code} -\begin{code} + push :: DarcsCommand push = DarcsCommand {command_name = "push", command_help = push_help, @@ -89,8 +87,7 @@ working_repo_dir, set_default, allow_unrelated_repos]} -\end{code} -\begin{code} + push_cmd :: [DarcsFlag] -> [String] -> IO () push_cmd opts [""] = push_cmd opts [] push_cmd opts [unfixedrepodir] = @@ -177,8 +174,7 @@ ExitSuccess -> putInfo $ text "Push successful." $$ pull_reminder push_cmd _ _ = impossible -\end{code} -\begin{code} + want_sign :: [DarcsFlag] -> Bool want_sign opts = case opts of [] -> False 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 @@ -24,7 +24,7 @@ import Darcs.Repository.Prefs ( get_preflist, set_defaultrepo ) import Darcs.URL ( is_url, is_file ) import Darcs.Utils ( withCurrentDirectory ) -import Darcs.Progress ( debugMessage ) +import Progress ( debugMessage ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import Darcs.SlurpDirectory ( empty_slurpy ) import Darcs.External ( execSSH ) @@ -33,8 +33,7 @@ import Darcs.Email ( make_email ) import Darcs.Sealed ( Sealed(..), seal ) #include "impossible.h" -\end{code} -\begin{code} + put_description :: String put_description = "Makes a copy of the repository" @@ -43,11 +42,16 @@ \haskell{put_help} \begin{code} put_help :: String -put_help = - "Put is the opposite of get. Put copies the content of the current \n" ++ - "repository and puts it in a newly created repository.\n" -\end{code} -\begin{code} +put_help = + "The `darcs put' command creates a copy of the current repository. It\n" ++ + "is currently very inefficient, so when creating local copies you\n" ++ + "should use `darcs get . x' instead of `darcs put x'.\n" ++ + "\n" ++ + "Currently this command just uses `darcs init' to create the target\n" ++ + "repository, then `darcs push --all' to copy patches to it. Options\n" ++ + "passed to `darcs put' are passed to the init and/or push commands as\n" ++ + "appropriate. See those commands for an explanation of each option.\n" + put ::DarcsCommand put = DarcsCommand {command_name = "put", command_help = put_help, @@ -62,8 +66,7 @@ command_basic_options = [match_one_context, set_scripts_executable, get_inventory_choices, set_default, working_repo_dir]} -\end{code} -\begin{code} + put_cmd :: [DarcsFlag] -> [String] -> IO () put_cmd _ [""] = fail "Empty repository argument given to put." put_cmd opts [unfixedrepodir] = @@ -135,45 +138,3 @@ fail "Couldn't initialize remote repository." where (addr,':':path) = break (==':') repo \end{code} - -\emph{WARNING:} Put is far less optimized than get, especially for local -repositories. We recommend avoiding use of put except for small -repositories. - -Put is used when you already have a repository and want to make a copy -of it. A typical use-case is when you want to branch your project. - -Put works by first initializing a repository. If the new repository is -not on the local file system then darcs will login to the remote host -and run \verb!darcs init! there. After the new repository is created -all selected patches will be pushed just as with the command -\verb!push!. - -\begin{options} ---apply-as -\end{options} - -If you give the \verb!--apply-as! flag, darcs will use sudo to apply the -changes as a different user. This can be useful if you want to set up a -system where several users can modify the same repository, but you don't -want to allow them full write access. This isn't secure against skilled -malicious attackers, but at least can protect your repository from clumsy, -inept or lazy users. - -\begin{options} ---context, --tag, --to-patch, --to-match -\end{options} -If you want to put a specific version of a repository, you have a few -options. You can either use the \verb!--tag!, \verb!--to-patch! or -\verb!--to-match! options, or you can use the \verb!--context=FILENAME! -option, which specifies a file containing a context generated with -\verb!darcs changes --context!. This allows you (for example) to include in -your compiled program an option to output the precise version of the -repository from which it was generated, and then perhaps ask users to -include this information in bug reports. - -Note that when specifying \verb!--to-patch! or \verb!--to-match!, you may -get a version of your code that has never before been seen, if the patches -have gotten themselves reordered. If you ever want to be able to precisely -reproduce a given version, you need either to tag it or create a context -file. diff --git a/src/Darcs/Commands/Record.lhs b/src/Darcs/Commands/Record.lhs --- a/src/Darcs/Commands/Record.lhs +++ b/src/Darcs/Commands/Record.lhs @@ -53,23 +53,23 @@ import Darcs.RepoPath ( FilePathLike, SubPath, sp2fn, toFilePath ) import Darcs.SlurpDirectory ( Slurpy, empty_slurpy ) import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_stub ) -import Darcs.Arguments ( DarcsFlag( PromptLongComment, Test, NoTest, NoEditLongComment, +import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment, EditLongComment, RmLogFile, LogFile, Pipe, PatchName, AskDeps, All ), get_author, working_repo_dir, lookforadds, - fixSubPaths, defineChanges, + fixSubPaths, defineChanges, testByDefault, ask_long_comment, askdeps, patch_select_flag, all_pipe_interactive, leave_test_dir, notest, author, patchname_option, umask_option, ignoretimes, nocompress, rmlogfile, logfile, list_registered_files, set_scripts_executable ) import Darcs.Utils ( askUser, promptYorn, edit_file, clarify_errors ) -import Darcs.Progress ( debugMessage, progressFL ) +import Progress ( debugMessage) +import Darcs.ProgressPatches( progressFL) import IsoDate ( getIsoDateTime, cleanLocalDate ) import Printer ( hPutDocLn, text, wrap_text, ($$), renderString ) #include "impossible.h" -\end{code} -\begin{code} + record_description :: String record_description = "Save changes in the working copy to the repository as a patch." @@ -85,8 +85,7 @@ record_help = renderString $ wrap_text 80 $ "Record is used to name a set of changes and record the patch to the "++ "repository." -\end{code} -\begin{code} + record :: DarcsCommand record = DarcsCommand {command_name = "record", command_help = record_help, @@ -109,8 +108,7 @@ ask_long_comment, lookforadds, working_repo_dir]} -\end{code} -\begin{code} + commit_description :: String commit_description = "Does not actually do anything, but offers advice on saving changes" @@ -124,8 +122,7 @@ commit :: DarcsCommand commit = command_stub "commit" commit_help commit_description record -\end{code} -\begin{code} + file_exists :: Slurpy -> SubPath -> IO Bool file_exists s rp = do file <- doesFileExist fp dir <- doesDirectoryExist fp @@ -135,13 +132,10 @@ where fp = toFilePath rp record_cmd :: [DarcsFlag] -> [String] -> IO () -record_cmd origopts args = do - check_name_is_not_option origopts - +record_cmd opts args = do + check_name_is_not_option opts let (logMessage,_, _) = loggers opts - opts = if NoTest `elem` origopts then origopts else Test:origopts - - withRepoLock opts $- \repository -> do + withRepoLock (testByDefault opts) $- \repository -> do rec <- if null args then return empty_slurpy else slurp_recorded repository files <- sort `fmap` fixSubPaths opts args @@ -166,7 +160,7 @@ else logMessage "No changes!" Just ch -> do_record repository opts existing_files ch where allow_empty_with_askdeps NilFL - | AskDeps `elem` origopts = Just NilFL + | AskDeps `elem` opts = Just NilFL | otherwise = Nothing allow_empty_with_askdeps p = Just p diff --git a/src/Darcs/Commands/Remove.lhs b/src/Darcs/Commands/Remove.lhs --- a/src/Darcs/Commands/Remove.lhs +++ b/src/Darcs/Commands/Remove.lhs @@ -38,9 +38,7 @@ import Darcs.Repository.Prefs ( filetype_function ) import Darcs.Diff ( unsafeDiff ) #include "impossible.h" -\end{code} -\begin{code} remove_description :: String remove_description = "Remove one or more files or directories from the repository." @@ -58,9 +56,7 @@ "file or directory, and darcs will notice that it has been removed.\n" ++ "Be aware that the file WILL be deleted from any other copy of the\n" ++ "repository to which you later apply the patch.\n" -\end{code} -\begin{code} remove :: DarcsCommand remove = DarcsCommand {command_name = "remove", command_help = remove_help, @@ -74,9 +70,7 @@ command_advanced_options = [umask_option], command_basic_options = [working_repo_dir]} -\end{code} -\begin{code} remove_cmd :: [DarcsFlag] -> [String] -> IO () remove_cmd opts relargs = withRepoLock opts $- \repository -> do diff --git a/src/Darcs/Commands/Repair.lhs b/src/Darcs/Commands/Repair.lhs --- a/src/Darcs/Commands/Repair.lhs +++ b/src/Darcs/Commands/Repair.lhs @@ -33,18 +33,17 @@ \options{repair} \begin{code} repair_description :: String -repair_description = "Repair the corrupted repository." +repair_description = "Repair a corrupted repository." \end{code} \haskell{repair_help} \begin{code} repair_help :: String repair_help = - "Repair attempts to fix corruption that may have entered your\n"++ - "repository.\n" -\end{code} + "The `darcs repair' command attempts to fix corruption in the current\n" ++ + "repository. Currently it can only repair damage to the pristine tree,\n" ++ + "which is where most corruption occurs.\n" -\begin{code} repair :: DarcsCommand repair = DarcsCommand {command_name = "repair", command_help = repair_help, @@ -57,13 +56,6 @@ command_argdefaults = nodefaults, command_advanced_options = [umask_option], command_basic_options = [working_repo_dir]} -\end{code} - -Repair currently will only repair damage to the pristine tree. -Fortunately this is just the sort of corruption that is most -likely to happen. - -\begin{code} repair_cmd :: [DarcsFlag] -> [String] -> IO () repair_cmd opts _ = withRepoLock opts $- \repository -> do diff --git a/src/Darcs/Commands/Replace.lhs b/src/Darcs/Commands/Replace.lhs --- a/src/Darcs/Commands/Replace.lhs +++ b/src/Darcs/Commands/Replace.lhs @@ -48,9 +48,7 @@ import Darcs.RepoPath ( SubPath, sp2fn, toFilePath ) import Darcs.Repository.Prefs ( FileType(TextFile) ) #include "impossible.h" -\end{code} -\begin{code} replace_description :: String replace_description = "Replace a token with a new value for that token." @@ -114,9 +112,7 @@ "special patch and will merge as expected with other patches.\n"++ "Tokens here are defined by a regexp specifying the characters\n"++ "which are allowed. By default a token corresponds to a C identifier.\n" -\end{code} -\begin{code} replace :: DarcsCommand replace = DarcsCommand {command_name = "replace", command_help = replace_help, @@ -131,9 +127,7 @@ command_advanced_options = [ignoretimes, umask_option], command_basic_options = [tokens, force_replace, working_repo_dir]} -\end{code} -\begin{code} replace_cmd :: [DarcsFlag] -> [String] -> IO () replace_cmd opts (old:new:relfs) = withRepoLock opts $- \repository -> do fs <- fixSubPaths opts relfs @@ -177,9 +171,7 @@ where f_fp = toFilePath f replace_cmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]" -\end{code} -\begin{code} default_toks :: String default_toks = "A-Za-z_0-9" filename_toks :: String diff --git a/src/Darcs/Commands/Revert.lhs b/src/Darcs/Commands/Revert.lhs --- a/src/Darcs/Commands/Revert.lhs +++ b/src/Darcs/Commands/Revert.lhs @@ -44,8 +44,7 @@ import Darcs.Patch.TouchesFiles ( choose_touching ) import Darcs.Commands.Unrevert ( write_unrevert ) import Darcs.Sealed ( unsafeUnseal ) -\end{code} -\begin{code} + revert_description :: String revert_description = "Revert to the recorded version (not always reversible)." @@ -64,8 +63,7 @@ "not yet been recorded. You will be prompted for which changes you\n"++ "wish to undo. The last revert can be undone safely using the unrevert\n"++ "command if the working copy was not modified in the meantime.\n" -\end{code} -\begin{code} + revert :: DarcsCommand revert = DarcsCommand {command_name = "revert", command_help = revert_help, diff --git a/src/Darcs/Commands/Rollback.lhs b/src/Darcs/Commands/Rollback.lhs --- a/src/Darcs/Commands/Rollback.lhs +++ b/src/Darcs/Commands/Rollback.lhs @@ -52,13 +52,11 @@ import Darcs.Commands.Record ( file_exists, get_log ) import Darcs.Commands.Unrecord ( get_last_patches ) import Darcs.Utils ( clarify_errors ) -import Darcs.Progress ( debugMessage ) +import Progress ( debugMessage ) import Darcs.Sealed ( Sealed(..), FlippedSeal(..) ) import IsoDate ( getIsoDateTime ) #include "impossible.h" -\end{code} -\begin{code} rollback_description :: String rollback_description = "Record a new patch reversing some recorded changes." @@ -82,8 +80,7 @@ "of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"++ "goal) rollback is perfectly safe, since it leaves in the repository a record\n"++ "of its changes.\n" -\end{code} -\begin{code} + rollback :: DarcsCommand rollback = DarcsCommand {command_name = "rollback", command_help = rollback_help, @@ -100,8 +97,7 @@ author, patchname_option, ask_long_comment, notest, leave_test_dir, working_repo_dir]} -\end{code} -\begin{code} + rollback_cmd :: [DarcsFlag] -> [String] -> IO () rollback_cmd opts args = withRepoLock opts $- \repository -> do let (logMessage,_,_) = loggers opts 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 @@ -63,15 +63,14 @@ import Darcs.SelectChanges ( with_selected_changes ) import Darcs.Patch.Depends ( get_common_and_uncommon ) import Darcs.Utils ( askUser, catchall, edit_file, formatPath ) -import Darcs.Progress ( debugMessage ) +import Progress ( debugMessage ) import Darcs.Email ( make_email ) import Printer ( Doc, vsep, vcat, text, ($$), putDocLn, putDoc ) import Darcs.RepoPath ( toFilePath, AbsolutePath, AbsolutePathOrStd, getCurrentDirectory, makeAbsoluteOrStd, useAbsoluteOrStd ) import HTTP ( postUrl ) #include "impossible.h" -\end{code} -\begin{code} + send_description :: String send_description = "Send by email a bundle of one or more patches." @@ -139,8 +138,7 @@ set_default, working_repo_dir, sendmail_cmd, allow_unrelated_repos]} -\end{code} -\begin{code} + send_cmd :: [DarcsFlag] -> [String] -> IO () send_cmd input_opts [""] = send_cmd input_opts [] send_cmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do @@ -365,17 +363,13 @@ then putInfoLn $ "Patch bundle would be sent to: "++unwords (map pn emails) else when (null the_targets) $ putInfoLn $ "Patch bundle will be sent to: "++unwords (map pn emails) -\end{code} -\begin{code} get_output :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd get_output (Output a:_) _ = return a get_output (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f get_output (_:flags) f = get_output flags f get_output [] _ = Nothing -\end{code} -\begin{code} get_targets :: [WhatToDo] -> IO [WhatToDo] get_targets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? " get_targets wtds = return wtds diff --git a/src/Darcs/Commands/SetPref.lhs b/src/Darcs/Commands/SetPref.lhs --- a/src/Darcs/Commands/SetPref.lhs +++ b/src/Darcs/Commands/SetPref.lhs @@ -32,58 +32,49 @@ import Darcs.Ordered ( FL(..) ) import Darcs.Repository.Prefs ( get_prefval, change_prefval, ) #include "impossible.h" -\end{code} -\begin{code} -setpref_description :: String -setpref_description = - "Set a value for a preference (test, predist, ...)." -\end{code} - -\options{setpref} -Usage example: -\begin{verbatim} -% darcs setpref test "echo I am not really testing anything." -\end{verbatim} - -\haskell{setpref_help} If you just want to set the pref value in your -repository only, you can just edit ``\verb!_darcs/prefs/prefs!''. Changes -you make in that file will be preserved. +-- | A list of all valid preferences for @_darcs/prefs/prefs@. +valid_pref_data :: [(String, String)] -- ^ (name, one line description) +valid_pref_data = + [("test", "a shell command that runs regression tests"), + ("predist", "a shell command to run before `darcs dist'"), + ("boringfile", "the path to a version-controlled boring file"), + ("binariesfile", "the path to a version-controlled binaries file")] -The ``\verb!_darcs/prefs/prefs!'' holds the only preferences information -that can propagate between repositories by pushes and pulls, and the only -way this happens is when the setprefs command is used. Note that although -prefs settings are included in patches, they are \emph{not} fully version -controlled. In particular, depending on the order in which a series of -merges is performed, you may end up with a different final prefs -configuration. In practice I don't expect this to be a problem, as the -prefs usually won't be changed very often. +valid_prefs :: [String] +valid_prefs = map fst valid_pref_data -\begin{code} -valid_pref_data :: [String] -valid_pref_data = ["test", "predist", "boringfile", "binariesfile"] -\end{code} -The following values are valid preferences options which can be configured -using setpref: -\begin{itemize} -\item ``test'' --- the command to run as a test script. -\item ``predist'' --- a command to run prior to tarring up a distribution - tarball. Typically this would consist of autoconf and/or automake. -\item ``boringfile'' --- the name of a file to read instead of the - ``boring'' prefs file. -\item ``binariesfile'' --- the name of a file to read instead of the - ``binaries'' prefs file. -\end{itemize} +setpref_description :: String +setpref_description = "Set the value of a preference (" ++ ps ++ ")." + where ps = iter valid_prefs + iter [x] = x + iter [x,y] = x ++ " or " ++ y + iter (x:xs) = x ++ ", " ++ (iter xs) + iter [] = "" -- impossible, but keeps -Wall happy -\begin{code} setpref_help :: String setpref_help = - "Setpref allows you to set a preference value in a way that will\n"++ - "propagate to other repositories.\n\n"++ - "Valid preferences are: "++unwords valid_pref_data++".\n" -\end{code} + "When working on project with multiple repositories and contributors,\n" ++ + "it is sometimes desirable for a preference to be set consistently\n" ++ + "project-wide. This is achieved by treating a preference set with\n" ++ + "`darcs setpref' as an unrecorded change, which can then be recorded\n" ++ + "and then treated like any other patch.\n" ++ + "\n" ++ + "Valid preferences are:\n" ++ + "\n" ++ + (unlines $ map unwords $ map (\ (x,y) -> [" ",x,"--",y]) valid_pref_data) ++ + "\n" ++ + "For example, a project using GNU autotools, with a `make test' target\n" ++ + "to perform regression tests, might enable Darcs' integrated regression\n" ++ + "testing with the following command:\n" ++ + "\n" ++ + " darcs setpref test 'autoconf && ./configure && make && make test'\n" ++ + "\n" ++ + "Note that merging is not currently implemented for preferences: if two\n" ++ + "patches attempt to set the same preference, the last patch applied to\n" ++ + "the repository will always take precedence. This is considered a\n" ++ + "low-priority bug, because preferences are seldom set.\n" -\begin{code} setpref :: DarcsCommand setpref = DarcsCommand {command_name = "setpref", command_help = setpref_help, @@ -93,23 +84,21 @@ ""], command_command = setpref_cmd, command_prereq = amInRepository, - command_get_arg_possibilities = return valid_pref_data, + command_get_arg_possibilities = return valid_prefs, command_argdefaults = nodefaults, command_advanced_options = [umask_option], command_basic_options = [working_repo_dir]} -\end{code} -\begin{code} setpref_cmd :: [DarcsFlag] -> [String] -> IO () setpref_cmd opts [pref,val] = withRepoLock opts $- \repository -> do when (' ' `elem` pref) $ do putStrLn $ "'"++pref++ "' is not a valid preference name: no spaces allowed!" exitWith $ ExitFailure 1 - when (not $ pref `elem` valid_pref_data) $ do + when (not $ pref `elem` valid_prefs) $ do putStrLn $ "'"++pref++"' is not a valid preference name!" - putStrLn $ "Try one of: "++unwords valid_pref_data++"" + putStrLn $ "Try one of: " ++ unwords valid_prefs exitWith $ ExitFailure 1 oval <- get_prefval pref old <- case oval of Just v -> return v diff --git a/src/Darcs/Commands/ShowAuthors.lhs b/src/Darcs/Commands/ShowAuthors.lhs --- a/src/Darcs/Commands/ShowAuthors.lhs +++ b/src/Darcs/Commands/ShowAuthors.lhs @@ -38,16 +38,12 @@ \begin{code} show_authors_description :: String show_authors_description = "Show all authors in the repository." -\end{code} -\begin{code} show_authors_help :: String show_authors_help = "The authors command writes a list of all patch authors in the repository to\n" ++ "standard output." -\end{code} -\begin{code} show_authors :: DarcsCommand show_authors = DarcsCommand { command_name = "authors", diff --git a/src/Darcs/Commands/ShowBug.lhs b/src/Darcs/Commands/ShowBug.lhs --- a/src/Darcs/Commands/ShowBug.lhs +++ b/src/Darcs/Commands/ShowBug.lhs @@ -52,9 +52,7 @@ command_argdefaults = nodefaults, command_advanced_options = [], command_basic_options = [working_repo_dir]} -\end{code} -\begin{code} show_bug_cmd :: [DarcsFlag] -> [String] -> IO () show_bug_cmd _ _ = bug "This is actually a fake bug in darcs." \end{code} diff --git a/src/Darcs/Commands/ShowContents.lhs b/src/Darcs/Commands/ShowContents.lhs --- a/src/Darcs/Commands/ShowContents.lhs +++ b/src/Darcs/Commands/ShowContents.lhs @@ -63,9 +63,7 @@ command_argdefaults = nodefaults, command_advanced_options = [], command_basic_options = [match_one, working_repo_dir]} -\end{code} -\begin{code} show_contents_cmd :: [DarcsFlag] -> [String] -> IO () show_contents_cmd opts args = withRepository opts $- \repository -> do formerdir <- getCurrentDirectory diff --git a/src/Darcs/Commands/ShowFiles.lhs b/src/Darcs/Commands/ShowFiles.lhs --- a/src/Darcs/Commands/ShowFiles.lhs +++ b/src/Darcs/Commands/ShowFiles.lhs @@ -55,17 +55,13 @@ \begin{code} show_files_description :: String show_files_description = "Show version-controlled files in the working copy." -\end{code} -\begin{code} show_files_help :: String show_files_help = "The files command lists the version-controlled files in the\n"++ "working copy. The similar manifest command, lists the same\n"++ "files, excluding any directories.\n" -\end{code} -\begin{code} show_files :: DarcsCommand show_files = DarcsCommand { command_name = "files", diff --git a/src/Darcs/Commands/ShowRepo.lhs b/src/Darcs/Commands/ShowRepo.lhs --- a/src/Darcs/Commands/ShowRepo.lhs +++ b/src/Darcs/Commands/ShowRepo.lhs @@ -52,9 +52,7 @@ import Darcs.Patch ( RepoPatch ) import Darcs.Ordered ( lengthRL, concatRL ) import qualified Data.ByteString.Char8 as BC (unpack) -\end{code} -\begin{code} show_repo_help :: String show_repo_help = "The repo command displays information about the current repository\n" ++ @@ -66,10 +64,7 @@ show_repo_description :: String show_repo_description = "Show repository summary information" -\end{code} - -\begin{code} show_repo :: DarcsCommand show_repo = DarcsCommand { command_name = "repo", command_help = show_repo_help, @@ -133,10 +128,7 @@ type PutInfo = String -> String -> IO () putInfo :: ShowInfo -> PutInfo putInfo m t i = unless (null i) (putStr $ m t i) -\end{code} - -\begin{code} -- Primary show-repo operation. Determines ordering of output for -- sub-displays. The `out' argument is one of the above operations to -- output a labelled text string or an XML tag and contained value. @@ -181,10 +173,7 @@ showRepoMOTD :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO () showRepoMOTD out (Repo loc _ _ _) = get_motd loc >>= out "MOTD" . BC.unpack -\end{code} - -\begin{code} -- Support routines to provide information used by the PutInfo operations above. numPatches :: RepoPatch p => Repository p C(r u r) -> IO Int diff --git a/src/Darcs/Commands/ShowTags.lhs b/src/Darcs/Commands/ShowTags.lhs --- a/src/Darcs/Commands/ShowTags.lhs +++ b/src/Darcs/Commands/ShowTags.lhs @@ -39,16 +39,12 @@ \begin{code} show_tags_description :: String show_tags_description = "Show all tags in the repository." -\end{code} -\begin{code} show_tags_help :: String show_tags_help = "The tags command writes a list of all tags in the repository to standard\n"++ "output." -\end{code} -\begin{code} show_tags :: DarcsCommand show_tags = DarcsCommand { command_name = "tags", diff --git a/src/Darcs/Commands/Tag.lhs b/src/Darcs/Commands/Tag.lhs --- a/src/Darcs/Commands/Tag.lhs +++ b/src/Darcs/Commands/Tag.lhs @@ -42,29 +42,41 @@ import Darcs.Lock ( world_readable_temp ) import Darcs.Flags ( DarcsFlag(..) ) import System.IO ( hPutStr, stderr ) -\end{code} -\begin{code} -tag_description :: String -tag_description = - "Tag the contents of the repository with a version name." -\end{code} +\end{code} +\haskell{tag_description} \options{tag} +\haskell{tag_help} +\begin{code} -\haskell{tag_help} Tag differs from record in that it doesn't record any -new changes, and it always depends on all patches residing in the -repository when it is tagged. This means that one can later reproduce this -version of the repository by calling, for example: -\begin{verbatim} -% darcs get --tag "darcs 3.14" REPOLOCATION -\end{verbatim} +tag_description :: String +tag_description = "Name the current repository state for future reference." -\begin{code} tag_help :: String tag_help = - "Tag is used to name a version of this repository (i.e. the whole tree).\n" -\end{code} -\begin{code} + "The `darcs tag' command names the current repository state, so that it\n" ++ + "can easily be referred to later. Every `important' state should be\n" ++ + "tagged; in particular it is good practice to tag each stable release\n" ++ + "with a number or codename. Advice on release numbering can be found\n" ++ + "at http://producingoss.com/en/development-cycle.html.\n" ++ + "\n" ++ + "To reproduce the state of a repository `R' as at tag `t', use the\n" ++ + "command `darcs get --tag t R'. The command `darcs show tags' lists\n" ++ + "all tags in the current repository.\n" ++ + "\n" ++ + "Tagging also provides significant performance benefits: when Darcs\n" ++ + "reaches a shared tag that depends on all antecedent patches, it can\n" ++ + "simply stop processing.\n" ++ + "\n" ++ + "Like normal patches, a tag has a name, an author, a timestamp and an\n" ++ + "optional long description, but it does not change the working tree.\n" ++ + "A tag can have any name, but it is generally best to pick a naming\n" ++ + "scheme and stick to it.\n" ++ + "\n" ++ + "The `darcs tag' command accepts the --pipe and --checkpoint options,\n" ++ + "which behave as described in `darcs record' and `darcs optimize'\n" ++ + "respectively.\n" + tag :: DarcsCommand tag = DarcsCommand {command_name = "tag", command_help = tag_help, @@ -81,8 +93,7 @@ pipe_interactive, ask_long_comment, working_repo_dir]} -\end{code} -\begin{code} + tag_cmd :: [DarcsFlag] -> [String] -> IO () tag_cmd opts args = withRepoLock opts $- \repository -> do date <- get_date opts @@ -109,53 +120,14 @@ has_patch_name (_:fs) = has_patch_name fs has_patch_name [] = False +-- This may be useful for developers, but users don't care about +-- internals: +-- +-- A tagged version automatically depends on all patches in the +-- repository. This allows you to later reproduce precisely that +-- version. The tag does this by depending on all patches in the +-- repository, except for those which are depended upon by other tags +-- already in the repository. In the common case of a sequential +-- series of tags, this means that the tag depends on all patches +-- since the last tag, plus that tag itself. \end{code} -Each tagged version has a version name. -The version is also flagged with the person who tagged it (taken by default -from the `DARCS\_EMAIL' or `EMAIL' environment variable). The date is also -included in the version information. - -A tagged version automatically depends on all patches in the repository. This -allows you to later reproduce precisely that version. The tag does this by -depending on all patches in the repository, except for those which are depended -upon by other tags already in the repository. In the common case of a sequential -series of tags, this means that the tag depends on all patches since the -last tag, plus that tag itself. - -\begin{options} ---checkpoint -\end{options} -The \verb!--checkpoint! option allows the tag be used later with the -\verb!--partial! flag to \verb!get! or \verb!check!. - -A partial repository only contains patches from after the checkpoint. A -partial repository works just like a normal repository, but any command that -needs to look at the contents of a missing patch will complain and abort. - -\begin{options} ---pipe -\end{options} - -If you run tag with the \verb!--pipe! option, you will be prompted for the -tag date and author. This interface is intended for scripting darcs, in -particular for writing repository conversion scripts. The prompts are -intended mostly as useful guide (since scripts won't need them), to help -you understand the format in which to provide the input. Here's an example -of what the \verb!--pipe! prompts looks like: - -\begin{verbatim} - What is the date? Mon Nov 15 13:38:01 EST 2004 - Who is the author? David Roundy - What is the version name? 3.0 - Finished tagging patch 'TAG 3.0' -\end{verbatim} - -Using \verb!tag! creates an entry in the repository history just like \verb!record!. -It will show up with \verb!darcs changes! appearing in the format: - -\begin{verbatim} - tagged My Tag Name -\end{verbatim} - -To display all tags in the repository, use the ``\verb!darcs query tags!'' -command. diff --git a/src/Darcs/Commands/TrackDown.lhs b/src/Darcs/Commands/TrackDown.lhs --- a/src/Darcs/Commands/TrackDown.lhs +++ b/src/Darcs/Commands/TrackDown.lhs @@ -54,9 +54,7 @@ "Given one argument, it treats it as a test command. Given two arguments,\n"++ "the first is an initialization command with is run only once, and the\n"++ "second is the test command.\n" -\end{code} -\begin{code} trackdown :: DarcsCommand trackdown = DarcsCommand {command_name = "trackdown", command_help = trackdown_help, @@ -70,9 +68,7 @@ command_argdefaults = nodefaults, command_advanced_options = [set_scripts_executable], command_basic_options = [working_repo_dir]} -\end{code} -\begin{code} trackdown_cmd :: [DarcsFlag] -> [String] -> IO () trackdown_cmd opts args = withRepoReadLock opts $- \repository -> do patches <- read_repo repository @@ -92,9 +88,7 @@ when (SetScriptsExecutable `elem` opts) setScriptsExecutable init track_next opts test $ map (invert . hopefully) $ unsafeUnRL $ concatRL patches -\end{code} -\begin{code} track_next :: RepoPatch p => [DarcsFlag] -> (IO ExitCode) -> [Named p] -> IO () track_next opts test (p:ps) = do test_result <- test diff --git a/src/Darcs/Commands/TransferMode.lhs b/src/Darcs/Commands/TransferMode.lhs --- a/src/Darcs/Commands/TransferMode.lhs +++ b/src/Darcs/Commands/TransferMode.lhs @@ -31,7 +31,7 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag, working_repo_dir ) import Darcs.Repository ( amInRepository ) -import Darcs.Progress ( setProgressMode ) +import Progress ( setProgressMode ) import Darcs.Global ( darcsdir ) import qualified Data.ByteString as B (hPut, readFile, length, ByteString) @@ -40,13 +40,21 @@ \options{transfer_mode} \begin{code} transfer_mode_description :: String -transfer_mode_description = "Allow access to files in repository." +transfer_mode_description = "Internal command for efficient ssh transfers." \end{code} \haskell{transfer_mode_help} \begin{code} transfer_mode_help :: String transfer_mode_help = - "Transfer-mode is used internally to grab file contents.\n" + "When pulling from or pushing to a remote repository over ssh, if both\n" ++ + "the local and remote ends have Darcs 2, the `transfer-mode' command\n" ++ + "will be invoked on the remote end. This allows Darcs to intelligently\n" ++ + "transfer information over a single ssh connection.\n" ++ + "\n" ++ + "If either end runs Darcs 1, a separate ssh connection will be created\n" ++ + "for each transfer. As well as being less efficient, this means users\n" ++ + "who do not run ssh-agent will be prompted for the ssh password tens or\n" ++ + "hundreds of times!\n" transfer_mode :: DarcsCommand transfer_mode = DarcsCommand {command_name = "transfer-mode", @@ -60,10 +68,7 @@ command_argdefaults = nodefaults, command_advanced_options = [], command_basic_options = [working_repo_dir]} -\end{code} - -\begin{code} transfer_mode_cmd :: [DarcsFlag] -> [String] -> IO () transfer_mode_cmd _ _ = do setProgressMode False putStrLn "Hello user, I am darcs transfer mode" diff --git a/src/Darcs/Commands/Unrecord.lhs b/src/Darcs/Commands/Unrecord.lhs --- a/src/Darcs/Commands/Unrecord.lhs +++ b/src/Darcs/Commands/Unrecord.lhs @@ -49,11 +49,10 @@ concatRL, reverseRL, mapRL ) import Darcs.Patch.Depends ( get_common_and_uncommon ) import Darcs.SelectChanges ( with_selected_last_changes_reversed ) -import Darcs.Progress ( debugMessage ) +import Progress ( debugMessage ) import Darcs.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped ) #include "gadts.h" -\end{code} -\begin{code} + unrecord_description :: String unrecord_description = "Remove recorded patches without changing the working copy." @@ -137,8 +136,7 @@ "Beware that you should not use this command if you are going to\n"++ "re-record the changes in any way and there is a possibility that\n"++ "another user may have already pulled the patch.\n" -\end{code} -\begin{code} + unrecord :: DarcsCommand unrecord = DarcsCommand {command_name = "unrecord", command_help = unrecord_help, @@ -154,8 +152,7 @@ deps_sel, all_interactive, working_repo_dir]} -\end{code} -\begin{code} + unrecord_cmd :: [DarcsFlag] -> [String] -> IO () unrecord_cmd opts _ = withRepoLock opts $- \repository -> do let (logMessage,_,_) = loggers opts @@ -184,15 +181,11 @@ case match_first_patchset opts ps of Sealed p1s -> case get_common_and_uncommon (ps,p1s) of (_,us :\/: _) -> FlippedSeal $ concatRL us -\end{code} -\begin{code} unpull_description :: String unpull_description = "Opposite of pull; unsafe if patch is not in remote repository." -\end{code} -\begin{code} unpull_help :: String unpull_help = "Unpull completely removes recorded patches from your local repository.\n"++ @@ -200,9 +193,7 @@ "shown in your changes list anymore.\n"++ "Beware that if the patches are not still present in another repository you\n"++ "will lose precious code by unpulling!\n" -\end{code} -\begin{code} unpull :: DarcsCommand unpull = (command_alias "unpull" obliterate) {command_help = unpull_help, @@ -221,9 +212,7 @@ obliterate_description :: String obliterate_description = "Delete selected patches from the repository. (UNSAFE!)" -\end{code} -\begin{code} obliterate_help :: String obliterate_help = "Obliterate completely removes recorded patches from your local repository.\n"++ @@ -297,9 +286,7 @@ working_repo_dir]} obliterate_cmd :: [DarcsFlag] -> [String] -> IO () obliterate_cmd = generic_obliterate_cmd "obliterate" -\end{code} -\begin{code} generic_obliterate_cmd :: String -> [DarcsFlag] -> [String] -> IO () generic_obliterate_cmd cmdname opts _ = withRepoLock opts $- \repository -> do let (logMessage,_,_) = loggers opts diff --git a/src/Darcs/Commands/Unrevert.lhs b/src/Darcs/Commands/Unrevert.lhs --- a/src/Darcs/Commands/Unrevert.lhs +++ b/src/Darcs/Commands/Unrevert.lhs @@ -49,11 +49,10 @@ import Darcs.Patch.Bundle ( scan_bundle, make_bundle ) import IsoDate ( getIsoDateTime ) import Darcs.SignalHandler ( withSignalsBlocked ) -import Darcs.Progress ( debugMessage ) +import Progress ( debugMessage ) import Darcs.Sealed ( Sealed(Sealed) ) #include "impossible.h" -\end{code} -\begin{code} + unrevert_description :: String unrevert_description = "Undo the last revert (may fail if changes after the revert)." @@ -65,14 +64,14 @@ \begin{code} unrevert_help :: String unrevert_help = - "Unrevert is used to undo the results of a revert command. It is only\n"++ - "guaranteed to work properly if you haven't made any changes since the\n"++ - "revert was performed.\n" -\end{code} -The command makes a best effort to merge the unreversion with any changes -you have since made. In fact, unrevert should even work if you've recorded -changes since reverting. -\begin{code} + "Unrevert is a rescue command in case you accidentally reverted\n" ++ + "something you wanted to keep (for example, accidentally typing `darcs\n" ++ + "rev -a' instead of `darcs rec -a').\n" ++ + "\n" ++ + "This command may fail if the repository has changed since the revert\n" ++ + "took place. Darcs will ask for confirmation before executing an\n" ++ + "interactive command that will *definitely* prevent unreversion.\n" + unrevert :: DarcsCommand unrevert = DarcsCommand {command_name = "unrevert", command_help = unrevert_help, @@ -87,8 +86,7 @@ command_basic_options = [ignoretimes, all_interactive, working_repo_dir]} -\end{code} -\begin{code} + unrevert_cmd :: [DarcsFlag] -> [String] -> IO () unrevert_cmd opts [] = withRepoLock opts $- \repository -> do us <- read_repo repository @@ -113,9 +111,7 @@ debugMessage "Finished unreverting." _ -> impossible unrevert_cmd _ _ = impossible -\end{code} -\begin{code} write_unrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> Slurpy -> FL Prim C(r x) -> IO () write_unrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository write_unrevert repository ps rec pend = do @@ -134,9 +130,7 @@ make_bundle [Unified] rec common (np :>: NilFL) where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y) fromRepoPrims _ xs = fromPrims xs -\end{code} -\begin{code} unrevert_patch_bundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p) unrevert_patch_bundle repository = do pf <- B.readFile (unrevertUrl repository) 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 @@ -62,23 +62,27 @@ \haskell{whatsnew_description} \begin{code} whatsnew_description :: String -whatsnew_description = "Display unrecorded changes in the working copy." -\end{code} -\haskell{whatsnew_help} \verb!darcs whatsnew! will return a non-zero value if -there are no changes, which can be useful if you just want to see in a -script if anything has been modified. If you want to see some context -around your changes, you can use the \verb!-u! option, to get output -similar to the unidiff format. +whatsnew_description = "List unrecorded changes in the working tree." -\begin{code} whatsnew_help :: String whatsnew_help = - "whatsnew gives you a view of what changes you've made in your working\n"++ - "copy that haven't yet been recorded. The changes are displayed in\n"++ - "darcs patch format. Note that --look-for-adds implies --summary usage.\n" -\end{code} + "The `darcs whatsnew' command lists unrecorded changes to the working\n" ++ + "tree. If you specify a set of files and directories, only unrecorded\n" ++ + "changes to those files and directories are listed.\n" ++ + "\n" ++ + "With the --summary option, the changes are condensed to one line per\n" ++ + "file, with mnemonics to indicate the nature and extent of the change.\n" ++ + "The --look-for-adds option causes candidates for `darcs add' to be\n" ++ + "included in the summary output.\n" ++ + "\n" ++ + "By default, `darcs whatsnew' uses Darcs' internal format for changes.\n" ++ + "To see some context (unchanged lines) around each change, use the\n" ++ + "--unified option. To view changes in conventional `diff' format, use\n" ++ + "the `darcs diff' comand; but note that `darcs whatsnew' is faster.\n" ++ + "\n" ++ + "This command exits unsuccessfully (returns a non-zero exit status) if\n" ++ + "there are no unrecorded changes.\n" -\begin{code} whatsnew :: DarcsCommand whatsnew = DarcsCommand {command_name = "whatsnew", command_help = whatsnew_help, @@ -93,9 +97,7 @@ command_basic_options = [summary, unified, lookforadds, working_repo_dir]} -\end{code} -\begin{code} whatsnew_cmd :: [DarcsFlag] -> [String] -> IO () whatsnew_cmd opts' args | LookForAdds `elem` opts' && NoSummary `notElem` opts' = @@ -163,7 +165,3 @@ where fp = toFilePath f file = encode_white fp \end{code} - -If you give one or more file or directory names as an argument to -\verb!whatsnew!, darcs will output only changes to those files or to files in -those directories. diff --git a/src/Darcs/Compat.hs b/src/Darcs/Compat.hs --- a/src/Darcs/Compat.hs +++ b/src/Darcs/Compat.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -cpp -fffi #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Compat (stdout_is_a_pipe, mk_stdout_temp, canonFilename, diff --git a/src/Darcs/Diff.hs b/src/Darcs/Diff.hs --- a/src/Darcs/Diff.hs +++ b/src/Darcs/Diff.hs @@ -87,8 +87,8 @@ #endif -- | The unsafeDiffAtPaths function calls diff_at_path for a set of files and --- returns all changes to those files. It does *not* explore the given paths --- recursively. +-- and directories, and returns all changes to those files. It recurses into +-- given directories when searching for changes. -- -- Comparing paths and not slurpies is useful when the user -- requests a diff for a file that is created or removed in the working copy: diff --git a/src/Darcs/External.hs b/src/Darcs/External.hs --- a/src/Darcs/External.hs +++ b/src/Darcs/External.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -cpp -fffi #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.External ( @@ -53,7 +52,7 @@ Verify, VerifySSL ) ) import Darcs.RepoPath ( AbsolutePath, toFilePath ) import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, ) -import Darcs.Progress ( withoutProgress, progressList, debugMessage ) +import Progress ( withoutProgress, progressList, debugMessage ) import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS) import qualified Data.ByteString as B (ByteString, empty, null, readFile -- ratify readFile: Just an import from ByteString diff --git a/src/Darcs/Flags.hs b/src/Darcs/Flags.hs --- a/src/Darcs/Flags.hs +++ b/src/Darcs/Flags.hs @@ -54,7 +54,8 @@ | Boring | AllowCaseOnly | AllowWindowsReserved | DontGrabDeps | DontPromptForDependencies | PromptForDependencies | Compress | NoCompress | UnCompress - | WorkDir String | RepoDir String | RemoteRepo String + | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String + | NewRepo String | Reply String | ApplyAs String | MachineReadable | HumanReadable | Pipe | Interactive diff --git a/src/Darcs/Lock.hs b/src/Darcs/Lock.hs --- a/src/Darcs/Lock.hs +++ b/src/Darcs/Lock.hs @@ -15,7 +15,6 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -cpp -fffi #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Lock ( withLock, withLockCanFail, diff --git a/src/Darcs/Match.lhs b/src/Darcs/Match.lhs --- a/src/Darcs/Match.lhs +++ b/src/Darcs/Match.lhs @@ -197,9 +197,7 @@ get_match_pattern (OnePattern m:_) = Just m get_match_pattern (SeveralPattern m:_) = Just m get_match_pattern (_:fs) = get_match_pattern fs -\end{code} -\begin{code} tagmatch :: String -> Matcher p tagmatch r = make_matcher ("tag-name "++r) tm where tm (Sealed2 p) = @@ -279,9 +277,7 @@ second_matcher_is_tag [] = False second_matcher_is_tag (UpToTag _:_) = True second_matcher_is_tag (_:fs) = second_matcher_is_tag fs -\end{code} -\begin{code} -- | @match_a_patchread fs p@ tells whether @p@ matches the matchers in -- the flags listed in @fs@. match_a_patchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool @@ -403,9 +399,7 @@ get_matching_tag m xxx@((p:<:ps):<:xs) | apply_matcher m p = get_patches_in_tag (info p) xxx | otherwise = get_matching_tag m (ps:<:xs) -\end{code} -\begin{code} -- | @match_exists m ps@ tells whether there is a patch matching -- @m@ in @ps@ match_exists :: Matcher p -> PatchSet p C(x) -> Bool @@ -413,9 +407,7 @@ match_exists m (NilRL:<:xs) = match_exists m xs match_exists m ((p:<:ps):<:xs) | apply_matcher m $ p = True | otherwise = match_exists m (ps:<:xs) -\end{code} -\begin{code} apply_inv_to_matcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m () apply_inv_to_matcher _ _ NilRL = impossible apply_inv_to_matcher ioe m (NilRL:<:xs) = apply_inv_to_matcher ioe m xs @@ -480,9 +472,6 @@ safetake _ NilRL = error "There aren't that many patches..." safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as -\end{code} - -\begin{code} -- | A @MatchMonad p m@ is a monad in which we match patches from @p@ -- by playing with them in @m@, a 'WriteableDirectory' monad. How we -- play with the patches depends on the instance of @MatchMonad@ we're diff --git a/src/Darcs/Patch/Apply.lhs b/src/Darcs/Patch/Apply.lhs --- a/src/Darcs/Patch/Apply.lhs +++ b/src/Darcs/Patch/Apply.lhs @@ -116,9 +116,7 @@ apply_to_slurpy p s = case withSlurpy s (apply [] p) of Left err -> fail err Right (s', ()) -> return s' -\end{code} -\begin{code} instance Apply p => Apply (Named p) where apply opts (NamedP _ _ p) = apply opts p applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p @@ -130,16 +128,12 @@ applyAndTryToFixFL x = do apply [] x; return Nothing applyAndTryToFix (ComP xs) = mapMaybeSnd ComP `fmap` applyAndTryToFix xs applyAndTryToFix x = do mapMaybeSnd ComP `fmap` applyAndTryToFixFL x -\end{code} -\begin{code} force_replace_slurpy :: Prim C(x y) -> Slurpy -> Maybe Slurpy force_replace_slurpy (FP f (TokReplace tcs old new)) s = slurp_modfile f (forceTokReplace tcs old new) s force_replace_slurpy _ _ = bug "Can only force_replace_slurpy on a replace." -\end{code} -\begin{code} instance Apply Prim where apply opts (Split ps) = applyFL opts ps apply _ Identity = return () diff --git a/src/Darcs/Patch/Bundle.hs b/src/Darcs/Patch/Bundle.hs --- a/src/Darcs/Patch/Bundle.hs +++ b/src/Darcs/Patch/Bundle.hs @@ -29,9 +29,8 @@ patchInfoAndPatch, unavailable, hopefully ) import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatch ) -import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly ) +import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly, is_tag ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) -import Darcs.Patch.Depends ( is_tag ) import Darcs.Ordered ( RL(..), FL(..), unsafeCoerceP, reverseFL, (+<+), mapFL, mapFL_FL ) import Printer ( Doc, renderPS, newline, text, ($$), 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 @@ -302,9 +302,7 @@ is_filepatch_merger (Regrem und unw p1 p2) = is_filepatch_merger (Merger und unw p1 p2) is_filepatch_merger (ComP _) = Nothing -\end{code} -\begin{code} #ifndef GADT_WITNESSES commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch) commute_recursive_merger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ @@ -350,9 +348,7 @@ assert False = Nothing assert True = Just () #endif -\end{code} -\begin{code} type CommuteFunction = FORALL(x y) (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) type MaybeCommute = FORALL(x y) (Patch :< Patch) C(x y) -> Maybe ((Patch :< Patch) C(x y)) \end{code} @@ -787,9 +783,7 @@ eol_c = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old then "\r" else "" -\end{code} -\begin{code} instance Effect Patch where effect p@(Merger _ _ _ _) = sort_coalesceFL $ effect $ merger_undo p effect p@(Regrem _ _ _ _) = invert $ effect $ invert p @@ -821,9 +815,7 @@ fromPrims (p :>: NilFL) = PP p fromPrims ps = join_patchesFL $ mapFL_FL PP ps joinPatches = join_patchesFL -\end{code} -\begin{code} #ifndef GADT_WITNESSES new_ur :: Patch -> RL Patch -> [RL Patch] new_ur p (Merger _ _ p1 p2 :<: ps) = @@ -844,9 +836,6 @@ headRL (x:<:_) = x headRL _ = bug "bad headRL" #endif -\end{code} - -\begin{code} instance Invert p => Invert (Named p) where invert (NamedP n d p) = NamedP (invert_name n) (map invert_name d) (invert p) diff --git a/src/Darcs/Patch/Core.lhs b/src/Darcs/Patch/Core.lhs --- a/src/Darcs/Patch/Core.lhs +++ b/src/Darcs/Patch/Core.lhs @@ -99,9 +99,6 @@ flattenFL (PP Identity) = NilFL flattenFL p = p :>: NilFL -\end{code} - -\begin{code} join_patchesFL :: FL Patch C(x y) -> Patch C(x y) join_patchesFL ps = ComP $! ps @@ -130,9 +127,7 @@ patchcontents :: Named p C(x y) -> p C(x y) patchcontents (NamedP _ _ p) = p -\end{code} -\begin{code} n_fn :: FilePath -> FilePath n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f) \end{code} diff --git a/src/Darcs/Patch/Depends.hs b/src/Darcs/Patch/Depends.hs --- a/src/Darcs/Patch/Depends.hs +++ b/src/Darcs/Patch/Depends.hs @@ -26,7 +26,6 @@ optimize_patchset, deep_optimize_patchset, slightly_optimize_patchset, get_patches_beyond_tag, get_patches_in_tag, - is_tag, patchset_union, patchset_intersection, commute_to_end, ) where @@ -44,12 +43,12 @@ lengthRL, concatRL, reverseRL, mapRL, unsafeCoerceP, EqCheck(..) ) import Darcs.Patch.Permutations ( partitionRL ) -import Darcs.Patch.Info ( PatchInfo, just_name, human_friendly ) +import Darcs.Patch.Info ( PatchInfo, human_friendly, is_tag ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) import Darcs.Patch.Patchy ( sloppyIdentity ) import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia, hopefully, conscientiously, hopefullyM ) -import Darcs.Progress ( progressRL ) +import Darcs.ProgressPatches ( progressRL ) import Darcs.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..) , flipSeal, seal, unseal ) import Printer ( errorDoc, renderString, ($$), text ) @@ -375,9 +374,6 @@ get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag" $$ human_friendly t -is_tag :: PatchInfo -> Bool -is_tag pinfo = take 4 (just_name pinfo) == "TAG " - get_tags_right :: RL (RL (PatchInfoAnd p)) C(x y) -> [PatchInfo] get_tags_right NilRL = [] get_tags_right (ps:<:_) = get_tags_r (mapRL info_and_deps ps) @@ -471,19 +467,27 @@ case partitionRL (\e -> info e `notElem` morecommon) a of commonps :> _ -> seal $ commonps :<: common -patchset_union :: RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p +patchset_union :: forall p. RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p patchset_union [] = seal (NilRL :<: NilRL) patchset_union [x] = x patchset_union (Sealed y:ys) = case patchset_union ys of - Sealed ys' -> with_partial_intersection y ys' $ - \common a b -> - case gcau_simple a b of - Left e -> missingPatchError e - Right (_, (a' :<: NilRL) :\/: (b' :<: NilRL)) -> + Sealed ys' -> with_partial_intersection y ys' f + where + f :: FORALL(z x y) PatchSet p C(z) -- ^ @common@ + -> RL (PatchInfoAnd p) C(z x) -- ^ @a@ + -> RL (PatchInfoAnd p) C(z y) -- ^ @b@ + -> SealedPatchSet p + f common a b = g_s $ gcau_simple a b + where + g_s :: Either MissingPatch + ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + -> SealedPatchSet p + g_s (Left e) = missingPatchError e + g_s (Right (_, (a' :<: NilRL) :\/: (b' :<: NilRL))) = case (merge_sets (a' :\/: b')) of Sealed a'b' -> seal $ (a'b' +<+ b) :<: common - _ -> impossible + g_s _ = impossible merge_sets :: RepoPatch p => (RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y) -> Sealed (RL (PatchInfoAnd p) C(y)) merge_sets (l :\/: r) = diff --git a/src/Darcs/Patch/Info.hs b/src/Darcs/Patch/Info.hs --- a/src/Darcs/Patch/Info.hs +++ b/src/Darcs/Patch/Info.hs @@ -21,7 +21,7 @@ just_name, just_author, repopatchinfo, RepoPatchInfo, human_friendly, to_xml, pi_date, set_pi_date, pi_name, pi_rename, pi_author, pi_tag, pi_log, - showPatchInfo, + showPatchInfo, is_tag ) where import Text.Html hiding (name, text) import System.Random ( randomRIO ) @@ -116,6 +116,10 @@ pi_author :: PatchInfo -> String pi_author = BC.unpack . _pi_author + +is_tag :: PatchInfo -> Bool +is_tag pinfo = take 4 (just_name pinfo) == "TAG " + -- | Note: we ignore timezone information in the date string, -- systematically treating a time as UTC. So if the patch 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 @@ -288,9 +288,7 @@ <|> noneOf ['"']) <|> between spaces spaces (many $ noneOf " ()") "string" -\end{code} -\begin{code} mymatch, exactmatch, authormatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ just_name (info hp) diff --git a/src/Darcs/Patch/Non.hs b/src/Darcs/Patch/Non.hs --- a/src/Darcs/Patch/Non.hs +++ b/src/Darcs/Patch/Non.hs @@ -21,7 +21,8 @@ #include "gadts.h" --- |"NonPatch" patches. +-- |'NonPatch' and 'Non' patches are patches that store a context as a +-- sequence of patches. See "Darcs.Patch.Real" for example usage. module Darcs.Patch.Non ( NonPatch, Non(..), Nonable(..), unNon, showNon, readNon, showNons, readNons, @@ -75,6 +76,7 @@ IsEq <- x =\/= y = True | otherwise = False +-- | 'Non' stores a context with a 'Prim' patch. data Non p C(x) where Non :: FL p C(a x) -> Prim C(x y) -> Non p C(a) diff --git a/src/Darcs/Patch/Prim.lhs b/src/Darcs/Patch/Prim.lhs --- a/src/Darcs/Patch/Prim.lhs +++ b/src/Darcs/Patch/Prim.lhs @@ -148,9 +148,7 @@ is_setpref :: Prim C(x y) -> Bool is_setpref (ChangePref _ _ _) = True is_setpref _ = False -\end{code} -\begin{code} addfile :: FilePath -> Prim C(x y) rmfile :: FilePath -> Prim C(x y) adddir :: FilePath -> Prim C(x y) @@ -174,9 +172,7 @@ tokreplace f tokchars old new = evalargs FP (fp2fn $ n_fn f) (TokReplace tokchars old new) binary f old new = FP (fp2fn $! n_fn f) $ Binary old new -\end{code} -\begin{code} n_fn :: FilePath -> FilePath n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f) \end{code} @@ -238,9 +234,6 @@ sloppyIdentity Identity = IsEq sloppyIdentity _ = NotEq -\end{code} - -\begin{code} instance Show (Prim C(x y)) where showsPrec d (Move fn1 fn2) = showParen (d > app_prec) $ showString "Move " . showsPrec (app_prec + 1) fn1 . showString " " . @@ -467,19 +460,20 @@ \begin{code} commute_split :: CommuteFunction commute_split (Split patches :< patch) = - toPerhaps $ do (p1 :< ps) <- cs (patches :< patch) - case sort_coalesceFL ps of - p :>: NilFL -> return (p1 :< p) - ps' -> return (p1 :< Split ps') + toPerhaps $ cs (patches :< patch) >>= sc where cs :: ((FL Prim) :< Prim) C(x y) -> Maybe ((Prim :< (FL Prim)) C(x y)) cs (NilFL :< p1) = return (p1 :< NilFL) cs (p:>:ps :< p1) = do p1' :< p' <- commutex (p :< p1) p1'' :< ps' <- cs (ps :< p1') return (p1'' :< p':>:ps') + sc :: (Prim :< (FL Prim)) C(x y) -> Maybe ((Prim :< Prim) C(x y)) + sc (p1 :< ps) = scFL $ p1 :< (sort_coalesceFL ps) + where scFL :: (Prim :< (FL Prim)) C(x y) + -> Maybe ((Prim :< Prim) C(x y)) + scFL (p1' :< (p :>: NilFL)) = return (p1' :< p) + scFL (p1' :< ps') = return (p1' :< Split ps') commute_split _ = Unknown -\end{code} -\begin{code} try_to_shrink :: FL Prim C(x y) -> FL Prim C(x y) try_to_shrink = mapPrimFL try_harder_to_shrink @@ -756,9 +750,7 @@ is_filepatch :: Prim C(x y) -> Maybe FileName is_filepatch (FP f _) = Just f is_filepatch _ = Nothing -\end{code} -\begin{code} is_superdir :: FileName -> FileName -> Bool is_superdir d1 d2 = isd (fn2fp d1) (fn2fp d2) where isd s1 s2 = @@ -796,9 +788,7 @@ Move (movedirfilename f' f d) (movedirfilename f' f d')) commute_filedir _ = Unknown -\end{code} -\begin{code} type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y)) subcommutes :: [(String, CommuteFunction)] subcommutes = @@ -956,9 +946,7 @@ | otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :< FP f (TokReplace t o n)) commuteFP _ _ = Unknown -\end{code} -\begin{code} coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) C(x y) -> Maybe (Prim C(x y)) coalesceFilePrim f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) @@ -1063,9 +1051,7 @@ -> FileContents -> Maybe FileContents applyBinary o n c | c == o = Just n applyBinary _ _ _ = Nothing -\end{code} -\begin{code} try_tok_replace :: String -> String -> String -> [B.ByteString] -> Maybe [B.ByteString] try_tok_replace t o n mss = @@ -1089,15 +1075,11 @@ else if tok == n then Nothing else Just $ before : tok : rest -\end{code} -\begin{code} modernizePrim :: Prim C(x y) -> FL Prim C(x y) modernizePrim (Split ps) = concatFL $ mapFL_FL modernizePrim ps modernizePrim p = p :>: NilFL -\end{code} -\begin{code} instance MyEq Prim where unsafeCompare (Move a b) (Move c d) = a == c && b == d unsafeCompare (DP d1 p1) (DP d2 p2) @@ -1152,9 +1134,6 @@ compare_FL _ _ NilFL = GT compare_FL f (x:>:xs) (y:>:ys) = f x y `merge_orders` compare_FL f xs ys -\end{code} - -\begin{code} class FromPrim p where fromPrim :: Prim C(x y) -> p C(x y) diff --git a/src/Darcs/Patch/Properties.lhs b/src/Darcs/Patch/Properties.lhs --- a/src/Darcs/Patch/Properties.lhs +++ b/src/Darcs/Patch/Properties.lhs @@ -249,9 +249,6 @@ greenText "y" $$ showPatch y $$ greenText "z" $$ showPatch z -\end{code} - -\begin{code} merge_arguments_consistent :: Patchy p => (FORALL(x y) p C(x y) -> Maybe Doc) -> (p :\/: p) C(a b) -> Maybe Doc @@ -317,9 +314,6 @@ redText "x'_" $$ showPatch x'_ $$ redText "y_" $$ showPatch y_ -\end{code} - -\begin{code} join_inverses :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))) -> Prim C(a b) -> Maybe Doc join_inverses j p = case j (invert p :> p) of @@ -344,10 +338,7 @@ NotEq -> Just $ greenText "join_commute 5" IsEq -> Nothing _ -> Nothing -\end{code} - -\begin{code} show_read :: (Show2 p, Patchy p) => p C(a b) -> Maybe Doc show_read p = let ps = renderPS (showPatch p) in case readPatch ps of diff --git a/src/Darcs/Patch/QuickCheck.hs b/src/Darcs/Patch/QuickCheck.hs deleted file mode 100644 --- a/src/Darcs/Patch/QuickCheck.hs +++ /dev/null @@ -1,781 +0,0 @@ -{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts -fallow-undecidable-instances #-} -{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables #-} - -#include "gadts.h" -module Darcs.Patch.QuickCheck ( WithStartState, RepoModel, Tree, -#ifndef GADT_WITNESSES - merge_examples, commute_examples, triple_examples, -#endif - prop_consistent_tree_flattenings, prop_fail, - prop_is_mergeable, - flattenOne, simpleCheck, simpleConditionalCheck, thoroughCheck, - commutePairFromTree, mergePairFromTree, - commuteTripleFromTree, - commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples, - patchFromTree, - quickCheck, real_patch_loop_examples, shrink - ) where - -import Control.Arrow ( (***) ) -import Control.Monad ( liftM, replicateM, mplus, mzero ) -import qualified Data.ByteString.Char8 as BC (pack) -import qualified Data.ByteString as B (ByteString) -import Test.QuickCheck -import Test.QuickCheck.Test(isSuccess) -import Darcs.Sealed -import Darcs.Patch ( Patch ) -import Darcs.Ordered -import Darcs.Patch.Patchy (--showPatch, - Invert(..), Commute(..)) -import Darcs.Patch.Prim (Prim(..), Effect(..), FilePatchType(..), FromPrim(..), is_identity ) -import Darcs.Patch.Real ( RealPatch, prim2real ) ---import Darcs.ColorPrinter ( errorDoc ) ---import Darcs.ColorPrinter ( traceDoc ) -import Darcs.Show ---import Printer ( greenText, ($$) ) -import Darcs.Patch.FileName ( FileName, fp2fn ) - -#include "impossible.h" - - -#ifndef GADT_WITNESSES -instance Eq (a C(x y)) => Eq (Sealed2 a) where - (Sealed2 x) == (Sealed2 y) = x == y -#endif - -instance Show2 Patch where - show2 = show - -#ifndef GADT_WITNESSES -triple_examples :: (FromPrim p, Commute p, Invert p) => [p :> p :> p] -triple_examples = [commuteTripleFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "g"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j"])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "s"])) NilTree))) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "e"])) NilTree)) - ,commuteTripleFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", - rmFileContents = [BC.pack "j"] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "s"])) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree))) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree)) - ] - - -merge_examples :: (FromPrim p, Commute p, Invert p) => [p :\/: p] -merge_examples = map (mergePairFromCommutePair id) commute_examples - -commute_examples :: (FromPrim p, Commute p) => [p :> p] -commute_examples = [ - commutePairFromTWFP id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (TWFP 3 - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "b"])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) NilTree)))))), - commutePairFromTWFP id $ - WithStartState - (RepoModel { rmFileName = fp2fn "./file", - rmFileContents = [BC.pack "f",BC.pack "s",BC.pack "d"] }) - (TWFP 3 - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "d"] [])) NilTree) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] [])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "s",BC.pack "d"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)))))), -{- commutePairFromTWFP id $ - WithStartState - (RepoModel { rmFileName = fp2fn "./file", - rmFileContents = [BC.pack "f",BC.pack "u", - BC.pack "s",BC.pack "d"] }) - (TWFP 5 - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 4 [] [BC.pack "x"])) - (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "d"] [])) NilTree)) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f",BC.pack "u"] [])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] [])) - (SeqTree (FP(fp2fn "./file") (Hunk 0 [BC.pack "u",BC.pack "s",BC.pack "d"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "a"])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "a"] [])) NilTree))))))),-} - commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", - rmFileContents = [BC.pack "n",BC.pack "t",BC.pack "h"] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "n",BC.pack "t",BC.pack "h"] [])) - NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "h"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "n"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t"] [])) NilTree)))), - commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "n"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "i"])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "i"])) NilTree))), - commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "c"])) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "c"] [BC.pack "r"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "d"])) NilTree)))) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree)), - commutePairFromTWFP id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (TWFP 1 - (ParTree - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "t"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "t"])) NilTree)) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree))), - commutePairFromTWFP id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", - rmFileContents = [BC.pack "f",BC.pack " r", - BC.pack "c",BC.pack "v"] }) - (TWFP 4 - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "c",BC.pack "v"] [])) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "r"] [])) - (SeqTree (FP (fp2fn "fi le") (Hunk 0 [BC.pack "f"] [])) NilTree)) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f",BC.pack "r"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "y"])) NilTree)))) - (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "v"] [])) NilTree))), - commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "z"])) NilTree) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "r"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "d"])) NilTree)))) - , commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", - rmFileContents = [BC.pack "t",BC.pack "r", - BC.pack "h"] }) - (ParTree - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t",BC.pack "r",BC.pack "h"] [])) - NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "o"])) NilTree)) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "h"] [])) NilTree))) - , commutePairFromTWFP id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) $ - TWFP 2 - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "y"])) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "m"])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)))) - , commutePairFromTree id $ - WithStartState (RepoModel {rmFileName = fp2fn "./file",rmFileContents = [] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "p"])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "p"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "c"])) NilTree))) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "z"])) NilTree)) - , commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j" ])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree)) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)) - , commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j" ])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree))) - , commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", - rmFileContents = [BC.pack "x",BC.pack "c"] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "c"] [])) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "x"] [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j"])) NilTree)))) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "l"])) NilTree)) - , commutePairFromTree id $ - WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) - (ParTree - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "s"))) NilTree) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "k"))) - (SeqTree (FP (fp2fn "./file") (Hunk 0 (packStringLetters "k") [])) - (SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "m"))) - (SeqTree (FP (fp2fn "./file") (Hunk 0 (packStringLetters "m") [])) NilTree))))) - ] -#endif - -simpleConditionalCheck :: (Arbitrary p, Show p, Show q) => (p -> Bool) -> (p -> Maybe q) -> IO Int -simpleConditionalCheck nottrivial t = do - okay <- quickCheckWithResult args t' - return $ if isSuccess okay then 0 else 1 - where t' p = nottrivial p ==> case t p of - Nothing -> True - Just q -> error $ show q - args = Args {replay = Nothing, - maxSuccess = 100, - maxDiscard = 5000, - maxSize = 100 - } - -simpleCheck :: (Arbitrary p, Show p, Show q) => (p -> Maybe q) -> IO Int -simpleCheck t = do okay <- quickCheckResult t' - return $ if isSuccess okay then 0 else 1 - where t' p = case t p of - Nothing -> True - Just q -> error $ show q - -thoroughCheck :: (Arbitrary p, Show p, Show q) => Int -> (p -> Maybe q) -> IO Int -thoroughCheck num t = do let args = Args {replay = Nothing, - maxSuccess = num, - maxDiscard = 20*num, - maxSize = max 100 (num `div` 10) - } - okay <- quickCheckWithResult args t' - return $ if isSuccess okay then 0 else 1 - where t' p = case t p of - Nothing -> True - Just q -> error $ show q - -data RepoModel C(x) - = RepoModel { - rmFileName :: !FileName, - rmFileContents :: [B.ByteString] - } deriving (Eq) - -instance Show (RepoModel C(x)) where - showsPrec d rm = showParen (d > app_prec) $ - showString "RepoModel { rmFileName = " . showsPrec 0 (rmFileName rm) . - showString ", rmFileContents = " . showsPrec 0 (rmFileContents rm) . - showString " }" - -instance Show1 RepoModel where - showsPrec1 = showsPrec - -#ifdef GADT_WITNESSES -data InitRepoModel -- this ought to be defined somewhere central as the unique starting state -#endif - -initRepoModel :: RepoModel C(InitRepoModel) -initRepoModel = RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] } -rebuildRepoModel :: RepoModel C(x) -> RepoModel C(y) -rebuildRepoModel rm = RepoModel { rmFileName = rmFileName rm, rmFileContents = rmFileContents rm } - -data WithEndState px s C(y) = WithEndState { wesPatch :: px C(y), _wesState :: s C(y) } - -class ArbitraryState s p where - arbitraryState :: s C(x) -> Gen (Sealed (WithEndState (p C(x)) s)) - -- does a coarbitrary make sense? - -class ArbitraryStateIn s p where - arbitraryStateIn :: s C(x) -> Gen (p C(x)) - -instance ArbitraryState RepoModel Prim where - arbitraryState rm = oneof [arbitraryFP rm] - -instance Arbitrary (Sealed2 (FL Prim)) where - arbitrary = do Sealed2 ps1 <- liftM (unseal (seal2 . wesPatch)) $ arbitraryState initRepoModel - return $ Sealed2 $ mapFL_FL make_identity_identity ps1 - where make_identity_identity :: Prim C(x y) -> Prim C(x y) - make_identity_identity p | IsEq <- is_identity p = identity - | otherwise = p - -instance Arbitrary (Sealed2 (FL (WithState RepoModel Prim))) where - arbitrary = liftM (unseal (seal2 . wesPatch)) $ arbitraryState initRepoModel - -prop_consistent_tree_flattenings :: Sealed (WithStartState RepoModel (Tree Prim)) -> Bool -prop_consistent_tree_flattenings (Sealed (WithStartState start t)) - = fromJust $ - do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2real t - rms <- return $ map (applyPatch start) flat - return $ and $ zipWith assert_equal_fst (zip rms flat) (tail $ zip rms flat) - -assert_equal_fst :: (Eq a, Show a, Show b, Show c) => (a, b) -> (a, c) -> Bool -assert_equal_fst (x,bx) (y,by) - | x == y = True - | otherwise = error ("Not really equal:\n" ++ show x ++ "\nand\n" ++ show y - ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by) - --- WithState and prop_fail are handy for debugging arbitrary code -data WithState s p C(x y) = WithState (s C(x)) (p C(x y)) (s C(y)) - deriving Show - -data WithStartState s p C(x) = WithStartState (s C(x)) (p C(x)) - -instance (Show1 s, Show1 p) => Show (WithStartState s p C(x)) where - showsPrec d (WithStartState s p) = showParen (d > app_prec) $ showString "WithStartState " . - showsPrec1 (app_prec + 1) s . showString " " . - showsPrec1 (app_prec + 1) p - -instance (Show1 s, Show1 p) => Show1 (WithStartState s p) where - showsPrec1 = showsPrec - -prop_fail :: Int -> Tree Prim C(x) -> Bool -prop_fail n xs = sizeTree xs < n - -instance ArbitraryState s p => ArbitraryState s (WithState s p) where - arbitraryState rm = do xandrm' <- arbitraryState rm - flip unseal xandrm' $ \(WithEndState x rm') -> - return $ seal $ WithEndState (WithState rm x rm') rm' - -instance ArbitraryState s p => ArbitraryState s (FL p) where - arbitraryState rm1 = sized $ \n -> do k <- choose (0, n) - arbitraryList k rm1 - where arbitraryList :: FORALL(x) Int -> s C(x) -> Gen (Sealed (WithEndState (FL p C(x)) s)) - arbitraryList 0 rm = return $ seal $ WithEndState NilFL rm - arbitraryList (n+1) rm = do Sealed (WithEndState x rm') <- arbitraryState rm - Sealed (WithEndState xs rm'') <- arbitraryList n rm' - return $ seal $ WithEndState (x :>: xs) rm'' - arbitraryList _ _ = impossible - -data Tree p C(x) where - NilTree :: Tree p C(x) - SeqTree :: p C(x y) -> Tree p C(y) -> Tree p C(x) - ParTree :: Tree p C(x) -> Tree p C(x) -> Tree p C(x) - -mapTree :: (FORALL(y z) p C(y z) -> q C(y z)) -> Tree p C(x) -> Tree q C(x) -mapTree _ NilTree = NilTree -mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t) -mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2) - -instance Show2 p => Show (Tree p C(x)) where - showsPrec _ NilTree = showString "NilTree" - showsPrec d (SeqTree a t) = showParen (d > app_prec) $ showString "SeqTree " . - showsPrec2 (app_prec + 1) a . showString " " . - showsPrec (app_prec + 1) t - showsPrec d (ParTree t1 t2) = showParen (d > app_prec) $ showString "ParTree " . - showsPrec (app_prec + 1) t1 . showString " " . - showsPrec (app_prec + 1) t2 - -instance Show2 p => Show1 (Tree p) where - showsPrec1 = showsPrec - -sizeTree :: Tree p C(x) -> Int -sizeTree NilTree = 0 -sizeTree (SeqTree _ t) = 1 + sizeTree t -sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2 - --- newtype G1 l p C(x) = G1 { _unG1 :: l (p C(x)) } -newtype G2 l p C(x y) = G2 { unG2 :: l (p C(x y)) } - -flattenTree :: (Commute p) => Tree p C(z) -> Sealed (G2 [] (FL p) C(z)) -flattenTree NilTree = seal $ G2 $ return NilFL -flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t -flattenTree (ParTree t1 t2) = flip unseal (flattenTree t1) $ \gpss1 -> - flip unseal (flattenTree t2) $ \gpss2 -> - seal $ G2 $ - do ps1 <- unG2 gpss1 - ps2 <- unG2 gpss2 - ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2) - -- We can't prove that the existential type in the result - -- of merge will be the same for each pair of - -- ps1 and ps2. - map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1'] - -instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where - arbitraryStateIn rm = frequency [(2, return NilTree) - ,(2, do Sealed (WithEndState p rm') <- arbitraryState rm - t <- arbitraryStateIn rm' - return (SeqTree p t)) - ,(1, do t1 <- arbitraryStateIn rm - t2 <- arbitraryStateIn rm - return (ParTree t1 t2))] - - -shrinkWSSTree :: Sealed (WithStartState RepoModel (Tree Prim)) - -> [Sealed (WithStartState RepoModel (Tree Prim))] -shrinkWSSTree = unseal doShrinkWSSTree - where - doShrinkWSSTree wss@(WithStartState rm t) - = shrinkWSSTree' wss -- shrink the tree - `mplus` - do -- shrink the starting context - pos <- [0 .. length (rmFileContents rm) - 1] - let rmFileContents' = take pos (rmFileContents rm) ++ drop (pos+1) (rmFileContents rm) - t' = shrinkPosStart pos (canonizeTree t) - return $ seal $ WithStartState (rm { rmFileContents = rmFileContents' }) (canonizeTree t') - - --- If we had a more general repo model, then Int would need to be more general too - -class ShrinkablePos p where - shrinkPos :: Int -> p C(x y) -> (p C(x y), Maybe Int) - shrinkPatch :: p C(x y) -> [(p C(x y), Maybe Int)] - nullPatch :: p C(x y) -> EqCheck C(x y) - -class ShrinkablePosStart p where - shrinkPosStart :: Int -> p C(x) -> p C(x) - -instance ShrinkablePos p => ShrinkablePosStart (Tree p) where - shrinkPosStart _ NilTree = NilTree - shrinkPosStart pos (SeqTree p t) - = let (p', mpos') = shrinkPos pos p - in case mpos' of - Nothing -> SeqTree p' t - Just pos' -> SeqTree p' (shrinkPosStart pos' t) - shrinkPosStart pos (ParTree t1 t2) = ParTree (shrinkPosStart pos t1) (shrinkPosStart pos t2) - -smartFP :: FileName -> FilePatchType C(x y) -> Prim C(x y) -smartFP _ (Hunk _ [] []) | avoidEmptyHunks = unsafeCoerceP Identity -smartFP fn filepatch = FP fn filepatch - -instance ShrinkablePos Prim where - shrinkPos pos (FP fn fp) = (smartFP fn *** id) (shrinkPos pos fp) - shrinkPos pos Identity = (Identity, Just pos) - shrinkPos _ _ = impossible - shrinkPatch (FP fn fp) = map (smartFP fn *** id) (shrinkPatch fp) - shrinkPatch Identity = [] - shrinkPatch _ = impossible - nullPatch (FP _ fp) = nullPatch fp - nullPatch Identity = IsEq - nullPatch _ = impossible - -avoidEmptyHunks :: Bool -avoidEmptyHunks = True - -instance ShrinkablePos FilePatchType where - shrinkPos pos (Hunk n old new) - | pos < n = (Hunk (n-1) old new, Just pos) - | pos >= n + length old = (Hunk n old new, Just (pos + length new - length old)) - | otherwise = (Hunk n (take pos' old ++ drop (pos'+1) old) new, Nothing) - where pos' = pos - n - shrinkPos _ _ = bug "foo1 in ShrinkablePos" - shrinkPatch (Hunk (n+1) [] []) = [(Hunk n [] [], Nothing)] - shrinkPatch (Hunk n old new) - = do i <- [0 .. length new - 1] - return (Hunk n old (take i new ++ drop (i+1) new), Just (n + i)) - shrinkPatch _ = bug "foo in ShrinkablePos" - nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe? - nullPatch _ = NotEq - -shrinkWSSTree' - -- start a new line here because apparently ' confuses CPP.. - :: WithStartState RepoModel (Tree Prim) C(x) - -> [Sealed (WithStartState RepoModel (Tree Prim))] -shrinkWSSTree' (WithStartState _ NilTree) = [] -shrinkWSSTree' (WithStartState rm t@(SeqTree p t')) - = return (seal (WithStartState (applyPatch rm p) (canonizeTree t'))) - `mplus` - liftM (seal . WithStartState rm) (map canonizeTree $ shrinkTree t) -shrinkWSSTree' (WithStartState rm t@(ParTree _ _)) - = liftM (seal . WithStartState rm) (map canonizeTree $ shrinkTree t) - --- canonize a tree, removing any dead branches -canonizeTree :: ShrinkablePos p => Tree p C(x) -> Tree p C(x) -canonizeTree NilTree = NilTree -canonizeTree (ParTree t1 t2) - | NilTree <- canonizeTree t1 = canonizeTree t2 - | NilTree <- canonizeTree t2 = canonizeTree t1 - | otherwise = ParTree (canonizeTree t1) (canonizeTree t2) -canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t - | otherwise = SeqTree p (canonizeTree t) - --- shrink the tree without changing the starting context -shrinkTree :: ShrinkablePos p => Tree p C(x) -> [Tree p C(x)] -shrinkTree NilTree = [] -shrinkTree (SeqTree p t) = do case nullPatch p of - IsEq -> return t - NotEq -> mzero - `mplus` - do (p', pos) <- shrinkPatch p - return (SeqTree p' (maybe id shrinkPosStart pos t)) - `mplus` - do t' <- shrinkTree t - return (SeqTree p t') -shrinkTree (ParTree t1 t2) = [t1, t2] - `mplus` - do t1' <- shrinkTree t1 - return (ParTree t1' t2) - `mplus` - do t2' <- shrinkTree t2 - return (ParTree t1 t2') - -instance Arbitrary (Sealed (WithStartState RepoModel (Tree Prim))) where - arbitrary = do Sealed (WithStartState rm tree) <- - liftM (seal . WithStartState initRepoModel) (arbitraryStateIn initRepoModel) - return $ Sealed $ WithStartState rm (canonizeTree tree) - shrink = shrinkWSSTree - -prop_is_mergeable :: forall p C(x) . (FromPrim p, Commute p) - => Sealed (WithStartState RepoModel (Tree Prim)) - -> Maybe (Tree p C(x)) -prop_is_mergeable (Sealed (WithStartState _ t)) - = case flattenOne t of - Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p) - in case lengthFL ps of - _ -> Nothing - -flattenOne :: (FromPrim p, Commute p) => Tree Prim C(x) -> Sealed (FL p C(x)) -flattenOne NilTree = seal NilFL -flattenOne (SeqTree p t) = flip unseal (flattenOne t) $ \ps -> seal (fromPrim p :>: ps) -flattenOne (ParTree t1 t2) = - flip unseal (flattenOne t1) $ \ps1 -> - flip unseal (flattenOne t2) $ \ps2 -> - --traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$ - -- greenText "ps2" $$ showPatch ps2) $ - case merge (ps1 :\/: ps2) of - ps2' :/\: _ -> seal (ps1 +>+ ps2') - -instance Arbitrary (Sealed2 (FL RealPatch)) where - arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState RepoModel (Tree Prim))) - return $ unseal seal2 (flattenOne tree) - -instance Arbitrary (Sealed2 RealPatch) where - arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState RepoModel (Tree Prim))) - case mapFL seal2 `unseal` flattenOne tree of - [] -> return $ seal2 $ fromPrim Identity - ps -> elements ps - -instance (Arbitrary (Sealed2 (FL p)), Commute p) => Arbitrary (Sealed2 (p :\/: p)) where - arbitrary = do Sealed2 (a :> b) <- arbitrary - case commute (a :> b) of - Just (b' :> _) -> return (seal2 (a :\/: b')) - Nothing -> arbitrary - -instance Arbitrary (Sealed2 (FL p)) => Arbitrary (Sealed2 (p :> p)) where - arbitrary = do Sealed2 ps <- arbitrary - let pairs = getPairs ps - case pairs of - [] -> arbitrary - _ -> elements pairs - -instance (Invert p, Arbitrary (Sealed2 (FL p))) => Arbitrary (Sealed2 (p :> p :> p)) where - arbitrary = do Sealed2 ps <- arbitrary - return $ last_triple ps - where last_triple :: FL p C(x y) -> Sealed2 (p :> p :> p) - last_triple NilFL = seal2 $ identity :> identity :> identity - last_triple (a :>: NilFL) = seal2 $ a :> invert a :> identity - last_triple (a :>: b :>: NilFL) = seal2 $ invert a :> a :> b - last_triple (a :>: b :>: c :>: NilFL) = seal2 $ a :> b :> c - last_triple (_ :>: xs) = last_triple xs - -data TreeWithFlattenPos p C(x) = TWFP Int (Tree p C(x)) - -commutePairFromTWFP :: (FromPrim p, Commute p) - => (FORALL (y z) (p :> p) C(y z) -> t) - -> (WithStartState RepoModel (TreeWithFlattenPos Prim) C(x) -> t) -commutePairFromTWFP handlePair (WithStartState _ (TWFP n t)) - = unseal2 handlePair $ - let xs = unseal getPairs (flattenOne t) - in if length xs > n && n >= 0 then xs!!n else seal2 (fromPrim Identity :> fromPrim Identity) - -commutePairFromTree :: (FromPrim p, Commute p) - => (FORALL (y z) (p :> p) C(y z) -> t) - -> (WithStartState RepoModel (Tree Prim) C(x) -> t) -commutePairFromTree handlePair (WithStartState _ t) - = unseal2 handlePair $ - let Sealed ps = flattenOne t - xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $ - getPairs ps - in if null xs then seal2 (fromPrim Identity :> fromPrim Identity) else last xs - -commuteTripleFromTree :: (FromPrim p, Commute p) - => (FORALL (y z) (p :> p :> p) C(y z) -> t) - -> (WithStartState RepoModel (Tree Prim) C(x) -> t) -commuteTripleFromTree handle (WithStartState _ t) - = unseal2 handle $ - let Sealed ps = flattenOne t - xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $ - getTriples ps - in if null xs - then seal2 (fromPrim Identity :> fromPrim Identity :> fromPrim Identity) - else last xs - -mergePairFromCommutePair :: (Commute p, Invert p) - => (FORALL (y z) (p :\/: p) C(y z) -> t) - -> (FORALL (y z) (p :> p) C(y z) -> t) -mergePairFromCommutePair handlePair (a :> b) - = case commute (a :> b) of - Just (b' :> _) -> handlePair (a :\/: b') - Nothing -> handlePair (b :\/: b) - --- impredicativity problems mean we can't use (.) in the definitions below - -mergePairFromTWFP :: (FromPrim p, Commute p, Invert p) - => (FORALL (y z) (p :\/: p) C(y z) -> t) - -> (WithStartState RepoModel (TreeWithFlattenPos Prim) C(x) -> t) -mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x) - -mergePairFromTree :: (FromPrim p, Commute p, Invert p) - => (FORALL (y z) (p :\/: p) C(y z) -> t) - -> (WithStartState RepoModel (Tree Prim) C(x) -> t) -mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x) - -patchFromCommutePair :: (Commute p, Invert p) - => (FORALL (y z) p C(y z) -> t) - -> (FORALL (y z) (p :> p) C(y z) -> t) -patchFromCommutePair handle (_ :> b) = handle b - -patchFromTree :: (FromPrim p, Commute p, Invert p) - => (FORALL (y z) p C(y z) -> t) - -> (WithStartState RepoModel (Tree Prim) C(x) -> t) -patchFromTree x = commutePairFromTree (patchFromCommutePair x) - - -instance Show2 p => Show (TreeWithFlattenPos p C(x)) where - showsPrec d (TWFP n t) = showParen (d > app_prec) $ showString "TWFP " . - showsPrec (app_prec + 1) n . showString " " . - showsPrec1 (app_prec + 1) t - -instance Show1 (TreeWithFlattenPos Prim) where - show1 = show - -instance Arbitrary (Sealed (WithStartState RepoModel (TreeWithFlattenPos Prim))) where - arbitrary = do Sealed (WithStartState rm t) <- arbitrary - let num = unseal (length . getPairs) (flattenOneRP t) - if num == 0 then return $ Sealed $ WithStartState rm $ TWFP 0 NilTree - else do n <- choose (0, num - 1) - return $ Sealed $ WithStartState rm $ TWFP n t - where -- just used to get the length. In principle this should be independent of the patch type. - flattenOneRP :: Tree Prim C(x) -> Sealed (FL RealPatch C(x)) - flattenOneRP = flattenOne - shrink (Sealed (WithStartState rm (TWFP n t))) = - [Sealed (WithStartState rm' (TWFP n' t')) | Sealed (WithStartState rm' t') <- shrink (Sealed (WithStartState rm t)), - n' <- [0..n]] - - -getPairs :: FL p C(x y) -> [Sealed2 (p :> p)] -getPairs NilFL = [] -getPairs (_:>:NilFL) = [] -getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c) - -getTriples :: FL p C(x y) -> [Sealed2 (p :> p :> p)] -getTriples NilFL = [] -getTriples (_:>:NilFL) = [] -getTriples (_:>:_:>:NilFL) = [] -getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d) - -arbitraryFP :: RepoModel C(x) -> Gen (Sealed (WithEndState (Prim C(x)) RepoModel)) -arbitraryFP rm - = do (fp, newcontents) <- arbitraryFilePatchType (rmFileContents rm) - return $ seal $ WithEndState (FP (rmFileName rm) fp) (rebuildRepoModel (rm { rmFileContents = newcontents })) - --- Really [B.ByteString] should be parametrised by x y, and the result tuple sealed on y -arbitraryFilePatchType :: [B.ByteString] -> Gen (FilePatchType C(x y), [B.ByteString]) -arbitraryFilePatchType contents = oneof [arbitraryHunk contents] - -arbitraryHunk :: [B.ByteString] -> Gen (FilePatchType C(x y), [B.ByteString]) -arbitraryHunk contents - = sized $ \n -> - do start <- choose (0, min n (length contents)) - (removelen, _) - <- frequency $ zip (if start == length contents then [1, 13, 0, 0] else [1, 3, 5, 3]) - [return (0, 0) - ,do xa <- choose (0, n) - return (0, xa) - ,do xr <- choose (1, min n (length contents - start)) - return (xr, 0) - ,do xr <- choose (1, min n (length contents - start)) - xa <- choose (0, n) - return (xr, xa) - ] - addlen <- choose (0, n) - additems <- replicateM addlen (do c <- choose ('a', 'z') - return $ BC.pack [c]) - let newcontents = take start contents ++ additems ++ drop (start + removelen) contents - return (Hunk start (take removelen $ drop start $ contents) additems, newcontents) - -class Applyable p where - applyPatch :: RepoModel C(x) -> p C(x y) -> RepoModel C(y) - -instance Applyable p => Applyable (FL p) where - applyPatch rm NilFL = rm - applyPatch rm (p :>: ps) = applyPatch (applyPatch rm p) ps - -instance Applyable RealPatch where - applyPatch rm p = applyPatch rm (effect p) - -instance Applyable Prim where - applyPatch (rm@RepoModel { rmFileName = filename, rmFileContents = oldcontents }) (FP filename' fp) - | filename == filename' = rebuildRepoModel (rm { rmFileContents = applyFilePatchType oldcontents fp }) - applyPatch rm Identity = rm - applyPatch _ _ = bug "We haven't defined applyPatch on Prim for all patch types." - -applyFilePatchType :: [B.ByteString] -> FilePatchType C(x y) -> [B.ByteString] -applyFilePatchType oldcontents (Hunk n old new) - = if take (length old) (drop n oldcontents) == old - then take n oldcontents ++ new ++ drop (n + length old) oldcontents - else error "Bad patch context" -applyFilePatchType _ _ = bug "We haven't defined applyFilePatchType for all patch types." - -packStringLetters :: String -> [B.ByteString] -packStringLetters = map (BC.pack . (:[])) - -real_patch_loop_examples :: [Sealed (WithStartState RepoModel (Tree Prim))] -real_patch_loop_examples = - [Sealed (WithStartState (RepoModel { rmFileName = fx, rmFileContents = [] }) - $ canonizeTree - (ParTree - (SeqTree (FP fx (Hunk 0 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd"))) - (ParTree - (SeqTree (FP fx (Hunk 46 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh"))) - (ParTree - (ParTree - NilTree - (ParTree - (ParTree - (ParTree - (SeqTree (FP fx (Hunk 14 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps"))) - (ParTree - NilTree - (ParTree - (SeqTree (FP fx (Hunk 39 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro"))) - (ParTree - (ParTree - (SeqTree (FP fx (Hunk 11 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg"))) NilTree) - NilTree) - NilTree)) - (SeqTree (FP fx (Hunk 24 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe"))) NilTree)))) - (SeqTree (FP fx (Hunk 55 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq"))) NilTree)) - (SeqTree (FP fx (Hunk 19 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx"))) - (SeqTree (FP fx (Hunk 25 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe"))) - (SeqTree (FP fx (Hunk 38 [] (packStringLetters "ji"))) - (ParTree - NilTree - (ParTree - NilTree - (ParTree - (ParTree - NilTree - (SeqTree (FP fx (Hunk 25 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj"))) - (SeqTree (FP fx (Hunk 38 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp"))) NilTree))) - (ParTree - NilTree - (SeqTree (FP fx (Hunk 43 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy"))) - (ParTree - NilTree - (SeqTree (FP fx (Hunk 63 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp"))) NilTree))))))))))) - (ParTree - NilTree - NilTree))) - NilTree)) - NilTree)) - (ParTree - NilTree - (SeqTree (FP fx (Hunk 0 [] (packStringLetters "ti"))) - (SeqTree (FP fx (Hunk 0 (packStringLetters "t") (packStringLetters "ybcop"))) - (SeqTree (FP fx (Hunk 1 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf"))) - (SeqTree (FP fx (Hunk 14 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc"))) - (SeqTree (FP fx (Hunk 50 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw"))) - (ParTree - NilTree - NilTree)))))))))] - -fx :: FileName -fx = fp2fn "./F" diff --git a/src/Darcs/Patch/Real.hs b/src/Darcs/Patch/Real.hs --- a/src/Darcs/Patch/Real.hs +++ b/src/Darcs/Patch/Real.hs @@ -56,23 +56,28 @@ --import Darcs.ColorPrinter ( traceDoc ) #include "impossible.h" --- Duplicate x: This patch has no effect since 'x' is already present in the repository +-- | +-- @Duplicate x@: This patch has no effect since @x@ is already present in the repository -- --- Etacilpud x: invert (Duplicate x) +-- @Etacilpud x: invert (Duplicate x)@ -- --- Normal prim: A primitive patch +-- @Normal prim@: A primitive patch -- --- Conflictor ix xx x: --- 'ix' is the set of patches: --- * that conflict with 'x' and also conflict with another patch in the repository --- * that conflict with a patch that conflict with 'x' --- 'xx' is the sequence of patches that conflict *only* with 'x' --- 'x' is the current patch +-- @Conflictor ix xx x@: +-- @ix@ is the set of patches: -- --- 'ix' and 'x' are stored as "Non" objects, which include any necessary +-- * that conflict with @x@ and also conflict with another patch in the repository +-- +-- * that conflict with a patch that conflict with @x@ +-- +-- @xx@ is the sequence of patches that conflict *only* with @x@ +-- +-- @x@ is the current patch +-- +-- @ix@ and @x@ are stored as @Non@ objects, which include any necessary -- context to uniquely define the patch that is referred to. -- --- InvConflictor ix xx x: like invert (Conflictor ix xx x) +-- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@ data RealPatch C(x y) where Duplicate :: Non RealPatch C(x) -> RealPatch C(x x) Etacilpud :: Non RealPatch C(x) -> RealPatch C(x x) @@ -136,9 +141,9 @@ assertConsistent x = assertDoc (do e <- is_consistent x Just (redText "Inconsistent patch:" $$ showPatch x $$ e)) x --- mergeAfterConflicting takes as input a sequence of conflicting --- patches xxx (which therefore have no effect) and a sequence of --- primitive patches yyy that follow said sequence of conflicting +-- | @mergeAfterConflicting@ takes as input a sequence of conflicting +-- patches @xxx@ (which therefore have no effect) and a sequence of +-- primitive patches @yyy@ that follow said sequence of conflicting -- patches, and may depend upon some of the conflicting patches (as a -- resolution). @@ -147,10 +152,10 @@ -- effect as the original primitive patch sequence in the input. -- So far as I can tell, the second output is always identical to --- mapFL Normal yyy +-- @mapFL Normal yyy@ --- The first output is the set of patches from xxx that are depended --- upon by yyy. +-- The first output is the set of patches from @xxx@ that are depended +-- upon by @yyy@. mergeAfterConflicting :: FL RealPatch C(x x) -> FL Prim C(x y) -> Maybe (FL RealPatch C(x x), FL RealPatch C(x y)) @@ -171,9 +176,10 @@ Left _ -> case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of a:>p':>b -> do (b',xs') <- mac b xs goneby + let pa = join_effects $ p':<:a --traceDoc (greenText "foo1" $$ - -- showPatch (join_effects $ p':<:a)) $ Just () - NilFL <- return $ join_effects $ p':<:a + -- showPatch pa) $ Just () + NilFL <- return pa return (reverseRL (p':<:a)+>+b', xs') `mplus` do NilFL <- return goneby NilFL <- return $ join_effects (p:<:ps) @@ -186,9 +192,10 @@ case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of a:>p':>b -> do (b',xs') <- mac b xs goneby + let pa = join_effects $ p':<:a --traceDoc (greenText "foo2" $$ - -- showPatch (join_effects $ p':<:a)) $ Just () - NilFL <- return $ join_effects $ p':<:a + -- showPatch pa) $ Just () + NilFL <- return pa return $ (reverseRL (p':<:a)+>+b', xs') geteff :: [Non RealPatch C(x)] -> FL Prim C(x y) -> ([Non RealPatch C(x)], FL RealPatch C(x y)) @@ -278,12 +285,13 @@ conflictedEffect (Normal x) = [IsC Okay x] resolve_conflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled] where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx) - nonxx = case nonxx_aux ix xx of - NilRL -> [] - Normal q:<:qs -> [Non (reverseRL qs) q] - _ -> [] + nonxx = nonxx_ (nonxx_aux ix xx) nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y) nonxx_aux a b = reverseFL $ xx2patches a b + nonxx_ :: RL RealPatch C(x y) -> [Non RealPatch C(x)] + nonxx_ NilRL = [] + nonxx_ ((Normal q) :<: qs) = [Non (reverseRL qs) q] + nonxx_ _ = [] isn :: Sealed (FL p C(x)) -> Bool isn (Sealed NilFL) = False isn _ = True diff --git a/src/Darcs/Patch/Test.hs b/src/Darcs/Patch/Test.hs deleted file mode 100644 --- a/src/Darcs/Patch/Test.hs +++ /dev/null @@ -1,681 +0,0 @@ --- Copyright (C) 2002-2003,2007 David Roundy --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2, or (at your option) --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; see the file COPYING. If not, write to --- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --- Boston, MA 02110-1301, USA. - -{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fglasgow-exts -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} - -#include "gadts.h" - -module Darcs.Patch.Test - ( prop_read_show, - prop_inverse_composition, prop_commute_twice, - prop_inverse_valid, prop_other_inverse_valid, - prop_commute_equivalency, prop_commute_either_order, - prop_commute_either_way, prop_merge_is_commutable_and_correct, - prop_merge_is_swapable, prop_merge_valid, - prop_unravel_three_merge, prop_unravel_seq_merge, - prop_unravel_order_independent, - prop_simple_smart_merge_good_enough, - prop_elegant_merge_good_enough, - prop_patch_and_inverse_is_identity, - quickmerge, check_patch, check_a_patch, verbose_check_a_patch, - prop_resolve_conflicts_valid, - test_patch, prop_commute_inverse, - subcommutes_inverse, subcommutes_nontrivial_inverse, - subcommutes_failure, - join_patches - ) where - -import Prelude hiding ( pi ) -import System.IO.Unsafe ( unsafePerformIO ) -import Test.QuickCheck -import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM ) - -import Darcs.Patch.Info ( PatchInfo, patchinfo ) -import Darcs.Patch.Check ( PatchCheck, Possibly(..), - check_move, remove_dir, create_dir, - is_valid, insert_line, file_empty, file_exists, - delete_line, modify_file, create_file, remove_file, - do_check, do_verbose_check, - ) -import RegChars ( regChars ) -import ByteStringUtils ( linesPS ) -import qualified Data.ByteString as B ( ByteString, null, concat ) -import qualified Data.ByteString.Char8 as BC ( break, pack ) -import Darcs.Patch.FileName ( fn2fp ) - -import Darcs.Patch.Patchy ( Commute ) -import Darcs.Patch ( addfile, adddir, move, showPatch, - hunk, tokreplace, joinPatches, binary, - changepref, is_merger, invert, commute, commutex, merge, - readPatch, resolve_conflicts, - effect, fromPrims, - unravel, merger, elegant_merge ) -import Darcs.Patch.Core ( Patch(..) ) -import Darcs.Patch.Prim ( Prim(..), DirPatchType(..), FilePatchType(..), - CommuteFunction, Perhaps(..), - subcommutes ) -import Printer ( renderPS ) -import Darcs.Ordered -import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal, unseal ) - -#include "impossible.h" - -instance Eq Patch where - x == y = IsEq == (x =\/= y) - -instance Eq Prim where - x == y = IsEq == (x =\/= y) - -instance (Commute a, MyEq a) => Eq (FL a) where - x == y = IsEq == (x =\/= y) - -instance Arbitrary Patch where - arbitrary = sized arbpatch --- coarbitrary p = coarbitrary (show p) - -instance Arbitrary Prim where - arbitrary = onepatchgen --- coarbitrary = impossible - -hunkgen :: Gen Prim -hunkgen = do - i <- frequency [(1,choose (0,5)),(1,choose (0,35)), - (2,return 0),(3,return 1),(2,return 2),(1,return 3)] - j <- frequency [(1,choose (0,5)),(1,choose (0,35)), - (2,return 0),(3,return 1),(2,return 2),(1,return 3)] - if i == 0 && j == 0 then hunkgen - else liftM4 hunk filepathgen linenumgen - (replicateM i filelinegen) - (replicateM j filelinegen) - -tokreplacegen :: Gen Prim -tokreplacegen = do - f <- filepathgen - o <- tokengen - n <- tokengen - if o == n - then return $ tokreplace f "A-Za-z" "old" "new" - else return $ tokreplace f "A-Za-z_" o n - -twofilegen :: (FilePath -> FilePath -> Prim) -> Gen Prim -twofilegen p = do - n1 <- filepathgen - n2 <- filepathgen - if n1 /= n2 && (check_a_patch $ fromPrims $ (p n1 n2 :>: NilFL)) - then return $ p n1 n2 - else twofilegen p - -chprefgen :: Gen Prim -chprefgen = do - f <- oneof [return "color", return "movie"] - o <- tokengen - n <- tokengen - if o == n then return $ changepref f "old" "new" - else return $ changepref f o n - -simplepatchgen :: Gen Prim -simplepatchgen = frequency [(1,liftM addfile filepathgen), - (1,liftM adddir filepathgen), - (1,liftM3 binary filepathgen arbitrary arbitrary), - (1,twofilegen move), - (1,tokreplacegen), - (1,chprefgen), - (7,hunkgen) - ] - -onepatchgen :: Gen Prim -onepatchgen = oneof [simplepatchgen, (invert) `fmap` simplepatchgen] - -norecursgen :: Int -> Gen Patch -norecursgen 0 = PP `fmap` onepatchgen -norecursgen n = oneof [PP `fmap` onepatchgen,flatcompgen n] - -arbpatch :: Int -> Gen Patch -arbpatch 0 = PP `fmap` onepatchgen -arbpatch n = frequency [(3,PP `fmap` onepatchgen), - -- (1,compgen n), - (2,flatcompgen n), - (0,raw_merge_gen n), - (0,mergegen n), - (1,PP `fmap` onepatchgen) - ] - -unempty :: Arbitrary a => Gen [a] -unempty = do - as <- arbitrary - case as of - [] -> unempty - _ -> return as - -join_patches :: [Patch] -> Patch -join_patches = joinPatches . unsafeFL - -raw_merge_gen :: Int -> Gen Patch -raw_merge_gen n = do p1 <- arbpatch len - p2 <- arbpatch len - if (check_a_patch $ join_patches [invert p1,p2]) && - (check_a_patch $ join_patches [invert p2,p1]) - then case merge (p2 :\/: p1) of - _ :/\: p2' -> return p2' - else raw_merge_gen n - where len = if n < 15 then n`div`3 else 3 - -mergegen :: Int -> Gen Patch -mergegen n = do - p1 <- norecursgen len - p2 <- norecursgen len - if (check_a_patch $ join_patches [invert p1,p2]) && - (check_a_patch $ join_patches [invert p2,p1]) - then case merge (p2:\/:p1) of - p1' :/\: p2' -> - if check_a_patch $ join_patches [p1,p2'] - then return $ join_patches [p1,p2'] - else return $ join_patches [PP $ addfile "Error_in_mergegen", - PP $ addfile "Error_in_mergegen", - p1,p2,p1',p2'] - else mergegen n - where len = if n < 15 then n`div`3 else 3 - -arbpi :: Gen PatchInfo -arbpi = do n <- unempty - a <- unempty - l <- unempty - d <- unempty - return $ unsafePerformIO $ patchinfo n d a l - -instance Arbitrary PatchInfo where - arbitrary = arbpi --- coarbitrary pi = coarbitrary (show pi) - -instance Arbitrary B.ByteString where - arbitrary = liftM BC.pack arbitrary --- coarbitrary ps = coarbitrary (unpackPS ps) - -{- -plistgen :: Int -> Int -> Gen [Patch] -plistgen s n - | n <= 0 = return [] - | otherwise = do - next <- arbpatch s - rest <- plistgen s (n-1) - return $ next : rest - -compgen :: Int -> Gen Patch -compgen n = do - size <- choose (0,n) - myp <- liftM join_patches $ plistgen size ((n+1) `div` (size+1)) --- here I assume we only want to consider valid patches... - if check_a_patch myp - then return myp - else compgen n --} - -flatlistgen :: Int -> Gen [Patch] -flatlistgen n = replicateM n (PP `fmap` onepatchgen) - -flatcompgen :: Int -> Gen Patch -flatcompgen n = do - myp <- liftM (join_patches . regularize_patches) $ flatlistgen n - if check_a_patch myp - then return myp - else flatcompgen n - --- resize to size 25, that means we'll get line numbers no greater --- than 1025 using QuickCheck 2.1 -linenumgen :: Gen Int -linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3), - (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ] - -tokengen :: Gen String -tokengen = oneof [return "hello", return "world", return "this", - return "is", return "a", return "silly", - return "token", return "test"] - -toklinegen :: Gen String -toklinegen = liftM unwords $ replicateM 3 tokengen - -filelinegen :: Gen B.ByteString -filelinegen = liftM BC.pack $ - frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen), - (1,return ""), (1,return "{"), (1,return "}") ] - -filepathgen :: Gen String -filepathgen = liftM fixpath badfpgen - -fixpath :: String -> String -fixpath "" = "test" -fixpath p = fpth p - -fpth :: String -> String -fpth ('/':'/':cs) = fpth ('/':cs) -fpth (c:cs) = c : fpth cs -fpth [] = [] - -newtype SafeChar = SS Char -instance Arbitrary SafeChar where - arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0") - -fromSafeChar :: SafeChar -> Char -fromSafeChar (SS s) = s - -badfpgen :: Gen String -badfpgen = frequency [(1,return "test"), (1,return "hello"), (1,return "world"), - (1,map fromSafeChar `fmap` arbitrary), - (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ] - -{- -instance Arbitrary Char where - arbitrary = oneof $ map return - (['a'..'z']++['A'..'Z']++['1'..'9']++['0','~','.',',','-','/']) --} --- coarbitrary c = coarbitrary (ord c) - -check_patch :: Patch -> PatchCheck Bool -check_a_patch :: Patch -> Bool -check_a_patch p = do_check $ do check_patch p - check_patch $ invert p -verbose_check_a_patch :: Patch -> Bool -verbose_check_a_patch p = do_verbose_check $ do check_patch p - check_patch $ invert p - -check_patch p | is_merger p = do - check_patch $ fromPrims $ effect p -check_patch (Merger _ _ _ _) = impossible -check_patch (Regrem _ _ _ _) = impossible -check_patch (ComP NilFL) = is_valid -check_patch (ComP (p:>:ps)) = - check_patch p >> check_patch (ComP ps) -check_patch (PP Identity) = is_valid -check_patch (PP (Split NilFL)) = is_valid -check_patch (PP (Split (p:>:ps))) = - check_patch (PP p) >> check_patch (PP (Split ps)) - -check_patch (PP (FP f RmFile)) = remove_file $ fn2fp f -check_patch (PP (FP f AddFile)) = create_file $ fn2fp f -check_patch (PP (FP f (Hunk line old new))) = do - file_exists $ fn2fp f - mapM (delete_line (fn2fp f) line) old - mapM (insert_line (fn2fp f) line) (reverse new) - is_valid -check_patch (PP (FP f (TokReplace t old new))) = - modify_file (fn2fp f) (try_tok_possibly t old new) --- note that the above isn't really a sure check, as it leaves PSomethings --- and PNothings which may have contained new... -check_patch (PP (FP f (Binary o n))) = do - file_exists $ fn2fp f - mapM (delete_line (fn2fp f) 1) (linesPS o) - file_empty $ fn2fp f - mapM (insert_line (fn2fp f) 1) (reverse $ linesPS n) - is_valid - -check_patch (PP (DP d AddDir)) = create_dir $ fn2fp d -check_patch (PP (DP d RmDir)) = remove_dir $ fn2fp d - -check_patch (PP (Move f f')) = check_move (fn2fp f) (fn2fp f') -check_patch (PP (ChangePref _ _ _)) = return True - -regularize_patches :: [Patch] -> [Patch] -regularize_patches patches = rpint [] patches - where rpint ok_ps [] = ok_ps - rpint ok_ps (p:ps) = - if check_a_patch (join_patches $ p:ok_ps) - then rpint (p:ok_ps) ps - else rpint ok_ps ps - -prop_inverse_composition :: Patch -> Patch -> Bool -prop_inverse_composition p1 p2 = - invert (join_patches [p1,p2]) == join_patches [invert p2, invert p1] -prop_inverse_valid :: Patch -> Bool -prop_inverse_valid p1 = check_a_patch $ join_patches [invert p1,p1] -prop_other_inverse_valid :: Patch -> Bool -prop_other_inverse_valid p1 = check_a_patch $ join_patches [p1,invert p1] - -prop_commute_twice :: Patch -> Patch -> Property -prop_commute_twice p1 p2 = - (does_commute p1 p2) ==> (Just (p2:>= commutex)) -does_commute :: Patch -> Patch -> Bool -does_commute p1 p2 = - commutex (p2: Patch -> Property -prop_commute_equivalency p1 p2 = - (does_commute p1 p2) ==> - case commutex (p2: check_a_patch $ join_patches [p1,p2,invert p1',invert p2'] - _ -> impossible - -prop_commute_either_way :: Patch -> Patch -> Property -prop_commute_either_way p1 p2 = - does_commute p1 p2 ==> does_commute (invert p2) (invert p1) - -prop_commute_either_order :: Patch -> Patch -> Patch -> Property -prop_commute_either_order p1 p2 p3 = - check_a_patch (join_patches [p1,p2,p3]) && - does_commute p1 (join_patches [p2,p3]) && - does_commute p2 p3 ==> - case commutex (p2: False - Just (p1': - case commutex (p3: False - Just (_: - case commutex (p3': False - Just (_:< p3'') -> - case commutex (p3: False - Just (_: - case commutex (p3'a: p3''a == p3'' - Nothing -> False - -prop_patch_and_inverse_is_identity :: Patch -> Patch -> Property -prop_patch_and_inverse_is_identity p1 p2 = - (check_a_patch $ join_patches [p1,p2]) && (commutex (p2: - case commutex (p2: case commutex (p2': True -- This is a subtle distinction. - Just (_: p2'' == p2 - Nothing -> impossible - -quickmerge :: (Patch :\/: Patch) -> Patch -quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of - _ :/\: p1' -> p1' - -prop_merge_is_commutable_and_correct :: Patch -> Patch -> Property -prop_merge_is_commutable_and_correct p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - case merge (p2:\/:p1) of - p1' :/\: p2' -> - case commutex (p2': False - Just (p1'': p2'' == p2 && p1' == p1'' -prop_merge_is_swapable :: Patch -> Patch -> Property -prop_merge_is_swapable p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - case merge (p2:\/:p1) of - p1' :/\: p2' -> - case merge (p1:\/:p2) of - p2''' :/\: p1''' -> p1' == p1''' && p2' == p2''' - -prop_merge_valid :: Patch -> Patch -> Property -prop_merge_valid p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - case merge (p2:\/:p1) of - _ :/\: p2' -> - check_a_patch $ join_patches [invert p1,p2,invert p2,p1,p2'] - -prop_simple_smart_merge_good_enough :: Patch -> Patch -> Property -prop_simple_smart_merge_good_enough p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - smart_merge (p2:\/:p1) == simple_smart_merge (p2:\/:p1) - -smart_merge :: (Patch :\/: Patch) -> Maybe (Patch :< Patch) -smart_merge (p1 :\/: p2) = - case simple_smart_merge (p1:\/:p2) of - Nothing -> Nothing - Just (p1'a: - case simple_smart_merge (p2 :\/: p1) >>= commutex of - Nothing -> Nothing - Just (p1'b :< p2b) -> - if p1'a == p1'b && p2a == p2b && p2a == p2 - then Just (p1'a :< p2) - else Nothing -simple_smart_merge :: (Patch :\/: Patch) -> Maybe (Patch :< Patch) -simple_smart_merge (p1 :\/: p2) = - case commutex (p1 :< invert p2) of - Just (_: - case commutex (p1':< p2) of - Just (_:< p1o) -> - if p1o == p1 then Just (p1' :< p2) - else Nothing - Nothing -> Nothing - Nothing -> Nothing - -prop_elegant_merge_good_enough :: Patch -> Patch -> Property -prop_elegant_merge_good_enough p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - (fst' `fmap` smart_merge (p2:\/:p1)) == - (snd'' `fmap` elegant_merge (p2:\/:p1)) - -fst' :: p :< p -> p -fst' (x:<_) = x - -snd'' :: q :/\: p -> p -snd'' (_:/\:x) = x - -instance Eq p => Eq (p :< p) where - (x: Show (p :< p) where - show (x :< y) = show x ++ " :< " ++ show y - -test_patch :: String -test_patch = test_str ++ test_note -tp1, tp2 :: Patch -tp1 = unsafeUnseal . fst . fromJust . readPatch $ BC.pack "\nmove ./test/test ./hello\n" -tp2 = unsafeUnseal . fst . fromJust . readPatch $ BC.pack "\nmove ./test ./hello\n" -tp1', tp2' :: Patch -tp2' = quickmerge (tp2:\/:tp1) -tp1' = quickmerge (tp1:\/:tp2) -test_note :: String -test_note = (if commutex (tp2': Patch -> Patch -> Property -prop_unravel_three_merge p1 p2 p3 = - (check_a_patch $ join_patches [invert p1,p2,invert p2,p3]) ==> - (unravel $ merger "0.0" (merger "0.0" p2 p3) (merger "0.0" p2 p1)) == - (unravel $ merger "0.0" (merger "0.0" p1 p3) (merger "0.0" p1 p2)) - -prop_unravel_seq_merge :: Patch -> Patch -> Patch -> Property -prop_unravel_seq_merge p1 p2 p3 = - (check_a_patch $ join_patches [invert p1,p2,p3]) ==> - (unravel $ merger "0.0" p3 $ merger "0.0" p2 p1) == - (unravel $ merger "0.0" (merger "0.0" p2 p1) p3) - -prop_unravel_order_independent :: Patch -> Patch -> Property -prop_unravel_order_independent p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - (unravel $ merger "0.0" p2 p1) == (unravel $ merger "0.0" p1 p2) - -prop_resolve_conflicts_valid :: Patch -> Patch -> Property -prop_resolve_conflicts_valid p1 p2 = - (check_a_patch $ join_patches [invert p1,p2]) ==> - and $ map (check_a_patch.(\l-> join_patches [p,merge_list l])) - $ resolve_conflicts p - where p = case merge (p1:\/:p2) of - _ :/\: p1' -> join_patches [p2,p1'] - -merge_list :: [Sealed (FL Prim C(x))] -> Patch -merge_list patches = fromPrims `unseal` doml NilFL patches - where doml mp (Sealed p:ps) = - case commute (invert p :> mp) of - Just (mp' :> _) -> doml (effect p +>+ effect mp') ps - Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions. - doml mp [] = Sealed mp - -try_tok_possibly :: String -> String -> String - -> [Possibly B.ByteString] -> Maybe [Possibly B.ByteString] -try_tok_possibly t o n mss = - mapM (silly_maybe_possibly $ liftM B.concat . - try_tok_internal t (BC.pack o) (BC.pack n)) - $ take 1000 mss - -silly_maybe_possibly :: (B.ByteString -> Maybe B.ByteString) -> - (Possibly B.ByteString -> Maybe (Possibly B.ByteString)) -silly_maybe_possibly f = - \px -> case px of - PNothing -> Just PNothing - PSomething -> Just PSomething - PJust x -> case f x of - Nothing -> Nothing - Just x' -> Just $ PJust x' - -try_tok_internal :: String -> B.ByteString -> B.ByteString - -> B.ByteString -> Maybe [B.ByteString] -try_tok_internal _ _ _ s | B.null s = Just [] -try_tok_internal t o n s = - case BC.break (regChars t) s of - (before,s') -> - case BC.break (not . regChars t) s' of - (tok,after) -> - case try_tok_internal t o n after of - Nothing -> Nothing - Just rest -> - if tok == o - then Just $ before : n : rest - else if tok == n - then Nothing - else Just $ before : tok : rest - -prop_read_show :: Patch -> Bool -prop_read_show p = case readPatch $ renderPS $ showPatch p of - Just (Sealed p',_) -> p' == p - Nothing -> False - --- |In order for merges to work right with commuted patches, inverting a patch --- past a patch and its inverse had golly well better give you the same patch --- back again. -prop_commute_inverse :: Patch -> Patch -> Property -prop_commute_inverse p1 p2 = - does_commute p1 p2 ==> case commutex (p2:< p1) of - Nothing -> impossible - Just (p1':<_) -> - case commutex (invert p2:< p1') of - Nothing -> False - Just (p1'':<_) -> p1'' == p1 - -subcommutes_inverse :: [(String, Prim -> Prim -> Property)] -subcommutes_inverse = zip names (map prop_subcommute cs) - where (names, cs) = unzip subcommutes - prop_subcommute c p1 p2 = - does c p1 p2 ==> - case c (p2:< p1) of - Succeeded (p1': - case c (invert p2:< p1') of - Succeeded (p1'': p1'' == p1 && - case c (invert p1:< invert p2) of - Succeeded (ip2':< ip1') -> - case c (p2':< invert p1) of - Succeeded (ip1o':< p2o) -> - invert ip1' == p1' && invert ip2' == p2' && - ip1o' == ip1' && p2o == p2 && - p1'' == p1 && ip2x' == ip2' - _ -> False - _ -> False - _ -> False - _ -> False - -subcommutes_nontrivial_inverse :: [(String, Prim -> Prim -> Property)] -subcommutes_nontrivial_inverse = zip names (map prop_subcommute cs) - where (names, cs) = unzip subcommutes - prop_subcommute c p1 p2 = - nontrivial c p1 p2 ==> - case c (p2:< p1) of - Succeeded (p1': - case c (invert p2:< p1') of - Succeeded (p1'': p1'' == p1 && - case c (invert p1:< invert p2) of - Succeeded (ip2':< ip1') -> - case c (p2':< invert p1) of - Succeeded (ip1o':< p2o) -> - invert ip1' == p1' && invert ip2' == p2' && - ip1o' == ip1' && p2o == p2 && - p1'' == p1 && ip2x' == ip2' - _ -> False - _ -> False - _ -> False - _ -> False - -subcommutes_failure :: [(String, Prim -> Prim -> Property)] -subcommutes_failure = zip names (map prop cs) - where (names, cs) = unzip subcommutes - prop c p1 p2 = - does_fail c p1 p2 ==> case c (invert p1 :< invert p2) of - Failed -> True - _ -> False - -does_fail :: CommuteFunction -> Prim -> Prim -> Bool -does_fail c p1 p2 = - fails (c (p2: Prim -> Prim -> Bool -does c p1 p2 = - succeeds (c (p2: Prim -> Prim -> Bool -nontrivial c p1 p2 = - succeeds (c (p2:> return 0 - run_primitive_tests "prim join inverses" - (\(a:\/:_) -> join_inverses join a) mergeables - ,do putStr "Checking prim join inverses using QuickCheck... " - simpleCheck (join_inverses join) - ,run_primitive_tests "prim inverse doesn't commute" - (\(a:\/:_) -> inverse_doesnt_commute a) mergeables - -- The following fails because of setpref patches... - --,do putStr "Checking prim inverse doesn't commute using QuickCheck... " - -- simpleCheck (inverse_doesnt_commute :: Prim -> Maybe Doc) - ,run_primitive_tests "join commute" (join_commute join) prim_permutables - ,do putStr "Checking prim join commute using QuickCheck... " - simpleCheck (unseal2 (join_commute join)) - - ,run_primitive_tests "prim recommute" - (recommute commute) $ map mergeable2commutable mergeables - ,run_primitive_tests "prim patch and inverse commute" - (patch_and_inverse_commute commute) $ map mergeable2commutable mergeables - ,run_primitive_tests "prim inverses commute" - (commute_inverses commute) $ map mergeable2commutable mergeables - --- ,do putStr "Checking prim recommute using QuickCheck... " --- simpleCheck (recommute --- (commute :: Prim :> Prim --- -> Maybe (Prim :> Prim))) - - ,run_primitive_tests "FL prim recommute" - (recommute commute) $ map mergeable2commutable mergeablesFL - ,run_primitive_tests "FL prim patch and inverse commute" - (patch_and_inverse_commute commute) $ map mergeable2commutable mergeablesFL - ,run_primitive_tests "FL prim inverses commute" - (commute_inverses commute) $ map mergeable2commutable mergeablesFL - - ,run_primitive_tests "fails" (commute_fails commute) ([] :: [Prim :> Prim]) - - ,run_primitive_tests "read and show work on Prim" show_read prim_patches - ,run_primitive_tests "read and show work on RealPatch" show_read real_patches - ,do putStr "Checking that readPatch and showPatch work on RealPatch... " - simpleCheck (unseal $ patchFromTree $ (show_read :: RealPatch -> Maybe Doc)) - ,do putStr "Checking that readPatch and showPatch work on FL RealPatch... " - simpleCheck (unseal2 $ (show_read :: FL RealPatch -> Maybe Doc)) - - ,run_primitive_tests "example flattenings work" - (\x -> if prop_consistent_tree_flattenings x - then Nothing - else Just $ redText "oops") - real_patch_loop_examples - ,do putStr "Checking that tree flattenings are consistent... " - simpleCheck ((\b -> if b then Nothing else Just False) . prop_consistent_tree_flattenings) - - ,do putStr "Checking with quickcheck that real patches are consistent... " - simpleCheck (unseal $ patchFromTree $ is_consistent) - ,run_primitive_tests "real merge input consistent" - (merge_arguments_consistent is_consistent) real_mergeables - ,run_primitive_tests "real merge input is forward" - (merge_arguments_consistent is_forward) real_mergeables - ,run_primitive_tests "real merge output is forward" - (merge_consistent is_forward) real_mergeables - ,run_primitive_tests "real merge output consistent" - (merge_consistent is_consistent) real_mergeables - ,run_primitive_tests "real merge either way" merge_either_way real_mergeables - ,run_primitive_tests "real merge and commute" merge_commute real_mergeables - - ,run_primitive_tests "real recommute" (recommute commute) real_commutables - ,run_primitive_tests "real inverses commute" (commute_inverses commute) real_commutables - - ,run_primitive_tests "real permutivity" (permutivity commute) $ - filter (not_duplicatestriple) real_triples - ,run_primitive_tests "real partial permutivity" (partial_permutivity commute) $ - filter (not_duplicatestriple) real_triples - - ,do putStr "Checking we can do merges using QuickCheck... " - simpleCheck (prop_is_mergeable :: - Sealed (WithStartState RepoModel (Tree Prim)) - -> Maybe (Tree RealPatch C(x))) - ,do putStr "Checking again we can do merges using QuickCheck... " - thoroughCheck 1000 (prop_is_mergeable :: - Sealed (WithStartState RepoModel (Tree Prim)) - -> Maybe (Tree RealPatch C(x))) - - ,do putStr "Checking recommute using QuickCheck Tree generator... " - simpleCheck (unseal $ commutePairFromTree $ - (recommute - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - ,do putStr "Checking recommute using QuickCheck TWFP generator... " - simpleCheck (unseal $ commutePairFromTWFP $ - (recommute - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - ,do putStr "Checking nontrivial recommute... " - simpleConditionalCheck (unseal $ commutePairFromTree $ nontrivial_reals) - (unseal $ commutePairFromTree $ - (recommute - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - ,do putStr "Checking nontrivial recommute using TWFP... " - simpleConditionalCheck (unseal $ commutePairFromTWFP $ nontrivial_reals) - (unseal $ commutePairFromTWFP $ - (recommute - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - - ,do putStr "Checking inverses commute using QuickCheck Tree generator... " - simpleCheck (unseal $ commutePairFromTree $ - (commute_inverses - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - ,do putStr "Checking inverses commute using QuickCheck TWFP generator... " - simpleCheck (unseal $ commutePairFromTWFP $ - (commute_inverses - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - ,do putStr "Checking nontrivial inverses commute... " - simpleConditionalCheck (unseal $ commutePairFromTree $ nontrivial_reals) - (unseal $ commutePairFromTree $ - (commute_inverses - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - ,do putStr "Checking nontrivial inverses commute using TWFP... " - simpleConditionalCheck (unseal $ commutePairFromTWFP $ nontrivial_reals) - (unseal $ commutePairFromTWFP $ - (commute_inverses - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - - ,do putStr "Checking merge either way using QuickCheck TWFP generator... " - simpleCheck (unseal $ mergePairFromTWFP $ - (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)) - ,do putStr "Checking merge either way using QuickCheck Tree generator... " - simpleCheck (unseal $ mergePairFromTree $ - (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)) - ,do putStr "Checking nontrivial merge either way... " - simpleConditionalCheck (unseal $ mergePairFromTree $ nontrivial_merge_reals) - (unseal $ mergePairFromTree $ - (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)) - ,do putStr "Checking nontrivial merge either way using TWFP... " - simpleConditionalCheck (unseal $ mergePairFromTWFP $ nontrivial_merge_reals) - (unseal $ mergePairFromTWFP $ - (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)) - - ,do putStr "Checking permutivity... " - simpleConditionalCheck (unseal $ commuteTripleFromTree not_duplicatestriple) - (unseal $ commuteTripleFromTree $ permutivity - (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))) - ,do putStr "Checking partial permutivity... " - simpleConditionalCheck (unseal $ commuteTripleFromTree not_duplicatestriple) - (unseal $ commuteTripleFromTree $ partial_permutivity - (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))) - ,do putStr "Checking nontrivial permutivity... " - simpleConditionalCheck (unseal $ commuteTripleFromTree - (\t -> nontrivial_triple t && not_duplicatestriple t)) - (unseal $ commuteTripleFromTree $ - (permutivity - (commute :: RealPatch :> RealPatch - -> Maybe (RealPatch :> RealPatch)))) - ] - -not_duplicatestriple :: RealPatch :> RealPatch :> RealPatch -> Bool -not_duplicatestriple (a :> b :> c) = not $ any is_duplicate [a,b,c] - ---not_duplicates_pair :: RealPatch :> RealPatch -> Bool ---not_duplicates_pair (a :> b) = not $ any is_duplicate [a,b] - -nontrivial_triple :: RealPatch :> RealPatch :> RealPatch -> Bool -nontrivial_triple (a :> b :> c) = - case commute (a :> b) of - Nothing -> False - Just (b' :> a') -> - case commute (a' :> c) of - Nothing -> False - Just (c'' :> a'') -> - case commute (b :> c) of - Nothing -> False - Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) && - (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) && - (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a')) - -nontrivial_reals :: RealPatch :> RealPatch -> Bool -nontrivial_reals = nontrivial_commute - -nontrivial_commute :: Patchy p => p :> p -> Bool -nontrivial_commute (x :> y) = case commute (x :> y) of - Just (y' :> x') -> not (y' `unsafeCompare` y) || - not (x' `unsafeCompare` x) - Nothing -> False - -nontrivial_merge_reals :: RealPatch :\/: RealPatch -> Bool -nontrivial_merge_reals = nontrivial_merge - -nontrivial_merge :: Patchy p => p :\/: p -> Bool -nontrivial_merge (x :\/: y) = case merge (x :\/: y) of - y' :/\: x' -> not (y' `unsafeCompare` y) || - not (x' `unsafeCompare` x) - -run_some_tests :: String -> [IO Int] -> IO Int -run_some_tests name ts = do unless (null name) $ putStr $ "Testing " ++ name ++ "... " - errs <- sum `fmap` sequence ts - unless (null name) $ - if errs < 1 - then putStrLn "passed." - else putStrLn $ "failed " ++ name ++" in "++ show errs ++ " tests." - return errs - -run_primitive_tests :: (Show a, Show b) => String -> (a -> Maybe b) -> [a] -> IO Int -run_primitive_tests name test datas = run_some_tests name $ map test' datas - where test' d = case test d of - Just e -> do putStrLn $ name ++ " failed!" - putStrLn $ "Input: " ++ show d - putStrLn $ "Output: " ++ show e - return 1 - Nothing -> return 0 - -quickhunk :: Int -> String -> String -> Prim -quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o) - (map (\c -> BC.pack [c]) n) - -prim_permutables :: [Prim :> Prim :> Prim] -prim_permutables = - [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"] - -mergeables :: [Prim :\/: Prim] -mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c", - quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c", - quickhunk 0 "" "a" :\/: quickhunk 1 "" "b", - quickhunk 0 "a" "" :\/: quickhunk 1 "" "b", - quickhunk 0 "a" "" :\/: quickhunk 1 "b" "", - quickhunk 0 "" "a" :\/: quickhunk 1 "b" "" - ] - -mergeablesFL :: [FL Prim :\/: FL Prim] -mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables ++ - [] -- [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL) - -- :\/: (quickhunk 1 "a" "z" :>: NilFL), - -- (quickhunk 1 "a" "b" :>: quickhunk 1 "b" "c" :>: NilFL) - -- :\/: (quickhunk 1 "a" "z" :>: NilFL)] - -mergeable2commutable :: Invert p => p :\/: p -> p :> p -mergeable2commutable (x :\/: y) = invert x :> y - -prim_patches :: [Prim] -prim_patches = concatMap mergeable2patches mergeables - where mergeable2patches (x:\/:y) = [x,y] - -real_patches :: [RealPatch] -real_patches = concatMap commutable2patches real_commutables - where commutable2patches (x:>y) = [x,y] - -real_triples :: [RealPatch :> RealPatch :> RealPatch] -real_triples = [ob' :> oa2 :> a2'', - oa' :> oa2 :> a2''] ++ triple_examples - ++ map unsafeUnseal2 (concatMap getTriples realFLs) - where oa = prim2real $ quickhunk 1 "o" "aa" - oa2 = oa - a2 = prim2real $ quickhunk 2 "a34" "2xx" - ob = prim2real $ quickhunk 1 "o" "bb" - ob' :/\: oa' = merge (oa :\/: ob) - a2' :/\: _ = merge (ob' :\/: a2) - a2'' :/\: _ = merge (oa2 :\/: a2') - -realFLs :: [FL RealPatch] -realFLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL] - where oa = prim2real $ quickhunk 1 "o" "a" - ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL) - -real_commutables :: [RealPatch :> RealPatch] -real_commutables = commute_examples ++ map mergeable2commutable real_mergeables++ - [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs) - where oa = prim2real $ quickhunk 1 "o" "a" - ob = prim2real $ quickhunk 1 "o" "b" - _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL) - -real_mergeables :: [RealPatch :\/: RealPatch] -real_mergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables - ++ real_igloo_mergeables - ++ real_quickcheck_mergeables - ++ merge_examples - ++ catMaybes (map pair2m (concatMap getPairs realFLs)) - ++ [(oa :\/: od), - (oa :\/: a2'), - (ob' :\/: od''), - (oe :\/: od), - (of' :\/: oe'), - (ob' :\/: oe'), - (oa :\/: oe'), - (ob' :\/: oc'), - (b2' :\/: oc'''), - (ob' :\/: a2), - (b2' :\/: og'''), - (oc''' :\/: og'''), - (oc'' :\/: og''), - (ob'' :\/: og''), - (ob'' :\/: oc''), - (oc' :\/: od'')] - where oa = prim2real $ quickhunk 1 "o" "aa" - a2 = prim2real $ quickhunk 2 "a34" "2xx" - og = prim2real $ quickhunk 3 "4" "g" - ob = prim2real $ quickhunk 1 "o" "bb" - b2 = prim2real $ quickhunk 2 "b" "2" - oc = prim2real $ quickhunk 1 "o" "cc" - od = prim2real $ quickhunk 7 "x" "d" - oe = prim2real $ quickhunk 7 "x" "e" - pf = prim2real $ quickhunk 7 "x" "f" - od'' = prim2real $ quickhunk 8 "x" "d" - ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL) - a2' :/\: _ = merge (ob' :\/: a2) - ob'' :/\: _ = merge (a2 :\/: ob') - og' :/\: _ = merge (oa :\/: og) - og'' :/\: _ = merge (a2 :\/: og') - og''' :/\: _ = merge (ob' :\/: og') - oc' :/\: _ = merge (oa :\/: oc) - oc'' :/\: _ = merge (a2 :\/: oc) - oc''' :/\: _ = merge (ob' :\/: oc') - oe' :/\: _ = merge (od :\/: oe) - of' :/\: _ = merge (od :\/: pf) - pair2m :: Sealed2 (RealPatch :> RealPatch) - -> Maybe (RealPatch :\/: RealPatch) - pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y) - return (xx :\/: y') - -real_igloo_mergeables :: [RealPatch :\/: RealPatch] -real_igloo_mergeables = [(a :\/: b), - (b :\/: c), - (a :\/: c), - (x :\/: a), - (y :\/: b), - (z :\/: c), - (x' :\/: y'), - (z' :\/: y'), - (x' :\/: z'), - (a :\/: a)] - where a = prim2real $ quickhunk 1 "1" "A" - b = prim2real $ quickhunk 2 "2" "B" - c = prim2real $ quickhunk 3 "3" "C" - x = prim2real $ quickhunk 1 "1BC" "xbc" - y = prim2real $ quickhunk 1 "A2C" "ayc" - z = prim2real $ quickhunk 1 "AB3" "abz" - x' :/\: _ = merge (a :\/: x) - y' :/\: _ = merge (b :\/: y) - z' :/\: _ = merge (c :\/: z) - -real_quickcheck_mergeables :: [RealPatch :\/: RealPatch] -real_quickcheck_mergeables = [-- invert k1 :\/: n1 - --, invert k2 :\/: n2 - hb :\/: k - , b' :\/: b' - , n' :\/: n' - , b :\/: d - , k' :\/: k' - , k3 :\/: k3 - ] ++ catMaybes (map pair2m pairs) - where hb = prim2real $ quickhunk 0 "" "hb" - k = prim2real $ quickhunk 0 "" "k" - n = prim2real $ quickhunk 0 "" "n" - b = prim2real $ quickhunk 1 "b" "" - d = prim2real $ quickhunk 2 "" "d" - d':/\:_ = merge (b :\/: d) - --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL) - --k2 :>: n2 :>: NilFL :/\: _ = - -- merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL) - k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL) - pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL) - pair2m :: Sealed2 (RealPatch :> RealPatch) - -> Maybe (RealPatch :\/: RealPatch) - pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y) - return (xx :\/: y') - - i = prim2real $ quickhunk 0 "" "i" - x = prim2real $ quickhunk 0 "" "x" - xi = prim2real $ quickhunk 0 "xi" "" - d3 :/\: _ = merge (xi :\/: d) - _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL) - -commute_fails :: (MyEq p, Patchy p) => (p :> p -> Maybe (p :> p)) -> p :> p - -> Maybe Doc -commute_fails c (x :> y) = do y' :> x' <- c (x :> y) - return $ redText "x" $$ showPatch x $$ - redText ":> y" $$ showPatch y $$ - redText "y'" $$ showPatch y' $$ - redText ":> x'" $$ showPatch x' diff --git a/src/Darcs/Progress.hs b/src/Darcs/Progress.hs deleted file mode 100644 --- a/src/Darcs/Progress.hs +++ /dev/null @@ -1,218 +0,0 @@ --- Various utility functions that do not belong anywhere else. - -{-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE CPP #-} - -#include "gadts.h" - -module Darcs.Progress ( beginTedious, endTedious, tediousSize, - debugMessage, debugFail, withoutProgress, - progress, finishedOne, finishedOneIO, - progressList, progressFL, progressRL, - setProgressMode ) where - -import Prelude hiding (lookup, catch) - -import Control.Exception ( catch, throw ) -import Control.Monad ( when ) -import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn, - hSetBuffering, hIsTerminalDevice, - Handle, BufferMode(LineBuffering) ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.Char ( toLower ) -import Data.Map ( Map, empty, adjust, insert, delete, lookup ) -import Data.Maybe ( isJust ) -import Control.Concurrent ( forkIO, threadDelay ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) - -import Darcs.Ordered ( FL(..), RL(..), lengthRL, lengthFL ) -import Darcs.Global ( withDebugMode, debugMessage, putTiming, debugFail ) - -handleProgress :: IO () -handleProgress = do threadDelay 1000000 - handleMoreProgress "" 0 - -handleMoreProgress :: String -> Int -> IO () -handleMoreProgress k n = withProgressMode $ \m -> - if m then do s <- getProgressLast - mp <- getProgressData s - case mp of - Nothing -> do threadDelay 1000000 - handleMoreProgress k n - Just p -> do when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p - threadDelay 1000000 - handleMoreProgress s (sofar p) - else do threadDelay 1000000 - handleMoreProgress k n - -printProgress :: String -> ProgressData -> IO () -printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) = - myput (k++" "++show s++"/"++show t++" : "++l) (k++" "++show s++"/"++show t) -printProgress k (ProgressData {latest=Just l}) = - myput (k++" "++l) k -printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s = - myput (k++" "++show s++"/"++show t) (k++" "++show s) -printProgress k (ProgressData {sofar=s}) = - myput (k++" "++show s) k - -myput :: String -> String -> IO () -myput l s = withDebugMode $ \debugMode -> - if debugMode - then putTiming >> hPutStrLn stderr l - else if '\n' `elem` l - then myput (takeWhile (/= '\n') l) s - else if length l < 80 then putTiming >> simpleput l - else putTiming >> simpleput (take 80 s) - -{-# NOINLINE simpleput #-} -simpleput :: String -> IO () -simpleput = unsafePerformIO $ mkhPutCr stderr - -beginTedious :: String -> IO () -beginTedious k = do debugMessage $ "Beginning " ++ lower k - setProgressData k $ ProgressData { sofar = 0, - latest = Nothing, - total = Nothing } - -endTedious :: String -> IO () -endTedious k = whenProgressMode $ do p <- getProgressData k - modifyIORef _progressData (\(a,m) -> (a,delete k m)) - when (isJust p) $ debugMessage $ "Done "++lower k - -lower :: String -> String -lower (x:xs) = toLower x:xs -lower "" = "" - -beginOrEndTedious :: String -> Int -> IO () -beginOrEndTedious k l = do mp <- getProgressData k - case mp of - Nothing -> do beginTedious k - tediousSize k l - Just p -> if total p == Just l - then endTedious k - else return () - -tediousSize :: String -> Int -> IO () -tediousSize k s = updateProgressData k uptot - where uptot p = case total p of Just t -> seq ts $ p { total = Just ts } - where ts = t + s - Nothing -> p { total = Just s } - -minlist :: Int -minlist = 4 - -progressList :: String -> [a] -> [a] -progressList _ [] = [] -progressList k (x:xs) = if l < minlist then x:xs - else startit x : pl xs - where l = length (x:xs) - startit y = unsafePerformIO $ do beginOrEndTedious k l - return y - pl [y] = [startit y] - pl [] = [] - pl (y:ys) = progress k y : pl ys - -progressFL :: String -> FL a C(x y) -> FL a C(x y) -progressFL _ NilFL = NilFL -progressFL k (x:>:xs) = if l < minlist then x:>:xs - else startit x :>: pl xs - where l = lengthFL (x:>:xs) - startit y = unsafePerformIO $ do beginOrEndTedious k l - return y - pl :: FL a C(x y) -> FL a C(x y) - pl (y:>:NilFL) = (startit y) :>: NilFL - pl NilFL = NilFL - pl (y:>:ys) = progress k y :>: pl ys - -progressRL :: String -> RL a C(x y) -> RL a C(x y) -progressRL _ NilRL = NilRL -progressRL k (x:<:xs) = if l < minlist then x:<:xs - else startit x :<: pl xs - where l = lengthRL (x:<:xs) - startit y = unsafePerformIO $ do beginOrEndTedious k l - return y - pl :: RL a C(x y) -> RL a C(x y) - pl (y:<:NilRL) = (startit y) :<: NilRL - pl NilRL = NilRL - pl (y:<:ys) = progress k y :<: pl ys - -progress :: String -> a -> a -progress k a = unsafePerformIO $ progressIO k >> return a - -progressIO :: String -> IO () -progressIO "" = return () -progressIO k = do updateProgressData k (\p -> p { sofar = sofar p + 1, - latest = Nothing }) - putDebug k "" - -finishedOne :: String -> String -> a -> a -finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a - -finishedOneIO :: String -> String -> IO () -finishedOneIO "" _ = return () -finishedOneIO k l = do updateProgressData k (\p -> p { sofar = sofar p + 1, - latest = Just l }) - putDebug k l - -putDebug :: String -> String -> IO () -putDebug _ _ = return () ---putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k ---putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l - -{-# NOINLINE _progressMode #-} -_progressMode :: IORef Bool -_progressMode = unsafePerformIO $ do hSetBuffering stderr LineBuffering - newIORef True - -{-# NOINLINE _progressData #-} -_progressData :: IORef (String, Map String ProgressData) -_progressData = unsafePerformIO $ do forkIO handleProgress - newIORef ("", empty) - -mkhPutCr :: Handle -> IO (String -> IO ()) -mkhPutCr fe = do - isTerm <- hIsTerminalDevice fe - stdoutIsTerm <- hIsTerminalDevice stdout - return $ if isTerm then \s -> do hPutStr fe $ '\r':s++"\r" - hFlush fe - let spaces = '\r':take (length s) (repeat ' ')++"\r" - hPutStr fe spaces - when stdoutIsTerm $ hPutStr stdout spaces - else \s -> when (not $ null s) $ do hPutStrLn fe s - hFlush fe - -setProgressMode :: Bool -> IO () -setProgressMode m = writeIORef _progressMode m - -withoutProgress :: IO a -> IO a -withoutProgress j = withProgressMode $ \m -> do debugMessage "Disabling progress reports..." - setProgressMode False - a <- j `catch` \e -> setProgressMode m >> throw e - if m then debugMessage "Reenabling progress reports." - else debugMessage "Leaving progress reports off." - setProgressMode m - return a - -updateProgressData :: String -> (ProgressData -> ProgressData) -> IO () -updateProgressData k f = whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m)) - -setProgressData :: String -> ProgressData -> IO () -setProgressData k p = whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m)) - -getProgressData :: String -> IO (Maybe ProgressData) -getProgressData k = withProgressMode $ \p -> if p then (lookup k . snd) `fmap` readIORef _progressData - else return Nothing - -getProgressLast :: IO String -getProgressLast = withProgressMode $ \p -> if p then fst `fmap` readIORef _progressData - else return "" - -whenProgressMode :: IO a -> IO () -whenProgressMode j = withProgressMode $ const $ j >> return () - -withProgressMode :: (Bool -> IO a) -> IO a -withProgressMode j = readIORef _progressMode >>= j - -data ProgressData = ProgressData { sofar :: !Int, - latest :: !(Maybe String), - total :: !(Maybe Int)} diff --git a/src/Darcs/ProgressPatches.hs b/src/Darcs/ProgressPatches.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/ProgressPatches.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} + +#include "gadts.h" +module Darcs.ProgressPatches (progressRL, progressFL, progressRLShowTags) +where +import Darcs.Ordered ( FL(..), RL(..), lengthRL, lengthFL ) +import Darcs.Hopefully (PatchInfoAnd,info) +import System.IO.Unsafe ( unsafePerformIO ) +import Progress (minlist, beginTedious, + endTedious, progress, progressKeepLatest, + tediousSize, finishedOne) +import Darcs.Patch.Info (just_name, is_tag) + + +-- | Evaluate an 'FL' list and report progress. +progressFL :: String -> FL a C(x y) -> FL a C(x y) +progressFL _ NilFL = NilFL +progressFL k (x:>:xs) = if l < minlist then x:>:xs + else startit x :>: pl xs + where l = lengthFL (x:>:xs) + startit y = unsafePerformIO $ do beginTedious k + tediousSize k l + return y + pl :: FL a C(x y) -> FL a C(x y) + pl NilFL = NilFL + pl (y:>:NilFL) = unsafePerformIO $ do endTedious k + return (y:>:NilFL) + pl (y:>:ys) = progress k y :>: pl ys + +-- | Evaluate an 'RL' list and report progress. +progressRL :: String -> RL a C(x y) -> RL a C(x y) +progressRL _ NilRL = NilRL +progressRL k (x:<:xs) = if l < minlist then x:<:xs + else startit x :<: pl xs + where l = lengthRL (x:<:xs) + startit y = unsafePerformIO $ do beginTedious k + tediousSize k l + return y + pl :: RL a C(x y) -> RL a C(x y) + pl NilRL = NilRL + pl (y:<:NilRL) = unsafePerformIO $ do endTedious k + return (y:<:NilRL) + pl (y:<:ys) = progress k y :<: pl ys + +-- | Evaluate an 'RL' list and report progress. In addition to printing +-- the number of patches we got, show the name of the last tag we got. +progressRLShowTags :: String -> RL (PatchInfoAnd p) C(x y) + -> RL (PatchInfoAnd p) C(x y) +progressRLShowTags _ NilRL = NilRL +progressRLShowTags k (x:<:xs) = if l < minlist then x:<:xs + else startit x :<: pl xs + where l = lengthRL (x:<:xs) + startit y = unsafePerformIO $ do beginTedious k + tediousSize k l + return y + pl :: RL (PatchInfoAnd p) C(x y) -> RL (PatchInfoAnd p) C(x y) + pl NilRL = NilRL + pl (y:<:NilRL) = unsafePerformIO $ do endTedious k + return (y:<:NilRL) + pl (y:<:ys) = + if is_tag iy + then finishedOne k ("back to "++ just_name iy) y :<: pl ys + else progressKeepLatest k y :<: pl ys + where + iy = info y diff --git a/src/Darcs/RepoPath.hs b/src/Darcs/RepoPath.hs --- a/src/Darcs/RepoPath.hs +++ b/src/Darcs/RepoPath.hs @@ -23,7 +23,7 @@ AbsolutePathOrStd, makeAbsoluteOrStd, ioAbsoluteOrStd, useAbsoluteOrStd, AbsoluteOrRemotePath, ioAbsoluteOrRemote, isRemote, - makeRelative, sp2fn, + sp2fn, FilePathOrURL(..), FilePathLike(toFilePath), getCurrentDirectory, setCurrentDirectory ) where @@ -96,16 +96,6 @@ simpleSubPath :: FilePath -> Maybe SubPath simpleSubPath x | is_relative x = Just $ SubPath $ FilePath.normalise $ map cleanup x | otherwise = Nothing - -makeRelative :: AbsolutePath -> AbsolutePath -> FilePath -makeRelative (AbsolutePath p1) (AbsolutePath p2) = mr p1 p2 - where mr x y | x == y = "." - mr x y | takedir x == takedir y = mr (dropdir x) (dropdir y) - mr x y = add_dotdots x y - add_dotdots "" y = dropWhile (=='/') y - add_dotdots x y = '.':'.':'/': add_dotdots (dropdir x) y - takedir = takeWhile (/='/') . dropWhile (=='/') - dropdir = dropWhile (/='/') . dropWhile (=='/') -- | Interpret a possibly relative path wrt the current working directory ioAbsolute :: FilePath -> IO AbsolutePath diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -44,12 +44,12 @@ unrevertUrl, applyToWorking, patchSetToPatches, createPristineDirectoryTree, createPartialsPristineDirectoryTree, - optimizeInventory, cleanRepository, checkPristineAgainstCwd, + optimizeInventory, cleanRepository, checkPristineAgainstSlurpy, getMarkedupFile, PatchSet, SealedPatchSet, PatchInfoAnd, setScriptsExecutable, checkUnrelatedRepos, - testTentative + testTentative, testRecorded ) where import System.Exit ( ExitCode(..), exitWith ) @@ -65,7 +65,7 @@ get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, get_unrecorded_in_files, read_repo, sync_repo, - prefsUrl, checkPristineAgainstCwd, checkPristineAgainstSlurpy, + prefsUrl, checkPristineAgainstSlurpy, add_to_pending, withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf, tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, @@ -78,7 +78,7 @@ optimizeInventory, cleanRepository, getMarkedupFile, setScriptsExecutable, - testTentative + testTentative, testRecorded ) import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) @@ -104,12 +104,13 @@ import Darcs.Repository.Prefs ( write_default_prefs ) import Darcs.Repository.Pristine ( createPristine, flagsToPristine ) import Darcs.Patch.Depends ( get_patches_beyond_tag ) -import Darcs.RepoPath ( toFilePath ) +import Darcs.SlurpDirectory ( empty_slurpy ) import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn ) import Darcs.External ( copyFileOrUrl, Cachable(..) ) -import Darcs.Progress ( debugMessage, progressFL, progressRL, tediousSize, +import Progress ( debugMessage, tediousSize, beginTedious, endTedious, progress ) -import Darcs.Lock ( withTempDir, writeBinFile ) +import Darcs.ProgressPatches (progressRLShowTags, progressFL) +import Darcs.Lock ( writeBinFile ) import Darcs.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped ) import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral, @@ -230,8 +231,7 @@ "--partial: hashed or darcs-2 repository detected, using --lazy instead" else if format_has HashedInventory rfto then do local_patches <- read_repo torepository - withTempDir "newpristine" $ \newpris -> - replacePristine torepository (toFilePath newpris) + replacePristineFromSlurpy torepository empty_slurpy let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $ mapRL_RL reverseRL local_patches sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply @@ -298,5 +298,5 @@ peekaboo x = case extractHash x of Left _ -> return () Right h -> fetchFileUsingCache c HashedPatchesDir h >> return () - sequence_ $ mapRL peekaboo $ progressRL "Copying patches" $ concatRL r + sequence_ $ mapRL peekaboo $ progressRLShowTags "Copying patches" $ concatRL r where putInfo = when (not $ Quiet `elem` opts) . putStrLn diff --git a/src/Darcs/Repository/ApplyPatches.hs b/src/Darcs/Repository/ApplyPatches.hs --- a/src/Darcs/Repository/ApplyPatches.hs +++ b/src/Darcs/Repository/ApplyPatches.hs @@ -28,7 +28,7 @@ import Darcs.Ordered ( FL(..), lengthFL, mapFL ) import Darcs.Flags ( DarcsFlag ) import Darcs.Utils ( putDocLnError ) -import Darcs.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) +import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) import Printer ( text ) apply_patches_with_feedback :: Patchy p => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO () diff --git a/src/Darcs/Repository/Cache.hs b/src/Darcs/Repository/Cache.hs --- a/src/Darcs/Repository/Cache.hs +++ b/src/Darcs/Repository/Cache.hs @@ -37,7 +37,7 @@ import Darcs.Flags ( Compression( .. ) ) import Darcs.Global ( darcsdir ) import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS ) -import Darcs.Progress ( progressList, debugMessage, debugFail ) +import Progress ( progressList, debugMessage, debugFail ) import Darcs.SlurpDirectory ( undefined_time ) import Darcs.URL ( is_file ) import Darcs.Utils ( withCurrentDirectory, catchall ) diff --git a/src/Darcs/Repository/Checkpoint.hs b/src/Darcs/Repository/Checkpoint.hs --- a/src/Darcs/Repository/Checkpoint.hs +++ b/src/Darcs/Repository/Checkpoint.hs @@ -138,8 +138,8 @@ changepps = concatFL . mapFL_FL changeps is_setprefFL :: Prim C(x y) -> EqCheck C(x y) -is_setprefFL p | is_setpref p = unsafeCoerceP IsEq - | otherwise = NotEq +is_setprefFL p | is_setpref p = NotEq + | otherwise = unsafeCoerceP IsEq write_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO () write_checkpoint repo@(Repo _ _ _ _) pinfo = do diff --git a/src/Darcs/Repository/DarcsRepo.lhs b/src/Darcs/Repository/DarcsRepo.lhs --- a/src/Darcs/Repository/DarcsRepo.lhs +++ b/src/Darcs/Repository/DarcsRepo.lhs @@ -63,7 +63,7 @@ import System.Directory ( doesDirectoryExist, createDirectoryIfMissing ) import Workaround ( renameFile ) import Darcs.Utils ( clarify_errors ) -import Darcs.Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) +import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr ) import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -88,10 +88,9 @@ reverseFL, mapFL, unsafeCoerceP, reverseRL, concatRL, mapRL, mapRL_RL ) import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo, - showPatchInfo, + showPatchInfo, is_tag ) import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) -import Darcs.Patch.Depends ( is_tag ) import Darcs.External ( gzFetchFilePS, fetchFilePS, copyFilesOrUrls, Cachable(..), cloneFile ) import Darcs.Lock ( writeBinFile, writeDocBinFile, appendDocBinFile, appendBinFile ) @@ -100,7 +99,7 @@ import Darcs.Repository.Pristine ( identifyPristine, applyPristine ) import Darcs.Global ( darcsdir ) import Darcs.Utils ( catchall ) -import Darcs.Progress ( progressFL ) +import Darcs.ProgressPatches ( progressFL ) import Printer ( text, (<>), Doc, ($$), empty ) import Darcs.Sealed ( Sealed(Sealed), seal, unseal ) \end{code} @@ -132,9 +131,6 @@ Nothing -> fail ("Couldn't parse patch file "++fn) return $ n2pia $ unsafeCoerceP pp -\end{code} - -\begin{code} --format_inventory is not exported for use outside of the DarcsRepo module --itself. format_inventory :: [PatchInfo] -> Doc @@ -234,9 +230,7 @@ revert_tentative_changes = do cloneFile (darcsdir++"/inventory") (darcsdir++"/tentative_inventory") writeBinFile (darcsdir++"/tentative_pristine") "" -\end{code} -\begin{code} copy_patches :: [DarcsFlag] -> FilePath -> FilePath -> [PatchInfo] -> IO () copy_patches opts dir out patches = do realdir <- toPath `fmap` ioAbsoluteOrRemote dir @@ -307,9 +301,7 @@ read_patch_ids inv = case readPatchInfo inv of Just (pinfo,r) -> pinfo : read_patch_ids r Nothing -> [] -\end{code} -\begin{code} read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)] read_checkpoints d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d diff --git a/src/Darcs/Repository/Format.hs b/src/Darcs/Repository/Format.hs --- a/src/Darcs/Repository/Format.hs +++ b/src/Darcs/Repository/Format.hs @@ -21,7 +21,7 @@ UseOldFashionedInventory ) ) import Darcs.Lock ( writeBinFile ) import Darcs.Utils ( catchall, prettyException ) -import Darcs.Progress ( beginTedious, endTedious, finishedOneIO ) +import Progress ( beginTedious, endTedious, finishedOneIO ) import Darcs.Global ( darcsdir ) import ByteStringUtils ( linesPS ) diff --git a/src/Darcs/Repository/HashedIO.hs b/src/Darcs/Repository/HashedIO.hs --- a/src/Darcs/Repository/HashedIO.hs +++ b/src/Darcs/Repository/HashedIO.hs @@ -46,7 +46,7 @@ import Darcs.Flags ( DarcsFlag, Compression( .. ), compression ) import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist ) import Darcs.Utils ( withCurrentDirectory ) -import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress ) +import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress ) import Darcs.Patch.FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn, break_on_dir, own_name, super_name ) diff --git a/src/Darcs/Repository/HashedRepo.hs b/src/Darcs/Repository/HashedRepo.hs --- a/src/Darcs/Repository/HashedRepo.hs +++ b/src/Darcs/Repository/HashedRepo.hs @@ -67,7 +67,7 @@ import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, Cachable( Uncachable ) ) import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile ) import Darcs.Utils ( withCurrentDirectory ) -import Darcs.Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO ) +import Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO ) #include "impossible.h" import Darcs.Ordered ( FL(..), RL(..), mapRL, mapFL, lengthRL ) diff --git a/src/Darcs/Repository/Internal.hs b/src/Darcs/Repository/Internal.hs --- a/src/Darcs/Repository/Internal.hs +++ b/src/Darcs/Repository/Internal.hs @@ -26,7 +26,7 @@ findRepository, amInRepository, amNotInRepository, slurp_pending, pristineFromWorking, revertRepositoryChanges, slurp_recorded, slurp_recorded_and_unrecorded, - withRecorded, checkPristineAgainstCwd, + withRecorded, checkPristineAgainstSlurpy, get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, get_unrecorded_in_files, @@ -48,7 +48,7 @@ PatchSet, SealedPatchSet, setScriptsExecutable, getRepository, rIO, - testTentative + testTentative, testRecorded ) where import Printer ( putDocLn, (<+>), text, ($$) ) @@ -60,7 +60,7 @@ import System.Cmd ( system ) import Darcs.External ( backupByCopying, clonePartialsTree ) import Darcs.IO ( runTolerantly, runSilently ) -import Darcs.Repository.Pristine ( identifyPristine, nopristine, checkPristine, +import Darcs.Repository.Pristine ( identifyPristine, nopristine, easyCreatePristineDirectoryTree, slurpPristine, syncPristine, easyCreatePartialsPristineDirectoryTree, createPristineFromWorking ) @@ -105,7 +105,7 @@ import qualified Darcs.Repository.DarcsRepo as DarcsRepo import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet, MarkConflicts, AllowConflicts, NoUpdateWorking, - RepoDir, WorkDir, UMask, Test, LeaveTestDir, + WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir, SetScriptsExecutable, DryRun, IgnoreTimes, Summary, NoSummary), want_external_merge, compression ) @@ -137,7 +137,8 @@ import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath, ioAbsoluteOrRemote, toPath ) import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort ) -import Darcs.Progress ( progressFL, debugMessage ) +import Progress ( debugMessage ) +import Darcs.ProgressPatches (progressFL) import Darcs.URL ( is_file ) import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function, getCaches ) @@ -242,7 +243,7 @@ currentDirIsRepository = isRight `liftM` maybeIdentifyRepository [] "." amInRepository :: [DarcsFlag] -> IO (Either String ()) -amInRepository (WorkDir d:_) = +amInRepository (WorkRepoDir d:_) = do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) air <- currentDirIsRepository if air @@ -273,10 +274,10 @@ return onFail amNotInRepository :: [DarcsFlag] -> IO (Either String ()) -amNotInRepository (WorkDir d:_) = do createDirectoryIfMissing False d - -- note that the above could always fail - setCurrentDirectory d - amNotInRepository [] +amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d + -- note that the above could always fail + setCurrentDirectory d + amNotInRepository [] amNotInRepository (_:f) = amNotInRepository f amNotInRepository [] = do air <- currentDirIsRepository @@ -284,10 +285,10 @@ else return $ Right () findRepository :: [DarcsFlag] -> IO (Either String ()) -findRepository (RepoDir d:_) | is_file d = +findRepository (WorkRepoUrl d:_) | is_file d = do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) findRepository [] -findRepository (WorkDir d:_) = +findRepository (WorkRepoDir d:_) = do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) findRepository [] findRepository (_:fs) = findRepository fs @@ -580,9 +581,10 @@ (effect them) pwprim debugMessage "Applying patches to the local directories..." when (mc == MakeChanges) $ - do case usi of - NilFL -> applyps r themi - _ -> applyps r (mapFL_FL n2pia pc) + do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO () + doChanges NilFL = applyps r themi + doChanges _ = applyps r (mapFL_FL n2pia pc) + doChanges usi setTentativePending r (effect pend' +>+ pw_resolution) return $ seal (effect pwprim +>+ pw_resolution) where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()] @@ -780,7 +782,16 @@ finalize_pending repository testTentative :: RepoPatch p => Repository p C(r u t) -> IO () -testTentative repository@(Repo dir opts _ _) = +testTentative = testAny withTentative + +testRecorded :: RepoPatch p => Repository p C(r u t) -> IO () +testRecorded = testAny withRecorded + +testAny :: RepoPatch p => (Repository p C(r u t) + -> ((AbsolutePath -> IO ()) -> IO ()) + -> (AbsolutePath -> IO ()) -> IO ()) + -> Repository p C(r u t) -> IO () +testAny withD repository@(Repo dir opts _ _) = when (Test `elem` opts) $ withCurrentDirectory dir $ do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ()) debugMessage "About to run test if it exists." @@ -788,7 +799,7 @@ case testline of Nothing -> return () Just testcode -> - withTentative repository (wd "testing") $ \_ -> + withD repository (wd "testing") $ \_ -> do putInfo "Running test...\n" when (SetScriptsExecutable `elem` opts) setScriptsExecutable ec <- system testcode @@ -975,14 +986,6 @@ withRecorded repository mk_dir f = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) f d - -checkPristineAgainstCwd :: RepoPatch p => Repository p C(r u t) -> IO Bool -checkPristineAgainstCwd (Repo dir _ rf (DarcsRepository p _)) - | not $ format_has HashedInventory rf = do here <- toPath `fmap` ioAbsoluteOrRemote "." - withCurrentDirectory dir $ checkPristine here p -checkPristineAgainstCwd r = - do s <- mmap_slurp "." - checkPristineAgainstSlurpy r s checkPristineAgainstSlurpy :: RepoPatch p => Repository p C(r u t) -> Slurpy -> IO Bool checkPristineAgainstSlurpy repository@(Repo _ opts _ _) s2 = diff --git a/src/Darcs/Repository/Prefs.lhs b/src/Darcs/Repository/Prefs.lhs --- a/src/Darcs/Repository/Prefs.lhs +++ b/src/Darcs/Repository/Prefs.lhs @@ -44,8 +44,7 @@ import System.FilePath ( () ) import Darcs.Flags ( DarcsFlag( NoCache, NoSetDefault, DryRun, Ephemeral, RemoteRepo ) ) -import Darcs.RepoPath ( AbsolutePath, ioAbsolute, makeRelative, toFilePath, - getCurrentDirectory ) +import Darcs.RepoPath ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory ) import Darcs.Utils ( catchall, stripCr ) import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) import Darcs.Patch.FileName ( fp2fn ) @@ -290,9 +289,7 @@ where abf fi (r:rs) = abf (\f -> fi f && isNothing (matchRegex r f)) rs abf fi [] = fi -\end{code} -\begin{code} normalize :: FilePath -> FilePath normalize ('.':'/':f) = normalize f normalize f = normalize_helper $ reverse f @@ -341,9 +338,7 @@ ftf f = if isbin $ normalize f then BinaryFile else TextFile in return ftf -\end{code} -\begin{code} -- this avoids a circular dependency with Repository prefsDirectory :: ReadableDirectory m => m String prefsDirectory = @@ -385,9 +380,7 @@ add_to_list :: Eq a => a -> [a] -> [a] add_to_list s [] = [s] add_to_list s (s':ss) = if s == s' then (s:ss) else s': add_to_list s ss -\end{code} -\begin{code} def_prefval :: String -> String -> IO String def_prefval p d = do pv <- get_prefval p @@ -417,14 +410,12 @@ Just old -> if old == f then return t else return old set_preflist "prefs" $ filter ((/=p).fst.(break(==' '))) pl ++ [p++" "++newval] -\end{code} -\begin{code} defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] -defaultrepo opts orig [] = +defaultrepo opts _ [] = do let fixR r | not (is_file r) = return r | otherwise = do absr <- ioAbsolute r - return $ toFilePath $ makeRelative orig absr + return $ toFilePath absr case [r | RemoteRepo r <- opts] of [] -> do defrepo <- get_preflist "defaultrepo" case defrepo of diff --git a/src/Darcs/Repository/Pristine.hs b/src/Darcs/Repository/Pristine.hs --- a/src/Darcs/Repository/Pristine.hs +++ b/src/Darcs/Repository/Pristine.hs @@ -23,7 +23,7 @@ module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine, createPristine, removePristine, identifyPristine, - checkPristine, slurpPristine, + slurpPristine, applyPristine, createPristineFromWorking, syncPristine, replacePristine, replacePristineFromSlurpy, getPristinePop, @@ -37,7 +37,7 @@ import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, renameDirectory, removeFile ) import Darcs.Lock ( rm_recursive, writeBinFile ) -import Darcs.Diff ( cmp, sync ) +import Darcs.Diff ( sync ) import Workaround ( getCurrentDirectory ) import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, writeSlurpy ) import Darcs.Utils ( catchall ) @@ -121,13 +121,6 @@ removePristine (NoPristine n) = removeFile n removePristine (PlainPristine n) = rm_recursive n removePristine HashedPristine = rm_recursive hashedPristineDirectory - -checkPristine :: FilePath -> Pristine -> IO Bool -checkPristine _ (NoPristine _) = return True -checkPristine path (PlainPristine n) = do cwd <- getCurrentDirectory - cmp (cwd ++ "/" ++ n) path -checkPristine _ HashedPristine = - bug "HashedPristine is not implemented yet." slurpPristine :: Pristine -> IO (Maybe Slurpy) slurpPristine (PlainPristine n) = do cwd <- getCurrentDirectory diff --git a/src/Darcs/Repository/Repair.hs b/src/Darcs/Repository/Repair.hs --- a/src/Darcs/Repository/Repair.hs +++ b/src/Darcs/Repository/Repair.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + module Darcs.Repository.Repair ( replayRepository, RepositoryConsistency(..) ) where @@ -16,7 +19,7 @@ mapRL ) import Darcs.Patch.Depends ( get_patches_beyond_tag ) import Darcs.Patch.Patchy ( applyAndTryToFix ) -import Darcs.Patch.Info ( human_friendly ) +import Darcs.Patch.Info ( PatchInfo( .. ), human_friendly ) import Darcs.Patch.Set ( PatchSet ) import Darcs.Patch ( RepoPatch, patch2patchinfo ) @@ -33,12 +36,13 @@ makePatchLazy ) import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) -import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) +import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) import Darcs.Utils ( catchall ) import Darcs.Global ( darcsdir ) import Darcs.Flags ( compression ) import Printer ( Doc, putDocLn, text ) import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) ) +#include "impossible.h" run_slurpy :: Slurpy -> SlurpMonad a -> IO (Slurpy, a) run_slurpy s f = @@ -54,27 +58,36 @@ clean_hashdir c HashedPristineDir $ catMaybes [Just h, current] return s' -applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO ((FL (PatchInfoAnd p)), Slurpy, Bool) +replaceInFL :: FL (PatchInfoAnd a) + -> [(PatchInfo, PatchInfoAnd a)] + -> FL (PatchInfoAnd a) +replaceInFL orig [] = orig +replaceInFL NilFL _ = impossible +replaceInFL (o:>:orig) ch@((o',c):ch_rest) + | info o == o' = c:>:replaceInFL orig ch_rest + | otherwise = o:>:replaceInFL orig ch + +applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO (FL (PatchInfoAnd p), Slurpy, Bool) applyAndFix _ _ s _ NilFL = return (NilFL, s, True) applyAndFix c opts s_ r psin = do beginTedious k tediousSize k $ lengthFL psin - ps <- aaf s_ psin + (repaired, slurpy, ok) <- aaf s_ psin endTedious k - return ps + orig <- (reverseRL . concatRL) `fmap` read_repo r + return (replaceInFL orig repaired, slurpy, ok) where k = "Replaying patch" - aaf s NilFL = return (NilFL, s, True) + aaf s NilFL = return ([], s, True) aaf s (p:>:ps) = do (s', mp') <- run_slurpy s $ applyAndTryToFix p finishedOneIO k $ show $ human_friendly $ info p - (p', ourok) <- case mp' of - Nothing -> return (p, True) - Just (e,pp) -> do putStrLn e - return (pp, False) - p'' <- makePatchLazy r p' s'' <- syncSlurpy (update_slurpy r c opts) s' (ps', s''', restok) <- aaf s'' ps - return ((p'':>:ps'), s''', restok && ourok) + case mp' of + Nothing -> return (ps', s''', restok) + Just (e,pp) -> do putStrLn e + p' <- makePatchLazy r pp + return ((info p, p'):ps', s''', False) data RepositoryConsistency p = RepositoryConsistent diff --git a/src/Darcs/Resolution.lhs b/src/Darcs/Resolution.lhs --- a/src/Darcs/Resolution.lhs +++ b/src/Darcs/Resolution.lhs @@ -47,7 +47,6 @@ import Darcs.Diff ( unsafeDiff ) import Darcs.Sealed ( Sealed(..) ) import Darcs.Repository.Prefs ( filetype_function ) -import Darcs.Flags ( DarcsFlag(LookForAdds) ) import Exec ( exec, Redirect(..) ) import Darcs.Lock ( withTempDir ) import Darcs.External ( cloneTree ) @@ -56,9 +55,7 @@ --import Darcs.ColorPrinter ( traceDoc ) --import Printer ( greenText, ($$), Doc ) --import Darcs.Patch ( showPatch ) -\end{code} -\begin{code} standard_resolution :: RepoPatch p => p C(x y) -> Sealed (FL Prim C(y)) standard_resolution p = merge_list $ map head $ resolve_conflicts p @@ -194,7 +191,7 @@ sc <- slurp dc sfixed <- slurp dm ftf <- filetype_function - case unsafeDiff [LookForAdds] ftf sc sfixed of + case unsafeDiff [] ftf sc sfixed of di -> lengthFL di `seq` return (Sealed di) -- The `seq` above forces the two slurpies to be read before -- we delete their directories. @@ -207,7 +204,7 @@ ec <- run c [('1', d1///f1), ('2', d2///f2), ('a', da///fa), ('o', dm///fm), ('%', "%")] when (ec /= ExitSuccess) $ putStrLn $ "External merge command exited with " ++ show ec - askUser "Hit return to move on..." + askUser "Hit return to move on, ^C to abort the whole operation..." return () run :: String -> [(Char,String)] -> IO ExitCode @@ -222,9 +219,7 @@ (///) :: FilePath -> FilePath -> FilePath d /// f = d ++ "/" ++ f -\end{code} -\begin{code} patchset_conflict_resolutions :: RepoPatch p => PatchSet p C(x) -> Sealed (FL Prim C(x)) patchset_conflict_resolutions (NilRL:<:_) = --traceDoc (greenText "no conflicts A") $ Sealed NilFL diff --git a/src/Darcs/RunCommand.hs b/src/Darcs/RunCommand.hs --- a/src/Darcs/RunCommand.hs +++ b/src/Darcs/RunCommand.hs @@ -49,7 +49,7 @@ import Darcs.Global ( setDebugMode, setSshControlMasterDisabled, setTimingsMode, setVerboseMode ) import Darcs.Match ( checkMatchSyntax ) -import Darcs.Progress ( setProgressMode ) +import Progress ( setProgressMode ) import Darcs.RepoPath ( getCurrentDirectory ) import Darcs.Test ( run_posthook, run_prehook ) import Darcs.Utils ( formatPath ) diff --git a/src/Darcs/SelectChanges.hs b/src/Darcs/SelectChanges.hs --- a/src/Darcs/SelectChanges.hs +++ b/src/Darcs/SelectChanges.hs @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -cpp -fffi -fglasgow-exts #-} +{-# OPTIONS_GHC -fglasgow-exts #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} -- , ScopedTypeVariables, TypeOperators, PatternGuards #-} @@ -47,6 +47,7 @@ import Darcs.Patch ( RepoPatch, Patchy, Prim, summary, invert, list_touched_files, commuteFL ) +import Darcs.Patch.Patchy ( showPatch ) import qualified Darcs.Patch ( thing, things ) import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+), lengthFL, concatRL, mapFL_FL, @@ -453,7 +454,8 @@ , KeyPress 'f' (jn++" the rest of the changes to this file") ] options_view = [ KeyPress 'v' ("view this "++thing++" in full") - , KeyPress 'p' ("view this "++thing++" in full with pager") ] + , KeyPress 'p' ("view this "++thing++" in full with pager") + , KeyPress 'l' ("list all selected "++things) ] options_summary = [ KeyPress 'x' ("view a summary of this "++thing) ] options_quit = @@ -482,6 +484,18 @@ 'f' -> do_next_action "Included" (Noun "change") $ do_file 'v' -> printPatch `unseal2` viewp >> repeat_this 'p' -> printPatchPager `unseal2` viewp >> repeat_this + 'l' -> do let selected = case get_choices pc of + (first_chs:>_:>last_chs) -> + if whichch == Last || whichch == FirstReversed + then map_patches last_chs + else map_patches first_chs + map_patches = mapFL (\a -> + showPatch `unseal2` (seal2 $ tp_patch a)) + putStrLn $ "---- Already selected "++things++" ----" + mapM_ putDocLn $ selected + putStrLn $ "---- end of already selected "++things++" ----" + (printFriendly opts) `unseal2` viewp + repeat_this 'x' -> do (putDocLn . prefix " " . summary) `unseal2` viewp repeat_this 'd' -> return pc @@ -536,11 +550,13 @@ putStr "\n" repeat_this -- prompt the user where + prev_patch :: IO ((PatchChoices p) C(r s)) prev_patch = case tps_done of NilRL -> repeat_this (tp':<:tps_done') -> text_view opts n_max (n-1) tps_done' (tp':>:tps_todo) pc + next_patch :: IO ((PatchChoices p) C(r s)) next_patch = case tps_todo' of NilFL -> -- May as well work out the length now we have all -- the patches in memory diff --git a/src/Darcs/Test.lhs b/src/Darcs/Test.lhs --- a/src/Darcs/Test.lhs +++ b/src/Darcs/Test.lhs @@ -16,7 +16,7 @@ % Boston, MA 02110-1301, USA. \begin{code} -module Darcs.Test ( run_test, get_test, +module Darcs.Test ( get_test, run_posthook, run_prehook ) where import Darcs.RepoPath ( AbsolutePath ) @@ -57,10 +57,6 @@ section~\ref{defaults}). \begin{code} -run_test :: [DarcsFlag] -> AbsolutePath -> IO ExitCode -run_test opts testdir = do test <- get_test opts - withCurrentDirectory testdir test - get_test :: [DarcsFlag] -> IO (IO ExitCode) get_test opts = let putInfo s = when (not $ Quiet `elem` opts) $ putStr s @@ -76,9 +72,7 @@ then putInfo "Test ran successfully.\n" else putInfo "Test failed!\n" return ec -\end{code} -\begin{code} run_posthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode run_posthook opts repodir = do ph <- get_posthook opts withCurrentDirectory repodir $ run_hook opts "Posthook" ph diff --git a/src/Darcs/Utils.hs b/src/Darcs/Utils.hs --- a/src/Darcs/Utils.hs +++ b/src/Darcs/Utils.hs @@ -1,6 +1,5 @@ -- Various utility functions that do not belong anywhere else. -{-# OPTIONS_GHC -cpp -fffi #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand, @@ -43,7 +42,7 @@ import Foreign.C.Error ( throwErrno ) import Foreign.C.Types ( CInt ) -import Darcs.Progress ( withoutProgress ) +import Progress ( withoutProgress ) #ifdef HAVE_HASKELINE import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine ) diff --git a/src/Exec.hs b/src/Exec.hs --- a/src/Exec.hs +++ b/src/Exec.hs @@ -16,7 +16,7 @@ -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -cpp -fffi -fglasgow-exts #-} +{-# OPTIONS_GHC -fglasgow-exts #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} -- , DeriveDataTypeable #-} @@ -48,7 +48,7 @@ import Control.Exception ( bracketOnError ) import Darcs.Global ( whenDebugMode ) -import Darcs.Progress ( withoutProgress ) +import Progress ( withoutProgress ) {- A redirection is a three-tuple of values (in, out, err). diff --git a/src/Progress.hs b/src/Progress.hs new file mode 100644 --- /dev/null +++ b/src/Progress.hs @@ -0,0 +1,202 @@ +-- Various utility functions that do not belong anywhere else. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Progress ( beginTedious, endTedious, tediousSize, + debugMessage, debugFail, withoutProgress, + progress, progressKeepLatest, finishedOne, + finishedOneIO, progressList, minlist, + setProgressMode) where + +import Prelude hiding (lookup, catch) + +import Control.Exception ( catch, throw ) +import Control.Monad ( when ) +import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn, + hSetBuffering, hIsTerminalDevice, + Handle, BufferMode(LineBuffering) ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.Char ( toLower ) +import Data.Map ( Map, empty, adjust, insert, delete, lookup ) +import Data.Maybe ( isJust ) +import Control.Concurrent ( forkIO, threadDelay ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) + +import Darcs.Global ( withDebugMode, debugMessage, putTiming, debugFail ) + +handleProgress :: IO () +handleProgress = do threadDelay 1000000 + handleMoreProgress "" 0 + +handleMoreProgress :: String -> Int -> IO () +handleMoreProgress k n = withProgressMode $ \m -> + if m then do s <- getProgressLast + mp <- getProgressData s + case mp of + Nothing -> do threadDelay 1000000 + handleMoreProgress k n + Just p -> do when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p + threadDelay 1000000 + handleMoreProgress s (sofar p) + else do threadDelay 1000000 + handleMoreProgress k n + +printProgress :: String -> ProgressData -> IO () +printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) = + myput (k++" "++show s++"/"++show t++" : "++l) (k++" "++show s++"/"++show t) +printProgress k (ProgressData {latest=Just l}) = + myput (k++" "++l) k +printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s = + myput (k++" "++show s++"/"++show t) (k++" "++show s) +printProgress k (ProgressData {sofar=s}) = + myput (k++" "++show s) k + +myput :: String -> String -> IO () +myput l s = withDebugMode $ \debugMode -> + if debugMode + then putTiming >> hPutStrLn stderr l + else if '\n' `elem` l + then myput (takeWhile (/= '\n') l) s + else if length l < 80 then putTiming >> simpleput l + else putTiming >> simpleput (take 80 s) + +{-# NOINLINE simpleput #-} +simpleput :: String -> IO () +simpleput = unsafePerformIO $ mkhPutCr stderr + +-- | @beginTedious k@ starts a tedious process and registers it in +-- '_progressData' with the key @k@. A tedious process is one for which we +-- want a progress indicator. +-- +-- Wouldn't it be safer if it had type String -> IO +-- ProgressDataKey, so that we can ensure there is no collision? +-- What happens if you call beginTedious twice with the same string, without +-- calling endTedious in the meantime? +beginTedious :: String -> IO () +beginTedious k = do debugMessage $ "Beginning " ++ (map toLower k) + setProgressData k $ ProgressData { sofar = 0, + latest = Nothing, + total = Nothing } + +-- | @endTedious k@ unregisters the tedious process with key @k@, printing "Done" if such +-- a tedious process exists. +endTedious :: String -> IO () +endTedious k = whenProgressMode $ do p <- getProgressData k + modifyIORef _progressData (\(a,m) -> (a,delete k m)) + when (isJust p) $ debugMessage $ "Done "++ + (map toLower k) + +tediousSize :: String -> Int -> IO () +tediousSize k s = updateProgressData k uptot + where uptot p = case total p of Just t -> seq ts $ p { total = Just ts } + where ts = t + s + Nothing -> p { total = Just s } + +minlist :: Int +minlist = 4 + +progressList :: String -> [a] -> [a] +progressList _ [] = [] +progressList k (x:xs) = if l < minlist then x:xs + else startit x : pl xs + where l = length (x:xs) + startit y = unsafePerformIO $ do beginTedious k + tediousSize k l + return y + pl [] = [] + pl [y] = unsafePerformIO $ do endTedious k + return [y] + pl (y:ys) = progress k y : pl ys + + +progress :: String -> a -> a +progress k a = unsafePerformIO $ progressIO k >> return a + +progressIO :: String -> IO () +progressIO "" = return () +progressIO k = do updateProgressData k (\p -> p { sofar = sofar p + 1, + latest = Nothing }) + putDebug k "" + +progressKeepLatest :: String -> a -> a +progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a + +progressKeepLatestIO :: String -> IO () +progressKeepLatestIO "" = return () +progressKeepLatestIO k = do updateProgressData k (\p -> p {sofar = sofar p + 1}) + putDebug k "" + +finishedOne :: String -> String -> a -> a +finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a + +finishedOneIO :: String -> String -> IO () +finishedOneIO "" _ = return () +finishedOneIO k l = do updateProgressData k (\p -> p { sofar = sofar p + 1, + latest = Just l }) + putDebug k l + +putDebug :: String -> String -> IO () +putDebug _ _ = return () +--putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k +--putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l + +{-# NOINLINE _progressMode #-} +_progressMode :: IORef Bool +_progressMode = unsafePerformIO $ do hSetBuffering stderr LineBuffering + newIORef True + +{-# NOINLINE _progressData #-} +_progressData :: IORef (String, Map String ProgressData) +_progressData = unsafePerformIO $ do forkIO handleProgress + newIORef ("", empty) + +mkhPutCr :: Handle -> IO (String -> IO ()) +mkhPutCr fe = do + isTerm <- hIsTerminalDevice fe + stdoutIsTerm <- hIsTerminalDevice stdout + return $ if isTerm then \s -> do hPutStr fe $ '\r':s++"\r" + hFlush fe + let spaces = '\r':replicate (length s) ' '++"\r" + hPutStr fe spaces + when stdoutIsTerm $ hPutStr stdout spaces + else \s -> when (not $ null s) $ do hPutStrLn fe s + hFlush fe + +setProgressMode :: Bool -> IO () +setProgressMode m = writeIORef _progressMode m + +withoutProgress :: IO a -> IO a +withoutProgress j = withProgressMode $ \m -> do debugMessage "Disabling progress reports..." + setProgressMode False + a <- j `catch` \e -> setProgressMode m >> throw e + if m then debugMessage "Reenabling progress reports." + else debugMessage "Leaving progress reports off." + setProgressMode m + return a + +updateProgressData :: String -> (ProgressData -> ProgressData) -> IO () +updateProgressData k f = whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m)) + +setProgressData :: String -> ProgressData -> IO () +setProgressData k p = whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m)) + +getProgressData :: String -> IO (Maybe ProgressData) +getProgressData k = withProgressMode $ \p -> if p then (lookup k . snd) `fmap` readIORef _progressData + else return Nothing + +getProgressLast :: IO String +getProgressLast = withProgressMode $ \p -> if p then fst `fmap` readIORef _progressData + else return "" + +whenProgressMode :: IO a -> IO () +whenProgressMode j = withProgressMode $ const $ j >> return () + +withProgressMode :: (Bool -> IO a) -> IO a +withProgressMode j = readIORef _progressMode >>= j + +data ProgressData = ProgressData { sofar :: !Int, + latest :: !(Maybe String), + total :: !(Maybe Int)} diff --git a/src/Ssh.hs b/src/Ssh.hs --- a/src/Ssh.hs +++ b/src/Ssh.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -cpp -fffi #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Ssh ( grabSSH, runSSH, getSSH, copySSH, copySSHs, SSHCmd(..) ) where @@ -28,7 +27,7 @@ import Darcs.Global ( atexit, sshControlMasterDisabled, darcsdir, withDebugMode ) import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist ) import Exec ( exec, Redirects, Redirect(..), ) -import Darcs.Progress ( withoutProgress, debugMessage, debugFail, progressList ) +import Progress ( withoutProgress, debugMessage, debugFail, progressList ) import qualified Data.ByteString as B (ByteString, hGet, writeFile, readFile) import qualified Data.ByteString.Char8 as BC (unpack) diff --git a/src/URL.hs b/src/URL.hs --- a/src/URL.hs +++ b/src/URL.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -cpp -fffi #-} {-# LANGUAGE CPP, ForeignFunctionInterface #-} module URL ( copyUrl, copyUrlFirst, pipeliningEnabledByDefault, @@ -22,9 +21,12 @@ import Workaround ( renameFile ) import Darcs.Global ( atexit ) -import Darcs.Progress ( debugFail, debugMessage ) +import Progress ( debugFail, debugMessage ) import Darcs.Lock ( removeFileMayNotExist ) +import Numeric ( showHex ) +import System.Random ( randomRIO ) + #if defined(HAVE_CURL) || defined(HAVE_LIBWWW) import Foreign.C.String ( withCString, peekCString, CString ) #elif defined(HAVE_HTTP) @@ -46,7 +48,8 @@ , Cachable , (MVar String) ) , waitToStart :: Q String - , pipeLength :: Int } + , pipeLength :: Int + , randomJunk :: String } data Q a = Q [a] [a] @@ -109,8 +112,10 @@ return ch urlThread :: Chan UrlRequest -> IO () -urlThread ch = evalStateT urlThread' (UrlState Map.empty emptyQ 0) - where urlThread' = do +urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange + evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk) + where rrange = (0, 2^(128 :: Integer) :: Integer) + urlThread' = do empty <- liftIO $ isEmptyChan ch st <- get let l = pipeLength st @@ -184,7 +189,7 @@ , pipeLength = l + 1 } dbg ("URL.request_url ("++u++"\n"++ " -> "++f++")") - let f_new = f++"-new" + let f_new = f++"-new_"++randomJunk st liftIO $ do err <- request_url u f_new c if null err then do atexit $ removeFileMayNotExist f_new @@ -224,22 +229,22 @@ liftIO $ if null e then case Map.lookup u p of Just (f, fs, _, v) -> do - renameFile (f++"-new") f - mapM_ (safeCopyFile f) fs + renameFile (f++"-new_"++randomJunk st) f + mapM_ (safeCopyFile st f) fs putMVar v e debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u else case Map.lookup u p of Just (f, _, _, v) -> do - removeFileMayNotExist (f++"-new") + removeFileMayNotExist (f++"-new_"++randomJunk st) putMVar v e debugMessage $ "URL.waitNextUrl failed: "++ u++" "++f++" "++e Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++u++" "++e unless (null u) $ put new_st - where safeCopyFile f t = let new_t = t++"-new" - in do copyFile f new_t - renameFile new_t t + where safeCopyFile st f t = let new_t = t++"-new_"++randomJunk st + in do copyFile f new_t + renameFile new_t t waitUrl :: String -> IO () waitUrl u = do debugMessage $ "URL.waitUrl "++u diff --git a/src/UTF8.lhs b/src/UTF8.lhs --- a/src/UTF8.lhs +++ b/src/UTF8.lhs @@ -31,12 +31,18 @@ 2002-09-02 Sven Moritz Hallberg +> {-# OPTIONS_GHC -cpp #-} > module UTF8 > ( encode ) where +#ifdef HAVE_UTF8STRING +> import qualified Codec.Binary.UTF8.String (encode) +> import Data.Word (Word8) +#else > import Data.Char (ord) > import Data.Word (Word8, Word16, Word32) > import Data.Bits (Bits, shiftR, (.&.), (.|.)) +#endif @@ -79,6 +85,7 @@ It dispatches the actual encoding to functions specific to the number of required bytes. +#ifndef HAVE_UTF8STRING > encodeOne :: Char -> [Word8] > encodeOne c >-- The report guarantees in (6.1.2) that this won't happen: @@ -96,12 +103,18 @@ > n8 = fromIntegral n :: Word8 > n16 = fromIntegral n :: Word16 > n32 = fromIntegral n :: Word32 +#endif With the above, a stream decoder is trivial: + > encode :: [Char] -> [Word8] +#ifdef HAVE_UTF8STRING +> encode = Codec.Binary.UTF8.String.encode +#else > encode = concatMap encodeOne +#endif Now follow the individual encoders for certain numbers of bytes... @@ -111,22 +124,27 @@ /.==| \\ //_ // // It's // || // \_/_//_//_ and it's here to stay! +#ifndef HAVE_UTF8STRING > encodeOne_onebyte :: Word8 -> [Word8] > encodeOne_onebyte cp = [cp] +#endif 00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx +#ifndef HAVE_UTF8STRING > encodeOne_twobyte :: Word16 -> [Word8] > encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)] > where > xs, ys :: Word8 > ys = fromIntegral (shiftR cp 6) > xs = (fromIntegral cp) .&. 0x3F +#endif zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx +#ifndef HAVE_UTF8STRING > encodeOne_threebyte :: Word16 -> [Word8] > encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)] > where @@ -134,10 +152,12 @@ > xs = (fromIntegral cp) .&. 0x3F > ys = (fromIntegral (shiftR cp 6)) .&. 0x3F > zs = fromIntegral (shiftR cp 12) +#endif 000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx +#ifndef HAVE_UTF8STRING > encodeOne_fourbyte :: Word32 -> [Word8] > encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs] > where @@ -146,3 +166,4 @@ > ys = (fromIntegral (shiftR cp 6)) .&. 0x3F > zs = (fromIntegral (shiftR cp 12)) .&. 0x3F > us = fromIntegral (shiftR cp 18) +#endif diff --git a/src/unit.lhs b/src/unit.lhs --- a/src/unit.lhs +++ b/src/unit.lhs @@ -45,9 +45,7 @@ {-# LANGUAGE CPP #-} module Main (main) where -\end{code} -\begin{code} import Control.Monad (when) import System.IO.Unsafe ( unsafePerformIO ) import ByteStringUtils @@ -792,17 +790,13 @@ t_test_check p = if check_a_patch p then [] else ["Failed the check: "++show p++"\n"] -\end{code} -\begin{code} prop_hex_conversion :: String -> Bool prop_hex_conversion s = fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s prop_concatPS :: [String] -> Bool prop_concatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss) -\end{code} -\begin{code} check_subcommutes :: Testable a => [(String, a)] -> String -> IO () check_subcommutes [] _ = return () check_subcommutes ((n,c):r) expl = diff --git a/src/win32/CtrlC.hs b/src/win32/CtrlC.hs --- a/src/win32/CtrlC.hs +++ b/src/win32/CtrlC.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fffi #-} {-# LANGUAGE ForeignFunctionInterface #-} module CtrlC (withCtrlCHandler) where diff --git a/src/win32/System/Posix.hs b/src/win32/System/Posix.hs --- a/src/win32/System/Posix.hs +++ b/src/win32/System/Posix.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fglasgow-exts -fffi #-} +{-# OPTIONS_GHC -fglasgow-exts #-} {-# LANGUAGE ForeignFunctionInterface #-} module System.Posix where diff --git a/tests/example_binary.png b/tests/example_binary.png new file mode 100644 Binary files /dev/null and b/tests/example_binary.png differ diff --git a/tests/filepath.sh b/tests/filepath.sh --- a/tests/filepath.sh +++ b/tests/filepath.sh @@ -4,8 +4,6 @@ . lib -# ugly hack for Cygwin and hspwd -IFS='' DIR=`hspwd` rm -rf temp1 temp2 diff --git a/tests/issue1057.sh b/tests/issue1057.sh --- a/tests/issue1057.sh +++ b/tests/issue1057.sh @@ -16,7 +16,6 @@ ln -s repo srepo cd srepo -IFS='' # annoying hack for cygwin and hspwd below DIR=`hspwd` echo $DIR not darcs pull --debug -a "$DIR" 2> out diff --git a/tests/lib b/tests/lib new file mode 100644 --- /dev/null +++ b/tests/lib @@ -0,0 +1,13 @@ +# This is a -*- sh -*- library. +set -ev + +## I would use the builtin !, but that has the wrong semantics. +not () { "$@" && exit 1 || :; } + +# trick: OS-detection (if needed) +abort_windows () { +if echo $OS | grep -i windows; then + echo This test does not work on Windows + exit 0 +fi +} diff --git a/tests/no_pristine.sh b/tests/no_pristine.sh deleted file mode 100644 --- a/tests/no_pristine.sh +++ /dev/null @@ -1,32 +0,0 @@ -#!/usr/bin/env bash - -# This test script, originally written by David Roundy and Ian Lynagh is in -# the public domain. - -set -ev - -rm -rf temp1 - -mkdir temp1 -cd temp1 - -darcs initialize --no-pristine-tree -echo ALL --author Testing Person >> _darcs/prefs/defaults -echo ALL --ignore-times >> _darcs/prefs/defaults - -echo foo > bar -darcs add bar -darcs record -a -m baz bar - -date > bar -darcs record --no-test -a -m 'patch 2' - -darcs setpref test 'echo hello world' -darcs record -a -m 'setpref' - -date >> bar -darcs record -a -m 'record with test' - -cd .. - -rm -rf temp1 diff --git a/tests/query_manifest.sh b/tests/query_manifest.sh --- a/tests/query_manifest.sh +++ b/tests/query_manifest.sh @@ -2,7 +2,6 @@ set -ev check_manifest () { - IFS=' ' : > files.tmp echo . > dirs.tmp echo . > files-dirs.tmp @@ -20,9 +19,7 @@ for x in files dirs files-dirs ; do sort $x.tmp >sorted-$x.tmp diff sorted-$x.tmp darcs-$x.tmp - done - IFS='' -} + done } rm -rf temp mkdir temp diff --git a/tests/repair-corrupt.sh b/tests/repair-corrupt.sh new file mode 100644 --- /dev/null +++ b/tests/repair-corrupt.sh @@ -0,0 +1,53 @@ +. lib + +rm -rf bad +mkdir bad +cd bad +darcs init + +echo foo > bar +darcs add bar +darcs rec -a -m 'foo' + +echo hey > foo +darcs add foo +darcs rec -a -m 'more foo' + +hashed=false +test -e _darcs/hashed_inventory && hashed=true + +# produce a corrupt patch +echo 'rmfile foo' > _darcs/patches/pending +$hashed || echo -n > _darcs/pristine/foo +darcs rec -a -m 'remove foo' + +not darcs check # unapplicable patch! + +# stash away contents of _darcs +cp -R _darcs/ _backup_darcs + +echo here > bar +darcs rec -a -m 'here' + +# corrupt pristine content +$hashed && inv=`grep ^pristine _darcs/hashed_inventory` +cp _backup_darcs/patches/* _darcs/patches/ +cp _backup_darcs/*inventory* _darcs/ +$hashed && { + cp _darcs/hashed_inventory hashed.tmp + sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory + rm hashed.tmp +} + +not darcs check # just a little paranoia + +darcs repair # repair succeeds +darcs check # and the resulting repo is consistent + +# *AND* it contains what we expect... +darcs show contents bar > foobar +echo foo > foobar1 +diff foobar foobar1 + +cd .. +rm -rf bad diff --git a/tests/toolbox.sh b/tests/toolbox.sh --- a/tests/toolbox.sh +++ b/tests/toolbox.sh @@ -2,9 +2,6 @@ . lib -# setting IFS is an ugly hack for Cygwin -# so that the hspwd backtick -IFS='' DIR=`hspwd` abort_windows