{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE MultiWayIf #-}
module Darcs.Patch.Prim.V1.Apply () where

import Darcs.Prelude

import Control.Exception ( throw )

import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Repair ( RepairToFL(..) )

import Darcs.Patch.Prim.Class ( PrimApply(..) )
import Darcs.Patch.Prim.V1.Core
    ( Prim(..),
      DirPatchType(..), FilePatchType(..) )
import Darcs.Patch.Prim.V1.Show ( showHunk )

import Darcs.Util.Path ( AnchoredPath, anchorPath )
import Darcs.Patch.Format ( FileNameFormat(FileNameFormatDisplay) )
import Darcs.Patch.TokenReplace ( tryTokReplace )

import Darcs.Patch.ApplyMonad ( ApplyMonadTree(..) )
import Darcs.Util.Tree( Tree )

import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, spanFL, (:>)(..) )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart )

import Darcs.Util.ByteString ( unlinesPS )
import Darcs.Util.Printer( renderString )

import qualified Data.ByteString as B
    ( ByteString
    , drop
    , empty
    , null
    , concat
    , isPrefixOf
    , length
    , splitAt
    )
import qualified Data.ByteString.Char8 as BC (pack, unpack, unlines, elemIndices)

type FileContents = B.ByteString

ap2fp :: AnchoredPath -> FilePath
ap2fp :: AnchoredPath -> FilePath
ap2fp = FilePath -> AnchoredPath -> FilePath
anchorPath FilePath
""

instance Apply Prim where
    type ApplyState Prim = Tree
    apply :: Prim wX wY -> m ()
apply (FP AnchoredPath
f FilePatchType wX wY
RmFile) = AnchoredPath -> m ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveFile AnchoredPath
f
    apply (FP AnchoredPath
f FilePatchType wX wY
AddFile) = AnchoredPath -> m ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateFile AnchoredPath
f
    apply (FP AnchoredPath
f (Hunk Int
l [ByteString]
o [ByteString]
n)) = AnchoredPath -> (ByteString -> m ByteString) -> m ()
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> (ByteString -> m ByteString) -> m ()
mModifyFilePS AnchoredPath
f ((ByteString -> m ByteString) -> m ())
-> (ByteString -> m ByteString) -> m ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath
-> (Int, [ByteString], [ByteString]) -> ByteString -> m ByteString
forall (m :: * -> *).
Monad m =>
AnchoredPath
-> (Int, [ByteString], [ByteString]) -> ByteString -> m ByteString
applyHunk AnchoredPath
f (Int
l, [ByteString]
o, [ByteString]
n)
    apply (FP AnchoredPath
f (TokReplace FilePath
t FilePath
o FilePath
n)) = AnchoredPath -> (ByteString -> m ByteString) -> m ()
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> (ByteString -> m ByteString) -> m ()
mModifyFilePS AnchoredPath
f ByteString -> m ByteString
forall (m :: * -> *). Monad m => ByteString -> m ByteString
doreplace
        where doreplace :: ByteString -> m ByteString
doreplace ByteString
fc =
                  case FilePath
-> ByteString -> ByteString -> ByteString -> Maybe ByteString
tryTokReplace FilePath
t (FilePath -> ByteString
BC.pack FilePath
o) (FilePath -> ByteString
BC.pack FilePath
n) ByteString
fc of
                  Maybe ByteString
Nothing -> IOError -> m ByteString
forall a e. Exception e => e -> a
throw (IOError -> m ByteString) -> IOError -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError (FilePath -> IOError) -> FilePath -> IOError
forall a b. (a -> b) -> a -> b
$ FilePath
"replace patch to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
ap2fp AnchoredPath
f
                             FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" couldn't apply."
                  Just ByteString
fc' -> ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
fc'
    apply (FP AnchoredPath
f (Binary ByteString
o ByteString
n)) = AnchoredPath -> (ByteString -> m ByteString) -> m ()
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> (ByteString -> m ByteString) -> m ()
mModifyFilePS AnchoredPath
f ByteString -> m ByteString
forall (m :: * -> *). Monad m => ByteString -> m ByteString
doapply
        where doapply :: ByteString -> m ByteString
doapply ByteString
oldf = if ByteString
o ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
oldf
                             then ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
n
                             else IOError -> m ByteString
forall a e. Exception e => e -> a
throw (IOError -> m ByteString) -> IOError -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError
                                  (FilePath -> IOError) -> FilePath -> IOError
