-- Copyright (C) 2009 Ganesh Sittampalam -- -- BSD3 module Darcs.Patch.Rebase ( takeHeadRebase , takeHeadRebaseFL , takeAnyRebase , takeAnyRebaseAndTrailingPatches , dropAnyRebase ) where import Prelude () import Darcs.Prelude import Darcs.Patch.Named.Wrapped ( WrappedNamed(RebaseP) ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) import Darcs.Patch.Rebase.Container ( Suspended(..) ) import Darcs.Patch.RepoType ( RepoType(..) , RebaseType(..) , IsRepoType(..) , SRepoType(..) , SRebaseType(..) ) import Darcs.Patch.Set ( PatchSet(..) ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed {- Notes Note [Rebase representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The entire rebase state is stored in a single Suspended patch (see Darcs.Patch.Rebase.Container). 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 mkRebase - 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. -} -- | 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 ('RepoType 'IsRebase) p wA wB -> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p), Sealed2 (Suspended p)) takeAnyRebase (PatchSet _ NilRL) = -- it should never be behind a tag so we can stop now bug "internal error: no suspended patch found" takeAnyRebase (PatchSet pss (ps :<: p)) | RebaseP _ rs <- hopefully p = (Sealed2 p, Sealed2 rs) | otherwise = takeAnyRebase (PatchSet pss ps) -- | Given the repository contents, get the rebase container patch, its -- contents, and the rest of the repository contents. The rebase patch can be -- anywhere in the repository and is returned without being commuted to the end. takeAnyRebaseAndTrailingPatches :: PatchSet ('RepoType 'IsRebase) p wA wB -> FlippedSeal (PatchInfoAnd ('RepoType 'IsRebase) p :> RL (PatchInfoAnd ('RepoType 'IsRebase) p)) wB takeAnyRebaseAndTrailingPatches (PatchSet _ NilRL) = -- it should never be behind a tag so we can stop now bug "internal error: no suspended patch found" takeAnyRebaseAndTrailingPatches (PatchSet pss (ps :<: p)) | RebaseP _ _ <- hopefully p = FlippedSeal (p :> NilRL) | otherwise = case takeAnyRebaseAndTrailingPatches (PatchSet pss ps) of FlippedSeal (r :> ps') -> FlippedSeal (r :> (ps' :<: p)) -- | Remove the rebase patch from a 'PatchSet'. dropAnyRebase :: forall rt p wA wB. IsRepoType rt => PatchSet rt p wA wB -> PatchSet rt p wA wB dropAnyRebase ps@(PatchSet tags patches) = case singletonRepoType::SRepoType rt of SRepoType SNoRebase -> ps SRepoType SIsRebase -> PatchSet tags (dropRebaseRL patches) -- | Remove the rebase patch from an 'RL' of patches. dropRebaseRL :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB -> RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB dropRebaseRL NilRL = bug "internal error: no suspended patch found" dropRebaseRL (ps :<: p) | RebaseP _ _ <- hopefully p = ps | otherwise = dropRebaseRL ps :<: p -- | 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 ('RepoType 'IsRebase) p wA wB -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, Suspended p wB wB, PatchSet ('RepoType 'IsRebase) p wA wB) takeHeadRebase (PatchSet pss (ps :<: p)) | RebaseP _ rs <- hopefully p = (p, rs, PatchSet pss ps) takeHeadRebase _ = bug "internal error: must have a rebase container patch at end of repository" -- | Same as 'takeHeadRebase' but for an 'RL' of patches. takeHeadRebaseRL :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, Suspended p wB wB, RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB) takeHeadRebaseRL (ps :<: p) | RebaseP _ rs <- hopefully p = (p, rs, ps) takeHeadRebaseRL _ = bug "internal error: must have a suspended patch at end of repository" -- | Same as 'takeHeadRebase' but for an 'FL' of patches. takeHeadRebaseFL :: FL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, Suspended p wB wB, FL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB) takeHeadRebaseFL ps = let (a, b, c) = takeHeadRebaseRL (reverseFL ps) in (a, b, reverseRL c)