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