--  Copyright (C) 2009-2012 Ganesh Sittampalam
--
--  BSD3
{-# LANGUAGE OverloadedStrings #-}
module Darcs.Repository.Rebase
    ( -- * Create/read/write rebase patch
      readTentativeRebase
    , writeTentativeRebase
    , withTentativeRebase
    , readRebase
    , finalizeTentativeRebase
    , revertTentativeRebase
    , withManualRebaseUpdate
      -- * Handle rebase format and status
    , checkHasRebase
    , displayRebaseStatus
    , updateRebaseFormat
      -- * Handle old-style rebase
    , extractOldStyleRebase
    , checkOldStyleRebaseStatus
    ) where

import Darcs.Prelude

import Control.Monad ( unless, void, when )
import System.Directory ( copyFile, renameFile )
import System.Exit ( exitFailure )
import System.FilePath.Posix ( (</>) )

import qualified Darcs.Patch.Rebase.Legacy.Wrapped as W
import Darcs.Patch.PatchInfoAnd
    ( PatchInfoAnd
    , PatchInfoAndG
    , fmapPIAP
    , hopefully
    )
import Darcs.Patch.Rebase.Suspended
    ( Suspended(Items)
    , countToEdit
    , readSuspended
    , showSuspended
    , simplifyPushes
    , removeFixupsFromSuspended
    )
import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )
import Darcs.Patch.RepoPatch ( RepoPatch, PrimOf )
import Darcs.Patch.Show ( ShowPatchFor(ForStorage) )
import Darcs.Patch.Witnesses.Ordered
    ( (:>)(..)
    , FL(..)
    , RL(..)
    , foldlwFL
    , mapRL_RL
    , (+<<+)
    )
import Darcs.Patch.Witnesses.Sealed ( Dup(..) )

import Darcs.Repository.Format
    ( RepoProperty ( RebaseInProgress_2_16, RebaseInProgress )
    , formatHas
    , addToFormat
    , removeFromFormat
    )
import Darcs.Repository.InternalTypes
    ( Repository
    , AccessType(..)
    , modifyRepoFormat
    , repoFormat
    , repoLocation
    )
import Darcs.Repository.Paths
    ( rebasePath
    , tentativeRebasePath
    )

import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) )
import Darcs.Util.English ( englishNum, Noun(..) )
import Darcs.Util.Exception ( catchDoesNotExistError )
import Darcs.Util.Lock ( writeDocBinFile, readBinFile )
import Darcs.Util.Parser ( parse )
import Darcs.Util.Printer ( text, hsep, vcat )
import Darcs.Util.Printer.Color ( ePutDocLn )
import Darcs.Util.URL ( isValidLocalPath )

withManualRebaseUpdate
   :: RepoPatch p
   => Repository rt p wU wR
   -> (Repository rt p wU wR -> IO (Repository rt p wU wR', FL (RebaseFixup (PrimOf p)) wR' wR, x))
   -> IO (Repository rt p wU wR', x)
withManualRebaseUpdate :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR wR' x.
RepoPatch p =>
Repository rt p wU wR
-> (Repository rt p wU wR
    -> IO
         (Repository rt p wU wR', FL (RebaseFixup (PrimOf p)) wR' wR, x))
-> IO (Repository rt p wU wR', x)
withManualRebaseUpdate Repository rt p wU wR
r Repository rt p wU wR
-> IO
     (Repository rt p wU wR', FL (RebaseFixup (PrimOf p)) wR' wR, x)
subFunc = do
    Suspended p wR
susp <- Repository rt p wU wR -> IO (Suspended p wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (Suspended p wR)
readTentativeRebase Repository rt p wU wR
r
    (Repository rt p wU wR'
r', FL (RebaseFixup (PrimOf p)) wR' wR
fixups, x
x) <- Repository rt p wU wR
-> IO
     (Repository rt p wU wR', FL (RebaseFixup (PrimOf p)) wR' wR, x)
subFunc Repository rt p wU wR
r
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Suspended p wR -> Int
forall (p :: * -> * -> *) wX. Suspended p wX -> Int
countToEdit Suspended p wR
susp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      -- HACK overwrite the changes that were made by subFunc
      -- which may and indeed does call add/remove patch
      Repository rt p wU wR' -> Suspended p wR' -> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> Suspended p wR -> IO ()
writeTentativeRebase Repository rt p wU wR'
r' (DiffAlgorithm
-> FL (RebaseFixup (PrimOf p)) wR' wR
-> Suspended p wR
-> Suspended p wR'
forall (p :: * -> * -> *) wX wY.
PrimPatchBase p =>
DiffAlgorithm
-> FL (RebaseFixup (PrimOf p)) wX wY
-> Suspended p wY
-> Suspended p wX
simplifyPushes DiffAlgorithm
MyersDiff FL (RebaseFixup (PrimOf p)) wR' wR
fixups Suspended p wR
susp)
    (Repository rt p wU wR', x) -> IO (Repository rt p wU wR', x)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository rt p wU wR'
r', x
x)

-- | Fail if there is an old-style rebase present.
-- To be called initially for every command except rebase upgrade.
checkOldStyleRebaseStatus :: Repository rt p wU wR -> IO ()
checkOldStyleRebaseStatus :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO ()
checkOldStyleRebaseStatus Repository rt p wU wR
repo = do
  let rf :: RepoFormat
rf = Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
repo
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress RepoFormat
rf) (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."
      ]

