module Data.Patch.Internal where
import Data.Monoid
import Data.Ord
import qualified Data.List as List
import qualified Data.Vector as Vector
import qualified Data.Vector.Mutable as MVector
import qualified Data.Vector.Generic as GVector
import Data.Vector (Vector)
import Data.Vector.Distance
import Lens.Micro
import Control.Applicative
import Data.Function
import Control.Monad.ST
newtype Patch a = Patch [Edit a] deriving (Eq)
instance Show a => Show (Patch a) where
show (Patch ls) = "fromList " ++ show ls
instance (Eq a, Read a) => Read (Patch a) where
readsPrec _ ('f':'r':'o':'m':'L':'i':'s':'t':' ':r) = map (\(a,s) -> (fromList a, s)) $ reads r
readsPrec _ _ = []
data Edit a = Insert Int a
| Delete Int a
| Replace Int a a
deriving (Show, Read, Eq)
inverse :: Patch a -> Patch a
inverse (Patch ls) = Patch $ snd $ List.mapAccumL go 0 ls
where
go :: Int -> Edit a -> (Int, Edit a)
go off (Insert i x) = (off + 1, Delete (off + i) x)
go off (Delete i x) = (off 1, Insert (off + i) x)
go off (Replace i a b) = (off, Replace (off + i) b a)
index :: Lens' (Edit a) Int
index f (Insert i a) = fmap (flip Insert a) $ f i
index f (Delete i a) = fmap (flip Delete a) $ f i
index f (Replace i a b) = fmap (\i' -> Replace i' a b) $ f i
old :: Traversal' (Edit a) a
old _ (Insert i a) = pure $ Insert i a
old f (Delete i a) = Delete i <$> f a
old f (Replace i a b) = Replace i <$> f a <*> pure b
new :: Traversal' (Edit a) a
new f (Insert i a) = Insert i <$> f a
new _ (Delete i a) = pure $ Delete i a
new f (Replace i a b) = Replace i <$> pure a <*> f b
toList :: Patch a -> [Edit a]
toList (Patch a) = a
unsafeFromList :: [Edit a] -> Patch a
unsafeFromList = Patch
fromList :: Eq a => [Edit a] -> Patch a
fromList = Patch . concatMap normalise . List.groupBy ((==) `on` (^. index)) . List.sortBy (comparing (^. index))
normalise :: [Edit a] -> [Edit a]
normalise grp = let (inserts, deletes, replaces) = partition3 grp
in normalise' inserts deletes replaces
where partition3 (x@(Insert {}):xs) = let (i,d,r) = partition3 xs in (x:i,d,r)
partition3 (x@(Delete {}):xs) = let (i,d,r) = partition3 xs in (i,x:d,r)
partition3 (x@(Replace {}):xs) = let (i,d,r) = partition3 xs in (i,d,x:r)
partition3 [] = ([],[],[])
normalise' (Insert _ x:is) (Delete i y:ds) rs = normalise' is ds (Replace i y x : rs)
normalise' is [] rs = is ++ take 1 rs
normalise' [] (d:_) _ = [d]
normalise' _ _ _ = error "Impossible!"
instance Eq a => Monoid (Patch a) where
mempty = Patch []
mappend (Patch a) (Patch b) = Patch $ merge a b (0 :: Int)
where
merge [] ys off = map (over index (+ off)) ys
merge xs [] _ = xs
merge (x:xs) (y:ys) off = let
y' = over index (+ off) y
in case comparing (^. index) x y' of
LT -> x : merge xs (y:ys) (off + offset x)
GT -> y' : merge (x:xs) ys off
EQ -> case (x,y') of
(Delete i o, Insert _ n) -> replace i o n $ merge xs ys (off + offset x)
(Delete {}, _) -> x : merge xs (y:ys) (off + offset x)
(_, Insert {}) -> y' : merge (x:xs) ys off
(Replace i o _, Replace _ _ o') -> replace i o o' $ merge xs ys off
(Replace i o _, Delete {}) -> Delete i o : merge xs ys off
(Insert i _, Replace _ _ o') -> Insert i o' : merge xs ys (off + offset x)
(Insert {}, Delete {}) -> merge xs ys (off + offset x)
offset (Insert {}) = 1
offset (Delete {}) = 1
offset (Replace {}) = 0
replace _ o n | o == n = id
replace i o n | otherwise = (Replace i o n :)
applicable :: (Eq a) => Patch a -> Vector a -> Bool
applicable (Patch s) i = all applicable' s
where
applicable' (Insert x _) = x <= Vector.length i
applicable' (Delete x c) = case i Vector.!? x of
Just c' | c == c' -> True
_ -> False
applicable' (Replace x c _) = case i Vector.!? x of
Just c' | c == c' -> True
_ -> False
composable :: Eq a => Patch a -> Patch a -> Bool
composable (Patch a) (Patch b) = go a b (0 :: Int)
where
go [] _ _ = True
go _ [] _ = True
go (x:xs) (y:ys) off = let
y' = over index (+ off) y
in case comparing (^. index) x y' of
LT -> go xs (y:ys) (off + offset x)
GT -> go (x:xs) ys off
EQ -> case (x,y') of
(Delete {}, Insert {}) -> go xs ys (off + offset x)
(Delete {}, _) -> go xs (y:ys) (off + offset x)
(_, Insert {}) -> go (x:xs) ys off
(Replace _ _ o, Replace _ n _) -> o == n && go xs ys off
(Replace _ _ o, Delete _ n) -> o == n && go xs ys off
(Insert _ o, Replace _ n _) -> o == n && go xs ys (off + offset x)
(Insert _ o, Delete _ n) -> o == n && go xs ys (off + offset x)
offset (Insert {}) = 1
offset (Delete {}) = 1
offset (Replace {}) = 0
sizeChange :: Patch a -> Int
sizeChange (Patch s) = foldr (\c d -> d + offset c) 0 s
where offset (Delete {}) = 1
offset (Insert {}) = 1
offset _ = 0
apply :: Patch a -> Vector a -> Vector a
apply p@(Patch s) i = Vector.create (MVector.unsafeNew dlength >>= \d -> go s i d 0 >> return d)
where
dlength = Vector.length i + sizeChange p
go :: [Edit a] -> Vector a -> MVector.STVector s a -> Int -> ST s ()
go [] src dest _
| MVector.length dest > 0 = GVector.unsafeCopy dest src
| otherwise = return ()
go (a : as) src dest si
| y <- a ^. index
, x <- y si
, x > 0
= do GVector.unsafeCopy (MVector.take x dest) (Vector.take x src)
go (a : as) (Vector.drop x src) (MVector.drop x dest) (si + x)
go (a : as) src dest si = case a of
Insert _ c -> do
MVector.unsafeWrite dest 0 c
go as src (MVector.unsafeTail dest) si
Delete _ _ ->
go as (Vector.unsafeTail src) dest (si + 1)
Replace _ _ c' -> do
MVector.unsafeWrite dest 0 c'
go as (Vector.unsafeTail src) (MVector.unsafeTail dest) (si + 1)
transformWith :: (Eq a) => (a -> a -> a) -> Patch a -> Patch a -> (Patch a, Patch a)
transformWith conflict (Patch p) (Patch q)
= let (a', b') = go p 0 q 0
in (Patch a', Patch b')
where
go [] _ [] _ = ([],[])
go xs a [] _ = (map (over index (+ a)) xs, [])
go [] _ ys b = ([], map (over index (+ b)) ys)
go (x:xs) a (y:ys) b =
case comparing (^. index) x y of
LT -> over _1 (over index (+ a) x:) $ go xs a (y:ys) (b + offset x)
GT -> over _2 (over index (+ b) y:) $ go (x:xs) (a + offset y) ys b
EQ -> case (x, y) of
_ | x == y -> go xs (a + offset y) ys (b + offset x)
(Insert i nx, Insert _ ny )
-> let n = conflict nx ny
in cons2 (Replace (i + a) ny n, Replace (i + b) nx n)
(go xs (a + offset y) ys (b + offset x))
(Replace i _ nx, Replace _ _ ny)
-> let n = conflict nx ny
in cons2 (Replace (i + a) ny n, Replace (i + b) nx n)
(go xs a ys b)
(Insert {}, _) -> over _1 (over index (+ a) x:) $ go xs a (y:ys) (b + offset x)
(_, Insert {}) -> over _2 (over index (+ b) y:) $ go (x:xs) (a + offset y) ys b
(Replace i _ nx, Delete {})
-> over _2 (over index (+ b) (Delete i nx):) $ go xs (a + offset y) ys b
(Delete {}, Replace i _ ny)
-> over _1 (over index (+ a) (Delete i ny):) $ go xs a ys (b + offset x)
(Delete {}, Delete {}) -> go xs (a + offset y) ys (b + offset x)
offset (Insert {}) = 1
offset (Delete {}) = 1
offset (Replace {}) = 0
cons2 (x,y) (xs, ys) = (x:xs, y:ys)
ours :: a -> a -> a
ours = const
theirs :: a -> a -> a
theirs = flip const
transform :: (Eq a, Monoid a) => Patch a -> Patch a -> (Patch a, Patch a)
transform = transformWith (<>)
diff :: Eq a => Vector a -> Vector a -> Patch a
diff v1 v2 = let (_ , s) = leastChanges params v1 v2
in unsafeFromList $ adjust 0 s
where
adjust _ [] = []
adjust !o (Insert i x:rest) = Insert (i+o) x : adjust (o1) rest
adjust !o (Delete i x:rest) = Delete (i+o) x : adjust (o+1) rest
adjust !o (Replace i x x':rest) = Replace (i+o) x x' : adjust o rest
params :: Eq a => Params a (Edit a) (Sum Int)
params = Params { equivalent = (==)
, delete = Delete
, insert = Insert
, substitute = Replace
, cost = const $ Sum 1
, positionOffset = \x -> case x of
Delete {} -> 0
_ -> 1
}
data HunkStatus = Inserted | Deleted | Replaced | Unchanged deriving (Eq, Show, Read)
type Hunks a = [(Vector a, HunkStatus)]
hunks :: Patch a -> Vector a -> Hunks a
hunks (Patch s) i = map eachGroup $ List.groupBy ((==) `on` snd) $ go s i 0
where go [] v _ | Vector.null v = []
| otherwise = [(v, Unchanged)]
go (a : as) v x
| x' <- a ^. index
= let (prefix, rest) = Vector.splitAt (x' x) v
hunk (Insert _ c) = (Vector.singleton c, Inserted)
hunk (Replace _ _ c) = (Vector.singleton c, Replaced)
hunk (Delete _ c) = (Vector.singleton c, Deleted)
offset (Insert {}) = 0
offset _ = 1
in (if x' > x then ((prefix,Unchanged) :) else id) $ hunk a : go as (Vector.drop (offset a) rest) (x' + offset a)
eachGroup r@((_,st):_) = (Vector.concat (map fst r), st)
eachGroup [] = error "impossible!"