module Darcs.UI.Commands.ShowContents ( showContents ) where
import Prelude ()
import Darcs.Prelude
import Prelude hiding ( (^) )
import Control.Monad ( filterM, forM_, forM )
import System.IO ( stdout )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags ( DarcsFlag, useCache, fixSubPaths )
import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Patch.Match ( haveNonrangeMatch )
import Darcs.Repository ( withRepository, RepoJob(..), readRecorded, repoPatchType )
import Darcs.Util.Lock ( withDelayedDir )
import Darcs.Repository.Match ( getNonrangeMatch )
import Darcs.Util.Tree.Plain( readPlainTree )
import qualified Darcs.Util.Tree.Monad as TM
import Darcs.Util.Path( floatPath, sp2fn, toFilePath, AbsolutePath )
showContentsDescription :: String
showContentsDescription :: String
showContentsDescription = "Outputs a specific version of a file."
showContentsHelp :: String
showContentsHelp :: String
showContentsHelp =
"Show contents can be used to display an earlier version of some file(s).\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
"If you give show contents no version arguments, it displays the recorded\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
"version of the file(s).\n"
showContents :: DarcsCommand [DarcsFlag]
showContents :: DarcsCommand [DarcsFlag]
showContents = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
-> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
{ commandProgramName :: String
commandProgramName = "darcs"
, commandName :: String
commandName = "contents"
, commandHelp :: String
commandHelp = String
showContentsHelp
, commandDescription :: String
commandDescription = String
showContentsDescription
, commandExtraArgs :: Int
commandExtraArgs = -1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = ["[FILE]..."]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showContentsCmd
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
findRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = []
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
DarcsOptDescr DarcsFlag Any ([MatchFlag] -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr DarcsFlag Any ([MatchFlag] -> Maybe String -> Any)
forall a.
OptSpec
DarcsOptDescr DarcsFlag a ([MatchFlag] -> Maybe String -> a)
showContentsBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
showContentsOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
DarcsFlag
Any
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
showContentsOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
showContentsOpts
}
where
showContentsBasicOpts :: OptSpec
DarcsOptDescr DarcsFlag a ([MatchFlag] -> Maybe String -> a)
showContentsBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag (Maybe String -> a) [MatchFlag]
MatchOption
O.matchUpToOne PrimOptSpec DarcsOptDescr DarcsFlag (Maybe String -> a) [MatchFlag]
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
DarcsOptDescr DarcsFlag a ([MatchFlag] -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
showContentsOpts :: DarcsOption
a
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
showContentsOpts = PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
[MatchFlag]
MatchOption
O.matchUpToOne PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
[MatchFlag]
-> OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
PrimDarcsOption (Maybe String)
O.repoDir OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
-> DarcsOption
a
([MatchFlag]
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
forall (d :: * -> *) f a. OptSpec d f a a
oid
showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showContentsCmd _ _ [] = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "show contents needs at least one argument."
showContentsCmd fps :: (AbsolutePath, AbsolutePath)
fps opts :: [DarcsFlag]
opts args :: [String]
args = do
[AnchoredPath]
floatedPaths <- (SubPath -> AnchoredPath) -> [SubPath] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath
floatPath (String -> AnchoredPath)
-> (SubPath -> String) -> SubPath -> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> String
forall a. FilePathLike a => a -> String
toFilePath (FileName -> String) -> (SubPath -> FileName) -> SubPath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> FileName
sp2fn) ([SubPath] -> [AnchoredPath]) -> IO [SubPath] -> IO [AnchoredPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
args
let matchFlags :: [MatchFlag]
matchFlags = MatchOption -> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags MatchOption
O.matchUpToOne [DarcsFlag]
opts
UseCache -> RepoJob () -> IO ()
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
let readContents :: RWST AnchoredPath () (TreeState IO) IO [ByteString]
readContents = do
[AnchoredPath]
okpaths <- (AnchoredPath -> RWST AnchoredPath () (TreeState IO) IO Bool)
-> [AnchoredPath]
-> RWST AnchoredPath () (TreeState IO) IO [AnchoredPath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM AnchoredPath -> RWST AnchoredPath () (TreeState IO) IO Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
TM.fileExists [AnchoredPath]
floatedPaths
[AnchoredPath]
-> (AnchoredPath
-> RWST AnchoredPath () (TreeState IO) IO ByteString)
-> RWST AnchoredPath () (TreeState IO) IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AnchoredPath]
okpaths ((AnchoredPath
-> RWST AnchoredPath () (TreeState IO) IO ByteString)
-> RWST AnchoredPath () (TreeState IO) IO [ByteString])
-> (AnchoredPath
-> RWST AnchoredPath () (TreeState IO) IO ByteString)
-> RWST AnchoredPath () (TreeState IO) IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \f :: AnchoredPath
f -> ([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks) (ByteString -> ByteString)
-> RWST AnchoredPath () (TreeState IO) IO ByteString
-> RWST AnchoredPath () (TreeState IO) IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> RWST AnchoredPath () (TreeState IO) IO ByteString
forall (m :: * -> *). TreeRO m => AnchoredPath -> m ByteString
TM.readFile AnchoredPath
f
execReadContents :: Tree IO -> IO [ByteString]
execReadContents tree :: Tree IO
tree = ([ByteString], Tree IO) -> [ByteString]
forall a b. (a, b) -> a
fst (([ByteString], Tree IO) -> [ByteString])
-> IO ([ByteString], Tree IO) -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RWST AnchoredPath () (TreeState IO) IO [ByteString]
-> Tree IO -> IO ([ByteString], Tree IO)
forall a. TreeIO a -> Tree IO -> IO (a, Tree IO)
TM.virtualTreeIO RWST AnchoredPath () (TreeState IO) IO [ByteString]
readContents Tree IO
tree
[ByteString]
files <- if PatchType rt p -> [MatchFlag] -> Bool
forall (rt :: RepoType) (p :: * -> * -> *).
(IsRepoType rt, Matchable p) =>
PatchType rt p -> [MatchFlag] -> Bool
haveNonrangeMatch (Repository rt p wR wU wR -> PatchType rt p
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> PatchType rt p
repoPatchType Repository rt p wR wU wR
repository) [MatchFlag]
matchFlags then
String -> (AbsolutePath -> IO [ByteString]) -> IO [ByteString]
forall a. String -> (AbsolutePath -> IO a) -> IO a
withDelayedDir "show.contents" ((AbsolutePath -> IO [ByteString]) -> IO [ByteString])
-> (AbsolutePath -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \_ -> do
Repository rt p wR wU wR -> [MatchFlag] -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p,
ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> [MatchFlag] -> IO ()
getNonrangeMatch Repository rt p wR wU wR
repository [MatchFlag]
matchFlags
String -> IO (Tree IO)
readPlainTree "." IO (Tree IO) -> (Tree IO -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO [ByteString]
execReadContents
else do
Repository rt p wR wU wR -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repository IO (Tree IO) -> (Tree IO -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO [ByteString]
execReadContents
[ByteString] -> (ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ByteString]
files ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPut Handle
stdout