module Darcs.Repository.Rebase
( RebaseJobFlags(..)
, withManualRebaseUpdate
, rebaseJob
, startRebaseJob
, maybeDisplaySuspendedStatus
) where
import Prelude ()
import Darcs.Prelude
import Darcs.Util.Global ( darcsdir )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.CommuteFn ( commuterIdRL )
import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.Named.Wrapped ( WrappedNamed(..), mkRebase )
import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully )
import Darcs.Patch.Rebase
( takeHeadRebase
, takeAnyRebase
, takeAnyRebaseAndTrailingPatches
)
import Darcs.Patch.Rebase.Container ( Suspended(..), countToEdit, simplifyPushes )
import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.RepoType
( RepoType(..), IsRepoType(..), SRepoType(..)
, RebaseType(..), SRebaseType(..)
)
import Darcs.Patch.Set ( PatchSet(..) )
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.Hashed
( tentativelyAddPatch
, tentativelyAddPatch_
, tentativelyAddPatches_
, tentativelyRemovePatches
, tentativelyRemovePatches_
, finalizeRepositoryChanges
, revertRepositoryChanges
, readTentativeRepo
, readRepo
, UpdatePristine(..)
)
import Darcs.Repository.InternalTypes ( Repository, repoFormat, repoLocation )
import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )
import Darcs.Util.Printer ( ePutDocLn, text )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Tree ( Tree )
import Control.Exception ( finally )
import System.FilePath.Posix ( (</>) )
data RebaseJobFlags =
RebaseJobFlags
{ RebaseJobFlags -> Compression
rjoCompression :: Compression
, RebaseJobFlags -> Verbosity
rjoVerbosity :: Verbosity
, RebaseJobFlags -> UpdateWorking
rjoUpdateWorking :: UpdateWorking
}
withManualRebaseUpdate
:: forall rt p x wR wU wT1 wT2
. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> RebaseJobFlags
-> Repository rt p wR wU wT1
-> (Repository rt p wR wU wT1 -> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x))
-> IO (Repository rt p wR wU wT2, x)
withManualRebaseUpdate :: RebaseJobFlags
-> Repository rt p wR wU wT1
-> (Repository rt p wR wU wT1
-> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x))
-> IO (Repository rt p wR wU wT2, x)
withManualRebaseUpdate (RebaseJobFlags compr :: Compression
compr verb :: Verbosity
verb uw :: UpdateWorking
uw) r :: Repository rt p wR wU wT1
r subFunc :: Repository rt p wR wU wT1
-> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)
subFunc
| SRepoType SIsRebase <- SRepoType rt
forall (rt :: RepoType). IsRepoType rt => SRepoType rt
singletonRepoType :: SRepoType rt
= do PatchSet rt p Origin wT1
patches <- Repository rt p wR wU wT1
-> String -> IO (PatchSet rt p Origin wT1)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> String -> IO (PatchSet rt p Origin wT)
readTentativeRepo Repository rt p wR wU wT1
r (Repository rt p wR wU wT1 -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wT1
r)
let go :: PatchSet rt p wS wT1 -> IO (Repository rt p wR wU wT2, x)
go :: PatchSet rt p wS wT1 -> IO (Repository rt p wR wU wT2, x)
go (PatchSet _ NilRL) = String -> IO (Repository rt p wR wU wT2, x)
forall a. String -> a
bug "trying to recontext rebase without rebase patch at head (tag)"
go (PatchSet _ (_ :<: q :: PatchInfoAnd rt p wY wT1
q)) =
case PatchInfoAnd rt p wY wT1 -> WrappedNamed rt p wY wT1
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully PatchInfoAnd rt p wY wT1
q of
NormalP {} ->
String -> IO (Repository rt p wR wU wT2, x)
forall a. String -> a
bug "trying to recontext rebase without a rebase patch at head (not match)"
RebaseP _ s :: Suspended p wY wY
s -> do
Repository rt p wR wU wY
r' <- Repository rt p wR wU wT1
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wY wT1
-> IO (Repository rt p wR wU wY)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches Repository rt p wR wU wT1
r Compression
compr UpdateWorking
uw (PatchInfoAnd rt p wY wT1
q PatchInfoAnd rt p wY wT1
-> FL (PatchInfoAnd rt p) wT1 wT1 -> FL (PatchInfoAnd rt p) wY wT1
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd rt p) wT1 wT1
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
(r'' :: Repository rt p wR wU wT2
r'', fixups :: FL (RebaseFixup p) wT2 wT1
fixups, x :: x
x) <- Repository rt p wR wU wT1
-> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)
subFunc Repository rt p wR wU wT1
Repository rt p wR wU wY
r'
PatchInfoAnd ('RepoType 'IsRebase) p wT2 wT2
q' <- WrappedNamed ('RepoType 'IsRebase) p wT2 wT2
-> PatchInfoAnd ('RepoType 'IsRebase) p wT2 wT2
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia (WrappedNamed ('RepoType 'IsRebase) p wT2 wT2
-> PatchInfoAnd ('RepoType 'IsRebase) p wT2 wT2)
-> IO (WrappedNamed ('RepoType 'IsRebase) p wT2 wT2)
-> IO (PatchInfoAnd ('RepoType 'IsRebase) p wT2 wT2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Suspended p wT2 wT2
-> IO (WrappedNamed ('RepoType 'IsRebase) p wT2 wT2)
forall (p :: * -> * -> *) wX.
(PrimPatchBase p, FromPrim p, Effect p) =>
Suspended p wX wX
-> IO (WrappedNamed ('RepoType 'IsRebase) p wX wX)
mkRebase (DiffAlgorithm
-> FL (RebaseFixup p) wT2 wT1
-> Suspended p wT1 wT1
-> Suspended p wT2 wT2
forall (p :: * -> * -> *) wX wY.
(PrimPatchBase p, Commute p, FromPrim p, Effect p) =>
DiffAlgorithm
-> FL (RebaseFixup p) wX wY
-> Suspended p wY wY
-> Suspended p wX wX
simplifyPushes DiffAlgorithm
D.MyersDiff FL (RebaseFixup p) wT2 wT1
fixups Suspended p wT1 wT1
Suspended p wY wY
s)
Repository rt p wR wU wT2
r''' <- Repository rt p wR wU wT2
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wT2 wT2
-> IO (Repository rt p wR wU wT2)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch Repository rt p wR wU wT2
r'' Compression
compr Verbosity
verb UpdateWorking
uw PatchInfoAnd rt p wT2 wT2
PatchInfoAnd ('RepoType 'IsRebase) p wT2 wT2
q'
(Repository rt p wR wU wT2, x) -> IO (Repository rt p wR wU wT2, x)
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository rt p wR wU wT2
r''', x
x)
PatchSet rt p Origin wT1 -> IO (Repository rt p wR wU wT2, x)
forall wS.
PatchSet rt p wS wT1 -> IO (Repository rt p wR wU wT2, x)
go PatchSet rt p Origin wT1
patches
withManualRebaseUpdate _flags :: RebaseJobFlags
_flags r :: Repository rt p wR wU wT1
r subFunc :: Repository rt p wR wU wT1
-> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)
subFunc
= do (r' :: Repository rt p wR wU wT2
r', _, x :: x
x) <- Repository rt p wR wU wT1
-> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)
subFunc Repository rt p wR wU wT1
r
(Repository rt p wR wU wT2, x) -> IO (Repository rt p wR wU wT2, x)
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository rt p wR wU wT2
r', x
x)
rebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
=> (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
rebaseJob :: (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
rebaseJob job :: Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job repo :: Repository ('RepoType 'IsRebase) p wR wU wR
repo flags :: RebaseJobFlags
flags = do
Repository ('RepoType 'IsRebase) p wR wU wR
repo' <- Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
moveRebaseToEnd Repository ('RepoType 'IsRebase) p wR wU wR
repo RebaseJobFlags
flags
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job Repository ('RepoType 'IsRebase) p wR wU wR
repo'
IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags -> IO ()
forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags -> IO ()
checkSuspendedStatus Repository ('RepoType 'IsRebase) p wR wU wR
repo' RebaseJobFlags
flags
startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
=> (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
startRebaseJob :: (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
startRebaseJob job :: Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job repo :: Repository ('RepoType 'IsRebase) p wR wU wR
repo flags :: RebaseJobFlags
flags = do
Repository ('RepoType 'IsRebase) p wR wU wR
repo' <- Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
forall (p :: * -> * -> *) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wT
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wT)
startRebaseIfNecessary Repository ('RepoType 'IsRebase) p wR wU wR
repo RebaseJobFlags
flags
(Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
forall (p :: * -> * -> *) wR wU a.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
rebaseJob Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job Repository ('RepoType 'IsRebase) p wR wU wR
repo' RebaseJobFlags
flags
checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO ()
checkSuspendedStatus :: Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags -> IO ()
checkSuspendedStatus repo :: Repository ('RepoType 'IsRebase) p wR wU wR
repo flags :: RebaseJobFlags
flags@(RebaseJobFlags compr :: Compression
compr _verb :: Verbosity
_verb uw :: UpdateWorking
uw) = do
(_, Sealed2 ps :: Suspended p wX wY
ps) <- PatchSet ('RepoType 'IsRebase) p Origin wR
-> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),
Sealed2 (Suspended p))
forall (p :: * -> * -> *) wA wB.
PatchSet ('RepoType 'IsRebase) p wA wB
-> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),
Sealed2 (Suspended p))
takeAnyRebase (PatchSet ('RepoType 'IsRebase) p Origin wR
-> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),
Sealed2 (Suspended p)))
-> IO (PatchSet ('RepoType 'IsRebase) p Origin wR)
-> IO
(Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),
Sealed2 (Suspended p))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository ('RepoType 'IsRebase) p wR wU wR
-> IO (PatchSet ('RepoType 'IsRebase) 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 ('RepoType 'IsRebase) p wR wU wR
repo
case Suspended p wX wY -> Int
forall (p :: * -> * -> *) wX wY. Suspended p wX wY -> Int
countToEdit Suspended p wX wY
ps of
0 -> do
String -> IO ()
debugMessage "Removing the rebase patch file..."
Repository ('RepoType 'IsRebase) p wR wU wR
repo' <- Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
moveRebaseToEnd Repository ('RepoType 'IsRebase) p wR wU wR
repo RebaseJobFlags
flags
Repository ('RepoType 'IsRebase) p wR wU wR
-> UpdateWorking -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> UpdateWorking -> IO ()
revertRepositoryChanges Repository ('RepoType 'IsRebase) p wR wU wR
repo' UpdateWorking
uw
(rebase :: PatchInfoAnd ('RepoType 'IsRebase) p wR wR
rebase, _, _) <- PatchSet ('RepoType 'IsRebase) p Origin wR
-> (PatchInfoAnd ('RepoType 'IsRebase) p wR wR, Suspended p wR wR,
PatchSet ('RepoType 'IsRebase) p Origin wR)
forall (p :: * -> * -> *) wA wB.
PatchSet ('RepoType 'IsRebase) p wA wB
-> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, Suspended p wB wB,
PatchSet ('RepoType 'IsRebase) p wA wB)
takeHeadRebase (PatchSet ('RepoType 'IsRebase) p Origin wR
-> (PatchInfoAnd ('RepoType 'IsRebase) p wR wR, Suspended p wR wR,
PatchSet ('RepoType 'IsRebase) p Origin wR))
-> IO (PatchSet ('RepoType 'IsRebase) p Origin wR)
-> IO
(PatchInfoAnd ('RepoType 'IsRebase) p wR wR, Suspended p wR wR,
PatchSet ('RepoType 'IsRebase) p Origin wR)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository ('RepoType 'IsRebase) p wR wU wR
-> IO (PatchSet ('RepoType 'IsRebase) 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 ('RepoType 'IsRebase) p wR wU wR
repo'
Repository ('RepoType 'IsRebase) p wR wU wR
repo'' <- Repository ('RepoType 'IsRebase) p wR wU wR
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wR wR
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches Repository ('RepoType 'IsRebase) p wR wU wR
repo' Compression
compr UpdateWorking
uw (PatchInfoAnd ('RepoType 'IsRebase) p wR wR
rebase PatchInfoAnd ('RepoType 'IsRebase) p wR wR
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wR wR
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wR wR
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd ('RepoType 'IsRebase) p) wR wR
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
Repository ('RepoType 'IsRebase) p wR wU wR
-> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository ('RepoType 'IsRebase) p wR wU wR
repo'' UpdateWorking
uw Compression
compr
RepoFormat -> String -> IO ()
writeRepoFormat
(RepoProperty -> RepoFormat -> RepoFormat
removeFromFormat RepoProperty
RebaseInProgress (Repository ('RepoType 'IsRebase) p wR wU wR -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository ('RepoType 'IsRebase) p wR wU wR
repo))
(String
darcsdir String -> String -> String
</> "format")
String -> IO ()
putStrLn "Rebase finished!"
n :: Int
n -> Doc -> IO ()
ePutDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Rebase in progress: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ " suspended patches"
moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
moveRebaseToEnd :: Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
moveRebaseToEnd repo :: Repository ('RepoType 'IsRebase) p wR wU wR
repo (RebaseJobFlags compr :: Compression
compr verb :: Verbosity
verb uw :: UpdateWorking
uw) = do
PatchSet ('RepoType 'IsRebase) p Origin wR
allpatches <- Repository ('RepoType 'IsRebase) p wR wU wR
-> IO (PatchSet ('RepoType 'IsRebase) 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 ('RepoType 'IsRebase) p wR wU wR
repo
case PatchSet ('RepoType 'IsRebase) p Origin wR
-> FlippedSeal
(PatchInfoAnd ('RepoType 'IsRebase) p
:> RL (PatchInfoAnd ('RepoType 'IsRebase) p))
wR
forall (p :: * -> * -> *) wA wB.
PatchSet ('RepoType 'IsRebase) p wA wB
-> FlippedSeal
(PatchInfoAnd ('RepoType 'IsRebase) p
:> RL (PatchInfoAnd ('RepoType 'IsRebase) p))
wB
takeAnyRebaseAndTrailingPatches PatchSet ('RepoType 'IsRebase) p Origin wR
allpatches of
FlippedSeal (_ :> NilRL) -> Repository ('RepoType 'IsRebase) p wR wU wR
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository ('RepoType 'IsRebase) p wR wU wR
repo
FlippedSeal (r :: PatchInfoAnd ('RepoType 'IsRebase) p wX wZ
r :> ps :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wR
ps) -> do
Just (ps' :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ
ps' :> r' :: PatchInfoAnd ('RepoType 'IsRebase) p wZ wR
r') <- Maybe
((:>)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
(PatchInfoAnd ('RepoType 'IsRebase) p)
wX
wR)
-> IO
(Maybe
((:>)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
(PatchInfoAnd ('RepoType 'IsRebase) p)
wX
wR))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
((:>)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
(PatchInfoAnd ('RepoType 'IsRebase) p)
wX
wR)
-> IO
(Maybe
((:>)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
(PatchInfoAnd ('RepoType 'IsRebase) p)
wX
wR)))
-> Maybe
((:>)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
(PatchInfoAnd ('RepoType 'IsRebase) p)
wX
wR)
-> IO
(Maybe
((:>)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
(PatchInfoAnd ('RepoType 'IsRebase) p)
wX
wR))
forall a b. (a -> b) -> a -> b
$ CommuteFn
(PatchInfoAnd ('RepoType 'IsRebase) p)
(PatchInfoAnd ('RepoType 'IsRebase) p)
-> (:>)
(PatchInfoAnd ('RepoType 'IsRebase) p)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
wX
wR
-> Maybe
((:>)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
(PatchInfoAnd ('RepoType 'IsRebase) p)
wX
wR)
forall (p1 :: * -> * -> *) (p2 :: * -> * -> *).
CommuteFn p1 p2 -> CommuteFn p1 (RL p2)
commuterIdRL CommuteFn
(PatchInfoAnd ('RepoType 'IsRebase) p)
(PatchInfoAnd ('RepoType 'IsRebase) p)
forall (p :: * -> * -> *). Commute p => CommuteFn p p
selfCommuter (PatchInfoAnd ('RepoType 'IsRebase) p wX wZ
r PatchInfoAnd ('RepoType 'IsRebase) p wX wZ
-> RL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wR
-> (:>)
(PatchInfoAnd ('RepoType 'IsRebase) p)
(RL (PatchInfoAnd ('RepoType 'IsRebase) p))
wX
wR
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> RL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wR
ps)
String -> IO ()
debugMessage "Moving rebase patch to head..."
Repository ('RepoType 'IsRebase) p wR wU wR
-> UpdateWorking -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> UpdateWorking -> IO ()
revertRepositoryChanges Repository ('RepoType 'IsRebase) p wR wU wR
repo UpdateWorking
uw
Repository ('RepoType 'IsRebase) p wR wU wZ
repo' <- UpdatePristine
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wR
-> IO (Repository ('RepoType 'IsRebase) p wR wU wZ)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches_ UpdatePristine
DontUpdatePristine Repository ('RepoType 'IsRebase) p wR wU wR
repo Compression
compr UpdateWorking
uw (RL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wR
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wR
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wR
ps)
Repository ('RepoType 'IsRebase) p wR wU wX
repo'' <- UpdatePristine
-> Repository ('RepoType 'IsRebase) p wR wU wZ
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ
-> IO (Repository ('RepoType 'IsRebase) p wR wU wX)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches_ UpdatePristine
DontUpdatePristine Repository ('RepoType 'IsRebase) p wR wU wZ
repo' Compression
compr UpdateWorking
uw (PatchInfoAnd ('RepoType 'IsRebase) p wX wZ
r PatchInfoAnd ('RepoType 'IsRebase) p wX wZ
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wZ
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd ('RepoType 'IsRebase) p) wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
Repository ('RepoType 'IsRebase) p wR wU wZ
repo''' <- UpdatePristine
-> Repository ('RepoType 'IsRebase) p wR wU wX
-> Compression
-> Verbosity
-> UpdateWorking
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ
-> IO (Repository ('RepoType 'IsRebase) p wR wU wZ)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository ('RepoType 'IsRebase) p wR wU wX
repo'' Compression
compr Verbosity
verb UpdateWorking
uw (RL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ
-> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ
ps')
Repository ('RepoType 'IsRebase) p wR wU wR
repo'''' <- UpdatePristine
-> Repository ('RepoType 'IsRebase) p wR wU wZ
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd ('RepoType 'IsRebase) p wZ wR
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch_ UpdatePristine
DontUpdatePristine Repository ('RepoType 'IsRebase) p wR wU wZ
repo''' Compression
compr Verbosity
verb UpdateWorking
uw PatchInfoAnd ('RepoType 'IsRebase) p wZ wR
r'
Repository ('RepoType 'IsRebase) p wR wU wR
-> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository ('RepoType 'IsRebase) p wR wU wR
repo'''' UpdateWorking
uw Compression
compr
Repository ('RepoType 'IsRebase) p wR wU wR
-> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository ('RepoType 'IsRebase) p wR wU wR
repo''''
displaySuspendedStatus :: RepoPatch p => Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()
displaySuspendedStatus :: Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()
displaySuspendedStatus repo :: Repository ('RepoType 'IsRebase) p wR wU wR
repo = do
(_, Sealed2 ps :: Suspended p wX wY
ps) <- PatchSet ('RepoType 'IsRebase) p Origin wR
-> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),
Sealed2 (Suspended p))
forall (p :: * -> * -> *) wA wB.
PatchSet ('RepoType 'IsRebase) p wA wB
-> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),
Sealed2 (Suspended p))
takeAnyRebase (PatchSet ('RepoType 'IsRebase) p Origin wR
-> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),
Sealed2 (Suspended p)))
-> IO (PatchSet ('RepoType 'IsRebase) p Origin wR)
-> IO
(Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p),
Sealed2 (Suspended p))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository ('RepoType 'IsRebase) p wR wU wR
-> IO (PatchSet ('RepoType 'IsRebase) 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 ('RepoType 'IsRebase) p wR wU wR
repo
Doc -> IO ()
ePutDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Rebase in progress: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Suspended p wX wY -> Int
forall (p :: * -> * -> *) wX wY. Suspended p wX wY -> Int
countToEdit Suspended p wX wY
ps) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " suspended patches"
maybeDisplaySuspendedStatus
:: RepoPatch p
=> SRebaseType rebaseType -> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
maybeDisplaySuspendedStatus :: SRebaseType rebaseType
-> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
maybeDisplaySuspendedStatus SIsRebase repo :: Repository ('RepoType rebaseType) p wR wU wR
repo = Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()
forall (p :: * -> * -> *) wR wU.
RepoPatch p =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()
displaySuspendedStatus Repository ('RepoType rebaseType) p wR wU wR
Repository ('RepoType 'IsRebase) p wR wU wR
repo
maybeDisplaySuspendedStatus SNoRebase _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
startRebaseIfNecessary :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository ('RepoType 'IsRebase) p wR wU wT
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wT)
startRebaseIfNecessary :: Repository ('RepoType 'IsRebase) p wR wU wT
-> RebaseJobFlags
-> IO (Repository ('RepoType 'IsRebase) p wR wU wT)
startRebaseIfNecessary repo :: Repository ('RepoType 'IsRebase) p wR wU wT
repo (RebaseJobFlags compr :: Compression
compr verb :: Verbosity
verb uw :: UpdateWorking
uw) =
let rf :: RepoFormat
rf = Repository ('RepoType 'IsRebase) p wR wU wT -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository ('RepoType 'IsRebase) p wR wU wT
repo
in
if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress RepoFormat
rf
then Repository ('RepoType 'IsRebase) p wR wU wT
-> IO (Repository ('RepoType 'IsRebase) p wR wU wT)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository ('RepoType 'IsRebase) p wR wU wT
repo
else do
RepoFormat -> String -> IO ()
writeRepoFormat (RepoProperty -> RepoFormat -> RepoFormat
addToFormat RepoProperty
RebaseInProgress RepoFormat
rf) (String
darcsdir String -> String -> String
</> "format")
String -> IO ()
debugMessage "Writing the rebase patch file..."
Repository ('RepoType 'IsRebase) p wR wU wT
-> UpdateWorking -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> UpdateWorking -> IO ()
revertRepositoryChanges Repository ('RepoType 'IsRebase) p wR wU wT
repo UpdateWorking
uw
WrappedNamed ('RepoType 'IsRebase) p wT wT
mypatch <- Suspended p wT wT
-> IO (WrappedNamed ('RepoType 'IsRebase) p wT wT)
forall (p :: * -> * -> *) wX.
(PrimPatchBase p, FromPrim p, Effect p) =>
Suspended p wX wX
-> IO (WrappedNamed ('RepoType 'IsRebase) p wX wX)
mkRebase (FL (RebaseItem p) wT wT -> Suspended p wT wT
forall (p :: * -> * -> *) wX wY.
FL (RebaseItem p) wX wY -> Suspended p wX wX
Items FL (RebaseItem p) wT wT
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
Repository ('RepoType 'IsRebase) p wR wU wT
repo' <- UpdatePristine
-> Repository ('RepoType 'IsRebase) p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd ('RepoType 'IsRebase) p wT wT
-> IO (Repository ('RepoType 'IsRebase) p wR wU wT)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch_ UpdatePristine
UpdatePristine Repository ('RepoType 'IsRebase) p wR wU wT
repo Compression
compr Verbosity
verb UpdateWorking
uw (PatchInfoAnd ('RepoType 'IsRebase) p wT wT
-> IO (Repository ('RepoType 'IsRebase) p wR wU wT))
-> PatchInfoAnd ('RepoType 'IsRebase) p wT wT
-> IO (Repository ('RepoType 'IsRebase) p wR wU wT)
forall a b. (a -> b) -> a -> b
$ WrappedNamed ('RepoType 'IsRebase) p wT wT
-> PatchInfoAnd ('RepoType 'IsRebase) p wT wT
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia WrappedNamed ('RepoType 'IsRebase) p wT wT
mypatch
Repository ('RepoType 'IsRebase) p wR wU wT
-> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository ('RepoType 'IsRebase) p wR wU wT
repo' UpdateWorking
uw Compression
compr
Repository ('RepoType 'IsRebase) p wR wU wT
-> IO (Repository ('RepoType 'IsRebase) p wR wU wT)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository ('RepoType 'IsRebase) p wR wU wT
repo'