-- | Fail unless we already have some suspended patches.
-- Not essential, since all rebase commands should be happy to work
-- with an empty rebase state.
checkHasRebase :: Repository rt p wU wR -> IO ()
checkHasRebase :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO ()
checkHasRebase Repository rt p wU wR
repo =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress_2_16 (RepoFormat -> Bool) -> RepoFormat -> Bool
forall a b. (a -> b) -> a -> b
$ Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
repo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No rebase in progress. Try 'darcs rebase suspend' first."

-- | Report the rebase status if there is (still) a rebase in progress
-- after the command has finished running.
-- To be called via 'finally' for every 'RepoJob'.
displayRebaseStatus :: RepoPatch p => Repository rt p wU wR -> IO ()
displayRebaseStatus :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO ()
displayRebaseStatus Repository rt p wU wR
repo = do
  -- The repoLocation may be a remote URL (e.g. darcs log). We neither can nor
  -- want to display anything in that case.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
isValidLocalPath (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
repo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- Why do we use 'readRebase' and not 'readTentativeRebase' here?
    -- There are three cases:
    -- * We had no transaction in the first place.
    -- * We had a successful transaction: then it will be finalized before we
    --   are called (because finalization is part of the RepoJob itself) and
    --   we want to report the new finalized state.
    -- * We had a transaction that was cancelled or failed: then we want to
    --   report the old (unmodified) rebase state.
    -- Thus, in all cases 'readRebase' is the correct choice. However, if there
    -- is no rebase in progress, then 'rebasePath' may not exist, so we must
    -- handle that.
    Suspended p wR
suspended <- Repository rt p wU wR -> IO (Suspended p wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (Suspended p wR)
readRebase Repository rt p wU wR
repo IO (Suspended p wR) -> IO (Suspended p wR) -> IO (Suspended p wR)
forall a. IO a -> IO a -> IO a
`catchDoesNotExistError` Suspended p wR -> IO (Suspended p wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (RebaseChange (PrimOf p)) wR wR -> Suspended p wR
forall (p :: * -> * -> *) wX wY.
FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX
Items FL (RebaseChange (PrimOf p)) wR wR
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
    case Suspended p wR -> Int
forall (p :: * -> * -> *) wX. Suspended p wX -> Int
countToEdit Suspended p wR
suspended of
      Int
0 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Int
count ->
        Doc -> IO ()
ePutDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep
          [ Doc
"Rebase in progress:"
          , String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
count)
          , Doc
"suspended"
          , String -> Doc
text (Int -> Noun -> ShowS
forall n. Countable n => Int -> n -> ShowS
englishNum Int
count (String -> Noun
Noun String
"patch") String
"")
          ]

-- | Rebase format update for all commands that modify the repo,
-- except rebase upgrade. This is called by 'finalizeRepositoryChanges'.
updateRebaseFormat :: RepoPatch p => Repository 'RW p wU wR -> IO ()
updateRebaseFormat :: forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO ()
updateRebaseFormat Repository 'RW p wU wR
repo = do
  let rf :: RepoFormat
rf = Repository 'RW p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RW p wU wR
repo
      hadRebase :: Bool
hadRebase = RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress_2_16 RepoFormat
rf
  Suspended p wR
suspended <-
    Repository 'RW p wU wR -> IO (Suspended p wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (Suspended p wR)
readTentativeRebase Repository 'RW p wU wR
repo IO (Suspended p wR) -> IO (Suspended p wR) -> IO (Suspended p wR)
forall a. IO a -> IO a -> IO a
`catchDoesNotExistError` Suspended p wR -> IO (Suspended p wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (RebaseChange (PrimOf p)) wR wR -> Suspended p wR
forall (p :: * -> * -> *) wX wY.
FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX
Items FL (RebaseChange (PrimOf p)) wR wR
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
  case Suspended p wR -> Int
forall (p :: * -> * -> *) wX. Suspended p wX -> Int
countToEdit Suspended p wR
suspended of
    Int
0 ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hadRebase (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IO (Repository 'RW p wU wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RW p wU wR) -> IO ())
-> IO (Repository 'RW p wU wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ (RepoFormat -> RepoFormat)
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoFormat -> RepoFormat)
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
modifyRepoFormat (RepoProperty -> RepoFormat -> RepoFormat
removeFromFormat RepoProperty
RebaseInProgress_2_16) Repository 'RW p wU wR
repo
        String -> IO ()
putStrLn String
"Rebase finished!"
    Int
_ ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hadRebase (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO (Repository 'RW p wU wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RW p wU wR) -> IO ())
-> IO (Repository 'RW p wU wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ (RepoFormat -> RepoFormat)
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoFormat -> RepoFormat)
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
modifyRepoFormat (RepoProperty -> RepoFormat -> RepoFormat
addToFormat RepoProperty
RebaseInProgress_2_16) Repository 'RW p wU wR
repo

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

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

writeTentativeRebase :: RepoPatch p
                     => Repository rt p wU wR -> Suspended p wR -> IO ()
writeTentativeRebase :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> Suspended p wR -> IO ()
writeTentativeRebase = String -> Repository rt p wU wR -> Suspended p wR -> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
String -> Repository rt p wU wR -> Suspended p wR -> IO ()
writeRebaseFile String
tentativeRebasePath

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

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

revertTentativeRebase :: RepoPatch p => Repository rt p wU wR -> IO ()
revertTentativeRebase :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO ()
revertTentativeRebase Repository rt p wU wR
repo =
  String -> String -> IO ()
copyFile String
rebasePath String
tentativeRebasePath
    IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchDoesNotExistError` Repository rt p wU wR -> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO ()
createTentativeRebase Repository rt p wU wR
repo

finalizeTentativeRebase :: IO ()
finalizeTentativeRebase :: IO ()
finalizeTentativeRebase = String -> String -> IO ()
renameFile String
tentativeRebasePath String
rebasePath

-- unsafe witnesses, not exported
readRebaseFile :: RepoPatch p
               => FilePath -> Repository rt p wU wR -> IO (Suspended p wX)
readRebaseFile :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR wX.
RepoPatch p =>
String -> Repository rt p wU wR -> IO (Suspended p wX)
readRebaseFile String
path Repository rt p wU wR
r = do
  Either String (Suspended p wX, ByteString)
parsed <- Parser (Suspended p wX)
-> ByteString -> Either String (Suspended p wX, ByteString)
forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser (Suspended p wX)
forall (p :: * -> * -> *) wX.
RepoPatch p =>
Parser (Suspended p wX)
readSuspended (ByteString -> Either String (Suspended p wX, ByteString))
-> IO ByteString -> IO (Either String (Suspended p wX, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
forall p. FilePathLike p => p -> IO ByteString
readBinFile (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
r String -> ShowS
</> String
path)
  case Either String (Suspended p wX, ByteString)
parsed of
    Left String
e -> String -> IO (Suspended p wX)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Suspended p wX)) -> String -> IO (Suspended p wX)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"parse error in file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path, String
e]
    Right (Suspended p wX
result, ByteString
_) -> Suspended p wX -> IO (Suspended p wX)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Suspended p wX
result

-- unsafe witnesses, not exported
writeRebaseFile :: RepoPatch p
                => FilePath -> Repository rt p wU wR
                -> Suspended p wR -> IO ()
writeRebaseFile :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
String -> Repository rt p wU wR -> Suspended p wR -> IO ()
writeRebaseFile String
path Repository rt p wU wR
r Suspended p wR
sp =
  String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
r String -> ShowS
</> String
path) (ShowPatchFor -> Suspended p wR -> Doc
forall (p :: * -> * -> *) wX.
PrimPatchBase p =>
ShowPatchFor -> Suspended p wX -> Doc
showSuspended ShowPatchFor
ForStorage Suspended p wR
sp)

type PiaW p = PatchInfoAndG (W.WrappedNamed p)

extractOldStyleRebase :: forall p wA wB. RepoPatch p
                      => RL (PiaW p) wA wB
                      -> Maybe ((RL (PatchInfoAnd p) :> Dup (Suspended p)) wA wB)
extractOldStyleRebase :: forall (p :: * -> * -> *) wA wB.
RepoPatch p =>
RL (PiaW p) wA wB
-> Maybe ((:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wA wB)
extractOldStyleRebase RL (PiaW p) wA wB
ps = (:>) (RL (PiaW p)) (FL (PatchInfoAnd p)) wA wB
-> Maybe ((:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wA wB)
go (RL (PiaW p) wA wB
ps RL (PiaW p) wA wB
-> FL (PatchInfoAnd p) wB wB
-> (:>) (RL (PiaW p)) (FL (PatchInfoAnd p)) wA wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd p) wB wB
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) where
  go :: (RL (PiaW p) :> FL (PatchInfoAnd p)) wA wB
     -> Maybe ((RL (PatchInfoAnd p) :> Dup (Suspended p)) wA wB)
  go :: (:>) (RL (PiaW p)) (FL (PatchInfoAnd p)) wA wB
-> Maybe ((:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wA wB)
go (RL (PiaW p) wA wZ
NilRL :> FL (PatchInfoAnd p) wZ wB
_) = Maybe ((:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wA wB)
forall a. Maybe a
Nothing
  go (RL (PiaW p) wA wY
xs :<: PiaW p wY wZ
x :> FL (PatchInfoAnd p) wZ wB
ys)
    | W.RebaseP PatchInfo
_ Suspended p wY
r <- PiaW p wY wZ -> WrappedNamed p wY wZ
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully PiaW p wY wZ
x = do
      let xs' :: RL (PatchInfoAnd p) wA wY
xs' = (forall wW wY. PiaW p wW wY -> PatchInfoAndG (Named p) wW wY)
-> RL (PiaW p) wA wY -> RL (PatchInfoAnd p) wA wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ
mapRL_RL ((WrappedNamed p wW wY -> Named p wW wY)
-> PatchInfoAndG (WrappedNamed p) wW wY
-> PatchInfoAndG (Named p) wW wY
forall (p :: * -> * -> *) wX wY (q :: * -> * -> *).
(p wX wY -> q wX wY)
-> PatchInfoAndG p wX wY -> PatchInfoAndG q wX wY
fmapPIAP WrappedNamed p wW wY -> Named p wW wY
forall (p :: * -> * -> *) wX wY.
WrappedNamed p wX wY -> Named p wX wY
W.fromRebasing) RL (PiaW p) wA wY
xs
          rffs :: Suspended p wZ -> Suspended p wB
rffs = (forall wA wB.
 PatchInfoAnd p wA wB -> Suspended p wA -> Suspended p wB)
-> FL (PatchInfoAnd p) wZ wB -> Suspended p wZ -> Suspended p wB
forall (p :: * -> * -> *) (r :: * -> *) wX wY.
(forall wA wB. p wA wB -> r wA -> r wB)
-> FL p wX wY -> r wX -> r wY
foldlwFL (Named p wA wB -> Suspended p wA -> Suspended p wB
forall (p :: * -> * -> *) wX wY.
(PrimPatchBase p, Effect p) =>
Named p wX wY -> Suspended p wX -> Suspended p wY
removeFixupsFromSuspended (Named p wA wB -> Suspended p wA -> Suspended p wB)
-> (PatchInfoAnd p wA wB -> Named p wA wB)
-> PatchInfoAnd p wA wB
-> Suspended p wA
-> Suspended p wB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wA wB -> Named p wA wB
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully) FL (PatchInfoAnd p) wZ wB
ys
      (:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wA wB
-> Maybe ((:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wA wB)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((RL (PatchInfoAnd p) wA wY
xs' RL (PatchInfoAnd p) wA wY
-> FL (PatchInfoAnd p) wY wB -> RL (PatchInfoAnd p) wA wB
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> RL p wX wZ
+<<+ FL (PatchInfoAnd p) wZ wB
FL (PatchInfoAnd p) wY wB
ys) RL (PatchInfoAnd p) wA wB
-> Dup (Suspended p) wB wB
-> (:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wA wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> Suspended p wB -> Dup (Suspended p) wB wB
forall (p :: * -> *) wX. p wX -> Dup p wX wX
Dup (Suspended p wZ -> Suspended p wB
rffs Suspended p wZ
Suspended p wY
r))
    | Bool
otherwise = (:>) (RL (PiaW p)) (FL (PatchInfoAnd p)) wA wB
-> Maybe ((:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wA wB)
go (RL (PiaW p) wA wY
xs RL (PiaW p) wA wY
-> FL (PatchInfoAnd p) wY wB
-> (:>) (RL (PiaW p)) (FL (PatchInfoAnd p)) wA wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> (WrappedNamed p wY wZ -> Named p wY wZ)
-> PiaW p wY wZ -> PatchInfoAndG (Named p) wY wZ
forall (p :: * -> * -> *) wX wY (q :: * -> * -> *).
(p wX wY -> q wX wY)
-> PatchInfoAndG p wX wY -> PatchInfoAndG q wX wY
fmapPIAP WrappedNamed p wY wZ -> Named p wY wZ
forall (p :: * -> * -> *) wX wY.
WrappedNamed p wX wY -> Named p wX wY
W.fromRebasing PiaW p wY wZ
x PatchInfoAndG (Named p) wY wZ
-> FL (PatchInfoAnd p) wZ wB -> FL (PatchInfoAnd p) wY wB
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd p) wZ wB
ys)