Permalink
Browse files

add patch-index changes

  • Loading branch information...
1 parent bc7a032 commit 7890f8c1f557f3dba4f47640808e34d8ad455b14 @beschmi committed Jun 22, 2012
@@ -34,7 +34,9 @@
module Darcs.Patch.Annotate
(
annotate
+ , annotatePI
, annotateDirectory
+ , annotateDirectoryPI
, format
, machineFormat
) where
@@ -63,6 +65,7 @@ import Storage.Hashed.Tree( Tree )
import Lcs( getChanges )
import Printer( renderString )
import ByteStringUtils ( linesPS, unlinesPS )
+import Darcs.Witnesses.Sealed
#include "impossible.h"
@@ -195,6 +198,30 @@ annotate patches inipath inicontent = annotate' patches initial
(Nothing, B.empty)
}
+annotatePI' :: (Apply p, ApplyState p ~ Tree)
@beschmi

beschmi Jun 22, 2012

Owner

The fooPI functions duplicate the original foo functions and differ only in the type since they do not use witnesses. Instead of 'FL (PatchInfoAnd p) wX wY', they use '[Sealed2 (PatchInfoAnd p)]'.

There are (at least) three options to handle this:

  1. call original functions and use unsafe operations to convert [..] to FL ..
  2. provide only [Sealed ..] functions, adapt other callers
  3. keep duplicated functions
@bsrkaditya

bsrkaditya Jun 25, 2012

Collaborator

How can you do 2 without doing 3? ie, are both not supposed to be done?

@beschmi

beschmi Jun 25, 2012

Owner

for 2, you remove the old functions and rename the fooPI functions
to foo. Then, they are not duplicated anymore.

@bsrkaditya

bsrkaditya Jun 26, 2012

Collaborator

Heffalump and I discussed about this. We came up with a solution that eliminates the new *PI functions.
This is now resolved.

