%  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 -fglasgow-exts -fno-warn-orphans #-}
#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,
                           -- to cut later:
                           applyBinary )
    where

import Prelude hiding ( catch, pi )
import Darcs.Flags ( DarcsFlag( SetScriptsExecutable ) )
import FastPackedString ( PackedString, packString, splitPS, concatPS,
                          breakPS, nullPS, nilPS, linesPS, takePS,
                          unlinesPS,
                          break_after_nth_newline,
                          break_before_nth_newline, )
import 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 )
import Darcs.Patch.Commute ()
import Darcs.Patch.Core ( Patch(..), Named(..) )
import Darcs.Patch.Prim ( Prim(..), Effect(effect),
                          DirPatchType(..), FilePatchType(..),
                          applyBinary, 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.IO ( WriteableDirectory(..), ReadableDirectory(..) )
import Darcs.FilePathMonad ( withFilePaths )
#include "impossible.h"
import Darcs.Patch.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'
\end{code}

\begin{code}
instance Apply p => Apply (Named p) where
    apply opts (NamedP _ _ p) = apply opts p

instance Apply Patch where
    apply opts p = applyFL opts $ effect p
\end{code}

\begin{code}
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."
\end{code}

\begin{code}
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 (packString o) (packString n)) ls of
                  Nothing -> fail $ "replace patch to " ++ fn2fp f
                             ++ " couldn't apply."
                  Just ls' -> return $ map concatPS 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 "_darcs/prefs")
           when b $ change_prefval p f t

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:_)) | takePS 2 n == packString "#!" &&
                                   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)
                  -> PackedString -> m PackedString
          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, [PackedString], [PackedString])]
           -> PackedString -> Maybe [PackedString]
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 = packString "\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 (nilPS:o) -> fail "applyHunks error"
          (_, suffix) ->
              do rest <- applyHunks hs suffix
                 return $ intersperse nl (prfix:n) ++ rest
    where nl = packString "\n"

applyHunkLines :: [(Int, [PackedString], [PackedString])]
               -> FileContents -> Maybe FileContents
applyHunkLines [] c = Just c
applyHunkLines [(1, [], n)] ps | nullPS ps = Just $ unlinesPS (n++[nilPS])
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++[nilPS]) ->
                        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 = concatPS pss
    return result
    where nl = packString "\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 = 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
\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 = [(PackedString, LineMark)]
empty_markedup_file :: MarkedUpFile
empty_markedup_file = [(nilPS, 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,(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 = concatMap mt mk
    where o = packString ostr
          n = packString nstr
          mt (sf, AddedLine pi) =
              case concatPS `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),
                   (packString "There seems to be an inconsistency...", None),
                   (packString "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 = splitPS '/' (fn2ps  f) in
               popChange xxx p $ fst $ breakP xxx tr
       applyToPopTree p@(FP f _) tr = popChange (splitPS '/' (fn2ps  f)) p tr
       applyToPopTree p@(DP f AddDir) tr =
           let xxx = splitPS '/' (fn2ps  f) in
               popChange xxx p $ fst $ breakP xxx 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)) $
               fst $ breakP (splitPS '/' $ fn2ps to) 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
       applyToPopTree Identity tr = tr

       -- 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] -> 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 :: [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')
                         _ -> (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 -> PackedString
pname (PopDir i _) = nameI i
pname (PopFile i) = nameI i
\end{code}

