% 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; if not, write to the Free Software Foundation, % Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. \chapter{Theory of patches} \label{Patch} \newtheorem{thm}{Theorem} \newtheorem{dfn}{Definition} \section{Background} I think a little background on the author is in order. I am a physicist, and think like a physicist. The proofs and theorems given here are what I would call ``physicist'' proofs and theorems, which is to say that while the proofs may not be rigorous, they are practical, and the theorems are intended to give physical insight. It would be great to have a mathematician work on this, but I am not a mathematician, and don't care for math. From the beginning of this theory, which originated as the result of a series of email discussions with Tom Lord, I have looked at patches as being analagous to the operators of quantum mechanics. I include in this appendix footnotes explaining the theory of patches in terms of the theory of quantum mechanics. I know that for most people this won't help at all, but many of my friends (and as I write this all three of darcs' users) are physicists, and this will be helpful to them. To nonphysicists, perhaps it will provide some insight into how at least this physicist thinks. \section{Introduction} \begin{code} module Patch ( Patch, rmfile, addfile, rmdir, adddir, move, hunk, tokreplace, join_patches, namepatch, binary, patch_description, showContextPatch, showPatch, infopatch, changepref, is_similar, is_addfile, is_hunk, is_setpref, is_merger, hPutPatch, gzWritePatch, writePatch, invert, commute, merge, readPatchPS, prop_readPS_show, canonize, reorder, submerge_in_dir, flatten, flatten_to_primitives, apply_to_slurpy, patchname, unjoin_patches, apply_to_filepaths, apply_to_filepath, force_replace_slurpy, patch2patchinfo, LineMark(AddedLine, RemovedLine, AddedRemovedLine, None), MarkedUpFile, markup_file, empty_markedup_file, patch_summary, xml_summary, prop_inverse_composition, prop_commute_twice, prop_inverse_valid, prop_other_inverse_valid, prop_commute_equivalency, prop_commute_either_order, prop_commute_either_way, prop_merge_is_commutable_and_correct, prop_merge_is_swapable, prop_merge_valid, prop_glump_order_independent, prop_glump_seq_merge, prop_glump_seq_merge_valid, prop_glump_three_merge, prop_glump_three_merge_valid, prop_unravel_three_merge, prop_unravel_seq_merge, prop_unravel_order_independent, prop_simple_smart_merge_good_enough, prop_elegant_merge_good_enough, prop_patch_and_inverse_is_identity, quickmerge, check_patch, check_a_patch, prop_resolve_conflicts_valid, test_patch, adddeps, getdeps, list_conflicted_files, list_touched_files, resolve_conflicts, merger_equivalent, -- for Population DirMark(..), patchChanges, applyToPop, ) where import Prelude hiding ( pi ) import IO ( Handle, hPutStr, hPutChar ) import Debug.QuickCheck import Control.Monad ( liftM, liftM2, liftM3, liftM4, liftM5, when, unless, replicateM, mplus, msum ) import List ( sort, nub, intersperse ) import Data.Char ( ord ) import Lcs ( lcs ) import SlurpDirectory ( Slurpy, FileContents, get_slurp, get_filecontents, slurp_runfunc, slurp_move, slurp_removedir, slurp_removefile, slurp_addfile, slurp_adddir, slurp_modfile, ) import PatchInfo ( PatchInfo, patchinfo, invert_name, human_friendly, readPatchInfoPS, make_filename, ) import PatchCheck ( PatchCheck, Possibly(..), check_move, remove_dir, create_dir, is_valid, insert_line, file_empty, file_exists, delete_line, modify_file, create_file, remove_file, do_check, do_verbose_check, ) import RegChars ( regChars ) import FastPackedString ( PackedString, unpackPS, packString, splitPS, tailPS, lengthPS, dropPS, linesPS, headPS, nullPS, dropWhilePS, mylexPS, breakOnPS, takePS, concatPS, fromHex2PS, dropWhitePS, fromPS2Hex, readIntPS, hPutPS, nilPS, breakPS, unlinesPS, ) import Maybe ( catMaybes, isJust ) import RepoPrefs ( change_prefval ) import PopulationData ( Population(..), Info(..), PopTree(..), DirMark(..) ) import FileName ( FileName( ), fp2fn, fn2fp, fn2ps, fn2s, s2fn, ps2fn, norm_path ) import Zlib ( gzWriteToFile ) import Lock ( writeToFile ) import AntiMemo ( AntiMemo, antimemoize, readAntiMemo, (|++|) ) import Printer ( Printable, PrintableString, Printers, Doc, printableStringFromString, printableFromChar, printableStringFromPS, renderWith, simplePrinters, text, text', vcat, blueText, invisibleText, invisibleText', empty, ($$), (<+>), (<>), ) #include "impossible.h" data Patch = NamedP !PatchInfo ![PatchInfo] !Patch | Move !FileName !FileName | DP !FileName !DirPatchType | FP !FileName !FilePatchType | Split [Patch] | ComP [Patch] | Merger !Bool !String Patch [Patch] Patch Patch | ChangePref !String !String !String deriving (Ord) instance Eq Patch where (NamedP n1 d1 p1) == (NamedP n2 d2 p2) = n1 == n2 && d1 == d2 && p1 == p2 (Move a b) == (Move c d) = a == c && b == d (DP d1 p1) == (DP d2 p2) = d1 == d2 && p1 == p2 (FP f1 fp1) == (FP f2 fp2) = f1 == f2 && fp1 == fp2 (Split ps1) == (Split ps2) = ps1 == ps2 (ComP ps1) == (ComP ps2) = ps1 == ps2 (Merger b1 g1 _ _ p1a p1b) == (Merger b2 g2 _ _ p2a p2b) = b1 == b2 && p1a == p2a && p1b == p2b && g1 == g2 (ChangePref a1 b1 c1) == (ChangePref a2 b2 c2) = c1 == c2 && b1 == b2 && a1 == a2 _ == _ = False instance Arbitrary Patch where arbitrary = sized arbpatch coarbitrary p = coarbitrary (show p) data FilePatchType = RmFile | AddFile | Hunk !Int (AntiMemo [PackedString]) (AntiMemo [PackedString]) | TokReplace !String !String !String | Binary PackedString PackedString deriving (Eq,Ord) data DirPatchType = RmDir | AddDir deriving (Eq,Ord) fn2d :: Printable a => FileName -> Doc a fn2d f = text $ printableStringFromString $ fn2s f \end{code} \begin{code} addfile :: FilePath -> Patch rmfile :: FilePath -> Patch adddir :: FilePath -> Patch rmdir :: FilePath -> Patch move :: FilePath -> FilePath -> Patch changepref :: String -> String -> String -> Patch hunk :: FilePath -> Int -> AntiMemo [PackedString] -> AntiMemo [PackedString] -> Patch tokreplace :: FilePath -> String -> String -> String -> Patch binary :: FilePath -> PackedString -> PackedString -> Patch join_patches :: [Patch] -> Patch unjoin_patches :: Patch -> Maybe [Patch] namepatch :: String -> String -> String -> [String] -> Patch -> Patch infopatch :: PatchInfo -> Patch -> Patch adddeps :: Patch -> [PatchInfo] -> Patch getdeps :: Patch -> [PatchInfo] evalargs :: (a -> b -> c) -> a -> b -> c evalargs f x y = (f $! x) $! y addfile f = FP (fp2fn $ n_fn f) AddFile rmfile f = FP (fp2fn $ n_fn f) RmFile adddir d = DP (fp2fn $ n_fn d) AddDir rmdir d = DP (fp2fn $ n_fn d) RmDir move f f' = Move (fp2fn $ n_fn f) (fp2fn $ n_fn f') changepref p f t = ChangePref p f t hunk f line old new = evalargs FP (fp2fn $ n_fn f) (Hunk line old new) tokreplace f tokchars old new = evalargs FP (fp2fn $ n_fn f) (TokReplace tokchars old new) binary f old new = FP (fp2fn $! n_fn f) $ Binary old new join_patches ps = ComP $! ps unjoin_patches (ComP ps) = Just ps unjoin_patches _ = Nothing namepatch date name author desc p = NamedP (patchinfo date name author desc) [] p infopatch pi p = NamedP pi [] p adddeps (NamedP pi ds p) ds' = NamedP pi (ds++ds') p adddeps _ _ = bug "can't adddeps to anything but named patch" getdeps (NamedP _ ds _) = ds getdeps _ = bug "can't getdeps on anything but named patch" patch2patchinfo :: Patch -> Maybe PatchInfo patch2patchinfo (NamedP i _ _) = Just i patch2patchinfo _ = Nothing patchname :: Patch -> Maybe String patchname (NamedP i _ _) = Just $ make_filename i patchname _ = Nothing patch_description :: Patch -> String patch_description p = case patch2patchinfo p of Nothing -> show p Just pi -> "\n" ++ human_friendly pi \end{code} \begin{code} hunkgen :: Gen Patch hunkgen = do i <- frequency [(1,choose (0,5)),(1,choose (0,35)), (2,return 0),(3,return 1),(2,return 2),(1,return 3)] j <- frequency [(1,choose (0,5)),(1,choose (0,35)), (2,return 0),(3,return 1),(2,return 2),(1,return 3)] if i == 0 && j == 0 then hunkgen else liftM4 hunk filepathgen linenumgen (return `liftM` replicateM i filelinegen) (return `liftM` replicateM j filelinegen) tokreplacegen :: Gen Patch tokreplacegen = do f <- filepathgen o <- tokengen n <- tokengen if o == n then return $ tokreplace f "A-Za-z" "old" "new" else return $ tokreplace f "A-Za-z_" o n twofilegen :: (FilePath -> FilePath -> Patch) -> Gen Patch twofilegen p = do n1 <- filepathgen n2 <- filepathgen if n1 /= n2 && (check_a_patch $ p n1 n2) then return $ p n1 n2 else twofilegen p chprefgen :: Gen Patch chprefgen = do f <- oneof [return "color", return "movie"] o <- tokengen n <- tokengen if o == n then return $ changepref f "old" "new" else return $ changepref f o n simplepatchgen :: Gen Patch simplepatchgen = frequency [(1,liftM addfile filepathgen), (1,liftM adddir filepathgen), (1,liftM3 binary filepathgen arbitrary arbitrary), (1,twofilegen move), (1,tokreplacegen), (1,chprefgen), (7,hunkgen) ] onepatchgen :: Gen Patch onepatchgen = oneof [simplepatchgen, liftM invert simplepatchgen] norecursgen :: Int -> Gen Patch norecursgen 0 = onepatchgen norecursgen n = oneof [onepatchgen,flatcompgen n] arbpatch :: Int -> Gen Patch arbpatch 0 = onepatchgen arbpatch n = frequency [(2,onepatchgen), -- (1,compgen n), (3,flatcompgen n), (1,mergegen n), (1,namedgen n), (1,depgen n), (1,onepatchgen) ] unempty :: Arbitrary a => Gen [a] unempty = do as <- arbitrary case as of [] -> unempty _ -> return as mergegen :: Int -> Gen Patch mergegen n = do p1 <- norecursgen len p2 <- norecursgen len if (check_a_patch $ join_patches [invert p1,p2]) && (check_a_patch $ join_patches [invert p2,p1]) then case merge (p2,p1) of Just (p2',p1') -> if check_a_patch $ join_patches [p1',p2'] then return $ join_patches [p1',p2'] else return $ join_patches [addfile "Error_in_mergegen", addfile "Error_in_mergegen", p1,p2,p1',p2'] Nothing -> impossible else mergegen n where len = if n < 15 then n`div`3 else 3 namedgen :: Int -> Gen Patch namedgen n = liftM5 namepatch unempty unempty unempty arbitrary $ arbpatch (n-1) arbpi :: Gen PatchInfo arbpi = liftM4 patchinfo unempty unempty unempty unempty instance Arbitrary PatchInfo where arbitrary = arbpi coarbitrary pi = coarbitrary (show pi) instance Arbitrary PackedString where arbitrary = liftM packString arbitrary coarbitrary ps = coarbitrary (unpackPS ps) depgen :: Int -> Gen Patch depgen n = liftM3 NamedP arbitrary arbitrary $ arbpatch (n-1) plistgen :: Int -> Int -> Gen [Patch] plistgen s n | n <= 0 = return [] | otherwise = do next <- arbpatch s rest <- plistgen s (n-1) return $ next : rest compgen :: Int -> Gen Patch compgen n = do size <- choose (0,n) myp <- liftM join_patches $ plistgen size ((n+1) `div` (size+1)) -- here I assume we only want to consider valid patches... if check_a_patch myp then return myp else compgen n flatlistgen :: Int -> Gen [Patch] flatlistgen n = replicateM n onepatchgen flatcompgen :: Int -> Gen Patch flatcompgen n = do myp <- liftM (join_patches . regularize_patches) $ flatlistgen n if check_a_patch myp then return myp else flatcompgen n linenumgen :: Gen Int linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3), (3,liftM (\n->1+abs n) arbitrary) ] tokengen :: Gen String tokengen = oneof [return "hello", return "world", return "this", return "is", return "a", return "silly", return "token", return "test"] toklinegen :: Gen String toklinegen = liftM unwords $ replicateM 5 tokengen filelinegen :: Gen PackedString filelinegen = liftM packString $ frequency [(1,arbitrary),(5,toklinegen), (1,return ""), (1,return "{"), (1,return "}") ] filepathgen :: Gen String filepathgen = liftM fixpath badfpgen fixpath :: String -> String fixpath "" = "test" fixpath p = fpth p fpth :: String -> String fpth ('/':'/':cs) = fpth ('/':cs) fpth (c:cs) = c : fpth cs fpth [] = [] badfpgen :: Gen String badfpgen = frequency [(1,return "test"), (1,return "hello"), (1,return "world"), (1,arbitrary), (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ] instance Arbitrary Char where arbitrary = oneof $ map return (['a'..'z']++['A'..'Z']++['1'..'9']++['0','~','.',',','-','/']) coarbitrary c = coarbitrary (ord c) \end{code} \begin{code} n_fn :: FilePath -> FilePath n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f) \end{code} A patch describes a change to the tree. It could be either a primitive patch (such as a file add/remove, a directory rename, or a hunk replacement within a file), or a compostive patch describing many such changes. Every patch type must satisfy the conditions described in this appendix. The theory of patches is independent of the data which the patches manipulate, which is what makes it both powerful and useful, as it provides a framework upon which one can build a revision control system in a sane manner. Although in a sense, the defining property of any patch is that it can be applied to a certain tree, and thus make a certain change, this change does not wholly define the patch. A patch is defined by a \emph{representation}, together with a set of rules for how it behaves (which it has in common with its patch type). The \emph{representation} of a patch defines what change that particular patch makes, and must be defined in the context of a specific tree. The theory of patches is a theory of the many ways one can change the representation of a patch to place it in the context of a different tree. The patch itself is not changed, since it describes a single change, which must be the same regardless of its representation\footnote{For those comfortable with quantum mechanics, think of a patch as a quantum mechanical operator, and the representation as the basis set. The analogy breaks down pretty quickly, however, since an operator could be described in any complete basis set, while a patch modifying the file {\tt foo} can only be described in the rather small set of contexts which have a file {\tt foo} to be modified.}. So how does one define a tree, or the context of a patch? The simplest way to define a tree is as the result of a series of patches applied to the empty tree\footnote{This is very similar to the second-quantized picture, in which any state is seen as the result of a number of creation operators acting on the vacuum, and provides a similar set of simplifications---in particular, the exclusion principle is very elegantly enforced by the properties of the anti-hermitian fermion creation operators.}. Thus, the context of a patch consists of the set of patches that precede it. \begin{code} apply_to_filepaths :: Patch -> [FilePath] -> [FilePath] apply_to_filepaths pa fs = concatMap (atof pa) fs where atof (Move f f') fi | fn2fp f == fi = [fn2fp f'] atof (FP f RmFile) fi | fn2fp f == fi = [] atof (DP f RmDir) fi | fn2fp f == fi = [] atof (NamedP _ _ p) fi = atof p fi atof (ComP []) fi = [fi] atof (ComP (p:ps)) fi = case atof p fi of [fi'] -> atof (ComP ps) fi' _ -> [] atof (Split ps) fi = atof (ComP ps) fi atof p fi | is_merger p = atof (merger_equivalent p) fi atof _ fi = [fi] apply_to_filepath :: Patch -> FilePath -> FilePath apply_to_filepath (Move f f') fi | fn2fp f == fi = fn2fp f' apply_to_filepath (FP f RmFile) fi | fn2fp f == fi = "" apply_to_filepath (DP f RmDir) fi | fn2fp f == fi = "" apply_to_filepath (NamedP _ _ p) fi = apply_to_filepath p fi apply_to_filepath (ComP []) fi = fi apply_to_filepath (ComP (p:ps)) fi = apply_to_filepath (ComP ps) $ apply_to_filepath p fi apply_to_filepath (Split ps) fi = apply_to_filepath (ComP ps) fi apply_to_filepath p fi | is_merger p = apply_to_filepath (merger_equivalent p) fi apply_to_filepath _ fi = fi apply_to_slurpy :: Patch -> Slurpy -> Maybe Slurpy apply_to_slurpy (NamedP _ _ p) s = apply_to_slurpy p s apply_to_slurpy p s | is_merger p = apply_to_slurpy (merger_equivalent p) s apply_to_slurpy (Merger _ _ _ _ _ _) _ = impossible apply_to_slurpy (ComP []) s = Just s apply_to_slurpy (ComP (p:ps)) s = apply_to_slurpy p s >>= apply_to_slurpy (ComP ps) apply_to_slurpy (Split []) s = Just s apply_to_slurpy (Split (p:ps)) s = apply_to_slurpy p s >>= apply_to_slurpy (Split ps) apply_to_slurpy (FP f RmFile) s = slurp_removefile f s apply_to_slurpy (FP f AddFile) s = slurp_addfile f s apply_to_slurpy (FP f (Hunk line old new)) s = slurp_modfile f (applyHunkLines line old new) s apply_to_slurpy (FP f (TokReplace tcs old new)) s = slurp_modfile f (applyTokReplace tcs old new) s apply_to_slurpy (FP f (Binary o n)) s = slurp_modfile f (applyBinary o n) s apply_to_slurpy (DP d AddDir) s = slurp_adddir d s apply_to_slurpy (DP d RmDir) s = slurp_removedir d s apply_to_slurpy (Move f f') s = slurp_move f f' s apply_to_slurpy (ChangePref p f t) s = slurp_runfunc (change_prefval p f t) s force_replace_slurpy :: Patch -> Slurpy -> Maybe Slurpy force_replace_slurpy (FP f (TokReplace tcs old new)) s = slurp_modfile f (forceTokReplace tcs old new) s force_replace_slurpy _ _ = bug "Can only force_replace_slurpy on a replace." \end{code} \begin{code} check_patch :: Patch -> PatchCheck Bool check_a_patch :: Patch -> Bool check_a_patch p = (do_check $ check_patch p) && (do_check $ check_patch $ invert p) verbose_check_a_patch :: Patch -> Bool verbose_check_a_patch p = (do_verbose_check $ check_patch p) && (do_check $ check_patch $ invert p) check_patch (NamedP _ _ p) = check_patch p check_patch p | is_merger p = do check_patch $ merger_equivalent p check_patch (Merger _ _ _ _ _ _) = impossible check_patch (ComP []) = is_valid check_patch (ComP (p:ps)) = check_patch p >> check_patch (ComP ps) check_patch (Split []) = is_valid check_patch (Split (p:ps)) = check_patch p >> check_patch (Split ps) check_patch (FP f RmFile) = remove_file $ fn2fp f check_patch (FP f AddFile) = create_file $ fn2fp f check_patch (FP f (Hunk line old new)) = do file_exists $ fn2fp f mapM (delete_line (fn2fp f) line) (readAntiMemo old) mapM (insert_line (fn2fp f) line) (reverse $ readAntiMemo new) is_valid check_patch (FP f (TokReplace t old new)) = modify_file (fn2fp f) (try_tok_possibly t old new) -- note that the above isn't really a sure check, as it leaves PSomethings -- and PNothings which may have contained new... check_patch (FP f (Binary o n)) = do file_exists $ fn2fp f mapM (delete_line (fn2fp f) 1) (linesPS o) file_empty $ fn2fp f mapM (insert_line (fn2fp f) 1) (reverse $ linesPS n) is_valid check_patch (DP d AddDir) = create_dir $ fn2fp d check_patch (DP d RmDir) = remove_dir $ fn2fp d check_patch (Move f f') = check_move (fn2fp f) (fn2fp f') check_patch (ChangePref _ _ _) = return True regularize_patches :: [Patch] -> [Patch] regularize_patches patches = rpint [] patches where rpint ok_ps [] = ok_ps rpint ok_ps (p:ps) = if check_a_patch (join_patches $ p:ok_ps) then rpint (p:ok_ps) ps else rpint ok_ps ps \end{code} The simplest relationship between two patches is that of ``sequential'' patches, which means that the context of the second patch (the one on the left) consists of the first patch (on the right) plus the context of the first patch. The composition of two patches (which is also a patch) refers to the patch which is formed by first applying one and then the other. The composition of two patches, $P_1$ and $P_2$ is represented as $P_2P_1$, where $P_1$ is to be applied first, then $P_2$\footnote{This notation is inspired by the notation of matrix multiplication or the application of operators upon a Hilbert space. In the algebra of patches, there is multiplication (i.e.\ composition), which is associative but not commutative, but no addition or subtraction.} There is one other very useful relationship that two patches can have, which is to be parallel patches, which means that the two patches have an identical context (i.e.\ their representation applies to identical trees). This is represented by $P_1\parallel P_2$. Of course, two patches may also have no simple relationship to one another. In that case, if you want to do something with them, you'll have to manipulate them with respect to other patches until they are either in sequence or in parallel. The most fundamental and simple property of patches is that they must be invertible. The inverse of a patch is decribed by: $P^{ -1}$. In the darcs implementation, the inverse is required to be computable from knowledge of the patch only, without knowledge of its context, but that (although convenient) is not required by the theory of patches. \begin{dfn} The inverse of patch $P$ is $P^{ -1}$, which is the ``simplest'' patch for which the composition \( P^{ -1} P \) makes no changes to the tree. \end{dfn} Using this definition, it is trivial to prove the following theorem relating to the inverse of a composition of two patches. \begin{thm} The inverse of the composition of two patches is \[ (P_2 P_1)^{ -1} = P_1^{ -1} P_2^{ -1}. \] \end{thm} Moreover, it is possible to show that the right inverse of a patch is equal to its left inverse. In this respect, patches continue to be analagous to square matrices, and indeed the proofs relating to these properties of the inverse are entirely analagous to the proofs in the case of matrix multiplication. The compositions proofs can also readily be extended to the composition of more than two patches. \begin{code} prop_inverse_composition :: Patch -> Patch -> Bool prop_inverse_composition p1 p2 = invert (join_patches [p1,p2]) == join_patches [invert p2, invert p1] prop_inverse_valid :: Patch -> Bool prop_inverse_valid p1 = check_a_patch $ join_patches [invert p1,p1] prop_other_inverse_valid :: Patch -> Bool prop_other_inverse_valid p1 = check_a_patch $ join_patches [p1,invert p1] \end{code} \begin{code} invert :: Patch -> Patch invert (NamedP n d p) = NamedP (invert_name n) (map invert_name d) (invert p) invert (Merger b g undo unwindings p1 p2) = Merger (not b) g undo unwindings p1 p2 invert (FP f RmFile) = FP f AddFile invert (FP f AddFile) = FP f RmFile invert (FP f (Hunk line old new)) = FP f $ Hunk line new old invert (FP f (TokReplace t o n)) = FP f $ TokReplace t n o invert (FP f (Binary o n)) = FP f $ Binary n o invert (DP d RmDir) = DP d AddDir invert (DP d AddDir) = DP d RmDir invert (Move f f') = Move f' f invert (ChangePref p f t) = ChangePref p t f -- I need to see if there is a combined map-reverse, which I think would -- be more efficient. invert (ComP ps) = ComP (map invert (reverse ps)) invert (Split ps) = Split (map invert (reverse 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.} \begin{code} prop_commute_twice :: Patch -> Patch -> Property prop_commute_twice p1 p2 = (does_commute p1 p2) ==> (Just (p2,p1) == (commute (p2,p1) >>= commute)) does_commute :: Patch -> Patch -> Bool does_commute p1 p2 = commute (p2,p1) /= Nothing && (check_a_patch $ join_patches [p1,p2]) prop_commute_equivalency :: Patch -> Patch -> Property prop_commute_equivalency p1 p2 = (does_commute p1 p2) ==> case commute (p2,p1) of Just (p1',p2') -> check_a_patch $ join_patches [p1,p2,invert p1',invert p2'] _ -> impossible \end{code} %I should add that one using the inversion relationship of sequential %patches, one can avoid having to provide redundant definitions of %commutation. \begin{code} prop_commute_either_way :: Patch -> Patch -> Property prop_commute_either_way p1 p2 = does_commute p1 p2 ==> does_commute (invert p2) (invert p1) \end{code} % There is another interesting property which is that a commute's results % can't be affected by commuting another thingamabopper. \begin{code} prop_commute_either_order :: Patch -> Patch -> Patch -> Property prop_commute_either_order p1 p2 p3 = check_a_patch (join_patches [p1,p2,p3]) && does_commute p1 (join_patches [p2,p3]) && does_commute p2 p3 ==> case commute (p2,p1) of Nothing -> False Just (p1',p2') -> case commute (p3,p1') of Nothing -> False Just (_,p3') -> case commute (p3',p2') of Nothing -> False Just (_, p3'') -> case commute (p3,p2) of Nothing -> False Just (_,p3'a) -> case commute (p3'a,p1) of Just (_,p3''a) -> p3''a == p3'' Nothing -> False \end{code} \begin{code} is_in_directory :: FileName -> FileName -> Bool is_in_directory d f = iid (fn2s d) (fn2s 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 clever_commute :: ((Patch, Patch) -> Maybe (Patch, Patch)) -> (Patch, Patch) -> Maybe (Patch, Patch) clever_commute c (p1,p2) = c (p1,p2) `mplus` (case c (invert p2,invert p1) of Just (p1', p2') -> Just (invert p2', invert p1') Nothing -> Nothing) commute :: (Patch,Patch) -> Maybe (Patch,Patch) commute (p1, p2) -- Deal with common case quickly! | p1_modifies /= Nothing && p2_modifies /= Nothing && p1_modifies /= p2_modifies = Just (p2, p1) where p1_modifies = is_filepatch_merger p1 p2_modifies = is_filepatch_merger p2 commute (NamedP n1 d1 p1, NamedP n2 d2 p2) = if n2 `elem` d1 || n1 `elem` d2 then Nothing else do (p2', p1') <- commute (p1,p2) return (NamedP n2 d2 p2', NamedP n1 d1 p1') commute (ChangePref p f t,p1) = seq p1 $ Just (p1,ChangePref p f t) commute (p2,ChangePref p f t) = seq p2 $ Just (ChangePref p f t,p2) commute (Merger True g _ _ p1 p2, pA) | pA == p1 = Just (merger g p2 p1, p2) | pA == invert (merger g p2 p1) = Nothing commute (pA, Merger False g _ _ p1 p2) | invert pA == p1 = Just (invert p2, invert $ merger g p2 p1) | pA == merger g p2 p1 = Nothing commute (ComP [], p1) = seq p1 $ Just (p1, ComP []) commute (p2, ComP []) = seq p2 $ Just (ComP [], p2) commute (ComP (p:ps), p1) = do (p1', p') <- commute (p, p1) (p1'', ComP ps') <- commute (ComP ps, p1') return (p1'', ComP $ p':ps') commute (patch2, ComP patches) = 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') <- commute (p2, p) (ps', p2'') <- ccr (p2', ps) return (p':ps', p2'') commute (NamedP n2 d2 p2, p1) = do (p1',p2') <- commute (p2,p1) return (p1', NamedP n2 d2 p2') commute (p2, NamedP n1 d1 p1) = do (p1',p2') <- commute (p2,p1) return (NamedP n1 d1 p1', p2') commute (p2,p1) = seq p1 $ seq p2 $ msum [clever_commute commute_nameconflict (p2, p1), clever_commute commute_filedir (p2, p1), clever_commute commute_split (p2, p1), clever_commute commute_recursive_merger (p2, p1), clever_commute other_commute_recursive_merger (p2, p1)] commute_no_merger :: (Patch,Patch) -> Maybe (Patch,Patch) commute_no_merger (p1, p2) -- Deal with common case quickly! | p1_modifies /= Nothing && p2_modifies /= Nothing && p1_modifies /= p2_modifies = Just (p2, p1) where p1_modifies = is_filepatch_merger p1 p2_modifies = is_filepatch_merger p2 commute_no_merger (NamedP n1 d1 p1, NamedP n2 d2 p2) = if n2 `elem` d1 || n1 `elem` d2 then Nothing else do (p2', p1') <- commute (p1,p2) return (NamedP n2 d2 p2', NamedP n1 d1 p1') commute_no_merger (ChangePref p f t,p1) = seq p1 $ Just (p1,ChangePref p f t) commute_no_merger (p2,ChangePref p f t) = seq p2 $ Just (ChangePref p f t,p2) commute_no_merger (ComP [], p1) = Just (p1, ComP []) commute_no_merger (ComP (p:ps), p1) = do (p1', p') <- commute_no_merger (p, p1) (p1'', ComP ps') <- commute_no_merger (ComP ps, p1') return (p1'', ComP $ p':ps') commute_no_merger (patch2, ComP patches) = do (patches', patch2') <- ccr (patch2, reverse patches) return (ComP $ reverse patches', patch2') where ccr (p2, []) = return ([], p2) ccr (p2, p:ps) = do (p', p2') <- commute_no_merger (p2, p) (ps', p2'') <- ccr (p2', ps) return (p':ps', p2'') commute_no_merger (NamedP n2 d2 p2, p1) = do (p1',p2') <- commute_no_merger (p2,p1) return (p1', NamedP n2 d2 p2') commute_no_merger (p2, NamedP n1 d1 p1) = do (p1',p2') <- commute_no_merger (p2,p1) return (NamedP n1 d1 p1', p2') commute_no_merger (p2, p1) = seq p1 $ seq p2 $ msum [clever_commute commute_nameconflict (p2, p1), clever_commute commute_filedir (p2, p1), clever_commute commute_split (p2, p1), clever_commute commute_recursive_merger (p2, p1), clever_commute other_commute_recursive_merger (p2, p1)] 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 _ = Nothing \end{code} \begin{code} prop_patch_and_inverse_is_identity :: Patch -> Patch -> Property prop_patch_and_inverse_is_identity p1 p2 = (check_a_patch $ ComP [p1,p2]) && (commute (p2,p1) /= Nothing) ==> case commute (p2,p1) of Just (_,p2') -> case commute (p2',invert p1) of Nothing -> True -- This is a subtle distinction. Just (_,p2'') -> p2'' == p2 Nothing -> impossible commute_recursive_merger :: (Patch,Patch) -> Maybe (Patch,Patch) commute_recursive_merger (p@(Merger True g _ _ p1 p2), pA) = do (pA', _) <- commute (undo, pA) commute (invert undo, pA') (_,p1') <- commute (p1, pA') (_,p2') <- commute (p2, pA') (pA'',gl') <- commute (glump g p1 p2, pA') when (gl' /= glump g p1' p2') Nothing commute (pA',invert p1') commute (pA',invert p2') if p1' == p1 && p2' == p2 then return (pA'', p) else return (pA'', merger g p1' p2') where undo = merger_undo p commute_recursive_merger (_,b) = seq b Nothing other_commute_recursive_merger :: (Patch,Patch) -> Maybe (Patch,Patch) other_commute_recursive_merger (pA'', p_old@(Merger True g _ _ p1' p2')) = do (gl,pA') <- commute (pA'',glump g p1' p2') p1 <- liftM (invert.fst) $ commute (pA',invert p1') p2 <- liftM (invert.fst) $ commute (pA',invert p2') let p = if p1 == p1' && p2 == p2' then p_old else merger g p1 p2 when (gl /= glump g p1 p2) Nothing commute (p1,pA') commute (p2,pA') undo <- return $ merger_undo p (pA,_) <- commute (invert undo, pA') when (pA == p1) Nothing commute (undo,pA) return (p, pA) other_commute_recursive_merger (a,_) = seq a Nothing movedirfilename :: FileName -> FileName -> FileName -> FileName movedirfilename old new name = seq new $ s2fn $ mdfn (fn2s old) (fn2s new) (fn2s 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 (fn2s d1) (fn2s 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 = s2fn $ fn2s 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) -> Maybe (Patch,Patch) commute_nameconflict (Move d d', FP f2 AddFile) | d == f2 && d' == conflicted_name f2 = Just (FP d' AddFile, ComP []) | d' == conflicted_name f2 = Just (Split [Move f2 d', FP f2 AddFile], Move d f2) commute_nameconflict (Move d d', DP f2 AddDir) | d == f2 && d' == conflicted_name f2 = Just (DP d' AddDir, ComP []) | d' == conflicted_name f2 = Just (Split [Move f2 d', DP f2 AddDir], Move d f2) commute_nameconflict (Move d d', Move f f') | d' == conflicted_name d && d == f' = Just (Move f d', ComP []) | d' == conflicted_name f' && (movedirfilename f' f d) > f = Just (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 = Just (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 = Just (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 = Just (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 = Just (Split [Move b f, Split [Move a b, p2]], Move old b) --commute_nameconflict (Split [Move a b, p2], DP f AddDir) -- | b == conflicted_name a && f == a = Just (DP b AddDir, p2) --commute_nameconflict (Split [Move a b, p2], FP f AddFile) -- | b == conflicted_name a && f == a = Just (FP b AddFile, p2) --commute_nameconflict (Split [Move a b, p2], Move old f) -- | b == conflicted_name a && f == a = Just (Move old b, p2) commute_nameconflict (_,b) = seq b Nothing commute_filedir :: (Patch,Patch) -> Maybe (Patch,Patch) commute_filedir (FP f1 p1, FP f2 p2) = if f1 /= f2 then Just ( 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 Just ( DP d2 p2, DP d1 p1 ) else Nothing commute_filedir (DP d dp, FP f fp) = if not $ is_in_directory d f then Just (FP f fp, DP d dp) else Nothing commute_filedir (Move d d', FP f2 p2) | f2 == d' = Nothing | otherwise = Just (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 = Nothing | d2 == d' = Nothing | otherwise = Just (DP (movedirfilename d d' d2) p2, Move d d') commute_filedir (Move d d', Move f f') | f == d' || f' == d = Nothing | f == d || f' == d' = Nothing | d `is_superdir` f && f' `is_superdir` d' = Nothing | otherwise = Just (Move (movedirfilename d d' f) (movedirfilename d d' f'), Move (movedirfilename f' f d) (movedirfilename f' f d')) commute_filedir (p2,p1) = seq p2 $ seq p1 $ Nothing \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 sequenctial 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) quickmerge :: (Patch, Patch) -> Patch quickmerge (p2,p1) = case merge (p2,p1) of Just (p1',_) -> p1' Nothing -> impossible \end{code} \begin{code} prop_merge_is_commutable_and_correct :: Patch -> Patch -> Property prop_merge_is_commutable_and_correct p1 p2 = (check_a_patch $ ComP [invert p1,p2]) ==> case merge (p2,p1) of Nothing -> False Just (p2',p1') -> case commute (p2',p1') of Nothing -> False Just (_,p2'') -> p2'' == p2 && p1' == p1 prop_merge_is_swapable :: Patch -> Patch -> Property prop_merge_is_swapable p1 p2 = (check_a_patch $ ComP [invert p1,p2]) ==> case merge (p2,p1) of Nothing -> False Just (p2',p1') -> case commute (p2',p1') of Nothing -> False Just (p1'',p2'') -> case merge (p1,p2) of Nothing -> False Just (p1''', p2''') -> p1'' == p1''' && p2'' == p2''' prop_merge_valid :: Patch -> Patch -> Property prop_merge_valid p1 p2 = (check_a_patch $ ComP [invert p1,p2]) ==> case merge (p2,p1) of Nothing -> False Just (p2',p1') -> check_a_patch $ join_patches [invert p1,p2,invert p2,p1',p2'] \end{code} \section{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} prop_simple_smart_merge_good_enough :: Patch -> Patch -> Property prop_simple_smart_merge_good_enough p1 p2 = (check_a_patch $ ComP [invert p1,p2]) ==> smart_merge (p2,p1) == simple_smart_merge (p2,p1) smart_merge :: (Patch, Patch) -> Maybe (Patch, Patch) smart_merge (p1,p2) = case simple_smart_merge (p1,p2) of Nothing -> Nothing Just (p1'a,p2a) -> case simple_smart_merge (p2,p1) >>= commute of Nothing -> Nothing Just (p1'b, p2b) -> if p1'a == p1'b && p2a == p2b && p2a == p2 then Just (p1'a, p2) else Nothing simple_smart_merge :: (Patch, Patch) -> Maybe (Patch, Patch) simple_smart_merge (p1, p2) = case commute (p1, invert p2) of Just (_,p1') -> case commute (p1', p2) of Just (_, p1o) -> if p1o == p1 then Just (p1', p2) else Nothing Nothing -> Nothing Nothing -> Nothing prop_elegant_merge_good_enough :: Patch -> Patch -> Property prop_elegant_merge_good_enough p1 p2 = (check_a_patch $ ComP [invert p1,p2]) ==> (fst `liftM` smart_merge (p2,p1)) == elegant_merge (p2,p1) elegant_merge :: (Patch, Patch) -> Maybe Patch elegant_merge (p1, p2) = case commute (p1, invert p2) of Just (_,p1') -> case commute (p1', p2) of Nothing -> Nothing Just (_,p1o) -> if p1o == p1 then Just p1' else Nothing Nothing -> Nothing \end{code} Of couse, 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 $ concat $ map 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 _ = [] nubsort :: Ord a => [a] -> [a] nubsort = nubsorted . sort where nubsorted (a:b:l) | a == b = nubsorted (a:l) | otherwise = a: nubsorted (b:l) nubsorted l = l \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 commute (merge_patch_after_patches p p2s, join_patches p2s) of Just (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' == 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 -> error $ "r_u commute bug, contact droundy@ag.o!\n" ++ "Original patch:\n" ++ show 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 $ nub $ 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} 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. \begin{code} prop_glump_order_independent :: String -> Patch -> Patch -> Property prop_glump_order_independent g p1 p2 = (check_a_patch $ ComP [invert p1,p2]) ==> glump g p1 p2 == glump g p2 p1 \end{code} Secondly, the result of the merge of three (or more) conflicting patches cannot depend on the order in which the merges are performed. \begin{code} prop_glump_seq_merge :: String -> Patch -> Patch -> Patch -> Property prop_glump_seq_merge g p1 p2 p3 = (check_a_patch $ ComP [invert p1,p2, p3]) ==> glump g p3 (merger g p2 p1) == glump g (merger g p2 p1) p3 prop_glump_seq_merge_valid :: String -> Patch -> Patch -> Patch -> Property prop_glump_seq_merge_valid _ p1 p2 p3 = (check_a_patch $ ComP [invert p1,p2, p3]) ==> (check_a_patch $ join_patches [invert p1,p2,p3,invert p3,invert p2]) test_patch :: String test_patch = test_str ++ test_note tp1, tp2 :: Patch tp1 = fst . fromJust . readPatchPS $ packString "\nmove ./test/test ./hello\n" tp2 = fst . fromJust . readPatchPS $ packString "\nmove ./test ./hello\n" tp1', tp2' :: Patch tp2' = quickmerge (tp2,tp1) tp1' = quickmerge (tp1,tp2) test_note :: String test_note = (if commute (tp2',tp1) == Just (tp1', tp2) then "At least they commute right.\n" else "Argh! they don't even commute right.\n") ++(if check_a_patch $ tp2 then "tp2 itself is valid!\n" else "Oh my! tp2 isn't even valid!\n") ++(if check_a_patch $ tp2' then "tp2' itself is valid!\n" else "Aaack! tp2' itself is invalid!\n") ++(if check_a_patch $ join_patches [tp1, tp2'] then "Valid merge tp2'!\n" else "Bad merge tp2'!\n") ++ (if check_a_patch $ join_patches [tp2, tp1'] then "Valid merge tp1'!\n" else "Bad merge tp1'!\n") ++ (if check_a_patch $ join_patches [tp2,tp1',invert tp2',invert tp1] then "Both agree!\n" else "The two merges don't agree!\n") ++ (if check_a_patch $ join_patches [invert tp2, tp1] then "They should be mergable!\n" else "Wait a minute, these guys can't be merged!\n") tp :: Patch tp = tp1' test_str :: String test_str = "Patches are:\n"++(show tp) ++(if check_a_patch tp then "At least the patch itself is valid.\n" else "The patch itself is bad!\n") ++"commute of tp1' and tp2 is "++show (commute (tp1',tp2))++"\n" ++"commute of tp2' and tp1 is "++show (commute (tp2',tp1))++"\n" {-++ "\nSimply flattened, it is:\n" ++ (show $ map (join_patches.flatten.merger_equivalent) $ flatten tp) ++ "\n\nUnravelled, it gives:\n" ++ (show $ map unravel $ flatten tp) ++ "\n\nUnwound, it gives:\n" ++ (show $ map unwind $ flatten tp) ++(if check_a_patch (join_patches$ reverse $ unwind tp) then "Unwinding is valid.\n" else "Bad unwinding!\n") ++(if check_a_patch $ join_patches [tp,invert tp] then "Inverse is valid.\n" else "Bad inverse!\n") ++(if check_a_patch $ join_patches [invert tp, tp] then "Other inverse is valid.\n" else "Bad other inverse!\n")-} \end{code} \begin{code} prop_glump_three_merge :: String -> Patch -> Patch -> Patch -> Property prop_glump_three_merge g p1 p2 p3 = (check_a_patch $ ComP [invert p1,p2,invert p2, p3]) ==> glump g (merger g p2 p1) (merger g p2 p3) == glump g (merger g p1 p2) (merger g p1 p3) && glump g (merger g p2 p1) (merger g p2 p3) == glump g (merger g p1 p3) (merger g p1 p2) prop_glump_three_merge_valid :: String -> Patch -> Patch -> Patch -> Property prop_glump_three_merge_valid g p1 p2 p3 = (check_a_patch $ ComP [invert p1,p2,invert p2, p3]) ==> (check_a_patch $ join_patches [invert p1,p2,invert p2,p3,invert p3, glump g (merger g p2 p1) (merger g p2 p3)]) \end{code} 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]] prop_unravel_three_merge :: Patch -> Patch -> Patch -> Property prop_unravel_three_merge p1 p2 p3 = (check_a_patch $ ComP [invert p1,p2,invert p2,p3]) ==> (unravel $ merger "a" (merger "a" p2 p3) (merger "a" p2 p1)) == (unravel $ merger "a" (merger "a" p1 p3) (merger "a" p1 p2)) \end{code} \begin{code} prop_unravel_seq_merge :: Patch -> Patch -> Patch -> Property prop_unravel_seq_merge p1 p2 p3 = (check_a_patch $ ComP [invert p1,p2,p3]) ==> (unravel $ merger "a" p3 $ merger "a" p2 p1) == (unravel $ merger "a" (merger "a" p2 p1) p3) \end{code} \begin{code} prop_unravel_order_independent :: Patch -> Patch -> Property prop_unravel_order_independent p1 p2 = (check_a_patch $ ComP [invert p1,p2]) ==> (unravel $ merger "a" p2 p1) == (unravel $ merger "a" p1 p2) \end{code} \begin{code} prop_resolve_conflicts_valid :: Patch -> Patch -> Property prop_resolve_conflicts_valid p1 p2 = (check_a_patch $ ComP [invert p1,p2]) ==> and $ map (check_a_patch.(\l-> join_patches [p,merge_list l])) $ resolve_conflicts p where p = case merge (p1,p2) of Just (p1',_) -> join_patches [p2,p1'] Nothing -> impossible merge_list :: [Patch] -> Patch merge_list ps = doml (join_patches []) ps doml :: Patch -> [Patch] -> Patch doml mp (p:ps) = case merge (mp,p) of Just (mp',_) -> doml (join_patches $ p : (flatten mp')) ps Nothing -> impossible doml mp [] = mp 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),_) -> (nub $ 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 = sort $ nub $ map (sort_coalesce_composite) $ map (concat . (map (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 _ `is_superpatch_of` [] = True [] `is_superpatch_of` _ = False a `is_superpatch_of` b | a == b = True | length b > length a = False a `is_superpatch_of` (b:bs) = case filter ((==b).head) $ head_permutations_normal_order a of ((_:as):_) -> as `is_superpatch_of` 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 new_ur :: Patch -> [Patch] -> [[Patch]] new_ur p (Merger _ _ _ _ p1 p2 : ps) = case filter (\pp-> head pp == p1) $ all_head_permutations ps of ((_:ps'):_) -> new_ur p (p1:ps') ++ new_ur p (p2:ps') _ -> error $ "Bug in new_ur - contact droundy@abridgegame.org!\n" ++ "Original patch:\n" ++ show p ++ "Unwound:\n" ++ unlines (map show $ unwind p) new_ur op ps = case filter (is_merger.head) $ all_head_permutations ps of [] -> [ps] (ps':_) -> new_ur op ps' is_merger :: Patch -> Bool is_merger (Merger _ _ _ _ _ _) = True is_merger _ = False merger :: String -> Patch -> Patch -> Patch merger g p1 p2 = Merger True g undoit unwindings p1 p2 where fake_p = Merger True g (join_patches []) [] p1 p2 unwindings = true_unwind fake_p p = Merger True g (join_patches []) 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 merger_undo :: Patch -> Patch merger_undo (Merger _ _ undo _ _ _) = undo merger_undo _ = impossible 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 p = p \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 [ps] -> join_patches ps pss -> if only_hunks pss then mangle_unravelled_hunks pss else join_patches $ head pss glump _ _ _ = impossible \end{code} \begin{code} only_hunks :: [[Patch]] -> Bool only_hunks [] = False only_hunks pss = fn2s 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 (readAntiMemo n) ++ drop (length $ readAntiMemo 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 _ = s2fn "" 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 (return old) (return 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 = if null (make_chunk l oldf) then concat nchs else [top] ++ concat (intersperse [middle] nchs) ++ [bottom] top = packString "v v v v v v v" middle = packString "*************" bottom = packString "^ ^ ^ ^ ^ ^ ^" \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 $ join_patches [] 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 == invert p1 = Just $ join_patches [] 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 _ = Nothing \end{code} \section{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} commuteFP :: FileName -> (FilePatchType, FilePatchType) -> Maybe (Patch, Patch) commuteFP f (Hunk line1 old1 new1, Hunk line2 old2 new2) = seq f $ 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 -> Nothing Just old2' -> case try_tok_replace t o n new2 of Nothing -> Nothing Just new2' -> Just (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 = Nothing | o == o2 = Nothing | n == o2 = Nothing | o == n2 = Nothing | n == n2 = Nothing | otherwise = Just (FP f $ TokReplace t2 o2 n2, FP f $ TokReplace t o n) commuteFP a (b,c) = seq a $ seq b $ seq c $ Nothing \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 _ p@(ChangePref _ _ _) = p subfn :: String -> FileName -> FileName subfn dir f = seq dir $ seq f $ s2fn $ n_fn $ dir++"/"++ fn2s (norm_path f) \end{code} Hunks are an example of a complex filepatch. A hunk is a set of lines of a text file to be replaced by a different set of lines. Either of these sets may be empty, which would mean a deletion or insertion of lines. \begin{code} applyHunkLines :: Int -> AntiMemo [PackedString] -> AntiMemo [PackedString] -> FileContents -> Maybe FileContents applyHunkLines _ o n fc | null (readAntiMemo o) && null (readAntiMemo n) = Just fc applyHunkLines l _ _ _ | l < 0 = bug "Patch.applyHunkLines: After -ve lines?" applyHunkLines l ooo nnn (ccc,_) = if readAntiMemo ahl == Nothing then Nothing else Just $ (fromJust `fmap` ahl, Nothing) where splitAtN 0 xs = Just ([], xs) splitAtN i (x:xs) = case splitAtN (i-1) xs of Just (ys, zs) -> Just (x:ys, zs) Nothing -> Nothing splitAtN _ [] = Nothing dropPrefix [] ys = Just ys dropPrefix (x:xs) (y:ys) | x == y = dropPrefix xs ys dropPrefix _ _ = Nothing ahl = do c <- ccc o <- ooo n <- nnn case splitAtN (l - 1) c of Just (pre, post) -> case dropPrefix o post of Just post' -> return $ Just (pre++n++post') Nothing -> return Nothing Nothing -> return Nothing \end{code} 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 && ((lengthnew2 /= 0 && lengthnew1 /= 0) || (lengthold2 /= 0 && lengthold1 /= 0)) = Just (FP f (Hunk line1 old1 new1), FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) | line2 + lengthold2 == line1 && ((lengthnew2 /= 0 && lengthnew1 /= 0) || (lengthold2 /= 0 && lengthold1 /= 0)) = Just (FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1), FP f (Hunk line2 old2 new2)) | otherwise = seq f Nothing where lengthnew1 = length $ readAntiMemo new1 lengthnew2 = length $ readAntiMemo new2 lengthold1 = length $ readAntiMemo old1 lengthold2 = length $ readAntiMemo 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 -> AntiMemo [PackedString] -> AntiMemo [PackedString] -> Int -> AntiMemo [PackedString] -> AntiMemo [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 -> AntiMemo [PackedString] -> AntiMemo [PackedString] -> Int -> AntiMemo [PackedString] -> AntiMemo [PackedString] -> Maybe Patch docoalesceHunk f line1 old1 new1 line2 old2 new2 | line1 == line2 && lengthold1 < lengthnew2 = if take lengthold1 (readAntiMemo new2) /= (readAntiMemo old1) then Nothing else case drop lengthold1 `fmap` new2 of extranew -> Just (FP f (Hunk line1 old2 (new1|++|extranew))) | line1 == line2 && lengthold1 > lengthnew2 = if take lengthnew2 `fmap` old1 /= new2 then Nothing else case drop lengthnew2 `fmap` 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) `fmap` old1 of extra-> docoalesceHunk f line1 old1 new1 line1 (extra|++|old2) (extra|++|new2) | line1 > line2 && lengthnew2 >= line1 - line2 = case take (line1 - line2) `fmap` new2 of extra-> docoalesceHunk f line2 (extra|++|old1) (extra|++|new1) line2 old2 new2 | otherwise = Nothing where lengthold1 = length $ readAntiMemo old1 lengthnew2 = length $ readAntiMemo 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 necesary, but is a good idea, since this process is $O(n)$, while the primary diff algorithm is something considerably more painful than that... 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 -> AntiMemo [PackedString] -> AntiMemo [PackedString] -> Maybe Patch canonizeHunk _ _ o n | o == n = Nothing canonizeHunk f line old new | readAntiMemo old == [] || readAntiMemo new == [] = Just $ FP f $ Hunk line old new canonizeHunk f line am_old am_new = case make_holey f line old new $ lcs old new of [p] -> Just p [] -> Nothing ps -> Just $ join_patches ps where new = readAntiMemo am_new old = readAntiMemo am_old make_holey :: FileName -> Int -> [PackedString] -> [PackedString] -> [PackedString] -> [Patch] make_holey f line old new thelcs = map (\ (l,o,n) -> FP f (Hunk l (return o) (return n))) (make_holey_hunkdata line old new thelcs) make_holey_hunkdata :: Int -> [PackedString] -> [PackedString] -> [PackedString] -> [(Int,[PackedString],[PackedString])] make_holey_hunkdata line os ns [] | os == [] && ns == [] = [] | otherwise = [(line, os, ns)] make_holey_hunkdata origline origos origns origls = let forwardhunks = mhh False origline [] [] origos origns origls newlength = length origns rawbackwardhunks = mhh (is_shorter_than 30 forwardhunks) 0 [] [] (reverse origos) (reverse origns) (reverse origls) backwardhunks = reverse $ map (\ (l,o,n)-> (origline + newlength - l - length n, reverse o, reverse n)) rawbackwardhunks mhh _ line ol nl o n [] | ol++o == [] && nl++n == [] = [] | otherwise = [(line,ol++o, nl++n)] mhh stubbornly line ol nl (o:os) (n:ns) (l:ls) | o /= l = mhh stubbornly line (ol++[o]) nl os (n:ns) (l:ls) | n /= l = mhh stubbornly line ol (nl++[n]) (o:os) ns (l:ls) | ol == [] && nl == [] = mhh stubbornly (line+1) [] [] os ns ls mhh True line ol nl (_:os) (_:ns) (_:ls) = (line,ol,nl) : make_holey_hunkdata (line+1+length nl) os ns ls mhh False line ol nl (_:os) (_:ns) (_:ls) = (line,ol,nl) : mhh False (line+1+length nl) [] [] os ns ls mhh _ _ _ _ _ _ _ = impossible in if length forwardhunks > length backwardhunks then backwardhunks else forwardhunks is_shorter_than :: Int -> [a] -> Bool is_shorter_than 0 _ = False is_shorter_than _ [] = True is_shorter_than n (_:ls) = is_shorter_than (n-1) ls applyBinary :: PackedString -> PackedString -> FileContents -> Maybe FileContents applyBinary o n (_,Just c) | c == o = Just (linesPS `antimemoize` n, Just n) applyBinary o n (ls,Nothing) | unlinesPS (readAntiMemo ls) == o = Just (linesPS `antimemoize` n, Just n) applyBinary _ _ _ = Nothing \end{code} \section{Token replace patches}\label{token_replace} Although most filepatches will be hunks, darcs is clever enough to support other types of changes as well. A ``token replace'' patch replaces all instances of a given token with some other version. A token, here, is defined by a regular expression, which must be of the simple [a-z...] type, indicating which characters are allowed in a token, with all other characters acting as delimiters. For example, a C identifier would be a token with the flag \verb![A-Za-z_0-9]!. \begin{code} forceTokReplace :: String -> String -> String -> FileContents -> Maybe FileContents forceTokReplace t os ns (c,_) = Just (map forceReplace `fmap` c, Nothing) where o = packString os n = packString ns tokchar = regChars t toks_and_intratoks ps | nullPS ps = [] toks_and_intratoks ps = let (before,s') = breakPS tokchar ps (tok, after) = breakPS (not . tokchar) s' in before : tok : toks_and_intratoks after forceReplace ps = concatPS $ map o_t_n $ toks_and_intratoks ps o_t_n s | s == o = n | otherwise = s applyTokReplace :: String -> String -> String -> FileContents -> Maybe FileContents applyTokReplace t o n (c,_) = case mapM (try_tok_internal t (packString o) (packString n)) $ readAntiMemo c of Nothing -> Nothing Just c' -> Just (return $ map concatPS c', Nothing) try_tok_possibly :: String -> String -> String -> [Possibly PackedString] -> Maybe [Possibly PackedString] try_tok_possibly t o n mss = mapM (silly_maybe_possibly $ liftM concatPS . try_tok_internal t (packString o) (packString n)) $ take 1000 mss try_tok_replace :: String -> String -> String -> AntiMemo [PackedString] -> Maybe (AntiMemo [PackedString]) try_tok_replace t o n mss = liftJust $ mapM (liftM concatPS . try_tok_internal t (packString o) (packString n)) `fmap` mss where liftJust xx = case readAntiMemo xx of Nothing -> Nothing _ -> Just (fromJust `fmap` xx) silly_maybe_possibly :: (PackedString -> Maybe PackedString) -> (Possibly PackedString -> Maybe (Possibly PackedString)) silly_maybe_possibly f = \px -> case px of PNothing -> Just PNothing PSomething -> Just PSomething PJust x -> case f x of Nothing -> Nothing Just x' -> Just $ PJust x' try_tok_internal :: String -> PackedString -> PackedString -> PackedString -> Maybe [PackedString] try_tok_internal _ _ _ s | nullPS s = Just [] 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} What makes the token replace patch special is the fact that a token replace can be merged with almost any ordinary hunk, giving exactly what you would want. For example, you might want to change the patch type {\tt TokReplace} to {\tt TokenReplace} (if you decided that saving two characters of space was stupid). If you did this using hunks, it would modify every line where {\tt TokReplace} occurred, and quite likely provoke a conflict with another patch modifying those lines. On the other hand, if you did is using a token replace patch, the only change that it could conflict with would be if someone else had used the token ``{\tt TokenReplace}'' in their patch rather than TokReplace---and that actually would be a real conflict! \section{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) -> Maybe (Patch, Patch) commute_split (Split patches, patch) = 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 _ = Nothing \end{code} \begin{code} reorder :: Patch -> Patch reorder (NamedP n d p) = NamedP n d $ reorder p reorder (ComP ps) = ComP $ sortps ps reorder p = p sortps :: [Patch] -> [Patch] sortps [] = [] sortps (p:ps) = push_patch p (sortps ps) push_patch :: Patch -> [Patch] -> [Patch] push_patch new [] = [new] push_patch new ps@(p:ps') = if new < p then new:ps else case commute (p, new) of Nothing -> new:ps Just (new', p') -> p':push_patch new' ps' sort_coalesce_composite :: [Patch] -> [Patch] sort_coalesce_composite [] = [] sort_coalesce_composite (p:ps) = push_coalesce_patch p (sort_coalesce_composite ps) 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' -> push_coalesce_patch new' ps' Nothing -> if new < p then new:ps else case commute (p, new) of Just (new', p') -> p':push_coalesce_patch new' ps' Nothing -> new:ps simplify_composite :: [Patch] -> Maybe Patch simplify_composite [p] = canonize p simplify_composite ps = Just $ ComP ps subcanonize_composite :: [Patch] -> [Patch] subcanonize_composite [] = [] subcanonize_composite (p:ps) = case canonize p of Just p' -> p' : subcanonize_composite ps Nothing -> impossible --Nothing -> subcanonize_composite ps canonizeComposite :: [Patch] -> Maybe Patch canonizeComposite ps = simplify_composite $ sort_coalesce_composite $ subcanonize_composite ps \end{code} %Another nice thing to be able to do with composite patches is to `flatten' %them, that is, turn them into a simple list of patches (appropriately %ordered, of course), with all nested compositeness unnested. \begin{code} {- INLINE flatten -} flatten :: Patch -> [Patch] flatten (ComP ps) = concat $ map flatten ps flatten p = [p] {- INLINE flatten_to_primitives -} flatten_to_primitives :: Patch -> [Patch] flatten_to_primitives (ComP ps) = concat $ map flatten_to_primitives ps flatten_to_primitives (NamedP _ _ p) = flatten_to_primitives p flatten_to_primitives p = [p] \end{code} %\section{Outputting interesting and useful information} %Just being able to manipulate patches and trees is not enough. We also %want to be able to view the patches and files. This requires another set %of functions, closely related to the patch application functions, which %will give us the necesary information to browse the changes we have made. %It is \emph{not} the Patch module's responsibility to add any sort of %markup or formatting, but simply to provide the information necesary for an %external module to do the formatting. \begin{code} data LineMark = AddedLine PatchInfo | RemovedLine PatchInfo | AddedRemovedLine PatchInfo PatchInfo | None deriving (Show) type MarkedUpFile = [(PackedString, LineMark)] empty_markedup_file :: MarkedUpFile empty_markedup_file = [(nilPS, None)] markup_file :: PatchInfo -> Patch -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) markup_file n (NamedP _ _ p') (f, mk) = markup_file n p' (f, mk) markup_file n p (f, mk) | is_merger p = markup_file n (merger_equivalent p) (f, mk) markup_file _ (Merger _ _ _ _ _ _) _ = impossible markup_file _ (ComP []) (f, mk) = (f, mk) markup_file n (ComP (p:ps)) (f, mk) = markup_file n (ComP ps) $ markup_file n p (f, mk) markup_file _ (Split []) (f, mk) = (f, mk) markup_file n (Split (p:ps)) (f, mk) = markup_file n (Split ps) $ markup_file n p (f, mk) markup_file _ (FP _ AddFile) (f, mk) = (f, mk) markup_file _ (FP _ RmFile) (f, mk) = (f, mk) markup_file n (FP f' (Hunk line old new)) (f, mk) | fn2s f' /= f = (f, mk) | otherwise = (f, markup_hunk n line (readAntiMemo old) (readAntiMemo new) mk) markup_file name (FP f' (TokReplace t o n)) (f, mk) | fn2s f' /= f = (f, mk) | otherwise = (f, markup_tok name t o n mk) markup_file _ (DP _ _) (f, mk) = (f, mk) markup_file _ (Move d d') (f, mk) = (fn2s $ movedirfilename d d' (s2fn f), mk) markup_file _ (ChangePref _ _ _) (f,mk) = (f,mk) markup_file n (FP f' (Binary _ _)) (f,mk) | fn2s f' == f = (f,(packString "Binary file", AddedLine n):mk) | otherwise = (f,mk) markup_hunk :: PatchInfo -> Int -> [PackedString] -> [PackedString] -> MarkedUpFile -> MarkedUpFile markup_hunk n l old new ((sf, RemovedLine pi):mk) = (sf, RemovedLine pi) : markup_hunk n l old new mk markup_hunk n l old new ((sf, AddedRemovedLine po pn):mk) = (sf, AddedRemovedLine po pn) : markup_hunk n l old new mk markup_hunk name 1 old (n:ns) mk = (n, AddedLine name) : markup_hunk name 1 old ns mk markup_hunk n 1 (o:os) [] ((sf, None):mk) | o == sf = (sf, RemovedLine n) : markup_hunk n 1 os [] mk | otherwise = [(packString "Error in patch application", AddedLine n)] markup_hunk n 1 (o:os) [] ((sf, AddedLine nold):mk) | o == sf = (sf, AddedRemovedLine nold n) : markup_hunk n 1 os [] mk | otherwise = [(packString "Error in patch application", AddedLine n)] markup_hunk _ 1 [] [] mk = mk markup_hunk n l old new ((sf, AddedLine pi):mk) | l > 1 = (sf, AddedLine pi) : markup_hunk n (l-1) old new mk | l < 1 = (sf, AddedLine pi) : markup_hunk n (l-1) old new mk markup_hunk n l old new ((sf, None):mk) | l > 1 = (sf, None) : markup_hunk n (l-1) old new mk | l < 1 = (sf, None) : markup_hunk n (l-1) old new mk markup_hunk _ _ _ _ [] = [] markup_hunk _ _ _ _ mk = (packString "Error: ",None) : mk markup_tok :: PatchInfo -> String -> String -> String -> MarkedUpFile -> MarkedUpFile markup_tok name t ostr nstr mk = concat $ map mt mk where o = packString ostr n = packString nstr mt (sf, AddedLine pi) = case concatPS `liftM` try_tok_internal t o n sf of Just sf' | sf' == sf -> [(sf, AddedLine pi)] | otherwise -> [(sf, AddedRemovedLine pi name), (sf', AddedLine name)] Nothing -> [(sf, AddedLine pi), (packString "There seems to be an inconsistency...", None), (packString "Please run darcs check.", None)] mt mark = [mark] \end{code} \section{Patch string formatting} Of course, in order to store our patches in a file, we'll have to save them as some sort of strings. The convention is that each patch string will end with a newline, but on parsing we skip any amount of whitespace between patches. \begin{code} prop_readPS_show :: Patch -> Bool prop_readPS_show p = case readPatchPS $ packString $ show p of Just (p',_) -> p' == p Nothing -> False \end{code} \begin{code} instance Show Patch where show p = renderWith simplePrinters $ show_patch_style p <> text "\n" showPatch :: Printable a => Printers a -> Patch -> PrintableString a showPatch ps p = renderWith ps $ show_patch_style p <> text "\n" show_patch_style :: Printable a => Patch -> Doc a show_patch_style (FP f AddFile) = showAddFile f show_patch_style (FP f RmFile) = showRmFile f show_patch_style (FP f (Hunk line old new)) = showHunk f line old new show_patch_style (FP f (TokReplace t old new)) = showTok f t old new show_patch_style (FP f (Binary old new)) = showBinary f old new show_patch_style (DP d AddDir) = showAddDir d show_patch_style (DP d RmDir) = showRmDir d show_patch_style (Move f f') = showMove f f' show_patch_style (ChangePref p f t) = showChangePref p f t show_patch_style (ComP ps) = showComP ps show_patch_style (Split ps) = showSplit ps show_patch_style (NamedP n d p) = showNamed n d p show_patch_style (Merger b g _ _ p1 p2) = showMerger b g p1 p2 showContextPatch :: Printable a => Printers a -> Slurpy -> Patch -> PrintableString a showContextPatch ps s p = renderWith ps $ showContextPatchStyle s p <> text "\n" showContextPatchStyle :: Printable a => Slurpy -> Patch -> Doc a showContextPatchStyle s p@(FP _ (Hunk _ _ _)) = showContextHunk s p showContextPatchStyle s (ComP ps) = showContextComP s ps showContextPatchStyle s (Split ps) = showContextSplit s ps showContextPatchStyle s p@(NamedP _ _ _) = showContextNamed s p showContextPatchStyle _ p = show_patch_style p hPutPatch :: Handle -> Patch -> IO () writePatch :: FilePath -> Patch -> IO () gzWritePatch :: FilePath -> Patch -> IO () hPutPatch h p@(ComP _) = hPutComP h p hPutPatch h p@(NamedP _ _ _) = hPutNamed h p hPutPatch h p@(Merger _ _ _ _ _ _) = hPutMerger h p hPutPatch h p@(Split _) = hPutSplit h p hPutPatch h p@(FP _ (Hunk _ _ _)) = hPutHunk h p hPutPatch h (FP f (Binary old new)) = hPutBinary h f old new hPutPatch h p = hPutStr h $ show p gzWritePatch f p = gzWriteToFile f $ \h -> hPutPatch h p writePatch f p = writeToFile f $ \h -> hPutPatch h p readPatchPS :: PackedString -> Maybe (Patch,PackedString) readPatchPS s = case (unpackPS . fst) `liftM` mylexPS s of Just "{" -> readComPPS s -- } Just "(" -> readSplitPS s -- ) Just "hunk" -> readHunkPS s Just "replace" -> readTokPS s Just "binary" -> readBinaryPS s Just "addfile" -> readAddFilePS s Just "adddir" -> readAddDirPS s Just "rmfile" -> readRmFilePS s Just "rmdir" -> readRmDirPS s Just "move" -> readMovePS s Just "changepref" -> readChangePrefPS s Just "merger" -> readMergerPS True s Just "regrem" -> readMergerPS False s Just ('[':_) -> readNamedPS s -- ] _ -> Nothing \end{code} \paragraph{Composite patch} A patch made up of a few other patches. \begin{verbatim} { (indented two) } \end{verbatim} \begin{code} showComP :: Printable a => [Patch] -> Doc a showComP ps = text "{" $$ vcat (map show_patch_style ps) $$ text "}" showContextComP :: Printable a => Slurpy -> [Patch] -> Doc a showContextComP slurpy patches = text "{" $$ showContextSeries slurpy patches $$ text "}" showContextSeries :: Printable a => Slurpy -> [Patch] -> Doc a showContextSeries slur patches = scs slur (join_patches []) patches where scs s pold (p:p2:ps) | is_hunk p = coolContextHunk s pold p p2 <> text "\n" <> scs (fromJust $ apply_to_slurpy p s) p (p2:ps) scs s pold [p] | is_hunk p = coolContextHunk s pold p (join_patches []) scs s _ (p:ps) = showContextPatchStyle s p <> text "\n" <> scs (fromJust $ apply_to_slurpy p s) p ps scs _ _ [] = empty hPutComP :: Handle -> Patch -> IO () hPutComP h (ComP ps) = do hPutStr h "{\n" mapM_ (hPutPatch h) ps hPutStr h "}\n" hPutComP _ _ = impossible readComPPS :: PackedString -> Maybe (Patch,PackedString) readComPPS s = case mylexPS s of Just (start,t) -> case read_patchesPS t of Just (ps,w) -> case mylexPS w of Just (end,x) -> if unpackPS end == "}" && unpackPS start == "{" then Just (ComP ps, dropWhitePS x) else Nothing Nothing -> impossible Nothing -> impossible Nothing -> impossible read_patchesPS :: PackedString -> Maybe ([Patch],PackedString) read_patchesPS s = case readPatchPS s of Nothing -> Just ([],s) Just (p,s') -> case read_patchesPS s' of Just (ps,s'') -> Just (p:ps,s'') Nothing -> impossible \end{code} \paragraph{Split patch} A split patch is similar to a composite patch (identical in how it's stored), but rather than being composed of several patches grouped together, it is created from one patch that has been split apart, typically through a merge or commutation. \begin{verbatim} ( (indented two) ) \end{verbatim} \begin{code} showSplit :: Printable a => [Patch] -> Doc a showSplit ps = text "(" $$ vcat (map show_patch_style ps) $$ text ")" showContextSplit :: Printable a => Slurpy -> [Patch] -> Doc a showContextSplit slurpy patches = text "(" $$ showContextSeries slurpy patches <> text ")" hPutSplit :: Handle -> Patch -> IO () hPutSplit h (Split ps) = do hPutStr h "(\n" mapM_ (hPutPatch h) ps hPutStr h ")\n" hPutSplit _ _ = impossible readSplitPS :: PackedString -> Maybe (Patch,PackedString) readSplitPS = parseGP $ do start <- GenP mylexPS assertGP $ start == packString "(" ps <- GenP read_patchesPS end <- GenP mylexPS assertGP $ end == packString ")" return $ Split ps \end{code} \paragraph{Hunk} Replace a hunk (set of contiguous lines) of text with a new hunk. \begin{verbatim} hunk FILE LINE# -LINE ... +LINE ... \end{verbatim} \begin{code} space, newline, plus, minus, asterisk :: Printable a => a space = printableFromChar ' ' newline = printableFromChar '\n' plus = printableFromChar '+' minus = printableFromChar '-' asterisk = printableFromChar '*' showHunk :: Printable a => FileName -> Int -> AntiMemo [PackedString] -> AntiMemo [PackedString] -> Doc a showHunk f line old new = let psfromPS = printableStringFromPS in blueText "hunk" <+> fn2d f <+> text (show line) $$ vcat (map (text' . (minus :) . psfromPS) $ readAntiMemo old) $$ vcat (map (text' . (plus :) . psfromPS) $ readAntiMemo new) showContextHunk :: Printable a => Slurpy -> Patch -> Doc a showContextHunk s p = coolContextHunk s (join_patches []) p (join_patches []) coolContextHunk :: Printable a => Slurpy -> Patch -> Patch -> Patch -> Doc a coolContextHunk s prev p@(FP f (Hunk l oo nn)) next = case (readAntiMemo . fst . get_filecontents) `liftM` get_slurp f s of Nothing -> show_patch_style p -- This is a weird error... Just ls -> let numpre = case prev of (FP f' (Hunk lprev _ nprev)) | f' == f && l - (lprev + length (readAntiMemo nprev) + 3) < 3 && lprev < l -> max 0 $ l - (lprev + length (readAntiMemo nprev) + 3) _ -> if l >= 4 then 3 else l - 1 pre = take numpre $ drop (l - numpre - 1) ls numpost = case next of (FP f' (Hunk lnext _ _)) | f' == f && lnext < l+length n+4 && lnext > l -> lnext - (l+length n) _ -> 3 cleanedls = case reverse ls of (x:xs) | nullPS x -> reverse xs _ -> ls post = take numpost $ drop (max 0 $ l+length o-1) cleanedls psfromPS = printableStringFromPS o = readAntiMemo oo n = readAntiMemo nn in blueText "hunk" <+> fn2d f <+> text (show l) $$ (vcat $ map (text' . (space :) . psfromPS) pre ++ map (text' . (minus :) . psfromPS) o ++ map (text' . (plus :) . psfromPS) n ++ map (text' . (space :) . psfromPS) post ) coolContextHunk _ _ _ _ = impossible hPutHunk :: Handle -> Patch -> IO () hPutHunk h (FP f (Hunk l o n)) = do hPutStr h $ "hunk "++fn2s f++" "++show l++"\n" mapM_ (hputpspre h '-') (readAntiMemo o) mapM_ (hputpspre h '+') (readAntiMemo n) hPutHunk _ _ = impossible hputpspre :: Handle -> Char -> PackedString -> IO () hputpspre h c ps = do hPutChar h c hPutPS h ps hPutChar h '\n' readHunkPS :: PackedString -> Maybe (Patch,PackedString) readHunkPS = parseGP $ do hun <- GenP mylexPS assertGP $ hun == packString "hunk" fi <- GenP mylexPS l <- GenP readIntPS skipGP tailPS -- skipping the newline... _ <- GenP $ lines_starting_withPS ' ' -- skipping context old <- GenP $ lines_starting_withPS '-' new <- GenP $ lines_starting_withPS '+' _ <- GenP $ lines_starting_withPS ' ' -- skipping context return $ hunk (fn2fp $ ps2fn fi) l old new \end{code} \paragraph{Token replace} Replace a token with a new token. Note that this format means that the white space must not be allowed within a token. If you know of a practical application of whitespace within a token, let me know and I may change this. \begin{verbatim} replace FILENAME [REGEX] OLD NEW \end{verbatim} \begin{code} showTok :: Printable a => FileName -> String -> String -> String -> Doc a showTok f t o n = blueText "replace" <+> fn2d f <+> text "[" <> text t <> text "]" <+> text o <+> text n readTokPS :: PackedString -> Maybe (Patch,PackedString) readTokPS = parseGP $ do rep <- GenP $ mylexPS assertGP $ rep == packString "replace" f <- GenP $ mylexPS regstr <- GenP $ mylexPS o <- GenP $ mylexPS n <- GenP $ mylexPS return $ FP (ps2fn f) $ TokReplace (drop_brackets $ unpackPS regstr) (unpackPS o) (unpackPS n) where drop_brackets = init . tail \end{code} \paragraph{Binary file modification} Modify a binary file \begin{verbatim} binary FILENAME oldhex *HEXHEXHEX ... newhex *HEXHEXHEX ... \end{verbatim} \begin{code} -- This is a generic parser monad for convenience... newtype GP a b = GenP (a -> Maybe (b,a)) instance Monad (GP a) where m >>= k = GenP $ parse_then m k return x = GenP (\a -> Just (x,a)) fail _ = GenP (\_ -> Nothing) parse_then :: GP a b -> (b -> GP a c) -> a -> Maybe (c,a) parse_then (GenP f) g a = case f a of Nothing -> Nothing Just (b,x) -> parseGP (g b) x parseGP :: GP a b -> a -> Maybe (b,a) parseGP (GenP p) a = p a skipGP :: (a -> a) -> GP a () skipGP s = GenP $ \a -> Just ((), s a) assertGP :: Bool -> GP a () assertGP b = unless b $ fail "" showBinary :: Printable a => FileName -> PackedString -> PackedString -> Doc a showBinary f o n = blueText "binary" <+> fn2d f <> invisibleText "\noldhex" <> invisibleText' (concatMap makeprintable $ break_every 78 $ fromPS2Hex o) <> invisibleText "\nnewhex" <> invisibleText' (concatMap makeprintable $ break_every 78 $ fromPS2Hex n) where makeprintable = ((newline:).(asterisk:)).printableStringFromPS hPutBinary :: Handle -> FileName -> PackedString -> PackedString -> IO () hPutBinary h f o n = do hPutStr h $ "binary "++fn2s f++"\noldhex\n" mapM_ (hputpspre h '*') $ break_every 78 $ fromPS2Hex o hPutStr h "newhex\n" mapM_ (hputpspre h '*') $ break_every 78 $ fromPS2Hex n readBinaryPS :: PackedString -> Maybe (Patch,PackedString) readBinaryPS = parseGP $ do bin <- GenP mylexPS assertGP $ bin == packString "binary" fi <- GenP mylexPS _ <- GenP mylexPS skipGP dropWhitePS old <- GenP $ lines_starting_withPS '*' _ <- GenP mylexPS skipGP dropWhitePS new <- GenP $ lines_starting_withPS '*' return $ binary (fn2fp $ ps2fn fi) (fromHex2PS $ concatPS $ readAntiMemo old) (fromHex2PS $ concatPS $ readAntiMemo new) break_every :: Int -> PackedString -> [PackedString] break_every n ps | lengthPS ps < n = [ps] | otherwise = takePS n ps : break_every n (dropPS n ps) \end{code} \paragraph{Add file} Add an empty file to the tree. \verb!addfile filename! \begin{code} showAddFile :: Printable a => FileName -> Doc a showAddFile f = blueText "addfile" <+> fn2d f readAddFilePS :: PackedString -> Maybe (Patch,PackedString) readAddFilePS s = case mylexPS s of Just (_,s') -> case mylexPS s' of Just (f,s'') -> Just (FP (ps2fn f) AddFile, s'') Nothing -> impossible Nothing -> impossible \end{code} \paragraph{Remove file} Delete a file from the tree. \verb!rmfile filename! \begin{code} showRmFile :: Printable a => FileName -> Doc a showRmFile f = blueText "rmfile" <+> fn2d f readRmFilePS :: PackedString -> Maybe (Patch,PackedString) readRmFilePS s = case mylexPS s of Just (_,s') -> case mylexPS s' of Just (f,s'') -> Just (FP (ps2fn f) RmFile, s'') Nothing -> impossible Nothing -> impossible \end{code} \paragraph{Move} Rename a file or directory. \verb!move oldname newname! \begin{code} showMove :: Printable a => FileName -> FileName -> Doc a showMove d d' = blueText "move" <+> fn2d d <+> fn2d d' readMovePS :: PackedString -> Maybe (Patch,PackedString) readMovePS s = case mylexPS s of Just (_,s') -> case mylexPS s' of Just (d,s'') -> case mylexPS s'' of Just (d',s''') -> Just (Move (ps2fn d) (ps2fn d'), s''') Nothing -> impossible Nothing -> impossible Nothing -> impossible \end{code} \paragraph{Change Pref} Change one of the preference settings. Darcs stores a number of simple string settings. Among these are the name of the test script and the name of the script that must be called prior to packing in a make dist. \begin{verbatim} changepref prefname oldval newval \end{verbatim} \begin{code} showChangePref :: Printable a => String -> String -> String -> Doc a showChangePref p f t = blueText "changepref" <+> text p $$ text f $$ text t readChangePrefPS :: PackedString -> Maybe (Patch,PackedString) readChangePrefPS s = case mylexPS s of Just (_,s') -> case mylexPS s' of Just (p,s'') -> case breakOnPS '\n' $ tailPS $ dropWhilePS (==' ') s'' of (f,s''') -> case breakOnPS '\n' $ tailPS s''' of (t,s4) -> Just (ChangePref (u p) (u f) (u t), tailPS s4) where u = unpackPS Nothing -> impossible Nothing -> impossible \end{code} \paragraph{Add dir} Add an empty directory to the tree. \verb!adddir filename! \begin{code} showAddDir :: Printable a => FileName -> Doc a showAddDir d = blueText "adddir" <+> fn2d d readAddDirPS :: PackedString -> Maybe (Patch,PackedString) readAddDirPS s = case mylexPS s of Just (_,s') -> case mylexPS s' of Just (f,s'') -> Just (DP (ps2fn f) AddDir, s'') Nothing -> impossible Nothing -> impossible \end{code} \paragraph{Remove dir} Delete a directory from the tree. \verb!rmdir filename! \begin{code} showRmDir :: Printable a => FileName -> Doc a showRmDir d = blueText "rmdir" <+> fn2d d readRmDirPS :: PackedString -> Maybe (Patch,PackedString) readRmDirPS s = case mylexPS s of Just (_,s') -> case mylexPS s' of Just (f,s'') -> Just (DP (ps2fn f) RmDir, s'') Nothing -> impossible Nothing -> impossible \end{code} \paragraph{Merger patches} Merge two patches. The MERGERVERSION is included to allow some degree of backwards compatibility if the merger algorithm needs to be changed. \begin{verbatim} merger MERGERVERSION \end{verbatim} \begin{code} showMerger :: Printable a => Bool -> String -> Patch -> Patch -> Doc a showMerger forwards g p1 p2 = blueText merger_name <+> text g <+> text "(" $$ show_patch_style p1 $$ show_patch_style p2 $$ text ")" where merger_name = if forwards then "merger" else "regrem" hPutMerger :: Handle -> Patch -> IO () hPutMerger h (Merger b g _ _ p1 p2) = do if b then hPutStr h $ "merger "++g++" (\n" else hPutStr h $ "regrem "++g++" (\n" hPutPatch h p1 hPutPatch h p2 hPutStr h ")\n" hPutMerger _ _ = impossible readMergerPS :: Bool -> PackedString -> Maybe (Patch,PackedString) readMergerPS b s = case mylexPS $ snd $ fromJust $ mylexPS s of Just (g,s1) -> case mylexPS s1 of Just (start,s2) -> case readPatchPS s2 of Just (p1, s3) -> case readPatchPS s3 of Just (p2, s4) -> case mylexPS s4 of Just (end,s5) -> if (unpackPS start) == "(" && (unpackPS end) == ")" then if b then Just (merger (unpackPS g) p1 p2, s5) else Just (invert $ merger (unpackPS g) p1 p2, s5) else Nothing Nothing -> impossible Nothing -> bug "readMergerPS 1" Nothing -> bug "readMergerPS 2" Nothing -> impossible Nothing -> impossible \end{code} \paragraph{Named patches} Named patches are diplayed as a `patch id' which is in square brackets, followed by a patch. Optionally, after the patch id (but before the patch itself) can come a list of dependencies surrounded by angle brackets. Each dependency consists of a patch id. \begin{code} showNamedPrefix :: Printable a => PatchInfo -> [PatchInfo] -> Doc a showNamedPrefix n d = text (show n) $$ text "<" $$ vcat (map (text . show) d) $$ text ">" showNamed :: Printable a => PatchInfo -> [PatchInfo] -> Patch -> Doc a showNamed n [] p = text (show n) <> show_patch_style p showNamed n d p = showNamedPrefix n d <+> show_patch_style p showContextNamed :: Printable a => Slurpy -> Patch -> Doc a showContextNamed s (NamedP n d p) = showNamedPrefix n d <+> showContextPatchStyle s p showContextNamed _ _ = impossible hPutNamed :: Handle -> Patch -> IO () hPutNamed h (NamedP n [] p) = do hPutStr h $ show n hPutStr h " < > " hPutPatch h p hPutNamed h (NamedP n d p) = do hPutStr h $ show n hPutStr h "\n<" hPutStr h $ concatMap (('\n':) . show) d hPutStr h "\n> " hPutPatch h p hPutNamed _ _ = impossible readNamedPS :: PackedString -> Maybe (Patch, PackedString) readNamedPS s = case readPatchInfoPS s of Nothing -> bug "readNamedPS 1" Just (n,s2) -> case read_dependsPS s2 of Nothing -> bug "readNamedPS 2" Just (d, s3) -> case readPatchPS s3 of Nothing -> error $ "Problem parsing patch named\n" ++ human_friendly n Just (p, s4) -> Just (NamedP n d p, s4) read_dependsPS :: PackedString -> Maybe ([PatchInfo], PackedString) read_dependsPS s = case mylexPS s of Just (st,s') -> if unpackPS st == "<" then read_pisPS s' else Just ([],s) Nothing -> impossible read_pisPS :: PackedString -> Maybe ([PatchInfo], PackedString) read_pisPS s = case readPatchInfoPS s of Just (pi,s') -> case read_pisPS s' of Just (pis,s'') -> Just (pi:pis,s'') Nothing -> impossible Nothing -> Just ([],tailPS $ dropWhilePS (/='>') s) \end{code} \begin{code} lines_starting_withPS :: Char -> PackedString -> Maybe (AntiMemo [PackedString],PackedString) lines_starting_withPS c thes = case lsw `antimemoize` thes of thetwo -> Just (fst `fmap` thetwo, snd $ readAntiMemo thetwo) where lsw s | nullPS s || headPS s /= c = ([], s) lsw s = case linesPS $ tailPS s of (l:_) -> case lsw $ dropPS (1+lengthPS l) $ tailPS s of (ls, rest) -> (l:ls, rest) [] -> impossible \end{code} \begin{code} -- FIXME: The following code is terribly crude (especially in the presense of mv's). patch_summary :: Patch -> String patch_summary = gen_summary False xml_summary :: Patch -> String xml_summary p = "\n"++gen_summary True p++"\n" -- Yuck duplicated code below... escapeXML :: String -> String escapeXML = strReplace '\'' "'" . strReplace '"' """ . strReplace '<' "<" . strReplace '&' "&" strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z:zs) | x == z = y ++ (strReplace x y zs) | otherwise = z : (strReplace x y zs) -- end yuck duplicated code. gen_summary :: Bool -> Patch -> String gen_summary use_xml p = unlines (themoves ++ themods) where themods = concatMap summ $ combine $ sort $ map s $ flatten_to_primitives p s :: Patch -> (FileName, Int, Int, Int, Bool) s (FP f (Hunk _ o n)) = (f, length $ readAntiMemo o, length $ readAntiMemo n, 0, False) s (FP f (Binary _ _)) = (f, 0, 0, 0, False) s (FP f AddFile) = (f, -1, 0, 0, False) s (FP f RmFile) = (f, 0, -1, 0, False) s (FP f (TokReplace _ _ _)) = (f, 0, 0, 1, False) s (DP d AddDir) = (d, -1, 0, 0, True) s (DP d RmDir) = (d, 0, -1, 0, True) s _ = (fp2fn "", 0, 0, 0, False) combine ((f,-1,b,r,isd):(f',_,b',r',_):ss) | f == f' = combine ((f,-1,b+b',r+r',isd):ss) combine ((f,a,_,r,isd):(f',a',-1,r',_):ss) | f == f' = combine ((f,a+a',-1,r+r',isd):ss) combine ((f,a,b,r,isd):(f',a',b',r',_):ss) | f == f' = combine ((f,a+a',b+b',r+r',isd):ss) combine ((f,a,b,r,isd):ss) = (f,a,b,r,isd) : combine ss combine [] = [] summ (f,_,-1,_,False) = if use_xml then ["" ++ escapeXML (drop_dotslash $ fn2s f) ++ ""] else ["R "++fn2fp f] summ (f,-1,_,_,False) = if use_xml then ["" ++ escapeXML (drop_dotslash $ fn2s f) ++ ""] else ["A "++fn2fp f] summ (f,0,0,0,False) | f == fp2fn "" = [] summ (f,a,b,r,False) = if use_xml then ["" ++ escapeXML (drop_dotslash $ fn2s f) ++ xrm a ++ xad b ++ xrp r ++ ""] else ["M "++fn2fp f++rm a++ad b++rp r] summ (f,_,-1,_,True) = if use_xml then ["" ++ escapeXML (drop_dotslash $ fn2s f) ++ ""] else ["R "++fn2fp f++"/"] summ (f,-1,_,_,True) = if use_xml then ["" ++ escapeXML (drop_dotslash $ fn2s f) ++ ""] else ["A "++fn2fp f++"/"] summ _ = [] ad 0 = "" ad a = " +"++show a xad 0 = "" xad a = "" rm 0 = "" rm a = " -"++show a xrm 0 = "" xrm a = "" rp 0 = "" rp a = " r"++show a xrp 0 = "" xrp a = "" drop_dotslash ('.':'/':str) = drop_dotslash str drop_dotslash str = str themoves :: [String] themoves = concatMap showmoves $ flatten_to_primitives p showmoves (Move a b) = if use_xml then ["" ] else [" "++fn2fp a++" -> "++fn2fp b] showmoves _ = [] \end{code} %FIXME: The following code needs to be moved. It is a function %``is\_similar'' which tells you if two patches are in the same category %human-wise. Currently it just returns true if they are filepatches on the %same file. \begin{code} is_similar :: Patch -> Patch -> Bool is_similar (FP f _) (FP f' _) = f == f' is_similar p1 p2 = p1 == p2 is_addfile :: Patch -> Bool is_addfile (FP _ AddFile) = True is_addfile _ = False is_hunk :: Patch -> Bool is_hunk (FP _ (Hunk _ _ _)) = True is_hunk _ = False is_setpref :: Patch -> Bool is_setpref (ChangePref _ _ _) = True is_setpref _ = False \end{code} %files or directories, changed by a patch %we get it solely from the patch here %instead of performing patch apply on a population %we !could! achieve the same by applying a patch to a cleaned population %and getting modified files and dirs %but this should be significantly slower when the population grows large %This could be useful for just presenting a summary of what a patch does %(especially useful for larger repos) \begin{code} patchChanges :: Patch -> [(String,DirMark)] patchChanges (NamedP _ _ p) = patchChanges p patchChanges (Move f1 f2) = [(fn2fp f1,MovedFile $ fn2fp f2), (fn2fp f2,MovedFile $ fn2fp f1)] patchChanges (DP d AddDir) = [(fn2fp d,AddedDir)] patchChanges (DP d RmDir) = [(fn2fp d,RemovedDir)] patchChanges (FP f AddFile) = [(fn2fp f,AddedFile)] patchChanges (FP f RmFile) = [(fn2fp f,RemovedFile)] patchChanges (FP f _) = [(fn2fp f,ModifiedFile)] patchChanges (Split ps) = concatMap patchChanges ps patchChanges (ComP ps) = concatMap patchChanges ps patchChanges p | is_merger p = patchChanges $ merger_equivalent p patchChanges (Merger _ _ _ _ _ _) = impossible patchChanges (ChangePref _ _ _) = [] \end{code} %apply a patch to a population at a given time \begin{code} applyToPop :: PatchInfo -> Patch -> Population -> Population applyToPop pi patch (Pop _ tree) = Pop pi (applyToPopTree patch tree) -- ``pi'' is global below! where applyToPopTree :: Patch -> PopTree -> PopTree applyToPopTree (NamedP _ _ p) tr = applyToPopTree p tr applyToPopTree p tr | is_merger p = applyToPopTree (merger_equivalent p) tr applyToPopTree (Merger _ _ _ _ _ _) _ = impossible applyToPopTree (ComP ps) tr = foldl (\t p -> applyToPopTree p t) tr ps applyToPopTree (Split ps) tr = foldl (\t p -> applyToPopTree p t) tr ps applyToPopTree p@(FP f _) tr = popChange (splitPS '/' (fn2ps f)) p tr applyToPopTree p@(DP d _) tr = popChange (splitPS '/' (fn2ps d)) p tr -- precondition: ``to'' does not exist yet! applyToPopTree (Move from to) tr = case (breakP (splitPS '/' (fn2ps from)) tr) of (tr',Just ins) -> let to' = (splitPS '/' (fn2ps to)) ins' = case ins of PopDir i trs -> PopDir (i {nameI = last to', modifiedByI = pi, modifiedHowI = MovedDir (fn2fp from)}) trs PopFile i -> PopFile (i {nameI = last to', modifiedByI = pi, modifiedHowI = MovedFile (fn2fp from)}) in insertP to' tr' ins' _ -> tr -- ignore the move if ``from'' couldn't be found applyToPopTree (ChangePref _ _ _) tr = tr -- break a poptree fst: org tree with subtree removed, -- snd: removed subtree breakP :: [PackedString] -> PopTree -> (PopTree,Maybe PopTree) breakP [parent,path] tr@(PopDir f trees) | parent == (nameI f) = case findRem path trees of Just (trees',tree') -> (PopDir f trees',Just tree') _ -> (tree,Nothing) | otherwise = (tr,Nothing) where findRem _ [] = Nothing findRem the_path (d:trs) | the_path == pname d = Just (trs,d) | otherwise = do (trs',d') <- findRem the_path trs return (d:trs',d') breakP (n:rest) tr@(PopDir f trs) | (nameI f) == n = case catMaybes inss of [ins] -> (PopDir f trs', Just ins) [] -> (tr,Nothing) _ -> error "breakP: more than one break" | otherwise = (tr,Nothing) where (trs',inss) = unzip (map (breakP rest) trs) breakP _ tr = (tr,Nothing) -- insert snd arg into fst arg insertP :: [PackedString] -> PopTree -> PopTree -> PopTree insertP [parent,_] org@(PopDir f trs) tr | parent == (nameI f) = PopDir f (tr:trs) | otherwise = org insertP (n:rest) org@(PopDir f trs) tr | (nameI f) == n = PopDir f trs' | otherwise = org where trs' = map (\o -> insertP rest o tr) trs insertP _ org _ = org -- change a population according to a patch popChange :: [PackedString] -> Patch -> PopTree -> PopTree popChange [parent,path] (DP d AddDir) tr@(PopDir f trs) | parent == (nameI f) = PopDir f (new:trs) | otherwise = tr where new = PopDir (Info {nameI = path, modifiedByI = pi, modifiedHowI = AddedDir, createdByI = Just pi, creationNameI = Just $ fn2ps d}) [] -- only mark a directory (and contents) as ``deleted'' do not delete it actually popChange [path] (DP _ RmDir) tr@(PopDir f trs) | path == (nameI f) = PopDir (f {modifiedByI = pi, modifiedHowI = RemovedDir}) trs' | otherwise = tr where trs' = map markDel trs -- recursively ``delete'' the contents popChange [parent,path] (FP d AddFile) tr@(PopDir f trs) | parent == (nameI f) = PopDir f (new:trs) | otherwise = tr where new = PopFile (Info {nameI = path, modifiedByI = pi, modifiedHowI = AddedFile, createdByI = Just pi, creationNameI = Just $ fn2ps d}) popChange [path] (FP _ RmFile) tr@(PopFile f) | path == (nameI f) = PopFile (f {modifiedByI = pi, modifiedHowI = RemovedFile}) | otherwise = tr popChange [path] (FP _ _) (PopFile f) | path == (nameI f) = PopFile (f {modifiedByI = pi, modifiedHowI = if modifiedHowI f == AddedFile && modifiedByI f == pi then AddedFile else ModifiedFile}) popChange (n:rest) p tr@(PopDir f trs) | (nameI f) == n = PopDir f (map (popChange rest p) trs) | otherwise = tr popChange _ _ tr = tr markDel (PopDir f trs) = PopDir (f {modifiedByI = pi, modifiedHowI = RemovedDir}) trs' where trs' = map markDel trs markDel (PopFile f) = PopFile (f {modifiedByI = pi, modifiedHowI = RemovedFile}) pname :: PopTree -> PackedString pname (PopDir i _) = nameI i pname (PopFile i) = nameI i \end{code}