darcs-reviewed mirror — http://darcs.net
Darcs.Annotate
hashed-storage >= 0.5.5 && < 0.6,
hashed-storage >= 0.5.6 && < 0.6,
vector >= 0.7,
hashed-storage >= 0.5.5 && < 0.6,
hashed-storage >= 0.5.6 && < 0.6,
vector >= 0.7,
hashed-storage >= 0.5.5 && < 0.6,
hashed-storage >= 0.5.6 && < 0.6,
vector >= 0.7,
-- Copyright (C) 2003 David Roundy
-- Copyright (C) 2003 David Roundy, 2010-2011 Petr Rockai
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, OverloadedStrings #-}
{-# OPTIONS_GHC -cpp #-}
module Darcs.Commands.Annotate ( annotate, createdAsXml ) where
module Darcs.Commands.Annotate ( annotate ) where
import Data.List ( sort )
import Control.Applicative ( (<$>) )
summary, unified, humanReadable,
summary, unified, -- machineReadable,
maybeFixSubPaths,
fixSubPaths,
import Darcs.Repository ( Repository, amInHashedRepository, withRepository, RepoJob(..), readRepo,
getMarkedupFile )
import Darcs.Patch.Set ( PatchSet, newset2RL )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.Patch ( RepoPatch, Named, LineMark(..), patch2patchinfo, xmlSummary )
import Darcs.Repository.State ( readRecorded )
import Darcs.Repository ( Repository, amInHashedRepository, withRepository, RepoJob(..), readRepo )
import Darcs.Patch.Set ( newset2RL )
import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, xmlSummary, invertRL )
import Darcs.Witnesses.Ordered ( mapRL )
import qualified Data.ByteString.Char8 as BC ( unpack, ByteString )
import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )
import Data.ByteString.Lazy ( toChunks )
import Darcs.Patch.Info ( PatchInfo, humanFriendly, toXml, makeFilename,
showPatchInfo )
import Darcs.Patch.PopulationData ( Population(..), PopTree(..), DirMark(..),
nameI, modifiedByI, modifiedHowI,
createdByI, creationNameI,
)
import Darcs.Patch.Population ( getRepoPopVersion, lookupPop, lookupCreationPop,
modifiedToXml,
)
import Darcs.Patch.PatchInfoAnd ( info )
import Darcs.RepoPath ( SubPath, toFilePath )
import Darcs.Match ( matchPatch, haveNonrangeMatch, getFirstMatch )
import Darcs.FilePathMonad( withFilePaths )
import Darcs.Patch.FileName( fp2fn )
import System.FilePath( (</>) )
import Darcs.RepoPath( toFilePath )
import Darcs.Patch.Info ( humanFriendly, toXml, showPatchInfo )
import Darcs.Match ( matchPatch, haveNonrangeMatch, getFirstMatch, getOnePatchset, getNonrangeMatchS )
import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2 )
import Printer ( putDocLn, text, errorDoc, ($$), prefix, (<+>),
Doc, empty, vcat, (<>), renderString, packedString )
#include "impossible.h"
import Darcs.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal )
import qualified Darcs.Annotate as A
import Printer ( putDocLn, Doc )
import Storage.Hashed.Tree( TreeItem(..), readBlob, list, expand )
import Storage.Hashed.Monad( findM, virtualTreeIO )
import Storage.Hashed.AnchoredPath( floatPath, anchorPath )
#include "gadts.h"
humanReadable,
-- machineReadable,
annotateCmd opts args = case args of
[] -> if haveNonrangeMatch opts
then annotatePattern opts
else fail $ "Annotate requires either a patch pattern or a " ++
"file or directory argument."
[""] -> annotateCmd opts []
[_] -> do
f <- head <$> maybeFixSubPaths opts args
case f of
Nothing -> fail "invalid argument"
Just f' -> annotatePath opts f'
_ -> fail "annotate accepts at most one argument"
annotateCmd opts files = withRepository opts (RepoJob (annotate' opts files))
annotatePattern :: [DarcsFlag] -> IO ()
annotatePattern opts =
withRepository opts $ RepoJob $ \repository -> do
annotate' ::
(RepoPatch p) => [DarcsFlag] -> [String] -> Repository p C(r u r) -> IO ()
annotate' opts [] repository = do
when (not $ haveNonrangeMatch opts) $
fail $ "Annotate requires either a patch pattern or a " ++
"file or directory argument."
annotatePath :: [DarcsFlag] -> SubPath -> IO ()
annotatePath opts file = withRepository opts $ RepoJob $ \repository -> do
annotate' opts [""] repository = annotate' opts [] repository
annotate' opts args@[_] repository = do
pinfo <- if haveNonrangeMatch opts
then return $ patch2patchinfo `unseal2` (matchPatch opts r)
else case mapRL info $ newset2RL r of
[] -> fail "Annotate does not currently work correctly on empty repositories."
(x:_) -> return x
pop <- getRepoPopVersion "." pinfo
-- deal with --creator-hash option
let maybe_creation_pi = findCreationPatchinfo opts r
lookup_thing = case maybe_creation_pi of
Nothing -> lookupPop
Just cp -> lookupCreationPop cp
let file' = toFilePath file
if null file'
then case pop of (Pop _ pt) -> annotatePop opts pinfo pt
else case lookup_thing file' pop of
Nothing -> fail $ "There is no file or directory named '"++file'++"'"
Just (Pop _ pt@(PopDir i _))
| modifiedHowI i == RemovedDir && modifiedByI i /= pinfo ->
errorDoc $ text ("The directory '" ++ file' ++
"' was removed by")
$$ humanFriendly (modifiedByI i)
| otherwise -> annotatePop opts pinfo pt
Just (Pop _ pt@(PopFile i))
| modifiedHowI i == RemovedFile && modifiedByI i /= pinfo ->
errorDoc $ text ("The file '" ++ file' ++
"' was removed by")
$$ humanFriendly (modifiedByI i)
| otherwise -> annotateFile repository opts pinfo file pt
annotatePop :: [DarcsFlag] -> PatchInfo -> PopTree PatchInfo -> IO ()
annotatePop opts pinfo pt = putDocLn $ p2format pinfo pt
where p2format = if XMLOutput `elem` opts
then p2xml
else p2s
indent :: Doc -> [Doc]
-- This is a bit nasty:
indent = map (text . i) . lines . renderString
where i "" = ""
i ('#':s) = ('#':s)
i s = " "++s
-- Annotate a directory listing
p2s :: PatchInfo -> PopTree PatchInfo -> Doc
p2s pinfo (PopFile inf) =
created_str
$$ f <+> file_change
where f = packedString $ nameI inf
file_created = text "Created by"
<+> showPatchInfo (fromJust $ createdByI inf)
<+> text "as"
<+> packedString (fromJust $ creationNameI inf)
created_str = prefix "# " file_created
file_change = if modifiedByI inf == pinfo
then text $ show (modifiedHowI inf)
else empty
p2s pinfo (PopDir inf pops) =
created_str
$$ dir <+> dir_change
$$ vcat (map (vcat . indent . p2s pinfo) $ sort pops)
where dir = packedString (nameI inf) <> text "/"
dir_created =
if createdByI inf /= Nothing
then text "Created by "
<+> showPatchInfo (fromJust $ createdByI inf)
<+> text "as"
<+> packedString (fromJust $ creationNameI inf) <> text "/"
else text "Root directory"
created_str = prefix "# " dir_created
dir_change = if modifiedByI inf == pinfo
then text $ show (modifiedHowI inf)
else empty
escapeXML :: String -> Doc
escapeXML = text . strReplace '\'' "'" . strReplace '"' """ .
strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&"
strReplace :: Char -> String -> String -> String
strReplace _ _ [] = []
strReplace x y (z:zs)
| x == z = y ++ (strReplace x y zs)
| otherwise = z : (strReplace x y zs)
createdAsXml :: PatchInfo -> String -> Doc
createdAsXml pinfo as = text "<created_as original_name='"
<> escapeXML as
<> text "'>"
$$ toXml pinfo
$$ text "</created_as>"
--removed_by_xml :: PatchInfo -> String
--removed_by_xml pinfo = "<removed_by>\n"++toXml pinfo++"</removed_by>\n"
p2xmlOpen :: PatchInfo -> PopTree PatchInfo -> Doc
p2xmlOpen _ (PopFile inf) =
text "<file name='" <> escapeXML f <> text "'>"
$$ created
$$ modified
where f = BC.unpack $ nameI inf
created = case createdByI inf of
Nothing -> empty
Just ci -> createdAsXml ci
(BC.unpack $ fromJust $ creationNameI inf)
modified = modifiedToXml inf
p2xmlOpen _ (PopDir inf _) =
text "<directory name='" <> escapeXML f <> text "'>"
$$ created
$$ modified
where f = BC.unpack $ nameI inf
created = case createdByI inf of
Nothing -> empty
Just ci -> createdAsXml ci
(BC.unpack $ fromJust $ creationNameI inf)
modified = modifiedToXml inf
p2xmlClose :: PatchInfo -> PopTree PatchInfo -> Doc
p2xmlClose _(PopFile _) = text "</file>"
p2xmlClose _ (PopDir _ _) = text "</directory>"
p2xml :: PatchInfo -> PopTree PatchInfo -> Doc
p2xml pinf p@(PopFile _) = p2xmlOpen pinf p $$ p2xmlClose pinf p
p2xml pinf p@(PopDir _ pops) = p2xmlOpen pinf p
$$ vcat (map (p2xml pinf) $ sort pops)
$$ p2xmlClose pinf p
annotateFile :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> PatchInfo -> SubPath -> PopTree PatchInfo -> IO ()
annotateFile repository opts pinfo f (PopFile inf) = do
if XMLOutput `elem` opts
then putDocLn $ p2xmlOpen pinfo (PopFile inf)
else putAnn $ if createdByI inf /= Nothing
then text ("File "++toFilePath f++" created by ")
<> showPatchInfo ci <> text (" as " ++ createdname)
else text $ "File "++toFilePath f
mk <- getMarkedupFile repository ci createdname
old_pis <- (dropWhile (/= pinfo).mapRL info.newset2RL) `fmap` readRepo repository
mapM_ (annotateMarkedup opts pinfo old_pis) mk
when (XMLOutput `elem` opts) $ putDocLn $ p2xmlClose pinfo (PopFile inf)
where ci = fromJust $ createdByI inf
createdname = BC.unpack $ fromJust $ creationNameI inf
annotateFile _ _ _ _ _ = impossible
annotateMarkedup :: [DarcsFlag] -> PatchInfo -> [PatchInfo]
-> (BC.ByteString, LineMark PatchInfo) -> IO ()
annotateMarkedup opts | XMLOutput `elem` opts = xmlMarkedup
| otherwise = textMarkedup
textMarkedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark PatchInfo) -> IO ()
textMarkedup _ _ (l,None) = putLine ' ' l
textMarkedup pinfo old_pis (l,RemovedLine wheni)
| wheni == pinfo = putLine '-' l
| wheni `elem` old_pis = return ()
| otherwise = putLine ' ' l
textMarkedup pinfo old_pis (l,AddedLine wheni)
| wheni == pinfo = putLine '+' l
| wheni `elem` old_pis = do putAnn $ text "Following line added by "
<> showPatchInfo wheni
putLine ' ' l
| otherwise = return ()
textMarkedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem)
| whenadd == pinfo = do putAnn $ text "Following line removed by "
<> showPatchInfo whenrem
putLine '+' l
| whenrem == pinfo = do putAnn $ text "Following line added by "
<> showPatchInfo whenadd
putLine '-' l
| whenadd `elem` old_pis && not (whenrem `elem` old_pis) =
do putAnn $ text "Following line removed by " <> showPatchInfo whenrem
putAnn $ text "Following line added by " <> showPatchInfo whenadd
putLine ' ' l
| otherwise = return ()
putLine :: Char -> BC.ByteString -> IO ()
putLine c s = putStrLn $ c : BC.unpack s
putAnn :: Doc -> IO ()
putAnn s = putDocLn $ prefix "# " s
(origpath:_) <- fixSubPaths opts args
recorded <- readRecorded repository
xmlMarkedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark PatchInfo) -> IO ()
xmlMarkedup _ _ (l,None) = putLine ' ' l
xmlMarkedup pinfo old_pis (l,RemovedLine wheni)
| wheni == pinfo = putDocLn $ text "<removed_line>"
$$ escapeXML (BC.unpack l)
$$ text "</removed_line>"
| wheni `elem` old_pis = return ()
| otherwise = putDocLn $ text "<normal_line>"
$$ text "<removed_by>"
$$ toXml wheni
$$ text "</removed_by>"
$$ escapeXML (BC.unpack l)
$$ text "</normal_line>"
xmlMarkedup pinfo old_pis (l,AddedLine wheni)
| wheni == pinfo = putDocLn $ text "<added_line>"
$$ escapeXML (BC.unpack l)
$$ text "</added_line>"
| wheni `elem` old_pis = putDocLn $ text "<normal_line>"
$$ text "<added_by>"
$$ toXml wheni
$$ text "</added_by>"
$$ escapeXML (BC.unpack l)
$$ text "</normal_line>"
| otherwise = return ()
xmlMarkedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem)
| whenadd == pinfo =
putDocLn $ text "<added_line>"
$$ text "<removed_by>"
$$ toXml whenrem
$$ text "</removed_by>"
$$ escapeXML (BC.unpack l)
$$ text "</added_line>"
| whenrem == pinfo =
putDocLn $ text "<removed_line>"
$$ text "<added_by>"
$$ toXml whenadd
$$ text "</added_by>"
$$ escapeXML (BC.unpack l)
$$ text "</removed_line>"
| whenadd `elem` old_pis && not (whenrem `elem` old_pis) =
putDocLn $ text "<normal_line>"
$$ text "<removed_by>"
$$ toXml whenrem
$$ text "</removed_by>"
$$ text "<added_by>"
$$ toXml whenadd
$$ text "</added_by>"
$$ escapeXML (BC.unpack l)
$$ text "</normal_line>"
| otherwise = return ()
(Sealed patches, initial, path) <-
if haveNonrangeMatch opts
then do Sealed x <- getOnePatchset repository opts
[path] <- return $ withFilePaths [toFilePath origpath] (getNonrangeMatchS opts r)
initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS opts r) recorded
return $ (seal $ newset2RL x, initial, path)
else return $ (seal $ newset2RL r, recorded, toFilePath origpath)
findCreationPatchinfo :: [DarcsFlag] -> PatchSet p C(Origin x) -> Maybe PatchInfo
findCreationPatchinfo [] _ = Nothing
findCreationPatchinfo (CreatorHash h:_) r = findHash h $ mapRL info $ newset2RL r
findCreationPatchinfo (_:fs) r = findCreationPatchinfo fs r
found <- findM initial (floatPath path)
-- TODO need to decide about the --machine flag
let fmt = {- if MachineReadable `elem` opts then A.machineFormat else -} A.format
case found of
Nothing -> fail $ "No such file or directory: " ++ path
Just (SubTree s) -> do
s' <- expand s
let subs = map (fp2fn . (path </>) . anchorPath "" . fst) $ list s'
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') $
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
findHash :: String -> [PatchInfo] -> Maybe PatchInfo
findHash _ [] = Nothing
findHash h (pinf:pinfs)
| take (length h) (makeFilename pinf) == h = Just pinf
| otherwise = findHash h pinfs
annotate' _ _ _ = fail "annotate accepts at most one argument"
import Darcs.Patch.Info ( toXml, showPatchInfo )
import Darcs.Patch.Info ( toXml, showPatchInfo, escapeXML, PatchInfo )
import Darcs.Commands.Annotate ( createdAsXml )
renderString, prefix, text, vcat, vsep,
renderString, prefix, text, vcat, vsep, (<>),
createdAsXml :: PatchInfo -> String -> Doc
createdAsXml pinfo as = text "<created_as original_name='"
<> escapeXML as
<> text "'>"
$$ toXml pinfo
$$ text "</created_as>"
getFirstMatch, getNonrangeMatch,
getFirstMatch, getNonrangeMatch, getNonrangeMatchS,
getNonrangeMatchS :: (RepoPatch p) =>
[DarcsFlag] -> PatchSet p C(Origin x) -> IO ()
getNonrangeMatchS :: (WriteableDirectory m, RepoPatch p) =>
[DarcsFlag] -> PatchSet p C(Origin x) -> m ()
getFirstMatchS :: (RepoPatch p) =>
[DarcsFlag] -> PatchSet p C(Origin x) -> IO ()
getFirstMatchS :: (WriteableDirectory m, RepoPatch p) =>
[DarcsFlag] -> PatchSet p C(Origin x) -> m ()
unpullLastN :: (WriteableDirectory m, MonadProgress m, Patchy p) => PatchSet p C(x y) -> Int -> m ()
unpullLastN :: Patchy p => PatchSet p C(x y) -> Int -> IO ()
getTagS :: (WriteableDirectory m, MonadProgress m, RepoPatch p) =>
Matcher p -> PatchSet p C(Origin x) -> m ()
getTagS :: (RepoPatch p) =>
Matcher p -> PatchSet p C(Origin x) -> IO ()
applyInvRL :: (WriteableDirectory m, MonadProgress m, Patchy p) => RL (PatchInfoAnd p) C(x r) -> m ()
applyInvRL :: (Patchy p) => RL (PatchInfoAnd p) C(x r) -> IO ()
showPatchInfo, isTag, readPatchInfos
showPatchInfo, isTag, readPatchInfos, escapeXML
set -ev
. lib
rm -rf temp
mkdir temp
cd temp
# annotate --xml should encode angle brackets in user name
touch c
echo x > c
darcs annotate --xml c | grep "<a\@b.com>"
darcs annotate c
darcs annotate c | grep "a@b.com"
rm -rf temp1
mkdir temp1
cd temp1
darcs annotate directory/bar > log
grep 'How beauteous mankind is' log
darcs annotate directory/bar | tee log
cd ..
rm -rf temp1
grep "mv foo then add new foo" log
not grep "unknown" log
echo '<?xml version="1.0" encoding="ISO-8859-1"?>' > $tmpf
darcs annotate --xml-output --repodir=R dir7 >> $tmpf
xmllint --noout --schema $xsdf $tmpf || exit 1
echo '<?xml version="1.0" encoding="ISO-8859-1"?>' > $tmpf
darcs annotate --xml-output --repodir=R dir7/file3 >> $tmpf
xmllint --noout --schema $xsdf $tmpf || exit 1
echo '<?xml version="1.0" encoding="ISO-8859-1"?>' > $tmpf
darcs annotate --xml-output --repodir=$repod src >> $tmpf
xmllint --noout --schema $xsdf $tmpf || exit 1
echo '<?xml version="1.0" encoding="ISO-8859-1"?>' > $tmpf
darcs annotate --xml-output --repodir=$repod src/Darcs/Patch/Summary.hs >> $tmpf
xmllint --noout --schema $xsdf $tmpf || exit 1