forall a b. (a -> b) -> a -> b
$ FilePath
"binary patch to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
ap2fp AnchoredPath
f
                                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" couldn't apply."
    apply (DP AnchoredPath
d DirPatchType wX wY
AddDir) = AnchoredPath -> m ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateDirectory AnchoredPath
d
    apply (DP AnchoredPath
d DirPatchType wX wY
RmDir) = AnchoredPath -> m ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveDirectory AnchoredPath
d
    apply (Move AnchoredPath
f AnchoredPath
f') = AnchoredPath -> AnchoredPath -> m ()
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> AnchoredPath -> m ()
mRename AnchoredPath
f AnchoredPath
f'
    apply (ChangePref FilePath
p FilePath
f FilePath
t) = FilePath -> FilePath -> FilePath -> m ()
forall (m :: * -> *).
ApplyMonadTree m =>
FilePath -> FilePath -> FilePath -> m ()
mChangePref FilePath
p FilePath
f FilePath
t

instance RepairToFL Prim where
    applyAndTryToFixFL :: Prim wX wY -> m (Maybe (FilePath, FL Prim wX wY))
applyAndTryToFixFL (FP AnchoredPath
f FilePatchType wX wY
RmFile) =
        do ByteString
x <- AnchoredPath -> m ByteString
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> m ByteString
mReadFilePS AnchoredPath
f
           AnchoredPath -> m ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveFile AnchoredPath
f
           Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath, FL Prim wX wY)
 -> m (Maybe (FilePath, FL Prim wX wY)))
-> Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
B.null ByteString
x
                        then Maybe (FilePath, FL Prim wX wY)
forall a. Maybe a
Nothing
                        else (FilePath, FL Prim wX wY) -> Maybe (FilePath, FL Prim wX wY)
forall a. a -> Maybe a
Just (FilePath
"WARNING: Fixing removal of non-empty file "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++AnchoredPath -> FilePath
ap2fp AnchoredPath
f,
                                   -- No need to coerce because the content
                                   -- removal patch has freely decided contexts
                                   AnchoredPath -> FilePatchType wX Any -> Prim wX Any
forall wX wY. AnchoredPath -> FilePatchType wX wY -> Prim wX wY
FP AnchoredPath
f (ByteString -> ByteString -> FilePatchType wX Any
forall wX wY. ByteString -> ByteString -> FilePatchType wX wY
Binary ByteString
x ByteString
B.empty) Prim wX Any -> FL Prim Any wY -> FL Prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: AnchoredPath -> FilePatchType Any wY -> Prim Any wY
forall wX wY. AnchoredPath -> FilePatchType wX wY -> Prim wX wY
FP AnchoredPath
f FilePatchType Any wY
forall wX wY. FilePatchType wX wY
RmFile Prim Any wY -> FL Prim wY wY -> FL Prim Any wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL Prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL )
    applyAndTryToFixFL (FP AnchoredPath
f FilePatchType wX wY
AddFile) =
        do Bool
exists <- AnchoredPath -> m Bool
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesFileExist AnchoredPath
f
           if Bool
exists
             then Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath, FL Prim wX wY)
 -> m (Maybe (FilePath, FL Prim wX wY)))
-> Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall a b. (a -> b) -> a -> b
$
                     (FilePath, FL Prim wX wY) -> Maybe (FilePath, FL Prim wX wY)
forall a. a -> Maybe a
Just (FilePath
"WARNING: Dropping add of existing file "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++AnchoredPath -> FilePath
ap2fp AnchoredPath
f,
                           -- the old context was wrong, so we have to coerce
                           FL Prim wY wY -> FL Prim wX wY
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL Prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
                          )
             else do AnchoredPath -> m ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateFile AnchoredPath
f
                     Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FilePath, FL Prim wX wY)
forall a. Maybe a
Nothing
    applyAndTryToFixFL (DP AnchoredPath
f DirPatchType wX wY
AddDir) =
        do Bool
exists <- AnchoredPath -> m Bool
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesDirectoryExist AnchoredPath
f
           if Bool
exists
             then Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath, FL Prim wX wY)
 -> m (Maybe (FilePath, FL Prim wX wY)))
-> Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall a b. (a -> b) -> a -> b
$
                     (FilePath, FL Prim wX wY) -> Maybe (FilePath, FL Prim wX wY)
forall a. a -> Maybe a
Just (FilePath
"WARNING: Dropping add of existing directory "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++AnchoredPath -> FilePath
ap2fp AnchoredPath
f,
                           -- the old context was wrong, so we have to coerce
                           FL Prim wY wY -> FL Prim wX wY
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL Prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
                          )
             else do AnchoredPath -> m ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateDirectory AnchoredPath
