module Darcs.UI.Commands.Annotate ( annotate ) where
import Prelude hiding ( (^) )
import Control.Arrow ( first )
import Control.Monad ( unless )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )
import Darcs.UI.Flags ( DarcsFlag(NoPatchIndexFlag), isUnified, useCache, fixSubPaths, hasSummary, umask )
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise
, defaultFlags, parseFlags )
import qualified Darcs.UI.Options.All as O
import Storage.Hashed.Plain( readPlainTree )
import Darcs.Repository.State ( readRecorded )
import Darcs.Repository
( withRepository
, withRepoLockCanFail
, RepoJob(..)
, readRepo
, repoPatchType
, listRegisteredFiles
)
import Darcs.Repository.Flags ( UpdateWorking(..) )
import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex )
import Darcs.Patch.Set ( newset2RL )
import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, invertRL )
import qualified Darcs.Patch ( summary )
import Darcs.Patch.Type ( PatchType(..) )
import Darcs.Patch.Dummy ( DummyPatch )
import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )
import Data.ByteString.Lazy ( toChunks )
import Darcs.UI.PrintPatch ( printPatch, contextualPrintPatch )
import Darcs.Patch.ApplyMonad( withFileNames )
import System.FilePath.Posix ( (</>) )
import Darcs.Patch.Info ( showPatchInfoUI, showPatchInfo )
import Darcs.Patch.Match ( matchPatch, haveNonrangeMatch, getNonrangeMatchS )
import Darcs.Repository.Match ( getFirstMatch, getOnePatchset )
import Darcs.Repository.Lock ( withTempDir )
import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal )
import qualified Darcs.Patch.Annotate as A
import Darcs.Util.Printer ( putDocLn, Doc )
import Storage.Hashed.Tree( TreeItem(..), readBlob, list, expand )
import Storage.Hashed.Monad( findM, virtualTreeIO )
import Darcs.Util.Path( floatPath, anchorPath, fp2fn, toFilePath
, AbsolutePath )
import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )
#include "impossible.h"
annotateDescription :: String
annotateDescription = "Display which patch last modified something."
annotateHelp :: String
annotateHelp = unlines
[ "The `darcs annotate` command provides two unrelated operations. When"
, "called on a file, it will find the patch that last modified each line"
, "in that file. When called on a patch (e.g. using `--patch`), it will"
, "print the internal representation of that patch."
, ""
, "The `--summary` option will result in a summarized patch annotation,"
, "similar to `darcs whatsnew`. It has no effect on file annotations."
, ""
, "By default, output is in a human-readable format. The `--machine-readable`"
, "option can be used to generate output for machine postprocessing."
]
annotateBasicOpts :: DarcsOption a
(Maybe O.Summary
-> O.WithContext
-> Bool
-> [O.MatchFlag]
-> Maybe String
-> a)
annotateBasicOpts = O.summary
^ O.withContext
^ O.machineReadable
^ O.matchOne
^ O.workingRepoDir
annotateAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a)
annotateAdvancedOpts = O.patchIndexYes
annotateOpts :: DarcsOption a
(Maybe O.Summary
-> O.WithContext
-> Bool
-> [O.MatchFlag]
-> Maybe String
-> Maybe O.StdCmdAction
-> Bool
-> Bool
-> O.Verbosity
-> Bool
-> O.WithPatchIndex
-> O.UseCache
-> Maybe String
-> Bool
-> Maybe String
-> Bool
-> a)
annotateOpts = annotateBasicOpts `withStdOpts` annotateAdvancedOpts
annotate :: DarcsCommand [DarcsFlag]
annotate = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "annotate"
, commandHelp = annotateHelp
, commandDescription = annotateDescription
, commandExtraArgs = 1
, commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
, commandCommand = annotateCmd
, commandPrereq = amInHashedRepository
, commandGetArgPossibilities = listRegisteredFiles
, commandArgdefaults = nodefaults
, commandAdvancedOptions = odesc annotateAdvancedOpts
, commandBasicOptions = odesc annotateBasicOpts
, commandDefaults = defaultFlags annotateOpts
, commandCheckOptions = ocheck annotateOpts
, commandParseOptions = onormalise annotateOpts
}
annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
annotateCmd fps opts [""] = annotate' fps opts []
annotateCmd fps opts [] = do
let matchFlags = parseFlags O.matchOne opts
unless (haveNonrangeMatch (PatchType :: PatchType DummyPatch) matchFlags) $
fail $ "Annotate requires either a patch pattern or a " ++
"file or directory argument."
annotate' fps opts []
annotateCmd fps opts args = annotate' fps opts args
annotate' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
annotate' _ opts [] =
withRepository (useCache opts) $ RepoJob $ \repository -> do
let matchFlags = parseFlags O.matchOne opts
Sealed2 p <- matchPatch matchFlags `fmap` readRepo repository
if hasSummary O.NoSummary opts == O.YesSummary
then do putDocLn $ showpi $ patch2patchinfo p
putDocLn $ show_summary p
else if isUnified opts == O.YesContext
then withTempDir "context" $ \_ ->
do getFirstMatch repository matchFlags
c <- readPlainTree "."
contextualPrintPatch c p
else printPatch p
where showpi | parseFlags O.machineReadable opts = showPatchInfo
| otherwise = showPatchInfoUI
show_summary :: RepoPatch p => Named p wX wY -> Doc
show_summary = Darcs.Patch.summary
annotate' fps opts args@[_] = do
unless (NoPatchIndexFlag `elem` opts)
$ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts) $ RepoJob attemptCreatePatchIndex
withRepository (useCache opts) $ RepoJob $ \repository -> do
let matchFlags = parseFlags O.matchOne opts
r <- readRepo repository
(origpath:_) <- fixSubPaths fps args
recorded <- readRecorded repository
(patches, initial, path') <-
if haveNonrangeMatch (repoPatchType repository) matchFlags
then do Sealed x <- getOnePatchset repository matchFlags
let fn = [fp2fn $ toFilePath origpath]
nonRangeMatch = getNonrangeMatchS matchFlags r
(_, [path], _) = withFileNames Nothing fn nonRangeMatch
initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS matchFlags r) recorded
return (seal $ newset2RL x, initial, toFilePath path)
else return (seal $ newset2RL r, recorded, toFilePath origpath)
let path = "./" ++ path'
found <- findM initial (floatPath $ toFilePath path)
let fmt = if parseFlags O.machineReadable opts then A.machineFormat else A.format
case found of
Nothing -> fail $ "No such file or directory: " ++ toFilePath 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), "/"]
(Sealed ans_patches) <- do
upi <- canUsePatchIndex repository
if not upi
then return patches
else getRelevantSubsequence patches repository subs
putStrLn $ fmt (BC.intercalate "\n" $
map (showPath . first (anchorPath "")) $ list s') $
A.annotateDirectory D.MyersDiff (invertRL ans_patches) (fp2fn path) subs
Just (File b) -> do (Sealed ans_patches) <- do
upi <- canUsePatchIndex repository
if not upi
then return patches
else getRelevantSubsequence patches repository [fp2fn path]
con <- BC.concat `fmap` toChunks `fmap` readBlob b
putStrLn $ fmt con $ A.annotate D.MyersDiff (invertRL ans_patches) (fp2fn path) con
Just (Stub _ _) -> impossible
annotate' _ _ _ = fail "annotate accepts at most one argument"