1--  Copyright (C) 2003-2004 David Roundy
2--
3--  This program is free software; you can redistribute it and/or modify
4--  it under the terms of the GNU General Public License as published by
5--  the Free Software Foundation; either version 2, or (at your option)
6--  any later version.
7--
8--  This program is distributed in the hope that it will be useful,
9--  but WITHOUT ANY WARRANTY; without even the implied warranty of
10--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11--  GNU General Public License for more details.
12--
13--  You should have received a copy of the GNU General Public License
14--  along with this program; see the file COPYING.  If not, write to
15--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
16--  Boston, MA 02110-1301, USA.
17
18module Darcs.UI.Commands.Tag ( tag ) where
19
20import Darcs.Prelude
21
22import Control.Monad ( when )
23import System.IO ( hPutStr, stderr )
24
25import Darcs.Patch.Apply ( ApplyState )
26import Darcs.Patch.Info ( patchinfo )
27import Darcs.Patch.Depends ( getUncovered )
28import Darcs.Patch
29    ( PrimPatch, PrimOf
30    , RepoPatch
31    )
32import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )
33import Darcs.Patch.Named ( infopatch, adddeps )
34import Darcs.Patch.Set
35    ( emptyPatchSet, appendPSFL, patchSet2FL, patchSetTags )
36import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) )
37import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )
38
39import Darcs.Repository
40    ( withRepoLock, Repository, RepoJob(..), readRepo
41    , tentativelyAddPatch, finalizeRepositoryChanges,
42    )
43import Darcs.Repository.Flags ( UpdatePending(..), DryRun(NoDryRun) )
44
45import Darcs.UI.Commands
46    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putFinished )
47import Darcs.UI.Completion ( noArgs )
48import Darcs.UI.Flags
49    ( DarcsFlag, getDate, compress, verbosity, useCache, umask, getAuthor, author )
50import Darcs.UI.Options
51    ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )
52import qualified Darcs.UI.Options.All as O
53import Darcs.UI.PatchHeader ( getLog )
54import Darcs.UI.SelectChanges
55    ( WhichChanges(..)
56    , selectionConfig
57    , runSelection
58    , SelectionConfig(allowSkipAll)
59    )
60import qualified Darcs.UI.SelectChanges as S
61
62import Darcs.Util.Path ( AbsolutePath )
63import Darcs.Util.Printer ( Doc, text )
64import Darcs.Util.Tree( Tree )
65
66
67tagDescription :: String
68tagDescription = "Name the current repository state for future reference."
69
70tagHelp :: Doc
71tagHelp = text $
72 "The `darcs tag` command names the current repository state, so that it\n" ++
73 "can easily be referred to later.  Every *important* state should be\n" ++
74 "tagged; in particular it is good practice to tag each stable release\n" ++
75 "with a number or codename.  Advice on release numbering can be found\n" ++
76 "at <http://producingoss.com/en/development-cycle.html>.\n" ++
77 "\n" ++
78 "To reproduce the state of a repository `R` as at tag `t`, use the\n" ++
79 "command `darcs clone --tag t R`.  The command `darcs show tags` lists\n" ++
80 "all tags in the current repository.\n" ++
81 "\n" ++
82 "Tagging also provides significant performance benefits: when Darcs\n" ++
83 "reaches a shared tag that depends on all antecedent patches, it can\n" ++
84 "simply stop processing.\n" ++
85 "\n" ++
86 "Like normal patches, a tag has a name, an author, a timestamp and an\n" ++
87 "optional long description, but it does not change the working tree.\n" ++
88 "A tag can have any name, but it is generally best to pick a naming\n" ++
89 "scheme and stick to it.\n" ++
90 "\n" ++
91 "By default a tag names the entire repository state at the time the tag\n" ++
92 "is created. If the --ask-deps option is used, the patches to include\n" ++
93 "as part of the tag can be explicitly selected.\n" ++
94 "\n" ++
95 "The `darcs tag` command accepts the `--pipe` option, which behaves as\n" ++
96 "described in `darcs record`.\n"
97
98tag :: DarcsCommand
99tag = DarcsCommand
100    { commandProgramName = "darcs"
101    , commandName = "tag"
102    , commandHelp = tagHelp
103    , commandDescription = tagDescription
104    , commandExtraArgs = -1
105    , commandExtraArgHelp = ["[TAGNAME]"]
106    , commandCommand = tagCmd
107    , commandPrereq = amInHashedRepository
108    , commandCompleteArgs = noArgs
109    , commandArgdefaults = nodefaults
110    , commandAdvancedOptions = odesc tagAdvancedOpts
111    , commandBasicOptions = odesc tagBasicOpts
112    , commandDefaults = defaultFlags tagOpts
113    , commandCheckOptions = ocheck tagOpts
114    }
115  where
116    tagBasicOpts
117      = O.patchname
118      ^ O.author
119      ^ O.pipe
120      ^ O.askLongComment
121      ^ O.askDeps
122      ^ O.repoDir
123    tagAdvancedOpts = O.compress ^ O.umask
124    tagOpts = tagBasicOpts `withStdOpts` tagAdvancedOpts
125
126tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
127tagCmd _ opts args =
128  withRepoLock NoDryRun (useCache ? opts) YesUpdatePending (umask ? opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do
129    date <- getDate (hasPipe opts)
130    the_author <- getAuthor (author ? opts) (hasPipe opts)
131    patches <- readRepo repository
132    tags <- return $ patchSetTags patches
133    Sealed chosenPatches <-
134        if O.askDeps ? opts
135            then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (patchSet2FL patches)
136            else return $ Sealed patches
137    let deps = getUncovered chosenPatches
138    (name, long_comment)  <- get_name_log (NilFL :: FL (PrimOf p) wA wA) args tags
139    myinfo <- patchinfo date name the_author long_comment
140    let mypatch = infopatch myinfo NilFL
141    _ <- tentativelyAddPatch repository (compress ? opts) (verbosity ? opts) YesUpdatePending
142             $ n2pia $ adddeps mypatch deps
143    _ <- finalizeRepositoryChanges repository YesUpdatePending (compress ? opts)
144    putFinished opts $ "tagging '"++name++"'"
145  where  get_name_log ::(PrimPatch prim) => FL prim wA wA -> [String] -> [String] -> IO (String, [String])
146         get_name_log nilFL a tags
147                          = do (name, comment, _) <- getLog
148                                  (case parseFlags O.patchname opts of
149                                    Nothing -> Just (unwords a)
150                                    Just s -> Just s)
151                                  (hasPipe opts)
152                                  (parseFlags O.logfile opts)
153                                  (parseFlags O.askLongComment opts)
154                                  Nothing nilFL
155                               when (length name < 2) $ hPutStr stderr $
156                                 "Do you really want to tag '"
157                                 ++name++"'? If not type: darcs obliterate --last=1\n"
158                               when (name `elem` tags) $
159                                  putStrLn $ "WARNING: The tag "  ++
160                                             "\"" ++ name ++ "\"" ++
161                                             " already exists."
162                               return ("TAG " ++ name, comment)
163
164-- This may be useful for developers, but users don't care about
165-- internals:
166--
167-- A tagged version automatically depends on all patches in the
168-- repository.  This allows you to later reproduce precisely that
169-- version.  The tag does this by depending on all patches in the
170-- repository, except for those which are depended upon by other tags
171-- already in the repository.  In the common case of a sequential
172-- series of tags, this means that the tag depends on all patches
173-- since the last tag, plus that tag itself.
174
175askAboutTagDepends
176     :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree)
177     => [DarcsFlag]
178     -> FL (PatchInfoAnd rt p) wX wY
179     -> IO (Sealed (FL (PatchInfoAnd rt p) wX))
180askAboutTagDepends flags ps = do
181  let opts = S.PatchSelectionOptions
182             { S.verbosity = verbosity ? flags
183             , S.matchFlags = []
184             , S.interactive = True
185             , S.selectDeps = O.PromptDeps
186             , S.withSummary = O.NoSummary
187             , S.withContext = O.NoContext
188             }
189  (deps:>_) <- runSelection ps $
190                     ((selectionConfig FirstReversed "depend on" opts Nothing Nothing)
191                          { allowSkipAll = False })
192  return $ Sealed deps
193
194hasPipe :: [DarcsFlag] -> Bool
195hasPipe = parseFlags O.pipe
196