% 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 #-}

#include "gadts.h"

module Darcs.Patch.Apply ( applyToFilepaths,
                           markupFile, emptyMarkedupFile,
                           LineMark(..), MarkedUpFile )

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, breakAfterNthNewline, breakBeforeNthNewline, )

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(..),
                          tryTokInternal, showHunk, FileNameFormat(..) )
import Darcs.Patch.Info ( PatchInfo )
import Control.Monad ( when )
import Darcs.Patch.RegChars ( regChars )
import Darcs.Repository.Prefs ( changePrefval )
import Darcs.Global ( darcsdir )
import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) )
import Darcs.FilePathMonad ( withFilePaths )
#include "impossible.h"
import Darcs.Witnesses.Ordered ( FL(..), (:>)(..),
                             mapFL, mapFL_FL, spanFL, foldlFL )

import Storage.Hashed.Tree( Tree )
import Storage.Hashed.Monad( virtualTreeIO )
import Printer( renderString )

type FileContents = B.ByteString
\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}
applyToFilepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath]
applyToFilepaths pa fs = withFilePaths fs (apply [] pa)

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

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 (tryTokInternal 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 $ changePrefval 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 " ++
                                   (renderString $ showHunk NewFormat f line old new) ++
                                   " to file " ++ fn2fp f ++ ": " ++ show ps
          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 breakBeforeNthNewline (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 breakBeforeNthNewline (l - 2) ps of
      (prfix, after_prefix) ->
          case breakBeforeNthNewline (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 breakAfterNthNewline (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)]
emptyMarkedupFile :: MarkedUpFile
emptyMarkedupFile = [(B.empty, None)]

markupFile :: Effect p => PatchInfo -> p C(x y)
            -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)
markupFile x p = mps (effect p)
    where mps :: FL Prim C(a b) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)
          mps NilFL = id
          mps (pp:>:pps) = mps pps . markupPrim x pp

markupPrim :: PatchInfo -> Prim C(x y)
            -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)
markupPrim _ (Split NilFL) (f, mk) = (f, mk)
markupPrim n (Split (p:>:ps)) (f, mk) = markupPrim n (Split ps) $
                                       markupPrim n p (f, mk)
markupPrim _ (FP _ AddFile) (f, mk) = (f, mk)
markupPrim _ (FP _ RmFile) (f, mk) = (f, mk)
markupPrim n (FP f' (Hunk line old new)) (f, mk)
    | fn2fp f' /= f = (f, mk)
    | otherwise = (f, markupHunk n line old new mk)
markupPrim name (FP f' (TokReplace t o n)) (f, mk)
    | fn2fp f' /= f = (f, mk)
    | otherwise = (f, markupTok name t o n mk)
markupPrim _ (DP _ _) (f, mk) = (f, mk)
markupPrim _ (Move d d') (f, mk) = (fn2fp $ movedirfilename d d' (fp2fn f), mk)
markupPrim _ (ChangePref _ _ _) (f,mk) = (f,mk)
markupPrim _ Identity (f,mk) = (f,mk)
markupPrim n (FP f' (Binary _ _)) (f,mk)
    | fn2fp f' == f = (f,(BC.pack "Binary file", AddedLine n):mk)
    | otherwise = (f,mk)

markupHunk :: PatchInfo -> Int -> [B.ByteString] -> [B.ByteString]
            -> MarkedUpFile -> MarkedUpFile
markupHunk n l old new ((sf, RemovedLine pi):mk) =
    (sf, RemovedLine pi) : markupHunk n l old new mk
markupHunk n l old new ((sf, AddedRemovedLine po pn):mk) =
    (sf, AddedRemovedLine po pn) : markupHunk n l old new mk

markupHunk name 1 old (n:ns) mk =
    (n, AddedLine name) : markupHunk name 1 old ns mk
markupHunk n 1 (o:os) [] ((sf, None):mk)
    | o == sf = (sf, RemovedLine n) : markupHunk n 1 os [] mk
    | otherwise = [(BC.pack "Error in patch application", AddedLine n)]
markupHunk n 1 (o:os) [] ((sf, AddedLine nold):mk)
    | o == sf = (sf, AddedRemovedLine nold n) : markupHunk n 1 os [] mk
    | otherwise = [(BC.pack "Error in patch application", AddedLine n)]
markupHunk _ 1 [] [] mk = mk

markupHunk n l old new ((sf, AddedLine pi):mk)
    | l > 1 = (sf, AddedLine pi) : markupHunk n (l-1) old new mk
    | l < 1 = (sf, AddedLine pi) : markupHunk n (l-1) old new mk
markupHunk n l old new ((sf, None):mk)
    | l > 1 = (sf, None) : markupHunk n (l-1) old new mk
    | l < 1 = (sf, None) : markupHunk n (l-1) old new mk

markupHunk _ _ _ _ [] = []

markupHunk _ _ _ _ mk = (BC.pack "Error: ",None) : mk

markupTok :: PatchInfo -> String -> String -> String
           -> MarkedUpFile -> MarkedUpFile
markupTok 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` tryTokInternal 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

    :: 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)})
                          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

-- | Apply a patch to a 'Tree', yielding a new 'Tree'.
applyToTree :: (Apply p) => p C(x y) -> Tree IO -> IO (Tree IO)
applyToTree patch t = snd `fmap` virtualTreeIO (apply [] patch) t