module Darcs.UI.Commands.ShowContents ( showContents ) where
import Prelude hiding ( (^) )
import Control.Monad ( filterM, forM_, forM, unless )
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.Flags ( DarcsFlag, useCache, fixSubPaths )
import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags, parseFlags )
import qualified Darcs.UI.Options.All as O ( MatchFlag, matchOne, workingRepoDir, StdCmdAction, Verbosity, UseCache )
import Darcs.Patch.ApplyMonad ( withFiles )
import Darcs.Patch.Match
( haveNonrangeMatch
, applyInvToMatcher
, nonrangeMatcher
, InclusiveOrExclusive(..)
, matchExists
, applyNInv
, hasIndexRange )
import Darcs.Repository ( withRepository, RepoJob(..), readRepo, readRecorded, repoPatchType )
import qualified Storage.Hashed.Monad as HSM
import Darcs.Util.Path( floatPath, anchorPath, FileName, fp2fn,
sp2fn, toFilePath, AbsolutePath )
showContentsDescription :: String
showContentsDescription = "Outputs a specific version of a file."
showContentsHelp :: String
showContentsHelp =
"Show contents can be used to display an earlier version of some file(s).\n"++
"If you give show contents no version arguments, it displays the recorded\n"++
"version of the file(s).\n"
showContentsBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe String -> a)
showContentsBasicOpts = O.matchOne ^ O.workingRepoDir
showContentsOpts :: DarcsOption a
([O.MatchFlag]
-> Maybe String
-> Maybe O.StdCmdAction
-> Bool
-> Bool
-> O.Verbosity
-> Bool
-> O.UseCache
-> Maybe String
-> Bool
-> Maybe String
-> Bool
-> a)
showContentsOpts = O.matchOne ^ O.workingRepoDir `withStdOpts` oid
showContents :: DarcsCommand [DarcsFlag]
showContents = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "contents"
, commandHelp = showContentsHelp
, commandDescription = showContentsDescription
, commandExtraArgs = 1
, commandExtraArgHelp = ["[FILE]..."]
, commandCommand = showContentsCmd
, commandPrereq = findRepository
, commandGetArgPossibilities = return []
, commandArgdefaults = nodefaults
, commandAdvancedOptions = []
, commandBasicOptions = odesc showContentsBasicOpts
, commandDefaults = defaultFlags showContentsOpts
, commandCheckOptions = ocheck showContentsOpts
, commandParseOptions = onormalise showContentsOpts
}
showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showContentsCmd _ _ [] = fail "show contents needs at least one argument."
showContentsCmd fps opts args = withRepository (useCache opts) $ RepoJob $ \repository -> do
path_list <- map sp2fn `fmap` fixSubPaths fps args
pristine <- readRecorded repository
unapply <- let matchFlags = parseFlags O.matchOne opts
in
if haveNonrangeMatch (repoPatchType repository) matchFlags
then do
patchset <- readRepo repository
case nonrangeMatcher matchFlags of
Nothing -> case hasIndexRange matchFlags of
Just (n, m) | n == m -> return $ applyNInv (n1) patchset
_ -> fail "Couldn't obtain a valid matcher."
Just m -> do
unless (matchExists m patchset) $
fail $ "Couldn't match pattern " ++ show m
return $ applyInvToMatcher Exclusive m patchset
else return (return ())
let dump :: HSM.TreeIO [(FileName, B.ByteString)]
dump = do
let floatedPaths = map (floatPath . toFilePath) path_list
okpaths <- filterM HSM.fileExists floatedPaths
forM okpaths $ \f -> do
content <- (B.concat . BL.toChunks) `fmap` HSM.readFile f
return (fp2fn $ ("./" ++) $ anchorPath "" f, content)
files <- flip withFiles unapply `fmap` fst
`fmap` HSM.virtualTreeIO dump pristine
forM_ files $ \(_, f) -> B.hPut stdout f