--  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 ( unless, when, void )
import System.Exit ( exitSuccess )

import Darcs.Patch.Match ( firstMatch )
import Darcs.Patch.PatchInfoAnd ( n2pia )
import Darcs.Patch ( canonizeFL, effect, invert )
import Darcs.Patch.Named ( anonymous )
import Darcs.Patch.Set ( emptyPatchSet, patchSet2FL )
import Darcs.Patch.Split ( reversePrimSplitter )
import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), nullFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Repository ( withRepoLock, RepoJob(..),
                          applyToWorking, readPatches,
                          finalizeRepositoryChanges, addToPending,
                          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,
                        wantGuiPause, diffingOpts,
                        diffAlgorithm, isInteractive, pathSetFromArgs )
import Darcs.UI.Options ( 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 = 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 = (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag])
-> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
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
    }

rollback :: DarcsCommand
rollback :: DarcsCommand
rollback = 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
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
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
PrimDarcsOption UMask
O.umask
    rollbackOpts :: CommandOptions
rollbackOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  ([MatchFlag]
   -> Maybe Bool
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  ([MatchFlag] -> Maybe Bool -> Maybe String -> DiffAlgorithm -> a)
rollbackBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  ([MatchFlag]
   -> 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
rollbackAdvancedOpts

exitIfNothingSelected :: FL p wX wY -> String -> IO ()
exitIfNothingSelected :: forall (p :: * -> * -> *) wX wY. 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 a b. IO a -> IO b -> IO b
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 = 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
_repo -> do
        files <- (AbsolutePath, AbsolutePath)
-> [String] -> IO (Maybe [AnchoredPath])
pathSetFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
        announceFiles (verbosity ? opts) files "Rolling back changes in"
        allpatches <- readPatches _repo
        let matchFlags = (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag])
-> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchSeveralOrLast [DarcsFlag]
opts
        (_ :> patches) <- return $
            if firstMatch matchFlags
                then getLastPatches matchFlags allpatches
                else emptyPatchSet :> patchSet2FL allpatches
        (_ :> ps) <-
            runSelection patches $
                selectionConfig LastReversed "rollback" (patchSelOpts opts) Nothing files

        exitIfNothingSelected ps "patches"
        setEnvDarcsPatches ps
        let prim_selection_context =
              WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PrimOf p))
-> Maybe [AnchoredPath]
-> SelectionConfig (PrimOf p)
forall (prim :: * -> * -> *).
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter prim)
-> Maybe [AnchoredPath]
-> 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 (PrimOptSpec DarcsOptDescr DarcsFlag a DiffAlgorithm
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
            hunks = DiffAlgorithm
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall (prim :: * -> * -> *) wX wY.
(IsHunk prim, PrimCoalesce prim, PrimConstruct prim) =>
DiffAlgorithm -> FL prim wX wY -> FL prim wX wY
canonizeFL (PrimOptSpec DarcsOptDescr DarcsFlag a DiffAlgorithm
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 p))) wX wY
 -> FL (PrimOf (FL (PatchInfoAnd p))) wX wY)
-> (FL (PatchInfoAnd p) wX wY
    -> FL (PrimOf (FL (PatchInfoAnd p))) wX wY)
-> FL (PatchInfoAnd p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL (PatchInfoAnd p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect
        _ :> to_undo <- runInvertibleSelection (hunks ps) prim_selection_context
        exitIfNothingSelected to_undo "changes"
        -- Note: use of anonymous is unproblematic here because we
        -- only store effects by adding them to pending and working)
        rbp <- n2pia `fmap` anonymous (invert to_undo)
        Sealed pw <- considerMergeToWorking _repo "rollback"
                         (O.YesAllowConflicts O.MarkConflicts)
                         (wantGuiPause opts)
                         O.NoReorder
                         (diffingOpts opts)
                         (Fork allpatches NilFL (rbp :>: NilFL))
        addToPending _repo (diffingOpts opts) pw
        withSignalsBlocked $ do
            _repo <- finalizeRepositoryChanges _repo (O.dryRun ? opts)
            unless (O.yes (O.dryRun ? opts)) $
              void $ applyToWorking _repo (verbosity ? opts) pw
        debugMessage "Finished applying unrecorded rollback patch"
        putInfo opts $ text "Changes rolled back in working tree"