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"
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
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')
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
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)
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)
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
applyAndTryToFixFL (Suspended ps) =
return . fmap (unlines *** ((:>: NilFL) . Suspended)) $ repairInternal ps
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
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)
| 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)
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)
takeAnyRebase :: PatchSet (Rebasing p) wA wB
-> (Sealed2 (PatchInfoAnd (Rebasing p)),
Sealed2 (FL (RebaseItem p)))
takeAnyRebase (PatchSet NilRL _) =
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)
takeAnyRebaseAndTrailingPatches
:: PatchSet (Rebasing p) wA wB
-> FlippedSeal (PatchInfoAnd (Rebasing p) :> RL (PatchInfoAnd (Rebasing p))) wB
takeAnyRebaseAndTrailingPatches (PatchSet NilRL _) =
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'))
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)