module Darcs.Repository.Unrevert
    ( finalizeTentativeUnrevert
    , revertTentativeUnrevert
    , writeUnrevert
    , readUnrevert
    , removeFromUnrevertContext
    ) where

import Darcs.Prelude

import Darcs.Patch ( PrimOf, RepoPatch, commuteRL )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Bundle ( interpretBundle, makeBundle, parseBundle )
import Darcs.Patch.Depends ( patchSetMerge, removeFromPatchSet )
import Darcs.Patch.Info ( patchinfo )
import Darcs.Patch.Named ( infopatch )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )
import Darcs.Patch.Set ( Origin, PatchSet, SealedPatchSet )
import Darcs.Patch.Witnesses.Ordered
    ( (:/\:)(..)
    , (:>)(..)
    , FL(..)
    , lengthFL
    , reverseFL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )
import Darcs.Repository.Paths ( tentativeUnrevertPath, unrevertPath )
import Darcs.Util.Exception ( catchDoesNotExistError, ifDoesNotExistError )
import Darcs.Util.Global ( debugMessage )
import Darcs.Util.IsoDate ( getIsoDateTime )
import Darcs.Util.Lock ( readBinFile, removeFileMayNotExist, writeDocBinFile )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Tree ( Tree )

import System.Directory ( copyFile, renameFile )
import System.Exit ( exitSuccess )

finalizeTentativeUnrevert :: IO ()
finalizeTentativeUnrevert :: IO ()
finalizeTentativeUnrevert =
  FilePath -> FilePath -> IO ()
renameFile FilePath
tentativeUnrevertPath FilePath
unrevertPath IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchDoesNotExistError`
    FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
unrevertPath

revertTentativeUnrevert :: IO ()
revertTentativeUnrevert :: IO ()
revertTentativeUnrevert =
  FilePath -> FilePath -> IO ()
copyFile FilePath
unrevertPath FilePath
tentativeUnrevertPath IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchDoesNotExistError`
    FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
tentativeUnrevertPath

writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree)
              => PatchSet p Origin wR
              -> FL (PrimOf p) wR wX
              -> IO ()
writeUnrevert :: forall (p :: * -> * -> *) wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
PatchSet p Origin wR -> FL (PrimOf p) wR wX -> IO ()
writeUnrevert PatchSet p Origin wR
_ FL (PrimOf p) wR wX
NilFL = FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
tentativeUnrevertPath
writeUnrevert PatchSet p Origin wR
recorded FL (PrimOf p) wR wX
ps = do
  FilePath
date <- IO FilePath
getIsoDateTime
  PatchInfo
info <- FilePath -> FilePath -> FilePath -> [FilePath] -> IO PatchInfo
patchinfo FilePath
date FilePath
"unrevert" FilePath
"anon" []
  let np :: Named p wR wX
np = PatchInfo -> FL (PrimOf p) wR wX -> Named p wR wX
forall (p :: * -> * -> *) wX wY.
FromPrim p =>
PatchInfo -> FL (PrimOf p) wX wY -> Named p wX wY
infopatch PatchInfo
info FL (PrimOf p) wR wX
ps
  Doc
bundle <- Maybe (ApplyState p IO)
-> PatchSet p Origin wR -> FL (Named p) wR wX -> IO Doc
forall (p :: * -> * -> *) wStart wX wY.
(RepoPatch p, ApplyMonadTrans (ApplyState p) IO,
 ObjectId (ObjectIdOfPatch p)) =>
