--  Copyright (C) 2003-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.

module Darcs.UI.Commands.Unrevert ( unrevert, writeUnrevert ) where

import Darcs.Prelude

import System.Exit ( exitSuccess )
import Darcs.Util.Tree( Tree )

import Darcs.UI.Commands
    ( DarcsCommand(..)
    , withStdOpts
    , nodefaults
    , amInHashedRepository
    , putFinished
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
    ( diffingOpts, verbosity, useCache, umask, compress, diffAlgorithm
    , isInteractive, withContext )
import Darcs.Repository.Flags
    ( UseIndex(..), ScanKnown (..), Reorder(..), AllowConflicts(..), ExternalMerge(..)
    , WantGuiPause(..), UpdatePending(..), DryRun(NoDryRun) )
import Darcs.UI.Flags ( DarcsFlag )
import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..),
                          considerMergeToWorking,
                          tentativelyAddToPending, finalizeRepositoryChanges,
                          readRepo,
                          readRecorded,
                          applyToWorking, unrecordedChanges )
import Darcs.Repository.Paths ( unrevertPath )
import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, commute )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Info ( patchinfo )
import Darcs.Patch.Named ( infopatch )
import Darcs.Patch.Set ( PatchSet, Origin )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )
import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), (+>+) )
import Darcs.UI.SelectChanges
    ( WhichChanges(First)
    , runInvertibleSelection
    , selectionConfigPrim
    )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )
import qualified Data.ByteString as B
import Darcs.Util.Lock ( writeDocBinFile, removeFileMayNotExist )
import Darcs.Patch.Depends ( mergeThem )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Prompt ( askUser )
import Darcs.Patch.Bundle ( parseBundle, interpretBundle, makeBundle )
import Darcs.Util.IsoDate ( getIsoDateTime )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Path ( AbsolutePath )

unrevertDescription :: String
unrevertDescription :: String
unrevertDescription =
 String
"Undo the last revert."

unrevertHelp :: Doc
unrevertHelp :: Doc
unrevertHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
 String
"Unrevert is a rescue command in case you accidentally reverted\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"something you wanted to keep (for example, typing `darcs rev -a`\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"instead of `darcs rec -a`).\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"This command may fail if the repository has changed since the revert\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"took place.  Darcs will ask for confirmation before executing an\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"interactive command that will DEFINITELY prevent unreversion.\n"

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 = []
    , interactive :: Bool
S.interactive = Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
flags
    , selectDeps :: SelectDeps
S.selectDeps = SelectDeps
O.PromptDeps -- option not supported, use default
    , withSummary :: WithSummary
S.withSummary = WithSummary
O.NoSummary -- option not supported, use default
    , withContext :: WithContext
S.withContext = PrimDarcsOption WithContext
withContext PrimDarcsOption WithContext -> [DarcsFlag] -> WithContext
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
    }

unrevert :: DarcsCommand
unrevert :: DarcsCommand
unrevert = 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
"unrevert"
    , commandHelp :: Doc
commandHelp = Doc
unrevertHelp
    , commandDescription :: String
commandDescription = String
unrevertDescription
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unrevertCmd
    , 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]
noArgs
    , 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
unrevertAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> DiffAlgorithm
   -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> DiffAlgorithm
   -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (UseIndex
   -> Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
unrevertBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> 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]
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
unrevertOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> 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
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
unrevertOpts
    }
  where
    unrevertBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (UseIndex
   -> Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
unrevertBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
  UseIndex
PrimDarcsOption UseIndex
O.useIndex
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
  UseIndex
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> WithContext -> DiffAlgorithm -> a)
     (Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> WithContext -> DiffAlgorithm -> a)
     (UseIndex
      -> Maybe Bool -> Maybe String -> WithContext -> 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 -> WithContext -> DiffAlgorithm -> a)
  (Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
PrimDarcsOption (Maybe Bool)
O.interactive -- True
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> WithContext -> DiffAlgorithm -> a)
  (UseIndex
   -> Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithContext -> DiffAlgorithm -> a)
     (Maybe String -> WithContext -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithContext -> DiffAlgorithm -> a)
     (UseIndex
      -> Maybe Bool -> Maybe String -> WithContext -> 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
  (WithContext -> DiffAlgorithm -> a)
  (Maybe String -> WithContext -> DiffAlgorithm -> a)
PrimDarcsOption (Maybe String)
O.repoDir
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (WithContext -> DiffAlgorithm -> a)
  (UseIndex
   -> Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> a)
     (WithContext -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> a)
     (UseIndex
      -> Maybe Bool -> Maybe String -> WithContext -> 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)
  (WithContext -> DiffAlgorithm -> a)
PrimDarcsOption WithContext
O.withContext
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> a)
  (UseIndex
   -> Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (UseIndex
      -> Maybe Bool -> Maybe String -> WithContext -> 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
    unrevertAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
unrevertAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
    unrevertOpts :: DarcsOption
  a
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
unrevertOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (UseIndex
   -> Maybe Bool -> Maybe String -> WithContext -> DiffAlgorithm -> a)
unrevertBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (UseIndex
   -> Maybe Bool
   -> Maybe String
   -> WithContext
   -> 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
     (UseIndex
      -> Maybe Bool
      -> Maybe String
      -> WithContext
      -> 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
unrevertAdvancedOpts

unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unrevertCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [] =
 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
  PatchSet rt p Origin wR
us <- 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
  Sealed PatchSet rt p Origin wX
them <- PatchSet rt p Origin wR -> IO (Sealed (PatchSet rt p Origin))
forall (p :: * -> * -> *) (rt :: RepoType) wR.
RepoPatch p =>
PatchSet rt p Origin wR -> IO (SealedPatchSet rt p Origin)
unrevertPatchBundle PatchSet rt p Origin wR
us
  Tree IO
recorded <- Repository rt p wR wU wR -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
_repository
  FL (PrimOf p) wR wU
unrecorded <- (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges ([DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts {- always ScanKnown here -})
    LookForMoves
O.NoLookForMoves LookForReplaces
O.NoLookForReplaces Repository rt p wR wU wR
_repository Maybe [AnchoredPath]
forall a. Maybe a
Nothing
  Sealed FL (PatchInfoAnd rt p) wR wX
h_them <- Sealed (FL (PatchInfoAnd rt p) wR)
-> IO (Sealed (FL (PatchInfoAnd rt p) wR))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PatchInfoAnd rt p) wR)
 -> IO (Sealed (FL (PatchInfoAnd rt p) wR)))
-> Sealed (FL (PatchInfoAnd rt p) wR)
-> IO (Sealed (FL (PatchInfoAnd rt p) wR))
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR
-> PatchSet rt p Origin wX -> Sealed (FL (PatchInfoAnd rt p) wR)
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(Commute p, Merge p) =>
PatchSet rt p Origin wX
-> PatchSet rt p Origin wY -> Sealed (FL (PatchInfoAnd rt p) wX)
mergeThem PatchSet rt p Origin wR
us PatchSet rt p Origin wX
them
  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
     wX
-> 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
_repository String
"unrevert"
                      AllowConflicts
YesAllowConflictsAndMark
                      ExternalMerge
NoExternalMerge WantGuiPause
NoWantGuiPause
                      (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 wX
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wX
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
us FL (PatchInfoAnd rt p) wR wR
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL FL (PatchInfoAnd rt p) wR wX
h_them)
  let selection_config :: SelectionConfig prim
selection_config =
        WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter prim)
-> Maybe [AnchoredPath]
-> Maybe (Tree IO)
-> SelectionConfig prim
forall (prim :: * -> * -> *).
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter prim)
-> Maybe [AnchoredPath]
-> Maybe (Tree IO)
-> SelectionConfig prim
selectionConfigPrim
            WhichChanges
First String
"unrevert" ([DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
opts)
            Maybe (Splitter prim)
forall a. Maybe a
Nothing Maybe [AnchoredPath]
forall a. Maybe a
Nothing (Tree IO -> Maybe (Tree IO)
forall a. a -> Maybe a
Just Tree IO
recorded)
  (FL (PrimOf p) wU wZ
p :> FL (PrimOf p) wZ wX
skipped) <- FL (PrimOf p) wU wX
-> SelectionConfig (PrimOf p)
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wU wX)
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 (PrimOf p) wU wX
pw SelectionConfig (PrimOf p)
forall (prim :: * -> * -> *). SelectionConfig prim
selection_config
  Repository rt p wR wU wR -> FL (PrimOf p) wU wZ -> 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
_repository FL (PrimOf p) wU wZ
p
  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
_repository <- 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
_repository UpdatePending
YesUpdatePending (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 wZ wR
_ <- Repository rt p wR wU wR
-> Verbosity
-> FL (PrimOf p) wU wZ
-> IO (Repository rt p wR wZ 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
_repository (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 wZ
p
         String -> IO ()
debugMessage String
"I'm about to writeUnrevert."
         Repository rt p wR wU wR
-> FL (PrimOf p) wZ wX -> Tree IO -> FL (PrimOf p) wR wZ -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> FL (PrimOf p) wX wY -> Tree IO -> FL (PrimOf p) wR wX -> IO ()
writeUnrevert Repository rt p wR wU wR
_repository FL (PrimOf p) wZ wX
skipped Tree IO
recorded (FL (PrimOf p) wR wU
unrecordedFL (PrimOf p) wR wU -> FL (PrimOf p) wU wZ -> FL (PrimOf p) wR wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+FL (PrimOf p) wU wZ
p)
  [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts String
"unreverting"
unrevertCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"impossible case"

writeUnrevert :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
              => Repository rt p wR wU wT -> FL (PrimOf p) wX wY
              -> Tree IO -> FL (PrimOf p) wR wX -> IO ()
writeUnrevert :: Repository rt p wR wU wT
-> FL (PrimOf p) wX wY -> Tree IO -> FL (PrimOf p) wR wX -> IO ()
writeUnrevert Repository rt p wR wU wT
_ FL (PrimOf p) wX wY
NilFL Tree IO
_ FL (PrimOf p) wR wX
_ = String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
unrevertPath
writeUnrevert Repository rt p wR wU wT
repository FL (PrimOf p) wX wY
ps Tree IO
recorded FL (PrimOf p) wR wX
pend =
  case (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wY
-> Maybe ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (FL (PrimOf p) wR wX
pend FL (PrimOf p) wR wX
-> FL (PrimOf p) wX wY
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) wX wY
ps) of
    Maybe ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wY)
Nothing -> do String
really <- String -> IO String
askUser String
"You will not be able to unrevert this operation! Proceed? "
                  case String
really of (Char
'y':String
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                 String
_ -> IO ()
forall a. IO a
exitSuccess
                  Repository rt p wR wU wT
-> FL (PrimOf p) wX wX -> Tree IO -> FL (PrimOf p) wR wX -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> FL (PrimOf p) wX wY -> Tree IO -> FL (PrimOf p) wR wX -> IO ()
writeUnrevert Repository rt p wR wU wT
repository FL (PrimOf p) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL Tree IO
recorded FL (PrimOf p) wR wX
pend
    Just (FL (PrimOf p) wR wZ
p' :> FL (PrimOf p) wZ wY
_) -> do
        PatchSet rt p Origin wR
rep <- Repository rt p wR wU wT -> 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 wT
repository
        String
date <- IO String
getIsoDateTime
        PatchInfo
info <- String -> String -> String -> [String] -> IO PatchInfo
patchinfo String
date String
"unrevert" String
"anon" []
        let np :: Named p wR wZ
np = PatchInfo -> FL (PrimOf p) wR wZ -> Named p wR wZ
forall (p :: * -> * -> *) wX wY.
FromPrim p =>
PatchInfo -> FL (PrimOf p) wX wY -> Named p wX wY
infopatch PatchInfo
info FL (PrimOf p) wR wZ
p'
        Doc
bundle <- Maybe (Tree IO)
-> PatchSet rt p Origin wR -> FL (Named p) wR wZ -> IO Doc
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Maybe (Tree IO)
-> PatchSet rt p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle (Tree IO -> Maybe (Tree IO)
forall a. a -> Maybe a
Just Tree IO
recorded) PatchSet rt p Origin wR
rep (Named p wR wZ
np Named p wR wZ -> FL (Named p) wZ wZ -> FL (Named p) wR wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (Named p) wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
        String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile String
unrevertPath Doc
bundle

unrevertPatchBundle :: RepoPatch p
                    => PatchSet rt p Origin wR
                    -> IO (SealedPatchSet rt p Origin)
unrevertPatchBundle :: PatchSet rt p Origin wR -> IO (SealedPatchSet rt p Origin)
unrevertPatchBundle PatchSet rt p Origin wR
us = do
  ByteString
pf <- String -> IO ByteString
B.readFile String
unrevertPath
        IO ByteString -> IO ByteString -> IO ByteString
forall a. IO a -> IO a -> IO a
`catchall` String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"There's nothing to unrevert!"
  case ByteString -> Either String (Sealed (Bundle rt p Any))
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
ByteString -> Either String (Sealed (Bundle rt p wX))
parseBundle ByteString
pf of
      Right (Sealed Bundle rt p Any wX
bundle) -> do
        case PatchSet rt p Origin wR
-> Bundle rt p Any wX -> Either String (PatchSet rt p Origin wX)
forall (p :: * -> * -> *) (rt :: RepoType) wT wA wB.
Commute p =>
PatchSet rt p Origin wT
-> Bundle rt p wA wB -> Either String (PatchSet rt p Origin wB)
interpretBundle PatchSet rt p Origin wR
us Bundle rt p Any wX
bundle of
          Left String
msg -> String -> IO (SealedPatchSet rt p Origin)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
          Right PatchSet rt p Origin wX
ps -> SealedPatchSet rt p Origin -> IO (SealedPatchSet rt p Origin)
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchSet rt p Origin wX -> SealedPatchSet rt p Origin
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed PatchSet rt p Origin wX
ps)
      Left String
err -> String -> IO (SealedPatchSet rt p Origin)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (SealedPatchSet rt p Origin))
-> String -> IO (SealedPatchSet rt p Origin)
forall a b. (a -> b) -> a -> b
$ String
"Couldn't parse unrevert patch:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err