Hi Jason and Reinier, How about splitting the review for this bundle?
Jason: could you read the Darcs.Gorsvet on a high level, and also the patches which touch other modules? Please let me know if you think this will be too much work so that I can assign another reviewer, perhaps me :-) Reinier: could you read Gorsvet.hs itself in a more thorough manner? For your convenience, I am I'm going to take Petr's recommendation to heart and attach the Darcs.Gorsvet module (as Gorsvet.hs) to be read in one go. Below, I have cut out everything which touches that file, leaving behind the stuff for Jason to focus on. Thanks! On Wed, May 27, 2009 at 15:41:03 +0200, Petr Rockai wrote: > this is the first big bundle from darcs-hs. It should have all the changes > that > make whatsnew work correctly using the index. (As correctly as I could make it > go). For reviewers, it may be better to apply all of the bundle and read > Darcs.Gorsvet from start to end (as opposed to reading things patch by > patch). There is some incorrect code in there that has gotten fixed later and > such. Import relevant bits of gorsvet, for now under Darcs.Gorsvet. ------------------------------------------------------------- > Petr Rockai <[email protected]>**20090517160635 > Ignore-this: 888c305b25231e3751fec6287e5ae2bd > ] hunk ./darcs.cabal 210 > Darcs.FilePathMonad > Darcs.Flags > Darcs.Global > + Darcs.Gorsvet > Darcs.Hopefully > Darcs.IO > Darcs.Lock > hunk ./darcs.cabal 317 > parsec >= 2.0 && < 3.1, > html == 1.0.*, > filepath == 1.1.*, > - haskeline >= 0.6.1 && < 0.7 > + haskeline >= 0.6.1 && < 0.7, > + hashed-storage > > if !os(windows) > build-depends: unix >= 1.0 && < 2.4 > hunk ./darcs.cabal 450 > parsec >= 2.0 && < 3.1, > html == 1.0.*, > filepath == 1.1.*, > - haskeline >= 0.6.1 && < 0.7 > + haskeline >= 0.6.1 && < 0.7, > + hashed-storage > > if !os(windows) > build-depends: unix >= 1.0 && < 2.4 Invalidate index at key positions in relevant (pristine-modifying) commands. ---------------------------------------------------------------------------- > Petr Rockai <[email protected]>**20090524092616 > Ignore-this: aaff5ce75478c57047c0c9398aa1ebde > ] hunk ./src/Darcs/Commands/Add.lhs 52 > import System.FilePath.Posix ( takeDirectory, (</>) ) > import System.IO ( hPutStrLn, stderr ) > import qualified System.FilePath.Windows as WindowsFilePath > +import Darcs.Gorsvet( invalidateIndex ) > > add_description :: String > add_description = "Add one or more new files or directories." > hunk ./src/Darcs/Commands/Add.lhs 119 > mapM_ (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $ > flist \\ nboring flist > date <- getIsoDateTime > + invalidateIndex repository > ps <- addp msgs opts date cur $ nboring flist > when (nullFL ps && not (null args)) $ > fail "No files were added" > hunk ./src/Darcs/Commands/AmendRecord.lhs 62 > ) > import Darcs.Utils ( askUser ) > import Printer ( putDocLn ) > +import Darcs.Gorsvet( invalidateIndex ) > > amendrecord_description :: String > amendrecord_description = > hunk ./src/Darcs/Commands/AmendRecord.lhs 166 > new_author > new_log > let newp = fixp oldp chs new_pinf > defineChanges newp > + invalidateIndex repository > withGutsOf repository $ do > tentativelyRemovePatches repository opts (hopefully > oldp :>: NilFL) > tentativelyAddPatch repository opts newp > hunk ./src/Darcs/Commands/Apply.lhs 76 > import Darcs.Patch.Bundle ( scan_bundle ) > import Darcs.Sealed ( Sealed(Sealed) ) > import Printer ( packedString, putDocLn, vcat, text, ($$), errorDoc, empty ) > +import Darcs.Gorsvet( invalidateIndex ) > #include "impossible.h" > > apply_description :: String > hunk ./src/Darcs/Commands/Apply.lhs 157 > definePatches to_be_applied > Sealed pw <- tentativelyMergePatches repository "apply" opts > (reverseRL $ head $ unsafeUnRL us') to_be_applied > + invalidateIndex repository > withSignalsBlocked $ do finalizeRepositoryChanges repository > wait_a_moment -- so work will be more recent > than rec > applyToWorking repository opts pw `catch` \e -> > hunk ./src/Darcs/Commands/Convert.lhs 71 > import Workaround ( setExecutable ) > import qualified Data.ByteString as B (isPrefixOf, readFile) > import qualified Data.ByteString.Char8 as BC (pack) > +import Darcs.Gorsvet( invalidateIndex ) > > convert_description :: String > convert_description = "Convert a repository from a legacy format." > hunk ./src/Darcs/Commands/Convert.lhs 201 > finalizeRepositoryChanges repository -- this is > to clean out pristine.hashed > revertRepositoryChanges repository > sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting > patch" patches > + invalidateIndex repository > revertable $ createPristineDirectoryTree repository "." > when (SetScriptsExecutable `elem` opts) $ > do putVerbose $ text "Making scripts executable" > hunk ./src/Darcs/Commands/Get.lhs 72 > import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) > import Darcs.Global ( darcsdir ) > import English ( englishNum, Noun(..) ) > +import Darcs.Gorsvet( invalidateIndex ) > #include "impossible.h" > > get_description :: String > hunk ./src/Darcs/Commands/Get.lhs 277 > let ps = patchSetToPatches us' > putInfo $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++ > (englishNum (lengthFL ps) (Noun "patch") "") > + invalidateIndex repository > withRepoLock opts $- \_ -> > do tentativelyRemovePatches repository opts ps > tentativelyAddToPending repository opts $ invert $ effect ps > hunk ./src/Darcs/Commands/Move.lhs 49 > slurp_remove, slurp_hasdir, slurp_hasfile ) > import Darcs.Patch.FileName ( fp2fn, fn2fp, super_name ) > import qualified System.FilePath.Windows as WindowsFilePath > + > +import Darcs.Gorsvet( invalidateIndex ) > #include "impossible.h" > > move_description :: String > hunk ./src/Darcs/Commands/Move.lhs 97 > work <- slurp "." > let old_fp = toFilePath old > new_fp = toFilePath new > + invalidateIndex repository > if slurp_hasdir (sp2fn new) work && slurp_has old_fp work > then move_to_dir repository opts [old_fp] new_fp > else do > hunk ./src/Darcs/Commands/Pull.lhs 62 > import Darcs.Utils ( clarify_errors, formatPath ) > import Darcs.Sealed ( Sealed(..), seal ) > import Printer ( putDocLn, vcat, ($$), text ) > +import Darcs.Gorsvet( invalidateIndex ) > #include "impossible.h" > > pull_description :: String > hunk ./src/Darcs/Commands/Pull.lhs 158 > | otherwise = MarkConflicts : opts > Sealed pw <- tentativelyMergePatches repository "pull" merge_opts > (reverseRL $ head $ unsafeUnRL us') to_be_pulled > + invalidateIndex repository > withGutsOf repository $ do finalizeRepositoryChanges repository > -- so work will be more recent than rec: > revertable $ do wait_a_moment > hunk ./src/Darcs/Commands/Record.lhs 73 > import Darcs.ProgressPatches( progressFL) > import IsoDate ( getIsoDateTime, cleanLocalDate ) > import Printer ( hPutDocLn, text, wrap_text, ($$), renderString ) > +import Darcs.Gorsvet( invalidateIndex ) > #include "impossible.h" > > record_description :: String > hunk ./src/Darcs/Commands/Record.lhs 228 > mypatch <- namepatch date name my_author my_log $ > fromPrims $ progressFL "Writing changes:" chs > tentativelyAddPatch repository opts $ n2pia $ adddeps > mypatch deps > + invalidateIndex repository > debugMessage "Applying to pristine..." > withGutsOf repository (finalizeRepositoryChanges repository) > `clarify_errors` failuremessage > hunk ./src/Darcs/Commands/Rollback.lhs 61 > import Progress ( debugMessage ) > import Darcs.Sealed ( Sealed(..), FlippedSeal(..) ) > import IsoDate ( getIsoDateTime ) > +import Darcs.Gorsvet( invalidateIndex ) > #include "impossible.h" > > rollback_description :: String > hunk ./src/Darcs/Commands/Rollback.lhs 144 > Sealed pw <- tentativelyMergePatches repository "rollback" > (MarkConflicts : opts) > NilFL (rbp :>: NilFL) > debugMessage "Finalizing rollback changes..." > + invalidateIndex repository > withGutsOf repository $ do > finalizeRepositoryChanges repository > debugMessage "About to apply rolled-back changes to working > directory." > hunk ./src/Darcs/Commands/Unrecord.lhs 55 > import Darcs.SelectChanges ( with_selected_last_changes_reversed ) > import Progress ( debugMessage ) > import Darcs.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped ) > +import Darcs.Gorsvet( invalidateIndex ) > #include "gadts.h" > > unrecord_description :: String > hunk ./src/Darcs/Commands/Unrecord.lhs 169 > when (Verbose `elem` opts) $ > logMessage "About to write out (potentially) modified patches..." > definePatches to_unrecord > + invalidateIndex repository > withGutsOf repository $ do tentativelyRemovePatches repository opts $ > mapFL_FL > hopefully to_unrecord > finalizeRepositoryChanges repository > hunk ./src/Darcs/Commands/Unrecord.lhs 307 > when (nullFL ps) $ do logMessage "No patches selected!" > exitWith ExitSuccess > definePatches ps > + invalidateIndex repository > withGutsOf repository $ > do tentativelyRemovePatches repository opts > (mapFL_FL hopefully ps) > tentativelyAddToPending repository opts $ > invert $ effect ps Use index for diffing in the basic whatsnew scenario. ----------------------------------------------------- > Petr Rockai <[email protected]>**20090524092752 > Ignore-this: b5926700c8741af15576aae40a3caae5 > ] hunk ./src/Darcs/Commands/WhatsNew.lhs 56 > import Darcs.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), > nullFL ) > > import Darcs.SlurpDirectory( Slurpy, slurp_has ) > +import Darcs.Gorsvet( unrecordedChanges, restrict_subpaths ) > > import Printer ( putDocLn, renderString, vcat, text ) > #include "impossible.h" > hunk ./src/Darcs/Commands/WhatsNew.lhs 140 > (do slurps <- slurp_recorded_and_unrecorded repository > warn_if_bogus slurps files > putStrLn $ "What's new in "++unwords (map show files)++":\n") > - changes <- get_unrecorded_in_files repository (map sp2fn files) > + changes <- unrecordedChanges repository (restrict_subpaths files) > when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ > ExitFailure 1) > printSummary repository $ mapFL_FL prim2real changes > where printSummary :: RepoPatch p => Repository p C(r u t) -> FL > RealPatch C(r y) -> IO () Pass options to unrecordedChanges and handle LookForAdds and IgnoreTimes. ------------------------------------------------------------------------- > Petr Rockai <[email protected]>**20090525132442 > Ignore-this: 3423146edfe30272c2cd2e8e7382ecae > ] hunk ./src/Darcs/Commands/WhatsNew.lhs 140 > (do slurps <- slurp_recorded_and_unrecorded repository > warn_if_bogus slurps files > putStrLn $ "What's new in "++unwords (map show files)++":\n") > - changes <- unrecordedChanges repository (restrict_subpaths files) > + changes <- unrecordedChanges opts repository (restrict_subpaths files) > when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ > ExitFailure 1) > printSummary repository $ mapFL_FL prim2real changes > where printSummary :: RepoPatch p => Repository p C(r u t) -> FL > RealPatch C(r y) -> IO () Extend the weird filenames part of the whatsnew test to cover indexed filenames. -------------------------------------------------------------------------------- > Petr Rockai <[email protected]>**20090527071506 > Ignore-this: 724c5d577ceb2e9235ef22c7829418c6 > ] hunk ./tests/whatsnew.sh 29 > echo test does not work on windows > exit 0; > else > - touch \\ > + echo foo > \\ > darcs add \\ > hunk ./tests/whatsnew.sh 31 > - darcs whatsnew > log > - not grep "no changes" log > + darcs whatsnew | tee log > + grep 'hunk ./\\92\\' log > fi > > hunk ./tests/whatsnew.sh 35 > +echo foo > "foo bar" > +darcs add "foo bar" > +darcs wh | tee log > +grep 'hunk ./foo\\32\\bar' log > + > +# check that filename encoding does not botch up the index > +darcs rec -am "weird filenames" > +not darcs wh > + > # whatsnew works with absolute paths > DIR="`pwd`" > echo date.t > date.t -- Eric Kow <http://www.nltg.brighton.ac.uk/home/Eric.Kow> PGP Key ID: 08AC04F9
{-# LANGUAGE FlexibleInstances #-}
-- Copyright (C) 2009 Petr Rockai
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use, copy,
-- modify, merge, publish, distribute, sublicense, and/or sell copies
-- of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
module Darcs.Gorsvet where
import Prelude hiding ( read, filter, writeFile, readFile )
-- darcs stuff
import ByteStringUtils( is_funky )
import Darcs.Repository ( Repository, slurp_pending )
import Darcs.Repository.Internal ( read_pending, setTentativePending
, announce_merge_conflicts
, check_unrecorded_conflicts )
import Darcs.Repository.HashedRepo ( add_to_tentative_inventory )
import Darcs.Repository.InternalTypes ( extractCache )
import Darcs.Resolution ( standard_resolution )
import Darcs.External ( backupByCopying )
import Darcs.ProgressPatches (progressFL)
import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply
, sort_coalesceFL, fromPrims
, effect, list_touched_files, joinPatches, merge
, anonymous, patchcontents, addfile, rmfile, adddir, rmdir
, invert)
import Darcs.Ordered ( FL(..), (+>+), (:\/:)(..), mapFL_FL, (:/\:)(..) )
import Darcs.Repository.Prefs ( filetype_function, FileType(..) )
import Darcs.IO
import Darcs.Hopefully ( n2pia, PatchInfoAnd, hopefully )
import Darcs.Sealed ( Sealed(Sealed), seal )
import Darcs.Patch.FileName ( fn2fp )
import Darcs.Flags ( Compression(..) )
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
import Control.Monad.State.Strict
import System.Directory( removeFile, doesFileExist )
import Data.Maybe
import Darcs.Arguments ( DarcsFlag( LookForAdds, IgnoreTimes ) )
import Darcs.RepoPath ( sp2fn )
import Storage.Hashed
import Storage.Hashed.Tree
import Storage.Hashed.Index
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Monad
import Storage.Hashed
---- FIXME this is from Storage.Hashed.Utils which is hidden ...
darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n
where n = (show s)
darcsFormatHash (Hash (Just s, h)) =
BS.concat [ darcsFormatSize s
, BS.singleton '-'
, h ]
darcsFormatHash h =
error $ "Unsuitable hash for darcs-compatible hashing " ++ show h
-- end FIXME
floatFn = floatPath . fn2fp
instance ReadableDirectory (StateT TreeState IO) where
mDoesDirectoryExist d = gets (\x -> isJust $ findTree (tree x) (floatFn d))
mDoesFileExist f = gets (\x -> isJust $ findFile (tree x) (floatFn f))
mInCurrentDirectory d action = do -- TODO bracket?
wd <- gets cwd
modify (\x -> x { cwd = floatFn d })
x <- action
modify (\x -> x { cwd = wd })
return x
mGetDirectoryContents = error "get dir contents"
mReadFilePS p = do x <- readFile (floatFn p) -- ratify readFile: ...
return $ BS.concat (BL.toChunks x)
instance WriteableDirectory (StateT TreeState IO) where
mWithCurrentDirectory = mInCurrentDirectory
mSetFileExecutable _ _ = return ()
mWriteFilePS p ps = writeFile -- ratify readFile: haskell_policy is stupid.
(floatFn p) (BL.fromChunks [ps])
mCreateDirectory p = createDirectory (floatFn p)
mRename from to = rename (floatFn from) (floatFn to)
mRemoveDirectory = unlink . floatFn
mRemoveFile = unlink . floatFn
treeDiff :: (FilePath -> FileType) -> Tree -> Tree -> IO (FL Prim)
treeDiff ft t1 t2 = do
(from, to) <- diffTrees t1 t2
diffs <- sequence $ zipTrees diff from to
return $ foldr (+>+) NilFL (diffs)
where diff :: AnchoredPath -> Maybe TreeItem -> Maybe TreeItem
-> IO (FL Prim)
diff p (Just (SubTree _)) (Just (SubTree _)) = return NilFL
diff p (Just (SubTree _)) Nothing =
return $ rmdir (anchorPath "" p) :>: NilFL
diff p Nothing (Just (SubTree _)) =
return $ adddir (anchorPath "" p) :>: NilFL
diff p Nothing b'@(Just (File _)) =
do diff <- diff p (Just (File emptyBlob)) b'
return $ addfile (anchorPath "" p) :>: diff
diff p a'@(Just (File _)) Nothing =
do diff <- diff p a' (Just (File emptyBlob))
return $ diff +>+ (rmfile (anchorPath "" p) :>: NilFL)
diff p (Just (File a')) (Just (File b')) =
do a <- read a'
b <- read b'
let path = anchorPath "" p
case ft path of
TextFile | no_bin a && no_bin b ->
return $ text_diff path a b
_ -> return $ if a /= b
then binary path (strict a) (strict b) :>: NilFL
else NilFL
diff p _ _ = fail $ "Missing case at path " ++ show p
text_diff p a b
| BL.null a && BL.null b = NilFL
| BL.null a = diff_from_empty p b
| BL.null b = diff_to_empty p a
| otherwise = line_diff p (lines a) (lines b)
line_diff p a b = canonize (hunk p 1 a b)
diff_to_empty p x | BL.last x == '\n' = line_diff p (init $ lines x) []
| otherwise = line_diff p (lines x) [BS.empty]
diff_from_empty p x = invert (diff_to_empty p x)
no_bin = not . is_funky . strict . BL.take 4096
lines = map strict . BL.split '\n'
strict = BS.concat . BL.toChunks
readRecordedAndPending :: (RepoPatch p) => Repository p -> IO Tree
readRecordedAndPending repo = do
pristine <- readDarcsPristine "."
Sealed pend <- read_pending repo
(_, t) <- virtualTreeIO (apply [] pend) pristine
return t
unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p
-> (Tree -> Tree) -> IO (FL Prim)
unrecordedChanges opts repo restrict_ = do
checkIndex repo
slurp_pending repo -- XXX: only here to get us the "pending conflicts" check
-- that I don't know yet how to implement properly
pristine <- readDarcsPristine "."
Sealed pending_patches <- read_pending repo
(res, current') <- virtualTreeIO (apply [] pending_patches) pristine
let current = {- restrict -} current'
working <- case (LookForAdds `elem` opts, IgnoreTimes `elem` opts) of
(False, False) -> (restrict_ `fmap` readIndex) >>= unfold
(False, True) -> do guide <- unfold current
restrict guide `fmap` readPlainTree "."
(True, _) -> filter nodarcs `fmap` readPlainTree "."
ft <- filetype_function
diff <- treeDiff ft current working
return $ sort_coalesceFL (pending_patches +>+ diff)
where nodarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False
nodarcs _ _ = True
-- XXX both application actions below could avoid unfolding if TreeIO would be
-- smart enough to unfold-as-needed...
applyToTentativePristine _ patches =
do pristine <- readDarcsPristine "." >>= unfold
(_, tree) <- hashedTreeIO (apply [] patches)
pristine "_darcs/pristine.hashed"
BS.writeFile "_darcs/tentative_pristine" $
BS.concat [BS.pack "pristine:"
, darcsFormatHash (fromJust $ treeHash tree)]
applyToWorking :: (RepoPatch p) => Repository p -> Sealed (FL Prim) -> IO Tree
applyToWorking _ (Sealed patches) =
do pristine <- readDarcsPristine "." >>= unfold
working <- readIndex
snd `fmap` plainTreeIO (apply [] patches) working "."
tentativelyMerge r cmd usi themi =
do let us = mapFL_FL hopefully usi
them = mapFL_FL hopefully themi
(_ :/\: pc) = merge (progressFL "Merging them" them
:\/: progressFL "Merging us" us)
pend <- unrecordedChanges [] r id
anonpend <- anonymous (fromPrims pend)
let pend' :/\: pw = merge (pc :\/: anonpend :>: NilFL)
pwprim = joinPatches $ mapFL_FL patchcontents pw
Sealed standard_resolved_pw = standard_resolution pwprim
mapM_ backupByCopying $ list_touched_files standard_resolved_pw
have_conflicts <- announce_merge_conflicts cmd [] standard_resolved_pw
have_unrecorded_conflicts <- check_unrecorded_conflicts [] pc
let Sealed pw_resolution = if have_conflicts || have_unrecorded_conflicts
then seal NilFL
else seal standard_resolved_pw
let doChanges :: FL (PatchInfoAnd p) -> 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 :: RepoPatch p => Repository p -> FL (PatchInfoAnd p) -> [IO ()]
mapAdd _ NilFL = []
mapAdd r' (a:>:as) =
(add_to_tentative_inventory (extractCache r') NoCompression a >> return ()) : mapAdd r' as
applyps :: (RepoPatch p) => Repository p -> FL (PatchInfoAnd p) -> IO ()
applyps repo ps = do sequence_ $ mapAdd repo ps
applyToTentativePristine repo ps
filter_paths files =
\p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files
restrict_paths files = if null files
then id
else filter $ filter_paths files
restrict_subpaths = restrict_paths . map (floatPath . fn2fp . sp2fn)
checkIndex repo = do
invalid <- doesFileExist "_darcs/index_invalid"
exist <- doesFileExist "_darcs/index"
when (not exist || invalid) $ updateIndex repo
when invalid $ removeFile "_darcs/index_invalid"
updateIndex repo = do
pristine <- readRecordedAndPending repo
updateIndexFrom pristine >>= unfold
return ()
invalidateIndex _ = do
BS.writeFile "_darcs/index_invalid" BS.empty
signature.asc
Description: Digital signature
_______________________________________________ darcs-users mailing list [email protected] http://lists.osuosl.org/mailman/listinfo/darcs-users
