% Copyright (C) 2007 David Roundy % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2, or (at your option) % any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program; see the file COPYING. If not, write to % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, % Boston, MA 02110-1301, USA. \section{Conflictor patches} \begin{code} {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} #include "gadts.h" module Darcs.Patch.Real ( RealPatch(..), prim2real, is_consistent, is_forward, is_duplicate, pullCommon, mergeUnravelled ) where import Control.Monad ( mplus, liftM ) import Data.List ( partition, nub ) import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Conflict(..), Effect(..), showPrim, FileNameFormat(NewFormat), sort_coalesceFL, IsConflictedPrim(..), ConflictState(..) ) import Darcs.Patch.Read ( readPrim ) import Darcs.Patch.Patchy import Darcs.Patch.Ordered --import Darcs.Patch.Read () --import Darcs.Patch.Viewing () --import Darcs.Patch.Apply () import Darcs.Patch.Commute ( mangle_unravelled ) import Darcs.Patch.Non ( Non(..), Nonable(..), unNon, showNons, showNon, readNons, readNon, add, addP, addPs, remP, remPs, remNons, (*>), (>*), (*>>), (>>*) ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL, removeRL, removeFL, remove_subsequenceFL ) import FastPackedString ( unpackPS ) import Darcs.Patch.ReadMonads (work, peek_input, my_lex ) import Darcs.Utils ( nubsort ) import Darcs.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal ) import Darcs.Show import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) ) import Darcs.ColorPrinter ( errorDoc, assertDoc ) --import Printer ( greenText ) --import Darcs.ColorPrinter ( traceDoc ) #include "impossible.h" -- Duplicate x: This patch has no effect since 'x' is already present in the repository -- -- Etacilpud x: invert (Duplicate x) -- -- Normal prim: A primitive patch -- -- Conflictor ix xx x: -- 'ix' is the set of patches: -- * that conflict with 'x' and also conflict with another patch in the repository -- * that conflict with a patch that conflict with 'x' -- 'xx' is the sequence of patches that conflict *only* with 'x' -- 'x' is the current patch -- -- 'ix' and 'x' are stored as "Non" objects, which include any necessary -- context to uniquely define the patch that is referred to. -- -- InvConflictor ix xx x: like invert (Conflictor ix xx x) 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) is_duplicate :: RealPatch C(s y) -> Bool is_duplicate (Duplicate _) = True is_duplicate (Etacilpud _) = True is_duplicate _ = False is_forward :: RealPatch C(s y) -> Maybe Doc is_forward p@(InvConflictor _ _ _) = Just $ redText "An inverse conflictor" $$ showPatch p is_forward p@(Etacilpud _) = Just $ redText "An inverse duplicate" $$ showPatch p is_forward _ = Nothing mergeUnravelled :: [Sealed ((FL Prim) C(x))] -> Maybe (FlippedSeal RealPatch C(x)) mergeUnravelled [] = Nothing mergeUnravelled [_] = Nothing mergeUnravelled ws = case reverseFL `fmap` mergeConflictingNons (map sealed2non $ filter notNullS 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 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 sort_coalesceFL $ effect p of -- this is just a safety check, and could NilFL -> Just p -- be removed when we're sure of the code. _ -> 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) assertConsistent :: RealPatch C(x y) -> RealPatch C(x y) assertConsistent x = assertDoc (do e <- is_consistent 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 = --traceDoc (greenText "mergeAfterConflicting xxx" $$ showPatch xxx $$ -- greenText "and yyy" $$ showPatch 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 sort_coalesceFL $ effect goneby of NilFL -> Just (NilFL, mapFL_FL Normal xs) _z -> --traceDoc (greenText "mac1 z" $$ showPatch _z) $ Nothing mac (p:<:ps) xs goneby = --traceDoc (greenText "mac ps" $$ showPatch ps $$ -- greenText "p" $$ showPatch p $$ -- greenText "xs" $$ showPatch xs $$ -- greenText "goneby" $$ showPatch goneby) $ case commuteFL (p :> mapFL_FL Normal xs) of Nothing -> case commuteWhatWeCanRL (ps :> p) of a:>p':>b -> do (b',xs') <- mac b xs goneby --traceDoc (greenText "foo1" $$ -- showPatch (sort_coalesceFL $ -- effect $ p':<:a)) $ Just () NilFL <- return $ sort_coalesceFL $ effect $ p':<:a return (reverseRL (p':<:a)+>+b', xs') `mplus` do NilFL <- return goneby NilFL <- return $ sort_coalesceFL $ effect (p:<:ps) return (reverseRL (p:<:ps), mapFL_FL Normal xs) Just (l:>p'') -> case allNormal l of Just xs'' -> mac ps xs'' (p'':>:goneby) Nothing -> case commuteWhatWeCanRL (ps :> p) of a:>p':>b -> do (b',xs') <- mac b xs goneby --traceDoc (greenText "foo2" $$ -- showPatch (sort_coalesceFL $ -- effect $ p':<:a)) $ Just () NilFL <- return $ sort_coalesceFL $ effect $ p':<:a 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 = --traceDoc (greenText "I got rid of x" $$ showPatch x) $ 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 is_consistent :: RealPatch C(x y) -> Maybe Doc is_consistent (Normal _) = Nothing is_consistent (Duplicate _) = Nothing is_consistent (Etacilpud _) = Nothing is_consistent (Conflictor im mm m@(Non deps _)) | not $ everyone_conflicts im = Just $ redText "Someone doesn't conflict in im in is_consistent" | Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in is_consistent" | any (\x -> any (x `conflicts_with`) nmm) im = Just $ redText "mm conflicts with im in is_consistent 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 all_conflicts_with m im of (im1,[]) | im1 `eqSet` im -> Nothing (_,imnc) -> Just $ redText "m doesn't conflict with im in is_consistent. unconflicting:" $$ showNons imnc where (nmm, rmm) = geteff im mm is_consistent c@(InvConflictor _ _ _) = is_consistent (invert c) everyone_conflicts :: [Non RealPatch C(x)] -> Bool everyone_conflicts [] = True everyone_conflicts (x:xs) = case all_conflicts_with x xs of ([],_) -> False (_,xs') -> everyone_conflicts xs' prim2real :: Prim C(x y) -> RealPatch C(x y) prim2real = Normal instance Patchy RealPatch instance MyEq p => Eq (Sealed (p C(x))) where (Sealed x) == (Sealed y) | IsEq <- x =\/= y = True | otherwise = False merge_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> Sealed (FL Prim C(x)) merge_with p [] = effect `mapSeal` unNon p merge_with p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $ filter (\x -> not (p `depends_upon` x) && not (p `conflicts_with` 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 all_conflicts_with 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] resolve_conflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled] where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx) nonxx = case reverseFL $ xx2patches ix xx of NilRL -> [] Normal q:<:qs -> [Non (reverseRL qs) q] _ -> [] isn :: Sealed (FL p C(x)) -> Bool isn (Sealed NilFL) = False isn _ = True resolve_conflicts _ = [] -- cA commute_no_conflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x) commute_no_conflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x) commute_no_conflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x) commute_no_conflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x) -- cB commute_no_conflicts (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) commute_no_conflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d')) commute_no_conflicts c@(Etacilpud _ :> _) = invertCommuteNC c commute_no_conflicts c@(_ :> Etacilpud _) = invertCommuteNC c -- cE commute_no_conflicts (Normal x :> Normal y) = do y' :> x' <- commute (x :> y) return (Normal y' :> Normal x') -- cF -- involves a conflict -- cG commute_no_conflicts (Normal x :> Conflictor iy yy y) = do iyy' :> x' <- commuteFL (x :> invert yy) y':iy' <- mapM (Normal x' >*) (y:iy) return (Conflictor iy' (invert iyy') y' :> Normal x') -- cFi+cGi -- handle with previous two pattern matches commute_no_conflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c -- icG FIXME: where is icF? commute_no_conflicts (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) -- icGi -- handle with previous pattern match commute_no_conflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c -- cH -- this involves a conflict commute -- cI commute_no_conflicts (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 (conflicts_with y) (x':ix') False <- return $ any (conflicts_with x') iy return (Conflictor iy' yy' y' :> Conflictor ix' xx' x') -- cHi+cIi uses previous two matches commute_no_conflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c -- cJ commute_no_conflicts (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 (conflicts_with y') (x':ix') False <- return $ any (conflicts_with x') iy' return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x') -- icJ commute_no_conflicts (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 (conflicts_with y') (x':ix') False <- return $ any (conflicts_with x') iy' return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y) 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) = list_touched_files (c +>+ fromPrim x :>: NilFL) 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 commuteWhatWeCanRL $ reverseFoo 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 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) | traceDoc (greenText "commuting x" $$ showPatch x $$ -- greenText "with y" $$ showPatch y) False = undefined commute (x :> y) | Just (y' :> x') <- commute_no_conflicts (assertConsistent x :> assertConsistent y) = Just (y' :> x') -- cF commute (Normal x :> Conflictor a1'nop2 n1'x p1') -- these patches conflicted | 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 <- sort_coalesceFL $ effect c -> Just (Normal y :> Conflictor a1'nop2 (y:>:NilFL) p2) (a1,n1,_) -> Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2) -- cFi -- handle with previous pattern match commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c -- cH commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2) | Just a2_minus_p1 <- remove1 p1' a2, not (p2 `depends_upon` 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 = --traceDoc (greenText "\n\nConflictor a1 n1 p1 is" $$ -- showPatch (assertConsistent $ Conflictor a1 n1 p1) $$ -- greenText "and Conflictor a2 n2 p2 is" $$ -- showPatch (assertConsistent $ Conflictor a2 n2 p2) $$ -- greenText "where n2'nons is" $$ showNons n2'nons $$ -- greenText "and others are" $$ -- showNons (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) $$ -- greenText "These came from" $$ -- showNons (a2_minus_p1++n2nons) $$ -- greenText "n1'n2'nons" $$ showNons n1'n2'nons $$ -- greenText "from n1' :> n2'" $$ -- showPatch n1' $$ greenText ":>" $$ showPatch n2' $$ -- greenText "p2" $$ showNon p2 $$ -- greenText "p2 fixed" $$ showNon p2ooo $$ -- -- greenText "pren1" $$ showPatch pren1 $$ -- greenText "n1'" $$ showPatch n1' $$ -- greenText "p2" $$ showNon p2 -- ) (fst $ all_conflicts_with 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 <- sort_coalesceFL $ effect 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 -- cHi -- uses previous match commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c commute _ = Nothing merge (InvConflictor _ _ _ :\/: _) = impossible merge (_ :\/: InvConflictor _ _ _) = impossible merge (Etacilpud _ :\/: _) = impossible merge (_ :\/: Etacilpud _) = impossible -- merge (x :\/: y) | traceDoc (greenText "merging x" $$ showPatch x $$ -- greenText "with y" $$ showPatch y) False = impossible -- mA merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a -- mB merge (Duplicate a :\/: b) = b :/\: Duplicate (addP (invert b) a) -- FIXME ??? -- smB merge m@(_ :\/: Duplicate _) = swapMerge m -- mC -- merge _ | traceDoc (greenText "about to look for conflictingness") False = impossible merge (x :\/: y) | Just (y' :> ix') <- commute (invert (assertConsistent x) :> assertConsistent y), Just (y'' :> _) <- commute (x :> y'), IsEq <- y'' =\/= y = --traceDoc (greenText "These didn't conflict") $ assertConsistent y' :/\: invert (assertConsistent ix') | IsEq <- x =\/= y, n <- addP (invert x) $ non x = --traceDoc (greenText "Found duplicate") $ Duplicate n :/\: Duplicate n -- merge (x :\/: y) | traceDoc (greenText "trying to merging x" $$ showPatch x $$ -- greenText "which conflicts with y" $$ showPatch y) False = impossible -- mD merge (Normal x :\/: Normal y) = Conflictor [] (x:>:NilFL) (non $ Normal y) :/\: Conflictor [] (y:>:NilFL) (non $ Normal x) -- mG merge (Normal x :\/: Conflictor iy yy y) = --traceDoc (greenText "merging Normal x" $$ showPatch x $$ -- greenText "and Conflictor iy yy y" $$ showPatch (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 -- smE+smG merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m -- merge (x :\/: y) | traceDoc (greenText "still trying to merge x" $$ showPatch x $$ -- greenText "with y" $$ showPatch y) False = impossible -- mH see also cH 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') -- +++ above is a more efficient version of nub -- (iy'++ix') given that we know each element shows up -- only once in either list. in --traceDoc (greenText "here I am! and so is ixy'" $$ showNons ixy' $$ -- greenText "and iy" $$ showNons iy $$ greenText (show $ length iy) $$ -- greenText "and ix" $$ showNons ix $$ -- greenText "and iy'" $$ showNons iy' $$ -- greenText "and ix'" $$ showNons ix' $$ -- greenText "and ic'" $$ showNons ic' -- ) $ Conflictor (x':ixy'++nxx') yy' y' :/\: Conflictor (y':ixy'++nyy') xx' x' Nothing -> impossible pullInContext fromNons -- merge _ = error "haven't finished fixing merge" list_touched_files (Duplicate p) = nonTouches p list_touched_files (Etacilpud p) = nonTouches p list_touched_files (Normal p) = list_touched_files p list_touched_files (Conflictor x c p) = nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p list_touched_files (InvConflictor x c p) = nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p {- all_conflicts_withFL :: FL Prim C(x y) -> [Non RealPatch C(x)] -> ([Non RealPatch C(x)], [Non RealPatch C(x)]) all_conflicts_withFL xx ns = case partition f ns of ([],nc) -> ([],nc) (c,nc) -> case acw c nc of (c',nc') -> (c++c',nc') where acw (y:ys) zs = case all_conflicts_with y zs of (c,nc) -> case acw ys nc of (c',nc') -> (c++c',nc') acw [] zs = ([],zs) f (Non c p) = case commuteRLFL (invertFL c :> mapFL_FL Normal xx) of Nothing -> True Just (xx' :> _) -> case commuteFL (Normal (invert p) :> xx') of Nothing -> True Just _ -> False -} all_conflicts_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> ([Non RealPatch C(x)], [Non RealPatch C(x)]) all_conflicts_with x ys = acw $ partition (conflicts_with x) ys where acw ([],nc) = ([],nc) acw (c:cs, nc) = case all_conflicts_with c nc of (c1,nc1) -> case acw (cs, nc1) of (xs',nc') -> (c:c1++xs',nc') conflicts_with :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool conflicts_with x y | x `depends_upon` y || y `depends_upon` x = False conflicts_with x (Non cy y) = case remPs cy x of Just (Non cx' x') -> case commuteFL (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of Just _ -> False Nothing -> True Nothing -> True depends_upon :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool depends_upon (Non xs _) (Non ys y) = case remove_subsequenceFL (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' <- commute_no_conflicts (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 "[" $$ showPatch 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 "[" $$ showPatch cs $$ blueText "]" $$ showNon p showContextPatch s (Normal p) = showContextPatch s p showContextPatch _ c = showPatch c instance ReadPatch RealPatch where readPatch' want_eof = do s <- peek_input case fmap (unpackPS . fst) $ my_lex s of Just "duplicate" -> do work my_lex p <- readNon return $ (Sealed . Duplicate) `fmap` p Just "etacilpud" -> do work my_lex p <- readNon return $ (Sealed . Etacilpud) `fmap` p Just "conflictor" -> do work my_lex --let tracePeek x = do y <- peek_input -- traceDoc (greenText x $$ greenText (show $ unpackPS y)) return () i <- readNons Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') Just p <- readNon return $ Just $ Sealed $ Conflictor i (unsafeCoerceP ps) p Just "rotcilfnoc" -> do work my_lex i <- readNons Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') Just p <- readNon return $ Just $ Sealed $ InvConflictor i ps p _ -> do mp <- readPrim NewFormat want_eof 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 show2 = show instance Nonable RealPatch where non (Duplicate d) = d non (Etacilpud d) = invertNon d -- FIXME !!! ??? 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 \end{code}