module Darcs.UI.Commands.ShowTags
( showTags
) where
import Prelude ()
import Darcs.Prelude
import Control.Monad ( unless, join )
import Data.Maybe ( fromMaybe )
import System.IO ( stderr, hPutStrLn )
import Darcs.Patch.Set ( PatchSet(..) )
import Darcs.Repository ( readRepo, withRepositoryLocation, RepoJob(..) )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )
import Darcs.UI.Commands.Util ( repoTags )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags ( DarcsFlag, useCache, getRepourl )
import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Util.Text ( formatText )
import Darcs.Util.Path ( AbsolutePath )
showTagsDescription :: String
showTagsDescription = "Show all tags in the repository."
showTagsHelp :: String
showTagsHelp = formatText 80
[ "The tags command writes a list of all tags in the repository to "
++ "standard output."
, "Tab characters (ASCII character 9) in tag names are changed to spaces "
++ "for better interoperability with shell tools. A warning is printed "
++ "if this happens."
]
showTags :: DarcsCommand [DarcsFlag]
showTags = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "tags"
, commandHelp = showTagsHelp
, commandDescription = showTagsDescription
, commandExtraArgs = 0
, commandExtraArgHelp = []
, commandCommand = tagsCmd
, commandPrereq = findRepository
, commandCompleteArgs = noArgs
, commandArgdefaults = nodefaults
, commandAdvancedOptions = []
, commandBasicOptions = odesc showTagsBasicOpts
, commandDefaults = defaultFlags showTagsOpts
, commandCheckOptions = ocheck showTagsOpts
, commandParseOptions = onormalise showTagsOpts
}
where
showTagsBasicOpts = O.possiblyRemoteRepo
showTagsOpts = showTagsBasicOpts `withStdOpts` oid
tagsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagsCmd _ opts _ = let repodir = fromMaybe "." (getRepourl opts) in
withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo ->
readRepo repo >>= printTags
where
printTags :: PatchSet rt p wW wZ -> IO ()
printTags = join . fmap (sequence_ . map process) . repoTags
process :: String -> IO ()
process t = normalize t t False >>= putStrLn
normalize :: String -> String -> Bool -> IO String
normalize _ [] _ = return []
normalize t (x : xs) flag =
if x == '\t' then do
unless flag $
hPutStrLn stderr $ "warning: tag with TAB character: " ++ t
rest <- normalize t xs True
return $ ' ' : rest
else do
rest <- normalize t xs flag
return $ x : rest