--  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 ) where

import Darcs.Prelude

import Control.Monad ( unless, when, void )

import Darcs.Patch ( commute )
import Darcs.Patch.Depends ( findCommon )
import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..), (+>+) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )
import Darcs.Repository
    ( RepoJob(..)
    , applyToWorking
    , considerMergeToWorking
    , finalizeRepositoryChanges
    , readPatches
    , addToPending
    , unrecordedChanges
    , withRepoLock
    )
import Darcs.Repository.Flags
    ( AllowConflicts(..)
    , ResolveConflicts(..)
    , Reorder(..)
    , WantGuiPause(..)
    )
import Darcs.Repository.Unrevert ( readUnrevert, writeUnrevert )
import Darcs.UI.Commands
    ( DarcsCommand(..)
    , amInHashedRepository
    , nodefaults
    , putFinished
    , withStdOpts
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
    ( diffingOpts
    , isInteractive
    , umask
    , useCache
    , verbosity
    )
import Darcs.UI.Flags ( DarcsFlag )
import Darcs.UI.Options ( (?), (^) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.SelectChanges
    ( WhichChanges(First)
    , runInvertibleSelection
    , selectionConfigPrim
    )
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.Prompt ( promptYorn )
import Darcs.Util.SignalHandler ( withSignalsBlocked )

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 = S.PatchSelectionOptions
    { verbosity :: Verbosity
S.verbosity = PrimOptSpec DarcsOptDescr DarcsFlag a 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
    }

unrevert :: DarcsCommand
unrevert :: DarcsCommand
unrevert = 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
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
unrevertOpts
    }
  where
    unrevertBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
unrevertBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> a)
  (Maybe Bool)
PrimDarcsOption (Maybe Bool)
O.interactive -- True
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> a)
  (Maybe Bool)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> a)
     (Maybe String -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> a)
     (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)
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (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
    unrevertAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
unrevertAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
O.umask
    unrevertOpts :: CommandOptions
unrevertOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
unrevertBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UMask
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption UMask
unrevertAdvancedOpts

unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unrevertCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [] =
 UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
_repository -> do
  PatchSet p Origin wR
us <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
_repository
  Sealed PatchSet p Origin wX
them <- PatchSet p Origin wR -> IO (Sealed (PatchSet p Origin))
forall (p :: * -> * -> *) wR.
RepoPatch p =>
PatchSet p Origin wR -> IO (SealedPatchSet p Origin)
readUnrevert PatchSet p Origin wR
us
  FL (PrimOf p) wR wU
unrecorded <- DiffOpts
-> Repository 'RW p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts) Repository 'RW p wU wR
_repository Maybe [AnchoredPath]
forall a. Maybe a
Nothing
  Sealed FL (PrimOf p) wU wX
pw <- Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wX
-> IO (Sealed (FL (PrimOf p) wU))
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wY
-> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking Repository 'RW p wU wR
_repository String
"unrevert"
                      (ResolveConflicts -> AllowConflicts
YesAllowConflicts ResolveConflicts
MarkConflicts)
                      WantGuiPause
NoWantGuiPause
                      Reorder
NoReorder
                      ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts)
                      (PatchSet p Origin wR
-> PatchSet p Origin wX
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wX
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchSet p Origin wX
-> PatchSet p Origin wY
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wX
     wY
findCommon PatchSet p Origin wR
us PatchSet p Origin wX
them)
  let selection_config :: SelectionConfig prim
selection_config =
        WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter prim)
-> Maybe [AnchoredPath]
-> SelectionConfig prim
forall (prim :: * -> * -> *).
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter prim)
-> Maybe [AnchoredPath]
-> 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
  (FL (PrimOf p) wU wZ
to_unrevert :> FL (PrimOf p) wZ wX
to_keep) <- 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 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wZ -> IO ()
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository 'RW p wU wR
_repository ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts) FL (PrimOf p) wU wZ
to_unrevert
  PatchSet p Origin wR
recorded <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
_repository
  String -> IO ()
debugMessage String
"I'm about to writeUnrevert."
  case (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX
-> Maybe ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX)
forall wX wY.
(:>) (FL (PrimOf p)) (FL (PrimOf p)) wX wY
-> Maybe ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wX wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute ((FL (PrimOf p) wR wU
unrecorded FL (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
to_unrevert) FL (PrimOf p) wR wZ
-> FL (PrimOf p) wZ wX
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) wZ wX
to_keep) of
    Maybe ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX)
Nothing -> do
      Bool
yes <- String -> IO Bool
promptYorn String
"You will not be able to undo this operation! Proceed?"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
yes (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> FL (PrimOf p) wR wR -> IO ()
forall (p :: * -> * -> *) wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
PatchSet p Origin wR -> FL (PrimOf p) wR wX -> IO ()
writeUnrevert PatchSet p Origin wR
recorded FL (PrimOf p) wR wR
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL -- i.e. remove unrevert
    Just (FL (PrimOf p) wR wZ
to_keep' :> FL (PrimOf p) wZ wX
_) -> PatchSet p Origin wR -> FL (PrimOf p) wR wZ -> IO ()
forall (p :: * -> * -> *) wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
PatchSet p Origin wR -> FL (PrimOf p) wR wX -> IO ()
writeUnrevert PatchSet p Origin wR
recorded FL (PrimOf p) wR wZ
to_keep'
  IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Repository 'RO p wU wR
_repository <- Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IO (Repository 'RO p wZ wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RO p wZ wR) -> IO ())
-> IO (Repository 'RO p wZ wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RO p wU wR
-> Verbosity -> FL (PrimOf p) wU wZ -> IO (Repository 'RO p wZ wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository rt p wY wR)
applyToWorking Repository 'RO p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
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
to_unrevert
  [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts String
"unreverting"
unrevertCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"impossible case"