#include "gadts.h"
module Darcs.Patch.V1.Commute
(
merge,
merger, unravel,
publicUnravel,
)
where
import Control.Monad ( MonadPlus, mplus, msum, mzero, guard )
import Darcs.Patch.Commute ( toFwdCommute )
import Darcs.Patch.ConflictMarking ( mangleUnravelled )
import Darcs.Patch.FileName ( FileName )
import Darcs.Patch.Invert ( invertRL )
import Darcs.Patch.Merge ( Merge(..) )
import Darcs.Patch.Patchy ( Commute(..), PatchInspect(..), Invert(..) )
import Darcs.Patch.V1.Core ( Patch(..),
isMerger,
mergerUndo )
import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )
import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.FileHunk ( IsHunk(..) )
import Darcs.Patch.Prim ( FromPrim(..), PrimPatch,
is_filepatch, sortCoalesceFL,
)
import Darcs.Patch.Permutations ( headPermutationsRL, simpleHeadPermutationsFL,
commuterIdFL, commuterFLId, selfCommuter )
import Printer ( text, vcat, ($$) )
import Darcs.Patch.V1.Show ( showPatch_ )
import Data.List ( nub, nubBy )
import Darcs.Witnesses.Sealed ( unsafeUnseal, unsafeUnsealFlipped )
import Darcs.Utils ( nubsort )
#include "impossible.h"
import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, unseal, FlippedSeal(..), mapFlipped )
import Darcs.Witnesses.Eq ( EqCheck(..), MyEq(..) )
import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart
, unsafeCoercePEnd )
import Darcs.Witnesses.Ordered ( mapFL_FL,
FL(..), RL(..),
(:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..),
lengthFL, mapRL,
reverseFL, reverseRL, concatFL
)
data Perhaps a = Unknown | Failed | Succeeded a
instance Monad Perhaps where
(Succeeded x) >>= k = k x
Failed >>= _ = Failed
Unknown >>= _ = Unknown
Failed >> _ = Failed
(Succeeded _) >> k = k
Unknown >> k = k
return = Succeeded
fail _ = Unknown
instance MonadPlus Perhaps where
mzero = Unknown
Unknown `mplus` ys = ys
Failed `mplus` _ = Failed
(Succeeded x) `mplus` _ = Succeeded x
toMaybe :: Perhaps a -> Maybe a
toMaybe (Succeeded x) = Just x
toMaybe _ = Nothing
toPerhaps :: Maybe a -> Perhaps a
toPerhaps (Just x) = Succeeded x
toPerhaps Nothing = Failed
cleverCommute :: Invert prim => CommuteFunction prim -> CommuteFunction prim
cleverCommute c (p1:<p2) =
case c (p1 :< p2) of
Succeeded x -> Succeeded x
Failed -> Failed
Unknown -> case c (invert p2 :< invert p1) of
Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1')
Failed -> Failed
Unknown -> Unknown
speedyCommute :: PrimPatch prim => CommuteFunction prim
speedyCommute (p1 :< p2)
| p1_modifies /= Nothing && p2_modifies /= Nothing &&
p1_modifies /= p2_modifies = Succeeded (unsafeCoerceP p2 :< unsafeCoerceP p1)
| otherwise = Unknown
where p1_modifies = isFilepatchMerger p1
p2_modifies = isFilepatchMerger p2
everythingElseCommute :: forall prim . PrimPatch prim => CommuteFunction prim
everythingElseCommute x = eec x
where
eec :: CommuteFunction prim
eec (PP px :< PP py) = toPerhaps $ do x' :> y' <- commute (py :> px)
return (PP y' :< PP x')
eec _xx =
msum [
cleverCommute commuteRecursiveMerger _xx
,cleverCommute otherCommuteRecursiveMerger _xx
]
unsafeMerger :: PrimPatch prim => String -> Patch prim C(x y) -> Patch prim C(x z) -> Patch prim C(a b)
unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2
mergerCommute :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))
mergerCommute (Merger _ _ p1 p2 :< pA)
| unsafeCompare pA p1 = Succeeded (unsafeMerger "0.0" p2 p1 :< unsafeCoercePStart p2)
| unsafeCompare pA (invert (unsafeMerger "0.0" p2 p1)) = Failed
mergerCommute (Merger _ _
(Merger _ _ c b)
(Merger _ _ c' a) :<
Merger _ _ b' c'')
| unsafeCompare b' b && unsafeCompare c c' && unsafeCompare c c'' =
Succeeded (unsafeMerger "0.0" (unsafeMerger "0.0" b (unsafeCoercePStart a)) (unsafeMerger "0.0" b c) :<
unsafeMerger "0.0" b (unsafeCoercePStart a))
mergerCommute _ = Unknown
instance PrimPatch prim => Merge (Patch prim) where
merge (y :\/: z) =
case actualMerge (y:\/:z) of
Sealed y' -> case commute (z :> y') of
Nothing -> bugDoc $ text "merge_patches bug"
$$ showPatch_ y
$$ showPatch_ z
$$ showPatch_ y'
Just (_ :> z') ->
unsafeCoercePStart z' :/\: y'
instance PrimPatch prim => Commute (Patch prim) where
commute x = toMaybe $ msum
[toFwdCommute speedyCommute x,
toFwdCommute (cleverCommute mergerCommute) x,
toFwdCommute everythingElseCommute x
]
instance PrimPatch prim => PatchInspect (Patch prim) where
listTouchedFiles (Merger _ _ p1 p2) = nubsort $ listTouchedFiles p1
++ listTouchedFiles p2
listTouchedFiles c@(Regrem _ _ _ _) = listTouchedFiles $ invert c
listTouchedFiles (PP p) = listTouchedFiles p
hunkMatches f (Merger _ _ p1 p2) = hunkMatches f p1 || hunkMatches f p2
hunkMatches f c@(Regrem _ _ _ _) = hunkMatches f $ invert c
hunkMatches f (PP p) = hunkMatches f p
commuteNoMerger :: PrimPatch prim => MaybeCommute prim
commuteNoMerger x =
toMaybe $ msum [speedyCommute x,
everythingElseCommute x]
isFilepatchMerger :: PrimPatch prim => Patch prim C(x y) -> Maybe FileName
isFilepatchMerger (PP p) = is_filepatch p
isFilepatchMerger (Merger _ _ p1 p2) = do
f1 <- isFilepatchMerger p1
f2 <- isFilepatchMerger p2
if f1 == f2 then return f1 else Nothing
isFilepatchMerger (Regrem und unw p1 p2)
= isFilepatchMerger (Merger und unw p1 p2)
commuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))
commuteRecursiveMerger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $
do (_ :> pA') <- commuterIdFL selfCommuter (pA :> undo)
_ <- commuterIdFL selfCommuter (pA' :> invert undo)
(_ :> pAmid) <- commute (pA :> unsafeCoercePStart (invert p1))
(p1' :> pAx) <- commute (pAmid :> p1)
guard (pAx `unsafeCompare` pA)
(p2' :> _) <- commute (pAmid :> p2)
(p2o :> _) <- commute (invert pAmid :> p2')
guard (p2o `unsafeCompare` p2)
let p' = if unsafeCompare p1' p1 && unsafeCompare p2' p2
then unsafeCoerceP p
else unsafeMerger "0.0" p1' p2'
undo' = mergerUndo p'
(pAo :> _) <- commuterFLId selfCommuter (undo' :> pA')
guard (pAo `unsafeCompare` pA)
return (pA' :< p')
where undo = mergerUndo p
commuteRecursiveMerger _ = Unknown
otherCommuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))
otherCommuteRecursiveMerger (pA':< p_old@(Merger _ _ p1' p2')) =
toPerhaps $
do (pA :> _) <- commuterFLId selfCommuter (mergerUndo p_old :> pA')
(pAmid :> p1) <- commute (unsafeCoercePEnd p1' :> pA)
(_ :> pAmido) <- commute (pA :> invert p1)
guard (pAmido `unsafeCompare` pAmid)
(p2 :> _) <- commute (invert pAmid :> p2')
(p2o' :> _) <- commute (pAmid :> p2)
guard (p2o' `unsafeCompare` p2')
let p = if p1 `unsafeCompare` p1' && p2 `unsafeCompare` p2'
then unsafeCoerceP p_old
else unsafeMerger "0.0" p1 p2
undo = mergerUndo p
guard (not $ pA `unsafeCompare` p1)
(_ :> pAo') <- commuterIdFL selfCommuter (pA :> undo)
guard (pAo' `unsafeCompare` pA')
return (p :< pA)
otherCommuteRecursiveMerger _ = Unknown
type CommuteFunction prim = FORALL(x y) (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))
type MaybeCommute prim = FORALL(x y) (Patch prim :< Patch prim) C(x y) -> Maybe ((Patch prim :< Patch prim) C(x y))
revCommuteFLId :: MaybeCommute prim -> (FL (Patch prim) :< Patch prim) C(x y) -> Maybe ((Patch prim :< FL (Patch prim)) C(x y))
revCommuteFLId _ (NilFL :< p) = return (p :< NilFL)
revCommuteFLId commuter ((q :>: qs) :< p) = do
p' :< q' <- commuter (q :< p)
p'' :< qs' <- revCommuteFLId commuter (qs :< p')
return (p'' :< (q' :>: qs'))
elegantMerge :: PrimPatch prim
=> (Patch prim :\/: Patch prim) C(x y)
-> Maybe ((Patch prim :/\: Patch prim) C(x y))
elegantMerge (p1 :\/: p2) = do
p1' :> ip2' <- commute (invert p2 :> p1)
p1o :> _ <- commute (p2 :> p1')
guard $ unsafeCompare p1o p1
return $ invert ip2' :/\: p1'
actualMerge :: PrimPatch prim => (Patch prim :\/: Patch prim) C(x y) -> Sealed (Patch prim C(y))
actualMerge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of
Just (_ :/\: p1') -> Sealed p1'
Nothing -> merger "0.0" p2 p1
unwind :: Patch prim C(x y) -> Sealed (RL (Patch prim) C(x))
unwind (Merger _ unwindings _ _) = Sealed unwindings
unwind p = Sealed (p :<: NilRL)
trueUnwind :: PrimPatch prim => Patch prim C(x y) -> Sealed (RL (Patch prim) C(x))
trueUnwind p@(Merger _ _ p1 p2) =
case (unwind p1, unwind p2) of
(Sealed (_:<:p1s),Sealed (_:<:p2s)) ->
Sealed (p :<: unsafeCoerceP p1 :<: unsafeUnsealFlipped (reconcileUnwindings p p1s (unsafeCoercePEnd p2s)))
_ -> impossible
trueUnwind _ = impossible
reconcileUnwindings :: PrimPatch prim
=> Patch prim C(a b) -> RL (Patch prim) C(x z) -> RL (Patch prim) C(y z) -> FlippedSeal (RL (Patch prim)) C(z)
reconcileUnwindings _ NilRL p2s = FlippedSeal p2s
reconcileUnwindings _ p1s NilRL = FlippedSeal p1s
reconcileUnwindings p (p1:<:p1s) p2s@(p2:<:tp2s) =
case [(p1s', p2s')|
p1s'@(hp1s':<:_) <- headPermutationsRL (p1:<:p1s),
p2s'@(hp2s':<:_) <- headPermutationsRL p2s,
hp1s' `unsafeCompare` hp2s'] of
((p1':<:p1s', _:<:p2s'):_) ->
mapFlipped (p1' :<:) $ reconcileUnwindings p p1s' (unsafeCoercePEnd p2s')
[] -> case reverseFL `fmap` putBefore p1 (reverseRL p2s) of
Just p2s' -> mapFlipped (p1 :<:) $ reconcileUnwindings p p1s p2s'
Nothing ->
case fmap reverseFL $ putBefore p2 $
reverseRL (p1:<:p1s) of
Just p1s' -> mapFlipped (p2 :<:) $
reconcileUnwindings p p1s' tp2s
Nothing ->
bugDoc $ text "in function reconcileUnwindings"
$$ text "Original patch:"
$$ showPatch_ p
_ -> bug "in reconcileUnwindings"
putBefore :: PrimPatch prim => Patch prim C(y z) -> FL (Patch prim) C(x z) -> Maybe (FL (Patch prim) C(y w))
putBefore p1 (p2:>:p2s) =
do p1' :> p2' <- commute (unsafeCoerceP p2 :> invert p1)
_ <- commute (p2' :> p1)
(unsafeCoerceP p2' :>:) `fmap` putBefore p1' (unsafeCoerceP p2s)
putBefore _ NilFL = Just (unsafeCoerceP NilFL)
instance PrimPatch prim => CommuteNoConflicts (Patch prim) where
commuteNoConflicts (x:>y) = do x' :< y' <- commuteNoMerger (y :< x)
return (y':>x')
instance PrimPatch prim => Conflict (Patch prim) where
resolveConflicts patch = rcs NilFL (patch :<: NilRL)
where rcs :: FL (Patch prim) C(y w) -> RL (Patch prim) C(x y) -> [[Sealed (FL prim C(w))]]
rcs _ NilRL = []
rcs passedby (p@(Merger _ _ _ _):<:ps) =
case revCommuteFLId commuteNoMerger (passedby:<p) of
Just (p'@(Merger _ _ p1 p2):<_) ->
(map Sealed $ nubBy unsafeCompare $
effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) : map (unsafeCoercePStart . unsafeUnseal) (unravel p'))
: rcs (p :>: passedby) ps
Nothing -> rcs (p :>: passedby) ps
_ -> impossible
rcs passedby (p:<:ps) = seq passedby $
rcs (p :>: passedby) ps
publicUnravel :: PrimPatch prim => Patch prim C(x y) -> [Sealed (FL prim C(y))]
publicUnravel = map (mapSeal unsafeCoercePStart) . unravel
unravel :: PrimPatch prim => Patch prim C(x y) -> [Sealed (FL prim C(x))]
unravel p = nub $ map (mapSeal (sortCoalesceFL . concatFL . mapFL_FL effect)) $
getSupers $ map (mapSeal reverseRL) $ unseal (newUr p) $ unwind p
getSupers :: PrimPatch prim => [Sealed (FL (Patch prim) C(x))] -> [Sealed (FL (Patch prim) C(x))]
getSupers (x:xs) =
case filter (not.(x `isSuperpatchOf`)) xs of
xs' -> if or $ map (`isSuperpatchOf` x) xs'
then getSupers xs'
else x : getSupers xs'
getSupers [] = []
isSuperpatchOf :: PrimPatch prim => Sealed (FL (Patch prim) C(x)) -> Sealed (FL (Patch prim) C(x)) -> Bool
Sealed x `isSuperpatchOf` Sealed y | lengthFL y > lengthFL x = False
Sealed x `isSuperpatchOf` Sealed y = x `iso` y
where iso :: PrimPatch prim => FL (Patch prim) C(x y) -> FL (Patch prim) C(x z) -> Bool
_ `iso` NilFL = True
NilFL `iso` _ = False
a `iso` (b:>:bs) =
head $ ([as `iso` bs | (ah :>: as) <- simpleHeadPermutationsFL a, IsEq <- [ah =\/= b]] :: [Bool]) ++ [False]
merger :: PrimPatch prim => String -> Patch prim C(x y) -> Patch prim C(x z) -> Sealed (Patch prim C(y))
merger "0.0" p1 p2 = Sealed $ Merger undoit unwindings p1 p2
where fake_p = Merger NilFL NilRL p1 p2
unwindings = unsafeUnseal (trueUnwind fake_p)
p = Merger NilFL unwindings p1 p2
undoit =
case (isMerger p1, isMerger p2) of
(True ,True ) -> case unwind p of
Sealed (_:<:t) -> unsafeCoerceP $ invertRL t
_ -> impossible
(False,False) -> unsafeCoerceP $ invert p1 :>: NilFL
(True ,False) -> unsafeCoerceP $ NilFL
(False,True ) -> unsafeCoerceP $ invert p1 :>: mergerUndo p2
merger g _ _ =
error $ "Cannot handle mergers other than version 0.0\n"++g
++ "\nPlease use darcs optimize --modernize with an older darcs."
glump09 :: PrimPatch prim => Patch prim C(x y) -> Patch prim C(x z) -> Sealed (FL (Patch prim) C(y))
glump09 p1 p2 = mapSeal (mapFL_FL fromPrim) $ mangleUnravelled $ unseal unravel $ merger "0.0" p1 p2
instance PrimPatch prim => Effect (Patch prim) where
effect p@(Merger _ _ _ _) = sortCoalesceFL $ effect $ mergerUndo p
effect p@(Regrem _ _ _ _) = invert $ effect $ invert p
effect (PP p) = p :>: NilFL
instance IsHunk prim => IsHunk (Patch prim) where
isHunk p = do PP p' <- return p
isHunk p'
newUr :: PrimPatch prim => Patch prim C(a b) -> RL (Patch prim) C(x y) -> [Sealed (RL (Patch prim) C(x))]
newUr p (Merger _ _ p1 p2 :<: ps) =
case filter (\(pp:<:_) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of
((_:<:ps'):_) -> newUr p (unsafeCoercePStart p1:<:ps') ++ newUr p (unsafeCoercePStart p2:<:ps')
_ -> bugDoc $ text "in function newUr"
$$ text "Original patch:"
$$ showPatch_ p
$$ text "Unwound:"
$$ vcat (unseal (mapRL showPatch_) $ unwind p)
newUr op ps =
case filter (\(p:<:_) -> isMerger p) $ headPermutationsRL ps of
[] -> [Sealed ps]
(ps':_) -> newUr op ps'
instance Invert prim => Invert (Patch prim) where
invert (Merger undo unwindings p1 p2)
= Regrem undo unwindings p1 p2
invert (Regrem undo unwindings p1 p2)
= Merger undo unwindings p1 p2
invert (PP p) = PP (invert p)
instance MyEq prim => MyEq (Patch prim) where
unsafeCompare = eqPatches
instance MyEq prim => Eq (Patch prim C(x y)) where
(==) = unsafeCompare
eqPatches :: MyEq prim => Patch prim C(x y) -> Patch prim C(w z) -> Bool
eqPatches (PP p1) (PP p2) = unsafeCompare p1 p2
eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b)
= eqPatches p1a p2a &&
eqPatches p1b p2b
eqPatches (Regrem _ _ p1a p1b) (Regrem _ _ p2a p2b)
= eqPatches p1a p2a &&
eqPatches p1b p2b
eqPatches _ _ = False