--  Copyright (C) 2009-2012 Ganesh Sittampalam
--
--  BSD3
{-# LANGUAGE OverloadedStrings #-}
module Darcs.Repository.Rebase
    ( withManualRebaseUpdate
    , rebaseJob
    , startRebaseJob
    , maybeDisplaySuspendedStatus
    -- create/read/write rebase patch
    , readTentativeRebase
    , writeTentativeRebase
    , withTentativeRebase
    , createTentativeRebase
    , readRebase
    , commuteOutOldStyleRebase
    , checkOldStyleRebaseStatus
    ) where

import Darcs.Prelude

import Control.Exception (throwIO )
import Control.Monad ( unless )
import System.Exit ( exitFailure )
import System.IO.Error ( catchIOError, isDoesNotExistError )

import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Commute ( Commute(..) )
import qualified Darcs.Patch.Named.Wrapped as W
import Darcs.Patch.PatchInfoAnd
    ( PatchInfoAndG
    , hopefully
    )
import Darcs.Patch.Read ( readPatch )
import Darcs.Patch.Rebase.Suspended
    ( Suspended(Items)
    , countToEdit
    , simplifyPushes
    )
import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )
import Darcs.Patch.RepoPatch ( RepoPatch, PrimOf )
import Darcs.Patch.RepoType
  ( RepoType(..), IsRepoType(..), SRepoType(..)
  , RebaseType(..), SRebaseType(..)
  )
import Darcs.Patch.Show ( displayPatch, showPatch, ShowPatchFor(ForStorage) )
import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd )

import Darcs.Repository.Format
    ( RepoProperty ( RebaseInProgress_2_16, RebaseInProgress )
    , formatHas
    , addToFormat
    , removeFromFormat
    , writeRepoFormat
    )
import Darcs.Repository.InternalTypes
    ( Repository
    , repoFormat
    , withRepoLocation
    )
import Darcs.Repository.Paths
    ( rebasePath
    , tentativeRebasePath
    , formatPath
    )

import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) )
import Darcs.Util.English ( englishNum, Noun(..) )
import Darcs.Util.Lock ( writeDocBinFile, readBinFile )
import Darcs.Util.Printer ( renderString, text, hsep, vcat, ($$) )
import Darcs.Util.Printer.Color ( ePutDocLn )
import Darcs.Util.Tree ( Tree )

import Control.Exception ( finally )

withManualRebaseUpdate
   :: forall rt p x wR wU wT1 wT2
    . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
   => Repository rt p wR wU wT1
   -> (Repository rt p wR wU wT1 -> IO (Repository rt p wR wU wT2, FL (RebaseFixup (PrimOf p)) wT2 wT1, x))
   -> IO (Repository rt p wR wU wT2, x)
withManualRebaseUpdate :: Repository rt p wR wU wT1
-> (Repository rt p wR wU wT1
    -> IO
         (Repository rt p wR wU wT2, FL (RebaseFixup (PrimOf p)) wT2 wT1,
          x))
-> IO (Repository rt p wR wU wT2, x)
withManualRebaseUpdate Repository rt p wR wU wT1
r Repository rt p wR wU wT1
-> IO
     (Repository rt p wR wU wT2, FL (RebaseFixup (PrimOf p)) wT2 wT1, x)
subFunc
  | SRepoType SRebaseType rebaseType
SIsRebase <- SRepoType rt
forall (rt :: RepoType). IsRepoType rt => SRepoType rt
singletonRepoType :: SRepoType rt = do
      Suspended p wT1 wT1
susp <- Repository rt p wR wU wT1 -> IO (Suspended p wT1 wT1)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Suspended p wT wT)
readTentativeRebase Repository rt p wR wU wT1
r
      (Repository rt p wR wU wT2
r', FL (RebaseFixup (PrimOf p)) wT2 wT1
fixups, x
x) <- Repository rt p wR wU wT1
-> IO
     (Repository rt p wR wU wT2, FL (RebaseFixup (PrimOf p)) wT2 wT1, x)
subFunc Repository rt p wR wU wT1
r
      -- HACK overwrite the changes that were made by subFunc
      -- which may and indeed does call add/remove patch
      Repository rt p wR wU wT2 -> Suspended p wT2 wT2 -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> Suspended p wT wT -> IO ()
