--  Copyright (C) 2002-2004,2007 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.

module Darcs.UI.Commands.Rollback ( rollback ) where

import Darcs.Prelude

import Control.Monad ( when, void )
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, sortCoalesceFL,
                     canonize, PrimOf )
import Darcs.Patch.Named ( anonymous )
import Darcs.Patch.Set ( PatchSet, Origin, emptyPatchSet, patchSet2FL )
import Darcs.Patch.Split ( reversePrimSplitter )
import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), concatFL, nullFL, mapFL_FL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Repository.Flags ( AllowConflicts (..), UseIndex(..), Reorder(..),
                                ScanKnown(..), UpdatePending(..), 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.Util ( announceFiles, getLastPatches )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags ( DarcsFlag, verbosity, umask, useCache,
                        compress, externalMerge, wantGuiPause,
                        diffAlgorithm, isInteractive, pathSetFromArgs )
import Darcs.UI.Options
    ( (^), odesc, ocheck
    , defaultFlags, parseFlags, (?)
    )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.SelectChanges ( WhichChanges(..),
                                selectionConfig, selectionConfigPrim,
                                runSelection, runInvertibleSelection )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.SignalHandler ( withSignalsBlocked )


rollbackDescription :: String
rollbackDescription :: String
rollbackDescription =
 String
"Apply the inverse of recorded changes to the working tree."

rollbackHelp :: Doc
rollbackHelp :: Doc
rollbackHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
"Rollback is used to undo the effects of some changes from patches"
    , String
"in the repository. The selected changes are undone in your working"
    , String
"tree, but the repository is left unchanged. First you are offered a"
    , String
"choice of which patches to undo, then which changes within the"
    , String
"patches to undo."
    , String
""
    , String
"Before doing `rollback`, you may want to temporarily undo the changes"
    , String
"of your working tree (if there are) and save them for later use."
    , String
"To do so, you can run `revert`, then run `rollback`, record a patch,"
    , String
"and run `unrevert` to restore the saved changes into your working tree."
    ]

patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts :: [DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
flags = PatchSelectionOptions :: Verbosity
-> [MatchFlag]
-> Bool
-> SelectDeps
-> WithSummary
-> 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
    , withSummary :: WithSummary
S.withSummary = WithSummary
O.NoSummary
    , withContext :: WithContext
S.withContext = WithContext
O.NoContext
    }

rollback :: DarcsCommand
rollback :: DarcsCommand
rollback = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"rollback"
    , commandHelp :: Doc
commandHelp = Doc
rollbackHelp
    , commandDescription :: String
commandDescription = String
rollbackDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
rollbackOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  ([MatchFlag]
   -> Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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 -- True
      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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
rollbackOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  ([MatchFlag]
   -> Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  ([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
rollbackBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  ([MatchFlag]
   -> Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     ([MatchFlag]
      -> Maybe Bool
      -> Maybe String
      -> DiffAlgorithm
      -> Maybe StdCmdAction
      -> Verbosity
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
rollbackAdvancedOpts

exitIfNothingSelected :: FL p wX wY -> String -> IO ()
exitIfNothingSelected :: FL p wX wY -> String -> IO ()
exitIfNothingSelected FL p wX wY
ps 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 (String
"No " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
args = DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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)
    UpdatePending
YesUpdatePending (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 rt p wR wU wR
repository -> do
        Maybe [AnchoredPath]
files <- (AbsolutePath, AbsolutePath)
-> [String] -> IO (Maybe [AnchoredPath])
pathSetFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
        Verbosity -> Maybe [AnchoredPath] -> 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 [AnchoredPath]
files String
"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
        (PatchSet rt p Origin wZ
_ :> 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 (p :: * -> * -> *) (rt :: RepoType) wR.
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 PatchSet rt p Origin Origin
forall (rt :: RepoType) (p :: * -> * -> *).
PatchSet rt p Origin Origin
emptyPatchSet 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
        (FL (PatchInfoAnd rt p) wZ wZ
_ :> FL (PatchInfoAnd rt p) wZ wR
ps) <-
            FL (PatchInfoAnd rt p) wZ wR
-> SelectionConfig (PatchInfoAnd rt p)
-> IO
     ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wR)
forall (p :: * -> * -> *) wX wY.
(MatchableRP p, ShowPatch p, ShowContextPatch p,
 ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p)) =>
FL p wX wY -> SelectionConfig p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PatchInfoAnd rt p) wZ wR
patches (SelectionConfig (PatchInfoAnd rt p)
 -> IO
      ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wR))
-> SelectionConfig (PatchInfoAnd rt p)
-> IO
     ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wR)
forall a b. (a -> b) -> a -> b
$
                WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PatchInfoAnd rt p))
-> Maybe [AnchoredPath]
-> SelectionConfig (PatchInfoAnd rt p)
forall (p :: * -> * -> *).
Matchable p =>
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter p)
-> Maybe [AnchoredPath]
-> SelectionConfig p
selectionConfig WhichChanges
LastReversed String
"rollback" ([DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
opts) Maybe (Splitter (PatchInfoAnd rt p))
forall a. Maybe a
Nothing Maybe [AnchoredPath]
files

        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 String
"patches"
        FL (PatchInfoAnd rt p) wZ wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd rt p) wZ wR
