module Darcs.Repository.Rebase
(
withManualRebaseUpdate
, rebaseJob
, startRebaseJob
, repoJobOnRebaseRepo
) where
import Darcs.Util.Global ( darcsdir )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.CommuteFn ( commuterIdRL )
import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully )
import Darcs.Patch.Rebase ( RebaseFixup
, Rebasing
, mkSuspended
, takeHeadRebase
, takeAnyRebase
, takeAnyRebaseAndTrailingPatches
, countToEdit
)
import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..)
, RecontextRebase1(..)
, RecontextRebase2(..)
)
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.Set ( PatchSet(..) )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
( FL(..), (:>)(..), RL(..), reverseRL
)
import Darcs.Patch.Witnesses.Sealed
( Sealed2(..), FlippedSeal(..) )
import Darcs.Repository.Flags
( Compression
, UpdateWorking(..)
, Verbosity
)
import Darcs.Repository.Format
( RepoProperty ( RebaseInProgress )
, formatHas
, addToFormat
, removeFromFormat
, writeRepoFormat
)
import Darcs.Repository.Internal
( tentativelyAddPatch
, tentativelyAddPatch_
, tentativelyAddPatches_
, tentativelyRemovePatches
, tentativelyRemovePatches_
, finalizeRepositoryChanges
, revertRepositoryChanges
, readTentativeRepo
, readRepo
, UpdatePristine(..)
)
import Darcs.Repository.InternalTypes ( Repository(..) )
import Darcs.Util.Progress ( debugMessage )
import Storage.Hashed.Tree ( Tree )
import Control.Applicative ( (<$>) )
import Control.Exception ( finally )
import System.FilePath.Posix ( (</>) )
#include "impossible.h"
withManualRebaseUpdate
:: forall p x wR wU wT1 wT2
. (RepoPatch p, ApplyState p ~ Tree)
=> Compression
-> Verbosity
-> UpdateWorking
-> Repository p wR wU wT1
-> (Repository p wR wU wT1 -> IO (Repository p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x))
-> IO (Repository p wR wU wT2, x)
withManualRebaseUpdate compr verb uw r subFunc
| Just (RecontextRebase1 recontext1) <- recontextRebase :: Maybe (RecontextRebase1 p)
= do patches <- readTentativeRepo r
let go :: PatchSet p wS wT1 -> IO (Repository p wR wU wT2, x)
go (PatchSet NilRL _) = bug "trying to recontext rebase without rebase patch at head (tag)"
go (PatchSet (q :<: _) _) =
case recontext1 (hopefully q) of
(NotEq, _) -> bug "trying to recontext rebase without rebase patch at head (not match)"
(IsEq, recontext2) -> do
r' <- tentativelyRemovePatches r compr uw (q :>: NilFL)
(r'', fixups, x) <- subFunc r'
q' <- n2pia <$> recontextFunc2 recontext2 fixups
r''' <- tentativelyAddPatch r'' compr verb uw q'
return (r''', x)
go patches
withManualRebaseUpdate _compr _verb _uw r subFunc
= do (r', _, x) <- subFunc r
return (r', x)
repoJobOnRebaseRepo :: (RepoPatch p, ApplyState p ~ Tree)
=> (Repository (Rebasing p) wR wU wR -> IO a)
-> Repository (Rebasing p) wR wU wR
-> IO a
repoJobOnRebaseRepo job repo = do
res <- job repo
displaySuspendedStatus repo
return res
rebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
=> (Repository (Rebasing p) wR wU wR -> IO a)
-> Repository (Rebasing p) wR wU wR
-> Compression
-> Verbosity
-> UpdateWorking
-> IO a
rebaseJob job repo compr verb uw = do
repo' <- moveRebaseToEnd repo compr verb uw
job repo'
`finally` checkSuspendedStatus repo' compr verb uw
startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
=> (Repository (Rebasing p) wR wU wR -> IO a)
-> Repository (Rebasing p) wR wU wR
-> Compression
-> Verbosity
-> UpdateWorking
-> IO a
startRebaseJob job repo compr verb uw = do
repo' <- startRebaseIfNecessary repo compr verb uw
rebaseJob job repo' compr verb uw
checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository (Rebasing p) wR wU wR
-> Compression
-> Verbosity
-> UpdateWorking
-> IO ()
checkSuspendedStatus repo@(Repo _ rf _ _) compr verb uw = do
allpatches <- readRepo repo
(_, Sealed2 ps) <- return $ takeAnyRebase allpatches
case countToEdit ps of
0 -> do
debugMessage "Removing the rebase patch file..."
repo' <- moveRebaseToEnd repo compr verb uw
revertRepositoryChanges repo' uw
(rebase, _, _) <- takeHeadRebase <$> readRepo repo'
repo'' <- tentativelyRemovePatches repo' compr uw (rebase :>: NilFL)
finalizeRepositoryChanges repo'' uw compr
writeRepoFormat (removeFromFormat RebaseInProgress rf) (darcsdir </> "format")
putStrLn "Rebase finished!"
n -> putStrLn $ "Rebase in progress: " ++ show n ++ " suspended patches"
moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository (Rebasing p) wR wU wR
-> Compression
-> Verbosity
-> UpdateWorking
-> IO (Repository (Rebasing p) wR wU wR)
moveRebaseToEnd repo compr verb uw = do
allpatches <- readRepo repo
case takeAnyRebaseAndTrailingPatches allpatches of
FlippedSeal (_ :> NilRL) -> return repo
FlippedSeal (r :> ps) -> do
Just (ps' :> r') <- return $ commuterIdRL selfCommuter (r :> ps)
debugMessage "Moving rebase patch to head..."
revertRepositoryChanges repo uw
repo' <- tentativelyRemovePatches_ DontUpdatePristine repo compr uw (reverseRL ps)
repo'' <- tentativelyRemovePatches_ DontUpdatePristine repo' compr uw (r :>: NilFL)
repo''' <- tentativelyAddPatches_ DontUpdatePristine repo'' compr verb uw (reverseRL ps')
repo'''' <- tentativelyAddPatch_ DontUpdatePristine repo''' compr verb uw r'
finalizeRepositoryChanges repo'''' uw compr
return repo''''
displaySuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wR -> IO ()
displaySuspendedStatus repo = do
allpatches <- readRepo repo
(_, Sealed2 ps) <- return $ takeAnyRebase allpatches
putStrLn $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches"
startRebaseIfNecessary :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository (Rebasing p) wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> IO (Repository (Rebasing p) wR wU wT)
startRebaseIfNecessary repo@(Repo _ rf _ _) compr verb uw =
if formatHas RebaseInProgress rf
then return repo
else do
writeRepoFormat (addToFormat RebaseInProgress rf) (darcsdir </> "format")
debugMessage "Writing the rebase patch file..."
revertRepositoryChanges repo uw
mypatch <- mkSuspended NilFL
repo' <- tentativelyAddPatch_ UpdatePristine repo compr verb uw $ n2pia mypatch
finalizeRepositoryChanges repo' uw compr
return repo'