% Copyright (C) 2003-2004 David Roundy
%
% This program is free software; you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation; either version 2, or (at your option)
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program; see the file COPYING. If not, write to
% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
% Boston, MA 02110-1301, USA.
\darcsCommand{tag}
\begin{code}
module Darcs.Commands.Tag ( tag ) where
import System.Directory ( removeFile )
import Control.Monad ( when )
import Darcs.Commands ( DarcsCommand(DarcsCommand, commandName, commandHelp,
commandDescription, commandExtraArgs,
commandExtraArgHelp, commandCommand, commandPrereq,
commandGetArgPossibilities, commandArgdefaults,
commandAdvancedOptions, commandBasicOptions),
nodefaults )
import Darcs.Arguments ( nocompress, umaskOption, patchnameOption, author,
pipeInteractive, askLongComment,
workingRepoDir, getAuthor )
import Darcs.Hopefully ( n2pia )
import Darcs.Repository ( amInRepository, withRepoLock, ($-), read_repo,
tentativelyAddPatch, finalizeRepositoryChanges,
)
import Darcs.Patch ( infopatch, identity, adddeps )
import Darcs.Patch.Info ( patchinfo )
import Darcs.Patch.Depends ( get_tags_right )
import Darcs.Commands.Record ( getDate, getLog )
import Darcs.Witnesses.Ordered ( FL(..) )
import Darcs.Lock ( world_readable_temp )
import Darcs.Flags ( DarcsFlag(..) )
import System.IO ( hPutStr, stderr )
tagDescription :: String
tagDescription = "Name the current repository state for future reference."
tagHelp :: String
tagHelp =
"The `darcs tag' command names the current repository state, so that it\n" ++
"can easily be referred to later. Every `important' state should be\n" ++
"tagged; in particular it is good practice to tag each stable release\n" ++
"with a number or codename. Advice on release numbering can be found\n" ++
"at http://producingoss.com/en/development-cycle.html.\n" ++
"\n" ++
"To reproduce the state of a repository `R' as at tag `t', use the\n" ++
"command `darcs get --tag t R'. The command `darcs show tags' lists\n" ++
"all tags in the current repository.\n" ++
"\n" ++
"Tagging also provides significant performance benefits: when Darcs\n" ++
"reaches a shared tag that depends on all antecedent patches, it can\n" ++
"simply stop processing.\n" ++
"\n" ++
"Like normal patches, a tag has a name, an author, a timestamp and an\n" ++
"optional long description, but it does not change the working tree.\n" ++
"A tag can have any name, but it is generally best to pick a naming\n" ++
"scheme and stick to it.\n" ++
"\n" ++
"The `darcs tag' command accepts the --pipe option, which behaves as\n" ++
"described in `darcs record'.\n"
tag :: DarcsCommand
tag = DarcsCommand {commandName = "tag",
commandHelp = tagHelp,
commandDescription = tagDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["[TAGNAME]"],
commandCommand = tagCmd,
commandPrereq = amInRepository,
commandGetArgPossibilities = return [],
commandArgdefaults = nodefaults,
commandAdvancedOptions = [nocompress,umaskOption],
commandBasicOptions = [patchnameOption, author,
pipeInteractive,
askLongComment,
workingRepoDir]}
tagCmd :: [DarcsFlag] -> [String] -> IO ()
tagCmd opts args = withRepoLock opts $- \repository -> do
date <- getDate opts
the_author <- getAuthor opts
deps <- get_tags_right `fmap` read_repo repository
(name, long_comment, mlogf) <- get_name_log opts args
myinfo <- patchinfo date name the_author long_comment
let mypatch = infopatch myinfo identity
tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps
finalizeRepositoryChanges repository
maybe (return ()) removeFile mlogf
putStrLn $ "Finished tagging patch '"++name++"'"
where get_name_log :: [DarcsFlag] -> [String] -> IO (String, [String], Maybe String)
get_name_log o a = do let o2 = if null a then o else (add_patch_name o (unwords a))
(name, comment, mlogf) <- getLog o2 Nothing (world_readable_temp "darcs-tag") NilFL
when (length name < 2) $ hPutStr stderr $
"Do you really want to tag '"
++name++"'? If not type: darcs obliterate --last=1\n"
return ("TAG " ++ name, comment, mlogf)
add_patch_name :: [DarcsFlag] -> String -> [DarcsFlag]
add_patch_name o a| has_patch_name o = o
| otherwise = [PatchName a] ++ o
has_patch_name (PatchName _:_) = True
has_patch_name (_:fs) = has_patch_name fs
has_patch_name [] = False
\end{code}