module Darcs.UI.Commands.ShowFiles ( showFiles ) where
import Prelude ()
import Darcs.Prelude
import Prelude hiding ( (^) )
import Darcs.UI.Flags ( DarcsFlag, useCache )
import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise
, defaultFlags, parseFlags )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )
import Darcs.Repository ( Repository, withRepository,
RepoJob(..), repoPatchType )
import Darcs.Patch ( IsRepoType, RepoPatch )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Repository.State ( readRecorded, readRecordedAndPending )
import Darcs.Util.Tree( Tree, TreeItem(..), list, expand )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Path( anchorPath, AbsolutePath )
import System.FilePath ( splitDirectories )
import Data.List( isPrefixOf )
import Darcs.Patch.Match ( haveNonrangeMatch )
import Darcs.Repository.Match ( getNonrangeMatch )
import Darcs.Util.Lock ( withDelayedDir )
showFilesDescription :: String
showFilesDescription = "Show version-controlled files in the working tree."
showFilesHelp :: String
showFilesHelp =
"The `darcs show files` command lists those files and directories in\n" ++
"the working tree that are under version control. This command is\n" ++
"primarily for scripting purposes; end users will probably want `darcs\n" ++
"whatsnew --summary`.\n" ++
"\n" ++
"A file is \"pending\" if it has been added but not recorded. By\n" ++
"default, pending files (and directories) are listed; the `--no-pending`\n" ++
"option prevents this.\n" ++
"\n" ++
"By default `darcs show files` lists both files and directories, but the\n" ++
"`--no-files` and `--no-directories` flags modify this behaviour.\n" ++
"\n" ++
"By default entries are one-per-line (i.e. newline separated). This\n" ++
"can cause problems if the files themselves contain newlines or other\n" ++
"control characters. To get around this, the `--null` option uses the\n" ++
"null character instead. The script interpreting output from this\n" ++
"command needs to understand this idiom; `xargs -0` is such a command.\n" ++
"\n" ++
"For example, to list version-controlled files by size:\n" ++
"\n" ++
" darcs show files -0 | xargs -0 ls -ldS\n"
showFilesBasicOpts :: DarcsOption a
(Bool -> Bool -> Bool -> Bool -> [O.MatchFlag] -> Maybe String -> a)
showFilesBasicOpts
= O.files
^ O.directories
^ O.pending
^ O.nullFlag
^ O.matchUpToOne
^ O.workingRepoDir
showFilesOpts :: DarcsOption a
(Bool
-> Bool
-> Bool
-> Bool
-> [O.MatchFlag]
-> Maybe String
-> Maybe O.StdCmdAction
-> Bool
-> Bool
-> O.Verbosity
-> Bool
-> O.UseCache
-> Maybe String
-> Bool
-> Maybe String
-> Bool
-> a)
showFilesOpts = showFilesBasicOpts `withStdOpts` oid
showFiles :: DarcsCommand [DarcsFlag]
showFiles = DarcsCommand {
commandProgramName = "darcs",
commandName = "files",
commandHelp = showFilesHelp,
commandDescription = showFilesDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["[FILE or DIRECTORY]..."],
commandCommand = manifestCmd toListFiles,
commandPrereq = amInRepository,
commandGetArgPossibilities = return [],
commandArgdefaults = nodefaults,
commandAdvancedOptions = [],
commandBasicOptions = odesc showFilesBasicOpts,
commandDefaults = defaultFlags showFilesOpts,
commandCheckOptions = ocheck showFilesOpts,
commandParseOptions = onormalise showFilesOpts }
toListFiles :: [DarcsFlag] -> Tree m -> [FilePath]
toListFiles opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories opts)
filesDirs :: Bool -> Bool -> Tree m -> [FilePath]
filesDirs False False _ = []
filesDirs False True t = "." : [ anchorPath "." p | (p, SubTree _) <- list t ]
filesDirs True False t = [ anchorPath "." p | (p, File _) <- list t ]
filesDirs True True t = "." : map (anchorPath "." . fst) (list t)
manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath])
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
manifestCmd to_list _ opts argList =
mapM_ output =<< manifestHelper to_list opts argList
where
output_null name = do { putStr name ; putChar '\0' }
output = if parseFlags O.nullFlag opts then output_null else putStrLn
manifestHelper :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO [FilePath]
manifestHelper to_list opts argList = do
list' <- to_list opts `fmap` withRepository (useCache opts) (RepoJob slurp)
case argList of
[] -> return list'
prefixes -> return (onlysubdirs prefixes list')
where
matchFlags = parseFlags O.matchUpToOne opts
slurp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> IO (Tree IO)
slurp r = do
let fUpto = haveNonrangeMatch (repoPatchType r) matchFlags
fPending = parseFlags O.pending opts
case (fUpto,fPending) of
(True, False) -> slurpUpto matchFlags r
(True, True) -> error "can't mix match and pending flags"
(False,False) -> expand =<< readRecorded r
(False,True) -> expand =<< readRecordedAndPending r
isParentDir a' b' =
let a = splitDirectories a'
b = splitDirectories b'
in (a `isPrefixOf` b) || (("." : a) `isPrefixOf` b)
onlysubdirs dirs = filter (\p -> any (`isParentDir` p) dirs)
slurpUpto :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> [O.MatchFlag] -> Repository rt p wR wU wR -> IO (Tree IO)
slurpUpto matchFlags r = withDelayedDir "show.files" $ \_ -> do
getNonrangeMatch r matchFlags
expand =<< readPlainTree "."