f
                     Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FilePath, FL Prim wX wY)
forall a. Maybe a
Nothing
    applyAndTryToFixFL (FP AnchoredPath
f (Binary ByteString
old ByteString
new)) =
        do ByteString
x <- AnchoredPath -> m ByteString
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> m ByteString
mReadFilePS AnchoredPath
f
           AnchoredPath -> (ByteString -> m ByteString) -> m ()
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> (ByteString -> m ByteString) -> m ()
mModifyFilePS AnchoredPath
f (\ByteString
_ -> ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
new)
           if ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
old
             then Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath, FL Prim wX wY)
 -> m (Maybe (FilePath, FL Prim wX wY)))
-> Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall a b. (a -> b) -> a -> b
$
                     (FilePath, FL Prim wX wY) -> Maybe (FilePath, FL Prim wX wY)
forall a. a -> Maybe a
Just (FilePath
"WARNING: Fixing binary patch to "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++AnchoredPath -> FilePath
ap2fp AnchoredPath
f,
                           AnchoredPath -> FilePatchType wX wY -> Prim wX wY
forall wX wY. AnchoredPath -> FilePatchType wX wY -> Prim wX wY
FP AnchoredPath
f (ByteString -> ByteString -> FilePatchType wX wY
forall wX wY. ByteString -> ByteString -> FilePatchType wX wY
Binary ByteString
x ByteString
new) Prim wX wY -> FL Prim wY wY -> FL Prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL Prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
                          )
             else Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FilePath, FL Prim wX wY)
forall a. Maybe a
Nothing
    applyAndTryToFixFL p :: Prim wX wY
p@(Move AnchoredPath
old AnchoredPath
new) =
        do Bool
old_is_file <- AnchoredPath -> m Bool
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesFileExist AnchoredPath
old
           Bool
old_is_dir <- AnchoredPath -> m Bool
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesDirectoryExist AnchoredPath
old
           Bool
new_is_file <- AnchoredPath -> m Bool
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesFileExist AnchoredPath
new
           Bool
new_is_dir <- AnchoredPath -> m Bool
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesDirectoryExist AnchoredPath
new
           if | Bool -> Bool
not (Bool
old_is_file Bool -> Bool -> Bool
|| Bool
old_is_dir) ->
                  Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath, FL Prim wX wY)
 -> m (Maybe (FilePath, FL Prim wX wY)))
-> Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall a b. (a -> b) -> a -> b
$
                     (FilePath, FL Prim wX wY) -> Maybe (FilePath, FL Prim wX wY)
forall a. a -> Maybe a
Just (FilePath
"WARNING: Dropping move patch with non-existing source "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++AnchoredPath -> FilePath
ap2fp AnchoredPath
old,
                           FL Prim wY wY -> FL Prim wX wY
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL Prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
                          )
              | Bool
new_is_file Bool -> Bool -> Bool
|| Bool
new_is_dir ->
                  Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath, FL Prim wX wY)
 -> m (Maybe (FilePath, FL Prim wX wY)))
-> Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall a b. (a -> b) -> a -> b
$
                     (FilePath, FL Prim wX wY) -> Maybe (FilePath, FL Prim wX wY)
forall a. a -> Maybe a
Just (FilePath
"WARNING: Dropping move patch with existing target "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++AnchoredPath -> FilePath
ap2fp AnchoredPath
old,
                           FL Prim wY wY -> FL Prim wX wY
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL Prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
                          )
              | Bool
otherwise -> Prim wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply Prim wX wY
p m ()
-> m (Maybe (FilePath, FL Prim wX wY))
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FilePath, FL Prim wX wY)
forall a. Maybe a
Nothing
    applyAndTryToFixFL Prim wX wY
