% Copyright (C) 2002-2005 David Roundy % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2, or (at your option) % any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program; see the file COPYING. If not, write to % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, % Boston, MA 02110-1301, USA. \begin{code} {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} {-# LANGUAGE CPP #-} #include "gadts.h" module Darcs.Patch.Apply ( apply_to_filepaths, apply_to_slurpy, forceTokReplace, markup_file, empty_markedup_file, patchChanges, applyToPop, LineMark(..), MarkedUpFile, force_replace_slurpy ) where import Prelude hiding ( catch, pi ) import Darcs.Flags ( DarcsFlag( SetScriptsExecutable ) ) import qualified Data.ByteString.Char8 as BC (split, break, pack, singleton) import qualified Data.ByteString as B (ByteString, null, empty, concat, isPrefixOf) import ByteStringUtils ( linesPS, unlinesPS, break_after_nth_newline, break_before_nth_newline, ) import Darcs.Patch.FileName ( fn2ps, fn2fp, fp2fn, movedirfilename ) import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..) ) import Data.List ( intersperse ) import Data.Maybe ( catMaybes ) import Darcs.Patch.Patchy ( Apply, apply, applyAndTryToFixFL, applyAndTryToFix, mapMaybeSnd ) import Darcs.Patch.Commute () import Darcs.Patch.Core ( Patch(..), Named(..) ) import Darcs.Patch.Prim ( Prim(..), Effect(effect), DirPatchType(..), FilePatchType(..), try_tok_internal ) import Darcs.Patch.Info ( PatchInfo ) import Control.Monad ( when ) import Darcs.SlurpDirectory ( FileContents, Slurpy, withSlurpy, slurp_modfile ) import RegChars ( regChars ) import Darcs.Repository.Prefs ( change_prefval ) import Darcs.Global ( darcsdir ) import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) ) import Darcs.FilePathMonad ( withFilePaths ) #include "impossible.h" import Darcs.Ordered ( FL(..), (:>)(..), mapFL, mapFL_FL, spanFL, foldlFL ) \end{code} \section{Introduction} 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 composite 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. \section{Applying patches} \begin{code} apply_to_filepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath] apply_to_filepaths pa fs = withFilePaths fs (apply [] pa) apply_to_slurpy :: (Apply p, Monad m) => p C(x y) -> Slurpy -> m Slurpy apply_to_slurpy p s = case withSlurpy s (apply [] p) of Left err -> fail err Right (s', ()) -> return s' instance Apply p => Apply (Named p) where apply opts (NamedP _ _ p) = apply opts p applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p instance Apply Patch where apply opts p = applyFL opts $ effect p applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x applyAndTryToFixFL (ComP xs) = mapMaybeSnd (\xs' -> ComP xs' :>: NilFL) `fmap` applyAndTryToFix xs applyAndTryToFixFL x = do apply [] x; return Nothing applyAndTryToFix (ComP xs) = mapMaybeSnd ComP `fmap` applyAndTryToFix xs applyAndTryToFix x = do mapMaybeSnd ComP `fmap` applyAndTryToFixFL x force_replace_slurpy :: Prim C(x y) -> 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." instance Apply Prim where apply opts (Split ps) = applyFL opts ps apply _ Identity = return () apply _ (FP f RmFile) = mRemoveFile f apply _ (FP f AddFile) = mCreateFile f apply opts p@(FP _ (Hunk _ _ _)) = applyFL opts (p :>: NilFL) apply _ (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace where doreplace ls = case mapM (try_tok_internal t (BC.pack o) (BC.pack n)) ls of Nothing -> fail $ "replace patch to " ++ fn2fp f ++ " couldn't apply." Just ls' -> return $ map B.concat ls' apply _ (FP f (Binary o n)) = mModifyFilePS f doapply where doapply oldf = if o == oldf then return n else fail $ "binary patch to " ++ fn2fp f ++ " couldn't apply." apply _ (DP d AddDir) = mCreateDirectory d apply _ (DP d RmDir) = mRemoveDirectory d apply _ (Move f f') = mRename f f' apply _ (ChangePref p f t) = do b <- mDoesDirectoryExist (fp2fn $ darcsdir++"/prefs") when b $ change_prefval p f t applyAndTryToFixFL (FP f RmFile) = do x <- mReadFilePS f if B.null x then do mRemoveFile f return Nothing else do mWriteFilePS f B.empty mRemoveFile f return $ Just ("WARNING: Fixing removal of non-empty file "++fn2fp f, FP f (Binary x B.empty) :>: FP f RmFile :>: NilFL ) applyAndTryToFixFL p = do apply [] p; return Nothing applyFL :: WriteableDirectory m => [DarcsFlag] -> FL Prim C(x y) -> m () applyFL _ NilFL = return () applyFL opts ((FP f h@(Hunk _ _ _)):>:the_ps) = case spanFL f_hunk the_ps of (xs :> ps') -> do let foo = h :>: mapFL_FL (\(FP _ h') -> h') xs mModifyFilePS f $ hunkmod foo case h of (Hunk 1 _ (n:_)) | BC.pack "#!" `B.isPrefixOf` n && SetScriptsExecutable `elem` opts -> mSetFileExecutable f True _ -> return () applyFL opts ps' where f_hunk (FP f' (Hunk _ _ _)) | f == f' = True f_hunk _ = False hunkmod :: WriteableDirectory m => FL FilePatchType C(x y) -> B.ByteString -> m B.ByteString hunkmod NilFL ps = return ps hunkmod (Hunk line old new:>:hs) ps = case applyHunkLines [(line,old,new)] ps of Just ps' -> hunkmod hs ps' Nothing -> fail $ "Error applying hunk to file " ++ fn2fp f hunkmod _ _ = impossible applyFL opts (p:>:ps) = do apply opts p applyFL opts ps \end{code} \subsection{Hunk patches} 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} applyHunks :: [(Int, [B.ByteString], [B.ByteString])] -> B.ByteString -> Maybe [B.ByteString] applyHunks [] ps = Just [ps] applyHunks ((l, [], n):hs) ps = case break_before_nth_newline (l - 2) ps of (prfix, after_prefix) -> do rest <- applyHunks hs after_prefix return $ intersperse nl (prfix:n) ++ rest where nl = BC.singleton '\n' applyHunks ((l, o, n):hs) ps = case break_before_nth_newline (l - 2) ps of (prfix, after_prefix) -> case break_before_nth_newline (length o) after_prefix of (oo, _) | oo /= unlinesPS (B.empty:o) -> fail "applyHunks error" (_, suffix) -> do rest <- applyHunks hs suffix return $ intersperse nl (prfix:n) ++ rest where nl = BC.singleton '\n' applyHunkLines :: [(Int, [B.ByteString], [B.ByteString])] -> FileContents -> Maybe FileContents applyHunkLines [] c = Just c applyHunkLines [(1, [], n)] ps | B.null ps = Just $ unlinesPS (n++[B.empty]) applyHunkLines hs@((l, o, n):hs') ps = do pss <- case l of 1 -> case break_after_nth_newline (length o) ps of Nothing -> if ps == unlinesPS o then return $ intersperse nl n else fail "applyHunkLines: Unexpected hunks" Just (shouldbeo, suffix) | shouldbeo /= unlinesPS (o++[B.empty]) -> fail $ "applyHunkLines: Bad patch!" | null n -> do x <- applyHunkLines hs' suffix return [x] | otherwise -> do rest <- applyHunks hs' suffix return $ intersperse nl n ++ nl:rest _ | l < 0 -> bug "Prim.applyHunkLines: After -ve lines?" | otherwise -> applyHunks hs ps let result = B.concat pss return result where nl = BC.singleton '\n' \end{code} \subsection{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\ldots]\ 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 $ unlinesPS $ map forceReplace $ linesPS c where o = BC.pack os n = BC.pack ns tokchar = regChars t toks_and_intratoks ps | B.null ps = [] toks_and_intratoks ps = let (before,s') = BC.break tokchar ps (tok, after) = BC.break (not . tokchar) s' in before : tok : toks_and_intratoks after forceReplace ps = B.concat $ map o_t_n $ toks_and_intratoks ps o_t_n s | s == o = n | otherwise = s \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 this 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{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 necessary 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 necessary for an %external module to do the formatting. \begin{code} data LineMark = AddedLine PatchInfo | RemovedLine PatchInfo | AddedRemovedLine PatchInfo PatchInfo | None deriving (Show) type MarkedUpFile = [(B.ByteString, LineMark)] empty_markedup_file :: MarkedUpFile empty_markedup_file = [(B.empty, None)] markup_file :: Effect p => PatchInfo -> p C(x y) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) markup_file x p = mps (effect p) where mps :: FL Prim C(a b) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) mps NilFL = id mps (pp:>:pps) = mps pps . markup_prim x pp markup_prim :: PatchInfo -> Prim C(x y) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) markup_prim _ (Split NilFL) (f, mk) = (f, mk) markup_prim n (Split (p:>:ps)) (f, mk) = markup_prim n (Split ps) $ markup_prim n p (f, mk) markup_prim _ (FP _ AddFile) (f, mk) = (f, mk) markup_prim _ (FP _ RmFile) (f, mk) = (f, mk) markup_prim n (FP f' (Hunk line old new)) (f, mk) | fn2fp f' /= f = (f, mk) | otherwise = (f, markup_hunk n line old new mk) markup_prim name (FP f' (TokReplace t o n)) (f, mk) | fn2fp f' /= f = (f, mk) | otherwise = (f, markup_tok name t o n mk) markup_prim _ (DP _ _) (f, mk) = (f, mk) markup_prim _ (Move d d') (f, mk) = (fn2fp $ movedirfilename d d' (fp2fn f), mk) markup_prim _ (ChangePref _ _ _) (f,mk) = (f,mk) markup_prim _ Identity (f,mk) = (f,mk) markup_prim n (FP f' (Binary _ _)) (f,mk) | fn2fp f' == f = (f,(BC.pack "Binary file", AddedLine n):mk) | otherwise = (f,mk) markup_hunk :: PatchInfo -> Int -> [B.ByteString] -> [B.ByteString] -> 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 = [(BC.pack "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 = [(BC.pack "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 = (BC.pack "Error: ",None) : mk markup_tok :: PatchInfo -> String -> String -> String -> MarkedUpFile -> MarkedUpFile markup_tok name t ostr nstr mk = concatMap mt mk where o = BC.pack ostr n = BC.pack nstr mt (sf, AddedLine pi) = case B.concat `fmap` 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), (BC.pack "There seems to be an inconsistency...", None), (BC.pack "Please run darcs check.", None)] mt mark = [mark] \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 :: Prim C(x y) -> [(String,DirMark)] 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) = concat $ mapFL patchChanges ps patchChanges (ChangePref _ _ _) = [] patchChanges Identity = [] \end{code} %apply a patch to a population at a given time \begin{code} applyToPop :: PatchInfo -> FL Prim C(x y) -> Population -> Population applyToPop _ NilFL = id applyToPop pinf (p:>:ps) = applyToPop pinf ps . applyToPop' pinf p applyToPop' :: PatchInfo -> Prim C(x y) -> Population -> Population applyToPop' pi patch (Pop _ tree) = Pop pi (applyToPopTree patch tree) -- ``pi'' is global below! where applyToPopTree :: Prim C(x y) -> PopTree -> PopTree applyToPopTree (Split ps) tr = foldlFL (\t p -> applyToPopTree p t) tr ps applyToPopTree p@(FP f AddFile) tr = let xxx = BC.split '/' (fn2ps f) in popChange xxx p $ fst $ breakP xxx tr applyToPopTree p@(FP f _) tr = popChange (BC.split '/' (fn2ps f)) p tr applyToPopTree p@(DP f AddDir) tr = let xxx = BC.split '/' (fn2ps f) in popChange xxx p $ fst $ breakP xxx tr applyToPopTree p@(DP d _) tr = popChange (BC.split '/' (fn2ps d)) p tr -- precondition: ``to'' does not exist yet! applyToPopTree (Move from to) tr = case breakP (BC.split '/' (fn2ps from)) $ fst $ breakP (BC.split '/' $ fn2ps to) tr of (tr',Just ins) -> let to' = (BC.split '/' (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 applyToPopTree Identity tr = tr -- insert snd arg into fst arg insertP :: [B.ByteString] -> 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 :: [B.ByteString] -> Prim C(x y) -> 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}) -- break a poptree fst: org tree with subtree removed, -- snd: removed subtree breakP :: [B.ByteString] -> 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') _ -> (tr,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) pname :: PopTree -> B.ByteString pname (PopDir i _) = nameI i pname (PopFile i) = nameI i \end{code}