Test diffBy against a model

Author: phadej

ChangeLog.md

@@ -4,6 +4,7 @@
   `Pretty` datastructure is changed.
 - Change `Expr` to use `OMap`; pretty-printing preserves field order.
 - Add `strict` and `these` instances
+- Add `Eq` and `NFData (Edit a)` instances.
 - Bump lower bounds
 
 ## 0.1

src-diff/RefDiffBy.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module RefDiffBy (diffBy) where
+
+import Data.TreeDiff.List (Edit (..))
+
+import qualified Data.Primitive as P
+
+diffBy :: forall a. (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
+diffBy eq xs' ys' = reverse (getCell (lcs xn yn))
+  where
+    xn = length xs'
+    yn = length ys'
+
+    xs = P.arrayFromListN xn xs'
+    ys = P.arrayFromListN yn ys'
+
+    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 -> Cell [Edit a]
+    lcs xi yi = P.indexArray memo (yi + xi * (yn + 1))
+
+    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 = bestOfThree
+        edit
+        (bimap (+1) (Ins y :) (lcs n (m - 1)))
+        (bimap (+1) (Del x :) (lcs (n - 1) m))
+      where
+        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))
+
+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 :: (Int -> Int) -> (a -> b) -> Cell a -> Cell b
+bimap f g (Cell i x) = Cell (f i) (g x)

src/Data/TreeDiff/List.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 -- | A list diff.
-module Data.TreeDiff.List (diffBy, Edit (..)) where
+module Data.TreeDiff.List (
+    diffBy,
+    Edit (..),
+) where
 
 import Control.DeepSeq (NFData (..))
 
@@ -15,7 +18,7 @@ data Edit a
     | Del a    -- ^ delete
     | Cpy a    -- ^ copy unchanged
     | Swp a a  -- ^ swap, i.e. delete + insert
-  deriving Show
+  deriving (Eq, Show)
 
 instance NFData a => NFData (Edit a) where
     rnf (Ins x)   = rnf x

tests/Tests.hs

@@ -2,10 +2,11 @@
 module Main (main) where
 
 import Data.Proxy                 (Proxy (..))
+import Data.Word                  (Word8)
 import GHC.Generics               (Generic)
 import Prelude ()
 import Prelude.Compat
-import Test.QuickCheck            (Property, counterexample)
+import Test.QuickCheck            (Property, counterexample, (===))
 import Test.Tasty                 (TestTree, defaultMain, testGroup)
 import Test.Tasty.Golden.Advanced (goldenTest)
 import Test.Tasty.QuickCheck      (testProperty)
@@ -17,15 +18,27 @@ import qualified Text.Trifecta.Result         as T (ErrInfo (..), Result (..))
 
 import Data.TreeDiff
 import Data.TreeDiff.Golden
+import Data.TreeDiff.List
 import Data.TreeDiff.QuickCheck
 
+import qualified RefDiffBy
+
 main :: IO ()
 main = defaultMain $ testGroup "tests"
     [ testProperty "trifecta-pretty roundtrip" roundtripTrifectaPretty
     , testProperty "parsec-ansi-wl-pprint roundtrip" roundtripParsecAnsiWl
+    , testProperty "diffBy model" diffByModel
     , goldenTests
     ]
 
+-------------------------------------------------------------------------------
+-- diffBy
+-------------------------------------------------------------------------------
+
+diffByModel :: [Word8] -> [Word8] -> Property
+diffByModel xs ys =
+    diffBy (==) xs ys === RefDiffBy.diffBy (==) xs ys
+
 -------------------------------------------------------------------------------
 -- Roundtrip
 -------------------------------------------------------------------------------

tree-diff.cabal

@@ -143,8 +143,9 @@ test-suite tree-diff-test
   default-language: Haskell2010
   type:             exitcode-stdio-1.0
   main-is:          Tests.hs
-  hs-source-dirs:   tests
+  hs-source-dirs:   tests src-diff
   ghc-options:      -Wall -threaded
+  other-modules:    RefDiffBy
 
   -- dependencies from library
   build-depends:
@@ -153,6 +154,7 @@ test-suite tree-diff-test
     , base
     , base-compat
     , parsec
+    , primitive
     , QuickCheck
     , tagged
     , tree-diff