Maybe (ApplyState p IO)
-> PatchSet p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle Maybe (Tree IO)
Maybe (ApplyState p IO)
forall a. Maybe a
Nothing PatchSet p Origin wR
recorded (Named p wR wX
np Named p wR wX -> FL (Named p) wX wX -> FL (Named p) wR wX
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (Named p) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
  FilePath -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile FilePath
tentativeUnrevertPath Doc
bundle

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

removeFromUnrevertContext :: forall p wR wX. (RepoPatch p, ApplyState p ~ Tree)
                          => PatchSet p Origin wR
                          -> FL (PatchInfoAnd p) wX wR
                          -> IO ()
removeFromUnrevertContext :: forall (p :: * -> * -> *) wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
PatchSet p Origin wR -> FL (PatchInfoAnd p) wX wR -> IO ()
removeFromUnrevertContext PatchSet p Origin wR
_ FL (PatchInfoAnd p) wX wR
NilFL = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- nothing to do
removeFromUnrevertContext PatchSet p Origin wR
ref FL (PatchInfoAnd p) wX wR
ps =
  () -> IO () -> IO ()
forall a. a -> IO a -> IO a
ifDoesNotExistError () (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> IO ()
debugMessage FilePath
"Reading the unrevert bundle..."
    Sealed Bundle p Any wX
bundle <- IO (Sealed (Bundle p Any))
forall {wX}. IO (Sealed (Bundle p wX))
unrevert_patch_bundle
    FilePath -> IO ()
debugMessage FilePath
"Adjusting the context of the unrevert changes..."
    FilePath -> IO ()
debugMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
"Removing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (FL (PatchInfoAnd p) wX wR -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd p) wX wR
ps) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" patches in removeFromUnrevertContext"
    Sealed PatchSet p Origin wX
bundle_ps <- Bundle p Any wX -> IO (Sealed (PatchSet p Origin))
forall {m :: * -> *} {wA} {wX}.
MonadFail m =>
Bundle p wA wX -> m (Sealed (PatchSet p Origin))
bundle_to_patchset Bundle p Any wX
bundle
    case PatchSet p Origin wR
-> PatchSet p Origin wX
-> (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wX
forall (p :: * -> * -> *) wX wY.
(Commute p, Merge p) =>
PatchSet p Origin wX
-> PatchSet p Origin wY
-> (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wY
patchSetMerge PatchSet p Origin wR
ref PatchSet p Origin wX
bundle_ps of
      (PatchInfoAnd p wR wY
unrevert :>: FL (PatchInfoAnd p) wY wZ
NilFL) :/\: FL (PatchInfoAnd p) wX wZ
_ -> do
        case (:>) (RL (PatchInfoAnd p)) (PatchInfoAnd p) wX wY
-> Maybe ((:>) (PatchInfoAnd p) (RL (PatchInfoAnd p)) wX wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) (RL p) p wX wY -> Maybe ((:>) p (RL p) wX wY)
commuteRL (FL (PatchInfoAnd p) wX wR -> RL (PatchInfoAnd p) wX wR
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd p) wX wR
ps RL (PatchInfoAnd p) wX wR
-> PatchInfoAnd p wR wY
-> (:>) (RL (PatchInfoAnd p)) (PatchInfoAnd p) wX wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PatchInfoAnd p wR wY
unrevert) of
          Maybe ((:>) (PatchInfoAnd p) (RL (PatchInfoAnd p)) wX wY)
Nothing -> IO ()
unrevert_impossible
          Just (PatchInfoAnd p wX wZ
unrevert' :> RL (PatchInfoAnd p) wZ wY
_) ->
            case FL (PatchInfoAnd p) wX wR
-> PatchSet p Origin wR -> Maybe (PatchSet p Origin wX)
forall (p :: * -> * -> *) wX wY wStart.
(Commute p, Eq2 p) =>
FL (PatchInfoAnd p) wX wY
-> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX)
removeFromPatchSet FL (PatchInfoAnd p) wX wR
ps PatchSet p Origin wR
ref of
              Maybe (PatchSet p Origin wX)
Nothing -> IO ()
unrevert_impossible
              Just PatchSet p Origin wX
common -> do
                FilePath -> IO ()
debugMessage FilePath
"Have now found the new context..."
                Doc
bundle' <- Maybe (ApplyState p IO)
-> PatchSet p Origin wX -> FL (Named p) wX wZ -> IO Doc
forall (p :: * -> * -> *) wStart wX wY.
(RepoPatch p, ApplyMonadTrans (ApplyState p) IO,
 ObjectId (ObjectIdOfPatch p)) =>
Maybe (ApplyState p IO)
-> PatchSet p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle Maybe (Tree IO)
Maybe (ApplyState p IO)
forall a. Maybe a
Nothing PatchSet p Origin wX
common (PatchInfoAnd p wX wZ -> Named p wX wZ
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully PatchInfoAnd p wX wZ
unrevert' Named p wX wZ -> FL (Named p) wZ wZ -> FL (Named p) wX 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)
                FilePath -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile FilePath
tentativeUnrevertPath Doc
bundle'
      (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wX
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO I guess this should be an error call
    FilePath -> IO ()
debugMessage FilePath
"Done adjusting the context of the unrevert changes"
  where
    unrevert_impossible :: IO ()
unrevert_impossible = do
      Bool
confirmed <-
        FilePath -> IO Bool
promptYorn FilePath
"This operation will make unrevert impossible!\nProceed?"
      if Bool
confirmed
        then FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
tentativeUnrevertPath
        else FilePath -> IO ()
putStrLn FilePath
"Cancelled." 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
    unrevert_patch_bundle :: IO (Sealed (Bundle p wX))
unrevert_patch_bundle = do
      ByteString
pf <- FilePath -> IO ByteString
forall p. FilePathLike p => p -> IO ByteString
readBinFile FilePath
tentativeUnrevertPath
      case ByteString -> Either FilePath (Sealed (Bundle p wX))
forall (p :: * -> * -> *) wX.
RepoPatch p =>
ByteString -> Either FilePath (Sealed (Bundle p wX))
parseBundle ByteString
pf of
        Right Sealed (Bundle p wX)
foo -> Sealed (Bundle p wX) -> IO (Sealed (Bundle p wX))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Sealed (Bundle p wX)
foo
        Left FilePath
err -> FilePath -> IO (Sealed (Bundle p wX))
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (Sealed (Bundle p wX)))
-> FilePath -> IO (Sealed (Bundle p wX))
forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't parse unrevert patch:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
    bundle_to_patchset :: Bundle p wA wX -> m (Sealed (PatchSet p Origin))
bundle_to_patchset Bundle p wA wX
bundle =
      (FilePath -> m (Sealed (PatchSet p Origin)))
-> (PatchSet p Origin wX -> m (Sealed (PatchSet p Origin)))
-> Either FilePath (PatchSet p Origin wX)
-> m (Sealed (PatchSet p Origin))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> m (Sealed (PatchSet p Origin))
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (Sealed (PatchSet p Origin) -> m (Sealed (PatchSet p Origin))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (PatchSet p Origin) -> m (Sealed (PatchSet p Origin)))
-> (PatchSet p Origin wX -> Sealed (PatchSet p Origin))
-> PatchSet p Origin wX
-> m (Sealed (PatchSet p Origin))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchSet p Origin wX -> Sealed (PatchSet p Origin)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed) (Either FilePath (PatchSet p Origin wX)
 -> m (Sealed (PatchSet p Origin)))
-> Either FilePath (PatchSet p Origin wX)
-> m (Sealed (PatchSet p Origin))
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR
-> Bundle p wA wX -> Either FilePath (PatchSet p Origin wX)
forall (p :: * -> * -> *) wT wA wB.
Commute p =>
PatchSet p Origin wT
-> Bundle p wA wB -> Either FilePath (PatchSet p Origin wB)
interpretBundle PatchSet p Origin wR
ref Bundle p wA wX
bundle