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