module Darcs.Commands.AmendRecord
(
amendrecord
, amendunrecord
) where
#include "gadts.h"
import Data.Maybe ( isJust, isNothing )
import Data.List ( intersect )
import Control.Applicative ( (<$>) )
import Control.Monad ( when, unless )
import System.Directory ( removeFile )
import System.Exit ( ExitCode(..), exitWith )
import Darcs.Arguments ( DarcsFlag ( All, AmendUnrecord, Unified ),
fixSubPaths, setEnvDarcsFiles,
allInteractive, ignoretimes,
askLongComment, askdeps, keepDate, author, patchnameOption,
leaveTestDir, nocompress, lookforadds,
workingRepoDir,
matchOneNontag, umaskOption,
test, listRegisteredFiles,
getEasyAuthor, setScriptsExecutableOption, amendUnrecord
, unified
)
import Darcs.Commands ( DarcsCommand(..), commandAlias, nodefaults )
import Darcs.Commands.Record ( getDate, getLog, askAboutDepends )
import Darcs.Commands.Util ( announceFiles )
import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName, AskDeps,
EditLongComment, PromptLongComment, KeepDate)
, isInteractive
, diffingOpts, compression, removeFromAmended )
import Darcs.Lock ( worldReadableTemp )
import Darcs.Patch ( RepoPatch, description, PrimOf, fromPrims,
infopatch, getdeps, adddeps, effect, invertFL
)
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString,
PatchInfo, patchinfo, isInverted, isTag, invertName,
)
import Darcs.Patch.Prim ( canonizeFL )
import Darcs.Patch.Split ( primSplitter )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully, info, patchDesc )
import Darcs.RepoPath ( toFilePath, SubPath() )
import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withGutsOf,
tentativelyRemovePatches, tentativelyAddPatch, finalizeRepositoryChanges,
amInHashedRepository
, invalidateIndex, unrecordedChanges
, testTentative
, readRecorded
)
import Darcs.Repository.Prefs ( globalPrefsDirDoc )
import Darcs.SelectChanges ( selectChanges, WhichChanges(..),
selectionContextPrim,
runSelection,
withSelectedPatchFromRepo )
import Darcs.Utils ( askUser, clarifyErrors, PromptConfig(..), promptChar )
import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL, reverseRL )
import Printer ( putDocLn )
import Storage.Hashed.Tree( Tree )
amendrecordDescription :: String
amendrecordDescription = "Improve a patch before it leaves your repository."
amendrecordHelp :: String
amendrecordHelp =
"Amend-record updates a `draft' patch with additions or improvements,\n" ++
"resulting in a single `finished' patch. This is better than recording\n" ++
"the additions and improvements as separate patches, because then\n" ++
"whenever the `draft' patch is copied between repositories, you would\n" ++
"need to make sure all the extra patches are copied, too.\n" ++
"\n" ++
"Do not copy draft patches between repositories, because a finished\n" ++
"patch cannot be copied into a repository that contains a draft of the\n" ++
"same patch. If this has already happened, `darcs obliterate' can be\n" ++
"used to remove the draft patch.\n" ++
"\n" ++
"Do not run amend-record in repository that other developers can pull\n" ++
"from, because if they pull while an amend-record is in progress, their\n" ++
"repository may be corrupted.\n" ++
"\n" ++
"When recording a draft patch, it is a good idea to start the name with\n" ++
"`DRAFT:' so that other developers know it is not finished. When\n" ++
"finished, remove it with `darcs amend-record --edit-long-comment'.\n" ++
"To change the patch name without starting an editor, use --patch-name.\n" ++
"\n" ++
"Like `darcs record', if you call amend-record with files as arguments,\n" ++
"you will only be asked about changes to those files. So to amend a\n" ++
"patch to foo.c with improvements in bar.c, you would run:\n" ++
"\n" ++
" darcs amend-record --match 'touch foo.c' bar.c\n" ++
"\n" ++
"It is usually a bad idea to amend another developer's patch. To make\n" ++
"amend-record only ask about your own patches by default, you can add\n" ++
"something like `amend-record match David Roundy' to " ++ globalPrefsDirDoc ++
"defaults, \n" ++
"where `David Roundy' is your name.\n"
amendrecord :: DarcsCommand
amendrecord = DarcsCommand
{
commandProgramName = "darcs"
, commandName = "amend-record"
, commandHelp = amendrecordHelp
, commandDescription = amendrecordDescription
, commandExtraArgs = 1
, commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
, commandCommand = amendrecordCmd
, commandPrereq = amInHashedRepository
, commandGetArgPossibilities = listRegisteredFiles
, commandArgdefaults = nodefaults
, commandAdvancedOptions =
[
nocompress
, ignoretimes
, umaskOption
, setScriptsExecutableOption
]
, commandBasicOptions =
[
matchOneNontag
, test
, leaveTestDir
, allInteractive
, author
, patchnameOption
, askdeps
, askLongComment
, keepDate
, lookforadds
, workingRepoDir
, amendUnrecord
, unified
]
}
amendunrecord :: DarcsCommand
amendunrecord = (commandAlias "amend-unrecord" Nothing amendrecord)
{ commandCommand = \fs -> commandCommand amendrecord (AmendUnrecord : fs)
, commandDescription = "Alias for `darcs " ++ commandName amendrecord ++
" --unrecord '.\n" ++
"This allows changes already recorded in the patch to be removed."
}
amendrecordCmd :: [DarcsFlag]
-> [String]
-> IO ()
amendrecordCmd opts [] = doAmendRecord opts Nothing
amendrecordCmd opts args = do
files <- fixSubPaths opts args
if null files
then fail "No valid arguments were given, nothing to do."
else doAmendRecord opts $ Just files
doAmendRecord :: [DarcsFlag] -> Maybe [SubPath] -> IO ()
doAmendRecord opts files =
withRepoLock opts $ RepoJob $ \(repository :: Repository p C(r u r)) -> do
withSelectedPatchFromRepo "amend" repository opts $ \ (_ :> oldp) -> do
announceFiles files "Amending changes in"
pristine <- readRecorded repository
let go :: FORALL(u1) FL (PrimOf p) C(r u1) -> IO ()
go NilFL | not (hasEditMetadata opts) = putStrLn "No changes!"
go ch =
do let context = selectionContextPrim "add"
(intersect [All,Unified] opts)
(Just primSplitter)
(map toFilePath <$> files)
(Just pristine)
(chosenPatches :> _) <- runSelection (selectChanges First ch) context
addChangesToPatch opts repository oldp chosenPatches
if not (isTag (info oldp))
then if removeFromAmended opts
then do let sel = selectChanges Last (effect oldp)
context = selectionContextPrim "unrecord"
(intersect [All,Unified] opts)
(Just primSplitter)
(map toFilePath <$> files)
(Just pristine)
(_ :> chosenPrims) <- runSelection sel context
let invPrims = reverseRL (invertFL chosenPrims)
addChangesToPatch opts repository oldp invPrims
else go =<< unrecordedChanges (diffingOpts opts) repository files
else if hasEditMetadata opts && isNothing files
then go NilFL
else do if hasEditMetadata opts
then putStrLn "You cannot add new changes to a tag."
else putStrLn "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend-record)."
go NilFL
addChangesToPatch :: forall p C(r u t x y) . (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag]
-> Repository p C(r u t)
-> PatchInfoAnd p C(x t)
-> FL (PrimOf p) C(t y)
-> IO ()
addChangesToPatch opts repository oldp chs =
if (nullFL chs && not (hasEditMetadata opts))
then putStrLn "You don't want to record anything!"
else do
invalidateIndex repository
withGutsOf repository $ do
repository' <- tentativelyRemovePatches repository (compression opts)
(oldp :>: NilFL)
(mlogf, newp) <- updatePatchHeader opts repository' oldp chs
setEnvDarcsFiles newp
repository'' <- tentativelyAddPatch repository' (compression opts) newp
let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf
rc <- testTentative repository
when (rc /= ExitSuccess) $ do
when (not $ isInteractive opts) $ exitWith rc `clarifyErrors` failmsg
putStrLn $ "Looks like you have a bad patch: '" ++ patchDesc newp ++ "'"
let prompt = "Shall I amend it anyway?"
yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])
case yn of
'y' -> return ()
_ -> exitWith rc `clarifyErrors` failmsg
finalizeRepositoryChanges repository'' `clarifyErrors` failmsg
maybe (return ()) removeFile mlogf
putStrLn "Finished amending patch:"
putDocLn $ description newp
updatePatchHeader :: forall p C(x y r u t) . (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag]
-> Repository p C(r u t)
-> PatchInfoAnd p C(t x)
-> FL (PrimOf p) C(x y)
-> IO (Maybe String, PatchInfoAnd p C(t y))
updatePatchHeader opts repository oldp chs = do
let newchs = canonizeFL (effect oldp +>+ chs)
let old_pdeps = getdeps $ hopefully oldp
newdeps <- if AskDeps `elem` opts
then askAboutDepends repository newchs opts old_pdeps
else return old_pdeps
let old_pinf = info oldp
prior = (piName old_pinf, piLog old_pinf)
make_log = worldReadableTemp "darcs-amend-record"
old_author = piAuthor old_pinf
date <- if KeepDate `elem` opts then return (piDateString old_pinf) else getDate opts
warnIfHijacking opts old_author
(new_name, new_log, mlogf) <- getLog opts (Just prior) make_log chs
let new_author = case getAuthor opts of
Just a -> a
Nothing -> piAuthor old_pinf
maybe_invert = if isInverted old_pinf then invertName else id
new_pinf <- maybe_invert `fmap` patchinfo date new_name
new_author new_log
let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps)
return (mlogf, newp)
warnIfHijacking :: [DarcsFlag]
-> String
-> IO ()
warnIfHijacking opts old_author = do
authors_here <- getEasyAuthor
let edit_author = isJust (getAuthor opts)
unless (edit_author || any (== old_author) authors_here) $ do
yorn <- askUser $
"You're not " ++ old_author ++"! Amend anyway? "
case yorn of ('y':_) -> return ()
_ -> exitWith ExitSuccess
hasEditMetadata :: [DarcsFlag]
-> Bool
hasEditMetadata [] = False
hasEditMetadata (Author _:_) = True
hasEditMetadata (LogFile _:_) = True
hasEditMetadata (PatchName _:_) = True
hasEditMetadata (EditLongComment:_) = True
hasEditMetadata (PromptLongComment:_) = True
hasEditMetadata (AskDeps:_) = True
hasEditMetadata (_:fs) = hasEditMetadata fs
getAuthor :: [DarcsFlag]
-> Maybe String
getAuthor (Author a:_) = Just a
getAuthor (_:as) = getAuthor as
getAuthor [] = Nothing