1-- Copyright (C) 2004,2007 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 18-- | 19-- Copyright : 2004, 2007 David Roundy 20-- License : GPL 21-- Maintainer : darcs-devel@darcs.net 22-- Stability : experimental 23-- Portability : portable 24 25{-# LANGUAGE OverloadedStrings #-} 26module Darcs.UI.Commands.Amend 27 ( 28 amend 29 , amendrecord 30 ) where 31 32import Darcs.Prelude 33 34import Control.Monad ( unless ) 35import Data.Maybe ( isNothing, isJust ) 36 37import Darcs.UI.Commands 38 ( DarcsCommand(..), withStdOpts 39 , commandAlias 40 , nodefaults 41 , setEnvDarcsFiles 42 , setEnvDarcsPatches 43 , amInHashedRepository 44 ) 45import Darcs.UI.Commands.Util 46 ( announceFiles 47 , historyEditHelp 48 , testTentativeAndMaybeExit 49 ) 50import Darcs.UI.Completion ( modifiedFileArgs, knownFileArgs ) 51import Darcs.UI.Flags ( diffOpts, pathSetFromArgs ) 52import Darcs.UI.Options ( (^), oparse, odesc, ocheck, defaultFlags, (?) ) 53import qualified Darcs.UI.Options.All as O 54import Darcs.UI.PatchHeader ( updatePatchHeader, AskAboutDeps(..) 55 , HijackOptions(..) 56 , runHijackT ) 57 58import Darcs.Repository.Flags ( UpdatePending(..), DryRun(NoDryRun) ) 59import Darcs.Patch ( IsRepoType, RepoPatch, description, PrimOf 60 , effect, invert, invertFL, sortCoalesceFL 61 ) 62import Darcs.Patch.Apply ( ApplyState ) 63import Darcs.Patch.Depends ( patchSetUnion, findCommonWithThem ) 64import Darcs.Patch.Info ( isTag ) 65import Darcs.Patch.Named ( fmapFL_Named ) 66import Darcs.Patch.PatchInfoAnd ( hopefully ) 67import Darcs.Patch.Set ( Origin, PatchSet, patchSet2RL ) 68import Darcs.Patch.Split ( primSplitter ) 69import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, patchDesc ) 70import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) 71import Darcs.Patch.Rebase.Name ( RebaseName(..) ) 72import Darcs.Util.Path ( AnchoredPath ) 73import Darcs.Repository 74 ( Repository 75 , withRepoLock 76 , RepoJob(..) 77 , identifyRepositoryFor 78 , ReadingOrWriting(Reading) 79 , tentativelyRemovePatches 80 , tentativelyAddPatch 81 , withManualRebaseUpdate 82 , finalizeRepositoryChanges 83 , invalidateIndex 84 , readPendingAndWorking 85 , readRecorded 86 , readRepo 87 ) 88import Darcs.Repository.Pending ( tentativelyRemoveFromPW ) 89import Darcs.Repository.Prefs ( getDefaultRepo ) 90import Darcs.UI.SelectChanges 91 ( WhichChanges(..) 92 , selectionConfigPrim 93 , runInvertibleSelection 94 , withSelectedPatchFromList 95 ) 96import qualified Darcs.UI.SelectChanges as S 97 ( PatchSelectionOptions(..) 98 ) 99import Darcs.Util.Exception ( clarifyErrors ) 100import Darcs.Patch.Witnesses.Ordered 101 ( FL(..), RL, (:>)(..), (+>+) 102 , nullFL, reverseRL, reverseFL, mapFL_FL 103 ) 104import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FlippedSeal(..) ) 105 106import Darcs.Util.English ( anyOfClause, itemizeVertical ) 107import Darcs.Util.Printer ( Doc, formatWords, putDocLn, text, (<+>), ($$), ($+$) ) 108import Darcs.Util.Printer.Color ( ePutDocLn ) 109import Darcs.Util.Tree( Tree ) 110 111 112amendDescription :: String 113amendDescription = "Improve a patch before it leaves your repository." 114 115 116amendHelp :: Doc 117amendHelp = 118 formatWords 119 [ "Amend updates a \"draft\" patch with additions or improvements," 120 , "resulting in a single \"finished\" patch." 121 ] 122 $+$ formatWords 123 [ "By default `amend` proposes you to record additional changes." 124 , "If instead you want to remove changes, use the flag `--unrecord`." 125 ] 126 $+$ formatWords 127 [ "When recording a draft patch, it is a good idea to start the name with" 128 , "`DRAFT:`. When done, remove it with `darcs amend --edit-long-comment`." 129 , "Alternatively, to change the patch name without starting an editor, " 130 , "use the `--name`/`-m` flag:" 131 ] 132 $+$ text 133 " darcs amend --match 'name \"DRAFT: foo\"' --name 'foo2'" 134 $+$ formatWords 135 [ "Like `darcs record`, if you call amend with files as arguments," 136 , "you will only be asked about changes to those files. So to amend a" 137 , "patch to foo.c with improvements in bar.c, you would run:" 138 ] 139 $+$ text 140 " darcs amend --match 'touch foo.c' bar.c" 141 $+$ historyEditHelp 142 143data AmendConfig = AmendConfig 144 { amendUnrecord :: Bool 145 , notInRemote :: [O.NotInRemote] 146 , matchFlags :: [O.MatchFlag] 147 , testChanges :: O.TestChanges 148 , interactive :: Maybe Bool 149 , author :: Maybe String 150 , selectAuthor :: Bool 151 , patchname :: Maybe String 152 , askDeps :: Bool 153 , askLongComment :: Maybe O.AskLongComment 154 , keepDate :: Bool 155 , lookfor :: O.LookFor 156 , _workingRepoDir :: Maybe String 157 , withContext :: O.WithContext 158 , diffAlgorithm :: O.DiffAlgorithm 159 , verbosity :: O.Verbosity 160 , compress :: O.Compression 161 , useIndex :: O.UseIndex 162 , umask :: O.UMask 163 , sse :: O.SetScriptsExecutable 164 , useCache :: O.UseCache 165 } 166 167amend :: DarcsCommand 168amend = DarcsCommand 169 { 170 commandProgramName = "darcs" 171 , commandName = "amend" 172 , commandHelp = amendHelp 173 , commandDescription = amendDescription 174 , commandExtraArgs = -1 175 , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] 176 , commandCommand = amendCmd 177 , commandPrereq = amInHashedRepository 178 , commandCompleteArgs = fileArgs 179 , commandArgdefaults = nodefaults 180 , commandAdvancedOptions = odesc advancedOpts 181 , commandBasicOptions = odesc basicOpts 182 , commandDefaults = defaultFlags allOpts 183 , commandCheckOptions = ocheck allOpts 184 } 185 where 186 fileArgs fps flags args = 187 if (O.amendUnrecord ? flags) 188 then knownFileArgs fps flags args 189 else modifiedFileArgs fps flags args 190 basicOpts 191 = O.amendUnrecord 192 ^ O.notInRemote 193 ^ O.matchOneNontag 194 ^ O.testChanges 195 ^ O.interactive --True 196 ^ O.author 197 ^ O.selectAuthor 198 ^ O.patchname 199 ^ O.askDeps 200 ^ O.askLongComment 201 ^ O.keepDate 202 ^ O.lookfor 203 ^ O.repoDir 204 ^ O.withContext 205 ^ O.diffAlgorithm 206 advancedOpts 207 = O.compress 208 ^ O.useIndex 209 ^ O.umask 210 ^ O.setScriptsExecutable 211 allOpts = withStdOpts basicOpts advancedOpts 212 config = oparse (basicOpts ^ O.verbosity ^ advancedOpts ^ O.useCache) AmendConfig 213 amendCmd fps flags args = pathSetFromArgs fps args >>= doAmend (config flags) 214 215amendrecord :: DarcsCommand 216amendrecord = commandAlias "amend-record" Nothing amend 217 218doAmend :: AmendConfig -> Maybe [AnchoredPath] -> IO () 219doAmend cfg files = 220 withRepoLock NoDryRun (useCache cfg) YesUpdatePending (umask cfg) $ 221 RebaseAwareJob $ \(repository :: Repository rt p wR wU wR) -> do 222 patchSet <- readRepo repository 223 FlippedSeal patches <- filterNotInRemote cfg repository patchSet 224 withSelectedPatchFromList "amend" patches (patchSelOpts cfg) $ \ (_ :> oldp) -> do 225 announceFiles (verbosity cfg) files "Amending changes in" 226 -- auxiliary function needed because the witness types differ for the isTag case 227 pristine <- readRecorded repository 228 pending :> working <- 229 readPendingAndWorking 230 (diffingOpts cfg) 231 (O.moves (lookfor cfg)) 232 (O.replaces (lookfor cfg)) 233 repository 234 files 235 let go :: forall wU1 . FL (PrimOf p) wR wU1 -> IO () 236 go NilFL | not (hasEditMetadata cfg) = 237 putInfo cfg "No changes!" 238 go ch = 239 do let selection_config = 240 selectionConfigPrim First "record" 241 (patchSelOpts cfg) 242 --([All,Unified] `intersect` opts) 243 (Just (primSplitter (diffAlgorithm cfg))) 244 files 245 (Just pristine) 246 (chosenPatches :> _) <- runInvertibleSelection ch selection_config 247 addChangesToPatch cfg repository oldp chosenPatches pending working 248 if not (isTag (info oldp)) 249 -- amending a normal patch 250 then if amendUnrecord cfg 251 then do let selection_config = 252 selectionConfigPrim Last "unrecord" 253 (patchSelOpts cfg) 254 -- ([All,Unified] `intersect` opts) 255 (Just (primSplitter (diffAlgorithm cfg))) 256 files 257 (Just pristine) 258 (_ :> chosenPrims) <- runInvertibleSelection (effect oldp) selection_config 259 let invPrims = reverseRL (invertFL chosenPrims) 260 addChangesToPatch cfg repository oldp invPrims pending working 261 else go (sortCoalesceFL (pending +>+ working)) 262 -- amending a tag 263 else if hasEditMetadata cfg && isNothing files 264 -- the user is not trying to add new changes to the tag so there is 265 -- no reason to warn. 266 then go NilFL 267 -- the user is trying to add new changes to a tag. 268 else do if hasEditMetadata cfg 269 -- the user already knows that it is possible to edit tag metadata, 270 -- note that s/he is providing editing options! 271 then ePutDocLn "You cannot add new changes to a tag." 272 -- the user may not be aware that s/he can edit tag metadata. 273 else ePutDocLn "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend)." 274 go NilFL 275 276 277addChangesToPatch :: forall rt p wR wU wT wX wY wP 278 . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 279 => AmendConfig 280 -> Repository rt p wR wU wT 281 -> PatchInfoAnd rt p wX wT 282 -> FL (PrimOf p) wT wY 283 -> FL (PrimOf p) wT wP 284 -> FL (PrimOf p) wP wU 285 -> IO () 286addChangesToPatch cfg _repository oldp chs pending working = 287 if nullFL chs && not (hasEditMetadata cfg) 288 then putInfo cfg "You don't want to record anything!" 289 else do 290 invalidateIndex _repository 291 -- If a rebase is in progress, we want to manually update the rebase 292 -- state, using the amendments directly as rebase fixups. This is 293 -- necessary because otherwise the normal commute rules for the rebase 294 -- state will first remove the original patch then add the amended patch, 295 -- and this can lead to more conflicts than using the amendment as a fixup 296 -- directly. For example, if a rename operation is amended in, the rename 297 -- can be propagated to any edits to the file in the rebase state, whereas 298 -- a delete then add would just cause a conflict. 299 -- 300 -- We can also signal that any explicit dependencies of the old patch 301 -- should be rewritten for the new patch using a 'NameFixup'. 302 (_repository, (mlogf, newp)) <- 303 withManualRebaseUpdate _repository $ \_repository -> do 304 -- Note we pass NoUpdatePending here and below when re-adding the 305 -- amended patch, and instead fix pending explicitly further below. 306 _repository <- 307 tentativelyRemovePatches 308 _repository 309 (compress cfg) 310 NoUpdatePending 311 (oldp :>: NilFL) 312 (mlogf, newp) <- 313 runHijackT AlwaysRequestHijackPermission $ 314 updatePatchHeader 315 "amend" 316 (if askDeps cfg 317 then AskAboutDeps _repository 318 else NoAskAboutDeps) 319 (patchSelOpts cfg) 320 (diffAlgorithm cfg) 321 (keepDate cfg) 322 (selectAuthor cfg) 323 (author cfg) 324 (patchname cfg) 325 (askLongComment cfg) 326 (fmapFL_Named effect (hopefully oldp)) 327 chs 328 let fixups = 329 mapFL_FL PrimFixup (invert chs) +>+ 330 NameFixup (Rename (info newp) (info oldp)) :>: 331 NilFL 332 setEnvDarcsFiles newp 333 _repository <- 334 tentativelyAddPatch 335 _repository 336 (compress cfg) 337 (verbosity cfg) 338 NoUpdatePending 339 newp 340 return (_repository, fixups, (mlogf, newp)) 341 let failmsg = maybe "" (\lf -> "\nLogfile left in " ++ lf ++ ".") mlogf 342 testTentativeAndMaybeExit 343 _repository 344 (verbosity cfg) 345 (testChanges cfg) 346 (sse cfg) 347 (isInteractive cfg) 348 ("you have a bad patch: '" ++ patchDesc newp ++ "'") 349 "amend it" 350 (Just failmsg) 351 tentativelyRemoveFromPW _repository chs pending working 352 _repository <- 353 finalizeRepositoryChanges _repository YesUpdatePending (compress cfg) 354 `clarifyErrors` failmsg 355 case verbosity cfg of 356 O.NormalVerbosity -> putDocLn "Finished amending patch." 357 O.Verbose -> putDocLn $ "Finished amending patch:" $$ description newp 358 _ -> return () 359 setEnvDarcsPatches (newp :>: NilFL) 360 361filterNotInRemote :: (IsRepoType rt, RepoPatch p) 362 => AmendConfig 363 -> Repository rt p wR wU wT 364 -> PatchSet rt p Origin wR 365 -> IO (FlippedSeal (RL (PatchInfoAnd rt p)) wR) 366filterNotInRemote cfg repository patchSet = do 367 nirs <- mapM getNotInRemotePath (notInRemote cfg) 368 if null nirs 369 then 370 return (FlippedSeal (patchSet2RL patchSet)) 371 else do 372 putInfo cfg $ 373 "Determining patches not in" <+> anyOfClause nirs $$ itemizeVertical 2 nirs 374 Sealed thems <- patchSetUnion `fmap` mapM readNir nirs 375 _ :> only_ours <- return $ findCommonWithThem patchSet thems 376 return (FlippedSeal (reverseFL only_ours)) 377 where 378 readNir loc = do 379 repo <- identifyRepositoryFor Reading repository (useCache cfg) loc 380 rps <- readRepo repo 381 return (Sealed rps) 382 getNotInRemotePath (O.NotInRemotePath p) = return p 383 getNotInRemotePath O.NotInDefaultRepo = do 384 defaultRepo <- getDefaultRepo 385 let err = fail $ "No default push/pull repo configured, please pass a " 386 ++ "repo name to --" ++ O.notInRemoteFlagName 387 maybe err return defaultRepo 388 389hasEditMetadata :: AmendConfig -> Bool 390hasEditMetadata cfg = isJust (author cfg) 391 || selectAuthor cfg 392 || isJust (patchname cfg) 393 || askLongComment cfg == Just O.YesEditLongComment 394 || askLongComment cfg == Just O.PromptLongComment 395 || askDeps cfg 396 397-- hasEditMetadata [] = False 398-- hasEditMetadata (Author _:_) = True 399-- hasEditMetadata (SelectAuthor:_) = True 400-- hasEditMetadata (LogFile _:_) = True -- ??? not listed as an option for amend 401-- hasEditMetadata (PatchName _:_) = True 402-- hasEditMetadata (EditLongComment:_) = True 403-- hasEditMetadata (PromptLongComment:_) = True 404-- hasEditMetadata (AskDeps:_) = True 405-- hasEditMetadata (_:fs) = hasEditMetadata fs 406 407 408patchSelOpts :: AmendConfig -> S.PatchSelectionOptions 409patchSelOpts cfg = S.PatchSelectionOptions 410 { S.verbosity = verbosity cfg 411 , S.matchFlags = matchFlags cfg 412 , S.interactive = isInteractive cfg 413 , S.selectDeps = O.PromptDeps -- option not supported, use default 414 , S.withSummary = O.NoSummary -- option not supported, use default 415 , S.withContext = withContext cfg 416 } 417 418diffingOpts :: AmendConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) 419diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) O.NoIncludeBoring (diffAlgorithm cfg) 420 421isInteractive :: AmendConfig -> Bool 422isInteractive = maybe True id . interactive 423 424putInfo :: AmendConfig -> Doc -> IO () 425putInfo cfg what = unless (verbosity cfg == O.Quiet) $ putDocLn what 426