p = Prim wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply Prim wX wY
p m ()
-> m (Maybe (FilePath, FL Prim wX wY))
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (FilePath, FL Prim wX wY)
-> m (Maybe (FilePath, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FilePath, FL Prim wX wY)
forall a. Maybe a
Nothing

instance PrimApply Prim where
    applyPrimFL :: FL Prim wX wY -> m ()
applyPrimFL FL Prim wX wY
NilFL = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    applyPrimFL (FP AnchoredPath
f h :: FilePatchType wX wY
h@(Hunk{}):>:FL Prim wY wY
the_ps)
     = case (forall wW wY. Prim wW wY -> Bool)
-> FL Prim wY wY -> (:>) (FL Prim) (FL Prim) wY wY
forall (a :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> Bool)
-> FL a wX wZ -> (:>) (FL a) (FL a) wX wZ
spanFL forall wW wY. Prim wW wY -> Bool
f_hunk FL Prim wY wY
the_ps of
           (FL Prim wY wZ
xs :> FL Prim wZ wY
ps') ->
               do let foo :: FL FilePatchType wX wZ
foo = FilePatchType wX wY
h FilePatchType wX wY
-> FL FilePatchType wY wZ -> FL FilePatchType wX wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: (forall wW wY. Prim wW wY -> FilePatchType wW wY)
-> FL Prim wY wZ -> FL FilePatchType wY wZ
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL (\(FP _ h') -> FilePatchType wW wY
h') FL Prim wY wZ
xs
                  AnchoredPath -> (ByteString -> m ByteString) -> m ()
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> (ByteString -> m ByteString) -> m ()
mModifyFilePS AnchoredPath
f ((ByteString -> m ByteString) -> m ())
-> (ByteString -> m ByteString) -> m ()
forall a b. (a -> b) -> a -> b
$ FL FilePatchType wX wZ -> ByteString -> m ByteString
forall (m :: * -> *) wX wY.
Monad m =>
FL FilePatchType wX wY -> ByteString -> m ByteString
hunkmod FL FilePatchType wX wZ
foo
                  FL Prim wZ wY -> m ()
forall (prim :: * -> * -> *) (m :: * -> *) wX wY.
(PrimApply prim, ApplyMonad (ApplyState prim) m) =>
FL prim wX wY -> m ()
applyPrimFL FL Prim wZ wY
ps'
        where f_hunk :: Prim wX wY -> Bool
f_hunk (FP AnchoredPath
f' (Hunk{})) = AnchoredPath
f AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
f'
              f_hunk Prim wX wY
_ = Bool
False
              -- TODO there should be a HOF that abstracts
              -- over this recursion scheme
              hunkmod :: Monad m => FL FilePatchType wX wY
                      -> B.ByteString -> m B.ByteString
              hunkmod :: FL FilePatchType wX wY -> ByteString -> m ByteString
hunkmod FL FilePatchType wX wY
NilFL ByteString
content = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
content
              hunkmod (Hunk Int
line [ByteString]
old [ByteString]
new:>:FL FilePatchType wY wY
hs) ByteString
content =
                  AnchoredPath
-> (Int, [ByteString], [ByteString]) -> ByteString -> m ByteString
forall (m :: * -> *).
Monad m =>
AnchoredPath
-> (Int, [ByteString], [ByteString]) -> ByteString -> m ByteString
applyHunk AnchoredPath
f (Int
line, [ByteString]
old, [ByteString]
new) ByteString
content m ByteString -> (ByteString -> m ByteString) -> m ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FL FilePatchType wY wY -> ByteString -> m ByteString
forall (m :: * -> *) wX wY.
Monad m =>
FL FilePatchType wX wY -> ByteString -> m ByteString
hunkmod FL FilePatchType wY wY
hs
              hunkmod FL FilePatchType wX wY
_ ByteString
_ = FilePath -> m ByteString
forall a. HasCallStack => FilePath -> a
error FilePath
"impossible case"
    applyPrimFL (Prim wX wY
p:>:FL Prim wY wY
ps) = Prim wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply Prim wX wY
p m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FL Prim wY wY -> m ()
forall (prim :: * -> * -> *) (m :: * -> *) wX wY.
(PrimApply prim, ApplyMonad (ApplyState prim) m) =>
FL prim wX wY -> m ()
applyPrimFL FL Prim wY wY
ps

applyHunk :: Monad m
          => AnchoredPath
          -> (Int, [B.ByteString], [B.ByteString])
          -> FileContents
          -> m FileContents
applyHunk :: AnchoredPath
-> (Int, [ByteString], [ByteString]) -> ByteString -> m ByteString
applyHunk AnchoredPath
f (Int, [ByteString], [ByteString])
h ByteString
fc =
  case (Int, [ByteString], [ByteString])
-> ByteString -> Either FilePath ByteString
applyHunkLines (Int, [ByteString], [ByteString])
h ByteString
fc of
    Right ByteString
fc' -> ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
fc'
    Left FilePath
msg ->
      IOError -> m ByteString
forall a e. Exception e => e -> a
throw (IOError -> m ByteString) -> IOError -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError (FilePath -> IOError) -> FilePath -> IOError
forall a b. (a -> b) -> a -> b
$
      FilePath
"### Error applying:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int, [ByteString], [ByteString]) -> FilePath
renderHunk (Int, [ByteString], [ByteString])
h FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
      FilePath
"\n### to file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
ap2fp AnchoredPath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
BC.unpack ByteString
fc FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
      FilePath
"### Reason: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg
  where
    renderHunk :: (Int, [ByteString], [ByteString]) -> FilePath
renderHunk (Int
l, [ByteString]
o, [ByteString]
n) = Doc -> FilePath
renderString (FileNameFormat
-> AnchoredPath -> Int -> [ByteString] -> [ByteString] -> Doc
showHunk FileNameFormat
FileNameFormatDisplay AnchoredPath
f Int
l [ByteString]
o [ByteString]
n)

{- The way darcs handles newlines is not easy to understand.

Everything seems pretty logical and conventional as long as files end in a
newline. In this case, the lines in a hunk can be regarded as newline
terminated, too. However, this view breaks down if we consider files that
are not newline terminated.

Here is a different view that covers the general case and explains,
conceptually, the algorithm below.

* Ever line (in a hunk or file) is regarded as being /preceded/ by a newline
  character.

* Every file starts out containing a single newline character, that is, a
  single empty line. A first empty line at the start of a file (if present)
  is /invisible/.

* When lines are appended to a file by a hunk, they are inserted /before/ a
  final empty line, if there is one. This results in a file that remains
  being terminated by a newline.

* In particular, when we start with an empty file and add a line, we push
  the invisible newline back, making it visible, and the newline that
  initiates our new content becomes invisible instead. This results in a
  newline terminated file, as above.

* However, if there is a newline at the end of a file (remember that this
  includes the case of an empty file), a hunk can /remove/ it by removing an
  empty line before adding anything. This results in a file that is /not/
  newline terminated.

The invisible newline character at the front is, of course, not present
anywhere in the representation of files, it is just a conceptual tool.

The algorithm below is highly optimized to minimize allocation of
intermediate ByteStrings. -}

applyHunkLines :: (Int, [B.ByteString], [B.ByteString])
               -> FileContents
               -> Either String FileContents
applyHunkLines :: (Int, [ByteString], [ByteString])
-> ByteString -> Either FilePath ByteString
applyHunkLines (Int
line, [ByteString]
old, [ByteString]
new) ByteString
content
  | Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =
      {- This case is subtle because here we have to deal with any invisible
      newline at the front of a file without it actually being present. We
      first try to drop everything up to the (length old)'th newline. 

      If this fails, we know that the content was not newline terminated. So
      we replace everything with the new content, interspersing but not
      terminating the lines with newline characters.

      If it succeeds, we insert the new content, interspersing /and/
      terminating the lines with newline characters before appending the
      rest of the content. -}
      case Int -> ByteString -> Maybe (ByteString, ByteString)
breakAfterNthNewline ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
old) ByteString
content of
        Maybe (ByteString, ByteString)
Nothing
          -- old content is not newline terminated
          | ByteString
content ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== [ByteString] -> ByteString
unlinesPS [ByteString]
old -> ByteString -> Either FilePath ByteString
forall a b. b -> Either a b
Right (ByteString -> Either FilePath ByteString)
-> ByteString -> Either FilePath ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
unlinesPS [ByteString]
new
          | Bool
otherwise -> FilePath -> Either FilePath ByteString
forall a b. a -> Either a b
Left FilePath
"Hunk wants to remove content that isn't there"
        Just (ByteString
should_be_old, ByteString
suffix)
          -- old content is newline terminated
          | ByteString
should_be_old ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== [ByteString] -> ByteString
BC.unlines [ByteString]
old ->
              ByteString -> Either FilePath ByteString
forall a b. b -> Either a b
Right (ByteString -> Either FilePath ByteString)
-> ByteString -> Either FilePath ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
unlinesPS ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString]
new [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
suffix]
          | Bool
otherwise ->
              FilePath -> Either FilePath ByteString
forall a b. a -> Either a b
Left FilePath
"Hunk wants to remove content that isn't there"
  | Int
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 = do
      {- This is the simpler case. We can be sure that we have at least one
      newline character at the point where we modify the file. This means we
      can apply the conceptual view literally, i.e. replace old content with
      new content /before/ this newline, where the lines in the old and new
      content are /preceded/ by newline characters. -}
      (ByteString
pre, ByteString
start) <- Int -> ByteString -> Either FilePath (ByteString, ByteString)
breakBeforeNthNewline (Int
lineInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2) ByteString
content
      let hunkContent :: [ByteString] -> ByteString
hunkContent [ByteString]
ls = [ByteString] -> ByteString
unlinesPS (ByteString
B.emptyByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
ls)
      ByteString
post <- ByteString -> ByteString -> Either FilePath ByteString
dropPrefix ([ByteString] -> ByteString
hunkContent [ByteString]
old) ByteString
start
      ByteString -> Either FilePath ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either FilePath ByteString)
-> ByteString -> Either FilePath ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
pre, [ByteString] -> ByteString
hunkContent [ByteString]
new, ByteString
post]
  | Bool
otherwise = FilePath -> Either FilePath ByteString
forall a b. a -> Either a b
Left FilePath
"Hunk has zero or negative line number"
  where
    dropPrefix :: ByteString -> ByteString -> Either FilePath ByteString
dropPrefix ByteString
x ByteString
y
      | ByteString
x ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
y = ByteString -> Either FilePath ByteString
forall a b. b -> Either a b
Right (ByteString -> Either FilePath ByteString)
-> ByteString -> Either FilePath ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
x) ByteString
y
      | Bool