+ => [Sealed2 (PatchInfoAnd p)]
+ -> Annotated
+ -> Annotated
+annotatePI' ([]) ann = ann
+annotatePI' (Sealed2 p: ps) ann
+ | complete ann = ann
+ | otherwise = annotatePI' ps $ execState (apply p) (ann { currentInfo = info p })
+
+
+annotatePI :: (Apply p, ApplyState p ~ Tree)
+ => [Sealed2 (PatchInfoAnd p)]
+ -> FileName
+ -> B.ByteString
+ -> Annotated
+annotatePI patches inipath inicontent = annotatePI' patches initial
+ where
+ initial = Annotated { path = Just inipath
+ , currentInfo = error "There is no currentInfo."
+ , current = zip [0..] (linesPS inicontent)
+ , what = File
+ , annotated = V.replicate (length $ breakLines inicontent)
+ (Nothing, B.empty)
+ }
annotateDirectory :: (Apply p, ApplyState p ~ Tree)
=> FL (PatchInfoAnd p) wX wY
@@ -210,6 +237,21 @@ annotateDirectory patches inipath inicontent = annotate' patches initial
, annotated = V.replicate (length inicontent) (Nothing, B.empty)
}
+annotateDirectoryPI :: (Apply p, ApplyState p ~ Tree)
+ => [Sealed2 (PatchInfoAnd p)]
+ -> FileName
+ -> [FileName]
+ -> Annotated
+annotateDirectoryPI patches inipath inicontent = annotatePI' patches initial
+ where
+ initial = Annotated { path = Just inipath
+ , currentInfo = error "There is no currentInfo."
+ , current = zip [0..] (map fn2ps inicontent)
+ , what = Directory
+ , annotated = V.replicate (length inicontent) (Nothing, B.empty)
+ }
+
+
machineFormat :: B.ByteString -> Annotated -> String
machineFormat d a = unlines [ case i of
@@ -18,7 +18,7 @@
{-# LANGUAGE CPP, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7
-module Darcs.Patch.PatchInfoAnd ( Hopefully, PatchInfoAnd,
+module Darcs.Patch.PatchInfoAnd ( Hopefully, PatchInfoAnd(..),
WPatchInfo, unWPatchInfo, compareWPatchInfo,
piap, n2pia, patchInfoAndPatch,
fmapPIAP, fmapFL_PIAP,
View
@@ -95,6 +95,7 @@ import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )
import ByteStringUtils ( packStringToUTF8, unpackPSFromUTF8 )
import qualified Data.ByteString.Char8 as BC (unpack, pack)
import qualified Data.ByteString as B (ByteString)
+import Data.Binary
import Darcs.Global ( darcsdir )
import Darcs.URL ( isAbsolute, isRelative, isSshNopath )
@@ -109,6 +110,10 @@ instance Show FileName where
showsPrec d (FN fp) = showParen (d > appPrec) $ showString "fp2fn " . showsPrec (appPrec + 1) fp
where appPrec = 10
+instance Binary FileName where
+ put (FN h) = put h
+ get = FN `fmap` get
+
{-# INLINE fp2fn #-}
fp2fn :: FilePath -> FileName
fp2fn fp = FN fp
View
@@ -269,6 +269,7 @@ import Darcs.Witnesses.Sealed ( Sealed(..) )
import Darcs.Global ( darcsdir )
import Darcs.URL ( isFile )
+import Darcs.UI.Flags ( useCache )
import Darcs.SignalHandler ( catchInterrupt )
import Printer ( Doc, text, hPutDocLn, putDocLn )
@@ -289,7 +290,7 @@ import qualified Codec.Archive.Tar as Tar
import Codec.Compression.GZip ( compress, decompress )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
-
+import Darcs.Repository.FileMod (createPatchIndexDisk)
#include "impossible.h"
@@ -313,6 +314,7 @@ createRepository useFormat1 useNoWorkingDir = do
writeRepoFormat repoFormat (darcsdir++"/format")
writeBinFile (darcsdir++"/hashed_inventory") ""
writePristine "." emptyTree
+ withRepository (useCache []) $ RepoJob $ \repo -> createPatchIndexDisk repo
data RepoSort = Hashed | Old
@@ -275,6 +275,8 @@ import System.Mem( performGC )
import qualified Storage.Hashed.Tree as Tree
import Storage.Hashed.Tree ( Tree )
+import Darcs.Repository.FileMod ( createOrUpdatePatchIndexDisk )
+import Darcs.Repository.Read ( readRepo )
#include "impossible.h"
@@ -466,17 +468,6 @@ siftForPending simple_ps =
Left _ -> sfp (p:>:sofar) ps
sfp sofar (p:<:ps) = sfp (p:>:sofar) ps
--- @todo: we should not have to open the result of HashedRepo and
--- seal it. Instead, update this function to work with type witnesses
--- by fixing DarcsRepo to match HashedRepo in the handling of
--- Repository state.
-readRepo :: (RepoPatch p, ApplyState p ~ Tree)
@beschmi

beschmi Jun 22, 2012

Owner

Why do we have to move this function to a separate file?

@kowey

kowey Jun 23, 2012

Collaborator

Was this to avoid an import cycle?

@beschmi

beschmi Jun 23, 2012

Owner

bsrkaditya: File Internal.hs
bsrkaditya: depends on FileMod.hs
beschmi: ok
beschmi: where do you use Repository.Read.readRepo?
bsrkaditya: (due to finalizeRepoChanges calling createOrUpdatePatchIndexDisk)
bsrkaditya: readRepo is used by FileMod.hs
bsrkaditya: in many places
bsrkaditya: which was in Internal.hs
beschmi: i see
bsrkaditya: hence I moved it to a new file Read.hs

- => Repository p wR wU wT
- -> IO (PatchSet p Origin wR)
-readRepo repo@(Repo r rf _)
- | formatHas HashedInventory rf = HashedRepo.readRepo repo r
- | otherwise = do Sealed ps <- Old.readOldRepo r
- return $ unsafeCoerceP ps
readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT
@@ -786,6 +777,7 @@ finalizeRepositoryChanges repository@(Repo dir rf _) _ updateWorking compr
HashedRepo.finalizeTentativeChanges repository compr
finalizePending repository updateWorking
debugMessage "Done finalizing changes..."
+ createOrUpdatePatchIndexDisk repository
| otherwise = fail Old.oldRepoFailMsg
revertRepositoryChanges :: RepoPatch p
@@ -0,0 +1,24 @@
+module Darcs.Repository.Read ( readRepo ) where
+
+import Darcs.Patch (RepoPatch)
+import Darcs.Patch.Apply ( ApplyState )
+import Storage.Hashed.Tree ( Tree )
+import Darcs.Repository.InternalTypes ( Repository(Repo) )
+import Darcs.Patch.Set ( PatchSet, Origin )
+import Darcs.Repository.Format ( formatHas, RepoProperty(HashedInventory) )
+import qualified Darcs.Repository.HashedRepo as HashedRepo ( readRepo )
+import qualified Darcs.Repository.Old as Old ( readOldRepo )
+import Darcs.Witnesses.Sealed ( Sealed(Sealed) )
+import Darcs.Witnesses.Unsafe ( unsafeCoerceP )
+
+-- @todo: we should not have to open the result of HashedRepo and
+-- seal it. Instead, update this function to work with type witnesses
+-- by fixing DarcsRepo to match HashedRepo in the handling of
+-- Repository state.
+readRepo :: (RepoPatch p, ApplyState p ~ Tree)
+ => Repository p wR wU wT
+ -> IO (PatchSet p Origin wR)
+readRepo repo@(Repo r rf _)
+ | formatHas HashedInventory rf = HashedRepo.readRepo repo r
+ | otherwise = do Sealed ps <- Old.readOldRepo r
+ return $ unsafeCoerceP ps
@@ -155,6 +155,7 @@ module Darcs.UI.Arguments
, usePacks
, recordRollback
, amendUnrecord
+ , patchIndex
) where
import System.Console.GetOpt
@@ -398,6 +399,7 @@ getContent AmendUnrecord = NoContent
getContent NoAmendUnrecord = NoContent
getContent UseWorkingDir = NoContent
getContent UseNoWorkingDir = NoContent
+getContent PatchIndexFlag = NoContent
getContentString :: DarcsFlag -> Maybe String
getContentString f =
@@ -614,6 +616,11 @@ fixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [SubPath]
fixSubPaths flags fs = nub . catMaybes <$> (maybeFixSubPaths flags $
filter (not . null) fs)
+patchIndex :: DarcsOption
+patchIndex = DarcsSingleOption $
+ DarcsNoArgOption [] ["patch-index"] PatchIndexFlag
+ "create, maintain, and use patch index"
+
-- | 'listOptions' is an option which lists the command's arguments
listOptions :: DarcsOption
listOptions = DarcsSingleOption $ DarcsNoArgOption [] ["list-options"] ListOptions
@@ -156,7 +156,7 @@ annotate' opts args@[_] repository = do
showPath (n, File _) = BC.pack (path </> n)
showPath (n, _) = BC.concat [BC.pack (path </> n), "/"]
putStrLn $ fmt (BC.intercalate "\n" $ map showPath $
- map (\(x,y) -> (anchorPath "" x, y)) $ list s') $
@beschmi

beschmi Jun 22, 2012

Owner

Where did that come from? This should not be in the final patch.

+ map (\(x,y) -> (anchorPath "" x, y)) $ list s') $
A.annotateDirectory (invertRL patches) (fp2fn $ "./" ++ path) subs
Just (File b) -> do con <- BC.concat `fmap` toChunks `fmap` readBlob b
putStrLn $ fmt con $ A.annotate (invertRL patches) (fp2fn $ "./" ++ path) con
@@ -35,15 +35,16 @@ import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, commandAlias, findRepos
import Darcs.UI.Arguments ( DarcsFlag(GenContext, HumanReadable, MachineReadable,
Interactive, Count,
NumberPatches, XMLOutput, Summary,
- Verbose, Debug),
+ Verbose, Debug, PatchIndexFlag),
fixSubPaths, changesFormat,
possiblyRemoteRepoDir, getRepourl,
workingRepoDir, onlyToFiles,
summary, changesReverse,
matchSeveralOrRange,
matchMaxcount, maxCount,
allInteractive,
- networkOptions
+ networkOptions,
+ patchIndex
)
import Darcs.UI.Flags ( doReverse, showChangesOnlyToFiles
, toMatchFlags, useCache )
@@ -53,6 +54,8 @@ import Darcs.Repository ( PatchSet, PatchInfoAnd,
withRepositoryDirectory, RepoJob(..),
readRepo, unrecordedChanges )
import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..) )
+import Darcs.Repository.FileMod ( filterPatches )
+import Darcs.Repository.InternalTypes ( Repository )
import Darcs.Patch.Set ( PatchSet(..), newset2RL )
import Darcs.Patch.Info ( toXml, showPatchInfo, escapeXML, PatchInfo )
import Darcs.Patch.Depends ( findCommonWithThem )
@@ -111,7 +114,8 @@ changes = DarcsCommand {commandProgramName = "darcs",
changesReverse,
possiblyRemoteRepoDir,
workingRepoDir,
- allInteractive]}
+ allInteractive,
+ patchIndex]}
changesCmd :: [DarcsFlag] -> [String] -> IO ()
changesCmd opts args
@@ -137,21 +141,21 @@ showChanges opts files =
let normfp = fn2fp . normPath . fp2fn
undoUnrecordedOnFPs = effectOnFilePaths (invert unrec)
recFiles = map normfp . undoUnrecordedOnFPs . map toFilePath <$> files
- filtered_changes p = maybe_reverse $ getChangesInfo opts recFiles p
+ filtered_changes p = maybe_reverse <$> getChangesInfo opts recFiles repository p
debugMessage "About to read the repository..."
patches <- readRepo repository
debugMessage "Done reading the repository."
if Interactive `elem` opts
- then do let (fp_and_fs, _, _) = filtered_changes patches
- fp = map fst fp_and_fs
+ then do (fp_and_fs, _, _) <- filtered_changes patches
+ let fp = map fst fp_and_fs
viewChanges opts fp
else do when (isJust files && not (XMLOutput `elem` opts)) $
putStrLn $ "Changes to "++unwords (fromJust recFiles)++":\n"
debugMessage "About to print the changes..."
let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters
ps <- readRepo repository -- read repo again to prevent holding onto
-- values forced by filtered_changes
- putDocLnWith printers $ changelog opts ps $ filtered_changes patches
+ putDocLnWith printers =<< changelog opts ps `fmap` filtered_changes patches
where maybe_reverse (xs,b,c) = if doReverse opts
then (reverse xs, b, c)
else (xs, b, c)
@@ -177,21 +181,27 @@ changesHelp' =
"patches, print only those that affect foo.c.\n"
getChangesInfo :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Maybe [FilePath]
+ -> Repository p wR wU wT
-> PatchSet p wX wY
- -> ( [(Sealed2 (PatchInfoAnd p), [FilePath])]
- , [(FilePath, FilePath)]
- , Maybe Doc )
-getChangesInfo opts plain_fs ps =
+ -> IO ( [(Sealed2 (PatchInfoAnd p), [FilePath])]
+ , [(FilePath, FilePath)]
+ , Maybe Doc )
+getChangesInfo opts plain_fs repo ps =
case (sp1s, sp2s) of
(Sealed p1s, Sealed p2s) ->
case findCommonWithThem p2s p1s of
_ :> us ->
let ps' = filterRL pf (reverseFL us) in
case plain_fs of
- Nothing -> foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $
+ Nothing -> return $ foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $
maybe id take (maxCount opts) ps'
Just fs -> let fs' = map (\x -> "./" ++ x) fs in
- filterPatchesByNames (maxCount opts) fs' ps'
+ if PatchIndexFlag `elem` opts
+ then do
+ ps'' <- filterPatches repo fs' ps'
+ return $ filterPatchesByNames (maxCount opts) fs' ps''
+ else
+ return $ filterPatchesByNames (maxCount opts) fs' ps'
where matchFlags = toMatchFlags opts
sp1s = if firstMatch matchFlags
then matchFirstPatchset matchFlags ps
@@ -96,6 +96,7 @@ import Printer ( text, errorDoc, ($$) )
import Darcs.Path ( toFilePath, toPath, ioAbsoluteOrRemote)
import Darcs.Witnesses.Sealed ( Sealed(..) )
import English ( englishNum, Noun(..) )
+import Darcs.Repository.FileMod( updatePatchIndexDisk )
getDescription :: String
getDescription = "Create a local copy of a repository."
@@ -181,6 +182,7 @@ getCmd opts [inrepodir] = do
patchSetToRepository fromrepo patches_to_get (useCache opts) (compression opts) (remoteDarcs opts)
debugMessage "Finished converting selected patch set to new repository"
else copyRepoAndGoToChosenVersion opts repodir rfsource
+ withRepository (useCache []) $ RepoJob $ updatePatchIndexDisk
getCmd _ _ = fail "You must provide 'get' with either one or two arguments."
-- | called by getCmd
@@ -28,6 +28,7 @@ import Darcs.UI.Commands.ShowFiles ( showFiles, manifestCmd, toListManifest )
import Darcs.UI.Commands.ShowTags ( showTags )
import Darcs.UI.Commands.ShowRepo ( showRepo )
import Darcs.UI.Commands.ShowIndex ( showIndex, showPristineCmd )
+import Darcs.UI.Commands.ShowPatchIndex ( showPatchIndexAll, showPatchIndexFiles, showPatchIndexAnnotate, showPatchIndexStatus )
showDescription :: String
showDescription = "Show information which is stored by darcs."
@@ -53,7 +54,11 @@ showCommand = SuperCommand {commandProgramName = "darcs",
CommandData showPristine,
CommandData showRepo,
CommandData showAuthors,
- CommandData showTags]
+ CommandData showTags,
+ CommandData showPatchIndexAll,
+ CommandData showPatchIndexFiles,
+ CommandData showPatchIndexAnnotate,
+ CommandData showPatchIndexStatus]
}
query :: DarcsCommand
Oops, something went wrong.

0 comments on commit 7890f8c

Please sign in to comment.