Merge pull request #54 from haskellari/small-impr

Small improvement in speed

Author: phadej

src/Data/TreeDiff/Class.hs

@@ -101,6 +101,9 @@ import qualified Data.Strict as Strict
 -- these
 import Data.These (These (..))
 
+-- primitive
+-- import qualified Data.Primitive as Prim
+
 -- $setup
 -- >>> :set -XDeriveGeneric
 -- >>> import Data.Foldable (traverse_)
@@ -571,3 +574,9 @@ instance (ToExpr a, ToExpr b) => ToExpr (These a b) where
     toExpr (This x)    = App "This" [toExpr x]
     toExpr (That y)    = App "That" [toExpr y]
     toExpr (These x y) = App "These " [toExpr x, toExpr y]
+
+-------------------------------------------------------------------------------
+-- primitive
+-------------------------------------------------------------------------------
+
+-- TODO: add instances

src/Data/TreeDiff/List.hs

@@ -2,10 +2,9 @@
 -- | A list diff.
 module Data.TreeDiff.List (diffBy, Edit (..)) where
 
-import Control.DeepSeq  (NFData (..))
-import Data.List.Compat (sortOn)
+import Control.DeepSeq (NFData (..))
 
-import qualified Data.Vector as V
+import qualified Data.Primitive as P
 
 -- | List edit operations
 --
@@ -39,43 +38,55 @@ instance NFData a => NFData (Edit a) where
 -- of more obviously correct implementation.
 --
 diffBy :: forall a. (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
-diffBy eq xs' ys' = reverse (snd (lcs xn yn))
+diffBy eq xs' ys' = reverse (getCell (lcs xn yn))
   where
-    xn = V.length xs
-    yn = V.length ys
+    xn = length xs'
+    yn = length ys'
 
-    xs = V.fromList xs'
-    ys = V.fromList ys'
+    xs = P.arrayFromListN xn xs'
+    ys = P.arrayFromListN yn ys'
 
-    memo :: V.Vector (Int, [Edit a])
-    memo = V.fromList
+    memo :: P.Array (Cell [Edit a])
+    memo = P.arrayFromListN ((xn + 1) * (yn + 1))
         [ impl xi yi
         | xi <- [0 .. xn]
         , yi <- [0 .. yn]
         ]
 
-    lcs :: Int -> Int -> (Int, [Edit a])
-    lcs xi yi = memo V.! (yi + xi * (yn + 1))
+    lcs :: Int -> Int -> Cell [Edit a]
+    lcs xi yi = P.indexArray memo (yi + xi * (yn + 1))
 
-    impl :: Int -> Int -> (Int, [Edit a])
-    impl 0 0 = (0, [])
-    impl 0 m = case lcs 0 (m-1) of
-        (w, edit) -> (w + 1, Ins (ys V.! (m - 1)) : edit)
-    impl n 0 = case lcs (n -1) 0 of
-        (w, edit) -> (w + 1, Del (xs V.! (n - 1)) : edit)
+    impl :: Int -> Int -> Cell [Edit a]
+    impl 0 0 = Cell 0 []
+    impl 0 m = case lcs 0 (m - 1) of
+        Cell w edit -> Cell (w + 1) (Ins (P.indexArray ys (m - 1)) : edit)
+    impl n 0 = case lcs (n - 1) 0 of
+        Cell w edit -> Cell (w + 1) (Del (P.indexArray xs (n - 1)) : edit)
 
-    impl n m = head $ sortOn fst
-        [ edit
-        , bimap (+1) (Ins y :) (lcs n (m - 1))
-        , bimap (+1) (Del x :) (lcs (n - 1) m)
-        ]
+    impl n m = bestOfThree
+        edit
+        (bimap (+1) (Ins y :) (lcs n (m - 1)))
+        (bimap (+1) (Del x :) (lcs (n - 1) m))
       where
-        x = xs V.! (n - 1)
-        y = ys V.! (m - 1)
+        x = P.indexArray xs (n - 1)
+        y = P.indexArray ys (m - 1)
 
         edit
             | eq x y    = bimap id   (Cpy x :)   (lcs (n - 1) (m - 1))
-            | otherwise = bimap (+1) (Swp x y :) (lcs (n -1 ) (m - 1))
+            | otherwise = bimap (+1) (Swp x y :) (lcs (n - 1) (m - 1))
+
+data Cell a = Cell !Int !a
+
+getCell :: Cell a -> a
+getCell (Cell _ x) = x
+
+bestOfThree :: Cell a -> Cell a -> Cell a -> Cell a
+bestOfThree a@(Cell i _x) b@(Cell j _y) c@(Cell k _z)
+    | i <= j
+    = if i <= k then a else c
+
+    | otherwise
+    = if j <= k then b else c
 
-bimap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)
-bimap f g (x, y) = (f x, g y)
+bimap :: (Int -> Int) -> (a -> b) -> Cell a -> Cell b
+bimap f g (Cell i x) = Cell (f i) (g x)

tests/Tests.hs

@@ -1,10 +1,7 @@
-{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE DeriveGeneric #-}
 module Main (main) where
 
 import Data.Proxy                 (Proxy (..))
-import Data.TreeDiff
-import Data.TreeDiff.Golden
-import Data.TreeDiff.QuickCheck
 import GHC.Generics               (Generic)
 import Prelude ()
 import Prelude.Compat
@@ -18,6 +15,10 @@ import qualified Text.PrettyPrint.ANSI.Leijen as WL
 import qualified Text.Trifecta                as T (eof, parseString)
 import qualified Text.Trifecta.Result         as T (ErrInfo (..), Result (..))
 
+import Data.TreeDiff
+import Data.TreeDiff.Golden
+import Data.TreeDiff.QuickCheck
+
 main :: IO ()
 main = defaultMain $ testGroup "tests"
     [ testProperty "trifecta-pretty roundtrip" roundtripTrifectaPretty
@@ -26,7 +27,7 @@ main = defaultMain $ testGroup "tests"
     ]
 
 -------------------------------------------------------------------------------
--- QuickCheck: ediffEq
+-- Roundtrip
 -------------------------------------------------------------------------------
 
 -- | This property tests that we can parse pretty printed 'Expr'.

tree-diff.cabal

@@ -100,6 +100,7 @@ library
     , bytestring-builder    ^>=0.10.8.2.0
     , hashable              ^>=1.2.7.0 || ^>=1.3.0.0
     , parsers               ^>=0.12.10
+    , primitive             ^>=0.7.1.0
     , QuickCheck            ^>=2.14.2
     , scientific            ^>=0.3.6.2
     , semialign             >=1.1        && <1.3
@@ -180,4 +181,6 @@ benchmark tree-diff-bench
     , tree-diff
 
   -- extra dependencies
-  build-depends:    criterion ^>=1.5.9.0, Diff ^>=0.4.0
+  build-depends:
+    , criterion  ^>=1.5.9.0
+    , Diff       ^>=0.4.0