#include "gadts.h"
module Darcs.Patch.Real
( RealPatch(..), prim2real, isConsistent, isForward, isDuplicate,
pullCommon, mergeUnravelled ) where
import Control.Monad ( mplus, liftM )
import Data.List ( partition, nub )
import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Conflict(..), Effect(..),
showPrim, showPrimFL, FileNameFormat(NewFormat),
IsConflictedPrim(..), ConflictState(..) )
import Darcs.Patch.Read ( readPrim )
import Darcs.Patch.Patchy
import Darcs.Witnesses.Ordered
import Darcs.Patch.Commute ( mangleUnravelled )
import Darcs.Patch.Non ( Non(..), Nonable(..), unNon,
showNons, showNon, readNons, readNon,
add, addP, addPs, remP, remPs, remNons,
(*>), (>*), (*>>), (>>*) )
import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL,
genCommuteWhatWeCanRL,
removeRL, removeFL, removeSubsequenceFL )
import qualified Data.ByteString.Char8 as BC ( ByteString, unpack )
import Darcs.Patch.ReadMonads ( work, peekInput, myLex )
import Darcs.Utils ( nubsort )
import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal )
import Darcs.Witnesses.Show
import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) )
import Darcs.ColorPrinter ( errorDoc, assertDoc )
#include "impossible.h"
data RealPatch C(x y) where
Duplicate :: Non RealPatch C(x) -> RealPatch C(x x)
Etacilpud :: Non RealPatch C(x) -> RealPatch C(x x)
Normal :: Prim C(x y) -> RealPatch C(x y)
Conflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(y x)
InvConflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(x y)
isDuplicate :: RealPatch C(s y) -> Bool
isDuplicate (Duplicate _) = True
isDuplicate (Etacilpud _) = True
isDuplicate _ = False
isForward :: RealPatch C(s y) -> Maybe Doc
isForward p@(InvConflictor _ _ _) =
Just $ redText "An inverse conflictor" $$ showPatch p
isForward p@(Etacilpud _) =
Just $ redText "An inverse duplicate" $$ showPatch p
isForward _ = Nothing
mergeUnravelled :: [Sealed ((FL Prim) C(x))] -> Maybe (FlippedSeal RealPatch C(x))
mergeUnravelled [] = Nothing
mergeUnravelled [_] = Nothing
mergeUnravelled ws = case mergeUnravelled_private ws of
Nothing -> Nothing
Just NilRL -> bug "found no patches in mergeUnravelled"
Just (z:<:_) -> Just $ FlippedSeal z
where notNullS :: Sealed ((FL Prim) C(x)) -> Bool
notNullS (Sealed NilFL) = False
notNullS _ = True
mergeUnravelled_private :: [Sealed (FL Prim C(x))] -> Maybe (RL RealPatch C(x x))
mergeUnravelled_private xs = reverseFL `fmap` mergeConflictingNons
(map sealed2non $ filter notNullS xs)
sealed2non :: Sealed ((FL Prim) C(x)) -> Non RealPatch C(x)
sealed2non (Sealed xs) = case reverseFL xs of
y:<:ys -> Non (mapFL_FL fromPrim $ reverseRL ys) y
NilRL -> bug "NilFL encountered in sealed2non"
mergeConflictingNons :: [Non RealPatch C(x)] -> Maybe (FL RealPatch C(x x))
mergeConflictingNons ns = mcn $ map unNon ns
where mcn :: [Sealed (FL RealPatch C(x))] -> Maybe (FL RealPatch C(x x))
mcn [] = Just NilFL
mcn [Sealed p] = case joinEffects p of
NilFL -> Just p
_ -> Nothing
mcn (Sealed p1:Sealed p2:zs) = case pullCommon p1 p2 of
Common c ps qs ->
case merge (ps :\/: qs) of
qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs)
joinEffects :: Effect p => p C(x y) -> FL Prim C(x y)
joinEffects = joinInverses . effect
where joinInverses :: FL Prim C(x y) -> FL Prim C(x y)
joinInverses NilFL = NilFL
joinInverses (p:>:ps) = case removeFL (invert p) ps' of
Just ps'' -> ps''
Nothing -> p :>: ps'
where ps' = joinInverses ps
assertConsistent :: RealPatch C(x y) -> RealPatch C(x y)
assertConsistent x = assertDoc (do e <- isConsistent x
Just (redText "Inconsistent patch:" $$ showPatch x $$ e)) x
mergeAfterConflicting :: FL RealPatch C(x x) -> FL Prim C(x y)
-> Maybe (FL RealPatch C(x x), FL RealPatch C(x y))
mergeAfterConflicting xxx yyy =
mac (reverseFL xxx) yyy NilFL
where mac :: RL RealPatch C(x y) -> FL Prim C(y z) -> FL RealPatch C(z a)
-> Maybe (FL RealPatch C(x x), FL RealPatch C(x a))
mac NilRL xs goneby = case joinEffects goneby of
NilFL -> Just (NilFL, mapFL_FL Normal xs)
_z ->
Nothing
mac (p:<:ps) xs goneby =
case commuteFLorComplain (p :> mapFL_FL Normal xs) of
Left _ -> case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of
a:>p':>b ->
do (b',xs') <- mac b xs goneby
let pa = joinEffects $ p':<:a
NilFL <- return pa
return (reverseRL (p':<:a)+>+b', xs')
`mplus` do NilFL <- return goneby
NilFL <- return $ joinEffects (p:<:ps)
return (reverseRL (p:<:ps),
mapFL_FL Normal xs)
Right (l:>p'') ->
case allNormal l of
Just xs'' -> mac ps xs'' (p'':>:goneby)
Nothing ->
case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of
a:>p':>b ->
do (b',xs') <- mac b xs goneby
let pa = joinEffects $ p':<:a
NilFL <- return pa
return $ (reverseRL (p':<:a)+>+b', xs')
geteff :: [Non RealPatch C(x)] -> FL Prim C(x y) -> ([Non RealPatch C(x)], FL RealPatch C(x y))
geteff _ NilFL = ([],NilFL)
geteff ix (x:>:xs) | Just ix' <- mapM (remP (Normal x)) ix
=
case geteff ix' xs of
(ns,xs') -> (non (Normal x) : map (addP (Normal x)) ns,
Normal x :>: xs')
geteff ix xx = case mergeConflictingNons ix of
Nothing -> errorDoc $ redText "mergeConflictingNons failed in geteff with ix" $$
showNons ix $$ redText "xx" $$ showPatch xx
Just rix -> case mergeAfterConflicting rix xx of
Just (a,x) -> (map (addPs (reverseFL a)) $ toNons x,
a +>+ x)
Nothing -> errorDoc $ redText "mergeAfterConflicting failed in geteff"$$
redText "where ix" $$ showNons ix $$
redText "and xx" $$ showPatch xx $$
redText "and rix" $$ showPatch rix
xx2nons :: [Non RealPatch C(x)] -> FL Prim C(x y) -> [Non RealPatch C(x)]
xx2nons ix xx = fst $ geteff ix xx
xx2patches :: [Non RealPatch C(x)] -> FL Prim C(x y) -> FL RealPatch C(x y)
xx2patches ix xx = snd $ geteff ix xx
allNormal :: FL RealPatch C(x y) -> Maybe (FL Prim C(x y))
allNormal (Normal x:>:xs) = (x :>:) `fmap` allNormal xs
allNormal NilFL = Just NilFL
allNormal _ = Nothing
isConsistent :: RealPatch C(x y) -> Maybe Doc
isConsistent (Normal _) = Nothing
isConsistent (Duplicate _) = Nothing
isConsistent (Etacilpud _) = Nothing
isConsistent (Conflictor im mm m@(Non deps _))
| not $ everyoneConflicts im = Just $ redText "Someone doesn't conflict in im in isConsistent"
| Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in isConsistent"
| any (\x -> any (x `conflictsWith`) nmm) im
= Just $ redText "mm conflicts with im in isConsistent where nmm is" $$
showNons nmm
| Nothing <- (nmm ++ im) `minus` toNons deps = Just $ redText "dependencies not in conflict:" $$
showNons (toNons deps) $$
redText "compared with deps itself:" $$
showPatch deps
| otherwise = case allConflictsWith m im of
(im1,[]) | im1 `eqSet` im -> Nothing
(_,imnc) -> Just $ redText "m doesn't conflict with im in isConsistent. unconflicting:"
$$ showNons imnc
where (nmm, rmm) = geteff im mm
isConsistent c@(InvConflictor _ _ _) = isConsistent (invert c)
everyoneConflicts :: [Non RealPatch C(x)] -> Bool
everyoneConflicts [] = True
everyoneConflicts (x:xs) = case allConflictsWith x xs of
([],_) -> False
(_,xs') -> everyoneConflicts xs'
prim2real :: Prim C(x y) -> RealPatch C(x y)
prim2real = Normal
instance Patchy RealPatch
mergeWith :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> Sealed (FL Prim C(x))
mergeWith p [] = effect `mapSeal` unNon p
mergeWith p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $
filter (\x -> not (p `dependsUpon` x) && not (p `conflictsWith` x)) xs
where mergeall :: [Sealed (FL RealPatch C(x))] -> Sealed (FL Prim C(x))
mergeall [Sealed x] = Sealed $ effect x
mergeall [] = Sealed NilFL
mergeall (Sealed x:Sealed y:rest) = case merge (x :\/: y) of
y' :/\: _ -> mergeall (Sealed (x+>+y'):rest)
unconflicting_of [] = []
unconflicting_of (q:qs) = case allConflictsWith q qs of
([],_) -> q:qs
(_,nc) -> unconflicting_of nc
instance Conflict RealPatch where
conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x]
conflictedEffect (Etacilpud _) = impossible
conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]
conflictedEffect (InvConflictor _ _ _) = impossible
conflictedEffect (Normal x) = [IsC Okay x]
resolveConflicts (Conflictor ix xx x) = [mangleUnravelled unravelled : unravelled]
where unravelled = nub $ filter isn $ map (`mergeWith` (x:ix++nonxx)) (x:ix++nonxx)
nonxx = nonxx_ (nonxx_aux ix xx)
nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y)
nonxx_aux a b = reverseFL $ xx2patches a b
nonxx_ :: RL RealPatch C(x y) -> [Non RealPatch C(x)]
nonxx_ NilRL = []
nonxx_ ((Normal q) :<: qs) = [Non (reverseRL qs) q]
nonxx_ _ = []
isn :: Sealed (FL p C(x)) -> Bool
isn (Sealed NilFL) = False
isn _ = True
resolveConflicts _ = []
commuteNoConflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x)
commuteNoConflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x)
commuteNoConflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x)
commuteNoConflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x)
commuteNoConflicts (x :> Duplicate d) = if d == addP (invert x) (non x)
then Just (x :> Duplicate d)
else do d' <- remP (invert x) d
return (Duplicate d' :> x)
commuteNoConflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d'))
commuteNoConflicts c@(Etacilpud _ :> _) = invertCommuteNC c
commuteNoConflicts c@(_ :> Etacilpud _) = invertCommuteNC c
commuteNoConflicts (Normal x :> Normal y) = do y' :> x' <- commute (x :> y)
return (Normal y' :> Normal x')
commuteNoConflicts (Normal x :> Conflictor iy yy y) =
case commuteFLorComplain (x :> invert yy) of
Right (iyy' :> x') -> do
y':iy' <- mapM (Normal x' >*) (y:iy)
return (Conflictor iy' (invert iyy') y' :> Normal x')
_ -> Nothing
commuteNoConflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c
commuteNoConflicts (Conflictor iy' yy' y' :> Normal x') =
do x :> iyy <- commuteRL (invertFL yy' :> x')
y:iy <- mapM (*> Normal x') (y':iy')
return (Normal x :> Conflictor iy (invertRL iyy) y)
commuteNoConflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c
commuteNoConflicts (Conflictor ix xx x :> Conflictor iy yy y) =
do xx' :> yy' <- commute (yy :> xx)
x':ix' <- mapM (yy >>*) (x:ix)
y':iy' <- mapM (*>> xx') (y:iy)
False <- return $ any (conflictsWith y) (x':ix')
False <- return $ any (conflictsWith x') iy
return (Conflictor iy' yy' y' :> Conflictor ix' xx' x')
commuteNoConflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c
commuteNoConflicts (InvConflictor ix xx x :> Conflictor iy yy y) =
do iyy' :> xx' <- commute (xx :> invert yy)
y':iy' <- mapM (xx' >>*) (y:iy)
x':ix' <- mapM (invertFL iyy' >>*) (x:ix)
False <- return $ any (conflictsWith y') (x':ix')
False <- return $ any (conflictsWith x') iy'
return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x')
commuteNoConflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') =
do xx :> iyy <- commute (invert yy' :> xx')
y:iy <- mapM (*>> xx') (y':iy')
x:ix <- mapM (*>> yy') (x':ix')
False <- return $ any (conflictsWith y') (x':ix')
False <- return $ any (conflictsWith x') iy'
return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y)
isInconsistent = isConsistent
instance FromPrim RealPatch where
fromPrim = prim2real
instance ToFromPrim RealPatch where
toPrim (Normal p) = Just p
toPrim _ = Nothing
instance MyEq RealPatch where
(Duplicate x) =\/= (Duplicate y) | x == y = IsEq
(Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq
(Normal x) =\/= (Normal y) = x =\/= y
(Conflictor cx xx x) =\/= (Conflictor cy yy y)
| map (add $ invertFL xx) cx `eqSet`
map (add $ invertFL yy) cy &&
add (invert xx) x == add (invert yy) y = xx =/\= yy
(InvConflictor cx xx x) =\/= (InvConflictor cy yy y)
| cx `eqSet` cy && x == y = xx =\/= yy
_ =\/= _ = NotEq
eqSet :: Eq a => [a] -> [a] -> Bool
eqSet [] [] = True
eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys
eqSet _ _ = False
remove1 :: Eq a => a -> [a] -> Maybe [a]
remove1 x (y:ys) | x == y = Just ys
| otherwise = (y :) `fmap` remove1 x ys
remove1 _ [] = Nothing
minus :: Eq a => [a] -> [a] -> Maybe [a]
minus xs [] = Just xs
minus xs (y:ys) = do xs' <- remove1 y xs
xs' `minus` ys
invertNon :: Non RealPatch C(x) -> Non RealPatch C(x)
invertNon (Non c x)
| Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x)
| otherwise = addPs (Normal x :<: reverseFL c) $ non nix
where nix = Normal $ invert x
nonTouches :: Non RealPatch C(x) -> [FilePath]
nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL)
nonHunkMatches :: (BC.ByteString -> Bool) -> Non RealPatch C(x) -> Bool
nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x
toNons :: (Conflict p, Patchy p, ToFromPrim p, Nonable p) => FL p C(x y) -> [Non p C(x)]
toNons xs = map lastNon $ initsFL xs
where lastNon :: (Conflict p, Patchy p, Nonable p) => Sealed ((p :> FL p) C(x)) -> Non p C(x)
lastNon (Sealed xxx) = case lastNon_aux xxx of
deps :> p :> _ -> case non p of
Non NilFL pp -> Non (reverseRL deps) pp
Non ds pp -> errorDoc $ redText "Weird case in toNons" $$
redText "please report this bug!" $$
(case xxx of
z:>zs -> showPatch (z:>:zs)) $$
redText "ds are" $$ showPatch ds $$
redText "pp is" $$ showPatch pp
reverseFoo :: (p :> FL p) C(x y) -> (RL p :> p) C(x y)
reverseFoo (p :> ps) = rf NilRL p ps
where rf :: RL p C(a b) -> p C(b c) -> FL p C(c d) -> (RL p :> p) C(a d)
rf rs l NilFL = rs :> l
rf rs x (y:>:ys) = rf (x:<:rs) y ys
lastNon_aux :: Commute p => (p :> FL p) C(x y) -> (RL p :> p :> RL p) C(x y)
lastNon_aux = commuteWhatWeCanRL . reverseFoo
initsFL :: Patchy p => FL p C(x y) -> [Sealed ((p :> FL p) C(x))]
initsFL NilFL = []
initsFL (x:>:xs) = Sealed (x:>NilFL) : map (\ (Sealed (y:>xs')) -> Sealed (x:>y:>:xs')) (initsFL xs)
fromNons :: [Non RealPatch C(x)] -> Maybe (Sealed (FL Prim C(x)))
fromNons [] = Just $ Sealed $ NilFL
fromNons ns = do (Sealed p, ns') <- pullInContext ns
ns'' <- mapM (remP $ fromPrim p) ns'
Sealed ps <- fromNons ns''
return $ Sealed $ p :>: ps
pullInContext :: [Non RealPatch C(x)] -> Maybe (Sealed (Prim C(x)), [Non RealPatch C(x)])
pullInContext (Non NilFL p:ns) = Just (Sealed p, ns)
pullInContext (n:ns) = do (sp,ns') <- pullInContext ns
return (sp, n:ns')
pullInContext [] = Nothing
filterConflictsFL :: Non RealPatch C(x) -> FL Prim C(x y) -> (FL Prim :> FL Prim) C(x y)
filterConflictsFL _ NilFL = NilFL :> NilFL
filterConflictsFL n (p:>:ps)
| Just n' <- remP (fromPrim p) n = case filterConflictsFL n' ps of
p1 :> p2 -> p:>:p1 :> p2
| otherwise = case commuteWhatWeCanFL (p :> ps) of
p1 :> p' :> p2 -> case filterConflictsFL n p1 of
p1a :> p1b -> p1a :> p1b +>+ p' :>: p2
instance Invert RealPatch where
invert (Duplicate d) = Etacilpud d
invert (Etacilpud d) = Duplicate d
invert (Normal p) = Normal (invert p)
invert (Conflictor x c p) = InvConflictor x c p
invert (InvConflictor x c p) = Conflictor x c p
identity = Normal identity
instance Commute RealPatch where
commute (x :> y) | Just (y' :> x') <- commuteNoConflicts (assertConsistent x :> assertConsistent y) = Just (y' :> x')
commute (Normal x :> Conflictor a1'nop2 n1'x p1')
| Just rn1' <- removeRL x (reverseFL n1'x) =
do let p2:n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (x:<:rn1')
a2 = p1':a1'nop2++n1nons
case (a1'nop2, reverseRL rn1', p1') of
([], NilFL, Non c y) | NilFL <- joinEffects c ->
Just (Normal y :> Conflictor a1'nop2 (y:>:NilFL) p2)
(a1,n1,_) -> Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)
commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c
commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)
| Just a2_minus_p1 <- remove1 p1' a2,
not (p2 `dependsUpon` p1') =
do let n1nons = map (add n2) $ xx2nons a1 n1
n2nons = xx2nons a2 n2
Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons
n2n1 = n2 +>+ n1
a1' = map (add n2) a1
p2ooo = remNons a1' p2
n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1
let n1'n2'nons = xx2nons a2_minus_p1n1 (n1'+>+n2')
n1'nons = take (lengthFL n1') n1'n2'nons
n2'nons = drop (lengthFL n1') n1'n2'nons
Just a1'nop2 = (a2++n2nons) `minus` (p1':n1'nons)
Just a2'o =
(fst $ allConflictsWith p2 $ a2_minus_p1++n2nons) `minus` n2'nons
Just a2' = mapM (remPs (xx2patches a1'nop2 n1')) $
a2'o
Just p2' = remPs (xx2patches a1'nop2 n1') p2
case (a2', n2', p2') of
([], NilFL, Non c x) | NilFL <- joinEffects c ->
Just (Normal x :> Conflictor a1'nop2 (n1'+>+x:>:NilFL) p1')
| otherwise -> impossible
_ -> Just (Conflictor a2' n2' p2' :> Conflictor (p2:a1'nop2) n1' p1')
where (_,rpn2) = geteff a2 n2
p1' = addPs (reverseFL rpn2) p1
commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c
commute _ = Nothing
merge (InvConflictor _ _ _ :\/: _) = impossible
merge (_ :\/: InvConflictor _ _ _) = impossible
merge (Etacilpud _ :\/: _) = impossible
merge (_ :\/: Etacilpud _) = impossible
merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a
merge (Duplicate a :\/: b) = b :/\: Duplicate (addP (invert b) a)
merge m@(_ :\/: Duplicate _) = swapMerge m
merge (x :\/: y) | Just (y' :> ix') <- commute (invert (assertConsistent x) :> assertConsistent y),
Just (y'' :> _) <- commute (x :> y'),
IsEq <- y'' =\/= y =
assertConsistent y' :/\: invert (assertConsistent ix')
| IsEq <- x =\/= y,
n <- addP (invert x) $ non x =
Duplicate n :/\: Duplicate n
merge (Normal x :\/: Normal y) =
Conflictor [] (x:>:NilFL) (non $ Normal y) :/\: Conflictor [] (y:>:NilFL) (non $ Normal x)
merge (Normal x :\/: Conflictor iy yy y) =
Conflictor iy yyx y :/\: Conflictor (y:iy++nyy) NilFL x'
where yyx = yy +>+ x:>:NilFL
(x':nyy) = reverse $ xx2nons iy yyx
merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m
merge (Conflictor ix xx x :\/: Conflictor iy yy y) =
case pullCommonRL (reverseFL xx) (reverseFL yy) of
CommonRL rxx1 ryy1 c ->
case commuteRLFL (ryy1 :> invertRL rxx1) of
Just (ixx' :> ryy') ->
let xx' = invert ixx'
yy' = reverseRL ryy'
y':iy' = map (add $ invertFL ixx') (y:iy)
x':ix' = map (add ryy') (x:ix)
nyy' = xx2nons iy' yy'
nxx' = xx2nons ix' xx'
icx = drop (lengthRL rxx1) $ xx2nons ix (reverseRL $ c+<+rxx1)
ic' = map (add ryy') icx
ixy' = ic' ++ (iy'+++ix')
in
Conflictor (x':ixy'++nxx') yy' y' :/\: Conflictor (y':ixy'++nyy') xx' x'
Nothing -> impossible pullInContext fromNons
listTouchedFiles (Duplicate p) = nonTouches p
listTouchedFiles (Etacilpud p) = nonTouches p
listTouchedFiles (Normal p) = listTouchedFiles p
listTouchedFiles (Conflictor x c p) =
nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p
listTouchedFiles (InvConflictor x c p) =
nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p
hunkMatches f (Duplicate p) = nonHunkMatches f p
hunkMatches f (Etacilpud p) = nonHunkMatches f p
hunkMatches f (Normal p) = hunkMatches f p
hunkMatches f (Conflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p]
hunkMatches f (InvConflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p]
allConflictsWith :: Non RealPatch C(x) -> [Non RealPatch C(x)]
-> ([Non RealPatch C(x)], [Non RealPatch C(x)])
allConflictsWith x ys = acw $ partition (conflictsWith x) ys
where acw ([],nc) = ([],nc)
acw (c:cs, nc) = case allConflictsWith c nc of
(c1,nc1) -> case acw (cs, nc1) of
(xs',nc') -> (c:c1++xs',nc')
conflictsWith :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool
conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False
conflictsWith x (Non cy y) =
case remPs cy x of
Just (Non cx' x') -> case commuteFLorComplain (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of
Right _ -> False
Left _ -> True
Nothing -> True
dependsUpon :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool
dependsUpon (Non xs _) (Non ys y) =
case removeSubsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of
Just _ -> True
Nothing -> False
(+++) :: Eq a => [a] -> [a] -> [a]
[] +++ x = x
x +++ [] = x
(x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys)
| otherwise = x : (xs +++ xys)
swapMerge :: (RealPatch :\/: RealPatch) C(x y) -> (RealPatch :/\: RealPatch) C(x y)
swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x'
invertCommute :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y))
invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x)
return (invert iy' :> invert ix')
invertCommuteNC :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y))
invertCommuteNC (x :> y) = do ix' :> iy' <- commuteNoConflicts (invert y :> invert x)
return (invert iy' :> invert ix')
pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y)
pullCommon NilFL ys = Common NilFL NilFL ys
pullCommon xs NilFL = Common NilFL xs NilFL
pullCommon (x:>:xs) xys | Just ys <- removeFL x xys = case pullCommon xs ys of
Common c xs' ys' -> Common (x:>:c) xs' ys'
pullCommon (x:>:xs) ys = case commuteWhatWeCanFL (x :> xs) of
xs1:>x':>xs2 -> case pullCommon xs1 ys of
Common c xs1' ys' -> Common c (xs1'+>+x':>:xs2) ys'
data Common p C(o x y) where
Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y)
pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o)
pullCommonRL NilRL ys = CommonRL NilRL ys NilRL
pullCommonRL xs NilRL = CommonRL xs NilRL NilRL
pullCommonRL (x:<:xs) xys
| Just ys <- removeRL x xys = case pullCommonRL xs ys of
CommonRL xs' ys' c -> CommonRL xs' ys' (x:<:c)
pullCommonRL (x:<:xs) ys =
case commuteWhatWeCanRL (xs :> x) of
xs1:>x':>xs2 -> case pullCommonRL xs2 ys of
CommonRL xs2' ys' c -> CommonRL (xs2'+<+x':<:xs1) ys' c
data CommonRL p C(x y f) where
CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f)
instance Apply RealPatch where
apply opts p = apply opts (effect p)
applyAndTryToFixFL (Normal p) = mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p
applyAndTryToFixFL x = do apply [] x; return Nothing
instance ShowPatch RealPatch where
showPatch (Duplicate d) = blueText "duplicate" $$ showNon d
showPatch (Etacilpud d) = blueText "etacilpud" $$ showNon d
showPatch (Normal p) = showPrim NewFormat p
showPatch (Conflictor i NilFL p) =
blueText "conflictor" <+> showNons i <+> blueText "[]" $$ showNon p
showPatch (Conflictor i cs p) =
blueText "conflictor" <+> showNons i <+> blueText "[" $$
showPrimFL NewFormat cs $$
blueText "]" $$
showNon p
showPatch (InvConflictor i NilFL p) =
blueText "rotcilfnoc" <+> showNons i <+> blueText "[]" $$ showNon p
showPatch (InvConflictor i cs p) =
blueText "rotcilfnoc" <+> showNons i <+> blueText "[" $$
showPrimFL NewFormat cs $$
blueText "]" $$
showNon p
showContextPatch (Normal p) = showContextPatch p
showContextPatch c = return $ showPatch c
instance ReadPatch RealPatch where
readPatch' _ =
do s <- peekInput
case fmap (BC.unpack . fst) $ myLex s of
Just "duplicate" ->
do work myLex
p <- readNon
return $ (Sealed . Duplicate) `fmap` p
Just "etacilpud" ->
do work myLex
p <- readNon
return $ (Sealed . Etacilpud) `fmap` p
Just "conflictor" ->
do work myLex
i <- readNons
Just (Sealed ps) <- bracketedFL (readPrim NewFormat) (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')
Just p <- readNon
return $ Just $ Sealed $ Conflictor i (unsafeCoerceP ps) p
Just "rotcilfnoc" ->
do work myLex
i <- readNons
Just (Sealed ps) <- bracketedFL (readPrim NewFormat) (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')
Just p <- readNon
return $ Just $ Sealed $ InvConflictor i ps p
_ -> do mp <- readPrim NewFormat
case mp of
Just p -> return $ Just $ Normal `mapSeal` p
Nothing -> return Nothing
instance Show (RealPatch C(x y)) where
show p = renderString $ showPatch p
instance Show2 RealPatch where
showDict2 = ShowDictClass
instance Nonable RealPatch where
non (Duplicate d) = d
non (Etacilpud d) = invertNon d
non (Normal p) = Non NilFL p
non (Conflictor _ xx x) = add (invertFL xx) x
non (InvConflictor _ _ n) = invertNon n
instance Effect RealPatch where
effect (Duplicate _) = NilFL
effect (Etacilpud _) = NilFL
effect (Normal p) = effect p
effect (Conflictor _ e _) = invert e
effect (InvConflictor _ e _) = e
effectRL (Duplicate _) = NilRL
effectRL (Etacilpud _) = NilRL
effectRL (Normal p) = effectRL p
effectRL (Conflictor _ e _) = invertFL e
effectRL (InvConflictor _ e _) = reverseFL e
isHunk rp = do Normal p <- return rp
isHunk p