├── .ghci ├── .gitignore ├── .travis.yml ├── Data ├── Patch.hs └── Patch │ └── Internal.hs ├── LICENSE ├── README.org ├── Setup.hs ├── bm └── benchmarks.hs ├── doctest.hs ├── patches-vector.cabal ├── stack-lts-2.yaml ├── stack-lts-3.yaml ├── stack-lts-5.yaml ├── stack.yaml └── test ├── Data └── Patch │ └── InternalSpec.hs ├── Spec.hs └── Test ├── Util.hs └── UtilSpec.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -itest 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | cabal.sandbox.config 3 | dist 4 | .stack-work 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # GHC depends on GMP. You can add other dependencies here as well. 8 | addons: 9 | apt: 10 | packages: 11 | - libgmp-dev 12 | 13 | # The different configurations we want to test. You could also do things like 14 | # change flags or use --stack-yaml to point to a different file. 15 | env: 16 | - ARGS="--stack-yaml stack-lts-2.yaml" 17 | - ARGS="--stack-yaml stack-lts-3.yaml" 18 | - ARGS="--stack-yaml stack-lts-5.yaml" 19 | 20 | before_install: 21 | # Download and unpack the stack executable 22 | - mkdir -p ~/.local/bin 23 | - export PATH=$HOME/.local/bin:$PATH 24 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 25 | 26 | # This line does all of the work: installs GHC if necessary, build the library, 27 | # executables, and test suites, and runs the test suites. --no-terminal works 28 | # around some quirks in Travis's terminal implementation. 29 | script: stack $ARGS --no-terminal --install-ghc test patches-vector:doctest-patches-vector patches-vector:spec-patches-vector --haddock 30 | 31 | # Caching so the next build will be fast too. 32 | cache: 33 | directories: 34 | - $HOME/.stack 35 | -------------------------------------------------------------------------------- /Data/Patch.hs: -------------------------------------------------------------------------------- 1 | -- | For gory implementation details, please see "Data.Patch.Internal" 2 | module Data.Patch 3 | ( 4 | -- * Patches 5 | Patch 6 | , toList 7 | , fromList 8 | , unsafeFromList 9 | , inverse 10 | , composable 11 | -- * Documents 12 | , apply 13 | , applicable 14 | , diff 15 | -- ** Transformations and merges 16 | , transformWith 17 | -- *** Conflict strategies 18 | , transform 19 | , ours 20 | , theirs 21 | -- * Edits 22 | , Edit (..) 23 | , index 24 | , old 25 | , new 26 | -- * Viewing Patches and Hunks 27 | , Hunks 28 | , HunkStatus (..) 29 | , hunks 30 | ) 31 | where 32 | 33 | import Data.Patch.Internal 34 | -------------------------------------------------------------------------------- /Data/Patch/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, Trustworthy #-} 2 | -- | For day-to-day use, please see "Data.Patch" 3 | module Data.Patch.Internal where 4 | import Data.Monoid 5 | import Data.Ord 6 | import qualified Data.List as List 7 | import qualified Data.Vector as Vector 8 | import qualified Data.Vector.Mutable as MVector 9 | import qualified Data.Vector.Generic as GVector 10 | import Data.Vector (Vector) 11 | import Data.Vector.Distance 12 | import Lens.Micro 13 | import Control.Applicative 14 | import Data.Function 15 | import Control.Monad.ST 16 | -- $setup 17 | -- >>> import Test.QuickCheck 18 | -- >>> import Test.Util 19 | -- 20 | -- >>> :set -XScopedTypeVariables 21 | 22 | -- $doctest_sucks 23 | -- prop> forAll (patchesFrom d) $ \ x -> read (show x) == x 24 | 25 | -- | A /patch/ is a collection of edits performed to a /document/, in this case a 'Vector'. They are 26 | -- implemented as a list 27 | -- of 'Edit', and can be converted to and from raw lists of edits using 'toList' and 'fromList' 28 | -- respectively. 29 | -- 30 | -- Patches form a groupoid (a 'Monoid' with inverses, and a partial composition relation), 31 | -- where the inverse element can be computed with 'inverse' and the groupoid operation 32 | -- is /composition/ of patches. Applying @p1 <> p2@ is the same as applying @p1@ /then/ 33 | -- @p2@ (see 'apply'). This composition operator may produce structurally 34 | -- different patches depending on associativity, however the patches are guaranteed to be /equivalent/ 35 | -- in the sense that the resultant document will be the same when they are applied. 36 | -- 37 | -- For convenience, we make our composition operator here total, to fit the `Monoid` typeclass, 38 | -- but provide some predicates ('composable' and 'applicable') to determine if the operation 39 | -- can be validly used. 40 | -- 41 | -- prop> forAll (patchesFrom d) $ \a -> a <> mempty == a 42 | -- 43 | -- prop> forAll (patchesFrom d) $ \a -> mempty <> a == a 44 | -- 45 | -- prop> forAll (historyFrom d 3) $ \[a, b, c] -> apply (a <> (b <> c)) d == apply ((a <> b) <> c) d 46 | -- 47 | -- The indices of the 'Edit' s of one 'Patch' are all based on the /original document/, so: 48 | -- 49 | -- >>> Vector.toList $ apply (fromList [Insert 0 'a', Insert 1 'b']) (Vector.fromList "123") 50 | -- "a1b23" 51 | -- 52 | -- >>> Vector.toList $ apply (fromList [Insert 0 'a', Insert 0 'b']) (Vector.fromList "123") 53 | -- "ab123" 54 | -- 55 | -- Note that the first 'Insert' didn't introduce an offset for the second. 56 | newtype Patch a = Patch [Edit a] deriving (Eq) 57 | 58 | instance Show a => Show (Patch a) where 59 | show (Patch ls) = "fromList " ++ show ls 60 | 61 | instance (Eq a, Read a) => Read (Patch a) where 62 | readsPrec _ ('f':'r':'o':'m':'L':'i':'s':'t':' ':r) = map (\(a,s) -> (fromList a, s)) $ reads r 63 | readsPrec _ _ = [] 64 | -- | An 'Edit' is a single alteration of the vector, either inserting, removing, or replacing an element. 65 | -- 66 | -- Useful optics are provided below, for the 'index', the 'old' element, and the 'new' element. 67 | data Edit a = Insert Int a -- ^ @Insert i x@ inserts the element @x@ at position @i@. 68 | | Delete Int a -- ^ @Delete i x@ deletes the element @x@ from position @i@. 69 | | Replace Int a a -- ^ @Replace i x x'@ replaces the element @x@ at position @i@ with @x'@. 70 | deriving (Show, Read, Eq) 71 | 72 | -- | Compute the inverse of a patch, such that: 73 | -- 74 | -- prop> forAll (patchesFrom d) $ \p -> p <> inverse p == mempty 75 | -- 76 | -- prop> forAll (patchesFrom d) $ \p -> inverse p <> p == mempty 77 | -- 78 | -- prop> forAll (patchesFrom d) $ \p -> inverse (inverse p) == p 79 | -- 80 | -- prop> forAll (historyFrom d 2) $ \[p, q] -> inverse (p <> q) == inverse q <> inverse p 81 | -- 82 | -- prop> forAll (patchesFrom d) $ \p -> inverse mempty == mempty 83 | -- 84 | -- prop> forAll (patchesFrom d) $ \p -> applicable (inverse p) (apply p d) 85 | -- 86 | -- prop> forAll (patchesFrom d) $ \p -> composable p (inverse p) 87 | -- 88 | -- prop> forAll (patchesFrom d) $ \p -> composable (inverse p) p 89 | inverse :: Patch a -> Patch a 90 | inverse (Patch ls) = Patch $ snd $ List.mapAccumL go 0 ls 91 | where 92 | go :: Int -> Edit a -> (Int, Edit a) 93 | go off (Insert i x) = (off + 1, Delete (off + i) x) 94 | go off (Delete i x) = (off - 1, Insert (off + i) x) 95 | go off (Replace i a b) = (off, Replace (off + i) b a) 96 | 97 | -- | A lens for the index where an edit is to be performed. 98 | -- 99 | -- prop> nonEmpty d ==> forAll (editsTo d) $ \e -> set index v e ^. index == v 100 | -- 101 | -- prop> nonEmpty d ==> forAll (editsTo d) $ \e -> set index (e ^. index) e == e 102 | -- 103 | -- prop> nonEmpty d ==> forAll (editsTo d) $ \e -> set index v' (set index v e) == set index v' e 104 | index :: Lens' (Edit a) Int 105 | index f (Insert i a) = fmap (flip Insert a) $ f i 106 | index f (Delete i a) = fmap (flip Delete a) $ f i 107 | index f (Replace i a b) = fmap (\i' -> Replace i' a b) $ f i 108 | 109 | -- | A traversal for the old element to be replaced/deleted. Empty in the case of an @Insert@. 110 | old :: Traversal' (Edit a) a 111 | old _ (Insert i a) = pure $ Insert i a 112 | old f (Delete i a) = Delete i <$> f a 113 | old f (Replace i a b) = Replace i <$> f a <*> pure b 114 | 115 | -- | A traversal for the new value to be inserted or replacing the old value. Empty in the case of a @Delete@. 116 | new :: Traversal' (Edit a) a 117 | new f (Insert i a) = Insert i <$> f a 118 | new _ (Delete i a) = pure $ Delete i a 119 | new f (Replace i a b) = Replace i <$> pure a <*> f b 120 | 121 | -- | Convert a patch to a list of edits. 122 | toList :: Patch a -> [Edit a] 123 | toList (Patch a) = a 124 | 125 | -- | Directly convert a list of edits to a patch, without sorting edits by index, and resolving contradictory 126 | -- edits. Use this function if you know that the input list is already a wellformed patch. 127 | unsafeFromList :: [Edit a] -> Patch a 128 | unsafeFromList = Patch 129 | 130 | -- | Convert a list of edits to a patch, making sure to eliminate conflicting edits and sorting by index. 131 | fromList :: Eq a => [Edit a] -> Patch a 132 | fromList = Patch . concatMap normalise . List.groupBy ((==) `on` (^. index)) . List.sortBy (comparing (^. index)) 133 | 134 | -- | Internal: Eliminate conflicting edits 135 | normalise :: [Edit a] -> [Edit a] 136 | normalise grp = let (inserts, deletes, replaces) = partition3 grp 137 | in normalise' inserts deletes replaces 138 | where partition3 (x@(Insert {}):xs) = let (i,d,r) = partition3 xs in (x:i,d,r) 139 | partition3 (x@(Delete {}):xs) = let (i,d,r) = partition3 xs in (i,x:d,r) 140 | partition3 (x@(Replace {}):xs) = let (i,d,r) = partition3 xs in (i,d,x:r) 141 | partition3 [] = ([],[],[]) 142 | 143 | normalise' (Insert _ x:is) (Delete i y:ds) rs = normalise' is ds (Replace i y x : rs) 144 | normalise' is [] rs = is ++ take 1 rs 145 | normalise' [] (d:_) _ = [d] 146 | normalise' _ _ _ = error "Impossible!" 147 | 148 | instance Eq a => Monoid (Patch a) where 149 | mempty = Patch [] 150 | mappend (Patch a) (Patch b) = Patch $ merge a b (0 :: Int) 151 | where 152 | merge [] ys off = map (over index (+ off)) ys 153 | merge xs [] _ = xs 154 | merge (x:xs) (y:ys) off = let 155 | y' = over index (+ off) y 156 | in case comparing (^. index) x y' of 157 | LT -> x : merge xs (y:ys) (off + offset x) 158 | GT -> y' : merge (x:xs) ys off 159 | EQ -> case (x,y') of 160 | (Delete i o, Insert _ n) -> replace i o n $ merge xs ys (off + offset x) 161 | (Delete {}, _) -> x : merge xs (y:ys) (off + offset x) 162 | (_, Insert {}) -> y' : merge (x:xs) ys off 163 | (Replace i o _, Replace _ _ o') -> replace i o o' $ merge xs ys off 164 | (Replace i o _, Delete {}) -> Delete i o : merge xs ys off 165 | (Insert i _, Replace _ _ o') -> Insert i o' : merge xs ys (off + offset x) 166 | (Insert {}, Delete {}) -> merge xs ys (off + offset x) 167 | 168 | offset (Insert {}) = -1 169 | offset (Delete {}) = 1 170 | offset (Replace {}) = 0 171 | replace _ o n | o == n = id 172 | replace i o n | otherwise = (Replace i o n :) 173 | 174 | -- | Returns true if a patch can be safely applied to a document, that is, 175 | -- @applicable p d@ holds when @d@ is a valid source document for the patch @p@. 176 | applicable :: (Eq a) => Patch a -> Vector a -> Bool 177 | applicable (Patch s) i = all applicable' s 178 | where 179 | applicable' (Insert x _) = x <= Vector.length i 180 | applicable' (Delete x c) = case i Vector.!? x of 181 | Just c' | c == c' -> True 182 | _ -> False 183 | applicable' (Replace x c _) = case i Vector.!? x of 184 | Just c' | c == c' -> True 185 | _ -> False 186 | 187 | -- | Returns true if a patch can be validly composed with another. 188 | -- That is, @composable p q@ holds if @q@ can be validly applied after @p@. 189 | composable :: Eq a => Patch a -> Patch a -> Bool 190 | composable (Patch a) (Patch b) = go a b (0 :: Int) 191 | where 192 | go [] _ _ = True 193 | go _ [] _ = True 194 | go (x:xs) (y:ys) off = let 195 | y' = over index (+ off) y 196 | in case comparing (^. index) x y' of 197 | LT -> go xs (y:ys) (off + offset x) 198 | GT -> go (x:xs) ys off 199 | EQ -> case (x,y') of 200 | (Delete {}, Insert {}) -> go xs ys (off + offset x) 201 | (Delete {}, _) -> go xs (y:ys) (off + offset x) 202 | (_, Insert {}) -> go (x:xs) ys off 203 | (Replace _ _ o, Replace _ n _) -> o == n && go xs ys off 204 | (Replace _ _ o, Delete _ n) -> o == n && go xs ys off 205 | (Insert _ o, Replace _ n _) -> o == n && go xs ys (off + offset x) 206 | (Insert _ o, Delete _ n) -> o == n && go xs ys (off + offset x) 207 | offset (Insert {}) = -1 208 | offset (Delete {}) = 1 209 | offset (Replace {}) = 0 210 | 211 | 212 | -- | Returns the delta of the document's size when a patch is applied. 213 | -- Essentially the number of @Insert@ minus the number of @Delete@. 214 | -- 215 | -- prop> forAll (patchesFrom d) $ \ p -> sizeChange p == Data.Vector.length (apply p d) - Data.Vector.length d 216 | sizeChange :: Patch a -> Int 217 | sizeChange (Patch s) = foldr (\c d -> d + offset c) 0 s 218 | where offset (Delete {}) = -1 219 | offset (Insert {}) = 1 220 | offset _ = 0 221 | 222 | -- | Apply a patch to a document. 223 | -- 224 | -- Technically, 'apply' is a /monoid morphism/ to the monoid of endomorphisms @Vector a -> Vector a@, 225 | -- and that's how we can derive the following two laws: 226 | -- 227 | -- prop> forAll (historyFrom d 2) $ \[a, b] -> apply b (apply a d) == apply (a <> b) d 228 | -- 229 | -- prop> apply mempty d == d 230 | -- 231 | apply :: Patch a -> Vector a -> Vector a 232 | apply p@(Patch s) i = Vector.create (MVector.unsafeNew dlength >>= \d -> go s i d 0 >> return d) 233 | where 234 | dlength = Vector.length i + sizeChange p 235 | go :: [Edit a] -> Vector a -> MVector.STVector s a -> Int -> ST s () 236 | go [] src dest _ 237 | | MVector.length dest > 0 = GVector.unsafeCopy dest src 238 | | otherwise = return () 239 | go (a : as) src dest si 240 | | y <- a ^. index 241 | , x <- y - si 242 | , x > 0 243 | = do GVector.unsafeCopy (MVector.take x dest) (Vector.take x src) 244 | go (a : as) (Vector.drop x src) (MVector.drop x dest) (si + x) 245 | go (a : as) src dest si = case a of 246 | Insert _ c -> do 247 | MVector.unsafeWrite dest 0 c 248 | go as src (MVector.unsafeTail dest) si 249 | Delete _ _ -> 250 | go as (Vector.unsafeTail src) dest (si + 1) 251 | Replace _ _ c' -> do 252 | MVector.unsafeWrite dest 0 c' 253 | go as (Vector.unsafeTail src) (MVector.unsafeTail dest) (si + 1) 254 | 255 | 256 | -- | Given two diverging patches @p@ and @q@, @transform m p q@ returns 257 | -- a pair of updated patches @(p',q')@ such that @q <> p'@ and 258 | -- @p <> q'@ are equivalent patches that incorporate the changes 259 | -- of /both/ @p@ and @q@, up to merge conflicts, which are handled by 260 | -- the provided function @m@. 261 | -- 262 | -- This is the standard @transform@ function of Operational Transformation 263 | -- patch resolution techniques, and can be thought of as the pushout 264 | -- of two diverging patches within the patch groupoid. 265 | -- 266 | -- prop> forAll (divergingPatchesFrom d) $ \(p,q) -> let (p', q') = transformWith ours p q in apply (p <> q') d == apply (q <> p') d 267 | -- prop> forAll (divergingPatchesFrom d) $ \(p,q) -> let (p', q') = transformWith ours p q in applicable p' (apply q d) && applicable q' (apply p d) 268 | -- prop> forAll (divergingPatchesFrom d) $ \(p,q) -> let (p', q') = transformWith ours p q in composable p q' && composable q p' 269 | -- 270 | -- This function is commutative iff @m@ is commutative. 271 | -- 272 | -- prop> forAll (divergingPatchesFrom d) $ \(p,q) -> let (p', q') = transformWith (*) p q; (q'', p'') = transformWith (*) q p in p' == p'' && q' == q'' 273 | -- 274 | -- prop> forAll (patchesFrom d) $ \ p -> transformWith (*) mempty p == (mempty, p) 275 | -- prop> forAll (patchesFrom d) $ \ p -> transformWith (*) p mempty == (p, mempty) 276 | -- Some example conflict strategies are provided below. 277 | transformWith :: (Eq a) => (a -> a -> a) -> Patch a -> Patch a -> (Patch a, Patch a) 278 | transformWith conflict (Patch p) (Patch q) 279 | = let (a', b') = go p 0 q 0 280 | in (Patch a', Patch b') 281 | where 282 | go [] _ [] _ = ([],[]) 283 | go xs a [] _ = (map (over index (+ a)) xs, []) 284 | go [] _ ys b = ([], map (over index (+ b)) ys) 285 | go (x:xs) a (y:ys) b = 286 | case comparing (^. index) x y of 287 | LT -> over _1 (over index (+ a) x:) $ go xs a (y:ys) (b + offset x) 288 | GT -> over _2 (over index (+ b) y:) $ go (x:xs) (a + offset y) ys b 289 | EQ -> case (x, y) of 290 | _ | x == y -> go xs (a + offset y) ys (b + offset x) 291 | (Insert i nx, Insert _ ny ) 292 | -> let n = conflict nx ny 293 | in cons2 (Replace (i + a) ny n, Replace (i + b) nx n) 294 | (go xs (a + offset y) ys (b + offset x)) 295 | (Replace i _ nx, Replace _ _ ny) 296 | -> let n = conflict nx ny 297 | in cons2 (Replace (i + a) ny n, Replace (i + b) nx n) 298 | (go xs a ys b) 299 | (Insert {}, _) -> over _1 (over index (+ a) x:) $ go xs a (y:ys) (b + offset x) 300 | (_, Insert {}) -> over _2 (over index (+ b) y:) $ go (x:xs) (a + offset y) ys b 301 | (Replace i _ nx, Delete {}) 302 | -> over _2 (over index (+ b) (Delete i nx):) $ go xs (a + offset y) ys b 303 | (Delete {}, Replace i _ ny) 304 | -> over _1 (over index (+ a) (Delete i ny):) $ go xs a ys (b + offset x) 305 | (Delete {}, Delete {}) -> go xs (a + offset y) ys (b + offset x) 306 | offset (Insert {}) = 1 307 | offset (Delete {}) = -1 308 | offset (Replace {}) = 0 309 | cons2 (x,y) (xs, ys) = (x:xs, y:ys) 310 | 311 | -- | Resolve a conflict by always using the left-hand side 312 | ours :: a -> a -> a 313 | ours = const 314 | 315 | -- | Resolve a conflict by always using the right-hand side 316 | theirs :: a -> a -> a 317 | theirs = flip const 318 | 319 | -- | A convenience version of 'transformWith' which resolves conflicts using 'mappend'. 320 | transform :: (Eq a, Monoid a) => Patch a -> Patch a -> (Patch a, Patch a) 321 | transform = transformWith (<>) 322 | 323 | -- | Compute the difference between two documents, using the Wagner-Fischer algorithm. O(mn) time and space. 324 | -- 325 | -- prop> apply (diff d e) d == e 326 | -- 327 | -- prop> diff d d == mempty 328 | -- 329 | -- prop> apply (diff d e) d == apply (inverse (diff e d)) d 330 | -- 331 | -- prop> apply (diff a b <> diff b c) a == apply (diff a c) a 332 | -- 333 | -- prop> applicable (diff a b) a 334 | diff :: Eq a => Vector a -> Vector a -> Patch a 335 | diff v1 v2 = let (_ , s) = leastChanges params v1 v2 336 | in unsafeFromList $ adjust 0 s 337 | where 338 | adjust _ [] = [] 339 | adjust !o (Insert i x:rest) = Insert (i+o) x : adjust (o-1) rest 340 | adjust !o (Delete i x:rest) = Delete (i+o) x : adjust (o+1) rest 341 | adjust !o (Replace i x x':rest) = Replace (i+o) x x' : adjust o rest 342 | params :: Eq a => Params a (Edit a) (Sum Int) 343 | params = Params { equivalent = (==) 344 | , delete = Delete 345 | , insert = Insert 346 | , substitute = Replace 347 | , cost = const $ Sum 1 348 | , positionOffset = \x -> case x of 349 | Delete {} -> 0 350 | _ -> 1 351 | } 352 | 353 | 354 | 355 | -- | The four different ways a hunk may have been manipulated. 356 | data HunkStatus = Inserted | Deleted | Replaced | Unchanged deriving (Eq, Show, Read) 357 | 358 | -- | The type for a series of hunks; a patch as it may be displayed to a user. 359 | type Hunks a = [(Vector a, HunkStatus)] 360 | 361 | -- | Render a patch on a document as a list of change hunks. Good for displaying 362 | -- a patch to a user. 363 | -- 364 | -- prop> forAll (patchesFrom d) $ \p -> Vector.concat (map fst (filter ((/= Deleted) . snd) (hunks p d))) == apply p d 365 | hunks :: Patch a -> Vector a -> Hunks a 366 | hunks (Patch s) i = map eachGroup $ List.groupBy ((==) `on` snd) $ go s i 0 367 | where go [] v _ | Vector.null v = [] 368 | | otherwise = [(v, Unchanged)] 369 | go (a : as) v x 370 | | x' <- a ^. index 371 | = let (prefix, rest) = Vector.splitAt (x' - x) v 372 | hunk (Insert _ c) = (Vector.singleton c, Inserted) 373 | hunk (Replace _ _ c) = (Vector.singleton c, Replaced) 374 | hunk (Delete _ c) = (Vector.singleton c, Deleted) 375 | offset (Insert {}) = 0 376 | offset _ = 1 377 | in (if x' > x then ((prefix,Unchanged) :) else id) $ hunk a : go as (Vector.drop (offset a) rest) (x' + offset a) 378 | eachGroup r@((_,st):_) = (Vector.concat (map fst r), st) 379 | eachGroup [] = error "impossible!" 380 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Liam O'Connor 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Liam O'Connor nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | 2 | [[https://travis-ci.org/liamoc/patches-vector][file:https://travis-ci.org/liamoc/patches-vector.svg]] [[http://hackage.haskell.org/package/patches-vector][file:https://img.shields.io/hackage/v/patches-vector.svg]] [[http://packdeps.haskellers.com/reverse/patches-vector][file:https://img.shields.io/hackage-deps/v/patches-vector.svg]] [[http://haskell.org][file:https://img.shields.io/badge/language-Haskell-blue.svg]] [[https://github.com/liamoc/patches-vector/blob/master/LICENSE][file:http://img.shields.io/badge/license-BSD3-brightgreen.svg]] 3 | 4 | * Patches for Vectors 5 | 6 | A /patch/ is a collection of modifications (/edits/) to be made to a sequence of elements. Commonly 7 | found in version control systems, patches are also a simple example of a /groupoid/, supporting (partial) 8 | composition and inversion. 9 | 10 | This library provides a pleasant interface for working with patches to vectors with any type of element. 11 | It includes patch composition, inversion, and application, as well as a way to compute a patch between 12 | two vectors using the Wagner-Fischer algorithm. 13 | 14 | It also includes a simple implementation of the [[https://en.wikipedia.org/wiki/Operational_transformation][operational transformation]] (OT) 15 | function to resolve diverging patches from the same document. This allows for reasonably painless 16 | implementation of merge functions, as well as many applications in distributed editing of documents. This 17 | operation also has an interpretation in terms of groupoids, where the transform function is the [[https://en.wikipedia.org/wiki/Pushout_(category_theory)][pushout]] of two 18 | diverging patches. 19 | 20 | This library is extensively covered by a comprehensive suite of 21 | QuickCheck properties, which are written into the documentation and 22 | run with ~doctest~. 23 | 24 | The actual package only depends on ~base~, ~microlens~, ~vector~ and 25 | a small library for doing Wagner-Fischer, [[https://github.com/thsutton/edit-distance-vector][thsutton/edit-distance-vector]]. 26 | 27 | It is released under the BSD3 license. 28 | 29 | ** Building, Installing 30 | 31 | ~patches-vector~ is released on Hackage and is available in the usual way: 32 | 33 | #+BEGIN_EXAMPLE 34 | $ cabal update 35 | $ cabal install patches-vector 36 | #+END_EXAMPLE 37 | 38 | You can also use ~stack~ if you prefer: 39 | 40 | #+BEGIN_EXAMPLE 41 | $ stack install patches-vector 42 | #+END_EXAMPLE 43 | 44 | A variety of ~stack-*.yaml~ files are provided in this repository for various LTS snapshots. 45 | 46 | ** Using 47 | 48 | The full Haddock documentation is available [[http://hackage.haskell.org/package/patches-vector][on Hackage]]. Mostly, construct patches using ~fromList~ or ~diff~, compose them with the ~Monoid~ instance, invert them with ~inverse~, 49 | and apply them to a vector with ~apply~. 50 | 51 | The ~transform~ function can be used to resolve diverging patches, and ~transformWith~ lets you select a merging strategy, such as ~ours~ or ~theirs~, rather than the default 52 | ~mappend~. See the Haddock documentation for more information. 53 | 54 | The ~hunks~ function can be used with a patch and a vector to provide a list of change hunks, that are convenient for other tools or for displaying to the user. 55 | 56 | ** Future work 57 | 58 | - More elaborate merge strategies that allow you to emulate insert/delete style patches. 59 | 60 | ** Other notes 61 | 62 | This library is designed to be used with my ~composition-tree~ library, which, along with this library gives you a basic version control system for vectors. Pretty neat! 63 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bm/benchmarks.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | import Data.Patch 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Gen 5 | import Test.QuickCheck.Random 6 | import Debug.Trace 7 | import qualified Data.Vector as Vector 8 | import Data.Vector (Vector) 9 | editsTo :: Arbitrary a => Vector a -> Gen (Edit a) 10 | editsTo v = do 11 | i <- choose (0, Vector.length v -1) 12 | c <- elements [const (Insert i), \o _ -> Delete i o, Replace i] 13 | x <- arbitrary 14 | return $ c (v Vector.! i) x 15 | 16 | patchesFrom' :: (Eq a, Arbitrary a) => Vector a -> Gen (Patch a) 17 | patchesFrom' v | Vector.length v > 0 = fromList <$> listOf (editsTo v) 18 | | otherwise = fromList <$> listOf (Insert 0 <$> arbitrary) 19 | patchesFrom :: Vector Int -> Gen (Patch Int) 20 | patchesFrom = patchesFrom' 21 | 22 | instance Arbitrary a => Arbitrary (Vector a) where arbitrary = Vector.fromList <$> listOf arbitrary 23 | 24 | qcgen :: QCGen 25 | qcgen = mkQCGen 19835315 26 | 27 | gen :: Int -> (Patch Int, Vector Int) 28 | gen i = let 29 | doc = unGen arbitrary qcgen i :: Vector Int 30 | patch = unGen (patchesFrom doc) qcgen i 31 | in traceShow (length $ toList patch, length doc) (patch,doc) 32 | 33 | main :: IO () 34 | main = 35 | defaultMain [ bgroup "apply" [ bench "1" $ nf (uncurry apply) (gen 500) 36 | , bench "2" $ nf (uncurry apply) (gen 1000) 37 | , bench "3" $ nf (uncurry apply) (gen 2000) 38 | , bench "4" $ nf (uncurry apply) (gen 4000) 39 | ] 40 | ] 41 | -------------------------------------------------------------------------------- /doctest.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest 2 | 3 | main :: IO () 4 | main = doctest ["Data/Patch/Internal.hs", "-i", "test", "-i."] 5 | -------------------------------------------------------------------------------- /patches-vector.cabal: -------------------------------------------------------------------------------- 1 | -- Initial edit-script.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: patches-vector 5 | version: 0.1.5.4 6 | synopsis: Patches (diffs) on vectors: composable, mergeable, and invertible. 7 | description: A patch is a collection of modifications (edits) to be made to a sequence of elements. Commonly 8 | found in version control systems, patches are also a simple example of a groupoid, supporting (partial) composition 9 | and inversion. 10 | . 11 | This library provides a pleasant interface for working with patches to vectors with any type of element. 12 | It includes patch composition, inversion, and application, as well as a way to compute a patch between 13 | two vectors using the Wagner-Fischer algorithm. 14 | . 15 | It also includes a simple implementation of the Operational Transform (OT) function to resolve 16 | diverging patches from the same document. This allows for reasonably painless implementation of merge 17 | functions, as well as many applications in distributed editing of documents. 18 | license: BSD3 19 | license-file: LICENSE 20 | author: Liam O'Connor 21 | maintainer: liamoc@cse.unsw.edu.au 22 | copyright: Liam O'Connor, 2015 23 | category: Data 24 | build-type: Simple 25 | cabal-version: >=1.10 26 | homepage: https://github.com/liamoc/patches-vector 27 | source-repository head 28 | type: git 29 | location: https://github.com/liamoc/patches-vector 30 | 31 | library 32 | exposed-modules: Data.Patch 33 | , Data.Patch.Internal 34 | build-depends: base >=4.7 && <5 35 | , edit-distance-vector >=1.0 && <1.1 36 | , vector >= 0.10 && < 0.12 37 | , microlens >= 0.2 && < 0.5 38 | default-language: Haskell2010 39 | 40 | test-suite doctest-patches-vector 41 | type: exitcode-stdio-1.0 42 | main-is: doctest.hs 43 | build-depends: base >= 4.7 && < 5 44 | , QuickCheck >= 2.7 && < 2.9 45 | , patches-vector 46 | , doctest >= 0.9 && < 0.12 47 | default-language: Haskell2010 48 | 49 | test-suite benchmarks-patches-vector 50 | type: exitcode-stdio-1.0 51 | main-is: benchmarks.hs 52 | hs-source-dirs: bm 53 | build-depends: base >= 4.7 && < 5 54 | , QuickCheck >= 2.7 && < 2.9 55 | , patches-vector 56 | , criterion >= 1.1 && < 1.2 57 | , vector >= 0.10 && <0.12 58 | default-language: Haskell2010 59 | 60 | test-suite spec-patches-vector 61 | type: exitcode-stdio-1.0 62 | main-is: Spec.hs 63 | hs-source-dirs: test 64 | other-modules: Data.Patch.InternalSpec 65 | , Test.Util 66 | , Test.UtilSpec 67 | build-depends: base >= 4.7 && < 5 68 | , QuickCheck >= 2.7 && < 2.9 69 | , patches-vector 70 | , criterion >= 1.1 && < 1.2 71 | , vector >= 0.10 && <0.12 72 | , hspec >= 2.1 && < 2.3 73 | default-language: Haskell2010 74 | -------------------------------------------------------------------------------- /stack-lts-2.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-2.22 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: 12 | - edit-distance-vector-1.0.0.2 13 | - microlens-0.3.4.1 14 | - doctest-0.10.1 15 | 16 | # Override default flag values for local packages and extra-deps 17 | flags: {} 18 | 19 | # Extra package databases containing global packages 20 | extra-package-dbs: [] 21 | 22 | # Control whether we use the GHC we find on the path 23 | # system-ghc: true 24 | 25 | # Require a specific version of stack, using version ranges 26 | # require-stack-version: -any # Default 27 | # require-stack-version: >= 0.1.4.0 28 | 29 | # Override the architecture used by stack, especially useful on Windows 30 | # arch: i386 31 | # arch: x86_64 32 | 33 | # Extra directories used by stack for building 34 | # extra-include-dirs: [/path/to/dir] 35 | # extra-lib-dirs: [/path/to/dir] 36 | -------------------------------------------------------------------------------- /stack-lts-3.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.10 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: 12 | - edit-distance-vector-1.0.0.2 13 | 14 | # Override default flag values for local packages and extra-deps 15 | flags: {} 16 | 17 | # Extra package databases containing global packages 18 | extra-package-dbs: [] 19 | 20 | # Control whether we use the GHC we find on the path 21 | # system-ghc: true 22 | 23 | # Require a specific version of stack, using version ranges 24 | # require-stack-version: -any # Default 25 | # require-stack-version: >= 0.1.4.0 26 | 27 | # Override the architecture used by stack, especially useful on Windows 28 | # arch: i386 29 | # arch: x86_64 30 | 31 | # Extra directories used by stack for building 32 | # extra-include-dirs: [/path/to/dir] 33 | # extra-lib-dirs: [/path/to/dir] 34 | -------------------------------------------------------------------------------- /stack-lts-5.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-5.8 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 0.1.4.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-7.10 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: 12 | - edit-distance-vector-1.0.0.4 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 0.1.4.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | -------------------------------------------------------------------------------- /test/Data/Patch/InternalSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Patch.InternalSpec where 3 | 4 | import Data.Monoid 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | import Data.Patch.Internal 9 | import Test.Util () 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "applicable" $ do 14 | it "mempty is always applicable" $ do 15 | property $ \d -> 16 | applicable (mempty :: Patch Int) d 17 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/Test/Util.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Test.Util where 4 | 5 | import Control.Applicative 6 | import Data.Vector (Vector) 7 | import qualified Data.Vector as Vector 8 | import Test.QuickCheck 9 | 10 | import Data.Patch 11 | 12 | nonEmpty :: Vector a -> Bool 13 | nonEmpty = (>0) . Vector.length 14 | 15 | editsTo :: Arbitrary a => Vector a -> Gen (Edit a) 16 | editsTo v = do 17 | i <- choose (0, Vector.length v -1) 18 | c <- elements [const (Insert i), \o _ -> Delete i o, Replace i] 19 | x <- arbitrary 20 | return $ c (v Vector.! i) x 21 | 22 | patchesFrom' :: (Eq a, Arbitrary a) => Vector a -> Gen (Patch a) 23 | patchesFrom' v | Vector.length v > 0 = fromList <$> listOf (editsTo v) 24 | patchesFrom' _ | otherwise = fromList <$> listOf (Insert 0 <$> arbitrary) 25 | 26 | patchesFrom :: Vector Int -> Gen (Patch Int) 27 | patchesFrom = patchesFrom' 28 | 29 | divergingPatchesFrom :: Vector Int -> Gen (Patch Int, Patch Int) 30 | divergingPatchesFrom v = (,) <$> patchesFrom v <*> patchesFrom v 31 | 32 | historyFrom :: Vector Int -> Int -> Gen [Patch Int] 33 | historyFrom _ 0 = return [] 34 | historyFrom d m = do 35 | p <- patchesFrom d 36 | r <- historyFrom (apply p d) $ m - 1 37 | return (p:r) 38 | 39 | instance Arbitrary a => Arbitrary (Vector a) where 40 | arbitrary = Vector.fromList <$> listOf arbitrary 41 | -------------------------------------------------------------------------------- /test/Test/UtilSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.UtilSpec where 3 | 4 | import Data.Monoid 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | import Data.Patch.Internal 9 | import Test.Util 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "patchesFrom" $ do 14 | it "creates applicable patches" $ do 15 | property $ \d -> 16 | forAll (patchesFrom d) $ \p -> applicable p d 17 | 18 | it "creates patches that are right-composable with mempty" $ do 19 | property $ \d -> 20 | forAll (patchesFrom d) $ \p -> composable mempty p 21 | 22 | it "creates patches that are left-composable with mempty" $ do 23 | property $ \d -> 24 | forAll (patchesFrom d) $ \p -> composable p mempty 25 | 26 | describe "historyFrom" $ do 27 | it "creates patches that are applicable in sequence" $ do 28 | property $ \d -> 29 | forAll (historyFrom d 2) $ \[p, q] -> 30 | applicable p d && applicable q (apply p d) 31 | 32 | it "creates patches that are applicable in merged form" $ do 33 | property $ \d -> 34 | forAll (historyFrom d 2) $ \[p, q] -> 35 | applicable (p <> q) d 36 | 37 | it "creates patches that are composable" $ do 38 | property $ \d -> 39 | forAll (historyFrom d 2) $ \[p, q] -> composable p q 40 | --------------------------------------------------------------------------------