module Data.Patch.Internal where
import Data.Monoid
import Data.Ord
import qualified Data.List as List
import qualified Data.Vector as Vector
import Data.Vector (Vector)
import Data.Vector.Distance
import Lens.Micro
import Control.Applicative
import Data.Function
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 . concat . map 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
apply :: Patch a -> Vector a -> Vector a
apply (Patch s) i = Vector.concat $ go s [i] 0
where go [] v _ = v
go (a : as) v x
| x' <- a ^. index
= let (prefix, rest)
| x' > x = splitVectorListAt (x' x) v
| otherwise = ([], v)
conclusion (Insert _ e) = Vector.singleton e : go as rest x'
conclusion (Delete _ _) = go as (drop1 rest) (x' + 1)
conclusion (Replace _ _ e) = go as (Vector.singleton e : drop1 rest) (x')
in prefix ++ conclusion a
drop1 :: [Vector a] -> [Vector a]
drop1 [] = []
drop1 (v:vs) | Vector.length v > 0 = Vector.drop 1 v : vs
drop1 (_:vs) | otherwise = drop1 vs
splitVectorListAt :: Int -> [Vector a] -> ([Vector a], [Vector a])
splitVectorListAt _ [] = ([],[])
splitVectorListAt j (v:vs) | j < Vector.length v = let (v1,v2) = Vector.splitAt j v in ([v1],v2:vs)
| otherwise = let (p1,p2) = splitVectorListAt (j Vector.length v) vs
in (v:p1, p2)
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 = 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 = \i c -> Delete i c
, insert = \i c -> Insert i c
, substitute = \i c c' -> Replace i c c'
, cost = \_ -> 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!"