writeTentativeRebase Repository rt p wR wU wT2
r' (DiffAlgorithm
-> FL (RebaseFixup (PrimOf 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 (PrimOf p)) wX wY
-> Suspended p wY wY
-> Suspended p wX wX
simplifyPushes DiffAlgorithm
MyersDiff FL (RebaseFixup (PrimOf p)) wT2 wT1
fixups Suspended p wT1 wT1
susp)
      (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)
  | Bool
otherwise = do
      (Repository rt p wR wU wT2
r', FL (RebaseFixup (PrimOf p)) wT2 wT1
_, x
x) <- Repository rt p wR wU wT1
-> IO
     (Repository rt p wR wU wT2, FL (RebaseFixup (PrimOf 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)

catchDoesNotExist :: IO a -> IO a -> IO a
catchDoesNotExist :: IO a -> IO a -> IO a
catchDoesNotExist IO a
a IO a
b =
  IO a
a IO a -> (IOError -> IO a) -> IO a
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> if IOError -> Bool
isDoesNotExistError IOError
e then IO a
b else IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO IOError
e)

checkOldStyleRebaseStatus :: RepoPatch p
                          => SRebaseType rebaseType
                          -> Repository ('RepoType rebaseType) p wR wU wR
                          -> IO ()
checkOldStyleRebaseStatus :: SRebaseType rebaseType
-> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
checkOldStyleRebaseStatus SRebaseType rebaseType
SNoRebase Repository ('RepoType rebaseType) p wR wU wR
_    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkOldStyleRebaseStatus SRebaseType rebaseType
SIsRebase Repository ('RepoType rebaseType) p wR wU wR
repo = do
    -- if the format says we have a rebase in progress,
    -- but initially we have zero new-style suspended patches
    -- this means an old-style rebase is in progress
    Int
count <-
      (Suspended p wR wR -> Int
forall (p :: * -> * -> *) wX wY. Suspended p wX wY -> Int
countToEdit (Suspended p wR wR -> Int) -> IO (Suspended p wR wR) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository ('RepoType rebaseType) p wR wU wR
-> IO (Suspended p wR wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
RepoPatch p =>
Repository rt p wR wU wR -> IO (Suspended p wR wR)
readRebase Repository ('RepoType rebaseType) p wR wU wR
repo)
      IO Int -> IO Int -> IO Int
forall a. IO a -> IO a -> IO a
`catchDoesNotExist`
      Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Doc -> IO ()
ePutDocLn Doc
upgradeMsg
      IO ()
forall a. IO a
exitFailure
  where
    upgradeMsg :: Doc
upgradeMsg = [Doc] -> Doc
vcat
      [ Doc
"An old-style rebase is in progress in this repository. You can upgrade it"
      , Doc
"to the new format using the 'darcs rebase upgrade' command. The repository"
      , Doc
"format is unaffected by this, but you won't be able to use a darcs version"
      , Doc
"older than 2.16 on this repository until the current rebase is finished."
      ]

-- | 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
          -> IO a
rebaseJob :: (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
rebaseJob Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job Repository ('RepoType 'IsRebase) p wR wU wR
repo = do
    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).
      --
      -- 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 -> IO ()
forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()
checkSuspendedStatus Repository ('RepoType 'IsRebase) p wR wU wR
repo

-- | Got a rebase operation to run where we may need to initialise the
-- rebase state first. Make sure you have taken the lock before calling this.
startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
               => (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
               -> Repository ('RepoType 'IsRebase) p wR wU wR
               -> IO a
startRebaseJob :: (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
startRebaseJob Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job Repository ('RepoType 'IsRebase) p wR wU wR
repo = do
    let rf :: RepoFormat
rf = 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
    if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress RepoFormat
rf then
      SRebaseType 'IsRebase
-> Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()
forall (p :: * -> * -> *) (rebaseType :: RebaseType) wR wU.
RepoPatch p =>
SRebaseType rebaseType
-> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
checkOldStyleRebaseStatus SRebaseType 'IsRebase
SIsRebase Repository ('RepoType 'IsRebase) p wR wU wR
repo
    else
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress_2_16 RepoFormat
rf) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        RepoFormat -> FilePath -> IO ()
writeRepoFormat (RepoProperty -> RepoFormat -> RepoFormat
addToFormat RepoProperty
RebaseInProgress_2_16 RepoFormat
rf) FilePath
formatPath
    (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR -> 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 -> IO a
rebaseJob Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job Repository ('RepoType 'IsRebase) p wR wU wR
repo

checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree)
                     => Repository ('RepoType 'IsRebase) p wR wU wR
                     -> IO ()
checkSuspendedStatus :: Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()
checkSuspendedStatus Repository ('RepoType 'IsRebase) p wR wU wR
_repo = do
    Suspended p wR wR
ps <- Repository ('RepoType 'IsRebase) p wR wU wR
-> IO (Suspended p wR wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Suspended p wT wT)
readTentativeRebase Repository ('RepoType 'IsRebase) p wR wU wR
_repo IO (Suspended p wR wR)
-> (IOError -> IO (Suspended p wR wR)) -> IO (Suspended p wR wR)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ -> Repository ('RepoType 'IsRebase) p wR wU wR
-> IO (Suspended p wR wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
RepoPatch p =>
Repository rt p wR wU wR -> IO (Suspended p wR wR)
readRebase Repository ('RepoType 'IsRebase) p wR wU wR
_repo
    case Suspended p wR wR -> Int
forall (p :: * -> * -> *) wX wY. Suspended p wX wY -> Int
countToEdit Suspended p wR wR
ps of
         Int
0 -> do
               RepoFormat -> FilePath -> IO ()
writeRepoFormat
                  (RepoProperty -> RepoFormat -> RepoFormat
removeFromFormat RepoProperty
RebaseInProgress_2_16 (RepoFormat -> RepoFormat) -> RepoFormat -> RepoFormat
forall a b. (a -> b) -> a -> b
$
                    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)
                  FilePath
formatPath
               FilePath -> IO ()
putStrLn FilePath
"Rebase finished!"
         Int
n -> Int -> IO ()
displaySuspendedStatus Int
n

displaySuspendedStatus :: Int -> IO ()
displaySuspendedStatus :: Int -> IO ()
displaySuspendedStatus Int
count =
  Doc -> IO ()
ePutDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep
    [ Doc
"Rebase in progress:"
    , FilePath -> Doc
text (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
count)
    , Doc
"suspended"
    , FilePath -> Doc
text (Int -> Noun -> ShowS
forall n. Countable n => Int -> n -> ShowS
englishNum Int
count (FilePath -> Noun
Noun FilePath
"patch") FilePath
"")
    ]

-- | Generic status display for non-rebase commands.
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 SRebaseType rebaseType
SIsRebase Repository ('RepoType rebaseType) p wR wU wR
repo = do
  Suspended p wR wR
ps <- Repository ('RepoType rebaseType) p wR wU wR
-> IO (Suspended p wR wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Suspended p wT wT)
readTentativeRebase Repository ('RepoType rebaseType) p wR wU wR
repo IO (Suspended p wR wR)
-> (IOError -> IO (Suspended p wR wR)) -> IO (Suspended p wR wR)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ -> Repository ('RepoType rebaseType) p wR wU wR
-> IO (Suspended p wR wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
RepoPatch p =>
Repository rt p wR wU wR -> IO (Suspended p wR wR)
readRebase Repository ('RepoType rebaseType) p wR wU wR
repo
  Int -> IO ()
displaySuspendedStatus (Suspended p wR wR -> Int
forall (p :: * -> * -> *) wX wY. Suspended p wX wY -> Int
countToEdit Suspended p wR wR
ps)
maybeDisplaySuspendedStatus SRebaseType rebaseType
SNoRebase Repository ('RepoType rebaseType) p wR wU wR
_    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

withTentativeRebase
  :: RepoPatch p
  => Repository rt p wR wU wT
  -> Repository rt p wR wU wY
  -> (Suspended p wT wT -> Suspended p wY wY)
  -> IO ()
withTentativeRebase :: Repository rt p wR wU wT
-> Repository rt p wR wU wY
-> (Suspended p wT wT -> Suspended p wY wY)
-> IO ()
withTentativeRebase Repository rt p wR wU wT
r Repository rt p wR wU wY
r' Suspended p wT wT -> Suspended p wY wY
f =
  Repository rt p wR wU wT -> IO (Suspended p wT wT)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Suspended p wT wT)
readTentativeRebase Repository rt p wR wU wT
r IO (Suspended p wT wT) -> (Suspended p wT wT -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Repository rt p wR wU wY -> Suspended p wY wY -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> Suspended p wT wT -> IO ()
writeTentativeRebase Repository rt p wR wU wY
r' (Suspended p wY wY -> IO ())
-> (Suspended p wT wT -> Suspended p wY wY)
-> Suspended p wT wT
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Suspended p wT wT -> Suspended p wY wY
f

readTentativeRebase :: RepoPatch p
                    => Repository rt p wR wU wT -> IO (Suspended p wT wT)
readTentativeRebase :: Repository rt p wR wU wT -> IO (Suspended p wT wT)
readTentativeRebase = FilePath -> Repository rt p wR wU wT -> IO (Suspended p wT wT)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wX.
RepoPatch p =>
FilePath -> Repository rt p wR wU wT -> IO (Suspended p wX wX)
readRebaseFile FilePath
tentativeRebasePath

writeTentativeRebase :: RepoPatch p
                     => Repository rt p wR wU wT -> Suspended p wT wT -> IO ()
writeTentativeRebase :: Repository rt p wR wU wT -> Suspended p wT wT -> IO ()
writeTentativeRebase = FilePath -> Repository rt p wR wU wT -> Suspended p wT wT -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wX.
RepoPatch p =>
FilePath -> Repository rt p wR wU wT -> Suspended p wX wX -> IO ()
writeRebaseFile FilePath
tentativeRebasePath

readRebase :: RepoPatch p => Repository rt p wR wU wR -> IO (Suspended p wR wR)
readRebase :: Repository rt p wR wU wR -> IO (Suspended p wR wR)
readRebase = FilePath -> Repository rt p wR wU wR -> IO (Suspended p wR wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wX.
RepoPatch p =>
FilePath -> Repository rt p wR wU wT -> IO (Suspended p wX wX)
readRebaseFile FilePath
rebasePath

createTentativeRebase :: RepoPatch p => Repository rt p wR wU wR -> IO ()
createTentativeRebase :: Repository rt p wR wU wR -> IO ()
createTentativeRebase Repository rt p wR wU wR
r = FilePath
-> Repository rt p wR wU wR -> Suspended p Any Any -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wX.
RepoPatch p =>
FilePath -> Repository rt p wR wU wT -> Suspended p wX wX -> IO ()
writeRebaseFile FilePath
tentativeRebasePath Repository rt p wR wU wR
r (FL (RebaseChange (PrimOf p)) wR wR -> Suspended p wR wR
forall (p :: * -> * -> *) wX wY.
FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX wX
Items FL (RebaseChange (PrimOf p)) wR wR
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL :: Suspended p wR wR)

-- unsafe witnesses, not exported
readRebaseFile :: RepoPatch p
               => FilePath -> Repository rt p wR wU wT -> IO (Suspended p wX wX)
readRebaseFile :: FilePath -> Repository rt p wR wU wT -> IO (Suspended p wX wX)
readRebaseFile FilePath
path Repository rt p wR wU wT
r =
  Repository rt p wR wU wT
-> IO (Suspended p wX wX) -> IO (Suspended p wX wX)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
r (IO (Suspended p wX wX) -> IO (Suspended p wX wX))
-> IO (Suspended p wX wX) -> IO (Suspended p wX wX)
forall a b. (a -> b) -> a -> b
$ do
    Either FilePath (Sealed (Suspended p wX))
parsed <- ByteString -> Either FilePath (Sealed (Suspended p wX))
forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Either FilePath (Sealed (p wX))
readPatch (ByteString -> Either FilePath (Sealed (Suspended p wX)))
-> IO ByteString -> IO (Either FilePath (Sealed (Suspended p wX)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
forall p. FilePathLike p => p -> IO ByteString
readBinFile FilePath
path
    case Either FilePath (Sealed (Suspended p wX))
parsed of
      Left FilePath
e -> FilePath -> IO (Suspended p wX wX)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (Suspended p wX wX))
-> FilePath -> IO (Suspended p wX wX)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath
"parse error in file " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path, FilePath
e]
      Right (Sealed Suspended p wX wX
sp) -> Suspended p wX wX -> IO (Suspended p wX wX)
forall (m :: * -> *) a. Monad m => a -> m a
return (Suspended p wX wX -> Suspended p wX wX
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd Suspended p wX wX
sp)

-- unsafe witnesses, not exported
writeRebaseFile :: RepoPatch p
                => FilePath -> Repository rt p wR wU wT
                -> Suspended p wX wX -> IO ()
writeRebaseFile :: FilePath -> Repository rt p wR wU wT -> Suspended p wX wX -> IO ()
writeRebaseFile FilePath
path Repository rt p wR wU wT
r Suspended p wX wX
sp =
  Repository rt p wR wU wT -> IO () -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
r (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile FilePath
path (ShowPatchFor -> Suspended p wX wX -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage Suspended p wX wX
sp)

type PiaW rt p = PatchInfoAndG rt (W.WrappedNamed rt p)

commuteOutOldStyleRebase :: RepoPatch p
                         => RL (PiaW rt p) wA wB
                         -> Maybe ((RL (PiaW rt p) :> PiaW rt p) wA wB)
commuteOutOldStyleRebase :: RL (PiaW rt p) wA wB
-> Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wB)
commuteOutOldStyleRebase RL (PiaW rt p) wA wB
NilRL = Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wB)
forall a. Maybe a
Nothing
commuteOutOldStyleRebase (RL (PiaW rt p) wA wY
ps :<: PiaW rt p wY wB
p)
  | W.RebaseP PatchInfo
_ Suspended p wY wY
_ <- PiaW rt p wY wB -> WrappedNamed rt p wY wB
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully PiaW rt p wY wB
p = (:>) (RL (PiaW rt p)) (PiaW rt p) wA wB
-> Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wB)
forall a. a -> Maybe a
Just (RL (PiaW rt p) wA wY
ps RL (PiaW rt p) wA wY
-> PiaW rt p wY wB -> (:>) (RL (PiaW rt p)) (PiaW rt p) wA wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PiaW rt p wY wB
p)
  | Bool
otherwise = do
      RL (PiaW rt p) wA wZ
ps' :> PiaW rt p wZ wY
r <- RL (PiaW rt p) wA wY
-> Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wY)
forall (p :: * -> * -> *) (rt :: RepoType) wA wB.
RepoPatch p =>
RL (PiaW rt p) wA wB
-> Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wB)
commuteOutOldStyleRebase RL (PiaW rt p) wA wY
ps
      case (:>) (PiaW rt p) (PiaW rt p) wZ wB
-> Maybe ((:>) (PiaW rt p) (PiaW rt p) wZ wB)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (PiaW rt p wZ wY
r PiaW rt p wZ wY
-> PiaW rt p wY wB -> (:>) (PiaW rt p) (PiaW rt p) wZ wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PiaW rt p wY wB
p) of
        Just (PatchInfoAndG rt (WrappedNamed rt p) wZ wZ
p' :> PatchInfoAndG rt (WrappedNamed rt p) wZ wB
r') -> (:>) (RL (PiaW rt p)) (PiaW rt p) wA wB
-> Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wB)
forall a. a -> Maybe a
Just (RL (PiaW rt p) wA wZ
ps' RL (PiaW rt p) wA wZ
-> PatchInfoAndG rt (WrappedNamed rt p) wZ wZ
-> RL (PiaW rt p) wA wZ
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchInfoAndG rt (WrappedNamed rt p) wZ wZ
p' RL (PiaW rt p) wA wZ
-> PatchInfoAndG rt (WrappedNamed rt p) wZ wB
-> (:>) (RL (PiaW rt p)) (PiaW rt p) wA wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PatchInfoAndG rt (WrappedNamed rt p) wZ wB
r')
        Maybe ((:>) (PiaW rt p) (PiaW rt p) wZ wB)
Nothing ->
          FilePath -> Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wB)
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wB))
-> FilePath -> Maybe ((:>) (RL (PiaW rt p)) (PiaW rt p) wA wB)
forall a b. (a -> b) -> a -> b
$ Doc -> FilePath
renderString (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ Doc
"internal error: cannot commute rebase patch:"
            Doc -> Doc -> Doc
$$ PiaW rt p wZ wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch PiaW rt p wZ wY
r
            Doc -> Doc -> Doc
$$ FilePath -> Doc
text FilePath
"with normal patch:"
            Doc -> Doc -> Doc
$$ PiaW rt p wY wB -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch PiaW rt p wY wB
p