otherwise =
        FilePath -> Either FilePath ByteString
forall a b. a -> Either a b
Left (FilePath -> Either FilePath ByteString)
-> FilePath -> Either FilePath ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Hunk wants to remove content that isn't there"

breakAfterNthNewline :: Int -> B.ByteString -> Maybe (B.ByteString, B.ByteString)
breakAfterNthNewline :: Int -> ByteString -> Maybe (ByteString, ByteString)
breakAfterNthNewline Int
0 ByteString
the_ps = (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
B.empty, ByteString
the_ps)
breakAfterNthNewline Int
n ByteString
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = FilePath -> Maybe (ByteString, ByteString)
forall a. HasCallStack => FilePath -> a
error FilePath
"precondition of breakAfterNthNewline"
breakAfterNthNewline Int
n ByteString
the_ps = Int -> [Int] -> Maybe (ByteString, ByteString)
forall t.
(Eq t, Num t) =>
t -> [Int] -> Maybe (ByteString, ByteString)
go Int
n (Char -> ByteString -> [Int]
BC.elemIndices Char
'\n' ByteString
the_ps)
  where
    go :: t -> [Int] -> Maybe (ByteString, ByteString)
go t
_ [] = Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing -- we have fewer than n newlines
    go t
1 (Int
i:[Int]
_) = (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
the_ps
    go !t
m (Int
_:[Int]
is) = t -> [Int] -> Maybe (ByteString, ByteString)
go (t
m t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [Int]
is

breakBeforeNthNewline :: Int -> B.ByteString -> Either String (B.ByteString, B.ByteString)
breakBeforeNthNewline :: Int -> ByteString -> Either FilePath (ByteString, ByteString)
breakBeforeNthNewline Int
n ByteString
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = FilePath -> Either FilePath (ByteString, ByteString)
forall a. HasCallStack => FilePath -> a
error FilePath
"precondition of breakBeforeNthNewline"
breakBeforeNthNewline Int
n ByteString
the_ps = Int -> [Int] -> Either FilePath (ByteString, ByteString)
forall t.
(Eq t, Num t) =>
t -> [Int] -> Either FilePath (ByteString, ByteString)
go Int
n (Char -> ByteString -> [Int]
BC.elemIndices Char
'\n' ByteString
the_ps)
  where
    go :: t -> [Int] -> Either FilePath (ByteString, ByteString)
go t
0 [] = (ByteString, ByteString)
-> Either FilePath (ByteString, ByteString)
forall a b. b -> Either a b
Right (ByteString
the_ps, ByteString
B.empty)
    go t
0 (Int
i:[Int]
_) = (ByteString, ByteString)
-> Either FilePath (ByteString, ByteString)
forall a b. b -> Either a b
Right ((ByteString, ByteString)
 -> Either FilePath (ByteString, ByteString))
-> (ByteString, ByteString)
-> Either FilePath (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
i ByteString
the_ps
    go !t
m (Int
_:[Int]
is) = t -> [Int] -> Either FilePath (ByteString, ByteString)
go (t
m t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [Int]
is
    go t
_ [] = FilePath -> Either FilePath (ByteString, ByteString)
forall a b. a -> Either a b
Left FilePath
"Line number does not exist"