ps
        let prim_selection_context :: SelectionConfig (PrimOf p)
prim_selection_context =
              WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PrimOf p))
-> Maybe [AnchoredPath]
-> Maybe (Tree IO)
-> SelectionConfig (PrimOf p)
forall (prim :: * -> * -> *).
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter prim)
-> Maybe [AnchoredPath]
-> Maybe (Tree IO)
-> SelectionConfig prim
selectionConfigPrim
                  WhichChanges
Last String
"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 [AnchoredPath]
files Maybe (Tree IO)
forall a. Maybe a
Nothing
            hunks :: FL (PatchInfoAnd rt p) wX wZ
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
hunks = FL (FL (PrimOf (FL (PatchInfoAnd rt p)))) wX wZ
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (FL (FL (PrimOf (FL (PatchInfoAnd rt p)))) wX wZ
 -> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ)
-> (FL (PatchInfoAnd rt p) wX wZ
    -> FL (FL (PrimOf (FL (PatchInfoAnd rt p)))) wX wZ)
-> FL (PatchInfoAnd rt p) wX wZ
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wW wY.
 PrimOf (FL (PatchInfoAnd rt p)) wW wY
 -> FL (PrimOf (FL (PatchInfoAnd rt p))) wW wY)
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
-> FL (FL (PrimOf (FL (PatchInfoAnd rt p)))) wX wZ
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 (FL (PatchInfoAnd rt p)) wW wY
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wW wY
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
DiffAlgorithm -> prim wX wY -> FL prim wX wY
canonize (DiffAlgorithm
 -> PrimOf (FL (PatchInfoAnd rt p)) wW wY
 -> FL (PrimOf (FL (PatchInfoAnd rt p))) wW wY)
