darcs-2.10.0: src/Darcs/Patch/Rebase.hs
-- Copyright (C) 2009 Ganesh Sittampalam
--
-- BSD3
{-# LANGUAGE CPP, GADTs, PatternGuards, TypeOperators, NoMonomorphismRestriction, ViewPatterns, UndecidableInstances #-}
module Darcs.Patch.Rebase
( Rebasing(..), RebaseItem(..), RebaseName(..), RebaseFixup(..)
, simplifyPush, simplifyPushes
, mkSuspended
, takeHeadRebase, takeHeadRebaseFL, takeHeadRebaseRL
, takeAnyRebase, takeAnyRebaseAndTrailingPatches
, countToEdit
) where
import Darcs.Patch ( RepoPatch )
import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.CommuteFn ( CommuteFn )
import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )
import Darcs.Patch.Debug ( PatchDebug(..) )
import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.FileHunk ( IsHunk(..) )
import Darcs.Patch.Format ( PatchListFormat(..), ListFormat, copyListFormat )
import Darcs.Patch.Matchable ( Matchable )
import Darcs.Patch.MaybeInternal ( MaybeInternal(..), InternalChecker(..) )
import Darcs.Patch.Merge ( Merge(..) )
import Darcs.Patch.Named ( Named(..), patchcontents, namepatch
, commuterIdNamed
)
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )
import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..),
ShowPatch(..), ReadPatch(..),
PatchInspect(..)
)
import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL )
import Darcs.Patch.Read ( bracketedFL )
import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )
import Darcs.Patch.Rebase.Name
( RebaseName(..)
, commutePrimName, commuteNamePrim
)
import Darcs.Patch.Rebase.NameHack ( NameHack(..) )
import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..), RecontextRebase1(..), RecontextRebase2(..) )
import Darcs.Patch.Repair ( Check(..), RepairToFL(..) )
import Darcs.Patch.Set ( PatchSet(..) )
import Darcs.Patch.Show ( ShowPatchBasic(..) )
import Darcs.Patch.ReadMonads ( ParserM, lexString, myLex' )
import Darcs.Patch.Witnesses.Eq
import Darcs.Patch.Witnesses.Ordered
import Darcs.Patch.Witnesses.Sealed
import Darcs.Patch.Witnesses.Show
( Show1(..), Show2(..), showsPrec2
, ShowDict(ShowDictClass), appPrec
)
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )
import Darcs.Util.IsoDate ( getIsoDateTime )
import Darcs.Util.Text ( formatParas )
import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) )
import Prelude hiding ( pi )
import Control.Applicative ( (<$>), (<|>) )
import Control.Arrow ( (***), second )
import Control.Monad ( when )
import Data.Maybe ( catMaybes )
import qualified Data.ByteString as B ( ByteString )
import qualified Data.ByteString.Char8 as BC ( pack )
#include "impossible.h"
{- Notes
Note [Rebase representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The entire rebase state is stored in a single Suspended patch.
This is both unnatural and inefficient:
- Unnatural because the rebase state is not really a patch and
treating it as one requires various hacks:
- It has to be given a fake name: see mkSuspended
- Since 'Named p' actually contains 'FL p', we have to
assume/assert that the FL either contains a sequence of Normals
or a single Suspended
- When 'Named ps' commutes past 'Named (Suspended items :> NilFL)',
we need to inject the name from 'Named ps' into 'items', which
is a layering violation: see Darcs.Patch.Rebase.NameHack
- We need to hide the patch in the UI: see Darcs.Patch.MaybeInternal
- We need a conditional hook so that amend-record can change the
Suspended patch itself: see Darcs.Patch.Rebase.Recontext
(something like this might be necessary no matter what the
representation)
- Inefficient because we need to write the entire rebase state out
each time, even though most operations will only affect a small
portion near the beginning.
- This also means that we need to commute the rebase patch back
to the head of the repo lazily: we only do so when a rebase
operation requires it. Otherwise, pulling in 100 patches
would entail writing out the entire rebase patch to disk 100
times.
The obvious alternative is to store the rebase state at the repository
level, using inventories in some appropriate way.
The main reason this wasn't done is that the repository handling code
is quite fragile and hard to modify safely.
Also, rebase relies heavily on witnesses to check correctness, and
the witnesses on the Repository type are not as reliable as those
on patch types, partly because of the cruft in the repository code,
and partly because it's inherently harder to track witnesses when
the objects being manipulated are stored on disk and being changed
imperatively.
If and when the repository code becomes easier to work with, rebase
should be changed accordingly.
-}
-- TODO: move some of the docs of types to individual constructors
-- once http://trac.haskell.org/haddock/ticket/43 is fixed.
-- |A patch that lives in a repository where a rebase is in
-- progress. Such a repository will consist of @Normal@ patches
-- along with exactly one @Suspended@ patch.
--
-- Most rebase operations will require the @Suspended@ patch
-- to be at the end of the repository.
--
-- @Normal@ represents a normal patch within a respository where a
-- rebase is in progress. @Normal p@ is given the same on-disk
-- representation as @p@, so a repository can be switched into
-- and out of rebasing mode simply by adding or removing a
-- @Suspended@ patch and setting the appropriate format flag.
--
-- The single @Suspended@ patch contains the entire rebase
-- state, in the form of 'RebaseItem's.
--
-- Note that the witnesses are such that the @Suspended@
-- patch has no effect on the context of the rest of the
-- repository; in a sense the patches within it are
-- dangling off to one side from the main repository.
--
-- See Note [Rebase representation] in the source for a discussion
-- of the design choice to embed the rebase state in a single patch.
data Rebasing p wX wY where
Normal :: p wX wY -> Rebasing p wX wY
Suspended :: FL (RebaseItem p) wX wY -> Rebasing p wX wX
instance (Show2 p, Show2 (PrimOf p)) => Show (Rebasing p wX wY) where
showsPrec d (Normal p) =
showParen (d > appPrec) $ showString "Darcs.Patch.Rebase.Normal " . showsPrec2 (appPrec + 1) p
showsPrec d (Suspended p) =
showParen (d > appPrec) $ showString "Darcs.Patch.Rebase.Suspended " . showsPrec2 (appPrec + 1) p
instance (Show2 p, Show2 (PrimOf p)) => Show1 (Rebasing p wX) where
showDict1 = ShowDictClass
instance (Show2 p, Show2 (PrimOf p)) => Show2 (Rebasing p) where
showDict2 = ShowDictClass
-- |A single item in the rebase state consists of either
-- a patch that is being edited, or a fixup that adjusts
-- the context so that a subsequent patch that is being edited
-- \"makes sense\".
--
-- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of
-- the patch will typically be the name the patch had before
-- it was added to the rebase state; if it is moved back
-- into the repository it must be given a fresh name to account
-- for the fact that it will not necessarily have the same
-- dependencies as the original patch. This is typically
-- done by changing the @Ignore-This@ junk.
--
-- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch
-- is correct. Where possible, @Fixup@ changes are commuted
-- as far as possible into the rebase state, so any remaining
-- ones will typically cause a conflict when the @ToEdit@ patch
-- is moved back into the repository.
data RebaseItem p wX wY where
ToEdit :: Named p wX wY -> RebaseItem p wX wY
Fixup :: RebaseFixup p wX wY -> RebaseItem p wX wY
instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY) where
showsPrec d (ToEdit p) =
showParen (d > appPrec) $ showString "ToEdit " . showsPrec2 (appPrec + 1) p
showsPrec d (Fixup p) =
showParen (d > appPrec) $ showString "Fixup " . showsPrec2 (appPrec + 1) p
instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX) where
showDict1 = ShowDictClass
instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p) where
showDict2 = ShowDictClass
countToEdit :: FL (RebaseItem p) wX wY -> Int
countToEdit NilFL = 0
countToEdit (ToEdit _ :>: ps) = 1 + countToEdit ps
countToEdit (_ :>: ps) = countToEdit ps
commuterRebasing :: (PrimPatchBase p, Commute p, Invert p, FromPrim p, Effect p)
=> D.DiffAlgorithm -> CommuteFn p p
-> CommuteFn (Rebasing p) (Rebasing p)
commuterRebasing _ commuter (Normal p :> Normal q) = do
q' :> p' <- commuter (p :> q)
return (Normal q' :> Normal p')
-- Two rebases in sequence must have the same starting context,
-- so they should trivially commute.
-- This case shouldn't actually happen since each repo only has
-- a single Suspended patch.
commuterRebasing _ _ (p@(Suspended _) :> q@(Suspended _)) =
return (q :> p)
commuterRebasing da _ (Normal p :> Suspended qs) =
return (unseal Suspended (addFixup da p qs) :> Normal p)
commuterRebasing da _ (Suspended ps :> Normal q) =
return (Normal q :> unseal Suspended (addFixup da (invert q) ps))
instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p) => Commute (Rebasing p) where
commute = commuterRebasing D.MyersDiff commute
instance (PrimPatchBase p, FromPrim p, Effect p, Commute p) => NameHack (Rebasing p) where
nameHack da = Just (pushIn . AddName, pushIn . DelName)
where
pushIn :: RebaseName p wX wX -> FL (Rebasing p) wX wY -> FL (Rebasing p) wX wY
pushIn n (Suspended ps :>: NilFL) = unseal (\qs -> Suspended qs :>: NilFL) (simplifyPush da (NameFixup n) ps)
pushIn _ ps = ps
instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p, CommuteNoConflicts p) => CommuteNoConflicts (Rebasing p) where
commuteNoConflicts = commuterRebasing D.MyersDiff commuteNoConflicts
instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Merge p) => Merge (Rebasing p) where
merge (Normal p :\/: Normal q) = case merge (p :\/: q) of
q' :/\: p' -> Normal q' :/\: Normal p'
merge (p@(Suspended _) :\/: q@(Suspended _)) = q :/\: p
merge (Normal p :\/: Suspended qs) = unseal Suspended (addFixup D.MyersDiff (invert p) qs) :/\: Normal p
merge (Suspended ps :\/: Normal q) = Normal q :/\: unseal Suspended (addFixup D.MyersDiff (invert q) ps)
instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Rebasing p) where
listTouchedFiles (Normal p) = listTouchedFiles p
listTouchedFiles (Suspended ps) = concat $ mapFL ltfItem ps
where ltfItem :: RebaseItem p wX wY -> [FilePath]
ltfItem (ToEdit q) = listTouchedFiles q
ltfItem (Fixup (PrimFixup q)) = listTouchedFiles q
ltfItem (Fixup (NameFixup _)) = []
hunkMatches f (Normal p) = hunkMatches f p
hunkMatches f (Suspended ps) = or $ mapFL hmItem ps
where hmItem :: RebaseItem p wA wB -> Bool
hmItem (ToEdit q) = hunkMatches f q
hmItem (Fixup (PrimFixup q)) = hunkMatches f q
hmItem (Fixup (NameFixup _)) = False
instance Invert p => Invert (Rebasing p) where
invert (Normal p) = Normal (invert p)
invert (Suspended ps) = Suspended ps -- TODO is this sensible?
instance Effect p => Effect (Rebasing p) where
effect (Normal p) = effect p
effect (Suspended _) = NilFL
instance (PrimPatchBase p, PatchListFormat p, Patchy p, FromPrim p, Conflict p, Effect p, CommuteNoConflicts p, IsHunk p)
=> Patchy (Rebasing p)
instance PatchDebug p => PatchDebug (Rebasing p)
instance ( PrimPatchBase p, PatchListFormat p, Patchy p
, FromPrim p, Conflict p, Effect p
, PatchInspect p
, CommuteNoConflicts p, IsHunk p
)
=> Matchable (Rebasing p)
instance (Conflict p, FromPrim p, Effect p, Invert p, Commute p) => Conflict (Rebasing p) where
resolveConflicts (Normal p) = resolveConflicts p
resolveConflicts (Suspended _) = []
instance Apply p => Apply (Rebasing p) where
type ApplyState (Rebasing p) = ApplyState p
apply (Normal p) = apply p
apply (Suspended _) = return ()
instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Rebasing p) where
showPatch (Normal p) = showPatch p
showPatch (Suspended ps) = blueText "rebase" <+> text "0.0" <+> blueText "{"
$$ vcat (mapFL showPatch ps)
$$ blueText "}"
instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p)
=> ShowPatch (Rebasing p) where
summary (Normal p) = summary p
summary (Suspended ps) = summaryFL ps
summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts
instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where
showPatch (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch p $$ blueText ")"
showPatch (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch p $$ blueText ")"
showPatch (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch p $$ blueText ")"
instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p)
=> ShowPatch (RebaseItem p) where
summary (ToEdit p) = summary p
summary (Fixup (PrimFixup p)) = summary p
summary (Fixup (NameFixup n)) = summary n
summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts
instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where
readPatch' = mapSeal ToEdit <$> readWith (BC.pack "rebase-toedit") <|>
mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|>
mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name" )
where readWith :: forall m q wX . (ParserM m, ReadPatch q) => B.ByteString -> m (Sealed (q wX))
readWith str = do lexString str
lexString (BC.pack "(")
res <- readPatch'
lexString (BC.pack ")")
return res
instance PrimPatchBase p => PrimPatchBase (Rebasing p) where
type PrimOf (Rebasing p) = PrimOf p
instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Rebasing p) where
readPatch' =
do lexString (BC.pack "rebase")
version <- myLex'
when (version /= BC.pack "0.0") $ error $ "can't handle rebase version " ++ show version
(lexString (BC.pack "{}") >> return (seal (Suspended NilFL)))
<|>
(unseal (Sealed . Suspended) <$> bracketedFL readPatch' '{' '}')
<|> mapSeal Normal <$> readPatch'
instance IsHunk p => IsHunk (Rebasing p) where
isHunk (Normal p) = isHunk p
isHunk (Suspended _) = Nothing
instance FromPrim p => FromPrim (Rebasing p) where
fromPrim p = Normal (fromPrim p)
instance Check p => Check (Rebasing p) where
isInconsistent (Normal p) = isInconsistent p
isInconsistent (Suspended ps) =
case catMaybes (mapFL isInconsistent ps) of
[] -> Nothing
xs -> Just (vcat xs)
instance Check p => Check (RebaseItem p) where
isInconsistent (Fixup _) = Nothing
isInconsistent (ToEdit p) = isInconsistent p
instance RepairToFL p => RepairToFL (Rebasing p) where
applyAndTryToFixFL (Normal p) = fmap (second $ mapFL_FL Normal) <$> applyAndTryToFixFL p
-- TODO: ideally we would apply ps in a sandbox to check the individual patches
-- are consistent with each other.
applyAndTryToFixFL (Suspended ps) =
return . fmap (unlines *** ((:>: NilFL) . Suspended)) $ repairInternal ps
-- Just repair the internals of the patch, without applying it to anything
-- or checking against an external context.
-- Included for the internal implementation of applyAndTryToFixFL for Rebasing,
-- consider either generalising it for use everywhere, or removing once
-- the implementation works in a sandbox and thus can use the "full" Repair on the
-- contained patches.
class RepairInternalFL p where
repairInternalFL :: p wX wY -> Maybe ([String], FL p wX wY)
class RepairInternal p where
repairInternal :: p wX wY -> Maybe ([String], p wX wY)
instance RepairInternalFL p => RepairInternal (FL p) where
repairInternal NilFL = Nothing
repairInternal (x :>: ys) =
case (repairInternalFL x, repairInternal ys) of
(Nothing , Nothing) -> Nothing
(Just (e, rxs), Nothing) -> Just (e , rxs +>+ ys )
(Nothing , Just (e', rys)) -> Just (e' , x :>: rys)
(Just (e, rxs), Just (e', rys)) -> Just (e ++ e', rxs +>+ rys)
instance RepairInternalFL (RebaseItem p) where
repairInternalFL (ToEdit _) = Nothing
repairInternalFL (Fixup p) = fmap (second $ mapFL_FL Fixup) $ repairInternalFL p
instance RepairInternalFL (RebaseFixup p) where
repairInternalFL (PrimFixup _) = Nothing
repairInternalFL (NameFixup _) = Nothing
instance PatchListFormat p => PatchListFormat (Rebasing p) where
patchListFormat = copyListFormat (patchListFormat :: ListFormat p)
instance RepoPatch p => RepoPatch (Rebasing p)
instance (Commute p, PrimPatchBase p, FromPrim p, Effect p) => RecontextRebase (Rebasing p) where
recontextRebase = Just (RecontextRebase1 recontext)
where
recontext :: forall wY wZ . Named (Rebasing p) wY wZ -> (EqCheck wY wZ, RecontextRebase2 (Rebasing p) wY wZ)
recontext (patchcontents -> (Suspended ps :>: NilFL))
= (IsEq, RecontextRebase2 (\fixups -> unseal mkSuspended(simplifyPushes D.MyersDiff (mapFL_FL translateFixup fixups) ps)))
recontext _ = (NotEq, bug "trying to recontext rebase without rebase patch at head")
translateFixup :: RebaseFixup (Rebasing p) wX wY -> RebaseFixup p wX wY
translateFixup (PrimFixup p) = PrimFixup p
translateFixup (NameFixup n) = NameFixup (translateName n)
translateName :: RebaseName (Rebasing p) wX wY -> RebaseName p wX wY
translateName (AddName name) = AddName name
translateName (DelName name) = DelName name
translateName (Rename old new) = Rename old new
instance MaybeInternal (Rebasing p) where
patchInternalChecker = Just (InternalChecker rebaseIsInternal)
where rebaseIsInternal :: FL (Rebasing p) wX wY -> EqCheck wX wY
rebaseIsInternal (Suspended _ :>: NilFL) = IsEq
rebaseIsInternal _ = NotEq
addFixup :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) => D.DiffAlgorithm -> p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
addFixup da p = simplifyPushes da (mapFL_FL PrimFixup (effect p))
canonizeNamePair :: (RebaseName p :> RebaseName p) wX wY -> FL (RebaseName p) wX wY
canonizeNamePair (AddName n :> Rename old new) | n == old = AddName new :>: NilFL
canonizeNamePair (Rename old new :> DelName n) | n == new = DelName old :>: NilFL
canonizeNamePair (Rename old1 new1 :> Rename old2 new2) | new1 == old2 = Rename old1 new2 :>: NilFL
canonizeNamePair (n1 :> n2) = n1 :>: n2 :>: NilFL
-- |Given a list of rebase items, try to push a new fixup as far as possible into
-- the list as possible, using both commutation and coalescing. If the fixup
-- commutes past all the 'ToEdit' patches then it is dropped entirely.
simplifyPush :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
=> D.DiffAlgorithm -> RebaseFixup p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
simplifyPush _ _f NilFL = Sealed NilFL
simplifyPush da (PrimFixup f1) (Fixup (PrimFixup f2) :>: ps)
| IsEq <- isInverse = Sealed ps
| otherwise
= case commute (f1 :> f2) of
Nothing -> Sealed (mapFL_FL (Fixup . PrimFixup) (canonizeFL da (f1 :>: f2 :>: NilFL)) +>+ ps)
Just (f2' :> f1') -> mapSeal (Fixup (PrimFixup f2') :>:) (simplifyPush da (PrimFixup f1') ps)
where isInverse = invert f1 =\/= f2
simplifyPush da (PrimFixup f) (Fixup (NameFixup n) :>: ps)
= case commutePrimName (f :> n) of
n' :> f' -> mapSeal (Fixup (NameFixup n') :>:) (simplifyPush da (PrimFixup f') ps)
simplifyPush da (PrimFixup f) (ToEdit e :>: ps)
= case commuterIdNamed selfCommuter (fromPrim f :> e) of
Nothing -> Sealed (Fixup (PrimFixup f) :>: ToEdit e :>: ps)
Just (e' :> f') -> mapSeal (ToEdit e' :>:) (simplifyPushes da (mapFL_FL PrimFixup (effect f')) ps)
simplifyPush da (NameFixup n1) (Fixup (NameFixup n2) :>: ps)
| IsEq <- isInverse = Sealed ps
| otherwise
= case commute (n1 :> n2) of
Nothing -> Sealed (mapFL_FL (Fixup . NameFixup) (canonizeNamePair (n1 :> n2)) +>+ ps)
Just (n2' :> n1') -> mapSeal (Fixup (NameFixup n2') :>:) (simplifyPush da (NameFixup n1') ps)
where isInverse = invert n1 =\/= n2
simplifyPush da (NameFixup n) (Fixup (PrimFixup f) :>: ps) =
case commuteNamePrim (n :> f) of
f' :> n' -> mapSeal (Fixup (PrimFixup f') :>:) (simplifyPush da (NameFixup n') ps)
simplifyPush da (NameFixup (AddName an)) (p@(ToEdit (NamedP pn deps _)) :>: ps)
| an == pn = impossible
| an `elem` deps = Sealed (Fixup (NameFixup (AddName an)) :>: p :>: ps)
| otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (AddName an)) ps)
simplifyPush da (NameFixup (DelName dn)) (p@(ToEdit (NamedP pn deps _)) :>: ps)
-- this case can arise if a patch is suspended then a fresh copy is pulled from another repo
| dn == pn = Sealed (Fixup (NameFixup (DelName dn)) :>: p :>: ps)
| dn `elem` deps = impossible
| otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (DelName dn)) ps)
simplifyPush da (NameFixup (Rename old new)) (p@(ToEdit (NamedP pn deps body)) :>: ps)
| old == pn = impossible
| new == pn = impossible
| old `elem` deps = impossible
| new `elem` deps =
let newdeps = map (\dep -> if new == dep then old else dep) deps
in mapSeal (ToEdit (NamedP pn newdeps (unsafeCoerceP body)) :>:) (simplifyPush da (NameFixup (Rename old new)) ps)
| otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (Rename old new)) ps)
-- |Like 'simplifyPush' but for a list of fixups.
simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
=> D.DiffAlgorithm -> FL (RebaseFixup p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
simplifyPushes _ NilFL ps = Sealed ps
simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps)
mkSuspended :: FL (RebaseItem p) wX wY -> IO (Named (Rebasing p) wX wX)
mkSuspended ps = do
let name = "DO NOT TOUCH: Rebase patch"
let desc = formatParas 72
["This patch is an internal implementation detail of rebase, used to store suspended patches, " ++
"and should not be visible in the user interface. Please report a bug if a darcs " ++
"command is showing you this patch."]
date <- getIsoDateTime
let author = "Invalid <invalid@invalid>"
namepatch date name author desc (Suspended ps :>: NilFL)
-- |given the repository contents, get the rebase container patch, and its contents
-- The rebase patch can be anywhere in the repository and is returned without being
-- commuted to the end.
takeAnyRebase :: PatchSet (Rebasing p) wA wB
-> (Sealed2 (PatchInfoAnd (Rebasing p)),
Sealed2 (FL (RebaseItem p)))
takeAnyRebase (PatchSet NilRL _) =
-- it should never be behind a tag so we can stop now
error "internal error: no suspended patch found"
takeAnyRebase (PatchSet (p :<: ps) pss)
| Suspended rs :>: NilFL <- patchcontents (hopefully p) = (Sealed2 p, Sealed2 rs)
| otherwise = takeAnyRebase (PatchSet ps pss)
-- |given the repository contents, get the rebase container patch, its contents, and the
-- rest of the repository contents. Commutes the patch to the end of the repository
-- if necessary. The rebase patch must be at the head of the repository.
takeAnyRebaseAndTrailingPatches
:: PatchSet (Rebasing p) wA wB
-> FlippedSeal (PatchInfoAnd (Rebasing p) :> RL (PatchInfoAnd (Rebasing p))) wB
takeAnyRebaseAndTrailingPatches (PatchSet NilRL _) =
-- it should never be behind a tag so we can stop now
error "internal error: no suspended patch found"
takeAnyRebaseAndTrailingPatches (PatchSet (p :<: ps) pss)
| Suspended _ :>: NilFL <- patchcontents (hopefully p) = FlippedSeal (p :> NilRL)
| otherwise = case takeAnyRebaseAndTrailingPatches (PatchSet ps pss) of
FlippedSeal (r :> ps') -> FlippedSeal (r :> (p :<: ps'))
-- |given the repository contents, get the rebase container patch, its contents, and the
-- rest of the repository contents. The rebase patch must be at the head of the repository.
takeHeadRebase :: PatchSet (Rebasing p) wA wB
-> (PatchInfoAnd (Rebasing p) wB wB,
Sealed (FL (RebaseItem p) wB),
PatchSet (Rebasing p) wA wB)
takeHeadRebase (PatchSet NilRL _) = error "internal error: must have a rebase container patch at end of repository"
takeHeadRebase (PatchSet (p :<: ps) pss)
| Suspended rs :>: NilFL <- patchcontents (hopefully p) = (p, Sealed rs, PatchSet ps pss)
| otherwise = error "internal error: must have a rebase container patch at end of repository"
takeHeadRebaseRL :: RL (PatchInfoAnd (Rebasing p)) wA wB
-> (PatchInfoAnd (Rebasing p) wB wB,
Sealed (FL (RebaseItem p) wB),
RL (PatchInfoAnd (Rebasing p)) wA wB)
takeHeadRebaseRL NilRL = error "internal error: must have a suspended patch at end of repository"
takeHeadRebaseRL (p :<: ps)
| Suspended rs :>: NilFL <- patchcontents (hopefully p) = (p, Sealed rs, ps)
| otherwise = error "internal error: must have a suspended patch at end of repository"
takeHeadRebaseFL :: FL (PatchInfoAnd (Rebasing p)) wA wB
-> (PatchInfoAnd (Rebasing p) wB wB,
Sealed (FL (RebaseItem p) wB),
FL (PatchInfoAnd (Rebasing p)) wA wB)
takeHeadRebaseFL ps = let (a, b, c) = takeHeadRebaseRL (reverseFL ps) in (a, b, reverseRL c)