--  Copyright (C) 2009-2012 Ganesh Sittampalam
--
--  BSD3
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 ( (</>) )

-- | Some common flags that are needed to run rebase jobs.
-- Normally flags are captured directly by the implementation of the specific
-- job's function, but the rebase infrastructure needs to do work on the repository
-- directly that sometimes needs these options, so they have to be passed
-- as part of the job definition.
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)

-- got a rebase operation to run where it is required that a rebase is already in progress
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'
      -- the use of finally here is because various things in job
      -- might cause an "expected" early exit leaving us needing
      -- to remove the rebase-in-progress state (e.g. when suspending,
      -- conflicts with recorded, user didn't specify any patches).
      -- It's a bit questionable/non-standard as it's doing quite a bit
      -- of cleanup and if there was an unexpected error then this
      -- may may things worse.
      -- The better fix would be to standardise expected early exits
      -- e.g. using a layer on top of IO or a common Exception type
      -- and then just catch those.
      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

-- got a rebase operation to run where we may need to initialise the rebase state first
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..."
               -- this shouldn't actually be necessary since the count should
               -- only go to zero after an actual rebase operation which would
               -- leave the patch at the end anyway, but be defensive.
               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
               -- in theory moveRebaseToEnd could just return the commuted one,
               -- but since the repository has been committed and re-opened
               -- best to just do things carefully
               (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 -- already at head
        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 -- TODO this isn't under the repo lock, and it should be
           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'