[darcs-devel] more hashed-inventory changes
David Roundy
droundy at darcs.net
Wed Sep 27 16:33:48 PDT 2006
Hi all,
The following is my latest hashed inventory patch bundle. I've added
a make target to run the entire test suite with hashed inventories.
Mostly it fails at the moment, but I have fixed a bit. The code is
now at the stage where others could reasonably hope to test and debug
it (since it's now so easy to generate failure cases--just run the
shell scripts).
I still don't have much time to devote to this, but the local LUG here
in Corvallis has a weekly "hacking pizza social", and I'm thinking I
may go there regularly and work on darcs.
David
Sun Sep 17 14:41:36 PDT 2006 David Roundy <droundy at darcs.net>
* clean up unrevert and pending handling.
Mon Sep 18 10:39:04 PDT 2006 David Roundy <droundy at darcs.net>
* add a bit of hashed inventory code.
Tue Sep 26 19:01:27 PDT 2006 David Roundy <droundy at darcs.net>
* add test target for testing hashed inventories.
Tue Sep 26 19:12:02 PDT 2006 David Roundy <droundy at darcs.net>
* put Repository in Show class for debugging ease.
Tue Sep 26 19:45:05 PDT 2006 David Roundy <droundy at darcs.net>
* fix parsing of hashed inventories.
Tue Sep 26 19:45:14 PDT 2006 David Roundy <droundy at darcs.net>
* make darcs check use Repository framework.
New patches:
[clean up unrevert and pending handling.
David Roundy <droundy at darcs.net>**20060917214136] {
hunk ./AmendRecord.lhs 26
- with_new_pending, sync_repo, amInRepository,
+ sync_repo, amInRepository,
hunk ./AmendRecord.lhs 45
-import Unrevert ( remove_from_unrevert_context )
hunk ./AmendRecord.lhs 115
- s files (flatten ch) Nothing $ \ (unrec,chs) ->
+ s files (flatten ch) Nothing $ \ (_,chs) ->
hunk ./AmendRecord.lhs 124
- remove_from_unrevert_context [oldp]
- tentativelyRemovePatches repository opts [oldp]
- tentativelyAddPatch repository opts newp
- withSignalsBlocked $
- with_new_pending repository (join_patches unrec) $
- finalizeRepositoryChanges repository
+ withSignalsBlocked $ do
+ tentativelyRemovePatches repository opts [oldp]
+ tentativelyAddPatch repository opts newp
+ finalizeRepositoryChanges repository
hunk ./Apply.lhs 46
- with_new_pending, sync_repo, read_repo,
- tentativelyAddPatch, finalizeRepositoryChanges,
+ sync_repo, read_repo,
+ tentativelyAddPatch, tentativelyAddToPending,
+ finalizeRepositoryChanges,
hunk ./Apply.lhs 50
-import Patch ( Patch, patch2patchinfo, invert, list_touched_files,
- join_patches, unjoin_patches, null_patch,
+import Patch ( Patch, patch2patchinfo, list_touched_files,
+ join_patches, unjoin_patches,
hunk ./Apply.lhs 182
- mp <- get_unrecorded repository (AnyOrder:opts)
- let npend = join_patches [invert us_patch, fromMaybePatch mp, pw_resolved]
- withSignalsBlocked $ with_new_pending repository npend $ do
- finalizeRepositoryChanges repository
- wait_a_moment -- so work will be more recent than rec
- Patch.apply opts True pw_resolved `catch` \e ->
- fail ("Error applying patch to working dir:\n" ++ show e)
+ tentativelyAddToPending repository opts pw_resolved
+ withSignalsBlocked $ do finalizeRepositoryChanges repository
+ wait_a_moment -- so work will be more recent than rec
+ Patch.apply opts True pw_resolved `catch` \e ->
+ fail ("Error applying patch to working dir:\n" ++ show e)
hunk ./Apply.lhs 207
- fromMaybePatch Nothing = null_patch
- fromMaybePatch (Just p) = p
hunk ./DarcsArguments.lhs 32
- edit_file, askdeps, ignoretimes, lookforadds,
- ask_long_comment, sendmail_cmd, view_file,
+ askdeps, ignoretimes, lookforadds,
+ ask_long_comment, sendmail_cmd,
hunk ./DarcsArguments.lhs 68
-import List
-import System
-import Exec ( exec_interactive )
+import List ( (\\) )
+import System ( ExitCode(ExitSuccess), exitWith, getEnv )
hunk ./DarcsArguments.lhs 77
-import DarcsUtils ( askUser, catchall, ortryrunning )
+import DarcsUtils ( askUser, catchall )
hunk ./DarcsArguments.lhs 897
-
-\begin{code}
-edit_file :: String -> IO ExitCode
-edit_file f = do
- ed <- get_editor
- exec_interactive ed [f]
- `ortryrunning` exec_interactive "emacs" [f]
- `ortryrunning` exec_interactive "emacs" ["-nw",f]
- `ortryrunning` exec_interactive "nano" [f]
-get_editor :: IO String
-get_editor = getEnv "DARCS_EDITOR" `catchall`
- getEnv "DARCSEDITOR" `catchall`
- getEnv "VISUAL" `catchall`
- getEnv "EDITOR" `catchall` return "vi"
-\end{code}
-
-\begin{code}
-view_file :: String -> IO ExitCode
-view_file f = do
- viewer <- get_viewer
- exec_interactive viewer [f]
- `ortryrunning` exec_interactive "more" [f]
-get_viewer :: IO String
-get_viewer = getEnv "DARCS_PAGER" `catchall`
- getEnv "PAGER" `catchall` return "less"
-\end{code}
hunk ./DarcsUtils.lhs 13
+ view_file, edit_file, promptChar, promptCharFancy, without_buffering,
hunk ./DarcsUtils.lhs 21
-import System ( ExitCode(..) )
-import System.IO ( hFlush, hPutStrLn, stderr, stdout )
+import System ( ExitCode(..), getEnv )
+import System.IO ( hFlush, hPutStrLn, stderr, stdout, stdin,
+ BufferMode ( NoBuffering ),
+ hLookAhead, hReady, hSetBuffering, hGetBuffering, hIsTerminalDevice )
hunk ./DarcsUtils.lhs 26
+import Data.Char ( toUpper )
hunk ./DarcsUtils.lhs 31
+import RawMode ( get_raw_mode, set_raw_mode )
+import Exec ( exec_interactive )
hunk ./DarcsUtils.lhs 146
+
+\begin{code}
+edit_file :: String -> IO ExitCode
+edit_file f = do
+ ed <- get_editor
+ exec_interactive ed [f]
+ `ortryrunning` exec_interactive "emacs" [f]
+ `ortryrunning` exec_interactive "emacs" ["-nw",f]
+ `ortryrunning` exec_interactive "nano" [f]
+get_editor :: IO String
+get_editor = getEnv "DARCS_EDITOR" `catchall`
+ getEnv "DARCSEDITOR" `catchall`
+ getEnv "VISUAL" `catchall`
+ getEnv "EDITOR" `catchall` return "vi"
+\end{code}
+
+\begin{code}
+view_file :: String -> IO ExitCode
+view_file f = do
+ viewer <- get_viewer
+ exec_interactive viewer [f]
+ `ortryrunning` exec_interactive "more" [f]
+get_viewer :: IO String
+get_viewer = getEnv "DARCS_PAGER" `catchall`
+ getEnv "PAGER" `catchall` return "less"
+\end{code}
+
+\begin{code}
+promptChar :: String -> [Char] -> IO Char
+promptChar p chs = promptCharFancy p chs Nothing False
+
+promptCharFancy :: String -> [Char] -> Maybe Char -> Bool -> IO Char
+promptCharFancy p chs md qmark_for_help =
+ do a <- without_buffering $
+ do putStr $ p ++ " ["++ setDefault chs ++"]" ++ helpStr
+ hFlush stdout
+ getChar
+ when (a /= '\n') $ putStr "\n"
+ case () of
+ _ | a `elem` chs -> return a
+ | a == ' ' -> case md of Nothing -> tryAgain
+ Just d -> return d
+ | a == '?' && qmark_for_help -> return a
+ | otherwise -> tryAgain
+ where
+ helpStr = if qmark_for_help then ", or ? for help: " else ""
+ tryAgain = do putStrLn "Invalid response, try again!"
+ promptCharFancy p chs md qmark_for_help
+ setDefault s = case md of Nothing -> s
+ Just d -> map (setUpper d) s
+ setUpper d c = if d == c then toUpper c else c
+
+without_buffering :: IO a -> IO a
+without_buffering job = do
+ bracket nobuf rebuf $ \_ -> job
+ where nobuf = do is_term <- hIsTerminalDevice stdin
+ bi <- hGetBuffering stdin
+ raw <- get_raw_mode
+ when is_term $ do hSetBuffering stdin NoBuffering
+ set_raw_mode True
+ return (bi,raw)
+ rebuf (bi,raw) = do is_term <- hIsTerminalDevice stdin
+#if SYS == windows
+ buffers <- hGetBuffering stdin
+ hSetBuffering stdin NoBuffering `catch` \_ -> return ()
+ drop_returns
+ hSetBuffering stdin buffers `catch` \_ -> return ()
+#else
+ drop_returns
+#endif
+ when is_term $ do hSetBuffering stdin bi
+ set_raw_mode raw
+ drop_returns = do is_ready <- hReady stdin
+ when is_ready $
+ do c <- hLookAhead stdin `catch` \_ -> return ' '
+ when (c == '\n') $
+ do getChar
+ drop_returns
+\end{code}
hunk ./Lock.lhs 27
- rm_recursive,
+ rm_recursive, removeFileMayNotExist,
hunk ./Match.lhs 42
-import DarcsArguments ( DarcsFlag( OnePatch, SeveralPatch, Context,
- AfterPatch, UpToPatch, LastN,
- OneTag, AfterTag, UpToTag,
- OnePattern, SeveralPattern,
- AfterPattern, UpToPattern ) )
+import DarcsFlags ( DarcsFlag( OnePatch, SeveralPatch, Context,
+ AfterPatch, UpToPatch, LastN,
+ OneTag, AfterTag, UpToTag,
+ OnePattern, SeveralPattern,
+ AfterPattern, UpToPattern ) )
hunk ./PatchBundle.lhs 21
-import DarcsArguments ( DarcsFlag( Unified ) )
-import Repository ( PatchSet )
+import DarcsFlags ( DarcsFlag( Unified ) )
+import PatchSet ( PatchSet )
hunk ./PrintPatch.lhs 28
-import DarcsArguments ( view_file )
+import DarcsUtils ( view_file )
hunk ./Pull.lhs 43
- with_new_pending, read_pending, sync_repo,
- tentativelyAddPatch, finalizeRepositoryChanges,
+ read_pending, sync_repo,
+ tentativelyAddPatch, tentativelyAddToPending, finalizeRepositoryChanges,
hunk ./Pull.lhs 48
- invert, list_conflicted_files, null_patch,
+ list_conflicted_files,
hunk ./Pull.lhs 51
-import SelectChanges ( promptChar )
hunk ./Pull.lhs 59
-import DarcsUtils ( clarify_errors, nubsort, formatPath )
+import DarcsUtils ( clarify_errors, nubsort, formatPath, promptChar )
hunk ./Pull.lhs 171
- mp <- get_unrecorded repository (AnyOrder:opts)
- let newpend = join_patches [invert pc, fromMaybePatch mp, pw_resolved]
- withSignalsBlocked $ with_new_pending repository newpend $ do
- finalizeRepositoryChanges repository
- -- so work will be more recent than rec:
- revertable wait_a_moment
- revertable $ apply opts True pw_resolved `catch` \e ->
- fail ("Error applying patch to working dir:\n" ++ show e)
+ tentativelyAddToPending repository opts pw_resolved
+ withSignalsBlocked $ do finalizeRepositoryChanges repository
+ -- so work will be more recent than rec:
+ revertable $
+ do wait_a_moment
+ apply opts True pw_resolved `catch` \e ->
+ fail ("Error applying patch to working dir:\n" ++ show e)
hunk ./Pull.lhs 180
- where fromMaybePatch Nothing = null_patch
- fromMaybePatch (Just p) = p
- revertable x = x `clarify_errors` unlines
+ where revertable x = x `clarify_errors` unlines
hunk ./Record.lhs 20
-import Control.Monad ( filterM, liftM, when )
+import Control.Monad ( filterM, when )
hunk ./Record.lhs 38
- get_unrecorded,
- with_new_pending, sync_repo, read_repo,
+ get_unrecorded, sync_repo, read_repo,
hunk ./Record.lhs 51
-import SelectChanges ( with_selected_changes_to_files, promptChar,
+import SelectChanges ( with_selected_changes_to_files,
hunk ./Record.lhs 57
-import DarcsUtils ( askUser )
+import DarcsUtils ( askUser, promptChar, edit_file )
hunk ./Record.lhs 160
- s files ps Nothing $ \ (skipped,chs) ->
+ s files ps Nothing $ \ (_,chs) ->
hunk ./Record.lhs 171
- my_author my_log logf deps chs skipped
+ my_author my_log logf deps chs
hunk ./Record.lhs 178
- -> [PatchInfo] -> [Patch] -> [Patch] -> IO ()
-do_actual_record opts name date my_author my_log logf deps chs skipped =
+ -> [PatchInfo] -> [Patch] -> IO ()
+do_actual_record opts name date my_author my_log logf deps chs =
hunk ./Record.lhs 196
- withSignalsBlocked $
- with_new_pending repository (join_patches skipped) $
- finalizeRepositoryChanges repository
+ withSignalsBlocked $ finalizeRepositoryChanges repository
hunk ./Record.lhs 231
- let (skipped, chs) =
+ let (_, chs) =
hunk ./Record.lhs 240
- n date my_a my_log Nothing []
- chs skipped
+ n date my_a my_log Nothing [] chs
replace ./Record.lhs [A-Za-z_0-9] liftM fmap
hunk ./Repository.lhs 23
- read_pending, with_new_pending, add_to_pending,
+ read_pending, add_to_pending,
hunk ./Repository.lhs 28
- tentativelyAddPatch, tentativelyRemovePatches, unrevertUrl,
+ tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
hunk ./Repository.lhs 30
+ unrevertUrl,
hunk ./Repository.lhs 37
+import Data.List ( (\\) )
hunk ./Repository.lhs 40
-import Directory ( doesDirectoryExist, setCurrentDirectory )
+import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile )
hunk ./Repository.lhs 43
+import FastPackedString ( readFilePS, gzReadFilePS, nilPS )
+import PatchBundle ( scan_bundle, make_bundle )
hunk ./Repository.lhs 51
-import Patch ( Patch, flatten, join_patches, reorder_and_coalesce,
- apply_to_slurpy, gzReadPatchFileLazily )
+import Patch ( Patch, flatten, flatten_to_primitives, join_patches, reorder_and_coalesce,
+ patch2patchinfo, commute, invert, null_patch,
+ is_similar, is_addfile, is_adddir,
+ apply_to_slurpy, gzReadPatchFileLazily, readPatch, writePatch )
+import Depends ( get_common_and_uncommon )
hunk ./Repository.lhs 58
-import DarcsUtils ( catchall, withCurrentDirectory, withUMask )
+import DarcsUtils ( promptChar, catchall, withCurrentDirectory, withUMask )
hunk ./Repository.lhs 60
-import Lock ( withLock )
+import Lock ( withLock, writeDocBinFile, removeFileMayNotExist )
hunk ./Repository.lhs 247
+handle_pend_for_add :: Repository -> [DarcsFlag] -> Patch -> IO ()
+handle_pend_for_add repository@(Repo _ _ rt) opts p =
+ do mpend <- read_pending repository
+ let is_okay pend pa | is_addfile pa = any (is_similar pa) pend
+ | is_adddir pa = any (is_similar pa) pend
+ | otherwise = True
+ filter_p :: [Patch] -> [Patch]
+ filter_p = if LookForAdds `elem` opts
+ then case flatten_to_primitives `fmap` mpend of
+ Nothing -> const []
+ Just pend -> filter (is_okay pend)
+ else id
+ prepend rt $ invert $ join_patches $ filter_p $ flatten_to_primitives p
+
hunk ./Repository.lhs 262
-tentativelyAddPatch (Repo dir _ (DarcsRepository _)) opts patch =
- withCurrentDirectory dir $ do
- fp <- DarcsRepo.add_to_tentative_inventory opts patch
- gzReadPatchFileLazily fp
-tentativelyAddPatch (Repo dir _ GitRepository) _ patch =
+tentativelyAddPatch r@(Repo dir _ (DarcsRepository _)) opts patch =
+ withCurrentDirectory dir $ do fp <- DarcsRepo.add_to_tentative_inventory opts patch
+ handle_pend_for_add r opts patch
+ gzReadPatchFileLazily fp
+tentativelyAddPatch r@(Repo dir _ GitRepository) opts patch =
hunk ./Repository.lhs 268
+ handle_pend_for_add r opts patch'
hunk ./Repository.lhs 272
+tentativelyAddToPending :: Repository -> [DarcsFlag] -> Patch -> IO ()
+tentativelyAddToPending (Repo dir _ rt) _ patch =
+ withCurrentDirectory dir $ do
+ let pn = pendingName rt
+ tpn = pn ++ ".tentative"
+ pend <- gzReadFilePS tpn `catchall` (return nilPS)
+ let newpend = case readPatch pend of
+ Nothing -> patch
+ Just (p,_) -> join_patches $ flatten_to_primitives p ++ flatten_to_primitives patch
+ writePatch tpn $ newpend
+
+prepend :: RepoType -> Patch -> IO ()
+prepend rt patch = do let pn = pendingName rt
+ ppn = pn ++ ".tentative_prepend"
+ pend <- gzReadFilePS ppn `catchall` (return nilPS)
+ let newpend = case readPatch pend of
+ Nothing -> patch
+ Just (p,_) -> join_patches $ flatten_to_primitives patch ++
+ flatten_to_primitives p
+ writePatch ppn $ newpend
+
hunk ./Repository.lhs 294
-tentativelyRemovePatches (Repo dir _ (DarcsRepository _)) opts ps =
- withCurrentDirectory dir $ DarcsRepo.remove_from_tentative_inventory opts ps
-tentativelyRemovePatches (Repo _ _ GitRepository) _ _ = error "unimplemented git"
+tentativelyRemovePatches (Repo dir _ rt@(DarcsRepository _)) opts ps =
+ withCurrentDirectory dir $ do
+ prepend rt $ join_patches ps
+ remove_from_unrevert_context ps
+ DarcsRepo.remove_from_tentative_inventory opts ps
+tentativelyRemovePatches (Repo dir _ GitRepository) _ ps =
+ withCurrentDirectory dir $ do
+ prepend GitRepository $ join_patches ps
+ remove_from_unrevert_context ps
+ fail "unimplemented git"
+
+finalize_pending :: Repository -> IO ()
+finalize_pending repository@(Repo dir _ rt) = do
+ withCurrentDirectory dir $ do let pn = pendingName rt
+ tpn = pn ++ ".tentative"
+ ppn = pn ++ ".tentative_prepend"
+ pend <- read_pending repository
+ ppfile <- gzReadFilePS ppn `catchall` (return nilPS)
+ tpfile <- gzReadFilePS tpn `catchall` (return nilPS)
+ let tpend = fst `fmap` readPatch tpfile
+ ppend = fst `fmap` readPatch ppfile
+ mp2p Nothing = null_patch
+ mp2p (Just p) = p
+ new_pending = join_patches $ map mp2p [ppend, pend, tpend]
+ with_new_pending repository new_pending (return ())
hunk ./Repository.lhs 321
-finalizeRepositoryChanges (Repo dir _ (DarcsRepository _)) =
- withCurrentDirectory dir $ DarcsRepo.finalize_tentative_changes
-finalizeRepositoryChanges (Repo dir _ GitRepository) =
- withCurrentDirectory dir $ GitRepo.finalize_tentative_changes
+finalizeRepositoryChanges repository@(Repo dir _ (DarcsRepository _)) =
+ withCurrentDirectory dir $ do DarcsRepo.finalize_tentative_changes
+ finalize_pending repository
+finalizeRepositoryChanges repository@(Repo dir _ GitRepository) =
+ withCurrentDirectory dir $ do GitRepo.finalize_tentative_changes
+ finalize_pending repository
hunk ./Repository.lhs 329
-revertRepositoryChanges (Repo dir _ (DarcsRepository _)) =
- withCurrentDirectory dir $ DarcsRepo.revert_tentative_changes
+revertRepositoryChanges (Repo dir _ dr@(DarcsRepository _)) =
+ withCurrentDirectory dir $
+ do removeFileMayNotExist $ (pendingName dr) ++ ".tentative"
+ removeFileMayNotExist $ (pendingName dr) ++ ".tentative_prepend"
+ DarcsRepo.revert_tentative_changes
hunk ./Repository.lhs 335
- withCurrentDirectory dir $ GitRepo.revert_tentative_changes
+ withCurrentDirectory dir $
+ do removeFileMayNotExist $ (pendingName GitRepository) ++ ".tentative"
+ removeFileMayNotExist $ (pendingName GitRepository) ++ ".tentative_prepend"
+ GitRepo.revert_tentative_changes
hunk ./Repository.lhs 348
-
hunk ./Repository.lhs 393
+
+\begin{code}
+remove_from_unrevert_context :: [Patch] -> IO ()
+remove_from_unrevert_context ps = do
+ repository <- identifyRepository "."
+ bundle <- unrevert_patch_bundle `catchall` return [[]]
+ case bundle of
+ [[]] -> return ()
+ _ -> do
+ let unrevert_loc = unrevertUrl repository
+ ref <- read_repo repository
+ case get_common_and_uncommon (bundle, ref) of
+ (common,[[(_, Just us)]],[[]]) ->
+ case commute (us, join_patches ps) of
+ Nothing -> unrevert_impossible unrevert_loc
+ Just (_, us') -> do
+ s <- slurp_recorded repository
+ writeDocBinFile unrevert_loc $
+ make_bundle [] s
+ (common \\ pis) [us']
+ (common,[[(_, Just _)]],_)
+ | any (`elem` common) pis -> unrevert_impossible unrevert_loc
+ | otherwise -> return ()
+ _ -> unrevert_impossible unrevert_loc
+ where unrevert_impossible unrevert_loc =
+ do yorn <- promptChar
+ "This operation will make unrevert impossible!\nProceed?"
+ "yn"
+ case yorn of
+ 'n' -> fail "Cancelled to avoid unrevert catastrophe!"
+ 'y' -> removeFile unrevert_loc `catchall` return ()
+ _ -> impossible
+ pis = map (fromJust . patch2patchinfo) ps
+ unrevert_patch_bundle :: IO PatchSet
+ unrevert_patch_bundle = do repository <- identifyRepository "."
+ pf <- readFilePS (unrevertUrl repository)
+ case scan_bundle pf of
+ Right foo -> return foo
+ Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
+\end{code}
hunk ./Resolve.lhs 27
-import Repository ( withRepoLock, amInRepository,
- read_repo, sync_repo, get_unrecorded, with_new_pending,
+import Repository ( withRepoLock, amInRepository, add_to_pending,
+ read_repo, sync_repo, get_unrecorded,
hunk ./Resolve.lhs 32
-import SelectChanges ( promptChar )
+import DarcsUtils ( promptChar )
hunk ./Resolve.lhs 86
- withSignalsBlocked $ with_new_pending repository res $
- apply opts True res `catch` \e ->
- bug ("Problem resolving conflicts in resolve!" ++ show e)
+ withSignalsBlocked $
+ do add_to_pending repository res
+ apply opts True res `catch` \e ->
+ bug ("Problem resolving conflicts in resolve!" ++ show e)
hunk ./Revert.lhs 34
- with_new_pending, sync_repo,
+ add_to_pending, sync_repo,
hunk ./Revert.lhs 113
- withSignalsBlocked $
- with_new_pending repository (join_patches skipped')$
+ withSignalsBlocked $ do
+ add_to_pending repository $ invert $ join_patches p
hunk ./Revert.lhs 116
- fail ("Unable to apply inverse patch!" ++ show e)
+ fail ("Unable to apply inverse patch!" ++ show e)
hunk ./Rollback.lhs 26
-import Repository ( amInRepository, withRepoLock, read_pending,
- with_new_pending,
+import Repository ( amInRepository, withRepoLock,
hunk ./Rollback.lhs 29
-import Patch ( join_patches, invert, patch2patchinfo, null_patch, )
+import Patch ( invert, patch2patchinfo, )
hunk ./Rollback.lhs 75
-rollback_cmd opts _ = withRepoLock opts $ \repository -> do
- mpend <- read_pending repository
- let pend = case mpend of
- Nothing -> null_patch
- Just p -> p
+rollback_cmd opts _ = withRepoLock opts $ \repository ->
hunk ./Rollback.lhs 86
- let newpend = join_patches [p, pend]
- withSignalsBlocked $ with_new_pending repository newpend $
- finalizeRepositoryChanges repository
+ withSignalsBlocked $ finalizeRepositoryChanges repository
hunk ./SelectChanges.lhs 29
- promptChar,
hunk ./SelectChanges.lhs 48
-import System.IO ( hIsTerminalDevice )
-import Control.Exception ( bracket )
hunk ./SelectChanges.lhs 78
-import DarcsUtils ( askUser )
+import DarcsUtils ( askUser, promptCharFancy, without_buffering )
hunk ./SelectChanges.lhs 80
-import RawMode ( get_raw_mode, set_raw_mode )
hunk ./SelectChanges.lhs 241
-
-without_buffering :: IO a -> IO a
-without_buffering job = do
- bracket nobuf rebuf $ \_ -> job
- where nobuf = do is_term <- hIsTerminalDevice stdin
- bi <- hGetBuffering stdin
- raw <- get_raw_mode
- when is_term $ do hSetBuffering stdin NoBuffering
- set_raw_mode True
- return (bi,raw)
- rebuf (bi,raw) = do is_term <- hIsTerminalDevice stdin
-#if SYS == windows
- buffers <- hGetBuffering stdin
- hSetBuffering stdin NoBuffering `catch` \_ -> return ()
- drop_returns
- hSetBuffering stdin buffers `catch` \_ -> return ()
-#else
- drop_returns
-#endif
- when is_term $ do hSetBuffering stdin bi
- set_raw_mode raw
- drop_returns = do is_ready <- hReady stdin
- when is_ready $
- do c <- hLookAhead stdin `catch` \_ -> return ' '
- when (c == '\n') $
- do getChar
- drop_returns
-
hunk ./SelectChanges.lhs 584
-
-\begin{code}
-promptChar :: String -> [Char] -> IO Char
-promptChar p chs = promptCharFancy p chs Nothing False
-
-promptCharFancy :: String -> [Char] -> Maybe Char -> Bool -> IO Char
-promptCharFancy p chs md qmark_for_help =
- do a <- without_buffering $
- do putStr $ p ++ " ["++ setDefault chs ++"]" ++ helpStr
- hFlush stdout
- getChar
- when (a /= '\n') $ putStr "\n"
- case () of
- _ | a `elem` chs -> return a
- | a == ' ' -> case md of Nothing -> tryAgain
- Just d -> return d
- | a == '?' && qmark_for_help -> return a
- | otherwise -> tryAgain
- where
- helpStr = if qmark_for_help then ", or ? for help: " else ""
- tryAgain = do putStrLn "Invalid response, try again!"
- promptCharFancy p chs md qmark_for_help
- setDefault s = case md of Nothing -> s
- Just d -> map (setUpper d) s
- setUpper d c = if d == c then toUpper c else c
-\end{code}
hunk ./Send.lhs 29
- edit_file, get_cc, get_author, working_repo_dir,
+ get_cc, get_author, working_repo_dir,
hunk ./Send.lhs 53
-import DarcsUtils ( askUser, catchall, formatPath )
+import DarcsUtils ( askUser, catchall, edit_file, formatPath )
hunk ./Unrecord.lhs 35
+ tentativelyAddToPending,
hunk ./Unrecord.lhs 37
- read_pending, with_new_pending, sync_repo,
+ sync_repo,
hunk ./Unrecord.lhs 40
- join_patches, commute, flatten, null_patch, apply
+ join_patches, commute, null_patch, apply
hunk ./Unrecord.lhs 44
-import Unrevert ( remove_from_unrevert_context )
hunk ./Unrecord.lhs 146
- pend <- do aack <- read_pending repository
- return $ case aack of Nothing -> []
- Just p -> flatten p
hunk ./Unrecord.lhs 155
- remove_from_unrevert_context to_unrecord
- let newpend = join_patches (to_unrecord ++ pend)
- withSignalsBlocked $ with_new_pending repository newpend $ do
- when (Verbose `elem` opts) $
- logMessage "About to write out (potentially) modified patches..."
- tentativelyRemovePatches repository opts to_unrecord
+ when (Verbose `elem` opts) $
+ logMessage "About to write out (potentially) modified patches..."
+ withSignalsBlocked $ do tentativelyRemovePatches repository opts to_unrecord
+ finalizeRepositoryChanges repository
hunk ./Unrecord.lhs 360
- Just (p_after_pending, pend') -> do
+ Just (p_after_pending,_) -> do
hunk ./Unrecord.lhs 363
- remove_from_unrevert_context ps
- withSignalsBlocked $ with_new_pending repository pend' $ do
- tentativelyRemovePatches repository opts ps
- finalizeRepositoryChanges repository
- apply opts True (invert p_after_pending) `catch` \e ->
- fail ("Couldn't undo patch in working dir.\n" ++ show e)
+ withSignalsBlocked $ do tentativelyRemovePatches repository opts ps
+ tentativelyAddToPending repository opts $
+ invert $ join_patches ps
+ finalizeRepositoryChanges repository
+ apply opts True (invert p_after_pending) `catch` \e ->
+ fail ("Couldn't undo patch in working dir.\n" ++ show e)
hunk ./Unrevert.lhs 18
-module Unrevert ( unrevert, remove_from_unrevert_context, write_unrevert ) where
--- TODO: Move remove_from_unrevert_context and write_unrevert into
--- Repository, with the former being private to Repository.
+module Unrevert ( unrevert, write_unrevert ) where
hunk ./Unrevert.lhs 20
-import Monad ( liftM )
-import List ( (\\) )
hunk ./Unrevert.lhs 26
-import Directory ( removeFile )
hunk ./Unrevert.lhs 27
- slurp_recorded, unrevertUrl,
- read_pending, with_new_pending,
+ unrevertUrl,
+ read_pending, add_to_pending,
hunk ./Unrevert.lhs 34
- patch2patchinfo, commute, namepatch, flatten_to_primitives,
+ commute, namepatch, flatten_to_primitives,
hunk ./Unrevert.lhs 39
-import Lock ( writeDocBinFile )
+import Lock ( writeDocBinFile, removeFileMayNotExist )
hunk ./Unrevert.lhs 45
-import SelectChanges ( promptChar )
hunk ./Unrevert.lhs 95
- pw_resolved <- join_patches `liftM` standard_resolution work_patch
+ pw_resolved <- join_patches `fmap` standard_resolution work_patch
hunk ./Unrevert.lhs 103
- withSignalsBlocked $ with_new_pending repository pend_and_p $
- do apply opts True (join_patches p) `catch` \e ->
+ withSignalsBlocked $
+ do add_to_pending repository $ join_patches p
+ apply opts True (join_patches p) `catch` \e ->
hunk ./Unrevert.lhs 118
- removeFile (unrevertUrl repository) `catchall` return ()
+ removeFileMayNotExist $ unrevertUrl repository
hunk ./Unrevert.lhs 146
-
-\begin{code}
-remove_from_unrevert_context :: [Patch] -> IO ()
-remove_from_unrevert_context ps = do
- bundle <- unrevert_patch_bundle `catchall` return [[]]
- case bundle of
- [[]] -> return ()
- _ -> do
- repository <- identifyRepository "."
- let unrevert_loc = unrevertUrl repository
- ref <- read_repo repository
- case get_common_and_uncommon (bundle, ref) of
- (common,[[(_, Just us)]],[[]]) ->
- case commute (us, join_patches ps) of
- Nothing -> unrevert_impossible unrevert_loc
- Just (_, us') -> do
- s <- slurp_recorded repository
- writeDocBinFile unrevert_loc $
- make_bundle [] s
- (common \\ pis) [us']
- (common,[[(_, Just _)]],_)
- | any (`elem` common) pis -> unrevert_impossible unrevert_loc
- | otherwise -> return ()
- _ -> unrevert_impossible unrevert_loc
- where unrevert_impossible unrevert_loc =
- do yorn <- promptChar
- "This operation will make unrevert impossible!\nProceed?"
- "yn"
- case yorn of
- 'n' -> fail "Cancelled to avoid unrevert catastrophe!"
- 'y' -> removeFile unrevert_loc `catchall` return ()
- _ -> impossible
- pis = map (fromJust . patch2patchinfo) ps
-\end{code}
}
[add a bit of hashed inventory code.
David Roundy <droundy at darcs.net>**20060918173904] {
hunk ./DarcsArguments.lhs 32
+ inventory_choices,
hunk ./DarcsArguments.lhs 662
+
+\begin{code}
+inventory_choices :: [DarcsOption]
+inventory_choices =
+ [DarcsNoArgOption [] ["hashed-inventory"] UseHashedInventory
+ "use a hashed inventory",
+ DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory
+ "use old fashioned inventory"]
+\end{code}
hunk ./DarcsFlags.lhs 66
+ | UseHashedInventory | UseOldFashionedInventory
hunk ./DarcsRepo.lhs 56
- add_to_inventory,
+ add_to_inventory, add_to_tentative_pristine,
hunk ./DarcsRepo.lhs 58
- finalize_tentative_changes,
+ finalize_tentative_changes, finalize_pristine_changes,
hunk ./DarcsRepo.lhs 380
- do appendDocBinFile ("_darcs/tentative_inventory") $ showPatchInfo pinf
- appendDocBinFile ("_darcs/tentative_pristine") $ showPatch p -- FIXME: this is inefficient!
- appendBinFile ("_darcs/tentative_pristine") "\n"
+ do appendDocBinFile ("_darcs/tentative_inventory") $ text "\n" <> showPatchInfo pinf
hunk ./DarcsRepo.lhs 384
+add_to_tentative_pristine :: FilePath -> IO ()
+add_to_tentative_pristine fp =
+ do p <- liftM (fromJust . liftM fst . readPatch) $ gzReadFilePS fp
+ appendDocBinFile ("_darcs/tentative_pristine") $ showPatch p -- FIXME: this is inefficient!
+ appendBinFile ("_darcs/tentative_pristine") "\n"
+
hunk ./DarcsRepo.lhs 413
-finalize_tentative_changes = withSignalsBlocked $
+finalize_tentative_changes = renameFile "_darcs/tentative_inventory" "_darcs/inventory"
+
+finalize_pristine_changes :: IO ()
+finalize_pristine_changes =
hunk ./DarcsRepo.lhs 420
- renameFile "_darcs/tentative_inventory" "_darcs/inventory"
hunk ./GNUmakefile 26
- FilePathUtils.hs IsoDate.lhs Lcs.lhs Lock.lhs Map.hs \
+ FilePathUtils.hs HashedRepo.lhs \
+ IsoDate.lhs Lcs.lhs Lock.lhs Map.hs \
hunk ./Get.lhs 34
+import Repository ( Repository, withRepoLock, identifyRepository, read_repo,
+ tentativelyRemovePatches, patchSetToPatches,
+ finalizeRepositoryChanges, sync_repo )
hunk ./Get.lhs 58
-import Repository ( Repository, patchSetToPatches, withRepoLock,
- sync_repo,
- tentativelyRemovePatches, finalizeRepositoryChanges,
- )
hunk ./Get.lhs 121
- patches <- lazily_read_repo repodir -- laziness doesn't matter here...
+ source_repository <- identifyRepository repodir
+ patches <- read_repo source_repository
hunk ./Get.lhs 187
- withRepoLock opts $ \repository ->
- do putVerbose $ text "Syncing the repository..."
- sync_repo repository
- putVerbose $ text "Repository synced, going to chosen version..."
- go_to_chosen_version repository putVerbose putInfo opts
+ withRepoLock opts $ \repository -> do putVerbose $ text "Syncing the repository..."
+ sync_repo repository
+ putVerbose $ text "Repository synced, going to chosen version..."
+ go_to_chosen_version repository putVerbose putInfo opts
addfile ./HashedRepo.lhs
hunk ./HashedRepo.lhs 1
+% Copyright (C) 2006 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; if not, write to the Free Software Foundation,
+% Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+\chapter{Hashed inventory format}
+\label{hashed_format}
+
+The hashed inventory format is similar to the ``DarcsRepo'' format (see
+Chapter~\ref{repository_format}), but I haven't gotten around to
+documenting it.
+
+\begin{code}
+module HashedRepo ( revert_tentative_changes, finalize_tentative_changes,
+ add_to_tentative_inventory,
+ read_repo, read_repo_lazily,
+ writeHashFile
+ ) where
+
+import System.IO.Unsafe ( unsafeInterleaveIO )
+import System.IO ( stderr, hPutStrLn )
+import System.Directory ( doesDirectoryExist )
+
+import Workaround ( renameFile )
+import DarcsFlags ( DarcsFlag )
+import PatchSet ( PatchSet )
+import DarcsRepo ( absolute_dir )
+import Patch ( Patch, showPatch, patch2patchinfo, readPatch, readPatchLazily,
+ gzReadPatchFileLazily )
+import PatchInfo ( PatchInfo, showPatchInfo, readPatchInfo )
+import FastPackedString ( PackedString, readFilePS, writeFilePS, gzReadFilePS, nullPS,
+ packString, breakOnPS, unpackPS )
+import Printer ( Doc )
+import SHA1 ( sha1PS )
+import External ( gzFetchFilePS, fetchFilePS, Cachable( Cachable, Uncachable ) )
+import Lock ( writeBinFile, withTemp, writeDocBinFile, appendBinFile, appendDocBinFile )
+import DarcsUtils ( withCurrentDirectory )
+#include "impossible.h"
+
+revert_tentative_changes :: IO ()
+revert_tentative_changes =
+ do readFilePS "_darcs/hashed_inventory" >>= writeFilePS "_darcs/tentative_hashed_inventory"
+ writeBinFile "_darcs/tentative_pristine" ""
+
+finalize_tentative_changes :: IO ()
+finalize_tentative_changes = renameFile "_darcs/tentative_hashed_inventory" "_darcs/hashed_inventory"
+
+add_to_tentative_inventory :: [DarcsFlag] -> Patch -> IO FilePath
+add_to_tentative_inventory _ p =
+ do hash <- withCurrentDirectory "_darcs/patches" $ writeHashFile $ showPatch p
+ let pinf = fromJust $ patch2patchinfo p
+ appendDocBinFile ("_darcs/tentative_hashed_inventory") $ showPatchInfo pinf
+ appendBinFile ("_darcs/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n"
+ return $ "_darcs/patches/" ++ hash
+
+writeHashFile :: Doc -> IO String
+writeHashFile d = withTemp $ \f -> do writeDocBinFile f d
+ hash <- sha1PS `fmap` readFilePS f
+ renameFile f hash
+ return hash
+
+read_repo :: String -> IO PatchSet
+read_repo d = do
+ realdir <- absolute_dir d
+ read_repo_private False realdir "hashed_inventory" `catch`
+ (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir)
+ ioError e)
+
+read_repo_lazily :: String -> IO PatchSet
+read_repo_lazily d = do
+ realdir <- absolute_dir d
+ read_repo_private True realdir "hashed_inventory" `catch`
+ (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir)
+ ioError e)
+
+read_repo_private :: Bool -> FilePath -> FilePath -> IO PatchSet
+read_repo_private am_lazy d iname = do
+ i <- fetchFilePS (d++"/_darcs/"++iname) Uncachable
+ (rest,str) <- case breakOnPS '\n' i of
+ (swt,pistr) | swt == packString "Starting with tag:" ->
+ do r <- rr $ head $ read_patch_ids pistr
+ return (r,pistr)
+ _ -> return ([],i)
+ pis <- return $ reverse $ read_patch_ids str
+ isdir <- doesDirectoryExist d
+ let parse (_,h) = let fn = d ++ "/_darcs/patches/" ++ h
+ in if isdir then parse_local fn
+ else parse_remote fn
+ these <- read_patches parse pis
+ return $ these : rest
+ where rr (_,h) = unsafeInterleaveIO $ read_repo_private am_lazy d $
+ "inventories/"++h
+ -- parse_remote should really download to a temporary file removed
+ -- at exit
+ parse_remote fn = do ps <- gzFetchFilePS fn Cachable
+ return $ fst `fmap` if am_lazy
+ then Just $ readPatchLazily ps
+ else readPatch ps
+ parse_local fn = if am_lazy
+ then Just `fmap` gzReadPatchFileLazily fn
+ else (fmap fst . readPatch) `fmap` gzReadFilePS fn
+ read_patches :: ((PatchInfo,String) -> IO (Maybe Patch))
+ -> [(PatchInfo,String)] -> IO [(PatchInfo, Maybe Patch)]
+ read_patches _ [] = return []
+ read_patches parse ((i,h):is) = do
+ mp <- unsafeInterleaveIO $ parse (i,h) `catch` \_ -> return Nothing
+ rest <- read_patches parse is
+ return $ (i,mp) : rest
+
+read_patch_ids :: PackedString -> [(PatchInfo, String)]
+read_patch_ids inv | nullPS inv = []
+read_patch_ids inv = case readPatchInfo inv of
+ Nothing -> []
+ Just (pinfo,r) ->
+ case readHash r of
+ Nothing -> []
+ Just (h,r') -> (pinfo,h) : read_patch_ids r'
+
+readHash :: PackedString -> Maybe (String, PackedString)
+readHash s = let (l,r) = breakOnPS '\n' s
+ (kw,h) = breakOnPS ' ' l
+ in if kw /= packString "hash:"
+ then Nothing
+ else Just (unpackPS h,r)
+
+{-
+read_patch_ids :: (Stringalike s, ParserM m, Monad (m s)) => Bool -> m s [(PatchInfo, PackedString)]
+read_patch_ids
+ = do mn <- maybe_work readPatchInfo
+ case mn of
+ Nothing -> return []
+ Just n ->
+ do d <- read_depends
+ Just p <- readPatch' want_eof
+ return $ NamedP n d p
+-}
+\end{code}
hunk ./Init.lhs 23
-import DarcsArguments ( DarcsFlag, pristine_tree, working_repo_dir )
+import DarcsArguments ( DarcsFlag, pristine_tree, working_repo_dir,
+ inventory_choices )
+
hunk ./Init.lhs 27
+import RepoFormat ( create_repo_format, writeRepoFormat,
+ RepoProperty ( Darcs1_0, HashedInventory ),
+ format_has_together )
hunk ./Init.lhs 31
+import Lock ( writeBinFile )
hunk ./Init.lhs 70
- command_darcsoptions = [pristine_tree,
- working_repo_dir]}
+ command_darcsoptions = [pristine_tree] ++
+ inventory_choices ++
+ [working_repo_dir]}
hunk ./Init.lhs 107
- write_inventory "." [[]]
+ let rf = create_repo_format opts
+ writeRepoFormat rf "_darcs/format"
+ if format_has_together [Darcs1_0,HashedInventory] rf
+ then do write_inventory "." [[]]
+ writeBinFile "_darcs/hashed_inventory" ""
+ else if format_has_together [HashedInventory] rf
+ then writeBinFile "_darcs/hashed_inventory" ""
+ else write_inventory "." [[]]
hunk ./RepoFormat.lhs 7
+ create_repo_format, writeRepoFormat,
hunk ./RepoFormat.lhs 9
- format_has,
+ format_has, format_has_together,
hunk ./RepoFormat.lhs 12
+import Data.List ( sort )
hunk ./RepoFormat.lhs 18
+import DarcsFlags ( DarcsFlag ( UseHashedInventory, UseOldFashionedInventory ) )
+import Lock ( writeBinFile )
hunk ./RepoFormat.lhs 23
-data RepoProperty = Darcs1_0
+data RepoProperty = Darcs1_0 | HashedInventory
hunk ./RepoFormat.lhs 43
+writeRepoFormat :: RepoFormat -> FilePath -> IO ()
+writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $
+ map (unwords . map unpackPS) rf
+
hunk ./RepoFormat.lhs 53
+
+create_repo_format :: [DarcsFlag] -> RepoFormat
+create_repo_format fs = RF [map rp2ps flags2inv]
+ where flags2inv | UseOldFashionedInventory `elem` fs &&
+ UseHashedInventory `elem` fs = [Darcs1_0, HashedInventory]
+ | UseHashedInventory `elem` fs = [HashedInventory]
+ | otherwise = [Darcs1_0]
+
hunk ./RepoFormat.lhs 85
-known_properties = [Darcs1_0]
+known_properties = [Darcs1_0, HashedInventory]
hunk ./RepoFormat.lhs 91
+
+format_has_together :: [RepoProperty] -> RepoFormat -> Bool
+format_has_together fs (RF ks) = fht (sort $ map rp2ps fs) ks
+ where fht _ [] = False
+ fht x (y:ys) | x == sort y = True
+ | otherwise = fht x ys
hunk ./RepoFormat.lhs 102
+rp2ps HashedInventory = packString "hashed-inventory"
hunk ./Repository.lhs 38
-import RepoFormat ( RepoFormat, identifyRepoFormat,
+import SignalHandler ( withSignalsBlocked )
+import RepoFormat ( RepoFormat, RepoProperty(Darcs1_0, HashedInventory),
+ identifyRepoFormat, format_has_together, format_has,
hunk ./Repository.lhs 48
-import DarcsRepo ( seekRepo, youNeedToBeInRepo )
+import DarcsRepo ( seekRepo, youNeedToBeInRepo, finalize_pristine_changes,
+ add_to_tentative_pristine )
+import qualified HashedRepo ( revert_tentative_changes, finalize_tentative_changes,
+ add_to_tentative_inventory, read_repo )
hunk ./Repository.lhs 56
-import Patch ( Patch, flatten, flatten_to_primitives, join_patches, reorder_and_coalesce,
- patch2patchinfo, commute, invert, null_patch,
- is_similar, is_addfile, is_adddir,
- apply_to_slurpy, gzReadPatchFileLazily, readPatch, writePatch )
+import Patch ( Patch, flatten, join_patches, reorder_and_coalesce,
+ commute, patch2patchinfo, null_patch, readPatch,
+ writePatch, flatten_to_primitives, invert, is_similar,
+ is_addfile, is_adddir,
+ apply_to_slurpy, gzReadPatchFileLazily )
hunk ./Repository.lhs 95
+ hash_darcs <- doesRemoteFileExist (url++"/_darcs/hashed_inventory")
hunk ./Repository.lhs 101
- case (darcs, git) of
- (Left s, Left _) ->
+ case (hash_darcs, darcs, git) of
+ (Left s, Left _, Left _) ->
hunk ./Repository.lhs 105
- (Right True, _)->
- return $ Right $ Repo url rf (DarcsRepository nopristine)
- (Left _, Right True) -> return (Right $ Repo url rf GitRepository)
- _ -> impossible
+ (Left _, Left _, Right True) -> return (Right $ Repo url rf GitRepository)
+ _ -> return $ Right $ Repo url rf (DarcsRepository nopristine)
hunk ./Repository.lhs 227
-read_repo (Repo r _ (DarcsRepository _)) = DarcsRepo.read_repo r
+read_repo (Repo r rf (DarcsRepository _))
+ | format_has HashedInventory rf = HashedRepo.read_repo r
+ | otherwise = DarcsRepo.read_repo r
hunk ./Repository.lhs 268
+data HashedVsOld a = HvsO { old, hashed :: a }
+
+decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a
+decideHashedOrNormal rf (HvsO { hashed = h, old = o })
+ | format_has_together [HashedInventory] rf = h
+ | format_has_together [Darcs1_0,HashedInventory] rf = o >> h
+ | otherwise = o
+
hunk ./Repository.lhs 277
-tentativelyAddPatch r@(Repo dir _ (DarcsRepository _)) opts patch =
- withCurrentDirectory dir $ do fp <- DarcsRepo.add_to_tentative_inventory opts patch
- handle_pend_for_add r opts patch
- gzReadPatchFileLazily fp
+tentativelyAddPatch r@(Repo dir rf (DarcsRepository _)) opts patch =
+ withCurrentDirectory dir $
+ do fp <- decideHashedOrNormal rf $ HvsO {
+ hashed = HashedRepo.add_to_tentative_inventory opts patch,
+ old = DarcsRepo.add_to_tentative_inventory opts patch
+ }
+ add_to_tentative_pristine fp
+ handle_pend_for_add r opts patch
+ gzReadPatchFileLazily fp
hunk ./Repository.lhs 341
-finalizeRepositoryChanges repository@(Repo dir _ (DarcsRepository _)) =
- withCurrentDirectory dir $ do DarcsRepo.finalize_tentative_changes
- finalize_pending repository
+finalizeRepositoryChanges repository@(Repo dir rf (DarcsRepository _)) =
+ withCurrentDirectory dir $ withSignalsBlocked $
+ do finalize_pristine_changes
+ decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.finalize_tentative_changes,
+ old = DarcsRepo.finalize_tentative_changes }
+ finalize_pending repository
hunk ./Repository.lhs 352
-revertRepositoryChanges (Repo dir _ dr@(DarcsRepository _)) =
+revertRepositoryChanges (Repo dir rf dr@(DarcsRepository _)) =
hunk ./Repository.lhs 356
- DarcsRepo.revert_tentative_changes
+ decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revert_tentative_changes,
+ old = DarcsRepo.revert_tentative_changes }
addfile ./tests/hashed_inventory.sh
hunk ./tests/hashed_inventory.sh 1
+#!/bin/sh
+
+
+set -ev
+
+test $DARCS || DARCS=$PWD/../darcs
+
+rm -rf temp1 temp2
+mkdir temp1
+cd temp1
+$DARCS init --hashed-inventory
+touch foo
+$DARCS add foo
+$DARCS rec -m t1 -a -A tester
+echo 1 >> foo
+$DARCS what -s | grep -v No\ changes
+$DARCS what -l | grep -v No\ changes
+$DARCS what -sl | grep -v No\ changes
+
+cd ..
+
+$DARCS get temp1 temp2
+cd temp2
+$DARCS changes
+
+cd ..
+rm -rf temp1 temp2
+
}
[add test target for testing hashed inventories.
David Roundy <droundy at darcs.net>**20060927020127] {
hunk ./GNUmakefile 287
- @cd tests &&\
+ @cd tests && rm -rf .darcs; \
hunk ./GNUmakefile 293
+test_scripts_hashed: darcs
+ @cd tests && \
+ rm -rf .darcs; \
+ mkdir .darcs; \
+ echo ALL --hashed-inventory >> .darcs/defaults; \
+ if [ -r $(TEST_FILTER_FILE) ];\
+ then grep "\.sh" tests_to_run | xargs $(SHELL_HARNESS); \
+ grep "\.pl" tests_to_run | xargs $(PERL_HARNESS); \
+ else $(SHELL_HARNESS) *.sh; $(PERL_HARNESS) *.pl; fi
+
}
[put Repository in Show class for debugging ease.
David Roundy <droundy at darcs.net>**20060927021202] {
hunk ./Pristine.lhs 51
+ deriving ( Show )
hunk ./RepoFormat.lhs 24
-newtype RepoFormat = RF [[PackedString]]
+newtype RepoFormat = RF [[PackedString]] deriving ( Show )
hunk ./Repository.lhs 73
-data Repository = Repo !String !RepoFormat !RepoType
+data Repository = Repo !String !RepoFormat !RepoType deriving ( Show )
hunk ./Repository.lhs 75
-data RepoType = DarcsRepository !Pristine | GitRepository
+data RepoType = DarcsRepository !Pristine | GitRepository deriving ( Show )
}
[fix parsing of hashed inventories.
David Roundy <droundy at darcs.net>**20060927024505] {
hunk ./HashedRepo.lhs 42
- packString, breakOnPS, unpackPS )
+ packString, breakOnPS, unpackPS, dropWhitePS )
hunk ./HashedRepo.lhs 130
-readHash s = let (l,r) = breakOnPS '\n' s
+readHash s = let s' = dropWhitePS s
+ (l,r) = breakOnPS '\n' s'
}
[make darcs check use Repository framework.
David Roundy <droundy at darcs.net>**20060927024514] {
hunk ./Check.lhs 31
-import DarcsRepo ( am_in_repo, read_repo, get_checkpoint_by_default,
- apply_patches_with_feedback, lazily_read_repo,
+import Repository ( Repository, amInRepository, read_repo, identifyRepository )
+import DarcsRepo ( get_checkpoint_by_default,
+ apply_patches_with_feedback,
hunk ./Check.lhs 85
- command_prereq = am_in_repo,
+ command_prereq = amInRepository,
hunk ./Check.lhs 101
- check_uniqueness putVerbose putInfo
- patches <- lazily_read_repo "."
+ repository <- identifyRepository "."
+ check_uniqueness putVerbose putInfo repository
+ patches <- read_repo repository -- FIXME: This should be lazy!
hunk ./Check.lhs 155
-check_uniqueness :: (Doc -> IO ()) -> (Doc -> IO ()) -> IO ()
-check_uniqueness putVerbose putInfo =
+check_uniqueness :: (Doc -> IO ()) -> (Doc -> IO ()) -> Repository -> IO ()
+check_uniqueness putVerbose putInfo repository =
hunk ./Check.lhs 158
- r <- read_repo "."
+ r <- read_repo repository
hunk ./Repair.lhs 79
- in withRepoLock opts $ \_ -> do
- check_uniqueness putVerbose putInfo
+ in withRepoLock opts $ \repository -> do
+ check_uniqueness putVerbose putInfo repository
}
Context:
[whatsnew --look-for-adds doesn't read unadded files (fix for issue79)
Jason Dagit <dagit at codersbase.com>**20060910193803
The default mode for whatsnew --look-for-adds is summary mode. In summary
mode full patches are not needed. This fix changes whatsnew
--look-for-adds to stop computing the full patch for a file when the
file is not managed by darcs.
]
[Correct canonical email for Kirill Smelkov
Kirill Smelkov <kirr at landau.phys.spbu.ru>**20060912080004]
[Be explicit about timezone handling (issue220); assume local by default.
Eric Kow <eric.kow at gmail.com>**20060812102034
Except for the local timezone in the user interface, this patch is not
expected to change darcs's behaviour. It merely makes current practice
explicit:
- Assume local timezone when parsing date strings from the user
interface (previous behaviour was assuming UTC).
- Assume UTC timezone when parsing date strings from PatchInfo.
Newer patch date strings do *not* specify the timezone, so it
would be prudent to treat these as UTC.
- Disregard timezone information altogether when reading patch
dates (issue220). Note that this bug was not caused by assuming local
timezone, because legacy patch date strings explicitly tell you what
the timezone to use. The bug was caused by a patch that fixed
issue173 by using timezone information correctly. To preserve
backwards-compatability, we deliberatly replicate the incorrect
behaviour of overriding the timezone with UTC.
(PatchInfo.make_filename)
]
[Account for timezone offset in cleanDate (Fixes issue173).
Eric Kow <eric.kow at gmail.com>**20060610193049
]
[Fix merge conflicts.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060906191317]
[fix bug in pristine handling when dealing with multiple patches.
David Roundy <droundy at darcs.net>**20060731111404]
[don't use DarcsRepo in list_authors.
David Roundy <droundy at darcs.net>**20060716033450]
[partially refactor Optimize.
David Roundy <droundy at darcs.net>**20060716032934]
[refactor Unrecord, adding tentativelyRemovePatches.
David Roundy <droundy at darcs.net>**20060716015150]
[refactor tag.
David Roundy <droundy at darcs.net>**20060716011853]
[refactor Repository to allow truly atomic updates.
David Roundy <droundy at darcs.net>**20060716011245]
[move test for tabs from makefile to haskell_policy test
Tommy Pettersson <ptp at lysator.liu.se>**20060730122348]
[add test for haskell policy
Tommy Pettersson <ptp at lysator.liu.se>**20060730121404]
[ratify some uses of readFile and hGetContents
Tommy Pettersson <ptp at lysator.liu.se>**20060730121158]
[Remove direct dependency to mapi32.dll; Improve MAPI compatibility.
Esa Ilari Vuokko <ei at vuokko.info>**20051130000915]
[Canonize Kirill Smelkov and Anders Hockersten.
Eric Kow <eric.kow at gmail.com>**20060910052541]
[Correct 'one one' in web page.
Eric Kow <eric.kow at loria.fr>**20060908191241]
[Do not redirect to or from /dev/null when calling ssh.
Eric Kow <eric.kow at loria.fr>**20060903214831
Redirection of stdin and stdout breaks putty, which uses these to
interact with the user. Quiet mode, and redirecting stderr are good
enough for making ssh silent.
]
[Exec improvements : Windows redirection, and more redirection control.
Eric Kow <eric.kow at gmail.com>**20060707054134
- Implement ability to redirect to /dev/null under Windows
(eivuokko on #darcs points out that it is NUL under Windows)
- Add exec_ function, which does the same thing as exec,
but allows redirection on stderr, and also allows us
to NOT redirect stdin/stderr
]
[Ignore .git if _darcs found.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060831231933]
[overhaul the darcs.net front page.
Mark Stosberg <mark at summersault.com>**20060820191415
The themes to this change are:
- Focus on the key benefits of darcs:
Distributed. Interactive. Smart.
- Recognize that the wiki is the central resource,
and remove some information that is duplicated here
and reference the wik instead.
I can post a demo of this HTML for easy comparison if you'd like.
Mark
]
[Reimplement --disable-ssh-cm flag (issue239).
Eric Kow <eric.kow at gmail.com>**20060812134856
My patch to "Only launch SSH control master on demand" accidentally
removed the ability to disable use of SSH ControlMaster. Also, the
way it was implemented is not compatible with launching on demand.
This implementation relies on a notion of global variables using
unsafe IORefs.
]
[Compile Global.lhs in place of AtExit.lhs.
Eric Kow <eric.kow at gmail.com>**20060812121943]
[Rename AtExit module to Global.
Eric Kow <eric.kow at gmail.com>**20060812121925
The goal is to capture some broad "global" notions like exit handlers
and global variables. Note the GPL header thrown in for good measure.
]
[Raise exception if unable to open logfile (issue142).
Zachary P. Landau <kapheine at divineinvasion.net>**20060810034035]
[Make the pull 'permission test' work when run as root
Jon Olsson <jon at vexed.se>**20060831193834]
[TAG darcs-unstable-20060831
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060831191554]
[rename test 0_test to better name harness
Tommy Pettersson <ptp at lysator.liu.se>**20060819214246]
[Fix issue 185: don't combine AddFile and RmFile in the same patch
lele at nautilus.homeip.net**20060820004024
For unknown reason (a possibly previous version of) darcs allows a
single patch to Add and Remove the same file in a single patch. The
"changes" command used to combine them, showing just a Remove. This
prevents combining those two events and shows two distinct actions.
]
[Check for module Text.Html in package html
Esa Ilari Vuokko <ei at vuokko.info>**20060815235739]
[Link to relevant symbol when checking for Control.Monad.Error
Esa Ilari Vuokko <ei at vuokko.info>**20060815235714]
[Workaround for HasBounds that was removed in base-2.0 (GHC 6.6)
Esa Ilari Vuokko <ei at vuokko.info>**20060815234127]
[Read sftp batch file in from stdin (part of issue237).
Eric Kow <eric.kow at gmail.com>**20060812143113
Passing the batch file in from stdin allows for sftp to be used with
password-based authentication. According to the sftp user manual regarding
the -b switch:
Since it lacks user interaction it should be
used in conjunction with non-interactive authentication
Credit for this idea goes to Ori Avtalion.
]
[Extend runSSH function to accept argument for stdin.
Eric Kow <eric.kow at gmail.com>**20060812142932]
[fail if replace token pattern contains spaces (issue231)
Tommy Pettersson <ptp at lysator.liu.se>**20060806110807
It would otherwise create a badly formated patch in pending with unexpected
results for subsequent commands.
]
[fix negation of result in test
Tommy Pettersson <ptp at lysator.liu.se>**20060806104215
Negation with ! "uses" the result and thus there is no "failure", so the
script wouldn't have exit with failure.
]
[add test that replace with spaces fail
Tommy Pettersson <ptp at lysator.liu.se>**20060806103033]
[unset default author environment variables in test suite harness
Tommy Pettersson <ptp at lysator.liu.se>**20060805151210
This makes it harder to accidently write tests that fail because no author
is set.
]
[set author in pull_two test so it doesn't hang
Tommy Pettersson <ptp at lysator.liu.se>**20060804181518]
[make test external stay in its temp1 dir
Tommy Pettersson <ptp at lysator.liu.se>**20060804134139]
[Do not run sftp with the -q flag (issue240).
Eric Kow <eric.kow at gmail.com>**20060811212030
sftp does not recognise it, and so any command which uses it fails.
]
[remove some tabs from haskell source
Tommy Pettersson <ptp at lysator.liu.se>**20060730122505]
[use FastPackeString when examining executable scripts in Get
Tommy Pettersson <ptp at lysator.liu.se>**20060729130645]
[Fixed typo in documentation.
Michal Sojka <sojkam1 at fel.cvut.cz>**20060514095212]
[TAG 1.0.8
Tommy Pettersson <ptp at lysator.liu.se>**20060616160213]
[make 1.0.8 latest stable on home page
Tommy Pettersson <ptp at lysator.liu.se>**20060616150806]
[bump version to 1.0.8
Tommy Pettersson <ptp at lysator.liu.se>**20060616150755]
[canonize Lele Gaifax
Tommy Pettersson <ptp at lysator.liu.se>**20060616150524]
[clean up docs on DarcsRepo format.
David Roundy <droundy at darcs.net>**20060808104321]
[add new obliterate test.
David Roundy <droundy at darcs.net>**20060806122536]
[fixes in pull.pl.
David Roundy <droundy at darcs.net>**20060805221055
The first fix avoids a false error that shows up because of identical
timestamps. The second verifies that revert -a doesn't prompt user.
]
[remove TODO from pull.pl.
David Roundy <droundy at darcs.net>**20060805192700]
[add new test that triggers bug in refactoring.
David Roundy <droundy at darcs.net>**20060804103830]
[I've now eliminated need to export DarcsRepo.write_patch.
David Roundy <droundy at darcs.net>**20060716033109]
[partial refactoring in annotate.
David Roundy <droundy at darcs.net>**20060716034319]
[add TODO for refactoring get_markedup_file.
David Roundy <droundy at darcs.net>**20060716034339]
[add TODO to refactor unrevert handling.
David Roundy <droundy at darcs.net>**20060716020247]
[refactor Population.
David Roundy <droundy at darcs.net>**20060716034837]
[fix bug in refactoring of get.
David Roundy <droundy at darcs.net>**20060726121655]
[partial refactoring of Get.
David Roundy <droundy at darcs.net>**20060716031605]
[simplify code a tad in get.
David Roundy <droundy at darcs.net>**20060726121737]
[make amend-record.pl test a bit pickier.
David Roundy <droundy at darcs.net>**20060730103854]
[fix ordering of operations to call pull_first_middles properly.
David Roundy <droundy at darcs.net>**20060730111409]
[refactor amend-record.
David Roundy <droundy at darcs.net>**20060716021003]
[Minor tweaks to list_authors.
Juliusz Chroboczek <jch at pps.jussieu.fr>**20060720180602]
[add some changelog entries
Tommy Pettersson <ptp at lysator.liu.se>**20060718152611]
[add some changelog entries
Tommy Pettersson <ptp at lysator.liu.se>**20060616150558]
[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.
]
[Refactor calls to ssh/scp/sftp.
Eric Kow <eric.kow at gmail.com>**20060706202509
]
[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.
]
[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.
]
[bump version to 1.0.8pre1
Tommy Pettersson <ptp at lysator.liu.se>**20060522122655]
[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).
]
[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.
]
[Fail with a sensible message when there is no default repository to pull from.
lele at nautilus.homeip.net**20060515135042]
[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]
[Suppress non-empty dir warning if Quiet.
Eric Kow <eric.kow at gmail.com>**20060513053456]
[Replace test rmdir.sh with rmdir.pl.
Eric Kow <eric.kow at gmail.com>**20060513043823]
[TAG 1.0.7
Tommy Pettersson <ptp at lysator.liu.se>**20060513171438]
[make 1.0.7 latest stable source on web page
Tommy Pettersson <ptp at lysator.liu.se>**20060513000703]
[add some entries to the change log
Tommy Pettersson <ptp at lysator.liu.se>**20060512235752]
[bump version to 1.0.7
Tommy Pettersson <ptp at lysator.liu.se>**20060512235738]
[TAG 1.0.7rc1
Tommy Pettersson <ptp at lysator.liu.se>**20060508101408]
[bump version to 1.0.7rc1
Tommy Pettersson <ptp at lysator.liu.se>**20060508101349]
[fix error is is_pipe test in error reporting. (fixes Issue160)
David Roundy <droundy at darcs.net>**20060501142114
The trouble was that Ian (quite naturally) assumed that my C function
stdout_is_a_pipe returned nonzero for true, whereas for some very, very
backwards reason it returned zero for true, and its result was properly
interpreted. So I caused this bug by my (unexplained) backwards
programming, but it was introduced when Ian refactored the C code. :(
]
[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]
[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.
]
[TAG 1.0.7pre1
Tommy Pettersson <ptp at lysator.liu.se>**20060427095905]
Patch bundle hash:
16e4fd0887107da67843e3b0bf40e6c3de7b01e2
More information about the darcs-devel
mailing list