-- Copyright (C) 2002-2005 David Roundy -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2, or (at your option) -- any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; see the file COPYING. If not, write to -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. {-# LANGUAGE CPP #-} 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 -- Warning: A do-notation statement discarded a result of type Darcs.Repository.InternalTypes.Repository p r u z. 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 is the function that executes the "obliterate" and -- "unpull" commands. genericObliterateCmd :: String -- ^ The name under which the command is invoked (@unpull@ or @obliterate@) -> [DarcsFlag] -- ^ The flags given on the command line -> [String] -- ^ Files given on the command line (unused) -> IO () genericObliterateCmd cmdname opts _ = withRepoLock opts $ RepoJob $ \repository -> do -- FIXME we may need to honour --ignore-times here, although this command -- does not take that option (yet) 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 $ -- Warning: A do-notation statement discarded a result of type Darcs.Repository.InternalTypes.Repository p r u z. 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 returns the repository up to some tag. The tag t is -- the last tag such that there is a patch after t that is matched by -- the user's query. 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 ()