-> DiffAlgorithm
-> PrimOf (FL (PatchInfoAnd rt p)) wW wY
-> FL (PrimOf (FL (PatchInfoAnd rt 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 (FL (PatchInfoAnd rt p))) wX wZ
 -> FL (FL (PrimOf (FL (PatchInfoAnd rt p)))) wX wZ)
-> (FL (PatchInfoAnd rt p) wX wZ
    -> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ)
-> FL (PatchInfoAnd rt p) wX wZ
-> FL (FL (PrimOf (FL (PatchInfoAnd rt p)))) wX wZ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
sortCoalesceFL (FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
 -> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ)
-> (FL (PatchInfoAnd rt p) wX wZ
    -> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ)
-> FL (PatchInfoAnd rt p) wX wZ
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL (PatchInfoAnd rt p) wX wZ
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect
        (:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wR
whatToUndo <- FL (PrimOf p) wZ wR
-> SelectionConfig (PrimOf p)
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wR)
forall (p :: * -> * -> *) wX wY.
(Invert p, MatchableRP p, ShowPatch p, ShowContextPatch p,
 ApplyState p ~ Tree) =>
FL p wX wY -> SelectionConfig p -> IO ((:>) (FL p) (FL p) wX wY)
runInvertibleSelection (FL (PatchInfoAnd rt p) wZ wR
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wZ wR
forall wX wZ.
FL (PatchInfoAnd rt p) wX wZ
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wZ
hunks FL (PatchInfoAnd rt p) wZ wR
ps) SelectionConfig (PrimOf p)
prim_selection_context
        [DarcsFlag]
-> Repository rt p wR wU wR
-> PatchSet rt p Origin wR
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wR
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU (q :: * -> * -> *)
       wA.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wR wU wR
-> PatchSet rt p Origin wR
-> (:>) q (FL (PrimOf p)) wA wR
-> IO ()
undoItNow [DarcsFlag]
opts Repository rt p wR wU wR
repository PatchSet rt p Origin wR
allpatches (:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wR
whatToUndo

undoItNow :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
          => [DarcsFlag] -> Repository rt p wR wU wR
          -> PatchSet rt p Origin wR
          -> (q :> FL (PrimOf p)) wA wR -> IO ()
undoItNow :: [DarcsFlag]
-> Repository rt p wR wU wR
-> PatchSet rt p Origin wR
-> (:>) q (FL (PrimOf p)) wA wR
-> IO ()
undoItNow [DarcsFlag]
opts Repository rt p wR wU wR
_repo PatchSet rt p Origin wR
context (q wA wZ
_ :> FL (PrimOf p) wZ wR
prims) = do
    FL (PrimOf p) wZ wR -> String -> IO ()
forall (p :: * -> * -> *) wX wY. FL p wX wY -> String -> IO ()
exitIfNothingSelected FL (PrimOf p) wZ wR
prims String
"changes"
    -- Note: use of anonymous is unproblematic here because we
    -- only store effects by adding them to pending and working)
    PatchInfoAndG rt (Named p) wR wZ
rbp <- Named p wR wZ -> PatchInfoAndG rt (Named p) wR wZ
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia (Named p wR wZ -> PatchInfoAndG rt (Named p) wR wZ)
-> IO (Named p wR wZ) -> IO (PatchInfoAndG rt (Named p) wR wZ)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FL (PrimOf p) wR wZ -> IO (Named p wR wZ)
forall (p :: * -> * -> *) wX wY.
FromPrim p =>
FL (PrimOf p) wX wY -> IO (Named p wX wY)
anonymous (FL (PrimOf p) wZ wR -> FL (PrimOf p) wR wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wZ wR
prims)
    Sealed FL (PrimOf p) wU wX
pw <- Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wZ
-> IO (Sealed (FL (PrimOf p) wU))
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wY
-> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking Repository rt p wR wU wR
_repo String
"rollback"
                     AllowConflicts
YesAllowConflictsAndMark
                     (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)
                     (PatchSet rt p Origin wR
-> FL (PatchInfoAnd rt p) wR wR
-> FL (PatchInfoAnd rt p) wR wZ
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wZ
forall (common :: * -> * -> *) (left :: * -> * -> *)
       (right :: * -> * -> *) wA wX wY wU.
common wA wU
-> left wU wX -> right wU wY -> Fork common left right wA wX wY
Fork PatchSet rt p Origin wR
context FL (PatchInfoAnd rt p) wR wR
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL (PatchInfoAndG rt (Named p) wR wZ
rbp PatchInfoAndG rt (Named p) wR wZ
-> FL (PatchInfoAnd rt p) wZ wZ -> FL (PatchInfoAnd rt p) wR 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 wR -> FL (PrimOf p) wU wX -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wX wY -> IO ()
tentativelyAddToPending Repository rt p wR wU wR
_repo FL (PrimOf p) wU wX
pw
    IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Repository rt p wR wU wR
_repo <- Repository rt p wR wU wR
-> UpdatePending -> Compression -> IO (Repository rt p wR wU wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdatePending -> Compression -> IO (Repository rt p wT wU wT)
finalizeRepositoryChanges Repository rt p wR wU wR
_repo UpdatePending
YesUpdatePending (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        IO (Repository rt p wR wX wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository rt p wR wX wR) -> IO ())
-> IO (Repository rt p wR wX wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR
-> Verbosity
-> FL (PrimOf p) wU wX
-> IO (Repository rt p wR wX wR)
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 wR
_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
    String -> IO ()
debugMessage String
"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 String
"Changes rolled back in working tree"