{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Annotate ( annotate ) where
import Darcs.Prelude
import Control.Monad ( when )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.External ( viewDocWith )
import Darcs.UI.Flags ( DarcsFlag, useCache, patchIndexYes, pathsFromArgs )
import Darcs.UI.Options ( (^), odesc, ocheck
, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.State ( readRecorded )
import Darcs.Repository
( withRepository
, withRepoLockCanFail
, RepoJob(..)
, readRepo
)
import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex )
import Darcs.Patch.Set ( patchSet2RL )
import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )
import Data.ByteString.Lazy ( toChunks )
import Darcs.Patch.ApplyMonad( withFileNames )
import Darcs.Patch.Match ( patchSetMatch, rollbackToPatchSetMatch )
import Darcs.Repository.Match ( getOnePatchset )
import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )
import qualified Darcs.Patch.Annotate as A
import Darcs.Util.Tree( TreeItem(..) )
import qualified Darcs.Util.Tree as T ( readBlob, list, expand )
import Darcs.Util.Tree.Monad( findM, virtualTreeIO )
import Darcs.Util.Path( AbsolutePath, AnchoredPath, displayPath, catPaths )
import Darcs.Util.Printer ( Doc, simplePrinters, renderString, text )
import Darcs.Util.Exception ( die )
annotateDescription :: String
annotateDescription :: String
annotateDescription = String
"Annotate lines of a file with the last patch that modified it."
annotateHelp :: Doc
annotateHelp :: Doc
annotateHelp = String -> Doc
text forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ String
"When `darcs annotate` is called on a file, it will find the patch that"
, String
"last modified each line in that file. This also works on directories."
, String
""
, String
"The `--machine-readable` option can be used to generate output for"
, String
"machine postprocessing."
]
annotate :: DarcsCommand
annotate :: DarcsCommand
annotate = DarcsCommand
{ commandProgramName :: String
commandProgramName = String
"darcs"
, commandName :: String
commandName = String
"annotate"
, commandHelp :: Doc
commandHelp = Doc
annotateHelp
, commandDescription :: String
commandDescription = String
annotateDescription
, commandExtraArgs :: Int
commandExtraArgs = Int
1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[FILE or DIRECTORY]"]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
annotateCmd
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
knownFileArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
annotateAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Bool -> [MatchFlag] -> Maybe String -> a)
annotateBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Bool
-> [MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> WithPatchIndex
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
annotateOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
(Bool
-> [MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> WithPatchIndex
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
annotateOpts
}
where
annotateBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Bool -> [MatchFlag] -> Maybe String -> a)
annotateBasicOpts = PrimDarcsOption Bool
O.machineReadable forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ MatchOption
O.matchUpToOne forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
annotateAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
annotateAdvancedOpts = forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
O.patchIndexYes
annotateOpts :: DarcsOption
a
(Bool
-> [MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> WithPatchIndex
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
annotateOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Bool -> [MatchFlag] -> Maybe String -> a)
annotateBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
annotateAdvancedOpts
annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
annotateCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
args = do
[AnchoredPath]
paths <- (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]
pathsFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
case [AnchoredPath]
paths of
[AnchoredPath
path] -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
patchIndexYes forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts forall a. Eq a => a -> a -> Bool
== WithPatchIndex
O.YesPatchIndex)
forall a b. (a -> b) -> a -> b
$ UseCache -> RepoJob () -> IO ()
withRepoLockCanFail (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
forall a b. (a -> b) -> a -> b
$ forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob (\Repository rt p wR wU wR
repo -> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()
attemptCreatePatchIndex Repository rt p wR wU wR
repo)
[DarcsFlag] -> AnchoredPath -> IO ()
annotateCmd' [DarcsFlag]
opts AnchoredPath
path
[AnchoredPath]
_ -> forall a. String -> IO a
die String
"Error: annotate requires a single filepath argument"
annotateCmd' :: [DarcsFlag] -> AnchoredPath -> IO ()
annotateCmd' :: [DarcsFlag] -> AnchoredPath -> IO ()
annotateCmd' [DarcsFlag]
opts AnchoredPath
fixed_path = forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
let matchFlags :: [MatchFlag]
matchFlags = forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags MatchOption
O.matchUpToOne [DarcsFlag]
opts
PatchSet rt p Origin wR
r <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
Tree IO
recorded <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repository
(Sealed (RL (PatchInfoAnd rt p) Origin)
patches, Tree IO
initial, AnchoredPath
path) <-
case [MatchFlag] -> Maybe PatchSetMatch
patchSetMatch [MatchFlag]
matchFlags of
Just PatchSetMatch
psm -> do
Sealed PatchSet rt p Origin wX
x <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wR
-> PatchSetMatch -> IO (SealedPatchSet rt p Origin)
getOnePatchset Repository rt p wR wU wR
repository PatchSetMatch
psm
let ([AnchoredPath]
_, [AnchoredPath
path'], [OrigFileNameOf]
_) =
forall a.
Maybe [OrigFileNameOf]
-> [AnchoredPath] -> FilePathMonad a -> FilePathMonadState
withFileNames forall a. Maybe a
Nothing [AnchoredPath
fixed_path] (forall (p :: * -> * -> *) (m :: * -> *) (rt :: RepoType) wX.
(ApplyMonad (ApplyState p) m, IsRepoType rt, MatchableRP p,
ApplyState p ~ Tree) =>
PatchSetMatch -> PatchSet rt p Origin wX -> m ()
rollbackToPatchSetMatch PatchSetMatch
psm PatchSet rt p Origin wR
r)
Tree IO
initial <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO (forall (p :: * -> * -> *) (m :: * -> *) (rt :: RepoType) wX.
(ApplyMonad (ApplyState p) m, IsRepoType rt, MatchableRP p,
ApplyState p ~ Tree) =>
PatchSetMatch -> PatchSet rt p Origin wX -> m ()
rollbackToPatchSetMatch PatchSetMatch
psm PatchSet rt p Origin wR
r) Tree IO
recorded
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> *) wX. a wX -> Sealed a
seal forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wX
x, Tree IO
initial, AnchoredPath
path')
Maybe PatchSetMatch
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> *) wX. a wX -> Sealed a
seal forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
r, Tree IO
recorded, AnchoredPath
fixed_path)
Maybe (TreeItem IO)
found <- forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> m (Maybe (TreeItem m))
findM Tree IO
initial AnchoredPath
path
let (ByteString -> AnnotateResult -> String
fmt, Doc -> IO ()
view) = if forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Bool
O.machineReadable [DarcsFlag]
opts
then (ByteString -> AnnotateResult -> String
A.machineFormat, String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
renderString)
else (ByteString -> AnnotateResult -> String
A.format, Printers -> Doc -> IO ()
viewDocWith Printers
simplePrinters)
Bool
usePatchIndex <- (forall a. YesNo a => a -> Bool
O.yes (forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
O.patchIndexYes forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) Bool -> Bool -> Bool
&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO Bool
canUsePatchIndex Repository rt p wR wU wR
repository
case Maybe (TreeItem IO)
found of
Maybe (TreeItem IO)
Nothing -> forall a. String -> IO a
die forall a b. (a -> b) -> a -> b
$ String
"Error: path not found in repository: " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
fixed_path
Just (SubTree Tree IO
s) -> do
Tree IO
s' <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
T.expand Tree IO
s
let subs :: [AnchoredPath]
subs = forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath -> AnchoredPath -> AnchoredPath
catPaths AnchoredPath
path forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
T.list Tree IO
s'
showPath :: (AnchoredPath, TreeItem m) -> ByteString
showPath (AnchoredPath
n, File Blob m
_) = String -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
displayPath forall a b. (a -> b) -> a -> b
$ AnchoredPath
path AnchoredPath -> AnchoredPath -> AnchoredPath
`catPaths` AnchoredPath
n
showPath (AnchoredPath
n, TreeItem m
_) = [ByteString] -> ByteString
BC.concat [String -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
displayPath forall a b. (a -> b) -> a -> b
$ AnchoredPath
path AnchoredPath -> AnchoredPath -> AnchoredPath
`catPaths` AnchoredPath
n, ByteString
"/"]
(Sealed RL (PatchInfoAnd rt p) Origin wX
ans_patches) <- do
if Bool -> Bool
not Bool
usePatchIndex
then forall (m :: * -> *) a. Monad m => a -> m a
return Sealed (RL (PatchInfoAnd rt p) Origin)
patches
else forall (p :: * -> * -> *) (a :: * -> * -> *) (rt :: RepoType) wK wR
wU.
(RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) =>
Sealed (RL a wK)
-> Repository rt p wR wU wR
-> PatchSet rt p Origin wR
-> [AnchoredPath]
-> IO (Sealed (RL a Origin))
getRelevantSubsequence Sealed (RL (PatchInfoAnd rt p) Origin)
patches Repository rt p wR wU wR
repository PatchSet rt p Origin wR
r [AnchoredPath]
subs
Doc -> IO ()
view forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall a b. (a -> b) -> a -> b
$
ByteString -> AnnotateResult -> String
fmt (ByteString -> [ByteString] -> ByteString
BC.intercalate ByteString
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *}. (AnchoredPath, TreeItem m) -> ByteString
showPath forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
T.list Tree IO
s') forall a b. (a -> b) -> a -> b
$
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
AnnotateRP p =>
RL (PatchInfoAnd rt p) wX wY
-> AnchoredPath -> [AnchoredPath] -> AnnotateResult
A.annotateDirectory RL (PatchInfoAnd rt p) Origin wX
ans_patches AnchoredPath
path [AnchoredPath]
subs
Just (File Blob IO
b) -> do (Sealed RL (PatchInfoAnd rt p) Origin wX
ans_patches) <- do
if Bool -> Bool
not Bool
usePatchIndex
then forall (m :: * -> *) a. Monad m => a -> m a
return Sealed (RL (PatchInfoAnd rt p) Origin)
patches
else forall (p :: * -> * -> *) (a :: * -> * -> *) (rt :: RepoType) wK wR
wU.
(RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) =>
Sealed (RL a wK)
-> Repository rt p wR wU wR
-> PatchSet rt p Origin wR
-> [AnchoredPath]
-> IO (Sealed (RL a Origin))
getRelevantSubsequence Sealed (RL (PatchInfoAnd rt p) Origin)
patches Repository rt p wR wU wR
repository PatchSet rt p Origin wR
r [AnchoredPath
path]
ByteString
con <- [ByteString] -> ByteString
BC.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> [ByteString]
toChunks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *). Blob m -> m ByteString
T.readBlob Blob IO
b
Doc -> IO ()
view forall a b. (a -> b) -> a -> b
$ String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> AnnotateResult -> String
fmt ByteString
con forall a b. (a -> b) -> a -> b
$
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
AnnotateRP p =>
RL (PatchInfoAnd rt p) wX wY
-> AnchoredPath -> ByteString -> AnnotateResult
A.annotateFile RL (PatchInfoAnd rt p) Origin wX
ans_patches AnchoredPath
path ByteString
con
Just (Stub IO (Tree IO)
_ Hash
_) -> forall a. HasCallStack => String -> a
error String
"impossible case"