module Darcs.UI.Commands.Rollback ( rollback ) where
import Prelude ()
import Darcs.Prelude
import Control.Exception ( catch, IOException )
import Control.Monad ( when )
import Data.List ( sort )
import Darcs.Util.Tree( Tree )
import System.Exit ( exitSuccess )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Match ( firstMatch )
import Darcs.Patch.PatchInfoAnd ( n2pia )
import Darcs.Patch ( IsRepoType, RepoPatch, invert, effect, fromPrims, sortCoalesceFL,
canonize, PrimOf )
import Darcs.Patch.Named.Wrapped ( anonymous )
import Darcs.Patch.Set ( PatchSet(..), patchSet2FL )
import Darcs.Patch.Split ( reversePrimSplitter )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..), concatFL,
nullFL, mapFL_FL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Repository.Flags ( AllowConflicts (..), UseIndex(..), Reorder(..),
ScanKnown(..), UpdateWorking(..), DryRun(NoDryRun))
import Darcs.Repository ( Repository, withRepoLock, RepoJob(..),
applyToWorking, readRepo,
finalizeRepositoryChanges, tentativelyAddToPending,
considerMergeToWorking )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, setEnvDarcsPatches,
amInHashedRepository, putInfo )
import Darcs.UI.Commands.Unrecord ( getLastPatches )
import Darcs.UI.Commands.Util ( announceFiles )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags ( DarcsFlag, verbosity, umask, useCache,
compress, externalMerge, wantGuiPause,
diffAlgorithm, fixSubPaths, isInteractive )
import Darcs.UI.Options
( (^), odesc, ocheck, onormalise
, defaultFlags, parseFlags, (?)
)
import qualified Darcs.UI.Options.All as O
import Darcs.UI.SelectChanges ( WhichChanges(..),
selectionContext, selectionContextPrim,
runSelection )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )
import Darcs.Util.Path ( toFilePath, AbsolutePath )
import Darcs.Util.Printer ( text )
import Darcs.Util.Progress ( debugMessage )
rollbackDescription :: String
rollbackDescription :: String
rollbackDescription =
"Apply the inverse of recorded changes to the working tree."
rollbackHelp :: String
rollbackHelp :: String
rollbackHelp = [String] -> String
unlines
[ "Rollback is used to undo the effects of some changes from patches"
, "in the repository. The selected changes are undone in your working"
, "tree, but the repository is left unchanged. First you are offered a"
, "choice of which patches to undo, then which changes within the"
, "patches to undo."
, ""
, "Before doing `rollback`, you may want to temporarily undo the changes"
, "of your working tree (if there are) and save them for later use."
, "To do so, you can run `revert`, then run `rollback`, record a patch,"
, "and run `unrevert` to restore the saved changes into your working tree."
]
patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts :: [DarcsFlag] -> PatchSelectionOptions
patchSelOpts flags :: [DarcsFlag]
flags = PatchSelectionOptions :: Verbosity
-> [MatchFlag]
-> Bool
-> SelectDeps
-> Summary
-> WithContext
-> PatchSelectionOptions
S.PatchSelectionOptions
{ verbosity :: Verbosity
S.verbosity = PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
, matchFlags :: [MatchFlag]
S.matchFlags = (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag])
-> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchSeveralOrLast [DarcsFlag]
flags
, interactive :: Bool
S.interactive = Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
flags
, selectDeps :: SelectDeps
S.selectDeps = SelectDeps
O.PromptDeps
, summary :: Summary
S.summary = Summary
O.NoSummary
, withContext :: WithContext
S.withContext = WithContext
O.NoContext
}
rollback :: DarcsCommand [DarcsFlag]
rollback :: DarcsCommand [DarcsFlag]
rollback = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
-> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
{ commandProgramName :: String
commandProgramName = "darcs"
, commandName :: String
commandName = "rollback"
, commandHelp :: String
commandHelp = String
rollbackHelp
, commandDescription :: String
commandDescription = String
rollbackDescription
, commandExtraArgs :: Int
commandExtraArgs = -1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
rollbackCmd
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
knownFileArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
rollbackAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr
DarcsFlag
Any
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> Any)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
rollbackBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
rollbackOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
DarcsFlag
Any
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
rollbackOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
rollbackOpts
}
where
rollbackBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
rollbackBasicOpts
= PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
[MatchFlag]
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchSeveralOrLast
PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
[MatchFlag]
-> OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DiffAlgorithm -> a)
(Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DiffAlgorithm -> a)
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DiffAlgorithm -> a)
(Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
PrimDarcsOption (Maybe Bool)
O.interactive
OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DiffAlgorithm -> a)
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(DiffAlgorithm -> a)
(Maybe String -> DiffAlgorithm -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(DiffAlgorithm -> a)
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
DarcsOptDescr
DarcsFlag
(DiffAlgorithm -> a)
(Maybe String -> DiffAlgorithm -> a)
PrimDarcsOption (Maybe String)
O.repoDir
OptSpec
DarcsOptDescr
DarcsFlag
(DiffAlgorithm -> a)
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (DiffAlgorithm -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
a
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (DiffAlgorithm -> a)
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
rollbackAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
rollbackAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
rollbackOpts :: DarcsOption
a
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
rollbackOpts = OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
rollbackBasicOpts OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
a
([MatchFlag]
-> Maybe Bool
-> Maybe String
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
rollbackAdvancedOpts
exitIfNothingSelected :: FL p wX wY -> String -> IO ()
exitIfNothingSelected :: FL p wX wY -> String -> IO ()
exitIfNothingSelected ps :: FL p wX wY
ps what :: String
what =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FL p wX wY -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL p wX wY
ps) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ("No " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ " selected!") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
rollbackCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
rollbackCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
rollbackCmd fps :: (AbsolutePath, AbsolutePath)
fps opts :: [DarcsFlag]
opts args :: [String]
args = DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
UpdateWorking
YesUpdateWorking (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
umask (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask)
-> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Maybe [SubPath]
files <- if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args
then Maybe [SubPath] -> IO (Maybe [SubPath])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [SubPath]
forall a. Maybe a
Nothing
else [SubPath] -> Maybe [SubPath]
forall a. a -> Maybe a
Just ([SubPath] -> Maybe [SubPath])
-> ([SubPath] -> [SubPath]) -> [SubPath] -> Maybe [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a]
sort ([SubPath] -> Maybe [SubPath])
-> IO [SubPath] -> IO (Maybe [SubPath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
args
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe [SubPath]
files Maybe [SubPath] -> Maybe [SubPath] -> Bool
forall a. Eq a => a -> a -> Bool
== [SubPath] -> Maybe [SubPath]
forall a. a -> Maybe a
Just []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "No valid arguments were given."
Verbosity -> Maybe [SubPath] -> String -> IO ()
announceFiles (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) Maybe [SubPath]
files "Rolling back changes in"
PatchSet rt p Origin wR
allpatches <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
let matchFlags :: [MatchFlag]
matchFlags = (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag])
-> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchSeveralOrLast [DarcsFlag]
opts
(_ :> patches :: FL (PatchInfoAnd rt p) wZ wR
patches) <- (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR
-> IO ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR)
forall (m :: * -> *) a. Monad m => a -> m a
return ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR
-> IO ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR))
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR
-> IO ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR)
forall a b. (a -> b) -> a -> b
$
if [MatchFlag] -> Bool
firstMatch [MatchFlag]
matchFlags
then [MatchFlag]
-> PatchSet rt p Origin wR
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wR.
(IsRepoType rt, RepoPatch p) =>
[MatchFlag]
-> PatchSet rt p Origin wR
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR
getLastPatches [MatchFlag]
matchFlags PatchSet rt p Origin wR
allpatches
else RL (Tagged rt p) Origin Origin
-> RL (PatchInfoAnd rt p) Origin Origin
-> PatchSet rt p Origin Origin
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet RL (Tagged rt p) Origin Origin
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL RL (PatchInfoAnd rt p) Origin Origin
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL PatchSet rt p Origin Origin
-> FL (PatchInfoAnd rt p) Origin wR
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PatchSet rt p Origin wR -> FL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin wR
allpatches
let filesFps :: Maybe [String]
filesFps = (SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath ([SubPath] -> [String]) -> Maybe [SubPath] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [SubPath]
files
patchCtx :: PatchSelectionContext (PatchInfoAnd rt p)
patchCtx = WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PatchInfoAnd rt p))
-> Maybe [String]
-> PatchSelectionContext (PatchInfoAnd rt p)
forall (rt :: RepoType) (p :: * -> * -> *).
(IsRepoType rt, RepoPatch p) =>
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PatchInfoAnd rt p))
-> Maybe [String]
-> PatchSelectionContext (PatchInfoAnd rt p)
selectionContext WhichChanges
LastReversed "rollback" ([DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
opts) Maybe (Splitter (PatchInfoAnd rt p))
forall a. Maybe a
Nothing Maybe [String]
filesFps
(_ :> ps :: FL (PatchInfoAnd rt p) wZ wR
ps) <-
FL (PatchInfoAnd rt p) wZ wR
-> PatchSelectionContext (PatchInfoAnd rt p)
-> IO
((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wR)
forall (p :: * -> * -> *) wX wY.
(Invert p, Commute p, Apply p, PatchInspect p, ShowPatch p,
ShowContextPatch p, ApplyState p ~ Tree) =>
FL p wX wY
-> PatchSelectionContext p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PatchInfoAnd rt p) wZ wR
patches PatchSelectionContext (PatchInfoAnd rt p)
patchCtx
FL (PatchInfoAnd rt p) wZ wR -> String -> IO ()
forall (p :: * -> * -> *) wX wY. FL p wX wY -> String -> IO ()
exitIfNothingSelected FL (PatchInfoAnd rt p) wZ wR
ps "patches"
FL (PatchInfoAnd rt p) wZ wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd rt p) wZ wR
ps
let hunkContext :: PatchSelectionContext (PrimOf p)
hunkContext = WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PrimOf p))
-> Maybe [String]
-> Maybe (Tree IO)
-> PatchSelectionContext (PrimOf p)
forall (prim :: * -> * -> *).
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter prim)
-> Maybe [String]
-> Maybe (Tree IO)
-> PatchSelectionContext prim
selectionContextPrim WhichChanges
Last "rollback" ([DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
opts)
(Splitter (PrimOf p) -> Maybe (Splitter (PrimOf p))
forall a. a -> Maybe a
Just (DiffAlgorithm -> Splitter (PrimOf p)
forall (prim :: * -> * -> *).
PrimPatch prim =>
DiffAlgorithm -> Splitter prim
reversePrimSplitter (PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [DarcsFlag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)))
Maybe [String]
filesFps Maybe (Tree IO)
forall a. Maybe a
Nothing
hunks :: FL (PrimOf p) wZ wR
hunks = FL (FL (PrimOf p)) wZ wR -> FL (PrimOf p) wZ wR
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (FL (FL (PrimOf p)) wZ wR -> FL (PrimOf p) wZ wR)
-> (FL (PatchInfoAnd rt p) wZ wR -> FL (FL (PrimOf p)) wZ wR)
-> FL (PatchInfoAnd rt p) wZ wR
-> FL (PrimOf p) wZ wR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wW wY. PrimOf p wW wY -> FL (PrimOf p) wW wY)
-> FL (PrimOf p) wZ wR -> FL (FL (PrimOf p)) wZ wR
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL (DiffAlgorithm -> PrimOf p wW wY -> FL (PrimOf p) wW wY
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
DiffAlgorithm -> prim wX wY -> FL prim wX wY
canonize (DiffAlgorithm -> PrimOf p wW wY -> FL (PrimOf p) wW wY)
-> DiffAlgorithm -> PrimOf p wW wY -> FL (PrimOf p) wW wY
forall a b. (a -> b) -> a -> b
$ PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [DarcsFlag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (FL (PrimOf p) wZ wR -> FL (FL (PrimOf p)) wZ wR)
-> (FL (PatchInfoAnd rt p) wZ wR -> FL (PrimOf p) wZ wR)
-> FL (PatchInfoAnd rt p) wZ wR
-> FL (FL (PrimOf p)) wZ wR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL (PrimOf p) wZ wR -> FL (PrimOf p) wZ wR
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
sortCoalesceFL (FL (PrimOf p) wZ wR -> FL (PrimOf p) wZ wR)
-> (FL (PatchInfoAnd rt p) wZ wR -> FL (PrimOf p) wZ wR)
-> FL (PatchInfoAnd rt p) wZ wR
-> FL (PrimOf p) wZ wR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL (PatchInfoAnd rt p) wZ wR -> FL (PrimOf p) wZ wR
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect (FL (PatchInfoAnd rt p) wZ wR -> FL (PrimOf p) wZ wR)
-> FL (PatchInfoAnd rt p) wZ wR -> FL (PrimOf p) wZ wR
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) wZ wR
ps
(:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wR
whatToUndo <- FL (PrimOf p) wZ wR
-> PatchSelectionContext (PrimOf p)
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wR)
forall (p :: * -> * -> *) wX wY.
(Invert p, Commute p, Apply p, PatchInspect p, ShowPatch p,
ShowContextPatch p, ApplyState p ~ Tree) =>
FL p wX wY
-> PatchSelectionContext p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PrimOf p) wZ wR
hunks PatchSelectionContext (PrimOf p)
hunkContext
[DarcsFlag]
-> Repository rt p wR wU wR
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wR
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT
(q :: * -> * -> *) wA.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wR wU wT
-> (:>) q (FL (PrimOf p)) wA wT
-> IO ()
undoItNow [DarcsFlag]
opts Repository rt p wR wU wR
repository (:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wR
whatToUndo
undoItNow :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag] -> Repository rt p wR wU wT
-> (q :> FL (PrimOf p)) wA wT -> IO ()
undoItNow :: [DarcsFlag]
-> Repository rt p wR wU wT
-> (:>) q (FL (PrimOf p)) wA wT
-> IO ()
undoItNow opts :: [DarcsFlag]
opts repo :: Repository rt p wR wU wT
repo (_ :> prims :: FL (PrimOf p) wZ wT
prims) = do
FL (PrimOf p) wZ wT -> String -> IO ()
forall (p :: * -> * -> *) wX wY. FL p wX wY -> String -> IO ()
exitIfNothingSelected FL (PrimOf p) wZ wT
prims "changes"
PatchInfoAnd rt p wT wZ
rbp <- WrappedNamed rt p wT wZ -> PatchInfoAnd rt p wT wZ
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia (WrappedNamed rt p wT wZ -> PatchInfoAnd rt p wT wZ)
-> IO (WrappedNamed rt p wT wZ) -> IO (PatchInfoAnd rt p wT wZ)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FL p wT wZ -> IO (WrappedNamed rt p wT wZ)
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
FL p wX wY -> IO (WrappedNamed rt p wX wY)
anonymous (FL (PrimOf (FL p)) wT wZ -> FL p wT wZ
forall (p :: * -> * -> *) wX wY.
FromPrims p =>
FL (PrimOf p) wX wY -> p wX wY
fromPrims (FL (PrimOf (FL p)) wT wZ -> FL p wT wZ)
-> FL (PrimOf (FL p)) wT wZ -> FL p wT wZ
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wZ wT -> FL (PrimOf p) wT wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wZ wT
prims)
Sealed pw :: FL (PrimOf p) wU wX
pw <- Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wT wT
-> FL (PatchInfoAnd rt p) wT wZ
-> IO (Sealed (FL (PrimOf p) wU))
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking Repository rt p wR wU wT
repo "rollback"
AllowConflicts
YesAllowConflictsAndMark UpdateWorking
YesUpdateWorking
(PrimDarcsOption ExternalMerge
externalMerge PrimDarcsOption ExternalMerge -> [DarcsFlag] -> ExternalMerge
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> WantGuiPause
wantGuiPause [DarcsFlag]
opts)
(PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) Reorder
NoReorder
(UseIndex
UseIndex, ScanKnown
ScanKnown, PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [DarcsFlag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
FL (PatchInfoAnd rt p) wT wT
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL (PatchInfoAnd rt p wT wZ
rbp PatchInfoAnd rt p wT wZ
-> FL (PatchInfoAnd rt p) wZ wZ -> FL (PatchInfoAnd rt p) wT wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd rt p) wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wX -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
RepoPatch p =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
tentativelyAddToPending Repository rt p wR wU wT
repo UpdateWorking
YesUpdateWorking FL (PrimOf p) wU wX
pw
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository rt p wR wU wT
repo UpdateWorking
YesUpdateWorking
(PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
Repository rt p wR wX wT
_ <- Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wX
-> IO (Repository rt p wR wX wT)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wU wT
repo (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wX
pw
IO (Repository rt p wR wX wT)
-> (IOException -> IO (Repository rt p wR wX wT))
-> IO (Repository rt p wR wX wT)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
\(IOException
e :: IOException) -> String -> IO (Repository rt p wR wX wT)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Repository rt p wR wX wT))
-> String -> IO (Repository rt p wR wX wT)
forall a b. (a -> b) -> a -> b
$
"error applying rolled back patch to working directory\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e
String -> IO ()
debugMessage "Finished applying unrecorded rollback patch"
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Changes rolled back in working directory"