% Copyright (C) 2002-2003 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. \begin{code} module PatchCommute ( merge, elegant_merge, submerge_in_dir, old_elegant_merge, new_elegant_merge, really_eq_patches, eq_patches, eq_list, compare_patches, compare_list, merger, merger_equivalent, glump, unravel, modernize_patch, resolve_conflicts, reorder_and_coalesce, canonize, commute, list_touched_files, list_conflicted_files, force_commute, try_to_shrink, subcommutes, helper_force_commute, -- FIXME remove this! CommuteFunction, Perhaps(..), -- for PatchApply applyBinary, try_tok_internal, movedirfilename ) where import Prelude hiding ( pi ) import Control.Monad ( liftM, liftM2, when, MonadPlus, mplus, msum, mzero ) import Data.Maybe ( isNothing ) import FastPackedString ( PackedString, packString, lastPS, nullPS, substrPS, breakPS, concatPS, unlinesPS, linesPS, ) import FileName ( FileName, fn2fp, fp2fn, norm_path ) import Printer ( errorDoc, vcat, text, ($$) ) import PatchCore ( Patch(..), DirPatchType(..), FilePatchType(..), nubAdjBy, is_merger, invert, join_patches, null_patch, is_null_patch, flatten, flatten_to_primitives, merger_undo, n_fn ) import PatchShow ( showPatch ) import Data.List ( intersperse, sort, sortBy, nubBy ) import Data.Maybe ( isJust, catMaybes ) import SlurpDirectory ( FileContents ) import Lcs ( getChanges ) import RegChars ( regChars ) import DarcsUtils ( bugDoc, nubsort ) #include "impossible.h" \end{code} \section{Commuting patches} \subsection{Composite patches} Composite patches are made up of a series of patches intended to be applied sequentially. They are represented by a list of patches, with the first patch in the list being applied first. \begin{code} commute_split :: (Patch, Patch) -> Perhaps (Patch, Patch) commute_split (Split patches, patch) = toPerhaps $ do (p1, ps) <- cs (patches, patch) case sort_coalesce_composite ps of [p] -> return (p1, p) ps' -> return (p1, Split ps') where cs ([], p1) = return (p1, []) cs (p:ps, p1) = do (p1', p') <- commute (p, p1) (p1'', ps') <- cs (ps, p1') return (p1'', p':ps') commute_split _ = Unknown \end{code} \begin{code} try_to_shrink :: [Patch] -> [Patch] try_to_shrink psold = let ps = sort_coalesce_composite psold ps_shrunk = shrink_a_bit ps in if length ps_shrunk < length ps then try_to_shrink ps_shrunk else ps_shrunk shrink_a_bit :: [Patch] -> [Patch] shrink_a_bit [] = [] shrink_a_bit (p:ps) = case try_one [] p ps of Nothing -> p : shrink_a_bit ps Just ps' -> ps' try_one :: [Patch] -> Patch -> [Patch] -> Maybe [Patch] try_one _ _ [] = Nothing try_one sofar p (p1:ps) = case coalesce (p1, p) of Just p' -> Just (reverse sofar ++ [p'] ++ ps) Nothing -> case commute (p1, p) of Nothing -> Nothing Just (p', p1') -> try_one (p1':sofar) p' ps reorder_and_coalesce :: Patch -> Patch reorder_and_coalesce (NamedP n d p) = NamedP n d $ reorder_and_coalesce p reorder_and_coalesce (ComP patches) = ComP $ sort_coalesce_composite patches reorder_and_coalesce p =p sort_coalesce_composite :: [Patch] -> [Patch] sort_coalesce_composite [] = [] sort_coalesce_composite (x:xs) | is_null_patch x = sort_coalesce_composite xs sort_coalesce_composite (x:xs) = push_coalesce_patch x (sort_coalesce_composite xs) push_coalesce_patch :: Patch -> [Patch] -> [Patch] push_coalesce_patch new [] = [new] push_coalesce_patch new ps@(p:ps') = case coalesce (p, new) of Just new' | is_null_patch new' -> ps' | otherwise -> push_coalesce_patch new' ps' Nothing -> if compare_patches new p == LT then new:ps else case commute (p, new) of Just (new', p') -> case push_coalesce_patch new' ps' of r | length r < 1 + length ps' -> push_coalesce_patch p' r r -> p' : r Nothing -> new:ps canonizeComposite :: [Patch] -> Maybe Patch canonizeComposite patches = simplify_composite $ sort_coalesce_composite $ catMaybes $ map canonize patches where simplify_composite :: [Patch] -> Maybe Patch simplify_composite [] = Nothing simplify_composite [p] = canonize p simplify_composite ps = Just $ ComP ps \end{code} \newcommand{\commute}{\longleftrightarrow} \newcommand{\commutes}{\longleftrightarrow} The first way (of only two) to change the context of a patch is by commutation, which is the process of changing the order of two sequential patches. \begin{dfn} The commutation of patches $P_1$ and $P_2$ is represented by \[ P_2 P_1 \commutes {P_1}' {P_2}'. \] Here $P_1'$ is intended to describe the same change as $P_1$, with the only difference being that $P_1'$ is applied after $P_2'$ rather than before $P_2$. \end{dfn} The above definition is obviously rather vague, the reason being that what is the ``same change'' has not been defined, and we simply assume (and hope) that the code's view of what is the ``same change'' will match those of its human users. The `$\commutes$' operator should be read as something like the $==$ operator in C, indicating that the right hand side performs identical changes to the left hand side, but the two patches are in reversed order. When read in this manner, it is clear that commutation must be a reversible process, and indeed this means that commutation \emph{can} fail, and must fail in certain cases. For example, the creation and deletion of the same file cannot be commuted. When two patches fail to commute, it is said that the second patch depends on the first, meaning that it must have the first patch in its context (remembering that the context of a patch is a set of patches, which is how we represent a tree). \footnote{The fact that commutation can fail makes a huge difference in the whole patch formalism. It may be possible to create a formalism in which commutation always succeeds, with the result of what would otherwise be a commutation that fails being something like a virtual particle (which can violate conservation of energy), and it may be that such a formalism would allow strict mathematical proofs (whereas those used in the current formalism are mostly only hand waving ``physicist'' proofs). However, I'm not sure how you'd deal with a request to delete a file that has not yet been created, for example. Obviously you'd need to create some kind of antifile, which would annihilate with the file when that file finally got created, but I'm not entirely sure how I'd go about doing this. $\ddot\frown$ So I'm sticking with my hand waving formalism.} %I should add that one using the inversion relationship of sequential %patches, one can avoid having to provide redundant definitions of %commutation. % There is another interesting property which is that a commute's results % can't be affected by commuting another thingamabopper. \begin{code} is_in_directory :: FileName -> FileName -> Bool is_in_directory d f = iid (fn2fp d) (fn2fp f) where iid (cd:cds) (cf:cfs) | cd /= cf = False | otherwise = iid cds cfs iid [] ('/':_) = True iid [] [] = True -- Count directory itself as being in directory... iid _ _ = False 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 clever_commute :: ((Patch, Patch) -> Perhaps (Patch, Patch)) -> (Patch, Patch) -> Perhaps (Patch, Patch) clever_commute 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 --clever_commute c (p1,p2) = c (p1,p2) `mplus` -- (case c (invert p2,invert p1) of -- Succeeded (p1', p2') -> Succeeded (invert p2', invert p1') -- Failed -> Failed -- Unknown -> Unknown) speedy_commute :: (Patch,Patch) -> Perhaps (Patch,Patch) speedy_commute (p1, p2) -- Deal with common case quickly! | p1_modifies /= Nothing && p2_modifies /= Nothing && p1_modifies /= p2_modifies = Succeeded (p2, p1) | otherwise = Unknown where p1_modifies = is_filepatch_merger p1 p2_modifies = is_filepatch_merger p2 everything_else_commute :: ((Patch,Patch) -> Maybe (Patch,Patch)) -> (Patch,Patch) -> Perhaps (Patch,Patch) everything_else_commute c x = eec x where eec (NamedP n1 d1 p1, NamedP n2 d2 p2) = if n2 `elem` d1 || n1 `elem` d2 then Failed else toPerhaps $ do (p2', p1') <- c (p1, p2) return (NamedP n2 d2 p2', NamedP n1 d1 p1') eec (ChangePref p f t,p1) = Succeeded (p1,ChangePref p f t) eec (p2,ChangePref p f t) = Succeeded (ChangePref p f t,p2) eec (ComP [], p1) = Succeeded (p1, ComP []) eec (p2, ComP []) = Succeeded (ComP [], p2) eec (ComP (p:ps), p1) = toPerhaps $ do (p1', p') <- c (p, p1) (p1'', ComP ps') <- c (ComP ps, p1') return (p1'', ComP $ p':ps') eec (patch2, ComP patches) = toPerhaps $ do (patches', patch2') <- ccr (patch2, reverse patches) return (ComP $ reverse patches', patch2') where ccr (p2, []) = seq p2 $ return ([], p2) ccr (p2, p:ps) = do (p', p2') <- c (p2, p) (ps', p2'') <- ccr (p2', ps) return (p':ps', p2'') eec (NamedP n2 d2 p2, p1) = toPerhaps $ do (p1',p2') <- c (p2,p1) return (p1', NamedP n2 d2 p2') eec (p2, NamedP n1 d1 p1) = toPerhaps $ do (p1',p2') <- c (p2,p1) return (NamedP n1 d1 p1', p2') eec (p2,p1) = msum [clever_commute commute_nameconflict (p2, p1), clever_commute commute_filedir (p2, p1), clever_commute commute_split (p2, p1), clever_commute simple_commute_conflict (p2, p1), clever_commute harder_commute_conflict (p2, p1), clever_commute commute_recursive_merger (p2, p1), clever_commute other_commute_recursive_merger (p2, p1)] {- Note that it must be true that commute (A^-1 A, P) = Just (P, A'^-1 A') and if commute (A, B) == Just (B', A') then commute (B^-1, A^-1) == Just (A'^-1, B'^-1) -} merger_commute :: (Patch,Patch) -> Perhaps (Patch,Patch) merger_commute (Merger True g _ _ p1 p2, pA) | eq_patches pA p1 = Succeeded (merger g p2 p1, p2) | eq_patches pA (invert (merger g p2 p1)) = Failed merger_commute (Merger True "0.0" _ _ (Merger True "0.0" _ _ c b) (Merger True "0.0" _ _ c' a), Merger True "0.0" _ _ b' c'') | eq_patches b' b && eq_patches c c' && eq_patches c c'' = Succeeded (merger "0.0" (merger "0.0" b a) (merger "0.0" b c), merger "0.0" b a) merger_commute _ = Unknown commute :: (Patch,Patch) -> Maybe (Patch,Patch) commute x = toMaybe $ msum [speedy_commute x, clever_commute simple_unforce x, clever_commute repeated_unforce x, clever_commute merger_commute x, everything_else_commute commute x ] commute_no_merger :: (Patch,Patch) -> Maybe (Patch,Patch) commute_no_merger x = toMaybe $ msum [speedy_commute x, everything_else_commute commute_no_merger x] force_commute :: (Patch, Patch) -> (Patch, Patch) force_commute z = case msum [speedy_commute z, clever_commute simple_unforce z, clever_commute repeated_unforce z, clever_commute merger_commute z, everything_else_commute (Just . force_commute) z] of Succeeded x -> x Failed -> case msum [clever_commute repeated_force z, simple_force z] of Succeeded x -> x _ -> impossible Unknown -> -- FIXME this Unknown shouldn't ever happen! Eventually I -- should make this an "impossible" and then track down the -- errors. case msum [clever_commute repeated_force z, simple_force z] of Succeeded x -> x _ -> impossible -- Handle commutation of simple single conflicts... simple_unforce :: (Patch,Patch) -> Perhaps (Patch,Patch) simple_unforce (Conflictor False [a] [b], p) | a `eq_patches` p = Succeeded (Conflictor False [b] [a], b) simple_unforce (Conflictor True [a] [ib], Conflictor False [ib'] [a']) | a `eq_patches` a' && ib `eq_patches` ib' = Succeeded (a, invert ib) simple_unforce _ = Unknown simple_force :: (Patch,Patch) -> Perhaps (Patch,Patch) simple_force (a, b) = Succeeded (Conflictor True [a] [invert b], Conflictor False [invert b] [a]) -- repeated_force requires clever_commute repeated_force :: (Patch,Patch) -> Perhaps (Patch,Patch) repeated_force (Conflictor False _ _, Conflictor _ _ _) = Unknown repeated_force (Conflictor False a [b], p) = Succeeded (Conflictor True [b] aip, Conflictor False aip [b]) where aip = a ++ [invert p] repeated_force _ = Unknown -- Handle commutation of repeated (but simple) conflicts... -- (requires clever_commute) repeated_unforce :: (Patch,Patch) -> Perhaps (Patch,Patch) repeated_unforce (Conflictor False ap@(_:_:_) [b], p) | last_patch_can_be p ap = -- FIXME: inefficient case filter (eq_patches (invert p) . head) $ all_head_permutations $ map invert $ reverse ap of ((_:ia):_) -> Succeeded (Conflictor False [b] ap, Conflictor False (map invert $ reverse ia) [b]) _ -> impossible repeated_unforce (Conflictor True [b] aip@(_:_:_), Conflictor False aip' [b']) | b' `eq_patches` b && aip' `same_length` aip = case filter (eq_patches (invert ip) . head) $ all_head_permutations $ map invert $ reverse aip' of [] -> Unknown ((_:a):_) | map invert (reverse a) `eq_patchsequence` init aip -> Succeeded (Conflictor False (map invert $ reverse a) [b'], invert ip) | otherwise -> Unknown _ -> impossible where ip = last aip [] `same_length` [] = True (_:x) `same_length` (_:y) = x `same_length` y _ `same_length` _ = False -- The following pattern is needed for commuting with patch and its -- inverse. repeated_unforce (Conflictor False [b'] ax, Conflictor False a [b]) | b' `eq_patches` b && length ax == length a + 1 = case filter (eq_patchsequence ia . tail) $ all_head_permutations $ map invert $ reverse ax of [] -> Unknown (ax'@(ix:_):_) -> Succeeded (Conflictor False (map invert $ reverse ax') [b], invert ix) _ -> impossible where ia = map invert $ reverse a repeated_unforce _ = Unknown first_patch_can_be :: Patch -> [Patch] -> Bool first_patch_can_be _ [] = False first_patch_can_be x xa = case filter (eq_patches x . head) $ all_head_permutations xa of [] -> False ((_:_):_) -> True _ -> impossible last_patch_can_be :: Patch -> [Patch] -> Bool last_patch_can_be x ax = first_patch_can_be (invert x) $ map invert $ reverse ax helper_force_commute :: (Patch,Patch) -> (Patch,Patch) -- Multiple forward force_commute: helper_force_commute (Conflictor False a [b], p) = (Conflictor True [b] aip, Conflictor False aip [b]) where aip = a ++ [invert p] -- Multiple backward force_commute: helper_force_commute (p1@(Conflictor True _ _), p) = (Conflictor True [p1] ip, Conflictor False ip [p1]) where ip = [invert p] helper_force_commute _ = impossible is_filepatch_merger :: Patch -> Maybe FileName is_filepatch_merger (FP f _) = Just f is_filepatch_merger (Merger _ _ _ _ p1 p2) = do f1 <- is_filepatch_merger p1 f2 <- is_filepatch_merger p2 if f1 == f2 then return f1 else Nothing is_filepatch_merger (Conflictor _ a b) = do f1 <- is_filepatch_merger $ join_patches a f2 <- is_filepatch_merger $ join_patches b if f1 == f2 then return f1 else Nothing is_filepatch_merger _ = Nothing \end{code} \begin{code} simple_commute_conflict :: (Patch, Patch) -> Perhaps (Patch, Patch) simple_commute_conflict (Conflictor False a [b], p) = toPerhaps $ do (ja', ip') <- commute_no_merger (invert p, join_patches a) (_, b') <- commute_no_merger (b, invert ip') commute_no_merger (b', ip') -- FIXME: Is this necesary? (p', _) <- commute_no_merger (invert $ join_patches a, p) -- FIXME REMOVE when (not (invert p' `eq_patches` ip')) $ impossible -- FIXME REMOVE Just (invert ip', Conflictor False (flatten ja') [b']) simple_commute_conflict (p', Conflictor False a' [b']) = toPerhaps $ do (ip, ja) <- commute_no_merger (join_patches a', invert p') (_, b) <- commute_no_merger (b', invert p') (_, p) <- commute_no_merger (p', invert $ join_patches a') -- FIXME REMOVE when (not (invert p `eq_patches` ip)) $ impossible -- FIXME REMOVE Just (Conflictor False (flatten ja) [b], invert ip) simple_commute_conflict _ = Unknown harder_commute_conflict :: (Patch, Patch) -> Perhaps (Patch, Patch) harder_commute_conflict (Conflictor False a b, p) = toPerhaps $ do (_, ja') <- commute_no_merger (join_patches a, p) commute_no_merger (ja', invert p) (_, jb') <- commute_no_merger (join_patches b, p) commute_no_merger (jb', invert p) Just (p, Conflictor False (flatten ja') (flatten jb')) harder_commute_conflict (p, Conflictor False a b) = toPerhaps $ do (_, ja') <- commute_no_merger (join_patches a, invert p) commute_no_merger (ja', p) (_, jb') <- commute_no_merger (join_patches b, invert p) commute_no_merger (jb', p) Just (Conflictor False (flatten ja') (flatten jb'), p) harder_commute_conflict _ = Unknown eq_patchsequence :: [Patch] -> [Patch] -> Bool eq_patchsequence a b | length a /= length b = False | otherwise = e a b where e (x:xs) y = case filter (eq_patches x . head) $ all_head_permutations y of ((_:ys):_) -> e xs ys _ -> False e [] [] = True e _ _ = impossible \end{code} \begin{code} commute_recursive_merger :: (Patch,Patch) -> Perhaps (Patch,Patch) commute_recursive_merger (p@(Merger True "0.0" _ _ p1 p2), pA) = toPerhaps $ do (pA', _) <- commute (undo, pA) commute (invert undo, pA') (pAmid, _) <- commute (invert p1, pA) (pAx, p1') <- commute (p1, pAmid) assert (pAx `eq_patches` pA) (_,p2') <- commute (p2, pAmid) (_, p2o) <- commute (p2', invert pAmid) assert (p2o `eq_patches` p2) let p' = if eq_patches p1' p1 && eq_patches p2' p2 then p else merger "0.0" p1' p2' undo' = merger_undo p' (_, pAo) <- commute (pA', undo') assert (pAo `eq_patches` pA) return (pA', p') where undo = merger_undo p commute_recursive_merger (Merger True _ _ _ _ _, _) = impossible commute_recursive_merger _ = Unknown other_commute_recursive_merger :: (Patch,Patch) -> Perhaps (Patch,Patch) other_commute_recursive_merger (pA', p_old@(Merger True "0.0" _ _ p1' p2')) = toPerhaps $ do (_, pA) <- commute (pA', merger_undo p_old) (p1, pAmid) <- commute (pA, p1') (pAmido, _) <- commute (invert p1, pA) assert (pAmido `eq_patches` pAmid) (_, p2) <- commute (p2', invert pAmid) (_, p2o') <- commute (p2, pAmid) assert (p2o' `eq_patches` p2') let p = if p1 `eq_patches` p1' && p2 `eq_patches` p2' then p_old else merger "0.0" p1 p2 undo = merger_undo p assert (not $ pA `eq_patches` p1) -- special case here... (pAo', _) <- commute (undo,pA) assert (pAo' `eq_patches` pA') return (p, pA) other_commute_recursive_merger (_, Merger True _ _ _ _ _) = impossible other_commute_recursive_merger _ = Unknown assert :: Bool -> Maybe () assert False = Nothing assert True = Just () movedirfilename :: FileName -> FileName -> FileName -> FileName movedirfilename old new name = seq new $ fp2fn $ mdfn (fn2fp old) (fn2fp new) (fn2fp name) where mdfn d d' f = if length f > length d && take (length d+1) f == d ++ "/" then d'++drop (length d) f else if f == d then d' else f is_superdir :: FileName -> FileName -> Bool is_superdir d1 d2 = isd (fn2fp d1) (fn2fp d2) where isd s1 s2 = length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/" make_conflicted :: Patch -> Patch make_conflicted (FP f AddFile) = FP (conflicted_name f) AddFile make_conflicted (DP f AddDir ) = DP (conflicted_name f) AddDir make_conflicted (Move a f) = Move a (conflicted_name f) make_conflicted _ = impossible conflicted_name :: FileName -> FileName conflicted_name f = fp2fn $ fn2fp f ++ "-conflict" create_conflict_merge :: (Patch,Patch) -> Maybe (Patch,Patch) create_conflict_merge (Move d d', FP f AddFile) | d' == f = Just (Move d $ conflicted_name f, FP f AddFile) create_conflict_merge (Move d d', DP f AddDir) | d' == f = Just (Move d $ conflicted_name f, DP f AddDir) create_conflict_merge (FP d AddFile, DP f AddDir) | d == f = Just (FP (conflicted_name d) AddFile, DP f AddDir) create_conflict_merge (Move d d', Move f f') | d' == f' && d > f = Just (Move (movedirfilename f f' d) $ conflicted_name f', Move f f') create_conflict_merge (p, Split [Move a b, p2]) | b == conflicted_name a = case create_conflict_merge (p, make_conflicted p2) of Nothing -> Nothing Just (p',_) -> Just (p', Split [Move a b, p2]) create_conflict_merge _ = Nothing commute_nameconflict :: (Patch,Patch) -> Perhaps (Patch,Patch) commute_nameconflict (Move d d', FP f2 AddFile) | d == f2 && d' == conflicted_name f2 = Succeeded (FP d' AddFile, ComP []) | d' == conflicted_name f2 = Succeeded (Split [Move f2 d', FP f2 AddFile], Move d f2) commute_nameconflict (Move d d', DP f2 AddDir) | d == f2 && d' == conflicted_name f2 = Succeeded (DP d' AddDir, ComP []) | d' == conflicted_name f2 = Succeeded (Split [Move f2 d', DP f2 AddDir], Move d f2) commute_nameconflict (Move d d', Move f f') | d' == conflicted_name d && d == f' = Succeeded (Move f d', ComP []) | d' == conflicted_name f' && (movedirfilename f' f d) > f = Succeeded (Split [Move f' d', Move (movedirfilename d d' f) f'], Move (movedirfilename f' f d) f') commute_nameconflict (FP f AddFile, DP d AddDir) | f == conflicted_name d = Succeeded (Split [Move d f, DP d AddDir], FP d AddFile) commute_nameconflict (DP f AddDir, Split [Move a b, p2]) | b == conflicted_name a && f == conflicted_name b = Succeeded (Split [Move b f, Split [Move a b, p2]], DP b AddDir) commute_nameconflict (FP f AddFile, Split [Move a b, p2]) | b == conflicted_name a && f == conflicted_name b = Succeeded (Split [Move b f, Split [Move a b, p2]], FP b AddFile) commute_nameconflict (Move old f, Split [Move a b, p2]) | b == conflicted_name a && f == conflicted_name b = Succeeded (Split [Move b f, Split [Move a b, p2]], Move old b) commute_nameconflict _ = Unknown commute_filedir :: (Patch,Patch) -> Perhaps (Patch,Patch) commute_filedir (FP f1 p1, FP f2 p2) = if f1 /= f2 then Succeeded ( FP f2 p2, FP f1 p1 ) else commuteFP f1 (p1, p2) commute_filedir (DP d1 p1, DP d2 p2) = if (not $ is_in_directory d1 d2) && (not $ is_in_directory d2 d1) && d1 /= d2 then Succeeded ( DP d2 p2, DP d1 p1 ) else Failed commute_filedir (DP d dp, FP f fp) = if not $ is_in_directory d f then Succeeded (FP f fp, DP d dp) else Failed commute_filedir (Move d d', FP f2 p2) | f2 == d' = Failed | p2 == AddFile && d == f2 = Failed | otherwise = Succeeded (FP (movedirfilename d d' f2) p2, Move d d') commute_filedir (Move d d', DP d2 p2) | is_superdir d2 d' || is_superdir d2 d = Failed | p2 == AddDir && d == d2 = Failed | d2 == d' = Failed | otherwise = Succeeded (DP (movedirfilename d d' d2) p2, Move d d') commute_filedir (Move d d', Move f f') | f == d' || f' == d = Failed | f == d || f' == d' = Failed | d `is_superdir` f && f' `is_superdir` d' = Failed | otherwise = Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f'), Move (movedirfilename f' f d) (movedirfilename f' f d')) commute_filedir _ = Unknown \end{code} \begin{code} type CommuteFunction = (Patch, Patch) -> Perhaps (Patch, Patch) subcommutes :: [(String, CommuteFunction)] subcommutes = [("speedy_commute", speedy_commute), ("commute_filedir", clever_commute commute_filedir), ("commute_filepatches", clever_commute commute_filepatches), ("simple_commute_conflict", clever_commute simple_commute_conflict), ("harder_commute_conflict", clever_commute harder_commute_conflict), ("simple conflicts", \x -> msum [clever_commute simple_unforce x, simple_force x]), ("repeated conflicts", \x -> msum [ clever_commute repeated_unforce x, clever_commute repeated_force x]), ("force_commute", \x -> Succeeded (force_commute x)), ("commute", toPerhaps . commute) ] \end{code} \paragraph{Merge} \newcommand{\merge}{\Longrightarrow} The second way one can change the context of a patch is by a {\bf merge} operation. A merge is an operation that takes two parallel patches and gives a pair of sequential patches. The merge operation is represented by the arrow ``\( \merge \)''. \begin{dfn}\label{merge_dfn} The result of a merge of two patches, $P_1$ and $P_2$ is one of two patches, $P_1'$ and $P_2'$, which satisfy the relationship: \[ P_2 \parallel P_1 \merge {P_2}' P_1 \commute {P_1}' P_2. \] \end{dfn} Note that the sequential patches resulting from a merge are \emph{required} to commute. This is an important consideration, as without it most of the manipulations we would like to perform would not be possible. The other important fact is that a merge \emph{cannot fail}. Naively, those two requirements seem contradictory. In reality, what it means is that the result of a merge may be a patch which is much more complex than any we have yet considered\footnote{Alas, I don't know how to prove that the two constraints even \emph{can} be satisfied. The best I have been able to do is to believe that they can be satisfied, and to be unable to find an case in which my implementation fails to satisfy them. These two requirements are the foundation of the entire theory of patches (have you been counting how many foundations it has?).}. \begin{code} merge :: (Patch, Patch) -> Maybe (Patch, Patch) \end{code} \subsection{How merges are actually performed} The constraint that any two compatible patches (patches which can successfully be applied to the same tree) can be merged is actually quite difficult to apply. The above merge constraints also imply that the result of a series of merges must be independent of the order of the merges. So I'm putting a whole section here for the interested to see what algorithms I use to actually perform the merges (as this is pretty close to being the most difficult part of the code). The first case is that in which the two merges don't actually conflict, but don't trivially merge either (e.g.\ hunk patches on the same file, where the line number has to be shifted as they are merged). This kind of merge can actually be very elegantly dealt with using only commutation and inversion. There is a handy little theorem which is immensely useful when trying to merge two patches. \begin{thm}\label{merge_thm} $ P_2' P_1 \commute P_1' P_2 $ if and only if $ P_1'^{ -1} P_2' \commute P_2 P_1^{ -1} $, provided both commutations succeed. If either commute fails, this theorem does not apply. \end{thm} This can easily be proven by multiplying both sides of the first commutation by $P_1'^{ -1}$ on the left, and by $P_1^{ -1}$ on the right. Besides being used in merging, this theorem is also useful in the recursive commutations of mergers. From Theorem~\ref{merge_thm}, we see that the merge of $P_1$ and $P_2'$ is simply the commutation of $P_2$ with $P_1^{ -1}$ (making sure to do the commutation the right way). Of course, if this commutation fails, the patches conflict. Moreover, one must check that the merged result actually commutes with $P_1$, as the theorem applies only when \emph{both} commutations are successful. \begin{code} -- Change the following function to switch between testing new Conflictor -- code, and using the old Merger code. elegant_merge :: (Patch, Patch) -> Maybe Patch elegant_merge = old_elegant_merge new_elegant_merge :: (Patch, Patch) -> Maybe Patch new_elegant_merge (p1, p2) = case force_commute (p1, invert p2) of (xa,p1') -> case force_commute (p1', p2) of -- FIXME: safety redundancy here. (x,p1o) -> if really_eq_patches p1o p1 then Just p1' else errorDoc $ text "Aaack in elegant_merge\n" $$ showPatch p1 $$ text "\nand also\n" $$ showPatch p2 $$ text "\nmerged 1:\n" $$ showPatch p1' $$ text "\nmerged 2 commuted:\n" $$ showPatch x $$ text "\nreconstituted:\n" $$ showPatch p1o $$ text "\nlast but not least:\n" $$ showPatch xa old_elegant_merge :: (Patch, Patch) -> Maybe Patch old_elegant_merge (p1, p2) = case commute (p1, invert p2) of Just (_,p1') -> case commute (p1', p2) of Nothing -> Nothing Just (_,p1o) -> if really_eq_patches p1o p1 then Just p1' else Nothing Nothing -> Nothing \end{code} Of course, there are patches that actually conflict, meaning a merge where the two patches truly cannot both be applied (e.g.\ trying to create a file and a directory with the same name). We deal with this case by creating a special kind of patch to support the merge, which we will call a ``merger''. Basically, a merger is a patch that contains the two patches that conflicted, and instructs darcs basically to resolve the conflict. By construction a merger will satisfy the commutation property (see Definition~\ref{merge_dfn}) that characterizes all merges. Moreover the merger's properties are what makes the order of merges unimportant (which is a rather critical property for darcs as a whole). The job of a merger is basically to undo the two conflicting patches, and then apply some sort of a ``resolution'' of the two instead. In the case of two conflicting hunks, this will look much like what CVS does, where it inserts both versions into the file. In general, of course, the two conflicting patches may both be mergers themselves, in which case the situation is considerably more complicated. \begin{code} list_conflicted_files :: Patch -> [FilePath] list_conflicted_files p = nubsort $ concatMap list_touched_files $ concat $ resolve_conflicts p list_touched_files :: Patch -> [FilePath] list_touched_files (NamedP _ _ p) = list_touched_files p list_touched_files (Move f1 f2) = map fn2fp [f1, f2] list_touched_files (Split ps) = nubsort $ concatMap list_touched_files ps list_touched_files (ComP ps) = nubsort $ concatMap list_touched_files ps list_touched_files (FP f _) = [fn2fp f] list_touched_files (DP d _) = [fn2fp d] list_touched_files (Merger _ _ _ _ p1 p2) = nubsort $ list_touched_files p1 ++ list_touched_files p2 list_touched_files _ = [] \end{code} \begin{code} merge (p1,p2) = Just (actual_merge (p1,p2), p2) actual_merge :: (Patch, Patch) -> Patch actual_merge (NamedP n d p1, p2) = seq p2 $ NamedP n d $ actual_merge (p1, p2) actual_merge (p1, NamedP _ _ p2) = actual_merge (p1, p2) actual_merge (ComP the_p1s, ComP the_p2s) = join_patches $ mc the_p1s the_p2s where mc :: [Patch] -> [Patch] -> [Patch] mc [] (_:_) = [] mc p1s [] = p1s mc p1s (p2:p2s) = mc (merge_patches_after_patch p1s p2) p2s actual_merge (ComP p1s, p2) = seq p2 $ join_patches $ merge_patches_after_patch p1s p2 actual_merge (p1, ComP p2s) = seq p1 $ merge_patch_after_patches p1 p2s actual_merge (p1, p2) = seq p1 $ seq p2 $ case elegant_merge (p1,p2) of Just p1' -> p1' Nothing -> case clever_merge create_conflict_merge (p1,p2) of Just (p1',_) -> p1' Nothing -> merger "0.0" p2 p1 merge_patch_after_patches :: Patch -> [Patch] -> Patch merge_patch_after_patches p (p1:p1s) = case merge (p, p1) of Nothing -> impossible Just (p',_) -> seq p' $ merge_patch_after_patches p' p1s merge_patch_after_patches p [] = p merge_patches_after_patch :: [Patch] -> Patch -> [Patch] merge_patches_after_patch p2s p = case force_commute (merge_patch_after_patches p p2s, join_patches p2s) of (ComP p2s', _) -> p2s' _ -> impossible clever_merge :: ((Patch, Patch) -> Maybe (Patch, Patch)) -> (Patch, Patch) -> Maybe (Patch, Patch) clever_merge m (p1,p2) = m (p1,p2) `mplus` (m (p2,p1) >>= commute) \end{code} Much of the merger code depends on a routine which recreates from a single merger the entire sequence of patches which led up to that merger (this is, of course, assuming that this is the complicated general case of a merger of mergers of mergers). This ``unwind'' procedure is rather complicated, but absolutely critical to the merger code, as without it we wouldn't even be able to undo the effects of the patches involved in the merger, since we wouldn't know what patches were all involved in it. Basically, unwind takes a merger such as \begin{verbatim} M( M(A,B), M(A,M(C,D))) \end{verbatim} From which it recreates a merge history: \begin{verbatim} C A M(A,B) M( M(A,B), M(A,M(C,D))) \end{verbatim} (For the curious, yes I can easily unwind this merger in my head [and on paper can unwind insanely more complex mergers]---that's what comes of working for a few months on an algorithm.) Let's start with a simple unwinding. The merger \verb!M(A,B)! simply means that two patches (\verb!A! and \verb!B!) conflicted, and of the two of them \verb!A! is first in the history. The last two patches in the unwinding of any merger are always just this easy. So this unwinds to: \begin{verbatim} A M(A,B) \end{verbatim} What about a merger of mergers? How about \verb!M(A,M(C,D))!. In this case we know the two most recent patches are: \begin{verbatim} A M(A,M(C,D)) \end{verbatim} But obviously the unwinding isn't complete, since we don't yet see where \verb!C! and \verb!D! came from. In this case we take the unwinding of \verb!M(C,D)! and drop its latest patch (which is \verb!M(C,D)! itself) and place that at the beginning of our patch train: \begin{verbatim} C A M(A,M(C,D)) \end{verbatim} As we look at \verb!M( M(A,B), M(A,M(C,D)))!, we consider the unwindings of each of its subpatches: \begin{verbatim} C A A M(A,B) M(A,M(C,D)) \end{verbatim} As we did with \verb!M(A,M(C,D))!, we'll drop the first patch on the right and insert the first patch on the left. That moves us up to the two \verb!A!'s. Since these agree, we can use just one of them (they ``should'' agree). That leaves us with the \verb!C! which goes first. The catch is that things don't always turn out this easily. There is no guarantee that the two \verb!A!'s would come out at the same time, and if they didn't, we'd have to rearrange things until they did. Or if there was no way to rearrange things so that they would agree, we have to go on to plan B, which I will explain now. Consider the case of \verb!M( M(A,B), M(C,D))!. We can easily unwind the two subpatches \begin{verbatim} A C M(A,B) M(C,D) \end{verbatim} Now we need to reconcile the \verb!A! and \verb!C!. How do we do this? Well, as usual, the solution is to use the most wonderful Theorem~\ref{merge_thm}. In this case we have to use it in the reverse of how we used it when merging, since we know that \verb!A! and \verb!C! could either one be the \emph{last} patch applied before \verb!M(A,B)! or \verb!M(C,D)!. So we can find \verb!C'! using \[ A^{ -1} C \commute C' A'^{ -1} \] Giving an unwinding of \begin{verbatim} C' A M(A,B) M( M(A,B), M(C,D) ) \end{verbatim} There is a bit more complexity to the unwinding process (mostly having to do with cases where you have deeper nesting), but I think the general principles that are followed are pretty much included in the above discussion. \begin{code} unwind :: Patch -> [Patch] -- Recreates a patch history in reverse. unwind (Merger _ _ _ unwindings _ _) = unwindings unwind p = [p]; true_unwind :: Patch -> [Patch] -- Recreates a patch history in reverse. true_unwind p@(Merger _ _ _ _ p1 p2) = case (unwind p1, unwind p2) of (_:p1s,_:p2s) -> p : p1 : reconcile_unwindings p p1s p2s _ -> impossible true_unwind _ = impossible reconcile_unwindings :: Patch -> [Patch] -> [Patch] -> [Patch] reconcile_unwindings _ [] p2s = p2s reconcile_unwindings _ p1s [] = p1s reconcile_unwindings p (p1:p1s) p2s = case [(p1s', p2s')| p1s' <- all_head_permutations (p1:p1s), p2s' <- all_head_permutations p2s, head p1s' `eq_patches` head p2s'] of ((p1':p1s', _:p2s'):_) -> p1' : reconcile_unwindings p p1s' p2s' [] -> case liftM reverse $ put_before p1 $ reverse p2s of Just p2s' -> p1 : reconcile_unwindings p p1s p2s' Nothing -> case liftM reverse $ put_before (head p2s) $ reverse (p1:p1s) of Just p1s' -> (head p2s) : reconcile_unwindings p p1s' (tail p2s) Nothing -> bugDoc $ text "in function reconcile_unwindings" $$ text "Original patch:" $$ showPatch p _ -> bug "in reconcile_unwindings" put_before :: Patch -> [Patch] -> Maybe [Patch] put_before p1 (p2:p2s) = case commute (invert p1,p2) of Nothing -> Nothing Just (p2',p1') -> case commute (p1,p2') of Nothing -> Nothing Just _ -> liftM (p2' :) $ put_before p1' p2s put_before _ [] = Just [] -- NOTE: all_head_permutations accepts a list of patches IN REVERSE -- ORDER!!! all_head_permutations :: [Patch] -> [[Patch]] all_head_permutations [] = [] all_head_permutations [p] = [[p]] all_head_permutations ps = reverse $ map reverse $ nubBy (eq_list eq_patches) $ tail_permutations_normal_order $ reverse ps tail_permutations_normal_order :: [Patch] -> [[Patch]] tail_permutations_normal_order [] = [] tail_permutations_normal_order (p1:ps) = case swap_to_back_n_o (p1:ps) of Just ps' -> ps' : map (p1:) (tail_permutations_normal_order ps) Nothing -> map (p1:) (tail_permutations_normal_order ps) swap_to_back_n_o :: [Patch] -> Maybe [Patch] swap_to_back_n_o [] = Just [] swap_to_back_n_o [p] = Just [p] swap_to_back_n_o (p1:p2:ps) = case commute (p2,p1) of Just (p1',p2') -> case swap_to_back_n_o (p1':ps) of Just ps' -> Just $ p2': ps' Nothing -> Nothing Nothing -> Nothing \end{code} It can sometimes be handy to have a canonical representation of a given patch. We achieve this by defining a canonical form for each patch type, and a function ``{\tt canonize}'' which takes a patch and puts it into canonical form. This routine is used by the diff function to create an optimal patch (based on an LCS algorithm) from a simple hunk describing the old and new version of a file. \begin{code} canonize :: Patch -> Maybe Patch canonize (NamedP n d p) = case canonize p of Just p' -> Just $ NamedP n d p' Nothing -> Nothing canonize (Merger True g _ _ p1 p2) = liftM2 (merger g) (canonize p1) (canonize p2) canonize (Merger False g _ _ p1 p2) = invert `liftM` liftM2 (merger g) (canonize p1) (canonize p2) canonize (Split ps) = Just $ Split $ sort_coalesce_composite ps canonize (ComP ps) = canonizeComposite ps canonize (FP f (Hunk line old new)) = canonizeHunk f line old new canonize p@(FP _ (Binary old new)) = if old /= new then Just p else Just null_patch canonize p = Just p \end{code} Note that canonization may fail, if the patch is internally inconsistent. A simpler, faster (and more generally useful) cousin of canonize is the coalescing function. This takes two sequential patches, and tries to turn them into one patch. This function is used to deal with ``split'' patches, which are created when the commutation of a primitive patch can only be represented by a composite patch. In this case the resulting composite patch must return to the original primitive patch when the commutation is reversed, which a split patch accomplishes by trying to coalesce its contents each time it is commuted. \begin{code} coalesce :: (Patch, Patch) -> Maybe Patch coalesce (FP f1 _, FP f2 _) | f1 /= f2 = Nothing coalesce (p2, p1) | p2 `eq_patches` invert p1 = Just null_patch coalesce (FP f1 p1, FP _ p2) = coalesceFilePatch f1 (p1, p2) -- f1 = f2 coalesce (ComP [], p) = Just p coalesce (p, ComP []) = Just p coalesce (Split [], p) = Just p coalesce (p, Split []) = Just p coalesce (Move a b, Move b' a') | a == a' = Just $ Move b' b coalesce (Move a b, FP f AddFile) | f == a = Just $ FP b AddFile coalesce (FP f RmFile, Move a b) | b == f = Just $ FP a RmFile coalesce (ChangePref p f1 t1, ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 coalesce _ = Nothing \end{code} \subsection{File patches} A file patch is a patch which only modifies a single file. There are some rules which can be made about file patches in general, which makes them a handy class. For example, commutation of two filepatches is trivial if they modify different files. There is an exception when one of the files has a name ending with ``-conflict'', in which case it may not commute with a file having the same name, but without the ``-conflict.'' If they happen to modify the same file, we'll have to check whether or not they commute. \begin{code} commute_filepatches :: (Patch, Patch) -> Perhaps (Patch, Patch) commute_filepatches (FP f1 p1, FP f2 p2) | f1 == f2 = commuteFP f1 (p1, p2) commute_filepatches _ = Unknown commuteFP :: FileName -> (FilePatchType, FilePatchType) -> Perhaps (Patch, Patch) commuteFP f (Hunk line1 old1 new1, Hunk line2 old2 new2) = seq f $ toPerhaps $ commuteHunk f (Hunk line1 old1 new1, Hunk line2 old2 new2) commuteFP f (TokReplace t o n, Hunk line2 old2 new2) = seq f $ case try_tok_replace t o n old2 of Nothing -> Failed Just old2' -> case try_tok_replace t o n new2 of Nothing -> Failed Just new2' -> Succeeded (FP f $ Hunk line2 old2' new2', FP f $ TokReplace t o n) commuteFP f (TokReplace t o n, TokReplace t2 o2 n2) | seq f $ t /= t2 = Failed | o == o2 = Failed | n == o2 = Failed | o == n2 = Failed | n == n2 = Failed | otherwise = Succeeded (FP f $ TokReplace t2 o2 n2, FP f $ TokReplace t o n) commuteFP _ _ = Unknown \end{code} \begin{code} coalesceFilePatch :: FileName -> (FilePatchType, FilePatchType) -> Maybe Patch coalesceFilePatch f (Hunk line1 old1 new1, Hunk line2 old2 new2) = coalesceHunk f line1 old1 new1 line2 old2 new2 coalesceFilePatch _ (AddFile, RmFile) = Just (ComP []) coalesceFilePatch f (TokReplace t1 o1 n1, TokReplace t2 o2 n2) | t1 == t2 && n2 == o1 = Just $ FP f $ TokReplace t1 o2 n1 coalesceFilePatch f (Binary m n, Binary o m') | m == m' = Just $ FP f $ Binary o n coalesceFilePatch _ _ = Nothing \end{code} There is another handy function, which primarily affects file patches (although it can also affect other patches, such as rename patches or dir add/remove patches), which is the submerge-in-directory function. This function changes the patch to act on a patch within a subdirectory rather than in the current directory, and is useful when performing the recursive diff. \begin{code} submerge_in_dir :: FilePath -> Patch -> Patch submerge_in_dir dir (Move f f') = Move (subfn dir f) (subfn dir f') submerge_in_dir dir (DP d dp) = DP (subfn dir d) dp submerge_in_dir dir (FP f fp) = FP (subfn dir f) fp submerge_in_dir dir (Split ps) = Split $ map (submerge_in_dir $! dir) ps submerge_in_dir dir (ComP ps) = ComP $ map (submerge_in_dir $! dir) ps submerge_in_dir dir (NamedP n d p) = NamedP n d (submerge_in_dir dir p) submerge_in_dir dir (Merger b g undo unwindings p1 p2) = Merger b g (sub undo) (map sub unwindings) (sub p1) (sub p2) where sub = submerge_in_dir $! dir submerge_in_dir dir (Conflictor inv a b) = Conflictor inv (sub a) (sub b) where sub = map (submerge_in_dir dir) submerge_in_dir _ p@(ChangePref _ _ _) = p subfn :: String -> FileName -> FileName subfn dir f = seq dir $ seq f $ fp2fn $ n_fn $ dir++"/"++ fn2fp (norm_path f) \end{code} \subsection{Hunks} The hunk is the simplest patch that has a commuting pattern in which the commuted patches differ from the originals (rather than simple success or failure). This makes commuting or merging two hunks a tad tedious. \begin{code} commuteHunk :: FileName -> (FilePatchType, FilePatchType) -> Maybe (Patch, Patch) commuteHunk f (Hunk line2 old2 new2, Hunk line1 old1 new1) | seq f $ line1 + lengthnew1 < line2 = Just (FP f (Hunk line1 old1 new1), FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) | line2 + lengthold2 < line1 = Just (FP f (Hunk (line1+ lengthnew2 - lengthold2) old1 new1), FP f (Hunk line2 old2 new2)) | line1 + lengthnew1 == line2 && lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = Just (FP f (Hunk line1 old1 new1), FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) | line2 + lengthold2 == line1 && lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = Just (FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1), FP f (Hunk line2 old2 new2)) | otherwise = seq f Nothing where lengthnew1 = length new1 lengthnew2 = length new2 lengthold1 = length old1 lengthold2 = length old2 commuteHunk _ _ = impossible \end{code} Hunks, of course, can be coalesced if they have any overlap. Note that coalesce code doesn't check if the two patches are conflicting. If you are coalescing two conflicting hunks, you've already got a bug somewhere. \begin{code} coalesceHunk :: FileName -> Int -> [PackedString] -> [PackedString] -> Int -> [PackedString] -> [PackedString] -> Maybe Patch coalesceHunk f line1 old1 new1 line2 old2 new2 = docoalesceHunk f line1 old1 new1 line2 old2 new2 --case commute (FP f (Hunk line1 old1 new1), -- FP f (Hunk line2 old2 new2)) of --Just (p1,p2) -> Nothing -- They don't coalesce --Nothing -> -- docoalesceHunk f line1 old1 new1 line2 old2 new2 docoalesceHunk :: FileName -> Int -> [PackedString] -> [PackedString] -> Int -> [PackedString] -> [PackedString] -> Maybe Patch docoalesceHunk f line1 old1 new1 line2 old2 new2 | line1 == line2 && lengthold1 < lengthnew2 = if take lengthold1 new2 /= old1 then Nothing else case drop lengthold1 new2 of extranew -> Just (FP f (Hunk line1 old2 (new1 ++ extranew))) | line1 == line2 && lengthold1 > lengthnew2 = if take lengthnew2 old1 /= new2 then Nothing else case drop lengthnew2 old1 of extraold -> Just (FP f (Hunk line1 (old2 ++ extraold) new1)) | line1 == line2 = if new2 == old1 then Just (FP f (Hunk line1 old2 new1)) else Nothing | line1 < line2 && lengthold1 >= line2 - line1 = case take (line2 - line1) old1 of extra-> docoalesceHunk f line1 old1 new1 line1 (extra ++ old2) (extra ++ new2) | line1 > line2 && lengthnew2 >= line1 - line2 = case take (line1 - line2) new2 of extra-> docoalesceHunk f line2 (extra ++ old1) (extra ++ new1) line2 old2 new2 | otherwise = Nothing where lengthold1 = length old1 lengthnew2 = length new2 \end{code} One of the most important pieces of code is the canonization of a hunk, which is where the ``diff'' algorithm is performed. This algorithm begins with chopping off the identical beginnings and endings of the old and new hunks. This isn't strictly necessary, but is a good idea, since this process is $O(n)$, while the primary diff algorithm is something considerably more painful than that\ldots\ actually the head would be dealt with all right, but with more space complexity. I think it's more efficient to just chop the head and tail off first. \begin{code} canonizeHunk :: FileName -> Int -> [PackedString] -> [PackedString] -> Maybe Patch canonizeHunk _ _ o n | o == n = Nothing canonizeHunk f line old new | null old || null new = Just $ FP f $ Hunk line old new canonizeHunk f line old new = case make_holey f line $ getChanges old new of [p] -> Just p [] -> Nothing ps -> Just $ join_patches ps make_holey :: FileName -> Int -> [(Int,[PackedString], [PackedString])] -> [Patch] make_holey f line changes = map (\ (l,o,n) -> FP f (Hunk (l+line) o n)) changes applyBinary :: PackedString -> PackedString -> FileContents -> Maybe FileContents applyBinary o n (_,Just c) | c == o = Just (linesPS n, Just n) applyBinary o n (ls,Nothing) | unlinesPS ls == o = Just (linesPS n, Just n) applyBinary _ _ _ = Nothing \end{code} \begin{code} try_tok_replace :: String -> String -> String -> [PackedString] -> Maybe [PackedString] try_tok_replace t o n mss = mapM (liftM concatPS . try_tok_internal t (packString o) (packString n)) mss try_tok_internal :: String -> PackedString -> PackedString -> PackedString -> Maybe [PackedString] try_tok_internal _ o n s | isNothing (substrPS o s) && isNothing (substrPS n s) = Just [s] try_tok_internal t o n s = case breakPS (regChars t) s of (before,s') -> case breakPS (not . regChars t) s' of (tok,after) -> case try_tok_internal t o n after of Nothing -> Nothing Just rest -> if tok == o then Just $ before : n : rest else if tok == n then Nothing else Just $ before : tok : rest \end{code} \section{Conflicts} There are a couple of simple constraints on the routine which determines how to resolve two conflicting patches (which is called `glump'). These must be satisfied in order that the result of a series of merges is always independent of their order. Firstly, the output of glump cannot change when the order of the two conflicting patches is switched. If it did, then commuting the merger could change the resulting patch, which would be bad. Secondly, the result of the merge of three (or more) conflicting patches cannot depend on the order in which the merges are performed. The conflict resolution code (glump) begins by ``unravelling'' the merger into a set of sequences of patches. Each sequence of patches corresponds to one non-conflicted patch that got merged together with the others. The result of the unravelling of a series of merges must obviously be independent of the order in which those merges are performed. This unravelling code (which uses the unwind code mentioned above) uses probably the second most complicated algorithm. Fortunately, if we can successfully unravel the merger, almost any function of the unravelled merger satisfies the two constraints mentioned above that the conflict resolution code must satisfy. \begin{code} unravel :: Patch -> [[Patch]] resolve_conflicts :: Patch -> [[Patch]] resolve_conflicts patch = rcs [] $ reverse $ flatten_to_primitives patch where rcs a [] = seq a [] rcs passedby (p@(Merger True "0.0" _ _ _ _):ps) = seq passedby $ case commute_no_merger (join_patches passedby,p) of Just (p'@(Merger True "0.0" _ _ p1 p2),_) -> (nubBy eq_patches $ glump "0.9" p1 p2 : map join_patches (unravel p')) : rcs (p : passedby) ps Nothing -> rcs (p : passedby) ps _ -> impossible rcs passedby (p:ps) = seq passedby $ rcs (p : passedby) ps \end{code} \begin{code} unravel p = nubAdjBy (eq_list eq_patches) $ sortBy (compare_list compare_patches) $ map (sort_coalesce_composite) $ map (concatMap (flatten.merger_equivalent)) $ get_supers $ map reverse $ new_ur p $ unwind p get_supers :: [[Patch]] -> [[Patch]] get_supers (x:xs) = case filter (not.(x `is_superpatch_of`)) xs of xs' -> if or $ map (`is_superpatch_of` x) xs' then get_supers xs' else x : get_supers xs' get_supers [] = [] is_superpatch_of :: [Patch] -> [Patch] -> Bool x `is_superpatch_of` y | length y > length x = False x `is_superpatch_of` y = x `iso` y where iso :: [Patch] -> [Patch] -> Bool _ `iso` [] = True [] `iso` _ = False a `iso` (b:bs) = case filter ((`eq_patches` b) . head) $ head_permutations_normal_order a of ((_:as):_) -> as `iso` bs [] -> False _ -> bug "bug in is_superpatch_of" head_permutations_normal_order :: [Patch] -> [[Patch]] head_permutations_normal_order [] = [] head_permutations_normal_order (p:ps) = (p:ps) : catMaybes (map (swapfirst.(p:)) $ head_permutations_normal_order ps) swapfirst :: [Patch] -> Maybe [Patch] swapfirst (p1:p2:ps) = case commute (p2,p1) of Just (p1',p2') -> Just $ p2':p1':ps Nothing -> Nothing swapfirst _ = Nothing merger :: String -> Patch -> Patch -> Patch merger g p1 p2 = Merger True g undoit unwindings p1 p2 where fake_p = Merger True g null_patch [] p1 p2 unwindings = true_unwind fake_p p = Merger True g null_patch unwindings p1 p2 undoit = case (is_merger p1, is_merger p2) of (True ,True ) -> join_patches $ map invert $ tail $ unwind p (False,False) -> invert p1 (True ,False) -> unglump p1 (False,True ) -> join_patches $ [invert p1, merger_undo p2] unglump (Merger True g' _ _ p1' p2') = invert $ glump g' p1' p2' unglump _ = impossible \end{code} \begin{code} only_hunks :: [[Patch]] -> Bool only_hunks [] = False only_hunks pss = fn2fp f /= "" && all oh pss where f = get_a_filename pss oh (FP f' (Hunk _ _ _):ps) = f == f' && oh ps oh (_:_) = False oh [] = True apply_hunks :: [Maybe PackedString] -> [Patch] -> [Maybe PackedString] apply_hunks ms (FP _ (Hunk l o n):ps) = apply_hunks (rls l ms) ps where rls 1 mls = map Just n ++ drop (length o) mls rls i (ml:mls) = ml : rls (i-1) mls rls _ [] = bug "rls in apply_hunks" apply_hunks ms [] = ms apply_hunks _ (_:_) = impossible get_hunks_old :: [Maybe PackedString] -> [Patch] -> [Maybe PackedString] get_hunks_old mls ps = apply_hunks (apply_hunks mls ps) (map invert $ reverse ps) get_old :: [Maybe PackedString] -> [[Patch]] -> [Maybe PackedString] get_old mls (ps:pss) = get_old (get_hunks_old mls ps) pss get_old mls [] = mls get_hunks_new :: [Maybe PackedString] -> [Patch] -> [Maybe PackedString] get_hunks_new mls ps = apply_hunks mls ps get_hunkline :: [[Maybe PackedString]] -> Int get_hunkline = ghl 1 where ghl :: Int -> [[Maybe PackedString]] -> Int ghl n pps = if any (isJust . head) pps then n else ghl (n+1) $ map tail pps get_a_filename :: [[Patch]] -> FileName get_a_filename ((FP f _:_):_) = f get_a_filename _ = fp2fn "" make_chunk :: Int -> [Maybe PackedString] -> [PackedString] make_chunk n mls = pull_chunk $ drop (n-1) mls where pull_chunk (Just l:mls') = l : pull_chunk mls' pull_chunk (Nothing:_) = [] pull_chunk [] = bug "should this be [] in pull_chunk?" mangle_unravelled_hunks :: [[Patch]] -> Patch --mangle_unravelled_hunks [[h1],[h2]] = Deal with simple cases handily? mangle_unravelled_hunks pss = if null nchs then bug "mangle_unravelled_hunks" else FP filename (Hunk l old new) where oldf = get_old (repeat Nothing) pss newfs = map (get_hunks_new oldf) pss l = get_hunkline $ oldf : newfs nchs = sort $ map (make_chunk l) newfs filename = get_a_filename pss old = make_chunk l oldf new = [top] ++ concat (intersperse [middle] nchs) ++ [bottom] top = packString $ "v v v v v v v" ++ eol_c middle = packString $ "*************" ++ eol_c bottom = packString $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c eol_c = if any (\ps -> not (nullPS ps) && lastPS ps == '\r') old then "\r" else "" \end{code} \begin{code} glump :: String -> Patch -> Patch -> Patch glump "0.1" p1 p2 = case unravel $ merger "0.1" p1 p2 of (ps:_) -> join_patches ps [] -> impossible glump "a" p1 p2 = glump "0.9" p1 p2 glump "0.0" _ _ = ComP [] glump "0.9" p1 p2 = case unravel $ merger "0.9" p1 p2 of pss -> if only_hunks pss then mangle_unravelled_hunks pss else join_patches $ head pss glump _ _ _ = impossible \end{code} \begin{code} merger_equivalent :: Patch -> Patch merger_equivalent p@(Merger True g _ _ p1 p2) = join_patches $ sort_coalesce_composite ((flatten $ merger_equivalent $ merger_undo p)++ (flatten $ merger_equivalent $ glump g p1 p2)) merger_equivalent p@(Merger False _ _ _ _ _) = invert $ merger_equivalent $ invert p merger_equivalent (Split ps) = Split $ map merger_equivalent ps merger_equivalent (ComP ps) = ComP $ map merger_equivalent ps merger_equivalent (NamedP n d p) = NamedP n d $ merger_equivalent p merger_equivalent (Conflictor False a [_]) = merger_equivalent $ invert $ join_patches a merger_equivalent (Conflictor True a [_]) = merger_equivalent $ join_patches a merger_equivalent (Conflictor _ _ _) = null_patch merger_equivalent p = p modernize_patch :: Patch -> Patch modernize_patch p@(Merger _ "0.9" _ _ _ _) = merger_equivalent p modernize_patch (NamedP n d p) = NamedP n d $ modernize_patch p modernize_patch (ComP ps) = ComP $ map modernize_patch ps modernize_patch (Split ps) = Split $ map modernize_patch ps modernize_patch p = p \end{code} \begin{code} new_ur :: Patch -> [Patch] -> [[Patch]] new_ur p (Merger _ _ _ _ p1 p2 : ps) = case filter ((`eq_patches` p1) . head) $ all_head_permutations ps of ((_:ps'):_) -> new_ur p (p1:ps') ++ new_ur p (p2:ps') _ -> bugDoc $ text "in function new_ur" $$ text "Original patch:" $$ showPatch p $$ text "Unwound:" $$ vcat (map showPatch $ unwind p) new_ur op ps = case filter (is_merger.head) $ all_head_permutations ps of [] -> [ps] (ps':_) -> new_ur op ps' \end{code} \begin{code} -- We define equality here, since it requires commutation in the case of -- Conflictors. eq_patches_base :: Bool -> Patch -> Patch -> Bool eq_patches_base really (NamedP n1 _ p1) (NamedP n2 _ p2) | really = n1 == n2 && eq_patches_base really p1 p2 | otherwise = n1 == n2 eq_patches_base _ (Move a b) (Move c d) = a == c && b == d eq_patches_base _ (DP d1 p1) (DP d2 p2) = d1 == d2 && p1 == p2 eq_patches_base _ (FP f1 fp1) (FP f2 fp2) = f1 == f2 && fp1 == fp2 eq_patches_base really (Split ps1) (Split ps2) = eq_list (eq_patches_base really) ps1 ps2 eq_patches_base really (ComP ps1) (ComP ps2) = eq_list (eq_patches_base really) ps1 ps2 eq_patches_base really (Merger b1 g1 _ _ p1a p1b) (Merger b2 g2 _ _ p2a p2b) = b1 == b2 && eq_patches_base really p1a p2a && eq_patches_base really p1b p2b && g1 == g2 eq_patches_base _ (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) = c1 == c2 && b1 == b2 && a1 == a2 eq_patches_base _ (Conflictor i a b) (Conflictor i' a' b') = i == i' && a `same_patches` a' && b `same_last_eq` b' eq_patches_base _ _ _ = False eq_patches :: Patch -> Patch -> Bool eq_patches = eq_patches_base False really_eq_patches :: Patch -> Patch -> Bool really_eq_patches = eq_patches_base True merge_orders :: Ordering -> Ordering -> Ordering merge_orders EQ x = x merge_orders LT _ = LT merge_orders GT _ = GT compare_patches :: Patch -> Patch -> Ordering compare_patches (NamedP n1 _ _) (NamedP n2 _ _) = compare n1 n2 compare_patches (NamedP _ _ _) _ = LT compare_patches _ (NamedP _ _ _) = GT compare_patches (Move a b) (Move c d) = compare (a, b) (c, d) compare_patches (Move _ _) _ = LT compare_patches _ (Move _ _) = GT compare_patches (DP d1 p1) (DP d2 p2) = compare (d1, p1) (d2, p2) compare_patches (DP _ _) _ = LT compare_patches _ (DP _ _) = GT compare_patches (FP f1 fp1) (FP f2 fp2) = compare (f1, fp1) (f2, fp2) compare_patches (FP _ _) _ = LT compare_patches _ (FP _ _) = GT compare_patches (Split ps1) (Split ps2) = compare_list compare_patches ps1 ps2 compare_patches (Split _) _ = LT compare_patches _ (Split _) = GT compare_patches (ComP ps1) (ComP ps2) = compare_list compare_patches ps1 ps2 compare_patches (ComP _) _ = LT compare_patches _ (ComP _) = GT compare_patches (Merger b1 g1 _ _ p1a p1b) (Merger b2 g2 _ _ p2a p2b) | b1 == b2 && p1a `eq_patches` p2a && p1b `eq_patches` p2b && g1 == g2 = EQ compare_patches (Merger b1 g1 p1 ps1 p1a p1b) (Merger b2 g2 p2 ps2 p2a p2b) = compare (b1, g1) (b2, g2) `merge_orders` compare_patches p1 p2 `merge_orders` compare_list compare_patches ps1 ps2 `merge_orders` compare_patches p1a p2a `merge_orders` compare_patches p1b p2b compare_patches (Merger _ _ _ _ _ _) _ = LT compare_patches _ (Merger _ _ _ _ _ _) = GT compare_patches (Conflictor True a b) (Conflictor True a' b') | la > la' = LT | la < la' = GT | lb < lb' = GT | lb > lb' = LT | otherwise = case compare_patches (join_patches a) (join_patches a') of LT -> LT GT -> GT EQ -> compare_patches (join_patches b) (join_patches b') where la = length a la' = length a' lb = length b lb' = length b' compare_patches c1@(Conflictor False _ _) c2@(Conflictor False _ _) = compare_patches (invert c2) (invert c1) compare_patches (Conflictor True _ _) (Conflictor False _ _) = LT compare_patches (Conflictor False _ _) (Conflictor True _ _) = GT compare_patches (Conflictor _ _ _) _ = GT compare_patches _ (Conflictor _ _ _) = LT compare_patches (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) = compare (c1, b1, a1) (c2, b2, a2) eq_list :: (a -> a -> Bool) -> [a] -> [a] -> Bool eq_list _ [] [] = True eq_list f (x:xs) (y:ys) = f x y && eq_list f xs ys eq_list _ _ _ = False compare_list :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering compare_list _ [] [] = EQ compare_list _ [] _ = LT compare_list _ _ [] = GT compare_list f (x:xs) (y:ys) = f x y `merge_orders` compare_list f xs ys -- The following verifies that the two sequences are permutations of one -- another same_patches :: [Patch] -> [Patch] -> Bool same_patches a b | length a /= length b = False same_patches [] [] = True same_patches cs (bb:bs) = case filter ((eq_patches bb) .head) $ all_head_permutations cs of ((_:cs'):_) -> same_patches cs' bs _ -> False same_patches _ _ = impossible same_last_eq :: [Patch] -> [Patch] -> Bool same_last_eq [] [] = bug "Can't take same_last_eq of empty lists." same_last_eq a b = last a `eq_patches` last b && init a `same_patches` init b \end{code}