diff --git a/Data/Patch/Internal.hs b/Data/Patch/Internal.hs --- a/Data/Patch/Internal.hs +++ b/Data/Patch/Internal.hs @@ -5,11 +5,14 @@ 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 -- $setup -- >>> import Test.QuickCheck -- >>> :{ @@ -152,7 +155,7 @@ -- | Convert a list of edits to a patch, making sure to eliminate conflicting edits and sorting by index. fromList :: Eq a => [Edit a] -> Patch a -fromList = Patch . concat . map normalise . List.groupBy ((==) `on` (^. index)) . List.sortBy (comparing (^. index)) +fromList = Patch . concatMap normalise . List.groupBy ((==) `on` (^. index)) . List.sortBy (comparing (^. index)) -- | Internal: Eliminate conflicting edits normalise :: [Edit a] -> [Edit a] @@ -240,6 +243,15 @@ offset (Delete {}) = 1 offset (Replace {}) = 0 + +-- | Returns the delta of the document's size when a patch is applied. +-- Essentially the number of @Insert@ minus the number of @Delete@. +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 a patch to a document. -- -- Technically, 'apply' is a /monoid morphism/ to the monoid of endomorphisms @Vector a -> Vector a@, @@ -250,27 +262,28 @@ -- prop> apply mempty d == d -- 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) - +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) -- | Given two diverging patches @p@ and @q@, @transform m p q@ returns @@ -353,7 +366,7 @@ -- prop> applicable (diff a b) a diff :: Eq a => Vector a -> Vector a -> Patch a diff v1 v2 = let (_ , s) = leastChanges params v1 v2 - in unsafeFromList $ adjust 0 $ s + in unsafeFromList $ adjust 0 s where adjust _ [] = [] adjust !o (Insert i x:rest) = Insert (i+o) x : adjust (o-1) rest @@ -361,10 +374,10 @@ 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 + , delete = Delete + , insert = Insert + , substitute = Replace + , cost = const $ Sum 1 , positionOffset = \x -> case x of Delete {} -> 0 _ -> 1 diff --git a/bm/benchmarks.hs b/bm/benchmarks.hs new file mode 100644 --- /dev/null +++ b/bm/benchmarks.hs @@ -0,0 +1,40 @@ +import Criterion.Main +import Data.Patch +import Test.QuickCheck +import Test.QuickCheck.Gen +import Test.QuickCheck.Random +import Debug.Trace +import qualified Data.Vector as Vector +import Data.Vector (Vector) +editsTo :: Arbitrary a => Vector a -> Gen (Edit a) +editsTo v = do + i <- choose (0, Vector.length v -1) + c <- elements [const (Insert i), \o _ -> Delete i o, Replace i] + x <- arbitrary + return $ c (v Vector.! i) x + +patchesFrom' :: (Eq a, Arbitrary a) => Vector a -> Gen (Patch a) +patchesFrom' v | Vector.length v > 0 = fromList <$> listOf (editsTo v) + | otherwise = fromList <$> listOf (Insert 0 <$> arbitrary) +patchesFrom :: Vector Int -> Gen (Patch Int) +patchesFrom = patchesFrom' + +instance Arbitrary a => Arbitrary (Vector a) where arbitrary = Vector.fromList <$> listOf arbitrary + +qcgen :: QCGen +qcgen = mkQCGen 19835315 + +gen :: Int -> (Patch Int, Vector Int) +gen i = let + doc = unGen arbitrary qcgen i :: Vector Int + patch = unGen (patchesFrom doc) qcgen i + in traceShow (length $ toList patch, length doc) (patch,doc) + +main :: IO () +main = + defaultMain [ bgroup "apply" [ bench "1" $ nf (uncurry apply) (gen 500) + , bench "2" $ nf (uncurry apply) (gen 1000) + , bench "3" $ nf (uncurry apply) (gen 2000) + , bench "4" $ nf (uncurry apply) (gen 4000) + ] + ] diff --git a/patches-vector.cabal b/patches-vector.cabal --- a/patches-vector.cabal +++ b/patches-vector.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: patches-vector -version: 0.1.4.4 +version: 0.1.5.0 synopsis: Patches (diffs) on vectors: composable, mergeable, and invertible. description: A patch is a collection of modifications (edits) to be made to a sequence of elements. Commonly found in version control systems, patches are also a simple example of a groupoid, supporting (partial) composition @@ -40,3 +40,9 @@ main-is: tests.hs build-depends: base >= 4.7 && < 4.9, QuickCheck >= 2.7 && < 2.9, patches-vector, doctest >= 0.9 && < 0.11 default-language: Haskell2010 + +test-suite benchmarks-patches-vector + type: exitcode-stdio-1.0 + main-is: benchmarks.hs + hs-source-dirs: bm + build-depends: base >= 4.7 && < 4.9, QuickCheck >= 2.7 && < 2.9, patches-vector, criterion >= 1.1 && < 1.2, vector >= 0.10 && <0.12