[darcs-devel] Getting a repository into a slurpy
Edwin Thomson
edwin.thomson at businesswebsoftware.com
Tue Aug 29 05:29:55 PDT 2006
Hello
I've made a patch that modifies diff to apply patches to in-memory
copies of the repository rather than on disk. As per David's
suggestion, it only does this when passed the --store-in-memory flag.
This is a huge speedup for the repositories I use a lot, when looking at
patches near the top of the pile.
It corresponds to (2) in David's list of suggestions for increasingly
useful versions. (3) seems rather tricky, because of renames. Is there
likely to be a cunning way to take advantage of Haskell's laziness to
deal with that?
I'm not really familiar with either Haskell or the darcs code, so I
don't know how sensible the way I've done things is (and there is more
duplicated code than I'd like, but I don't know how to get rid of it
without tangling myself up). I'm happy to take suggestions for
improvement and re-record the patch.
Edwin
David Roundy wrote:
> (1) do all patch application in memory and then write them to disk
> (2) Do (1), but when writing to disk, only write the files (from the
> Slurpy) that you actually want to diff.
> (3) Remove unwanted files from the Slurpy *before* applying patches
-------------- next part --------------
New patches:
[Added --store-in-memory option for diff
edwin.thomson at businesswebsoftware.com**20060829091335
] {
hunk ./DarcsArguments.lhs 65
+ store_in_memory,
hunk ./DarcsArguments.lhs 200
- diff_cmd_flag,
+ diff_cmd_flag, store_in_memory,
hunk ./DarcsArguments.lhs 615
+store_in_memory = DarcsNoArgOption [] ["store-in-memory"] StoreInMemory
+ "do patch application in memory rather than on disk"
hunk ./DarcsFlags.lhs 72
+ | StoreInMemory
hunk ./DiffCommand.lhs 28
-import DarcsArguments ( DarcsFlag(DiffFlags, Unified, DiffCmd),
- match_range,
+import DarcsArguments ( DarcsFlag(DiffFlags, Unified, DiffCmd, StoreInMemory),
+ match_range, store_in_memory,
hunk ./DiffCommand.lhs 33
-import Match ( get_first_match, get_second_match,
+import Match ( get_first_match, get_second_match, get_first_match_s, get_second_match_s, apply_patches_to_some_files,
hunk ./DiffCommand.lhs 79
- working_repo_dir]}
+ working_repo_dir, store_in_memory]}
hunk ./DiffCommand.lhs 177
- then withCurrentDirectory odir $ get_first_match formerdir opts
+ then withCurrentDirectory odir $ first_application formerdir
hunk ./DiffCommand.lhs 182
- then withCurrentDirectory ndir $ get_second_match formerdir opts
+ then withCurrentDirectory ndir $ second_application formerdir
hunk ./DiffCommand.lhs 210
+ first_application dir = if StoreInMemory `elem` opts
+ then apply_patches_to_some_files dir path_list $ get_first_match_s opts
+ else get_first_match dir opts
+ second_application dir = if StoreInMemory `elem` opts
+ then apply_patches_to_some_files dir path_list $ get_second_match_s opts
+ else get_second_match dir opts
hunk ./Match.lhs 20
- get_first_match, get_second_match,
+ get_first_match, get_second_match, get_first_match_s, get_second_match_s,
hunk ./Match.lhs 22
- have_patchset_match, get_one_patchset,
+ have_patchset_match, get_one_patchset, apply_patches_to_some_files
hunk ./Match.lhs 48
-import Printer ( errorDoc, text, ($$) )
+import Printer ( errorDoc, text, ($$), renderString )
+
+import DarcsIO ( WriteableDirectory(..), ReadableDirectory(..) )
+import SlurpDirectory ( SlurpMonad(..) )
+import DarcsRepo ( slurp_recorded )
+import FileName (fp2fn, FileName, super_name, norm_path, (///))
+import FastPackedString (PackedString)
+
hunk ./Match.lhs 102
+get_first_match_s :: [DarcsFlag] ->PatchSet -> SlurpMonad ()
+get_first_match_s fs repo =
+ case has_lastn fs of
+ Just n -> get_dropn_s repo n
+ Nothing -> case first_matcher fs of
+ Nothing -> fail "Pattern not specified in get_first_match."
+ Just m -> if first_matcher_is_tag fs
+ then get_tag_s repo m
+ else get_before_matcher_s repo m
+
+
hunk ./Match.lhs 123
+
+
+get_second_match_s :: [DarcsFlag] ->PatchSet -> SlurpMonad ()
+get_second_match_s fs repo =
+ case second_matcher fs of
+ Nothing -> fail "Two patterns not specified in get_second_match."
+ Just m -> if second_matcher_is_tag fs
+ then get_tag_s repo m
+ else get_matcher_s repo m
+
hunk ./Match.lhs 321
+
+
+maybe_read_file :: FileName -> SlurpMonad ([(FileName, PackedString)])
+maybe_read_file file = do
+ d <- mDoesDirectoryExist file
+ if d
+ then do
+ children <- mInCurrentDirectory file mGetDirectoryContents
+ maybe_read_files [file /// ch | ch <- children]
+ else do
+ e <- mDoesFileExist file
+ if e
+ then do
+ contents <- mReadFilePS file
+ return [(norm_path file, contents)]
+ else return []
+ where maybe_read_files [] = return []
+ maybe_read_files (f:fs) = do
+ x <- maybe_read_file f
+ y <- maybe_read_files fs
+ return $ concat [x,y]
+
+get_file_contents :: FilePath -> [FilePath] -> (PatchSet -> SlurpMonad()) -> IO ([(FileName, PackedString)])
+get_file_contents r files gf = do
+ s <- slurp_recorded r
+ repo <- read_repo r
+ let SM slurpFunc = gf repo >> mapM ( maybe_read_file . fp2fn) files
+ case (slurpFunc $ Right s) of
+ Left err -> fail err
+ Right (_, ret) -> return $ concat ret
+
+apply_patches_to_some_files :: FilePath -> [FilePath] -> (PatchSet -> SlurpMonad()) -> IO ()
+apply_patches_to_some_files r files gf = do
+ fcs <- get_file_contents r files gf
+ writeFiles fcs
+ where writeFiles [] = return ()
+ writeFiles ((p, c):xs) = (ensureDirectories $ super_name p) >> ( mWriteFilePS p c) >> writeFiles xs
+ ensureDirectories d = do
+ isPar <- mDoesDirectoryExist d
+ if isPar
+ then return ()
+ else ensureDirectories (super_name d) >> (mCreateDirectory d)
+
+get_matcher_s :: PatchSet -> Matcher -> SlurpMonad ()
+get_matcher_s repo m =
+ if match_exists m repo
+ then apply_foo repo
+ else fail $ "Couldn't match pattern "++ show m
+ where apply_foo [] = impossible
+ apply_foo ([]:xs) = apply_foo xs
+ apply_foo ((p:ps):xs)
+ | apply_matcher m p = return ()
+ | otherwise = apply_invp p >> apply_foo (ps:xs)
+
+get_before_matcher_s :: PatchSet -> Matcher -> SlurpMonad ()
+get_before_matcher_s repo m =
+ if match_exists m repo
+ then apply_foo repo
+ else fail $ "Couldn't match pattern "++ show m
+ where apply_foo [] = impossible
+ apply_foo ([]:xs) = apply_foo xs
+ apply_foo ((p:ps):xs)
+ | apply_matcher m p = apply_invp p
+ | otherwise = apply_invp p >> apply_foo (ps:xs)
+
+get_dropn_s :: PatchSet -> Int -> SlurpMonad ()
+get_dropn_s repo n = apply_foo $ safetake n $ concat repo
+ where apply_foo [] = return ()
+ apply_foo (p:ps) = apply_invp p >> apply_foo ps
+
+get_tag_s :: PatchSet -> Matcher -> SlurpMonad ()
+get_tag_s repo match = do
+ let pinfo = fromJust $ patch2patchinfo $ find_a_patch match repo
+ case get_patches_beyond_tag pinfo repo of
+ [extras] -> apply_foo $ extras
+ _ -> impossible
+ where apply_foo [] = return ()
+ apply_foo (p:ps) = apply_invp p >> apply_foo ps
+
hunk ./Match.lhs 401
-apply_invp :: (PatchInfo, Maybe Patch) -> IO ()
-apply_invp p = apply [] False (invert $ fromJustP p) `catch` \e ->
- fail ("Inverse patch failed!\n" ++ show e)
+apply_invp :: WriteableDirectory m => (PatchInfo, Maybe Patch) -> m ()
+apply_invp p = apply [] False (invert $ fromJustP p)
hunk ./Match.lhs 405
- errorDoc $ text "Sorry, partial repository problem. The patch"
- $$ human_friendly pinf
- $$ text "is not available."
- $$ text ""
- $$ text "If you think what you're trying to do is ok then"
- $$ text "report this as a bug on the darcs-user list."
+ error $ "Sorry, partial repository problem. The patch"
+ ++ renderString (human_friendly pinf)
+ ++ "is not available."
+ ++ ""
+ ++ "If you think what you're trying to do is ok then"
+ ++ "report this as a bug on the darcs-user list."
hunk ./Match.lhs 419
- safetake 0 _ = []
- safetake _ [] = error "There aren't that many patches..."
- safetake i (a:as) = a : safetake (i-1) as
hunk ./Match.lhs 420
+
+safetake :: Int -> [a] -> [a]
+safetake 0 _ = []
+safetake _ [] = error "There aren't that many patches..."
+safetake i (a:as) = a : safetake (i-1) as
+
hunk ./SlurpDirectory.lhs 43
- SlurpMonad, withSlurpy,
+ SlurpMonad(..), withSlurpy
}
Context:
[Test pull.pl, CREATE_DIR_ERROR: removed TODO now that directory name is printed in error message
Marnix Klooster <marnix.klooster at gmail.com>**20060304164033
Also removes a superfluous (and erroneous) chdir statement, which tried to
change to non-existing directory templ (last character was ell instead of one).
Also improves the description of this test.
]
[Refactor calls to ssh/scp/sftp.
Eric Kow <eric.kow at gmail.com>**20060706202509
]
[Extend test suite for patch matching.
Eric Kow <eric.kow at gmail.com>**20060513192501
]
[Implement help --match (issue91).
Eric Kow <eric.kow at gmail.com>**20060513185610
Also, refactor matching code in a way that encourages developers
to document for help --match any new matchers they create.
]
[Replace dateparser.sh with more general match.pl for testing --match.
Eric Kow <eric.kow at gmail.com>**20060513104942
]
[Add tests for pristine error and quiet mode when removing a directory.
Eric Kow <eric.kow at gmail.com>**20060513100021]
[Replace test rmdir.sh with rmdir.pl.
Eric Kow <eric.kow at gmail.com>**20060513043823]
[add some changelog entries
Tommy Pettersson <ptp at lysator.liu.se>**20060718152611]
[Minor tweaks to list_authors.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060720180602]
[Added elc and pyc to binaries.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060713184214]
[Run ssh/scp/sftp quietly.
Eric Kow <eric.kow at gmail.com>**20060707025245
This is useful for silencing Putty, and could also be for OpenSSH should
we decide to stop redirecting to /dev/null.
]
[Added up links in web interface.
Peter Stuifzand <peter at stuifzand.com>**20060610082238
Added a link to the 'projects' part of the cgi repository interface, so that
you go back to the project list.
]
[Add a test suite for calling external programs.
Eric Kow <eric.kow at gmail.com>**20060521045407
For now this only includes a test for ssh (issue171).
]
[Suppress non-empty dir warning if Quiet.
Eric Kow <eric.kow at gmail.com>**20060513053456]
[Add forgotten file umask.h.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060423174844]
[Add --umask to all commands that write to the current repository.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060407195655]
[Add option --umask.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060407194552]
[Actually switch umasks in withRepoLock.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060407194202]
[Implement withUMask.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060407193312]
[Add umask.c.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060407193255]
[Propagate opts to withRepoLock.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060325190622]
[Merge makefile targets test_perl and test_shell into test_scripts.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060607223134
This should keep parallel make from breaking.
]
[add some changelog entries
Tommy Pettersson <ptp at lysator.liu.se>**20060616150558]
[Add warning to Eric's SSHControlMaster rework.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060528194136]
[Only launch SSH control master on demand (fixes issue171)
Eric Kow <eric.kow at gmail.com>**20060528093000
A secondary benefit is that this encapsulates the use of the control
master functionality and consequently simplifies calling ssh. There is
no need to deal with the details of launching or exiting the control
master.
]
[bump version to 1.0.8pre1
Tommy Pettersson <ptp at lysator.liu.se>**20060522122655]
[Fail with a sensible message when there is no default repository to pull from.
lele at nautilus.homeip.net**20060515135042]
[TAG 1.0.7
Tommy Pettersson <ptp at lysator.liu.se>**20060513171438]
Patch bundle hash:
67254a299420f582d501ff5cb0d33d4fd382c8d9
More information about the darcs-devel
mailing list