module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, getLastPatches ) where
import Control.Monad ( when )
import System.Exit ( exitWith, ExitCode( ExitSuccess ) )
import Data.Maybe( isJust )
import Printer ( text, putDoc )
import English ( presentParticiple )
import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc )
import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias,
putVerbose )
import Darcs.Arguments ( DarcsFlag,
output, outputAutoName, getOutput,
workingRepoDir, nocompress, setEnvDarcsPatches,
matchSeveralOrLast, depsSel,
ignoretimes,
allInteractive, umaskOption, summary, dryRun,
printDryRunMessageAndExit, changesReverse
)
import Darcs.Flags ( doReverse, UseIndex(..), ScanKnown(..), compression )
import Darcs.Match ( firstMatch, matchFirstPatchset, matchAPatchread )
import Darcs.Repository ( PatchInfoAnd, withGutsOf,
withRepoLock, RepoJob(..),
tentativelyRemovePatches, finalizeRepositoryChanges,
tentativelyAddToPending,
applyToWorking,
readRepo, amInHashedRepository,
invalidateIndex, unrecordedChanges )
import Darcs.Patch ( RepoPatch, invert, commute, effect )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), appendPSFL )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.Witnesses.Ordered ( RL(..), (:>)(..), (+<+),
mapFL_FL, nullFL,
reverseRL, mapRL, FL(..) )
import Darcs.Patch.Depends ( findCommonWithThem )
import Darcs.SelectChanges ( selectChanges
, WhichChanges(..)
, selectionContext, runSelection )
import Darcs.Patch.Bundle ( makeBundleN, patchFilename, contextPatches )
import Progress ( debugMessage )
import Darcs.Witnesses.Sealed ( Sealed(..) )
import Darcs.RepoPath( useAbsoluteOrStd )
import Darcs.Lock( writeDocBinFile )
import Storage.Hashed.Tree( Tree )
#include "gadts.h"
unrecordDescription :: String
unrecordDescription =
"Remove recorded patches without changing the working copy."
unrecordHelp :: String
unrecordHelp =
"Unrecord does the opposite of record in that it makes the changes from\n"++
"patches active changes again which you may record or revert later. The\n"++
"working copy itself will not change.\n"++
"Beware that you should not use this command if you are going to\n"++
"re-record the changes in any way and there is a possibility that\n"++
"another user may have already pulled the patch.\n"
unrecord :: DarcsCommand
unrecord = DarcsCommand {commandProgramName = "darcs",
commandName = "unrecord",
commandHelp = unrecordHelp,
commandDescription = unrecordDescription,
commandExtraArgs = 0,
commandExtraArgHelp = [],
commandCommand = unrecordCmd,
commandPrereq = amInHashedRepository,
commandGetArgPossibilities = return [],
commandArgdefaults = nodefaults,
commandAdvancedOptions =
[nocompress,umaskOption,changesReverse],
commandBasicOptions = [matchSeveralOrLast,
depsSel,
allInteractive,
workingRepoDir]}
unrecordCmd :: [DarcsFlag] -> [String] -> IO ()
unrecordCmd opts _ = withRepoLock opts $ RepoJob $ \repository -> do
allpatches <- readRepo repository
(_ :> patches) <- return $ if firstMatch opts
then getLastPatches opts allpatches
else matchingHead opts allpatches
let context = selectionContext "unrecord" opts Nothing Nothing
selector = if doReverse opts
then selectChanges Last
else selectChanges LastReversed
(_ :> to_unrecord) <- runSelection (selector patches) context
when (nullFL to_unrecord) $ do putStrLn "No patches selected!"
exitWith ExitSuccess
putVerbose opts $ text
"About to write out (potentially) modified patches..."
setEnvDarcsPatches to_unrecord
invalidateIndex repository
withGutsOf repository $ do _ <- tentativelyRemovePatches repository (compression opts) to_unrecord
finalizeRepositoryChanges repository
putStrLn "Finished unrecording."
getLastPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin r)
-> ((PatchSet p) :> (FL (PatchInfoAnd p))) C(Origin r)
getLastPatches opts ps =
case matchFirstPatchset opts ps of
Sealed p1s -> findCommonWithThem ps p1s
unpullDescription :: String
unpullDescription =
"Opposite of pull; unsafe if patch is not in remote repository."
unpullHelp :: String
unpullHelp =
"Unpull completely removes recorded patches from your local repository.\n"++
"The changes will be undone in your working copy and the patches will not be\n"++
"shown in your changes list anymore.\n"++
"Beware that if the patches are not still present in another repository you\n"++
"will lose precious code by unpulling!\n"
unpull :: DarcsCommand
unpull = (commandAlias "unpull" Nothing obliterate)
{commandHelp = unpullHelp,
commandDescription = unpullDescription,
commandCommand = unpullCmd}
unpullCmd :: [DarcsFlag] -> [String] -> IO ()
unpullCmd = genericObliterateCmd "unpull"
obliterateDescription :: String
obliterateDescription =
"Delete selected patches from the repository. (UNSAFE!)"
obliterateHelp :: String
obliterateHelp =
"Obliterate completely removes recorded patches from your local repository.\n"++
"The changes will be undone in your working copy and the patches will not be\n"++
"shown in your changes list anymore.\n"++
"Beware that you can lose precious code by obliterating!\n"
obliterate :: DarcsCommand
obliterate = DarcsCommand {commandProgramName = "darcs",
commandName = "obliterate",
commandHelp = obliterateHelp,
commandDescription = obliterateDescription,
commandExtraArgs = 0,
commandExtraArgHelp = [],
commandCommand = obliterateCmd,
commandPrereq = amInHashedRepository,
commandGetArgPossibilities = return [],
commandArgdefaults = nodefaults,
commandAdvancedOptions = [nocompress,ignoretimes,umaskOption, changesReverse],
commandBasicOptions = [matchSeveralOrLast,
depsSel,
allInteractive,
workingRepoDir,
summary,
output,
outputAutoName]++
dryRun}
obliterateCmd :: [DarcsFlag] -> [String] -> IO ()
obliterateCmd = genericObliterateCmd "obliterate"
genericObliterateCmd :: String
-> [DarcsFlag]
-> [String]
-> IO ()
genericObliterateCmd cmdname opts _ = withRepoLock opts $ RepoJob $ \repository -> do
pend <- unrecordedChanges (UseIndex, ScanKnown) repository Nothing
allpatches <- readRepo repository
(auto_kept :> removal_candidates) <- return $
if firstMatch opts
then getLastPatches opts allpatches
else matchingHead opts allpatches
let
context = selectionContext cmdname opts Nothing Nothing
selector = if doReverse opts
then selectChanges Last
else selectChanges LastReversed
(kept :> removed) <- runSelection (selector removal_candidates) context
when (nullFL removed) $ do putStrLn "No patches selected!"
exitWith ExitSuccess
case commute (effect removed :> pend) of
Nothing -> fail $ "Can't "++ cmdname ++
" patch without reverting some unrecorded change."
Just (_ :> p_after_pending) -> do
printDryRunMessageAndExit "obliterate" opts removed
setEnvDarcsPatches removed
when (isJust $ getOutput opts "") $
savetoBundle opts (auto_kept `appendPSFL` kept) removed
invalidateIndex repository
withGutsOf repository $
do _ <- tentativelyRemovePatches repository (compression opts) removed
tentativelyAddToPending repository opts $ invert $ effect removed
finalizeRepositoryChanges repository
debugMessage "Applying patches to working directory..."
_ <- applyToWorking repository opts (invert p_after_pending) `catch` \e ->
fail ("Couldn't undo patch in working dir.\n" ++ show e)
return ()
putStrLn $ "Finished " ++ presentParticiple cmdname ++ "."
matchingHead :: forall p C(r). RepoPatch p =>
[DarcsFlag] -> PatchSet p C(Origin r)
-> (PatchSet p :> FL (PatchInfoAnd p)) C(Origin r)
matchingHead opts set =
case mh set of
(start :> patches) -> (start :> reverseRL patches)
where
mh :: FORALL(x) PatchSet p C(Origin x)
-> (PatchSet p :> RL (PatchInfoAnd p)) C(Origin x)
mh s@(PatchSet x _)
| or (mapRL (matchAPatchread opts) x) = contextPatches s
mh (PatchSet x (Tagged t _ ps :<: ts))
= case mh (PatchSet (t:<:ps) ts)
of (start :> patches) -> (start :> x +<+ patches)
mh ps = (ps :> NilRL)
savetoBundle :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag]
-> PatchSet p C(Origin z) -> FL (PatchInfoAnd p) C(z t)
-> IO ()
savetoBundle opts kept removed@(x :>: _) = do
bundle <- makeBundleN Nothing kept (mapFL_FL hopefully removed)
let filename = patchFilename $ patchDesc x
Just outname = getOutput opts filename
useAbsoluteOrStd writeDocBinFile putDoc outname $ bundle
savetoBundle _ _ NilFL = return ()