{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Darcs.Patch.Prim.V1.Mangle () where
import Darcs.Prelude
import qualified Data.ByteString.Char8 as BC (pack, last)
import qualified Data.ByteString as B (null, ByteString)
import Data.Maybe ( isJust, listToMaybe )
import Data.List ( sort, intercalate, nub )
import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )
import Darcs.Patch.Inspect ( PatchInspect(listTouchedFiles) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Prim.Class
( PrimConstruct(primFromHunk)
, PrimMangleUnravelled(..)
)
import Darcs.Patch.Prim.V1.Core ( Prim )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), mapFL_FL_M )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal )
import Darcs.Util.Path ( AnchoredPath )
newtype FileState wX = FileState { forall wX. FileState wX -> [Maybe ByteString]
content :: [Maybe B.ByteString] }
unknownFileState :: FileState wX
unknownFileState :: forall wX. FileState wX
unknownFileState = forall wX. [Maybe ByteString] -> FileState wX
FileState (forall a. a -> [a]
repeat forall a. Maybe a
Nothing)
applyHunk :: FileHunk wX wY -> FileState wX -> FileState wY
applyHunk :: forall wX wY. FileHunk wX wY -> FileState wX -> FileState wY
applyHunk (FileHunk AnchoredPath
_ Int
line [ByteString]
old [ByteString]
new) = forall wX. [Maybe ByteString] -> FileState wX
FileState forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ByteString] -> [Maybe ByteString]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall wX. FileState wX -> [Maybe ByteString]
content
where
go :: [Maybe ByteString] -> [Maybe ByteString]
go [Maybe ByteString]
mls =
case forall a. Int -> [a] -> ([a], [a])
splitAt (Int
line forall a. Num a => a -> a -> a
- Int
1) [Maybe ByteString]
mls of
([Maybe ByteString]
before, [Maybe ByteString]
rest) ->
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Maybe ByteString]
before, forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [ByteString]
new, forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
old) [Maybe ByteString]
rest]
applyHunks :: FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks :: forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks FL FileHunk wX wY
NilFL = forall a. a -> a
id
applyHunks (FileHunk wX wY
p:>:FL FileHunk wY wY
ps) = forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks FL FileHunk wY wY
ps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall wX wY. FileHunk wX wY -> FileState wX -> FileState wY
applyHunk FileHunk wX wY
p
instance PrimMangleUnravelled Prim where
mangleUnravelled :: forall wX. Unravelled Prim wX -> Maybe (Mangled Prim wX)
mangleUnravelled Unravelled Prim wX
pss = do
[Sealed (FL FileHunk wX)]
hunks <- forall (prim :: * -> * -> *) wX.
IsHunk prim =>
[Sealed (FL prim wX)] -> Maybe [Sealed (FL FileHunk wX)]
onlyHunks Unravelled Prim wX
pss
AnchoredPath
filename <- forall a. [a] -> Maybe a
listToMaybe (forall {wX}. [Sealed (FL Prim wX)] -> [AnchoredPath]
filenames Unravelled Prim wX
pss)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal ((forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
FileHunk wX wY -> prim wX wY
primFromHunk) forall a b. (a -> b) -> a -> b
$ forall wX.
AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)
mangleHunks AnchoredPath
filename [Sealed (FL FileHunk wX)]
hunks
where
filenames :: [Sealed (FL Prim wX)] -> [AnchoredPath]
filenames = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles)
onlyHunks :: forall prim wX. IsHunk prim
=> [Sealed (FL prim wX)]
-> Maybe [Sealed (FL FileHunk wX)]
onlyHunks :: forall (prim :: * -> * -> *) wX.
IsHunk prim =>
[Sealed (FL prim wX)] -> Maybe [Sealed (FL FileHunk wX)]
onlyHunks = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall wA. Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
toHunk where
toHunk :: Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
toHunk :: forall wA. Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
toHunk (Sealed FL prim wA wX
ps) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: * -> *) wX. a wX -> Sealed a
Sealed forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
Monad m =>
(forall wW wY. a wW wY -> m (b wW wY))
-> FL a wX wZ -> m (FL b wX wZ)
mapFL_FL_M forall (p :: * -> * -> *) wX wY.
IsHunk p =>
p wX wY -> Maybe (FileHunk wX wY)
isHunk FL prim wA wX
ps
mangleHunks :: AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)
mangleHunks :: forall wX.
AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)
mangleHunks AnchoredPath
_ [] = forall a. HasCallStack => [Char] -> a
error [Char]
"mangleHunks called with empty list of alternatives"
mangleHunks AnchoredPath
path [Sealed (FL FileHunk wX)]
ps = forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (forall wX wY.
AnchoredPath
-> Int -> [ByteString] -> [ByteString] -> FileHunk wX wY
FileHunk AnchoredPath
path Int
l [ByteString]
old [ByteString]
new)
where
oldf :: FileState wX
oldf = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall wX. FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
oldFileState forall wX. FileState wX
unknownFileState [Sealed (FL FileHunk wX)]
ps
newfs :: [Sealed FileState]
newfs = forall a b. (a -> b) -> [a] -> [b]
map (forall wX.
FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState
newFileState FileState wX
oldf) [Sealed (FL FileHunk wX)]
ps
l :: Int
l = [Sealed FileState] -> Int
getHunkline (forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FileState wX
oldf forall a. a -> [a] -> [a]
: [Sealed FileState]
newfs)
nchs :: [[ByteString]]
nchs = forall a. Ord a => [a] -> [a]
sort (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Sealed FileState -> [ByteString]
makeChunk Int
l) [Sealed FileState]
newfs)
old :: [ByteString]
old = Int -> Sealed FileState -> [ByteString]
makeChunk Int
l (forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FileState wX
oldf)
new :: [ByteString]
new = [ByteString
top] forall a. [a] -> [a] -> [a]
++ [ByteString]
old forall a. [a] -> [a] -> [a]
++ [ByteString
initial] forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [ByteString
middle] [[ByteString]]
nchs forall a. [a] -> [a] -> [a]
++ [ByteString
bottom]
top :: ByteString
top = [Char] -> ByteString
BC.pack ([Char]
"v v v v v v v" forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
initial :: ByteString
initial = [Char] -> ByteString
BC.pack ([Char]
"=============" forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
middle :: ByteString
middle = [Char] -> ByteString
BC.pack ([Char]
"*************" forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
bottom :: ByteString
bottom = [Char] -> ByteString
BC.pack ([Char]
"^ ^ ^ ^ ^ ^ ^" forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
eol_c :: [Char]
eol_c =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ByteString
line -> Bool -> Bool
not (ByteString -> Bool
B.null ByteString
line) Bool -> Bool -> Bool
&& ByteString -> Char
BC.last ByteString
line forall a. Eq a => a -> a -> Bool
== Char
'\r') [ByteString]
old
then [Char]
"\r"
else [Char]
""
oldFileState :: FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
oldFileState :: forall wX. FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
oldFileState FileState wX
mls (Sealed FL FileHunk wX wX
ps) = forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks (FL FileHunk wX wX
ps forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL FileHunk wX wX
ps) FileState wX
mls
newFileState :: FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState
newFileState :: forall wX.
FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState
newFileState FileState wX
mls (Sealed FL FileHunk wX wX
ps) = forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks FL FileHunk wX wX
ps FileState wX
mls)
getHunkline :: [Sealed FileState] -> Int
getHunkline :: [Sealed FileState] -> Int
getHunkline = forall {t} {a}. Num t => t -> [[Maybe a]] -> t
go Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal forall wX. FileState wX -> [Maybe ByteString]
content)
where
go :: t -> [[Maybe a]] -> t
go t
n [[Maybe a]]
pps =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) [[Maybe a]]
pps
then t
n
else t -> [[Maybe a]] -> t
go (t
n forall a. Num a => a -> a -> a
+ t
1) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> [a]
tail [[Maybe a]]
pps
makeChunk :: Int -> Sealed FileState -> [B.ByteString]
makeChunk :: Int -> Sealed FileState -> [ByteString]
makeChunk Int
n = forall {a}. [Maybe a] -> [a]
takeWhileJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop (Int
n forall a. Num a => a -> a -> a
- Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal forall wX. FileState wX -> [Maybe ByteString]
content
where
takeWhileJust :: [Maybe a] -> [a]
takeWhileJust = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Maybe a
x [a]
acc -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[a]
acc) Maybe a
x) []